commit 2922ed591d1c0dc3be7a92e211ac7b18aa12edcc
Author: Alex Shinn <ashinn@users.noreply.github.com>
Date:   Mon Jan 26 08:06:59 2015 +0900

    Forgot to install regexp (patch from Lorenzo)

diff --git a/.hgignore b/.hgignore
new file mode 100644
index 00000000..cd3c0af6
--- /dev/null
+++ b/.hgignore
@@ -0,0 +1,44 @@
+syntax: glob
+*~
+*.i
+*.s
+*.o
+*.so
+*.so.*
+*.pc
+*.sch
+*.sps
+*.txt
+*.image
+*.wav
+*.dylib
+*.class
+*.dSYM
+*.orig
+.hg
+junk*
+*.tgz
+*.tar.gz
+*.tar.bz2
+*.log
+*.err
+*.out
+gc
+gc6.8
+clibs.c
+chibi-scheme
+chibi-scheme-static
+build-lib/chibi/char-set/derived.scm
+include/chibi/install.h
+lib/chibi/filesystem.c
+lib/chibi/io/io.c
+lib/chibi/net.c
+lib/chibi/process.c
+lib/chibi/system.c
+lib/chibi/time.c
+lib/chibi/stty.c
+doc/*.html
+doc/lib/chibi/*.html
+misc/*
+tests/ffi/*.c
+tests/ffi/*.stub
diff --git a/AUTHORS b/AUTHORS
new file mode 100644
index 00000000..9f8567cb
--- /dev/null
+++ b/AUTHORS
@@ -0,0 +1,51 @@
+Alex Shinn wrote the initial version of chibi-scheme and all
+distributed modules.
+
+The `dynamic-wind' implementation is adapted from the implementation
+in the appendix to the Scheme48 reference manual, reportedly first
+written by Chris Hanson and John Lamping.
+
+The (scheme time) module includes code for handling leap seconds
+from Alan Watson's Scheme clock library at
+http://code.google.com/p/scheme-clock/ under the same license.
+
+The benchmarks are based on the Racket versions of the classic
+Gabriel benchmarks from
+http://www.cs.utah.edu/~mflatt/benchmarks-20100126/log3/index.html.
+They are not installed or needed but are included for convenience.
+
+Thanks to the following people for patches and bug reports:
+
+  * Alan Watson
+  * Alexander Shendi
+  * Andreas Rottman
+  * Bakul Shah
+  * Ben Mather
+  * Ben Weaver
+  * Bruno Deferrari
+  * Doug Currie
+  * Derrick Eddington
+  * Dmitry Chestnykh
+  * Eduardo Cavazos
+  * Felix Winkelmann
+  * Gregor Klinke
+  * Jeremy Wolff
+  * Jeronimo Pellegrini
+  * John Cowan
+  * John Samsa
+  * Lars J Aas
+  * Lorenzo Campedelli
+  * Meng Zhang
+  * Michal Kowalski (sladegen)
+  * Miroslav Urbanek
+  * Rajesh Krishnan
+  * Seth Alves
+  * Stephen Lewis
+  * Taylor Venable
+  * Travis Cross
+  * Zhang Meng
+
+If you would prefer not to be listed, or are one of the users listed
+without a full name, please contact me.  If you've made a contribution
+and are not listed, please accept my apologies and contact me
+immediately!
diff --git a/COPYING b/COPYING
new file mode 100644
index 00000000..cb3c8220
--- /dev/null
+++ b/COPYING
@@ -0,0 +1,24 @@
+Copyright (c) 2009-2012 Alex Shinn
+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 author may not be used to endorse or promote products
+   derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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.
diff --git a/Makefile b/Makefile
new file mode 100644
index 00000000..c99b0524
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,410 @@
+# -*- makefile-gmake -*-
+
+.PHONY: dist mips-dist cleaner test test-all test-dist checkdefs
+.DEFAULT_GOAL := all
+
+SOVERSION ?= $(shell cat VERSION)
+SOVERSION_MAJOR ?= $(shell echo "$(SOVERSION)" | sed "s/\..*//")
+
+CHIBI_FFI ?= $(CHIBI) -q tools/chibi-ffi
+CHIBI_FFI_DEPENDENCIES ?= $(CHIBI_DEPENDENCIES) tools/chibi-ffi
+
+CHIBI_DOC ?= $(CHIBI) tools/chibi-doc
+CHIBI_DOC_DEPENDENCIES ?= $(CHIBI_DEPENDENCIES) tools/chibi-doc
+
+GENSTATIC ?= ./tools/chibi-genstatic
+
+CHIBI ?= LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH=".:$(DYLD_LIBRARY_PATH)" CHIBI_MODULE_PATH=lib ./chibi-scheme$(EXE)
+CHIBI_DEPENDENCIES = ./chibi-scheme$(EXE)
+
+########################################################################
+
+CHIBI_COMPILED_LIBS = lib/chibi/filesystem$(SO) lib/chibi/process$(SO) \
+	lib/chibi/time$(SO) lib/chibi/system$(SO) lib/chibi/stty$(SO) \
+	lib/chibi/weak$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) \
+	lib/chibi/net$(SO) lib/chibi/ast$(SO)
+CHIBI_IO_COMPILED_LIBS = lib/chibi/io/io$(SO)
+CHIBI_OPT_COMPILED_LIBS = lib/chibi/optimize/rest$(SO) \
+	lib/chibi/optimize/profile$(SO)
+COMPILED_LIBS = $(CHIBI_COMPILED_LIBS) $(CHIBI_IO_COMPILED_LIBS) \
+	$(CHIBI_OPT_COMPILED_LIBS) lib/srfi/18/threads$(SO) \
+	lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) lib/srfi/39/param$(SO) \
+	lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) lib/srfi/98/env$(SO) \
+	lib/scheme/time$(SO)
+
+BASE_INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h include/chibi/bignum.h
+INCLUDES = $(BASE_INCLUDES) include/chibi/eval.h
+
+MODULE_DOCS := ast config disasm equiv filesystem generic heap-stats io \
+	loop match mime modules net pathname process repl scribble stty \
+	system test time trace type-inference uri weak monad/environment \
+	show show/base
+
+HTML_LIBS = $(MODULE_DOCS:%=doc/lib/chibi/%.html)
+
+META_FILES = lib/.chibi.meta lib/.srfi.meta lib/.scheme.meta
+
+########################################################################
+
+include Makefile.libs
+
+########################################################################
+# Library config.
+#
+# This is to allow "make SEXP_USE_BOEHM=1" and "make SEXP_USE_DL=0" to
+# automatically include the necessary compiler and linker flags in
+# addition to setting those features.  If not using GNU make just
+# comment out the ifs and use the else branches for the defaults.
+
+ifeq ($(SEXP_USE_BOEHM),1)
+GCLDFLAGS := -lgc
+XCPPFLAGS := $(CPPFLAGS) -Iinclude $(D:%=-DSEXP_USE_%) -DSEXP_USE_BOEHM=1
+else
+GCLDFLAGS :=
+XCPPFLAGS := $(CPPFLAGS) -Iinclude $(D:%=-DSEXP_USE_%)
+endif
+
+ifeq ($(SEXP_USE_DL),0)
+XLDFLAGS  := $(LDFLAGS) $(RLDFLAGS) $(GCLDFLAGS) -lm
+XCFLAGS   := -Wall -DSEXP_USE_DL=0 -g -g3 -O3 $(CFLAGS)
+else
+XLDFLAGS  := $(LDFLAGS) $(RLDFLAGS) $(GCLDFLAGS) $(LIBDL) -lm
+XCFLAGS   := -Wall -g -g3 -O3 $(CFLAGS)
+endif
+
+########################################################################
+
+all: chibi-scheme$(EXE) all-libs chibi-scheme.pc $(META_FILES)
+
+include/chibi/install.h: Makefile
+	echo '#define sexp_so_extension "'$(SO)'"' > $@
+	echo '#define sexp_default_module_path "'$(MODDIR):$(BINMODDIR)'"' >> $@
+	echo '#define sexp_platform "'$(PLATFORM)'"' >> $@
+	echo '#define sexp_version "'`cat VERSION`'"' >> $@
+	echo '#define sexp_release_name "'`cat RELEASE`'"' >> $@
+
+%.o: %.c $(BASE_INCLUDES)
+	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $<
+
+gc-ulimit.o: gc.c $(BASE_INCLUDES)
+	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -DSEXP_USE_LIMITED_MALLOC -o $@ $<
+
+sexp-ulimit.o: sexp.c $(BASE_INCLUDES)
+	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -DSEXP_USE_LIMITED_MALLOC -o $@ $<
+
+main.o: main.c $(INCLUDES)
+	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $<
+
+SEXP_OBJS = gc.o sexp.o bignum.o
+SEXP_ULIMIT_OBJS = gc-ulimit.o sexp-ulimit.o bignum.o
+EVAL_OBJS = opcodes.o vm.o eval.o simplify.o
+
+libchibi-sexp$(SO): $(SEXP_OBJS)
+	$(CC) $(CLIBFLAGS) $(CLINKFLAGS) -o $@ $^ $(XLDFLAGS)
+
+libchibi-scheme$(SO_VERSIONED_SUFFIX): $(SEXP_OBJS) $(EVAL_OBJS)
+	$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(LIBCHIBI_FLAGS) -o $@ $^ $(XLDFLAGS)
+
+libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX): libchibi-scheme$(SO_VERSIONED_SUFFIX)
+	$(LN) -sf $< $@
+
+libchibi-scheme$(SO): libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX)
+	$(LN) -sf $< $@
+
+libchibi-scheme.a: $(SEXP_OBJS) $(EVAL_OBJS)
+	$(AR) rcs $@ $^
+
+chibi-scheme$(EXE): main.o libchibi-scheme$(SO)
+	$(CC) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< -L. -lchibi-scheme
+
+chibi-scheme-static$(EXE): main.o $(SEXP_OBJS) $(EVAL_OBJS)
+	$(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) -lm
+
+chibi-scheme-ulimit$(EXE): main.o $(SEXP_ULIMIT_OBJS) $(EVAL_OBJS)
+	$(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) -lm
+
+clibs.c: $(GENSTATIC) chibi-scheme$(EXE)
+	$(FIND) lib -name \*.sld | $(CHIBI) $(GENSTATIC) > $@
+
+chibi-scheme.pc: chibi-scheme.pc.in
+	echo "# pkg-config" > chibi-scheme.pc
+	echo "prefix=$(PREFIX)" >> chibi-scheme.pc
+	echo "exec_prefix=\$${prefix}" >> chibi-scheme.pc
+	echo "libdir=$(LIBDIR)" >> chibi-scheme.pc
+	echo "includedir=\$${prefix}/include" >> chibi-scheme.pc
+	echo "version=$(VERSION)" >> chibi-scheme.pc
+	echo "" >> chibi-scheme.pc
+	cat chibi-scheme.pc.in >> chibi-scheme.pc
+
+# A special case, this needs to be linked with the LDFLAGS in case
+# we're using Boehm.
+lib/chibi/ast$(SO): lib/chibi/ast.c $(INCLUDES) libchibi-scheme$(SO)
+	-$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< $(GCLDFLAGS) -L. -lchibi-scheme
+
+doc: doc/chibi.html doc-libs
+
+%.html: %.scrbl $(CHIBI_DOC_DEPENDENCIES)
+	$(CHIBI_DOC) --html $< > $@
+
+lib/.%.meta: lib/%/ tools/generate-install-meta.scm
+	-$(FIND) $< -name \*.sld | \
+	 $(CHIBI) tools/generate-install-meta.scm `cat VERSION` > $@
+
+########################################################################
+# Dist builds - rules to build generated files included in distribution
+# (currently just char-sets since it takes a long time and we don't want
+# to bundle the raw Unicode files or require a net connection to build).
+
+data/%.txt:
+	curl --silent http://www.unicode.org/Public/UNIDATA/$*.txt > $@
+
+build-lib/chibi/char-set/derived.scm: data/UnicodeData.txt data/DerivedCoreProperties.txt chibi-scheme$(EXE)
+	$(CHIBI) tools/extract-unicode-props.scm --default > $@
+
+lib/chibi/char-set/ascii.scm: build-lib/chibi/char-set/derived.scm chibi-scheme$(EXE)
+	$(CHIBI) -Abuild-lib tools/optimize-char-sets.scm --ascii chibi.char-set.compute > $@
+
+lib/chibi/char-set/full.scm: build-lib/chibi/char-set/derived.scm chibi-scheme$(EXE)
+	$(CHIBI) -Abuild-lib tools/optimize-char-sets.scm chibi.char-set.compute > $@
+
+lib/scheme/char/case-offsets.scm: data/CaseFolding.txt chibi-scheme$(EXE) all-libs
+	$(CHIBI) tools/extract-case-offsets.scm $< > $@
+
+########################################################################
+# Tests
+
+checkdefs:
+	@for d in $(D); do \
+	    if ! $(GREP) -q " SEXP_USE_$${d%%=*} " include/chibi/features.h; then \
+	        echo "WARNING: unknown definition $$d"; \
+	    fi; \
+	done
+
+test-basic: chibi-scheme$(EXE)
+	@for f in tests/basic/*.scm; do \
+	    $(CHIBI) -xchibi $$f >$${f%.scm}.out 2>$${f%.scm}.err; \
+	    if $(DIFF) -q $(DIFFOPTS) $${f%.scm}.out $${f%.scm}.res; then \
+	        echo "[PASS] $${f%.scm}"; \
+	    else \
+	        echo "[FAIL] $${f%.scm}"; \
+	    fi; \
+	done
+
+test-memory: chibi-scheme-ulimit$(EXE)
+	./tests/memory/memory-tests.sh
+
+test-build:
+	MAKE=$(MAKE) ./tests/build/build-tests.sh
+
+test-ffi: chibi-scheme$(EXE)
+	$(CHIBI) tests/ffi/ffi-tests.scm
+
+test-threads: chibi-scheme$(EXE) lib/srfi/18/threads$(SO) lib/srfi/39/param$(SO) lib/srfi/98/env$(SO) lib/chibi/ast$(SO) lib/chibi/time$(SO)
+	$(CHIBI) -xchibi tests/thread-tests.scm
+
+test-numbers: chibi-scheme$(EXE)
+	$(CHIBI) -xchibi tests/numeric-tests.scm
+
+test-flonums: chibi-scheme$(EXE)
+	$(CHIBI) -xchibi tests/flonum-tests.scm
+
+test-hash: chibi-scheme$(EXE) lib/srfi/69/hash$(SO)
+	$(CHIBI) -xchibi tests/hash-tests.scm
+
+test-io: chibi-scheme$(EXE) lib/chibi/io/io$(SO)
+	$(CHIBI) -xchibi tests/io-tests.scm
+
+test-match: chibi-scheme$(EXE)
+	$(CHIBI) -xchibi tests/match-tests.scm
+
+test-loop: chibi-scheme$(EXE)
+	$(CHIBI) -xchibi tests/loop-tests.scm
+
+test-sort: chibi-scheme$(EXE) lib/srfi/33/bit$(SO)
+	$(CHIBI) -xchibi tests/sort-tests.scm
+
+test-srfi-1: chibi-scheme$(EXE)
+	$(CHIBI) -xchibi tests/srfi-1-tests.scm
+
+test-records: chibi-scheme$(EXE)
+	$(CHIBI) -xchibi tests/record-tests.scm
+
+test-weak: chibi-scheme$(EXE) lib/chibi/weak$(SO)
+	$(CHIBI) -xchibi tests/weak-tests.scm
+
+test-unicode: chibi-scheme$(EXE)
+	$(CHIBI) -xchibi tests/unicode-tests.scm
+
+test-process: chibi-scheme$(EXE) lib/chibi/process$(SO)
+	$(CHIBI) -xchibi tests/process-tests.scm
+
+test-system: chibi-scheme$(EXE) lib/chibi/system$(SO)
+	$(CHIBI) -xchibi tests/system-tests.scm
+
+test-libs: chibi-scheme$(EXE)
+	$(CHIBI) -xchibi tests/lib-tests.scm
+
+test-r5rs: chibi-scheme$(EXE)
+	$(CHIBI) -xchibi tests/r5rs-tests.scm
+
+test-r7rs: chibi-scheme$(EXE)
+	$(CHIBI) tests/r7rs-tests.scm
+
+test: test-r7rs
+
+test-all: test test-libs test-ffi
+
+test-dist: test-all test-memory test-build
+
+bench-gabriel: chibi-scheme$(EXE)
+	./benchmarks/gabriel/run.sh
+
+########################################################################
+# Packaging
+
+clean: clean-libs
+	-$(RM) *.o *.i *.s *.8 tests/basic/*.out tests/basic/*.err
+
+cleaner: clean
+	-$(RM) chibi-scheme$(EXE) chibi-scheme-static$(EXE) chibi-scheme-ulimit$(EXE) \
+	    libchibi-scheme$(SO)* *.a *.pc include/chibi/install.h lib/.*.meta \
+	    $(shell $(FIND) lib -name \*.o)
+
+dist-clean: dist-clean-libs cleaner
+
+install: all
+	$(MKDIR) $(DESTDIR)$(BINDIR)
+	$(INSTALL) -m0755 chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/
+	$(INSTALL) -m0755 tools/chibi-ffi $(DESTDIR)$(BINDIR)/
+	$(INSTALL) -m0755 tools/chibi-doc $(DESTDIR)$(BINDIR)/
+	$(INSTALL) -m0755 tools/snow-chibi $(DESTDIR)$(BINDIR)/
+	$(MKDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(MODDIR)/chibi/crypto $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(MODDIR)/chibi/iset $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(MODDIR)/chibi/math $(DESTDIR)$(MODDIR)/chibi/monad $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(MODDIR)/chibi/regexp $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(MODDIR)/chibi/snow $(DESTDIR)$(MODDIR)/chibi/term
+	$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/char
+	$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/time
+	$(MKDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(MODDIR)/srfi/33 $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(MODDIR)/srfi/99/records
+	$(INSTALL) -m0644 $(META_FILES) $(DESTDIR)$(MODDIR)/
+	$(INSTALL) -m0644 lib/*.scm $(DESTDIR)$(MODDIR)/
+	$(INSTALL) -m0644 lib/chibi/*.sld lib/chibi/*.scm $(DESTDIR)$(MODDIR)/chibi/
+	$(INSTALL) -m0644 lib/chibi/char-set/*.sld lib/chibi/char-set/*.scm $(DESTDIR)$(MODDIR)/chibi/char-set/
+	$(INSTALL) -m0644 lib/chibi/crypto/*.sld lib/chibi/crypto/*.scm $(DESTDIR)$(MODDIR)/chibi/crypto/
+	$(INSTALL) -m0644 lib/chibi/io/*.scm $(DESTDIR)$(MODDIR)/chibi/io/
+	$(INSTALL) -m0644 lib/chibi/iset/*.sld lib/chibi/iset/*.scm $(DESTDIR)$(MODDIR)/chibi/iset/
+	$(INSTALL) -m0644 lib/chibi/loop/*.scm $(DESTDIR)$(MODDIR)/chibi/loop/
+	$(INSTALL) -m0644 lib/chibi/match/*.scm $(DESTDIR)$(MODDIR)/chibi/match/
+	$(INSTALL) -m0644 lib/chibi/math/*.sld lib/chibi/math/*.scm $(DESTDIR)$(MODDIR)/chibi/math/
+	$(INSTALL) -m0644 lib/chibi/monad/*.sld lib/chibi/monad/*.scm $(DESTDIR)$(MODDIR)/chibi/monad/
+	$(INSTALL) -m0644 lib/chibi/net/*.sld lib/chibi/net/*.scm $(DESTDIR)$(MODDIR)/chibi/net/
+	$(INSTALL) -m0644 lib/chibi/optimize/*.sld lib/chibi/optimize/*.scm $(DESTDIR)$(MODDIR)/chibi/optimize/
+	$(INSTALL) -m0644 lib/chibi/parse/*.sld lib/chibi/parse/*.scm $(DESTDIR)$(MODDIR)/chibi/parse/
+	$(INSTALL) -m0644 lib/chibi/regexp/*.sld lib/chibi/regexp/*.scm $(DESTDIR)$(MODDIR)/chibi/regexp/
+	$(INSTALL) -m0644 lib/chibi/show/*.sld lib/chibi/show/*.scm $(DESTDIR)$(MODDIR)/chibi/show/
+	$(INSTALL) -m0644 lib/chibi/snow/*.sld lib/chibi/snow/*.scm $(DESTDIR)$(MODDIR)/chibi/snow/
+	$(INSTALL) -m0644 lib/chibi/term/*.sld lib/chibi/term/*.scm $(DESTDIR)$(MODDIR)/chibi/term/
+	$(INSTALL) -m0644 lib/scheme/*.sld lib/scheme/*.scm $(DESTDIR)$(MODDIR)/scheme/
+	$(INSTALL) -m0644 lib/scheme/char/*.sld lib/scheme/char/*.scm $(DESTDIR)$(MODDIR)/scheme/char/
+	$(INSTALL) -m0644 lib/scheme/time/*.sld $(DESTDIR)$(MODDIR)/scheme/time/
+	$(INSTALL) -m0644 lib/srfi/*.sld lib/srfi/*.scm $(DESTDIR)$(MODDIR)/srfi/
+	$(INSTALL) -m0644 lib/srfi/1/*.scm $(DESTDIR)$(MODDIR)/srfi/1/
+	$(INSTALL) -m0644 lib/srfi/18/*.scm $(DESTDIR)$(MODDIR)/srfi/18/
+	$(INSTALL) -m0644 lib/srfi/27/*.scm $(DESTDIR)$(MODDIR)/srfi/27/
+	$(INSTALL) -m0644 lib/srfi/33/*.scm $(DESTDIR)$(MODDIR)/srfi/33/
+	$(INSTALL) -m0644 lib/srfi/39/*.scm $(DESTDIR)$(MODDIR)/srfi/39/
+	$(INSTALL) -m0644 lib/srfi/69/*.scm $(DESTDIR)$(MODDIR)/srfi/69/
+	$(INSTALL) -m0644 lib/srfi/95/*.scm $(DESTDIR)$(MODDIR)/srfi/95/
+	$(INSTALL) -m0644 lib/srfi/99/*.sld $(DESTDIR)$(MODDIR)/srfi/99/
+	$(INSTALL) -m0644 lib/srfi/99/records/*.sld lib/srfi/99/records/*.scm $(DESTDIR)$(MODDIR)/srfi/99/records/
+	$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/io/
+	$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
+	$(MKDIR) $(DESTDIR)$(BINMODDIR)/scheme/
+	$(MKDIR) $(DESTDIR)$(BINMODDIR)/srfi/18 $(DESTDIR)$(BINMODDIR)/srfi/27 $(DESTDIR)$(BINMODDIR)/srfi/33 $(DESTDIR)$(BINMODDIR)/srfi/39 $(DESTDIR)$(BINMODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/98
+	$(INSTALL) -m0755 $(CHIBI_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/
+	$(INSTALL) -m0755 $(CHIBI_IO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/io/
+	$(INSTALL) -m0755 $(CHIBI_OPT_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
+	$(INSTALL) -m0755 lib/scheme/time$(SO) $(DESTDIR)$(BINMODDIR)/scheme/
+	$(INSTALL) -m0755 lib/srfi/18/threads$(SO) $(DESTDIR)$(BINMODDIR)/srfi/18
+	$(INSTALL) -m0755 lib/srfi/27/rand$(SO) $(DESTDIR)$(BINMODDIR)/srfi/27
+	$(INSTALL) -m0755 lib/srfi/33/bit$(SO) $(DESTDIR)$(BINMODDIR)/srfi/33
+	$(INSTALL) -m0755 lib/srfi/39/param$(SO) $(DESTDIR)$(BINMODDIR)/srfi/39
+	$(INSTALL) -m0755 lib/srfi/69/hash$(SO) $(DESTDIR)$(BINMODDIR)/srfi/69
+	$(INSTALL) -m0755 lib/srfi/95/qsort$(SO) $(DESTDIR)$(BINMODDIR)/srfi/95
+	$(INSTALL) -m0755 lib/srfi/98/env$(SO) $(DESTDIR)$(BINMODDIR)/srfi/98
+	$(MKDIR) $(DESTDIR)$(INCDIR)
+	$(INSTALL) -m0644 $(INCLUDES) $(DESTDIR)$(INCDIR)/
+	$(MKDIR) $(DESTDIR)$(LIBDIR)
+	$(MKDIR) $(DESTDIR)$(SOLIBDIR)
+	$(INSTALL) -m0755 libchibi-scheme$(SO_VERSIONED_SUFFIX) $(DESTDIR)$(SOLIBDIR)/
+	$(LN) -s -f libchibi-scheme$(SO_VERSIONED_SUFFIX) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX)
+	$(LN) -s -f libchibi-scheme$(SO_VERSIONED_SUFFIX) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO)
+	-$(INSTALL) -m0644 libchibi-scheme.a $(DESTDIR)$(SOLIBDIR)/
+	$(MKDIR) $(DESTDIR)$(SOLIBDIR)/pkgconfig
+	$(INSTALL) -m0644 chibi-scheme.pc $(DESTDIR)$(SOLIBDIR)/pkgconfig/
+	$(MKDIR) $(DESTDIR)$(MANDIR)
+	$(INSTALL) -m0644 doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/
+	$(INSTALL) -m0644 doc/chibi-ffi.1 $(DESTDIR)$(MANDIR)/
+	$(INSTALL) -m0644 doc/chibi-doc.1 $(DESTDIR)$(MANDIR)/
+	-if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi
+
+uninstall:
+	-$(RM) $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE)
+	-$(RM) $(DESTDIR)$(BINDIR)/chibi-scheme-static$(EXE)
+	-$(RM) $(DESTDIR)$(BINDIR)/chibi-ffi
+	-$(RM) $(DESTDIR)$(BINDIR)/chibi-doc
+	-$(RM) $(DESTDIR)$(BINDIR)/snow-chibi
+	-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO)
+	-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO_VERSIONED_SUFFIX)
+	-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX)
+	-$(RM) $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a
+	-$(RM) $(DESTDIR)$(SOLIBDIR)/pkgconfig/chibi-scheme.pc
+	-$(CD) $(DESTDIR)$(INCDIR) && $(RM) $(INCLUDES)
+	-$(RM) $(DESTDIR)$(MODDIR)/srfi/99/records/*.{sld,scm}
+	-$(RM) $(DESTDIR)$(MODDIR)/.*.meta
+	-$(RM) $(DESTDIR)$(MODDIR)/*.{sld,scm} $(DESTDIR)$(MODDIR)/*/*.{sld,scm} $(DESTDIR)$(MODDIR)/*/*/*.{sld,scm}
+	-$(CD) $(DESTDIR)$(MODDIR) && $(RM) $(COMPILED_LIBS:lib/%=%)
+	-$(CD) $(DESTDIR)$(BINMODDIR) && $(RM) $(COMPILED_LIBS:lib/%=%)
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(BINMODDIR)/chibi/char-set
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/crypto $(DESTDIR)$(BINMODDIR)/chibi/crypto
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(BINMODDIR)/chibi/io
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/iset $(DESTDIR)$(BINMODDIR)/chibi/iset
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(BINMODDIR)/chibi/loop
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(BINMODDIR)/chibi/match
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/math $(DESTDIR)$(BINMODDIR)/chibi/math
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/monad $(DESTDIR)$(BINMODDIR)/chibi/monad
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(BINMODDIR)/chibi/net
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(BINMODDIR)/chibi/optimize
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(BINMODDIR)/chibi/parse
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/regexp $(DESTDIR)$(BINMODDIR)/chibi/regexp
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(BINMODDIR)/chibi/show
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/snow $(DESTDIR)$(BINMODDIR)/chibi/snow
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/term $(DESTDIR)$(BINMODDIR)/chibi/term
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi $(DESTDIR)$(BINMODDIR)/chibi
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/char $(DESTDIR)$(BINMODDIR)/scheme/char
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/time $(DESTDIR)$(BINMODDIR)/scheme/time
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme $(DESTDIR)$(BINMODDIR)/scheme
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(BINMODDIR)/srfi/1
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(BINMODDIR)/srfi/18
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(BINMODDIR)/srfi/27
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/33 $(DESTDIR)$(BINMODDIR)/srfi/33
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(BINMODDIR)/srfi/39
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/69
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/95
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/98 $(DESTDIR)$(BINMODDIR)/srfi/98
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/99/records $(DESTDIR)$(BINMODDIR)/srfi/99/records
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(BINMODDIR)/srfi/99
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi $(DESTDIR)$(BINMODDIR)/srfi
+	-$(RMDIR) $(DESTDIR)$(MODDIR) $(DESTDIR)$(BINMODDIR)
+	-$(RM) $(DESTDIR)$(MANDIR)/chibi-scheme.1 $(DESTDIR)$(MANDIR)/chibi-ffi.1 $(DESTDIR)$(MANDIR)/chibi-doc.1
+	-$(RM) $(DESTDIR)$(SOLIBDIR)/pkgconfig/chibi-scheme.pc
+
+dist: dist-clean
+	$(RM) chibi-scheme-`cat VERSION`.tgz
+	$(MKDIR) chibi-scheme-`cat VERSION`
+	@for f in `hg manifest | grep -v ^benchmarks/`; do $(MKDIR) chibi-scheme-`cat VERSION`/`dirname $$f`; $(SYMLINK) `pwd`/$$f chibi-scheme-`cat VERSION`/$$f; done
+	$(TAR) cphzvf chibi-scheme-`cat VERSION`.tgz chibi-scheme-`cat VERSION`
+	$(RM) -r chibi-scheme-`cat VERSION`
+
+mips-dist: dist-clean
+	$(RM) chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz
+	$(MKDIR) chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`
+	@for f in `hg manifest | grep -v ^benchmarks/`; do $(MKDIR) chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/`dirname $$f`; $(SYMLINK) `pwd`/$$f chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/$$f; done
+	$(TAR) cphzvf chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`
+	$(RM) -r chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`
diff --git a/Makefile.detect b/Makefile.detect
new file mode 100644
index 00000000..7b786442
--- /dev/null
+++ b/Makefile.detect
@@ -0,0 +1,119 @@
+# -*- makefile-gmake -*-
+
+########################################################################
+# Detect the PLATFORM with uname.
+
+ifndef PLATFORM
+ifeq ($(shell uname),Darwin)
+PLATFORM=macosx
+else
+ifeq ($(shell uname),FreeBSD)
+PLATFORM=bsd
+else
+ifeq ($(shell uname),NetBSD)
+PLATFORM=bsd
+else
+ifeq ($(shell uname),OpenBSD)
+PLATFORM=bsd
+else
+ifeq ($(shell uname),DragonFly)
+PLATFORM=bsd
+else
+ifeq ($(shell uname -o),Msys)
+PLATFORM=mingw
+SOLIBDIR = $(BINDIR)
+DIFFOPTS = -b
+else
+ifeq ($(shell uname -o),Cygwin)
+PLATFORM=cygwin
+SOLIBDIR = $(BINDIR)
+DIFFOPTS = -b
+else
+ifeq ($(shell uname -o),GNU/Linux)
+PLATFORM=linux
+else
+PLATFORM=unix
+endif
+endif
+endif
+endif
+endif
+endif
+endif
+endif
+
+########################################################################
+# Set default variables for the platform.
+
+LIBDL = -ldl
+SO_VERSIONED_SUFFIX = $(SO).$(SOVERSION)
+SO_MAJOR_VERSIONED_SUFFIX = $(SO).$(SOVERSION_MAJOR)
+
+ifeq ($(PLATFORM),macosx)
+SO  = .dylib
+SO_VERSIONED_SUFFIX = .$(SOVERSION)$(SO)
+SO_MAJOR_VERSIONED_SUFFIX = .$(SOVERSION_MAJOR)$(SO)
+EXE =
+CLIBFLAGS =
+CLINKFLAGS = -dynamiclib
+STATICFLAGS = -DSEXP_USE_DL=0  # -static-libgcc
+LIBCHIBI_FLAGS = -install_name $(DESTDIR)$(SOLIBDIR)/libchibi-scheme.$(SOVERSION).dylib
+else
+ifeq ($(PLATFORM),bsd)
+SO  = .so
+EXE =
+CLIBFLAGS = -fPIC
+CLINKFLAGS = -shared
+LIBDL = 
+else
+ifeq ($(PLATFORM),mingw)
+SO  = .dll
+EXE = .exe
+CC = gcc
+CLIBFLAGS =
+CLINKFLAGS = -shared
+CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL
+LIBCHIBI_FLAGS = -Wl,--out-implib,libchibi-scheme$(SO).a
+STATICFLAGS = -DSEXP_USE_DL=0
+LIBDL = 
+else
+ifeq ($(PLATFORM),cygwin)
+SO  = .dll
+EXE = .exe
+CC = gcc
+CLIBFLAGS =
+CLINKFLAGS = -shared
+CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0
+LIBCHIBI_FLAGS = -Wl,--out-implib,libchibi-scheme$(SO).a
+else
+SO  = .so
+EXE =
+CLIBFLAGS = -fPIC
+CLINKFLAGS = -shared
+STATICFLAGS = -static -DSEXP_USE_DL=0
+LIBCHIBI_FLAGS = -Wl,-soname,libchibi-scheme$(SO).$(SOVERSION_MAJOR)
+ifeq ($(PLATFORM),BSD)
+LIBDL=
+RLDFLAGS=-Wl,-R$(DESTDIR)$(LIBDIR)
+endif
+endif
+endif
+endif
+endif
+endif
+
+ifeq ($(PLATFORM),unix)
+#RLDFLAGS=-rpath $(LIBDIR)
+RLDFLAGS=-Wl,-R$(DESTDIR)$(LIBDIR)
+endif
+
+########################################################################
+# Check for NTP (who needs autoconf?)
+
+ifndef $(SEXP_USE_NTP_GETTIME)
+SEXP_USE_NTP_GETTIME := $(shell echo "main(){struct ntptimeval n; ntp_gettime(&n);}" | gcc -fsyntax-only -include sys/timex.h -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
+endif
+
+ifeq ($(SEXP_USE_NTP_GETTIME),1)
+CPPFLAGS += -DSEXP_USE_NTPGETTIME
+endif
diff --git a/Makefile.libs b/Makefile.libs
new file mode 100644
index 00000000..00eaab29
--- /dev/null
+++ b/Makefile.libs
@@ -0,0 +1,88 @@
+# -*- makefile-gmake -*-
+
+# Include-able makefile for building Chibi libraries - see README.libs
+# for usage.
+
+.PHONY: all all-libs clean clean-libs dist-clean dist-clean-libs install install-libs uninstall uninstall-libs doc doc-libs
+.PRECIOUS: %.c lib/%.c
+
+# install configuration
+
+CC        ?= cc
+AR        ?= ar
+CD        ?= cd
+RM        ?= rm -f
+LS        ?= ls
+CP        ?= cp
+LN        ?= ln
+INSTALL   ?= install
+MKDIR     ?= $(INSTALL) -d
+RMDIR     ?= rmdir
+TAR       ?= tar
+DIFF      ?= diff
+GREP      ?= grep
+FIND      ?= find
+SYMLINK   ?= ln -s
+
+PREFIX    ?= /usr/local
+BINDIR    ?= $(PREFIX)/bin
+LIBDIR    ?= $(PREFIX)/lib
+SOLIBDIR  ?= $(PREFIX)/lib
+INCDIR    ?= $(PREFIX)/include/chibi
+MODDIR    ?= $(PREFIX)/share/chibi
+BINMODDIR ?= $(PREFIX)/lib/chibi
+MANDIR    ?= $(PREFIX)/share/man/man1
+
+DESTDIR   ?=
+
+########################################################################
+# System configuration - if not using GNU make, set PLATFORM and the
+# flags from Makefile.detect (at least SO, EXE, CLIBFLAGS) as necessary.
+
+include Makefile.detect
+
+########################################################################
+
+all-libs: $(COMPILED_LIBS)
+
+lib/%.c: lib/%.stub $(CHIBI_FFI_DEPENDENCIES)
+	$(CHIBI_FFI) $<
+
+lib/%$(SO): lib/%.c $(INCLUDES) libchibi-scheme$(SO)
+	$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< -L. $(XLIBS) -lchibi-scheme
+
+doc-libs: $(HTML_LIBS)
+
+doc/lib/%.html: lib/%.sld $(CHIBI_DOC_DEPENDENCIES)
+	$(MKDIR) $(dir $@)
+	$(CHIBI_DOC) --html $(subst /,.,$*) > $@
+
+clean-libs:
+	$(RM) $(COMPILED_LIBS)
+	$(RM) -r $(patsubst %,%.dSYM,$(COMPILED_LIBS))
+	$(RM) $(HTML_LIBS)
+
+dist-clean-libs: clean-libs
+	$(RM) $(patsubst %.stub, %.c, $(shell $(FIND) lib -name \*.stub))
+
+install-libs: all-libs
+	for dir in $(dir $(patsubst lib/%,%,$(COMPILED_LIBS))) ; do \
+	$(MKDIR) $(DESTDIR)$(BINMODDIR)/$$dir; \
+	done
+	for file in $(patsubst lib/%,%,$(COMPILED_LIBS)) ; do \
+	$(INSTALL) lib/$$file $(DESTDIR)$(BINMODDIR)/$$file ; \
+	done
+	for dir in $(dir $(patsubst lib/%,%,$(SCM_LIBS))) ; do \
+	$(MKDIR) $(DESTDIR)$(MODDIR)/$$dir; \
+	done
+	for file in $(patsubst lib/%,%,$(SCM_LIBS)) ; do \
+	$(INSTALL) lib/$$file $(DESTDIR)$(MODDIR)/$$file ; \
+	done
+
+uninstall-libs:
+	for file in $(patsubst lib/%,%,$(COMPILED_LIBS)) ; do \
+	$(RM) $(DESTDIR)$(BINMODDIR)/$$file ; \
+	done
+	for file in $(patsubst lib/%,%,$(SCM_LIBS)) ; do \
+	$(RM) $(DESTDIR)$(MODDIR)/$$file ; \
+	done
diff --git a/README b/README
new file mode 100644
index 00000000..520dfcb8
--- /dev/null
+++ b/README
@@ -0,0 +1,39 @@
+
+                             Chibi-Scheme
+                            --------------
+                                   
+    Minimal Scheme Implementation for use as an Extension Language
+
+              http://synthcode.com/wiki/chibi-scheme/
+
+Chibi-Scheme is a very small library intended for use as an extension
+and scripting language in C programs.  In addition to support for
+lightweight VM-based threads, each VM itself runs in an isolated heap
+allowing multiple VMs to run simultaneously in different OS threads.
+
+The default language is the R7RS (scheme base) library.
+
+Support for additional languages such as JavaScript, Go, Lua and Bash
+are planned for future releases.  Scheme is chosen as a substrate
+because its first class continuations and guaranteed tail-call
+optimization makes implementing other languages easy.
+
+To build on most platforms just run "make && make test".  This will
+provide a shared library "libchibi-scheme", as well as a sample
+"chibi-scheme" command-line repl.  You can then run
+
+  sudo make install
+
+to install the binaries and libraries.  You can optionally specify a
+PREFIX for the installation directory:
+
+  make PREFIX=/path/to/install/
+  sudo make PREFIX=/path/to/install/ install
+
+By default files are installed in /usr/local.
+
+If you want to try out chibi-scheme without installing, be sure to set
+LD_LIBRARY_PATH so it can find the shared libraries.
+
+For more detailed documentation, run "make doc" and see the generated
+"doc/chibi.html".
diff --git a/README.libs b/README.libs
new file mode 100644
index 00000000..6c17f960
--- /dev/null
+++ b/README.libs
@@ -0,0 +1,110 @@
+Using the Makefile.libs File To Build and Install Libraries
+-----------------------------------------------------------
+
+The Makefile.libs file distributed with the Chibi Scheme sources
+can facilitate building and installing Chibi Scheme libraries written
+in C or Scheme. To use it, follow these instructions:
+
+1. Copy the Makefile.libs and Makefile.detect files from the Chibi
+   Scheme source directory to the library source top-level directory.
+
+2. Place the library source in the subdirectory "lib" of the library
+   source top-level directory. For example,
+
+      lib/foo/bar.c
+      lib/foo/bar.h
+      lib/foo/bar.sld
+      lib/foo/bar.scm
+
+3. In the Makefile in the library source top-level directory, define
+   the following targets:
+
+      all
+      doc
+      install
+      uninstall
+      clean
+      dist-clean
+  
+   These should depend on the corresponding "-libs" target, but
+   can include additional commands. For example:
+
+      all: all-libs
+      install: install-libs
+              cp -r doc $(PREFIX)/share/chibi/
+      uninstall: uninstall-libs
+      doc: doc-libs
+      clean: clean-libs
+      dist-clean: dist-clean-libs
+  
+   The all target should be the first target in the Makefile.
+
+   The all-libs target makes the shared libraries in the library.
+   The doc-libs target generates HTML files for the library. The
+   install-libs and uninstall-libs targets install and uninstall
+   the library under the prefix. The clean-libs target removes the
+   shared libraries and generated HTML files. The dist-clean-libs
+   removes any .c files generated from .stub files and also performs
+   a clean-libs.
+
+4. In the Makefile in the library source top-level directory, define
+   the following variables:
+
+      COMPILED_LIBS: Any shared libraries that should be built and
+      installed. The shared library is build from the corresponding
+      .c or .stub file. The $(SO) variable should be used for the
+      shared-library suffix; in order for this to work COMPILED_LIBS
+      should be defined as a recursively-expanded variable (with
+      =) rather than a simply-expanded variable (with :=).
+
+      INCLUDES: Any other files on which the shared libraries depend.
+
+      SCM_LIBS: Any Scheme source files that should be installed.
+
+      HTML_LIBS: Any HTML files that should be generated. The HTML
+      files are generated from the corresponding .sld files using
+      chibi-doc.
+      
+   For example,
+  
+      COMPILED_LIBS = lib/foo/bar$(SO)
+      INCLUDES = lib/foo/bar.h
+      SCM_LIBS = lib/foo/bar.sld lib/foo/bar.scm
+      HTML_LIBS = doc/lib/foo/bar.html
+
+5. Add additional flags as necessary to XCPPFLAGS, XCFLAGS, and XLIBS.
+   These flags are passed to the compiler and linker when they
+   generate the shared library. These should probably be defined at
+   minimum as:
+
+      XCPPFLAGS += -I$(PREFIX)/include
+      XCFLAGS += -L$(PREFIX)/lib
+      XLIBS +=
+  
+   These additions will ensure that the compiler and linker can
+   find the Chibi Scheme include and library files, even if they
+   are installed under a non-standard prefix.
+
+6. Include the common Makefile using:
+
+   include Makefile.libs
+
+A complete example is:
+
+   all: all-libs
+   install: install-libs
+   uninstall: uninstall-libs
+   doc: doc-libs
+   clean: clean-libs
+   dist-clean: dist-clean-libs
+
+   COMPILED_LIBS = lib/foo/bar$(SO)
+   INCLUDES = lib/foo/bar.h
+   SCM_LIBS = lib/foo/bar.sld lib/foo/bar.scm
+   HTML_LIBS = doc/lib/foo/bar.html
+
+   XCPPFLAGS += -I$(PREFIX)/include
+   XCFLAGS += -L$(PREFIX)/lib
+   XLIBS += -lpthread
+
+   include Makefile.libs
diff --git a/RELEASE b/RELEASE
new file mode 100644
index 00000000..db9dd08e
--- /dev/null
+++ b/RELEASE
@@ -0,0 +1 @@
+nitrogen
diff --git a/TODO b/TODO
new file mode 100644
index 00000000..1d741ce1
--- /dev/null
+++ b/TODO
@@ -0,0 +1,187 @@
+-*- org -*-
+
+* compiler
+** DONE ast rewrite
+   - State "DONE"       [2009-04-09 Thu 14:32]
+** DONE call/cc support
+   - State "DONE"       [2009-04-09 Thu 14:36]
+** DONE exceptions
+   - State "DONE"       [2009-04-09 Thu 14:45]
+** TODO native x86 backend
+   API redesign in preparation complete, initial
+   tests on native factorial and closures working.
+** TODO fasl/image files
+   sexp_copy_context() can form the basis for images,
+   FASL for arbitrary modules will need additional
+   help with resolving external references.
+*** DONE optional image loading on startup
+    - State "DONE"       from "TODO"       [2011-11-10 Thu 20:44]
+*** TODO static image compiled into library
+    With this you'll be able to run Chibi without any filesystem.
+*** TODO external tool to compact and optimize images
+    The current GC is mark&sweep, which can cause fragmentation,
+    but we can at at least compact the initial fixed image.
+*** TODO fasl versions of modules
+    Important for large applications, and fast loading of script
+    with many dependencies.
+** DONE shared stack on EVAL
+   - State "DONE"       [2009-12-26 Sat 08:22]
+
+* compiler optimizations
+** DONE constant folding
+   - State "DONE"       [2009-12-16 Wed 23:25]
+** DONE simplification pass, dead-code elimination
+   - State "DONE"       [2009-12-18 Fri 14:14]
+   This is important in particular for the output generated by
+   syntax-rules.
+** TODO lambda lift
+   The current closure representation is not very efficient, so this
+   would help a lot.
+** TODO inlining (and disabling primitive inlining)
+   Being able to redefine procedures is important though.
+** TODO unsafe operations
+   Possibly, don't want to make things too complicated or unstable.
+** TODO plugin infrastructure
+** DONE type inference with warnings
+   - State "DONE"       from "TODO"       [2010-09-21 Tue 23:18]
+*** TODO structured type inference
+*** DONE infer error branches
+    CLOSED: [2011-11-14 Mon 08:17]
+*** TODO elide type checks from type information
+
+* macros
+** DONE hygiene
+   - State "DONE"       [2009-04-09 Thu 14:41]
+** DONE hygienic nested let-syntax
+   - State "DONE"       [2009-12-08 Tue 14:41]
+** DONE macroexpand utility
+   - State "DONE"       [2009-12-08 Tue 14:41]
+** DONE SRFI-46 basic syntax-rules extensions
+   - State "DONE"       [2009-12-26 Sat 07:59]
+** DONE (... ...) support
+   - State "DONE"       [2009-12-26 Sat 02:06]
+** TODO compiler macros
+** TODO syntax-rules common pattern reduction
+** TODO syntax-rules loop optimization
+
+* garbage collection
+** DONE precise gc rewrite
+   - State "DONE"       [2009-06-22 Mon 14:27]
+** DONE fix heap growing
+   - State "DONE"       [2009-06-22 Mon 14:29]
+** DONE separate gc heaps
+   - State "DONE"       [2009-12-08 Tue 14:29]
+** DONE add finalizers
+   - State "DONE"       [2009-12-08 Tue 14:29]
+** DONE support weak references
+   - State "DONE"       from "TODO"       [2010-09-21 Tue 23:16]
+*** TODO support proper weak key-value references
+
+* runtime
+** DONE bignums
+   - State "DONE"       [2009-07-07 Tue 14:42]
+** DONE unicode
+   - State "DONE"       from "TODO"       [2010-07-11 Sun 23:58]
+   Supported with UTF-8 strings, string-ref is O(n) and
+   string-set! may need to reallocate the whole string.
+   string-cursor-ref can be used for O(1) string access.
+** DONE threads
+   - State "DONE"       from "TODO"       [2010-07-11 Sun 15:31]
+   VM now supports an optional hook for green threads,
+   and a SRFI-18 interface is provided as a separate module.
+   I/O operations will currently block all threads though,
+   this needs to be addressed.
+*** DONE thread-local parameters
+    CLOSED: [2010-12-06 Mon 21:52]
+*** TODO efficient priority queues
+** DONE virtual ports
+   - State "DONE"       [2010-01-02 Sat 20:12]
+** DONE dynamic-wind
+   - State "DONE"       [2009-12-26 Sat 01:51]
+   Adapted a version from Scheme48.
+** DONE recursive disasm
+   - State "DONE"       [2009-12-18 Fri 14:15]
+
+* FFI
+** DONE libdl support
+   - State "DONE"       [2009-12-08 Tue 14:45]
+** DONE opcode generation interface
+   - State "DONE"       [2009-11-15 Sun 14:45]
+** DONE stub generator
+   - State "DONE"       [2009-12-26 Sat 01:50]
+*** DONE define-c-struct
+    - State "DONE"       [2009-11-29 Sun 14:48]
+*** DONE define-c
+    - State "DONE"       [2009-11-29 Sun 14:48]
+*** DONE array return types
+    - State "DONE"       [2009-12-26 Sat 01:49]
+*** DONE pre-buffered string types (like getcwd)
+    - State "DONE"       [2009-12-26 Sat 01:49]
+
+* module system
+** DONE scheme48-like config language
+   - State "DONE"       [2009-10-13 Tue 14:38]
+** DONE shared library includes
+   - State "DONE"       [2009-12-08 Tue 14:39]
+** DONE only/except/rename/prefix modifiers
+   - State "DONE"       [2009-12-16 Wed 18:57]
+** TODO scheme-complete.el support
+** DONE access individual modules from repl
+   - State "DONE"       [2009-12-26 Sat 01:49]
+
+* core modules
+** DONE SRFI-0 cond-expand
+   - State "DONE"       [2009-12-16 Wed 20:12]
+** DONE SRFI-9 define-record-type
+   - State "DONE"       [2009-12-08 Tue 14:50]
+** DONE SRFI-69 hash-tables
+   - State "DONE"       [2009-11-15 Sun 14:50]
+** DONE match library
+   - State "DONE"       [2009-12-08 Tue 14:54]
+** DONE loop library
+   - State "DONE"       [2009-12-08 Tue 14:54]
+** DONE network interface
+   - State "DONE"       from "TODO"       [2011-11-10 Thu 20:46]
+** DONE posix interface
+   - State "DONE"       from "TODO"       [2010-07-11 Sun 15:36]
+   Splitting this into several parts.
+*** DONE filesystem interface
+    - State "DONE"       [2009-12-26 Sat 01:50]
+*** DONE process interface
+    - State "DONE"       [2009-12-26 Sat 01:50]
+*** DONE time interface
+    - State "DONE"       [2009-12-26 Sat 01:50]
+*** DONE host system interface
+    - State "DONE"       [2010-01-02 Sat 20:12]
+** DONE pathname library
+   - State "DONE"       [2009-12-16 Wed 18:58]
+** DONE uri library
+   - State "DONE"       [2009-12-16 Wed 18:58]
+** TODO http library
+** TODO show (formatting) library
+** TODO zip library
+** TODO tar library
+** TODO md5sum library
+
+* ports
+** DONE basic mingw support
+   - State "DONE"       [2009-06-22 Mon 14:36]
+** DONE Plan 9 support
+   - State "DONE"       [2009-08-10 Mon 14:37]
+** DONE 64-bit support
+   - State "DONE"       [2009-11-01 Sun 14:37]
+** DONE iPhone support
+   - State "DONE"       from "TODO"       [2011-11-10 Thu 20:46]
+** TODO bare-metal support
+
+* miscellaneous
+** DONE user documentation
+   - State "DONE"       from "TODO"       [2011-11-10 Thu 20:45]
+** TODO full test suite for libraries
+** TODO thorough source documentation
+
+* distribution
+** TODO packaging format (Snow2)
+** TODO code repository with fetch+install tool
+** TODO translator to/from other implementations
+
diff --git a/VERSION b/VERSION
new file mode 100644
index 00000000..7486fdbc
--- /dev/null
+++ b/VERSION
@@ -0,0 +1 @@
+0.7.2
diff --git a/benchmarks/gabriel/chibi-prelude.scm b/benchmarks/gabriel/chibi-prelude.scm
new file mode 100644
index 00000000..3f9fb1d1
--- /dev/null
+++ b/benchmarks/gabriel/chibi-prelude.scm
@@ -0,0 +1,30 @@
+
+(import (chibi time) (scheme cxr) (srfi 33) (srfi 39))
+
+(define (timeval->milliseconds tv)
+  (quotient (+ (* 1000000 (timeval-seconds tv)) (timeval-microseconds tv))
+            1000))
+
+(define (time* thunk)
+  (call-with-output-string
+    (lambda (out)
+      (let* ((start (car (get-time-of-day)))
+             (result (parameterize ((current-output-port out)) (thunk)))
+             (end (car (get-time-of-day)))
+             (msecs (- (timeval->milliseconds end)
+                       (timeval->milliseconds start))))
+        (display "user: ")
+        (display msecs)
+        (display " system: 0")
+        (display " real: ")
+        (display msecs)
+        (display " gc: 0")
+        (newline)
+        (display "result: ")
+        (write result)
+        (newline)
+        result))))
+
+(define-syntax time
+  (syntax-rules ()
+    ((_ expr) (time* (lambda () expr)))))
diff --git a/benchmarks/gabriel/conform.sch b/benchmarks/gabriel/conform.sch
new file mode 100644
index 00000000..dadcc5d9
--- /dev/null
+++ b/benchmarks/gabriel/conform.sch
@@ -0,0 +1,623 @@
+;
+; conform.scm   [portable/R^399RS version]
+; By Jim Miller [mods by oz]
+;               [call to run-benchmark added by wdc 14 Feb 1997]
+
+; (declare (usual-integrations))
+
+;; SORT
+
+(define (vector-copy v)
+  (let* ((length (vector-length v))
+	 (result (make-vector length)))
+    (let loop ((n 0))
+      (vector-set! result n (vector-ref v n))
+      (if (= n length)
+	  v
+	  (loop (+ n 1))))))
+
+(define (sort obj pred)
+  (define (loop l)
+    (if (and (pair? l) (pair? (cdr l)))
+	(split l '() '())
+	l))
+
+  (define (split l one two)
+    (if (pair? l)
+	(split (cdr l) two (cons (car l) one))
+	(merge (loop one) (loop two))))
+
+  (define (merge one two)
+    (cond ((null? one) two)
+	  ((pred (car two) (car one))
+	   (cons (car two)
+		 (merge (cdr two) one)))
+	  (else
+	   (cons (car one)
+		 (merge (cdr one) two)))))
+
+  (cond ((or (pair? obj) (null? obj))
+	 (loop obj))
+	((vector? obj)
+	 (sort! (vector-copy obj) pred))
+	(else
+	 (error "sort: argument should be a list or vector" obj))))
+
+;; This merge sort is stable for partial orders (for predicates like
+;; <=, rather than like <).
+
+(define (sort! v pred)
+  (define (sort-internal! vec temp low high)
+    (if (< low high)
+	(let* ((middle (quotient (+ low high) 2))
+	       (next (+ middle 1)))
+	  (sort-internal! temp vec low middle)
+	  (sort-internal! temp vec next high)
+	  (let loop ((p low) (p1 low) (p2 next))
+	    (if (not (> p high))
+		(cond ((> p1 middle)
+		       (vector-set! vec p (vector-ref temp p2))
+		       (loop (+ p 1) p1 (+ p2 1)))
+		      ((or (> p2 high)
+			   (pred (vector-ref temp p1)
+				 (vector-ref temp p2)))
+		       (vector-set! vec p (vector-ref temp p1))
+		       (loop (+ p 1) (+ p1 1) p2))
+		      (else
+		       (vector-set! vec p (vector-ref temp p2))
+		       (loop (+ p 1) p1 (+ p2 1)))))))))
+
+  (if (not (vector? v))
+      (error "sort!: argument not a vector" v))
+
+  (sort-internal! v
+		  (vector-copy v)
+		  0
+		  (- (vector-length v) 1))
+  v)
+
+;; SET OPERATIONS
+; (representation as lists with distinct elements)
+
+(define (adjoin element set)
+  (if (memq element set) set (cons element set)))
+
+(define (eliminate element set)
+  (cond ((null? set) set)
+	((eq? element (car set)) (cdr set))
+	(else (cons (car set) (eliminate element (cdr set))))))
+
+(define (intersect list1 list2)
+  (let loop ((l list1))
+    (cond ((null? l) '())
+	  ((memq (car l) list2) (cons (car l) (loop (cdr l))))
+	  (else (loop (cdr l))))))
+
+(define (union list1 list2)
+  (if (null? list1)
+      list2
+      (union (cdr list1)
+	     (adjoin (car list1) list2))))
+
+;; GRAPH NODES
+
+; (define-structure
+;   (internal-node
+;    (print-procedure (unparser/standard-method
+; 		     'graph-node
+; 		     (lambda (state node)
+; 		       (unparse-object state (internal-node-name node))))))
+;   name
+;   (green-edges '())
+;   (red-edges '())
+;   blue-edges)
+
+; Above is MIT version; below is portable
+
+(define make-internal-node vector)
+(define (internal-node-name node) (vector-ref node 0))
+(define (internal-node-green-edges node) (vector-ref node 1))
+(define (internal-node-red-edges node) (vector-ref node 2))
+(define (internal-node-blue-edges node) (vector-ref node 3))
+(define (set-internal-node-name! node name) (vector-set! node 0 name))
+(define (set-internal-node-green-edges! node edges) (vector-set! node 1 edges))
+(define (set-internal-node-red-edges! node edges) (vector-set! node 2 edges))
+(define (set-internal-node-blue-edges! node edges) (vector-set! node 3 edges))
+
+; End of portability stuff
+
+(define (make-node name . blue-edges)	; User's constructor
+  (let ((name (if (symbol? name) (symbol->string name) name))
+	(blue-edges (if (null? blue-edges) 'NOT-A-NODE-YET (car blue-edges))))
+    (make-internal-node name '() '() blue-edges)))
+
+(define (copy-node node)
+  (make-internal-node (name node) '() '() (blue-edges node)))
+
+; Selectors
+
+(define name internal-node-name)
+(define (make-edge-getter selector)
+  (lambda (node)
+    (if (or (none-node? node) (any-node? node))
+	(error "Can't get edges from the ANY or NONE nodes")
+	(selector node))))
+(define red-edges (make-edge-getter internal-node-red-edges))
+(define green-edges (make-edge-getter internal-node-green-edges))
+(define blue-edges (make-edge-getter internal-node-blue-edges))
+
+; Mutators
+
+(define (make-edge-setter mutator!)
+  (lambda (node value)
+    (cond ((any-node? node) (error "Can't set edges from the ANY node"))
+	  ((none-node? node) 'OK)
+	  (else (mutator! node value)))))
+(define set-red-edges! (make-edge-setter set-internal-node-red-edges!))
+(define set-green-edges! (make-edge-setter set-internal-node-green-edges!))
+(define set-blue-edges! (make-edge-setter set-internal-node-blue-edges!))
+
+;; BLUE EDGES
+
+; (define-structure
+;   (blue-edge
+;    (print-procedure
+;     (unparser/standard-method
+;      'blue-edge
+;      (lambda (state edge)
+;        (unparse-object state (blue-edge-operation edge))))))
+;   operation arg-node res-node)
+
+; Above is MIT version; below is portable
+
+(define make-blue-edge vector)
+(define (blue-edge-operation edge) (vector-ref edge 0))
+(define (blue-edge-arg-node edge) (vector-ref edge 1))
+(define (blue-edge-res-node edge) (vector-ref edge 2))
+(define (set-blue-edge-operation! edge value) (vector-set! edge 0 value))
+(define (set-blue-edge-arg-node! edge value) (vector-set! edge 1 value))
+(define (set-blue-edge-res-node! edge value) (vector-set! edge 2 value))
+
+; End of portability stuff
+
+; Selectors
+(define operation blue-edge-operation)
+(define arg-node blue-edge-arg-node)
+(define res-node blue-edge-res-node)
+
+; Mutators
+(define set-arg-node! set-blue-edge-arg-node!)
+(define set-res-node! set-blue-edge-res-node!)
+
+; Higher level operations on blue edges
+
+(define (lookup-op op node)
+  (let loop ((edges (blue-edges node)))
+    (cond ((null? edges) '())
+	  ((eq? op (operation (car edges))) (car edges))
+	  (else (loop (cdr edges))))))
+
+(define (has-op? op node)
+  (not (null? (lookup-op op node))))
+
+; Add a (new) blue edge to a node
+
+; (define (adjoin-blue-edge! blue-edge node)
+;   (let ((current-one (lookup-op (operation blue-edge) node)))
+;     (cond ((null? current-one)
+; 	       (set-blue-edges! node
+; 		 (cons blue-edge (blue-edges node))))
+; 	  ((and (eq? (arg-node current-one) (arg-node blue-edge))
+; 		(eq? (res-node current-one) (res-node blue-edge)))
+; 	   'OK)
+; 	   (else (error "Two non-equivalent blue edges for op"
+; 			blue-edge node)))))
+
+;; GRAPHS
+
+; (define-structure
+;   (internal-graph
+;    (print-procedure
+;     (unparser/standard-method 'graph
+;      (lambda (state edge)
+;        (unparse-object state (map name (internal-graph-nodes edge)))))))
+;   nodes already-met already-joined)
+
+; Above is MIT version; below is portable
+
+(define make-internal-graph vector)
+(define (internal-graph-nodes graph) (vector-ref graph 0))
+(define (internal-graph-already-met graph) (vector-ref graph 1))
+(define (internal-graph-already-joined graph) (vector-ref graph 2))
+(define (set-internal-graph-nodes! graph nodes) (vector-set! graph 0 nodes))
+
+; End of portability stuff
+
+; Constructor
+
+(define (make-graph . nodes)
+  (make-internal-graph nodes (make-empty-table) (make-empty-table)))
+
+; Selectors
+
+(define graph-nodes internal-graph-nodes)
+(define already-met internal-graph-already-met)
+(define already-joined internal-graph-already-joined)
+
+; Higher level functions on graphs
+
+(define (add-graph-nodes! graph nodes)
+  (set-internal-graph-nodes! graph (cons nodes (graph-nodes graph))))
+
+(define (copy-graph g)
+  (define (copy-list l) (vector->list (list->vector l)))
+  (make-internal-graph
+   (copy-list (graph-nodes g))
+   (already-met g)
+   (already-joined g)))
+
+(define (clean-graph g)
+  (define (clean-node node)
+    (if (not (or (any-node? node) (none-node? node)))
+	(begin
+	  (set-green-edges! node '())
+	  (set-red-edges! node '()))))
+  (for-each clean-node (graph-nodes g))
+  g)
+
+(define (canonicalize-graph graph classes)
+  (define (fix node)
+    (define (fix-set object selector mutator)
+      (mutator object 
+	       (map (lambda (node)
+		      (find-canonical-representative node classes))
+		    (selector object))))
+    (if (not (or (none-node? node) (any-node? node)))
+	(begin
+	  (fix-set node green-edges set-green-edges!)
+	  (fix-set node red-edges set-red-edges!)
+	  (for-each 
+	   (lambda (blue-edge)
+	     (set-arg-node! blue-edge
+			    (find-canonical-representative (arg-node blue-edge) classes))
+	     (set-res-node! blue-edge
+			    (find-canonical-representative (res-node blue-edge) classes)))
+	   (blue-edges node))))
+    node)
+  (define (fix-table table)
+    (define (canonical? node) (eq? node (find-canonical-representative node classes)))
+    (define (filter-and-fix predicate-fn update-fn list)
+      (let loop ((list list))
+	(cond ((null? list) '())
+	      ((predicate-fn (car list))
+	       (cons (update-fn (car list)) (loop (cdr list))))
+	      (else (loop (cdr list))))))
+    (define (fix-line line)
+      (filter-and-fix
+       (lambda (entry) (canonical? (car entry)))
+       (lambda (entry) (cons (car entry)
+			     (find-canonical-representative (cdr entry) classes)))
+       line))
+    (if (null? table)
+	'()
+	(cons (car table)
+	      (filter-and-fix
+	       (lambda (entry) (canonical? (car entry)))
+	       (lambda (entry) (cons (car entry) (fix-line (cdr entry))))
+	       (cdr table)))))
+  (make-internal-graph
+   (map (lambda (class) (fix (car class))) classes)
+   (fix-table (already-met graph))
+   (fix-table (already-joined graph))))
+
+;; USEFUL NODES
+
+(define none-node (make-node 'none #t))
+(define (none-node? node) (eq? node none-node))
+
+(define any-node (make-node 'any '()))
+(define (any-node? node) (eq? node any-node))
+
+;; COLORED EDGE TESTS
+
+
+(define (green-edge? from-node to-node)
+  (cond ((any-node? from-node) #f)
+	((none-node? from-node) #t)
+	((memq to-node (green-edges from-node)) #t)
+	(else #f)))
+
+(define (red-edge? from-node to-node)
+  (cond ((any-node? from-node) #f)
+	((none-node? from-node) #t)
+	((memq to-node (red-edges from-node)) #t)
+	(else #f)))
+
+;; SIGNATURE
+
+; Return signature (i.e. <arg, res>) given an operation and a node
+
+(define sig
+  (let ((none-comma-any (cons none-node any-node)))
+    (lambda (op node)			; Returns (arg, res)
+      (let ((the-edge (lookup-op op node)))
+	(if (not (null? the-edge))
+	    (cons (arg-node the-edge) (res-node the-edge))
+	    none-comma-any)))))
+
+; Selectors from signature
+
+(define (arg pair) (car pair))
+(define (res pair) (cdr pair))
+
+;; CONFORMITY
+
+(define (conforms? t1 t2)
+  (define nodes-with-red-edges-out '())
+  (define (add-red-edge! from-node to-node)
+    (set-red-edges! from-node (adjoin to-node (red-edges from-node)))
+    (set! nodes-with-red-edges-out
+	  (adjoin from-node nodes-with-red-edges-out)))
+  (define (greenify-red-edges! from-node)
+    (set-green-edges! from-node
+		      (append (red-edges from-node) (green-edges from-node)))
+    (set-red-edges! from-node '()))
+  (define (delete-red-edges! from-node)
+    (set-red-edges! from-node '()))
+  (define (does-conform t1 t2)
+    (cond ((or (none-node? t1) (any-node? t2)) #t)
+	  ((or (any-node? t1) (none-node? t2)) #f)
+	  ((green-edge? t1 t2) #t)
+	  ((red-edge? t1 t2) #t)
+	  (else
+	   (add-red-edge! t1 t2)
+	   (let loop ((blues (blue-edges t2)))
+	     (if (null? blues)
+		 #t
+		 (let* ((current-edge (car blues))
+			(phi (operation current-edge)))
+		   (and (has-op? phi t1)
+			(does-conform
+			 (res (sig phi t1))
+			 (res (sig phi t2)))
+			(does-conform
+			 (arg (sig phi t2))
+			 (arg (sig phi t1)))
+			(loop (cdr blues)))))))))
+  (let ((result (does-conform t1 t2)))
+    (for-each (if result greenify-red-edges! delete-red-edges!)
+	      nodes-with-red-edges-out)
+    result))
+
+(define (equivalent? a b)
+  (and (conforms? a b) (conforms? b a)))
+
+;; EQUIVALENCE CLASSIFICATION
+; Given a list of nodes, return a list of equivalence classes
+
+(define (classify nodes)
+  (let node-loop ((classes '())
+		  (nodes nodes))
+    (if (null? nodes)
+	(map (lambda (class)
+	       (sort class
+		     (lambda (node1 node2)
+		       (< (string-length (name node1))
+			  (string-length (name node2))))))
+	     classes)
+	(let ((this-node (car nodes)))
+	  (define (add-node classes)
+	    (cond ((null? classes) (list (list this-node)))
+		  ((equivalent? this-node (caar classes))
+		   (cons (cons this-node (car classes))
+			 (cdr classes)))
+		  (else (cons (car classes)
+			      (add-node (cdr classes))))))
+	  (node-loop (add-node classes)
+		     (cdr nodes))))))
+
+; Given a node N and a classified set of nodes,
+; find the canonical member corresponding to N
+
+(define (find-canonical-representative element classification)
+  (let loop ((classes classification))
+    (cond ((null? classes) (error "Can't classify" element)) 
+	  ((memq element (car classes)) (car (car classes)))
+	  (else (loop (cdr classes))))))
+
+; Reduce a graph by taking only one member of each equivalence 
+; class and canonicalizing all outbound pointers
+
+(define (reduce graph)
+  (let ((classes (classify (graph-nodes graph))))
+    (canonicalize-graph graph classes)))
+
+;; TWO DIMENSIONAL TABLES
+
+(define (make-empty-table) (list 'TABLE))
+
+(define (lookup table x y)
+  (let ((one (assq x (cdr table))))
+    (if one
+	(let ((two (assq y (cdr one))))
+	  (if two (cdr two) #f))
+	#f)))
+
+(define (insert! table x y value)
+  (define (make-singleton-table x y)
+    (list (cons x y)))
+  (let ((one (assq x (cdr table))))
+    (if one
+	(set-cdr! one (cons (cons y value) (cdr one)))
+	(set-cdr! table (cons (cons x (make-singleton-table y value))
+			      (cdr table))))))
+
+;; MEET/JOIN 
+; These update the graph when computing the node for node1*node2
+
+(define (blue-edge-operate arg-fn res-fn graph op sig1 sig2)
+  (make-blue-edge op
+		  (arg-fn graph (arg sig1) (arg sig2))
+		  (res-fn graph (res sig1) (res sig2))))
+
+(define (meet graph node1 node2)
+  (cond ((eq? node1 node2) node1)
+	((or (any-node? node1) (any-node? node2)) any-node) ; canonicalize
+	((none-node? node1) node2)
+	((none-node? node2) node1)
+	((lookup (already-met graph) node1 node2)) ; return it if found
+	((conforms? node1 node2) node2)
+	((conforms? node2 node1) node1)
+	(else
+	 (let ((result
+		(make-node (string-append "(" (name node1) " ^ " (name node2) ")"))))
+	   (add-graph-nodes! graph result)
+	   (insert! (already-met graph) node1 node2 result)
+	   (set-blue-edges! result
+	     (map
+	      (lambda (op)
+		(blue-edge-operate join meet graph op (sig op node1) (sig op node2)))
+	      (intersect (map operation (blue-edges node1))
+			 (map operation (blue-edges node2)))))
+	   result))))
+
+(define (join graph node1 node2)
+  (cond ((eq? node1 node2) node1)
+	((any-node? node1) node2)
+	((any-node? node2) node1)
+	((or (none-node? node1) (none-node? node2)) none-node) ; canonicalize
+	((lookup (already-joined graph) node1 node2)) ; return it if found
+	((conforms? node1 node2) node1)
+	((conforms? node2 node1) node2)
+	(else
+	 (let ((result
+		(make-node (string-append "(" (name node1) " v " (name node2) ")"))))
+	   (add-graph-nodes! graph result)
+	   (insert! (already-joined graph) node1 node2 result)
+	   (set-blue-edges! result
+             (map
+	      (lambda (op)
+		(blue-edge-operate meet join graph op (sig op node1) (sig op node2)))
+	      (union (map operation (blue-edges node1))
+		     (map operation (blue-edges node2)))))
+	   result))))
+
+;; MAKE A LATTICE FROM A GRAPH
+
+(define (make-lattice g print?)
+  (define (step g)
+    (let* ((copy (copy-graph g))
+	   (nodes (graph-nodes copy)))
+      (for-each (lambda (first)
+		  (for-each (lambda (second)
+			      (meet copy first second)
+			      (join copy first second))
+			    nodes))
+		nodes)
+      copy))
+  (define (loop g count)
+    (if print? (display count))
+    (let ((lattice (step g)))
+      (if print? (begin (display " -> ")
+			(display (length (graph-nodes lattice)))))
+      (let* ((new-g (reduce lattice))
+	     (new-count (length (graph-nodes new-g))))
+	(if (= new-count count)
+	    (begin
+	      (if print? (newline))
+	      new-g)
+	    (begin
+	      (if print? (begin (display " -> ")
+				(display new-count) (newline)))
+	      (loop new-g new-count))))))
+  (let ((graph
+	 (apply make-graph
+		(adjoin any-node (adjoin none-node (graph-nodes (clean-graph g)))))))
+    (loop graph (length (graph-nodes graph)))))
+
+;; DEBUG and TEST
+
+(define a '())
+(define b '())
+(define c '())
+(define d '())
+
+(define (reset)
+  (set! a (make-node 'a))
+  (set! b (make-node 'b))
+  (set-blue-edges! a (list (make-blue-edge 'phi any-node b)))
+  (set-blue-edges! b (list (make-blue-edge 'phi any-node a)
+			   (make-blue-edge 'theta any-node b)))
+  (set! c (make-node "c"))
+  (set! d (make-node "d"))
+  (set-blue-edges! c (list (make-blue-edge 'theta any-node b)))
+  (set-blue-edges! d (list (make-blue-edge 'phi any-node c)
+			   (make-blue-edge 'theta any-node d)))
+  '(made a b c d))
+
+(define (test)
+  (reset)
+  (map name
+       (graph-nodes
+	(make-lattice (make-graph a b c d any-node none-node) #t))))
+					   ;;; note printflag #t
+;(define (time-test)
+;  (let ((t (runtime)))
+;    (let ((ans (test)))
+;      (cons ans (- (runtime) t)))))
+
+;
+; run and make sure result is correct
+;
+(define (go)
+  (reset)
+  (let ((result '("(((b v d) ^ a) v c)"
+		  "(c ^ d)"
+		  "(b v (a ^ d))"
+		  "((a v d) ^ b)"
+		  "(b v d)"
+		  "(b ^ (a v c))"
+		  "(a v (c ^ d))"
+		  "((b v d) ^ a)"
+		  "(c v (a v d))"
+		  "(a v c)"
+		  "(d v (b ^ (a v c)))"
+		  "(d ^ (a v c))"
+		  "((a ^ d) v c)"
+		  "((a ^ b) v d)"
+		  "(((a v d) ^ b) v (a ^ d))"
+		  "(b ^ d)"
+		  "(b v (a v d))"
+		  "(a ^ c)"
+		  "(b ^ (c v d))"
+		  "(a ^ b)"
+		  "(a v b)"
+		  "((a ^ d) ^ b)"
+		  "(a ^ d)"
+		  "(a v d)"
+		  "d"
+		  "(c v d)"
+		  "a"
+		  "b"
+		  "c"
+		  "any"
+		  "none")))
+
+    (if (equal? (test) result)
+	(display " ok.")
+	(display " um."))
+    (newline)))
+
+;[mods made by wdc]
+;(go)
+;(exit)
+
+(time (let loop ((n 10))
+        (if (zero? n)
+            'done
+            (begin
+              (go)
+              (loop (- n 1))))))
+
+
+
diff --git a/benchmarks/gabriel/cpstack.sch b/benchmarks/gabriel/cpstack.sch
new file mode 100644
index 00000000..6ef109b8
--- /dev/null
+++ b/benchmarks/gabriel/cpstack.sch
@@ -0,0 +1,34 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File:         cpstak.sch
+; Description:  continuation-passing version of TAK
+; Author:       Will Clinger
+; Created:      20-Aug-87
+; Language:     Scheme
+; Status:       Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ 
+;;; CPSTAK -- A continuation-passing version of the TAK benchmark.
+;;; A good test of first class procedures and tail recursion.
+
+(define (cpstak x y z)
+  (define (tak x y z k)
+    (if (not (< y x))
+        (k z)
+        (tak (- x 1)
+             y
+             z
+             (lambda (v1)
+               (tak (- y 1)
+                    z
+                    x
+                    (lambda (v2)
+                      (tak (- z 1)
+                           x
+                           y
+                           (lambda (v3)
+                             (tak v1 v2 v3 k)))))))))
+  (tak x y z (lambda (a) a)))
+ 
+;;; call: (cpstak 18 12 6)
+ 
+(time (cpstak 18 12 2))
diff --git a/benchmarks/gabriel/ctak.sch b/benchmarks/gabriel/ctak.sch
new file mode 100644
index 00000000..f6c6cbc1
--- /dev/null
+++ b/benchmarks/gabriel/ctak.sch
@@ -0,0 +1,61 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File:         ctak.sch
+; Description:  The ctak benchmark
+; Author:       Richard Gabriel
+; Created:      5-Apr-85
+; Modified:     10-Apr-85 14:53:02 (Bob Shaw)
+;               24-Jul-87 (Will Clinger)
+; Language:     Scheme
+; Status:       Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+; The original version of this benchmark used a continuation mechanism that
+; is less powerful than call-with-current-continuation and also relied on
+; dynamic binding, which is not provided in standard Scheme.  Since the
+; intent of the benchmark seemed to be to test non-local exits, the dynamic
+; binding has been replaced here by lexical binding.
+
+; For Scheme the comment that follows should read:
+;;; CTAK -- A version of the TAK procedure that uses continuations.
+
+;;; CTAK -- A version of the TAK function that uses the CATCH/THROW facility.
+
+(define (ctak x y z)
+  (call-with-current-continuation
+   (lambda (k)
+     (ctak-aux k x y z))))
+
+(define (ctak-aux k x y z)
+  (cond ((not (< y x))  ;xy
+         (k z))
+        (else (call-with-current-continuation
+               (ctak-aux
+                k
+                (call-with-current-continuation
+                 (lambda (k)
+                   (ctak-aux k
+                             (- x 1)
+                             y
+                             z)))
+                (call-with-current-continuation
+                 (lambda (k)
+                   (ctak-aux k
+                             (- y 1)
+                             z
+                             x)))
+                (call-with-current-continuation
+                 (lambda (k)
+                   (ctak-aux k
+                             (- z 1)
+                             x
+                             y))))))))
+
+;;; call: (ctak 18 12 6)
+
+(let ((input (with-input-from-file "input.txt" read)))
+  (time (let loop ((n 8) (v 0))
+          (if (zero? n)
+              v
+              (loop (- n 1)
+                    (ctak 18 12 (if input 6 0)))))))
+
diff --git a/benchmarks/gabriel/dderiv.sch b/benchmarks/gabriel/dderiv.sch
new file mode 100644
index 00000000..5e47a0b0
--- /dev/null
+++ b/benchmarks/gabriel/dderiv.sch
@@ -0,0 +1,97 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File:         dderiv.sch
+; Description:  DDERIV benchmark from the Gabriel tests
+; Author:       Vaughan Pratt
+; Created:      8-Apr-85
+; Modified:     10-Apr-85 14:53:29 (Bob Shaw)
+;               23-Jul-87 (Will Clinger)
+;               9-Feb-88 (Will Clinger)
+; Language:     Scheme (but see note below)
+; Status:       Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ 
+; Note:  This benchmark uses property lists.  The procedures that must
+; be supplied are get and put, where (put x y z) is equivalent to Common
+; Lisp's (setf (get x y) z).
+
+;;; DDERIV -- Symbolic derivative benchmark written by Vaughn Pratt.
+ 
+;;; This benchmark is a variant of the simple symbolic derivative program
+;;; (DERIV). The main change is that it is `table-driven.'  Instead of using a
+;;; large COND that branches on the CAR of the expression, this program finds
+;;; the code that will take the derivative on the property list of the atom in
+;;; the CAR position. So, when the expression is (+ . <rest>), the code
+;;; stored under the atom '+ with indicator DERIV will take <rest> and
+;;; return the derivative for '+. The way that MacLisp does this is with the
+;;; special form: (DEFUN (FOO BAR) ...). This is exactly like DEFUN with an
+;;; atomic name in that it expects an argument list and the compiler compiles
+;;; code, but the name of the function with that code is stored on the
+;;; property list of FOO under the indicator BAR, in this case. You may have
+;;; to do something like:
+ 
+;;; :property keyword is not Common Lisp.
+ 
+; Returns the wrong answer for quotients.
+; Fortunately these aren't used in the benchmark.
+ 
+(define pg-alist '())
+(define (put sym d what)
+  (set! pg-alist (cons (cons sym what) pg-alist)))
+(define (get sym d)
+  (cdr (assq sym pg-alist)))
+
+(define (dderiv-aux a)
+  (list '/ (dderiv a) a))
+ 
+(define (f+dderiv a)
+  (cons '+ (map dderiv a)))
+ 
+(define (f-dderiv a)
+  (cons '- (map dderiv a)))
+ 
+(define (*dderiv a)
+  (list '* (cons '* a)
+        (cons '+ (map dderiv-aux a))))
+ 
+(define (/dderiv a)
+  (list '-
+        (list '/
+              (dderiv (car a))
+              (cadr a))
+        (list '/
+              (car a)
+              (list '*
+                    (cadr a)
+                    (cadr a)
+                    (dderiv (cadr a))))))
+ 
+(define (dderiv a)
+  (cond
+    ((not (pair? a))
+     (cond ((eq? a 'x) 1) (else 0)))
+    (else (let ((dderiv (get (car a) 'dderiv)))
+         (cond (dderiv (dderiv (cdr a)))
+               (else 'error))))))
+ 
+(define (run)
+  (do ((i 0 (+ i 1)))
+      ((= i 50000))
+    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
+    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
+    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
+    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
+    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))))
+ 
+(put '+ 'dderiv f+dderiv)    ; install procedure on the property list
+ 
+(put '- 'dderiv f-dderiv)    ; install procedure on the property list
+ 
+(put '* 'dderiv *dderiv)    ; install procedure on the property list
+ 
+(put '/ 'dderiv /dderiv)    ; install procedure on the property list
+ 
+;;; call:  (run)
+ 
+(time (run))
+
+
diff --git a/benchmarks/gabriel/deriv.sch b/benchmarks/gabriel/deriv.sch
new file mode 100644
index 00000000..74881b46
--- /dev/null
+++ b/benchmarks/gabriel/deriv.sch
@@ -0,0 +1,59 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File:         deriv.sch
+; Description:  The DERIV benchmark from the Gabriel tests.
+; Author:       Vaughan Pratt
+; Created:      8-Apr-85
+; Modified:     10-Apr-85 14:53:50 (Bob Shaw)
+;               23-Jul-87 (Will Clinger)
+;               9-Feb-88 (Will Clinger)
+; Language:     Scheme
+; Status:       Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ 
+;;; DERIV -- Symbolic derivative benchmark written by Vaughn Pratt.
+;;; It uses a simple subset of Lisp and does a lot of  CONSing.
+
+; Returns the wrong answer for quotients.
+; Fortunately these aren't used in the benchmark.
+
+(define (deriv-aux a) (list '/ (deriv a) a))
+ 
+(define (deriv a)
+  (cond
+    ((not (pair? a))
+     (cond ((eq? a 'x) 1) (else 0)))
+    ((eq? (car a) '+)
+     (cons '+ (map deriv (cdr a))))
+    ((eq? (car a) '-)
+     (cons '- (map deriv
+                      (cdr a))))
+    ((eq? (car a) '*)
+     (list '*
+           a
+           (cons '+ (map deriv-aux (cdr a)))))
+    ((eq? (car a) '/)
+     (list '-
+           (list '/
+                 (deriv (cadr a))
+                 (caddr a))
+           (list '/
+                 (cadr a)
+                 (list '*
+                       (caddr a)
+                       (caddr a)
+                       (deriv (caddr a))))))
+    (else 'error)))
+ 
+(define (run)
+  (do ((i 0 (+ i 1)))
+      ((= i 50000))
+    (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
+    (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
+    (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
+    (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
+    (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))))
+ 
+;;; call:  (run)
+ 
+(time (run))
+
diff --git a/benchmarks/gabriel/destruct.sch b/benchmarks/gabriel/destruct.sch
new file mode 100644
index 00000000..bbc4473e
--- /dev/null
+++ b/benchmarks/gabriel/destruct.sch
@@ -0,0 +1,70 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File:         destruct.sch
+; Description:  DESTRUCTIVE benchmark from Gabriel tests
+; Author:       Bob Shaw, HPLabs/ATC
+; Created:      8-Apr-85
+; Modified:     10-Apr-85 14:54:12 (Bob Shaw)
+;               23-Jul-87 (Will Clinger)
+;               22-Jan-88 (Will Clinger)
+; Language:     Scheme
+; Status:       Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ 
+; append! is no longer a standard Scheme procedure, so it must be defined
+; for implementations that don't already have it.
+
+(define (my-append! x y)
+  (if (null? x)
+      y
+      (do ((a x b)
+           (b (cdr x) (cdr b)))
+          ((null? b)
+           (set-cdr! a y)
+           x))))
+
+;;; DESTRU -- Destructive operation benchmark
+ 
+(define (destructive n m)
+  (let ((l (do ((i 10 (- i 1))
+                (a '() (cons '() a)))
+               ((= i 0) a))))
+    (do ((i n (- i 1)))
+        ((= i 0))
+      (cond ((null? (car l))
+             (do ((l l (cdr l)))
+                 ((null? l))
+               (or (car l)
+                   (set-car! l (cons '() '())))
+               (my-append! (car l)
+                      (do ((j m (- j 1))
+                           (a '() (cons '() a)))
+                          ((= j 0) a)))))
+            (else
+             (do ((l1 l (cdr l1))
+                  (l2 (cdr l) (cdr l2)))
+                 ((null? l2))
+               (set-cdr! (do ((j (quotient (length (car l2)) 2) (- j 1))
+                            (a (car l2) (cdr a)))
+                           ((zero? j) a)
+                         (set-car! a i))
+                       (let ((n (quotient (length (car l1)) 2)))
+                         (cond ((= n 0) (set-car! l1 '())
+                                (car l1))
+                               (else
+                                (do ((j n (- j 1))
+                                     (a (car l1) (cdr a)))
+                                    ((= j 1)
+                                     (let ((x (cdr a)))
+                                            (set-cdr! a '())
+                                          x))
+                                  (set-car! a i))))))))))))
+ 
+;;; call:  (destructive 600 50)
+
+(let ((input (with-input-from-file "input.txt" read)))
+  (time (let loop ((n 10) (v 0))
+          (if (zero? n)
+              'v
+              (loop (- n 1)
+                    (destructive (if input 600 0) 500))))))
+
diff --git a/benchmarks/gabriel/div.sch b/benchmarks/gabriel/div.sch
new file mode 100644
index 00000000..cbdaeb08
--- /dev/null
+++ b/benchmarks/gabriel/div.sch
@@ -0,0 +1,57 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File:         div.sch
+; Description:  DIV benchmarks
+; Author:       Richard Gabriel
+; Created:      8-Apr-85
+; Modified:     19-Jul-85 18:28:01 (Bob Shaw)
+;               23-Jul-87 (Will Clinger)
+; Language:     Scheme
+; Status:       Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ 
+;;; DIV2 -- Benchmark which divides by 2 using lists of n ()'s.
+;;; This file contains a recursive as well as an iterative test.
+
+(define (create-n n)
+  (do ((n n (- n 1))
+       (a '() (cons '() a)))
+      ((= n 0) a)))
+ 
+(define *ll* (create-n 200))
+ 
+(define (iterative-div2 l)
+  (do ((l l (cddr l))
+       (a '() (cons (car l) a)))
+      ((null? l) a)))
+ 
+(define (recursive-div2 l)
+  (cond ((null? l) '())
+        (else (cons (car l) (recursive-div2 (cddr l))))))
+ 
+(define (test-1 l)
+  (do ((i 3000 (- i 1)))
+      ((= i 0))
+    (iterative-div2 l)
+    (iterative-div2 l)
+    (iterative-div2 l)
+    (iterative-div2 l)))
+ 
+(define (test-2 l)
+  (do ((i 3000 (- i 1)))
+      ((= i 0))
+    (recursive-div2 l)
+    (recursive-div2 l)
+    (recursive-div2 l)
+    (recursive-div2 l)))
+ 
+;;; for the iterative test call: (test-1 *ll*)
+;;; for the recursive test call: (test-2 *ll*)
+ 
+(let ((input (with-input-from-file "input.txt" read)))
+  (time (let loop ((n 10) (v 0))
+          (if (zero? n)
+              v
+              (loop (- n 1)
+                    (cons
+                     (test-1 (if input *ll* '()))
+                     (test-2 (if input *ll* '()))))))))
diff --git a/benchmarks/gabriel/earley.sch b/benchmarks/gabriel/earley.sch
new file mode 100644
index 00000000..d5f90a23
--- /dev/null
+++ b/benchmarks/gabriel/earley.sch
@@ -0,0 +1,649 @@
+;;; EARLEY -- Earley's parser, written by Marc Feeley.
+
+; $Id: earley.sch,v 1.2 1999/07/12 18:05:19 lth Exp $
+; 990708 / lth -- changed 'main' to 'earley-benchmark'.
+;
+; (make-parser grammar lexer) is used to create a parser from the grammar
+; description `grammar' and the lexer function `lexer'.
+;
+; A grammar is a list of definitions.  Each definition defines a non-terminal
+; by a set of rules.  Thus a definition has the form: (nt rule1 rule2...).
+; A given non-terminal can only be defined once.  The first non-terminal
+; defined is the grammar's goal.  Each rule is a possibly empty list of
+; non-terminals.  Thus a rule has the form: (nt1 nt2...).  A non-terminal
+; can be any scheme value.  Note that all grammar symbols are treated as
+; non-terminals.  This is fine though because the lexer will be outputing
+; non-terminals.
+;
+; The lexer defines what a token is and the mapping between tokens and
+; the grammar's non-terminals.  It is a function of one argument, the input,
+; that returns the list of tokens corresponding to the input.  Each token is
+; represented by a list.  The first element is some `user-defined' information
+; associated with the token and the rest represents the token's class(es) (as a
+; list of non-terminals that this token corresponds to).
+;
+; The result of `make-parser' is a function that parses the single input it
+; is given into the grammar's goal.  The result is a `parse' which can be
+; manipulated with the procedures: `parse->parsed?', `parse->trees'
+; and `parse->nb-trees' (see below).
+;
+; Let's assume that we want a parser for the grammar
+;
+;  S -> x = E
+;  E -> E + E | V
+;  V -> V y |
+;
+; and that the input to the parser is a string of characters.  Also, assume we
+; would like to map the characters `x', `y', `+' and `=' into the corresponding
+; non-terminals in the grammar.  Such a parser could be created with
+;
+; (make-parser
+;   '(
+;      (s (x = e))
+;      (e (e + e) (v))
+;      (v (v y) ())
+;    )
+;   (lambda (str)
+;     (map (lambda (char)
+;            (list char ; user-info = the character itself
+;                  (case char
+;                    ((#\x) 'x)
+;                    ((#\y) 'y)
+;                    ((#\+) '+)
+;                    ((#\=) '=)
+;                    (else (fatal-error "lexer error")))))
+;          (string->list str)))
+; )
+;
+; An alternative definition (that does not check for lexical errors) is
+;
+; (make-parser
+;   '(
+;      (s (#\x #\= e))
+;      (e (e #\+ e) (v))
+;      (v (v #\y) ())
+;    )
+;   (lambda (str) (map (lambda (char) (list char char)) (string->list str)))
+; )
+;
+; To help with the rest of the discussion, here are a few definitions:
+;
+; An input pointer (for an input of `n' tokens) is a value between 0 and `n'.
+; It indicates a point between two input tokens (0 = beginning, `n' = end).
+; For example, if `n' = 4, there are 5 input pointers:
+;
+;   input                   token1     token2     token3     token4
+;   input pointers       0          1          2          3          4
+;
+; A configuration indicates the extent to which a given rule is parsed (this
+; is the common `dot notation').  For simplicity, a configuration is
+; represented as an integer, with successive configurations in the same
+; rule associated with successive integers.  It is assumed that the grammar
+; has been extended with rules to aid scanning.  These rules are of the
+; form `nt ->', and there is one such rule for every non-terminal.  Note
+; that these rules are special because they only apply when the corresponding
+; non-terminal is returned by the lexer.
+;
+; A configuration set is a configuration grouped with the set of input pointers
+; representing where the head non-terminal of the configuration was predicted.
+;
+; Here are the rules and configurations for the grammar given above:
+;
+;  S -> .         \
+;       0          |
+;  x -> .          |
+;       1          |
+;  = -> .          |
+;       2          |
+;  E -> .          |
+;       3           > special rules (for scanning)
+;  + -> .          |
+;       4          |
+;  V -> .          |
+;       5          |
+;  y -> .          |
+;       6         /
+;  S -> .  x  .  =  .  E  .
+;       7     8     9     10
+;  E -> .  E  .  +  .  E  .
+;       11    12    13    14
+;  E -> .  V  .
+;       15    16
+;  V -> .  V  .  y  .
+;       17    18    19
+;  V -> .
+;       20
+;
+; Starters of the non-terminal `nt' are configurations that are leftmost
+; in a non-special rule for `nt'.  Enders of the non-terminal `nt' are
+; configurations that are rightmost in any rule for `nt'.  Predictors of the
+; non-terminal `nt' are configurations that are directly to the left of `nt'
+; in any rule.
+;
+; For the grammar given above,
+;
+;   Starters of V   = (17 20)
+;   Enders of V     = (5 19 20)
+;   Predictors of V = (15 17)
+
+(define (make-parser grammar lexer)
+
+  (define (non-terminals grammar) ; return vector of non-terminals in grammar
+
+    (define (add-nt nt nts)
+      (if (member nt nts) nts (cons nt nts))) ; use equal? for equality tests
+
+    (let def-loop ((defs grammar) (nts '()))
+      (if (pair? defs)
+        (let* ((def (car defs))
+               (head (car def)))
+          (let rule-loop ((rules (cdr def))
+                          (nts (add-nt head nts)))
+            (if (pair? rules)
+              (let ((rule (car rules)))
+                (let loop ((l rule) (nts nts))
+                  (if (pair? l)
+                    (let ((nt (car l)))
+                      (loop (cdr l) (add-nt nt nts)))
+                    (rule-loop (cdr rules) nts))))
+              (def-loop (cdr defs) nts))))
+        (list->vector (reverse nts))))) ; goal non-terminal must be at index 0
+
+  (define (ind nt nts) ; return index of non-terminal `nt' in `nts'
+    (let loop ((i (- (vector-length nts) 1)))
+      (if (>= i 0)
+        (if (equal? (vector-ref nts i) nt) i (loop (- i 1)))
+        #f)))
+
+  (define (nb-configurations grammar) ; return nb of configurations in grammar
+    (let def-loop ((defs grammar) (nb-confs 0))
+      (if (pair? defs)
+        (let ((def (car defs)))
+          (let rule-loop ((rules (cdr def)) (nb-confs nb-confs))
+            (if (pair? rules)
+              (let ((rule (car rules)))
+                (let loop ((l rule) (nb-confs nb-confs))
+                  (if (pair? l)
+                    (loop (cdr l) (+ nb-confs 1))
+                    (rule-loop (cdr rules) (+ nb-confs 1)))))
+              (def-loop (cdr defs) nb-confs))))
+      nb-confs)))
+
+; First, associate a numeric identifier to every non-terminal in the
+; grammar (with the goal non-terminal associated with 0).
+;
+; So, for the grammar given above we get:
+;
+; s -> 0   x -> 1   = -> 4   e ->3    + -> 4   v -> 5   y -> 6
+
+  (let* ((nts (non-terminals grammar))          ; id map = list of non-terms
+         (nb-nts (vector-length nts))           ; the number of non-terms
+         (nb-confs (+ (nb-configurations grammar) nb-nts)) ; the nb of confs
+         (starters (make-vector nb-nts '()))    ; starters for every non-term
+         (enders (make-vector nb-nts '()))      ; enders for every non-term
+         (predictors (make-vector nb-nts '()))  ; predictors for every non-term
+         (steps (make-vector nb-confs #f))      ; what to do in a given conf
+         (names (make-vector nb-confs #f)))     ; name of rules
+
+    (define (setup-tables grammar nts starters enders predictors steps names)
+
+      (define (add-conf conf nt nts class)
+        (let ((i (ind nt nts)))
+          (vector-set! class i (cons conf (vector-ref class i)))))
+
+      (let ((nb-nts (vector-length nts)))
+
+        (let nt-loop ((i (- nb-nts 1)))
+          (if (>= i 0)
+            (begin
+              (vector-set! steps i (- i nb-nts))
+              (vector-set! names i (list (vector-ref nts i) 0))
+              (vector-set! enders i (list i))
+              (nt-loop (- i 1)))))
+
+        (let def-loop ((defs grammar) (conf (vector-length nts)))
+          (if (pair? defs)
+            (let* ((def (car defs))
+                   (head (car def)))
+              (let rule-loop ((rules (cdr def)) (conf conf) (rule-num 1))
+                (if (pair? rules)
+                  (let ((rule (car rules)))
+                    (vector-set! names conf (list head rule-num))
+                    (add-conf conf head nts starters)
+                    (let loop ((l rule) (conf conf))
+                      (if (pair? l)
+                        (let ((nt (car l)))
+                          (vector-set! steps conf (ind nt nts))
+                          (add-conf conf nt nts predictors)
+                          (loop (cdr l) (+ conf 1)))
+                        (begin
+                          (vector-set! steps conf (- (ind head nts) nb-nts))
+                          (add-conf conf head nts enders)
+                          (rule-loop (cdr rules) (+ conf 1) (+ rule-num 1))))))
+                  (def-loop (cdr defs) conf))))))))
+
+; Now, for each non-terminal, compute the starters, enders and predictors and
+; the names and steps tables.
+
+    (setup-tables grammar nts starters enders predictors steps names)
+
+; Build the parser description
+
+    (let ((parser-descr (vector lexer
+                                nts
+                                starters
+                                enders
+                                predictors
+                                steps
+                                names)))
+      (lambda (input)
+
+        (define (ind nt nts) ; return index of non-terminal `nt' in `nts'
+          (let loop ((i (- (vector-length nts) 1)))
+            (if (>= i 0)
+              (if (equal? (vector-ref nts i) nt) i (loop (- i 1)))
+              #f)))
+
+        (define (comp-tok tok nts) ; transform token to parsing format
+          (let loop ((l1 (cdr tok)) (l2 '()))
+            (if (pair? l1)
+              (let ((i (ind (car l1) nts)))
+                (if i
+                  (loop (cdr l1) (cons i l2))
+                  (loop (cdr l1) l2)))
+              (cons (car tok) (reverse l2)))))
+
+        (define (input->tokens input lexer nts)
+          (list->vector (map (lambda (tok) (comp-tok tok nts)) (lexer input))))
+
+        (define (make-states nb-toks nb-confs)
+          (let ((states (make-vector (+ nb-toks 1) #f)))
+            (let loop ((i nb-toks))
+              (if (>= i 0)
+                (let ((v (make-vector (+ nb-confs 1) #f)))
+                  (vector-set! v 0 -1)
+                  (vector-set! states i v)
+                  (loop (- i 1)))
+                states))))
+
+        (define (conf-set-get state conf)
+          (vector-ref state (+ conf 1)))
+
+        (define (conf-set-get* state state-num conf)
+          (let ((conf-set (conf-set-get state conf)))
+            (if conf-set
+              conf-set
+              (let ((conf-set (make-vector (+ state-num 6) #f)))
+                (vector-set! conf-set 1 -3) ; old elems tail (points to head)
+                (vector-set! conf-set 2 -1) ; old elems head
+                (vector-set! conf-set 3 -1) ; new elems tail (points to head)
+                (vector-set! conf-set 4 -1) ; new elems head
+                (vector-set! state (+ conf 1) conf-set)
+                conf-set))))
+
+        (define (conf-set-merge-new! conf-set)
+          (vector-set! conf-set
+            (+ (vector-ref conf-set 1) 5)
+            (vector-ref conf-set 4))
+          (vector-set! conf-set 1 (vector-ref conf-set 3))
+          (vector-set! conf-set 3 -1)
+          (vector-set! conf-set 4 -1))
+
+        (define (conf-set-head conf-set)
+          (vector-ref conf-set 2))
+
+        (define (conf-set-next conf-set i)
+          (vector-ref conf-set (+ i 5)))
+
+        (define (conf-set-member? state conf i)
+          (let ((conf-set (vector-ref state (+ conf 1))))
+            (if conf-set
+              (conf-set-next conf-set i)
+              #f)))
+
+        (define (conf-set-adjoin state conf-set conf i)
+          (let ((tail (vector-ref conf-set 3))) ; put new element at tail
+            (vector-set! conf-set (+ i 5) -1)
+            (vector-set! conf-set (+ tail 5) i)
+            (vector-set! conf-set 3 i)
+            (if (< tail 0)
+              (begin
+                (vector-set! conf-set 0 (vector-ref state 0))
+                (vector-set! state 0 conf)))))
+
+        (define (conf-set-adjoin* states state-num l i)
+          (let ((state (vector-ref states state-num)))
+            (let loop ((l1 l))
+              (if (pair? l1)
+                (let* ((conf (car l1))
+                       (conf-set (conf-set-get* state state-num conf)))
+                  (if (not (conf-set-next conf-set i))
+                    (begin
+                      (conf-set-adjoin state conf-set conf i)
+                      (loop (cdr l1)))
+                    (loop (cdr l1))))))))
+
+        (define (conf-set-adjoin** states states* state-num conf i)
+          (let ((state (vector-ref states state-num)))
+            (if (conf-set-member? state conf i)
+              (let* ((state* (vector-ref states* state-num))
+                     (conf-set* (conf-set-get* state* state-num conf)))
+                (if (not (conf-set-next conf-set* i))
+                  (conf-set-adjoin state* conf-set* conf i))
+                #t)
+              #f)))
+
+        (define (conf-set-union state conf-set conf other-set)
+          (let loop ((i (conf-set-head other-set)))
+            (if (>= i 0)
+              (if (not (conf-set-next conf-set i))
+                (begin
+                  (conf-set-adjoin state conf-set conf i)
+                  (loop (conf-set-next other-set i)))
+                (loop (conf-set-next other-set i))))))
+
+        (define (forw states state-num starters enders predictors steps nts)
+
+          (define (predict state state-num conf-set conf nt starters enders)
+
+            ; add configurations which start the non-terminal `nt' to the
+            ; right of the dot
+
+            (let loop1 ((l (vector-ref starters nt)))
+              (if (pair? l)
+                (let* ((starter (car l))
+                       (starter-set (conf-set-get* state state-num starter)))
+                  (if (not (conf-set-next starter-set state-num))
+                    (begin
+                      (conf-set-adjoin state starter-set starter state-num)
+                      (loop1 (cdr l)))
+                    (loop1 (cdr l))))))
+
+            ; check for possible completion of the non-terminal `nt' to the
+            ; right of the dot
+
+            (let loop2 ((l (vector-ref enders nt)))
+              (if (pair? l)
+                (let ((ender (car l)))
+                  (if (conf-set-member? state ender state-num)
+                    (let* ((next (+ conf 1))
+                           (next-set (conf-set-get* state state-num next)))
+                      (conf-set-union state next-set next conf-set)
+                      (loop2 (cdr l)))
+                    (loop2 (cdr l)))))))
+
+          (define (reduce states state state-num conf-set head preds)
+
+            ; a non-terminal is now completed so check for reductions that
+            ; are now possible at the configurations `preds'
+
+            (let loop1 ((l preds))
+              (if (pair? l)
+                (let ((pred (car l)))
+                  (let loop2 ((i head))
+                    (if (>= i 0)
+                      (let ((pred-set (conf-set-get (vector-ref states i) pred)))
+                        (if pred-set
+                          (let* ((next (+ pred 1))
+                                 (next-set (conf-set-get* state state-num next)))
+                            (conf-set-union state next-set next pred-set)))
+                        (loop2 (conf-set-next conf-set i)))
+                      (loop1 (cdr l))))))))
+
+          (let ((state (vector-ref states state-num))
+                (nb-nts (vector-length nts)))
+            (let loop ()
+              (let ((conf (vector-ref state 0)))
+                (if (>= conf 0)
+                  (let* ((step (vector-ref steps conf))
+                         (conf-set (vector-ref state (+ conf 1)))
+                         (head (vector-ref conf-set 4)))
+                    (vector-set! state 0 (vector-ref conf-set 0))
+                    (conf-set-merge-new! conf-set)
+                    (if (>= step 0)
+                      (predict state state-num conf-set conf step starters enders)
+                      (let ((preds (vector-ref predictors (+ step nb-nts))))
+                        (reduce states state state-num conf-set head preds)))
+                    (loop)))))))
+
+        (define (forward starters enders predictors steps nts toks)
+          (let* ((nb-toks (vector-length toks))
+                 (nb-confs (vector-length steps))
+                 (states (make-states nb-toks nb-confs))
+                 (goal-starters (vector-ref starters 0)))
+            (conf-set-adjoin* states 0 goal-starters 0) ; predict goal
+            (forw states 0 starters enders predictors steps nts)
+            (let loop ((i 0))
+              (if (< i nb-toks)
+                (let ((tok-nts (cdr (vector-ref toks i))))
+                  (conf-set-adjoin* states (+ i 1) tok-nts i) ; scan token
+                  (forw states (+ i 1) starters enders predictors steps nts)
+                  (loop (+ i 1)))))
+            states))
+
+        (define (produce conf i j enders steps toks states states* nb-nts)
+          (let ((prev (- conf 1)))
+            (if (and (>= conf nb-nts) (>= (vector-ref steps prev) 0))
+              (let loop1 ((l (vector-ref enders (vector-ref steps prev))))
+                (if (pair? l)
+                  (let* ((ender (car l))
+                         (ender-set (conf-set-get (vector-ref states j)
+                                                  ender)))
+                    (if ender-set
+                      (let loop2 ((k (conf-set-head ender-set)))
+                        (if (>= k 0)
+                          (begin
+                            (and (>= k i)
+                                 (conf-set-adjoin** states states* k prev i)
+                                 (conf-set-adjoin** states states* j ender k))
+                            (loop2 (conf-set-next ender-set k)))
+                          (loop1 (cdr l))))
+                      (loop1 (cdr l)))))))))
+
+        (define (back states states* state-num enders steps nb-nts toks)
+          (let ((state* (vector-ref states* state-num)))
+            (let loop1 ()
+              (let ((conf (vector-ref state* 0)))
+                (if (>= conf 0)
+                  (let* ((conf-set (vector-ref state* (+ conf 1)))
+                         (head (vector-ref conf-set 4)))
+                    (vector-set! state* 0 (vector-ref conf-set 0))
+                    (conf-set-merge-new! conf-set)
+                    (let loop2 ((i head))
+                      (if (>= i 0)
+                        (begin
+                          (produce conf i state-num enders steps
+                                   toks states states* nb-nts)
+                          (loop2 (conf-set-next conf-set i)))
+                        (loop1)))))))))
+
+        (define (backward states enders steps nts toks)
+          (let* ((nb-toks (vector-length toks))
+                 (nb-confs (vector-length steps))
+                 (nb-nts (vector-length nts))
+                 (states* (make-states nb-toks nb-confs))
+                 (goal-enders (vector-ref enders 0)))
+            (let loop1 ((l goal-enders))
+              (if (pair? l)
+                (let ((conf (car l)))
+                  (conf-set-adjoin** states states* nb-toks conf 0)
+                  (loop1 (cdr l)))))
+            (let loop2 ((i nb-toks))
+              (if (>= i 0)
+                (begin
+                  (back states states* i enders steps nb-nts toks)
+                  (loop2 (- i 1)))))
+            states*))
+
+        (define (parsed? nt i j nts enders states)
+          (let ((nt* (ind nt nts)))
+            (if nt*
+              (let ((nb-nts (vector-length nts)))
+                (let loop ((l (vector-ref enders nt*)))
+                  (if (pair? l)
+                    (let ((conf (car l)))
+                      (if (conf-set-member? (vector-ref states j) conf i)
+                        #t
+                        (loop (cdr l))))
+                    #f)))
+              #f)))
+
+        (define (deriv-trees conf i j enders steps names toks states nb-nts)
+          (let ((name (vector-ref names conf)))
+
+            (if name ; `conf' is at the start of a rule (either special or not)
+              (if (< conf nb-nts)
+                (list (list name (car (vector-ref toks i))))
+                (list (list name)))
+
+              (let ((prev (- conf 1)))
+                (let loop1 ((l1 (vector-ref enders (vector-ref steps prev)))
+                            (l2 '()))
+                  (if (pair? l1)
+                    (let* ((ender (car l1))
+                           (ender-set (conf-set-get (vector-ref states j)
+                                                    ender)))
+                      (if ender-set
+                        (let loop2 ((k (conf-set-head ender-set)) (l2 l2))
+                          (if (>= k 0)
+                            (if (and (>= k i)
+                                     (conf-set-member? (vector-ref states k)
+                                                       prev i))
+                              (let ((prev-trees
+                                      (deriv-trees prev i k enders steps names
+                                                   toks states nb-nts))
+                                    (ender-trees
+                                      (deriv-trees ender k j enders steps names
+                                                   toks states nb-nts)))
+                                (let loop3 ((l3 ender-trees) (l2 l2))
+                                  (if (pair? l3)
+                                    (let ((ender-tree (list (car l3))))
+                                      (let loop4 ((l4 prev-trees) (l2 l2))
+                                        (if (pair? l4)
+                                          (loop4 (cdr l4)
+                                                 (cons (append (car l4)
+                                                               ender-tree)
+                                                       l2))
+                                          (loop3 (cdr l3) l2))))
+                                    (loop2 (conf-set-next ender-set k) l2))))
+                              (loop2 (conf-set-next ender-set k) l2))
+                            (loop1 (cdr l1) l2)))
+                        (loop1 (cdr l1) l2)))
+                    l2))))))
+
+        (define (deriv-trees* nt i j nts enders steps names toks states)
+          (let ((nt* (ind nt nts)))
+            (if nt*
+              (let ((nb-nts (vector-length nts)))
+                (let loop ((l (vector-ref enders nt*)) (trees '()))
+                  (if (pair? l)
+                    (let ((conf (car l)))
+                      (if (conf-set-member? (vector-ref states j) conf i)
+                        (loop (cdr l)
+                              (append (deriv-trees conf i j enders steps names
+                                                   toks states nb-nts)
+                                      trees))
+                        (loop (cdr l) trees)))
+                    trees)))
+              #f)))
+
+        (define (nb-deriv-trees conf i j enders steps toks states nb-nts)
+          (let ((prev (- conf 1)))
+            (if (or (< conf nb-nts) (< (vector-ref steps prev) 0))
+              1
+              (let loop1 ((l (vector-ref enders (vector-ref steps prev)))
+                          (n 0))
+                (if (pair? l)
+                  (let* ((ender (car l))
+                         (ender-set (conf-set-get (vector-ref states j)
+                                                  ender)))
+                    (if ender-set
+                      (let loop2 ((k (conf-set-head ender-set)) (n n))
+                        (if (>= k 0)
+                          (if (and (>= k i)
+                                   (conf-set-member? (vector-ref states k)
+                                                     prev i))
+                            (let ((nb-prev-trees
+                                    (nb-deriv-trees prev i k enders steps
+                                                    toks states nb-nts))
+                                  (nb-ender-trees
+                                    (nb-deriv-trees ender k j enders steps
+                                                    toks states nb-nts)))
+                              (loop2 (conf-set-next ender-set k)
+                                     (+ n (* nb-prev-trees nb-ender-trees))))
+                            (loop2 (conf-set-next ender-set k) n))
+                          (loop1 (cdr l) n)))
+                      (loop1 (cdr l) n)))
+                  n)))))
+
+        (define (nb-deriv-trees* nt i j nts enders steps toks states)
+          (let ((nt* (ind nt nts)))
+            (if nt*
+              (let ((nb-nts (vector-length nts)))
+                (let loop ((l (vector-ref enders nt*)) (nb-trees 0))
+                  (if (pair? l)
+                    (let ((conf (car l)))
+                      (if (conf-set-member? (vector-ref states j) conf i)
+                        (loop (cdr l)
+                              (+ (nb-deriv-trees conf i j enders steps
+                                                 toks states nb-nts)
+                                 nb-trees))
+                        (loop (cdr l) nb-trees)))
+                    nb-trees)))
+              #f)))
+
+        (let* ((lexer      (vector-ref parser-descr 0))
+               (nts        (vector-ref parser-descr 1))
+               (starters   (vector-ref parser-descr 2))
+               (enders     (vector-ref parser-descr 3))
+               (predictors (vector-ref parser-descr 4))
+               (steps      (vector-ref parser-descr 5))
+               (names      (vector-ref parser-descr 6))
+               (toks       (input->tokens input lexer nts)))
+
+          (vector nts
+                  starters
+                  enders
+                  predictors
+                  steps
+                  names
+                  toks
+                  (backward (forward starters enders predictors steps nts toks)
+                            enders steps nts toks)
+                  parsed?
+                  deriv-trees*
+                  nb-deriv-trees*))))))
+
+(define (parse->parsed? parse nt i j)
+  (let* ((nts     (vector-ref parse 0))
+         (enders  (vector-ref parse 2))
+         (states  (vector-ref parse 7))
+         (parsed? (vector-ref parse 8)))
+    (parsed? nt i j nts enders states)))
+
+(define (parse->trees parse nt i j)
+  (let* ((nts          (vector-ref parse 0))
+         (enders       (vector-ref parse 2))
+         (steps        (vector-ref parse 4))
+         (names        (vector-ref parse 5))
+         (toks         (vector-ref parse 6))
+         (states       (vector-ref parse 7))
+         (deriv-trees* (vector-ref parse 9)))
+    (deriv-trees* nt i j nts enders steps names toks states)))
+
+(define (parse->nb-trees parse nt i j)
+  (let* ((nts             (vector-ref parse 0))
+         (enders          (vector-ref parse 2))
+         (steps           (vector-ref parse 4))
+         (toks            (vector-ref parse 6))
+         (states          (vector-ref parse 7))
+         (nb-deriv-trees* (vector-ref parse 10)))
+    (nb-deriv-trees* nt i j nts enders steps toks states)))
+
+(define (test k)
+  (let ((p (make-parser '( (s (a) (s s)) )
+                        (lambda (l) (map (lambda (x) (list x x)) l)))))
+    (let ((x (p (vector->list (make-vector k 'a)))))
+      (length (parse->trees x 's 0 k)))))
+
+(time (test 12))
diff --git a/benchmarks/gabriel/fft.sch b/benchmarks/gabriel/fft.sch
new file mode 100644
index 00000000..92ed55d0
--- /dev/null
+++ b/benchmarks/gabriel/fft.sch
@@ -0,0 +1,117 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File:         fft.cl
+; Description:  FFT benchmark from the Gabriel tests.
+; Author:       Harry Barrow
+; Created:      8-Apr-85
+; Modified:     6-May-85 09:29:22 (Bob Shaw)
+;               11-Aug-87 (Will Clinger)
+; Language:     Scheme
+; Status:       Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define pi (atan 0 -1))
+
+;;; FFT -- This is an FFT benchmark written by Harry Barrow.
+;;; It tests a variety of floating point operations,
+;;; including array references.
+ 
+(define *re* (make-vector 1025 0.0))
+ 
+(define *im* (make-vector 1025 0.0))
+ 
+(define (fft areal aimag)
+  (let ((ar 0)
+        (ai 0)
+        (i 0)
+        (j 0)
+        (k 0)
+        (m 0)
+        (n 0)
+        (le 0)
+        (le1 0)
+        (ip 0)
+        (nv2 0)
+        (nm1 0)
+        (ur 0)
+        (ui 0)
+        (wr 0)
+        (wi 0)
+        (tr 0)
+        (ti 0))
+    ;; initialize
+    (set! ar areal)
+    (set! ai aimag)
+    (set! n (vector-length ar))
+    (set! n (- n 1))
+    (set! nv2 (quotient n 2))
+    (set! nm1 (- n 1))
+    (set! m 0)                                  ;compute m = log(n)
+    (set! i 1)
+    (let loop ()
+      (if (< i n)
+          (begin (set! m (+ m 1))
+                 (set! i (+ i i))
+                 (loop))))
+    (cond ((not (= n (expt 2 m)))
+           (error "array size not a power of two.")))
+    ;; interchange elements in bit-reversed order
+    (set! j 1)
+    (set! i 1)
+    (let l3 ()
+      (cond ((< i j)
+             (set! tr (vector-ref ar j))
+             (set! ti (vector-ref ai j))
+             (vector-set! ar j (vector-ref ar i))
+             (vector-set! ai j (vector-ref ai i))
+             (vector-set! ar i tr)
+             (vector-set! ai i ti)))
+      (set! k nv2)
+      (let l6 ()
+        (cond ((< k j)
+               (set! j (- j k))
+               (set! k (/ k 2))
+               (l6))))
+      (set! j (+ j k))
+      (set! i (+ i 1))
+      (cond ((< i n)
+             (l3))))
+    (do ((l 1 (+ l 1)))                 ;loop thru stages (syntax converted
+        ((> l m))                       ; from old MACLISP style \bs)
+        (set! le (expt 2 l))
+        (set! le1 (quotient le 2))
+        (set! ur 1.0)
+        (set! ui 0.)
+        (set! wr (cos (/ pi le1)))
+        (set! wi (sin (/ pi le1)))
+        ;; loop thru butterflies
+        (do ((j 1 (+ j 1)))
+            ((> j le1))
+            ;; do a butterfly
+            (do ((i j (+ i le)))
+                ((> i n))
+                (set! ip (+ i le1))
+                (set! tr (- (* (vector-ref ar ip) ur)
+                            (* (vector-ref ai ip) ui)))
+                (set! ti (+ (* (vector-ref ar ip) ui)
+                            (* (vector-ref ai ip) ur)))
+                (vector-set! ar ip (- (vector-ref ar i) tr))
+                (vector-set! ai ip (- (vector-ref ai i) ti))
+                (vector-set! ar i (+ (vector-ref ar i) tr))
+                (vector-set! ai i (+ (vector-ref ai i) ti))))
+        (set! tr (- (* ur wr) (* ui wi)))
+        (set! ti (+ (* ur wi) (* ui wr)))
+        (set! ur tr)
+        (set! ui ti))
+    #t))
+ 
+;;; the timer which does 10 calls on fft
+ 
+(define (fft-bench)
+  (do ((ntimes 0 (+ ntimes 1)))
+      ((= ntimes 1000))
+      (fft *re* *im*)))
+ 
+;;; call:  (fft-bench)
+ 
+(time (fft-bench))
+
diff --git a/benchmarks/gabriel/graphs.sch b/benchmarks/gabriel/graphs.sch
new file mode 100644
index 00000000..7a27c230
--- /dev/null
+++ b/benchmarks/gabriel/graphs.sch
@@ -0,0 +1,645 @@
+; Modified 2 March 1997 by Will Clinger to add graphs-benchmark
+; and to expand the four macros below.
+; Modified 11 June 1997 by Will Clinger to eliminate assertions
+; and to replace a use of "recur" with a named let.
+;
+; Performance note: (graphs-benchmark 7) allocates
+;   34509143 pairs
+;     389625 vectors with 2551590 elements
+;   56653504 closures (not counting top level and known procedures)
+
+; End of new code.
+
+;;; ==== std.ss ====
+
+; (define-syntax assert
+;     (syntax-rules ()
+; 	((assert test info-rest ...)
+; 	    #f)))
+; 
+; (define-syntax deny
+;     (syntax-rules ()
+; 	((deny test info-rest ...)
+; 	    #f)))
+; 
+; (define-syntax when
+;     (syntax-rules ()
+; 	((when test e-first e-rest ...)
+; 	    (if test
+; 		(begin e-first
+; 		    e-rest ...)))))
+; 
+; (define-syntax unless
+;     (syntax-rules ()
+; 	((unless test e-first e-rest ...)
+; 	    (if (not test)
+; 		(begin e-first
+; 		    e-rest ...)))))
+
+;;; ==== util.ss ====
+
+
+; Fold over list elements, associating to the left.
+(define fold
+    (lambda (lst folder state)
+	'(assert (list? lst)
+	    lst)
+	'(assert (procedure? folder)
+	    folder)
+	(do ((lst lst
+		    (cdr lst))
+		(state state
+		    (folder (car lst)
+			state)))
+	    ((null? lst)
+		state))))
+
+; Given the size of a vector and a procedure which
+; sends indices to desired vector elements, create
+; and return the vector.
+(define proc->vector
+  (lambda (size f)
+    '(assert (and (integer? size)
+                 (exact? size)
+                 (>= size 0))
+      size)
+    '(assert (procedure? f)
+      f)
+    (if (zero? size)
+        (vector)
+        (let ((x (make-vector size (f 0))))
+          (let loop ((i 1))
+            (if (< i size) (begin               ; [wdc - was when]
+              (vector-set! x i (f i))
+              (loop (+ i 1)))))
+          x))))
+
+(define vector-fold
+    (lambda (vec folder state)
+	'(assert (vector? vec)
+	    vec)
+	'(assert (procedure? folder)
+	    folder)
+	(let ((len
+		    (vector-length vec)))
+	    (do ((i 0
+			(+ i 1))
+		    (state state
+			(folder (vector-ref vec i)
+			    state)))
+		((= i len)
+		    state)))))
+
+(define vec-map
+    (lambda (vec proc)
+	(proc->vector (vector-length vec)
+	    (lambda (i)
+		(proc (vector-ref vec i))))))
+
+; Given limit, return the list 0, 1, ..., limit-1.
+(define giota
+    (lambda (limit)
+	'(assert (and (integer? limit)
+		(exact? limit)
+		(>= limit 0))
+	    limit)
+	(let _-*-
+	    ((limit
+		    limit)
+		(res
+		    '()))
+	    (if (zero? limit)
+		res
+		(let ((limit
+			    (- limit 1)))
+		    (_-*- limit
+			(cons limit res)))))))
+
+; Fold over the integers [0, limit).
+(define gnatural-fold
+    (lambda (limit folder state)
+	'(assert (and (integer? limit)
+		(exact? limit)
+		(>= limit 0))
+	    limit)
+	'(assert (procedure? folder)
+	    folder)
+	(do ((i 0
+		    (+ i 1))
+		(state state
+		    (folder i state)))
+	    ((= i limit)
+		state))))
+
+; Iterate over the integers [0, limit).
+(define gnatural-for-each
+    (lambda (limit proc!)
+	'(assert (and (integer? limit)
+		(exact? limit)
+		(>= limit 0))
+	    limit)
+	'(assert (procedure? proc!)
+	    proc!)
+	(do ((i 0
+		    (+ i 1)))
+	    ((= i limit))
+	    (proc! i))))
+
+(define natural-for-all?
+    (lambda (limit ok?)
+	'(assert (and (integer? limit)
+		(exact? limit)
+		(>= limit 0))
+	    limit)
+	'(assert (procedure? ok?)
+	    ok?)
+	(let _-*-
+	    ((i 0))
+	    (or (= i limit)
+		(and (ok? i)
+		    (_-*- (+ i 1)))))))
+
+(define natural-there-exists?
+    (lambda (limit ok?)
+	'(assert (and (integer? limit)
+		(exact? limit)
+		(>= limit 0))
+	    limit)
+	'(assert (procedure? ok?)
+	    ok?)
+	(let _-*-
+	    ((i 0))
+	    (and (not (= i limit))
+		(or (ok? i)
+		    (_-*- (+ i 1)))))))
+
+(define there-exists?
+    (lambda (lst ok?)
+	'(assert (list? lst)
+	    lst)
+	'(assert (procedure? ok?)
+	    ok?)
+	(let _-*-
+	    ((lst lst))
+	    (and (not (null? lst))
+		(or (ok? (car lst))
+		    (_-*- (cdr lst)))))))
+
+
+;;; ==== ptfold.ss ====
+
+
+; Fold over the tree of permutations of a universe.
+; Each branch (from the root) is a permutation of universe.
+; Each node at depth d corresponds to all permutations which pick the
+; elements spelled out on the branch from the root to that node as
+; the first d elements.
+; Their are two components to the state:
+;	The b-state is only a function of the branch from the root.
+;	The t-state is a function of all nodes seen so far.
+; At each node, b-folder is called via
+;	(b-folder elem b-state t-state deeper accross)
+; where elem is the next element of the universe picked.
+; If b-folder can determine the result of the total tree fold at this stage,
+; it should simply return the result.
+; If b-folder can determine the result of folding over the sub-tree
+; rooted at the resulting node, it should call accross via
+;	(accross new-t-state)
+; where new-t-state is that result.
+; Otherwise, b-folder should call deeper via
+;	(deeper new-b-state new-t-state)
+; where new-b-state is the b-state for the new node and new-t-state is
+; the new folded t-state.
+; At the leaves of the tree, t-folder is called via
+;	(t-folder b-state t-state accross)
+; If t-folder can determine the result of the total tree fold at this stage,
+; it should simply return that result.
+; If not, it should call accross via
+;	(accross new-t-state)
+; Note, fold-over-perm-tree always calls b-folder in depth-first order.
+; I.e., when b-folder is called at depth d, the branch leading to that
+; node is the most recent calls to b-folder at all the depths less than d.
+; This is a gross efficiency hack so that b-folder can use mutation to
+; keep the current branch.
+(define fold-over-perm-tree
+    (lambda (universe b-folder b-state t-folder t-state)
+	'(assert (list? universe)
+	    universe)
+	'(assert (procedure? b-folder)
+	    b-folder)
+	'(assert (procedure? t-folder)
+	    t-folder)
+	(let _-*-
+	    ((universe
+		    universe)
+		(b-state
+		    b-state)
+		(t-state
+		    t-state)
+		(accross
+		    (lambda (final-t-state)
+			final-t-state)))
+	    (if (null? universe)
+		(t-folder b-state t-state accross)
+		(let _-**-
+		    ((in
+			    universe)
+			(out
+			    '())
+			(t-state
+			    t-state))
+		    (let* ((first
+				(car in))
+			    (rest
+				(cdr in))
+			    (accross
+				(if (null? rest)
+				    accross
+				    (lambda (new-t-state)
+					(_-**- rest
+					    (cons first out)
+					    new-t-state)))))
+			(b-folder first
+			    b-state
+			    t-state
+			    (lambda (new-b-state new-t-state)
+				(_-*- (fold out cons rest)
+				    new-b-state
+				    new-t-state
+				    accross))
+			    accross)))))))
+
+
+;;; ==== minimal.ss ====
+
+
+; A directed graph is stored as a connection matrix (vector-of-vectors)
+; where the first index is the `from' vertex and the second is the `to'
+; vertex.  Each entry is a bool indicating if the edge exists.
+; The diagonal of the matrix is never examined.
+; Make-minimal? returns a procedure which tests if a labelling
+; of the vertices is such that the matrix is minimal.
+; If it is, then the procedure returns the result of folding over
+; the elements of the automoriphism group.  If not, it returns #f.
+; The folding is done by calling folder via
+;	(folder perm state accross)
+; If the folder wants to continue, it should call accross via
+;	(accross new-state)
+; If it just wants the entire minimal? procedure to return something,
+; it should return that.
+; The ordering used is lexicographic (with #t > #f) and entries
+; are examined in the following order:
+;	1->0, 0->1
+;
+;	2->0, 0->2
+;	2->1, 1->2
+;
+;	3->0, 0->3
+;	3->1, 1->3
+;	3->2, 2->3
+;	...
+(define make-minimal?
+    (lambda (max-size)
+	'(assert (and (integer? max-size)
+		(exact? max-size)
+		(>= max-size 0))
+	    max-size)
+	(let ((iotas
+		    (proc->vector (+ max-size 1)
+			giota))
+		(perm
+		    (make-vector max-size 0)))
+	    (lambda (size graph folder state)
+		'(assert (and (integer? size)
+			(exact? size)
+			(<= 0 size max-size))
+		    size
+		    max-size)
+		'(assert (vector? graph)
+		    graph)
+		'(assert (procedure? folder)
+		    folder)
+		(fold-over-perm-tree (vector-ref iotas size)
+		    (lambda (perm-x x state deeper accross)
+			(case (cmp-next-vertex graph perm x perm-x)
+			    ((less)
+				#f)
+			    ((equal)
+				(vector-set! perm x perm-x)
+				(deeper (+ x 1)
+				    state))
+			    ((more)
+				(accross state))
+			    ;(else
+                            ; (assert #f))
+                            ))
+		    0
+		    (lambda (leaf-depth state accross)
+			'(assert (eqv? leaf-depth size)
+			    leaf-depth
+			    size)
+			(folder perm state accross))
+		    state)))))
+
+; Given a graph, a partial permutation vector, the next input and the next
+; output, return 'less, 'equal or 'more depending on the lexicographic
+; comparison between the permuted and un-permuted graph.
+(define cmp-next-vertex
+    (lambda (graph perm x perm-x)
+	(let ((from-x
+		    (vector-ref graph x))
+		(from-perm-x
+		    (vector-ref graph perm-x)))
+	    (let _-*-
+		((y
+			0))
+		(if (= x y)
+		    'equal
+		    (let ((x->y?
+				(vector-ref from-x y))
+			    (perm-y
+				(vector-ref perm y)))
+			(cond ((eq? x->y?
+				    (vector-ref from-perm-x perm-y))
+				(let ((y->x?
+					    (vector-ref (vector-ref graph y)
+						x)))
+				    (cond ((eq? y->x?
+						(vector-ref (vector-ref graph perm-y)
+						    perm-x))
+					    (_-*- (+ y 1)))
+					(y->x?
+					    'less)
+					(else
+					    'more))))
+			    (x->y?
+				'less)
+			    (else
+				'more))))))))
+
+
+;;; ==== rdg.ss ====
+
+
+; Fold over rooted directed graphs with bounded out-degree.
+; Size is the number of vertices (including the root).  Max-out is the
+; maximum out-degree for any vertex.  Folder is called via
+;	(folder edges state)
+; where edges is a list of length size.  The ith element of the list is
+; a list of the vertices j for which there is an edge from i to j.
+; The last vertex is the root.
+(define fold-over-rdg
+    (lambda (size max-out folder state)
+	'(assert (and (exact? size)
+		(integer? size)
+		(> size 0))
+	    size)
+	'(assert (and (exact? max-out)
+		(integer? max-out)
+		(>= max-out 0))
+	    max-out)
+	'(assert (procedure? folder)
+	    folder)
+	(let* ((root
+		    (- size 1))
+		(edge?
+		    (proc->vector size
+			(lambda (from)
+			    (make-vector size #f))))
+		(edges
+		    (make-vector size '()))
+		(out-degrees
+		    (make-vector size 0))
+		(minimal-folder
+		    (make-minimal? root))
+		(non-root-minimal?
+		    (let ((cont
+				(lambda (perm state accross)
+				    '(assert (eq? state #t)
+					state)
+				    (accross #t))))
+			(lambda (size)
+			    (minimal-folder size
+				edge?
+				cont
+				#t))))
+		(root-minimal?
+		    (let ((cont
+				(lambda (perm state accross)
+				    '(assert (eq? state #t)
+					state)
+				    (case (cmp-next-vertex edge? perm root root)
+					((less)
+					    #f)
+					((equal more)
+					    (accross #t))
+					;(else
+					;    (assert #f))
+                                        ))))
+			(lambda ()
+			    (minimal-folder root
+				edge?
+				cont
+				#t)))))
+	    (let _-*-
+		((vertex
+			0)
+		    (state
+			state))
+		(cond ((not (non-root-minimal? vertex))
+			state)
+		    ((= vertex root)
+			'(assert
+			    (begin
+				(gnatural-for-each root
+				    (lambda (v)
+					'(assert (= (vector-ref out-degrees v)
+						(length (vector-ref edges v)))
+					    v
+					    (vector-ref out-degrees v)
+					    (vector-ref edges v))))
+				#t))
+			(let ((reach?
+				    (make-reach? root edges))
+				(from-root
+				    (vector-ref edge? root)))
+			    (let _-*-
+				((v
+					0)
+				    (outs
+					0)
+				    (efr
+					'())
+				    (efrr
+					'())
+				    (state
+					state))
+				(cond ((not (or (= v root)
+						(= outs max-out)))
+					(vector-set! from-root v #t)
+					(let ((state
+						    (_-*- (+ v 1)
+							(+ outs 1)
+							(cons v efr)
+							(cons (vector-ref reach? v)
+							    efrr)
+							state)))
+					    (vector-set! from-root v #f)
+					    (_-*- (+ v 1)
+						outs
+						efr
+						efrr
+						state)))
+				    ((and (natural-for-all? root
+						(lambda (v)
+						    (there-exists? efrr
+							(lambda (r)
+							    (vector-ref r v)))))
+					    (root-minimal?))
+					(vector-set! edges root efr)
+					(folder
+					    (proc->vector size
+						(lambda (i)
+						    (vector-ref edges i)))
+					    state))
+				    (else
+					state)))))
+		    (else
+			(let ((from-vertex
+				    (vector-ref edge? vertex)))
+			    (let _-**-
+				((sv
+					0)
+				    (outs
+					0)
+				    (state
+					state))
+				(if (= sv vertex)
+				    (begin
+					(vector-set! out-degrees vertex outs)
+					(_-*- (+ vertex 1)
+					    state))
+				    (let* ((state
+						; no sv->vertex, no vertex->sv
+						(_-**- (+ sv 1)
+						    outs
+						    state))
+					    (from-sv
+						(vector-ref edge? sv))
+					    (sv-out
+						(vector-ref out-degrees sv))
+					    (state
+						(if (= sv-out max-out)
+						    state
+						    (begin
+							(vector-set! edges
+							    sv
+							    (cons vertex
+								(vector-ref edges sv)))
+							(vector-set! from-sv vertex #t)
+							(vector-set! out-degrees sv (+ sv-out 1))
+							(let* ((state
+								    ; sv->vertex, no vertex->sv
+								    (_-**- (+ sv 1)
+									outs
+									state))
+								(state
+								    (if (= outs max-out)
+									state
+									(begin
+									    (vector-set! from-vertex sv #t)
+									    (vector-set! edges
+										vertex
+										(cons sv
+										    (vector-ref edges vertex)))
+									    (let ((state
+											; sv->vertex, vertex->sv
+											(_-**- (+ sv 1)
+											    (+ outs 1)
+											    state)))
+										(vector-set! edges
+										    vertex
+										    (cdr (vector-ref edges vertex)))
+										(vector-set! from-vertex sv #f)
+										state)))))
+							    (vector-set! out-degrees sv sv-out)
+							    (vector-set! from-sv vertex #f)
+							    (vector-set! edges
+								sv
+								(cdr (vector-ref edges sv)))
+							    state)))))
+					(if (= outs max-out)
+					    state
+					    (begin
+						(vector-set! edges
+						    vertex
+						    (cons sv
+							(vector-ref edges vertex)))
+						(vector-set! from-vertex sv #t)
+						(let ((state
+							    ; no sv->vertex, vertex->sv
+							    (_-**- (+ sv 1)
+								(+ outs 1)
+								state)))
+						    (vector-set! from-vertex sv #f)
+						    (vector-set! edges
+							vertex
+							(cdr (vector-ref edges vertex)))
+						    state)))))))))))))
+
+; Given a vector which maps vertex to out-going-edge list,
+; return a vector  which gives reachability.
+(define make-reach?
+    (lambda (size vertex->out)
+	(let ((res
+		    (proc->vector size
+			(lambda (v)
+			    (let ((from-v
+					(make-vector size #f)))
+				(vector-set! from-v v #t)
+				(for-each
+				    (lambda (x)
+					(vector-set! from-v x #t))
+				    (vector-ref vertex->out v))
+				from-v)))))
+	    (gnatural-for-each size
+		(lambda (m)
+		    (let ((from-m
+				(vector-ref res m)))
+			(gnatural-for-each size
+			    (lambda (f)
+				(let ((from-f
+					    (vector-ref res f)))
+				    (if (vector-ref from-f m); [wdc - was when]
+                                       (begin
+					(gnatural-for-each size
+					    (lambda (t)
+						(if (vector-ref from-m t)
+                                                   (begin ; [wdc - was when]
+						    (vector-set! from-f t #t)))))))))))))
+	    res)))
+
+
+;;; ==== test input ====
+
+; Produces all directed graphs with N vertices, distinguished root,
+; and out-degree bounded by 2, upto isomorphism (there are 44).
+
+;(define go
+;  (let ((N 7))
+;    (fold-over-rdg N
+;      2 
+;      cons
+;      '())))
+
+(let ((input (with-input-from-file "input.txt" read)))
+  (time
+   (length
+    (let loop ((n 3) (v 0))
+      (if (zero? n)
+          v
+          (loop (- n 1)
+                (fold-over-rdg (if input 6 0)
+                               2 
+                               cons
+                               '())))))))
diff --git a/benchmarks/gabriel/kanren.sch b/benchmarks/gabriel/kanren.sch
new file mode 100644
index 00000000..8d46a91d
--- /dev/null
+++ b/benchmarks/gabriel/kanren.sch
@@ -0,0 +1,6489 @@
+;; smashed into benchmark form by Matthew
+
+(define errorf error)
+
+; like cout << arguments << args
+; where argument can be any Scheme object. If it's a procedure
+; (without args) it's executed rather than printed (like newline)
+
+(define (cout . args)
+  (for-each (lambda (x)
+              (if (procedure? x) (x) (display x)))
+            args))
+
+(define cerr cout)
+
+(define pntall (lambda v (write v) (newline)))
+(define (_pretty-print v) (write v) (newline))
+
+(define nl (string #\newline))
+
+;; =========================================================================
+;;  term.scm
+;; =========================================================================
+
+;		Terms, variables, substitutions, unification
+;
+; The appropriate prelude (e.g., chez-specific.scm) is assumed.
+
+; Some terminology related to variables and substitutions
+;
+; A substitution subst is a finite map { xi -> ti ... }
+; where xi is a logic variable.
+; ti is a term ::= variable | Scheme-atom | (cons term term)
+; We will sometimes call one `component' xi -> ti of a substitution
+; a commitment, or a binding, of a variable xi to a term ti.
+;
+; A variable x is free in the substitution subst if x \not\in Dom(subst)
+;
+; Given a term t and a substitution subst, a weak reduction
+;   t -->w  t'
+; is defined as
+;   x -->w subst[x]  if x is a var and x \in Dom(subst)
+;   t -->w t otherwise
+;
+; A strong reduction
+;   t -->s t' 
+; is defined as
+;   x -->s subst[x]  if x is a var and x \in Dom(subst)
+;   (cons t1 t2) -->s (cons t1' t2')
+;          where t1 -->s t1'  t2 -->s t2'
+;   t -->s t otherwise
+;
+; The notion of reduction can be extended to substitutions themselves:
+;   { xi -> ti ...} -->w { xi -> ti' } where ti -> ti'
+; ditto for -->s.
+; Let -->w* be a reflexive transitive closure of -->w, and 
+; let -->w! be a fixpoint of -->w. Ditto for -->s* and -->s!
+; For acyclic substitutions, the fixpoints exist.
+;
+; The confluence of the reduction is guaranteed by the particular form
+; of the substitution produced by the unifier (the unifier always
+; deals with the weak normal forms of submitted terms).
+;
+; The similarity of the weak normalization with call-by-value and
+; the strong normalization with the applicative-order reduction should
+; be apparent.
+;
+; Variable x is called ultimately free if
+; x -->w! x' and x' is free in the subtutution in question.
+;
+; Two ultimately free variables x and y belong to the same equivalence class
+; if x -->w! u and y -->w! u
+; The (free) variable u is the natural class representative.
+; For the purpose of presentation, one may wish for a better representative.
+; Given a set of equivalent variables xi -->w! u,
+; a pretty representative is a member z of that set such that the
+; string name of 'z' is lexicographically smaller than the string names 
+; of the other variables in that set.
+;
+; If a variable x is ultimately free in subst and x ->w! u, 
+; then there is a binding
+; v1 -> v2 where both v1 and v2 are variables and v2 ->w! u. Furthermore,
+; the set of all such v1 union {u} is the whole equivalence class of x.
+; That property is guaranteed by the unifier. That property lets us
+; build an inverse index to find the equivalence class of x.
+;
+; $Id: term.scm,v 4.50 2005/02/12 00:05:27 oleg Exp $
+
+
+;----------------------------------------
+; A few preliminaries
+; LET*-AND: a simplified and streamlined AND-LET*.
+; The latter is defined in SRFI-2 <http://srfi.schemers.org/srfi-2/>
+
+(define-syntax let*-and
+  (syntax-rules ()
+    ((_ false-exp () body0 body1 ...) (begin body0 body1 ...))
+    ((_ false-exp ((var0 exp0) (var1 exp1) ...) body0 body1 ...)
+     (let ((var0 exp0))
+       (if var0
+         (let*-and false-exp ((var1 exp1) ...) body0 body1 ...)
+         false-exp)))))
+
+; Regression testing framework
+; test-check TITLE TESTED-EXPRESSION EXPECTED-RESULT 
+; where TITLE is something printable (e.g., a symbol or a string)
+; EXPECTED-RESULT and TESTED-EXPRESSION are both expressions.
+; The expressions are evaluated and their results are cmpared
+; by equal?
+; If the results compare, we just print the TITLE.
+; Otherwise, we print the TITLE, the TESTED-EXPRESSION, and
+; the both results.
+(define-syntax test-check
+  (syntax-rules ()
+    ((_ title tested-expression expected-result)
+       (begin
+         (cout "Testing " title nl)
+         (let* ((expected expected-result)
+                (produced tested-expression))
+           (or (equal? expected produced)
+               (errorf 'test-check
+                       "Failed: ~a~%Expected: ~a~%Computed: ~a~%"
+                       'tested-expression expected produced)))
+         #f))))
+
+(define symbol-append
+  (lambda symbs
+    (string->symbol
+      (apply string-append
+        (map symbol->string symbs)))))
+
+;----------------------------------------
+
+
+;; use SRFI-9 records
+(define (make-logical-variable name)
+  (vector 'lv name))
+(define (logical-variable? x)
+  (and (vector? x) (eq? 'lv (vector-ref x 0))))
+(define (logical-variable-id x)
+  (vector-ref x 1))
+
+(define logical-variable make-logical-variable)
+(define var? logical-variable?)
+
+; Introduction of a logical variable
+(define-syntax let-lv
+  (syntax-rules ()
+    ((_ (id ...) body)
+      (let ((id (logical-variable 'id)) ...) body))))
+
+; The anonymous variable
+(define __ (let-lv (_) _))
+
+; Another way to introduce logical variables: via distinguished pairs
+; (define logical-var-tag (list '*logical-var-tag*)) ; unique for eq?
+; (define native-pair? pair?)
+; (define logical-variable
+;   (lambda (id)
+;     (cons logical-var-tag id)))
+; (define var?
+;   (lambda (x)
+;     (and (native-pair? x) (eq? (car x) logical-var-tag))))
+; (define logical-variable-id
+;   (lambda (x)
+;     (if (var? x) (cdr x) 
+;       (errorf 'logical-variable-id "Invalid Logic Variable: ~s" x))))
+; (define pair?
+;   (lambda (x)
+;     (and (native-pair? x) (not (eq? (car x) logical-var-tag)))))
+
+
+; Eigen-variables -- unique symbols that represent universally-quantified
+; variables in a term
+; For identification, we prefix the name of the eigen-variable with
+; the exclamation mark. The mark makes sure the symbol stands out when
+; printed.
+
+(define counter 0)
+(define (jensym s)
+  (set! counter (+ counter 1))
+  (string->symbol (string-append "!$gen$!" s (number->string counter))))
+
+(define eigen-variable
+  (lambda (id)
+    (symbol-append '! id '_ (jensym "x"))))
+
+(define eigen-var?
+  (lambda (x)
+    (and (symbol? x)
+      (let ((str (symbol->string x)))
+	(> (string-length str) 2)
+	(char=? (string-ref str 0) #\!)))))
+
+
+; (eigen (id ...) body) -- evaluate body in the environment
+; extended with the bindings of id ... to the corresponding
+; eigen-variables
+(define-syntax eigen
+  (syntax-rules ()
+    ((_ (id ...) body)
+      (let ((id (eigen-variable 'id)) ...) body))))
+
+(define (eigen-test)
+(test-check 'eigen
+  (and
+    (eigen () #t)
+    (eigen (x) (eigen-var? x))
+    (eigen (x y)
+      (begin (display "eigens: ") (display (list x y))
+	(newline) #t)))
+  #t))
+
+;;; ------------------------------------------------------
+
+(define commitment cons)
+(define commitment->term cdr)
+(define commitment->var car)
+
+(define empty-subst '())
+(define empty-subst? null?)
+
+(define extend-subst
+  (lambda (v t subst)
+    (cons (commitment v t) subst)))
+
+; get the free vars of a term (a list without duplicates)
+(define vars-of
+  (lambda (term)
+    (let loop ((term term) (fv '()))
+      (cond
+        ((var? term) (if (memq term fv) fv (cons term fv)))
+        ((pair? term) (loop (cdr term) (loop (car term) fv)))
+        (else fv)))))
+
+; Check to see if a var occurs in a term
+(define occurs?
+  (lambda (var term)
+    (cond
+      ((var? term) (eq? term var))
+      ((pair? term) (or (occurs? var (car term)) (occurs? var (cdr term))))
+      (else #f))))
+
+; A ground term contains no variables
+(define ground?
+  (lambda (t)
+    (cond
+      ((var? t) #f)
+      ((pair? t) (and (ground? (car t)) (ground? (cdr t))))
+      (else #t))))
+
+; Given a term v and a subst s, return v', the weak normal form of v:
+; v -->w! v' with respect to s
+(define subst-in-weak
+  (lambda (v s)
+    (cond
+      ((var? v) 
+       (cond
+         ((assq v s) =>
+          (lambda (b) (subst-in-weak (commitment->term b) s)))
+         (else v)))
+      (else v))))
+
+; Given a term v and a subst s, return v', the strong normal form of v:
+; v -->s! v' with respect to s
+(define subst-in
+  (lambda (t subst)
+    (cond
+      ((var? t)
+       (let ((c (assq t subst)))
+         (if c (subst-in (commitment->term c) subst) t)))
+      ((pair? t)
+       (cons
+         (subst-in (car t) subst)
+         (subst-in (cdr t) subst)))
+      (else t))))
+
+
+; ; Given a term v and a subst s, return v', the strong normal form of v:
+; ; v -->s! v' with respect to s
+; (define subst-vars-recursively
+;   (lambda (t subst)
+;     (cond
+;       ((var? t)
+;        (cond
+;          ((assq t subst) =>
+;           (lambda (c)
+;             (subst-vars-recursively
+;               (commitment->term c) (remq c subst))))
+;          (else t)))
+;       ((pair? t)
+;        (cons
+;          (subst-vars-recursively (car t) subst)
+;          (subst-vars-recursively (cdr t) subst)))
+;       (else t))))
+
+; (define normalize-subst
+;   (lambda (subst)
+;     (map (lambda (c)
+;            (commitment (commitment->var c)
+;              (subst-vars-recursively (commitment->term c) subst)))
+;       subst)))
+
+
+; Sooner or later, we will need to print out a term or do something
+; else with it. We have to decide what to do with free variables that
+; may be in that term.
+; The long experience with Kanren and miniKanren and long discussions
+; convinced us that it's best to `display' free variables as
+; _.n where n is a number. BTW, we can't just display
+; logical-variable-id, because distinct logical variables may have the same
+; logical-variable-id.
+
+; reify:: term -> reified-term
+; where reified-term is identical to term if it is ground.
+; Otherwise, we replace all free variables in term with _.n symbols
+; The 'reverse' in (reverse (vars-of t))
+; just makes the output look as it used to look before. Consider it
+(define reify
+  (lambda (term)
+    (let ((fv (reverse (vars-of term))))
+      (if (null? fv) term		; the term is ground
+	(let ((renaming			; build the renaming substitution
+		(let loop ((counter 0) (fv fv))
+		  (if (null? fv) empty-subst
+		    (extend-subst 
+		      (car fv)
+		      (string->symbol
+			(string-append "_." (number->string counter)))
+		      (loop (+ 1 counter) (cdr fv)))))))
+	  (subst-in term renaming))))))
+
+
+; we will also need to print the substitution, either in whole or in part
+; reify-subst:: list-of-vars subst -> reified-subst
+; where list-of-vars is a list of variables to reify, or the empty
+; list. In the latter case, all variables from subst are reified.
+; reified-subst has a form ((var-name reified-term) ...)
+; where var-name, for historical reasons, has the form id.0
+; where `id' is logical-variable-id.
+
+(define reify-subst
+  (lambda (vars subst)
+    (let* ((vars (if (null? vars) (map commitment->var subst) vars))
+	   (terms (reify (subst-in vars subst))))
+      (map (lambda (x y)
+	     (list (string->symbol 
+		     (string-append (symbol->string (logical-variable-id x))
+		       ".0"))
+	       y))
+	     vars terms))))
+
+      
+  
+
+; (define compose-subst/own-survivors
+;   (lambda (base refining survivors)
+;     (let refine ((b* base))
+;       (if (null? b*) survivors
+;           (cons-if-real-commitment
+;             (commitment->var (car b*))
+;             (subst-in (commitment->term (car b*)) refining)
+;             (refine (cdr b*)))))))
+;
+; (define compose-subst
+;   (lambda (base refining)
+;     (cond
+;       ((null? base) refining)
+;       ((null? refining) base)
+;       (else
+;         (compose-subst/own-survivors base refining
+;           (let survive ((r* refining))
+;             (cond
+;               ((null? r*) '())
+;               ((assq (commitment->var (car r*)) base) (survive (cdr r*)))
+;               (else (cons (car r*) (survive (cdr r*)))))))))))
+
+; Replace a logical variable with the corresponding eigen-variable
+; Note: to be really right, universalize should be a scoping predicate,
+; something like exists:
+; (universalize (term) goal)
+; to prove 'goal' in the env where term is universalized.
+; In that case, the introduced eigen-variables do not escape.
+; Also, perhaps universalize should take a subst and first
+; do (subst-in term subst) and then universalize the remaining
+; logical variables -- which by that time would surely be free.
+(define universalize
+  (lambda (term)
+    (let ((fv (vars-of term)))
+      (let ((subst
+              (map
+                (lambda (v)
+                  (commitment v (eigen-variable (logical-variable-id v))))
+                fv)))
+        (subst-in term subst)))))
+
+
+; copy-term TERM -> TERM
+; return a TERM that is identical to the input term modulo the replacement
+; of variables in TERM with fresh logical variables. 
+; If a logical variable occurs several times in TERM, the result
+; will have the same number of occurrences of the replacement fresh
+; variable.
+; This is a sort-of dual to universalize, to be used on the other side
+; of the implication. It replaces the existential quantification
+; (implicit in free logical variables of a term) with the universal
+; quantification.
+(define copy-term
+  (lambda (t)
+    (let* ((fv (vars-of t))
+	   (subst
+	     (map (lambda (old-var)
+		    (commitment old-var
+		      (logical-variable (logical-variable-id old-var))))
+	       fv)))
+      (subst-in t subst))))
+
+
+; Similar to universalize: makes nicer symbols for variables that look
+; nicer when printed. The 'reverse' in (reverse (vars-of t))
+; just makes the output look as it used to look before. Consider it
+; a historical accident.
+; (define concretize
+;   (lambda (t)
+;     (subst-in t
+;       (let loop ((fv (reverse (vars-of t))) (env '()))
+; 	(cond
+; 	  ((null? fv) empty-subst)
+; 	  (else (let ((id (logical-variable-id (car fv))))
+; 		  (let ((num (let*-and 0 ((pr (assq id env))) (+ (cdr pr) 1))))
+; 		    (cons (commitment (car fv) (artificial-id id num))
+; 		      (loop (cdr fv) (cons (cons id num) env)))))))))))
+;  (define artificial-id
+;   (lambda (t-id num)
+;     (string->symbol
+;       (string-append
+;         (symbol->string t-id) "." (number->string num)))))
+
+
+
+
+
+;-------------------------------------------------------
+;;;; This is Oleg's unifier
+
+; Either t or u may be:
+; __
+; free-var
+; bound-var
+; pair
+; other-value
+; So, we have in general 25 possibilities to consider.
+; actually, a pair or components of a pair can be variable-free
+; or not. In the latter case, we have got to traverse them.
+; Also, if a term to unify has come from subst, it has special properties,
+; which we can exploit. See below.
+;
+; "Measurements of the dynamic behavior of unification on four real
+; programs show that one or both of the arguments are variables about
+; 85% of the time [63]. A subroutine call is made only if both arguments
+; are nonvariables." (Peter Van Roy, The Wonder Years ...)
+;
+; Just like in the union-find unification algorithm, we produce
+; substitutions in the "triangular form" (see Baader, Snyder, Unification
+; Theory). Circularity is detected only at the end (when we do subst-in).
+
+(define unify
+  (lambda (t u subst)
+    (cond
+      ((eq? t u) subst)			; quick tests first
+      ((eq? t __) subst)
+      ((eq? u __) subst)
+      ((var? t)
+       (let*-and (unify-free/any t u subst) ((ct (assq t subst)))
+	 (if (var? u)			; ct is a bound var, u is a var
+	   (let*-and (unify-free/bound u ct subst) ((cu (assq u subst)))
+	     (unify-bound/bound ct cu subst))
+	   (unify-bound/nonvar ct u subst))))
+      ((var? u)				; t is not a variable...
+       (let*-and
+         (cond
+           ((pair? t) (unify-free/list u t subst))
+           ; t is not a var and is not a pair: it's atomic
+           (else (extend-subst u t subst)))
+         ((cu (assq u subst)))
+         (unify-bound/nonvar cu t subst)))
+      ((and (pair? t) (pair? u))
+       (let*-and #f ((subst (unify (car t) (car u) subst)))
+         (unify (cdr t) (cdr u) subst)))
+      (else (and (equal? t u) subst)))))
+
+; ct is a commitment to a bound variable, u is a atomic or a composite
+; value -- but not a variable
+(define unify-bound/nonvar
+  (lambda (ct u subst)
+    (let ((t (commitment->term ct)))
+      (cond				; search for the end of ct -> chain
+	((eq? t u) subst)
+	((var? t)
+	  (let*-and 
+	    (cond
+	      ((pair? u) (unify-free/list t u subst))
+              ; u is not a var and is not a pair: it's atomic
+	      (else (extend-subst t u subst)))
+	    ((ct (assq t subst)))
+	    (unify-bound/nonvar ct u subst)))
+	; t is some simple or composite value. So is u.
+      ((and (pair? t) (pair? u))
+	(let*-and #f ((subst (unify-internal/any (car t) (car u) subst)))
+	  (unify-internal/any (cdr t) (cdr u) subst)))
+      (else (and (equal? t u) subst))))))
+
+
+; Just like unify. However, the first term, t, comes from
+; an internalized term. We know it can't be __ and can't contain __
+
+(define unify-internal/any
+  (lambda (t u subst)
+    (cond
+      ((eq? t u) subst)			; quick tests first
+      ((eq? u __) subst)
+      ((var? t)
+       (let*-and (unify-free/any t u subst) ((ct (assq t subst)))
+	 (if (var? u)			; ct is a bound var, u is a var
+	   (let*-and (unify-free/bound u ct subst) ((cu (assq u subst)))
+	     (unify-bound/bound ct cu subst))
+	   (unify-bound/nonvar ct u subst))))
+      ((var? u)				; t is not a variable...
+       (let*-and			; It's a part of an internal term
+	 (extend-subst u t subst)	; no further checks needed
+         ((cu (assq u subst)))
+         (unify-internals (commitment->term cu) t subst)))
+      ((and (pair? t) (pair? u))
+       (let*-and #f ((subst (unify-internal/any (car t) (car u) subst)))
+         (unify-internal/any (cdr t) (cdr u) subst)))
+      (else (and (equal? t u) subst)))))
+
+
+; Unify two already bound variables represented by their commitments
+; ct and cu.
+; We single out this case because in the future we may wish
+; to unify the classes of these variables, by making a redundant
+; binding of (commitment->var ct) to (commitment->term cu) or
+; the other way around.
+; Aside from the above, this function can take advantage of the following
+; facts about (commitment->term cx) (where cx is an existing commitment):
+;   - it is never __
+;   - it never contains __
+; Most importantly, if, for example, (commitment->term ct) is a free variable,
+; we enter its binding to (commitment->term cu) with fewer checks.
+; in particular, we never need to call unify-free/list nor
+; unify-free/any as we do need to rebuild any terms.
+
+(define unify-internals
+  (lambda (t u subst)
+      (cond
+	((eq? t u) subst)               ; quick tests first
+	((var? t)
+         (let*-and (cond                ; t is a free variable
+                     ((var? u)
+                      (let*-and (extend-subst t u subst) ((cu (assq u subst)))
+                        (unify-free/bound t cu subst)))
+                     (else              ; t is free, u is not a var: done
+                       (extend-subst t u subst)))
+           ((ct (assq t subst)))
+           (cond			; t is a bound variable
+             ((var? u) 
+              (let*-and (unify-free/bound u ct subst) ((cu (assq u subst)))
+                (unify-bound/bound ct cu subst)))
+             (else                      ; unify bound and a value
+               (unify-internals (commitment->term ct) u subst)))))
+	((var? u)                       ; t is not a variable...
+         (let*-and (extend-subst u t subst) ((cu (assq u subst)))
+           (unify-internals (commitment->term cu) t subst)))
+        ((and (pair? t) (pair? u))
+         (let*-and #f ((subst (unify-internals (car t) (car u) subst)))
+           (unify-internals (cdr t) (cdr u) subst)))
+        (else (and (equal? t u) subst)))))
+
+(define unify-bound/bound
+  (lambda (ct cu subst)
+    (unify-internals (commitment->term ct) (commitment->term cu) subst)))
+
+
+; t-var is a free variable, u can be anything
+; This is analogous to get_variable instruction of Warren Abstract Machine
+; (WAM).
+; This function is not recursive and always succeeds, 
+; because unify-free/bound and unify-free/list always succeed.
+(define unify-free/any
+  (lambda (t-var u subst)
+    (cond
+      ((eq? u __) subst)
+      ((var? u)
+       (let*-and (extend-subst t-var u subst) ((cu (assq u subst)))
+         (unify-free/bound t-var cu subst)))
+      ((pair? u) (unify-free/list t-var u subst))
+      (else ; u is not a var and is not a pair: it's atomic
+	(extend-subst t-var u subst)))))
+
+; On entrance: t-var is free.
+; we are trying to unify it with a bound variable (commitment->var cu)
+; Chase the binding chain, see below for comments
+; This also works somewhat like union-find...
+; This function always succeeds. The resulting substitution is either
+; identical to the input one, or differs only in the binding to t-var.
+;
+; Unlike the previous version of the unifier,
+; The following code does not introduce the temp variables *a and *d
+; It makes substitutions more complex. Therefore, pruning them
+; will take a while, and will break up the sharing. Therefore, we
+; don't do any pruning.
+
+(define unify-free/bound
+  (lambda (t-var cu s)
+    (let loop ((cm cu))
+      (let ((u-term (commitment->term cm)))
+	(cond
+	  ((eq? u-term t-var) s)
+	  ((var? u-term)
+	    (cond
+	      ((assq u-term s) => loop)
+	      (else (extend-subst t-var u-term s)))) ; u-term is free here
+	  (else (extend-subst t-var u-term s)))))))
+
+; ((and (pattern-var? tree2) (assq tree2 env)) => ; tree2 is a bound var
+;        ; binding a free variable to a bound. Search for a substantial binding
+;        ; or a loop. If we find a loop tree1->tree2->...->tree1
+;        ; then we do not enter the binding to tree1, because tree1 is not
+;        ; actually constrained.
+;       (lambda (tree2-binding)
+; 	(let loop ((binding tree2-binding))
+; 	  (cond
+; 	    ((eq? tree1 (cdr binding)) env)  ; loop: no binding needed
+; 	    ((and (pattern-var? (cdr binding)) (assq (cdr binding) env))
+; 	      => loop)
+; 	    (else (cons (cons tree1 (cdr binding)) env))))))
+
+; t-var is a free variable, u-value is a proper or improper
+; list, which may be either fully or partially grounded (or not at all).
+; We scan the u-value for __, and if, found, replace them with fresh
+; variables. We then bind t-var to the term.
+; This function is not recursive and always succeeds.
+;
+; We assume that more often than not u-value does not contain __.
+; Therefore, to avoid the wasteful rebuilding of u-value, we 
+; first scan it for the occurrence of __. If the scan returns negative,
+; we can use u-value as it is.
+
+      ; Rebuild lst replacing all anonymous variables with some
+      ; fresh logical variables
+      ; If lst contains no anonymous variables, return #f
+      ; Note that lst itself may be #f -- and yet no contradiction arises.
+(define ufl-rebuild-without-anons
+  (lambda (lst)
+    (cond
+      ((eq? lst __) (logical-variable '*anon))
+      ((not (pair? lst)) #f)
+      ((null? (cdr lst))
+	(let ((new-car (ufl-rebuild-without-anons (car lst))))
+	  (and new-car (cons new-car '()))))
+      (else
+	(let ((new-car (ufl-rebuild-without-anons (car lst)))
+              (new-cdr (ufl-rebuild-without-anons (cdr lst))))
+	  (if new-car
+	    (cons new-car (or new-cdr (cdr lst)))
+	    (and new-cdr (cons (car lst) new-cdr))))))))
+
+(define unify-free/list
+  (lambda (t-var u-value subst)
+    (extend-subst t-var
+      (or (ufl-rebuild-without-anons u-value) u-value)
+      subst)))
+
+;------------------------------------------------------------------------
+; Tests
+
+(define (term-tests)
+  
+  ; (cout nl "Compositions of substitutions" nl)
+  ; (let-lv (x y)
+  ;   (test-check 'test-compose-subst-0
+  ;     (append (unit-subst x y) (unit-subst y 52))
+  ;     `(,(commitment x y) ,(commitment y 52))))
+  
+  
+  ; (test-check 'test-compose-subst-1
+  ;   (let-lv (x y)
+  ;     (equal?
+  ;       (compose-subst (unit-subst x y) (unit-subst y 52))
+  ;       `(,(commitment x 52) ,(commitment y 52))))
+  ;   #t)
+  
+  ; (test-check 'test-compose-subst-2
+  ;   (let-lv (w x y)
+  ;     (equal?
+  ;       (let ((s (compose-subst (unit-subst y w) (unit-subst w 52))))
+  ; 	(compose-subst (unit-subst x y) s))
+  ;       `(,(commitment x 52) ,(commitment y 52) ,(commitment w 52))))
+  ;   #t)
+  
+  ; (test-check 'test-compose-subst-3
+  ;   (let-lv (w x y)
+  ;     (equal?
+  ;       (let ((s (compose-subst (unit-subst w 52) (unit-subst y w))))
+  ; 	(compose-subst (unit-subst x y) s))
+  ;       `(,(commitment x w) ,(commitment w 52) ,(commitment y w))))
+  ;   #t)
+  
+  ; (test-check 'test-compose-subst-4
+  ;   (let-lv (x y z)
+  ;     (equal?
+  ;       (let ((s (compose-subst (unit-subst y z) (unit-subst x y)))
+  ; 	    (r (compose-subst
+  ; 		 (compose-subst (unit-subst x 'a) (unit-subst y 'b))
+  ; 		 (unit-subst z y))))
+  ; 	(compose-subst s r))
+  ;       `(,(commitment x 'b) ,(commitment z y))))
+  ;   #t)
+  
+  ; (test-check 'test-compose-subst-5
+  ;   (concretize-subst
+  ;     (compose-subst
+  ;       (let-lv (x) (unit-subst x 3))
+  ;       (let-lv (x) (unit-subst x 4))))
+  ;   '((x.0 . 3) (x.1 . 4)))
+  
+  
+  ; (test-check 'test-compose-subst-5
+  ;   (let-lv (x y z)
+  ;     (equal?
+  ;       (let ((term `(p ,x ,y (g ,z))))
+  ; 	(let ((s (compose-subst (unit-subst y z) (unit-subst x `(f ,y))))
+  ; 	      (r (compose-subst (unit-subst x 'a) (unit-subst z 'b))))
+  ; 	  (let ((term1 (subst-in term s)))
+  ; 	    (write term1)
+  ; 	    (newline)
+  ; 	    (let ((term2 (subst-in term1 r)))
+  ; 	      (write term2)
+  ; 	      (newline)
+  ; 	      (let ((sr (compose-subst s r)))
+  ; 		(write sr)
+  ; 		(newline)
+  ; 		(subst-in term sr))))))
+  ;       (begin
+  ; 	`(p (f ,y) ,z (g ,z))
+  ; 	`(p (f ,y) b (g b))
+  ; 	`(,(commitment y 'b) ,(commitment x `(f ,y)) ,(commitment z 'b))
+  ; 	`(p (f ,y) b (g b)))))
+  ;   #t)
+  
+  
+  (test-check 'test-unify/pairs-oleg1
+    (let-lv (x y)
+      (unify `(,x ,4) `(3 ,x) empty-subst))
+    #f)
+  
+  (test-check 'test-unify/pairs-oleg2
+    (let-lv (x y)
+      (unify `(,x ,x) '(3 4) empty-subst))
+    #f)
+  
+  (let-lv (x y)
+    (test-check 'test-unify/pairs-oleg3
+      (reify-subst '() (unify `(,x ,y) '(3 4) empty-subst))
+      '((y.0 4) (x.0 3))))
+  
+  (let-lv (x y)
+    (test-check 'test-unify/pairs-oleg4
+      (reify-subst '() (unify `(,x 4) `(3 ,y) empty-subst))
+      `((y.0 4) (x.0 3))))
+  
+  (let-lv (x y w z)
+    (test-check 'test-unify/pairs-oleg5
+      (reify-subst (list w y x)
+        (unify `(,x 4 3 ,w) `(3 ,y ,x ,z) empty-subst))
+      '((w.0 _.0) (y.0 4) (x.0 3))))
+  
+  (let-lv (x y w z)
+    (test-check 'test-unify/pairs-oleg6
+      (reify-subst (list y x)
+        (unify `(,x 4) `(,y ,y) empty-subst))
+      '((y.0 4) (x.0 4))))
+  
+  (test-check 'test-unify/pairs-oleg7
+    (let-lv (x y)
+      (unify `(,x 4 3) `(,y ,y ,x) empty-subst))
+      #f)
+  
+  (let-lv (x y w z u)
+    (test-check 'test-unify/pairs-oleg8
+      (reify-subst (list u z y x)
+        (unify
+  	`(,w (,x (,y ,z) 8))
+  	`(,w (,u (abc ,u) ,z))
+  	empty-subst))
+      '((u.0 8) (z.0 8) (y.0 abc) (x.0 8))))
+  
+  (let-lv (x y w z u)
+    (test-check 'test-unify/pairs-oleg8
+      (reify-subst (list y x)
+        (unify `(p (f a) (g ,x)) `(p ,x ,y) empty-subst))
+      '((y.0 (g (f a))) (x.0 (f a)))))
+  
+  (let-lv (x y w z u)
+    (test-check 'test-unify/pairs-oleg10
+      (reify-subst (list x y)
+        (unify `(p (g ,x) (f a)) `(p ,y ,x) empty-subst))
+      '((x.0 (f a)) (y.0 (g (f a))))))
+  
+  (let-lv (x y w z u)
+    (test-check 'test-unify/pairs-oleg11
+      (reify-subst (list y x z)
+        (unify
+  	`(p a ,x (h (g ,z)))
+  	`(p ,z (h ,y) (h ,y))
+  	empty-subst))
+      '((y.0 (g a)) (x.0 (h (g a))) (z.0 a))))
+  
+  ; The following loops...
+  ; (concretize-subst
+  ;   (let-lv (x y)
+  ;     (let* ((s (unify x `(1 ,x) '()))
+  ; 	   (s (unify y `(1 ,y) s))
+  ; 	   (s (unify x y s))) s)))
+  
+  
+  ; (let-lv (x y w z u)
+  ;   (test-check 'test-unify/pairs-oleg12
+  ;     (concretize-subst ;;; was #f
+  ;       (let ((s (unify `(p ,x ,x) `(p ,y (f ,y)) empty-subst)))
+  ; 	(let ((var (map commitment->var s)))
+  ; 	  (map commitment
+  ; 	    var
+  ; 	    (subst-vars-recursively var s)))))
+  ;     `(;,(commitment '*d.0 '())
+  ;        ,(commitment '*a.0 '(f *a.0))
+  ;        ;,(commitment '*d.1 '((f . *d.1)))
+  ;        ,(commitment '*d.0 '((f . *d.0)))
+  ;        ;,(commitment '*a.1 'f)
+  ;        ;,(commitment 'y.0  '(f (f . *d.1)))
+  ;        ,(commitment 'y.0  '(f (f . *d.0)))
+  ;        ,(commitment 'x.0  '(f (f . *d.0))))))
+  
+  ; (let-lv (x y w z u)
+  ;   (test-check 'test-unify/pairs-oleg13
+  ;     (concretize-subst ;;; was #f
+  ;       (let ((s (unify `(p ,x ,x) `(p ,y (f ,y)) empty-subst)))
+  ; 	(let ((var (map commitment->var s)))
+  ; 	  (map commitment
+  ; 	    var
+  ; 	    (subst-vars-recursively var s)))))
+  ;     `(;,(commitment '*d.0 '())
+  ;        ,(commitment '*a.0 '(f *a.0))
+  ;        ;,(commitment '*d.1 '((f . *d.1)))
+  ;        ,(commitment '*d.0 '((f . *d.0)))
+  ;        ;,(commitment '*a.1 'f)
+  ;        ;,(commitment 'y.0  '(f (f . *d.1)))
+  ;        ,(commitment 'y.0  '(f (f . *d.0)))
+  ;        ,(commitment 'x.0  '(f (f . *d.0))))))
+  
+  ;Baader & Snyder
+  (test-check 'test-pathological
+    (list
+        (let-lv (x0 x1 y0 y1)
+  	(begin
+  	  (_pretty-print
+  	    (reify-subst '()
+  	      (unify
+  		`(h ,x1 (f ,y0 ,y0) ,y1)
+  		`(h (f ,x0 ,x0) ,y1 ,x1)
+  		empty-subst)))
+  	  (newline) #t))
+  
+        (let-lv (x0 x1 x2 y0 y1 y2)
+  	(begin
+  	  (_pretty-print
+             (reify-subst '()
+              (unify
+                `(h ,x1 ,x2 (f ,y0 ,y0) (f ,y1 ,y1) ,y2)
+                `(h (f ,x0 ,x0) (f ,x1 ,x1) ,y1 ,y2 ,x2)
+                empty-subst)))
+          (newline) #t))
+  
+        (let-lv (x0 x1 x2 x3 x4 y0 y1 y2 y3 y4)
+         (begin
+          (_pretty-print
+            (reify-subst '()
+              (unify
+                `(h ,x1 ,x2 ,x3 ,x4 (f ,y0 ,y0) (f ,y1 ,y1) (f ,y2 ,y2) (f ,y3 ,y3) ,y4)
+                `(h (f ,x0 ,x0) (f ,x1 ,x1) (f ,x2 ,x2) (f ,x3 ,x3) ,y1 ,y2 ,y3 ,y4 ,x4)
+                empty-subst))) #t)))
+    (list #t #t #t))
+  
+  
+  (test-check 'length-of-subst
+    (let-lv (x y z)
+      (let* ((subst (unify x `(1 2 3 4 5 ,z) '()))
+  	    (subst (unify x `(1 . ,y) subst))
+  	    (subst (unify z 42 subst)))
+        (reify-subst '() subst)))
+    '((z.0 42) (y.0 (2 3 4 5 42)) (x.0 (1 2 3 4 5 42))))
+    ;'((z.0 . 42) (y.0 2 3 4 5 a*.0) (a*.0 . z.0) (x.0 1 2 3 4 5 a*.0)))
+
+  10
+  )
+  
+
+;; =========================================================================
+;;  kanren.scm
+;; =========================================================================
+
+;			The body of KANREN
+;
+; The appropriate prelude (e.g., chez-specific.scm) is assumed.
+;
+; $Id: kanren.ss,v 4.50 2005/02/12 00:05:05 oleg Exp $
+
+(define-syntax lambda@
+  (syntax-rules ()
+    ((_ (formal) body0 body1 ...) (lambda (formal) body0 body1 ...))
+    ((_ (formal0 formal1 formal2 ...) body0 body1 ...)
+     (lambda (formal0)
+       (lambda@ (formal1 formal2 ...) body0 body1 ...)))))
+
+(define-syntax at@
+  (syntax-rules ()
+    ((_ rator rand) (rator rand))
+    ((_ rator rand0 rand1 rand2 ...) (at@ (rator rand0) rand1 rand2 ...))))
+
+;(test-check 'test-@-lambda@
+;  (at@ (lambda@ (x y z) (+ x (+ y z))) 1 2 3)
+;  6)
+
+;'(test-check 'test-@-lambda@
+;  (at@ (lambda@ (x y z) (+ x (+ y z))) 1 2 3)
+;  42)
+
+(define Y
+  (lambda (f)
+    ((lambda (u) (u (lambda (x) (lambda (n) ((f (u x)) n)))))
+     (lambda (x) (x x)))))
+
+; An attempt to do a limited beta-substitution at macro-expand time
+; (define-syntax @    
+;   (syntax-rules (syntax-rules)
+;     ((_ (syntax-rules sdata ...) rand0 ...)
+;       (let-syntax 
+; 	((tempname (syntax-rules sdata ...)))
+; 	(tempname rand0 ...)))
+;     ((_ rator rand0 rand1 ...)
+;      (@-simple rator rand0 rand1 ...))))
+
+
+;  Fk    = () -> Ans
+;  Ans   = Nil + [Subst,Fk] or just a conceptual stream of substitutions
+;  Sk    = Subst -> Fk -> Ans  
+;  Goal  = Subst -> SGoal
+;  SGoal = Sk -> Fk -> Ans
+
+;  initial-sk : Sk
+;  initial-fk : Fk
+
+(define initial-sk (lambda@ (subst fk)
+		     (cons subst fk)))
+(define initial-fk (lambda () '()))
+
+
+; Trivial goals
+(define succeed (lambda@ (s k) (at@ k s)))  ; eta-reduced
+(define fail (lambda@ (s k f) (f)))
+(define sfail (lambda@ (k f) (f)))	; Failed SGoal
+
+
+;------------------------------------------------------------------------
+; Making logical variables "scoped" and garbage-collected
+;  -----> it was used, but no longer
+;  -----> The code is still here, as we plan to come back to this...
+;
+; A framework to remove introduced variables when they leave their scope.
+; To make removing variables easier, we consider the list of subst as a
+; "stack". Before we add a new variable, we retain a pointer to the
+; stack. Then, when we are about to remove the added variables after their
+; scope is ended, we stop at the shared retained substitution, and we know
+; that anything below the retained substitution can't possibly contain the
+; reference to the variables we're about to remove.
+;
+; Pruning of substitutions is analogous to environment pruning (aka tail-call
+; optimization) in WAM on _forward_ execution.
+
+; LV-ELIM IN-SUBST SUBST ID ....
+; remove the bindings of ID ... from SUBST (by composing with the
+; rest of subst). IN-SUBST is the mark.
+; If we locate IN-SUBST in SUBST, we know that everything below the
+; mark can't possibly contain ID ...
+
+; lv-elim-1 VAR IN-SUBST SUBST
+; VAR is a logical variable, SUBST is a substitution, and IN-SUBST
+; is a tail of SUBST (which may be '()).
+; VAR is supposed to have non-complex binding in SUBST
+; (see Definition 3 in the document "Properties of Substitutions").
+; If VAR is bound in SUBST, the corresponding commitment 
+; is supposed to occur in SUBST up to but not including IN-SUBST.
+; According to Proposition 10, if VAR freely occurs in SUBST, all such
+; terms are VAR itself.
+; The result is a substitution with the commitment to VAR removed
+; and the other commitments composed with the removed commitment.
+; The order of commitments is preserved.
+
+(define lv-elim-1
+  (lambda (var in-subst subst)
+    (if (eq? subst in-subst) subst
+      ; if VAR is not bound, there is nothing to prune
+      (let*-and subst ((var-binding (assq var subst)))
+	(let ((tv (commitment->term var-binding)))
+	  (let loop ((current subst))
+	    (cond
+	      ((null? current) current)
+	      ((eq? current in-subst) current)
+	      ((eq? (car current) var-binding)
+	       (loop (cdr current)))
+	      ((eq? (commitment->term (car current)) var)
+	       (cons (commitment (commitment->var (car current)) tv)
+		 (loop (cdr current))))
+	      (else (cons (car current) (loop (cdr current)))))))))))
+
+; The same but for multiple vars
+; To prune multiple-vars, we can prune them one-by-one
+; We can attempt to be more efficient and prune them in parallel.
+; But we encounter a problem:
+; If we have a substitution
+;  ((x . y) (y . 1) (a . x))
+; Then pruning 'x' first and 'y' second will give us ((a . 1))
+; Pruning 'y' first and 'x' second will give us ((a . 1))
+; But naively attempting to prune 'x' and 'y' in parallel
+; disregarding dependency between them results in ((a . y))
+; which is not correct.
+; We should only be concerned about a direct dependency:
+;  ((x . y) (y . (1 t)) (t . x) (a . x))
+; pruning x and y in sequence or in parallel gives the same result:
+;  ((t . (1 t)) (a . (1 t)))
+; We should also note that the unifier will never return a substitution
+; that contains a cycle ((x1 . x2) (x2 . x3) ... (xn . x1))
+
+(define lv-elim
+  (lambda (vars in-subst subst)
+    (if (eq? subst in-subst)
+      subst
+      (let ((var-bindings ; the bindings of truly bound vars
+	      (let loop ((vars vars))
+		(if (null? vars) vars
+		  (let ((binding (assq (car vars) subst)))
+		    (if binding
+		      (cons binding (loop (cdr vars)))
+		      (loop (cdr vars))))))))
+	(cond
+	  ((null? var-bindings) subst) ; none of vars are bound
+	  ((null? (cdr var-bindings))
+	    ; only one variable to prune, use the faster version
+	   (lv-elim-1 (commitment->var (car var-bindings))
+	     in-subst subst))
+	  ((let test ((vb var-bindings)) ; check multiple dependency
+	     (and (pair? vb)
+	       (or (let ((term (commitment->term (car vb))))
+		     (and (var? term) (assq term var-bindings)))
+		 (test (cdr vb)))))
+	    ; do pruning sequentially
+	   (let loop ((var-bindings var-bindings) (subst subst))
+	     (if (null? var-bindings) subst
+	       (loop (cdr var-bindings)
+		 (lv-elim-1 (commitment->var (car var-bindings))
+		   in-subst subst)))))
+	  (else				; do it in parallel
+	    (let loop ((current subst))
+	      (cond
+		((null? current) current)
+		((eq? current in-subst) current)
+		((memq (car current) var-bindings)
+		 (loop (cdr current)))
+		((assq (commitment->term (car current)) var-bindings) =>
+		 (lambda (ct)
+		   (cons (commitment (commitment->var (car current)) 
+			   (commitment->term ct))
+		     (loop (cdr current)))))
+		(else (cons (car current) (loop (cdr current))))))))))))
+
+; when the unifier is moved up, move lv-elim test from below up...
+
+; That was the code for the unifier that introduced temp variables
+; (define-syntax exists
+;   (syntax-rules ()
+;     ((_ () gl) gl)
+;     ((_ (ex-id) gl)
+;      (let-lv (ex-id)
+;        (lambda@ (sk fk in-subst)
+;          (at@ gl
+;            (lambda@ (fk out-subst)
+;              (at@ sk fk (lv-elim-1 ex-id in-subst out-subst)))
+;            fk in-subst))))
+;     ((_ (ex-id ...) gl)
+;      (let-lv (ex-id ...) 
+;        (lambda@ (sk fk in-subst)
+;          (at@ gl
+;            (lambda@ (fk out-subst)
+;              (at@ sk fk (lv-elim (list ex-id ...) in-subst out-subst)))
+;            fk in-subst))))))
+
+; For the unifier that doesn't introduce temp variables,
+; exists is essentially let-lv
+; At present, we don't do any GC.
+; Here's the reason we don't do any pruning now:
+; Let's unify the variable x with a term `(1 2 3 4 5 ,z). The result
+; will be the binding x -> `(1 2 3 4 5 ,z). Let's unify `(1 . ,y) with
+; x. The result will be a binding y -> `(2 3 4 5 ,z). Note that the
+; bindings of x and y share a tail. Let us now unify z with 42. The
+; result will be a binding z->42. So far, so good. Suppose however that
+; z now "goes out of scope" (the exists form that introduced z
+; finishes). We now have to traverse all the terms in the substitution
+; and replace z with its binding. The result will be a substitution
+; 	x -> (1 2 3 4 5 42)
+; 	y -> (2 3 4 5 42)
+; Now, the bindings of x and y do not share anything at all! The pruning
+; has broke sharing. If we want to unify x and `(1 . ,y) again, we have
+; to fully traverse the corresponding terms again.
+; So, to prune variables and preserve sharing, we have to topologically sort
+; the bindings first!
+
+(define-syntax _exists
+  (syntax-rules ()
+    ((_ () gl) gl)
+    ((_ (ex-id ...) gl)
+     (let-lv (ex-id ...) gl))
+    ))
+
+;-----------------------------------------------------------
+; Sequencing of relations
+; Goal is a multi-valued function (which takes
+;   subst, sk, fk, and exits to either sk or fk).
+; A relation is a parameterized goal.
+;
+; All sequencing operations are defined on goals.
+; They can be "lifted" to relations (see below).
+; 
+
+; TRACE-GOAL-RAW TITLE GL -> GL
+; Traces all invocations and re-invocations of a goal
+; printing subst before and after, in their raw form
+(define trace-goal-raw
+  (lambda (title gl)
+    (let ((print-it
+	    (lambda (event subst)
+	      (display title) (display " ")
+	      (display event) (_pretty-print subst) (newline))))
+      (lambda@ (subst sk fk)
+	(print-it "CALL:" subst)
+	(at@ gl subst
+	  (lambda@ (subst fk)
+	    (print-it "RETURN:" subst)
+	    (at@ sk subst
+	      (lambda ()
+		(display title) (display " REDO") (newline)
+		(fk))
+	      ))
+	  (lambda ()
+	    (display title) (display " FAIL") (newline)
+	    (fk))
+	  )))))
+
+; Conjunctions
+; All conjunctions below satisfy properties
+;    ans is an answer of (a-conjunction gl1 gl2 ...) ==>
+;       forall i. ans is an answer of gl_i
+;    (a-conjunction) ==> success
+
+
+; (all gl1 gl2 ...)
+; A regular Prolog conjunction. Non-deterministic (i.e., can have 0, 1,
+; or more answers).
+; Properties:
+;  (all gl) ==> gl
+;  (all gl1 ... gl_{n-1} gln) is a "join" of answerlists of
+;        (all gl1 ... gl_{n-1}) and gln
+
+(define-syntax all
+  (syntax-rules ()
+    ((_) succeed)
+    ((_ gl) gl)
+    ((_ gl0 gl1 ...)
+     (lambda@ (subst sk) (splice-in-gls/all subst sk gl0 gl1 ...)))))
+
+(define-syntax splice-in-gls/all
+  (syntax-rules ()
+    ((_ subst sk gl) (at@ gl subst sk))
+    ((_ subst sk gl0 gl1 ...)
+     (at@ gl0 subst (lambda (subst) (splice-in-gls/all subst sk gl1 ...))))))
+
+
+; (promise-one-answer gl)
+; Operationally, it is the identity.
+; It is an optimization directive: if the user knows that an goal
+; can produce at most one answer, he can tell the system about it.
+; The behavior is undefined if the user has lied.
+
+(define-syntax promise-one-answer
+  (syntax-rules ()
+    ((_ gl) gl)))
+
+; (all! gl1 gl2 ...)
+; A committed choice nondeterminism conjunction
+; From the Mercury documentation:
+
+;   In addition to the determinism annotations described earlier, there
+;   are "committed choice" versions of multi and nondet, called cc_multi
+;   and cc_nondet. These can be used instead of multi or nondet if all
+;   calls to that mode of the predicate (or function) occur in a context
+;   in which only one solution is needed.
+;
+; (all! gl) evaluates gl in a single-choice context. That is,
+; if gl fails, (all! gl) fails. If gl has at least one answer,
+; this answer is returned.
+; (all! gl) has at most one answer regardless of the answers of gl.
+;   ans is an answer of (all! gl) ==> ans is an answer of gl
+; The converse is not true.
+; Corollary: (all! gl) =/=> gl
+; Corollary: gl is (semi-) deterministic: (all! gl) ==> gl
+; (all! (promise-one-answer gl)) ==> gl
+;
+; By definition, (all! gl1 gl2 ...) ===> (all! (all gl1 gl2 ...))
+
+(define-syntax all!
+  (syntax-rules (promise-one-answer)
+    ((_) (promise-one-answer (all)))
+    ((_ (promise-one-answer gl)) (promise-one-answer gl)) ; keep the mark
+    ((_ gl0 gl1 ...)
+     (promise-one-answer
+       (lambda@ (subst sk fk)
+	 (at@
+	   (splice-in-gls/all subst
+	     (lambda@ (subst fk-ign) (at@ sk subst fk)) gl0 gl1 ...)
+	   fk))))))
+
+; (all!! gl1 gl2 ...)
+; Even more committed choice nondeterministic conjunction
+; It evaluates all elements of the conjunction in a single answer context
+; (all!! gl) ==> (all! gl) =/=> gl
+; (all!! gl1 gl2 ...) ==> (all (all! gl1) (all! gl2) ...)
+;                       ==> (all! (all! gl1) (all! gl2) ...)
+; (all!! gl1 ... gln (promise-one-answer gl)) ==>
+;    (all (all!! gl1 ... gln) gl)
+
+(define-syntax all!!
+  (syntax-rules ()
+    ((_) (all!))
+    ((_ gl) (all! gl))
+    ((_ gl0 gl1 ...)
+     (promise-one-answer 
+       (lambda@ (subst sk fk)
+         (splice-in-gls/all!! subst sk fk gl0 gl1 ...))))))
+
+(define-syntax splice-in-gls/all!!
+  (syntax-rules (promise-one-answer)
+    ((_ subst sk fk)
+      (at@ sk subst fk))
+    ((_ subst sk fk (promise-one-answer gl))
+      (at@ gl subst sk fk))
+    ((_ subst sk fk gl0 gl1 ...)
+      (at@ gl0 subst
+	(lambda@ (subst fk-ign) (splice-in-gls/all!! subst sk fk gl1 ...))
+	fk))))
+
+; (if-only COND THEN)
+; (if-only COND THEN ELSE)
+; Here COND, THEN, ELSE are goals.
+; If COND succeeds at least once, the result is equivalent to
+;      (all (all! COND) TNEN)
+; If COND fails, the result is the same as ELSE.
+; If ELSE is omitted, it is assumed fail. That is, (if-only COND THEN)
+; fails if the condition fails.  "This  unusual semantics
+; is part of the ISO and all de-facto Prolog standards."
+; Thus, declaratively,
+;   (if-only COND THEN ELSE) ==> (any (all (all! COND) THEN)
+;                                     (all (fails COND) ELSE))
+; Operationally, we try to generate a good code.
+
+; "The majority of predicates written by human programmers are
+; intended to give at most one solution, i.e., they are
+; deterministic. These predicates are in effect case statements
+; [sic!], yet they are too often compiled in an inefficient manner
+; using the full generality of backtracking (which implies saving the
+; machine state and repeated failure and state restoration)." (Peter
+; Van Roy, 1983-1993: The Wonder Years of Sequential Prolog
+; Implementation).
+
+
+(define-syntax if-only
+  (syntax-rules ()
+    ((_ condition then)
+     (lambda@ (subst sk fk)
+       (at@ condition subst
+         ; sk from cond
+         (lambda@ (subst fk-ign) (at@ then subst sk fk))
+         ; failure from cond
+         fk)))
+    ((_ condition then else)
+     (lambda@ (subst sk fk)
+       (at@ condition subst
+         (lambda@ (subst fk-ign) (at@ then subst sk fk))
+         (lambda () (at@ else subst sk fk))
+         )))))
+
+; (if-all! (COND1 ... CONDN) THEN)
+; (if-all! (COND1 ... CONDN) THEN ELSE)
+;
+; (if-all! (COND1 ... CONDN) THEN ELSE) ==>
+;   (if-only (all! COND1 ... CONDN) THEN ELSE)
+; (if-all! (COND1) THEN ELSE) ==>
+;   (if-only COND1 THEN ELSE)
+
+; Eventually, it might be a recognized special case in if-only.
+
+; (define-syntax if-all!
+;   (syntax-rules ()
+;     ((_ (condition) then) (if-only condition then))
+;     ((_ (condition) then else) (if-only condition then else))
+;     ((_ (condition1 condition2 ...) then)
+;      (lambda@ (sk fk)
+;        (@ (splice-in-gls/all
+;             (lambda@ (fk-ign)
+;               (@ then sk fk))
+;             condition1 condition2 ...)
+;           fk)))
+;     ((_ (condition1 condition2 ...) then else)
+;      (lambda@ (sk fk subst)
+;        (@ (splice-in-gls/all
+;             (lambda@ (fk-ign)
+;               (@ then sk fk)) condition1 condition2 ...)
+;           (lambda ()
+;             (@ else sk fk subst))
+; 	 subst)))))
+
+; Disjunction of goals
+; All disjunctions below satisfy properties
+;  ans is an answer of (a-disjunction gl1 gl2 ...) ==>
+;    exists i. ans is an answer of gl_i
+; (a-disjunction) ==> fail
+
+; Any disjunction. A regular Prolog disjunction (introduces
+; a choicepoints, in Prolog terms)
+; Note that 'any' is not a union! In particular, it is not
+; idempotent.
+; (any) ===> fail
+; (any gl) ===> gl
+; (any gl1 ... gln) ==> _concatenation_ of their answerlists
+
+(define-syntax any
+  (syntax-rules ()
+    ((_) fail)
+    ((_ gl) gl)
+    ((_ gl ...)
+      (lambda@ (subst sk fk)
+	(splice-in-gls/any subst sk fk gl ...)))))
+
+(define-syntax splice-in-gls/any
+  (syntax-rules ()
+    ((_ subst sk fk gl1) (at@ gl1 subst sk fk))
+    ((_ subst sk fk gl1 gl2 ...)
+     (at@ gl1 subst sk (lambda () (splice-in-gls/any subst sk fk gl2 ...))))))
+
+
+; Negation
+; (fails gl) succeeds iff gl has no solutions
+; (fails gl) is a semi-deterministic predicate: it can have at most
+; one solution
+; (succeeds gl) succeeds iff gl has a solution
+;
+; (fails (fails gl)) <===> (succeeds gl)
+; but (succeeds gl) =/=> gl
+; Cf. (equal? (not (not x)) x) is #f in Scheme in general.
+; Note, negation is only sound if some rules (Grounding Rules) are satisfied.
+
+(define fails
+  (lambda (gl)
+    (lambda@ (subst sk fk)
+      (at@ gl subst
+        (lambda@ (subst current-fk) (fk))
+        (lambda () (at@ sk subst fk))
+        ))))
+
+; Again, G-Rule must hold for this predicate to be logically sound
+(define succeeds
+  (lambda (gl)
+    (lambda@ (subst sk fk)
+      (at@ gl subst (lambda@ (subst-ign fk-ign) (at@ sk subst fk))
+	fk))))
+
+; partially-eval-sgl: Partially evaluate a semi-goal. A
+; semi-goal is an expression that, when applied to two
+; arguments, sk and fk, can produce zero, one, or more answers.  Any
+; goal can be turned into a semi-goal if partially applied
+; to subst.  The following higher-order semi-goal takes a
+; goal and yields the first answer and another, residual
+; goal. The latter, when evaluated, will give the rest of the
+; answers of the original semi-goal.  partially-eval-sgl could
+; be implemented with streams (lazy lists). The following is a purely
+; combinational implementation.
+;
+; (at@ partially-eval-sgl sgl a b) =>
+;   (b) if sgl has no answers
+;   (a s residial-sgl) if sgl has a answer. That answer is delivered
+;                       in s. 
+; The residial semi-goal can be passed to partially-eval-sgl
+; again, and so on, to obtain all answers from a goal one by one.
+
+; The following definition is eta-reduced.
+
+(define (partially-eval-sgl sgl)
+  (at@ sgl
+    (lambda@ (subst fk a b)
+      (at@ a subst 
+	(lambda@ (sk1 fk1)
+	  (at@
+	    (fk) 
+	    ; new a
+	    (lambda@ (sub11 x) (at@ sk1 sub11 (lambda () (at@ x sk1 fk1))))
+	    ; new b
+	    fk1))))
+    (lambda () (lambda@ (a b) (b)))))
+
+; An interleaving disjunction.
+; Declaratively, any-interleave is the same as any.
+; Operationally, any-interleave schedules each component goal
+; in round-robin. So, any-interleave is fair: it won't let a goal
+; that produces infinitely many answers (such as repeat) starve the others.
+; any-interleave introduces a breadth-first-like traversal of the
+; decision tree.
+; I seem to have seen a theorem that says that a _fair_ scheduling
+; (like that provided by any-interleave) entails a minimal or well-founded
+; semantics of a Prolog program.
+
+(define-syntax any-interleave
+  (syntax-rules ()
+    ((_) fail)
+    ((_ gl) gl)
+    ((_ gl ...)
+     (lambda@ (subst sk fk)
+       (interleave sk fk (list (gl subst) ...))))))
+
+; we treat sgls as a sort of a circular list
+(define interleave
+  (lambda (sk fk sgls)
+    (cond
+      ((null? sgls) (fk))		; all of the sgls are finished
+      ((null? (cdr sgls))
+       ; only one of sgls left -- run it through the end
+       (at@ (car sgls) sk fk))
+      (else
+        (let loop ((curr sgls) (residuals '()))
+	  ; check if the current round is finished
+	  (if (null? curr) (interleave sk fk (reverse residuals))
+	    (at@
+	      partially-eval-sgl (car curr)
+	      ; (car curr) had an answer
+	      (lambda@ (subst residual)
+	        (at@ sk subst
+	          ; re-entrance cont
+		  (lambda () (loop (cdr curr) (cons residual residuals)))))
+	    ; (car curr) is finished - drop it, and try next
+	    (lambda () (loop (cdr curr) residuals)))))))))
+
+; An interleaving disjunction removing duplicates: any-union
+; This is a true union of the constituent goals: it is fair, and
+; it removes overlap in the goals to union, if any. Therefore,
+;    (any-union gl gl) ===> gl
+; whereas (any gl gl) =/=> gl
+; because the latter has twice as many answers as gl.
+;
+; Any-union (or interleave-non-overlap, to be precise) is quite similar
+; to the function interleave above. But now, the order of goals
+; matters. Given goals gl1 gl2 ... glk ... gln,
+; at the k-th step we try to partially-eval glk. If it yields an answer,
+; we check if gl_{k+1} ... gln can be satisfied with that answer.
+; If any of them does, we disregard the current answer and ask glk for
+; another one. We maintain the invariant that
+;  ans is an answer of (any-union gl1 ... gln) 
+;  ===> exists i. ans is an answer of gl_i
+;       && forall j>i. ans is not an answer of gl_j
+; The latter property guarantees the true union.
+; Note the code below does not check if the answers of each individual
+; goal are unique. It is trivial to modify the code so that
+; any-union removes the duplicates not only among the goals but
+; also within a goal. That change entails a run-time cost. More
+; importantly, it breaks the property
+; (any-union gl gl) ===> gl
+; Only a weaker version, (any-union' gl gl) ===> (any-union' gl)
+; would hold. Therefore, we do not make that change.
+
+(define-syntax any-union
+  (syntax-rules ()
+    ((_) fail)
+    ((_ gl) gl)
+    ((_ gl ...)
+     (lambda@ (subst sk fk)
+       (interleave-non-overlap sk fk (list (cons (gl subst) gl) ...))))))
+
+; we treat sagls as a sort of a circular list
+; Each element of sagls is a pair (sgl . gl)
+; where gl is the original goal (needed for the satisfiability testing)
+; and sgl is the corresponding semi-goal or a 
+; residual thereof.
+(define interleave-non-overlap
+  (lambda (sk fk sagls)
+    (let outer ((sagls sagls))
+      (cond
+        ((null? sagls) (fk))  ; all of the sagls are finished
+        ((null? (cdr sagls))  ; only one gl is left -- run it through the end
+	 (at@ (caar sagls) sk fk))
+        (else
+	  (let loop ((curr sagls)
+                     (residuals '()))
+            ; check if the current round is finished
+	    (if (null? curr) (outer (reverse residuals))
+                (at@
+                 partially-eval-sgl (caar curr)
+                  ; (caar curr) had an answer
+                 (lambda@ (subst residual)
+                  ; let us see now if the answer, subst, satisfies any of the
+                  ; gls down the curr.
+                   (let check ((to-check (cdr curr)))
+                     (if (null? to-check) ; OK, subst is unique,give it to user
+                         (at@ sk subst
+                           ; re-entrance cont
+                           (lambda ()
+                             (loop (cdr curr) 
+                               (cons (cons residual (cdar curr)) residuals))))
+                         (at@ (cdar to-check) subst
+                            ; subst was the answer to some other gl:
+			    ; check failed
+                            (lambda@ (subst1 fk1)
+                              (loop (cdr curr) 
+                                (cons (cons residual (cdar curr)) residuals)))
+                            ; subst was not the answer: continue check
+                            (lambda () (check (cdr to-check)))))))
+                 ; (car curr) is finished - drop it, and try next
+                 (lambda () (loop (cdr curr) residuals))))))))))
+
+
+; Another if-then-else
+; (if-some COND THEN)
+; (if-some COND THEN ELSE)
+; Here COND, THEN, ELSE are goals.
+; If COND succeeds at least once, the result is equivalent to
+;      (all COND TNEN)
+; If COND fails, the result is the same as ELSE.
+; If ELSE is omitted, it is assumed fail. That is, (if-some COND THEN)
+; fails if the condition fails.  "This  unusual semantics
+; is part of the ISO and all de-facto Prolog standards."
+; Thus, declaratively,
+;   (if-some COND THEN ELSE) ==> (any (all COND THEN)
+;                                     (all (fails COND) ELSE))
+; from which follows
+;   (if-some COND THEN)              ==> (all COND THEN)
+;   (if-some COND THEN fail)         ==> (all COND THEN)
+; but
+;   (if-some COND succeed ELSE)     =/=> (any COND ELSE)
+;
+; Other corollary:
+;   (if-some COND THEN ELSE) ==> (if-only (fails COND) ELSE (all COND THEN))
+;
+; Operationally, we try to generate a good code.
+;
+; In Prolog, if-some is called a soft-cut (aka *->). In Mercury,
+; if-some is the regular IF-THEN-ELSE.
+;
+; We can implement if-some with partially-eval-sgl. Given a COND, we
+; peel off one answer, if possible. If there is one, we then execute THEN
+; passing it the answer and the fk from COND so that if THEN fails,
+; it can obtain another answer. If COND has no answers, we execute
+; ELSE. Again, we can do all that purely declaratively, without
+; talking about introducing and destroying choice points.
+
+(define-syntax if-some
+  (syntax-rules ()
+    ((_ condition then) (all condition then))
+    ((_ condition then else)
+     (lambda@ (subst sk fk)
+       (at@ partially-eval-sgl (condition subst)
+         (lambda@ (ans residual)
+           (at@ then ans sk
+             ; then failed. Check to see if condition has another answer
+             (lambda () (at@ residual (lambda@ (subst) (at@ then subst sk)) fk))))
+             ; condition failed
+         (lambda () (at@ else subst sk fk)))))))
+
+
+; An interleaving conjunction: all-interleave
+;
+; This conjunction is similar to the regular conjunction `all' but
+; delivers the answers in the breadth-first rather than depth-first
+; order.
+;
+; Motivation.
+; Let us consider the conjunction (all gl1 gl2)
+; where gl1 is (any gl11 gl12) and gl2 is an goal with the
+; infinite number of answers (in the environment when either gl11 or
+; gl12 succeed). It is easy to see (all gl1 gl2) will have the
+; infinite number of answers too -- but only the proper subset of
+; all the possible answers. Indeed, (all gl1 gl2) will essentially
+; be equivalent to (all gl11 gl2). Because gl2 succeeds infinitely
+; many times, the choice gl12 in gl1 will never be explored.
+; We can see that formally:
+; (all gl1 gl2) 
+;   = (all (any gl11 gl12) gl2) 
+;   = (any (all gl11 gl2) (all gl12 gl2))
+; Because (all gl11 gl2) can succeed infinitely many times, it starves
+; the other disjunction, (all gl12 gl2).
+; But we know how to deal with that: we just replace any with any-interleave:
+; (all gl1 gl2) --> (any-interleave (all gl11 gl2) (all gl12 gl2))
+;
+; It seems that the problem is solved? We just re-write our expressions
+; into the disjunctive normal form, and then replace the top-level
+; `any' with `any-interleave'. Alas, that means that to get the benefit
+; of fair scheduling and get all the possible solutions of the conjunction
+; (i.e., recursive enumerability), we need to re-write all the code.
+; We have to explicitly re-write a conjunction of disjunctions into
+; the disjunctive normal form. That is not that easy considering that gl2
+; will most likely be a recursive goal re-invoking the original
+; conjunction. That would be a lot of re-writing.
+;
+; The conjunction all-interleave effectively does the above `re-writing'
+; That is, given the example above,
+;	(all-interleave (any gl11 gl12) gl2)
+; is observationally equivalent to
+;	(any-interleave (all gl11 gl2) (all gl12 gl2))
+;
+; The advantage is that we do not need to re-write our conjunctions:
+; we merely replace `all' with `all-interleave.'
+; 
+; How can we do that in the general case, (all gl1 gl2)
+; where gl1 is not _explicitly_ a disjunction? We should remember the
+; property of partially-eval-sgl: Any goal `gl' with at least one
+; answer can be represented as (any gl-1 gl-rest)
+; where gl-1 is a primitive goal holding the first answer of `gl',
+; and gl-rest holding the rest of the answers. We then apply the
+; all-any-distributive law and re-write
+; (all-interleave gl1 gl2) 
+; ==> (all-interleave (any gl1-1 gl1-rest) gl2) 
+; ==> (any-interleave (all gl1 gl2) (all-interleave gl1-rest gl2))
+;
+; If gl1 has no answers, then (all-interleave gl1 gl2) fails, as
+; a conjunction must.
+; It is also easy to see that
+; (all-interleave gl1 gl2 ...) is the same as
+; (all-interleave gl1 (all-interleave gl2 ...))
+;
+; Although all-interleave was motivated by an example (all gl1 gl2)
+; where gl1 is finitary and only gl2 is infinitary, the above
+; equations (and the implementation below) show that all-interleave
+; can do the right thing even if gl1 is infinitary as well. To be
+; precise, given
+;
+;	(all-interleave gl1 gl2)
+;
+; with gl1 and gl2 infinitary, the i-th solution of gl1 will be
+; observed in every 2^i-th solution to the whole conjunction. Granted,
+; all-interleave isn't precisely very fair -- the later solutions of
+; gl1 will appear progressively more rarely -- yet, they will all
+; appear. The infinity of c0 is big enough. That is, given any
+; solution to gl1, we will eventually, in finite time, find it in the
+; solution of the whole conjunction (provided gl2 doesn't fail on
+; that solution, of course).
+
+
+
+(define-syntax all-interleave
+  (syntax-rules ()
+    ((_) (all))
+    ((_ gl) gl)
+    ((_ gl0 gl1 ...)
+      (lambda@ (subst)
+	(all-interleave-bin
+	  (gl0 subst) (all-interleave gl1 ...))))))
+
+(define all-interleave-bin
+  (lambda (sgl1 gl2)
+    (lambda@ (sk fk)
+      (at@ partially-eval-sgl sgl1
+	(lambda@ (ans residual)
+	  (interleave sk fk
+	    (list 
+	      (at@ gl2 ans)
+	      (all-interleave-bin residual gl2)
+	    )))
+	  ;gl1 failed
+	  fk))))
+
+
+; Relations...........................
+
+; The current incremented unification of argument passing is quite similar to
+; the compilation of argument unifications in WAM.
+
+; relation (VAR ...) (to-show TERM ...) [GL]
+; Defines a relation of arity (length '(TERM ...)) with an optional body
+; GL. VAR ... are logical variables that are local to the relation, i.e.,
+; appear in TERM or GL. It's better to list as VAR ... only logical
+; variables that appear in TERM. Variables that appear only in GL should
+; be introduced with exists. That makes their existential quantification
+; clearer. Variables that appear in TERM are universally quantified.
+;
+; relation (head-let TERM ...) [GL]
+; See relation-head-let below.
+;
+; relation (ANNOT-VAR ...) (to-show TERM ...) [GL]  (see remark below!)
+; where ANNOT-VAR is either a simple VAR or (once VAR)
+; where 'once' is a distingushed symbol. The latter form introduces
+; a once-var, aka linear variable. A linear variable appears only once in
+; TERM ... and only at the top level (that is, one and only one TERM
+; in the to-show pattern contains ONCE-VAR, and that term is ONCE-VAR
+; itself). In addition, ONCE-VAR must appear at most once in the body GL.
+; (Of course, then ONCE-VAR could be _, instead.)
+; If these conditions are satisfied, we can replace a logical variable
+; ONCE-VAR with a regular Scheme variable.
+
+; Alternative notation:
+; (relation (a c) (to-show term1 (once c) term2) body)
+; Makes it easier to deal with. But it is unsatisfactory:
+; to-show becomes a binding form...
+;
+; When ``compiling'' a relation, we now look through the
+; (to-show ...) pattern for a top-level occurrence of the logical variable
+; introduced by the relation. For example:
+;	(relation (x y) (to-show `(,x . ,y) x) body)
+; we notice that the logical variable 'x' occurs at the top-level. Normally we
+; compile the relation like that into the following
+;    (lambda (g1 g2)
+;      (_exists (x y)
+;        (lambda@ (subst)
+; 	 (let*-and (fail subst) ((subst (unify g1 `(,x . ,y)  subst))
+; 			         (subst (unify g2 x subst)))
+; 	     (at@ body subst)))))
+;
+; However, that we may permute the order of 'unify g...' clauses
+; to read
+;    (lambda (g1 g2)
+;      (_exists (x y)
+;        (lambda@ (subst)
+; 	 (let*-and (fail subst) ((subst (unify x g2 subst))
+; 			         (subst (unify g1 `(,x . ,y)  subst))
+; 			         )
+; 	     (at@ body subst)))))
+;
+; We may further note that according to the properties of the unifier
+; (see below), (unify x g2 subst) must always succeed, 
+; because x is a fresh variable.
+; Furthermore, the result of (unify x g2 subst) is either subst itself,
+; or subst with the binding of x. Therefore, we can check if
+; the binding at the top of (unify x g2 subst) is the binding to x. If
+; so, we can remove the binding and convert the variable x from being logical
+; to being lexical. Thus, we compile the relation as
+;
+;    (lambda (g1 g2)
+;      (_exists (x y)
+;        (lambda@ (subst)
+; 	 (let* ((subst (unify-free/any x g2 subst))
+; 	        (fast-path? (and (pair? subst)
+; 			         (eq? x (commitment->var (car subst)))))
+; 	        (x (if fast-path? (commitment->term (car subst)) x))
+; 	        (subst (if fast-path? (cdr subst) subst)))
+; 	 (let*-and sfail ((subst (unify g1 `(,x . ,y)  subst))
+; 			 )
+; 	     (at@ body subst))))))
+;
+; The benefit of that approach is that we limit the growth of subst and avoid
+; keeping commitments that had to be garbage-collected later.
+
+
+(define-syntax relation
+  (syntax-rules (to-show head-let once __)
+    ((_ (head-let head-term ...) gl)
+     (relation-head-let (head-term ...) gl))
+    ((_ (head-let head-term ...))	; not particularly useful without body
+     (relation-head-let (head-term ...)))
+    ((_ () (to-show term ...) gl)	; pattern with no vars _is_ linear
+     (relation-head-let (`,term ...) gl))
+    ((_ () (to-show term ...))		; the same without body: not too useful
+     (relation-head-let (`,term ...)))
+    ((_ (ex-id ...) (to-show term ...) gl)  ; body present
+     (relation "a" () () (ex-id ...) (term ...) gl))
+    ((_ (ex-id ...) (to-show term ...))      ; no body
+     (relation "a" () () (ex-id ...) (term ...)))
+    ; process the list of variables and handle annotations
+    ((_ "a" vars once-vars ((once id) . ids) terms . gl)
+     (relation "a" vars (id . once-vars) ids terms . gl))
+    ((_ "a" vars once-vars (id . ids) terms . gl)
+     (relation "a" (id . vars) once-vars ids terms . gl))
+    ((_ "a" vars once-vars () terms . gl)
+     (relation "g" vars once-vars () () () (subst) terms . gl))
+    ; generating temp names for each term in the head
+    ; don't generate if the term is a variable that occurs in
+    ; once-vars
+    ; For _ variables in the pattern, generate unique names for the lambda
+    ; parameters, and forget them
+    ; also, note and keep track of the first occurrence of a term
+    ; that is just a var (bare-var) 
+    ((_ "g" vars once-vars (gs ...) gunis bvars bvar-cl (__ . terms) . gl)
+     (relation "g" vars once-vars (gs ... anon) gunis
+       bvars bvar-cl terms . gl))
+    ((_ "g" vars once-vars (gs ...) gunis bvars (subst . cls)
+           (term . terms) . gl)
+     (id-memv?? term once-vars 
+       ; success continuation: term is a once-var
+       (relation "g" vars once-vars (gs ... term) gunis bvars (subst . cls)
+	 terms . gl)
+       ; failure continuation: term is not a once-var
+       (id-memv?? term vars
+	 ; term is a bare var
+	 (id-memv?? term bvars
+	   ; term is a bare var, but we have seen it already: general case
+	   (relation "g" vars once-vars  (gs ... g) ((g . term) . gunis) 
+	     bvars (subst . cls) terms . gl)
+	   ; term is a bare var, and we have not seen it
+	   (relation "g" vars once-vars (gs ... g) gunis
+	     (term . bvars)
+	     (subst
+	       (subst (unify-free/any term g subst))
+	       (fast-path? (and (pair? subst)
+			      (eq? term (commitment->var (car subst)))))
+	       (term (if fast-path? (commitment->term (car subst)) term))
+	       (subst (if fast-path? (cdr subst) subst))
+	       . cls)
+	     terms . gl))
+	 ; term is not a bare var
+	 (relation "g" vars once-vars  (gs ... g) ((g . term) . gunis) 
+	   bvars (subst . cls) terms . gl))))
+    ((_ "g" vars once-vars gs gunis bvars bvar-cl () . gl)
+     (relation "f" vars once-vars gs gunis bvar-cl . gl))
+
+    ; Final: writing the code
+    ((_ "f" vars () () () (subst) gl)   ; no arguments (no head-tests)
+      (lambda ()
+	(_exists vars gl)))
+                                    ; no tests but pure binding
+    ((_ "f" (ex-id ...) once-vars (g ...) () (subst) gl)
+     (lambda (g ...)
+       (_exists (ex-id ...) gl)))
+				    ; the most general
+    ((_ "f" (ex-id ...) once-vars (g ...) ((gv . term) ...) 
+       (subst let*-clause ...) gl) 
+     (lambda (g ...)
+       (_exists (ex-id ...)
+	 (lambda (subst)
+	   (let* (let*-clause ...)
+	     (let*-and sfail ((subst (unify gv term subst)) ...)
+	       (at@ gl subst)))))))))
+
+; A macro-expand-time memv function for identifiers
+;	id-memv?? FORM (ID ...) KT KF
+; FORM is an arbitrary form or datum, ID is an identifier.
+; The macro expands into KT if FORM is an identifier that occurs
+; in the list of identifiers supplied by the second argument.
+; Otherwise, id-memv?? expands to KF.
+; All the identifiers in (ID ...) must be unique.
+; Two identifiers match if both refer to the same binding occurrence, or
+; (both are undefined and have the same spelling).
+
+(define-syntax id-memv??
+  (syntax-rules ()
+    ((id-memv?? form (id ...) kt kf)
+      (let-syntax
+	((test
+	   (syntax-rules (id ...)
+	     ((test id _kt _kf) _kt) ...
+	     ((test otherwise _kt _kf) _kf))))
+	(test form kt kf)))))
+
+; Test cases
+; (id-memv?? x (a b c) #t #f)
+; (id-memv?? a (a b c) 'OK #f)
+; (id-memv?? () (a b c) #t #f)
+; (id-memv?? (x ...) (a b c) #t #f)
+; (id-memv?? "abc" (a b c) #t #f)
+; (id-memv?? x () #t #f)
+; (let ((x 1))
+;   (id-memv?? x (a b x) 'OK #f))
+; (let ((x 1))
+;   (id-memv?? x (a x b) 'OK #f))
+; (let ((x 1))
+;   (id-memv?? x (x a b) 'OK #f))
+
+
+; relation-head-let (head-term ...) gl 
+; A simpler, and more efficient kind of relation. The simplicity comes
+; from a simpler pattern at the head of the relation. The pattern must
+; be linear and shallow with respect to introduced variables.  The gl
+; is optional (although omitting it doesn't make much sense in
+; practice) There are two kinds of head-terms.  One kind is an
+; identifier. This identifier is taken to be a logical identifier, to
+; be unified with the corresponding actual argument.  Each logical
+; identifier must occur exactly once.  Another kind of a head-terms is
+; anything else. That anything else may be a constant, a scheme
+; variable, or a complex term that may even include logical variables
+; such as _ -- but not logical variables defined in the same head-let
+; pattern.  To make the task of distinguishing logical identifiers
+; from anything else easier, we require that anything else of a sort
+; of a manifest constant be explicitly quoted or quasiquoted. It would
+; be OK to add `, to each 'anything else' term.
+;
+; Examples:
+; (relation-head-let (x y z) (foo x y z))
+; Here x y and z are logical variables.
+; (relation-head-let (x y '7) (foo x y))
+; Here we used a manifest constant that must be quoted
+; (relation-head-let (x y `(1 2 . ,_)) (foo x y))
+; We used a quasi-quoted constant with an anonymous variable.
+; (let ((z `(1 2 . ,_))) (relation-head-let (x y `,z) (foo x y))
+; The same as above, but using a lexical Scheme variable.
+; The binding procedure is justified by Proposition 9 of
+; the Properties of Substitutions.
+;
+; 'head-let' is an example of "compile-time" simplifications. 
+; For example, we distinguish constants in the term head at
+; "compile time" and so we re-arrange the argument-passing
+; unifications to handle the constants first.
+; The test for the anonymous variable (eq? gvv0 _) below
+; is an example of a global simplification with a run-time
+; test. A compiler could have inferred the result of the test -- but only
+; upon the global analysis of all the clauses.
+; Replacing a logical variable with an ordinary variable, which does 
+; not have to be pruned, is equivalent to the use of temporary and
+; unsafe variables in WAM.
+
+(define-syntax relation-head-let
+  (syntax-rules ()
+    ((_ (head-term ...) . gls)
+     (relation-head-let "g" () (head-term ...) (head-term ...) . gls))
+    ; generate names of formal parameters
+    ((_ "g" (genvar ...) ((head-term . tail-term) . ht-rest)
+       head-terms . gls)
+     (relation-head-let "g" (genvar ... g) ht-rest head-terms . gls))
+    ((_ "g" (genvar ...) (head-term . ht-rest) head-terms . gls)
+     (relation-head-let "g" (genvar ... head-term) ht-rest head-terms . gls))
+    ((_ "g" genvars  () head-terms . gls)
+     (relation-head-let "d" () () genvars head-terms genvars . gls))
+    ; partition head-terms into vars and others
+    ((_ "d" vars others (gv . gv-rest) ((hth . htt) . ht-rest) gvs . gls)
+     (relation-head-let "d" vars ((gv (hth . htt)) . others)
+       gv-rest ht-rest gvs . gls))
+    ((_ "d" vars others (gv . gv-rest) (htv . ht-rest) gvs . gls)
+     (relation-head-let "d" (htv . vars) others
+       gv-rest ht-rest gvs . gls))
+    ((_ "d" vars others () () gvs . gls)
+     (relation-head-let "f" vars others gvs . gls))
+ 
+    ; final generation
+    ((_ "f" vars ((gv term) ...) gvs) ; no body
+     (lambda gvs                                     ; don't bother bind vars
+       (lambda@ (subst)
+	 (let*-and sfail ((subst (unify gv term subst)) ...)
+	   (at@ succeed subst)))))
+
+    ((_ "f" (var0 ...) ((gvo term) ...) gvs gl)
+     (lambda gvs
+       (lambda@ (subst)			; first unify the constants
+	 (let*-and sfail ((subst (unify gvo term subst)) ...)
+           (let ((var0 (if (eq? var0 __) (logical-variable '?) var0)) ...)
+             (at@ gl subst))))))))
+
+; (define-syntax relation/cut
+;   (syntax-rules (to-show)
+;     ((_ cut-id (ex-id ...) (to-show x ...) gl ...)
+;      (relation/cut cut-id (ex-id ...) () (x ...) (x ...) gl ...))
+;     ((_ cut-id ex-ids (var ...) (x0 x1 ...) xs gl ...)
+;      (relation/cut cut-id ex-ids (var ... g) (x1 ...) xs gl ...))
+;     ((_ cut-id (ex-id ...) (g ...) () (x ...) gl ...)
+;      (lambda (g ...)
+;        (_exists (ex-id ...)
+;          (all! (== g x) ...
+;            (lambda@ (sk fk subst cutk)
+;              (let ((cut-id (!! cutk)))
+;                (at@ (all gl ...) sk fk subst cutk)))))))))
+
+(define-syntax fact
+  (syntax-rules ()
+    ((_ (ex-id ...) term ...)
+     (relation (ex-id ...) (to-show term ...) succeed))))
+
+; Lifting from goals to relations
+; (define-rel-lifted-comb rel-syntax gl-proc-or-syntax)
+; Given (gl-proc-or-syntax gl ...)
+; define 
+; (rel-syntax (id ...) rel-exp ...)
+; We should make rel-syntax behave as a CBV function, that is,
+; evaluate rel-exp early.
+; Otherwise, things like
+; (define father (extend-relation father ...))
+; loop.
+
+; (define-syntax extend-relation
+;   (syntax-rules ()
+;     ((_ (id ...) rel-exp ...)
+;      (extend-relation-aux (id ...) () rel-exp ...))))
+
+; (define-syntax extend-relation-aux
+;   (syntax-rules ()
+;     ((_ (id ...) ((g rel-exp) ...))
+;      (let ((g rel-exp) ...)
+;        (lambda (id ...)
+;          (any (g id ...) ...))))
+;     ((_ (id ...) (let-pair ...) rel-exp0 rel-exp1 ...)
+;      (extend-relation-aux (id ...)
+;        (let-pair ... (g rel-exp0)) rel-exp1 ...))))
+
+(define-syntax define-rel-lifted-comb
+  (syntax-rules ()
+    ((_ rel-syntax-name gl-proc-or-syntax)
+     (define-syntax rel-syntax-name
+       (syntax-rules ()
+         ((_ ids . rel-exps)
+          (lift-gl-to-rel-aux gl-proc-or-syntax ids () . rel-exps)))))))
+
+(define-syntax lift-gl-to-rel-aux
+  (syntax-rules ()
+    ((_ gl-handler ids ((g rel-var) ...))
+     (let ((g rel-var) ...)
+       (lambda ids
+         (gl-handler (g . ids) ...))))
+    ((_ gl-handler ids (let-pair ...) rel-exp0 rel-exp1 ...)
+     (lift-gl-to-rel-aux gl-handler ids 
+       (let-pair ... (g rel-exp0)) rel-exp1 ...))))
+
+(define-rel-lifted-comb extend-relation any)
+
+; The following  goal-to-relations 
+; transformers are roughly equivalent. I don't know which is better.
+; see examples below.
+
+; (lift-to-relations ids (gl-comb rel rel ...))
+(define-syntax lift-to-relations
+  (syntax-rules ()
+    ((_ ids (gl-comb rel ...))
+     (lift-gl-to-rel-aux gl-comb ids () rel ...))))
+
+; (let-gls ids ((name rel) ...) body)
+; NB: some macro systems do not like if 'ids' below is replaced by (id ...)
+(define-syntax let-gls
+  (syntax-rules ()
+    ((_ ids ((gl-name rel-exp) ...) body)
+     (lambda ids
+       (let ((gl-name (rel-exp . ids)) ...)
+         body)))))
+
+; Unify lifted to be a binary relation
+(define-syntax ==
+  (syntax-rules (__)
+    ((_ __ u) (lambda@ (subst sk) (at@ sk subst)))
+    ((_ t __) (lambda@ (subst sk) (at@ sk subst)))
+    ((_ t u)
+     (lambda@ (subst)
+       (let*-and sfail ((subst (unify t u subst)))
+         (succeed subst))))))
+
+
+;	query (redo-k subst id ...) A SE ... -> result or '()
+; The macro 'query' runs the goal A in the empty
+; initial substitution, and reifies the resulting
+; answer: the substitution and the redo-continuation bound
+; to fresh variables with the names supplied by the user.
+; The substitution and the redo continuation can then be used
+; by Scheme expressions SE ...
+; Before running the goal, the macro creates logical variables
+; id ... for use in A and SE ...
+; If the goal fails, '() is returned and SE ... are not evaluated.
+; Note the similarity with shift/reset-based programming
+; where the immediate return signifies "failure" and the invocation
+; of the continuation a "success"
+; Returning '() on failure makes it easy to create the list of answers
+
+(define-syntax query
+  (syntax-rules ()
+    ((_ (redo-k subst id ...) A SE ...)
+      (let-lv (id ...)
+	(at@ A empty-subst
+	  (lambda@ (subst redo-k) SE ...)
+	  (lambda () '()))))))
+
+(define stream-prefix
+  (lambda (n strm)
+    (if (null? strm) '()
+      (cons (car strm)
+        (if (zero? n) '()
+          (stream-prefix (- n 1) ((cdr strm))))))))
+
+(define-syntax solve
+  (syntax-rules ()
+    ((_ n (var0 ...) gl)
+      (if (<= n 0) '()
+	(stream-prefix (- n 1)
+	  (query (redo-k subst var0 ...)
+	    gl
+	    (cons (reify-subst (list var0 ...) subst) redo-k)))))))
+
+
+(define-syntax solution
+  (syntax-rules ()
+    ((_ (var0 ...) x)
+     (let ((ls (solve 1 (var0 ...) x)))
+       (if (null? ls) #f (car ls))))))
+
+
+(define-syntax project
+  (syntax-rules ()
+    ((_ (var ...) gl)
+     (lambda@ (subst)
+       (let ((var (nonvar! (subst-in var subst))) ...)
+	 (at@ gl subst))))))
+
+(define-syntax project/no-check
+  (syntax-rules ()
+    ((_ (var ...) gl)
+     (lambda@ (subst)
+       (let ((var (subst-in var subst)) ...)
+	 (at@ gl subst))))))
+
+(define-syntax predicate
+  (syntax-rules ()
+    ((_ scheme-expression)
+     (lambda@ (subst)
+       (if scheme-expression (succeed subst) (fail subst))))))
+
+(define nonvar!
+  (lambda (t)
+    (if (var? t)
+      (errorf 'nonvar! "Logic variable ~s found after substituting."
+	(reify t))
+      t)))
+
+; TRACE-VARS TITLE (VAR ...)
+; Is a deterministic goal that prints the current values of VARS
+; TITLE is any displayable thing.
+
+; (define-syntax trace-vars
+;   (syntax-rules ()
+;     ((trace-vars title (var0 ...))
+;      (promise-one-answer
+;        (predicate/no-check (var0 ...)
+;          (begin (display title) (display " ")
+;                 (display '(var0 ...)) (display " ") (display (list var0 ...))
+;                 (newline)))))))
+
+(define-syntax trace-vars
+  (syntax-rules ()
+    ((_ title (var0 ...))
+     (promise-one-answer
+       (project/no-check (var0 ...)
+         (predicate
+	   (for-each 
+	     (lambda (name val)
+	       (cout title " " name ": " val nl))
+             '(var0 ...) (reify `(,var0 ...)))
+	   ))))))
+
+;equality predicate: X == Y in Prolog
+;if X is a var, then X == Y holds only if Y
+;is the same var
+(define *equal?
+  (lambda (x y)
+    (cond
+      ((and (var? x) (var? y)) (eq? x y))
+      ((var? x) #f)                     ; y is not a var
+      ((var? y) #f)                     ; x is not a var
+      (else (equal? x y)))))
+
+; extend-relation-with-recur-limit LIMIT VARS RELS -> REL
+; This is a variation of 'extend-relation' that makes sure
+; that the extended relation is not recursively entered more
+; than LIMIT times. The form extend-relation-with-recur-limit
+; can be used to cut a left-recursive relation, and to implement
+; an iterative deepening strategy.
+; extend-relation-with-recur-limit must be a special form
+; because we need to define the depth-counter-var
+; outside of relations' lambda (so we count the recursive invocations
+; for all arguments).
+(define-syntax extend-relation-with-recur-limit
+  (syntax-rules ()
+    ((_ limit ids rel ...)
+      (let ((depth-counter-var (logical-variable '*depth-counter*)))
+	(lambda ids
+	  (let ((gl (any (rel . ids) ...)))
+	    (lambda@ (subst)
+	      (cond
+		((assq depth-counter-var subst)
+		  => (lambda (cmt)
+		       (let ((counter (commitment->term cmt)))
+			 (if (>= counter limit)
+			   sfail
+			   (let ((s (extend-subst depth-counter-var
+				      (+ counter 1) subst)))
+			     (at@ gl s))))))
+		(else
+		  (let ((s (extend-subst depth-counter-var 1 subst)))
+		    (at@ gl s)))))))))
+    ))
+
+; ?- help(call_with_depth_limit/3).
+; call_with_depth_limit(+Goal, +Limit, -Result)
+;     If  Goal can be proven  without recursion deeper than Limit  levels,
+;     call_with_depth_limit/3 succeeds,  binding  Result  to  the  deepest
+;     recursion  level  used  during the  proof.    Otherwise,  Result  is
+;     unified  with depth_limit_exceeded  if the limit was exceeded  during
+;     the  proof,  or the  entire predicate  fails if  Goal fails  without
+;     exceeding Limit.
+
+;     The  depth-limit is  guarded by the  internal machinery.   This  may
+;     differ  from the depth computed based  on a theoretical model.   For
+;     example,  true/0  is  translated  into an  inlined  virtual  machine
+;     instruction.   Also, repeat/0 is not implemented as below, but  as a
+;     non-deterministic foreign predicate.
+
+;     repeat.
+;     repeat :-
+;             repeat.
+
+;     As  a  result, call_with_depth_limit/3 may  still loop  inifitly  on
+;     programs  that should  theoretically finish  in finite time.    This
+;     problem  can be cured by  using Prolog equivalents to such  built-in
+;     predicates.
+
+;     This   predicate  may  be   used  for  theorem-provers  to   realise
+;     techniques  like iterrative  deepening.   It  was implemented  after
+;     discussion with Steve Moyle smoyle@ermine.ox.ac.uk.
+
+;------------------------------------------------------------------------
+;;;;; Starts the real work of the system.
+
+(define-rel-lifted-comb intersect-relation all)
+  
+(define (kanren-tests)
+  (let* ((father  
+  	(relation ()
+  	  (to-show 'jon 'sam)))
+        (child-of-male
+  	(relation (child dad)
+  	  (to-show child dad)
+  	  (father dad child)))
+         (child-of-male1
+  	 (relation (child dad)
+  	   (to-show child dad)
+  	   (child-of-male dad child)))
+         )
+    (test-check 'test-father0
+      (let ((result
+  	    (at@ (father 'jon 'sam) empty-subst
+  	      initial-sk initial-fk)))
+        (and
+  	(equal? (car result) '())
+  	(equal? ((cdr result)) '())))
+      #t)
+  
+    (test-check 'test-child-of-male-0
+      (reify-subst '()
+        (car (at@ (child-of-male 'sam 'jon) empty-subst
+  	     initial-sk initial-fk)))
+    ;`(,(commitment 'child.0 'sam) ,(commitment 'dad.0 'jon)))
+    '())  ; variables shouldn't leak
+  
+  
+    ; The mark should be found here...
+    (test-check 'test-child-of-male-1
+    (reify-subst '()
+      (car (at@ (child-of-male 'sam 'jon) empty-subst
+  	    initial-sk initial-fk)))
+    ;`(,(commitment 'child.0 'sam) ,(commitment 'dad.0 'jon)))
+    '())
+  )
+  
+  (let* ((father  
+  	(relation ()
+  	  (to-show 'jon 'sam)))
+         (rob/sal
+  	 (relation ()
+  	   (to-show 'rob 'sal)))
+         (new-father
+  	 (extend-relation (a1 a2) father rob/sal))
+  	(rob/pat
+  	  (relation ()
+  	    (to-show 'rob 'pat)))
+  	(newer-father
+  	  (extend-relation (a1 a2) new-father rob/pat))
+  
+  	)
+    (test-check 'test-father-1
+      (let ((result
+  	    (at@ (new-father 'rob 'sal) empty-subst
+  	      initial-sk initial-fk)))
+        (and
+  	(equal? (car result) '())
+  	(equal? ((cdr result)) '())))
+      #t)
+  
+    (test-check 'test-father-2
+      (query (redo-k subst x)
+        (new-father 'rob x)
+        (list (equal? (car subst) (commitment x 'sal)) (redo-k)))
+      '(#t ()))
+  
+    (test-check 'test-father-3
+      (query (_ subst x)
+        (new-father 'rob x)
+        (reify-subst (list x) subst))
+      '((x.0 sal)))
+  
+    (test-check 'test-father-4
+      (query (_ subst x y)
+        (new-father x y)
+        (reify-subst (list x y) subst))
+      '((x.0 jon) (y.0 sam)))
+  
+    (test-check 'test-father-5
+      (query (redok subst x)
+        (newer-father 'rob x)
+        (_pretty-print subst)
+        (cons
+  	(reify-subst (list x) subst)
+  	(redok)))
+      '(((x.0 sal)) ((x.0 pat))))
+  
+  )
+  
+  (let* ((father  
+  	 (extend-relation (a1 a2)
+  	   (relation () (to-show 'jon 'sam))
+  	   (relation () (to-show 'rob 'sal))
+  	   (relation () (to-show 'rob 'pat))
+  	   (relation () (to-show 'sam 'rob)))
+  	 ))
+  
+    (test-check 'test-father-6/solve
+      (and
+        (equal?
+  	(solve 5 (x) (father 'rob x))
+  	'(((x.0 sal)) ((x.0 pat))))
+        (equal?
+  	(solve 6 (x y) (father x y))
+  	'(((x.0 jon) (y.0 sam))
+  	   ((x.0 rob) (y.0 sal))
+  	   ((x.0 rob) (y.0 pat))
+  	   ((x.0 sam) (y.0 rob)))))
+    #t)
+  
+    (test-check 'test-father-7/solution
+      (solution (x) (father 'rob x))
+      '((x.0 sal)))
+  )
+  
+  
+  
+  ; (define-syntax intersect-relation
+  ;   (syntax-rules ()
+  ;     ((_ (id ...) rel-exp) rel-exp)
+  ;     ((_ (id ...) rel-exp0 rel-exp1 rel-exp2 ...)
+  ;      (binary-intersect-relation (id ...) rel-exp0
+  ;        (intersect-relation (id ...) rel-exp1 rel-exp2 ...)))))
+  
+  (let*
+    ((parents-of-scouts
+       (extend-relation (a1 a2)
+         (fact () 'sam 'rob)
+         (fact () 'roz 'sue)
+         (fact () 'rob 'sal)))
+      (parents-of-athletes
+        (extend-relation (a1 a2)
+  	(fact () 'sam 'roz)
+  	(fact () 'roz 'sue)
+  	(fact () 'rob 'sal)))
+  
+      (busy-parents
+        (intersect-relation (a1 a2) parents-of-scouts parents-of-athletes))
+  
+      (conscientious-parents
+        (extend-relation (a1 a2) parents-of-scouts parents-of-athletes))
+      )
+  
+    (test-check 'test-conscientious-parents
+      (solve 7 (x y) (conscientious-parents x y))
+      '(((x.0 sam) (y.0 rob))
+         ((x.0 roz) (y.0 sue))
+         ((x.0 rob) (y.0 sal))
+         ((x.0 sam) (y.0 roz))
+         ((x.0 roz) (y.0 sue))
+         ((x.0 rob) (y.0 sal))))
+  )
+  
+  (let* ((father  
+  	 (extend-relation (a1 a2)
+  	   (relation () (to-show 'jon 'sam))
+  	   (relation () (to-show 'rob 'sal))
+  	   (relation () (to-show 'rob 'pat))
+  	   (relation () (to-show 'sam 'rob)))
+  	 ))
+  
+    (let
+      ((grandpa-sam
+         (relation (grandchild)
+  	 (to-show grandchild)
+  	 (_exists (parent)
+  	   (all (father 'sam parent)
+  	        (father parent grandchild))))))
+      (test-check 'test-grandpa-sam-1
+        (solve 6 (y) (grandpa-sam y))
+        '(((y.0 sal)) ((y.0 pat))))
+     )
+  
+    (let
+      ((grandpa-sam
+         (relation ((once grandchild))
+  	 (to-show grandchild)
+  	 (_exists (parent)
+  	   (all (father 'sam parent)
+  	        (father parent grandchild))))))
+      (test-check 'test-grandpa-sam-1
+        (solve 6 (y) (grandpa-sam y))
+        '(((y.0 sal)) ((y.0 pat))))
+      )
+  
+    (let ((child
+  	  (relation ((once child) (once dad))
+  	    (to-show child dad)
+  	    (father dad child))))
+      (test-check 'test-child-1
+        (solve 10 (x y) (child x y))
+        '(((x.0 sam) (y.0 jon))
+  	 ((x.0 sal) (y.0 rob))
+  	 ((x.0 pat) (y.0 rob))
+  	 ((x.0 rob) (y.0 sam))))
+      )
+  
+    (let ((grandpa
+  	  (relation ((once grandad) (once grandchild))
+  	    (to-show grandad grandchild)
+  	    (_exists (parent)
+  	      (all
+  		(father grandad parent)
+  		(father parent grandchild))))))
+      (test-check 'test-grandpa-1
+        (solve 4 (x) (grandpa 'sam x))
+        '(((x.0 sal)) ((x.0 pat)))))
+  
+    (let ((grandpa-maker
+  	  (lambda (guide* grandad*)
+  	    (relation (grandchild)
+  	      (to-show grandchild)
+  	      (_exists (parent)
+  		(all
+  		  (guide* grandad* parent)
+  		  (guide* parent grandchild)))))))
+      (test-check 'test-grandpa-maker-2
+        (solve 4 (x) ((grandpa-maker father 'sam) x))
+        '(((x.0 sal)) ((x.0 pat)))))
+    
+  )
+  
+  (let*
+    ((father
+       (extend-relation (a1 a2)
+         (fact () 'jon 'sam)
+         (extend-relation (a1 a2)
+  	 (fact () 'sam 'rob)
+  	 (extend-relation (a1 a2)
+  	   (fact () 'sam 'roz)
+  	   (extend-relation (a1 a2)
+  	     (fact () 'rob 'sal)
+  	     (fact () 'rob 'pat))))))
+      (mother
+        (extend-relation (a1 a2)
+  	(fact () 'roz 'sue)
+  	(fact () 'roz 'sid)))
+      )
+  
+    (let*
+      ((grandpa/father
+         (relation (grandad grandchild)
+  	 (to-show grandad grandchild)
+  	 (_exists (parent)
+  	   (all
+  	     (father grandad parent)
+  	     (father parent grandchild)))))
+       (grandpa/mother
+         (relation (grandad grandchild)
+  	 (to-show grandad grandchild)
+  	 (_exists (parent)
+  	   (all
+  	     (father grandad parent)
+  	     (mother parent grandchild)))))
+       (grandpa
+         (extend-relation (a1 a2) grandpa/father grandpa/mother)))
+  
+      (test-check 'test-grandpa-5
+        (solve 10 (y) (grandpa 'sam y))
+        '(((y.0 sal)) ((y.0 pat)) ((y.0 sue)) ((y.0 sid))))
+      )
+  
+    ; A relation is just a function
+    (let
+      ((grandpa-sam
+         (let ((r (relation (child)
+  		  (to-show child)
+  		  (_exists (parent)
+  		    (all
+  		      (father 'sam parent)
+  		      (father parent child))))))
+  	 (relation (child)
+  	   (to-show child)
+  	   (r child)))))
+  
+      (test-check 'test-grandpa-55
+        (solve 6 (y) (grandpa-sam y))
+        '(((y.0 sal)) ((y.0 pat))))
+      )
+  
+  ; The solution that used cuts
+  ; (define grandpa/father
+  ;   (relation/cut cut (grandad grandchild)
+  ;     (to-show grandad grandchild)
+  ;     (_exists (parent)
+  ;       (all
+  ;         (father grandad parent)
+  ;         (father parent grandchild)
+  ;         cut))))
+  ;
+  ; (define grandpa/mother
+  ;   (relation (grandad grandchild)
+  ;     (to-show grandad grandchild)
+  ;     (_exists (parent)
+  ;       (all
+  ;         (father grandad parent)
+  ;         (mother parent grandchild)))))
+  
+  
+  ; Now we don't need it
+    (let*
+      ((grandpa/father
+         (relation (grandad grandchild)
+  	 (to-show grandad grandchild)
+  	 (_exists (parent)
+  	   (all!
+  	     (father grandad parent)
+  	     (father parent grandchild)))))
+  
+        (grandpa/mother
+  	(relation (grandad grandchild)
+  	  (to-show grandad grandchild)
+  	  (_exists (parent)
+  	    (all
+  	      (father grandad parent)
+  	      (mother parent grandchild)))))
+  
+        (grandpa
+  	(lift-to-relations (a1 a2)
+  	  (all!
+  	    (extend-relation (a1 a2) grandpa/father grandpa/mother))))
+        )
+      (test-check 'test-grandpa-8
+        (solve 10 (x y) (grandpa x y))
+        '(((x.0 jon) (y.0 rob))))
+      )
+    
+  ; The solution that used to require cuts
+  ; (define grandpa/father
+  ;   (relation/cut cut (grandad grandchild)
+  ;     (to-show grandad grandchild)
+  ;     (_exists (parent)
+  ;       (all cut (father grandad parent) (father parent grandchild)))))
+  
+    (let
+      ((grandpa/father
+         (relation (grandad grandchild)
+  	 (to-show grandad grandchild)
+  	 (_exists (parent)
+  	   (all
+  	     (father grandad parent) (father parent grandchild)))))
+  
+        (grandpa/mother
+  	(relation (grandad grandchild)
+  	  (to-show grandad grandchild)
+  	  (_exists (parent)
+  	    (all
+  	      (father grandad parent) (mother parent grandchild)))))
+        )
+  
+  ; Properly, this requires soft cuts, aka *->, or Mercury's
+  ; if-then-else. But we emulate it...
+      (let
+        ((grandpa
+  	 (let-gls (a1 a2) ((grandpa/father grandpa/father)
+  			   (grandpa/mother grandpa/mother))
+  	   (if-only (succeeds grandpa/father) grandpa/father grandpa/mother)))
+  	)
+        (test-check 'test-grandpa-10
+  	(solve 10 (x y) (grandpa x y))
+  	'(((x.0 jon) (y.0 rob))
+  	   ((x.0 jon) (y.0 roz))
+  	   ((x.0 sam) (y.0 sal))
+  	   ((x.0 sam) (y.0 pat))))
+        (test-check 'test-grandpa-10-1
+  	(solve 10 (x) (grandpa x 'sue))
+  	'(((x.0 sam))))
+        )
+  
+  ; The same as above, with if-all! -- just to test the latter.
+      (let
+        ((grandpa
+  	 (let-gls (a1 a2) ((grandpa/father grandpa/father)
+  			    (grandpa/mother grandpa/mother))
+  	   (if-only (all! (succeeds grandpa/father) (succeeds grandpa/father))
+  	     grandpa/father grandpa/mother))))
+  
+        (test-check 'test-grandpa-10
+  	(solve 10 (x y) (grandpa x y))
+  	'(((x.0 jon) (y.0 rob))
+  	   ((x.0 jon) (y.0 roz))
+  	   ((x.0 sam) (y.0 sal))
+  	   ((x.0 sam) (y.0 pat))))
+  
+        (test-check 'test-grandpa-10-1
+  	(solve 10 (x) (grandpa x 'sue))
+  	'(((x.0 sam))))
+        )
+  
+  
+  ; Now do it with soft-cuts
+      (let
+        ((grandpa
+  	 (let-gls (a1 a2) ((grandpa/father grandpa/father)
+  			    (grandpa/mother grandpa/mother))
+  	   (if-some grandpa/father succeed grandpa/mother)))
+  	)
+        (test-check 'test-grandpa-10-soft-cut
+  	(solve 10 (x y) (grandpa x y))
+  	'(((x.0 jon) (y.0 rob))
+  	   ((x.0 jon) (y.0 roz))
+  	   ((x.0 sam) (y.0 sal))
+  	   ((x.0 sam) (y.0 pat))))
+        )
+  
+      (let*
+        ((a-grandma
+  	 (relation (grandad grandchild)
+  	   (to-show grandad grandchild)
+  	   (_exists (parent)
+  	     (all! (mother grandad parent)))))
+  	(no-grandma-grandpa
+  	  (let-gls (a1 a2) ((a-grandma a-grandma)
+  			     (grandpa (lift-to-relations (a1 a2)
+  					(all!
+  					  (extend-relation (a1 a2) 
+  					    grandpa/father grandpa/mother)))))
+  	    (if-only a-grandma fail grandpa)))
+  	)
+        (test-check 'test-no-grandma-grandpa-1
+  	(solve 10 (x) (no-grandma-grandpa 'roz x))
+  	'()))
+  ))
+  
+  (let
+    ((parents-of-scouts
+       (extend-relation (a1 a2)
+         (fact () 'sam 'rob)
+         (fact () 'roz 'sue)
+         (fact () 'rob 'sal)))
+      (fathers-of-cubscouts
+        (extend-relation (a1 a2)
+  	(fact () 'sam 'bob)
+  	(fact () 'tom 'adam)
+  	(fact () 'tad 'carl)))
+      )
+  
+    (test-check 'test-partially-eval-sgl
+     (let-lv (p1 p2)
+      (let* ((parents-of-scouts-sgl
+  	     ((parents-of-scouts p1 p2) empty-subst))
+             (cons@ (lambda@ (x y) (cons x y)))
+             (split1 (at@ 
+                      partially-eval-sgl parents-of-scouts-sgl
+                      cons@ (lambda () '())))
+             (a1 (car split1))
+             (split2 (at@ partially-eval-sgl (cdr split1) cons@
+                       (lambda () '())))
+             (a2 (car split2))
+             (split3 (at@ partially-eval-sgl (cdr split2) cons@
+                       (lambda () '())))
+             (a3 (car split3)))
+        (map (lambda (subst)
+               (reify-subst (list p1 p2) subst))
+  	(list a1 a2 a3))))
+    '(((p1.0 sam) (p2.0 rob)) ((p1.0 roz) (p2.0 sue)) ((p1.0 rob) (p2.0 sal))))
+  )
+  
+  
+  (test-check 'test-pred1
+    (let ((test1
+  	  (lambda (x)
+  	    (any (predicate (< 4 5))
+  	      (== x (< 6 7))))))
+      (solution (x) (test1 x)))
+    '((x.0 _.0)))
+  
+  (test-check 'test-pred2
+    (let ((test2
+  	  (lambda (x)
+  	    (any (predicate (< 5 4))
+  	      (== x (< 6 7))))))
+      (solution (x) (test2 x)))
+    '((x.0 #t)))
+  
+  (test-check 'test-pred3
+    (let ((test3
+  	  (lambda (x y)
+  	    (any
+  	      (== x (< 5 4))
+  	      (== y (< 6 7))))))
+      (solution (x y) (test3 x y)))
+    `((x.0 #f) (y.0 _.0)))
+  
+  (test-check 'test-Seres-Spivey
+    (let ((father
+  	  (lambda (dad child)
+  	    (any
+  	      (all (== dad 'jon) (== child 'sam))
+  	      (all (== dad 'sam) (== child 'rob))
+  	      (all (== dad 'sam) (== child 'roz))
+  	      (all (== dad 'rob) (== child 'sal))
+  	      (all (== dad 'rob) (== child 'pat))
+  	      (all (== dad 'jon) (== child 'hal))
+  	      (all (== dad 'hal) (== child 'ted))
+  	      (all (== dad 'sam) (== child 'jay))))))
+      (letrec
+          ((ancestor
+             (lambda (old young)
+               (any
+                 (father old young)
+                 (_exists (not-so-old)
+                   (all
+                     (father old not-so-old)
+                     (ancestor not-so-old young)))))))
+        (solve 20 (x) (ancestor 'jon x))))
+    '(((x.0 sam))
+      ((x.0 hal))
+      ((x.0 rob))
+      ((x.0 roz))
+      ((x.0 jay))
+      ((x.0 sal))
+      ((x.0 pat))
+      ((x.0 ted))))
+  
+  (let ()
+  (define towers-of-hanoi
+    (letrec
+        ((move
+           (extend-relation (a1 a2 a3 a4)
+             (fact () 0 __ __ __)
+             (relation (n a b c)
+               (to-show n a b c)
+               (project (n)
+                 (if-only (predicate (positive? n))
+                   (let ((m (- n 1)))
+                     (all 
+                       (move m a c b)
+                       (project (a b)
+                         (begin
+                           (cout "Move a disk from " a " to " b nl)
+                           (move m c b a)))))))))))
+      (relation (n)
+        (to-show n)
+        (move n 'left 'middle 'right))))
+  
+  (cout "test-towers-of-hanoi with 3 disks: "
+    (solution () (towers-of-hanoi 3))
+    nl nl
+    ))
+  
+  
+  (test-check 'test-fun-resubst
+    (reify
+      (let ((j (relation (x w z)
+  	       (to-show z)
+  	       (let ((x 4)
+                       (w 3))
+                   (== z (cons x w))))))
+        (solve 4 (q) (j q))))
+    '(((q.0 (4 . 3)))))
+  
+  (let ()
+  (define towers-of-hanoi-path
+    (let ((steps '()))
+      (let ((push-step (lambda (x y) (set! steps (cons `(,x ,y) steps)))))
+        (letrec
+            ((move
+               (extend-relation (a1 a2 a3 a4)
+                 (fact () 0 __ __ __)
+                 (relation (n a b c)
+                   (to-show n a b c)
+                   (project (n)
+                     (if-only (predicate (positive? n))
+                       (let ((m (- n 1)))
+                         (all
+                           (move m a c b)
+                           (project (a b)
+                             (begin
+                               (push-step a b)
+                               (move m c b a)))))))))))
+          (relation (n path)
+            (to-show n path)
+            (begin
+              (set! steps '())
+              (any
+                (fails (move n 'l 'm 'r))
+                (== path (reverse steps)))))))))
+  
+  (test-check 'test-towers-of-hanoi-path
+    (solution (path) (towers-of-hanoi-path 3 path))
+    '((path.0 ((l m) (l r) (m r) (l m) (r l) (r m) (l m))))))
+  
+  ;------------------------------------------------------------------------
+  
+            
+  (test-check 'unification-of-free-vars-1
+    (solve 1 (x)
+      (let-lv (y)
+        (all!! (== x y) (== y 5))))
+    '(((x.0 5))))
+  
+  (test-check 'unification-of-free-vars-2
+    (solve 1 (x)
+      (let-lv (y)
+        (all!! (== y 5) (== x y))))
+    '(((x.0 5))))
+  
+  (test-check 'unification-of-free-vars-3
+    (solve 1 (x)
+      (let-lv (y)
+        (all!! (== y x) (== y 5))))
+    '(((x.0 5))))
+  
+  (test-check 'unification-of-free-vars-3
+    (solve 1 (x)
+      (let-lv (y)
+        (all!! (== x y) (== y 5) (== x y))))
+    '(((x.0 5))))
+  
+  (test-check 'unification-of-free-vars-4
+    (solve 1 (x)
+      (_exists (y)
+        (all! (== y x) (== y 5) (== x y))))
+    '(((x.0 5))))
+  
+  
+  (letrec
+    ((concat
+       (lambda (xs ys)
+         (cond
+  	 ((null? xs) ys)
+  	 (else (cons (car xs) (concat (cdr xs) ys)))))))
+  
+    (test-check 'test-concat-as-function
+      (concat '(a b c) '(u v))
+      '(a b c u v))
+  
+    (test-check 'test-fun-concat
+      (solve 1 (q)
+        (== q (concat '(a b c) '(u v))))
+      '(((q.0 (a b c u v)))))
+  )
+  
+  ; Now the same with the relation
+  (letrec
+    ((concat
+       (extend-relation (a1 a2 a3)
+         (fact (xs) '() xs xs)
+         (relation (x xs (once ys) zs)
+  	 (to-show `(,x . ,xs) ys `(,x . ,zs))
+  	 (concat xs ys zs)))))
+   (test-check 'test-concat
+    (values
+      (and
+        (equal?
+          (solve 6 (q) (concat '(a b c) '(u v) q))
+          '(((q.0 (a b c u v)))))
+        (equal?
+          (solve 6 (q) (concat '(a b c) q '(a b c u v)))
+          '(((q.0 (u v)))))
+        (equal?
+          (solve 6 (q) (concat q '(u v) '(a b c u v)))
+          '(((q.0 (a b c)))))
+        (equal?
+          (solve 6 (q r) (concat q r '(a b c u v)))
+          '(((q.0 ()) (r.0 (a b c u v)))
+            ((q.0 (a)) (r.0 (b c u v)))
+            ((q.0 (a b)) (r.0 (c u v)))
+            ((q.0 (a b c)) (r.0 (u v)))
+            ((q.0 (a b c u)) (r.0 (v)))
+            ((q.0 (a b c u v)) (r.0 ()))))
+        (equal?
+          (solve 6 (q r s) (concat q r s))
+  	'(((q.0 ()) (r.0 _.0) (s.0 _.0))
+  	  ((q.0 (_.0)) (r.0 _.1) (s.0 (_.0 . _.1)))
+  	  ((q.0 (_.0 _.1)) (r.0 _.2) (s.0 (_.0 _.1 . _.2)))
+  	  ((q.0 (_.0 _.1 _.2)) (r.0 _.3) (s.0 (_.0 _.1 _.2 . _.3)))
+  	  ((q.0 (_.0 _.1 _.2 _.3)) (r.0 _.4) (s.0 (_.0 _.1 _.2 _.3 . _.4)))
+  	  ((q.0 (_.0 _.1 _.2 _.3 _.4)) (r.0 _.5)
+  	   (s.0 (_.0 _.1 _.2 _.3 _.4 . _.5))))
+  	)
+        '(equal?
+          (solve 6 (q r) (concat q '(u v) `(a b c . ,r)))
+          '(((q.0 (a b c)) (r.0 (u v)))
+            ((q.0 (a b c _.0)) (r.0 (_.0 u v)))
+            ((q.0 (a b c _.0 _.1)) (r.0 (_.0 _.1 u v)))
+            ((q.0 (a b c _.0 _.1 _.2)) (r.0 (_.0 _.1 _.2 u v)))
+            ((q.0 (a b c _.0 _.1 _.2 _.3)) (r.0 (_.0 _.1 _.2 _.3 u v)))
+            ((q.0 (a b c _.0 _.1 _.2 _.3 _.4))
+             (r.0 (_.0 _.1 _.2 _.3 _.4 u v)))))
+        (equal?
+          (solve 6 (q) (concat q '() q))
+          '(((q.0 ()))
+            ((q.0 (_.0)))
+            ((q.0 (_.0 _.1)))
+            ((q.0 (_.0 _.1 _.2)))
+            ((q.0 (_.0 _.1 _.2 _.3)))
+            ((q.0 (_.0 _.1 _.2 _.3 _.4)))))
+        ))
+    #t)
+  )
+  
+  ; Using the properties of the unifier to do the proper garbage
+  ; collection of logical vars
+  
+  ; (test-check 'lv-elim-1
+  ;   (reify
+  ;     (let-lv (x z dummy)
+  ;       (at@ 
+  ; 	(_exists (y)
+  ; 	  (== `(,x ,z ,y) `(5 9 ,x)))
+  ; 	(lambda@ (fk subst) subst)
+  ; 	initial-fk
+  ; 	(unit-subst dummy 'dummy))))
+  ;   '((y.0 . 5) (z.0 . 9) (x.0 . 5) (dummy.0 . dummy)))
+  ;   ;'((z.0 . 9) (x.0 . 5) (dummy.0 . dummy)))
+  
+  ; (test-check 'lv-elim-2
+  ;   (reify
+  ;     (let-lv (x dummy)
+  ;       (at@ 
+  ; 	(_exists (y)
+  ; 	  (== `(,x ,y) `((5 ,y) ,7)))
+  ; 	(lambda@ (fk subst) subst)
+  ; 	initial-fk
+  ; 	(unit-subst dummy 'dummy))))
+  ;   '((y.0 . 7) (x.0 5 y.0) (dummy.0 . dummy)))
+  ;   ;'((a*.0 . 7) (x.0 5 a*.0) (dummy.0 . dummy)))
+  
+  ; ; verifying corollary 2 of proposition 10
+  ; (test-check 'lv-elim-3
+  ;   (reify
+  ;     (let-lv (x v dummy)
+  ;       (at@ 
+  ; 	(_exists (y)
+  ; 	  (== x `(a b c ,v d)))
+  ; 	(lambda@ (fk subst) subst)
+  ; 	initial-fk
+  ; 	(unit-subst dummy 'dummy))))
+  ;   '((x.0 a b c v.0 d) (dummy.0 . dummy)))
+  ;   ;'((a*.0 . v.0) (x.0 a b c a*.0 d) (dummy.0 . dummy)))
+  
+  ; ; pruning several variables sequentially and in parallel
+  ; (test-check 'lv-elim-4-1
+  ;   (reify
+  ;     (let-lv (x v b dummy)
+  ;       (at@ 
+  ; 	(let-lv (y)
+  ; 	  (== `(,b ,x ,y) `(,x ,y 1)))
+  ; 	(lambda@ (fk subst) subst)
+  ; 	initial-fk
+  ; 	(unit-subst dummy 'dummy))))
+  ;   '((y.0 . 1) (x.0 . y.0) (b.0 . x.0) (dummy.0 . dummy)))
+  
+  ; ; (test-check 'lv-elim-4-2
+  ; ;   (concretize
+  ; ;     (let-lv (v b dummy)
+  ; ;       (at@ 
+  ; ; 	(_exists (x)
+  ; ; 	  (_exists (y)
+  ; ; 	    (== `(,b ,x ,y) `(,x ,y 1))))
+  ; ; 	  (lambda@ (fk subst) subst)
+  ; ; 	  initial-fk
+  ; ; 	  (unit-subst dummy 'dummy))))
+  ; ;     '((b.0 . 1) (dummy.0 . dummy)))
+  
+  ; ; (test-check 'lv-elim-4-3
+  ; ;   (concretize
+  ; ;     (let-lv (v b dummy)
+  ; ;       (at@ 
+  ; ; 	(_exists (y)
+  ; ; 	  (_exists (x)
+  ; ; 	    (== `(,b ,x ,y) `(,x ,y 1))))
+  ; ; 	  (lambda@ (fk subst) subst)
+  ; ; 	  initial-fk
+  ; ; 	  (unit-subst dummy 'dummy))))
+  ; ;     '((b.0 . 1) (dummy.0 . dummy)))
+  
+  ; (test-check 'lv-elim-4-4
+  ;   (reify
+  ;     (let-lv (v b dummy)
+  ;       (at@ 
+  ; 	(_exists (x y)
+  ; 	    (== `(,b ,x ,y) `(,x ,y 1)))
+  ; 	  (lambda@ (fk subst) subst)
+  ; 	  initial-fk
+  ; 	  (unit-subst dummy 'dummy))))
+  ;   '((y.0 . 1) (x.0 . y.0) (b.0 . x.0) (dummy.0 . dummy)))
+  ;   ;'((b.0 . 1) (dummy.0 . dummy)))
+  
+  ; ; pruning several variables sequentially and in parallel
+  ; ; for indirect (cyclic) dependency
+  ; (test-check 'lv-elim-5-1
+  ;   (reify
+  ;     (let-lv (x v b dummy)
+  ;       (at@ 
+  ; 	(let-lv (y)
+  ; 	  (== `(,b ,y ,x) `(,x (1 ,x) ,y)))
+  ; 	(lambda@ (fk subst) subst)
+  ; 	initial-fk
+  ; 	(unit-subst dummy 'dummy))))
+  ;   '((x.0 1 x.0) (y.0 1 x.0) (b.0 . x.0) (dummy.0 . dummy)))
+  ;   ;'((x.0 1 a*.0) (a*.0 . x.0) (y.0 1 a*.0) (b.0 . x.0) (dummy.0 . dummy)))
+  
+  ; ; (test-check 'lv-elim-5-2
+  ; ;   (concretize
+  ; ;     (let-lv (v b dummy)
+  ; ;       (at@ 
+  ; ; 	(_exists (x)
+  ; ; 	  (_exists (y)
+  ; ; 	  (== `(,b ,y ,x) `(,x (1 ,x) ,y))))
+  ; ; 	(lambda@ (fk subst) subst)
+  ; ; 	initial-fk
+  ; ; 	(unit-subst dummy 'dummy))))
+  ; ;   '((a*.0 1 a*.0) (b.0 1 a*.0) (dummy.0 . dummy)))
+  
+  ; ; (test-check 'lv-elim-5-3
+  ; ;   (concretize
+  ; ;     (let-lv (v b dummy)
+  ; ;       (at@ 
+  ; ; 	(_exists (y)
+  ; ; 	  (_exists (x)
+  ; ; 	  (== `(,b ,y ,x) `(,x (1 ,x) ,y))))
+  ; ; 	(lambda@ (fk subst) subst)
+  ; ; 	initial-fk
+  ; ; 	(unit-subst dummy 'dummy))))
+  ; ;   '((a*.0 1 a*.0) (b.0 1 a*.0) (dummy.0 . dummy)))
+  
+  ; (test-check 'lv-elim-5-4
+  ;   (reify
+  ;     (let-lv (v b dummy)
+  ;       (at@ 
+  ; 	(_exists (x y)
+  ; 	  (== `(,b ,y ,x) `(,x (1 ,x) ,y)))
+  ; 	(lambda@ (fk subst) subst)
+  ; 	initial-fk
+  ; 	(unit-subst dummy 'dummy))))
+  ;   '((x.0 1 x.0) (y.0 1 x.0) (b.0 . x.0) (dummy.0 . dummy)))
+  ;  ;'((a*.0 1 a*.0) (b.0 1 a*.0) (dummy.0 . dummy)))
+  
+  ; ; We should only be concerned about a direct dependency:
+  ; ;  ((x . y) (y . (1 t)) (t . x) (a . x))
+  ; ; pruning x and y in sequence or in parallel gives the same result:
+  ; ;  ((t . (1 t)) (a . (1 t)))
+  
+  
+  ; Extending relations in truly mathematical sense.
+  ; First, why do we need this.
+  (let*
+    ((fact1 (fact () 'x1 'y1))
+     (fact2 (fact () 'x2 'y2))
+     (fact3 (fact () 'x3 'y3))
+     (fact4 (fact () 'x4 'y4))
+  
+     ; R1 and R2 are overlapping
+     (R1 (extend-relation (a1 a2) fact1 fact2))
+     (R2 (extend-relation (a1 a2) fact1 fact3))
+    )
+     ; Infinitary relation
+     ; r(z,z).
+     ; r(s(X),s(Y)) :- r(X,Y).
+    (letrec
+     ((Rinf
+       (extend-relation (a1 a2)
+         (fact () 'z 'z)
+         (relation (x y t1 t2)
+  	 (to-show t1 t2)
+  	 (all
+  	   (== t1 `(s ,x))
+  	   (== t2 `(s ,y))
+  	   (Rinf x y)))))
+    )
+  
+    (cout nl "R1:" nl)
+    (_pretty-print (solve 10 (x y) (R1 x y)))
+    (cout nl "R2:" nl)
+    (_pretty-print (solve 10 (x y) (R2 x y)))
+    (cout nl "R1+R2:" nl)
+    (_pretty-print 
+      (solve 10 (x y)
+        ((extend-relation (a1 a2) R1 R2) x y)))
+  
+    (cout nl "Rinf:" nl)
+    (values (_pretty-print (solve 5 (x y) (Rinf x y))))
+    (cout nl "Rinf+R1: Rinf starves R1:" nl)
+    (values
+      (_pretty-print 
+        (solve 5 (x y)
+  	((extend-relation (a1 a2) Rinf R1) x y))))
+  
+  ; Solving the starvation problem: extend R1 and R2 so that they
+  ; are interleaved
+  ; ((sf-extend R1 R2) sk fk)
+  ; (R1 sk fk)
+  ; If R1 fails, we try the rest of R2
+  ; If R1 succeeds, it executes (sk fk)
+  ; with fk to re-prove R1. Thus fk is the "rest" of R1
+  ; So we pass sk (lambda () (run-rest-of-r2 interleave-with-rest-of-r1))
+  ; There is a fixpoint in the following algorithm!
+  ; Or a second-level shift/reset!
+  
+    (test-check "Rinf+R1"
+      (values
+        (solve 7 (x y)
+  	(any-interleave (Rinf x y) (R1 x y))))
+      '(((x.0 z) (y.0 z))
+         ((x.0 x1) (y.0 y1))
+         ((x.0 (s z)) (y.0 (s z)))
+         ((x.0 x2) (y.0 y2))
+         ((x.0 (s (s z))) (y.0 (s (s z))))
+         ((x.0 (s (s (s z)))) (y.0 (s (s (s z)))))
+         ((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z)))))))
+      )
+  
+    (test-check "R1+Rinf"
+      (values
+        (solve 7 (x y)
+  	(any-interleave (R1 x y) (Rinf x y))))
+      '(((x.0 x1) (y.0 y1))
+         ((x.0 z) (y.0 z))
+         ((x.0 x2) (y.0 y2))
+         ((x.0 (s z)) (y.0 (s z)))
+         ((x.0 (s (s z))) (y.0 (s (s z))))
+         ((x.0 (s (s (s z)))) (y.0 (s (s (s z)))))
+         ((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z)))))))
+      )
+  
+  
+    (test-check "R2+R1"
+      (solve 7 (x y)
+        (any-interleave (R2 x y) (R1 x y)))
+      '(((x.0 x1) (y.0 y1))
+         ((x.0 x1) (y.0 y1))
+         ((x.0 x3) (y.0 y3))
+         ((x.0 x2) (y.0 y2)))
+      )
+  
+    (test-check "R1+fact3"
+      (solve 7 (x y)
+        (any-interleave (R1 x y) (fact3 x y)))
+      '(((x.0 x1) (y.0 y1)) ((x.0 x3) (y.0 y3)) ((x.0 x2) (y.0 y2)))
+      )
+  
+    (test-check "fact3+R1"
+      (solve 7 (x y)
+        (any-interleave (fact3 x y) (R1 x y)))
+      '(((x.0 x3) (y.0 y3)) ((x.0 x1) (y.0 y1)) ((x.0 x2) (y.0 y2)))
+      )
+  
+  ; testing all-interleave
+    (test-check 'all-interleave-1
+      (solve 100 (x y z)
+        (all-interleave
+  	(any (== x 1) (== x 2))
+  	(any (== y 3) (== y 4))
+  	(any (== z 5) (== z 6) (== z 7))))
+      '(((x.0 1) (y.0 3) (z.0 5))
+         ((x.0 2) (y.0 3) (z.0 5))
+         ((x.0 1) (y.0 4) (z.0 5))
+         ((x.0 2) (y.0 4) (z.0 5))
+         ((x.0 1) (y.0 3) (z.0 6))
+         ((x.0 2) (y.0 3) (z.0 6))
+         ((x.0 1) (y.0 4) (z.0 6))
+         ((x.0 2) (y.0 4) (z.0 6))
+         ((x.0 1) (y.0 3) (z.0 7))
+         ((x.0 2) (y.0 3) (z.0 7))
+         ((x.0 1) (y.0 4) (z.0 7))
+         ((x.0 2) (y.0 4) (z.0 7)))
+      )
+  
+    (test-check "R1 * Rinf: clearly starvation"
+      (solve 5 (x y u v)
+        (all (R1 x y) (Rinf u v)))
+    ; indeed, only the first choice of R1 is apparent
+      '(((x.0 x1) (y.0 y1) (u.0 z) (v.0 z))
+         ((x.0 x1) (y.0 y1) (u.0 (s z)) (v.0 (s z)))
+         ((x.0 x1) (y.0 y1) (u.0 (s (s z))) (v.0 (s (s z))))
+         ((x.0 x1) (y.0 y1) (u.0 (s (s (s z)))) (v.0 (s (s (s z)))))
+         ((x.0 x1) (y.0 y1) (u.0 (s (s (s (s z))))) (v.0 (s (s (s (s z)))))))
+      )
+  
+    (test-check "R1 * Rinf: interleaving"
+      (solve 5 (x y u v)
+        (all-interleave (R1 x y) (Rinf u v)))
+    ; both choices of R1 are apparent
+      '(((x.0 x1) (y.0 y1) (u.0 z) (v.0 z))
+         ((x.0 x2) (y.0 y2) (u.0 z) (v.0 z))
+         ((x.0 x1) (y.0 y1) (u.0 (s z)) (v.0 (s z)))
+         ((x.0 x2) (y.0 y2) (u.0 (s z)) (v.0 (s z)))
+         ((x.0 x1) (y.0 y1) (u.0 (s (s z))) (v.0 (s (s z)))))
+      )
+  
+    ;; Test for nonoverlapping.
+  
+    (cout nl "any-union" nl)
+    (test-check "R1+R2"
+      (solve 10 (x y)
+        (any-union (R1 x y) (R2 x y)))
+      '(((x.0 x1) (y.0 y1))
+         ((x.0 x2) (y.0 y2))
+         ((x.0 x3) (y.0 y3))))
+  
+    (test-check "R2+R1"
+      (solve 10 (x y)
+        (any-union (R2 x y) (R1 x y)))
+      '(((x.0 x1) (y.0 y1))
+         ((x.0 x3) (y.0 y3))
+         ((x.0 x2) (y.0 y2))))
+    
+    (test-check "R1+R1"
+      (solve 10 (x y)
+        (any-union (R1 x y) (R1 x y)))
+      '(((x.0 x1) (y.0 y1))
+         ((x.0 x2) (y.0 y2))))
+    
+    (test-check "Rinf+R1"
+      (solve 7 (x y)
+        (any-union (Rinf x y) (R1 x y)))
+      '(((x.0 z) (y.0 z))
+       ((x.0 x1) (y.0 y1))
+        ((x.0 (s z)) (y.0 (s z)))
+        ((x.0 x2) (y.0 y2))
+        ((x.0 (s (s z))) (y.0 (s (s z))))
+        ((x.0 (s (s (s z)))) (y.0 (s (s (s z)))))
+        ((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z))))))))
+  
+    (test-check "R1+RInf"
+      (solve 7 (x y)
+        (any-union (R1 x y) (Rinf x y)))
+      '(((x.0 x1) (y.0 y1))
+         ((x.0 z) (y.0 z))
+         ((x.0 x2) (y.0 y2))
+         ((x.0 (s z)) (y.0 (s z)))
+         ((x.0 (s (s z))) (y.0 (s (s z))))
+         ((x.0 (s (s (s z)))) (y.0 (s (s (s z)))))
+         ((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z))))))))
+  
+  
+  ; Infinitary relation Rinf2
+  ; r(z,z).
+  ; r(s(s(X)),s(s(Y))) :- r(X,Y).
+  ; Rinf2 overlaps with Rinf in the infinite number of points
+    (letrec
+      ((Rinf2
+         (extend-relation (a1 a2)
+  	 (fact () 'z 'z)
+  	 (relation (x y t1 t2)
+  	   (to-show t1 t2)
+  	   (all
+  	     (== t1 `(s (s ,x)))
+  	     (== t2 `(s (s ,y)))
+  	     (Rinf2 x y)))))
+        )
+      (test-check "Rinf2"
+        (solve 5 (x y) (Rinf2 x y))
+        '(((x.0 z) (y.0 z))
+  	 ((x.0 (s (s z))) (y.0 (s (s z))))
+  	 ((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z))))))
+  	 ((x.0 (s (s (s (s (s (s z)))))))
+  	   (y.0 (s (s (s (s (s (s z))))))))
+  	 ((x.0 (s (s (s (s (s (s (s (s z)))))))))
+  	   (y.0 (s (s (s (s (s (s (s (s z))))))))))))
+  
+      (test-check "Rinf+Rinf2"
+        (solve 9 (x y)
+  	(any-union (Rinf x y) (Rinf2 x y)))
+        '(((x.0 z) (y.0 z))
+  	 ((x.0 (s z)) (y.0 (s z)))
+  	 ((x.0 (s (s z))) (y.0 (s (s z))))
+  	 ((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z))))))
+  	 ((x.0 (s (s (s z)))) (y.0 (s (s (s z)))))
+  	 ((x.0 (s (s (s (s (s (s z)))))))
+  	   (y.0 (s (s (s (s (s (s z))))))))
+  	 ((x.0 (s (s (s (s (s (s (s (s z)))))))))
+  	   (y.0 (s (s (s (s (s (s (s (s z))))))))))
+  	 ((x.0 (s (s (s (s (s z)))))) (y.0 (s (s (s (s (s z)))))))
+  	 ((x.0 (s (s (s (s (s (s (s (s (s (s z)))))))))))
+  	   (y.0 (s (s (s (s (s (s (s (s (s (s z))))))))))))))
+      
+      (test-check "Rinf2+Rinf"
+        (solve 9 (x y)
+  	(any-union (Rinf2 x y) (Rinf x y)))
+        '(((x.0 z) (y.0 z))
+  	 ((x.0 (s z)) (y.0 (s z)))
+  	 ((x.0 (s (s z))) (y.0 (s (s z))))
+  	 ((x.0 (s (s (s z)))) (y.0 (s (s (s z)))))
+  	 ((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z))))))
+  	 ((x.0 (s (s (s (s (s z)))))) (y.0 (s (s (s (s (s z)))))))
+  	 ((x.0 (s (s (s (s (s (s z)))))))
+  	   (y.0 (s (s (s (s (s (s z))))))))
+  	 ((x.0 (s (s (s (s (s (s (s z))))))))
+  	   (y.0 (s (s (s (s (s (s (s z)))))))))
+  	 ((x.0 (s (s (s (s (s (s (s (s z)))))))))
+  	   (y.0 (s (s (s (s (s (s (s (s z))))))))))))
+      )))
+  
+  
+  (cout nl "Append with limited depth" nl)
+  ; In Prolog, we normally write:
+  ; append([],L,L).
+  ; append([X|L1],L2,[X|L3]) :- append(L1,L2,L3).
+  ;
+  ; If we switch the clauses, we get non-termination.
+  ; In our system, it doesn't matter!
+  
+  (letrec
+    ((extend-clause-1
+       (relation (l)
+         (to-show '() l l)
+         succeed))
+     (extend-clause-2
+       (relation (x l1 l2 l3)
+         (to-show `(,x . ,l1) l2 `(,x . ,l3))
+         (extend-rel l1 l2 l3)))
+     (extend-rel
+         (extend-relation-with-recur-limit 5 (a b c)
+  	 extend-clause-1
+  	 extend-clause-2))
+      )
+  
+    ; Note (solve 100 ...)
+    ; Here 100 is just a large number: we want to print all solutions
+      (cout nl "Extend: clause1 first: " 
+        (solve 100 (a b c) (extend-rel a b c))
+        nl))
+  
+  (letrec
+    ((extend-clause-1
+       (relation (l)
+         (to-show '() l l)
+         succeed))
+     (extend-clause-2
+       (relation (x l1 l2 l3)
+         (to-show `(,x . ,l1) l2 `(,x . ,l3))
+         (extend-rel l1 l2 l3)))
+     (extend-rel
+       (extend-relation-with-recur-limit 3 (a b c)
+         extend-clause-2
+         extend-clause-1)))
+  
+    (cout nl "Extend: clause2 first. In Prolog, it would diverge!: " 
+      (solve 100 (a b c) (extend-rel a b c)) nl))
+  
+  
+  (letrec
+    ((base-+-as-relation
+       (fact (n) 'zero n n))
+     (recursive-+-as-relation
+       (relation (n1 n2 n3)
+         (to-show `(succ ,n1) n2 `(succ ,n3))
+         (plus-as-relation n1 n2 n3)))
+     ; Needed eta-expansion here: otherwise, SCM correctly reports
+     ; an error (but Petite doesn't, alas)
+     ; This is a peculiarity of extend-relation as a macro
+     ; Potentially, we need the same approach as in minikanren
+     (plus-as-relation
+       (extend-relation (a1 a2 a3)
+         (lambda (a1 a2 a3) (base-+-as-relation a1 a2 a3))
+         (lambda (a1 a2 a3) (recursive-+-as-relation a1 a2 a3))
+         ))
+      )
+  
+    (test-check "Addition"
+      (solve 20 (x y)
+        (plus-as-relation x y '(succ (succ (succ (succ (succ zero)))))))
+      '(((x.0 zero) (y.0 (succ (succ (succ (succ (succ zero)))))))
+         ((x.0 (succ zero)) (y.0 (succ (succ (succ (succ zero))))))
+         ((x.0 (succ (succ zero))) (y.0 (succ (succ (succ zero)))))
+         ((x.0 (succ (succ (succ zero)))) (y.0 (succ (succ zero))))
+         ((x.0 (succ (succ (succ (succ zero))))) (y.0 (succ zero)))
+         ((x.0 (succ (succ (succ (succ (succ zero)))))) (y.0 zero))))
+  
+    (newline)
+  )
+10)
+
+;; ========================================================================
+;; type-inference example
+;; ========================================================================
+
+; Type Inference
+;
+; We show two variations of Hindley-Milner type inference. Both
+; variations support polymorphic, generalizing `let'. Both variations
+; use Kanren's logical variables for type variables, and take advantage
+; of Kanren's unifier to solve the equations that arise during the course
+; of type inference. These features make the Kanren realization of the
+; type inference algorithm concise and lucid.
+;
+; The variations differ in the syntax of the `source' language, and in
+; the way type environments are implemented.  One variation realizes
+; type environments as regular lists, of associations between symbolic
+; variable names and their types. The other variation extends the type
+; entailment relation (which is a first-class relation in Kanren). The
+; latter approach is similar to that of inductive proofs (see files
+; ./deduction.scm and ./mirror-equ.scm)
+;
+; $Id: type-inference.scm,v 4.50 2005/02/12 00:05:01 oleg Exp $
+
+; (display "Type inference") (newline)
+
+; Variation 1: use a subset of Scheme itself as the source language
+; The following two functions translate between the source language
+; and intermediate one.
+
+(define parse
+  (lambda (e)
+    (cond
+      ((symbol? e) `(var ,e))
+      ((number? e) `(intc ,e))
+      ((boolean? e) `(boolc ,e))
+      (else (case (car e)
+              ((zero?) `(zero? ,(parse (cadr e))))
+              ((sub1) `(sub1 ,(parse (cadr e))))
+              ((+) `(+ ,(parse (cadr e)) ,(parse (caddr e))))
+              ((if) `(if ,(parse (cadr e)) ,(parse (caddr e)) ,(parse (cadddr e))))
+              ((fix) `(fix ,(parse (cadr e))))
+              ((lambda) `(lambda ,(cadr e) ,(parse (caddr e))))
+              ((let) `(let ((,(car (car (cadr e))) ,(parse (cadr (car (cadr e))))))
+                        ,(parse (caddr e))))
+              (else `(app ,(parse (car e)) ,(parse (cadr e)))))))))
+
+(define unparse
+  (lambda (e)
+    (case (car e)
+      ((var) (cadr e))
+      ((intc) (cadr e))
+      ((boolc) (cadr e))
+      ((zero?) `(zero? ,(unparse (cadr e))))
+      ((sub1) `(sub1 ,(unparse (cadr e))))
+      ((+) `(+ ,(unparse (cadr e)) ,(unparse (caddr e))))
+      ((if) `(if ,(unparse (cadr e)) ,(unparse (caddr e)) ,(unparse (cadddr e))))
+      ((fix) `(fix ,(unparse (cadr e))))
+      ((lambda) `(lambda (,(car (cadr e))) ,(unparse (caddr e))))
+      ((let) 
+       `(let ((,(car (car (cadr e)))
+               ,(unparse (cadr (car (cadr e))))))
+          ,(unparse (caddr e))))
+      ((app) `(,(unparse (cadr e)) ,(unparse (caddr e)))))))
+
+; Type environments
+;
+; A type environment (often denoted as \Gamma, or g in this code)
+; is an association between the names of variables of source language
+; terms and the types of those variables.
+; As a side condition, each variable may occur in the list
+; exactly once.
+; Hmm, to model lexical scope better, we may relax that condition.
+;
+; Here we implement type environments as regular associative lists,
+; lists of triples:
+;    (<var-name> non-generic <type>)
+;    (<var-name> generic <type-gen>)
+;
+; <var-name> is a symbolic name of a source term variable.
+; <type> is a type term, e.g., int, bool, (--> int bool), etc.
+; <type> may include logical variables, which are treated then as
+; type variables.
+;
+; The association '(<var-name> generic <type-gen>)' asserts that
+; <var-name> is given a _generic_ type. <type-gen> then is a
+; predicate of arity 1. To be more precise, (<type-gen> <type>)
+; is an goal that succeeds or fails depending on the fact if
+; <type> is an instance of a generic type represented by <type-gen>.
+; 
+; This is precisely the logical meaning of generalization, as
+; pointed out by Ken:
+; <blockquote>
+; A cleaner, but less efficient, formulation of HM type inference is to
+; use the following let rule instead:
+;
+;     Gamma |- M : t    Gamma |- N[M/x] : t'
+;     -------------------------------------- Let
+;          Gamma |- let x = M in N : t'
+;
+; Look ma, no FV!  In words, this rule treats let as a construct for
+; syntactic substitution.  This means storing either M, or a thunk
+; returning (a logical variable associated with a fresh copy of) the type
+; of M, under x in the environment.  This formulation avoids var? while
+; taking advantage of built-in unification (to some extent).
+; </blockquote>
+;
+; We must emphasize that in Kanren, relations are first-class, and may,
+; therefore, be included as parts of a data structure: of an associative
+; list in our case.
+
+; Because type environments are regular lists, we can build them using
+; regular cons. The empty type environemnt is the empty list.  The
+; following is a Kanren relation that searches the associative
+; list. We are interested in the first match.
+
+; The following is a general-purpose function
+; (membero v l) holds if v is a member of the list l. 
+; 'v' must be sufficiently instantiated (at least, the search key
+; must be instantiated, to justify our use of the committed choice
+; non-determinism).
+(define membero
+  (relation (v lt lh)
+    (to-show v `(,lh . ,lt))
+    (if-some (== v lh) succeed
+      (membero v lt))))
+
+; The following is the type-environment-specific function.
+; (env g v t) holds if the source term variable v has a type t
+; in the environment g.
+; We require that 'v' be instantiated, to justify our use
+; of the committed choice non-determinism (e.g., membero).
+
+(define env
+  (relation (head-let g v t)
+    (_exists (tq)
+      (all!!
+	(membero `(,v . ,tq) g)
+	(any
+	  (== tq `(non-generic ,t))
+	  (_exists (type-gen)
+	    (all!!
+	      (== tq `(generic ,type-gen))
+	      (project (type-gen)
+		(type-gen t)))))))))
+
+;;;; This starts the rules
+
+(define int 'int)
+(define bool 'bool)
+
+(define var-rel
+  (relation (g v t)
+    (to-show g `(var ,v) t)
+    (all! (env g v t))))
+
+(define int-rel
+  (fact (g x) g `(intc ,x) int))
+
+(define bool-rel
+  (fact (g x) g `(boolc ,x) bool))
+
+(define zero?-rel
+  (relation (g x)
+    (to-show g `(zero? ,x) bool)
+    (all! (!- g x int))))
+
+(define sub1-rel
+  (relation (g x)
+    (to-show g `(sub1 ,x) int)
+    (all! (!- g x int))))
+
+(define plus-rel
+  (relation (g x y)
+    (to-show g `(+ ,x ,y) int)
+    (all!! (!- g x int) (!- g y int))))
+
+(define if-rel
+  (relation (g t test conseq alt)
+    (to-show g `(if ,test ,conseq ,alt) t)
+    (all!! (!- g test bool) (!- g conseq t) (!- g alt t))))
+
+(define lambda-rel
+  (relation (g v t body type-v)
+    (to-show g `(lambda (,v) ,body) `(a--> ,type-v ,t))
+    (all! (!- `((,v non-generic ,type-v) . ,g) body t))))
+
+(define app-rel
+  (relation (g t rand rator)
+    (to-show g `(app ,rator ,rand) t)
+    (_exists (t-rand)
+      (all!! (!- g rator `(a--> ,t-rand ,t)) (!- g rand t-rand)))))
+
+(define fix-rel
+  (relation (g rand t)
+    (to-show g `(fix ,rand) t)
+    (all! (!- g rand `(a--> ,t ,t)))))
+
+; Type-checking polymorphic let: (let ([,v ,rand]) ,body)
+; There is obviously an inefficiency, because we typecheck `rand'
+; every time the variable `v' occurs in the body (and once more). 
+; We can fix it, with copy term. But for now, we leave this optimization out.
+; The reason to test `(!- g rand some-type)' at the very beginning is
+; to make sure that `rand' itself is well-typed. As Ken pointed out,
+; we must outlaw expressions such as (let ((x (z z))) y) where 'x'
+; does not occur in the body. The variable 'x' still must have some
+; type.
+
+(define polylet-rel
+  (relation (g v rand body t)
+    (to-show g `(let ((,v ,rand)) ,body) t)
+    (all!!
+      (_exists (some-type) (!- g rand some-type))
+      (!- `((,v generic ,(relation (head-let t-rand)
+			   (all!!
+			     (!- g rand t-rand)
+			     (trace-vars 'poly-let (t-rand rand)))))
+	     . ,g)
+	body t))))
+
+
+(define !-
+  (extend-relation (a1 a2 a3)
+    var-rel int-rel bool-rel zero?-rel sub1-rel plus-rel 
+    if-rel lambda-rel app-rel fix-rel polylet-rel))
+
+(define (ti-tests)
+(test-check 'test-!-1
+  (and
+    (equal?
+      (solution (?) (!- '() '(intc 17) int))
+      '((?.0 _.0)))
+    (equal?
+      (solution (?) (!- '() '(intc 17) ?))
+      '((?.0 int))))
+  #t)
+
+(test-check 'arithmetic-primitives
+  (solution (?) (!- '() '(zero? (intc 24)) ?))
+  '((?.0 bool)))
+
+(test-check 'test-!-sub1
+  (solution (?) (!- '() '(zero? (sub1 (intc 24))) ?))
+  '((?.0 bool)))
+
+(test-check 'test-!-+
+  (solution (?)
+      (!- '() '(zero? (sub1 (+ (intc 18) (+ (intc 24) (intc 50))))) ?))
+  '((?.0 bool)))
+
+(test-check 'test-!-2
+  (and
+    (equal?
+      (solution (?) (!- '() '(zero? (intc 24)) ?))
+      '((?.0 bool)))
+    (equal?
+      (solution (?) (!- '() '(zero? (+ (intc 24) (intc 50))) ?))
+      '((?.0 bool)))
+    (equal?
+      (solution (?)
+	(!- '() '(zero? (sub1 (+ (intc 18) (+ (intc 24) (intc 50))))) ?))
+      '((?.0 bool))))
+  #t)
+
+(test-check 'test-!-3
+  (solution (?) (!- '() '(if (zero? (intc 24)) (intc 3) (intc 4)) ?))
+  '((?.0 int)))
+
+(test-check 'if-expressions
+  (solution (?)
+    (!- '() '(if (zero? (intc 24)) (zero? (intc 3)) (zero? (intc 4))) ?))
+  '((?.0 bool)))
+
+(test-check 'variables
+  (and
+    (equal?
+      (solution (?)
+          (env '((b non-generic int) (a non-generic bool)) 'a ?))
+      '((?.0 bool)))
+    (equal?
+      (solution (?)
+	(!- '((a non-generic int)) '(zero? (var a)) ?))
+      '((?.0 bool)))
+    (equal?
+      (solution (?)
+	(!- '((b non-generic bool) (a non-generic int))
+            '(zero? (var a))
+            ?))
+      '((?.0 bool))))
+  #t)
+
+(test-check 'variables-4a
+  (solution (?)
+    (!- '((b non-generic bool) (a non-generic int))
+        '(lambda (x) (+ (var x) (intc 5)))
+        ?))
+  '((?.0 (a--> int int))))
+
+(test-check 'variables-4b
+  (solution (?)
+    (!- '((b non-generic bool) (a non-generic int))
+        '(lambda (x) (+ (var x) (var a)))
+        ?))
+  '((?.0 (a--> int int))))
+
+(test-check 'variables-4c
+  (solution (?)
+    (!- '() '(lambda (a) (lambda (x) (+ (var x) (var a)))) ?))
+  '((?.0 (a--> int (a--> int int)))))
+
+(test-check 'everything-but-polymorphic-let
+  (solution (?)
+    (!- '() (parse
+              '(lambda (f)
+                 (lambda (x)
+                   ((f x) x))))
+        ?))
+  '((?.0 (a-->
+           (a--> _.0 (a--> _.0 _.1))
+           (a--> _.0 _.1)))))
+
+(test-check 'everything-but-polymorphic-let
+  (solution (?)
+    (!- '()
+        (parse
+          '((fix (lambda (sum)
+                   (lambda (n)
+                     (if (zero? n)
+                         0
+                         (+ n (sum (sub1 n)))))))
+            10))
+        ?))
+  '((?.0 int)))
+
+(test-check 'everything-but-polymorphic-let
+  (solution (?)
+    (!- '()
+        (parse
+          '((fix (lambda (sum)
+                   (lambda (n)
+                     (+ n (sum (sub1 n))))))
+            10))
+        ?))
+  '((?.0 int)))
+
+(test-check 'everything-but-polymorphic-let
+  (solution (?)
+    (!- '()
+        (parse '((lambda (f)
+                   (if (f (zero? 5))
+                       (+ (f 4) 8)
+                       (+ (f 3) 7)))
+                 (lambda (x) x)))
+        ?))
+  #f)
+
+(test-check 'polymorphic-let
+  (solution (?)
+    (!- '()
+        (parse
+          '(let ((f (lambda (x) x)))
+             (if (f (zero? 5))
+                 (+ (f 4) 8)
+                 (+ (f 3) 7))))
+        ?))
+  '((?.0 int)))
+
+(test-check 'with-robust-syntax
+  (solution (?)
+    (!- '()
+        '(app
+           (fix
+             (lambda (sum)
+               (lambda (n)
+                 (if (if (zero? (var n)) (boolc #t) (boolc #f))
+                     (intc 0)
+                     (+ (var n) (app (var sum) (sub1 (var n))))))))
+           (intc 10))
+        ?))
+  '((?.0 int)))
+
+(test-check 'with-robust-syntax-but-long-jumps/poly-let
+  (solution (?)
+    (!- '()
+        '(let ((f (lambda (x) (var x))))
+           (if (app (var f) (zero? (intc 5)))
+               (+ (app (var f) (intc 4)) (intc 8))
+               (+ (app (var f) (intc 3)) (intc 7))))
+        ?))
+  '((?.0 int)))
+
+(test-check 'type-habitation-1
+  (solution (g ?)
+    (!- g ? '(a--> int int)))
+  '((g.0 ((_.0 non-generic (a--> int int)) . _.1)) (?.0 (var _.0))))
+
+(test-check 'type-habitation-2
+  (solution (g h r q z y t)
+    (!- g `(,h ,r (,q ,z ,y)) t))
+  '((g.0 ((_.0 non-generic int) . _.1))
+    (h.0 +)
+    (r.0 (var _.0))
+    (q.0 +)
+    (z.0 (var _.0))
+    (y.0 (var _.0))
+    (t.0 int))
+)
+
+(test-check 'type-habitation-3
+  (and
+    (equal?
+      (solution (la f b)
+	(!- '() `(,la (,f) ,b) '(a--> int int)))
+      '((la.0 lambda) (f.0 _.0) (b.0 (var _.0))))
+    (equal?
+      (solution (h r q z y t u v)
+	(!- '() `(,h ,r (,q ,z ,y)) `(,t ,u ,v)))
+      '((h.0 lambda)
+        (r.0 (_.0))
+        (q.0 +)
+        (z.0 (var _.0))
+        (y.0 (var _.0))
+        (t.0 a-->)
+        (u.0 int)
+        (v.0 int))))
+  #t)
+
+10)
+
+;----------------------------------------------------------------------
+; A different implementation of type environments
+; We define a first-class (and recursive) relation !-
+; so that (!- `(var ,v) t) holds iff the source term variable v has a type
+; t. 
+; This variant is close to the `natural deduction' scheme.
+; It also has an OO flavor: we need open recursion.
+
+; The following are the separate components of which the relation
+; !- will be built. All these components nevertheless receive the full
+; !- as the argument. Actually, they will receive the 'self'-like
+; argument. We need to explicitly find the fixpoint.
+
+; (cout nl "Natural-deduction-like type inference" nl nl)
+
+
+(define pint-rel
+  (lambda (s!-)
+    (fact (x) `(intc ,x) int)))
+
+(define pbool-rel
+  (lambda (s!-)
+    (fact (x) `(boolc ,x) bool)))
+
+(define pzero?-rel
+  (lambda (s!-)
+    (let ((!- (s!- s!-)))
+      (relation (x)
+	(to-show `(zero? ,x) bool)
+	(all! (!- x int))))))
+
+(define psub1-rel
+  (lambda (s!-)
+    (let ((!- (s!- s!-)))
+      (relation (x)
+	(to-show `(sub1 ,x) int)
+	(all! (!- x int))))))
+
+(define p+-rel
+  (lambda (s!-)
+    (let ((!- (s!- s!-)))
+      (relation (x y)
+	(to-show `(+ ,x ,y) int)
+	(all!! (!- x int) (!- y int))))))
+
+(define pif-rel
+  (lambda (s!-)
+    (let ((!- (s!- s!-)))
+      (relation (t test conseq alt)
+	(to-show `(if ,test ,conseq ,alt) t)
+	(all!! (!- test bool) (!- conseq t) (!- alt t))))))
+
+; Here we extend !- with an additional assumption that v has the type
+; type-v. This extension corresponds to a non-generic, regular type.
+(define plambda-rel
+  (lambda (s!-)
+    (relation (v t body type-v)
+      (to-show `(lambda (,v) ,body) `(a--> ,type-v ,t))
+      (let* ((snew-!-
+	       (lambda (self)
+		 (extend-relation (v t)
+		   (fact () `(var ,v) type-v) ; lexically-scoped relation
+		   (s!- self))))
+	      (!- (snew-!- snew-!-)))
+	(all! (!- body t))))))
+
+
+(define papp-rel
+  (lambda (s!-)
+    (let ((!- (s!- s!-)))
+      (relation (t rand rator)
+	(to-show `(app ,rator ,rand) t)
+	(_exists (t-rand)
+	  (all!! (!- rator `(a--> ,t-rand ,t)) (!- rand t-rand)))))))
+
+(define pfix-rel
+  (lambda (s!-)
+     (let ((!- (s!- s!-)))
+       (relation (rand t)
+	 (to-show `(fix ,rand) t)
+	 (all! (!- rand `(a--> ,t ,t)))))))
+
+; Type-checking polymorphic let: (let ((,v ,rand)) ,body)
+; There is obviously an inefficiency, because we typecheck `rand'
+; every time the variable `v' occurs in the body (and once more). 
+; We can fix it, with copy term. But for now, we leave this optimization out.
+; The reason to test `(!- g rand some-type)' at the very beginning is
+; to make sure that `rand' itself is well-typed. As Ken pointed out,
+; we must outlaw expressions such as (let ((x (z z))) y) where 'x'
+; does not occur in the body. The variable 'x' still must have some
+; type.
+
+(define ppolylet-rel
+  (lambda (s!-)
+    (let ((!- (s!- s!-)))
+      (relation (v rand body t)
+	(to-show `(let ((,v ,rand)) ,body) t)
+	(all!! 
+	  (_exists (some-type) (!- rand some-type))
+	  (let* ((snew-!-
+		   (lambda (self)
+		     (extend-relation (v t)
+		       (relation (head-let `(var ,v) t-rand)
+			 (all!!
+			   (!- rand t-rand)
+			   (trace-vars 'poly-let (t-rand rand))))
+		       (s!- self))))
+		  (!- (snew-!- snew-!-)))
+	    (!- body t)))))))
+
+; Now we build the recursive !- relation, as a fixpoint
+
+(define s!-
+  (lambda (self)
+    (lambda (v t)
+      ((extend-relation (a1 a2)
+	 (pint-rel self)
+	 (pbool-rel self)  (pzero?-rel self)
+	 (psub1-rel self)  (p+-rel self)
+	 (pif-rel self)    (plambda-rel self)
+	 (papp-rel self)   (pfix-rel self)
+	 (ppolylet-rel self)) v t))))
+
+(define !-/2 (s!- s!-))
+
+
+; And we re-do all the tests
+
+(define (ti-tests-2)
+
+(test-check 'test-!-1
+  (and
+    (equal?
+      (solution (?) (!-/2 '(intc 17) int))
+      '((?.0 _.0)))
+    (equal?
+      (solution (?) (!-/2 '(intc 17) ?))
+      '((?.0 int))))
+  #t)
+
+(test-check 'arithmetic-primitives
+  (solution (?) (!-/2 '(zero? (intc 24)) ?))
+  '((?.0 bool)))
+
+(test-check 'test-!-sub1
+  (solution (?) (!-/2 '(zero? (sub1 (intc 24))) ?))
+  '((?.0 bool)))
+
+(test-check 'test-!-+
+  (solution (?)
+      (!-/2 '(zero? (sub1 (+ (intc 18) (+ (intc 24) (intc 50))))) ?))
+  '((?.0 bool)))
+
+(test-check 'test-!-2
+  (and
+    (equal?
+      (solution (?) (!-/2 '(zero? (intc 24)) ?))
+      '((?.0 bool)))
+    (equal?
+      (solution (?) (!-/2 '(zero? (+ (intc 24) (intc 50))) ?))
+      '((?.0 bool)))
+    (equal?
+      (solution (?)
+	(!-/2 '(zero? (sub1 (+ (intc 18) (+ (intc 24) (intc 50))))) ?))
+      '((?.0 bool))))
+  #t)
+
+(test-check 'test-!-3
+  (solution (?) (!-/2 '(if (zero? (intc 24)) (intc 3) (intc 4)) ?))
+  '((?.0 int)))
+
+(test-check 'if-expressions
+  (solution (?)
+    (!-/2 '(if (zero? (intc 24)) (zero? (intc 3)) (zero? (intc 4))) ?))
+  '((?.0 bool)))
+
+; Commented out: we need to extend !- if we wish to typecheck open terms
+'(test-check 'variables
+  (and
+    (equal?
+      (solution (?)
+          (env '((b non-generic int) (a non-generic bool)) 'a ?))
+      '((?.0 bool)))
+    (equal?
+      (solution (?)
+	(!-/2 '((a non-generic int)) '(zero? (var a)) ?))
+      '((?.0 bool)))
+    (equal?
+      (solution (?)
+	(!-/2 '((b non-generic bool) (a non-generic int))
+            '(zero? (var a))
+            ?))
+      '((?.0 bool))))
+  #t)
+
+(test-check 'variables-4a
+  (solution (?)
+    (!-/2 '(lambda (x) (+ (var x) (intc 5)))
+        ?))
+  '((?.0 (a--> int int))))
+
+; Commented out: we need to extend !- if we wish to typecheck open terms
+'(test-check 'variables-4b
+  (solution (?)
+    (!-/2 '((b non-generic bool) (a non-generic int))
+        '(lambda (x) (+ (var x) (var a)))
+        ?))
+  '((?.0 (a--> int int))))
+
+(test-check 'variables-4c
+  (solution (?)
+    (!-/2 '(lambda (a) (lambda (x) (+ (var x) (var a)))) ?))
+  '((?.0 (a--> int (a--> int int)))))
+
+(test-check 'everything-but-polymorphic-let
+  (solution (?)
+    (!-/2 (parse
+	  '(lambda (f)
+	     (lambda (x)
+	       ((f x) x))))
+      ?))
+  '((?.0 (a-->
+           (a--> _.0 (a--> _.0 _.1))
+           (a--> _.0 _.1)))))
+
+(test-check 'everything-but-polymorphic-let
+  (solution (?)
+    (!-/2 (parse
+          '((fix (lambda (sum)
+                   (lambda (n)
+                     (if (zero? n)
+                         0
+                         (+ n (sum (sub1 n)))))))
+            10))
+        ?))
+  '((?.0 int)))
+
+(test-check 'everything-but-polymorphic-let
+  (solution (?)
+    (!-/2 (parse
+          '((fix (lambda (sum)
+                   (lambda (n)
+                     (+ n (sum (sub1 n))))))
+            10))
+        ?))
+  '((?.0 int)))
+
+(test-check 'everything-but-polymorphic-let
+  (solution (?)
+    (!-/2 (parse '((lambda (f)
+                   (if (f (zero? 5))
+                       (+ (f 4) 8)
+                       (+ (f 3) 7)))
+                 (lambda (x) x)))
+        ?))
+  #f)
+
+(test-check 'polymorphic-let
+  (solution (?)
+    (!-/2 (parse
+          '(let ((f (lambda (x) x)))
+             (if (f (zero? 5))
+                 (+ (f 4) 8)
+                 (+ (f 3) 7))))
+        ?))
+  '((?.0 int)))
+
+(test-check 'with-robust-syntax
+  (solution (?)
+    (!-/2 '(app
+           (fix
+             (lambda (sum)
+               (lambda (n)
+                 (if (if (zero? (var n)) (boolc #t) (boolc #f))
+                     (intc 0)
+                     (+ (var n) (app (var sum) (sub1 (var n))))))))
+           (intc 10))
+        ?))
+  '((?.0 int)))
+
+(test-check 'with-robust-syntax-but-long-jumps/poly-let
+  (solution (?)
+    (!-/2 '(let ((f (lambda (x) (var x))))
+           (if (app (var f) (zero? (intc 5)))
+               (+ (app (var f) (intc 4)) (intc 8))
+               (+ (app (var f) (intc 3)) (intc 7))))
+        ?))
+  '((?.0 int)))
+
+; The latter doesn't work: but it wasn't too informative anyway
+'(test-check 'type-habitation-1
+  (solution (?)
+    (!-/2 ? '(a--> int int)))
+  '((g.0 ((v.0 non-generic (a--> int int)) . lt.0)) (?.0 (var v.0))))
+
+(test-check 'type-habitation-2
+  (solution (h r q z y t)
+    (!-/2 `(,h ,r (,q ,z ,y)) t))
+  '((h.0 +)
+    (r.0 (intc _.0))
+    (q.0 +)
+    (z.0 (intc _.1))
+    (y.0 (intc _.2))
+    (t.0 int))
+)
+
+(test-check 'type-habitation-3
+  (and
+    (equal?
+      (solution (la f b)
+	(!-/2  `(,la (,f) ,b) '(a--> int int)))
+      '((la.0 lambda) (f.0 _.0) (b.0 (var _.0))))
+    (equal?
+      (solution (h r q z y t u v)
+	(!-/2  `(,h ,r (,q ,z ,y)) `(,t ,u ,v)))
+      '((h.0 lambda)
+        (r.0 (_.0))
+        (q.0 +)
+        (z.0 (var _.0))
+        (y.0 (var _.0))
+        (t.0 a-->)
+        (u.0 int)
+        (v.0 int))))
+  #t)
+10)
+
+
+; The code below uses the low-level function var? Every use of var?
+; entails a proof obligation that such use is safe. In our case here,
+; invertible-binary-function->ternary-relation and
+; invertible-unary-function->binary-relation are sound.
+
+(define invertible-binary-function->ternary-relation
+  (lambda (op inverted-op)
+    (relation (head-let x y z)
+      (project/no-check (z)
+	(if-only (predicate (var? z))
+          (project (x y) (== z (op x y))) ; z is free, x and y must not
+	  (project/no-check (y)
+	    (if-only (predicate (var? y)) ; y is free, z is not
+	      (project (x)
+		(== y (inverted-op z x)))
+	      (project/no-check (x)
+		(if-only (predicate (var? x)) ; x is free, y and z are not
+		  (== x (inverted-op z y))
+		  (== z (op x y)))))))))))
+
+
+(define t++ (invertible-binary-function->ternary-relation + -))
+(define t-- (invertible-binary-function->ternary-relation - +))
+(define ** (invertible-binary-function->ternary-relation * /))
+(define // (invertible-binary-function->ternary-relation / *))
+
+(define symbol->lnum
+  (lambda (sym)
+    (map char->integer (string->list (symbol->string sym)))))
+
+(define lnum->symbol
+  (lambda (lnums)
+    (string->symbol (list->string (map integer->char lnums)))))
+
+(define invertible-unary-function->binary-relation
+  (lambda (op inverted-op)
+    (relation (head-let x y)
+      (project/no-check (y)
+	(if-only (predicate (var? y))
+	  (project (x) (== y (op x)))	; y is free, x must not
+	  (project/no-check (x)
+	    (if-only (predicate (var? x))
+	      (== x (inverted-op y))
+	      (== y (op x)))))))))
+
+(define name
+  (invertible-unary-function->binary-relation symbol->lnum lnum->symbol))
+
+(define (ti-tests-3)
+(test-check 'test-instantiated-1
+  (and
+    (equal?
+      (solution (x) (t++ x 16.0 8))
+      '((x.0 -8.0)))
+    (equal?
+      (solution (x) (t++ 10 16.0 x))
+      '((x.0 26.0)))
+    (equal?
+      (solution (x) (t-- 10 x 3))
+      '((x.0 13))))
+  #t)
+
+(test-check 'test-instantiated-2
+  (and
+    (equal?
+      (solution (x) (name 'sleep x))
+      '((x.0 (115 108 101 101 112))))
+    (equal?
+      (solution (x) (name x '(115 108 101 101 112)))
+      '((x.0 sleep))))
+  #t)
+10)
+
+;; ========================================================================
+;; typeclasses example
+;; ========================================================================
+
+;(newline)
+;(display "Checking for dependency satisfaction in Haskell typeclasses")
+;(newline)
+; Suppose we have the following Haskell class and instance declarations
+;      class C a b c | a b -> c 
+;      instance C a b c => C a (x,y,b) c
+;      instance C a (a,c,b) c
+;
+; They will be compiled into the following database of instances,
+; which define the class membership.
+(define typeclass-C-instance-1
+  (relation (a b c x y)
+    (to-show a `(,x ,y ,b) c)
+    (typeclass-C a b c)))
+
+(define typeclass-C-instance-2
+  (relation (a b c)
+    (to-show a `(,a ,c ,b) c)
+    succeed))
+
+(define typeclass-C
+  (extend-relation (a b c) 
+    typeclass-C-instance-2
+    typeclass-C-instance-1))
+
+; Run the checker for the dependency a b -> c
+; Try to find the counter-example, that is, two members of (C a b c)
+; such that a's and b's are the same but the c's are different.
+
+  
+(define typeclass-counter-example-query
+  (lambda (a b c1 c2)
+    (all 
+      (typeclass-C a b c1)
+      (typeclass-C a b c2)
+      (fails (project/no-check (c1 c2) (predicate (*equal? c1 c2)))))))
+
+; This does loop
+;'(define typeclass-C
+;   (extend-relation (a b c) 
+;     typeclass-C-instance-1
+;     typeclass-C-instance-2))
+
+(define typeclass-C/x
+  (extend-relation-with-recur-limit 2 (a b c)
+    typeclass-C-instance-1
+    typeclass-C-instance-2))
+
+; (pntall "~%Test: checking dependency satisfaction: Another example.~%")
+; Suppose we have the following Haskell class and instance declarations
+;	class F a b | a->b
+;	instance F a b => F [a] [b]
+;	instance F [a] a
+;
+
+(define typeclass-F
+  (extend-relation-with-recur-limit 10 (a b)
+    (relation (a b)
+      (to-show `(list ,a) `(list ,b))
+      (typeclass-F a b))
+    (fact (a) `(list ,a) a)))
+
+
+; Run the checker for the dependency a -> b
+; Try to find the counter-example, that is, two members of (F a b)
+; such that as is the same but bs are different.
+(define typeclass-F-counter-example-query
+  (lambda (a b1 b2)
+    (all 
+      (typeclass-F a b1)
+      (typeclass-F a b2)
+      (fails (project/no-check (b1 b2) (predicate (*equal? b1 b2)))))))
+
+; (pntall "~%Overloading resolution in Haskell.~%")
+; Suppose we have the following Haskell class and instance declarations
+;	class F a b | a->b where f :: a->b->Bool
+;	instance F a b => F [a] [b]
+;
+; we need to typecheck
+;   g x = f [x] x
+; which says that f:: [a] -> a -> Bool
+; In general, we need to figure out which instance to choose for f.
+; In other words, we need to find out which subset of F to use.
+; Here's only one instance. So we need to figure out if it applies.
+
+(define typeclass-F-instance-1
+  (relation (a b)
+    (to-show `(list ,a) `(list ,b))
+    (typeclass-F/x a b)))
+
+; This is a closed-world assumption
+(define typeclass-F/x
+  (extend-relation-with-recur-limit 10 (a b)
+    typeclass-F-instance-1))
+
+; This is an open-world assumption
+(define typeclass-F/x2
+  (extend-relation-with-recur-limit 2 (a b)
+    typeclass-F-instance-1
+    (relation (a b1 b2)	; a relation under constraint a->b
+      (to-show a b1)
+      (fails
+	(all!
+	  (typeclass-F/x a b2)
+	  (fails (project/no-check (b1 b2) (predicate (*equal? b1 b2)))))))
+    ))
+
+(define (tc-tests)
+  (pntall "~%Counter-example: ~s~%"
+          (solution (a b c1 c2)
+                    (typeclass-counter-example-query a b c1 c2)))
+
+  (pntall "~%Counter-example: ~s~%"
+          (solution (a b c1 c2)
+                    (typeclass-counter-example-query a b c1 c2)))
+
+  (pntall "~%Counter-example: ~s~%"
+          (solve 4 (a b c1 c2)
+                 (typeclass-counter-example-query a b c1 c2)))
+  
+  (pntall "~%Counter-example: ~s~%" 
+          (solve 4 (a b1 b2) (typeclass-F-counter-example-query a b1 b2)))
+  
+  
+  (test-check "Typechecking (closed world)" 
+              (solve 4 (a)
+                     (typeclass-F-instance-1 `(list ,a) a))
+              '())					; meaning: does not typecheck!
+  
+  
+  (pntall "~%Typechecking (open world): ~s~%" 
+          (solve 4 (a) (typeclass-F-instance-1 `(list ,a) a)))
+  
+  (test-check "Typechecking (open world) f [x] int" 
+              (solve 4 (a) (typeclass-F-instance-1 `(list ,a) 'int))
+              '())					; meaning: does not typecheck!
+
+  10
+  )
+
+;; ========================================================================
+;; zebra example
+;; ========================================================================
+
+; (display "Zebra") (newline)
+
+;   1. There are five houses in a row, each of a different color
+;       and inhabited by men of different nationalities,
+;       with different pets, drinks, and cigarettes.
+;   2. The Englishman lives in the red house.
+;   3. The Spaniard owns a dog.
+;   4. Coffee is drunk in the green house.
+;   5. The Ukrainian drinks tea.
+;   6. The green house is directly to the right of the ivory house.
+;   7. The Old Gold smoker owns snails.
+;   8. Kools are being smoked in the yellow house.
+;   9. Milk is drunk in the middle house.
+;  10. The Norwegian lives in the first house on the left.
+;  11. The Chesterfield smoker lives next to the fox owner.
+;  12. Kools are smoked in the house next to the house where the horse is kept.
+;  13. The Lucky Strike smoker drinks orange juice.
+;  14. The Japanese smokes Parliaments.
+;  15. The Norwegian lives next to the blue house.
+
+; (define memb 
+;   (extend-relation (a1 a2)
+;     (fact (item) item `(,item . ,_))
+;     (relation (item rest) (to-show item `(,_ . ,rest)) (memb item rest))))
+
+(define memb 
+  (relation (head-let item lst) 
+    (any (== lst `(,item . ,__))
+      (_exists (rest)
+	(if-only (== lst `(,__ . ,rest)) (memb item rest))))))
+
+
+(define next-to
+  (relation (head-let item1 item2 rest)
+    (any (on-right item1 item2 rest) (on-right item2 item1 rest))))
+
+(define on-right
+  (extend-relation (a0 a1 a2)
+    (fact (item1 item2) item1 item2 `(,item1 ,item2 . ,__))
+    (relation ((once item1) (once item2) rest)
+      (to-show item1 item2 `(,__ . ,rest))
+      (on-right item1 item2 rest))))
+        
+(define zebra
+  (relation (head-let h)
+    (if-only
+      (all!
+        (== h `((norwegian ,__ ,__ ,__ ,__) ,__ (,__ ,__ milk ,__ ,__) ,__ ,__))
+        (memb `(englishman ,__ ,__ ,__ red) h)
+        (on-right `(,__ ,__ ,__ ,__ ivory) `(,__ ,__ ,__ ,__ green) h)
+        (next-to `(norwegian ,__ ,__ ,__ ,__) `(,__ ,__ ,__ ,__ blue) h)
+        (memb `(,__ kools ,__ ,__ yellow) h)
+        (memb `(spaniard ,__ ,__ dog ,__) h)
+        (memb `(,__ ,__ coffee ,__ green) h) 
+        (memb `(ukrainian ,__ tea ,__ ,__) h)
+        (memb `(,__ luckystrikes oj ,__ ,__) h)
+        (memb `(japanese parliaments ,__ ,__ ,__) h)
+        (memb `(,__ oldgolds ,__ snails ,__) h)
+        (next-to `(,__ ,__ ,__ horse ,__) `(,__ kools ,__ ,__ ,__) h)
+        (next-to `(,__ ,__ ,__ fox ,__) `(,__ chesterfields ,__ ,__ ,__) h)
+        )
+      (all (memb `(,__ ,__ water ,__ ,__) h)
+	(memb `(,__ ,__ ,__ zebra ,__) h)))))
+
+;'(_pretty-print
+;  (time (let loop ((n 100000))
+;              (cond
+;                ((zero? n) 'done)
+;                (else (solution (h) (zebra h))
+;                  (loop (sub1 n)))))))
+
+(define (zebra-test)
+(test-check "Zebra"
+  (values (solution (h) (zebra h)))
+  '((h.0 ((norwegian kools water fox yellow)
+          (ukrainian chesterfields tea horse blue)
+          (englishman oldgolds milk snails red)
+          (spaniard luckystrikes oj dog ivory)
+          (japanese parliaments coffee zebra green)))))
+10)
+
+; Sample timing (Pentium IV, 2GHz, 1GB RAM)
+; (time (solution (h) ...))
+;     1 collection
+;     22 ms elapsed cpu time, including 0 ms collecting
+;     27 ms elapsed real time, including 0 ms collecting
+;     981560 bytes allocated, including 1066208 bytes reclaimed
+
+; For version 3.17 of kanren (with head-let ...)
+; (time (solution (h) ...))
+;     1 collection
+;     19 ms elapsed cpu time, including 0 ms collecting
+;     19 ms elapsed real time, including 0 ms collecting
+;     788928 bytes allocated, including 1052312 bytes reclaimed
+;
+; For version of kanren 3.36 (with once annotations)
+; This seems to be similar of SWI-Prolog, which gives 0.01 sec
+; timing for the equivalent zebra code.
+; (time (solution (h) ...))
+;     no collections
+;     11 ms elapsed cpu time
+;     11 ms elapsed real time
+;     532912 bytes allocated
+
+; For version of kanren 4.0 (increased sharing during unification)
+; (time (solution (h) ...))
+;     no collections
+;     7 ms elapsed cpu time
+;     8 ms elapsed real time
+;     443792 bytes allocated
+; For version of kanren 4.1 (detection of bare variables, less garbage)
+;     no collections
+;     8 ms elapsed cpu time
+;     9 ms elapsed real time
+;     448920 bytes allocated
+; For version of kanren 4.50 (subst sk fk order)
+;     no collections
+;     8 ms elapsed cpu time
+;     8 ms elapsed real time
+;     416864 bytes allocated
+
+;; ========================================================================
+;; Mirror example
+;; ========================================================================
+
+; First we need an extendible database of relations.
+; We should be able to add to the database later on -- extend
+; it with assumptions.
+;
+; One approach for the database is a finite map (hash table, assoc
+; list) from the name of a relation to the procedure that is a relation
+; in our system. Or, to make it even better, from a tuple
+; (name arity) to the body of the relation.
+; This is the approach of Prolog.
+; Suppose we have a term (foo ?a ?b ?c) where ?a, ?b and ?c are arbitrary
+; terms (logical variables, constants, expressions, etc). 
+; We would like to check if this term is consistent with (i.e., can
+; be proven by) a particular instance of the database.
+; First, we need to look up a key (foo 3) in the database. If the
+; lookup fails, so does our query. If the lookup succeeds, we get
+; a procedure of three arguments. We apply this procedure to
+; ?a, ?b, and ?c and obtain an goal, which we can 'solve'
+; as usual.
+
+; In the following, we chose a different approach. We represent the database
+; of relations as a relation itself -- we will call it KB. That
+; relation takes one argument -- the term to prove, and returns an goal
+; that represents the answer (that goal may be 'fail').
+; A database of one fact
+;  foo(a,b,c).
+; in Prolog notation will be represented in our approach as a relation
+;   (relation _ () (to-show `(foo a b c)))
+; If we want to add another relation, say
+; bar(X,X).
+; we need to _extend_ the above relation with
+;  (relation _ (x) (to-show `(bar x x))).
+;
+; This approach is probably less efficient than the first one. It has
+; however a redeeming value -- we do not need a separate procedure
+; to look up names/arities of relations. We don't need separate procedures
+; for extending our database. We can use the existing machinery of
+; 'solving' relations for 'solving' the database of relations.
+; This approach seems reminiscent of the Futamura projections:
+; we use the same engine for meta-evaluations. Bootstrapping.
+
+; First we define the inductive structure
+
+; In Athena:
+;  (structure (BTree S)
+;     (leaf S)
+;     (root (BTree S) (BTree S)))
+
+; In Prolog
+; btree(leaf(S)).
+; btree(root(T1,T2)) :- btree(T1),btree(T2).
+
+; Note, our trees here (as well as those in Prolog) are polytypic
+; (polymorphic): leaves can have values of different sorts.
+
+; When we attempt to translate
+;	btree(root(T1,T2)) :- btree(T1),btree(T2).
+; into our system, we encounter the first difficulty. To find out
+; if a term btree(root(T1,T2)) is consistent with our database of relations,
+; we need to check if terms  btree(T1) and  btree(T2) are consistent.
+; Thus, to add btree(root(T1,T2)) to our database, we need to use
+; the database itself to verify btree(T1) and btree(T2). Clearly,
+; we need a fixpoint. The need for the fixpoint _exists no matter what is
+; the representation of the database -- a finite map or a relation.
+; Prolog solves the fixpoint problem by making the database global
+; and using mutations (similar to the way letrec is implemented in Scheme).
+; If we attempt to be purely functional, we must make the fixpoint explicit
+; and employ Y.
+
+; Note, the kb variable below represents the "current" database.
+; In our approach, the database is a relation of one argument,
+; which is a term to prove. A Second-order relation???
+
+(define btree
+  (lambda (kb)
+    (extend-relation (t)
+      (fact (val) `(btree (leaf ,val)))
+      (relation (t1 t2)
+	(to-show `(btree (root ,t1 ,t2)))
+	(project (t1 t2)
+          (all
+	    (predicate (pntall "btree ~s ~s ~n" t1 t2))
+	    (kb `(btree ,t1))
+	    (kb `(btree ,t2))))))))
+
+;%> (declare mirror ((S) -> ((BTree S)) (BTree S)))
+
+; Introduce an equality predicate and the first axiom for mirror
+; In Athena:
+; (define mirror-axiom-1
+;   (forall ?x
+;     (= (mirror (leaf ?x)) (leaf ?x))))
+
+; In Prolog
+; myeq(leaf(X),mirror(leaf(X))).
+
+(define mirror-axiom-eq-1
+  (lambda (kb)
+    (fact (val) `(myeq (leaf ,val) (mirror (leaf ,val))))))
+
+; The second axiom
+; In Athena:
+; (define mirror-axiom-eq-2
+;   (forall ?t1 ?t2
+;     (= (mirror (root ?t1 ?t2))
+;       (root (mirror ?t2) (mirror ?t1)))))
+
+; In Prolog
+; myeq(root(B,A),mirror(root(T1,T2))) :- myeq(A,mirror(T1)),myeq(B,mirror(T2)).
+
+; implicitly the axiom in Prolog and the one below assume
+; the transitivity of myeq. Indeed, one may think that the direct
+; translation from Athena to Prolog would be
+;
+;   myeq(mirror(root(T1,T2)),root(mirror(T2),mirror(T1)))
+; or
+;   myeq(mirror(root(T1,T2)),root(B,A)) :- B = T2, A = T1.
+; However, Athena actually assumes that B and T2 can be myeq rather
+; than merely identical. We also switched the order of arguments
+; in myeq, assuming symmetry of myeq.
+; It really helped in Prolog. In our system, we could have used
+; the same order as in Athena and add:
+;    myeq(A,A).   % reflexivity: identity implies equality
+;    myeq(A,B) :- myeq(B,A). % symmetry
+; Clearly if we add these relations to Prolog code, it will diverge.
+; In our system, we can use with-depth to keep divergence in check.
+; Still, for simplicity and clarity we will simply model the Prolog solution
+; in our code.
+
+(define mirror-axiom-eq-2
+  (lambda (kb)
+    (relation  (a b t1 t2)
+      (to-show `(myeq (root ,b ,a) (mirror (root ,t1 ,t2))))
+      (all
+	(kb `(myeq ,a (mirror ,t1)))
+	(kb `(myeq ,b (mirror ,t2)))))))
+
+; we could also add reflexivity and transitivity and symmetry axioms
+; and with-depth to keep them from diverging.
+
+; Define the goal
+; In Athena:
+;  (define (goal t)
+;     (= (mirror (mirror t)) t))
+
+; In Prolog
+; Note, the goal is _equivalent_ to the conjunction of the
+; predicates. That's why we couldn't use the standard Prolog
+; notation goal(T) :- btree(T), ...
+; because the latter would give us only the implication.
+; goal(T,[btree(T),myeq(T,mirror(T1)),myeq(T1,mirror(T))]).
+
+(define goal
+  (lambda (t)
+    (let-lv (t1)
+      (list
+	`(btree ,t)
+	`(myeq ,t  (mirror ,t1))
+	`(myeq ,t1 (mirror ,t))))))
+
+; For clarity, the above predicate can be written as two (prolog) relations
+; The forward relation:
+; (goal t) is implied by (btree t), (myeq t (mirror t1)) and 
+;                        (myeq t1 (mirror t))
+; In the above, t is universally quantified and t1 is existentially
+; quantified
+
+(define goal-fwd
+  (lambda (kb)
+    (relation (t t1)
+      (to-show `(goal ,t))
+      (all
+	(kb `(btree ,t))
+	(kb `(myeq ,t  (mirror ,t1)))
+	(kb `(myeq ,t1 (mirror ,t)))))))
+
+; The reverse relation for the goal:
+; (goal t) implies (btree t), (myeq t (mirror t1)) and 
+;                             (myeq t1 (mirror t))
+; In the above, t is universally quantified and t1 is existentially
+; quantified
+; Because t1 now appears on the left-hand side, it is represented
+; as an eigenvariable (skolem function) rather than a logical variable
+
+(define goal-rev
+  (let* ((sk (eigen-variable 'sk))
+	 (t1-sk (lambda (t) `(,sk ,t))))
+    (lambda (kb)
+      (extend-relation (t)
+	(relation (t)			; (goal t) => (btree t)
+	  (to-show `(btree ,t))
+	  (kb `(goal ,t)))
+	(relation (t)			; (goal t) => (myeq t  (mirror t1))
+	  (to-show `(myeq ,t  (mirror ,(t1-sk t))))
+	  (kb `(goal ,t)))
+	(relation (t)			; (goal t) => (myeq t1 (mirror t))
+	  (to-show `(myeq ,(t1-sk t) (mirror ,t)))
+	  (kb `(goal ,t)))
+	))))
+      
+; The initial assumptions: just the btree
+(define init-kb (Y btree))
+
+; Verification engine
+;	verify-goal PREDS KB
+; returns a nullary relation that is the conjunction of preds against the
+; assumption base kb
+(define verify-goal
+  (lambda (preds kb)
+    (cond
+      ((null? (cdr preds)) (kb (car preds)))
+      (else (all
+              (kb (car preds))
+              (verify-goal (cdr preds) kb))))))
+
+; extend the kb with the list of assumptions
+; this is just like 'any' only it's a procedure rather than a syntax
+; Why we need universalize?
+; Suppose, the list of facts includes
+;	(fact (x) (foo x)) and (fact (x) (bar x))
+; definitely, we do not want to imply that facts foo and bar _share_
+; the same logical variable. The facts are independent and should
+; not have any variables in common.
+; Furthermore, we do not want to add
+;	(fact (x) (foo x))
+; because that would mean exist x. foo x
+; We want our facts to be universally quantified. So, we add
+;	(fact () (foo 'unique-symbol))
+; See the distinction between sigma and pi in Lambda-Prolog.
+; We use extend-kb to extend the database with assumptions, which most
+; often are universally quantified.
+
+(define extend-kb
+  (lambda (facts kb)
+    (let ((facts (universalize facts)))
+      (pntall "Extending KB with ~s~%" facts)
+      (let loop ((facts facts))
+        (if (null? facts) kb
+            (extend-relation (t)
+              (fact () (car facts))
+              (loop (cdr facts))))))))
+
+; Here's Athena's induction proof.
+;
+; (by-induction-on ?t (goal ?t)
+;   ((leaf x) (!pf (goal (leaf x)) [mirror-axiom-1]))
+;   ((root t1 t2) 
+;     (!pf (goal (root t1 t2)) [(goal t1) (goal t2)  mirror-axiom-2])))
+
+; The first part of it, the base case, can be expressed in Prolog
+; as follows.
+; ?- goal(leaf(X),C),verify(C,[]).
+; Here how it looks in our system:
+(define (mirror-tests)
+(test-check "First check the base case"
+  (query (_ subst)
+    (verify-goal (goal '(leaf x))
+      (extend-relation (t) (mirror-axiom-eq-1 init-kb) init-kb))
+    (reify-subst '() subst))
+  '((val.0 x) (t1.0 (leaf x)) (val.0 x) (val.0 x)))
+
+(test-check "Check the base case, using goal-fwd"
+  (query (_ subst)
+    (let ((kb0
+	    (extend-relation (t) (mirror-axiom-eq-1 init-kb) init-kb)))
+      (let ((kb1
+	      (extend-relation (t) (goal-fwd kb0) kb0)))
+	(kb1 '(goal (leaf x))))) ; note, x is an eigenvariable!
+    (reify-subst '() subst))
+  '((val.0 x) (t1.0 (leaf x)) (val.0 x) (val.0 x) (t.0 (leaf x))))
+
+; that is, we obtain the list of subgoals to verify '(leaf x)
+; by invoking the function 'goal'.
+; we extend the initial database (which contains btree facts)
+; with mirror-axiom-eq-1. Thus, mirror-axiom-eq-1 and btree form
+; the assumptions. We then verify the subgoals against the assumptions.
+; Note that we wrote
+;    '(leaf x)
+; rather than
+;    (let-lv (x) `(leaf ,x))
+; because we want to prove that (goal '(leaf x)) holds for _all_ x
+; rather than for some particular x.
+;
+; non-empty result printed by the above expressions means success...
+
+
+; The inductive case.
+; Now, assume the goal holds for t1 and t2 and check if it holds
+; for root(t1,t2)
+;?- goal(t1,A1),goal(t2,A2), append(A1,A2,A), goal(root(t1,t2),C), verify(C,A).
+
+(test-check "Some preliminary checks"
+  (solution (foo)
+    (verify-goal '((btree t2)) ; (goal t2) => (btree t2)
+      (let ((kb0
+	      (extend-kb (goal 't1) 
+		(extend-kb (goal 't2) init-kb))))
+	kb0)))
+  '((foo.0 _.0)))
+
+(test-check "Some preliminary checks, using goal-rev"
+  (solution (foo)
+    (let ((kb
+	    (Y
+	      (lambda (kb)
+		(extend-relation (t)
+		  (btree kb)
+		  (goal-rev kb)
+		  (fact () '(goal t1))
+		  (fact () '(goal t2)))))))
+      (kb '(btree t2))))
+  '((foo.0 _.0)))
+
+; the above two expressions should give the same result: a non-empty stream
+; (with an empty substitution: no variables leak)
+
+(test-check "Another check"
+  (solution (foo)
+	;(goal t1), (goal t2) => (btree (root t1 t2))
+    (verify-goal '((btree t1) (btree t2)
+		   (btree (root t1 t2)))
+      (let ((kb0
+	      (extend-kb (goal 't1) 
+		(extend-kb (goal 't2) 
+		  (fact () 'nothing)))))
+	(Y
+	  (lambda (kb)
+	    (extend-relation (t)
+	      kb0
+	      (btree kb)
+	      (mirror-axiom-eq-2 kb)))))))
+  '((foo.0 _.0)))
+
+(test-check "Another check, using goal-rev"
+  (solution (foo)
+    (let ((kb
+	    (Y
+	      (lambda (kb)
+		(extend-relation (t)
+		  (btree kb)
+		  (goal-rev kb)
+		  (mirror-axiom-eq-2 kb)
+		  (fact () '(goal t1))
+		  (fact () '(goal t2)))))))
+      (kb '(btree (root t1 t2)))))
+  '((foo.0 _.0)))
+
+; now we really need Y because we rely on the clause
+;	btree(root(T1,T2)) :- btree(T1),btree(T2).
+; which is recursive.
+
+(test-check "Check the inductive case"
+  (query (_ subst)
+    (verify-goal (goal '(root t1 t2))
+      (let ((kb0
+	      (extend-kb (goal 't1) 
+		(extend-kb (goal 't2) 
+		  (fact () 'initial)))))
+	(Y
+	  (lambda (kb)
+	    (extend-relation (t)
+	      kb0
+	      (btree kb)
+	      (mirror-axiom-eq-2 kb))))))
+    (cout (reify-subst '() subst) nl) #t)
+  #t)
+
+(pntall "~%Check particulars of the inductive case, using goal-rev, goal-fwd ~s~%"
+  (let ((kb
+          (Y
+            (lambda (kb)
+              (extend-relation (t)
+                (btree kb)
+                (fact () '(goal t1))
+                (fact () '(goal t2))
+                (mirror-axiom-eq-2 kb)
+                (goal-rev kb)
+                )))))
+    (list
+      (solve 1 (x) (kb `(myeq (root t1 t2)  (mirror ,x))))
+      (solve 1 (x) (kb `(myeq ,x (mirror (root t1 t2))))))))
+
+(test-check "Check the inductive case, using goal-rev, goal-fwd"
+  (query (_ subst)
+    (let ((kb
+	    (Y
+	      (lambda (kb)
+		(extend-relation (t)
+		  (btree kb)
+		  (fact () '(goal t1))
+		  (fact () '(goal t2))
+		  (mirror-axiom-eq-2 kb)
+		  (goal-rev kb))))))
+      (let ((kb1 (goal-fwd kb)))
+	(kb1 '(goal (root t1 t2)))))
+    (cout (reify-subst '() subst) nl) #t)
+  #t)
+
+10)
+
+
+; Again, we use Y because btree and mirror-axiom-eq-2 are recursive.
+; We need the database that is the fixpoint of all constituent
+; relations.
+; The output above is a non-empty list: meaning that the inductive
+; phase of the proof checks.
+
+;; ========================================================================
+;; Mirror-equ example
+;; ========================================================================
+
+; See mirror.scm for preliminaries
+
+(define btrii
+  (lambda (kb)
+    (extend-relation (t)
+      (fact (val) `(btrii (leaf ,val)))
+      (relation (t1 t2)
+	(to-show `(btrii (root ,t1 ,t2)))
+	(all
+	  (trace-vars 'btrii (t1 t2))
+	  (kb `(btrii ,t1))
+	  (kb `(btrii ,t2)))))))
+
+(define myeq-axioms
+  (lambda (kb)
+    (extend-relation (t)
+      (fact (val) `(myeq ,val ,val)) ; reflexivity
+      (relation (a b)
+	(to-show `(myeq ,a ,b))		; symmetry
+	(all
+	  (trace-vars 'symmetry (a b))
+	  (kb `(myeq ,b ,a))))
+      (relation (a b)			; transitivity
+	(to-show `(myeq ,a ,b))
+	(_exists (c)
+	  (all
+	    (kb `(myeq ,a ,c))
+	    (kb `(myeq ,c ,b)))))
+      )))
+
+(define myeq-axioms-trees		; equational theory of trees
+  (lambda (kb)				; equality commutes with root
+    (relation (a b c d)
+      (to-show `(myeq (root ,a ,b) (root ,c ,d)))
+      (all
+	(trace-vars 'trees (a b))
+	(kb `(myeq ,a ,c))
+	(kb `(myeq ,b ,d))))))
+  
+; equality on leaves follows from the reflexivity of equality
+
+(define myeq-axioms-mirror		; equational theory of mirror
+  (lambda (kb)				; equality commutes with root
+    (extend-relation (t)
+      (relation (a b)
+	(to-show `(myeq (mirror ,a) ,b))
+	(all
+	  (trace-vars 'mirror (a b))
+	  (_exists (c)
+	    (all (kb `(myeq ,b (mirror ,c)))
+	         (kb `(myeq ,a ,c)))))))))
+
+; Axioms of mirror
+; In Prolog
+; myeq(leaf(X),mirror(leaf(X))).
+
+(define mirror-axiom-eq-1/x
+  (lambda (kb)
+    (fact (val) `(myeq (leaf ,val) (mirror (leaf ,val))))))
+
+
+; The second axiom
+; In Athena:
+; (define mirror-axiom-eq-2/x
+;   (forall ?t1 ?t2
+;     (= (mirror (root ?t1 ?t2))
+;       (root (mirror ?t2) (mirror ?t1)))))
+
+(define mirror-axiom-eq-2/x
+  (lambda (kb)
+    (relation (t1 t2) 
+      (to-show `(myeq (mirror (root ,t1 ,t2)) (root (mirror ,t2) (mirror ,t1))))
+      (trace-vars 'mirror-ax2 (t1 t2)))))
+
+; Define the goal
+; In Athena:
+;  (define (goal t)
+;     (= (mirror (mirror t)) t))
+
+(define goal/x
+  (lambda (t)
+    (list 
+      `(btrii ,t)
+      `(myeq (mirror (mirror ,t)) ,t))))
+
+(define goal-fwd/x
+  (lambda (kb)
+    (relation (t)
+      (to-show `(goal/x ,t))
+      (all
+	(kb `(btrii ,t))
+	(kb `(myeq (mirror (mirror ,t)) ,t))))))
+
+(define goal-rev/x
+  (lambda (kb)
+    (extend-relation (t)
+      (relation (t)			; (goal t) => (btrii t)
+	(to-show `(btrii ,t))
+	(kb `(goal/x ,t)))
+      (relation (t)		; (goal t) => (myeq (mirror (mirror t)) t)
+	(to-show `(myeq (mirror (mirror ,t)) ,t))
+	(kb `(goal/x ,t))))))
+
+; (by-induction-on ?t (goal ?t)
+;   ((leaf x) (!pf (goal (leaf x)) [mirror-axiom-1]))
+;   ((root t1 t2) 
+;     (!pf (goal (root t1 t2)) [(goal t1) (goal t2)  mirror-axiom-2])))
+
+
+
+(define-syntax un@ ; uncurry 
+  (syntax-rules ()
+    ((_ proc arg1 ...)
+      (lambda (arg1 ...) (at@ proc arg1 ...)))))
+
+; The initial assumptions: just the btrii
+;(define init-kb (Y btrii))
+; Note that in order to be effective, 
+; extend-relation-with-recur-limit should not be under lambda!
+; We want to use the same recursion count for all
+; entrances to init-kb-coll.
+; Also note that the limit 5 is the number of axioms in init-kb-coll
+; plus one. This count will guarantee that each axiom will be tried
+; once, but not more than twice.
+(define init-kb-coll
+  (extend-relation-with-recur-limit 5 (kb t)
+    (un@ btrii kb t)
+    (un@ myeq-axioms kb t)
+    (un@ myeq-axioms-mirror kb t)
+    (un@ myeq-axioms-trees kb t)))
+
+(define (mirror-equ-tests)
+(test-check "First check the base case, using goal-fwd"
+  (query (_ subst)
+    (let ((kb0
+	    (Y (lambda (kb)
+		 (extend-relation (t) 
+		   (mirror-axiom-eq-1/x kb)
+		   (lambda (t) (init-kb-coll kb t)))))))
+      (let ((kb1
+	      (extend-relation (t) (goal-fwd/x kb0) kb0)))
+	(kb1 '(goal/x (leaf x))))) ; note, x is an eigenvariable!
+     ;(cout (reify-subst '() subst) nl)
+    #t)
+  #t)
+
+; (goal t2) => (btrii t2)
+(test-check "Some preliminary checks, using goal-rev"
+  (query (_ subst)
+    (let ((kb
+	    (Y
+	      (lambda (kb)
+		(extend-relation (t)
+		  (lambda (t) (init-kb-coll kb t))
+		  (goal-rev/x kb)
+		  (fact () '(goal/x t1))
+		  (fact () '(goal/x t2)))))))
+      (kb '(btrii t2)))
+     ;(cout (reify-subst '() subst) nl)
+    #t)
+  #t)
+
+(test-check "Another check, using goal-rev"
+	;(goal t1), (goal t2) => (btrii (root t1 t2))
+  (query (_ subst)
+    (let ((kb
+	    (Y
+	      (lambda (kb)
+		(extend-relation (t)
+		  (lambda (t) (init-kb-coll kb t))
+		  (goal-rev/x kb)
+		  (mirror-axiom-eq-2/x kb)
+		  (fact () '(goal/x t1))
+		  (fact () '(goal/x t2)))))))
+      (kb '(btrii (root t1 t2))))
+    (cout (reify-subst '() subst) nl)
+    #t)
+  #t)
+
+(pntall "~%Check particulars of the inductive case, using goal-rev, goal-fwd ~s~%"
+  (let ((kb
+          (Y
+            (lambda (kb)
+              (extend-relation (t)
+                (lambda (t) (init-kb-coll kb t))
+                (fact () '(goal/x t1))
+                (fact () '(goal/x t2))
+                (mirror-axiom-eq-2/x kb)
+                (goal-rev/x kb)
+                )))))
+    (list
+      ;(solve 1 (x) (kb `(myeq (root t1 t2)  (mirror ,x))))
+      (solve 1 (x) (kb `(myeq ,x (mirror (root t1 t2)))))
+      )))
+
+10)
+
+;; ========================================================================
+;; pure bin arith example
+;; ========================================================================
+
+;	     Pure, declarative, and constructive binary arithmetics
+;
+; aka: Addition, Multiplication, Division with remainder 
+; as sound and complete, pure and declarative relations that can be
+; used in any mode whatsoever and that recursively enumerate their domains.
+; The relations define arithmetics over base-2 non-negative numerals
+; of *arbitrary* size.
+;
+; aka: division as relation.
+; The function divo below is a KANREN relation between four binary numerals
+; n, m, q, and r such that the following holds
+;	_exists r. 0<=r<m, n = q*m + r
+;
+; The relation 'divo' encompasses all four operations of arithmetics:
+; we can use (divo x y z zero) to multiply and divide and
+; (divo x y one r) to add and subtract.
+;
+; See pure-arithm.scm in this directory for Peano arithmetics.
+
+; The arithmetic relations possess interesting properties.
+; For example, given the relation (divo N M Q R) which holds
+; iff N = M*Q + R and 0<=R<M, we can try:
+;   -- (divo 1 0 Q _). It fails and does not try to enumerate
+;      all natural numbers.
+;   -- (divo 5 M 1 _). It finds all such M that divide (perhaps unevenly)
+;      5 with the quotient of 1. The answer is the set (5 4 3).
+; Again, (divo 5 M 7 _) simply fails and does not loop forever.
+; We can use the (**o X Y Z) relation either to multiply two numbers
+; X and Y -- or to find all factorizations of Z. See the test below.
+; Furthermore, we can try to evaluate (++o X 1 Y) and get the stream
+; of answers, among which is ((0 _.0 . _.1) (1 _.0 . _.1))
+; which essentially says that 2*x and 2*x +1 are successors, for all x>0!
+;
+; We give two implementations of addition and multiplication
+; relations, `++o' and `**o'. Both versions have the properties of
+; soundness and nealy refutational completeness. The first version of `++o'
+; is faster, but it does not always recursively enumerate its domain
+; if that domain is infinite.  This is the case when, e.g., (**o x y
+; z) is invoked when all three x, y, and z are uninstantiated
+; variables. The relation in that case has the infinite number of
+; solutions, as expected. Alas, those solutions look as follows:
+;	x = 2,  y = 3, z = 6
+;	x = 4,  y = 3, z = 12
+;	x = 8,  y = 3, z = 24
+;	x = 16, y = 3, z = 48
+; That is, (**o x y z) keeps generating solutions where x is a power of
+; two. Therefore, when the answerset of the relation `**o' is infinite, it
+; truly produces an infinite set of solutions -- but only the subset of
+; all possible solutions. In other words, `**o' does not recursively
+; enumerate the set of all numbers such that x*y=z if that set is infinite.
+;
+; Therefore, 
+;   (all (== x '(1 1)) (== y '(1 1)) (**o x y z))
+;   (all (**o x y z)   (== x '(1 1)) (== y '(1 1)))
+; work differently. The former terminates and binds z to the representation
+; of 9 (the product of 3 and 3). The latter fails to terminate.
+; This is not generally surprising as `all', like 'commas' in Prolog, 
+; is not truly a conjunction: they are not commutative. Still, 
+; we would like our `++o' and `**o' to have the algebraic properties
+; expected of addition and multiplication.
+;
+; The second version of `++o' and `**o' completely fixes the
+; problem without losing any performance.  The addition and
+; multiplication relations completely enumerate their domain, even if
+; it is infinite. Furthermore, ++o and **o now generate the numbers
+; _in sequence_, which is quite pleasing. We achieve the
+; property of recursive enumerability without giving up neither
+; completeness nor refutational completeness. As before, if 'z' is
+; instantiated but 'x' and 'y' are not, (++o x y z) delivers *all*
+; non-negative numbers that add to z and (**o x y z) computes *all*
+; factorizations of z.
+;
+; Such relations are easy to implement in an impure system such as Prolog,
+; with the help of a predicate 'var'. The latter can tell if its argument
+; is an uninstantiated variable. However, 'var' is impure. The present
+; file shows the implementation of arithmetic relations in a _pure_
+; logic system.
+;
+; The present approach places the correct upper bounds on the
+; generated numbers to make sure the search process will terminate.
+; Therefore, our arithmetic relations are not only sound
+; (e.g., if (**o X Y Z) holds then it is indeed X*Y=Z) but also
+; complete (if X*Y=Z is true then (**o X Y Z) holds) and
+; nearly refutationally complete (if X*Y=Z is false and X, Y, and Z
+; are either fully instantiated, or not instantiated, then (**o X Y Z) fails,
+; in finite time). The refutational completeness
+; claim is limited to the case when all terms passed to arithmetical
+; functions do not share variables, are either fully instantiated or not
+; instantiated at all. Indeed, sharing of variables or partial
+; instantiation essentially imposes the constraint: e.g.,
+;   (solution (q) (**o `(1 . ,q) `(1 1) `(1 . ,q)))
+; is tantamount to
+; (solution (q) (exist (q1)
+;         (all (**o `(1 . ,q) `(1 1) `(1 . ,q1)) (== q q1))))
+; That conjunction will never succeed. See the corresponding Prolog
+; code for justification and relation to the 10th Hilbert problem.
+;
+; The numerals are represented in the binary little-endian
+; (least-significant bit first) notation. The higher-order bit must be 1.
+; ()  represents 0
+; (1) represents 1
+; (0 1) represents 2
+; (1 1) represents 3
+; (0 0 1) represents 4
+; etc.
+;
+
+
+; There is a Prolog version of this code, which has termination proofs.
+;
+; $Id: pure-bin-arithm.scm,v 4.50 2005/02/12 00:04:49 oleg Exp $
+
+; Auxiliary functions to build and show binary numerals
+;
+(define (build n)
+  (if (zero? n) '() (cons (if (even? n) 0 1) (build (quotient n 2)))))
+
+(define (trans n)
+  (if (null? n) 0 (+ (car n) (* 2 (trans (cdr n))))))
+
+
+; (zeroo x) holds if x is zero numeral
+(define zeroo
+  (fact () '()))
+
+; Not a zero
+(define pos
+  (fact () `(,__ . ,__)))
+
+; At least two
+(define gt1
+  (fact () `(,__ ,__ . ,__)))
+
+; compare the lengths of two numerals
+; (<ol a b) 
+; holds if a=0 and b>0, or if (floor (log2 a)) < (floor (log2 b))
+; That is, we compare the length (logarithms) of two numerals
+; For a positive numeral, its bitlength = (floor (log2 n)) + 1
+; We also make sure that 'n' is a well-formed number.
+(define <ol
+  (extend-relation (n m)
+    (fact () '() `(,__ . ,__))
+    (fact () '(1) `(,__ ,__ . ,__))
+    (relation (x y x1 y1) (to-show `(,__ ,x1 . ,x) `(,__ ,y1 . ,y))
+      (<ol `(,x1 . ,x) `(,y1 . ,y)))))
+
+; holds if both a and b have the same number of bits, i.e., they are zero
+; or if (floor (log2 a)) = (floor (log2 b))
+(define =ol
+  (extend-relation (n m)
+    (fact () '() '())
+    (fact () '(1) '(1))
+    (relation (x y x1 y1) (to-show `(,__ ,x1 . ,x) `(,__ ,y1 . ,y))
+      (=ol `(,x1 . ,x) `(,y1 . ,y)))))
+
+; (<ol3 p1 p n m) holds iff
+; p1 = 0 and p > 0 or
+; length(p1) < min(length(p), length(n) + length(m) + 1)
+(define <ol3
+  (relation (head-let p1 p n m)
+    (any
+      (all (== p1 '()) (pos p))
+      (_exists (p1r pr)
+	(all
+	  (== p1 `(,__ . ,p1r))
+	  (== p  `(,__ . ,pr))
+	  (any-interleave
+	    (_exists (mr)
+	      (all (== n '()) (== m  `(,__ . ,mr)) 
+		(<ol3 p1r pr n mr)))
+	    (_exists (nr)
+	      (all (== n  `(,__ . ,nr)) 
+		(<ol3 p1r pr nr m)))
+	    ))))))
+
+; (<ol2 p n m) holds iff
+; length(n) + length(m) -1 <= length(p) <= length(n) + length(m)
+; This predicate has nice properties: see the corresponding Prolog
+; code for proofs.
+(define <ol2
+  (relation (head-let p n m)
+    (any-interleave
+      (all (== p '()) (== n '()) (== m '()))
+      (all (== p '()) (== n '()) (== m '(1)))
+      (all (== p '()) (== n '(1)) (== m '()))
+      (_exists (pr mr)
+	(all
+	  (== p `(,__ . ,pr)) (== n '()) (== m `(,__ . ,mr))
+	  (<ol2 pr '() mr)))
+      (_exists (pr nr)
+	(all
+	  (== p `(,__ . ,pr)) (== n `(,__ . ,nr))
+	  (<ol2 pr nr m)))
+      )))
+
+
+; Half-adder: carry-in a b r carry-out
+; The relation holds if
+; carry-in + a + b = r + 2*carry-out
+; where carry-in a b r carry-out are all either 0 or 1.
+
+(define half-adder
+  (extend-relation (carry-in a b r carry-out)
+    (fact () 0 0 0 0 0)
+    (fact () 0 1 0 1 0)
+    (fact () 0 0 1 1 0)
+    (fact () 0 1 1 0 1)
+
+    (fact () 1 0 0 1 0)
+    (fact () 1 1 0 0 1)
+    (fact () 1 0 1 0 1)
+    (fact () 1 1 1 1 1)
+))
+
+; full-adder: carry-in a b r
+; holds if carry-in + a + b = r
+; where a, b, and r are binary numerals and carry-in is either 0 or 1
+
+; We do the addition bit-by-bit starting from the least-significant
+; one. So, we have already two cases to consider per each number: The
+; number has no bits, and the number has some bits.
+
+; (define full-adder
+;   (extend-relation (carry-in a b r)
+;     (fact (a) 0 a '() a) 		; 0 + a + 0 = a
+;     (relation (b)			; 0 + 0 + b = b
+;       (to-show 0 '() b b)
+;       (pos b))
+;     (relation (head-let '1 a '() r)	; 1 + a + 0 = 0 + a + 1
+;       (full-adder 0 a '(1) r))
+;     (relation (head-let '1 '() b r)	; 1 + 0 + b = 0 + 1 + b
+;       (all (pos b)
+; 	(full-adder 0 '(1) b r)))
+; 
+;     ; The following three relations are needed
+;     ; to make all numbers well-formed by construction,
+;     ; that is, to make sure the higher-order bit is one.
+;     (relation (head-let carry-in '(1) '(1) r)	; c + 1 + 1 >= 2
+;       (_exists (r1 r2)
+; 	(all (== r `(,r1 ,r2))
+; 	     (half-adder carry-in 1 1 r1 r2))))
+; 
+;     ; cin + 1 + (2*br + bb) = (2*rr + rb) where br > 0 and so is rr > 0
+;     (relation (carry-in bb br rb rr)
+;       (to-show carry-in '(1) `(,bb . ,br) `(,rb . ,rr))
+;       (all
+; 	(pos br) (pos rr)
+; 	(_exists (carry-out)
+; 	  (all
+; 	    (half-adder carry-in 1 bb rb carry-out)
+; 	    (full-adder carry-out '() br rr)))))
+; 
+;     ; symmetric case for the above
+;     (relation (head-let carry-in a '(1) r)
+;       (all
+; 	(gt1 a) (gt1 r)
+; 	(full-adder carry-in '(1) a r)))
+; 
+;     ; carry-in + (2*ar + ab) + (2*br + bb) 
+;     ; = (carry-in + ab + bb) (mod 2)
+;     ; + 2*(ar + br + (carry-in + ab + bb)/2)
+;     ; The cases of ar= 0 or br = 0 have already been handled.
+;     ; So, now we require ar >0 and br>0. That implies that rr>0.
+;     (relation (carry-in ab ar bb br rb rr)
+;       (to-show carry-in `(,ab . ,ar) `(,bb . ,br) `(,rb . ,rr))
+;       (all
+; 	(pos ar) (pos br) (pos rr)
+; 	(_exists (carry-out)
+; 	  (all
+; 	    (half-adder carry-in ab bb rb carry-out)
+; 	    (full-adder carry-out ar br rr))))
+;     )))
+
+; After we have checked that  both summands have some bits, and so we
+; can decompose them the least-significant bit and the other ones, it appears
+; we only need to consider the general case, the last relation in
+; the code above.
+; But that is not sufficient. Let's consider
+;	(full-adder 0 (1 . ()) (1 0 . ()) (0 1 . ()))
+; It would then hold. But it shouldn't, because (1 0 . ()) is a bad
+; number (with the most-significant bit 0). One can say why we should
+; care about user supplying bad numbers. But we do: we don't know which
+; arguments of full-adder are definite numbers and which are
+; uninstantiated variables. We don't know which are the input and which
+; are the output. So, if we keep only the last relation for the
+; case of positive summands, and try to
+;	(_exists (x) (full-adder 0 (1 . ()) x (0 1 . ())))
+; we will see x bound to (1 0) -- an invalid number. So, our adder, when
+; asked to subtract numbers, gave a bad number. And it would give us
+; a bad number in all the cases when we use it to subtract numbers and
+; the result has fewer bits than the number to subtract from. 
+;
+; To guard against such a behavior (i.e., to transparently normalize
+; the numbers when the full-adder is used in the ``subtraction'' mode)
+; we have to specifically distinguish cases of 
+; "bit0 + 2*bit_others" where bit_others>0, and the
+; terminal case "1" (that is, the most significant bit 1 and no other
+; bits).
+; The various (pos ...) conditions in the code are to guarantee that all
+; cases are disjoin. At any time, only one case can match. Incidentally,
+; the lack of overlap guarantees the optimality of the code.
+
+
+; The full-adder above is not recursively enumerating however.
+; Indeed, (solve 10 (x y z) (full-adder '0 x y z))
+; gives solutions with x = 1.
+; We now convert the adder into a recursively enumerable form.
+; We lose some performance however (but see below!)
+;
+; The general principles are:
+; Convert the relation into a disjunctive normal form, that is
+;  (any (all a b c) (all c d e) ...)
+; and then replace the single, top-level any with any-interleave.
+; The conversion may be too invasive. We, therefore, use an effective
+; conversion: if we have a relation
+; (all (any a b) (any c d))
+; then rather than re-writing it into
+; (any (all a c) (all a d) (all b c) (all b d))
+; to push disjunctions out and conjunctions in, we do
+; (all gen (all (any a b) (any c d)))
+; where gen is a relation whose answer set is precisely such
+; that each answer in gen makes (all (any a b) (any c d))
+; semi-deterministic. That is, with the generator gen, we
+; make all the further choices determined.
+;
+; In the code below we use a different kind of generator, whose full
+; justification (with proofs) appears in the Prolog version of the code.
+; Please see the predicate `enum' in that Prolog code.
+;
+; The price to pay is slow-down.
+; Note, if we had all-interleave, then we would generally have
+; breadth-first search and so the changes to the recursively enumerable
+; version would be minimal and without loss of speed.
+
+; The following full-adder* is almost the same as full-adder above.
+; 
+; (define full-adder*
+;   (extend-relation (carry-in a b r)
+; ;     (fact (a) 0 a '() a) 		; 0 + a + 0 = a
+; ;     (relation (b)			; 0 + 0 + b = b
+; ;       (to-show 0 '() b b)
+; ;       (pos b))
+; ;     (relation (head-let '1 a '() r)	; 1 + a + 0 = 0 + a + 1
+; ;       (full-adder 0 a '(1) r))
+; ;     (relation (head-let '1 '() b r)	; 1 + 0 + b = 0 + 1 + b
+; ;       (all (pos b)
+; ; 	(full-adder 0 '(1) b r)))
+; 
+;     ; The following three relations are needed
+;     ; to make all numbers well-formed by construction,
+;     ; that is, to make sure the higher-order bit is one.
+;     (relation (head-let carry-in '(1) '(1) r)	; c + 1 + 1 >= 2
+;       (_exists (r1 r2)
+; 	(all (== r `(,r1 ,r2))
+; 	     (half-adder carry-in 1 1 r1 r2))))
+; 
+;     ; cin + 1 + (2*br + bb) = (2*rr + rb) where br > 0 and so is rr > 0
+;     (relation (carry-in bb br rb rr)
+;       (to-show carry-in '(1) `(,bb . ,br) `(,rb . ,rr))
+;       (all
+; 	(pos br) (pos rr)
+; 	(_exists (carry-out)
+; 	  (all
+; 	    (half-adder carry-in 1 bb rb carry-out)
+; 	    (full-adder carry-out '() br rr)))))
+; 
+;     ; symmetric case for the above
+;     (relation (head-let carry-in a '(1) r)
+;       (all
+; 	(gt1 a) (gt1 r)
+; 	(full-adder* carry-in '(1) a r)))
+; 
+;     ; carry-in + (2*ar + ab) + (2*br + bb) 
+;     ; = (carry-in + ab + bb) (mod 2)
+;     ; + 2*(ar + br + (carry-in + ab + bb)/2)
+;     ; The cases of ar= 0 or br = 0 have already been handled.
+;     ; So, now we require ar >0 and br>0. That implies that rr>0.
+;     (relation (carry-in ab ar bb br rb rr)
+;       (to-show carry-in `(,ab . ,ar) `(,bb . ,br) `(,rb . ,rr))
+;       (all
+; 	(pos ar) (pos br) (pos rr)
+; 	(_exists (carry-out)
+; 	  (all
+; 	    (half-adder carry-in ab bb rb carry-out)
+; 	    (full-adder* carry-out ar br rr))))
+;     )))
+
+; This driver handles the trivial cases and then invokes full-adder*
+; coupled with the recursively enumerating generator.
+
+; (define full-adder
+;   (extend-relation (carry-in a b r)
+;     (fact (a) 0 a '() a) 		; 0 + a + 0 = a
+;     (relation (b)			; 0 + 0 + b = b
+;       (to-show 0 '() b b)
+;       (pos b))
+;     (relation (head-let '1 a '() r)	; 1 + a + 0 = 0 + a + 1
+;       (full-adder 0 a '(1) r))
+;     (relation (head-let '1 '() b r)	; 1 + 0 + b = 0 + 1 + b
+;       (all (pos b)
+; 	(full-adder 0 '(1) b r)))
+;     (relation (head-let carry-in a b r)
+;       (any-interleave
+; 	; Note that we take advantage of the fact that if
+; 	; a + b = r and length(b) <= length(a) then length(a) <= length(r)
+; 	(all (<ol a `(,_ . ,r))		; or, length(a) < length(2*r)
+; 	  (any (<ol b a) (=ol b a))
+; 	  (full-adder* carry-in a b r))
+; 	; commutative case, length(a) < length(b)
+; 	(all (<ol b `(,_ . ,r))
+; 	  (<ol a b)
+; 	  (full-adder* carry-in a b r))
+; 	))))
+
+; There is the third way of doing the addition, using
+; all-interleave and any-interleave.
+; Note that the code below is almost identical to the very first,
+; non-recursively enumerating full-adder, only
+; extend-relation is replaced with extend-relation-interleave
+; and all is replaced with all-interleave in two places.
+; The results are amazing, as the tests below show.
+; For example, the test "print a few numbers that are greater than 4"
+; shows that the numbers are generated _in sequence_, despite
+; our addition being binary (and so one would expect the numbers
+; being generated in Gray code or so).
+; Also, tests multiplication-all-3 and multiplication-all-4
+; show that (**o (build 3) y z) and (**o y (build 3) z)
+; generates the _same_ answerlist, and in that answerlist, 'y' appears
+; in sequence: 0,1,2....
+
+
+(define-rel-lifted-comb extend-relation-interleave any-interleave)
+
+(define full-adder
+  (extend-relation-interleave (carry-in a b r)
+    (fact (a) 0 a '() a) 		; 0 + a + 0 = a
+    (relation (b)			; 0 + 0 + b = b
+      (to-show 0 '() b b)
+      (pos b))
+    (relation (head-let '1 a '() r)	; 1 + a + 0 = 0 + a + 1
+      (full-adder 0 a '(1) r))
+    (relation (head-let '1 '() b r)	; 1 + 0 + b = 0 + 1 + b
+      (all (pos b)
+	(full-adder 0 '(1) b r)))
+
+    ; The following three relations are needed
+    ; to make all numbers well-formed by construction,
+    ; that is, to make sure the higher-order bit is one.
+    (relation (head-let carry-in '(1) '(1) r)	; c + 1 + 1 >= 2
+      (_exists (r1 r2)
+	(all (== r `(,r1 ,r2))
+	     (half-adder carry-in 1 1 r1 r2))))
+
+    ; cin + 1 + (2*br + bb) = (2*rr + rb) where br > 0 and so is rr > 0
+    (relation (carry-in bb br rb rr)
+      (to-show carry-in '(1) `(,bb . ,br) `(,rb . ,rr))
+      (all
+	(pos br) (pos rr)
+	(_exists (carry-out)
+	  (all-interleave
+	    (half-adder carry-in 1 bb rb carry-out)
+	    (full-adder carry-out '() br rr)))))
+
+    ; symmetric case for the above
+    (relation (head-let carry-in a '(1) r)
+      (all
+	(gt1 a) (gt1 r)
+	(full-adder carry-in '(1) a r)))
+
+    ; carry-in + (2*ar + ab) + (2*br + bb) 
+    ; = (carry-in + ab + bb) (mod 2)
+    ; + 2*(ar + br + (carry-in + ab + bb)/2)
+    ; The cases of ar= 0 or br = 0 have already been handled.
+    ; So, now we require ar >0 and br>0. That implies that rr>0.
+    (relation (carry-in ab ar bb br rb rr)
+      (to-show carry-in `(,ab . ,ar) `(,bb . ,br) `(,rb . ,rr))
+      (all
+	(pos ar) (pos br) (pos rr)
+	(_exists (carry-out)
+	  (all-interleave
+	    (half-adder carry-in ab bb rb carry-out)
+	    (full-adder carry-out ar br rr))))
+    )))
+
+; a + b = c
+(define a++o
+  (relation (head-let a b c)
+    (full-adder 0 a b c)))
+
+; a - b = c
+(define a--o
+  (lambda (x y out)
+    (a++o y out x)))
+
+
+;(define <o  ; n < m iff _exists x >0 such that n + x = m
+;  (relation (head-let n m)
+;    (_exists (x) (all (pos x) (a++o n x m)))))
+
+; The following is an optimization: it is easier to test for the
+; length of two numbers. If one number has fewer bits than the other number,
+; the former is clearly shorter (provided that the numbers are well-formed,
+; that is, the higher-order bit is one). So we don't need to go through
+; the trouble of subtracting them.
+(define <o  ; n < m iff _exists x >0 such that n + x = m
+  (relation (head-let n m)
+    (any-interleave
+      (<ol n m)
+      (all (=ol n m)
+	(_exists (x) (all (pos x) (a++o n x m)))))))
+
+
+; n * m = p
+(define **o
+  (relation (head-let n m p)
+    (any-interleave
+      (all (zeroo n) (== p '()))		; 0 * m = 0
+      (all (zeroo m) (pos n) (== p '()))	; n * 0 = 0
+      (all (== n '(1)) (pos m) (== m p))        ; 1 * m = m
+      (all (== m '(1)) (gt1 n) (== n p))        ; n * 1 = n, n>1
+
+      ; (2*nr) * m = 2*(nr*m), m>0 (the case of m=0 is taken care of already)
+      ; nr > 0, otherwise the number is ill-formed
+      (_exists (nr pr)
+	(all
+	  (gt1 m)
+	  (== n `(0 . ,nr))
+	  (== p `(0 . ,pr))
+	  (pos nr) (pos pr)
+	  (**o nr m pr)))
+
+      ; The symmetric case to the above: m is even, n is odd
+      (_exists (mr pr)
+	(all
+	  (== n `(1 ,__ . ,__))		; n is odd and n > 1
+	  (== m `(0 . ,mr))
+	  (== p `(0 . ,pr))
+	  (pos mr) (pos pr)
+	  (**o n mr pr)))
+
+      ; (2*nr+1) * m = 2*(n*m) + m
+      ; m > 0; also nr>0 for well-formedness
+      ; the result is certainly greater than 1.
+      ; we note that m > 0 and so 2*(nr*m) < 2*(nr*m) + m
+      ; and (floor (log2 (nr*m))) < (floor (log2 (2*(nr*m) + m)))
+      (_exists (nr p1)
+	(all
+	  (== m `(1 ,__ . ,__))		; m is odd and n > 1
+	  (== n `(1 . ,nr))
+	  (pos nr) (gt1 p)
+	  (<ol3 p1 p n m)
+	  (**o nr m p1)
+	  (a++o `(0 . ,p1) m p)))
+)))
+
+; n = q*m + r
+; where 0<=r<m
+
+; This is divo from pure-arithm.scm
+; it still works -- but very slow for some operations
+; because <o takes linear time...
+
+;(define divo
+;  (relation (head-let n m q r)
+;    (any-interleave
+;      (all (== q '()) (== r n) (<o n m))      ; if n < m, then q=0, n=r
+;      (all (== n m) (== q '(1)) (== r '()))  ; n = 1*n + 0
+;      (_exists (p)
+;	(all (<o m n) (<o r m)  (a++o p r n) ;(trace-vars 1 (p r n))
+;	  (**o q m p))))))
+
+; A faster divo algorithm
+; 
+; (define divo
+;   (relation (head-let n m q r)
+;     (any-interleave
+;       (all (== r n) (== q '()) (<ol n m) (<o n m)) ; m has more digits than n: q=0,n=r
+;       (all
+; 	(<ol m n)			; n has mode digits than m
+; 					; q is not zero, n>0, so q*m <= n,
+; 	(_exists (p)			; definitely q*m < 2*n
+; 	  (all (<o r m) (<ol p `(0 . ,n))
+; 	    (a++o p r n) ;(trace-vars 1 (p r n))
+; 	    (**o q m p)))
+; 	)
+;       ; n has the same number of digits than m
+;       (all (== q '(1)) (=ol n m) (a++o r m n) (<o r m))
+;       (all (== q '()) (== r n) (=ol n m) (<o n m))  ; if n < m, then q=0, n=r
+;       )))
+; ; 	(any-interleave
+; ; 	  (all (== m '(1)) (== r '()) (== n q)) ; n = n*1 + 0
+; ; 	  ; For even divisors:
+; ; 	  ; n = (2*m)*q + r => (n - r) is even and (n-r)/2 = m*q
+; ; 	  (_exists (p m1)
+; ; 	    (all (== m `(0 . ,m1))
+; ; 	         (== m1 `(__, . ,__))
+; ; 	         (**o m1 q p)
+; ; 	         (a--o n r `(0 . ,p))))
+; 
+
+; A faster and more refutationally complete divo algorithm
+; Again, divo n m q r 
+; holds iff n = m*q + r
+; Let l be the bit-length of r (if r=0, l=0).
+; Let n = 2^(l+1) * n1 + n2
+;     q = 2^(l+1) * q1 + q2
+; Note that n1 or q1 may be zero.
+; We obtain that
+;    n = m*q + r
+; is equivalent to the conjunction of the following two relations
+;    q2*m + r - n2 is divisible by 2^(l+1)
+;    n1 = q1*m + (q2*m + r - n2)/2^(l+1)
+; We note that by construction (see the mentioning of (<ol m n) below)
+; all numbers in 'q2*m + r - n2' are length-limited. Therefore, we can
+; obtain the success or failure of 'q2*m + r - n2' in finite time.
+; This fact let us fail the 'divo' relation, in finite time,
+; when it obviously does not hold, as in
+;	(divo `(0 . ,x) (build 2) q '(1))
+; (because no even number can give the remainder 1 upon the 
+; division by two).
+;
+; We should note that if n1=0, we obtain that q1 must be zero
+; (because m>0) and q2*m + r = n2. The latter can be solved in finite
+; time.
+; We also note that (q2*m + r - n2)/2^(l+1) < m
+; because r - n2 < (2^(l+1) - q2)* m
+; because 2^(l+1) - q2 >=1 and m > r by construction. Therefore, to
+; solve the relation n1 = q1*m + (q2*m + r - n2)/2^(l+1) we use
+; divo itself: (divo n1 m q1 (q2*m + r - n2)/2^(l+1))
+; Thus our division algorithm is recursive. On each stage we determine at
+; least one bit of the quotient (if r=0, l=0 and q2 is either 0 or 1),
+; in finite time.
+
+(define divo
+  (relation (head-let n m q r)
+    (any-interleave
+	; m has more digits than n: q=0,n=r
+      (all (== r n) (== q '()) (<o n m)) ; if n < m, then q=0, n=r
+      ; n is at least m and has the same number of digits than m
+      (all (== q '(1)) (=ol n m) (a++o r m n) (<o r m))
+      (all-interleave
+	(<ol m n)			; n has more digits than m
+					; Note that m is L-instantiated here
+	(<o r m)			; r is L-instantiated
+	(pos q)				; q must be positive then
+	(_exists (n1 n2 q1 q2 q2m q2mr rr r1)
+	  (all-interleave
+	    (split n r n1 n2)
+	    (split q r q1 q2)
+	    (any
+	      (all
+		(== n1 '())
+		(== q1 '())
+		(a--o n2 r q2m)
+		(**o q2 m q2m))			; provably terminates
+	      (all-interleave (pos n1) 
+		(**o q2 m q2m)
+		(a++o q2m r q2mr)
+		(a--o q2mr n2 rr)		; rr = q2*m + r - n2
+		(split rr r r1 '())		; r1 = rr/2^(l+1), evenly
+		(divo n1 m q1 r1)))))
+	)
+      )))
+
+; split n r n1 n2
+; holds if n = 2^(l+1)*n1 + n2 where l = bitlength(r)
+; This relation makes sense to use only when 'r' is L-instantiated
+; (see the Prolog code file for the definition of L-instantiated).
+; In that case, the relation has only the finite number of answers, in
+; all of which n2 is L-instatantiated.
+; We take trouble to assure that we produce only well-formed numbers:
+; the major bit must be one.
+
+(define split
+  (extend-relation-interleave (n r n1 n2)
+    (fact () '() __ '() '())
+    (fact (b n) `(0 ,b . ,n) '() `(,b . ,n) '())
+    (fact (n) `(1 . ,n) '() n '(1))
+    (relation (b n r n1)
+      (to-show `(0 ,b . ,n) `(,__ . ,r) n1 '())
+      (split `(,b . ,n) r n1 '()))
+    (relation (n r n1)
+      (to-show `(1 . ,n) `(,__ . ,r) n1 '(1))
+      (split n r n1 '()))
+    (relation (b n r n1 n2)
+      (to-show `(,b . ,n) `(,__ . ,r) n1 `(,b . ,n2))
+      (all (pos n2)
+	(split n r n1 n2)))
+))
+
+
+; Exponentiation and discrete logarithm
+; n = b^q + r, where 0 <= r and q is the largest such integer
+;
+; From the above condition we obtain the upper bound on r:
+; n >= b^q, n < b^(q+1) = b^q * b = (n-r)* b 
+; r*b < n*(b-1)
+;
+; We can also obtain the bounds on q:
+; if |b| is the bitwidth of b and |n| is the bitwidth of n,
+; we have, by the definition of the bitwidth:
+;  (1) 2^(|b|-1) <= b < 2^|b|
+;  (2) 2^(|n|-1) <= n < 2^|n|
+; Raising (1) to the power of q:
+;      2^((|b|-1)*q) <= b^q
+; OTH, b^q <= n, and n < 2^|n|. So we obtain
+;  (3)   (|b|-1)*q < |n|
+; which defines the upper bound on |q|.
+; OTH, raising (1) to the power of (q+1):
+;    b^(q+1) < 2^(|b|*(q+1))
+; But n < b^(q+1) by definition of exponentiation, and keeping in mind (1)
+; (4) |n|-1 < |b|*(q+1)
+; which is the lower bound on q.
+
+; When b = 2, exponentiation and discrete logarithm are easier to obtain
+; n = 2^q + r, 0<= 2*r < n
+; Here, we just relate n and q.
+;    exp2 n b q
+; holds if: n = (|b|+1)^q + r, q is the largest such number, and
+; (|b|+1) is a power of two.
+; Side condition: (|b|+1) is a power of two and b is L-instantiated.
+; To obtain the binary exp/log relation, invoke the relation as
+;  (exp2 n '() q)
+; Properties: if n is L-instantiated, one answer, q is fully instantiated.
+; If q is fully instantiated: one answer, n is L-instantiated.
+; In any event, q is always fully instantiated in any answer
+; and n is L-instantiated.
+; We depend on the properties of split.
+
+(define exp2
+  (letrec
+    ((r-append				; relational append
+       (extend-relation (a b c)
+	 (fact (b) '() b b)
+	 (relation (ah ar b cr) (to-show `(,ah . ,ar) b `(,ah . ,cr))
+	   (r-append ar b cr)))))
+  (relation (head-let n b q)
+    (any-interleave
+      (all (== n '(1)) (== q '()))  ; 1 = b^0
+      (all (gt1 n) (== q '(1)) (split n b '(1) __))
+      (_exists (q1 b2)			; n = (2^k)^(2*q) + r
+	(all-interleave                 ;   = (2^(2*k))^q + r
+	     (== q `(0 . ,q1))
+	     (pos q1)
+	     (<ol b n)
+	     (r-append b `(1 . ,b) b2)
+	     (exp2 n b2 q1)))
+      (_exists (q1 n1 b2)		; n = (2^k)^(2*q+1) + r
+	(all-interleave 		; n/(2^k) = (2^(2*k))^q + r'
+	     (== q `(1 . ,q1))
+	     (pos q1)
+	     (pos n1)
+	     (split n b n1 __)
+	     (r-append b `(1 . ,b) b2)
+	     (exp2 n1 b2 q1)))
+      )))
+)
+
+
+; nq = n^q where n is L-instantiated and q is fully instantiated
+(define repeated-mul
+  (extend-relation (n q nq)
+    (fact () `(,__ . ,__) '() '(1))
+    (fact (n) n '(1) n)
+    (relation (head-let n q nq)
+      (all
+	(gt1 q)
+	(_exists (q1 nq1)
+	  (all
+	    (a++o q1 '(1) q)
+	    (repeated-mul n q1 nq1)
+	    (**o nq1 n nq)))))))
+
+; We call this predicate logo rather than expo due to its close similarity
+; to divo. As the tests at the end show, logo can be used for determining
+; the exact discrete logarithm, logarithm with a residual, exponentiation,
+; and even operations (such as determining the base) that are not
+; commonly discussed in high school.
+(define logo
+  (relation (head-let n b q r)
+    (any-interleave
+      (all (== n '(1)) (pos b) (== q '()) (== r '())) ; 1 = b^0 + 0, b >0
+      (all (== q '())  (<o n b)  (a++o r '(1) n)) ; n = b^0 + (n-1)
+	; n = b + r, n and b the same sz
+      (all (== q '(1)) (gt1 b) (=ol n b) (a++o r b n))
+      (all (== b '(1)) (pos q) (a++o r '(1) n))  ; n = 1^q + (n-1), q>0
+      (all (== b '()) (pos q) (== r n))         ; n = 0^q + n, q>0
+      ; in the rest, n is longer than b
+      (all (== b '(0 1))		; b = 2
+	   (_exists (n1)
+	     (all
+	       (pos n1)
+	       (== n `(,__ ,__ . ,n1))    ; n is at least 4
+	       (exp2 n '() q)		; that will L-instantiate n and n1
+	       (split n n1 __ r))))
+      ; the general case
+      (all
+	(any (== b '(1 1)) (== b `(,__ ,__ ,__ . ,__))) ; b >= 3
+	(<ol b n)			; b becomes L-instantiated
+	                                ; If b was L-instantiated, the previous
+					; goal had only *one* answer
+	(_exists (bw nw nw1 bw1 ql1 ql qh qdh qd bql bqd bq bq1)
+	 (all
+	  (exp2 b '() bw1)
+	  (a++o bw1 '(1) bw)
+	  (<ol q n)			; A _very_ lose bound, but makes
+					; sure q will be L-instatiated
+					; Now, we can use b and q to bound n
+					; |n|-1 < |b|*(q+1)
+	  (_exists (q1 bwq1)
+	    (all
+	      (a++o q '(1) q1)
+	      (**o bw q1 bwq1)		; |b|*(q+1)
+	      (<o nw1 bwq1)))
+	  (exp2 n '() nw1)		; n becomes L-instantiated
+					; Now we have only finite number of ans
+	  (a++o nw1 '(1) nw)
+	  (divo nw bw ql1 __)		; low boundary on q:
+	  (a++o ql '(1) ql1)		; |n| = |b|(ql+1) + c
+	  (any (== q ql) (<ol ql q))	; Tighten the estimate for q
+	  (repeated-mul b ql bql)	; bql = b^ql
+	  (divo nw bw1 qh __)		; upper boundary on q-1
+	  (a++o ql qdh qh)
+	  (a++o ql qd q)
+	  (any (== qd qdh) (<o qd qdh)) ; qd is bounded
+	  (repeated-mul b qd bqd)	; b^qd
+	  (**o bql bqd bq)		; b^q
+	  (**o b   bq  bq1)		; b^(q+1)
+	  (a++o bq r n)
+	  (<o n bq1)			; check the r condition
+	  ))))))
+
+	
+
+
+;------------------------------------------------------------------------
+;				Tests
+
+
+(define-syntax test
+  (syntax-rules ()
+    ((_ (x) gl)
+      (query (redok subst x) gl
+	(display (trans (subst-in x subst)))
+	(newline)))))
+
+(define (subset? l1 l2)
+  (or (null? l1)
+    (and (member (car l1) l2) (subset? (cdr l1) l2))))
+(define (set-equal? l1 l2) (or (subset? l1 l2) (subset? l2 l1)))
+
+(define (pure-bin-arith-tests)  
+(cout nl "addition" nl)
+(test (x) (a++o (build 29) (build 3) x))
+(test (x) (a++o (build 3) x (build 29)))
+(test (x) (a++o x (build 3) (build 29)))
+(test-check "all numbers that sum to 4"
+  (solve 10 (w)
+    (_exists (y z)
+      (all (a++o y z (build 4))
+	(project (y z) (== `(,(trans y) ,(trans z)) w)))))
+   '(((w.0 (4 0)))
+     ((w.0 (0 4)))
+     ((w.0 (1 3)))
+     ((w.0 (3 1)))
+     ((w.0 (2 2)))
+     )
+  )
+(test-check "print a few numbers such as X + 1 = Y"
+  (solve 5 (x y) (a++o x (build 1) y))
+   '(((x.0 ()) (y.0 (1))) ; 0 + 1 = 1
+     ((x.0 (1)) (y.0 (0 1))) ; 1 + 1 = 2
+       ; 2*x and 2*x+1 are successors, for all x>0!
+      ((x.0 (0 _.0 . _.1)) (y.0 (1 _.0 . _.1)))
+      ((x.0 (1 1)) (y.0 (0 0 1)))
+      ((x.0 (1 0 _.0 . _.1)) (y.0 (0 1 _.0 . _.1))))
+)
+
+; check that add(X,Y,Z) recursively enumerates all
+; numbers such as X+Y=Z
+;
+(cout "Test recursive enumerability of addition" nl)
+(let ((n 7))
+  (do ((i 0 (+ 1 i))) ((> i n))
+    (do ((j 0 (+ 1 j))) ((> j n))
+      (let ((p (+ i j)))
+	(test-check
+	  (string-append "enumerability: " (number->string i)
+	    "+" (number->string j) "=" (number->string p))
+	  (solve 1 (x y z) 
+	    (all (a++o x y z)
+	      (== x (build i)) (== y (build j)) (== z (build p))))
+	  `(((x.0 ,(build i)) (y.0 ,(build j))
+	      (z.0 ,(build p)))))))))
+
+(test-check "strong commutativity"
+  (solve 5 (a b c)
+    (all (a++o a b c)
+    (_exists (x y z)
+      (all!
+	(a++o x y z)
+	(== x b)
+	(== y a)
+	(== z c)
+	))))
+  '(((a.0 ()) (b.0 ()) (c.0 ()))
+    ((a.0 ()) (b.0 (_.0 . _.1)) (c.0 (_.0 . _.1)))
+    ((a.0 (1)) (b.0 (1)) (c.0 (0 1)))
+    ((a.0 (1)) (b.0 (0 _.0 . _.1)) (c.0 (1 _.0 . _.1)))
+    ((a.0 (0 _.0 . _.1)) (b.0 (1)) (c.0 (1 _.0 . _.1))))
+)
+
+
+(cout nl "subtraction" nl)
+(test (x) (a--o (build 29) (build 3) x))
+(test (x) (a--o (build 29) x (build 3)))
+(test (x) (a--o x (build 3) (build 26)))
+(test (x) (a--o (build 29) (build 29) x))
+(test (x) (a--o (build 29) (build 30) x))
+(test-check "print a few numbers such as Y - Z = 4"
+  (solve 11 (y z) (a--o y z (build 4)))
+  '(((y.0 (0 0 1)) (z.0 ()))    ; 4 - 0 = 4
+    ((y.0 (1 0 1)) (z.0 (1)))   ; 5 - 1 = 4
+    ((y.0 (0 1 1)) (z.0 (0 1))) ; 6 - 2 = 4
+    ((y.0 (1 1 1)) (z.0 (1 1))) ; 7 - 3 = 4
+    ((y.0 (0 0 0 1)) (z.0 (0 0 1))) ; 8 - 4 = 4
+    ((y.0 (1 0 0 1)) (z.0 (1 0 1)))  ; 9 - 5 = 4
+    ((y.0 (0 1 0 1)) (z.0 (0 1 1)))  ; 10 - 6 = 4
+    ((y.0 (1 1 0 1)) (z.0 (1 1 1)))  ; 11 - 7 = 4
+     ; 8*k + 4 - 8*k = 4 forall k> 0!!
+    ((y.0 (0 0 1 _.0 . _.1)) (z.0 (0 0 0 _.0 . _.1)))
+    ((y.0 (1 0 1 _.0 . _.1)) (z.0 (1 0 0 _.0 . _.1)))
+    ((y.0 (0 1 1 _.0 . _.1)) (z.0 (0 1 0 _.0 . _.1))))
+)
+
+(test-check "print a few numbers such as X - Y = Z"
+  (solve 5 (x y z) (a--o x y z))
+  '(((x.0 _.0) (y.0 _.0) (z.0 ())) ; 0 - 0 = 0
+    ((x.0 (_.0 . _.1)) (y.0 ()) (z.0 (_.0 . _.1))) ; a - 0 = a
+    ((x.0 (0 1)) (y.0 (1)) (z.0 (1)))
+    ((x.0 (1 _.0 . _.1)) (y.0 (1)) (z.0 (0 _.0 . _.1)))
+    ((x.0 (1 _.0 . _.1)) (y.0 (0 _.0 . _.1)) (z.0 (1))))
+)
+
+
+(cout nl "comparisons" nl)
+(test (x) (<o x (build 4)))
+(test (x) (all (== x (build 3)) (<o x (build 4))))
+(test (x) (all (== x (build 4)) (<o x (build 3))))
+(test-check "print all numbers that are less than 6"
+  (solve 10 (x) (<o x (build 6)))
+  '(((x.0 ())) ((x.0 (1 0 1))) ((x.0 (1))) 
+     ((x.0 (0 0 1))) ((x.0 (_.0 1))))
+  )
+
+(test-check "print *all* numbers that are greater than 4"
+  (solve 10 (x) (<o (build 4) x))
+  '(((x.0 (_.0 _.1 _.2 _.3 . _.4)))
+    ((x.0 (1 0 1))) ((x.0 (0 1 1))) ((x.0 (1 1 1))))
+)
+
+
+
+(cout nl "multiplication" nl)
+(test (x) (**o (build 2) (build 3) x))
+(test (x) (**o (build 3) x (build 12)))
+(test (x) (**o x (build 3) (build 12)))
+(test (x) (**o x (build 5) (build 12)))
+(test (x) (all (== x (build 2)) (**o x (build 2) (build 4))))
+(test-check 'multiplication-fail-1
+  (test (x) (all (== x (build 3)) (**o x (build 2) (build 4))))
+  '())
+(test-check 'multiplication-all-1
+  (solve 7 (w) 
+    (_exists (y z) (all (**o y z (build 6))
+		    (project (y z) (== `(,(trans y) ,(trans z)) w)))))
+  '(((w.0 (1 6))) ((w.0 (6 1))) ((w.0 (2 3)))  ((w.0 (3 2)))))
+
+; Only one answer
+(test-check 'multiplication-all-2
+  (solve 7 (w) 
+    (_exists (x)
+      (all (**o (build 3) (build 2) x)
+	(project (x) (== (trans x) w)))))
+  '(((w.0 6))))
+
+(test-check 'multiplication-all-3
+  (solve 7 (y z) (**o (build 3) y z))
+  '(((y.0 ()) (z.0 ()))  ; 0 * 3 = 0
+    ((y.0 (1)) (z.0 (1 1))) ; 1 * 3 = 3
+    ((y.0 (0 1)) (z.0 (0 1 1))) ; 2 * 3 = 6
+    ((y.0 (1 1)) (z.0 (1 0 0 1))) ; 3 * 3 = 9
+    ((y.0 (0 0 1)) (z.0 (0 0 1 1))) ; 4 * 3 = 12
+    ((y.0 (1 0 1)) (z.0 (1 1 1 1))) ; 5 * 3 = 15
+    ((y.0 (0 1 1)) (z.0 (0 1 0 0 1)))) ; 6 * 3 = 18
+)
+
+; Just as above
+(test-check 'multiplication-all-4
+  (solve 7 (y z) (**o y (build 3) z))
+  '(((y.0 ()) (z.0 ()))
+    ((y.0 (1)) (z.0 (1 1)))
+    ((y.0 (0 1)) (z.0 (0 1 1)))
+    ((y.0 (1 1)) (z.0 (1 0 0 1)))
+    ((y.0 (0 0 1)) (z.0 (0 0 1 1)))
+    ((y.0 (1 0 1)) (z.0 (1 1 1 1)))
+    ((y.0 (0 1 1)) (z.0 (0 1 0 0 1))))
+)
+
+(test-check 'multiplication-all-5
+  (solve 7 (x y z) (**o x y z))
+  '(((x.0 ()) (y.0 _.0) (z.0 ())) ; 0 * y = 0 for any y whatsoever
+    ((x.0 (_.0 . _.1)) (y.0 ()) (z.0 ())) ; x * 0 = 0 for x > 0
+     ; 1 * y = y for y > 0
+    ((x.0 (1)) (y.0 (_.0 . _.1)) (z.0 (_.0 . _.1)))
+    ((x.0 (_.0 _.1 . _.2)) (y.0 (1)) 
+      (z.0 (_.0 _.1 . _.2))) ;  x * 1 = x, x > 1
+     ; 2 * y = even positive number, for y > 1
+    ((x.0 (0 1)) (y.0 (_.0 _.1 . _.2)) 
+      (z.0 (0 _.0 _.1 . _.2)))
+     ; x * 2 = shifted-left x, for even x>1
+    ((x.0 (1 _.0 . _.1)) (y.0 (0 1)) (z.0 (0 1 _.0 . _.1)))
+     ; 3 * 3 = 9
+    ((x.0 (1 1)) (y.0 (1 1)) (z.0 (1 0 0 1)))
+    )
+)
+
+(test-check 'multiplication-even-1
+  (solve 10 (y z) (**o (build 2) y z))
+  '(((y.0 ()) (z.0 ()))
+    ((y.0 (1)) (z.0 (0 1))) ; 2 * 1 = 2
+     ; 2*y is an even number, for any y > 1!
+    ((y.0 (_.0 _.1 . _.2)) (z.0 (0 _.0 _.1 . _.2)))
+     )
+)
+
+(test-check 'multiplication-even-2
+  ; multiplication by an even number cannot yield an odd number
+  (solution (q x y u v) (**o '(1 1) `(0 0 1 ,x . ,y) `(1 0 0 ,u . ,v)))
+  #f
+)
+
+(test-check 'multiplication-even-3
+  ; multiplication by an even number cannot yield an odd number
+  (solution (q x y z) (**o `(0 0 1 . ,y) `(1 . ,x) `(1 0 . ,z)))
+  #f
+)
+
+; check that mul(X,Y,Z) recursively enumerates all
+; numbers such as X*Y=Z
+;
+(cout "Test recursive enumerability of multiplication" nl)
+(let ((n 7))
+  (do ((i 0 (+ 1 i))) ((> i n))
+    (do ((j 0 (+ 1 j))) ((> j n))
+      (let ((p (* i j)))
+	(test-check
+	  (string-append "enumerability: " (number->string i)
+	    "*" (number->string j) "=" (number->string p))
+	  (solve 1 (x y z) 
+	    (all (**o x y z)
+	      (== x (build i)) (== y (build j)) (== z (build p))))
+	  `(((x.0 ,(build i)) (y.0 ,(build j))
+	      (z.0 ,(build p)))))))))
+
+(cout nl "split" nl)
+
+(test-check 'split-1
+  (solve 5 (x y) (split (build 4) '() x y))
+  '(((x.0 (0 1)) (y.0 ()))))
+(test-check 'split-2
+  (solve 5 (x y) (split (build 4) '(1) x y))
+  '(((x.0 (1)) (y.0 ()))))
+(test-check 'split-3
+  (solve 5 (x y) (split (build 4) '(1 1) x y))
+  '(((x.0 ()) (y.0 (0 0 1)))))
+(test-check 'split-4
+  (solve 5 (x y) (split (build 4) '(1 1 1) x y))
+  '(((x.0 ()) (y.0 (0 0 1)))))
+(test-check 'split-5
+  (solve 5 (x y) (split (build 5) '(1) x y))
+  '(((x.0 (1)) (y.0 (1)))))
+(test-check 'split-6
+  (solve 5 (n) (split n (build 5) '() '(1)))
+  '(((n.0 (1)))))
+
+(cout nl "division, general" nl)
+
+
+(test-check 'divo-1
+  (solution (x) (divo (build 4) (build 2) x __))
+  '((x.0 (0 1))))
+(test-check 'div-fail-1 (test (x) (divo (build 4) (build 0) x __)) '())
+(test-check 'divo-2
+  (solution (x) (divo (build 4) (build 3) x __))
+  '((x.0 (1))))
+(test-check 'divo-3
+  (solution (x) (divo (build 4) (build 4) x __))
+  '((x.0 (1))))
+(test-check 'divo-4
+  (solution (x y) (divo (build 4) (build 5) x y))
+  '((x.0 ()) (y.0 (0 0 1))))
+
+
+(test-check 'divo-33-1
+  (solution (x) (divo (build 33) (build 3) x __))
+  `((x.0 ,(build 11))))
+(test-check 'divo-33-2
+  (solution (x) (divo (build 33) x (build 11) __))
+  `((x.0 ,(build 3))))
+(test-check 'divo-33-3
+  (solution (x) (divo x (build 3) (build 11) __))
+  `((x.0 ,(build 33))))
+(test-check 'divo-33-5
+  (solution (x y) (divo (build 33) (build 5) x y))
+  `((x.0 ,(build 6)) (y.0 ,(build 3))))
+
+
+(test-check 'divo-5-4
+  (solve 3 (x y) (divo x (build 5) y (build 4)))
+  '(((x.0 (0 0 1)) (y.0 ()))
+    ((x.0 (0 0 0 0 0 0 1)) (y.0 (0 0 1 1)))
+    ((x.0 (1 0 0 0 1 1)) (y.0 (1 0 0 1))))
+)
+(test-check 'divo-5-5
+  (solve 3 (x y) (divo x (build 5) y (build 5)))
+  '())
+
+
+(test (x) (divo x (build 5) __ (build 4)))
+(test (x) (divo x (build 5) (build 3) (build 4)))
+(test (x) (divo x __ (build 3) (build 4)))
+(test-check 'div-fail-2 (test (x) (divo (build 5) x (build 7) __)) '())
+
+(test-check "all numbers such as 5/Z = 1"
+  (solve 7 (w) 
+    (_exists (z) (all (divo (build 5) z (build 1) __)
+		    (project (z) (== `(,(trans z)) w)))))
+  '(((w.0 (5))) ((w.0 (3))) ((w.0 (4)))))
+
+(test-check "all inexact factorizations of 12"
+  (set-equal?
+   (solve 100 (w) 
+    (_exists (m q r n)
+      (all 
+	(== n (build 12))
+	(<o m n)
+	(divo n m q r)
+	(project (m q r) (== `(,(trans m) ,(trans q) ,(trans r)) w)))))
+  '(((w.0 (1 12 0))) ((w.0 (11 1 1)))
+    ((w.0 (2 6 0)))  ((w.0 (10 1 2)))
+    ((w.0 (4 3 0)))  ((w.0 (8 1 4)))
+    ((w.0 (6 2 0)))  ((w.0 (3 4 0)))
+    ((w.0 (9 1 3)))  ((w.0 (7 1 5)))
+    ((w.0 (5 2 2)))))
+  #t)
+
+
+(test-check 'div-all-3
+  (solve 4 (x y z r) (divo x y z r))
+'(((x.0 ()) (y.0 (_.0 . _.1)) (z.0 ()) (r.0 ())) ; 0 = a*0 + 0, a>0
+  ((x.0 (1)) (y.0 (1)) (z.0 (1)) (r.0 ())) ; 1 = 1*1 + 0
+  ((x.0 (0 1)) (y.0 (1)) (z.0 (0 1)) (r.0 ())) ; 2 = 1*2 + 0
+  ((x.0 (0 1)) (y.0 (1 1)) (z.0 ()) (r.0 (0 1))) ; 2 = 3*0 + 2
+))
+
+(test-check 'div-even
+  (solve 3  (y z r) (divo `(0 . ,y) (build 2) z r))
+  '(((y.0 (1)) (z.0 (1)) (r.0 ()))
+    ((y.0 (0 1)) (z.0 (0 1)) (r.0 ()))
+    ((y.0 (1 1)) (z.0 (1 1)) (r.0 ())))
+)
+
+(test-check 'div-even-fail
+  (solve 3  (y z r) (divo `(0 . ,y) (build 2) z '(1)))
+  '()
+)
+
+(test-check 'div-odd
+  (solve 3  (y z) (divo `(1 0 . ,y) (build 2) z '(1)))
+  '(((y.0 (0 1)) (z.0 (0 0 1))) ; 9 = 2*4 + 1
+    ((y.0 (1)) (z.0 (0 1))) ; 5 = 2*2 + 1
+    ((y.0 (0 0 1)) (z.0 (0 0 0 1)))) ; 17 = 8*2 + 1
+)
+
+(test-check 'div-odd-fail
+  (solve 3  (y z r) (divo `(1 0 . ,y) (build 2) z '()))
+  '()
+)
+
+(test-check 'div-enum-sample
+  (solve 1 (n m q r)
+    (all (divo n m q r)
+      (== n (build 10)) (== m (build 2)) (== q (build 5))
+      (== r '())))
+  '(((n.0 (0 1 0 1)) (m.0 (0 1)) (q.0 (1 0 1)) (r.0 ())))
+)
+
+; the latter takes awfully long time
+'(test-check 'div-enum-sample-1
+  (solve 1 (n m q r)
+    (all (divo n m q r)
+      (== n (build 10)) (== m (build 3)) (== q (build 3))
+      (== r '(1))))
+  '(((n.0 (1 1 1)) (m.0 (0 1)) (q.0 (1 1)) (r.0 (1))))
+)
+
+; check that divo(N,M,Q,R) recursively enumerates all
+; numbers such as N=M*Q+R, R<M
+; It is a slow test...
+(cout "Test recursive enumerability of division" nl)
+'(let ((n 3))
+  (do ((m 1 (+ 1 m))) ((> m n))
+    (do ((q 0 (+ 1 q))) ((> q n))
+      (do ((r 0 (+ 1 r))) ((>= r m))
+	(let ((n (+ (* m q) r)))
+	 (test-check
+	  (string-append "enumerability: " (number->string n)
+	    "=" (number->string m) "*" (number->string q)
+	    "+" (number->string r))
+	  (solve 1 (n1 m1 q1 r1) 
+	    (all (divo n1 m1 q1 r1)
+	      (== n1 (build n)) (== m1 (build m))
+	      (== q1 (build q)) (== r1 (build r))
+	      ))
+	  `(((n1.0 ,(build n)) (m1.0 ,(build m))
+	     (q1.0 ,(build q)) (r1.0 ,(build r))))))))))
+
+
+; quite dubious tests. The problem is actually in =ol and <ol
+; (solve 1 (q)
+;     (poso q)
+;     (divo `(0 . ,q) `(1 1 . ,q) '() `(0 . ,q))))
+;
+; (solve 1 (q)
+;     (poso q)
+;     (divo `(0 . ,q) `(1 . ,q) '() `(0 . ,q))))
+
+
+(test-check 'exp2-1
+  (solve 10 (q) (exp2 '(1 1 1 1) '() q))
+  '(((q.0 (1 1)))))
+
+(test-check 'exp2-2
+  (solve 10 (q) (exp2 '(1 0 1 1 1) '()  q))
+  '(((q.0 (0 0 1)))))
+
+; These are all answers!
+(test-check 'exp2-3
+  (solve 100 (n) (exp2 n '() '(1 0 1)))
+  '(((n.0 (0 0 0 0 0 1)))
+    ((n.0 (1 0 0 0 0 1)))
+    ((n.0 (0 1 0 0 0 1)))
+    ((n.0 (1 1 0 0 0 1)))
+    ((n.0 (0 _.0 1 0 0 1)))
+    ((n.0 (1 _.0 1 0 0 1)))
+    ((n.0 (0 _.0 _.1 1 0 1)))
+    ((n.0 (1 _.0 _.1 1 0 1)))
+    ((n.0 (0 _.0 _.1 _.2 1 1)))
+    ((n.0 (1 _.0 _.1 _.2 1 1))))
+)
+
+
+(test-check 'exp2-4
+  (solve 5 (n q) (exp2 n '() q))
+  '(((n.0 (1)) (q.0 ()))
+    ((n.0 (0 1)) (q.0 (1)))
+    ((n.0 (0 0 1)) (q.0 (0 1)))
+    ((n.0 (0 0 0 1)) (q.0 (1 1)))
+    ((n.0 (1 1)) (q.0 (1)))))
+
+
+(test-check 'logo-15-1
+  (solve 10 (q r) (logo (build 15) (build 2) q r))
+  '(((q.0 (1 1)) (r.0 (1 1 1)))))
+
+(test-check 'logo-15-3
+  (solve 10 (q r) (logo (build 15) (build 3) q r))
+  '(((q.0 (0 1)) (r.0 (0 1 1)))))
+
+(test-check 'logo-15-4
+  (solve 10 (q r) (logo (build 15) (build 4) q r))
+  '(((q.0 (1)) (r.0 (1 1 0 1)))))
+
+(test-check 'logo-15-5
+  (solve 10 (q r) (logo (build 15) (build 5) q r))
+  '(((q.0 (1)) (r.0 (0 1 0 1)))))
+
+(test-check 'logo-15-15
+  (solve 10 (q r) (logo (build 15) (build 15) q r))
+  '(((q.0 (1)) (r.0 ()))))
+
+(test-check 'logo-15-16
+  (solve 10 (q r) (logo (build 15) (build 16) q r))
+  '(((q.0 ()) (r.0 (0 1 1 1)))))
+
+(test-check 'logo-15--3
+  (solve 10 (b r) (logo (build 15) b (build 3) r))
+  '(((b.0 (1)) (r.0 (0 1 1 1)))  ; 15 = 1^3 + 14
+    ((b.0 ()) (r.0 (1 1 1 1)))   ; 15 = 0^3 + 15
+    ((b.0 (0 1)) (r.0 (1 1 1))))) ; 15 = 2^3 + 7
+
+(test-check 'logo-15--3-1
+  (solve 10 (q) (logo q '(1) (build 2) '()))
+  '(((q.0 (1)))))
+
+(test-check 'logo-32--4
+  (solve 10 (b r) (logo (build 32) b (build 4) r))
+  '(((b.0 (1)) (r.0 (1 1 1 1 1))) ((b.0 ()) (r.0 (0 0 0 0 0 1)))))
+
+(test-check 'logo-33--5
+  (solve 10 (b r) (logo (build 33) b (build 5) r))
+  '(((b.0 (1)) (r.0 (0 0 0 0 0 1)))
+    ((b.0 ()) (r.0 (1 0 0 0 0 1)))
+    ((b.0 (0 1)) (r.0 (1)))))
+
+(test-check 'logo-2-5
+  (solve 10 (n) (logo n (build 2) (build 5) '(1)))
+  '(((n.0 (1 0 0 0 0 1)))))
+
+(test-check 'logo-3-2
+  (solve 10 (n) (logo n (build 3) (build 2) '(1)))
+  '(((n.0 (0 1 0 1)))))
+
+(test-check 'logo-3-3
+  (solve 10 (n) (logo n (build 3) (build 3) '(1)))
+  '(((n.0 (0 0 1 1 1)))))
+
+(test-check 'powers-of-3
+  (solve 10 (n q r) (logo n (build 3) q r))
+  '(((n.0 (1)) (q.0 ()) (r.0 ()))
+    ((n.0 (0 1)) (q.0 ()) (r.0 (1)))
+    ((n.0 (1 1)) (q.0 (1)) (r.0 ()))
+    ((n.0 (0 0 1)) (q.0 (1)) (r.0 (1)))
+    ((n.0 (1)) (q.0 ()) (r.0 ()))
+    ((n.0 (0 0 0 1)) (q.0 (1)) (r.0 (1 0 1)))
+    ((n.0 (1 0 1)) (q.0 (1)) (r.0 (0 1)))
+    ((n.0 (1 1 1)) (q.0 (1)) (r.0 (0 0 1)))
+    ((n.0 (0 1 1)) (q.0 (1)) (r.0 (1 1)))
+    ((n.0 (0 0 0 0 1)) (q.0 (0 1)) (r.0 (1 1 1))))
+)
+
+(test-check 'powers-of-exp-3
+  (solve 7 (n b r) (logo n b (build 3) r))
+  '(((n.0 (1)) (b.0 (1)) (r.0 ()))
+    ((n.0 _.0) (b.0 ()) (r.0 _.0))
+    ((n.0 (0 0 0 1)) (b.0 (0 1)) (r.0 ()))
+    ((n.0 (1 1 0 1 1)) (b.0 (1 1)) (r.0 ()))
+    ((n.0 (0 1)) (b.0 (1)) (r.0 (1)))
+    ((n.0 (1 0 0 1)) (b.0 (0 1)) (r.0 (1)))
+    ((n.0 (0 0 1 1 1)) (b.0 (1 1)) (r.0 (1))))
+)
+10)
+
+;; ========================================================================
+
+(define (all-tests)
+  (eigen-test)
+  (term-tests)
+  (kanren-tests)
+  (ti-tests)
+  (ti-tests-2)
+  (ti-tests-3)
+  (tc-tests)
+  (zebra-test)
+  (mirror-tests)
+  (mirror-equ-tests)
+  (pure-bin-arith-tests))
+
+(time (all-tests))
+
diff --git a/benchmarks/gabriel/lattice.sch b/benchmarks/gabriel/lattice.sch
new file mode 100644
index 00000000..08802541
--- /dev/null
+++ b/benchmarks/gabriel/lattice.sch
@@ -0,0 +1,215 @@
+;;; LATTICE -- Obtained from Andrew Wright.
+
+; Given a comparison routine that returns one of
+;       less
+;       more
+;       equal
+;       uncomparable
+; return a new comparison routine that applies to sequences.
+(define lexico
+    (lambda (base)
+        (define lex-fixed
+            (lambda (fixed lhs rhs)
+                (define check
+                    (lambda (lhs rhs)
+                        (if (null? lhs)
+                            fixed
+                            (let ((probe
+                                        (base (car lhs)
+                                            (car rhs))))
+                                (if (or (eq? probe 'equal)
+                                        (eq? probe fixed))
+                                    (check (cdr lhs)
+                                        (cdr rhs))
+                                    'uncomparable)))))
+                (check lhs rhs)))
+        (define lex-first
+            (lambda (lhs rhs)
+                (if (null? lhs)
+                    'equal
+                    (let ((probe
+                                (base (car lhs)
+                                    (car rhs))))
+                        (case probe
+                            ((less more)
+                                (lex-fixed probe
+                                    (cdr lhs)
+                                    (cdr rhs)))
+                            ((equal)
+                                (lex-first (cdr lhs)
+                                    (cdr rhs)))
+                            ((uncomparable)
+                                'uncomparable))))))
+        lex-first))
+
+(define (make-lattice elem-list cmp-func)
+    (cons elem-list cmp-func))
+
+(define lattice->elements car)
+
+(define lattice->cmp cdr)
+
+; Select elements of a list which pass some test.
+(define zulu-select
+    (lambda (test lst)
+        (define select-a
+            (lambda (ac lst)
+                (if (null? lst)
+                    (reverse! ac)
+                    (select-a
+                        (let ((head (car lst)))
+                            (if (test head)
+                                (cons head ac)
+                                ac))
+                        (cdr lst)))))
+        (select-a '() lst)))
+
+(define reverse!
+    (letrec ((rotate
+                (lambda (fo fum)
+                    (let ((next (cdr fo)))
+                        (set-cdr! fo fum)
+                        (if (null? next)
+                            fo
+                            (rotate next fo))))))
+        (lambda (lst)
+            (if (null? lst)
+                '()
+                (rotate lst '())))))
+
+; Select elements of a list which pass some test and map a function
+; over the result.  Note, only efficiency prevents this from being the
+; composition of select and map.
+(define select-map
+    (lambda (test func lst)
+        (define select-a
+            (lambda (ac lst)
+                (if (null? lst)
+                    (reverse! ac)
+                    (select-a
+                        (let ((head (car lst)))
+                            (if (test head)
+                                (cons (func head)
+                                    ac)
+                                ac))
+                        (cdr lst)))))
+        (select-a '() lst)))
+
+
+
+; This version of map-and tail-recurses on the last test.
+(define map-and
+    (lambda (proc lst)
+        (if (null? lst)
+            #t
+            (letrec ((drudge
+                        (lambda (lst)
+                            (let ((rest (cdr lst)))
+                                (if (null? rest)
+                                    (proc (car lst))
+                                    (and (proc (car lst))
+                                        (drudge rest)))))))
+                (drudge lst)))))
+
+(define (maps-1 source target pas new)
+    (let ((scmp (lattice->cmp source))
+            (tcmp (lattice->cmp target)))
+        (let ((less
+                    (select-map
+                        (lambda (p)
+                            (eq? 'less
+                                (scmp (car p) new)))
+                        cdr
+                        pas))
+                (more
+                    (select-map
+                        (lambda (p)
+                            (eq? 'more
+                                (scmp (car p) new)))
+                        cdr
+                        pas)))
+            (zulu-select
+                (lambda (t)
+                    (and
+                        (map-and
+                            (lambda (t2)
+                                (memq (tcmp t2 t) '(less equal)))
+                            less)
+                        (map-and
+                            (lambda (t2)
+                                (memq (tcmp t2 t) '(more equal)))
+                            more)))
+                (lattice->elements target)))))
+
+(define (maps-rest source target pas rest to-1 to-collect)
+    (if (null? rest)
+        (to-1 pas)
+        (let ((next (car rest))
+                (rest (cdr rest)))
+            (to-collect
+                (map
+                    (lambda (x)
+                        (maps-rest source target
+                            (cons
+                                (cons next x)
+                                pas)
+                            rest
+                            to-1
+                            to-collect))
+                    (maps-1 source target pas next))))))
+
+(define (maps source target)
+    (make-lattice
+        (maps-rest source
+            target
+            '()
+            (lattice->elements source)
+            (lambda (x) (list (map cdr x)))
+            (lambda (x) (apply append x)))
+        (lexico (lattice->cmp target))))
+
+(define (count-maps source target)
+  (maps-rest source
+             target
+             '()
+             (lattice->elements source)
+             (lambda (x) 1)
+             sum))
+
+(define (sum lst)
+  (if (null? lst)
+      0
+      (+ (car lst) (sum (cdr lst)))))
+
+(define (run)
+  (let* ((l2
+            (make-lattice '(low high)
+                (lambda (lhs rhs)
+                    (case lhs
+                        ((low)
+                            (case rhs
+                                ((low)
+                                    'equal)
+                                ((high)
+                                    'less)
+                                (else
+                                    (error 'make-lattice "base" rhs))))
+                        ((high)
+                            (case rhs
+                                ((low)
+                                    'more)
+                                ((high)
+                                    'equal)
+                                (else
+                                    (error 'make-lattice "base" rhs))))
+                        (else
+                            (error 'make-lattice "base" lhs))))))
+        (l3 (maps l2 l2))
+        (l4 (maps l3 l3)))
+    (count-maps l2 l2)
+    (count-maps l3 l3)
+    (count-maps l2 l3)
+    (count-maps l3 l2)
+    (count-maps l4 l4)))
+
+(time (run))
diff --git a/benchmarks/gabriel/lattice2.sch b/benchmarks/gabriel/lattice2.sch
new file mode 100644
index 00000000..482ed678
--- /dev/null
+++ b/benchmarks/gabriel/lattice2.sch
@@ -0,0 +1,205 @@
+;; Like "lattice.sch", but uses `reverse' instead of
+;; defining `reverse!' (to avoid `set-cdr!')
+
+;;; LATTICE -- Obtained from Andrew Wright.
+
+; Given a comparison routine that returns one of
+;       less
+;       more
+;       equal
+;       uncomparable
+; return a new comparison routine that applies to sequences.
+(define lexico
+    (lambda (base)
+        (define lex-fixed
+            (lambda (fixed lhs rhs)
+                (define check
+                    (lambda (lhs rhs)
+                        (if (null? lhs)
+                            fixed
+                            (let ((probe
+                                        (base (car lhs)
+                                            (car rhs))))
+                                (if (or (eq? probe 'equal)
+                                        (eq? probe fixed))
+                                    (check (cdr lhs)
+                                        (cdr rhs))
+                                    'uncomparable)))))
+                (check lhs rhs)))
+        (define lex-first
+            (lambda (lhs rhs)
+                (if (null? lhs)
+                    'equal
+                    (let ((probe
+                                (base (car lhs)
+                                    (car rhs))))
+                        (case probe
+                            ((less more)
+                                (lex-fixed probe
+                                    (cdr lhs)
+                                    (cdr rhs)))
+                            ((equal)
+                                (lex-first (cdr lhs)
+                                    (cdr rhs)))
+                            ((uncomparable)
+                                'uncomparable))))))
+        lex-first))
+
+(define (make-lattice elem-list cmp-func)
+    (cons elem-list cmp-func))
+
+(define lattice->elements car)
+
+(define lattice->cmp cdr)
+
+; Select elements of a list which pass some test.
+(define zulu-select
+    (lambda (test lst)
+        (define select-a
+            (lambda (ac lst)
+                (if (null? lst)
+                    (reverse ac)
+                    (select-a
+                        (let ((head (car lst)))
+                            (if (test head)
+                                (cons head ac)
+                                ac))
+                        (cdr lst)))))
+        (select-a '() lst)))
+
+; Select elements of a list which pass some test and map a function
+; over the result.  Note, only efficiency prevents this from being the
+; composition of select and map.
+(define select-map
+    (lambda (test func lst)
+        (define select-a
+            (lambda (ac lst)
+                (if (null? lst)
+                    (reverse ac)
+                    (select-a
+                        (let ((head (car lst)))
+                            (if (test head)
+                                (cons (func head)
+                                    ac)
+                                ac))
+                        (cdr lst)))))
+        (select-a '() lst)))
+
+
+
+; This version of map-and tail-recurses on the last test.
+(define map-and
+    (lambda (proc lst)
+        (if (null? lst)
+            #t
+            (letrec ((drudge
+                        (lambda (lst)
+                            (let ((rest (cdr lst)))
+                                (if (null? rest)
+                                    (proc (car lst))
+                                    (and (proc (car lst))
+                                        (drudge rest)))))))
+                (drudge lst)))))
+
+(define (maps-1 source target pas new)
+    (let ((scmp (lattice->cmp source))
+            (tcmp (lattice->cmp target)))
+        (let ((less
+                    (select-map
+                        (lambda (p)
+                            (eq? 'less
+                                (scmp (car p) new)))
+                        cdr
+                        pas))
+                (more
+                    (select-map
+                        (lambda (p)
+                            (eq? 'more
+                                (scmp (car p) new)))
+                        cdr
+                        pas)))
+            (zulu-select
+                (lambda (t)
+                    (and
+                        (map-and
+                            (lambda (t2)
+                                (memq (tcmp t2 t) '(less equal)))
+                            less)
+                        (map-and
+                            (lambda (t2)
+                                (memq (tcmp t2 t) '(more equal)))
+                            more)))
+                (lattice->elements target)))))
+
+(define (maps-rest source target pas rest to-1 to-collect)
+    (if (null? rest)
+        (to-1 pas)
+        (let ((next (car rest))
+                (rest (cdr rest)))
+            (to-collect
+                (map
+                    (lambda (x)
+                        (maps-rest source target
+                            (cons
+                                (cons next x)
+                                pas)
+                            rest
+                            to-1
+                            to-collect))
+                    (maps-1 source target pas next))))))
+
+(define (maps source target)
+    (make-lattice
+        (maps-rest source
+            target
+            '()
+            (lattice->elements source)
+            (lambda (x) (list (map cdr x)))
+            (lambda (x) (apply append x)))
+        (lexico (lattice->cmp target))))
+
+(define (count-maps source target)
+  (maps-rest source
+             target
+             '()
+             (lattice->elements source)
+             (lambda (x) 1)
+             sum))
+
+(define (sum lst)
+  (if (null? lst)
+      0
+      (+ (car lst) (sum (cdr lst)))))
+
+(define (run)
+  (let* ((l2
+            (make-lattice '(low high)
+                (lambda (lhs rhs)
+                    (case lhs
+                        ((low)
+                            (case rhs
+                                ((low)
+                                    'equal)
+                                ((high)
+                                    'less)
+                                (else
+                                    (error 'make-lattice "base" rhs))))
+                        ((high)
+                            (case rhs
+                                ((low)
+                                    'more)
+                                ((high)
+                                    'equal)
+                                (else
+                                    (error 'make-lattice "base" rhs))))
+                        (else
+                            (error 'make-lattice "base" lhs))))))
+        (l3 (maps l2 l2))
+        (l4 (maps l3 l3)))
+    (count-maps l2 l2)
+    (count-maps l3 l3)
+    (count-maps l2 l3)
+    (count-maps l3 l2)
+    (count-maps l4 l4)))
+
+(time (run))
diff --git a/benchmarks/gabriel/maze.sch b/benchmarks/gabriel/maze.sch
new file mode 100644
index 00000000..e56bf17a
--- /dev/null
+++ b/benchmarks/gabriel/maze.sch
@@ -0,0 +1,680 @@
+;;; MAZE -- Constructs a maze on a hexagonal grid, written by Olin Shivers.
+
+;------------------------------------------------------------------------------
+; Was file "rand.scm".
+
+; Minimal Standard Random Number Generator
+; Park & Miller, CACM 31(10), Oct 1988, 32 bit integer version.
+; better constants, as proposed by Park.
+; By Ozan Yigit
+
+;;; Rehacked by Olin 4/1995.
+
+(define (random-state n)
+  (cons n #f))
+
+(define (rand state)
+  (let ((seed (car state))
+        (A 2813) ; 48271
+        (M 8388607) ; 2147483647
+        (Q 2787) ; 44488
+        (R 2699)) ; 3399
+    (let* ((hi (quotient seed Q))
+           (lo (modulo seed Q))
+           (test (- (* A lo) (* R hi)))
+           (val (if (> test 0) test (+ test M))))
+      (set-car! state val)
+      val)))
+
+(define (random-int n state)
+  (modulo (rand state) n))
+
+; poker test
+; seed 1
+; cards 0-9 inclusive (random 10)
+; five cards per hand
+; 10000 hands
+;
+; Poker Hand     Example    Probability  Calculated
+; 5 of a kind    (aaaaa)      0.0001      0
+; 4 of a kind    (aaaab)      0.0045      0.0053
+; Full house     (aaabb)      0.009       0.0093
+; 3 of a kind    (aaabc)      0.072       0.0682
+; two pairs      (aabbc)      0.108       0.1104
+; Pair           (aabcd)      0.504       0.501
+; Bust           (abcde)      0.3024      0.3058
+
+; (define (random n)
+;   (let* ((M 2147483647)
+;        (slop (modulo M n)))
+;     (let loop ((r (rand)))
+;       (if (> r slop)
+;         (modulo r n)  
+;         (loop (rand))))))
+; 
+; (define (rngtest)
+;   (display "implementation ")
+;   (srand 1)
+;   (let loop ((n 0))
+;     (if (< n 10000)
+;         (begin
+;          (rand)
+;          (loop (1+ n)))))
+;   (if (= *seed* 399268537)
+;       (display "looks correct.")
+;       (begin
+;        (display "failed.")
+;        (newline)
+;        (display "   current seed ") (display *seed*)
+;        (newline)
+;        (display "   correct seed 399268537")))
+;   (newline))
+
+;------------------------------------------------------------------------------
+; Was file "uf.scm".
+
+;;; Tarjan's amortised union-find data structure.
+;;; Copyright (c) 1995 by Olin Shivers.
+
+;;; This data structure implements disjoint sets of elements.
+;;; Four operations are supported. The implementation is extremely
+;;; fast -- any sequence of N operations can be performed in time
+;;; so close to linear it's laughable how close it is. See your
+;;; intro data structures book for more. The operations are:
+;;;
+;;; - (base-set nelts) -> set
+;;;   Returns a new set, of size NELTS.
+;;;
+;;; - (set-size s) -> integer
+;;;   Returns the number of elements in set S.
+;;;
+;;; - (union! set1 set2)
+;;;   Unions the two sets -- SET1 and SET2 are now considered the same set
+;;;   by SET-EQUAL?.
+;;;
+;;; - (set-equal? set1 set2)
+;;;   Returns true <==> the two sets are the same.
+
+;;; Representation: a set is a cons cell. Every set has a "representative"
+;;; cons cell, reached by chasing cdr links until we find the cons with
+;;; cdr = (). Set equality is determined by comparing representatives using
+;;; EQ?. A representative's car contains the number of elements in the set.
+
+;;; The speed of the algorithm comes because when we chase links to find 
+;;; representatives, we collapse links by changing all the cells in the path
+;;; we followed to point directly to the representative, so that next time
+;;; we walk the cdr-chain, we'll go directly to the representative in one hop.
+
+
+(define (base-set nelts) (cons nelts '()))
+
+;;; Sets are chained together through cdr links. Last guy in the chain
+;;; is the root of the set.
+
+(define (get-set-root s)
+  (let lp ((r s))                       ; Find the last pair
+    (let ((next (cdr r)))               ; in the list. That's
+      (cond ((pair? next) (lp next))    ; the root r.
+
+            (else
+             (if (not (eq? r s))        ; Now zip down the list again,
+                 (let lp ((x s))        ; changing everyone's cdr to r.
+                   (let ((next (cdr x)))        
+                     (cond ((not (eq? r next))
+                            (set-cdr! x r)
+                            (lp next))))))
+             r)))))                     ; Then return r.
+
+(define (set-equal? s1 s2) (eq? (get-set-root s1) (get-set-root s2)))
+
+(define (set-size s) (car (get-set-root s)))
+
+(define (union! s1 s2)
+  (let* ((r1 (get-set-root s1))
+         (r2 (get-set-root s2))
+         (n1 (set-size r1))
+         (n2 (set-size r2))
+         (n  (+ n1 n2)))
+
+    (cond ((> n1 n2)
+           (set-cdr! r2 r1)
+           (set-car! r1 n))
+          (else
+           (set-cdr! r1 r2)
+           (set-car! r2 n)))))
+
+;------------------------------------------------------------------------------
+; Was file "maze.scm".
+
+;;; Building mazes with union/find disjoint sets.
+;;; Copyright (c) 1995 by Olin Shivers.
+
+;;; This is the algorithmic core of the maze constructor.
+;;; External dependencies:
+;;; - RANDOM-INT
+;;; - Union/find code
+;;; - bitwise logical functions
+
+; (define-record wall
+;   owner         ; Cell that owns this wall.
+;   neighbor      ; The other cell bordering this wall.
+;   bit)          ; Integer -- a bit identifying this wall in OWNER's cell.
+
+; (define-record cell
+;   reachable     ; Union/find set -- all reachable cells.
+;   id            ; Identifying info (e.g., the coords of the cell).
+;   (walls -1)    ; A bitset telling which walls are still standing.
+;   (parent #f)   ; For DFS spanning tree construction.
+;   (mark #f))    ; For marking the solution path.
+
+(define (make-wall owner neighbor bit)
+  (vector 'wall owner neighbor bit))
+
+(define (wall:owner o)          (vector-ref o 1))
+(define (set-wall:owner o v)    (vector-set! o 1 v))
+(define (wall:neighbor o)       (vector-ref o 2))
+(define (set-wall:neighbor o v) (vector-set! o 2 v))
+(define (wall:bit o)            (vector-ref o 3))
+(define (set-wall:bit o v)      (vector-set! o 3 v))
+
+(define (make-cell reachable id)
+  (vector 'cell reachable id -1 #f #f))
+
+(define (cell:reachable o)       (vector-ref o 1))
+(define (set-cell:reachable o v) (vector-set! o 1 v))
+(define (cell:id o)              (vector-ref o 2))
+(define (set-cell:id o v)        (vector-set! o 2 v))
+(define (cell:walls o)           (vector-ref o 3))
+(define (set-cell:walls o v)     (vector-set! o 3 v))
+(define (cell:parent o)          (vector-ref o 4))
+(define (set-cell:parent o v)    (vector-set! o 4 v))
+(define (cell:mark o)            (vector-ref o 5))
+(define (set-cell:mark o v)      (vector-set! o 5 v))
+
+;;; Iterates in reverse order.
+
+(define (vec-for-each proc v)
+  (let lp ((i (- (vector-length v) 1)))
+    (cond ((>= i 0)
+           (proc (vector-ref v i))
+           (lp (- i 1))))))
+
+
+;;; Randomly permute a vector.
+
+(define (permute-vec! v random-state)
+  (let lp ((i (- (vector-length v) 1)))
+    (cond ((> i 1)
+           (let ((elt-i (vector-ref v i))
+                 (j (random-int i random-state)))       ; j in [0,i)
+             (vector-set! v i (vector-ref v j))
+             (vector-set! v j elt-i))
+           (lp (- i 1)))))
+  v)
+
+
+;;; This is the core of the algorithm.
+
+(define (dig-maze walls ncells)
+  (call-with-current-continuation
+    (lambda (quit)
+      (vec-for-each
+       (lambda (wall)                   ; For each wall,
+         (let* ((c1   (wall:owner wall)) ; find the cells on
+                (set1 (cell:reachable c1))
+
+                (c2   (wall:neighbor wall)) ; each side of the wall
+                (set2 (cell:reachable c2)))
+
+           ;; If there is no path from c1 to c2, knock down the
+           ;; wall and union the two sets of reachable cells.
+           ;; If the new set of reachable cells is the whole set
+           ;; of cells, quit.
+           (if (not (set-equal? set1 set2))
+               (let ((walls (cell:walls c1))    
+                     (wall-mask (bitwise-not (wall:bit wall))))
+                 (union! set1 set2)
+                 (set-cell:walls c1 (bitwise-and walls wall-mask))
+                 (if (= (set-size set1) ncells) (quit #f))))))
+       walls))))
+
+
+;;; Some simple DFS routines useful for determining path length 
+;;; through the maze.
+
+;;; Build a DFS tree from ROOT. 
+;;; (DO-CHILDREN proc maze node) applies PROC to each of NODE's children.
+;;; We assume there are no loops in the maze; if this is incorrect, the
+;;; algorithm will diverge.
+
+(define (dfs-maze maze root do-children)
+  (let search ((node root) (parent #f))
+    (set-cell:parent node parent)
+    (do-children (lambda (child)
+                   (if (not (eq? child parent))
+                       (search child node)))
+                 maze node)))
+
+;;; Move the root to NEW-ROOT.
+
+(define (reroot-maze new-root)
+  (let lp ((node new-root) (new-parent #f))
+    (let ((old-parent (cell:parent node)))
+      (set-cell:parent node new-parent)
+      (if old-parent (lp old-parent node)))))
+
+;;; How far from CELL to the root?
+
+(define (path-length cell)
+  (do ((len 0 (+ len 1))
+       (node (cell:parent cell) (cell:parent node)))
+      ((not node) len)))
+
+;;; Mark the nodes from NODE back to root. Used to mark the winning path.
+
+(define (mark-path node)
+  (let lp ((node node))
+    (set-cell:mark node #t)
+    (cond ((cell:parent node) => lp))))
+
+;------------------------------------------------------------------------------
+; Was file "harr.scm".
+
+;;; Hex arrays
+;;; Copyright (c) 1995 by Olin Shivers.
+
+;;; External dependencies:
+;;; - define-record
+
+;;;        ___       ___       ___
+;;;       /   \     /   \     /   \
+;;;   ___/  A  \___/  A  \___/  A  \___
+;;;  /   \     /   \     /   \     /   \
+;;; /  A  \___/  A  \___/  A  \___/  A  \
+;;; \     /   \     /   \     /   \     /
+;;;  \___/     \___/     \___/     \___/
+;;;  /   \     /   \     /   \     /   \
+;;; /     \___/     \___/     \___/     \
+;;; \     /   \     /   \     /   \     /
+;;;  \___/     \___/     \___/     \___/
+;;;  /   \     /   \     /   \     /   \
+;;; /     \___/     \___/     \___/     \
+;;; \     /   \     /   \     /   \     /
+;;;  \___/     \___/     \___/     \___/
+
+;;; Hex arrays are indexed by the (x,y) coord of the center of the hexagonal
+;;; element. Hexes are three wide and two high; e.g., to get from the center
+;;; of an elt to its {NW, N, NE} neighbors, add {(-3,1), (0,2), (3,1)}
+;;; respectively.
+;;;
+;;; Hex arrays are represented with a matrix, essentially made by shoving the
+;;; odd columns down a half-cell so things line up. The mapping is as follows:
+;;;     Center coord      row/column
+;;;     ------------      ----------
+;;;     (x,  y)        -> (y/2, x/3)
+;;;     (3c, 2r + c&1) <- (r,   c)
+
+
+; (define-record harr
+;   nrows
+;   ncols
+;   elts)
+
+(define (make-harr nrows ncols elts)
+  (vector 'harr nrows ncols elts))
+
+(define (harr:nrows o)       (vector-ref o 1))
+(define (set-harr:nrows o v) (vector-set! o 1 v))
+(define (harr:ncols o)       (vector-ref o 2))
+(define (set-harr:ncols o v) (vector-set! o 2 v))
+(define (harr:elts o)        (vector-ref o 3))
+(define (set-harr:elts o v)  (vector-set! o 3 v))
+
+(define (harr r c)
+  (make-harr r c (make-vector (* r c))))
+
+
+
+(define (href ha x y)
+  (let ((r (quotient y 2))
+        (c (quotient x 3)))
+    (vector-ref (harr:elts ha)
+                (+ (* (harr:ncols ha) r) c))))
+
+(define (hset! ha x y val)
+  (let ((r (quotient y 2))
+        (c (quotient x 3)))
+    (vector-set! (harr:elts ha)
+                 (+ (* (harr:ncols ha) r) c)
+                 val)))
+
+(define (href/rc ha r c)
+    (vector-ref (harr:elts ha)
+                (+ (* (harr:ncols ha) r) c)))
+
+;;; Create a nrows x ncols hex array. The elt centered on coord (x, y)
+;;; is the value returned by (PROC x y).
+
+(define (harr-tabulate nrows ncols proc)
+  (let ((v (make-vector (* nrows ncols))))
+
+    (do ((r (- nrows 1) (- r 1)))
+        ((< r 0))
+      (do ((c 0 (+ c 1))
+           (i (* r ncols) (+ i 1)))
+          ((= c ncols))
+        (vector-set! v i (proc (* 3 c) (+ (* 2 r) (bitwise-and c 1))))))
+
+    (make-harr nrows ncols v)))
+
+
+(define (harr-for-each proc harr)
+  (vec-for-each proc (harr:elts harr)))
+
+;------------------------------------------------------------------------------
+; Was file "hex.scm".
+
+;;; Hexagonal hackery for maze generation.
+;;; Copyright (c) 1995 by Olin Shivers.
+
+;;; External dependencies:
+;;; - cell and wall records
+;;; - Functional Postscript for HEXES->PATH
+;;; - logical functions for bit hacking
+;;; - hex array code.
+
+;;; To have the maze span (0,0) to (1,1):
+;;; (scale (/ (+ 1 (* 3 ncols))) (/ (+ 1 (* 2 nrows)))
+;;;        (translate (point 2 1) maze))
+
+;;; Every elt of the hex array manages his SW, S, and SE wall.
+;;; Terminology: - An even column is one whose column index is even. That
+;;;                means the first, third, ... columns (indices 0, 2, ...).
+;;;              - An odd column is one whose column index is odd. That
+;;;                means the second, fourth... columns (indices 1, 3, ...).
+;;;              The even/odd flip-flop is confusing; be careful to keep it
+;;;              straight. The *even* columns are the low ones. The *odd*
+;;;              columns are the high ones.
+;;;    _   _
+;;;  _/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/
+;;;  0 1 2 3
+
+(define south-west 1)
+(define south      2)
+(define south-east 4)
+
+(define (gen-maze-array r c)
+  (harr-tabulate r c (lambda (x y) (make-cell (base-set 1) (cons x y)))))
+
+;;; This could be made more efficient.
+(define (make-wall-vec harr)
+  (let* ((nrows (harr:nrows harr))
+         (ncols (harr:ncols harr))
+         (xmax (* 3 (- ncols 1)))
+
+         ;; Accumulate walls.
+         (walls '())
+         (add-wall (lambda (o n b) ; owner neighbor bit
+                     (set! walls (cons (make-wall o n b) walls)))))
+        
+    ;; Do everything but the bottom row.
+    (do ((x (* (- ncols 1) 3) (- x 3)))
+        ((< x 0))
+      (do ((y (+ (* (- nrows 1) 2) (bitwise-and x 1))
+              (- y 2)))
+          ((<= y 1))    ; Don't do bottom row.
+          (let ((hex (href harr x y)))
+            (if (not (zero? x))
+                (add-wall hex (href harr (- x 3) (- y 1)) south-west))
+            (add-wall hex (href harr x (- y 2)) south)
+            (if (< x xmax)
+                (add-wall hex (href harr (+ x 3) (- y 1)) south-east)))))
+
+    ;; Do the SE and SW walls of the odd columns on the bottom row.
+    ;; If the rightmost bottom hex lies in an odd column, however,
+    ;; don't add it's SE wall -- it's a corner hex, and has no SE neighbor.
+    (if (> ncols 1)
+        (let ((rmoc-x (+ 3 (* 6 (quotient (- ncols 2) 2)))))
+          ;; Do rightmost odd col.
+          (let ((rmoc-hex (href harr rmoc-x 1)))
+            (if (< rmoc-x xmax) ; Not  a corner -- do E wall.
+                (add-wall rmoc-hex (href harr xmax 0) south-east))
+            (add-wall rmoc-hex (href harr (- rmoc-x 3) 0) south-west))
+
+          (do ((x (- rmoc-x 6) ; Do the rest of the bottom row's odd cols.
+                  (- x 6)))
+              ((< x 3)) ; 3 is X coord of leftmost odd column.
+            (add-wall (href harr x 1) (href harr (- x 3) 0) south-west)
+            (add-wall (href harr x 1) (href harr (+ x 3) 0) south-east))))
+
+    (list->vector walls)))
+
+
+;;; Find the cell ctop from the top row, and the cell cbot from the bottom
+;;; row such that cbot is furthest from ctop. 
+;;; Return [ctop-x, ctop-y, cbot-x, cbot-y].
+
+(define (pick-entrances harr)
+  (dfs-maze harr (href/rc harr 0 0) for-each-hex-child)
+  (let ((nrows (harr:nrows harr))
+        (ncols (harr:ncols harr)))
+    (let tp-lp ((max-len -1)
+                (entrance #f)
+                (exit #f)
+                (tcol (- ncols 1)))
+      (if (< tcol 0) (vector entrance exit)
+          (let ((top-cell (href/rc harr (- nrows 1) tcol)))
+            (reroot-maze top-cell)
+            (let ((result
+                    (let bt-lp ((max-len max-len)
+                                (entrance entrance)
+                                (exit exit)
+                                (bcol (- ncols 1)))
+;                     (format #t "~a ~a ~a ~a~%" max-len entrance exit bcol)
+                      (if (< bcol 0) (vector max-len entrance exit)
+                          (let ((this-len (path-length (href/rc harr 0 bcol))))
+                            (if (> this-len max-len)
+                                (bt-lp this-len tcol bcol (- bcol 1))
+                                (bt-lp max-len  entrance exit (- bcol 1))))))))
+              (let ((max-len (vector-ref result 0))
+                    (entrance (vector-ref result 1))
+                    (exit (vector-ref result 2)))
+                (tp-lp max-len entrance exit (- tcol 1)))))))))
+                
+
+
+;;; Apply PROC to each node reachable from CELL.
+(define (for-each-hex-child proc harr cell)
+  (let* ((walls (cell:walls cell))
+         (id (cell:id cell))
+         (x (car id))
+         (y (cdr id))
+         (nr (harr:nrows harr))
+         (nc (harr:ncols harr))
+         (maxy (* 2 (- nr 1)))
+         (maxx (* 3 (- nc 1))))
+    (if (not (bit-test walls south-west)) (proc (href harr (- x 3) (- y 1))))
+    (if (not (bit-test walls south))      (proc (href harr x       (- y 2))))
+    (if (not (bit-test walls south-east)) (proc (href harr (+ x 3) (- y 1))))
+
+    ;; NW neighbor, if there is one (we may be in col 1, or top row/odd col)
+    (if (and (> x 0)    ; Not in first column.
+             (or (<= y maxy)            ; Not on top row or
+                 (zero? (modulo x 6)))) ; not in an odd column.
+        (let ((nw (href harr (- x 3) (+ y 1))))
+          (if (not (bit-test (cell:walls nw) south-east)) (proc nw))))
+
+    ;; N neighbor, if there is one (we may be on top row).
+    (if (< y maxy)              ; Not on top row
+        (let ((n (href harr x (+ y 2))))
+          (if (not (bit-test (cell:walls n) south)) (proc n))))
+
+    ;; NE neighbor, if there is one (we may be in last col, or top row/odd col)
+    (if (and (< x maxx) ; Not in last column.
+             (or (<= y maxy)            ; Not on top row or
+                 (zero? (modulo x 6)))) ; not in an odd column.
+        (let ((ne (href harr (+ x 3) (+ y 1))))
+          (if (not (bit-test (cell:walls ne) south-west)) (proc ne))))))
+
+
+
+;;; The top-level
+(define (make-maze nrows ncols)
+  (let* ((cells (gen-maze-array nrows ncols))
+         (walls (permute-vec! (make-wall-vec cells) (random-state 20))))
+    (dig-maze walls (* nrows ncols))
+    (let ((result (pick-entrances cells)))
+      (let ((entrance (vector-ref result 0))
+            (exit (vector-ref result 1)))
+        (let* ((exit-cell (href/rc cells 0 exit))
+               (walls (cell:walls exit-cell)))
+          (reroot-maze (href/rc cells (- nrows 1) entrance))
+          (mark-path exit-cell)
+          (set-cell:walls exit-cell (bitwise-and walls (bitwise-not south)))
+          (vector cells entrance exit))))))
+
+
+(define (pmaze nrows ncols)
+  (let ((result (make-maze nrows ncols)))
+    (let ((cells (vector-ref result 0))
+          (entrance (vector-ref result 1))
+          (exit (vector-ref result 2)))
+      (print-hexmaze cells entrance))))
+
+;------------------------------------------------------------------------------
+; Was file "hexprint.scm".
+
+;;; Print out a hex array with characters.
+;;; Copyright (c) 1995 by Olin Shivers.
+
+;;; External dependencies:
+;;; - hex array code
+;;; - hex cell code
+
+;;;    _   _
+;;;  _/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ 
+
+;;; Top part of top row looks like this:
+;;;    _   _  _   _
+;;;  _/ \_/ \/ \_/ \
+;;; /        
+
+(define output #f) ; the list of all characters written out, in reverse order.
+
+(define (write-ch c)
+  (set! output (cons c output)))
+
+(define (print-hexmaze harr entrance)
+  (let* ((nrows  (harr:nrows harr))
+         (ncols  (harr:ncols harr))
+         (ncols2 (* 2 (quotient ncols 2))))
+
+    ;; Print out the flat tops for the top row's odd cols.
+    (do ((c 1 (+ c 2)))
+        ((>= c ncols))
+;     (display "   ")
+      (write-ch #\space)
+      (write-ch #\space)
+      (write-ch #\space)
+      (write-ch (if (= c entrance) #\space #\_)))
+;   (newline)
+    (write-ch #\newline)
+
+    ;; Print out the slanted tops for the top row's odd cols
+    ;; and the flat tops for the top row's even cols.
+    (write-ch #\space)
+    (do ((c 0 (+ c 2)))
+        ((>= c ncols2))
+;     (format #t "~a/~a\\"
+;             (if (= c entrance) #\space #\_)
+;             (dot/space harr (- nrows 1) (+ c 1)))
+      (write-ch (if (= c entrance) #\space #\_))
+      (write-ch #\/)
+      (write-ch (dot/space harr (- nrows 1) (+ c 1)))
+      (write-ch #\\))
+    (if (odd? ncols)
+        (write-ch (if (= entrance (- ncols 1)) #\space #\_)))
+;   (newline)
+    (write-ch #\newline)
+
+    (do ((r (- nrows 1) (- r 1)))
+        ((< r 0))
+
+      ;; Do the bottoms for row r's odd cols.
+      (write-ch #\/)
+      (do ((c 1 (+ c 2)))
+          ((>= c ncols2))
+        ;; The dot/space for the even col just behind c.
+        (write-ch (dot/space harr r (- c 1)))
+        (display-hexbottom (cell:walls (href/rc harr r c))))    
+
+      (cond ((odd? ncols)
+             (write-ch (dot/space harr r (- ncols 1)))
+             (write-ch #\\)))
+;     (newline)
+      (write-ch #\newline)
+
+      ;; Do the bottoms for row r's even cols.
+      (do ((c 0 (+ c 2)))
+          ((>= c ncols2))
+        (display-hexbottom (cell:walls (href/rc harr r c)))
+        ;; The dot/space is for the odd col just after c, on row below.
+        (write-ch (dot/space harr (- r 1) (+ c 1))))
+      
+      (cond ((odd? ncols)
+             (display-hexbottom (cell:walls (href/rc harr r (- ncols 1)))))
+            ((not (zero? r)) (write-ch #\\)))
+;     (newline)
+      (write-ch #\newline))))
+
+(define (bit-test j bit)
+  (not (zero? (bitwise-and j bit))))
+
+;;; Return a . if harr[r,c] is marked, otherwise a space.
+;;; We use the dot to mark the solution path.
+(define (dot/space harr r c)
+  (if (and (>= r 0) (cell:mark (href/rc harr r c))) #\. #\space))
+
+;;; Print a \_/ hex bottom.
+(define (display-hexbottom hexwalls)
+  (write-ch (if (bit-test hexwalls south-west) #\\ #\space))
+  (write-ch (if (bit-test hexwalls south     ) #\_ #\space))
+  (write-ch (if (bit-test hexwalls south-east) #\/ #\space)))
+
+;;;    _   _
+;;;  _/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ \_/
+;;; / \_/ \_/
+;;; \_/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ \_/
+
+;------------------------------------------------------------------------------
+
+(let ((input (with-input-from-file "input.txt" read)))
+  (time (let loop ((n 1000) (v 0))
+          (if (zero? n)
+              (list->string v)
+              (begin
+                (set! output '())
+                (pmaze 20 (if input 7 0))
+                (loop (- n 1) output))))))
diff --git a/benchmarks/gabriel/maze2.sch b/benchmarks/gabriel/maze2.sch
new file mode 100644
index 00000000..4a2a9168
--- /dev/null
+++ b/benchmarks/gabriel/maze2.sch
@@ -0,0 +1,683 @@
+;; Like "maze.sch", but avoids `set-car!'  and `set-cdr!' by using
+;;  vectors for mutable records.
+
+;;; MAZE -- Constructs a maze on a hexagonal grid, written by Olin Shivers.
+
+;------------------------------------------------------------------------------
+; Was file "rand.scm".
+
+; Minimal Standard Random Number Generator
+; Park & Miller, CACM 31(10), Oct 1988, 32 bit integer version.
+; better constants, as proposed by Park.
+; By Ozan Yigit
+
+;;; Rehacked by Olin 4/1995.
+
+(define (random-state n)
+  (vector n))
+
+(define (rand state)
+  (let ((seed (vector-ref state 0))
+        (A 2813) ; 48271
+        (M 8388607) ; 2147483647
+        (Q 2787) ; 44488
+        (R 2699)) ; 3399
+    (let* ((hi (quotient seed Q))
+           (lo (modulo seed Q))
+           (test (- (* A lo) (* R hi)))
+           (val (if (> test 0) test (+ test M))))
+      (vector-set! state 0 val)
+      val)))
+
+(define (random-int n state)
+  (modulo (rand state) n))
+
+; poker test
+; seed 1
+; cards 0-9 inclusive (random 10)
+; five cards per hand
+; 10000 hands
+;
+; Poker Hand     Example    Probability  Calculated
+; 5 of a kind    (aaaaa)      0.0001      0
+; 4 of a kind    (aaaab)      0.0045      0.0053
+; Full house     (aaabb)      0.009       0.0093
+; 3 of a kind    (aaabc)      0.072       0.0682
+; two pairs      (aabbc)      0.108       0.1104
+; Pair           (aabcd)      0.504       0.501
+; Bust           (abcde)      0.3024      0.3058
+
+; (define (random n)
+;   (let* ((M 2147483647)
+;        (slop (modulo M n)))
+;     (let loop ((r (rand)))
+;       (if (> r slop)
+;         (modulo r n)  
+;         (loop (rand))))))
+; 
+; (define (rngtest)
+;   (display "implementation ")
+;   (srand 1)
+;   (let loop ((n 0))
+;     (if (< n 10000)
+;         (begin
+;          (rand)
+;          (loop (1+ n)))))
+;   (if (= *seed* 399268537)
+;       (display "looks correct.")
+;       (begin
+;        (display "failed.")
+;        (newline)
+;        (display "   current seed ") (display *seed*)
+;        (newline)
+;        (display "   correct seed 399268537")))
+;   (newline))
+
+;------------------------------------------------------------------------------
+; Was file "uf.scm".
+
+;;; Tarjan's amortised union-find data structure.
+;;; Copyright (c) 1995 by Olin Shivers.
+
+;;; This data structure implements disjoint sets of elements.
+;;; Four operations are supported. The implementation is extremely
+;;; fast -- any sequence of N operations can be performed in time
+;;; so close to linear it's laughable how close it is. See your
+;;; intro data structures book for more. The operations are:
+;;;
+;;; - (base-set nelts) -> set
+;;;   Returns a new set, of size NELTS.
+;;;
+;;; - (set-size s) -> integer
+;;;   Returns the number of elements in set S.
+;;;
+;;; - (union! set1 set2)
+;;;   Unions the two sets -- SET1 and SET2 are now considered the same set
+;;;   by SET-EQUAL?.
+;;;
+;;; - (set-equal? set1 set2)
+;;;   Returns true <==> the two sets are the same.
+
+;;; Representation: a set is a cons cell. Every set has a "representative"
+;;; cons cell, reached by chasing cdr links until we find the cons with
+;;; cdr = (). Set equality is determined by comparing representatives using
+;;; EQ?. A representative's car contains the number of elements in the set.
+
+;;; The speed of the algorithm comes because when we chase links to find 
+;;; representatives, we collapse links by changing all the cells in the path
+;;; we followed to point directly to the representative, so that next time
+;;; we walk the cdr-chain, we'll go directly to the representative in one hop.
+
+
+(define (base-set nelts) (vector nelts '()))
+
+;;; Sets are chained together through cdr links. Last guy in the chain
+;;; is the root of the set.
+
+(define (get-set-root s)
+  (let lp ((r s))                       ; Find the last pair
+    (let ((next (vector-ref r 1)))      ; in the list. That's
+      (cond ((vector? next) (lp next))  ; the root r.
+
+            (else
+             (if (not (eq? r s))        ; Now zip down the list again,
+                 (let lp ((x s))        ; changing everyone's cdr to r.
+                   (let ((next (vector-ref x 1)))        
+                     (cond ((not (eq? r next))
+                            (vector-set! x 1 r)
+                            (lp next))))))
+             r)))))                     ; Then return r.
+
+(define (set-equal? s1 s2) (eq? (get-set-root s1) (get-set-root s2)))
+
+(define (set-size s) (vector-ref (get-set-root s) 0))
+
+(define (union! s1 s2)
+  (let* ((r1 (get-set-root s1))
+         (r2 (get-set-root s2))
+         (n1 (set-size r1))
+         (n2 (set-size r2))
+         (n  (+ n1 n2)))
+
+    (cond ((> n1 n2)
+           (vector-set! r2 1 r1)
+           (vector-set! r1 1 n))
+          (else
+           (vector-set! r1 1 r2)
+           (vector-set! r2 1 n)))))
+
+;------------------------------------------------------------------------------
+; Was file "maze.scm".
+
+;;; Building mazes with union/find disjoint sets.
+;;; Copyright (c) 1995 by Olin Shivers.
+
+;;; This is the algorithmic core of the maze constructor.
+;;; External dependencies:
+;;; - RANDOM-INT
+;;; - Union/find code
+;;; - bitwise logical functions
+
+; (define-record wall
+;   owner         ; Cell that owns this wall.
+;   neighbor      ; The other cell bordering this wall.
+;   bit)          ; Integer -- a bit identifying this wall in OWNER's cell.
+
+; (define-record cell
+;   reachable     ; Union/find set -- all reachable cells.
+;   id            ; Identifying info (e.g., the coords of the cell).
+;   (walls -1)    ; A bitset telling which walls are still standing.
+;   (parent #f)   ; For DFS spanning tree construction.
+;   (mark #f))    ; For marking the solution path.
+
+(define (make-wall owner neighbor bit)
+  (vector 'wall owner neighbor bit))
+
+(define (wall:owner o)          (vector-ref o 1))
+(define (set-wall:owner o v)    (vector-set! o 1 v))
+(define (wall:neighbor o)       (vector-ref o 2))
+(define (set-wall:neighbor o v) (vector-set! o 2 v))
+(define (wall:bit o)            (vector-ref o 3))
+(define (set-wall:bit o v)      (vector-set! o 3 v))
+
+(define (make-cell reachable id)
+  (vector 'cell reachable id -1 #f #f))
+
+(define (cell:reachable o)       (vector-ref o 1))
+(define (set-cell:reachable o v) (vector-set! o 1 v))
+(define (cell:id o)              (vector-ref o 2))
+(define (set-cell:id o v)        (vector-set! o 2 v))
+(define (cell:walls o)           (vector-ref o 3))
+(define (set-cell:walls o v)     (vector-set! o 3 v))
+(define (cell:parent o)          (vector-ref o 4))
+(define (set-cell:parent o v)    (vector-set! o 4 v))
+(define (cell:mark o)            (vector-ref o 5))
+(define (set-cell:mark o v)      (vector-set! o 5 v))
+
+;;; Iterates in reverse order.
+
+(define (vec-for-each proc v)
+  (let lp ((i (- (vector-length v) 1)))
+    (cond ((>= i 0)
+           (proc (vector-ref v i))
+           (lp (- i 1))))))
+
+
+;;; Randomly permute a vector.
+
+(define (permute-vec! v random-state)
+  (let lp ((i (- (vector-length v) 1)))
+    (cond ((> i 1)
+           (let ((elt-i (vector-ref v i))
+                 (j (random-int i random-state)))       ; j in [0,i)
+             (vector-set! v i (vector-ref v j))
+             (vector-set! v j elt-i))
+           (lp (- i 1)))))
+  v)
+
+
+;;; This is the core of the algorithm.
+
+(define (dig-maze walls ncells)
+  (call-with-current-continuation
+    (lambda (quit)
+      (vec-for-each
+       (lambda (wall)                   ; For each wall,
+         (let* ((c1   (wall:owner wall)) ; find the cells on
+                (set1 (cell:reachable c1))
+
+                (c2   (wall:neighbor wall)) ; each side of the wall
+                (set2 (cell:reachable c2)))
+
+           ;; If there is no path from c1 to c2, knock down the
+           ;; wall and union the two sets of reachable cells.
+           ;; If the new set of reachable cells is the whole set
+           ;; of cells, quit.
+           (if (not (set-equal? set1 set2))
+               (let ((walls (cell:walls c1))    
+                     (wall-mask (bitwise-not (wall:bit wall))))
+                 (union! set1 set2)
+                 (set-cell:walls c1 (bitwise-and walls wall-mask))
+                 (if (= (set-size set1) ncells) (quit #f))))))
+       walls))))
+
+
+;;; Some simple DFS routines useful for determining path length 
+;;; through the maze.
+
+;;; Build a DFS tree from ROOT. 
+;;; (DO-CHILDREN proc maze node) applies PROC to each of NODE's children.
+;;; We assume there are no loops in the maze; if this is incorrect, the
+;;; algorithm will diverge.
+
+(define (dfs-maze maze root do-children)
+  (let search ((node root) (parent #f))
+    (set-cell:parent node parent)
+    (do-children (lambda (child)
+                   (if (not (eq? child parent))
+                       (search child node)))
+                 maze node)))
+
+;;; Move the root to NEW-ROOT.
+
+(define (reroot-maze new-root)
+  (let lp ((node new-root) (new-parent #f))
+    (let ((old-parent (cell:parent node)))
+      (set-cell:parent node new-parent)
+      (if old-parent (lp old-parent node)))))
+
+;;; How far from CELL to the root?
+
+(define (path-length cell)
+  (do ((len 0 (+ len 1))
+       (node (cell:parent cell) (cell:parent node)))
+      ((not node) len)))
+
+;;; Mark the nodes from NODE back to root. Used to mark the winning path.
+
+(define (mark-path node)
+  (let lp ((node node))
+    (set-cell:mark node #t)
+    (cond ((cell:parent node) => lp))))
+
+;------------------------------------------------------------------------------
+; Was file "harr.scm".
+
+;;; Hex arrays
+;;; Copyright (c) 1995 by Olin Shivers.
+
+;;; External dependencies:
+;;; - define-record
+
+;;;        ___       ___       ___
+;;;       /   \     /   \     /   \
+;;;   ___/  A  \___/  A  \___/  A  \___
+;;;  /   \     /   \     /   \     /   \
+;;; /  A  \___/  A  \___/  A  \___/  A  \
+;;; \     /   \     /   \     /   \     /
+;;;  \___/     \___/     \___/     \___/
+;;;  /   \     /   \     /   \     /   \
+;;; /     \___/     \___/     \___/     \
+;;; \     /   \     /   \     /   \     /
+;;;  \___/     \___/     \___/     \___/
+;;;  /   \     /   \     /   \     /   \
+;;; /     \___/     \___/     \___/     \
+;;; \     /   \     /   \     /   \     /
+;;;  \___/     \___/     \___/     \___/
+
+;;; Hex arrays are indexed by the (x,y) coord of the center of the hexagonal
+;;; element. Hexes are three wide and two high; e.g., to get from the center
+;;; of an elt to its {NW, N, NE} neighbors, add {(-3,1), (0,2), (3,1)}
+;;; respectively.
+;;;
+;;; Hex arrays are represented with a matrix, essentially made by shoving the
+;;; odd columns down a half-cell so things line up. The mapping is as follows:
+;;;     Center coord      row/column
+;;;     ------------      ----------
+;;;     (x,  y)        -> (y/2, x/3)
+;;;     (3c, 2r + c&1) <- (r,   c)
+
+
+; (define-record harr
+;   nrows
+;   ncols
+;   elts)
+
+(define (make-harr nrows ncols elts)
+  (vector 'harr nrows ncols elts))
+
+(define (harr:nrows o)       (vector-ref o 1))
+(define (set-harr:nrows o v) (vector-set! o 1 v))
+(define (harr:ncols o)       (vector-ref o 2))
+(define (set-harr:ncols o v) (vector-set! o 2 v))
+(define (harr:elts o)        (vector-ref o 3))
+(define (set-harr:elts o v)  (vector-set! o 3 v))
+
+(define (harr r c)
+  (make-harr r c (make-vector (* r c))))
+
+
+
+(define (href ha x y)
+  (let ((r (quotient y 2))
+        (c (quotient x 3)))
+    (vector-ref (harr:elts ha)
+                (+ (* (harr:ncols ha) r) c))))
+
+(define (hset! ha x y val)
+  (let ((r (quotient y 2))
+        (c (quotient x 3)))
+    (vector-set! (harr:elts ha)
+                 (+ (* (harr:ncols ha) r) c)
+                 val)))
+
+(define (href/rc ha r c)
+    (vector-ref (harr:elts ha)
+                (+ (* (harr:ncols ha) r) c)))
+
+;;; Create a nrows x ncols hex array. The elt centered on coord (x, y)
+;;; is the value returned by (PROC x y).
+
+(define (harr-tabulate nrows ncols proc)
+  (let ((v (make-vector (* nrows ncols))))
+
+    (do ((r (- nrows 1) (- r 1)))
+        ((< r 0))
+      (do ((c 0 (+ c 1))
+           (i (* r ncols) (+ i 1)))
+          ((= c ncols))
+        (vector-set! v i (proc (* 3 c) (+ (* 2 r) (bitwise-and c 1))))))
+
+    (make-harr nrows ncols v)))
+
+
+(define (harr-for-each proc harr)
+  (vec-for-each proc (harr:elts harr)))
+
+;------------------------------------------------------------------------------
+; Was file "hex.scm".
+
+;;; Hexagonal hackery for maze generation.
+;;; Copyright (c) 1995 by Olin Shivers.
+
+;;; External dependencies:
+;;; - cell and wall records
+;;; - Functional Postscript for HEXES->PATH
+;;; - logical functions for bit hacking
+;;; - hex array code.
+
+;;; To have the maze span (0,0) to (1,1):
+;;; (scale (/ (+ 1 (* 3 ncols))) (/ (+ 1 (* 2 nrows)))
+;;;        (translate (point 2 1) maze))
+
+;;; Every elt of the hex array manages his SW, S, and SE wall.
+;;; Terminology: - An even column is one whose column index is even. That
+;;;                means the first, third, ... columns (indices 0, 2, ...).
+;;;              - An odd column is one whose column index is odd. That
+;;;                means the second, fourth... columns (indices 1, 3, ...).
+;;;              The even/odd flip-flop is confusing; be careful to keep it
+;;;              straight. The *even* columns are the low ones. The *odd*
+;;;              columns are the high ones.
+;;;    _   _
+;;;  _/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/
+;;;  0 1 2 3
+
+(define south-west 1)
+(define south      2)
+(define south-east 4)
+
+(define (gen-maze-array r c)
+  (harr-tabulate r c (lambda (x y) (make-cell (base-set 1) (cons x y)))))
+
+;;; This could be made more efficient.
+(define (make-wall-vec harr)
+  (let* ((nrows (harr:nrows harr))
+         (ncols (harr:ncols harr))
+         (xmax (* 3 (- ncols 1)))
+
+         ;; Accumulate walls.
+         (walls '())
+         (add-wall (lambda (o n b) ; owner neighbor bit
+                     (set! walls (cons (make-wall o n b) walls)))))
+        
+    ;; Do everything but the bottom row.
+    (do ((x (* (- ncols 1) 3) (- x 3)))
+        ((< x 0))
+      (do ((y (+ (* (- nrows 1) 2) (bitwise-and x 1))
+              (- y 2)))
+          ((<= y 1))    ; Don't do bottom row.
+          (let ((hex (href harr x y)))
+            (if (not (zero? x))
+                (add-wall hex (href harr (- x 3) (- y 1)) south-west))
+            (add-wall hex (href harr x (- y 2)) south)
+            (if (< x xmax)
+                (add-wall hex (href harr (+ x 3) (- y 1)) south-east)))))
+
+    ;; Do the SE and SW walls of the odd columns on the bottom row.
+    ;; If the rightmost bottom hex lies in an odd column, however,
+    ;; don't add it's SE wall -- it's a corner hex, and has no SE neighbor.
+    (if (> ncols 1)
+        (let ((rmoc-x (+ 3 (* 6 (quotient (- ncols 2) 2)))))
+          ;; Do rightmost odd col.
+          (let ((rmoc-hex (href harr rmoc-x 1)))
+            (if (< rmoc-x xmax) ; Not  a corner -- do E wall.
+                (add-wall rmoc-hex (href harr xmax 0) south-east))
+            (add-wall rmoc-hex (href harr (- rmoc-x 3) 0) south-west))
+
+          (do ((x (- rmoc-x 6) ; Do the rest of the bottom row's odd cols.
+                  (- x 6)))
+              ((< x 3)) ; 3 is X coord of leftmost odd column.
+            (add-wall (href harr x 1) (href harr (- x 3) 0) south-west)
+            (add-wall (href harr x 1) (href harr (+ x 3) 0) south-east))))
+
+    (list->vector walls)))
+
+
+;;; Find the cell ctop from the top row, and the cell cbot from the bottom
+;;; row such that cbot is furthest from ctop. 
+;;; Return [ctop-x, ctop-y, cbot-x, cbot-y].
+
+(define (pick-entrances harr)
+  (dfs-maze harr (href/rc harr 0 0) for-each-hex-child)
+  (let ((nrows (harr:nrows harr))
+        (ncols (harr:ncols harr)))
+    (let tp-lp ((max-len -1)
+                (entrance #f)
+                (exit #f)
+                (tcol (- ncols 1)))
+      (if (< tcol 0) (vector entrance exit)
+          (let ((top-cell (href/rc harr (- nrows 1) tcol)))
+            (reroot-maze top-cell)
+            (let ((result
+                    (let bt-lp ((max-len max-len)
+                                (entrance entrance)
+                                (exit exit)
+                                (bcol (- ncols 1)))
+;                     (format #t "~a ~a ~a ~a~%" max-len entrance exit bcol)
+                      (if (< bcol 0) (vector max-len entrance exit)
+                          (let ((this-len (path-length (href/rc harr 0 bcol))))
+                            (if (> this-len max-len)
+                                (bt-lp this-len tcol bcol (- bcol 1))
+                                (bt-lp max-len  entrance exit (- bcol 1))))))))
+              (let ((max-len (vector-ref result 0))
+                    (entrance (vector-ref result 1))
+                    (exit (vector-ref result 2)))
+                (tp-lp max-len entrance exit (- tcol 1)))))))))
+                
+
+
+;;; Apply PROC to each node reachable from CELL.
+(define (for-each-hex-child proc harr cell)
+  (let* ((walls (cell:walls cell))
+         (id (cell:id cell))
+         (x (car id))
+         (y (cdr id))
+         (nr (harr:nrows harr))
+         (nc (harr:ncols harr))
+         (maxy (* 2 (- nr 1)))
+         (maxx (* 3 (- nc 1))))
+    (if (not (bit-test walls south-west)) (proc (href harr (- x 3) (- y 1))))
+    (if (not (bit-test walls south))      (proc (href harr x       (- y 2))))
+    (if (not (bit-test walls south-east)) (proc (href harr (+ x 3) (- y 1))))
+
+    ;; NW neighbor, if there is one (we may be in col 1, or top row/odd col)
+    (if (and (> x 0)    ; Not in first column.
+             (or (<= y maxy)            ; Not on top row or
+                 (zero? (modulo x 6)))) ; not in an odd column.
+        (let ((nw (href harr (- x 3) (+ y 1))))
+          (if (not (bit-test (cell:walls nw) south-east)) (proc nw))))
+
+    ;; N neighbor, if there is one (we may be on top row).
+    (if (< y maxy)              ; Not on top row
+        (let ((n (href harr x (+ y 2))))
+          (if (not (bit-test (cell:walls n) south)) (proc n))))
+
+    ;; NE neighbor, if there is one (we may be in last col, or top row/odd col)
+    (if (and (< x maxx) ; Not in last column.
+             (or (<= y maxy)            ; Not on top row or
+                 (zero? (modulo x 6)))) ; not in an odd column.
+        (let ((ne (href harr (+ x 3) (+ y 1))))
+          (if (not (bit-test (cell:walls ne) south-west)) (proc ne))))))
+
+
+
+;;; The top-level
+(define (make-maze nrows ncols)
+  (let* ((cells (gen-maze-array nrows ncols))
+         (walls (permute-vec! (make-wall-vec cells) (random-state 20))))
+    (dig-maze walls (* nrows ncols))
+    (let ((result (pick-entrances cells)))
+      (let ((entrance (vector-ref result 0))
+            (exit (vector-ref result 1)))
+        (let* ((exit-cell (href/rc cells 0 exit))
+               (walls (cell:walls exit-cell)))
+          (reroot-maze (href/rc cells (- nrows 1) entrance))
+          (mark-path exit-cell)
+          (set-cell:walls exit-cell (bitwise-and walls (bitwise-not south)))
+          (vector cells entrance exit))))))
+
+
+(define (pmaze nrows ncols)
+  (let ((result (make-maze nrows ncols)))
+    (let ((cells (vector-ref result 0))
+          (entrance (vector-ref result 1))
+          (exit (vector-ref result 2)))
+      (print-hexmaze cells entrance))))
+
+;------------------------------------------------------------------------------
+; Was file "hexprint.scm".
+
+;;; Print out a hex array with characters.
+;;; Copyright (c) 1995 by Olin Shivers.
+
+;;; External dependencies:
+;;; - hex array code
+;;; - hex cell code
+
+;;;    _   _
+;;;  _/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ 
+
+;;; Top part of top row looks like this:
+;;;    _   _  _   _
+;;;  _/ \_/ \/ \_/ \
+;;; /        
+
+(define output #f) ; the list of all characters written out, in reverse order.
+
+(define (write-ch c)
+  (set! output (cons c output)))
+
+(define (print-hexmaze harr entrance)
+  (let* ((nrows  (harr:nrows harr))
+         (ncols  (harr:ncols harr))
+         (ncols2 (* 2 (quotient ncols 2))))
+
+    ;; Print out the flat tops for the top row's odd cols.
+    (do ((c 1 (+ c 2)))
+        ((>= c ncols))
+;     (display "   ")
+      (write-ch #\space)
+      (write-ch #\space)
+      (write-ch #\space)
+      (write-ch (if (= c entrance) #\space #\_)))
+;   (newline)
+    (write-ch #\newline)
+
+    ;; Print out the slanted tops for the top row's odd cols
+    ;; and the flat tops for the top row's even cols.
+    (write-ch #\space)
+    (do ((c 0 (+ c 2)))
+        ((>= c ncols2))
+;     (format #t "~a/~a\\"
+;             (if (= c entrance) #\space #\_)
+;             (dot/space harr (- nrows 1) (+ c 1)))
+      (write-ch (if (= c entrance) #\space #\_))
+      (write-ch #\/)
+      (write-ch (dot/space harr (- nrows 1) (+ c 1)))
+      (write-ch #\\))
+    (if (odd? ncols)
+        (write-ch (if (= entrance (- ncols 1)) #\space #\_)))
+;   (newline)
+    (write-ch #\newline)
+
+    (do ((r (- nrows 1) (- r 1)))
+        ((< r 0))
+
+      ;; Do the bottoms for row r's odd cols.
+      (write-ch #\/)
+      (do ((c 1 (+ c 2)))
+          ((>= c ncols2))
+        ;; The dot/space for the even col just behind c.
+        (write-ch (dot/space harr r (- c 1)))
+        (display-hexbottom (cell:walls (href/rc harr r c))))    
+
+      (cond ((odd? ncols)
+             (write-ch (dot/space harr r (- ncols 1)))
+             (write-ch #\\)))
+;     (newline)
+      (write-ch #\newline)
+
+      ;; Do the bottoms for row r's even cols.
+      (do ((c 0 (+ c 2)))
+          ((>= c ncols2))
+        (display-hexbottom (cell:walls (href/rc harr r c)))
+        ;; The dot/space is for the odd col just after c, on row below.
+        (write-ch (dot/space harr (- r 1) (+ c 1))))
+      
+      (cond ((odd? ncols)
+             (display-hexbottom (cell:walls (href/rc harr r (- ncols 1)))))
+            ((not (zero? r)) (write-ch #\\)))
+;     (newline)
+      (write-ch #\newline))))
+
+(define (bit-test j bit)
+  (not (zero? (bitwise-and j bit))))
+
+;;; Return a . if harr[r,c] is marked, otherwise a space.
+;;; We use the dot to mark the solution path.
+(define (dot/space harr r c)
+  (if (and (>= r 0) (cell:mark (href/rc harr r c))) #\. #\space))
+
+;;; Print a \_/ hex bottom.
+(define (display-hexbottom hexwalls)
+  (write-ch (if (bit-test hexwalls south-west) #\\ #\space))
+  (write-ch (if (bit-test hexwalls south     ) #\_ #\space))
+  (write-ch (if (bit-test hexwalls south-east) #\/ #\space)))
+
+;;;    _   _
+;;;  _/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ \_/
+;;; / \_/ \_/
+;;; \_/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ \_/
+
+;------------------------------------------------------------------------------
+
+(let ((input (with-input-from-file "input.txt" read)))
+  (time (let loop ((n 1000) (v 0))
+          (if (zero? n)
+              (list->string v)
+              (begin
+                (set! output '())
+                (pmaze 20 (if input 7 0))
+                (loop (- n 1) output))))))
diff --git a/benchmarks/gabriel/mazefun.sch b/benchmarks/gabriel/mazefun.sch
new file mode 100644
index 00000000..bec2f56e
--- /dev/null
+++ b/benchmarks/gabriel/mazefun.sch
@@ -0,0 +1,206 @@
+;;; MAZEFUN -- Constructs a maze in a purely functional way,
+;;; written by Marc Feeley.
+
+(define iota
+  (lambda (n)
+    (iota-iter n '())))
+
+(define iota-iter
+  (lambda (n lst)
+    (if (= n 0)
+        lst
+        (iota-iter (- n 1) (cons n lst)))))
+
+(define foldr
+  (lambda (f base lst)
+
+    (define foldr-aux
+      (lambda (lst)
+        (if (null? lst)
+            base
+            (f (car lst) (foldr-aux (cdr lst))))))
+
+    (foldr-aux lst)))
+
+(define foldl
+  (lambda (f base lst)
+
+    (define foldl-aux
+      (lambda (base lst)
+        (if (null? lst)
+          base
+          (foldl-aux (f base (car lst)) (cdr lst)))))
+
+    (foldl-aux base lst)))
+
+(define for
+  (lambda (lo hi f)
+
+    (define for-aux
+      (lambda (lo)
+        (if (< lo hi)
+            (cons (f lo) (for-aux (+ lo 1)))
+            '())))
+
+    (for-aux lo)))
+
+(define concat
+  (lambda (lists)
+    (foldr append '() lists)))
+
+(define list-read
+  (lambda (lst i)
+    (if (= i 0)
+        (car lst)
+        (list-read (cdr lst) (- i 1)))))
+
+(define list-write
+  (lambda (lst i val)
+    (if (= i 0)
+        (cons val (cdr lst))
+        (cons (car lst) (list-write (cdr lst) (- i 1) val)))))
+
+(define list-remove-pos
+  (lambda (lst i)
+    (if (= i 0)
+        (cdr lst)
+        (cons (car lst) (list-remove-pos (cdr lst) (- i 1))))))
+
+(define duplicates?
+  (lambda (lst)
+    (if (null? lst)
+        #f
+        (or (member (car lst) (cdr lst))
+            (duplicates? (cdr lst))))))
+
+; Manipulation de matrices.
+
+(define make-matrix
+  (lambda (n m init)
+    (for 0 n (lambda (i) (for 0 m (lambda (j) (init i j)))))))
+
+(define matrix-read
+  (lambda (mat i j)
+    (list-read (list-read mat i) j)))
+
+(define matrix-write
+  (lambda (mat i j val)
+    (list-write mat i (list-write (list-read mat i) j val))))
+
+(define matrix-size
+  (lambda (mat)
+    (cons (length mat) (length (car mat)))))
+
+(define matrix-map
+  (lambda (f mat)
+    (map (lambda (lst) (map f lst)) mat)))
+
+(define initial-random 0)
+
+(define next-random
+  (lambda (current-random)
+    (remainder (+ (* current-random 3581) 12751) 131072)))
+
+(define shuffle
+  (lambda (lst)
+    (shuffle-aux lst initial-random)))
+
+(define shuffle-aux
+  (lambda (lst current-random)
+    (if (null? lst)
+        '()
+        (let ((new-random (next-random current-random)))
+          (let ((i (modulo new-random (length lst))))
+            (cons (list-read lst i)
+                  (shuffle-aux (list-remove-pos lst i)
+                               new-random)))))))
+
+(define make-maze
+  (lambda (n m) ; n and m must be odd
+    (if (not (and (odd? n) (odd? m)))
+        'error
+        (let ((cave
+               (make-matrix n m (lambda (i j)
+                                  (if (and (even? i) (even? j))
+                                      (cons i j)
+                                      #f))))
+              (possible-holes
+               (concat
+                (for 0 n (lambda (i)
+                           (concat
+                            (for 0 m (lambda (j)
+                                       (if (equal? (even? i) (even? j))
+                                           '()
+                                           (list (cons i j)))))))))))
+          (cave-to-maze (pierce-randomly (shuffle possible-holes) cave))))))
+
+(define cave-to-maze
+  (lambda (cave)
+    (matrix-map (lambda (x) (if x '_ '*)) cave)))
+
+(define pierce
+  (lambda (pos cave)
+    (let ((i (car pos)) (j (cdr pos)))
+      (matrix-write cave i j pos))))
+
+(define pierce-randomly
+  (lambda (possible-holes cave)
+    (if (null? possible-holes)
+        cave
+        (let ((hole (car possible-holes)))
+          (pierce-randomly (cdr possible-holes)
+                           (try-to-pierce hole cave))))))
+
+(define try-to-pierce
+  (lambda (pos cave)
+    (let ((i (car pos)) (j (cdr pos)))
+      (let ((ncs (neighboring-cavities pos cave)))
+        (if (duplicates?
+             (map (lambda (nc) (matrix-read cave (car nc) (cdr nc))) ncs))
+            cave
+            (pierce pos
+                    (foldl (lambda (c nc) (change-cavity c nc pos))
+                           cave
+                           ncs)))))))
+
+(define change-cavity
+  (lambda (cave pos new-cavity-id)
+    (let ((i (car pos)) (j (cdr pos)))
+      (change-cavity-aux cave pos new-cavity-id (matrix-read cave i j)))))
+
+(define change-cavity-aux
+  (lambda (cave pos new-cavity-id old-cavity-id)
+    (let ((i (car pos)) (j (cdr pos)))
+      (let ((cavity-id (matrix-read cave i j)))
+        (if (equal? cavity-id old-cavity-id)
+            (foldl (lambda (c nc)
+                     (change-cavity-aux c nc new-cavity-id old-cavity-id))
+                   (matrix-write cave i j new-cavity-id)
+                   (neighboring-cavities pos cave))
+            cave)))))
+
+(define neighboring-cavities
+  (lambda (pos cave)
+    (let ((size (matrix-size cave)))
+      (let ((n (car size)) (m (cdr size)))
+        (let ((i (car pos)) (j (cdr pos)))
+          (append (if (and (> i 0) (matrix-read cave (- i 1) j))
+                      (list (cons (- i 1) j))
+                      '())
+                  (if (and (< i (- n 1)) (matrix-read cave (+ i 1) j))
+                      (list (cons (+ i 1) j))
+                      '())
+                  (if (and (> j 0) (matrix-read cave i (- j 1)))
+                      (list (cons i (- j 1)))
+                      '())
+                  (if (and (< j (- m 1)) (matrix-read cave i (+ j 1)))
+                      (list (cons i (+ j 1)))
+                      '())))))))
+
+
+(let ((input (with-input-from-file "input.txt" read)))
+  (time (let loop ((n 500) (v 0))
+          (if (zero? n)
+              v
+              (loop (- n 1)
+                    (make-maze 11 (if input 11 0)))))))
diff --git a/benchmarks/gabriel/nboyer.sch b/benchmarks/gabriel/nboyer.sch
new file mode 100644
index 00000000..c7e887a2
--- /dev/null
+++ b/benchmarks/gabriel/nboyer.sch
@@ -0,0 +1,759 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File:         nboyer.sch
+; Description:  The Boyer benchmark
+; Author:       Bob Boyer
+; Created:      5-Apr-85
+; Modified:     10-Apr-85 14:52:20 (Bob Shaw)
+;               22-Jul-87 (Will Clinger)
+;               2-Jul-88 (Will Clinger -- distinguished #f and the empty list)
+;               13-Feb-97 (Will Clinger -- fixed bugs in unifier and rules,
+;                          rewrote to eliminate property lists, and added
+;                          a scaling parameter suggested by Bob Boyer)
+;               19-Mar-99 (Will Clinger -- cleaned up comments)
+;               4-Apr-01 (Will Clinger -- changed four 1- symbols to sub1)
+; Language:     Scheme
+; Status:       Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; NBOYER -- Logic programming benchmark, originally written by Bob Boyer.
+;;; Fairly CONS intensive.
+
+; Note:  The version of this benchmark that appears in Dick Gabriel's book
+; contained several bugs that are corrected here.  These bugs are discussed
+; by Henry Baker, "The Boyer Benchmark Meets Linear Logic", ACM SIGPLAN Lisp
+; Pointers 6(4), October-December 1993, pages 3-10.  The fixed bugs are:
+;
+;    The benchmark now returns a boolean result.
+;    FALSEP and TRUEP use TERM-MEMBER? rather than MEMV (which is called MEMBER
+;         in Common Lisp)
+;    ONE-WAY-UNIFY1 now treats numbers correctly
+;    ONE-WAY-UNIFY1-LST now treats empty lists correctly
+;    Rule 19 has been corrected (this rule was not touched by the original
+;         benchmark, but is used by this version)
+;    Rules 84 and 101 have been corrected (but these rules are never touched
+;         by the benchmark)
+;
+; According to Baker, these bug fixes make the benchmark 10-25% slower.
+; Please do not compare the timings from this benchmark against those of
+; the original benchmark.
+;
+; This version of the benchmark also prints the number of rewrites as a sanity
+; check, because it is too easy for a buggy version to return the correct
+; boolean result.  The correct number of rewrites is
+;
+;     n      rewrites       peak live storage (approximate, in bytes)
+;     0         95024           520,000
+;     1        591777         2,085,000
+;     2       1813975         5,175,000
+;     3       5375678
+;     4      16445406
+;     5      51507739
+
+; Nboyer is a 2-phase benchmark.
+; The first phase attaches lemmas to symbols.  This phase is not timed,
+; but it accounts for very little of the runtime anyway.
+; The second phase creates the test problem, and tests to see
+; whether it is implied by the lemmas.
+
+(define (nboyer-benchmark . args)
+  (let ((n (if (null? args) 0 (car args))))
+    (setup-boyer)
+    (time (test-boyer n))))
+
+(define (setup-boyer) #t) ; assigned below
+(define (test-boyer) #t)  ; assigned below
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;
+; The first phase.
+;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+; In the original benchmark, it stored a list of lemmas on the
+; property lists of symbols.
+; In the new benchmark, it maintains an association list of
+; symbols and symbol-records, and stores the list of lemmas
+; within the symbol-records.
+
+(let ()
+  
+  (define (setup)
+    (add-lemma-lst
+     (quote ((equal (compile form)
+                    (reverse (codegen (optimize form)
+                                      (nil))))
+             (equal (eqp x y)
+                    (equal (fix x)
+                           (fix y)))
+             (equal (greaterp x y)
+                    (lessp y x))
+             (equal (lesseqp x y)
+                    (not (lessp y x)))
+             (equal (greatereqp x y)
+                    (not (lessp x y)))
+             (equal (boolean x)
+                    (or (equal x (t))
+                        (equal x (f))))
+             (equal (iff x y)
+                    (and (implies x y)
+                         (implies y x)))
+             (equal (even1 x)
+                    (if (zerop x)
+                        (t)
+                        (odd (sub1 x))))
+             (equal (countps- l pred)
+                    (countps-loop l pred (zero)))
+             (equal (fact- i)
+                    (fact-loop i 1))
+             (equal (reverse- x)
+                    (reverse-loop x (nil)))
+             (equal (divides x y)
+                    (zerop (remainder y x)))
+             (equal (assume-true var alist)
+                    (cons (cons var (t))
+                          alist))
+             (equal (assume-false var alist)
+                    (cons (cons var (f))
+                          alist))
+             (equal (tautology-checker x)
+                    (tautologyp (normalize x)
+                                (nil)))
+             (equal (falsify x)
+                    (falsify1 (normalize x)
+                              (nil)))
+             (equal (prime x)
+                    (and (not (zerop x))
+                         (not (equal x (add1 (zero))))
+                         (prime1 x (sub1 x))))
+             (equal (and p q)
+                    (if p (if q (t)
+                                (f))
+                          (f)))
+             (equal (or p q)
+                    (if p (t)
+                          (if q (t)
+                                (f))))
+             (equal (not p)
+                    (if p (f)
+                          (t)))
+             (equal (implies p q)
+                    (if p (if q (t)
+                                (f))
+                          (t)))
+             (equal (fix x)
+                    (if (numberp x)
+                        x
+                        (zero)))
+             (equal (if (if a b c)
+                        d e)
+                    (if a (if b d e)
+                          (if c d e)))
+             (equal (zerop x)
+                    (or (equal x (zero))
+                        (not (numberp x))))
+             (equal (plus (plus x y)
+                          z)
+                    (plus x (plus y z)))
+             (equal (equal (plus a b)
+                           (zero))
+                    (and (zerop a)
+                         (zerop b)))
+             (equal (difference x x)
+                    (zero))
+             (equal (equal (plus a b)
+                           (plus a c))
+                    (equal (fix b)
+                           (fix c)))
+             (equal (equal (zero)
+                           (difference x y))
+                    (not (lessp y x)))
+             (equal (equal x (difference x y))
+                    (and (numberp x)
+                         (or (equal x (zero))
+                             (zerop y))))
+             (equal (meaning (plus-tree (append x y))
+                             a)
+                    (plus (meaning (plus-tree x)
+                                   a)
+                          (meaning (plus-tree y)
+                                   a)))
+             (equal (meaning (plus-tree (plus-fringe x))
+                             a)
+                    (fix (meaning x a)))
+             (equal (append (append x y)
+                            z)
+                    (append x (append y z)))
+             (equal (reverse (append a b))
+                    (append (reverse b)
+                            (reverse a)))
+             (equal (times x (plus y z))
+                    (plus (times x y)
+                          (times x z)))
+             (equal (times (times x y)
+                           z)
+                    (times x (times y z)))
+             (equal (equal (times x y)
+                           (zero))
+                    (or (zerop x)
+                        (zerop y)))
+             (equal (exec (append x y)
+                          pds envrn)
+                    (exec y (exec x pds envrn)
+                            envrn))
+             (equal (mc-flatten x y)
+                    (append (flatten x)
+                            y))
+             (equal (member x (append a b))
+                    (or (member x a)
+                        (member x b)))
+             (equal (member x (reverse y))
+                    (member x y))
+             (equal (length (reverse x))
+                    (length x))
+             (equal (member a (intersect b c))
+                    (and (member a b)
+                         (member a c)))
+             (equal (nth (zero)
+                         i)
+                    (zero))
+             (equal (exp i (plus j k))
+                    (times (exp i j)
+                           (exp i k)))
+             (equal (exp i (times j k))
+                    (exp (exp i j)
+                         k))
+             (equal (reverse-loop x y)
+                    (append (reverse x)
+                            y))
+             (equal (reverse-loop x (nil))
+                    (reverse x))
+             (equal (count-list z (sort-lp x y))
+                    (plus (count-list z x)
+                          (count-list z y)))
+             (equal (equal (append a b)
+                           (append a c))
+                    (equal b c))
+             (equal (plus (remainder x y)
+                          (times y (quotient x y)))
+                    (fix x))
+             (equal (power-eval (big-plus1 l i base)
+                                base)
+                    (plus (power-eval l base)
+                          i))
+             (equal (power-eval (big-plus x y i base)
+                                base)
+                    (plus i (plus (power-eval x base)
+                                  (power-eval y base))))
+             (equal (remainder y 1)
+                    (zero))
+             (equal (lessp (remainder x y)
+                           y)
+                    (not (zerop y)))
+             (equal (remainder x x)
+                    (zero))
+             (equal (lessp (quotient i j)
+                           i)
+                    (and (not (zerop i))
+                         (or (zerop j)
+                             (not (equal j 1)))))
+             (equal (lessp (remainder x y)
+                           x)
+                    (and (not (zerop y))
+                         (not (zerop x))
+                         (not (lessp x y))))
+             (equal (power-eval (power-rep i base)
+                                base)
+                    (fix i))
+             (equal (power-eval (big-plus (power-rep i base)
+                                          (power-rep j base)
+                                          (zero)
+                                          base)
+                                base)
+                    (plus i j))
+             (equal (gcd x y)
+                    (gcd y x))
+             (equal (nth (append a b)
+                         i)
+                    (append (nth a i)
+                            (nth b (difference i (length a)))))
+             (equal (difference (plus x y)
+                                x)
+                    (fix y))
+             (equal (difference (plus y x)
+                                x)
+                    (fix y))
+             (equal (difference (plus x y)
+                                (plus x z))
+                    (difference y z))
+             (equal (times x (difference c w))
+                    (difference (times c x)
+                                (times w x)))
+             (equal (remainder (times x z)
+                               z)
+                    (zero))
+             (equal (difference (plus b (plus a c))
+                                a)
+                    (plus b c))
+             (equal (difference (add1 (plus y z))
+                                z)
+                    (add1 y))
+             (equal (lessp (plus x y)
+                           (plus x z))
+                    (lessp y z))
+             (equal (lessp (times x z)
+                           (times y z))
+                    (and (not (zerop z))
+                         (lessp x y)))
+             (equal (lessp y (plus x y))
+                    (not (zerop x)))
+             (equal (gcd (times x z)
+                         (times y z))
+                    (times z (gcd x y)))
+             (equal (value (normalize x)
+                           a)
+                    (value x a))
+             (equal (equal (flatten x)
+                           (cons y (nil)))
+                    (and (nlistp x)
+                         (equal x y)))
+             (equal (listp (gopher x))
+                    (listp x))
+             (equal (samefringe x y)
+                    (equal (flatten x)
+                           (flatten y)))
+             (equal (equal (greatest-factor x y)
+                           (zero))
+                    (and (or (zerop y)
+                             (equal y 1))
+                         (equal x (zero))))
+             (equal (equal (greatest-factor x y)
+                           1)
+                    (equal x 1))
+             (equal (numberp (greatest-factor x y))
+                    (not (and (or (zerop y)
+                                  (equal y 1))
+                              (not (numberp x)))))
+             (equal (times-list (append x y))
+                    (times (times-list x)
+                           (times-list y)))
+             (equal (prime-list (append x y))
+                    (and (prime-list x)
+                         (prime-list y)))
+             (equal (equal z (times w z))
+                    (and (numberp z)
+                         (or (equal z (zero))
+                             (equal w 1))))
+             (equal (greatereqp x y)
+                    (not (lessp x y)))
+             (equal (equal x (times x y))
+                    (or (equal x (zero))
+                        (and (numberp x)
+                             (equal y 1))))
+             (equal (remainder (times y x)
+                               y)
+                    (zero))
+             (equal (equal (times a b)
+                           1)
+                    (and (not (equal a (zero)))
+                         (not (equal b (zero)))
+                         (numberp a)
+                         (numberp b)
+                         (equal (sub1 a)
+                                (zero))
+                         (equal (sub1 b)
+                                (zero))))
+             (equal (lessp (length (delete x l))
+                           (length l))
+                    (member x l))
+             (equal (sort2 (delete x l))
+                    (delete x (sort2 l)))
+             (equal (dsort x)
+                    (sort2 x))
+             (equal (length (cons x1
+                                  (cons x2
+                                        (cons x3 (cons x4
+                                                       (cons x5
+                                                             (cons x6 x7)))))))
+                    (plus 6 (length x7)))
+             (equal (difference (add1 (add1 x))
+                                2)
+                    (fix x))
+             (equal (quotient (plus x (plus x y))
+                              2)
+                    (plus x (quotient y 2)))
+             (equal (sigma (zero)
+                           i)
+                    (quotient (times i (add1 i))
+                              2))
+             (equal (plus x (add1 y))
+                    (if (numberp y)
+                        (add1 (plus x y))
+                        (add1 x)))
+             (equal (equal (difference x y)
+                           (difference z y))
+                    (if (lessp x y)
+                        (not (lessp y z))
+                        (if (lessp z y)
+                            (not (lessp y x))
+                            (equal (fix x)
+                                   (fix z)))))
+             (equal (meaning (plus-tree (delete x y))
+                             a)
+                    (if (member x y)
+                        (difference (meaning (plus-tree y)
+                                             a)
+                                    (meaning x a))
+                        (meaning (plus-tree y)
+                                 a)))
+             (equal (times x (add1 y))
+                    (if (numberp y)
+                        (plus x (times x y))
+                        (fix x)))
+             (equal (nth (nil)
+                         i)
+                    (if (zerop i)
+                        (nil)
+                        (zero)))
+             (equal (last (append a b))
+                    (if (listp b)
+                        (last b)
+                        (if (listp a)
+                            (cons (car (last a))
+                                  b)
+                            b)))
+             (equal (equal (lessp x y)
+                           z)
+                    (if (lessp x y)
+                        (equal (t) z)
+                        (equal (f) z)))
+             (equal (assignment x (append a b))
+                    (if (assignedp x a)
+                        (assignment x a)
+                        (assignment x b)))
+             (equal (car (gopher x))
+                    (if (listp x)
+                        (car (flatten x))
+                        (zero)))
+             (equal (flatten (cdr (gopher x)))
+                    (if (listp x)
+                        (cdr (flatten x))
+                        (cons (zero)
+                              (nil))))
+             (equal (quotient (times y x)
+                              y)
+                    (if (zerop y)
+                        (zero)
+                        (fix x)))
+             (equal (get j (set i val mem))
+                    (if (eqp j i)
+                        val
+                        (get j mem)))))))
+  
+  (define (add-lemma-lst lst)
+    (cond ((null? lst)
+           #t)
+          (else (add-lemma (car lst))
+                (add-lemma-lst (cdr lst)))))
+  
+  (define (add-lemma term)
+    (cond ((and (pair? term)
+                (eq? (car term)
+                     (quote equal))
+                (pair? (cadr term)))
+           (put (car (cadr term))
+                (quote lemmas)
+                (cons
+                 (translate-term term)
+                 (get (car (cadr term)) (quote lemmas)))))
+          (else (error "ADD-LEMMA did not like term:  " term))))
+  
+  ; Translates a term by replacing its constructor symbols by symbol-records.
+  
+  (define (translate-term term)
+    (cond ((not (pair? term))
+           term)
+          (else (cons (symbol->symbol-record (car term))
+                      (translate-args (cdr term))))))
+  
+  (define (translate-args lst)
+    (cond ((null? lst)
+           '())
+          (else (cons (translate-term (car lst))
+                      (translate-args (cdr lst))))))
+  
+  ; For debugging only, so the use of MAP does not change
+  ; the first-order character of the benchmark.
+  
+  (define (untranslate-term term)
+    (cond ((not (pair? term))
+           term)
+          (else (cons (get-name (car term))
+                      (map untranslate-term (cdr term))))))
+  
+  ; A symbol-record is represented as a vector with two fields:
+  ; the symbol (for debugging) and
+  ; the list of lemmas associated with the symbol.
+
+  (define (put sym property value)
+    (put-lemmas! (symbol->symbol-record sym) value))
+  
+  (define (get sym property)
+    (get-lemmas (symbol->symbol-record sym)))
+
+  (define (symbol->symbol-record sym)
+    (let ((x (assq sym *symbol-records-alist*)))
+      (if x
+          (cdr x)
+          (let ((r (make-symbol-record sym)))
+            (set! *symbol-records-alist*
+                  (cons (cons sym r)
+                        *symbol-records-alist*))
+            r))))
+
+  ; Association list of symbols and symbol-records.
+  
+  (define *symbol-records-alist* '())
+  
+  ; A symbol-record is represented as a vector with two fields:
+  ; the symbol (for debugging) and
+  ; the list of lemmas associated with the symbol.
+  
+  (define (make-symbol-record sym)
+    (vector sym '()))
+  
+  (define (put-lemmas! symbol-record lemmas)
+    (vector-set! symbol-record 1 lemmas))
+  
+  (define (get-lemmas symbol-record)
+    (vector-ref symbol-record 1))
+  
+  (define (get-name symbol-record)
+    (vector-ref symbol-record 0))
+  
+  (define (symbol-record-equal? r1 r2)
+    (eq? r1 r2))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;
+  ; The second phase.
+  ;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  
+  (define (test n)
+    (let ((term
+           (apply-subst
+            (translate-alist
+             (quote ((x f (plus (plus a b)
+                                (plus c (zero))))
+                     (y f (times (times a b)
+                                 (plus c d)))
+                     (z f (reverse (append (append a b)
+                                           (nil))))
+                     (u equal (plus a b)
+                              (difference x y))
+                     (w lessp (remainder a b)
+                              (member a (length b))))))
+            (translate-term
+             (do ((term
+                   (quote (implies (and (implies x y)
+                                        (and (implies y z)
+                                             (and (implies z u)
+                                                  (implies u w))))
+                                   (implies x w)))
+                   (list 'or term '(f)))
+                  (n n (- n 1)))
+                 ((zero? n) term))))))
+    (tautp term)))
+  
+  (define (translate-alist alist)
+    (cond ((null? alist)
+           '())
+          (else (cons (cons (caar alist)
+                            (translate-term (cdar alist)))
+                      (translate-alist (cdr alist))))))
+  
+  (define (apply-subst alist term)
+    (cond ((not (pair? term))
+           (let ((temp-temp (assq term alist)))
+             (if temp-temp
+                 (cdr temp-temp)
+                 term)))
+          (else (cons (car term)
+                      (apply-subst-lst alist (cdr term))))))
+  
+  (define (apply-subst-lst alist lst)
+    (cond ((null? lst)
+           '())
+          (else (cons (apply-subst alist (car lst))
+                      (apply-subst-lst alist (cdr lst))))))
+  
+  (define (tautp x)
+    (tautologyp (rewrite x)
+                '() '()))
+  
+  (define (tautologyp x true-lst false-lst)
+    (cond ((truep x true-lst)
+           #t)
+          ((falsep x false-lst)
+           #f)
+          ((not (pair? x))
+           #f)
+          ((eq? (car x) if-constructor)
+           (cond ((truep (cadr x)
+                         true-lst)
+                  (tautologyp (caddr x)
+                              true-lst false-lst))
+                 ((falsep (cadr x)
+                          false-lst)
+                  (tautologyp (cadddr x)
+                              true-lst false-lst))
+                 (else (and (tautologyp (caddr x)
+                                        (cons (cadr x)
+                                              true-lst)
+                                        false-lst)
+                            (tautologyp (cadddr x)
+                                        true-lst
+                                        (cons (cadr x)
+                                              false-lst))))))
+          (else #f)))
+  
+  (define if-constructor '*) ; becomes (symbol->symbol-record 'if)
+  
+  (define rewrite-count 0) ; sanity check
+  
+  (define (rewrite term)
+    (set! rewrite-count (+ rewrite-count 1))
+    (cond ((not (pair? term))
+           term)
+          (else (rewrite-with-lemmas (cons (car term)
+                                           (rewrite-args (cdr term)))
+                                     (get-lemmas (car term))))))
+  
+  (define (rewrite-args lst)
+    (cond ((null? lst)
+           '())
+          (else (cons (rewrite (car lst))
+                      (rewrite-args (cdr lst))))))
+  
+  (define (rewrite-with-lemmas term lst)
+    (cond ((null? lst)
+           term)
+          ((one-way-unify term (cadr (car lst)))
+           (rewrite (apply-subst unify-subst (caddr (car lst)))))
+          (else (rewrite-with-lemmas term (cdr lst)))))
+  
+  (define unify-subst '*)
+  
+  (define (one-way-unify term1 term2)
+    (begin (set! unify-subst '())
+           (one-way-unify1 term1 term2)))
+  
+  (define (one-way-unify1 term1 term2)
+    (cond ((not (pair? term2))
+           (let ((temp-temp (assq term2 unify-subst)))
+             (cond (temp-temp
+                    (term-equal? term1 (cdr temp-temp)))
+                   ((number? term2)          ; This bug fix makes
+                    (equal? term1 term2))    ; nboyer 10-25% slower!
+                   (else
+                    (set! unify-subst (cons (cons term2 term1)
+                                            unify-subst))
+                    #t))))
+          ((not (pair? term1))
+           #f)
+          ((eq? (car term1)
+                (car term2))
+           (one-way-unify1-lst (cdr term1)
+                               (cdr term2)))
+          (else #f)))
+  
+  (define (one-way-unify1-lst lst1 lst2)
+    (cond ((null? lst1)
+           (null? lst2))
+          ((null? lst2)
+           #f)
+          ((one-way-unify1 (car lst1)
+                           (car lst2))
+           (one-way-unify1-lst (cdr lst1)
+                               (cdr lst2)))
+          (else #f)))
+  
+  (define (falsep x lst)
+    (or (term-equal? x false-term)
+        (term-member? x lst)))
+  
+  (define (truep x lst)
+    (or (term-equal? x true-term)
+        (term-member? x lst)))
+  
+  (define false-term '*)  ; becomes (translate-term '(f))
+  (define true-term '*)   ; becomes (translate-term '(t))
+  
+  ; The next two procedures were in the original benchmark
+  ; but were never used.
+  
+  (define (trans-of-implies n)
+    (translate-term
+     (list (quote implies)
+           (trans-of-implies1 n)
+           (list (quote implies)
+                 0 n))))
+  
+  (define (trans-of-implies1 n)
+    (cond ((equal? n 1)
+           (list (quote implies)
+                 0 1))
+          (else (list (quote and)
+                      (list (quote implies)
+                            (- n 1)
+                            n)
+                      (trans-of-implies1 (- n 1))))))
+  
+  ; Translated terms can be circular structures, which can't be
+  ; compared using Scheme's equal? and member procedures, so we
+  ; use these instead.
+  
+  (define (term-equal? x y)
+    (cond ((pair? x)
+           (and (pair? y)
+                (symbol-record-equal? (car x) (car y))
+                (term-args-equal? (cdr x) (cdr y))))
+          (else (equal? x y))))
+  
+  (define (term-args-equal? lst1 lst2)
+    (cond ((null? lst1)
+           (null? lst2))
+          ((null? lst2)
+           #f)
+          ((term-equal? (car lst1) (car lst2))
+           (term-args-equal? (cdr lst1) (cdr lst2)))
+          (else #f)))
+  
+  (define (term-member? x lst)
+    (cond ((null? lst)
+           #f)
+          ((term-equal? x (car lst))
+           #t)
+          (else (term-member? x (cdr lst)))))
+  
+  (set! setup-boyer
+        (lambda ()
+          (set! *symbol-records-alist* '())
+          (set! if-constructor (symbol->symbol-record 'if))
+          (set! false-term (translate-term '(f)))
+          (set! true-term  (translate-term '(t)))
+          (setup)))
+  
+  (set! test-boyer
+        (lambda (n)
+          (set! rewrite-count 0)
+          (let ((answer (test n)))
+            (write rewrite-count)
+            (display " rewrites")
+            (newline)
+            (if answer
+                rewrite-count
+                #f)))))
+
+(nboyer-benchmark 4)
+
diff --git a/benchmarks/gabriel/nestedloop.sch b/benchmarks/gabriel/nestedloop.sch
new file mode 100644
index 00000000..64c6c056
--- /dev/null
+++ b/benchmarks/gabriel/nestedloop.sch
@@ -0,0 +1,64 @@
+
+;; Imperative body:
+(define (loops n)
+  (let ((result 0))
+    (let loop1 ((i1 1)) 
+      (if (> i1 n)
+          'done
+          (begin
+            (let loop2 ((i2 1)) 
+              (if (> i2 n)
+                  'done
+                  (begin
+                    (let loop3 ((i3 1)) 
+                      (if (> i3 n)
+                          'done
+                          (begin
+                            (let loop4 ((i4 1)) 
+                              (if (> i4 n)
+                                  'done
+                                  (begin
+                                    (let loop5 ((i5 1)) 
+                                      (if (> i5 n)
+                                          'done
+                                          (begin
+                                            (let loop6 ((i6 1)) 
+                                              (if (> i6 n)
+                                                  'done
+                                                  (begin
+                                                    (set! result (+ result 1))
+                                                    (loop6 (+ i6 1)))))
+                                            (loop5 (+ i5 1)))))
+                                    (loop4 (+ i4 1)))))
+                            (loop3 (+ i3 1)))))
+                    (loop2 (+ i2 1)))))
+            (loop1 (+ i1 1)))))
+    result))
+
+;; Functional body:
+(define (func-loops n)
+  (let loop1 ((i1 1)(result 0))
+      (if (> i1 n)
+          result
+          (let loop2 ((i2 1)(result result))
+            (if (> i2 n)
+                (loop1 (+ i1 1) result)
+                (let loop3 ((i3 1)(result result))
+                  (if (> i3 n)
+                      (loop2 (+ i2 1) result)
+                      (let loop4 ((i4 1)(result result))
+                        (if (> i4 n)
+                            (loop3 (+ i3 1) result)
+                            (let loop5 ((i5 1)(result result))
+                              (if (> i5 n)
+                                  (loop4 (+ i4 1) result)
+                                  (let loop6 ((i6 1)(result result))
+                                    (if (> i6 n)
+                                        (loop5 (+ i5 1) result)
+                                        (loop6 (+ i6 1) (+ result 1)))))))))))))))
+
+(let ((cnt (if (with-input-from-file "input.txt" read) 18 1)))
+  (time (list
+         (loops cnt)
+         (func-loops cnt))))
+
diff --git a/benchmarks/gabriel/nfa.sch b/benchmarks/gabriel/nfa.sch
new file mode 100644
index 00000000..b00dcd07
--- /dev/null
+++ b/benchmarks/gabriel/nfa.sch
@@ -0,0 +1,53 @@
+; The recursive-nfa benchmark.  (Figure 45, page 143.)
+
+;; Changed by Matthew 2006/08/21 to move string->list out of the loop
+
+  
+(define (recursive-nfa input)
+  
+  (define (state0 input)
+    (or (state1 input) (state3 input) #f))
+  
+  (define (state1 input)
+    (and (not (null? input))
+         (or (and (char=? (car input) #\a)
+                  (state1 (cdr input)))
+             (and (char=? (car input) #\c)
+                  (state1 input))
+             (state2 input))))
+  
+  (define (state2 input)
+    (and (not (null? input))
+         (char=? (car input) #\b)
+         (not (null? (cdr input)))
+         (char=? (cadr input) #\c)
+         (not (null? (cddr input)))
+         (char=? (caddr input) #\d)
+         'state2))
+  
+  (define (state3 input)
+    (and (not (null? input))
+         (or (and (char=? (car input) #\a)
+                  (state3 (cdr input)))
+             (state4 input))))
+  
+  (define (state4 input)
+    (and (not (null? input))
+         (char=? (car input) #\b)
+         (not (null? (cdr input)))
+         (char=? (cadr input) #\c)
+         'state4))
+
+  (or (state0 input)
+      'fail))
+
+(time (let ((input (string->list (string-append (make-string 133 #\a) "bc"))))
+        (let loop ((n 150000))
+          (if (zero? n)
+              'done
+              (begin
+                (recursive-nfa input)
+                (loop (- n 1)))))))
+
+
+
diff --git a/benchmarks/gabriel/nothing.sch b/benchmarks/gabriel/nothing.sch
new file mode 100644
index 00000000..d3cd0721
--- /dev/null
+++ b/benchmarks/gabriel/nothing.sch
@@ -0,0 +1 @@
+(time 1)
diff --git a/benchmarks/gabriel/nqueens.sch b/benchmarks/gabriel/nqueens.sch
new file mode 100644
index 00000000..26a6f851
--- /dev/null
+++ b/benchmarks/gabriel/nqueens.sch
@@ -0,0 +1,36 @@
+;;; NQUEENS -- Compute number of solutions to 8-queens problem.
+;; 2006/08 -- renamed `try' to `try-it' to avoid Bigloo collision (mflatt)
+
+(define trace? #f)
+
+(define (nqueens n)
+
+  (define (one-to n)
+    (let loop ((i n) (l '()))
+      (if (= i 0) l (loop (- i 1) (cons i l)))))
+
+  (define (try-it x y z)
+    (if (null? x)
+      (if (null? y)
+        (begin (if trace? (begin (write z) (newline))) 1)
+        0)
+      (+ (if (ok? (car x) 1 z)
+           (try-it (append (cdr x) y) '() (cons (car x) z))
+           0)
+         (try-it (cdr x) (cons (car x) y) z))))
+
+  (define (ok? row dist placed)
+    (if (null? placed)
+      #t
+      (and (not (= (car placed) (+ row dist)))
+           (not (= (car placed) (- row dist)))
+           (ok? row (+ dist 1) (cdr placed)))))
+
+  (try-it (one-to n) '() '()))
+
+(let ((input (with-input-from-file "input.txt" read)))
+  (time
+   (let loop ((n 500) (v 0))
+     (if (zero? n)
+         v
+         (loop (- n 1) (nqueens (if input 8 0)))))))
diff --git a/benchmarks/gabriel/nucleic2.sch b/benchmarks/gabriel/nucleic2.sch
new file mode 100644
index 00000000..4c3c347a
--- /dev/null
+++ b/benchmarks/gabriel/nucleic2.sch
@@ -0,0 +1,3508 @@
+; File: "nucleic2.scm"
+;
+; Author: Marc Feeley (feeley@iro.umontreal.ca)
+; Last modification by Feeley: June 6, 1994.
+; Modified for R5RS Scheme by William D Clinger: 22 October 1996.
+; Last modification by Clinger: 19 March 1999.
+;
+; This program is a modified version of the program described in
+;
+;   M. Feeley, M. Turcotte, G. Lapalme.  Using Multilisp for Solving
+;   Constraint Satisfaction Problems: an Application to Nucleic Acid 3D
+;   Structure Determination.  Lisp and Symbolic Computation 7(2/3),
+;   231-246, 1994.
+;
+; The differences between this program and the original are described in
+;
+;   P.H. Hartel, M. Feeley, et al.  Benchmarking Implementations of
+;   Functional Languages with "Pseudoknot", a Float-Intensive Benchmark.
+;   Journal of Functional Programming 6(4), 621-655, 1996.
+
+; This procedure uses Marc Feeley's run-benchmark procedure to time
+; the benchmark.
+
+; PORTABILITY.
+;
+; This program should run in any R5RS-conforming implementation of Scheme.
+; To run this program in an implementation that does not support the R5RS
+; macro system, however, you will have to place a single quotation mark (')
+; on the following line and also modify the "SYSTEM DEPENDENT CODE" below.
+
+; ********** R5RS Scheme
+
+(begin
+
+(define-syntax FLOAT+    (syntax-rules () ((FLOAT+ x ...) (+ x ...))))
+(define-syntax FLOAT-    (syntax-rules () ((FLOAT- x ...) (- x ...))))
+(define-syntax FLOAT*    (syntax-rules () ((FLOAT* x ...) (* x ...))))
+(define-syntax FLOAT/    (syntax-rules () ((FLOAT/ x ...) (/ x ...))))
+(define-syntax FLOAT=    (syntax-rules () ((FLOAT=  x y)  (=  x y))))
+(define-syntax FLOAT<    (syntax-rules () ((FLOAT<  x y)  (<  x y))))
+(define-syntax FLOAT<=   (syntax-rules () ((FLOAT<= x y)  (<= x y))))
+(define-syntax FLOAT>    (syntax-rules () ((FLOAT>  x y)  (>  x y))))
+(define-syntax FLOAT>=   (syntax-rules () ((FLOAT>= x y)  (>= x y))))
+(define-syntax FLOATsin  (syntax-rules () ((FLOATsin  x)  (sin  x))))
+(define-syntax FLOATcos  (syntax-rules () ((FLOATcos  x)  (cos  x))))
+(define-syntax FLOATatan (syntax-rules () ((FLOATatan x)  (atan x))))
+(define-syntax FLOATsqrt (syntax-rules () ((FLOATsqrt x)  (sqrt x))))
+
+(define-syntax FUTURE    (syntax-rules () ((FUTURE x) x)))
+(define-syntax TOUCH     (syntax-rules () ((TOUCH x)  x)))
+
+(define-syntax define-structure
+  (syntax-rules ()
+    ((define-structure #f
+       name make make-constant (select1 ...) (set1 ...))
+     (begin (define-syntax make
+              (syntax-rules ()
+                ((make select1 ...)
+                 (vector select1 ...))))
+            (define-syntax make-constant
+              (syntax-rules ()
+                ; The vectors that are passed to make-constant aren't quoted.
+                ((make-constant . args)
+                 (constant-maker make . args))))
+            (define-selectors (select1 ...)
+                              (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))
+            (define-setters   (set1 ...)
+                              (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))))
+    ((define-structure pred?
+       name make make-constant (select1 ...) (set1 ...))
+     (begin (define-syntax pred?
+              (syntax-rules ()
+                ((pred? v)
+                 (and (vector? v) (eq? (vector-ref v 0) 'name)))))
+            (define-syntax make
+              (syntax-rules ()
+                ((make select1 ...)
+                 (vector 'name select1 ...))))
+            (define-syntax make-constant
+              (syntax-rules ()
+                ; The vectors that are passed to make-constant aren't quoted.
+                ((make-constant . args)
+                 (constant-maker make . args))))
+            (define-selectors (select1 ...)
+                              (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))
+            (define-setters   (set1 ...)
+                              (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))))))
+(define-syntax constant-maker
+  (syntax-rules ()
+    ; The quotation marks are added here.
+    ((constant-maker make arg ...)
+     (make 'arg ...))))
+(define-syntax define-selectors
+  (syntax-rules ()
+    ((define-selectors (select) (i i1 ...))
+     (define-syntax select
+       (syntax-rules ()
+         ((select v) (vector-ref v i)))))
+    ((define-selectors (select select1 ...) (i i1 ...))
+     (begin (define-syntax select
+              (syntax-rules ()
+                ((select v) (vector-ref v i))))
+            (define-selectors (select1 ...) (i1 ...))))))
+(define-syntax define-setters
+  (syntax-rules ()
+    ((define-setters (set) (i i1 ...))
+     (define-syntax set
+       (syntax-rules ()
+         ((set v x) (vector-set! v i x)))))
+    ((define-setters (set set1 ...) (i i1 ...))
+     (begin (define-syntax set
+              (syntax-rules ()
+                ((set v x) (vector-set! v i x))))
+            (define-setters (set1 ...) (i1 ...))))))
+
+(define-structure #f pt
+  make-pt make-constant-pt
+  (pt-x pt-y pt-z)
+  (pt-x-set! pt-y-set! pt-z-set!))
+
+(define-structure #f tfo
+  make-tfo make-constant-tfo
+  (tfo-a tfo-b tfo-c tfo-d tfo-e tfo-f tfo-g tfo-h tfo-i tfo-tx tfo-ty tfo-tz)
+  (tfo-a-set! tfo-b-set! tfo-c-set! tfo-d-set! tfo-e-set! tfo-f-set!
+   tfo-g-set! tfo-h-set! tfo-i-set! tfo-tx-set! tfo-ty-set! tfo-tz-set!))
+
+(define-structure nuc? nuc
+  make-nuc make-constant-nuc
+  (nuc-dgf-base-tfo  ; defines the standard position for wc and wc-dumas
+   nuc-P-O3*-275-tfo ; defines the standard position for the connect function
+   nuc-P-O3*-180-tfo
+   nuc-P-O3*-60-tfo
+   nuc-P nuc-O1P nuc-O2P nuc-O5* nuc-C5*
+   nuc-H5* nuc-H5**
+   nuc-C4* nuc-H4* nuc-O4* nuc-C1* nuc-H1*
+   nuc-C2* nuc-H2**
+   nuc-O2* nuc-H2* nuc-C3* nuc-H3* nuc-O3*
+   nuc-N1 nuc-N3 nuc-C2 nuc-C4 nuc-C5 nuc-C6)
+  (nuc-dgf-base-tfo-set!
+   nuc-P-O3*-275-tfo-set!
+   nuc-P-O3*-180-tfo-set!
+   nuc-P-O3*-60-tfo-set!
+   nuc-P-set! nuc-O1P-set! nuc-O2P-set! nuc-O5*-set! nuc-C5*-set!
+   nuc-H5*-set! nuc-H5**-set!
+   nuc-C4*-set! nuc-H4*-set! nuc-O4*-set! nuc-C1*-set! nuc-H1*-set!
+   nuc-C2*-set! nuc-H2**-set!
+   nuc-O2*-set! nuc-H2*-set! nuc-C3*-set! nuc-H3*-set! nuc-O3*-set!
+   nuc-N1-set! nuc-N3-set! nuc-C2-set! nuc-C4-set! nuc-C5-set! nuc-C6-set!))
+
+(define-structure rA? rA
+  make-rA make-constant-rA
+  (rA-dgf-base-tfo  ; defines the standard position for wc and wc-dumas
+   rA-P-O3*-275-tfo ; defines the standard position for the connect function
+   rA-P-O3*-180-tfo
+   rA-P-O3*-60-tfo
+   rA-P rA-O1P rA-O2P rA-O5* rA-C5*
+   rA-H5* rA-H5**
+   rA-C4* rA-H4* rA-O4* rA-C1* rA-H1*
+   rA-C2* rA-H2**
+   rA-O2* rA-H2* rA-C3* rA-H3* rA-O3*
+   rA-N1 rA-N3 rA-C2 rA-C4 rA-C5 rA-C6
+   rA-N6 rA-N7 rA-N9 rA-C8
+   rA-H2 rA-H61 rA-H62 rA-H8)
+  (rA-dgf-base-tfo-set!
+   rA-P-O3*-275-tfo-set!
+   rA-P-O3*-180-tfo-set!
+   rA-P-O3*-60-tfo-set!
+   rA-P-set! rA-O1P-set! rA-O2P-set! rA-O5*-set! rA-C5*-set!
+   rA-H5*-set! rA-H5**-set!
+   rA-C4*-set! rA-H4*-set! rA-O4*-set! rA-C1*-set! rA-H1*-set!
+   rA-C2*-set! rA-H2**-set!
+   rA-O2*-set! rA-H2*-set! rA-C3*-set! rA-H3*-set! rA-O3*-set!
+   rA-N1-set! rA-N3-set! rA-C2-set! rA-C4-set! rA-C5-set! rA-C6-set!
+   rA-N6-set! rA-N7-set! rA-N9-set! rA-C8-set!
+   rA-H2-set! rA-H61-set! rA-H62-set! rA-H8-set!))
+
+(define-structure rC? rC
+  make-rC make-constant-rC
+  (rC-dgf-base-tfo  ; defines the standard position for wc and wc-dumas
+   rC-P-O3*-275-tfo ; defines the standard position for the connect function
+   rC-P-O3*-180-tfo
+   rC-P-O3*-60-tfo
+   rC-P rC-O1P rC-O2P rC-O5* rC-C5*
+   rC-H5* rC-H5**
+   rC-C4* rC-H4* rC-O4* rC-C1* rC-H1*
+   rC-C2* rC-H2**
+   rC-O2* rC-H2* rC-C3* rC-H3* rC-O3*
+   rC-N1 rC-N3 rC-C2 rC-C4 rC-C5 rC-C6
+   rC-N4 rC-O2 rC-H41 rC-H42 rC-H5 rC-H6)
+  (rC-dgf-base-tfo-set!
+   rC-P-O3*-275-tfo-set!
+   rC-P-O3*-180-tfo-set!
+   rC-P-O3*-60-tfo-set!
+   rC-P-set! rC-O1P-set! rC-O2P-set! rC-O5*-set! rC-C5*-set!
+   rC-H5*-set! rC-H5**-set!
+   rC-C4*-set! rC-H4*-set! rC-O4*-set! rC-C1*-set! rC-H1*-set!
+   rC-C2*-set! rC-H2**-set!
+   rC-O2*-set! rC-H2*-set! rC-C3*-set! rC-H3*-set! rC-O3*-set!
+   rC-N1-set! rC-N3-set! rC-C2-set! rC-C4-set! rC-C5-set! rC-C6-set!
+   rC-N4-set! rC-O2-set! rC-H41-set! rC-H42-set! rC-H5-set! rC-H6-set!))
+
+(define-structure rG? rG
+  make-rG make-constant-rG
+  (rG-dgf-base-tfo  ; defines the standard position for wc and wc-dumas
+   rG-P-O3*-275-tfo ; defines the standard position for the connect function
+   rG-P-O3*-180-tfo
+   rG-P-O3*-60-tfo
+   rG-P rG-O1P rG-O2P rG-O5* rG-C5*
+   rG-H5* rG-H5**
+   rG-C4* rG-H4* rG-O4* rG-C1* rG-H1*
+   rG-C2* rG-H2**
+   rG-O2* rG-H2* rG-C3* rG-H3* rG-O3*
+   rG-N1 rG-N3 rG-C2 rG-C4 rG-C5 rG-C6
+   rG-N2 rG-N7 rG-N9 rG-C8 rG-O6
+   rG-H1 rG-H21 rG-H22 rG-H8)
+  (rG-dgf-base-tfo-set!
+   rG-P-O3*-275-tfo-set!
+   rG-P-O3*-180-tfo-set!
+   rG-P-O3*-60-tfo-set!
+   rG-P-set! rG-O1P-set! rG-O2P-set! rG-O5*-set! rG-C5*-set!
+   rG-H5*-set! rG-H5**-set!
+   rG-C4*-set! rG-H4*-set! rG-O4*-set! rG-C1*-set! rG-H1*-set!
+   rG-C2*-set! rG-H2**-set!
+   rG-O2*-set! rG-H2*-set! rG-C3*-set! rG-H3*-set! rG-O3*-set!
+   rG-N1-set! rG-N3-set! rG-C2-set! rG-C4-set! rG-C5-set! rG-C6-set!
+   rG-N2-set! rG-N7-set! rG-N9-set! rG-C8-set! rG-O6-set!
+   rG-H1-set! rG-H21-set! rG-H22-set! rG-H8-set!))
+
+(define-structure rU? rU
+  make-rU make-constant-rU
+  (rU-dgf-base-tfo  ; defines the standard position for wc and wc-dumas
+   rU-P-O3*-275-tfo ; defines the standard position for the connect function
+   rU-P-O3*-180-tfo
+   rU-P-O3*-60-tfo
+   rU-P rU-O1P rU-O2P rU-O5* rU-C5*
+   rU-H5* rU-H5**
+   rU-C4* rU-H4* rU-O4* rU-C1* rU-H1*
+   rU-C2* rU-H2**
+   rU-O2* rU-H2* rU-C3* rU-H3* rU-O3*
+   rU-N1 rU-N3 rU-C2 rU-C4 rU-C5 rU-C6
+   rU-O2 rU-O4 rU-H3 rU-H5 rU-H6)
+  (rU-dgf-base-tfo-set!
+   rU-P-O3*-275-tfo-set!
+   rU-P-O3*-180-tfo-set!
+   rU-P-O3*-60-tfo-set!
+   rU-P-set! rU-O1P-set! rU-O2P-set! rU-O5*-set! rU-C5*-set!
+   rU-H5*-set! rU-H5**-set!
+   rU-C4*-set! rU-H4*-set! rU-O4*-set! rU-C1*-set! rU-H1*-set!
+   rU-C2*-set! rU-H2**-set!
+   rU-O2*-set! rU-H2*-set! rU-C3*-set! rU-H3*-set! rU-O3*-set!
+   rU-N1-set! rU-N3-set! rU-C2-set! rU-C4-set! rU-C5-set! rU-C6-set!
+   rU-O2-set! rU-O4-set! rU-H3-set! rU-H5-set! rU-H6-set!))
+
+(define-structure #f var
+  make-var make-constant-var
+  (var-id var-tfo var-nuc)
+  (var-id-set! var-tfo-set! var-nuc-set!))
+
+; Comment out the next three syntax definitions if you want
+; lazy computation.
+
+(define-syntax mk-var
+  (syntax-rules ()
+    ((mk-var i tfo nuc)
+     (make-var i tfo nuc))))
+
+(define-syntax absolute-pos
+  (syntax-rules ()
+    ((absolute-pos var p)
+     (tfo-apply (var-tfo var) p))))
+
+(define-syntax lazy-computation-of
+  (syntax-rules ()
+    ((lazy-computation-of expr)
+     expr)))
+
+; Uncomment the next three syntax definitions if you want
+; lazy computation.
+
+; (define-syntax mk-var
+;   (syntax-rules ()
+;     ((mk-var i tfo nuc)
+;      (make-var i tfo (make-relative-nuc tfo nuc)))))
+;
+; (define-syntax absolute-pos
+;   (syntax-rules ()
+;     ((absolute-pos var p)
+;      (force p))))
+;
+; (define-syntax lazy-computation-of
+;   (syntax-rules ()
+;     ((lazy-computation-of expr)
+;      (delay expr))))
+
+(define-syntax atom-pos
+  (syntax-rules ()
+    ((atom-pos atom var)
+     (let ((v var))
+       (absolute-pos v (atom (var-nuc v)))))))
+
+)
+
+; -- MATH UTILITIES -----------------------------------------------------------
+
+(define constant-pi          3.14159265358979323846)
+(define constant-minus-pi   -3.14159265358979323846)
+(define constant-pi/2        1.57079632679489661923)
+(define constant-minus-pi/2 -1.57079632679489661923)
+
+(define (math-atan2 y x)
+  (cond ((FLOAT> x 0.0)
+         (FLOATatan (FLOAT/ y x)))
+        ((FLOAT< y 0.0)
+         (if (FLOAT= x 0.0)
+           constant-minus-pi/2
+           (FLOAT+ (FLOATatan (FLOAT/ y x)) constant-minus-pi)))
+        (else
+         (if (FLOAT= x 0.0)
+           constant-pi/2
+           (FLOAT+ (FLOATatan (FLOAT/ y x)) constant-pi)))))
+
+; -- POINTS -------------------------------------------------------------------
+
+(define (pt-sub p1 p2)
+  (make-pt (FLOAT- (pt-x p1) (pt-x p2))
+           (FLOAT- (pt-y p1) (pt-y p2))
+           (FLOAT- (pt-z p1) (pt-z p2))))
+
+(define (pt-dist p1 p2)
+  (let ((dx (FLOAT- (pt-x p1) (pt-x p2)))
+        (dy (FLOAT- (pt-y p1) (pt-y p2)))
+        (dz (FLOAT- (pt-z p1) (pt-z p2))))
+    (FLOATsqrt (FLOAT+ (FLOAT* dx dx) (FLOAT* dy dy) (FLOAT* dz dz)))))
+
+(define (pt-phi p)
+  (let* ((x (pt-x p))
+         (y (pt-y p))
+         (z (pt-z p))
+         (b (math-atan2 x z)))
+    (math-atan2 (FLOAT+ (FLOAT* (FLOATcos b) z) (FLOAT* (FLOATsin b) x)) y)))
+
+(define (pt-theta p)
+  (math-atan2 (pt-x p) (pt-z p)))
+
+; -- COORDINATE TRANSFORMATIONS -----------------------------------------------
+
+; The notation for the transformations follows "Paul, R.P. (1981) Robot
+; Manipulators.  MIT Press." with the exception that our transformation
+; matrices don't have the perspective terms and are the transpose of
+; Paul's one.  See also "M\"antyl\"a, M. (1985) An Introduction to
+; Solid Modeling, Computer Science Press" Appendix A.
+;
+; The components of a transformation matrix are named like this:
+;
+;  a  b  c
+;  d  e  f
+;  g  h  i
+; tx ty tz
+;
+; The components tx, ty, and tz are the translation vector.
+
+(define tfo-id  ; the identity transformation matrix
+  '#(1.0 0.0 0.0
+     0.0 1.0 0.0
+     0.0 0.0 1.0
+     0.0 0.0 0.0))
+
+; The function "tfo-apply" multiplies a transformation matrix, tfo, by a
+; point vector, p.  The result is a new point.
+
+(define (tfo-apply tfo p)
+  (let ((x (pt-x p))
+        (y (pt-y p))
+        (z (pt-z p)))
+    (make-pt
+     (FLOAT+ (FLOAT* x (tfo-a tfo)) 
+             (FLOAT* y (tfo-d tfo)) 
+             (FLOAT* z (tfo-g tfo)) 
+             (tfo-tx tfo))
+     (FLOAT+ (FLOAT* x (tfo-b tfo)) 
+             (FLOAT* y (tfo-e tfo))
+             (FLOAT* z (tfo-h tfo))
+             (tfo-ty tfo))
+     (FLOAT+ (FLOAT* x (tfo-c tfo)) 
+             (FLOAT* y (tfo-f tfo))
+             (FLOAT* z (tfo-i tfo))
+             (tfo-tz tfo)))))
+
+; The function "tfo-combine" multiplies two transformation matrices A and B.
+; The result is a new matrix which cumulates the transformations described
+; by A and B.
+
+(define (tfo-combine A B)
+  (make-tfo
+   (FLOAT+ (FLOAT* (tfo-a A) (tfo-a B))
+           (FLOAT* (tfo-b A) (tfo-d B))
+           (FLOAT* (tfo-c A) (tfo-g B)))
+   (FLOAT+ (FLOAT* (tfo-a A) (tfo-b B))
+           (FLOAT* (tfo-b A) (tfo-e B))
+           (FLOAT* (tfo-c A) (tfo-h B)))
+   (FLOAT+ (FLOAT* (tfo-a A) (tfo-c B))
+           (FLOAT* (tfo-b A) (tfo-f B))
+           (FLOAT* (tfo-c A) (tfo-i B)))
+   (FLOAT+ (FLOAT* (tfo-d A) (tfo-a B))
+           (FLOAT* (tfo-e A) (tfo-d B))
+           (FLOAT* (tfo-f A) (tfo-g B)))
+   (FLOAT+ (FLOAT* (tfo-d A) (tfo-b B))
+           (FLOAT* (tfo-e A) (tfo-e B))
+           (FLOAT* (tfo-f A) (tfo-h B)))
+   (FLOAT+ (FLOAT* (tfo-d A) (tfo-c B))
+           (FLOAT* (tfo-e A) (tfo-f B))
+           (FLOAT* (tfo-f A) (tfo-i B)))
+   (FLOAT+ (FLOAT* (tfo-g A) (tfo-a B))
+           (FLOAT* (tfo-h A) (tfo-d B))
+           (FLOAT* (tfo-i A) (tfo-g B)))
+   (FLOAT+ (FLOAT* (tfo-g A) (tfo-b B))
+           (FLOAT* (tfo-h A) (tfo-e B))
+           (FLOAT* (tfo-i A) (tfo-h B)))
+   (FLOAT+ (FLOAT* (tfo-g A) (tfo-c B))
+           (FLOAT* (tfo-h A) (tfo-f B))
+           (FLOAT* (tfo-i A) (tfo-i B)))
+   (FLOAT+ (FLOAT* (tfo-tx A) (tfo-a B))
+           (FLOAT* (tfo-ty A) (tfo-d B))
+           (FLOAT* (tfo-tz A) (tfo-g B))
+           (tfo-tx B))
+   (FLOAT+ (FLOAT* (tfo-tx A) (tfo-b B))
+           (FLOAT* (tfo-ty A) (tfo-e B))
+           (FLOAT* (tfo-tz A) (tfo-h B))
+           (tfo-ty B))
+   (FLOAT+ (FLOAT* (tfo-tx A) (tfo-c B))
+           (FLOAT* (tfo-ty A) (tfo-f B))
+           (FLOAT* (tfo-tz A) (tfo-i B))
+           (tfo-tz B))))
+
+; The function "tfo-inv-ortho" computes the inverse of a homogeneous
+; transformation matrix.
+
+(define (tfo-inv-ortho tfo)
+  (let* ((tx (tfo-tx tfo))
+         (ty (tfo-ty tfo))
+         (tz (tfo-tz tfo)))
+    (make-tfo
+     (tfo-a tfo) (tfo-d tfo) (tfo-g tfo)
+     (tfo-b tfo) (tfo-e tfo) (tfo-h tfo)
+     (tfo-c tfo) (tfo-f tfo) (tfo-i tfo)
+     (FLOAT- (FLOAT+ (FLOAT* (tfo-a tfo) tx)
+                     (FLOAT* (tfo-b tfo) ty)
+                     (FLOAT* (tfo-c tfo) tz)))
+     (FLOAT- (FLOAT+ (FLOAT* (tfo-d tfo) tx)
+                     (FLOAT* (tfo-e tfo) ty)
+                     (FLOAT* (tfo-f tfo) tz)))
+     (FLOAT- (FLOAT+ (FLOAT* (tfo-g tfo) tx)
+                     (FLOAT* (tfo-h tfo) ty)
+                     (FLOAT* (tfo-i tfo) tz))))))
+
+; Given three points p1, p2, and p3, the function "tfo-align" computes
+; a transformation matrix such that point p1 gets mapped to (0,0,0), p2 gets
+; mapped to the Y axis and p3 gets mapped to the YZ plane.
+
+(define (tfo-align p1 p2 p3)
+  (let* ((x1 (pt-x p1))       (y1 (pt-y p1))       (z1 (pt-z p1))
+         (x3 (pt-x p3))       (y3 (pt-y p3))       (z3 (pt-z p3))
+         (x31 (FLOAT- x3 x1)) (y31 (FLOAT- y3 y1)) (z31 (FLOAT- z3 z1))
+         (rotpY (pt-sub p2 p1))
+         (Phi (pt-phi rotpY))
+         (Theta (pt-theta rotpY))
+         (sinP (FLOATsin Phi))
+         (sinT (FLOATsin Theta))
+         (cosP (FLOATcos Phi))
+         (cosT (FLOATcos Theta))
+         (sinPsinT (FLOAT* sinP sinT))
+         (sinPcosT (FLOAT* sinP cosT))
+         (cosPsinT (FLOAT* cosP sinT))
+         (cosPcosT (FLOAT* cosP cosT))
+         (rotpZ 
+          (make-pt 
+           (FLOAT- (FLOAT* cosT x31)
+                   (FLOAT* sinT z31))
+           (FLOAT+ (FLOAT* sinPsinT x31)
+                   (FLOAT* cosP y31)
+                   (FLOAT* sinPcosT z31))
+           (FLOAT+ (FLOAT* cosPsinT x31)
+                   (FLOAT- (FLOAT* sinP y31))
+                   (FLOAT* cosPcosT z31))))
+         (Rho (pt-theta rotpZ))
+         (cosR (FLOATcos Rho))
+         (sinR (FLOATsin Rho))
+         (x (FLOAT+ (FLOAT- (FLOAT* x1 cosT))
+                    (FLOAT* z1 sinT)))
+         (y (FLOAT- (FLOAT- (FLOAT- (FLOAT* x1 sinPsinT))
+                            (FLOAT* y1 cosP))
+                    (FLOAT* z1 sinPcosT)))
+         (z (FLOAT- (FLOAT+ (FLOAT- (FLOAT* x1 cosPsinT))
+                            (FLOAT* y1 sinP))
+                    (FLOAT* z1 cosPcosT))))
+    (make-tfo
+     (FLOAT- (FLOAT* cosT cosR) (FLOAT* cosPsinT sinR))
+     sinPsinT
+     (FLOAT+ (FLOAT* cosT sinR) (FLOAT* cosPsinT cosR))
+     (FLOAT* sinP sinR)
+     cosP
+     (FLOAT- (FLOAT* sinP cosR))
+     (FLOAT- (FLOAT- (FLOAT* sinT cosR)) (FLOAT* cosPcosT sinR))
+     sinPcosT
+     (FLOAT+ (FLOAT- (FLOAT* sinT sinR)) (FLOAT* cosPcosT cosR))
+     (FLOAT- (FLOAT* x cosR) (FLOAT* z sinR))
+     y
+     (FLOAT+ (FLOAT* x sinR) (FLOAT* z cosR)))))
+
+; -- NUCLEIC ACID CONFORMATIONS DATA BASE -------------------------------------
+
+; Numbering of atoms follows the paper:
+;
+; IUPAC-IUB Joint Commission on Biochemical Nomenclature (JCBN)
+; (1983) Abbreviations and Symbols for the Description of
+; Conformations of Polynucleotide Chains.  Eur. J. Biochem 131,
+; 9-15.
+;
+; In the atom names, we have used "*" instead of "'".
+
+; Define part common to all 4 nucleotide types.
+
+; Define remaining atoms for each nucleotide type.
+
+; Database of nucleotide conformations:
+
+(define rA
+  (make-constant-rA
+    #( -0.0018  -0.8207   0.5714  ; dgf-base-tfo
+        0.2679  -0.5509  -0.7904
+        0.9634   0.1517   0.2209
+        0.0073   8.4030   0.6232)
+    #( -0.8143  -0.5091  -0.2788  ; P-O3*-275-tfo
+       -0.0433  -0.4257   0.9038
+       -0.5788   0.7480   0.3246
+        1.5227   6.9114  -7.0765)
+    #(  0.3822  -0.7477   0.5430  ; P-O3*-180-tfo
+        0.4552   0.6637   0.5935
+       -0.8042   0.0203   0.5941
+       -6.9472  -4.1186  -5.9108)
+    #(  0.5640   0.8007  -0.2022  ; P-O3*-60-tfo
+       -0.8247   0.5587  -0.0878
+        0.0426   0.2162   0.9754
+        6.2694  -7.0540   3.3316)
+    #(  2.8930   8.5380  -3.3280) ; P   
+    #(  1.6980   7.6960  -3.5570) ; O1P 
+    #(  3.2260   9.5010  -4.4020) ; O2P 
+    #(  4.1590   7.6040  -3.0340) ; O5* 
+    #(  5.4550   8.2120  -2.8810) ; C5* 
+    #(  5.4546   8.8508  -1.9978) ; H5* 
+    #(  5.7588   8.6625  -3.8259) ; H5**
+    #(  6.4970   7.1480  -2.5980) ; C4* 
+    #(  7.4896   7.5919  -2.5214) ; H4* 
+    #(  6.1630   6.4860  -1.3440) ; O4* 
+    #(  6.5400   5.1200  -1.4190) ; C1* 
+    #(  7.2763   4.9681  -0.6297) ; H1* 
+    #(  7.1940   4.8830  -2.7770) ; C2* 
+    #(  6.8667   3.9183  -3.1647) ; H2**
+    #(  8.5860   5.0910  -2.6140) ; O2* 
+    #(  8.9510   4.7626  -1.7890) ; H2* 
+    #(  6.5720   6.0040  -3.6090) ; C3* 
+    #(  5.5636   5.7066  -3.8966) ; H3* 
+    #(  7.3801   6.3562  -4.7350) ; O3* 
+    #(  4.7150   0.4910  -0.1360) ; N1  
+    #(  6.3490   2.1730  -0.6020) ; N3  
+    #(  5.9530   0.9650  -0.2670) ; C2  
+    #(  5.2900   2.9790  -0.8260) ; C4  
+    #(  3.9720   2.6390  -0.7330) ; C5  
+    #(  3.6770   1.3160  -0.3660) ; C6  
+    #(  2.4280   0.8450  -0.2360) ; N6  
+    #(  3.1660   3.7290  -1.0360) ; N7  
+    #(  5.3170   4.2990  -1.1930) ; N9  
+    #(  4.0100   4.6780  -1.2990) ; C8  
+    #(  6.6890   0.1903  -0.0518) ; H2  
+    #(  1.6470   1.4460  -0.4040) ; H61 
+    #(  2.2780  -0.1080  -0.0280) ; H62 
+    #(  3.4421   5.5744  -1.5482) ; H8  
+  ))
+
+(define rA01
+  (make-constant-rA
+    #( -0.0043  -0.8175   0.5759  ; dgf-base-tfo
+        0.2617  -0.5567  -0.7884
+        0.9651   0.1473   0.2164
+        0.0359   8.3929   0.5532)
+    #( -0.8143  -0.5091  -0.2788  ; P-O3*-275-tfo
+       -0.0433  -0.4257   0.9038
+       -0.5788   0.7480   0.3246
+        1.5227   6.9114  -7.0765)
+    #(  0.3822  -0.7477   0.5430  ; P-O3*-180-tfo
+        0.4552   0.6637   0.5935
+       -0.8042   0.0203   0.5941
+       -6.9472  -4.1186  -5.9108)
+    #(  0.5640   0.8007  -0.2022  ; P-O3*-60-tfo
+       -0.8247   0.5587  -0.0878
+        0.0426   0.2162   0.9754
+        6.2694  -7.0540   3.3316)
+    #(  2.8930   8.5380  -3.3280) ; P   
+    #(  1.6980   7.6960  -3.5570) ; O1P 
+    #(  3.2260   9.5010  -4.4020) ; O2P 
+    #(  4.1590   7.6040  -3.0340) ; O5* 
+    #(  5.4352   8.2183  -2.7757) ; C5* 
+    #(  5.3830   8.7883  -1.8481) ; H5* 
+    #(  5.7729   8.7436  -3.6691) ; H5**
+    #(  6.4830   7.1518  -2.5252) ; C4* 
+    #(  7.4749   7.5972  -2.4482) ; H4* 
+    #(  6.1626   6.4620  -1.2827) ; O4* 
+    #(  6.5431   5.0992  -1.3905) ; C1* 
+    #(  7.2871   4.9328  -0.6114) ; H1* 
+    #(  7.1852   4.8935  -2.7592) ; C2* 
+    #(  6.8573   3.9363  -3.1645) ; H2**
+    #(  8.5780   5.1025  -2.6046) ; O2* 
+    #(  8.9516   4.7577  -1.7902) ; H2* 
+    #(  6.5522   6.0300  -3.5612) ; C3* 
+    #(  5.5420   5.7356  -3.8459) ; H3* 
+    #(  7.3487   6.4089  -4.6867) ; O3* 
+    #(  4.7442   0.4514  -0.1390) ; N1  
+    #(  6.3687   2.1459  -0.5926) ; N3  
+    #(  5.9795   0.9335  -0.2657) ; C2  
+    #(  5.3052   2.9471  -0.8125) ; C4  
+    #(  3.9891   2.5987  -0.7230) ; C5  
+    #(  3.7016   1.2717  -0.3647) ; C6  
+    #(  2.4553   0.7925  -0.2390) ; N6  
+    #(  3.1770   3.6859  -1.0198) ; N7  
+    #(  5.3247   4.2695  -1.1710) ; N9  
+    #(  4.0156   4.6415  -1.2759) ; C8  
+    #(  6.7198   0.1618  -0.0547) ; H2  
+    #(  1.6709   1.3900  -0.4039) ; H61 
+    #(  2.3107  -0.1627  -0.0373) ; H62 
+    #(  3.4426   5.5361  -1.5199) ; H8  
+  ))
+
+(define rA02
+  (make-constant-rA
+    #(  0.5566   0.0449   0.8296  ; dgf-base-tfo
+        0.5125   0.7673  -0.3854
+       -0.6538   0.6397   0.4041
+       -9.1161  -3.7679  -2.9968)
+    #( -0.8143  -0.5091  -0.2788  ; P-O3*-275-tfo
+       -0.0433  -0.4257   0.9038
+       -0.5788   0.7480   0.3246
+        1.5227   6.9114  -7.0765)
+    #(  0.3822  -0.7477   0.5430  ; P-O3*-180-tfo
+        0.4552   0.6637   0.5935
+       -0.8042   0.0203   0.5941
+       -6.9472  -4.1186  -5.9108)
+    #(  0.5640   0.8007  -0.2022  ; P-O3*-60-tfo
+       -0.8247   0.5587  -0.0878
+        0.0426   0.2162   0.9754
+        6.2694  -7.0540   3.3316)
+    #(  2.8930   8.5380  -3.3280) ; P   
+    #(  1.6980   7.6960  -3.5570) ; O1P 
+    #(  3.2260   9.5010  -4.4020) ; O2P 
+    #(  4.1590   7.6040  -3.0340) ; O5* 
+    #(  4.5778   6.6594  -4.0364) ; C5* 
+    #(  4.9220   7.1963  -4.9204) ; H5* 
+    #(  3.7996   5.9091  -4.1764) ; H5**
+    #(  5.7873   5.8869  -3.5482) ; C4* 
+    #(  6.0405   5.0875  -4.2446) ; H4* 
+    #(  6.9135   6.8036  -3.4310) ; O4* 
+    #(  7.7293   6.4084  -2.3392) ; C1* 
+    #(  8.7078   6.1815  -2.7624) ; H1* 
+    #(  7.1305   5.1418  -1.7347) ; C2* 
+    #(  7.2040   5.1982  -0.6486) ; H2**
+    #(  7.7417   4.0392  -2.3813) ; O2* 
+    #(  8.6785   4.1443  -2.5630) ; H2* 
+    #(  5.6666   5.2728  -2.1536) ; C3* 
+    #(  5.1747   5.9805  -1.4863) ; H3* 
+    #(  4.9997   4.0086  -2.1973) ; O3* 
+    #( 10.3245   8.5459   1.5467) ; N1  
+    #(  9.8051   6.9432  -0.1497) ; N3  
+    #( 10.5175   7.4328   0.8408) ; C2  
+    #(  8.7523   7.7422  -0.4228) ; C4  
+    #(  8.4257   8.9060   0.2099) ; C5  
+    #(  9.2665   9.3242   1.2540) ; C6  
+    #(  9.0664  10.4462   1.9610) ; N6  
+    #(  7.2750   9.4537  -0.3428) ; N7  
+    #(  7.7962   7.5519  -1.3859) ; N9  
+    #(  6.9479   8.6157  -1.2771) ; C8  
+    #( 11.4063   6.9047   1.1859) ; H2  
+    #(  8.2845  11.0341   1.7552) ; H61 
+    #(  9.6584  10.6647   2.7198) ; H62 
+    #(  6.0430   8.9853  -1.7594) ; H8  
+  ))
+
+(define rA03
+  (make-constant-rA
+    #( -0.5021   0.0731   0.8617  ; dgf-base-tfo
+       -0.8112   0.3054  -0.4986
+       -0.2996  -0.9494  -0.0940
+        6.4273  -5.1944  -3.7807)
+    #( -0.8143  -0.5091  -0.2788  ; P-O3*-275-tfo
+       -0.0433  -0.4257   0.9038
+       -0.5788   0.7480   0.3246
+        1.5227   6.9114  -7.0765)
+    #(  0.3822  -0.7477   0.5430  ; P-O3*-180-tfo
+        0.4552   0.6637   0.5935
+       -0.8042   0.0203   0.5941
+       -6.9472  -4.1186  -5.9108)
+    #(  0.5640   0.8007  -0.2022  ; P-O3*-60-tfo
+       -0.8247   0.5587  -0.0878
+        0.0426   0.2162   0.9754
+        6.2694  -7.0540   3.3316)
+    #(  2.8930   8.5380  -3.3280) ; P   
+    #(  1.6980   7.6960  -3.5570) ; O1P 
+    #(  3.2260   9.5010  -4.4020) ; O2P 
+    #(  4.1590   7.6040  -3.0340) ; O5* 
+    #(  4.1214   6.7116  -1.9049) ; C5* 
+    #(  3.3465   5.9610  -2.0607) ; H5* 
+    #(  4.0789   7.2928  -0.9837) ; H5**
+    #(  5.4170   5.9293  -1.8186) ; C4* 
+    #(  5.4506   5.3400  -0.9023) ; H4* 
+    #(  5.5067   5.0417  -2.9703) ; O4* 
+    #(  6.8650   4.9152  -3.3612) ; C1* 
+    #(  7.1090   3.8577  -3.2603) ; H1* 
+    #(  7.7152   5.7282  -2.3894) ; C2* 
+    #(  8.5029   6.2356  -2.9463) ; H2**
+    #(  8.1036   4.8568  -1.3419) ; O2* 
+    #(  8.3270   3.9651  -1.6184) ; H2* 
+    #(  6.7003   6.7565  -1.8911) ; C3* 
+    #(  6.5898   7.5329  -2.6482) ; H3* 
+    #(  7.0505   7.2878  -0.6105) ; O3* 
+    #(  9.6740   4.7656  -7.6614) ; N1  
+    #(  9.0739   4.3013  -5.3941) ; N3  
+    #(  9.8416   4.2192  -6.4581) ; C2  
+    #(  7.9885   5.0632  -5.6446) ; C4  
+    #(  7.6822   5.6856  -6.8194) ; C5  
+    #(  8.5831   5.5215  -7.8840) ; C6  
+    #(  8.4084   6.0747  -9.0933) ; N6  
+    #(  6.4857   6.3816  -6.7035) ; N7  
+    #(  6.9740   5.3703  -4.7760) ; N9  
+    #(  6.1133   6.1613  -5.4808) ; C8  
+    #( 10.7627   3.6375  -6.4220) ; H2  
+    #(  7.6031   6.6390  -9.2733) ; H61 
+    #(  9.1004   5.9708  -9.7893) ; H62 
+    #(  5.1705   6.6830  -5.3167) ; H8  
+  ))
+
+(define rA04
+  (make-constant-rA
+    #( -0.5426  -0.8175   0.1929  ; dgf-base-tfo
+        0.8304  -0.5567  -0.0237
+        0.1267   0.1473   0.9809
+       -0.5075   8.3929   0.2229)
+    #( -0.8143  -0.5091  -0.2788  ; P-O3*-275-tfo
+       -0.0433  -0.4257   0.9038
+       -0.5788   0.7480   0.3246
+        1.5227   6.9114  -7.0765)
+    #(  0.3822  -0.7477   0.5430  ; P-O3*-180-tfo
+        0.4552   0.6637   0.5935
+       -0.8042   0.0203   0.5941
+       -6.9472  -4.1186  -5.9108)
+    #(  0.5640   0.8007  -0.2022  ; P-O3*-60-tfo
+       -0.8247   0.5587  -0.0878
+        0.0426   0.2162   0.9754
+        6.2694  -7.0540   3.3316)
+    #(  2.8930   8.5380  -3.3280) ; P   
+    #(  1.6980   7.6960  -3.5570) ; O1P 
+    #(  3.2260   9.5010  -4.4020) ; O2P 
+    #(  4.1590   7.6040  -3.0340) ; O5* 
+    #(  5.4352   8.2183  -2.7757) ; C5* 
+    #(  5.3830   8.7883  -1.8481) ; H5* 
+    #(  5.7729   8.7436  -3.6691) ; H5**
+    #(  6.4830   7.1518  -2.5252) ; C4* 
+    #(  7.4749   7.5972  -2.4482) ; H4* 
+    #(  6.1626   6.4620  -1.2827) ; O4* 
+    #(  6.5431   5.0992  -1.3905) ; C1* 
+    #(  7.2871   4.9328  -0.6114) ; H1* 
+    #(  7.1852   4.8935  -2.7592) ; C2* 
+    #(  6.8573   3.9363  -3.1645) ; H2**
+    #(  8.5780   5.1025  -2.6046) ; O2* 
+    #(  8.9516   4.7577  -1.7902) ; H2* 
+    #(  6.5522   6.0300  -3.5612) ; C3* 
+    #(  5.5420   5.7356  -3.8459) ; H3* 
+    #(  7.3487   6.4089  -4.6867) ; O3* 
+    #(  3.6343   2.6680   2.0783) ; N1  
+    #(  5.4505   3.9805   1.2446) ; N3  
+    #(  4.7540   3.3816   2.1851) ; C2  
+    #(  4.8805   3.7951   0.0354) ; C4  
+    #(  3.7416   3.0925  -0.2305) ; C5  
+    #(  3.0873   2.4980   0.8606) ; C6  
+    #(  1.9600   1.7805   0.7462) ; N6  
+    #(  3.4605   3.1184  -1.5906) ; N7  
+    #(  5.3247   4.2695  -1.1710) ; N9  
+    #(  4.4244   3.8244  -2.0953) ; C8  
+    #(  5.0814   3.4352   3.2234) ; H2  
+    #(  1.5423   1.6454  -0.1520) ; H61 
+    #(  1.5716   1.3398   1.5392) ; H62 
+    #(  4.2675   3.8876  -3.1721) ; H8  
+  ))
+
+(define rA05
+  (make-constant-rA
+    #( -0.5891   0.0449   0.8068  ; dgf-base-tfo
+        0.5375   0.7673   0.3498
+       -0.6034   0.6397  -0.4762
+       -0.3019  -3.7679  -9.5913)
+    #( -0.8143  -0.5091  -0.2788  ; P-O3*-275-tfo
+       -0.0433  -0.4257   0.9038
+       -0.5788   0.7480   0.3246
+        1.5227   6.9114  -7.0765)
+    #(  0.3822  -0.7477   0.5430  ; P-O3*-180-tfo
+        0.4552   0.6637   0.5935
+       -0.8042   0.0203   0.5941
+       -6.9472  -4.1186  -5.9108)
+    #(  0.5640   0.8007  -0.2022  ; P-O3*-60-tfo
+       -0.8247   0.5587  -0.0878
+        0.0426   0.2162   0.9754
+        6.2694  -7.0540   3.3316)
+    #(  2.8930   8.5380  -3.3280) ; P   
+    #(  1.6980   7.6960  -3.5570) ; O1P 
+    #(  3.2260   9.5010  -4.4020) ; O2P 
+    #(  4.1590   7.6040  -3.0340) ; O5* 
+    #(  4.5778   6.6594  -4.0364) ; C5* 
+    #(  4.9220   7.1963  -4.9204) ; H5* 
+    #(  3.7996   5.9091  -4.1764) ; H5**
+    #(  5.7873   5.8869  -3.5482) ; C4* 
+    #(  6.0405   5.0875  -4.2446) ; H4* 
+    #(  6.9135   6.8036  -3.4310) ; O4* 
+    #(  7.7293   6.4084  -2.3392) ; C1* 
+    #(  8.7078   6.1815  -2.7624) ; H1* 
+    #(  7.1305   5.1418  -1.7347) ; C2* 
+    #(  7.2040   5.1982  -0.6486) ; H2**
+    #(  7.7417   4.0392  -2.3813) ; O2* 
+    #(  8.6785   4.1443  -2.5630) ; H2* 
+    #(  5.6666   5.2728  -2.1536) ; C3* 
+    #(  5.1747   5.9805  -1.4863) ; H3* 
+    #(  4.9997   4.0086  -2.1973) ; O3* 
+    #( 10.2594  10.6774  -1.0056) ; N1  
+    #(  9.7528   8.7080  -2.2631) ; N3  
+    #( 10.4471   9.7876  -1.9791) ; C2  
+    #(  8.7271   8.5575  -1.3991) ; C4  
+    #(  8.4100   9.3803  -0.3580) ; C5  
+    #(  9.2294  10.5030  -0.1574) ; C6  
+    #(  9.0349  11.3951   0.8250) ; N6  
+    #(  7.2891   8.9068   0.3121) ; N7  
+    #(  7.7962   7.5519  -1.3859) ; N9  
+    #(  6.9702   7.8292  -0.3353) ; C8  
+    #( 11.3132  10.0537  -2.5851) ; H2  
+    #(  8.2741  11.2784   1.4629) ; H61 
+    #(  9.6733  12.1368   0.9529) ; H62 
+    #(  6.0888   7.3990   0.1403) ; H8  
+  ))
+
+(define rA06
+  (make-constant-rA
+    #( -0.9815   0.0731  -0.1772  ; dgf-base-tfo
+        0.1912   0.3054  -0.9328
+       -0.0141  -0.9494  -0.3137
+        5.7506  -5.1944   4.7470)
+    #( -0.8143  -0.5091  -0.2788  ; P-O3*-275-tfo
+       -0.0433  -0.4257   0.9038
+       -0.5788   0.7480   0.3246
+        1.5227   6.9114  -7.0765)
+    #(  0.3822  -0.7477   0.5430  ; P-O3*-180-tfo
+        0.4552   0.6637   0.5935
+       -0.8042   0.0203   0.5941
+       -6.9472  -4.1186  -5.9108)
+    #(  0.5640   0.8007  -0.2022  ; P-O3*-60-tfo
+       -0.8247   0.5587  -0.0878
+        0.0426   0.2162   0.9754
+        6.2694  -7.0540   3.3316)
+    #(  2.8930   8.5380  -3.3280) ; P   
+    #(  1.6980   7.6960  -3.5570) ; O1P 
+    #(  3.2260   9.5010  -4.4020) ; O2P 
+    #(  4.1590   7.6040  -3.0340) ; O5* 
+    #(  4.1214   6.7116  -1.9049) ; C5* 
+    #(  3.3465   5.9610  -2.0607) ; H5* 
+    #(  4.0789   7.2928  -0.9837) ; H5**
+    #(  5.4170   5.9293  -1.8186) ; C4* 
+    #(  5.4506   5.3400  -0.9023) ; H4* 
+    #(  5.5067   5.0417  -2.9703) ; O4* 
+    #(  6.8650   4.9152  -3.3612) ; C1* 
+    #(  7.1090   3.8577  -3.2603) ; H1* 
+    #(  7.7152   5.7282  -2.3894) ; C2* 
+    #(  8.5029   6.2356  -2.9463) ; H2**
+    #(  8.1036   4.8568  -1.3419) ; O2* 
+    #(  8.3270   3.9651  -1.6184) ; H2* 
+    #(  6.7003   6.7565  -1.8911) ; C3* 
+    #(  6.5898   7.5329  -2.6482) ; H3* 
+    #(  7.0505   7.2878  -0.6105) ; O3* 
+    #(  6.6624   3.5061  -8.2986) ; N1  
+    #(  6.5810   3.2570  -5.9221) ; N3  
+    #(  6.5151   2.8263  -7.1625) ; C2  
+    #(  6.8364   4.5817  -5.8882) ; C4  
+    #(  7.0116   5.4064  -6.9609) ; C5  
+    #(  6.9173   4.8260  -8.2361) ; C6  
+    #(  7.0668   5.5163  -9.3763) ; N6  
+    #(  7.2573   6.7070  -6.5394) ; N7  
+    #(  6.9740   5.3703  -4.7760) ; N9  
+    #(  7.2238   6.6275  -5.2453) ; C8  
+    #(  6.3146   1.7741  -7.3641) ; H2  
+    #(  7.2568   6.4972  -9.3456) ; H61 
+    #(  7.0437   5.0478 -10.2446) ; H62 
+    #(  7.4108   7.6227  -4.8418) ; H8  
+  ))
+
+(define rA07
+  (make-constant-rA
+    #(  0.2379   0.1310  -0.9624  ; dgf-base-tfo
+       -0.5876  -0.7696  -0.2499
+       -0.7734   0.6249  -0.1061
+       30.9870 -26.9344  42.6416)
+    #(  0.7529   0.1548   0.6397  ; P-O3*-275-tfo
+        0.2952  -0.9481  -0.1180
+        0.5882   0.2777  -0.7595
+      -58.8919 -11.3095   6.0866)
+    #( -0.0239   0.9667  -0.2546  ; P-O3*-180-tfo
+        0.9731  -0.0359  -0.2275
+       -0.2290  -0.2532  -0.9399
+        3.5401 -29.7913  52.2796)
+    #( -0.8912  -0.4531   0.0242  ; P-O3*-60-tfo
+       -0.1183   0.1805  -0.9764
+        0.4380  -0.8730  -0.2145
+       19.9023  54.8054  15.2799)
+    #( 41.8210   8.3880  43.5890) ; P   
+    #( 42.5400   8.0450  44.8330) ; O1P 
+    #( 42.2470   9.6920  42.9910) ; O2P 
+    #( 40.2550   8.2030  43.7340) ; O5* 
+    #( 39.3505   8.4697  42.6565) ; C5* 
+    #( 39.1377   7.5433  42.1230) ; H5* 
+    #( 39.7203   9.3119  42.0717) ; H5**
+    #( 38.0405   8.9195  43.2869) ; C4* 
+    #( 37.3687   9.3036  42.5193) ; H4* 
+    #( 37.4319   7.8146  43.9387) ; O4* 
+    #( 37.1959   8.1354  45.3237) ; C1* 
+    #( 36.1788   8.5202  45.3970) ; H1* 
+    #( 38.1721   9.2328  45.6504) ; C2* 
+    #( 39.1555   8.7939  45.8188) ; H2**
+    #( 37.7862  10.0617  46.7013) ; O2* 
+    #( 37.3087   9.6229  47.4092) ; H2* 
+    #( 38.1844  10.0268  44.3367) ; C3* 
+    #( 39.1578  10.5054  44.2289) ; H3* 
+    #( 37.0547  10.9127  44.3441) ; O3* 
+    #( 34.8811   4.2072  47.5784) ; N1  
+    #( 35.1084   6.1336  46.1818) ; N3  
+    #( 34.4108   5.1360  46.7207) ; C2  
+    #( 36.3908   6.1224  46.6053) ; C4  
+    #( 36.9819   5.2334  47.4697) ; C5  
+    #( 36.1786   4.1985  48.0035) ; C6  
+    #( 36.6103   3.2749  48.8452) ; N6  
+    #( 38.3236   5.5522  47.6595) ; N7  
+    #( 37.3887   7.0024  46.2437) ; N9  
+    #( 38.5055   6.6096  46.9057) ; C8  
+    #( 33.3553   5.0152  46.4771) ; H2  
+    #( 37.5730   3.2804  49.1507) ; H61 
+    #( 35.9775   2.5638  49.1828) ; H62 
+    #( 39.5461   6.9184  47.0041) ; H8  
+  ))
+
+(define rA08
+  (make-constant-rA
+    #(  0.1084  -0.0895  -0.9901  ; dgf-base-tfo
+        0.9789  -0.1638   0.1220
+       -0.1731  -0.9824   0.0698
+       -2.9039  47.2655  33.0094)
+    #(  0.7529   0.1548   0.6397  ; P-O3*-275-tfo
+        0.2952  -0.9481  -0.1180
+        0.5882   0.2777  -0.7595
+      -58.8919 -11.3095   6.0866)
+    #( -0.0239   0.9667  -0.2546  ; P-O3*-180-tfo
+        0.9731  -0.0359  -0.2275
+       -0.2290  -0.2532  -0.9399
+        3.5401 -29.7913  52.2796)
+    #( -0.8912  -0.4531   0.0242  ; P-O3*-60-tfo
+       -0.1183   0.1805  -0.9764
+        0.4380  -0.8730  -0.2145
+       19.9023  54.8054  15.2799)
+    #( 41.8210   8.3880  43.5890) ; P   
+    #( 42.5400   8.0450  44.8330) ; O1P 
+    #( 42.2470   9.6920  42.9910) ; O2P 
+    #( 40.2550   8.2030  43.7340) ; O5* 
+    #( 39.4850   8.9301  44.6977) ; C5* 
+    #( 39.0638   9.8199  44.2296) ; H5* 
+    #( 40.0757   9.0713  45.6029) ; H5**
+    #( 38.3102   8.0414  45.0789) ; C4* 
+    #( 37.7842   8.4637  45.9351) ; H4* 
+    #( 37.4200   7.9453  43.9769) ; O4* 
+    #( 37.2249   6.5609  43.6273) ; C1* 
+    #( 36.3360   6.2168  44.1561) ; H1* 
+    #( 38.4347   5.8414  44.1590) ; C2* 
+    #( 39.2688   5.9974  43.4749) ; H2**
+    #( 38.2344   4.4907  44.4348) ; O2* 
+    #( 37.6374   4.0386  43.8341) ; H2* 
+    #( 38.6926   6.6079  45.4637) ; C3* 
+    #( 39.7585   6.5640  45.6877) ; H3* 
+    #( 37.8238   6.0705  46.4723) ; O3* 
+    #( 33.9162   6.2598  39.7758) ; N1  
+    #( 34.6709   6.5759  42.0215) ; N3  
+    #( 33.7257   6.5186  41.0858) ; C2  
+    #( 35.8935   6.3324  41.5018) ; C4  
+    #( 36.2105   6.0601  40.1932) ; C5  
+    #( 35.1538   6.0151  39.2537) ; C6  
+    #( 35.3088   5.7642  37.9649) ; N6  
+    #( 37.5818   5.8677  40.0507) ; N7  
+    #( 37.0932   6.3197  42.1810) ; N9  
+    #( 38.0509   6.0354  41.2635) ; C8  
+    #( 32.6830   6.6898  41.3532) ; H2  
+    #( 36.2305   5.5855  37.5925) ; H61 
+    #( 34.5056   5.7512  37.3528) ; H62 
+    #( 39.1318   5.8993  41.2285) ; H8  
+  ))
+
+(define rA09
+  (make-constant-rA
+    #(  0.8467   0.4166  -0.3311  ; dgf-base-tfo
+       -0.3962   0.9089   0.1303
+        0.3552   0.0209   0.9346
+      -42.7319 -26.6223 -29.8163)
+    #(  0.7529   0.1548   0.6397  ; P-O3*-275-tfo
+        0.2952  -0.9481  -0.1180
+        0.5882   0.2777  -0.7595
+      -58.8919 -11.3095   6.0866)
+    #( -0.0239   0.9667  -0.2546  ; P-O3*-180-tfo
+        0.9731  -0.0359  -0.2275
+       -0.2290  -0.2532  -0.9399
+        3.5401 -29.7913  52.2796)
+    #( -0.8912  -0.4531   0.0242  ; P-O3*-60-tfo
+       -0.1183   0.1805  -0.9764
+        0.4380  -0.8730  -0.2145
+       19.9023  54.8054  15.2799)
+    #( 41.8210   8.3880  43.5890) ; P   
+    #( 42.5400   8.0450  44.8330) ; O1P 
+    #( 42.2470   9.6920  42.9910) ; O2P 
+    #( 40.2550   8.2030  43.7340) ; O5* 
+    #( 39.3505   8.4697  42.6565) ; C5* 
+    #( 39.1377   7.5433  42.1230) ; H5* 
+    #( 39.7203   9.3119  42.0717) ; H5**
+    #( 38.0405   8.9195  43.2869) ; C4* 
+    #( 37.6479   8.1347  43.9335) ; H4* 
+    #( 38.2691  10.0933  44.0524) ; O4* 
+    #( 37.3999  11.1488  43.5973) ; C1* 
+    #( 36.5061  11.1221  44.2206) ; H1* 
+    #( 37.0364  10.7838  42.1836) ; C2* 
+    #( 37.8636  11.0489  41.5252) ; H2**
+    #( 35.8275  11.3133  41.7379) ; O2* 
+    #( 35.6214  12.1896  42.0714) ; H2* 
+    #( 36.9316   9.2556  42.2837) ; C3* 
+    #( 37.1778   8.8260  41.3127) ; H3* 
+    #( 35.6285   8.9334  42.7926) ; O3* 
+    #( 38.1482  15.2833  46.4641) ; N1  
+    #( 37.3641  13.0968  45.9007) ; N3  
+    #( 37.5032  14.1288  46.7300) ; C2  
+    #( 37.9570  13.3377  44.7113) ; C4  
+    #( 38.6397  14.4660  44.3267) ; C5  
+    #( 38.7473  15.5229  45.2609) ; C6  
+    #( 39.3720  16.6649  45.0297) ; N6  
+    #( 39.1079  14.3351  43.0223) ; N7  
+    #( 38.0132  12.4868  43.6280) ; N9  
+    #( 38.7058  13.1402  42.6620) ; C8  
+    #( 37.0731  14.0857  47.7306) ; H2  
+    #( 39.8113  16.8281  44.1350) ; H61 
+    #( 39.4100  17.3741  45.7478) ; H62 
+    #( 39.0412  12.9660  41.6397) ; H8  
+  ))
+
+(define rA10
+  (make-constant-rA
+    #(  0.7063   0.6317  -0.3196  ; dgf-base-tfo
+       -0.0403  -0.4149  -0.9090
+       -0.7068   0.6549  -0.2676
+        6.4402 -52.1496  30.8246)
+    #(  0.7529   0.1548   0.6397  ; P-O3*-275-tfo
+        0.2952  -0.9481  -0.1180
+        0.5882   0.2777  -0.7595
+      -58.8919 -11.3095   6.0866)
+    #( -0.0239   0.9667  -0.2546  ; P-O3*-180-tfo
+        0.9731  -0.0359  -0.2275
+       -0.2290  -0.2532  -0.9399
+        3.5401 -29.7913  52.2796)
+    #( -0.8912  -0.4531   0.0242  ; P-O3*-60-tfo
+       -0.1183   0.1805  -0.9764
+        0.4380  -0.8730  -0.2145
+       19.9023  54.8054  15.2799)
+    #( 41.8210   8.3880  43.5890) ; P   
+    #( 42.5400   8.0450  44.8330) ; O1P 
+    #( 42.2470   9.6920  42.9910) ; O2P 
+    #( 40.2550   8.2030  43.7340) ; O5* 
+    #( 39.4850   8.9301  44.6977) ; C5* 
+    #( 39.0638   9.8199  44.2296) ; H5* 
+    #( 40.0757   9.0713  45.6029) ; H5**
+    #( 38.3102   8.0414  45.0789) ; C4* 
+    #( 37.7099   7.8166  44.1973) ; H4* 
+    #( 38.8012   6.8321  45.6380) ; O4* 
+    #( 38.2431   6.6413  46.9529) ; C1* 
+    #( 37.3505   6.0262  46.8385) ; H1* 
+    #( 37.8484   8.0156  47.4214) ; C2* 
+    #( 38.7381   8.5406  47.7690) ; H2**
+    #( 36.8286   8.0368  48.3701) ; O2* 
+    #( 36.8392   7.3063  48.9929) ; H2* 
+    #( 37.3576   8.6512  46.1132) ; C3* 
+    #( 37.5207   9.7275  46.1671) ; H3* 
+    #( 35.9985   8.2392  45.9032) ; O3* 
+    #( 39.9117   2.2278  48.8527) ; N1  
+    #( 38.6207   3.6941  47.4757) ; N3  
+    #( 38.9872   2.4888  47.9057) ; C2  
+    #( 39.2961   4.6720  48.1174) ; C4  
+    #( 40.2546   4.5307  49.0912) ; C5  
+    #( 40.5932   3.2189  49.4985) ; C6  
+    #( 41.4938   2.9317  50.4229) ; N6  
+    #( 40.7195   5.7755  49.5060) ; N7  
+    #( 39.1730   6.0305  47.9170) ; N9  
+    #( 40.0413   6.6250  48.7728) ; C8  
+    #( 38.5257   1.5960  47.4838) ; H2  
+    #( 41.9907   3.6753  50.8921) ; H61 
+    #( 41.6848   1.9687  50.6599) ; H62 
+    #( 40.3571   7.6321  49.0452) ; H8  
+  ))
+
+(define rAs 
+  (list rA01 rA02 rA03 rA04 rA05 rA06 rA07 rA08 rA09 rA10))
+
+(define rC
+  (make-constant-rC
+    #( -0.0359  -0.8071   0.5894  ; dgf-base-tfo
+       -0.2669   0.5761   0.7726
+       -0.9631  -0.1296  -0.2361
+        0.1584   8.3434   0.5434)
+    #( -0.8313  -0.4738  -0.2906  ; P-O3*-275-tfo
+        0.0649   0.4366  -0.8973
+        0.5521  -0.7648  -0.3322
+        1.6833   6.8060  -7.0011)
+    #(  0.3445  -0.7630   0.5470  ; P-O3*-180-tfo
+       -0.4628  -0.6450  -0.6082
+        0.8168  -0.0436  -0.5753
+       -6.8179  -3.9778  -5.9887)
+    #(  0.5855   0.7931  -0.1682  ; P-O3*-60-tfo
+        0.8103  -0.5790   0.0906
+       -0.0255  -0.1894  -0.9816
+        6.1203  -7.1051   3.1984)
+    #(  2.6760  -8.4960   3.2880) ; P   
+    #(  1.4950  -7.6230   3.4770) ; O1P 
+    #(  2.9490  -9.4640   4.3740) ; O2P 
+    #(  3.9730  -7.5950   3.0340) ; O5* 
+    #(  5.2430  -8.2420   2.8260) ; C5* 
+    #(  5.1974  -8.8497   1.9223) ; H5* 
+    #(  5.5548  -8.7348   3.7469) ; H5**
+    #(  6.3140  -7.2060   2.5510) ; C4* 
+    #(  7.2954  -7.6762   2.4898) ; H4* 
+    #(  6.0140  -6.5420   1.2890) ; O4* 
+    #(  6.4190  -5.1840   1.3620) ; C1* 
+    #(  7.1608  -5.0495   0.5747) ; H1* 
+    #(  7.0760  -4.9560   2.7270) ; C2* 
+    #(  6.7770  -3.9803   3.1099) ; H2**
+    #(  8.4500  -5.1930   2.5810) ; O2* 
+    #(  8.8309  -4.8755   1.7590) ; H2* 
+    #(  6.4060  -6.0590   3.5580) ; C3* 
+    #(  5.4021  -5.7313   3.8281) ; H3* 
+    #(  7.1570  -6.4240   4.7070) ; O3* 
+    #(  5.2170  -4.3260   1.1690) ; N1  
+    #(  4.2960  -2.2560   0.6290) ; N3  
+    #(  5.4330  -3.0200   0.7990) ; C2  
+    #(  2.9930  -2.6780   0.7940) ; C4  
+    #(  2.8670  -4.0630   1.1830) ; C5  
+    #(  3.9570  -4.8300   1.3550) ; C6  
+    #(  2.0187  -1.8047   0.5874) ; N4  
+    #(  6.5470  -2.5560   0.6290) ; O2  
+    #(  1.0684  -2.1236   0.7109) ; H41 
+    #(  2.2344  -0.8560   0.3162) ; H42 
+    #(  1.8797  -4.4972   1.3404) ; H5  
+    #(  3.8479  -5.8742   1.6480) ; H6  
+  ))
+
+(define rC01
+  (make-constant-rC
+    #( -0.0137  -0.8012   0.5983  ; dgf-base-tfo
+       -0.2523   0.5817   0.7733
+       -0.9675  -0.1404  -0.2101
+        0.2031   8.3874   0.4228)
+    #( -0.8313  -0.4738  -0.2906  ; P-O3*-275-tfo
+        0.0649   0.4366  -0.8973
+        0.5521  -0.7648  -0.3322
+        1.6833   6.8060  -7.0011)
+    #(  0.3445  -0.7630   0.5470  ; P-O3*-180-tfo
+       -0.4628  -0.6450  -0.6082
+        0.8168  -0.0436  -0.5753
+       -6.8179  -3.9778  -5.9887)
+    #(  0.5855   0.7931  -0.1682  ; P-O3*-60-tfo
+        0.8103  -0.5790   0.0906
+       -0.0255  -0.1894  -0.9816
+        6.1203  -7.1051   3.1984)
+    #(  2.6760  -8.4960   3.2880) ; P   
+    #(  1.4950  -7.6230   3.4770) ; O1P 
+    #(  2.9490  -9.4640   4.3740) ; O2P 
+    #(  3.9730  -7.5950   3.0340) ; O5* 
+    #(  5.2416  -8.2422   2.8181) ; C5* 
+    #(  5.2050  -8.8128   1.8901) ; H5* 
+    #(  5.5368  -8.7738   3.7227) ; H5**
+    #(  6.3232  -7.2037   2.6002) ; C4* 
+    #(  7.3048  -7.6757   2.5577) ; H4* 
+    #(  6.0635  -6.5092   1.3456) ; O4* 
+    #(  6.4697  -5.1547   1.4629) ; C1* 
+    #(  7.2354  -5.0043   0.7018) ; H1* 
+    #(  7.0856  -4.9610   2.8521) ; C2* 
+    #(  6.7777  -3.9935   3.2487) ; H2**
+    #(  8.4627  -5.1992   2.7423) ; O2* 
+    #(  8.8693  -4.8638   1.9399) ; H2* 
+    #(  6.3877  -6.0809   3.6362) ; C3* 
+    #(  5.3770  -5.7562   3.8834) ; H3* 
+    #(  7.1024  -6.4754   4.7985) ; O3* 
+    #(  5.2764  -4.2883   1.2538) ; N1  
+    #(  4.3777  -2.2062   0.7229) ; N3  
+    #(  5.5069  -2.9779   0.9088) ; C2  
+    #(  3.0693  -2.6246   0.8500) ; C4  
+    #(  2.9279  -4.0146   1.2149) ; C5  
+    #(  4.0101  -4.7892   1.4017) ; C6  
+    #(  2.1040  -1.7437   0.6331) ; N4  
+    #(  6.6267  -2.5166   0.7728) ; O2  
+    #(  1.1496  -2.0600   0.7287) ; H41 
+    #(  2.3303  -0.7921   0.3815) ; H42 
+    #(  1.9353  -4.4465   1.3419) ; H5  
+    #(  3.8895  -5.8371   1.6762) ; H6  
+  ))
+
+(define rC02
+  (make-constant-rC
+    #(  0.5141   0.0246   0.8574  ; dgf-base-tfo
+       -0.5547  -0.7529   0.3542
+        0.6542  -0.6577  -0.3734
+       -9.1111  -3.4598  -3.2939)
+    #( -0.8313  -0.4738  -0.2906  ; P-O3*-275-tfo
+        0.0649   0.4366  -0.8973
+        0.5521  -0.7648  -0.3322
+        1.6833   6.8060  -7.0011)
+    #(  0.3445  -0.7630   0.5470  ; P-O3*-180-tfo
+       -0.4628  -0.6450  -0.6082
+        0.8168  -0.0436  -0.5753
+       -6.8179  -3.9778  -5.9887)
+    #(  0.5855   0.7931  -0.1682  ; P-O3*-60-tfo
+        0.8103  -0.5790   0.0906
+       -0.0255  -0.1894  -0.9816
+        6.1203  -7.1051   3.1984)
+    #(  2.6760  -8.4960   3.2880) ; P   
+    #(  1.4950  -7.6230   3.4770) ; O1P 
+    #(  2.9490  -9.4640   4.3740) ; O2P 
+    #(  3.9730  -7.5950   3.0340) ; O5* 
+    #(  4.3825  -6.6585   4.0489) ; C5* 
+    #(  4.6841  -7.2019   4.9443) ; H5* 
+    #(  3.6189  -5.8889   4.1625) ; H5**
+    #(  5.6255  -5.9175   3.5998) ; C4* 
+    #(  5.8732  -5.1228   4.3034) ; H4* 
+    #(  6.7337  -6.8605   3.5222) ; O4* 
+    #(  7.5932  -6.4923   2.4548) ; C1* 
+    #(  8.5661  -6.2983   2.9064) ; H1* 
+    #(  7.0527  -5.2012   1.8322) ; C2* 
+    #(  7.1627  -5.2525   0.7490) ; H2**
+    #(  7.6666  -4.1249   2.4880) ; O2* 
+    #(  8.5944  -4.2543   2.6981) ; H2* 
+    #(  5.5661  -5.3029   2.2009) ; C3* 
+    #(  5.0841  -6.0018   1.5172) ; H3* 
+    #(  4.9062  -4.0452   2.2042) ; O3* 
+    #(  7.6298  -7.6136   1.4752) ; N1  
+    #(  8.6945  -8.7046  -0.2857) ; N3  
+    #(  8.6943  -7.6514   0.6066) ; C2  
+    #(  7.7426  -9.6987  -0.3801) ; C4  
+    #(  6.6642  -9.5742   0.5722) ; C5  
+    #(  6.6391  -8.5592   1.4526) ; C6  
+    #(  7.9033 -10.6371  -1.3010) ; N4  
+    #(  9.5840  -6.8186   0.6136) ; O2  
+    #(  7.2009 -11.3604  -1.3619) ; H41 
+    #(  8.7058 -10.6168  -1.9140) ; H42 
+    #(  5.8585 -10.3083   0.5822) ; H5  
+    #(  5.8197  -8.4773   2.1667) ; H6  
+  ))
+
+(define rC03
+  (make-constant-rC
+    #( -0.4993   0.0476   0.8651  ; dgf-base-tfo
+        0.8078  -0.3353   0.4847
+        0.3132   0.9409   0.1290
+        6.2989  -5.2303  -3.8577)
+    #( -0.8313  -0.4738  -0.2906  ; P-O3*-275-tfo
+        0.0649   0.4366  -0.8973
+        0.5521  -0.7648  -0.3322
+        1.6833   6.8060  -7.0011)
+    #(  0.3445  -0.7630   0.5470  ; P-O3*-180-tfo
+       -0.4628  -0.6450  -0.6082
+        0.8168  -0.0436  -0.5753
+       -6.8179  -3.9778  -5.9887)
+    #(  0.5855   0.7931  -0.1682  ; P-O3*-60-tfo
+        0.8103  -0.5790   0.0906
+       -0.0255  -0.1894  -0.9816
+        6.1203  -7.1051   3.1984)
+    #(  2.6760  -8.4960   3.2880) ; P   
+    #(  1.4950  -7.6230   3.4770) ; O1P 
+    #(  2.9490  -9.4640   4.3740) ; O2P 
+    #(  3.9730  -7.5950   3.0340) ; O5* 
+    #(  3.9938  -6.7042   1.9023) ; C5* 
+    #(  3.2332  -5.9343   2.0319) ; H5* 
+    #(  3.9666  -7.2863   0.9812) ; H5**
+    #(  5.3098  -5.9546   1.8564) ; C4* 
+    #(  5.3863  -5.3702   0.9395) ; H4* 
+    #(  5.3851  -5.0642   3.0076) ; O4* 
+    #(  6.7315  -4.9724   3.4462) ; C1* 
+    #(  7.0033  -3.9202   3.3619) ; H1* 
+    #(  7.5997  -5.8018   2.4948) ; C2* 
+    #(  8.3627  -6.3254   3.0707) ; H2**
+    #(  8.0410  -4.9501   1.4724) ; O2* 
+    #(  8.2781  -4.0644   1.7570) ; H2* 
+    #(  6.5701  -6.8129   1.9714) ; C3* 
+    #(  6.4186  -7.5809   2.7299) ; H3* 
+    #(  6.9357  -7.3841   0.7235) ; O3* 
+    #(  6.8024  -5.4718   4.8475) ; N1  
+    #(  7.9218  -5.5700   6.8877) ; N3  
+    #(  7.8908  -5.0886   5.5944) ; C2  
+    #(  6.9789  -6.3827   7.4823) ; C4  
+    #(  5.8742  -6.7319   6.6202) ; C5  
+    #(  5.8182  -6.2769   5.3570) ; C6  
+    #(  7.1702  -6.7511   8.7402) ; N4  
+    #(  8.7747  -4.3728   5.1568) ; O2  
+    #(  6.4741  -7.3461   9.1662) ; H41 
+    #(  7.9889  -6.4396   9.2429) ; H42 
+    #(  5.0736  -7.3713   6.9922) ; H5  
+    #(  4.9784  -6.5473   4.7170) ; H6  
+  ))
+
+(define rC04
+  (make-constant-rC
+    #( -0.5669  -0.8012   0.1918  ; dgf-base-tfo
+       -0.8129   0.5817   0.0273
+       -0.1334  -0.1404  -0.9811
+       -0.3279   8.3874   0.3355)
+    #( -0.8313  -0.4738  -0.2906  ; P-O3*-275-tfo
+        0.0649   0.4366  -0.8973
+        0.5521  -0.7648  -0.3322
+        1.6833   6.8060  -7.0011)
+    #(  0.3445  -0.7630   0.5470  ; P-O3*-180-tfo
+       -0.4628  -0.6450  -0.6082
+        0.8168  -0.0436  -0.5753
+       -6.8179  -3.9778  -5.9887)
+    #(  0.5855   0.7931  -0.1682  ; P-O3*-60-tfo
+        0.8103  -0.5790   0.0906
+       -0.0255  -0.1894  -0.9816
+        6.1203  -7.1051   3.1984)
+    #(  2.6760  -8.4960   3.2880) ; P   
+    #(  1.4950  -7.6230   3.4770) ; O1P 
+    #(  2.9490  -9.4640   4.3740) ; O2P 
+    #(  3.9730  -7.5950   3.0340) ; O5* 
+    #(  5.2416  -8.2422   2.8181) ; C5* 
+    #(  5.2050  -8.8128   1.8901) ; H5* 
+    #(  5.5368  -8.7738   3.7227) ; H5**
+    #(  6.3232  -7.2037   2.6002) ; C4* 
+    #(  7.3048  -7.6757   2.5577) ; H4* 
+    #(  6.0635  -6.5092   1.3456) ; O4* 
+    #(  6.4697  -5.1547   1.4629) ; C1* 
+    #(  7.2354  -5.0043   0.7018) ; H1* 
+    #(  7.0856  -4.9610   2.8521) ; C2* 
+    #(  6.7777  -3.9935   3.2487) ; H2**
+    #(  8.4627  -5.1992   2.7423) ; O2* 
+    #(  8.8693  -4.8638   1.9399) ; H2* 
+    #(  6.3877  -6.0809   3.6362) ; C3* 
+    #(  5.3770  -5.7562   3.8834) ; H3* 
+    #(  7.1024  -6.4754   4.7985) ; O3* 
+    #(  5.2764  -4.2883   1.2538) ; N1  
+    #(  3.8961  -3.0896  -0.1893) ; N3  
+    #(  5.0095  -3.8907  -0.0346) ; C2  
+    #(  3.0480  -2.6632   0.8116) ; C4  
+    #(  3.4093  -3.1310   2.1292) ; C5  
+    #(  4.4878  -3.9124   2.3088) ; C6  
+    #(  2.0216  -1.8941   0.4804) ; N4  
+    #(  5.7005  -4.2164  -0.9842) ; O2  
+    #(  1.4067  -1.5873   1.2205) ; H41 
+    #(  1.8721  -1.6319  -0.4835) ; H42 
+    #(  2.8048  -2.8507   2.9918) ; H5  
+    #(  4.7491  -4.2593   3.3085) ; H6  
+  ))
+
+(define rC05
+  (make-constant-rC
+    #( -0.6298   0.0246   0.7763  ; dgf-base-tfo
+       -0.5226  -0.7529  -0.4001
+        0.5746  -0.6577   0.4870
+       -0.0208  -3.4598  -9.6882)
+    #( -0.8313  -0.4738  -0.2906  ; P-O3*-275-tfo
+        0.0649   0.4366  -0.8973
+        0.5521  -0.7648  -0.3322
+        1.6833   6.8060  -7.0011)
+    #(  0.3445  -0.7630   0.5470  ; P-O3*-180-tfo
+       -0.4628  -0.6450  -0.6082
+        0.8168  -0.0436  -0.5753
+       -6.8179  -3.9778  -5.9887)
+    #(  0.5855   0.7931  -0.1682  ; P-O3*-60-tfo
+        0.8103  -0.5790   0.0906
+       -0.0255  -0.1894  -0.9816
+        6.1203  -7.1051   3.1984)
+    #(  2.6760  -8.4960   3.2880) ; P   
+    #(  1.4950  -7.6230   3.4770) ; O1P 
+    #(  2.9490  -9.4640   4.3740) ; O2P 
+    #(  3.9730  -7.5950   3.0340) ; O5* 
+    #(  4.3825  -6.6585   4.0489) ; C5* 
+    #(  4.6841  -7.2019   4.9443) ; H5* 
+    #(  3.6189  -5.8889   4.1625) ; H5**
+    #(  5.6255  -5.9175   3.5998) ; C4* 
+    #(  5.8732  -5.1228   4.3034) ; H4* 
+    #(  6.7337  -6.8605   3.5222) ; O4* 
+    #(  7.5932  -6.4923   2.4548) ; C1* 
+    #(  8.5661  -6.2983   2.9064) ; H1* 
+    #(  7.0527  -5.2012   1.8322) ; C2* 
+    #(  7.1627  -5.2525   0.7490) ; H2**
+    #(  7.6666  -4.1249   2.4880) ; O2* 
+    #(  8.5944  -4.2543   2.6981) ; H2* 
+    #(  5.5661  -5.3029   2.2009) ; C3* 
+    #(  5.0841  -6.0018   1.5172) ; H3* 
+    #(  4.9062  -4.0452   2.2042) ; O3* 
+    #(  7.6298  -7.6136   1.4752) ; N1  
+    #(  8.5977  -9.5977   0.7329) ; N3  
+    #(  8.5951  -8.5745   1.6594) ; C2  
+    #(  7.7372  -9.7371  -0.3364) ; C4  
+    #(  6.7596  -8.6801  -0.4476) ; C5  
+    #(  6.7338  -7.6721   0.4408) ; C6  
+    #(  7.8849 -10.7881  -1.1289) ; N4  
+    #(  9.3993  -8.5377   2.5743) ; O2  
+    #(  7.2499 -10.8809  -1.9088) ; H41 
+    #(  8.6122 -11.4649  -0.9468) ; H42 
+    #(  6.0317  -8.6941  -1.2588) ; H5  
+    #(  5.9901  -6.8809   0.3459) ; H6  
+  ))
+
+(define rC06
+  (make-constant-rC
+    #( -0.9837   0.0476  -0.1733  ; dgf-base-tfo
+       -0.1792  -0.3353   0.9249
+       -0.0141   0.9409   0.3384
+        5.7793  -5.2303   4.5997)
+    #( -0.8313  -0.4738  -0.2906  ; P-O3*-275-tfo
+        0.0649   0.4366  -0.8973
+        0.5521  -0.7648  -0.3322
+        1.6833   6.8060  -7.0011)
+    #(  0.3445  -0.7630   0.5470  ; P-O3*-180-tfo
+       -0.4628  -0.6450  -0.6082
+        0.8168  -0.0436  -0.5753
+       -6.8179  -3.9778  -5.9887)
+    #(  0.5855   0.7931  -0.1682  ; P-O3*-60-tfo
+        0.8103  -0.5790   0.0906
+       -0.0255  -0.1894  -0.9816
+        6.1203  -7.1051   3.1984)
+    #(  2.6760  -8.4960   3.2880) ; P   
+    #(  1.4950  -7.6230   3.4770) ; O1P 
+    #(  2.9490  -9.4640   4.3740) ; O2P 
+    #(  3.9730  -7.5950   3.0340) ; O5* 
+    #(  3.9938  -6.7042   1.9023) ; C5* 
+    #(  3.2332  -5.9343   2.0319) ; H5* 
+    #(  3.9666  -7.2863   0.9812) ; H5**
+    #(  5.3098  -5.9546   1.8564) ; C4* 
+    #(  5.3863  -5.3702   0.9395) ; H4* 
+    #(  5.3851  -5.0642   3.0076) ; O4* 
+    #(  6.7315  -4.9724   3.4462) ; C1* 
+    #(  7.0033  -3.9202   3.3619) ; H1* 
+    #(  7.5997  -5.8018   2.4948) ; C2* 
+    #(  8.3627  -6.3254   3.0707) ; H2**
+    #(  8.0410  -4.9501   1.4724) ; O2* 
+    #(  8.2781  -4.0644   1.7570) ; H2* 
+    #(  6.5701  -6.8129   1.9714) ; C3* 
+    #(  6.4186  -7.5809   2.7299) ; H3* 
+    #(  6.9357  -7.3841   0.7235) ; O3* 
+    #(  6.8024  -5.4718   4.8475) ; N1  
+    #(  6.6920  -5.0495   7.1354) ; N3  
+    #(  6.6201  -4.5500   5.8506) ; C2  
+    #(  6.9254  -6.3614   7.4926) ; C4  
+    #(  7.1046  -7.2543   6.3718) ; C5  
+    #(  7.0391  -6.7951   5.1106) ; C6  
+    #(  6.9614  -6.6648   8.7815) ; N4  
+    #(  6.4083  -3.3696   5.6340) ; O2  
+    #(  7.1329  -7.6280   9.0324) ; H41 
+    #(  6.8204  -5.9469   9.4777) ; H42 
+    #(  7.2954  -8.3135   6.5440) ; H5  
+    #(  7.1753  -7.4798   4.2735) ; H6  
+  ))
+
+(define rC07
+  (make-constant-rC
+    #(  0.0033   0.2720  -0.9623  ; dgf-base-tfo
+        0.3013  -0.9179  -0.2584
+       -0.9535  -0.2891  -0.0850
+       43.0403  13.7233  34.5710)
+    #(  0.9187   0.2887   0.2694  ; P-O3*-275-tfo
+        0.0302  -0.7316   0.6811
+        0.3938  -0.6176  -0.6808
+      -48.4330  26.3254  13.6383)
+    #( -0.1504   0.7744  -0.6145  ; P-O3*-180-tfo
+        0.7581   0.4893   0.4311
+        0.6345  -0.4010  -0.6607
+      -31.9784 -13.4285  44.9650)
+    #( -0.6236  -0.7810  -0.0337  ; P-O3*-60-tfo
+       -0.6890   0.5694  -0.4484
+        0.3694  -0.2564  -0.8932
+       12.1105  30.8774  46.0946)
+    #( 33.3400  11.0980  46.1750) ; P   
+    #( 34.5130  10.2320  46.4660) ; O1P 
+    #( 33.4130  12.3960  46.9340) ; O2P 
+    #( 31.9810  10.3390  46.4820) ; O5* 
+    #( 30.8152  11.1619  46.2003) ; C5* 
+    #( 30.4519  10.9454  45.1957) ; H5* 
+    #( 31.0379  12.2016  46.4400) ; H5**
+    #( 29.7081  10.7448  47.1428) ; C4* 
+    #( 28.8710  11.4416  47.0982) ; H4* 
+    #( 29.2550   9.4394  46.8162) ; O4* 
+    #( 29.3907   8.5625  47.9460) ; C1* 
+    #( 28.4416   8.5669  48.4819) ; H1* 
+    #( 30.4468   9.2031  48.7952) ; C2* 
+    #( 31.4222   8.9651  48.3709) ; H2**
+    #( 30.3701   8.9157  50.1624) ; O2* 
+    #( 30.0652   8.0304  50.3740) ; H2* 
+    #( 30.1622  10.6879  48.6120) ; C3* 
+    #( 31.0952  11.2399  48.7254) ; H3* 
+    #( 29.1076  11.1535  49.4702) ; O3* 
+    #( 29.7883   7.2209  47.5235) ; N1  
+    #( 29.1825   5.0438  46.8275) ; N3  
+    #( 28.8008   6.2912  47.2263) ; C2  
+    #( 30.4888   4.6890  46.7186) ; C4  
+    #( 31.5034   5.6405  47.0249) ; C5  
+    #( 31.1091   6.8691  47.4156) ; C6  
+    #( 30.8109   3.4584  46.3336) ; N4  
+    #( 27.6171   6.5989  47.3189) ; O2  
+    #( 31.7923   3.2301  46.2638) ; H41 
+    #( 30.0880   2.7857  46.1215) ; H42 
+    #( 32.5542   5.3634  46.9395) ; H5  
+    #( 31.8523   7.6279  47.6603) ; H6  
+  ))
+
+(define rC08
+  (make-constant-rC
+    #(  0.0797  -0.6026  -0.7941  ; dgf-base-tfo
+        0.7939   0.5201  -0.3150
+        0.6028  -0.6054   0.5198
+      -36.8341  41.5293   1.6628)
+    #(  0.9187   0.2887   0.2694  ; P-O3*-275-tfo
+        0.0302  -0.7316   0.6811
+        0.3938  -0.6176  -0.6808
+      -48.4330  26.3254  13.6383)
+    #( -0.1504   0.7744  -0.6145  ; P-O3*-180-tfo
+        0.7581   0.4893   0.4311
+        0.6345  -0.4010  -0.6607
+      -31.9784 -13.4285  44.9650)
+    #( -0.6236  -0.7810  -0.0337  ; P-O3*-60-tfo
+       -0.6890   0.5694  -0.4484
+        0.3694  -0.2564  -0.8932
+       12.1105  30.8774  46.0946)
+    #( 33.3400  11.0980  46.1750) ; P   
+    #( 34.5130  10.2320  46.4660) ; O1P 
+    #( 33.4130  12.3960  46.9340) ; O2P 
+    #( 31.9810  10.3390  46.4820) ; O5* 
+    #( 31.8779   9.9369  47.8760) ; C5* 
+    #( 31.3239  10.6931  48.4322) ; H5* 
+    #( 32.8647   9.6624  48.2489) ; H5**
+    #( 31.0429   8.6773  47.9401) ; C4* 
+    #( 31.0779   8.2331  48.9349) ; H4* 
+    #( 29.6956   8.9669  47.5983) ; O4* 
+    #( 29.2784   8.1700  46.4782) ; C1* 
+    #( 28.8006   7.2731  46.8722) ; H1* 
+    #( 30.5544   7.7940  45.7875) ; C2* 
+    #( 30.8837   8.6410  45.1856) ; H2**
+    #( 30.5100   6.6007  45.0582) ; O2* 
+    #( 29.6694   6.4168  44.6326) ; H2* 
+    #( 31.5146   7.5954  46.9527) ; C3* 
+    #( 32.5255   7.8261  46.6166) ; H3* 
+    #( 31.3876   6.2951  47.5516) ; O3* 
+    #( 28.3976   8.9302  45.5933) ; N1  
+    #( 26.2155   9.6135  44.9910) ; N3  
+    #( 27.0281   8.8961  45.8192) ; C2  
+    #( 26.7044  10.3489  43.9595) ; C4  
+    #( 28.1088  10.3837  43.7247) ; C5  
+    #( 28.8978   9.6708  44.5535) ; C6  
+    #( 25.8715  11.0249  43.1749) ; N4  
+    #( 26.5733   8.2371  46.7484) ; O2  
+    #( 26.2707  11.5609  42.4177) ; H41 
+    #( 24.8760  10.9939  43.3427) ; H42 
+    #( 28.5089  10.9722  42.8990) ; H5  
+    #( 29.9782   9.6687  44.4097) ; H6  
+  ))
+
+(define rC09
+  (make-constant-rC
+    #(  0.8727   0.4760  -0.1091  ; dgf-base-tfo
+       -0.4188   0.6148  -0.6682
+       -0.2510   0.6289   0.7359
+       -8.1687 -52.0761 -25.0726)
+    #(  0.9187   0.2887   0.2694  ; P-O3*-275-tfo
+        0.0302  -0.7316   0.6811
+        0.3938  -0.6176  -0.6808
+      -48.4330  26.3254  13.6383)
+    #( -0.1504   0.7744  -0.6145  ; P-O3*-180-tfo
+        0.7581   0.4893   0.4311
+        0.6345  -0.4010  -0.6607
+      -31.9784 -13.4285  44.9650)
+    #( -0.6236  -0.7810  -0.0337  ; P-O3*-60-tfo
+       -0.6890   0.5694  -0.4484
+        0.3694  -0.2564  -0.8932
+       12.1105  30.8774  46.0946)
+    #( 33.3400  11.0980  46.1750) ; P   
+    #( 34.5130  10.2320  46.4660) ; O1P 
+    #( 33.4130  12.3960  46.9340) ; O2P 
+    #( 31.9810  10.3390  46.4820) ; O5* 
+    #( 30.8152  11.1619  46.2003) ; C5* 
+    #( 30.4519  10.9454  45.1957) ; H5* 
+    #( 31.0379  12.2016  46.4400) ; H5**
+    #( 29.7081  10.7448  47.1428) ; C4* 
+    #( 29.4506   9.6945  47.0059) ; H4* 
+    #( 30.1045  10.9634  48.4885) ; O4* 
+    #( 29.1794  11.8418  49.1490) ; C1* 
+    #( 28.4388  11.2210  49.6533) ; H1* 
+    #( 28.5211  12.6008  48.0367) ; C2* 
+    #( 29.1947  13.3949  47.7147) ; H2**
+    #( 27.2316  13.0683  48.3134) ; O2* 
+    #( 27.0851  13.3391  49.2227) ; H2* 
+    #( 28.4131  11.5507  46.9391) ; C3* 
+    #( 28.4451  12.0512  45.9713) ; H3* 
+    #( 27.2707  10.6955  47.1097) ; O3* 
+    #( 29.8751  12.7405  50.0682) ; N1  
+    #( 30.7172  13.1841  52.2328) ; N3  
+    #( 30.0617  12.3404  51.3847) ; C2  
+    #( 31.1834  14.3941  51.8297) ; C4  
+    #( 30.9913  14.8074  50.4803) ; C5  
+    #( 30.3434  13.9610  49.6548) ; C6  
+    #( 31.8090  15.1847  52.6957) ; N4  
+    #( 29.6470  11.2494  51.7616) ; O2  
+    #( 32.1422  16.0774  52.3606) ; H41 
+    #( 31.9392  14.8893  53.6527) ; H42 
+    #( 31.3632  15.7771  50.1491) ; H5  
+    #( 30.1742  14.2374  48.6141) ; H6  
+  ))
+
+(define rC10
+  (make-constant-rC
+    #(  0.1549   0.8710  -0.4663  ; dgf-base-tfo
+        0.6768  -0.4374  -0.5921
+       -0.7197  -0.2239  -0.6572
+       25.2447 -14.1920  50.3201)
+    #(  0.9187   0.2887   0.2694  ; P-O3*-275-tfo
+        0.0302  -0.7316   0.6811
+        0.3938  -0.6176  -0.6808
+      -48.4330  26.3254  13.6383)
+    #( -0.1504   0.7744  -0.6145  ; P-O3*-180-tfo
+        0.7581   0.4893   0.4311
+        0.6345  -0.4010  -0.6607
+      -31.9784 -13.4285  44.9650)
+    #( -0.6236  -0.7810  -0.0337  ; P-O3*-60-tfo
+       -0.6890   0.5694  -0.4484
+        0.3694  -0.2564  -0.8932
+       12.1105  30.8774  46.0946)
+    #( 33.3400  11.0980  46.1750) ; P   
+    #( 34.5130  10.2320  46.4660) ; O1P 
+    #( 33.4130  12.3960  46.9340) ; O2P 
+    #( 31.9810  10.3390  46.4820) ; O5* 
+    #( 31.8779   9.9369  47.8760) ; C5* 
+    #( 31.3239  10.6931  48.4322) ; H5* 
+    #( 32.8647   9.6624  48.2489) ; H5**
+    #( 31.0429   8.6773  47.9401) ; C4* 
+    #( 30.0440   8.8473  47.5383) ; H4* 
+    #( 31.6749   7.6351  47.2119) ; O4* 
+    #( 31.9159   6.5022  48.0616) ; C1* 
+    #( 31.0691   5.8243  47.9544) ; H1* 
+    #( 31.9300   7.0685  49.4493) ; C2* 
+    #( 32.9024   7.5288  49.6245) ; H2**
+    #( 31.5672   6.1750  50.4632) ; O2* 
+    #( 31.8416   5.2663  50.3200) ; H2* 
+    #( 30.8618   8.1514  49.3749) ; C3* 
+    #( 31.1122   8.9396  50.0850) ; H3* 
+    #( 29.5351   7.6245  49.5409) ; O3* 
+    #( 33.1890   5.8629  47.7343) ; N1  
+    #( 34.4004   4.2636  46.4828) ; N3  
+    #( 33.2062   4.8497  46.7851) ; C2  
+    #( 35.5600   4.6374  47.0822) ; C4  
+    #( 35.5444   5.6751  48.0577) ; C5  
+    #( 34.3565   6.2450  48.3432) ; C6  
+    #( 36.6977   4.0305  46.7598) ; N4  
+    #( 32.1661   4.5034  46.2348) ; O2  
+    #( 37.5405   4.3347  47.2259) ; H41 
+    #( 36.7033   3.2923  46.0706) ; H42 
+    #( 36.4713   5.9811  48.5428) ; H5  
+    #( 34.2986   7.0426  49.0839) ; H6  
+  ))
+
+(define rCs 
+  (list rC01 rC02 rC03 rC04 rC05 rC06 rC07 rC08 rC09 rC10))
+
+(define rG
+  (make-constant-rG
+    #( -0.0018  -0.8207   0.5714  ; dgf-base-tfo
+        0.2679  -0.5509  -0.7904
+        0.9634   0.1517   0.2209
+        0.0073   8.4030   0.6232)
+    #( -0.8143  -0.5091  -0.2788  ; P-O3*-275-tfo
+       -0.0433  -0.4257   0.9038
+       -0.5788   0.7480   0.3246
+        1.5227   6.9114  -7.0765)
+    #(  0.3822  -0.7477   0.5430  ; P-O3*-180-tfo
+        0.4552   0.6637   0.5935
+       -0.8042   0.0203   0.5941
+       -6.9472  -4.1186  -5.9108)
+    #(  0.5640   0.8007  -0.2022  ; P-O3*-60-tfo
+       -0.8247   0.5587  -0.0878
+        0.0426   0.2162   0.9754
+        6.2694  -7.0540   3.3316)
+    #(  2.8930   8.5380  -3.3280) ; P   
+    #(  1.6980   7.6960  -3.5570) ; O1P 
+    #(  3.2260   9.5010  -4.4020) ; O2P 
+    #(  4.1590   7.6040  -3.0340) ; O5* 
+    #(  5.4550   8.2120  -2.8810) ; C5* 
+    #(  5.4546   8.8508  -1.9978) ; H5* 
+    #(  5.7588   8.6625  -3.8259) ; H5**
+    #(  6.4970   7.1480  -2.5980) ; C4* 
+    #(  7.4896   7.5919  -2.5214) ; H4* 
+    #(  6.1630   6.4860  -1.3440) ; O4* 
+    #(  6.5400   5.1200  -1.4190) ; C1* 
+    #(  7.2763   4.9681  -0.6297) ; H1* 
+    #(  7.1940   4.8830  -2.7770) ; C2* 
+    #(  6.8667   3.9183  -3.1647) ; H2**
+    #(  8.5860   5.0910  -2.6140) ; O2* 
+    #(  8.9510   4.7626  -1.7890) ; H2* 
+    #(  6.5720   6.0040  -3.6090) ; C3* 
+    #(  5.5636   5.7066  -3.8966) ; H3* 
+    #(  7.3801   6.3562  -4.7350) ; O3* 
+    #(  4.7150   0.4910  -0.1360) ; N1  
+    #(  6.3490   2.1730  -0.6020) ; N3  
+    #(  5.9530   0.9650  -0.2670) ; C2  
+    #(  5.2900   2.9790  -0.8260) ; C4  
+    #(  3.9720   2.6390  -0.7330) ; C5  
+    #(  3.6770   1.3160  -0.3660) ; C6  
+    #(  6.8426   0.0056  -0.0019) ; N2  
+    #(  3.1660   3.7290  -1.0360) ; N7  
+    #(  5.3170   4.2990  -1.1930) ; N9  
+    #(  4.0100   4.6780  -1.2990) ; C8  
+    #(  2.4280   0.8450  -0.2360) ; O6  
+    #(  4.6151  -0.4677   0.1305) ; H1  
+    #(  6.6463  -0.9463   0.2729) ; H21 
+    #(  7.8170   0.2642  -0.0640) ; H22 
+    #(  3.4421   5.5744  -1.5482) ; H8  
+  ))
+
+(define rG01
+  (make-constant-rG
+    #( -0.0043  -0.8175   0.5759  ; dgf-base-tfo
+        0.2617  -0.5567  -0.7884
+        0.9651   0.1473   0.2164
+        0.0359   8.3929   0.5532)
+    #( -0.8143  -0.5091  -0.2788  ; P-O3*-275-tfo
+       -0.0433  -0.4257   0.9038
+       -0.5788   0.7480   0.3246
+        1.5227   6.9114  -7.0765)
+    #(  0.3822  -0.7477   0.5430  ; P-O3*-180-tfo
+        0.4552   0.6637   0.5935
+       -0.8042   0.0203   0.5941
+       -6.9472  -4.1186  -5.9108)
+    #(  0.5640   0.8007  -0.2022  ; P-O3*-60-tfo
+       -0.8247   0.5587  -0.0878
+        0.0426   0.2162   0.9754
+        6.2694  -7.0540   3.3316)
+    #(  2.8930   8.5380  -3.3280) ; P   
+    #(  1.6980   7.6960  -3.5570) ; O1P 
+    #(  3.2260   9.5010  -4.4020) ; O2P 
+    #(  4.1590   7.6040  -3.0340) ; O5* 
+    #(  5.4352   8.2183  -2.7757) ; C5* 
+    #(  5.3830   8.7883  -1.8481) ; H5* 
+    #(  5.7729   8.7436  -3.6691) ; H5**
+    #(  6.4830   7.1518  -2.5252) ; C4* 
+    #(  7.4749   7.5972  -2.4482) ; H4* 
+    #(  6.1626   6.4620  -1.2827) ; O4* 
+    #(  6.5431   5.0992  -1.3905) ; C1* 
+    #(  7.2871   4.9328  -0.6114) ; H1* 
+    #(  7.1852   4.8935  -2.7592) ; C2* 
+    #(  6.8573   3.9363  -3.1645) ; H2**
+    #(  8.5780   5.1025  -2.6046) ; O2* 
+    #(  8.9516   4.7577  -1.7902) ; H2* 
+    #(  6.5522   6.0300  -3.5612) ; C3* 
+    #(  5.5420   5.7356  -3.8459) ; H3* 
+    #(  7.3487   6.4089  -4.6867) ; O3* 
+    #(  4.7442   0.4514  -0.1390) ; N1  
+    #(  6.3687   2.1459  -0.5926) ; N3  
+    #(  5.9795   0.9335  -0.2657) ; C2  
+    #(  5.3052   2.9471  -0.8125) ; C4  
+    #(  3.9891   2.5987  -0.7230) ; C5  
+    #(  3.7016   1.2717  -0.3647) ; C6  
+    #(  6.8745  -0.0224  -0.0058) ; N2  
+    #(  3.1770   3.6859  -1.0198) ; N7  
+    #(  5.3247   4.2695  -1.1710) ; N9  
+    #(  4.0156   4.6415  -1.2759) ; C8  
+    #(  2.4553   0.7925  -0.2390) ; O6  
+    #(  4.6497  -0.5095   0.1212) ; H1  
+    #(  6.6836  -0.9771   0.2627) ; H21 
+    #(  7.8474   0.2424  -0.0653) ; H22 
+    #(  3.4426   5.5361  -1.5199) ; H8  
+  ))
+
+(define rG02
+  (make-constant-rG
+    #(  0.5566   0.0449   0.8296  ; dgf-base-tfo
+        0.5125   0.7673  -0.3854
+       -0.6538   0.6397   0.4041
+       -9.1161  -3.7679  -2.9968)
+    #( -0.8143  -0.5091  -0.2788  ; P-O3*-275-tfo
+       -0.0433  -0.4257   0.9038
+       -0.5788   0.7480   0.3246
+        1.5227   6.9114  -7.0765)
+    #(  0.3822  -0.7477   0.5430  ; P-O3*-180-tfo
+        0.4552   0.6637   0.5935
+       -0.8042   0.0203   0.5941
+       -6.9472  -4.1186  -5.9108)
+    #(  0.5640   0.8007  -0.2022  ; P-O3*-60-tfo
+       -0.8247   0.5587  -0.0878
+        0.0426   0.2162   0.9754
+        6.2694  -7.0540   3.3316)
+    #(  2.8930   8.5380  -3.3280) ; P   
+    #(  1.6980   7.6960  -3.5570) ; O1P 
+    #(  3.2260   9.5010  -4.4020) ; O2P 
+    #(  4.1590   7.6040  -3.0340) ; O5* 
+    #(  4.5778   6.6594  -4.0364) ; C5* 
+    #(  4.9220   7.1963  -4.9204) ; H5* 
+    #(  3.7996   5.9091  -4.1764) ; H5**
+    #(  5.7873   5.8869  -3.5482) ; C4* 
+    #(  6.0405   5.0875  -4.2446) ; H4* 
+    #(  6.9135   6.8036  -3.4310) ; O4* 
+    #(  7.7293   6.4084  -2.3392) ; C1* 
+    #(  8.7078   6.1815  -2.7624) ; H1* 
+    #(  7.1305   5.1418  -1.7347) ; C2* 
+    #(  7.2040   5.1982  -0.6486) ; H2**
+    #(  7.7417   4.0392  -2.3813) ; O2* 
+    #(  8.6785   4.1443  -2.5630) ; H2* 
+    #(  5.6666   5.2728  -2.1536) ; C3* 
+    #(  5.1747   5.9805  -1.4863) ; H3* 
+    #(  4.9997   4.0086  -2.1973) ; O3* 
+    #( 10.3245   8.5459   1.5467) ; N1  
+    #(  9.8051   6.9432  -0.1497) ; N3  
+    #( 10.5175   7.4328   0.8408) ; C2  
+    #(  8.7523   7.7422  -0.4228) ; C4  
+    #(  8.4257   8.9060   0.2099) ; C5  
+    #(  9.2665   9.3242   1.2540) ; C6  
+    #( 11.6077   6.7966   1.2752) ; N2  
+    #(  7.2750   9.4537  -0.3428) ; N7  
+    #(  7.7962   7.5519  -1.3859) ; N9  
+    #(  6.9479   8.6157  -1.2771) ; C8  
+    #(  9.0664  10.4462   1.9610) ; O6  
+    #( 10.9838   8.7524   2.2697) ; H1  
+    #( 12.2274   7.0896   2.0170) ; H21 
+    #( 11.8502   5.9398   0.7984) ; H22 
+    #(  6.0430   8.9853  -1.7594) ; H8  
+  ))
+
+(define rG03
+  (make-constant-rG
+    #( -0.5021   0.0731   0.8617  ; dgf-base-tfo
+       -0.8112   0.3054  -0.4986
+       -0.2996  -0.9494  -0.0940
+        6.4273  -5.1944  -3.7807)
+    #( -0.8143  -0.5091  -0.2788  ; P-O3*-275-tfo
+       -0.0433  -0.4257   0.9038
+       -0.5788   0.7480   0.3246
+        1.5227   6.9114  -7.0765)
+    #(  0.3822  -0.7477   0.5430  ; P-O3*-180-tfo
+        0.4552   0.6637   0.5935
+       -0.8042   0.0203   0.5941
+       -6.9472  -4.1186  -5.9108)
+    #(  0.5640   0.8007  -0.2022  ; P-O3*-60-tfo
+       -0.8247   0.5587  -0.0878
+        0.0426   0.2162   0.9754
+        6.2694  -7.0540   3.3316)
+    #(  2.8930   8.5380  -3.3280) ; P   
+    #(  1.6980   7.6960  -3.5570) ; O1P 
+    #(  3.2260   9.5010  -4.4020) ; O2P 
+    #(  4.1590   7.6040  -3.0340) ; O5* 
+    #(  4.1214   6.7116  -1.9049) ; C5* 
+    #(  3.3465   5.9610  -2.0607) ; H5* 
+    #(  4.0789   7.2928  -0.9837) ; H5**
+    #(  5.4170   5.9293  -1.8186) ; C4* 
+    #(  5.4506   5.3400  -0.9023) ; H4* 
+    #(  5.5067   5.0417  -2.9703) ; O4* 
+    #(  6.8650   4.9152  -3.3612) ; C1* 
+    #(  7.1090   3.8577  -3.2603) ; H1* 
+    #(  7.7152   5.7282  -2.3894) ; C2* 
+    #(  8.5029   6.2356  -2.9463) ; H2**
+    #(  8.1036   4.8568  -1.3419) ; O2* 
+    #(  8.3270   3.9651  -1.6184) ; H2* 
+    #(  6.7003   6.7565  -1.8911) ; C3* 
+    #(  6.5898   7.5329  -2.6482) ; H3* 
+    #(  7.0505   7.2878  -0.6105) ; O3* 
+    #(  9.6740   4.7656  -7.6614) ; N1  
+    #(  9.0739   4.3013  -5.3941) ; N3  
+    #(  9.8416   4.2192  -6.4581) ; C2  
+    #(  7.9885   5.0632  -5.6446) ; C4  
+    #(  7.6822   5.6856  -6.8194) ; C5  
+    #(  8.5831   5.5215  -7.8840) ; C6  
+    #( 10.9733   3.5117  -6.4286) ; N2  
+    #(  6.4857   6.3816  -6.7035) ; N7  
+    #(  6.9740   5.3703  -4.7760) ; N9  
+    #(  6.1133   6.1613  -5.4808) ; C8  
+    #(  8.4084   6.0747  -9.0933) ; O6  
+    #( 10.3759   4.5855  -8.3504) ; H1  
+    #( 11.6254   3.3761  -7.1879) ; H21 
+    #( 11.1917   3.0460  -5.5593) ; H22 
+    #(  5.1705   6.6830  -5.3167) ; H8  
+  ))
+
+(define rG04
+  (make-constant-rG
+    #( -0.5426  -0.8175   0.1929  ; dgf-base-tfo
+        0.8304  -0.5567  -0.0237
+        0.1267   0.1473   0.9809
+       -0.5075   8.3929   0.2229)
+    #( -0.8143  -0.5091  -0.2788  ; P-O3*-275-tfo
+       -0.0433  -0.4257   0.9038
+       -0.5788   0.7480   0.3246
+        1.5227   6.9114  -7.0765)
+    #(  0.3822  -0.7477   0.5430  ; P-O3*-180-tfo
+        0.4552   0.6637   0.5935
+       -0.8042   0.0203   0.5941
+       -6.9472  -4.1186  -5.9108)
+    #(  0.5640   0.8007  -0.2022  ; P-O3*-60-tfo
+       -0.8247   0.5587  -0.0878
+        0.0426   0.2162   0.9754
+        6.2694  -7.0540   3.3316)
+    #(  2.8930   8.5380  -3.3280) ; P   
+    #(  1.6980   7.6960  -3.5570) ; O1P 
+    #(  3.2260   9.5010  -4.4020) ; O2P 
+    #(  4.1590   7.6040  -3.0340) ; O5* 
+    #(  5.4352   8.2183  -2.7757) ; C5* 
+    #(  5.3830   8.7883  -1.8481) ; H5* 
+    #(  5.7729   8.7436  -3.6691) ; H5**
+    #(  6.4830   7.1518  -2.5252) ; C4* 
+    #(  7.4749   7.5972  -2.4482) ; H4* 
+    #(  6.1626   6.4620  -1.2827) ; O4* 
+    #(  6.5431   5.0992  -1.3905) ; C1* 
+    #(  7.2871   4.9328  -0.6114) ; H1* 
+    #(  7.1852   4.8935  -2.7592) ; C2* 
+    #(  6.8573   3.9363  -3.1645) ; H2**
+    #(  8.5780   5.1025  -2.6046) ; O2* 
+    #(  8.9516   4.7577  -1.7902) ; H2* 
+    #(  6.5522   6.0300  -3.5612) ; C3* 
+    #(  5.5420   5.7356  -3.8459) ; H3* 
+    #(  7.3487   6.4089  -4.6867) ; O3* 
+    #(  3.6343   2.6680   2.0783) ; N1  
+    #(  5.4505   3.9805   1.2446) ; N3  
+    #(  4.7540   3.3816   2.1851) ; C2  
+    #(  4.8805   3.7951   0.0354) ; C4  
+    #(  3.7416   3.0925  -0.2305) ; C5  
+    #(  3.0873   2.4980   0.8606) ; C6  
+    #(  5.1433   3.4373   3.4609) ; N2  
+    #(  3.4605   3.1184  -1.5906) ; N7  
+    #(  5.3247   4.2695  -1.1710) ; N9  
+    #(  4.4244   3.8244  -2.0953) ; C8  
+    #(  1.9600   1.7805   0.7462) ; O6  
+    #(  3.2489   2.2879   2.9191) ; H1  
+    #(  4.6785   3.0243   4.2568) ; H21 
+    #(  5.9823   3.9654   3.6539) ; H22 
+    #(  4.2675   3.8876  -3.1721) ; H8  
+  ))
+
+(define rG05
+  (make-constant-rG
+    #( -0.5891   0.0449   0.8068  ; dgf-base-tfo
+        0.5375   0.7673   0.3498
+       -0.6034   0.6397  -0.4762
+       -0.3019  -3.7679  -9.5913)
+    #( -0.8143  -0.5091  -0.2788  ; P-O3*-275-tfo
+       -0.0433  -0.4257   0.9038
+       -0.5788   0.7480   0.3246
+        1.5227   6.9114  -7.0765)
+    #(  0.3822  -0.7477   0.5430  ; P-O3*-180-tfo
+        0.4552   0.6637   0.5935
+       -0.8042   0.0203   0.5941
+       -6.9472  -4.1186  -5.9108)
+    #(  0.5640   0.8007  -0.2022  ; P-O3*-60-tfo
+       -0.8247   0.5587  -0.0878
+        0.0426   0.2162   0.9754
+        6.2694  -7.0540   3.3316)
+    #(  2.8930   8.5380  -3.3280) ; P   
+    #(  1.6980   7.6960  -3.5570) ; O1P 
+    #(  3.2260   9.5010  -4.4020) ; O2P 
+    #(  4.1590   7.6040  -3.0340) ; O5* 
+    #(  4.5778   6.6594  -4.0364) ; C5* 
+    #(  4.9220   7.1963  -4.9204) ; H5* 
+    #(  3.7996   5.9091  -4.1764) ; H5**
+    #(  5.7873   5.8869  -3.5482) ; C4* 
+    #(  6.0405   5.0875  -4.2446) ; H4* 
+    #(  6.9135   6.8036  -3.4310) ; O4* 
+    #(  7.7293   6.4084  -2.3392) ; C1* 
+    #(  8.7078   6.1815  -2.7624) ; H1* 
+    #(  7.1305   5.1418  -1.7347) ; C2* 
+    #(  7.2040   5.1982  -0.6486) ; H2**
+    #(  7.7417   4.0392  -2.3813) ; O2* 
+    #(  8.6785   4.1443  -2.5630) ; H2* 
+    #(  5.6666   5.2728  -2.1536) ; C3* 
+    #(  5.1747   5.9805  -1.4863) ; H3* 
+    #(  4.9997   4.0086  -2.1973) ; O3* 
+    #( 10.2594  10.6774  -1.0056) ; N1  
+    #(  9.7528   8.7080  -2.2631) ; N3  
+    #( 10.4471   9.7876  -1.9791) ; C2  
+    #(  8.7271   8.5575  -1.3991) ; C4  
+    #(  8.4100   9.3803  -0.3580) ; C5  
+    #(  9.2294  10.5030  -0.1574) ; C6  
+    #( 11.5110  10.1256  -2.7114) ; N2  
+    #(  7.2891   8.9068   0.3121) ; N7  
+    #(  7.7962   7.5519  -1.3859) ; N9  
+    #(  6.9702   7.8292  -0.3353) ; C8  
+    #(  9.0349  11.3951   0.8250) ; O6  
+    #( 10.9013  11.4422  -0.9512) ; H1  
+    #( 12.1031  10.9341  -2.5861) ; H21 
+    #( 11.7369   9.5180  -3.4859) ; H22 
+    #(  6.0888   7.3990   0.1403) ; H8  
+  ))
+
+(define rG06
+  (make-constant-rG
+    #( -0.9815   0.0731  -0.1772  ; dgf-base-tfo
+        0.1912   0.3054  -0.9328
+       -0.0141  -0.9494  -0.3137
+        5.7506  -5.1944   4.7470)
+    #( -0.8143  -0.5091  -0.2788  ; P-O3*-275-tfo
+       -0.0433  -0.4257   0.9038
+       -0.5788   0.7480   0.3246
+        1.5227   6.9114  -7.0765)
+    #(  0.3822  -0.7477   0.5430  ; P-O3*-180-tfo
+        0.4552   0.6637   0.5935
+       -0.8042   0.0203   0.5941
+       -6.9472  -4.1186  -5.9108)
+    #(  0.5640   0.8007  -0.2022  ; P-O3*-60-tfo
+       -0.8247   0.5587  -0.0878
+        0.0426   0.2162   0.9754
+        6.2694  -7.0540   3.3316)
+    #(  2.8930   8.5380  -3.3280) ; P   
+    #(  1.6980   7.6960  -3.5570) ; O1P 
+    #(  3.2260   9.5010  -4.4020) ; O2P 
+    #(  4.1590   7.6040  -3.0340) ; O5* 
+    #(  4.1214   6.7116  -1.9049) ; C5* 
+    #(  3.3465   5.9610  -2.0607) ; H5* 
+    #(  4.0789   7.2928  -0.9837) ; H5**
+    #(  5.4170   5.9293  -1.8186) ; C4* 
+    #(  5.4506   5.3400  -0.9023) ; H4* 
+    #(  5.5067   5.0417  -2.9703) ; O4* 
+    #(  6.8650   4.9152  -3.3612) ; C1* 
+    #(  7.1090   3.8577  -3.2603) ; H1* 
+    #(  7.7152   5.7282  -2.3894) ; C2* 
+    #(  8.5029   6.2356  -2.9463) ; H2**
+    #(  8.1036   4.8568  -1.3419) ; O2* 
+    #(  8.3270   3.9651  -1.6184) ; H2* 
+    #(  6.7003   6.7565  -1.8911) ; C3* 
+    #(  6.5898   7.5329  -2.6482) ; H3* 
+    #(  7.0505   7.2878  -0.6105) ; O3* 
+    #(  6.6624   3.5061  -8.2986) ; N1  
+    #(  6.5810   3.2570  -5.9221) ; N3  
+    #(  6.5151   2.8263  -7.1625) ; C2  
+    #(  6.8364   4.5817  -5.8882) ; C4  
+    #(  7.0116   5.4064  -6.9609) ; C5  
+    #(  6.9173   4.8260  -8.2361) ; C6  
+    #(  6.2717   1.5402  -7.4250) ; N2  
+    #(  7.2573   6.7070  -6.5394) ; N7  
+    #(  6.9740   5.3703  -4.7760) ; N9  
+    #(  7.2238   6.6275  -5.2453) ; C8  
+    #(  7.0668   5.5163  -9.3763) ; O6  
+    #(  6.5754   2.9964  -9.1545) ; H1  
+    #(  6.1908   1.1105  -8.3354) ; H21 
+    #(  6.1346   0.9352  -6.6280) ; H22 
+    #(  7.4108   7.6227  -4.8418) ; H8  
+  ))
+
+(define rG07
+  (make-constant-rG
+    #(  0.0894  -0.6059   0.7905  ; dgf-base-tfo
+       -0.6810   0.5420   0.4924
+       -0.7268  -0.5824  -0.3642
+       34.1424  45.9610 -11.8600)
+    #( -0.8644  -0.4956  -0.0851  ; P-O3*-275-tfo
+       -0.0427   0.2409  -0.9696
+        0.5010  -0.8345  -0.2294
+        4.0167  54.5377  12.4779)
+    #(  0.3706  -0.6167   0.6945  ; P-O3*-180-tfo
+       -0.2867  -0.7872  -0.5460
+        0.8834   0.0032  -0.4686
+      -52.9020  18.6313  -0.6709)
+    #(  0.4155   0.9025  -0.1137  ; P-O3*-60-tfo
+        0.9040  -0.4236  -0.0582
+       -0.1007  -0.0786  -0.9918
+       -7.6624 -25.2080  49.5181)
+    #( 31.3810   0.1400  47.5810) ; P   
+    #( 29.9860   0.6630  47.6290) ; O1P 
+    #( 31.7210  -0.6460  48.8090) ; O2P 
+    #( 32.4940   1.2540  47.2740) ; O5* 
+    #( 33.8709   0.7918  47.2113) ; C5* 
+    #( 34.1386   0.5870  46.1747) ; H5* 
+    #( 34.0186  -0.0095  47.9353) ; H5**
+    #( 34.7297   1.9687  47.6685) ; C4* 
+    #( 35.7723   1.6845  47.8113) ; H4* 
+    #( 34.6455   2.9768  46.6660) ; O4* 
+    #( 34.1690   4.1829  47.2627) ; C1* 
+    #( 35.0437   4.7633  47.5560) ; H1* 
+    #( 33.4145   3.7532  48.4954) ; C2* 
+    #( 32.4340   3.3797  48.2001) ; H2**
+    #( 33.3209   4.6953  49.5217) ; O2* 
+    #( 33.2374   5.6059  49.2295) ; H2* 
+    #( 34.2724   2.5970  48.9773) ; C3* 
+    #( 33.6373   1.8935  49.5157) ; H3* 
+    #( 35.3453   3.1884  49.7285) ; O3* 
+    #( 34.0511   7.8930  43.7791) ; N1  
+    #( 34.9937   6.3369  45.3199) ; N3  
+    #( 35.0882   7.3126  44.4200) ; C2  
+    #( 33.7190   5.9650  45.5374) ; C4  
+    #( 32.5845   6.4770  44.9458) ; C5  
+    #( 32.7430   7.5179  43.9914) ; C6  
+    #( 36.3030   7.7827  44.1036) ; N2  
+    #( 31.4499   5.8335  45.4368) ; N7  
+    #( 33.2760   4.9817  46.4043) ; N9  
+    #( 31.9235   4.9639  46.2934) ; C8  
+    #( 31.8602   8.1000  43.3695) ; O6  
+    #( 34.2623   8.6223  43.1283) ; H1  
+    #( 36.5188   8.5081  43.4347) ; H21 
+    #( 37.0888   7.3524  44.5699) ; H22 
+    #( 31.0815   4.4201  46.7218) ; H8  
+  ))
+
+(define rG08
+  (make-constant-rG
+    #(  0.2224   0.6335   0.7411  ; dgf-base-tfo
+       -0.3644  -0.6510   0.6659
+        0.9043  -0.4181   0.0861
+      -47.6824  -0.5823 -31.7554)
+    #( -0.8644  -0.4956  -0.0851  ; P-O3*-275-tfo
+       -0.0427   0.2409  -0.9696
+        0.5010  -0.8345  -0.2294
+        4.0167  54.5377  12.4779)
+    #(  0.3706  -0.6167   0.6945  ; P-O3*-180-tfo
+       -0.2867  -0.7872  -0.5460
+        0.8834   0.0032  -0.4686
+      -52.9020  18.6313  -0.6709)
+    #(  0.4155   0.9025  -0.1137  ; P-O3*-60-tfo
+        0.9040  -0.4236  -0.0582
+       -0.1007  -0.0786  -0.9918
+       -7.6624 -25.2080  49.5181)
+    #( 31.3810   0.1400  47.5810) ; P   
+    #( 29.9860   0.6630  47.6290) ; O1P 
+    #( 31.7210  -0.6460  48.8090) ; O2P 
+    #( 32.4940   1.2540  47.2740) ; O5* 
+    #( 32.5924   2.3488  48.2255) ; C5* 
+    #( 33.3674   2.1246  48.9584) ; H5* 
+    #( 31.5994   2.5917  48.6037) ; H5**
+    #( 33.0722   3.5577  47.4258) ; C4* 
+    #( 33.0310   4.4778  48.0089) ; H4* 
+    #( 34.4173   3.3055  47.0316) ; O4* 
+    #( 34.5056   3.3910  45.6094) ; C1* 
+    #( 34.7881   4.4152  45.3663) ; H1* 
+    #( 33.1122   3.1198  45.1010) ; C2* 
+    #( 32.9230   2.0469  45.1369) ; H2**
+    #( 32.7946   3.6590  43.8529) ; O2* 
+    #( 33.5170   3.6707  43.2207) ; H2* 
+    #( 32.2730   3.8173  46.1566) ; C3* 
+    #( 31.3094   3.3123  46.2244) ; H3* 
+    #( 32.2391   5.2039  45.7807) ; O3* 
+    #( 39.3337   2.7157  44.1441) ; N1  
+    #( 37.4430   3.8242  45.0824) ; N3  
+    #( 38.7276   3.7646  44.7403) ; C2  
+    #( 36.7791   2.6963  44.7704) ; C4  
+    #( 37.2860   1.5653  44.1678) ; C5  
+    #( 38.6647   1.5552  43.8235) ; C6  
+    #( 39.5123   4.8216  44.9936) ; N2  
+    #( 36.2829   0.6110  44.0078) ; N7  
+    #( 35.4394   2.4314  44.9931) ; N9  
+    #( 35.2180   1.1815  44.5128) ; C8  
+    #( 39.2907   0.6514  43.2796) ; O6  
+    #( 40.3076   2.8048  43.9352) ; H1  
+    #( 40.4994   4.9066  44.7977) ; H21 
+    #( 39.0738   5.6108  45.4464) ; H22 
+    #( 34.3856   0.4842  44.4185) ; H8  
+  ))
+
+(define rG09
+  (make-constant-rG
+    #( -0.9699  -0.1688  -0.1753  ; dgf-base-tfo
+       -0.1050  -0.3598   0.9271
+       -0.2196   0.9176   0.3312
+       45.6217 -38.9484 -12.3208)
+    #( -0.8644  -0.4956  -0.0851  ; P-O3*-275-tfo
+       -0.0427   0.2409  -0.9696
+        0.5010  -0.8345  -0.2294
+        4.0167  54.5377  12.4779)
+    #(  0.3706  -0.6167   0.6945  ; P-O3*-180-tfo
+       -0.2867  -0.7872  -0.5460
+        0.8834   0.0032  -0.4686
+      -52.9020  18.6313  -0.6709)
+    #(  0.4155   0.9025  -0.1137  ; P-O3*-60-tfo
+        0.9040  -0.4236  -0.0582
+       -0.1007  -0.0786  -0.9918
+       -7.6624 -25.2080  49.5181)
+    #( 31.3810   0.1400  47.5810) ; P   
+    #( 29.9860   0.6630  47.6290) ; O1P 
+    #( 31.7210  -0.6460  48.8090) ; O2P 
+    #( 32.4940   1.2540  47.2740) ; O5* 
+    #( 33.8709   0.7918  47.2113) ; C5* 
+    #( 34.1386   0.5870  46.1747) ; H5* 
+    #( 34.0186  -0.0095  47.9353) ; H5**
+    #( 34.7297   1.9687  47.6685) ; C4* 
+    #( 34.5880   2.8482  47.0404) ; H4* 
+    #( 34.3575   2.2770  49.0081) ; O4* 
+    #( 35.5157   2.1993  49.8389) ; C1* 
+    #( 35.9424   3.2010  49.8893) ; H1* 
+    #( 36.4701   1.2820  49.1169) ; C2* 
+    #( 36.1545   0.2498  49.2683) ; H2**
+    #( 37.8262   1.4547  49.4008) ; O2* 
+    #( 38.0227   1.6945  50.3094) ; H2* 
+    #( 36.2242   1.6797  47.6725) ; C3* 
+    #( 36.4297   0.8197  47.0351) ; H3* 
+    #( 37.0289   2.8480  47.4426) ; O3* 
+    #( 34.3005   3.5042  54.6070) ; N1  
+    #( 34.7693   3.7936  52.2874) ; N3  
+    #( 34.4484   4.2541  53.4939) ; C2  
+    #( 34.9354   2.4584  52.2785) ; C4  
+    #( 34.8092   1.5915  53.3422) ; C5  
+    #( 34.4646   2.1367  54.6085) ; C6  
+    #( 34.2514   5.5708  53.6503) ; N2  
+    #( 35.0641   0.2835  52.9337) ; N7  
+    #( 35.2669   1.6690  51.1915) ; N9  
+    #( 35.3288   0.3954  51.6563) ; C8  
+    #( 34.3151   1.5317  55.6650) ; O6  
+    #( 34.0623   3.9797  55.4539) ; H1  
+    #( 33.9950   6.0502  54.5016) ; H21 
+    #( 34.3512   6.1432  52.8242) ; H22 
+    #( 35.5414  -0.6006  51.2679) ; H8  
+  ))
+
+(define rG10
+  (make-constant-rG
+    #( -0.0980  -0.9723   0.2122  ; dgf-base-tfo
+       -0.9731   0.1383   0.1841
+       -0.2083  -0.1885  -0.9597
+       17.8469  38.8265  37.0475)
+    #( -0.8644  -0.4956  -0.0851  ; P-O3*-275-tfo
+       -0.0427   0.2409  -0.9696
+        0.5010  -0.8345  -0.2294
+        4.0167  54.5377  12.4779)
+    #(  0.3706  -0.6167   0.6945  ; P-O3*-180-tfo
+       -0.2867  -0.7872  -0.5460
+        0.8834   0.0032  -0.4686
+      -52.9020  18.6313  -0.6709)
+    #(  0.4155   0.9025  -0.1137  ; P-O3*-60-tfo
+        0.9040  -0.4236  -0.0582
+       -0.1007  -0.0786  -0.9918
+       -7.6624 -25.2080  49.5181)
+    #( 31.3810   0.1400  47.5810) ; P   
+    #( 29.9860   0.6630  47.6290) ; O1P 
+    #( 31.7210  -0.6460  48.8090) ; O2P 
+    #( 32.4940   1.2540  47.2740) ; O5* 
+    #( 32.5924   2.3488  48.2255) ; C5* 
+    #( 33.3674   2.1246  48.9584) ; H5* 
+    #( 31.5994   2.5917  48.6037) ; H5**
+    #( 33.0722   3.5577  47.4258) ; C4* 
+    #( 34.0333   3.3761  46.9447) ; H4* 
+    #( 32.0890   3.8338  46.4332) ; O4* 
+    #( 31.6377   5.1787  46.5914) ; C1* 
+    #( 32.2499   5.8016  45.9392) ; H1* 
+    #( 31.9167   5.5319  48.0305) ; C2* 
+    #( 31.1507   5.0820  48.6621) ; H2**
+    #( 32.0865   6.8890  48.3114) ; O2* 
+    #( 31.5363   7.4819  47.7942) ; H2* 
+    #( 33.2398   4.8224  48.2563) ; C3* 
+    #( 33.3166   4.5570  49.3108) ; H3* 
+    #( 34.2528   5.7056  47.7476) ; O3* 
+    #( 28.2782   6.3049  42.9364) ; N1  
+    #( 30.4001   5.8547  43.9258) ; N3  
+    #( 29.6195   6.1568  42.8913) ; C2  
+    #( 29.7005   5.7006  45.0649) ; C4  
+    #( 28.3383   5.8221  45.2343) ; C5  
+    #( 27.5519   6.1461  44.0958) ; C6  
+    #( 30.1838   6.3385  41.6890) ; N2  
+    #( 27.9936   5.5926  46.5651) ; N7  
+    #( 30.2046   5.3825  46.3136) ; N9  
+    #( 29.1371   5.3398  47.1506) ; C8  
+    #( 26.3361   6.3024  44.0495) ; O6  
+    #( 27.8122   6.5394  42.0833) ; H1  
+    #( 29.7125   6.5595  40.8235) ; H21 
+    #( 31.1859   6.2231  41.6389) ; H22 
+    #( 28.9406   5.1504  48.2059) ; H8  
+  ))
+
+(define rGs
+  (list rG01 rG02 rG03 rG04 rG05 rG06 rG07 rG08 rG09 rG10))
+
+(define rU
+  (make-constant-rU
+    #( -0.0359  -0.8071   0.5894  ; dgf-base-tfo
+       -0.2669   0.5761   0.7726
+       -0.9631  -0.1296  -0.2361
+        0.1584   8.3434   0.5434)
+    #( -0.8313  -0.4738  -0.2906  ; P-O3*-275-tfo
+        0.0649   0.4366  -0.8973
+        0.5521  -0.7648  -0.3322
+        1.6833   6.8060  -7.0011)
+    #(  0.3445  -0.7630   0.5470  ; P-O3*-180-tfo
+       -0.4628  -0.6450  -0.6082
+        0.8168  -0.0436  -0.5753
+       -6.8179  -3.9778  -5.9887)
+    #(  0.5855   0.7931  -0.1682  ; P-O3*-60-tfo
+        0.8103  -0.5790   0.0906
+       -0.0255  -0.1894  -0.9816
+        6.1203  -7.1051   3.1984)
+    #(  2.6760  -8.4960   3.2880) ; P   
+    #(  1.4950  -7.6230   3.4770) ; O1P 
+    #(  2.9490  -9.4640   4.3740) ; O2P 
+    #(  3.9730  -7.5950   3.0340) ; O5* 
+    #(  5.2430  -8.2420   2.8260) ; C5* 
+    #(  5.1974  -8.8497   1.9223) ; H5* 
+    #(  5.5548  -8.7348   3.7469) ; H5**
+    #(  6.3140  -7.2060   2.5510) ; C4* 
+    #(  7.2954  -7.6762   2.4898) ; H4* 
+    #(  6.0140  -6.5420   1.2890) ; O4* 
+    #(  6.4190  -5.1840   1.3620) ; C1* 
+    #(  7.1608  -5.0495   0.5747) ; H1* 
+    #(  7.0760  -4.9560   2.7270) ; C2* 
+    #(  6.7770  -3.9803   3.1099) ; H2**
+    #(  8.4500  -5.1930   2.5810) ; O2* 
+    #(  8.8309  -4.8755   1.7590) ; H2* 
+    #(  6.4060  -6.0590   3.5580) ; C3* 
+    #(  5.4021  -5.7313   3.8281) ; H3* 
+    #(  7.1570  -6.4240   4.7070) ; O3* 
+    #(  5.2170  -4.3260   1.1690) ; N1  
+    #(  4.2960  -2.2560   0.6290) ; N3  
+    #(  5.4330  -3.0200   0.7990) ; C2  
+    #(  2.9930  -2.6780   0.7940) ; C4  
+    #(  2.8670  -4.0630   1.1830) ; C5  
+    #(  3.9570  -4.8300   1.3550) ; C6  
+    #(  6.5470  -2.5560   0.6290) ; O2  
+    #(  2.0540  -1.9000   0.6130) ; O4  
+    #(  4.4300  -1.3020   0.3600) ; H3  
+    #(  1.9590  -4.4570   1.3250) ; H5  
+    #(  3.8460  -5.7860   1.6240) ; H6  
+  ))
+
+(define rU01
+  (make-constant-rU
+    #( -0.0137  -0.8012   0.5983  ; dgf-base-tfo
+       -0.2523   0.5817   0.7733
+       -0.9675  -0.1404  -0.2101
+        0.2031   8.3874   0.4228)
+    #( -0.8313  -0.4738  -0.2906  ; P-O3*-275-tfo
+        0.0649   0.4366  -0.8973
+        0.5521  -0.7648  -0.3322
+        1.6833   6.8060  -7.0011)
+    #(  0.3445  -0.7630   0.5470  ; P-O3*-180-tfo
+       -0.4628  -0.6450  -0.6082
+        0.8168  -0.0436  -0.5753
+       -6.8179  -3.9778  -5.9887)
+    #(  0.5855   0.7931  -0.1682  ; P-O3*-60-tfo
+        0.8103  -0.5790   0.0906
+       -0.0255  -0.1894  -0.9816
+        6.1203  -7.1051   3.1984)
+    #(  2.6760  -8.4960   3.2880) ; P   
+    #(  1.4950  -7.6230   3.4770) ; O1P 
+    #(  2.9490  -9.4640   4.3740) ; O2P 
+    #(  3.9730  -7.5950   3.0340) ; O5* 
+    #(  5.2416  -8.2422   2.8181) ; C5* 
+    #(  5.2050  -8.8128   1.8901) ; H5* 
+    #(  5.5368  -8.7738   3.7227) ; H5**
+    #(  6.3232  -7.2037   2.6002) ; C4* 
+    #(  7.3048  -7.6757   2.5577) ; H4* 
+    #(  6.0635  -6.5092   1.3456) ; O4* 
+    #(  6.4697  -5.1547   1.4629) ; C1* 
+    #(  7.2354  -5.0043   0.7018) ; H1* 
+    #(  7.0856  -4.9610   2.8521) ; C2* 
+    #(  6.7777  -3.9935   3.2487) ; H2**
+    #(  8.4627  -5.1992   2.7423) ; O2* 
+    #(  8.8693  -4.8638   1.9399) ; H2* 
+    #(  6.3877  -6.0809   3.6362) ; C3* 
+    #(  5.3770  -5.7562   3.8834) ; H3* 
+    #(  7.1024  -6.4754   4.7985) ; O3* 
+    #(  5.2764  -4.2883   1.2538) ; N1  
+    #(  4.3777  -2.2062   0.7229) ; N3  
+    #(  5.5069  -2.9779   0.9088) ; C2  
+    #(  3.0693  -2.6246   0.8500) ; C4  
+    #(  2.9279  -4.0146   1.2149) ; C5  
+    #(  4.0101  -4.7892   1.4017) ; C6  
+    #(  6.6267  -2.5166   0.7728) ; O2  
+    #(  2.1383  -1.8396   0.6581) ; O4  
+    #(  4.5223  -1.2489   0.4716) ; H3  
+    #(  2.0151  -4.4065   1.3290) ; H5  
+    #(  3.8886  -5.7486   1.6535) ; H6  
+  ))
+
+(define rU02
+  (make-constant-rU
+    #(  0.5141   0.0246   0.8574  ; dgf-base-tfo
+       -0.5547  -0.7529   0.3542
+        0.6542  -0.6577  -0.3734
+       -9.1111  -3.4598  -3.2939)
+    #( -0.8313  -0.4738  -0.2906  ; P-O3*-275-tfo
+        0.0649   0.4366  -0.8973
+        0.5521  -0.7648  -0.3322
+        1.6833   6.8060  -7.0011)
+    #(  0.3445  -0.7630   0.5470  ; P-O3*-180-tfo
+       -0.4628  -0.6450  -0.6082
+        0.8168  -0.0436  -0.5753
+       -6.8179  -3.9778  -5.9887)
+    #(  0.5855   0.7931  -0.1682  ; P-O3*-60-tfo
+        0.8103  -0.5790   0.0906
+       -0.0255  -0.1894  -0.9816
+        6.1203  -7.1051   3.1984)
+    #(  2.6760  -8.4960   3.2880) ; P   
+    #(  1.4950  -7.6230   3.4770) ; O1P 
+    #(  2.9490  -9.4640   4.3740) ; O2P 
+    #(  3.9730  -7.5950   3.0340) ; O5* 
+    #(  4.3825  -6.6585   4.0489) ; C5* 
+    #(  4.6841  -7.2019   4.9443) ; H5* 
+    #(  3.6189  -5.8889   4.1625) ; H5**
+    #(  5.6255  -5.9175   3.5998) ; C4* 
+    #(  5.8732  -5.1228   4.3034) ; H4* 
+    #(  6.7337  -6.8605   3.5222) ; O4* 
+    #(  7.5932  -6.4923   2.4548) ; C1* 
+    #(  8.5661  -6.2983   2.9064) ; H1* 
+    #(  7.0527  -5.2012   1.8322) ; C2* 
+    #(  7.1627  -5.2525   0.7490) ; H2**
+    #(  7.6666  -4.1249   2.4880) ; O2* 
+    #(  8.5944  -4.2543   2.6981) ; H2* 
+    #(  5.5661  -5.3029   2.2009) ; C3* 
+    #(  5.0841  -6.0018   1.5172) ; H3* 
+    #(  4.9062  -4.0452   2.2042) ; O3* 
+    #(  7.6298  -7.6136   1.4752) ; N1  
+    #(  8.6945  -8.7046  -0.2857) ; N3  
+    #(  8.6943  -7.6514   0.6066) ; C2  
+    #(  7.7426  -9.6987  -0.3801) ; C4  
+    #(  6.6642  -9.5742   0.5722) ; C5  
+    #(  6.6391  -8.5592   1.4526) ; C6  
+    #(  9.5840  -6.8186   0.6136) ; O2  
+    #(  7.8505 -10.5925  -1.2223) ; O4  
+    #(  9.4601  -8.7514  -0.9277) ; H3  
+    #(  5.9281 -10.2509   0.5782) ; H5  
+    #(  5.8831  -8.4931   2.1028) ; H6  
+  ))
+
+(define rU03
+  (make-constant-rU
+    #( -0.4993   0.0476   0.8651  ; dgf-base-tfo
+        0.8078  -0.3353   0.4847
+        0.3132   0.9409   0.1290
+        6.2989  -5.2303  -3.8577)
+    #( -0.8313  -0.4738  -0.2906  ; P-O3*-275-tfo
+        0.0649   0.4366  -0.8973
+        0.5521  -0.7648  -0.3322
+        1.6833   6.8060  -7.0011)
+    #(  0.3445  -0.7630   0.5470  ; P-O3*-180-tfo
+       -0.4628  -0.6450  -0.6082
+        0.8168  -0.0436  -0.5753
+       -6.8179  -3.9778  -5.9887)
+    #(  0.5855   0.7931  -0.1682  ; P-O3*-60-tfo
+        0.8103  -0.5790   0.0906
+       -0.0255  -0.1894  -0.9816
+        6.1203  -7.1051   3.1984)
+    #(  2.6760  -8.4960   3.2880) ; P   
+    #(  1.4950  -7.6230   3.4770) ; O1P 
+    #(  2.9490  -9.4640   4.3740) ; O2P 
+    #(  3.9730  -7.5950   3.0340) ; O5* 
+    #(  3.9938  -6.7042   1.9023) ; C5* 
+    #(  3.2332  -5.9343   2.0319) ; H5* 
+    #(  3.9666  -7.2863   0.9812) ; H5**
+    #(  5.3098  -5.9546   1.8564) ; C4* 
+    #(  5.3863  -5.3702   0.9395) ; H4* 
+    #(  5.3851  -5.0642   3.0076) ; O4* 
+    #(  6.7315  -4.9724   3.4462) ; C1* 
+    #(  7.0033  -3.9202   3.3619) ; H1* 
+    #(  7.5997  -5.8018   2.4948) ; C2* 
+    #(  8.3627  -6.3254   3.0707) ; H2**
+    #(  8.0410  -4.9501   1.4724) ; O2* 
+    #(  8.2781  -4.0644   1.7570) ; H2* 
+    #(  6.5701  -6.8129   1.9714) ; C3* 
+    #(  6.4186  -7.5809   2.7299) ; H3* 
+    #(  6.9357  -7.3841   0.7235) ; O3* 
+    #(  6.8024  -5.4718   4.8475) ; N1  
+    #(  7.9218  -5.5700   6.8877) ; N3  
+    #(  7.8908  -5.0886   5.5944) ; C2  
+    #(  6.9789  -6.3827   7.4823) ; C4  
+    #(  5.8742  -6.7319   6.6202) ; C5  
+    #(  5.8182  -6.2769   5.3570) ; C6  
+    #(  8.7747  -4.3728   5.1568) ; O2  
+    #(  7.1154  -6.7509   8.6509) ; O4  
+    #(  8.7055  -5.3037   7.4491) ; H3  
+    #(  5.1416  -7.3178   6.9665) ; H5  
+    #(  5.0441  -6.5310   4.7784) ; H6  
+  ))
+
+(define rU04
+  (make-constant-rU
+    #( -0.5669  -0.8012   0.1918  ; dgf-base-tfo
+       -0.8129   0.5817   0.0273
+       -0.1334  -0.1404  -0.9811
+       -0.3279   8.3874   0.3355)
+    #( -0.8313  -0.4738  -0.2906  ; P-O3*-275-tfo
+        0.0649   0.4366  -0.8973
+        0.5521  -0.7648  -0.3322
+        1.6833   6.8060  -7.0011)
+    #(  0.3445  -0.7630   0.5470  ; P-O3*-180-tfo
+       -0.4628  -0.6450  -0.6082
+        0.8168  -0.0436  -0.5753
+       -6.8179  -3.9778  -5.9887)
+    #(  0.5855   0.7931  -0.1682  ; P-O3*-60-tfo
+        0.8103  -0.5790   0.0906
+       -0.0255  -0.1894  -0.9816
+        6.1203  -7.1051   3.1984)
+    #(  2.6760  -8.4960   3.2880) ; P   
+    #(  1.4950  -7.6230   3.4770) ; O1P 
+    #(  2.9490  -9.4640   4.3740) ; O2P 
+    #(  3.9730  -7.5950   3.0340) ; O5* 
+    #(  5.2416  -8.2422   2.8181) ; C5* 
+    #(  5.2050  -8.8128   1.8901) ; H5* 
+    #(  5.5368  -8.7738   3.7227) ; H5**
+    #(  6.3232  -7.2037   2.6002) ; C4* 
+    #(  7.3048  -7.6757   2.5577) ; H4* 
+    #(  6.0635  -6.5092   1.3456) ; O4* 
+    #(  6.4697  -5.1547   1.4629) ; C1* 
+    #(  7.2354  -5.0043   0.7018) ; H1* 
+    #(  7.0856  -4.9610   2.8521) ; C2* 
+    #(  6.7777  -3.9935   3.2487) ; H2**
+    #(  8.4627  -5.1992   2.7423) ; O2* 
+    #(  8.8693  -4.8638   1.9399) ; H2* 
+    #(  6.3877  -6.0809   3.6362) ; C3* 
+    #(  5.3770  -5.7562   3.8834) ; H3* 
+    #(  7.1024  -6.4754   4.7985) ; O3* 
+    #(  5.2764  -4.2883   1.2538) ; N1  
+    #(  3.8961  -3.0896  -0.1893) ; N3  
+    #(  5.0095  -3.8907  -0.0346) ; C2  
+    #(  3.0480  -2.6632   0.8116) ; C4  
+    #(  3.4093  -3.1310   2.1292) ; C5  
+    #(  4.4878  -3.9124   2.3088) ; C6  
+    #(  5.7005  -4.2164  -0.9842) ; O2  
+    #(  2.0800  -1.9458   0.5503) ; O4  
+    #(  3.6834  -2.7882  -1.1190) ; H3  
+    #(  2.8508  -2.8721   2.9172) ; H5  
+    #(  4.7188  -4.2247   3.2295) ; H6  
+  ))
+
+(define rU05
+  (make-constant-rU
+    #( -0.6298   0.0246   0.7763  ; dgf-base-tfo
+       -0.5226  -0.7529  -0.4001
+        0.5746  -0.6577   0.4870
+       -0.0208  -3.4598  -9.6882)
+    #( -0.8313  -0.4738  -0.2906  ; P-O3*-275-tfo
+        0.0649   0.4366  -0.8973
+        0.5521  -0.7648  -0.3322
+        1.6833   6.8060  -7.0011)
+    #(  0.3445  -0.7630   0.5470  ; P-O3*-180-tfo
+       -0.4628  -0.6450  -0.6082
+        0.8168  -0.0436  -0.5753
+       -6.8179  -3.9778  -5.9887)
+    #(  0.5855   0.7931  -0.1682  ; P-O3*-60-tfo
+        0.8103  -0.5790   0.0906
+       -0.0255  -0.1894  -0.9816
+        6.1203  -7.1051   3.1984)
+    #(  2.6760  -8.4960   3.2880) ; P   
+    #(  1.4950  -7.6230   3.4770) ; O1P 
+    #(  2.9490  -9.4640   4.3740) ; O2P 
+    #(  3.9730  -7.5950   3.0340) ; O5* 
+    #(  4.3825  -6.6585   4.0489) ; C5* 
+    #(  4.6841  -7.2019   4.9443) ; H5* 
+    #(  3.6189  -5.8889   4.1625) ; H5**
+    #(  5.6255  -5.9175   3.5998) ; C4* 
+    #(  5.8732  -5.1228   4.3034) ; H4* 
+    #(  6.7337  -6.8605   3.5222) ; O4* 
+    #(  7.5932  -6.4923   2.4548) ; C1* 
+    #(  8.5661  -6.2983   2.9064) ; H1* 
+    #(  7.0527  -5.2012   1.8322) ; C2* 
+    #(  7.1627  -5.2525   0.7490) ; H2**
+    #(  7.6666  -4.1249   2.4880) ; O2* 
+    #(  8.5944  -4.2543   2.6981) ; H2* 
+    #(  5.5661  -5.3029   2.2009) ; C3* 
+    #(  5.0841  -6.0018   1.5172) ; H3* 
+    #(  4.9062  -4.0452   2.2042) ; O3* 
+    #(  7.6298  -7.6136   1.4752) ; N1  
+    #(  8.5977  -9.5977   0.7329) ; N3  
+    #(  8.5951  -8.5745   1.6594) ; C2  
+    #(  7.7372  -9.7371  -0.3364) ; C4  
+    #(  6.7596  -8.6801  -0.4476) ; C5  
+    #(  6.7338  -7.6721   0.4408) ; C6  
+    #(  9.3993  -8.5377   2.5743) ; O2  
+    #(  7.8374 -10.6990  -1.1008) ; O4  
+    #(  9.2924 -10.3081   0.8477) ; H3  
+    #(  6.0932  -8.6982  -1.1929) ; H5  
+    #(  6.0481  -6.9515   0.3446) ; H6  
+  ))
+
+(define rU06
+  (make-constant-rU
+    #( -0.9837   0.0476  -0.1733  ; dgf-base-tfo
+       -0.1792  -0.3353   0.9249
+       -0.0141   0.9409   0.3384
+        5.7793  -5.2303   4.5997)
+    #( -0.8313  -0.4738  -0.2906  ; P-O3*-275-tfo
+        0.0649   0.4366  -0.8973
+        0.5521  -0.7648  -0.3322
+        1.6833   6.8060  -7.0011)
+    #(  0.3445  -0.7630   0.5470  ; P-O3*-180-tfo
+       -0.4628  -0.6450  -0.6082
+        0.8168  -0.0436  -0.5753
+       -6.8179  -3.9778  -5.9887)
+    #(  0.5855   0.7931  -0.1682  ; P-O3*-60-tfo
+        0.8103  -0.5790   0.0906
+       -0.0255  -0.1894  -0.9816
+        6.1203  -7.1051   3.1984)
+    #(  2.6760  -8.4960   3.2880) ; P   
+    #(  1.4950  -7.6230   3.4770) ; O1P 
+    #(  2.9490  -9.4640   4.3740) ; O2P 
+    #(  3.9730  -7.5950   3.0340) ; O5* 
+    #(  3.9938  -6.7042   1.9023) ; C5* 
+    #(  3.2332  -5.9343   2.0319) ; H5* 
+    #(  3.9666  -7.2863   0.9812) ; H5**
+    #(  5.3098  -5.9546   1.8564) ; C4* 
+    #(  5.3863  -5.3702   0.9395) ; H4* 
+    #(  5.3851  -5.0642   3.0076) ; O4* 
+    #(  6.7315  -4.9724   3.4462) ; C1* 
+    #(  7.0033  -3.9202   3.3619) ; H1* 
+    #(  7.5997  -5.8018   2.4948) ; C2* 
+    #(  8.3627  -6.3254   3.0707) ; H2**
+    #(  8.0410  -4.9501   1.4724) ; O2* 
+    #(  8.2781  -4.0644   1.7570) ; H2* 
+    #(  6.5701  -6.8129   1.9714) ; C3* 
+    #(  6.4186  -7.5809   2.7299) ; H3* 
+    #(  6.9357  -7.3841   0.7235) ; O3* 
+    #(  6.8024  -5.4718   4.8475) ; N1  
+    #(  6.6920  -5.0495   7.1354) ; N3  
+    #(  6.6201  -4.5500   5.8506) ; C2  
+    #(  6.9254  -6.3614   7.4926) ; C4  
+    #(  7.1046  -7.2543   6.3718) ; C5  
+    #(  7.0391  -6.7951   5.1106) ; C6  
+    #(  6.4083  -3.3696   5.6340) ; O2  
+    #(  6.9679  -6.6901   8.6800) ; O4  
+    #(  6.5626  -4.3957   7.8812) ; H3  
+    #(  7.2781  -8.2254   6.5350) ; H5  
+    #(  7.1657  -7.4312   4.3503) ; H6  
+  ))
+
+(define rU07
+  (make-constant-rU
+    #( -0.9434   0.3172   0.0971  ; dgf-base-tfo
+        0.2294   0.4125   0.8816
+        0.2396   0.8539  -0.4619
+        8.3625 -52.7147   1.3745)
+    #(  0.2765  -0.1121  -0.9545  ; P-O3*-275-tfo
+       -0.8297   0.4733  -0.2959
+        0.4850   0.8737   0.0379
+      -14.7774 -45.2464  21.9088)
+    #(  0.1063  -0.6334  -0.7665  ; P-O3*-180-tfo
+       -0.5932  -0.6591   0.4624
+       -0.7980   0.4055  -0.4458
+       43.7634   4.3296  28.4890)
+    #(  0.7136  -0.5032  -0.4873  ; P-O3*-60-tfo
+        0.6803   0.3317   0.6536
+       -0.1673  -0.7979   0.5791
+      -17.1858  41.4390 -27.0751)
+    #( 21.3880  15.0780  45.5770) ; P   
+    #( 21.9980  14.5500  46.8210) ; O1P 
+    #( 21.1450  14.0270  44.5420) ; O2P 
+    #( 22.1250  16.3600  44.9460) ; O5* 
+    #( 21.5037  16.8594  43.7323) ; C5* 
+    #( 20.8147  17.6663  43.9823) ; H5* 
+    #( 21.1086  16.0230  43.1557) ; H5**
+    #( 22.5654  17.4874  42.8616) ; C4* 
+    #( 22.1584  17.7243  41.8785) ; H4* 
+    #( 23.0557  18.6826  43.4751) ; O4* 
+    #( 24.4788  18.6151  43.6455) ; C1* 
+    #( 24.9355  19.0840  42.7739) ; H1* 
+    #( 24.7958  17.1427  43.6474) ; C2* 
+    #( 24.5652  16.7400  44.6336) ; H2**
+    #( 26.1041  16.8773  43.2455) ; O2* 
+    #( 26.7516  17.5328  43.5149) ; H2* 
+    #( 23.8109  16.5979  42.6377) ; C3* 
+    #( 23.5756  15.5686  42.9084) ; H3* 
+    #( 24.2890  16.7447  41.2729) ; O3* 
+    #( 24.9420  19.2174  44.8923) ; N1  
+    #( 25.2655  20.5636  44.8883) ; N3  
+    #( 25.1663  21.2219  43.8561) ; C2  
+    #( 25.6911  21.1219  46.0494) ; C4  
+    #( 25.8051  20.4068  47.2048) ; C5  
+    #( 26.2093  20.9962  48.2534) ; C6  
+    #( 25.4692  19.0221  47.2053) ; O2  
+    #( 25.0502  18.4827  46.0370) ; O4  
+    #( 25.9599  22.1772  46.0966) ; H3  
+    #( 25.5545  18.4409  48.1234) ; H5  
+    #( 24.7854  17.4265  45.9883) ; H6  
+  ))
+
+(define rU08
+  (make-constant-rU
+    #( -0.0080  -0.7928   0.6094  ; dgf-base-tfo
+       -0.7512   0.4071   0.5197
+       -0.6601  -0.4536  -0.5988
+       44.1482  30.7036   2.1088)
+    #(  0.2765  -0.1121  -0.9545  ; P-O3*-275-tfo
+       -0.8297   0.4733  -0.2959
+        0.4850   0.8737   0.0379
+      -14.7774 -45.2464  21.9088)
+    #(  0.1063  -0.6334  -0.7665  ; P-O3*-180-tfo
+       -0.5932  -0.6591   0.4624
+       -0.7980   0.4055  -0.4458
+       43.7634   4.3296  28.4890)
+    #(  0.7136  -0.5032  -0.4873  ; P-O3*-60-tfo
+        0.6803   0.3317   0.6536
+       -0.1673  -0.7979   0.5791
+      -17.1858  41.4390 -27.0751)
+    #( 21.3880  15.0780  45.5770) ; P   
+    #( 21.9980  14.5500  46.8210) ; O1P 
+    #( 21.1450  14.0270  44.5420) ; O2P 
+    #( 22.1250  16.3600  44.9460) ; O5* 
+    #( 23.5096  16.1227  44.5783) ; C5* 
+    #( 23.5649  15.8588  43.5222) ; H5* 
+    #( 23.9621  15.4341  45.2919) ; H5**
+    #( 24.2805  17.4138  44.7151) ; C4* 
+    #( 25.3492  17.2309  44.6030) ; H4* 
+    #( 23.8497  18.3471  43.7208) ; O4* 
+    #( 23.4090  19.5681  44.3321) ; C1* 
+    #( 24.2595  20.2496  44.3524) ; H1* 
+    #( 23.0418  19.1813  45.7407) ; C2* 
+    #( 22.0532  18.7224  45.7273) ; H2**
+    #( 23.1307  20.2521  46.6291) ; O2* 
+    #( 22.8888  21.1051  46.2611) ; H2* 
+    #( 24.0799  18.1326  46.0700) ; C3* 
+    #( 23.6490  17.4370  46.7900) ; H3* 
+    #( 25.3329  18.7227  46.5109) ; O3* 
+    #( 22.2515  20.1624  43.6698) ; N1  
+    #( 22.4760  21.0609  42.6406) ; N3  
+    #( 23.6229  21.3462  42.3061) ; C2  
+    #( 21.3986  21.6081  42.0236) ; C4  
+    #( 20.1189  21.3012  42.3804) ; C5  
+    #( 19.1599  21.8516  41.7578) ; C6  
+    #( 19.8919  20.3745  43.4387) ; O2  
+    #( 20.9790  19.8423  44.0440) ; O4  
+    #( 21.5235  22.3222  41.2097) ; H3  
+    #( 18.8732  20.1200  43.7312) ; H5  
+    #( 20.8545  19.1313  44.8608) ; H6  
+  ))
+
+(define rU09
+  (make-constant-rU
+    #( -0.0317   0.1374   0.9900  ; dgf-base-tfo
+       -0.3422  -0.9321   0.1184
+        0.9391  -0.3351   0.0765
+      -32.1929  25.8198 -28.5088)
+    #(  0.2765  -0.1121  -0.9545  ; P-O3*-275-tfo
+       -0.8297   0.4733  -0.2959
+        0.4850   0.8737   0.0379
+      -14.7774 -45.2464  21.9088)
+    #(  0.1063  -0.6334  -0.7665  ; P-O3*-180-tfo
+       -0.5932  -0.6591   0.4624
+       -0.7980   0.4055  -0.4458
+       43.7634   4.3296  28.4890)
+    #(  0.7136  -0.5032  -0.4873  ; P-O3*-60-tfo
+        0.6803   0.3317   0.6536
+       -0.1673  -0.7979   0.5791
+      -17.1858  41.4390 -27.0751)
+    #( 21.3880  15.0780  45.5770) ; P   
+    #( 21.9980  14.5500  46.8210) ; O1P 
+    #( 21.1450  14.0270  44.5420) ; O2P 
+    #( 22.1250  16.3600  44.9460) ; O5* 
+    #( 21.5037  16.8594  43.7323) ; C5* 
+    #( 20.8147  17.6663  43.9823) ; H5* 
+    #( 21.1086  16.0230  43.1557) ; H5**
+    #( 22.5654  17.4874  42.8616) ; C4* 
+    #( 23.0565  18.3036  43.3915) ; H4* 
+    #( 23.5375  16.5054  42.4925) ; O4* 
+    #( 23.6574  16.4257  41.0649) ; C1* 
+    #( 24.4701  17.0882  40.7671) ; H1* 
+    #( 22.3525  16.9643  40.5396) ; C2* 
+    #( 21.5993  16.1799  40.6133) ; H2**
+    #( 22.4693  17.4849  39.2515) ; O2* 
+    #( 23.0899  17.0235  38.6827) ; H2* 
+    #( 22.0341  18.0633  41.5279) ; C3* 
+    #( 20.9509  18.1709  41.5846) ; H3* 
+    #( 22.7249  19.3020  41.2100) ; O3* 
+    #( 23.8580  15.0648  40.5757) ; N1  
+    #( 25.1556  14.5982  40.4523) ; N3  
+    #( 26.1047  15.3210  40.7448) ; C2  
+    #( 25.3391  13.3315  40.0020) ; C4  
+    #( 24.2974  12.5148  39.6749) ; C5  
+    #( 24.5450  11.3410  39.2610) ; C6  
+    #( 22.9633  12.9979  39.8053) ; O2  
+    #( 22.8009  14.2648  40.2524) ; O4  
+    #( 26.3414  12.9194  39.8855) ; H3  
+    #( 22.1227  12.3533  39.5486) ; H5  
+    #( 21.7989  14.6788  40.3650) ; H6  
+  ))
+
+(define rU10
+  (make-constant-rU
+    #( -0.9674   0.1021  -0.2318  ; dgf-base-tfo
+       -0.2514  -0.2766   0.9275
+        0.0306   0.9555   0.2933
+       27.8571 -42.1305 -24.4563)
+    #(  0.2765  -0.1121  -0.9545  ; P-O3*-275-tfo
+       -0.8297   0.4733  -0.2959
+        0.4850   0.8737   0.0379
+      -14.7774 -45.2464  21.9088)
+    #(  0.1063  -0.6334  -0.7665  ; P-O3*-180-tfo
+       -0.5932  -0.6591   0.4624
+       -0.7980   0.4055  -0.4458
+       43.7634   4.3296  28.4890)
+    #(  0.7136  -0.5032  -0.4873  ; P-O3*-60-tfo
+        0.6803   0.3317   0.6536
+       -0.1673  -0.7979   0.5791
+      -17.1858  41.4390 -27.0751)
+    #( 21.3880  15.0780  45.5770) ; P   
+    #( 21.9980  14.5500  46.8210) ; O1P 
+    #( 21.1450  14.0270  44.5420) ; O2P 
+    #( 22.1250  16.3600  44.9460) ; O5* 
+    #( 23.5096  16.1227  44.5783) ; C5* 
+    #( 23.5649  15.8588  43.5222) ; H5* 
+    #( 23.9621  15.4341  45.2919) ; H5**
+    #( 24.2805  17.4138  44.7151) ; C4* 
+    #( 23.8509  18.1819  44.0720) ; H4* 
+    #( 24.2506  17.8583  46.0741) ; O4* 
+    #( 25.5830  18.0320  46.5775) ; C1* 
+    #( 25.8569  19.0761  46.4256) ; H1* 
+    #( 26.4410  17.1555  45.7033) ; C2* 
+    #( 26.3459  16.1253  46.0462) ; H2**
+    #( 27.7649  17.5888  45.6478) ; O2* 
+    #( 28.1004  17.9719  46.4616) ; H2* 
+    #( 25.7796  17.2997  44.3513) ; C3* 
+    #( 25.9478  16.3824  43.7871) ; H3* 
+    #( 26.2154  18.4984  43.6541) ; O3* 
+    #( 25.7321  17.6281  47.9726) ; N1  
+    #( 25.5136  18.5779  48.9560) ; N3  
+    #( 25.2079  19.7276  48.6503) ; C2  
+    #( 25.6482  18.1987  50.2518) ; C4  
+    #( 25.9847  16.9266  50.6092) ; C5  
+    #( 26.0918  16.6439  51.8416) ; C6  
+    #( 26.2067  15.9515  49.5943) ; O2  
+    #( 26.0713  16.3497  48.3080) ; O4  
+    #( 25.4890  18.9105  51.0618) ; H3  
+    #( 26.4742  14.9310  49.8682) ; H5  
+    #( 26.2346  15.6394  47.4975) ; H6  
+  ))
+
+(define rUs
+  (list rU01 rU02 rU03 rU04 rU05 rU06 rU07 rU08 rU09 rU10))
+
+(define rG*
+  (make-constant-rG
+    #( -0.2067  -0.0264   0.9780  ; dgf-base-tfo
+        0.9770  -0.0586   0.2049
+        0.0519   0.9979   0.0379
+        1.0331 -46.8078 -36.4742)
+    #( -0.8644  -0.4956  -0.0851  ; P-O3*-275-tfo
+       -0.0427   0.2409  -0.9696
+        0.5010  -0.8345  -0.2294
+        4.0167  54.5377  12.4779)
+    #(  0.3706  -0.6167   0.6945  ; P-O3*-180-tfo
+       -0.2867  -0.7872  -0.5460
+        0.8834   0.0032  -0.4686
+      -52.9020  18.6313  -0.6709)
+    #(  0.4155   0.9025  -0.1137  ; P-O3*-60-tfo
+        0.9040  -0.4236  -0.0582
+       -0.1007  -0.0786  -0.9918
+       -7.6624 -25.2080  49.5181)
+    #( 31.3810   0.1400  47.5810) ; P   
+    #( 29.9860   0.6630  47.6290) ; O1P 
+    #( 31.7210  -0.6460  48.8090) ; O2P 
+    #( 32.4940   1.2540  47.2740) ; O5* 
+    #( 32.1610   2.2370  46.2560) ; C5* 
+    #( 31.2986   2.8190  46.5812) ; H5* 
+    #( 32.0980   1.7468  45.2845) ; H5**
+    #( 33.3476   3.1959  46.1947) ; C4* 
+    #( 33.2668   3.8958  45.3630) ; H4* 
+    #( 33.3799   3.9183  47.4216) ; O4* 
+    #( 34.6515   3.7222  48.0398) ; C1* 
+    #( 35.2947   4.5412  47.7180) ; H1* 
+    #( 35.1756   2.4228  47.4827) ; C2* 
+    #( 34.6778   1.5937  47.9856) ; H2**
+    #( 36.5631   2.2672  47.4798) ; O2* 
+    #( 37.0163   2.6579  48.2305) ; H2* 
+    #( 34.6953   2.5043  46.0448) ; C3* 
+    #( 34.5444   1.4917  45.6706) ; H3* 
+    #( 35.6679   3.3009  45.3487) ; O3* 
+    #( 37.4804   4.0914  52.2559) ; N1  
+    #( 36.9670   4.1312  49.9281) ; N3  
+    #( 37.8045   4.2519  50.9550) ; C2  
+    #( 35.7171   3.8264  50.3222) ; C4  
+    #( 35.2668   3.6420  51.6115) ; C5  
+    #( 36.2037   3.7829  52.6706) ; C6  
+    #( 39.0869   4.5552  50.7092) ; N2  
+    #( 33.9075   3.3338  51.6102) ; N7  
+    #( 34.6126   3.6358  49.5108) ; N9  
+    #( 33.5805   3.3442  50.3425) ; C8  
+    #( 35.9958   3.6512  53.8724) ; O6  
+    #( 38.2106   4.2053  52.9295) ; H1  
+    #( 39.8218   4.6863  51.3896) ; H21 
+    #( 39.3420   4.6857  49.7407) ; H22 
+    #( 32.5194   3.1070  50.2664) ; H8  
+  ))
+
+(define rU*
+  (make-constant-rU
+    #( -0.0109   0.5907   0.8068  ; dgf-base-tfo
+        0.2217  -0.7853   0.5780
+        0.9751   0.1852  -0.1224
+       -1.4225 -11.0956  -2.5217)
+    #( -0.8313  -0.4738  -0.2906  ; P-O3*-275-tfo
+        0.0649   0.4366  -0.8973
+        0.5521  -0.7648  -0.3322
+        1.6833   6.8060  -7.0011)
+    #(  0.3445  -0.7630   0.5470  ; P-O3*-180-tfo
+       -0.4628  -0.6450  -0.6082
+        0.8168  -0.0436  -0.5753
+       -6.8179  -3.9778  -5.9887)
+    #(  0.5855   0.7931  -0.1682  ; P-O3*-60-tfo
+        0.8103  -0.5790   0.0906
+       -0.0255  -0.1894  -0.9816
+        6.1203  -7.1051   3.1984)
+    #(  2.6760  -8.4960   3.2880) ; P   
+    #(  1.4950  -7.6230   3.4770) ; O1P 
+    #(  2.9490  -9.4640   4.3740) ; O2P 
+    #(  3.9730  -7.5950   3.0340) ; O5* 
+    #(  5.2430  -8.2420   2.8260) ; C5* 
+    #(  5.1974  -8.8497   1.9223) ; H5* 
+    #(  5.5548  -8.7348   3.7469) ; H5**
+    #(  6.3140  -7.2060   2.5510) ; C4* 
+    #(  5.8744  -6.2116   2.4731) ; H4* 
+    #(  7.2798  -7.2260   3.6420) ; O4* 
+    #(  8.5733  -6.9410   3.1329) ; C1* 
+    #(  8.9047  -6.0374   3.6446) ; H1* 
+    #(  8.4429  -6.6596   1.6327) ; C2* 
+    #(  9.2880  -7.1071   1.1096) ; H2**
+    #(  8.2502  -5.2799   1.4754) ; O2* 
+    #(  8.7676  -4.7284   2.0667) ; H2* 
+    #(  7.1642  -7.4416   1.3021) ; C3* 
+    #(  7.4125  -8.5002   1.2260) ; H3* 
+    #(  6.5160  -6.9772   0.1267) ; O3* 
+    #(  9.4531  -8.1107   3.4087) ; N1  
+    #( 11.5931  -9.0015   3.6357) ; N3  
+    #( 10.8101  -7.8950   3.3748) ; C2  
+    #( 11.1439 -10.2744   3.9206) ; C4  
+    #(  9.7056 -10.4026   3.9332) ; C5  
+    #(  8.9192  -9.3419   3.6833) ; C6  
+    #( 11.3013  -6.8063   3.1326) ; O2  
+    #( 11.9431 -11.1876   4.1375) ; O4  
+    #( 12.5840  -8.8673   3.6158) ; H3  
+    #(  9.2891 -11.2898   4.1313) ; H5  
+    #(  7.9263  -9.4537   3.6977) ; H6  
+  ))
+
+
+
+; -- PARTIAL INSTANTIATIONS ---------------------------------------------------
+
+(define (get-var id lst)
+  (let ((v (car lst)))
+    (if (= id (var-id v))
+      v
+      (get-var id (cdr lst)))))
+
+(define (make-relative-nuc tfo n)
+  (cond ((rA? n)
+         (make-rA
+           (nuc-dgf-base-tfo  n)
+           (nuc-P-O3*-275-tfo n)
+           (nuc-P-O3*-180-tfo n)
+           (nuc-P-O3*-60-tfo  n)
+           (lazy-computation-of (tfo-apply tfo (nuc-P    n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O1P  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O2P  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O5*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C5*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H5*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H5** n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C4*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H4*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O4*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C1*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H1*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C2*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H2** n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O2*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H2*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C3*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H3*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O3*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-N1   n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-N3   n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C2   n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C4   n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C5   n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C6   n)))
+           (lazy-computation-of (tfo-apply tfo (rA-N6    n)))
+           (lazy-computation-of (tfo-apply tfo (rA-N7    n)))
+           (lazy-computation-of (tfo-apply tfo (rA-N9    n)))
+           (lazy-computation-of (tfo-apply tfo (rA-C8    n)))
+           (lazy-computation-of (tfo-apply tfo (rA-H2    n)))
+           (lazy-computation-of (tfo-apply tfo (rA-H61   n)))
+           (lazy-computation-of (tfo-apply tfo (rA-H62   n)))
+           (lazy-computation-of (tfo-apply tfo (rA-H8    n)))))
+        ((rC? n)
+         (make-rC
+           (nuc-dgf-base-tfo  n)
+           (nuc-P-O3*-275-tfo n)
+           (nuc-P-O3*-180-tfo n)
+           (nuc-P-O3*-60-tfo  n)
+           (lazy-computation-of (tfo-apply tfo (nuc-P    n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O1P  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O2P  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O5*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C5*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H5*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H5** n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C4*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H4*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O4*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C1*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H1*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C2*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H2** n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O2*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H2*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C3*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H3*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O3*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-N1   n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-N3   n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C2   n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C4   n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C5   n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C6   n)))
+           (lazy-computation-of (tfo-apply tfo (rC-N4    n)))
+           (lazy-computation-of (tfo-apply tfo (rC-O2    n)))
+           (lazy-computation-of (tfo-apply tfo (rC-H41   n)))
+           (lazy-computation-of (tfo-apply tfo (rC-H42   n)))
+           (lazy-computation-of (tfo-apply tfo (rC-H5    n)))
+           (lazy-computation-of (tfo-apply tfo (rC-H6    n)))))
+        ((rG? n)
+         (make-rG
+           (nuc-dgf-base-tfo  n)
+           (nuc-P-O3*-275-tfo n)
+           (nuc-P-O3*-180-tfo n)
+           (nuc-P-O3*-60-tfo  n)
+           (lazy-computation-of (tfo-apply tfo (nuc-P    n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O1P  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O2P  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O5*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C5*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H5*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H5** n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C4*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H4*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O4*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C1*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H1*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C2*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H2** n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O2*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H2*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C3*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H3*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O3*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-N1   n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-N3   n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C2   n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C4   n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C5   n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C6   n)))
+           (lazy-computation-of (tfo-apply tfo (rG-N2    n)))
+           (lazy-computation-of (tfo-apply tfo (rG-N7    n)))
+           (lazy-computation-of (tfo-apply tfo (rG-N9    n)))
+           (lazy-computation-of (tfo-apply tfo (rG-C8    n)))
+           (lazy-computation-of (tfo-apply tfo (rG-O6    n)))
+           (lazy-computation-of (tfo-apply tfo (rG-H1    n)))
+           (lazy-computation-of (tfo-apply tfo (rG-H21   n)))
+           (lazy-computation-of (tfo-apply tfo (rG-H22   n)))
+           (lazy-computation-of (tfo-apply tfo (rG-H8    n)))))
+        (else
+         (make-rU
+           (nuc-dgf-base-tfo  n)
+           (nuc-P-O3*-275-tfo n)
+           (nuc-P-O3*-180-tfo n)
+           (nuc-P-O3*-60-tfo  n)
+           (lazy-computation-of (tfo-apply tfo (nuc-P    n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O1P  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O2P  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O5*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C5*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H5*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H5** n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C4*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H4*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O4*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C1*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H1*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C2*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H2** n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O2*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H2*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C3*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-H3*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-O3*  n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-N1   n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-N3   n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C2   n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C4   n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C5   n)))
+           (lazy-computation-of (tfo-apply tfo (nuc-C6   n)))
+           (lazy-computation-of (tfo-apply tfo (rU-O2    n)))
+           (lazy-computation-of (tfo-apply tfo (rU-O4    n)))
+           (lazy-computation-of (tfo-apply tfo (rU-H3    n)))
+           (lazy-computation-of (tfo-apply tfo (rU-H5    n)))
+           (lazy-computation-of (tfo-apply tfo (rU-H6    n)))))))
+
+; -- SEARCH -------------------------------------------------------------------
+
+; Sequential backtracking algorithm
+
+(define (search partial-inst domains constraint?)
+  (if (null? domains)
+    (list partial-inst)
+    (let ((remaining-domains (cdr domains)))
+
+      (define (try-assignments lst)
+        (if (null? lst)
+          '()
+          (let ((var (car lst)))
+            (if (constraint? var partial-inst)
+              (let* ((subsols1
+                       (search
+                         (cons var partial-inst)
+                         remaining-domains
+                         constraint?))
+                     (subsols2
+                       (try-assignments (cdr lst))))
+                (append subsols1 subsols2))
+              (try-assignments (cdr lst))))))
+
+      (try-assignments ((car domains) partial-inst)))))
+
+; -- DOMAINS ------------------------------------------------------------------
+
+; Primary structure:   strand A CUGCCACGUCUG, strand B CAGACGUGGCAG
+;
+; Secondary structure: strand A CUGCCACGUCUG
+;                               ||||||||||||
+;                               GACGGUGCAGAC strand B
+;
+; Tertiary structure:
+;
+;    5' end of strand A C1----G12 3' end of strand B
+;                     U2-------A11
+;                    G3-------C10
+;                    C4-----G9
+;                     C5---G8
+;                        A6
+;                      G6-C7
+;                     C5----G8
+;                    A4-------U9
+;                    G3--------C10
+;                     A2-------U11
+;   5' end of strand B C1----G12 3' end of strand A
+;
+; "helix", "stacked" and "connected" describe the spatial relationship
+; between two consecutive nucleotides. E.g. the nucleotides C1 and U2
+; from the strand A.
+;
+; "wc" (stands for Watson-Crick and is a type of base-pairing),
+; and "wc-dumas" describe the spatial relationship between 
+; nucleotides from two chains that are growing in opposite directions.
+; E.g. the nucleotides C1 from strand A and G12 from strand B.
+
+; Dynamic Domains
+
+; Given,
+;   "ref" a nucleotide which is already positioned,
+;   "nuc" the nucleotide to be placed,
+;   and "tfo" a transformation matrix which expresses the desired
+;   relationship between "ref" and "nuc",
+; the function "dgf-base" computes the transformation matrix that
+; places the nucleotide "nuc" in the given relationship to "ref".
+
+(define (dgf-base tfo ref nuc)
+  (let* ((ref-nuc (var-nuc ref))
+         (align
+          (tfo-inv-ortho
+            (cond ((rA? ref-nuc)
+                   (tfo-align (atom-pos nuc-C1* ref)
+                              (atom-pos rA-N9   ref)
+                              (atom-pos nuc-C4  ref)))
+                  ((rC? ref-nuc)
+                   (tfo-align (atom-pos nuc-C1* ref)
+                              (atom-pos nuc-N1  ref)
+                              (atom-pos nuc-C2  ref)))
+                  ((rG? ref-nuc)
+                   (tfo-align (atom-pos nuc-C1* ref)
+                              (atom-pos rG-N9   ref)
+                              (atom-pos nuc-C4  ref)))
+                  (else
+                   (tfo-align (atom-pos nuc-C1* ref)
+                              (atom-pos nuc-N1  ref)
+                              (atom-pos nuc-C2  ref)))))))
+    (tfo-combine (nuc-dgf-base-tfo nuc)
+                 (tfo-combine tfo align))))
+
+; Placement of first nucleotide.
+
+(define (reference nuc i)
+  (lambda (partial-inst)
+    (list (mk-var i tfo-id nuc))))
+
+; The transformation matrix for wc is from:
+;
+; Chandrasekaran R. et al (1989) A Re-Examination of the Crystal
+; Structure of A-DNA Using Fiber Diffraction Data. J. Biomol.
+; Struct. & Dynamics 6(6):1189-1202.
+
+(define wc-tfo
+  '#(-1.0000  0.0028 -0.0019
+      0.0028  0.3468 -0.9379
+     -0.0019 -0.9379 -0.3468
+     -0.0080  6.0730  8.7208))
+
+(define (wc nuc i j)
+  (lambda (partial-inst)
+    (let* ((ref (get-var j partial-inst))
+           (tfo (dgf-base wc-tfo ref nuc)))
+      (list (mk-var i tfo nuc)))))
+
+(define wc-Dumas-tfo
+  '#(-0.9737 -0.1834  0.1352
+     -0.1779  0.2417 -0.9539
+      0.1422 -0.9529 -0.2679
+      0.4837  6.2649  8.0285))
+         
+(define (wc-Dumas nuc i j)
+  (lambda (partial-inst)
+    (let* ((ref (get-var j partial-inst))
+           (tfo (dgf-base wc-Dumas-tfo ref nuc)))
+      (list (mk-var i tfo nuc)))))
+
+(define helix5*-tfo
+  '#( 0.9886 -0.0961  0.1156
+      0.1424  0.8452 -0.5152
+     -0.0482  0.5258  0.8492
+     -3.8737  0.5480  3.8024))
+
+(define (helix5* nuc i j)
+  (lambda (partial-inst)
+    (let* ((ref (get-var j partial-inst))
+           (tfo (dgf-base helix5*-tfo ref nuc)))
+      (list (mk-var i tfo nuc)))))
+
+(define helix3*-tfo
+  '#( 0.9886  0.1424 -0.0482
+     -0.0961  0.8452  0.5258
+      0.1156 -0.5152  0.8492
+      3.4426  2.0474 -3.7042))
+
+(define (helix3* nuc i j)
+  (lambda (partial-inst)
+    (let* ((ref (get-var j partial-inst))
+           (tfo (dgf-base helix3*-tfo ref nuc)))
+      (list (mk-var i tfo nuc)))))
+
+(define G37-A38-tfo
+  '#( 0.9991  0.0164 -0.0387
+     -0.0375  0.7616 -0.6470
+      0.0189  0.6478  0.7615
+     -3.3018  0.9975  2.5585))
+
+(define (G37-A38 nuc i j)
+  (lambda (partial-inst)
+    (let* ((ref (get-var j partial-inst))
+           (tfo (dgf-base G37-A38-tfo ref nuc)))
+      (mk-var i tfo nuc))))
+
+(define (stacked5* nuc i j)
+  (lambda (partial-inst)
+    (cons ((G37-A38 nuc i j) partial-inst)
+          ((helix5* nuc i j) partial-inst))))
+
+(define A38-G37-tfo
+  '#( 0.9991 -0.0375  0.0189
+      0.0164  0.7616  0.6478 
+     -0.0387 -0.6470  0.7615
+      3.3819  0.7718 -2.5321))
+
+(define (A38-G37 nuc i j)
+  (lambda (partial-inst)
+    (let* ((ref (get-var j partial-inst))
+           (tfo (dgf-base A38-G37-tfo ref nuc)))
+      (mk-var i tfo nuc))))
+   
+(define (stacked3* nuc i j)
+  (lambda (partial-inst)
+    (cons ((A38-G37 nuc i j) partial-inst)
+          ((helix3* nuc i j) partial-inst))))
+
+(define (P-O3* nucs i j)
+  (lambda (partial-inst)
+    (let* ((ref (get-var j partial-inst))
+           (align
+             (tfo-inv-ortho
+               (tfo-align (atom-pos nuc-O3* ref)
+                          (atom-pos nuc-C3* ref)
+                          (atom-pos nuc-C4* ref)))))
+      (let loop ((lst nucs) (domains '()))
+        (if (null? lst)
+          domains
+          (let ((nuc (car lst)))
+            (let ((tfo-60 (tfo-combine (nuc-P-O3*-60-tfo nuc) align))
+                  (tfo-180 (tfo-combine (nuc-P-O3*-180-tfo nuc) align))
+                  (tfo-275 (tfo-combine (nuc-P-O3*-275-tfo nuc) align)))
+              (loop (cdr lst)
+                    (cons (mk-var i tfo-60 nuc)
+                          (cons (mk-var i tfo-180 nuc)
+                                (cons (mk-var i tfo-275 nuc) domains)))))))))))
+
+; -- PROBLEM STATEMENT --------------------------------------------------------
+
+; Define anticodon problem -- Science 253:1255 Figure 3a, 3b and 3c
+
+(define anticodon-domains
+  (list 
+   (reference rC  27   )
+   (helix5*   rC  28 27)
+   (helix5*   rA  29 28)
+   (helix5*   rG  30 29)
+   (helix5*   rA  31 30)
+   (wc        rU  39 31)
+   (helix5*   rC  40 39)
+   (helix5*   rU  41 40)
+   (helix5*   rG  42 41)
+   (helix5*   rG  43 42)
+   (stacked3* rA  38 39)
+   (stacked3* rG  37 38)
+   (stacked3* rA  36 37)
+   (stacked3* rA  35 36)
+   (stacked3* rG  34 35);<-. Distance
+   (P-O3*     rCs 32 31);  | Constraint
+   (P-O3*     rUs 33 32);<-' 3.0 Angstroms
+   ))
+
+; Anticodon constraint
+
+(define (anticodon-constraint? v partial-inst)
+  (if (= (var-id v) 33)
+    (let ((p   (atom-pos nuc-P (get-var 34 partial-inst))) ; P in nucleotide 34
+          (o3* (atom-pos nuc-O3* v)))                      ; O3' in nucl. 33
+      (FLOAT<= (pt-dist p o3*) 3.0))                       ; check distance
+    #t))
+
+(define (anticodon)
+  (search '() anticodon-domains anticodon-constraint?))
+
+; Define pseudoknot problem -- Science 253:1255 Figure 4a and 4b
+
+(define pseudoknot-domains
+  (list
+   (reference rA  23   )
+   (wc-Dumas  rU   8 23)
+   (helix3*   rG  22 23)
+   (wc-Dumas  rC   9 22)
+   (helix3*   rG  21 22)
+   (wc-Dumas  rC  10 21)
+   (helix3*   rC  20 21)
+   (wc-Dumas  rG  11 20)
+   (helix3*   rU* 19 20);<-.
+   (wc-Dumas  rA  12 19);  | Distance
+;                       ;  | Constraint
+; Helix 1               ;  | 4.0 Angstroms
+   (helix3*   rC   3 19);  |
+   (wc-Dumas  rG  13  3);  |
+   (helix3*   rC   2  3);  |
+   (wc-Dumas  rG  14  2);  |
+   (helix3*   rC   1  2);  |
+   (wc-Dumas  rG* 15  1);  |
+;                       ;  |
+; L2 LOOP               ;  |
+   (P-O3*     rUs 16 15);  |
+   (P-O3*     rCs 17 16);  |
+   (P-O3*     rAs 18 17);<-'
+;
+; L1 LOOP
+   (helix3*   rU   7  8);<-.
+   (P-O3*     rCs  4  3);  | Constraint
+   (stacked5* rU   5  4);  | 4.5 Angstroms
+   (stacked5* rC   6  5);<-'
+   ))
+  
+; Pseudoknot constraint
+
+(define (pseudoknot-constraint? v partial-inst)
+  (case (var-id v)
+    ((18)
+     (let ((p   (atom-pos nuc-P (get-var 19 partial-inst)))
+           (o3* (atom-pos nuc-O3* v)))
+       (FLOAT<= (pt-dist p o3*) 4.0)))
+    ((6)
+     (let ((p   (atom-pos nuc-P (get-var 7 partial-inst)))
+           (o3* (atom-pos nuc-O3* v)))
+       (FLOAT<= (pt-dist p o3*) 4.5)))
+    (else
+     #t)))
+
+(define (pseudoknot)
+  (search '() pseudoknot-domains pseudoknot-constraint?))
+
+; -- TESTING -----------------------------------------------------------------
+
+(define (list-of-atoms n)
+  (append (list-of-common-atoms n)
+          (list-of-specific-atoms n)))
+
+(define (list-of-common-atoms n)
+  (list
+    (nuc-P    n)
+    (nuc-O1P  n)
+    (nuc-O2P  n)
+    (nuc-O5*  n)
+    (nuc-C5*  n)
+    (nuc-H5*  n)
+    (nuc-H5** n)
+    (nuc-C4*  n)
+    (nuc-H4*  n)
+    (nuc-O4*  n)
+    (nuc-C1*  n)
+    (nuc-H1*  n)
+    (nuc-C2*  n)
+    (nuc-H2** n)
+    (nuc-O2*  n)
+    (nuc-H2*  n)
+    (nuc-C3*  n)
+    (nuc-H3*  n)
+    (nuc-O3*  n)
+    (nuc-N1   n)
+    (nuc-N3   n)
+    (nuc-C2   n)
+    (nuc-C4   n)
+    (nuc-C5   n)
+    (nuc-C6   n)))
+
+(define (list-of-specific-atoms n)
+  (cond ((rA? n)
+         (list
+           (rA-N6   n)
+           (rA-N7   n)
+           (rA-N9   n)
+           (rA-C8   n)
+           (rA-H2   n)
+           (rA-H61  n)
+           (rA-H62  n)
+           (rA-H8   n)))
+        ((rC? n)
+         (list
+           (rC-N4   n)
+           (rC-O2   n)
+           (rC-H41  n)
+           (rC-H42  n)
+           (rC-H5   n)
+           (rC-H6   n)))
+        ((rG? n)
+         (list
+           (rG-N2   n)
+           (rG-N7   n)
+           (rG-N9   n)
+           (rG-C8   n)
+           (rG-O6   n)
+           (rG-H1   n)
+           (rG-H21  n)
+           (rG-H22  n)
+           (rG-H8   n)))
+        (else
+         (list
+           (rU-O2   n)
+           (rU-O4   n)
+           (rU-H3   n)
+           (rU-H5   n)
+           (rU-H6   n)))))
+
+(define (var-most-distant-atom v)
+
+  (define (distance pos)
+    (let ((abs-pos (absolute-pos v pos)))
+      (let ((x (pt-x abs-pos)) (y (pt-y abs-pos)) (z (pt-z abs-pos)))
+        (FLOATsqrt (FLOAT+ (FLOAT* x x) (FLOAT* y y) (FLOAT* z z))))))
+
+  (maximum (map distance (list-of-atoms (var-nuc v)))))
+
+(define (sol-most-distant-atom s)
+  (maximum (map var-most-distant-atom s)))
+
+(define (most-distant-atom sols)
+  (maximum (map sol-most-distant-atom sols)))
+
+(define (maximum lst)
+  (let loop ((m (car lst)) (l (cdr lst)))
+    (if (null? l)
+      m
+      (let ((x (car l)))
+        (loop (if (FLOAT> x m) x m) (cdr l))))))
+
+(define (check)
+  (length (pseudoknot)))
+
+(define (run)
+  (most-distant-atom (pseudoknot)))
+
+; To run program, evaluate: (run)
+
+(time (let loop ((i 10)) (if (zero? i) 'done (begin (run) (loop (- i 1))))))
diff --git a/benchmarks/gabriel/paraffins.sch b/benchmarks/gabriel/paraffins.sch
new file mode 100644
index 00000000..708a85ad
--- /dev/null
+++ b/benchmarks/gabriel/paraffins.sch
@@ -0,0 +1,175 @@
+;;; PARAFFINS -- Compute how many paraffins exist with N carbon atoms.
+
+(define (gen n)
+  (let* ((n/2 (quotient n 2))
+         (radicals (make-vector (+ n/2 1) '(H))))
+
+    (define (rads-of-size n)
+      (let loop1 ((ps
+                   (three-partitions (- n 1)))
+                  (lst
+                   '()))
+        (if (null? ps)
+          lst
+          (let* ((p (car ps))
+                 (nc1 (vector-ref p 0))
+                 (nc2 (vector-ref p 1))
+                 (nc3 (vector-ref p 2)))
+            (let loop2 ((rads1
+                         (vector-ref radicals nc1))
+                        (lst
+                         (loop1 (cdr ps)
+                                lst)))
+              (if (null? rads1)
+                lst
+                (let loop3 ((rads2
+                             (if (= nc1 nc2)
+                               rads1
+                               (vector-ref radicals nc2)))
+                            (lst
+                             (loop2 (cdr rads1)
+                                    lst)))
+                  (if (null? rads2)
+                    lst
+                    (let loop4 ((rads3
+                                 (if (= nc2 nc3)
+                                   rads2
+                                   (vector-ref radicals nc3)))
+                                (lst
+                                 (loop3 (cdr rads2)
+                                        lst)))
+                      (if (null? rads3)
+                        lst
+                        (cons (vector 'C
+                                      (car rads1)
+                                      (car rads2)
+                                      (car rads3))
+                              (loop4 (cdr rads3)
+                                     lst))))))))))))
+
+    (define (bcp-generator j)
+      (if (odd? j)
+        '()
+        (let loop1 ((rads1
+                     (vector-ref radicals (quotient j 2)))
+                    (lst
+                     '()))
+          (if (null? rads1)
+            lst
+            (let loop2 ((rads2
+                         rads1)
+                        (lst
+                         (loop1 (cdr rads1)
+                                lst)))
+              (if (null? rads2)
+                lst
+                (cons (vector 'BCP
+                              (car rads1)
+                              (car rads2))
+                      (loop2 (cdr rads2)
+                             lst))))))))
+
+    (define (ccp-generator j)
+      (let loop1 ((ps
+                   (four-partitions (- j 1)))
+                  (lst
+                   '()))
+        (if (null? ps)
+          lst
+          (let* ((p (car ps))
+                 (nc1 (vector-ref p 0))
+                 (nc2 (vector-ref p 1))
+                 (nc3 (vector-ref p 2))
+                 (nc4 (vector-ref p 3)))
+            (let loop2 ((rads1
+                         (vector-ref radicals nc1))
+                        (lst
+                         (loop1 (cdr ps)
+                                lst)))
+              (if (null? rads1)
+                lst
+                (let loop3 ((rads2
+                             (if (= nc1 nc2)
+                               rads1
+                               (vector-ref radicals nc2)))
+                            (lst
+                             (loop2 (cdr rads1)
+                                    lst)))
+                  (if (null? rads2)
+                    lst
+                    (let loop4 ((rads3
+                                 (if (= nc2 nc3)
+                                   rads2
+                                   (vector-ref radicals nc3)))
+                                (lst
+                                 (loop3 (cdr rads2)
+                                        lst)))
+                      (if (null? rads3)
+                        lst
+                        (let loop5 ((rads4
+                                     (if (= nc3 nc4)
+                                       rads3
+                                       (vector-ref radicals nc4)))
+                                    (lst
+                                     (loop4 (cdr rads3)
+                                            lst)))
+                          (if (null? rads4)
+                            lst
+                            (cons (vector 'CCP
+                                          (car rads1)
+                                          (car rads2)
+                                          (car rads3)
+                                          (car rads4))
+                                  (loop5 (cdr rads4)
+                                         lst))))))))))))))
+
+    (let loop ((i 1))
+      (if (> i n/2)
+        (vector (bcp-generator n)
+                (ccp-generator n))
+        (begin
+          (vector-set! radicals i (rads-of-size i))
+          (loop (+ i 1)))))))
+
+(define (three-partitions m)
+  (let loop1 ((lst '())
+              (nc1 (quotient m 3)))
+    (if (< nc1 0)
+      lst
+      (let loop2 ((lst lst)
+                  (nc2 (quotient (- m nc1) 2)))
+        (if (< nc2 nc1)
+          (loop1 lst
+                 (- nc1 1))
+          (loop2 (cons (vector nc1 nc2 (- m (+ nc1 nc2))) lst)
+                 (- nc2 1)))))))
+
+(define (four-partitions m)
+  (let loop1 ((lst '())
+              (nc1 (quotient m 4)))
+    (if (< nc1 0)
+      lst
+      (let loop2 ((lst lst)
+                  (nc2 (quotient (- m nc1) 3)))
+        (if (< nc2 nc1)
+          (loop1 lst
+                 (- nc1 1))
+          (let ((start (max nc2 (- (quotient (+ m 1) 2) (+ nc1 nc2)))))
+            (let loop3 ((lst lst)
+                        (nc3 (quotient (- m (+ nc1 nc2)) 2)))
+              (if (< nc3 start)
+                (loop2 lst (- nc2 1))
+                (loop3 (cons (vector nc1 nc2 nc3 (- m (+ nc1 (+ nc2 nc3)))) lst)
+                       (- nc3 1))))))))))
+
+(define (nb n)
+  (let ((x (gen n)))
+    (+ (length (vector-ref x 0))
+       (length (vector-ref x 1)))))
+
+(let ((input (with-input-from-file "input.txt" read)))
+  (time
+   (let loop ((n 100) (v 0))
+     (if (zero? n)
+         v
+         (loop (- n 1) (nb (if input 17 0)))))))
diff --git a/benchmarks/gabriel/peval.sch b/benchmarks/gabriel/peval.sch
new file mode 100644
index 00000000..40d50471
--- /dev/null
+++ b/benchmarks/gabriel/peval.sch
@@ -0,0 +1,633 @@
+;;; PEVAL -- A simple partial evaluator for Scheme, written by Marc Feeley.
+
+;------------------------------------------------------------------------------
+
+; Utilities
+
+(define (every? pred? l)
+  (let loop ((l l))
+    (or (null? l) (and (pred? (car l)) (loop (cdr l))))))
+
+(define (some? pred? l)
+  (let loop ((l l))
+    (if (null? l) #f (or (pred? (car l)) (loop (cdr l))))))
+
+(define (map2 f l1 l2)
+  (let loop ((l1 l1) (l2 l2))
+    (if (pair? l1)
+      (cons (f (car l1) (car l2)) (loop (cdr l1) (cdr l2)))
+      '())))
+
+(define (get-last-pair l)
+  (let loop ((l l))
+    (let ((x (cdr l))) (if (pair? x) (loop x) l))))
+
+;------------------------------------------------------------------------------
+;
+; The partial evaluator.
+
+(define (partial-evaluate proc args)
+  (peval (alphatize proc '()) args))
+
+(define (alphatize exp env) ; return a copy of 'exp' where each bound var has
+  (define (alpha exp)       ; been renamed (to prevent aliasing problems)
+    (cond ((const-expr? exp)
+           (quot (const-value exp)))
+          ((symbol? exp)
+           (let ((x (assq exp env))) (if x (cdr x) exp)))
+          ((or (eq? (car exp) 'if) (eq? (car exp) 'begin))
+           (cons (car exp) (map alpha (cdr exp))))
+          ((or (eq? (car exp) 'let) (eq? (car exp) 'letrec))
+           (let ((new-env (new-variables (map car (cadr exp)) env)))
+             (list (car exp)
+                   (map (lambda (x)
+                          (list (cdr (assq (car x) new-env))
+                                (if (eq? (car exp) 'let)
+                                  (alpha (cadr x))
+                                  (alphatize (cadr x) new-env))))
+                        (cadr exp))
+                   (alphatize (caddr exp) new-env))))
+          ((eq? (car exp) 'lambda)
+           (let ((new-env (new-variables (cadr exp) env)))
+             (list 'lambda
+                   (map (lambda (x) (cdr (assq x new-env))) (cadr exp))
+                   (alphatize (caddr exp) new-env))))
+          (else
+           (map alpha exp))))
+  (alpha exp))
+
+(define (const-expr? expr) ; is 'expr' a constant expression?
+  (and (not (symbol? expr))
+       (or (not (pair? expr))
+           (eq? (car expr) 'quote))))
+
+(define (const-value expr) ; return the value of a constant expression
+  (if (pair? expr) ; then it must be a quoted constant
+    (cadr expr)
+    expr))
+
+(define (quot val) ; make a quoted constant whose value is 'val'
+  (list 'quote val))
+
+(define (new-variables parms env)
+  (append (map (lambda (x) (cons x (new-variable x))) parms) env))
+
+(define *current-num* 0)
+
+(define (new-variable name)
+  (set! *current-num* (+ *current-num* 1))
+  (string->symbol
+    (string-append (symbol->string name)
+                   "_"
+                   (number->string *current-num*))))
+
+;------------------------------------------------------------------------------
+;
+; (peval proc args) will transform a procedure that is known to be called
+; with constants as some of its arguments into a specialized procedure that
+; is 'equivalent' but accepts only the non-constant parameters.  'proc' is the
+; list representation of a lambda-expression and 'args' is a list of values,
+; one for each parameter of the lambda-expression.  A special value (i.e.
+; 'not-constant') is used to indicate an argument that is not a constant.
+; The returned procedure is one that has as parameters the parameters of the
+; original procedure which are NOT passed constants.  Constants will have been
+; substituted for the constant parameters that are referenced in the body
+; of the procedure.
+;
+; For example:
+;
+;   (peval
+;     '(lambda (x y z) (f z x y)) ; the procedure
+;     (list 1 not-constant #t))   ; the knowledge about x, y and z
+;
+; will return: (lambda (y) (f '#t '1 y))
+
+(define (peval proc args)
+  (simplify!
+    (let ((parms (cadr proc))  ; get the parameter list
+          (body (caddr proc))) ; get the body of the procedure
+      (list 'lambda
+            (remove-constant parms args) ; remove the constant parameters
+            (beta-subst ; in the body, replace variable refs to the constant
+              body      ; parameters by the corresponding constant
+              (map2 (lambda (x y) (if (not-constant? y) '(()) (cons x (quot y))))
+                    parms
+                    args))))))
+
+(define not-constant (list '?)) ; special value indicating non-constant parms.
+
+(define (not-constant? x) (eq? x not-constant))
+
+(define (remove-constant l a) ; remove from list 'l' all elements whose
+  (cond ((null? l)            ; corresponding element in 'a' is a constant
+         '())
+        ((not-constant? (car a))
+         (cons (car l) (remove-constant (cdr l) (cdr a))))
+        (else
+         (remove-constant (cdr l) (cdr a)))))
+
+(define (extract-constant l a) ; extract from list 'l' all elements whose
+  (cond ((null? l)             ; corresponding element in 'a' is a constant
+         '())
+        ((not-constant? (car a))
+         (extract-constant (cdr l) (cdr a)))
+        (else
+         (cons (car l) (extract-constant (cdr l) (cdr a))))))
+
+(define (beta-subst exp env) ; return a modified 'exp' where each var named in
+  (define (bs exp)           ; 'env' is replaced by the corresponding expr (it
+    (cond ((const-expr? exp) ; is assumed that the code has been alphatized)
+           (quot (const-value exp)))
+          ((symbol? exp)
+           (let ((x (assq exp env))) 
+             (if x (cdr x) exp)))
+          ((or (eq? (car exp) 'if) (eq? (car exp) 'begin))
+           (cons (car exp) (map bs (cdr exp))))
+          ((or (eq? (car exp) 'let) (eq? (car exp) 'letrec))
+           (list (car exp)
+                 (map (lambda (x) (list (car x) (bs (cadr x)))) (cadr exp))
+                 (bs (caddr exp))))
+          ((eq? (car exp) 'lambda)
+           (list 'lambda
+                 (cadr exp)
+                 (bs (caddr exp))))
+          (else
+           (map bs exp))))
+  (bs exp))
+
+;------------------------------------------------------------------------------
+;
+; The expression simplifier.
+
+(define (simplify! exp)     ; simplify the expression 'exp' destructively (it
+                            ; is assumed that the code has been alphatized)
+  (define (simp! where env)
+
+    (define (s! where)
+      (let ((exp (car where)))
+
+        (cond ((const-expr? exp))  ; leave constants the way they are
+
+              ((symbol? exp))      ; leave variable references the way they are
+
+              ((eq? (car exp) 'if) ; dead code removal for conditionals
+               (s! (cdr exp))      ; simplify the predicate
+               (if (const-expr? (cadr exp)) ; is the predicate a constant?
+                 (begin
+                   (set-car! where
+                     (if (memq (const-value (cadr exp)) '(#f ())) ; false?
+                       (if (= (length exp) 3) ''() (cadddr exp))
+                       (caddr exp)))
+                   (s! where))
+                 (for-each! s! (cddr exp)))) ; simplify consequent and alt.
+
+              ((eq? (car exp) 'begin)
+               (for-each! s! (cdr exp))
+               (let loop ((exps exp)) ; remove all useless expressions
+                 (if (not (null? (cddr exps))) ; not last expression?
+                   (let ((x (cadr exps)))
+                     (loop (if (or (const-expr? x)
+                                   (symbol? x)
+                                   (and (pair? x) (eq? (car x) 'lambda)))
+                             (begin (set-cdr! exps (cddr exps)) exps)
+                             (cdr exps))))))
+               (if (null? (cddr exp)) ; only one expression in the begin?
+                 (set-car! where (cadr exp))))
+
+              ((or (eq? (car exp) 'let) (eq? (car exp) 'letrec))
+               (let ((new-env (cons exp env)))
+                 (define (keep i)
+                   (if (>= i (length (cadar where)))
+                     '()
+                     (let* ((var (car (list-ref (cadar where) i)))
+                            (val (cadr (assq var (cadar where))))
+                            (refs (ref-count (car where) var))
+                            (self-refs (ref-count val var))
+                            (total-refs (- (car refs) (car self-refs)))
+                            (oper-refs (- (cadr refs) (cadr self-refs))))
+                       (cond ((= total-refs 0)
+                              (keep (+ i 1)))
+                             ((or (const-expr? val)
+                                  (symbol? val)
+                                  (and (pair? val)
+                                       (eq? (car val) 'lambda)
+                                       (= total-refs 1)
+                                       (= oper-refs 1)
+                                       (= (car self-refs) 0))
+                                  (and (caddr refs)
+                                       (= total-refs 1)))
+                              (set-car! where
+                                (beta-subst (car where)
+                                            (list (cons var val))))
+                              (keep (+ i 1)))
+                             (else
+                              (cons var (keep (+ i 1))))))))
+                 (simp! (cddr exp) new-env)
+                 (for-each! (lambda (x) (simp! (cdar x) new-env)) (cadr exp))
+                 (let ((to-keep (keep 0)))
+                   (if (< (length to-keep) (length (cadar where)))
+                     (begin
+                       (if (null? to-keep)
+                         (set-car! where (caddar where))
+                         (set-car! (cdar where)
+                           (map (lambda (v) (assq v (cadar where))) to-keep)))
+                       (s! where))
+                     (if (null? to-keep)
+                       (set-car! where (caddar where)))))))
+
+              ((eq? (car exp) 'lambda)
+               (simp! (cddr exp) (cons exp env)))
+
+              (else
+               (for-each! s! exp)
+               (cond ((symbol? (car exp)) ; is the operator position a var ref?
+                      (let ((frame (binding-frame (car exp) env)))
+                        (if frame ; is it a bound variable?
+                          (let ((proc (bound-expr (car exp) frame)))
+                            (if (and (pair? proc)
+                                     (eq? (car proc) 'lambda)
+                                     (some? const-expr? (cdr exp)))
+                              (let* ((args (arg-pattern (cdr exp)))
+                                     (new-proc (peval proc args))
+                                     (new-args (remove-constant (cdr exp) args)))
+                                (set-car! where
+                                  (cons (add-binding new-proc frame (car exp))
+                                        new-args)))))
+                          (set-car! where
+                            (constant-fold-global (car exp) (cdr exp))))))
+                     ((not (pair? (car exp))))
+                     ((eq? (caar exp) 'lambda)
+                      (set-car! where
+                        (list 'let
+                              (map2 list (cadar exp) (cdr exp))
+                              (caddar exp)))
+                      (s! where)))))))
+
+    (s! where))
+
+  (define (remove-empty-calls! where env)
+
+    (define (rec! where)
+      (let ((exp (car where)))
+
+        (cond ((const-expr? exp))
+              ((symbol? exp))
+              ((eq? (car exp) 'if)
+               (rec! (cdr exp))
+               (rec! (cddr exp))
+               (rec! (cdddr exp)))
+              ((eq? (car exp) 'begin)
+               (for-each! rec! (cdr exp)))
+              ((or (eq? (car exp) 'let) (eq? (car exp) 'letrec))
+               (let ((new-env (cons exp env)))
+                 (remove-empty-calls! (cddr exp) new-env)
+                 (for-each! (lambda (x) (remove-empty-calls! (cdar x) new-env))
+                            (cadr exp))))
+              ((eq? (car exp) 'lambda)
+               (rec! (cddr exp)))
+              (else
+               (for-each! rec! (cdr exp))
+               (if (and (null? (cdr exp)) (symbol? (car exp)))
+                 (let ((frame (binding-frame (car exp) env)))
+                   (if frame ; is it a bound variable?
+                     (let ((proc (bound-expr (car exp) frame)))
+                       (if (and (pair? proc)
+                                (eq? (car proc) 'lambda))
+                         (begin
+                           (set! changed? #t)
+                           (set-car! where (caddr proc))))))))))))
+
+    (rec! where))
+
+  (define changed? #f)
+
+  (let ((x (list exp)))
+    (let loop ()
+      (set! changed? #f)
+      (simp! x '())
+      (remove-empty-calls! x '())
+      (if changed? (loop) (car x)))))
+
+(define (ref-count exp var) ; compute how many references to variable 'var'
+  (let ((total 0)           ; are contained in 'exp'
+        (oper 0)
+        (always-evaled #t))
+    (define (rc exp ae)
+      (cond ((const-expr? exp))
+            ((symbol? exp)
+             (if (eq? exp var)
+               (begin
+                 (set! total (+ total 1))
+                 (set! always-evaled (and ae always-evaled)))))
+            ((eq? (car exp) 'if)
+             (rc (cadr exp) ae)
+             (for-each (lambda (x) (rc x #f)) (cddr exp)))
+            ((eq? (car exp) 'begin)
+             (for-each (lambda (x) (rc x ae)) (cdr exp)))
+            ((or (eq? (car exp) 'let) (eq? (car exp) 'letrec))
+             (for-each (lambda (x) (rc (cadr x) ae)) (cadr exp))
+             (rc (caddr exp) ae))
+            ((eq? (car exp) 'lambda)
+             (rc (caddr exp) #f))
+            (else
+             (for-each (lambda (x) (rc x ae)) exp)
+             (if (symbol? (car exp))
+               (if (eq? (car exp) var) (set! oper (+ oper 1)))))))
+    (rc exp #t)
+    (list total oper always-evaled)))
+
+(define (binding-frame var env)
+  (cond ((null? env) #f)
+        ((or (eq? (caar env) 'let) (eq? (caar env) 'letrec))
+         (if (assq var (cadar env)) (car env) (binding-frame var (cdr env))))
+        ((eq? (caar env) 'lambda)
+         (if (memq var (cadar env)) (car env) (binding-frame var (cdr env))))
+        (else
+         '(fatal-error "ill-formed environment"))))
+
+(define (bound-expr var frame)
+  (cond ((or (eq? (car frame) 'let) (eq? (car frame) 'letrec))
+         (cadr (assq var (cadr frame))))
+        ((eq? (car frame) 'lambda)
+         not-constant)
+        (else
+         '(fatal-error "ill-formed frame"))))
+
+(define (add-binding val frame name)
+  (define (find-val val bindings)
+    (cond ((null? bindings) #f)
+          ((equal? val (cadar bindings)) ; *kludge* equal? is not exactly what
+           (caar bindings))              ; we want...
+          (else
+           (find-val val (cdr bindings)))))
+  (or (find-val val (cadr frame))
+      (let ((var (new-variable name)))
+        (set-cdr! (get-last-pair (cadr frame)) (list (list var val)))
+        var)))
+
+(define (for-each! proc! l) ; call proc! on each CONS CELL in the list 'l'
+  (if (not (null? l))
+    (begin (proc! l) (for-each! proc! (cdr l)))))
+
+(define (arg-pattern exps) ; return the argument pattern (i.e. the list of
+  (if (null? exps)         ; constants in 'exps' but with the not-constant
+    '()                    ; value wherever the corresponding expression in
+    (cons (if (const-expr? (car exps)) ; 'exps' is not a constant)
+            (const-value (car exps))
+            not-constant)
+          (arg-pattern (cdr exps)))))
+
+;------------------------------------------------------------------------------
+;
+; Knowledge about primitive procedures.
+
+(define *primitives*
+  (list
+    (cons 'car (lambda (args)
+                 (and (= (length args) 1)
+                      (pair? (car args))
+                      (quot (car (car args))))))
+    (cons 'cdr (lambda (args)
+                 (and (= (length args) 1)
+                      (pair? (car args))
+                      (quot (cdr (car args))))))
+    (cons '+ (lambda (args)
+               (and (every? number? args)
+                    (quot (sum args 0)))))
+    (cons '* (lambda (args)
+               (and (every? number? args)
+                    (quot (product args 1)))))
+    (cons '- (lambda (args)
+               (and (> (length args) 0)
+                    (every? number? args)
+                    (quot (if (null? (cdr args))
+                            (- (car args))
+                            (- (car args) (sum (cdr args) 0)))))))
+    (cons '/ (lambda (args)
+               (and (> (length args) 1)
+                    (every? number? args)
+                    (quot (if (null? (cdr args))
+                            (/ (car args))
+                            (/ (car args) (product (cdr args) 1)))))))
+    (cons '< (lambda (args)
+               (and (= (length args) 2)
+                    (every? number? args)
+                    (quot (< (car args) (cadr args))))))
+    (cons '= (lambda (args)
+               (and (= (length args) 2)
+                    (every? number? args)
+                    (quot (= (car args) (cadr args))))))
+    (cons '> (lambda (args)
+               (and (= (length args) 2)
+                    (every? number? args)
+                    (quot (> (car args) (cadr args))))))
+    (cons 'eq? (lambda (args)
+                 (and (= (length args) 2)
+                      (quot (eq? (car args) (cadr args))))))
+    (cons 'not (lambda (args)
+                 (and (= (length args) 1)
+                      (quot (not (car args))))))
+    (cons 'null? (lambda (args)
+                   (and (= (length args) 1)
+                        (quot (null? (car args))))))
+    (cons 'pair? (lambda (args)
+                   (and (= (length args) 1)
+                        (quot (pair? (car args))))))
+    (cons 'symbol? (lambda (args)
+                     (and (= (length args) 1)
+                          (quot (symbol? (car args))))))
+  )
+)
+
+(define (sum lst n)
+  (if (null? lst)
+    n
+    (sum (cdr lst) (+ n (car lst)))))
+
+(define (product lst n)
+  (if (null? lst)
+    n
+    (product (cdr lst) (* n (car lst)))))
+
+(define (reduce-global name args)
+  (let ((x (assq name *primitives*)))
+    (and x ((cdr x) args))))
+
+(define (constant-fold-global name exprs)
+
+  (define (flatten args op)
+    (cond ((null? args)
+           '())
+          ((and (pair? (car args)) (eq? (caar args) op))
+           (append (flatten (cdar args) op) (flatten (cdr args) op)))
+          (else
+           (cons (car args) (flatten (cdr args) op)))))
+
+  (let ((args (if (or (eq? name '+) (eq? name '*)) ; associative ops
+                (flatten exprs name)
+                exprs)))
+    (or (and (every? const-expr? args)
+             (reduce-global name (map const-value args)))
+        (let ((pattern (arg-pattern args)))
+          (let ((non-const (remove-constant args pattern))
+                (const (map const-value (extract-constant args pattern))))
+            (cond ((eq? name '+) ; + is commutative
+                   (let ((x (reduce-global '+ const)))
+                     (if x
+                       (let ((y (const-value x)))
+                         (cons '+
+                               (if (= y 0) non-const (cons x non-const))))
+                       (cons name args))))
+                  ((eq? name '*) ; * is commutative
+                   (let ((x (reduce-global '* const)))
+                     (if x
+                       (let ((y (const-value x)))
+                         (cons '*
+                               (if (= y 1) non-const (cons x non-const))))
+                       (cons name args))))
+                  ((eq? name 'cons)
+                   (cond ((and (const-expr? (cadr args))
+                               (null? (const-value (cadr args))))
+                          (list 'list (car args)))
+                         ((and (pair? (cadr args))
+                               (eq? (car (cadr args)) 'list))
+                          (cons 'list (cons (car args) (cdr (cadr args)))))
+                         (else
+                          (cons name args))))
+                  (else
+                   (cons name args))))))))
+
+;------------------------------------------------------------------------------
+;
+; Examples:
+
+(define (try-peval proc args)
+  (partial-evaluate proc args))
+
+; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+(define example1
+  '(lambda (a b c)
+     (if (null? a) b (+ (car a) c))))
+
+;(try-peval example1 (list '(10 11) not-constant '1))
+
+; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+(define example2
+  '(lambda (x y)
+     (let ((q (lambda (a b) (if (< a 0) b (- 10 b)))))
+       (if (< x 0) (q (- y) (- x)) (q y x)))))
+
+;(try-peval example2 (list not-constant '1))
+
+; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+(define example3
+  '(lambda (l n)
+     (letrec ((add-list
+               (lambda (l n)
+                 (if (null? l)
+                   '()
+                   (cons (+ (car l) n) (add-list (cdr l) n))))))
+       (add-list l n))))
+
+;(try-peval example3 (list not-constant '1))
+
+;(try-peval example3 (list '(1 2 3) not-constant))
+
+; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+(define example4
+  '(lambda (exp env)
+     (letrec ((eval
+               (lambda (exp env)
+                 (letrec ((eval-list
+                            (lambda (l env)
+                              (if (null? l)
+                                '()
+                                (cons (eval (car l) env)
+                                      (eval-list (cdr l) env))))))
+                   (if (symbol? exp) (lookup exp env)
+                     (if (not (pair? exp)) exp
+                       (if (eq? (car exp) 'quote) (car (cdr exp))
+                         (apply (eval (car exp) env)
+                                (eval-list (cdr exp) env)))))))))
+       (eval exp env))))
+
+;(try-peval example4 (list 'x not-constant))
+
+;(try-peval example4 (list '(f 1 2 3) not-constant))
+
+; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+(define example5
+  '(lambda (a b)
+     (letrec ((funct
+               (lambda (x)
+                 (+ x b (if (< x 1) 0 (funct (- x 1)))))))
+       (funct a))))
+
+;(try-peval example5 (list '5 not-constant))
+
+; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+(define example6
+  '(lambda ()
+     (letrec ((fib
+               (lambda (x)
+                 (if (< x 2) x (+ (fib (- x 1)) (fib (- x 2)))))))
+       (fib 10))))
+
+;(try-peval example6 '())
+
+; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+(define example7
+  '(lambda (input)
+     (letrec ((copy (lambda (in)
+                      (if (pair? in)
+                        (cons (copy (car in))
+                              (copy (cdr in)))
+                        in))))
+       (copy input))))
+
+;(try-peval example7 (list '(a b c d e f g h i j k l m n o p q r s t u v w x y z)))
+
+; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+(define example8
+  '(lambda (input)
+     (letrec ((reverse (lambda (in result)
+                         (if (pair? in)
+                           (reverse (cdr in) (cons (car in) result))
+                           result))))
+       (reverse input '()))))
+
+;(try-peval example8 (list '(a b c d e f g h i j k l m n o p q r s t u v w x y z)))
+
+; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+(define (test init)
+  (set! *current-num* init)
+  (list (try-peval example1 (list '(10 11) not-constant '1))
+        (try-peval example2 (list not-constant '1))
+        (try-peval example3 (list not-constant '1))
+        (try-peval example3 (list '(1 2 3) not-constant))
+        (try-peval example4 (list 'x not-constant))
+        (try-peval example4 (list '(f 1 2 3) not-constant))
+        (try-peval example5 (list '5 not-constant))
+        (try-peval example6 '())
+        (try-peval
+         example7
+         (list '(a b c d e f g h i j k l m n o p q r s t u v w x y z)))
+        (try-peval
+         example8
+         (list '(a b c d e f g h i j k l m n o p q r s t u v w x y z)))))
+
+(let ((input (with-input-from-file "input.txt" read)))
+  (time
+   (let loop ((n 60) (v 0))
+     (if (zero? n)
+         v
+         (loop (- n 1) (test (if input 0 17)))))))
diff --git a/benchmarks/gabriel/puzzle.sch b/benchmarks/gabriel/puzzle.sch
new file mode 100644
index 00000000..69cb0690
--- /dev/null
+++ b/benchmarks/gabriel/puzzle.sch
@@ -0,0 +1,171 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File:         puzzle.sch
+; Description:  PUZZLE benchmark
+; Author:       Richard Gabriel, after Forrest Baskett
+; Created:      12-Apr-85
+; Modified:     12-Apr-85 14:20:23 (Bob Shaw)
+;               11-Aug-87 (Will Clinger)
+;               22-Jan-88 (Will Clinger)
+; Language:     Scheme
+; Status:       Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (iota n)
+  (do ((n n (- n 1))
+       (list '() (cons (- n 1) list)))
+      ((zero? n) list)))
+
+;;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in Pascal.
+
+(define size 1048575)
+(define classmax 3)
+(define typemax 12)
+
+(define *iii* 0)
+(define *kount* 0)
+(define *d* 8)
+
+(define *piececount* (make-vector (+ classmax 1) 0))
+(define *class* (make-vector (+ typemax 1) 0))
+(define *piecemax* (make-vector (+ typemax 1) 0))
+(define *puzzle* (make-vector (+ size 1)))
+(define *p* (make-vector (+ typemax 1)))
+(define nothing
+  (for-each (lambda (i) (vector-set! *p* i (make-vector (+ size 1))))
+            (iota (+ typemax 1))))
+
+(define (fit i j)
+  (let ((end (vector-ref *piecemax* i)))
+    (do ((k 0 (+ k 1)))
+        ((or (> k end)
+             (and (vector-ref (vector-ref *p* i) k)
+                  (vector-ref *puzzle* (+ j k))))
+         (if (> k end) #t #f)))))
+
+(define (place i j)
+  (let ((end (vector-ref *piecemax* i)))
+    (do ((k 0 (+ k 1)))
+        ((> k end))
+        (cond ((vector-ref (vector-ref *p* i) k)
+               (vector-set! *puzzle* (+ j k) #t)
+               #t)))
+    (vector-set! *piececount*
+                 (vector-ref *class* i)
+                 (- (vector-ref *piececount* (vector-ref *class* i)) 1))
+    (do ((k j (+ k 1)))
+        ((or (> k size) (not (vector-ref *puzzle* k)))
+         ;        (newline)
+         ;        (display "*Puzzle* filled")
+         (if (> k size) 0 k)))))
+
+(define (puzzle-remove i j)
+  (let ((end (vector-ref *piecemax* i)))
+    (do ((k 0 (+ k 1)))
+        ((> k end))
+        (cond ((vector-ref (vector-ref *p* i) k)
+               (vector-set! *puzzle* (+ j k) #f)
+               #f)))
+    (vector-set! *piececount*
+                 (vector-ref *class* i)
+                 (+ (vector-ref *piececount* (vector-ref *class* i)) 1))))
+
+
+(define (trial j)
+  (let ((k 0))
+    (call-with-current-continuation
+     (lambda (return)
+       (do ((i 0 (+ i 1)))
+           ((> i typemax) (set! *kount* (+ *kount* 1)) '())
+           (cond
+            ((not
+              (zero?
+               (vector-ref *piececount* (vector-ref *class* i))))
+             (cond
+              ((fit i j)
+               (set! k (place i j))
+               (cond
+                ((or (trial k) (zero? k))
+                 ;(trial-output (+ i 1) (+ k 1))
+                 (set! *kount* (+ *kount* 1))
+                 (return #t))
+                (else (puzzle-remove i j))))))))))))
+
+(define (trial-output x y)
+  (newline)
+  (display (string-append "Piece "
+                          (number->string x '(int))
+                          " at "
+                          (number->string y '(int))
+                          ".")))
+
+(define (definePiece iclass ii jj kk)
+  (let ((index 0))
+    (do ((i 0 (+ i 1)))
+        ((> i ii))
+        (do ((j 0 (+ j 1)))
+            ((> j jj))
+            (do ((k 0 (+ k 1)))
+                ((> k kk))
+                (set! index (+ i (* *d* (+ j (* *d* k)))))
+                (vector-set! (vector-ref *p* *iii*) index  #t))))
+    (vector-set! *class* *iii* iclass)
+    (vector-set! *piecemax* *iii* index)
+    (cond ((not (= *iii* typemax))
+           (set! *iii* (+ *iii* 1))))))
+
+(define (start)
+  (do ((m 0 (+ m 1)))
+      ((> m size))
+      (vector-set! *puzzle* m #t))
+  (do ((i 1 (+ i 1)))
+      ((> i 5))
+      (do ((j 1 (+ j 1)))
+          ((> j 5))
+          (do ((k 1 (+ k 1)))
+              ((> k 5))
+              (vector-set! *puzzle* (+ i (* *d* (+ j (* *d* k)))) #f))))
+  (do ((i 0 (+ i 1)))
+      ((> i typemax))
+      (do ((m 0 (+ m 1)))
+          ((> m size))
+          (vector-set! (vector-ref *p* i) m #f)))
+  (set! *iii* 0)
+  (definePiece 0 3 1 0)
+  (definePiece 0 1 0 3)
+  (definePiece 0 0 3 1)
+  (definePiece 0 1 3 0)
+  (definePiece 0 3 0 1)
+  (definePiece 0 0 1 3)
+  
+  (definePiece 1 2 0 0)
+  (definePiece 1 0 2 0)
+  (definePiece 1 0 0 2)
+  
+  (definePiece 2 1 1 0)
+  (definePiece 2 1 0 1)
+  (definePiece 2 0 1 1)
+  
+  (definePiece 3 1 1 1)
+  
+  (vector-set! *piececount* 0 13)
+  (vector-set! *piececount* 1 3)
+  (vector-set! *piececount* 2 1)
+  (vector-set! *piececount* 3 1)
+  (let ((m (+ (* *d* (+ *d* 1)) 1))
+        (n 0))
+    (cond ((fit 0 m) (set! n (place 0 m)))
+          (else (begin (newline) (display "Error."))))
+    (cond ((trial n)
+           (begin (newline)
+                  (display "Success in ")
+                  (write *kount*)
+                  (display " trials.")
+                  (newline)
+                  'ok))
+          (else (begin (newline) (display "Failure."))))))
+
+;;; call:  (start)
+
+(time (start))
+
+
diff --git a/benchmarks/gabriel/run.sh b/benchmarks/gabriel/run.sh
new file mode 100755
index 00000000..36dba94f
--- /dev/null
+++ b/benchmarks/gabriel/run.sh
@@ -0,0 +1,16 @@
+#!/bin/sh
+
+BENCHDIR=$(dirname $0)
+if [ "${BENCHDIR%%/*}" == "." ]; then
+    BENCHDIR=$(pwd)${BENCHDIR#.}
+fi
+CHIBIHOME=${BENCHDIR%%/benchmarks/gabriel}
+CHIBI="${CHIBI:-${CHIBIHOME}/chibi-scheme} -I$CHIBIHOME"
+
+cd $BENCHDIR
+for t in *.sch; do
+    echo "${t%%.sch}"
+    LD_LIBRARY_PATH="$CHIBIHOME" DYLD_LIBRARY_PATH="$CHIBIHOME" \
+        $CHIBI -I"$CHIBIHOME/lib" -lchibi-prelude.scm $t
+done
+cd -
diff --git a/benchmarks/gabriel/sboyer.sch b/benchmarks/gabriel/sboyer.sch
new file mode 100644
index 00000000..37befe9d
--- /dev/null
+++ b/benchmarks/gabriel/sboyer.sch
@@ -0,0 +1,774 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File:         sboyer.sch
+; Description:  The Boyer benchmark
+; Author:       Bob Boyer
+; Created:      5-Apr-85
+; Modified:     10-Apr-85 14:52:20 (Bob Shaw)
+;               22-Jul-87 (Will Clinger)
+;               2-Jul-88 (Will Clinger -- distinguished #f and the empty list)
+;               13-Feb-97 (Will Clinger -- fixed bugs in unifier and rules,
+;                          rewrote to eliminate property lists, and added
+;                          a scaling parameter suggested by Bob Boyer)
+;               19-Mar-99 (Will Clinger -- cleaned up comments)
+;               4-Apr-01 (Will Clinger -- changed four 1- symbols to sub1)
+; Language:     Scheme
+; Status:       Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; SBOYER -- Logic programming benchmark, originally written by Bob Boyer.
+;;; Much less CONS-intensive than NBOYER because it uses Henry Baker's
+;;; "sharing cons".
+
+; Note:  The version of this benchmark that appears in Dick Gabriel's book
+; contained several bugs that are corrected here.  These bugs are discussed
+; by Henry Baker, "The Boyer Benchmark Meets Linear Logic", ACM SIGPLAN Lisp
+; Pointers 6(4), October-December 1993, pages 3-10.  The fixed bugs are:
+;
+;    The benchmark now returns a boolean result.
+;    FALSEP and TRUEP use TERM-MEMBER? rather than MEMV (which is called MEMBER
+;         in Common Lisp)
+;    ONE-WAY-UNIFY1 now treats numbers correctly
+;    ONE-WAY-UNIFY1-LST now treats empty lists correctly
+;    Rule 19 has been corrected (this rule was not touched by the original
+;         benchmark, but is used by this version)
+;    Rules 84 and 101 have been corrected (but these rules are never touched
+;         by the benchmark)
+;
+; According to Baker, these bug fixes make the benchmark 10-25% slower.
+; Please do not compare the timings from this benchmark against those of
+; the original benchmark.
+;
+; This version of the benchmark also prints the number of rewrites as a sanity
+; check, because it is too easy for a buggy version to return the correct
+; boolean result.  The correct number of rewrites is
+;
+;     n      rewrites       peak live storage (approximate, in bytes)
+;     0         95024
+;     1        591777
+;     2       1813975
+;     3       5375678
+;     4      16445406
+;     5      51507739
+
+; Sboyer is a 2-phase benchmark.
+; The first phase attaches lemmas to symbols.  This phase is not timed,
+; but it accounts for very little of the runtime anyway.
+; The second phase creates the test problem, and tests to see
+; whether it is implied by the lemmas.
+
+(define (sboyer-benchmark . args)
+  (let ((n (if (null? args) 0 (car args))))
+    (setup-boyer)
+    (time (test-boyer n))))
+
+(define (setup-boyer) #t) ; assigned below
+(define (test-boyer) #t)  ; assigned below
+
+(define (id x) x)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;
+; The first phase.
+;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+; In the original benchmark, it stored a list of lemmas on the
+; property lists of symbols.
+; In the new benchmark, it maintains an association list of
+; symbols and symbol-records, and stores the list of lemmas
+; within the symbol-records.
+
+(let ()
+  
+  (define (setup)
+    (add-lemma-lst
+     (quote ((equal (compile form)
+                    (reverse (codegen (optimize form)
+                                      (nil))))
+             (equal (eqp x y)
+                    (equal (fix x)
+                           (fix y)))
+             (equal (greaterp x y)
+                    (lessp y x))
+             (equal (lesseqp x y)
+                    (not (lessp y x)))
+             (equal (greatereqp x y)
+                    (not (lessp x y)))
+             (equal (boolean x)
+                    (or (equal x (t))
+                        (equal x (f))))
+             (equal (iff x y)
+                    (and (implies x y)
+                         (implies y x)))
+             (equal (even1 x)
+                    (if (zerop x)
+                        (t)
+                        (odd (sub1 x))))
+             (equal (countps- l pred)
+                    (countps-loop l pred (zero)))
+             (equal (fact- i)
+                    (fact-loop i 1))
+             (equal (reverse- x)
+                    (reverse-loop x (nil)))
+             (equal (divides x y)
+                    (zerop (remainder y x)))
+             (equal (assume-true var alist)
+                    (cons (cons var (t))
+                          alist))
+             (equal (assume-false var alist)
+                    (cons (cons var (f))
+                          alist))
+             (equal (tautology-checker x)
+                    (tautologyp (normalize x)
+                                (nil)))
+             (equal (falsify x)
+                    (falsify1 (normalize x)
+                              (nil)))
+             (equal (prime x)
+                    (and (not (zerop x))
+                         (not (equal x (add1 (zero))))
+                         (prime1 x (sub1 x))))
+             (equal (and p q)
+                    (if p (if q (t)
+                                (f))
+                          (f)))
+             (equal (or p q)
+                    (if p (t)
+                          (if q (t)
+                                (f))))
+             (equal (not p)
+                    (if p (f)
+                          (t)))
+             (equal (implies p q)
+                    (if p (if q (t)
+                                (f))
+                          (t)))
+             (equal (fix x)
+                    (if (numberp x)
+                        x
+                        (zero)))
+             (equal (if (if a b c)
+                        d e)
+                    (if a (if b d e)
+                          (if c d e)))
+             (equal (zerop x)
+                    (or (equal x (zero))
+                        (not (numberp x))))
+             (equal (plus (plus x y)
+                          z)
+                    (plus x (plus y z)))
+             (equal (equal (plus a b)
+                           (zero))
+                    (and (zerop a)
+                         (zerop b)))
+             (equal (difference x x)
+                    (zero))
+             (equal (equal (plus a b)
+                           (plus a c))
+                    (equal (fix b)
+                           (fix c)))
+             (equal (equal (zero)
+                           (difference x y))
+                    (not (lessp y x)))
+             (equal (equal x (difference x y))
+                    (and (numberp x)
+                         (or (equal x (zero))
+                             (zerop y))))
+             (equal (meaning (plus-tree (append x y))
+                             a)
+                    (plus (meaning (plus-tree x)
+                                   a)
+                          (meaning (plus-tree y)
+                                   a)))
+             (equal (meaning (plus-tree (plus-fringe x))
+                             a)
+                    (fix (meaning x a)))
+             (equal (append (append x y)
+                            z)
+                    (append x (append y z)))
+             (equal (reverse (append a b))
+                    (append (reverse b)
+                            (reverse a)))
+             (equal (times x (plus y z))
+                    (plus (times x y)
+                          (times x z)))
+             (equal (times (times x y)
+                           z)
+                    (times x (times y z)))
+             (equal (equal (times x y)
+                           (zero))
+                    (or (zerop x)
+                        (zerop y)))
+             (equal (exec (append x y)
+                          pds envrn)
+                    (exec y (exec x pds envrn)
+                            envrn))
+             (equal (mc-flatten x y)
+                    (append (flatten x)
+                            y))
+             (equal (member x (append a b))
+                    (or (member x a)
+                        (member x b)))
+             (equal (member x (reverse y))
+                    (member x y))
+             (equal (length (reverse x))
+                    (length x))
+             (equal (member a (intersect b c))
+                    (and (member a b)
+                         (member a c)))
+             (equal (nth (zero)
+                         i)
+                    (zero))
+             (equal (exp i (plus j k))
+                    (times (exp i j)
+                           (exp i k)))
+             (equal (exp i (times j k))
+                    (exp (exp i j)
+                         k))
+             (equal (reverse-loop x y)
+                    (append (reverse x)
+                            y))
+             (equal (reverse-loop x (nil))
+                    (reverse x))
+             (equal (count-list z (sort-lp x y))
+                    (plus (count-list z x)
+                          (count-list z y)))
+             (equal (equal (append a b)
+                           (append a c))
+                    (equal b c))
+             (equal (plus (remainder x y)
+                          (times y (quotient x y)))
+                    (fix x))
+             (equal (power-eval (big-plus1 l i base)
+                                base)
+                    (plus (power-eval l base)
+                          i))
+             (equal (power-eval (big-plus x y i base)
+                                base)
+                    (plus i (plus (power-eval x base)
+                                  (power-eval y base))))
+             (equal (remainder y 1)
+                    (zero))
+             (equal (lessp (remainder x y)
+                           y)
+                    (not (zerop y)))
+             (equal (remainder x x)
+                    (zero))
+             (equal (lessp (quotient i j)
+                           i)
+                    (and (not (zerop i))
+                         (or (zerop j)
+                             (not (equal j 1)))))
+             (equal (lessp (remainder x y)
+                           x)
+                    (and (not (zerop y))
+                         (not (zerop x))
+                         (not (lessp x y))))
+             (equal (power-eval (power-rep i base)
+                                base)
+                    (fix i))
+             (equal (power-eval (big-plus (power-rep i base)
+                                          (power-rep j base)
+                                          (zero)
+                                          base)
+                                base)
+                    (plus i j))
+             (equal (gcd x y)
+                    (gcd y x))
+             (equal (nth (append a b)
+                         i)
+                    (append (nth a i)
+                            (nth b (difference i (length a)))))
+             (equal (difference (plus x y)
+                                x)
+                    (fix y))
+             (equal (difference (plus y x)
+                                x)
+                    (fix y))
+             (equal (difference (plus x y)
+                                (plus x z))
+                    (difference y z))
+             (equal (times x (difference c w))
+                    (difference (times c x)
+                                (times w x)))
+             (equal (remainder (times x z)
+                               z)
+                    (zero))
+             (equal (difference (plus b (plus a c))
+                                a)
+                    (plus b c))
+             (equal (difference (add1 (plus y z))
+                                z)
+                    (add1 y))
+             (equal (lessp (plus x y)
+                           (plus x z))
+                    (lessp y z))
+             (equal (lessp (times x z)
+                           (times y z))
+                    (and (not (zerop z))
+                         (lessp x y)))
+             (equal (lessp y (plus x y))
+                    (not (zerop x)))
+             (equal (gcd (times x z)
+                         (times y z))
+                    (times z (gcd x y)))
+             (equal (value (normalize x)
+                           a)
+                    (value x a))
+             (equal (equal (flatten x)
+                           (cons y (nil)))
+                    (and (nlistp x)
+                         (equal x y)))
+             (equal (listp (gopher x))
+                    (listp x))
+             (equal (samefringe x y)
+                    (equal (flatten x)
+                           (flatten y)))
+             (equal (equal (greatest-factor x y)
+                           (zero))
+                    (and (or (zerop y)
+                             (equal y 1))
+                         (equal x (zero))))
+             (equal (equal (greatest-factor x y)
+                           1)
+                    (equal x 1))
+             (equal (numberp (greatest-factor x y))
+                    (not (and (or (zerop y)
+                                  (equal y 1))
+                              (not (numberp x)))))
+             (equal (times-list (append x y))
+                    (times (times-list x)
+                           (times-list y)))
+             (equal (prime-list (append x y))
+                    (and (prime-list x)
+                         (prime-list y)))
+             (equal (equal z (times w z))
+                    (and (numberp z)
+                         (or (equal z (zero))
+                             (equal w 1))))
+             (equal (greatereqp x y)
+                    (not (lessp x y)))
+             (equal (equal x (times x y))
+                    (or (equal x (zero))
+                        (and (numberp x)
+                             (equal y 1))))
+             (equal (remainder (times y x)
+                               y)
+                    (zero))
+             (equal (equal (times a b)
+                           1)
+                    (and (not (equal a (zero)))
+                         (not (equal b (zero)))
+                         (numberp a)
+                         (numberp b)
+                         (equal (sub1 a)
+                                (zero))
+                         (equal (sub1 b)
+                                (zero))))
+             (equal (lessp (length (delete x l))
+                           (length l))
+                    (member x l))
+             (equal (sort2 (delete x l))
+                    (delete x (sort2 l)))
+             (equal (dsort x)
+                    (sort2 x))
+             (equal (length (cons x1
+                                  (cons x2
+                                        (cons x3 (cons x4
+                                                       (cons x5
+                                                             (cons x6 x7)))))))
+                    (plus 6 (length x7)))
+             (equal (difference (add1 (add1 x))
+                                2)
+                    (fix x))
+             (equal (quotient (plus x (plus x y))
+                              2)
+                    (plus x (quotient y 2)))
+             (equal (sigma (zero)
+                           i)
+                    (quotient (times i (add1 i))
+                              2))
+             (equal (plus x (add1 y))
+                    (if (numberp y)
+                        (add1 (plus x y))
+                        (add1 x)))
+             (equal (equal (difference x y)
+                           (difference z y))
+                    (if (lessp x y)
+                        (not (lessp y z))
+                        (if (lessp z y)
+                            (not (lessp y x))
+                            (equal (fix x)
+                                   (fix z)))))
+             (equal (meaning (plus-tree (delete x y))
+                             a)
+                    (if (member x y)
+                        (difference (meaning (plus-tree y)
+                                             a)
+                                    (meaning x a))
+                        (meaning (plus-tree y)
+                                 a)))
+             (equal (times x (add1 y))
+                    (if (numberp y)
+                        (plus x (times x y))
+                        (fix x)))
+             (equal (nth (nil)
+                         i)
+                    (if (zerop i)
+                        (nil)
+                        (zero)))
+             (equal (last (append a b))
+                    (if (listp b)
+                        (last b)
+                        (if (listp a)
+                            (cons (car (last a))
+                                  b)
+                            b)))
+             (equal (equal (lessp x y)
+                           z)
+                    (if (lessp x y)
+                        (equal (t) z)
+                        (equal (f) z)))
+             (equal (assignment x (append a b))
+                    (if (assignedp x a)
+                        (assignment x a)
+                        (assignment x b)))
+             (equal (car (gopher x))
+                    (if (listp x)
+                        (car (flatten x))
+                        (zero)))
+             (equal (flatten (cdr (gopher x)))
+                    (if (listp x)
+                        (cdr (flatten x))
+                        (cons (zero)
+                              (nil))))
+             (equal (quotient (times y x)
+                              y)
+                    (if (zerop y)
+                        (zero)
+                        (fix x)))
+             (equal (get j (set i val mem))
+                    (if (eqp j i)
+                        val
+                        (get j mem)))))))
+  
+  (define (add-lemma-lst lst)
+    (cond ((null? lst)
+           #t)
+          (else (add-lemma (car lst))
+                (add-lemma-lst (cdr lst)))))
+  
+  (define (add-lemma term)
+    (cond ((and (pair? term)
+                (eq? (car term)
+                     (quote equal))
+                (pair? (cadr term)))
+           (put (car (cadr term))
+                (quote lemmas)
+                (cons
+                 (translate-term term)
+                 (get (car (cadr term)) (quote lemmas)))))
+          (else (error "ADD-LEMMA did not like term:  " term))))
+  
+  ; Translates a term by replacing its constructor symbols by symbol-records.
+  
+  (define (translate-term term)
+    (cond ((not (pair? term))
+           term)
+          (else (cons (symbol->symbol-record (car term))
+                      (translate-args (cdr term))))))
+  
+  (define (translate-args lst)
+    (cond ((null? lst)
+           '())
+          (else (cons (translate-term (car lst))
+                      (translate-args (cdr lst))))))
+  
+  ; For debugging only, so the use of MAP does not change
+  ; the first-order character of the benchmark.
+  
+  (define (untranslate-term term)
+    (cond ((not (pair? term))
+           term)
+          (else (cons (get-name (car term))
+                      (map untranslate-term (cdr term))))))
+  
+  ; A symbol-record is represented as a vector with two fields:
+  ; the symbol (for debugging) and
+  ; the list of lemmas associated with the symbol.
+  
+  (define (put sym property value)
+    (put-lemmas! (symbol->symbol-record sym) value))
+  
+  (define (get sym property)
+    (get-lemmas (symbol->symbol-record sym)))
+  
+  (define (symbol->symbol-record sym)
+    (let ((x (assq sym *symbol-records-alist*)))
+      (if x
+          (cdr x)
+          (let ((r (make-symbol-record sym)))
+            (set! *symbol-records-alist*
+                  (cons (cons sym r)
+                        *symbol-records-alist*))
+            r))))
+  
+  ; Association list of symbols and symbol-records.
+  
+  (define *symbol-records-alist* '())
+  
+  ; A symbol-record is represented as a vector with two fields:
+  ; the symbol (for debugging) and
+  ; the list of lemmas associated with the symbol.
+  
+  (define (make-symbol-record sym)
+    (vector sym '()))
+  
+  (define (put-lemmas! symbol-record lemmas)
+    (vector-set! symbol-record 1 lemmas))
+  
+  (define (get-lemmas symbol-record)
+    (vector-ref symbol-record 1))
+  
+  (define (get-name symbol-record)
+    (vector-ref symbol-record 0))
+  
+  (define (symbol-record-equal? r1 r2)
+    (eq? r1 r2))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;
+  ; The second phase.
+  ;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  
+  (define (test n)
+    (let ((term
+           (apply-subst
+            (translate-alist
+             (quote ((x f (plus (plus a b)
+                                (plus c (zero))))
+                     (y f (times (times a b)
+                                 (plus c d)))
+                     (z f (reverse (append (append a b)
+                                           (nil))))
+                     (u equal (plus a b)
+                              (difference x y))
+                     (w lessp (remainder a b)
+                              (member a (length b))))))
+            (translate-term
+             (do ((term
+                   (quote (implies (and (implies x y)
+                                        (and (implies y z)
+                                             (and (implies z u)
+                                                  (implies u w))))
+                                   (implies x w)))
+                   (list 'or term '(f)))
+                  (n n (- n 1)))
+                 ((zero? n) term))))))
+    (tautp term)))
+  
+  (define (translate-alist alist)
+    (cond ((null? alist)
+           '())
+          (else (cons (cons (caar alist)
+                            (translate-term (cdar alist)))
+                      (translate-alist (cdr alist))))))
+  
+  (define (apply-subst alist term)
+    (cond ((not (pair? term))
+           (let ((temp-temp (assq term alist)))
+             (if temp-temp
+                 (cdr temp-temp)
+                 term)))
+          (else (cons (car term)
+                      (apply-subst-lst alist (cdr term))))))
+  
+  (define (apply-subst-lst alist lst)
+    (cond ((null? lst)
+           '())
+          (else (cons (apply-subst alist (car lst))
+                      (apply-subst-lst alist (cdr lst))))))
+  
+  (define (tautp x)
+    (tautologyp (rewrite x)
+                '() '()))
+  
+  (define (tautologyp x true-lst false-lst)
+    (cond ((truep x true-lst)
+           #t)
+          ((falsep x false-lst)
+           #f)
+          ((not (pair? x))
+           #f)
+          ((eq? (car x) if-constructor)
+           (cond ((truep (cadr x)
+                         true-lst)
+                  (tautologyp (caddr x)
+                              true-lst false-lst))
+                 ((falsep (cadr x)
+                          false-lst)
+                  (tautologyp (cadddr x)
+                              true-lst false-lst))
+                 (else (and (tautologyp (caddr x)
+                                        (cons (cadr x)
+                                              true-lst)
+                                        false-lst)
+                            (tautologyp (cadddr x)
+                                        true-lst
+                                        (cons (cadr x)
+                                              false-lst))))))
+          (else #f)))
+  
+  (define if-constructor '*) ; becomes (symbol->symbol-record 'if)
+  
+  (define rewrite-count 0) ; sanity check
+  
+  ; The next procedure is Henry Baker's sharing CONS, which avoids
+  ; allocation if the result is already in hand.
+  ; The REWRITE and REWRITE-ARGS procedures have been modified to
+  ; use SCONS instead of CONS.
+  
+  (define (scons x y original)
+    (if (and (eq? x (car original))
+             (eq? y (cdr original)))
+        original
+        (cons x y)))
+  
+  (define (rewrite term)
+    (set! rewrite-count (+ rewrite-count 1))
+    (cond ((not (pair? term))
+           term)
+          (else (rewrite-with-lemmas (scons (car term)
+                                            (rewrite-args (cdr term))
+                                            term)
+                                     (get-lemmas (car term))))))
+  
+  (define (rewrite-args lst)
+    (cond ((null? lst)
+           '())
+          (else (scons (rewrite (car lst))
+                       (rewrite-args (cdr lst))
+                       lst))))
+  
+  (define (rewrite-with-lemmas term lst)
+    (cond ((null? lst)
+           term)
+          ((one-way-unify term (cadr (car lst)))
+           (rewrite ( apply-subst unify-subst (caddr (car lst)))))
+          (else (rewrite-with-lemmas term (cdr lst)))))
+  
+  (define unify-subst '*)
+  
+  (define (one-way-unify term1 term2)
+    (begin (set! unify-subst '())
+           (one-way-unify1 term1 term2)))
+  
+  (define (one-way-unify1 term1 term2)
+    (cond ((not (pair? term2))
+           (let ((temp-temp (assq term2 unify-subst)))
+             (cond (temp-temp
+                    (term-equal? term1 (cdr temp-temp)))
+                   ((number? term2)          ; This bug fix makes
+                    (equal? term1 term2))    ; nboyer 10-25% slower!
+                   (else
+                    (set! unify-subst (cons (cons term2 term1)
+                                            unify-subst))
+                    #t))))
+          ((not (pair? term1))
+           #f)
+          ((eq? (car term1)
+                (car term2))
+           (one-way-unify1-lst (cdr term1)
+                               (cdr term2)))
+          (else #f)))
+  
+  (define (one-way-unify1-lst lst1 lst2)
+    (cond ((null? lst1)
+           (null? lst2))
+          ((null? lst2)
+           #f)
+          ((one-way-unify1 (car lst1)
+                           (car lst2))
+           (one-way-unify1-lst (cdr lst1)
+                               (cdr lst2)))
+          (else #f)))
+  
+  (define (falsep x lst)
+    (or (term-equal? x false-term)
+        (term-member? x lst)))
+  
+  (define (truep x lst)
+    (or (term-equal? x true-term)
+        (term-member? x lst)))
+  
+  (define false-term '*)  ; becomes (translate-term '(f))
+  (define true-term '*)   ; becomes (translate-term '(t))
+  
+  ; The next two procedures were in the original benchmark
+  ; but were never used.
+  
+  (define (trans-of-implies n)
+    (translate-term
+     (list (quote implies)
+           (trans-of-implies1 n)
+           (list (quote implies)
+                 0 n))))
+  
+  (define (trans-of-implies1 n)
+    (cond ((equal? n 1)
+           (list (quote implies)
+                 0 1))
+          (else (list (quote and)
+                      (list (quote implies)
+                            (- n 1)
+                            n)
+                      (trans-of-implies1 (- n 1))))))
+  
+  ; Translated terms can be circular structures, which can't be
+  ; compared using Scheme's equal? and member procedures, so we
+  ; use these instead.
+  
+  (define (term-equal? x y)
+    (cond ((pair? x)
+           (and (pair? y)
+                (symbol-record-equal? (car x) (car y))
+                (term-args-equal? (cdr x) (cdr y))))
+          (else (equal? x y))))
+  
+  (define (term-args-equal? lst1 lst2)
+    (cond ((null? lst1)
+           (null? lst2))
+          ((null? lst2)
+           #f)
+          ((term-equal? (car lst1) (car lst2))
+           (term-args-equal? (cdr lst1) (cdr lst2)))
+          (else #f)))
+  
+  (define (term-member? x lst)
+    (cond ((null? lst)
+           #f)
+          ((term-equal? x (car lst))
+           #t)
+          (else (term-member? x (cdr lst)))))
+  
+  (set! setup-boyer
+        (lambda ()
+          (set! *symbol-records-alist* '())
+          (set! if-constructor (symbol->symbol-record 'if))
+          (set! false-term (translate-term '(f)))
+          (set! true-term  (translate-term '(t)))
+          (setup)))
+  
+  (set! test-boyer
+        (lambda (n)
+          (set! rewrite-count 0)
+          (let ((answer (test n)))
+            (write rewrite-count)
+            (display " rewrites")
+            (newline)
+            (if answer
+                rewrite-count
+                #f)))))
+
+(sboyer-benchmark 5)
diff --git a/benchmarks/gabriel/scheme.sch b/benchmarks/gabriel/scheme.sch
new file mode 100644
index 00000000..ac891d53
--- /dev/null
+++ b/benchmarks/gabriel/scheme.sch
@@ -0,0 +1,1077 @@
+;;; SCHEME -- A Scheme interpreter evaluating a sort, written by Marc Feeley.
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (scheme-eval expr)
+  (let ((code (scheme-comp expr scheme-global-environment)))
+    (code #f)))
+
+(define scheme-global-environment
+  (cons '()   ; environment chain
+        '())) ; macros
+
+(define (scheme-add-macro name proc)
+  (set-cdr! scheme-global-environment
+    (cons (cons name proc) (cdr scheme-global-environment)))
+  name)
+
+(define (scheme-error msg . args)
+  'error)
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (lst->vector l)
+  (let* ((n (length l))
+         (v (make-vector n)))
+    (let loop ((l l) (i 0))
+      (if (pair? l)
+        (begin
+          (vector-set! v i (car l))
+          (loop (cdr l) (+ i 1)))
+        v))))
+
+(define (vector->lst v)
+  (let loop ((l '()) (i (- (vector-length v) 1)))
+    (if (< i 0)
+      l
+      (loop (cons (vector-ref v i) l) (- i 1)))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define scheme-syntactic-keywords
+  '(quote quasiquote unquote unquote-splicing
+    lambda if set! cond => else and or
+    case let let* letrec begin do define
+    define-macro))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (push-frame frame env)
+  (if (null? frame)
+    env
+    (cons (cons (car env) frame) (cdr env))))
+
+(define (lookup-var name env)
+  (let loop1 ((chain (car env)) (up 0))
+    (if (null? chain)
+      name
+      (let loop2 ((chain chain)
+                  (up up)
+                  (frame (cdr chain))
+                  (over 1))
+        (cond ((null? frame)
+               (loop1 (car chain) (+ up 1)))
+              ((eq? (car frame) name)
+               (cons up over))
+              (else
+               (loop2 chain up (cdr frame) (+ over 1))))))))
+
+(define (macro? name env)
+  (assq name (cdr env)))
+
+(define (push-macro name proc env)
+  (cons (car env) (cons (cons name proc) (cdr env))))
+
+(define (lookup-macro name env)
+  (cdr (assq name (cdr env))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (variable x)
+  (if (not (symbol? x))
+    (scheme-error "Identifier expected" x))
+  (if (memq x scheme-syntactic-keywords)
+    (scheme-error "Variable name can not be a syntactic keyword" x)))
+
+(define (shape form n)
+  (let loop ((form form) (n n) (l form))
+    (cond ((<= n 0))
+          ((pair? l)
+           (loop form (- n 1) (cdr l)))
+          (else
+           (scheme-error "Ill-constructed form" form)))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (macro-expand expr env)
+  (apply (lookup-macro (car expr) env) (cdr expr)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-var expr env)
+  (variable expr)
+  (gen-var-ref (lookup-var expr env)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-self-eval expr env)
+  (gen-cst expr))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-quote expr env)
+  (shape expr 2)
+  (gen-cst (cadr expr)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-quasiquote expr env)
+  (comp-quasiquotation (cadr expr) 1 env))
+
+(define (comp-quasiquotation form level env)
+  (cond ((= level 0)
+         (scheme-comp form env))
+        ((pair? form)
+         (cond
+           ((eq? (car form) 'quasiquote)
+            (comp-quasiquotation-list form (+ level 1) env))
+           ((eq? (car form) 'unquote)
+            (if (= level 1)
+              (scheme-comp (cadr form) env)
+              (comp-quasiquotation-list form (- level 1) env)))
+           ((eq? (car form) 'unquote-splicing)
+            (if (= level 1)
+              (scheme-error "Ill-placed 'unquote-splicing'" form))
+            (comp-quasiquotation-list form (- level 1) env))
+           (else
+            (comp-quasiquotation-list form level env))))
+        ((vector? form)
+         (gen-vector-form
+           (comp-quasiquotation-list (vector->lst form) level env)))
+        (else
+         (gen-cst form))))
+
+(define (comp-quasiquotation-list l level env)
+  (if (pair? l)
+    (let ((first (car l)))
+      (if (= level 1)
+        (if (unquote-splicing? first)
+          (begin
+            (shape first 2)
+            (gen-append-form (scheme-comp (cadr first) env)
+                             (comp-quasiquotation (cdr l) 1 env)))
+          (gen-cons-form (comp-quasiquotation first level env)
+                         (comp-quasiquotation (cdr l) level env)))
+        (gen-cons-form (comp-quasiquotation first level env)
+                       (comp-quasiquotation (cdr l) level env))))
+    (comp-quasiquotation l level env)))
+
+(define (unquote-splicing? x)
+  (if (pair? x)
+    (if (eq? (car x) 'unquote-splicing) #t #f)
+    #f))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-unquote expr env)
+  (scheme-error "Ill-placed 'unquote'" expr))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-unquote-splicing expr env)
+  (scheme-error "Ill-placed 'unquote-splicing'" expr))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-set! expr env)
+  (shape expr 3)
+  (variable (cadr expr))
+  (gen-var-set (lookup-var (cadr expr) env) (scheme-comp (caddr expr) env)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-lambda expr env)
+  (shape expr 3)
+  (let ((parms (cadr expr)))
+    (let ((frame (parms->frame parms)))
+      (let ((nb-vars (length frame))
+            (code (comp-body (cddr expr) (push-frame frame env))))
+        (if (rest-param? parms)
+          (gen-lambda-rest nb-vars code)
+          (gen-lambda nb-vars code))))))
+
+(define (parms->frame parms)
+  (cond ((null? parms)
+         '())
+        ((pair? parms)
+         (let ((x (car parms)))
+           (variable x)
+           (cons x (parms->frame (cdr parms)))))
+        (else
+         (variable parms)
+         (list parms))))
+
+(define (rest-param? parms)
+  (cond ((pair? parms)
+         (rest-param? (cdr parms)))
+        ((null? parms)
+         #f)
+        (else
+         #t)))
+
+(define (comp-body body env)
+
+  (define (letrec-defines vars vals body env)
+    (if (pair? body)
+
+      (let ((expr (car body)))
+        (cond ((not (pair? expr))
+               (letrec-defines* vars vals body env))
+              ((macro? (car expr) env)
+               (letrec-defines vars
+                               vals
+                               (cons (macro-expand expr env) (cdr body))
+                               env))
+              (else
+               (cond
+                 ((eq? (car expr) 'begin)
+                  (letrec-defines vars
+                                  vals
+                                  (append (cdr expr) (cdr body))
+                                  env))
+                 ((eq? (car expr) 'define)
+                  (let ((x (definition-name expr)))
+                    (variable x)
+                    (letrec-defines (cons x vars)
+                                    (cons (definition-value expr) vals)
+                                    (cdr body)
+                                    env)))
+                 ((eq? (car expr) 'define-macro)
+                  (let ((x (definition-name expr)))
+                    (letrec-defines vars
+                                    vals
+                                    (cdr body)
+                                    (push-macro
+                                      x
+                                      (scheme-eval (definition-value expr))
+                                      env))))
+                 (else
+                  (letrec-defines* vars vals body env))))))
+
+      (scheme-error "Body must contain at least one evaluable expression")))
+
+  (define (letrec-defines* vars vals body env)
+    (if (null? vars)
+      (comp-sequence body env)
+      (comp-letrec-aux vars vals body env)))
+
+  (letrec-defines '() '() body env))
+
+(define (definition-name expr)
+  (shape expr 3)
+  (let ((pattern (cadr expr)))
+    (let ((name (if (pair? pattern) (car pattern) pattern)))
+      (if (not (symbol? name))
+        (scheme-error "Identifier expected" name))
+      name)))
+
+(define (definition-value expr)
+  (let ((pattern (cadr expr)))
+    (if (pair? pattern)
+      (cons 'lambda (cons (cdr pattern) (cddr expr)))
+      (caddr expr))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-if expr env)
+  (shape expr 3)
+  (let ((code1 (scheme-comp (cadr expr) env))
+        (code2 (scheme-comp (caddr expr) env)))
+    (if (pair? (cdddr expr))
+      (gen-if code1 code2 (scheme-comp (cadddr expr) env))
+      (gen-when code1 code2))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-cond expr env)
+  (comp-cond-aux (cdr expr) env))
+
+(define (comp-cond-aux clauses env)
+  (if (pair? clauses)
+    (let ((clause (car clauses)))
+      (shape clause 1)
+      (cond ((eq? (car clause) 'else)
+             (shape clause 2)
+             (comp-sequence (cdr clause) env))
+            ((not (pair? (cdr clause)))
+             (gen-or (scheme-comp (car clause) env)
+                     (comp-cond-aux (cdr clauses) env)))
+            ((eq? (cadr clause) '=>)
+             (shape clause 3)
+             (gen-cond-send (scheme-comp (car clause) env)
+                            (scheme-comp (caddr clause) env)
+                            (comp-cond-aux (cdr clauses) env)))
+            (else
+             (gen-if (scheme-comp (car clause) env)
+                     (comp-sequence (cdr clause) env)
+                     (comp-cond-aux (cdr clauses) env)))))
+    (gen-cst '())))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-and expr env)
+  (let ((rest (cdr expr)))
+    (if (pair? rest) (comp-and-aux rest env) (gen-cst #t))))
+
+(define (comp-and-aux l env)
+  (let ((code (scheme-comp (car l) env))
+        (rest (cdr l)))
+    (if (pair? rest) (gen-and code (comp-and-aux rest env)) code)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-or expr env)
+  (let ((rest (cdr expr)))
+    (if (pair? rest) (comp-or-aux rest env) (gen-cst #f))))
+
+(define (comp-or-aux l env)
+  (let ((code (scheme-comp (car l) env))
+        (rest (cdr l)))
+    (if (pair? rest) (gen-or code (comp-or-aux rest env)) code)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-case expr env)
+  (shape expr 3)
+  (gen-case (scheme-comp (cadr expr) env)
+            (comp-case-aux (cddr expr) env)))
+
+(define (comp-case-aux clauses env)
+  (if (pair? clauses)
+    (let ((clause (car clauses)))
+      (shape clause 2)
+      (if (eq? (car clause) 'else)
+        (gen-case-else (comp-sequence (cdr clause) env))
+        (gen-case-clause (car clause)
+                         (comp-sequence (cdr clause) env)
+                         (comp-case-aux (cdr clauses) env))))
+    (gen-case-else (gen-cst '()))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-let expr env)
+  (shape expr 3)
+  (let ((x (cadr expr)))
+    (cond ((symbol? x)
+           (shape expr 4)
+           (let ((y (caddr expr)))
+             (let ((proc (cons 'lambda (cons (bindings->vars y) (cdddr expr)))))
+               (scheme-comp (cons (list 'letrec (list (list x proc)) x)
+                                  (bindings->vals y))
+                            env))))
+          ((pair? x)
+           (scheme-comp (cons (cons 'lambda (cons (bindings->vars x) (cddr expr)))
+                              (bindings->vals x))
+                        env))
+          (else
+           (comp-body (cddr expr) env)))))
+
+(define (bindings->vars bindings)
+  (if (pair? bindings)
+    (let ((binding (car bindings)))
+      (shape binding 2)
+      (let ((x (car binding)))
+        (variable x)
+        (cons x (bindings->vars (cdr bindings)))))
+    '()))
+
+(define (bindings->vals bindings)
+  (if (pair? bindings)
+    (let ((binding (car bindings)))
+      (cons (cadr binding) (bindings->vals (cdr bindings))))
+    '()))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-let* expr env)
+  (shape expr 3)
+  (let ((bindings (cadr expr)))
+    (if (pair? bindings)
+      (scheme-comp (list 'let
+                         (list (car bindings))
+                         (cons 'let* (cons (cdr bindings) (cddr expr))))
+                   env)
+      (comp-body (cddr expr) env))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-letrec expr env)
+  (shape expr 3)
+  (let ((bindings (cadr expr)))
+    (comp-letrec-aux (bindings->vars bindings)
+                     (bindings->vals bindings)
+                     (cddr expr)
+                     env)))
+
+(define (comp-letrec-aux vars vals body env)
+  (if (pair? vars)
+    (let ((new-env (push-frame vars env)))
+      (gen-letrec (comp-vals vals new-env)
+                  (comp-body body new-env)))
+    (comp-body body env)))
+
+(define (comp-vals l env)
+  (if (pair? l)
+    (cons (scheme-comp (car l) env) (comp-vals (cdr l) env))
+    '()))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-begin expr env)
+  (shape expr 2)
+  (comp-sequence (cdr expr) env))
+
+(define (comp-sequence exprs env)
+  (if (pair? exprs)
+    (comp-sequence-aux exprs env)
+    (gen-cst '())))
+
+(define (comp-sequence-aux exprs env)
+  (let ((code (scheme-comp (car exprs) env))
+        (rest (cdr exprs)))
+    (if (pair? rest) (gen-sequence code (comp-sequence-aux rest env)) code)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-do expr env)
+  (shape expr 3)
+  (let ((bindings (cadr expr))
+        (exit (caddr expr)))
+    (shape exit 1)
+    (let* ((vars (bindings->vars bindings))
+           (new-env1 (push-frame '(#f) env))
+           (new-env2 (push-frame vars new-env1)))
+      (gen-letrec
+        (list
+          (gen-lambda
+            (length vars)
+            (gen-if
+              (scheme-comp (car exit) new-env2)
+              (comp-sequence (cdr exit) new-env2)
+              (gen-sequence
+                (comp-sequence (cdddr expr) new-env2)
+                (gen-combination
+                  (gen-var-ref '(1 . 1))
+                  (comp-vals (bindings->steps bindings) new-env2))))))
+        (gen-combination
+          (gen-var-ref '(0 . 1))
+          (comp-vals (bindings->vals bindings) new-env1))))))
+
+(define (bindings->steps bindings)
+  (if (pair? bindings)
+    (let ((binding (car bindings)))
+      (cons (if (pair? (cddr binding)) (caddr binding) (car binding))
+            (bindings->steps (cdr bindings))))
+    '()))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-define expr env)
+  (shape expr 3)
+  (let ((pattern (cadr expr)))
+    (let ((x (if (pair? pattern) (car pattern) pattern)))
+      (variable x)
+      (gen-sequence
+        (gen-var-set (lookup-var x env)
+                     (scheme-comp (if (pair? pattern)
+                                    (cons 'lambda (cons (cdr pattern) (cddr expr)))
+                                    (caddr expr))
+                                  env))
+        (gen-cst x)))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-define-macro expr env)
+  (let ((x (definition-name expr)))
+    (gen-macro x (scheme-eval (definition-value expr)))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-combination expr env)
+  (gen-combination (scheme-comp (car expr) env) (comp-vals (cdr expr) env)))
+
+;------------------------------------------------------------------------------
+
+(define (gen-var-ref var)
+  (if (pair? var)
+    (gen-rte-ref (car var) (cdr var))
+    (gen-glo-ref (scheme-global-var var))))
+
+(define (gen-rte-ref up over)
+  (case up
+    ((0)  (gen-slot-ref-0 over))
+    ((1)  (gen-slot-ref-1 over))
+    (else (gen-slot-ref-up-2 (gen-rte-ref (- up 2) over)))))
+
+(define (gen-slot-ref-0 i)
+  (case i
+    ((0)  (lambda (rte) (vector-ref rte 0)))
+    ((1)  (lambda (rte) (vector-ref rte 1)))
+    ((2)  (lambda (rte) (vector-ref rte 2)))
+    ((3)  (lambda (rte) (vector-ref rte 3)))
+    (else (lambda (rte) (vector-ref rte i)))))
+
+(define (gen-slot-ref-1 i)
+  (case i
+    ((0)  (lambda (rte) (vector-ref (vector-ref rte 0) 0)))
+    ((1)  (lambda (rte) (vector-ref (vector-ref rte 0) 1)))
+    ((2)  (lambda (rte) (vector-ref (vector-ref rte 0) 2)))
+    ((3)  (lambda (rte) (vector-ref (vector-ref rte 0) 3)))
+    (else (lambda (rte) (vector-ref (vector-ref rte 0) i)))))
+
+(define (gen-slot-ref-up-2 code)
+  (lambda (rte) (code (vector-ref (vector-ref rte 0) 0))))
+
+(define (gen-glo-ref i)
+  (lambda (rte) (scheme-global-var-ref i)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-cst val)
+  (case val
+    ((()) (lambda (rte) '()))
+    ((#f) (lambda (rte) #f))
+    ((#t) (lambda (rte) #t))
+    ((-2) (lambda (rte) -2))
+    ((-1) (lambda (rte) -1))
+    ((0)  (lambda (rte) 0))
+    ((1)  (lambda (rte) 1))
+    ((2)  (lambda (rte) 2))
+    (else (lambda (rte) val))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-append-form code1 code2)
+  (lambda (rte) (append (code1 rte) (code2 rte))))
+
+(define (gen-cons-form code1 code2)
+  (lambda (rte) (cons (code1 rte) (code2 rte))))
+
+(define (gen-vector-form code)
+  (lambda (rte) (lst->vector (code rte))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-var-set var code)
+  (if (pair? var)
+    (gen-rte-set (car var) (cdr var) code)
+    (gen-glo-set (scheme-global-var var) code)))
+
+(define (gen-rte-set up over code)
+  (case up
+    ((0)  (gen-slot-set-0 over code))
+    ((1)  (gen-slot-set-1 over code))
+    (else (gen-slot-set-n (gen-rte-ref (- up 2) 0) over code))))
+
+(define (gen-slot-set-0 i code)
+  (case i
+    ((0)  (lambda (rte) (vector-set! rte 0 (code rte))))
+    ((1)  (lambda (rte) (vector-set! rte 1 (code rte))))
+    ((2)  (lambda (rte) (vector-set! rte 2 (code rte))))
+    ((3)  (lambda (rte) (vector-set! rte 3 (code rte))))
+    (else (lambda (rte) (vector-set! rte i (code rte))))))
+
+(define (gen-slot-set-1 i code)
+  (case i
+    ((0)  (lambda (rte) (vector-set! (vector-ref rte 0) 0 (code rte))))
+    ((1)  (lambda (rte) (vector-set! (vector-ref rte 0) 1 (code rte))))
+    ((2)  (lambda (rte) (vector-set! (vector-ref rte 0) 2 (code rte))))
+    ((3)  (lambda (rte) (vector-set! (vector-ref rte 0) 3 (code rte))))
+    (else (lambda (rte) (vector-set! (vector-ref rte 0) i (code rte))))))
+
+(define (gen-slot-set-n up i code)
+  (case i
+    ((0)  (lambda (rte) (vector-set! (up (vector-ref rte 0)) 0 (code rte))))
+    ((1)  (lambda (rte) (vector-set! (up (vector-ref rte 0)) 1 (code rte))))
+    ((2)  (lambda (rte) (vector-set! (up (vector-ref rte 0)) 2 (code rte))))
+    ((3)  (lambda (rte) (vector-set! (up (vector-ref rte 0)) 3 (code rte))))
+    (else (lambda (rte) (vector-set! (up (vector-ref rte 0)) i (code rte))))))
+
+(define (gen-glo-set i code)
+  (lambda (rte) (scheme-global-var-set! i (code rte))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-lambda-rest nb-vars body)
+  (case nb-vars
+    ((1)  (gen-lambda-1-rest body))
+    ((2)  (gen-lambda-2-rest body))
+    ((3)  (gen-lambda-3-rest body))
+    (else (gen-lambda-n-rest nb-vars body))))
+
+(define (gen-lambda-1-rest body)
+  (lambda (rte)
+    (lambda a
+      (body (vector rte a)))))
+
+(define (gen-lambda-2-rest body)
+  (lambda (rte)
+    (lambda (a . b)
+      (body (vector rte a b)))))
+
+(define (gen-lambda-3-rest body)
+  (lambda (rte)
+    (lambda (a b . c)
+      (body (vector rte a b c)))))
+
+(define (gen-lambda-n-rest nb-vars body)
+  (lambda (rte)
+    (lambda (a b c . d)
+      (let ((x (make-vector (+ nb-vars 1))))
+        (vector-set! x 0 rte)
+        (vector-set! x 1 a)
+        (vector-set! x 2 b)
+        (vector-set! x 3 c)
+        (let loop ((n nb-vars) (x x) (i 4) (l d))
+          (if (< i n)
+            (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l)))
+            (vector-set! x i l)))
+        (body x)))))
+
+(define (gen-lambda nb-vars body)
+  (case nb-vars
+    ((0)  (gen-lambda-0 body))
+    ((1)  (gen-lambda-1 body))
+    ((2)  (gen-lambda-2 body))
+    ((3)  (gen-lambda-3 body))
+    (else (gen-lambda-n nb-vars body))))
+
+(define (gen-lambda-0 body)
+  (lambda (rte)
+    (lambda ()
+      (body rte))))
+
+(define (gen-lambda-1 body)
+  (lambda (rte)
+    (lambda (a)
+      (body (vector rte a)))))
+
+(define (gen-lambda-2 body)
+  (lambda (rte)
+    (lambda (a b)
+      (body (vector rte a b)))))
+
+(define (gen-lambda-3 body)
+  (lambda (rte)
+    (lambda (a b c)
+      (body (vector rte a b c)))))
+
+(define (gen-lambda-n nb-vars body)
+  (lambda (rte)
+    (lambda (a b c . d)
+      (let ((x (make-vector (+ nb-vars 1))))
+        (vector-set! x 0 rte)
+        (vector-set! x 1 a)
+        (vector-set! x 2 b)
+        (vector-set! x 3 c)
+        (let loop ((n nb-vars) (x x) (i 4) (l d))
+          (if (<= i n)
+            (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l)))))
+        (body x)))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-sequence code1 code2)
+  (lambda (rte) (code1 rte) (code2 rte)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-when code1 code2)
+  (lambda (rte)
+    (if (code1 rte)
+      (code2 rte)
+      '())))
+
+(define (gen-if code1 code2 code3)
+  (lambda (rte)
+    (if (code1 rte)
+      (code2 rte)
+      (code3 rte))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-cond-send code1 code2 code3)
+  (lambda (rte)
+    (let ((temp (code1 rte)))
+      (if temp
+        ((code2 rte) temp)
+        (code3 rte)))))
+              
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-and code1 code2)
+  (lambda (rte)
+    (let ((temp (code1 rte)))
+      (if temp
+        (code2 rte)
+        temp))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-or code1 code2)
+  (lambda (rte)
+    (let ((temp (code1 rte)))
+      (if temp
+        temp
+        (code2 rte)))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-case code1 code2)
+  (lambda (rte) (code2 rte (code1 rte))))
+
+(define (gen-case-clause datums code1 code2)
+  (lambda (rte key) (if (memv key datums) (code1 rte) (code2 rte key))))
+
+(define (gen-case-else code)
+  (lambda (rte key) (code rte)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-letrec vals body)
+  (let ((nb-vals (length vals)))
+    (case nb-vals
+      ((1)  (gen-letrec-1 (car vals) body))
+      ((2)  (gen-letrec-2 (car vals) (cadr vals) body))
+      ((3)  (gen-letrec-3 (car vals) (cadr vals) (caddr vals) body))
+      (else (gen-letrec-n nb-vals vals body)))))
+
+(define (gen-letrec-1 val1 body)
+  (lambda (rte)
+    (let ((x (vector rte #f)))
+      (vector-set! x 1 (val1 x))
+      (body x))))
+
+(define (gen-letrec-2 val1 val2 body)
+  (lambda (rte)
+    (let ((x (vector rte #f #f)))
+      (vector-set! x 1 (val1 x))
+      (vector-set! x 2 (val2 x))
+      (body x))))
+
+(define (gen-letrec-3 val1 val2 val3 body)
+  (lambda (rte)
+    (let ((x (vector rte #f #f #f)))
+      (vector-set! x 1 (val1 x))
+      (vector-set! x 2 (val2 x))
+      (vector-set! x 3 (val3 x))
+      (body x))))
+
+(define (gen-letrec-n nb-vals vals body)
+  (lambda (rte)
+    (let ((x (make-vector (+ nb-vals 1))))
+      (vector-set! x 0 rte)
+      (let loop ((x x) (i 1) (l vals))
+        (if (pair? l)
+          (begin (vector-set! x i ((car l) x)) (loop x (+ i 1) (cdr l)))))
+      (body x))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-macro name proc)
+  (lambda (rte) (scheme-add-macro name proc)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-combination oper args)
+  (case (length args)
+    ((0)  (gen-combination-0 oper))
+    ((1)  (gen-combination-1 oper (car args)))
+    ((2)  (gen-combination-2 oper (car args) (cadr args)))
+    ((3)  (gen-combination-3 oper (car args) (cadr args) (caddr args)))
+    (else (gen-combination-n oper args))))
+
+(define (gen-combination-0 oper)
+  (lambda (rte) ((oper rte))))
+
+(define (gen-combination-1 oper arg1)
+  (lambda (rte) ((oper rte) (arg1 rte))))
+
+(define (gen-combination-2 oper arg1 arg2)
+  (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte))))
+
+(define (gen-combination-3 oper arg1 arg2 arg3)
+  (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte) (arg3 rte))))
+
+(define (gen-combination-n oper args)
+  (lambda (rte)
+    (define (evaluate l rte)
+      (if (pair? l)
+        (cons ((car l) rte) (evaluate (cdr l) rte))
+        '()))
+    (apply (oper rte) (evaluate args rte))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (scheme-comp expr env)
+  (cond ((symbol? expr)
+         (comp-var expr env))
+        ((not (pair? expr))
+         (comp-self-eval expr env))
+        ((macro? (car expr) env)
+         (scheme-comp (macro-expand expr env) env))
+        (else
+         (cond
+           ((eq? (car expr) 'quote)            (comp-quote expr env))
+           ((eq? (car expr) 'quasiquote)       (comp-quasiquote expr env))
+           ((eq? (car expr) 'unquote)          (comp-unquote expr env))
+           ((eq? (car expr) 'unquote-splicing) (comp-unquote-splicing expr env))
+           ((eq? (car expr) 'set!)             (comp-set! expr env))
+           ((eq? (car expr) 'lambda)           (comp-lambda expr env))
+           ((eq? (car expr) 'if)               (comp-if expr env))
+           ((eq? (car expr) 'cond)             (comp-cond expr env))
+           ((eq? (car expr) 'and)              (comp-and expr env))
+           ((eq? (car expr) 'or)               (comp-or expr env))
+           ((eq? (car expr) 'case)             (comp-case expr env))
+           ((eq? (car expr) 'let)              (comp-let expr env))
+           ((eq? (car expr) 'let*)             (comp-let* expr env))
+           ((eq? (car expr) 'letrec)           (comp-letrec expr env))
+           ((eq? (car expr) 'begin)            (comp-begin expr env))
+           ((eq? (car expr) 'do)               (comp-do expr env))
+           ((eq? (car expr) 'define)           (comp-define expr env))
+           ((eq? (car expr) 'define-macro)     (comp-define-macro expr env))
+           (else                               (comp-combination expr env))))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (scheme-global-var name)
+  (let ((x (assq name scheme-global-variables)))
+    (if x
+      x
+      (let ((y (cons name '())))
+        (set! scheme-global-variables (cons y scheme-global-variables))
+        y))))
+
+(define (scheme-global-var-ref i)
+  (cdr i))
+
+(define (scheme-global-var-set! i val)
+  (set-cdr! i val)
+  '())
+
+(define scheme-global-variables '())
+
+(define (def-proc name value)
+  (scheme-global-var-set!
+    (scheme-global-var name)
+    value))
+
+(define nothing
+  (begin
+(def-proc 'not                            (lambda (x) (not x)))
+(def-proc 'boolean?                       boolean?)
+(def-proc 'eqv?                           eqv?)
+(def-proc 'eq?                            eq?)
+(def-proc 'equal?                         equal?)
+(def-proc 'pair?                          (lambda (obj) (pair? obj)))
+(def-proc 'cons                           (lambda (x y) (cons x y)))
+(def-proc 'car                            (lambda (x) (car x)))
+(def-proc 'cdr                            (lambda (x) (cdr x)))
+(def-proc 'set-car!                       set-car!)
+(def-proc 'set-cdr!                       set-cdr!)
+(def-proc 'caar                           caar)
+(def-proc 'cadr                           cadr)
+(def-proc 'cdar                           cdar)
+(def-proc 'cddr                           cddr)
+(def-proc 'caaar                          caaar)
+(def-proc 'caadr                          caadr)
+(def-proc 'cadar                          cadar)
+(def-proc 'caddr                          caddr)
+(def-proc 'cdaar                          cdaar)
+(def-proc 'cdadr                          cdadr)
+(def-proc 'cddar                          cddar)
+(def-proc 'cdddr                          cdddr)
+(def-proc 'caaaar                         caaaar)
+(def-proc 'caaadr                         caaadr)
+(def-proc 'caadar                         caadar)
+(def-proc 'caaddr                         caaddr)
+(def-proc 'cadaar                         cadaar)
+(def-proc 'cadadr                         cadadr)
+(def-proc 'caddar                         caddar)
+(def-proc 'cadddr                         cadddr)
+(def-proc 'cdaaar                         cdaaar)
+(def-proc 'cdaadr                         cdaadr)
+(def-proc 'cdadar                         cdadar)
+(def-proc 'cdaddr                         cdaddr)
+(def-proc 'cddaar                         cddaar)
+(def-proc 'cddadr                         cddadr)
+(def-proc 'cdddar                         cdddar)
+(def-proc 'cddddr                         cddddr)
+(def-proc 'null?                          (lambda (x) (null? x)))
+(def-proc 'list?                          list?)
+(def-proc 'list                           list)
+(def-proc 'length                         length)
+(def-proc 'append                         append)
+(def-proc 'reverse                        reverse)
+(def-proc 'list-ref                       list-ref)
+(def-proc 'memq                           memq)
+(def-proc 'memv                           memv)
+(def-proc 'member                         member)
+(def-proc 'assq                           assq)
+(def-proc 'assv                           assv)
+(def-proc 'assoc                          assoc)
+(def-proc 'symbol?                        symbol?)
+(def-proc 'symbol->string                 symbol->string)
+(def-proc 'string->symbol                 string->symbol)
+(def-proc 'number?                        number?)
+(def-proc 'complex?                       complex?)
+(def-proc 'real?                          real?)
+(def-proc 'rational?                      rational?)
+(def-proc 'integer?                       integer?)
+(def-proc 'exact?                         exact?)
+(def-proc 'inexact?                       inexact?)
+;(def-proc '=                              =)
+;(def-proc '<                              <)
+;(def-proc '>                              >)
+;(def-proc '<=                             <=)
+;(def-proc '>=                             >=)
+;(def-proc 'zero?                          zero?)
+;(def-proc 'positive?                      positive?)
+;(def-proc 'negative?                      negative?)
+;(def-proc 'odd?                           odd?)
+;(def-proc 'even?                          even?)
+(def-proc 'max                            max)
+(def-proc 'min                            min)
+;(def-proc '+                              +)
+;(def-proc '*                              *)
+;(def-proc '-                              -)
+(def-proc '/                              /)
+(def-proc 'abs                            abs)
+;(def-proc 'quotient                       quotient)
+;(def-proc 'remainder                      remainder)
+;(def-proc 'modulo                         modulo)
+(def-proc 'gcd                            gcd)
+(def-proc 'lcm                            lcm)
+;(def-proc 'numerator                      numerator)
+;(def-proc 'denominator                    denominator)
+(def-proc 'floor                          floor)
+(def-proc 'ceiling                        ceiling)
+(def-proc 'truncate                       truncate)
+(def-proc 'round                          round)
+;(def-proc 'rationalize                    rationalize)
+(def-proc 'exp                            exp)
+(def-proc 'log                            log)
+(def-proc 'sin                            sin)
+(def-proc 'cos                            cos)
+(def-proc 'tan                            tan)
+(def-proc 'asin                           asin)
+(def-proc 'acos                           acos)
+(def-proc 'atan                           atan)
+(def-proc 'sqrt                           sqrt)
+(def-proc 'expt                           expt)
+;(def-proc 'make-rectangular               make-rectangular)
+;(def-proc 'make-polar                     make-polar)
+;(def-proc 'real-part                      real-part)
+;(def-proc 'imag-part                      imag-part)
+;(def-proc 'magnitude                      magnitude)
+;(def-proc 'angle                          angle)
+(def-proc 'exact->inexact                 exact->inexact)
+(def-proc 'inexact->exact                 inexact->exact)
+(def-proc 'number->string                 number->string)
+(def-proc 'string->number                 string->number)
+(def-proc 'char?                          char?)
+(def-proc 'char=?                         char=?)
+(def-proc 'char<?                         char<?)
+(def-proc 'char>?                         char>?)
+(def-proc 'char<=?                        char<=?)
+(def-proc 'char>=?                        char>=?)
+(def-proc 'char-ci=?                      char-ci=?)
+(def-proc 'char-ci<?                      char-ci<?)
+(def-proc 'char-ci>?                      char-ci>?)
+(def-proc 'char-ci<=?                     char-ci<=?)
+(def-proc 'char-ci>=?                     char-ci>=?)
+(def-proc 'char-alphabetic?               char-alphabetic?)
+(def-proc 'char-numeric?                  char-numeric?)
+(def-proc 'char-whitespace?               char-whitespace?)
+(def-proc 'char-lower-case?               char-lower-case?)
+(def-proc 'char->integer                  char->integer)
+(def-proc 'integer->char                  integer->char)
+(def-proc 'char-upcase                    char-upcase)
+(def-proc 'char-downcase                  char-downcase)
+(def-proc 'string?                        string?)
+(def-proc 'make-string                    make-string)
+(def-proc 'string                         string)
+(def-proc 'string-length                  string-length)
+(def-proc 'string-ref                     string-ref)
+(def-proc 'string-set!                    string-set!)
+(def-proc 'string=?                       string=?)
+(def-proc 'string<?                       string<?)
+(def-proc 'string>?                       string>?)
+(def-proc 'string<=?                      string<=?)
+(def-proc 'string>=?                      string>=?)
+(def-proc 'string-ci=?                    string-ci=?)
+(def-proc 'string-ci<?                    string-ci<?)
+(def-proc 'string-ci>?                    string-ci>?)
+(def-proc 'string-ci<=?                   string-ci<=?)
+(def-proc 'string-ci>=?                   string-ci>=?)
+(def-proc 'substring                      substring)
+(def-proc 'string-append                  string-append)
+(def-proc 'vector?                        vector?)
+(def-proc 'make-vector                    make-vector)
+(def-proc 'vector                         vector)
+(def-proc 'vector-length                  vector-length)
+(def-proc 'vector-ref                     vector-ref)
+(def-proc 'vector-set!                    vector-set!)
+(def-proc 'procedure?                     procedure?)
+(def-proc 'apply                          apply)
+(def-proc 'map                            map)
+(def-proc 'for-each                       for-each)
+;(def-proc 'call-with-current-continuation call-with-current-continuation)
+(def-proc 'call-with-input-file           call-with-input-file)
+(def-proc 'call-with-output-file          call-with-output-file)
+(def-proc 'input-port?                    input-port?)
+(def-proc 'output-port?                   output-port?)
+(def-proc 'current-input-port             current-input-port)
+(def-proc 'current-output-port            current-output-port)
+(def-proc 'open-input-file                open-input-file)
+(def-proc 'open-output-file               open-output-file)
+(def-proc 'close-input-port               close-input-port)
+(def-proc 'close-output-port              close-output-port)
+(def-proc 'eof-object?                    eof-object?)
+(def-proc 'read                           read)
+(def-proc 'read-char                      read-char)
+(def-proc 'peek-char                      peek-char)
+(def-proc 'write                          write)
+(def-proc 'display                        display)
+(def-proc 'newline                        newline)
+(def-proc 'write-char                     write-char)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define expr1
+  '(let ()
+
+     (define (sort-list obj pred)
+
+       (define (loop l)
+         (if (and (pair? l) (pair? (cdr l)))
+             (split l '() '())
+             l))
+
+       (define (split l one two)
+         (if (pair? l)
+             (split (cdr l) two (cons (car l) one))
+             (merge (loop one) (loop two))))
+
+       (define (merge one two)
+         (cond ((null? one) two)
+               ((pred (car two) (car one))
+                (cons (car two)
+                      (merge (cdr two) one)))
+               (else
+                (cons (car one)
+                      (merge (cdr one) two)))))
+
+       (loop obj))
+
+     (sort-list '("one" "two" "three" "four" "five" "six"
+                  "seven" "eight" "nine" "ten" "eleven" "twelve")
+                string<?)))
+
+
+(let ((input (with-input-from-file "input.txt" read)))
+  (time
+   (let loop ((n 3000) (v 0))
+     (if (zero? n)
+         v
+         (loop (- n 1) (scheme-eval (if input expr1 '(+ 1 2))))))))
diff --git a/benchmarks/gabriel/scheme2.sch b/benchmarks/gabriel/scheme2.sch
new file mode 100644
index 00000000..934b5783
--- /dev/null
+++ b/benchmarks/gabriel/scheme2.sch
@@ -0,0 +1,1083 @@
+;; Like "scheme.ss", but avoids `set-cdr!'. The main change is that
+;;  a global variable is a 1-slot vector instead of a pair. (The
+;;  name of the global variable isn't needed at run time.)
+
+;;; SCHEME -- A Scheme interpreter evaluating a sort, written by Marc Feeley.
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (scheme-eval expr)
+  (let ((code (scheme-comp expr scheme-global-environment)))
+    (code #f)))
+
+(define scheme-global-environment
+  (cons '()   ; environment chain
+        '())) ; macros
+
+(define (scheme-add-macro name proc)
+  (set! scheme-global-environment
+        (cons
+         (car scheme-global-environment)
+         (cons (cons name proc) (cdr scheme-global-environment))))
+  name)
+
+(define (scheme-error msg . args)
+  'error)
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (lst->vector l)
+  (let* ((n (length l))
+         (v (make-vector n)))
+    (let loop ((l l) (i 0))
+      (if (pair? l)
+        (begin
+          (vector-set! v i (car l))
+          (loop (cdr l) (+ i 1)))
+        v))))
+
+(define (vector->lst v)
+  (let loop ((l '()) (i (- (vector-length v) 1)))
+    (if (< i 0)
+      l
+      (loop (cons (vector-ref v i) l) (- i 1)))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define scheme-syntactic-keywords
+  '(quote quasiquote unquote unquote-splicing
+    lambda if set! cond => else and or
+    case let let* letrec begin do define
+    define-macro))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (push-frame frame env)
+  (if (null? frame)
+    env
+    (cons (cons (car env) frame) (cdr env))))
+
+(define (lookup-var name env)
+  (let loop1 ((chain (car env)) (up 0))
+    (if (null? chain)
+      name
+      (let loop2 ((chain chain)
+                  (up up)
+                  (frame (cdr chain))
+                  (over 1))
+        (cond ((null? frame)
+               (loop1 (car chain) (+ up 1)))
+              ((eq? (car frame) name)
+               (cons up over))
+              (else
+               (loop2 chain up (cdr frame) (+ over 1))))))))
+
+(define (macro? name env)
+  (assq name (cdr env)))
+
+(define (push-macro name proc env)
+  (cons (car env) (cons (cons name proc) (cdr env))))
+
+(define (lookup-macro name env)
+  (cdr (assq name (cdr env))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (variable x)
+  (if (not (symbol? x))
+    (scheme-error "Identifier expected" x))
+  (if (memq x scheme-syntactic-keywords)
+    (scheme-error "Variable name can not be a syntactic keyword" x)))
+
+(define (shape form n)
+  (let loop ((form form) (n n) (l form))
+    (cond ((<= n 0))
+          ((pair? l)
+           (loop form (- n 1) (cdr l)))
+          (else
+           (scheme-error "Ill-constructed form" form)))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (macro-expand expr env)
+  (apply (lookup-macro (car expr) env) (cdr expr)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-var expr env)
+  (variable expr)
+  (gen-var-ref (lookup-var expr env)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-self-eval expr env)
+  (gen-cst expr))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-quote expr env)
+  (shape expr 2)
+  (gen-cst (cadr expr)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-quasiquote expr env)
+  (comp-quasiquotation (cadr expr) 1 env))
+
+(define (comp-quasiquotation form level env)
+  (cond ((= level 0)
+         (scheme-comp form env))
+        ((pair? form)
+         (cond
+           ((eq? (car form) 'quasiquote)
+            (comp-quasiquotation-list form (+ level 1) env))
+           ((eq? (car form) 'unquote)
+            (if (= level 1)
+              (scheme-comp (cadr form) env)
+              (comp-quasiquotation-list form (- level 1) env)))
+           ((eq? (car form) 'unquote-splicing)
+            (if (= level 1)
+              (scheme-error "Ill-placed 'unquote-splicing'" form))
+            (comp-quasiquotation-list form (- level 1) env))
+           (else
+            (comp-quasiquotation-list form level env))))
+        ((vector? form)
+         (gen-vector-form
+           (comp-quasiquotation-list (vector->lst form) level env)))
+        (else
+         (gen-cst form))))
+
+(define (comp-quasiquotation-list l level env)
+  (if (pair? l)
+    (let ((first (car l)))
+      (if (= level 1)
+        (if (unquote-splicing? first)
+          (begin
+            (shape first 2)
+            (gen-append-form (scheme-comp (cadr first) env)
+                             (comp-quasiquotation (cdr l) 1 env)))
+          (gen-cons-form (comp-quasiquotation first level env)
+                         (comp-quasiquotation (cdr l) level env)))
+        (gen-cons-form (comp-quasiquotation first level env)
+                       (comp-quasiquotation (cdr l) level env))))
+    (comp-quasiquotation l level env)))
+
+(define (unquote-splicing? x)
+  (if (pair? x)
+    (if (eq? (car x) 'unquote-splicing) #t #f)
+    #f))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-unquote expr env)
+  (scheme-error "Ill-placed 'unquote'" expr))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-unquote-splicing expr env)
+  (scheme-error "Ill-placed 'unquote-splicing'" expr))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-set! expr env)
+  (shape expr 3)
+  (variable (cadr expr))
+  (gen-var-set (lookup-var (cadr expr) env) (scheme-comp (caddr expr) env)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-lambda expr env)
+  (shape expr 3)
+  (let ((parms (cadr expr)))
+    (let ((frame (parms->frame parms)))
+      (let ((nb-vars (length frame))
+            (code (comp-body (cddr expr) (push-frame frame env))))
+        (if (rest-param? parms)
+          (gen-lambda-rest nb-vars code)
+          (gen-lambda nb-vars code))))))
+
+(define (parms->frame parms)
+  (cond ((null? parms)
+         '())
+        ((pair? parms)
+         (let ((x (car parms)))
+           (variable x)
+           (cons x (parms->frame (cdr parms)))))
+        (else
+         (variable parms)
+         (list parms))))
+
+(define (rest-param? parms)
+  (cond ((pair? parms)
+         (rest-param? (cdr parms)))
+        ((null? parms)
+         #f)
+        (else
+         #t)))
+
+(define (comp-body body env)
+
+  (define (letrec-defines vars vals body env)
+    (if (pair? body)
+
+      (let ((expr (car body)))
+        (cond ((not (pair? expr))
+               (letrec-defines* vars vals body env))
+              ((macro? (car expr) env)
+               (letrec-defines vars
+                               vals
+                               (cons (macro-expand expr env) (cdr body))
+                               env))
+              (else
+               (cond
+                 ((eq? (car expr) 'begin)
+                  (letrec-defines vars
+                                  vals
+                                  (append (cdr expr) (cdr body))
+                                  env))
+                 ((eq? (car expr) 'define)
+                  (let ((x (definition-name expr)))
+                    (variable x)
+                    (letrec-defines (cons x vars)
+                                    (cons (definition-value expr) vals)
+                                    (cdr body)
+                                    env)))
+                 ((eq? (car expr) 'define-macro)
+                  (let ((x (definition-name expr)))
+                    (letrec-defines vars
+                                    vals
+                                    (cdr body)
+                                    (push-macro
+                                      x
+                                      (scheme-eval (definition-value expr))
+                                      env))))
+                 (else
+                  (letrec-defines* vars vals body env))))))
+
+      (scheme-error "Body must contain at least one evaluable expression")))
+
+  (define (letrec-defines* vars vals body env)
+    (if (null? vars)
+      (comp-sequence body env)
+      (comp-letrec-aux vars vals body env)))
+
+  (letrec-defines '() '() body env))
+
+(define (definition-name expr)
+  (shape expr 3)
+  (let ((pattern (cadr expr)))
+    (let ((name (if (pair? pattern) (car pattern) pattern)))
+      (if (not (symbol? name))
+        (scheme-error "Identifier expected" name))
+      name)))
+
+(define (definition-value expr)
+  (let ((pattern (cadr expr)))
+    (if (pair? pattern)
+      (cons 'lambda (cons (cdr pattern) (cddr expr)))
+      (caddr expr))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-if expr env)
+  (shape expr 3)
+  (let ((code1 (scheme-comp (cadr expr) env))
+        (code2 (scheme-comp (caddr expr) env)))
+    (if (pair? (cdddr expr))
+      (gen-if code1 code2 (scheme-comp (cadddr expr) env))
+      (gen-when code1 code2))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-cond expr env)
+  (comp-cond-aux (cdr expr) env))
+
+(define (comp-cond-aux clauses env)
+  (if (pair? clauses)
+    (let ((clause (car clauses)))
+      (shape clause 1)
+      (cond ((eq? (car clause) 'else)
+             (shape clause 2)
+             (comp-sequence (cdr clause) env))
+            ((not (pair? (cdr clause)))
+             (gen-or (scheme-comp (car clause) env)
+                     (comp-cond-aux (cdr clauses) env)))
+            ((eq? (cadr clause) '=>)
+             (shape clause 3)
+             (gen-cond-send (scheme-comp (car clause) env)
+                            (scheme-comp (caddr clause) env)
+                            (comp-cond-aux (cdr clauses) env)))
+            (else
+             (gen-if (scheme-comp (car clause) env)
+                     (comp-sequence (cdr clause) env)
+                     (comp-cond-aux (cdr clauses) env)))))
+    (gen-cst '())))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-and expr env)
+  (let ((rest (cdr expr)))
+    (if (pair? rest) (comp-and-aux rest env) (gen-cst #t))))
+
+(define (comp-and-aux l env)
+  (let ((code (scheme-comp (car l) env))
+        (rest (cdr l)))
+    (if (pair? rest) (gen-and code (comp-and-aux rest env)) code)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-or expr env)
+  (let ((rest (cdr expr)))
+    (if (pair? rest) (comp-or-aux rest env) (gen-cst #f))))
+
+(define (comp-or-aux l env)
+  (let ((code (scheme-comp (car l) env))
+        (rest (cdr l)))
+    (if (pair? rest) (gen-or code (comp-or-aux rest env)) code)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-case expr env)
+  (shape expr 3)
+  (gen-case (scheme-comp (cadr expr) env)
+            (comp-case-aux (cddr expr) env)))
+
+(define (comp-case-aux clauses env)
+  (if (pair? clauses)
+    (let ((clause (car clauses)))
+      (shape clause 2)
+      (if (eq? (car clause) 'else)
+        (gen-case-else (comp-sequence (cdr clause) env))
+        (gen-case-clause (car clause)
+                         (comp-sequence (cdr clause) env)
+                         (comp-case-aux (cdr clauses) env))))
+    (gen-case-else (gen-cst '()))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-let expr env)
+  (shape expr 3)
+  (let ((x (cadr expr)))
+    (cond ((symbol? x)
+           (shape expr 4)
+           (let ((y (caddr expr)))
+             (let ((proc (cons 'lambda (cons (bindings->vars y) (cdddr expr)))))
+               (scheme-comp (cons (list 'letrec (list (list x proc)) x)
+                                  (bindings->vals y))
+                            env))))
+          ((pair? x)
+           (scheme-comp (cons (cons 'lambda (cons (bindings->vars x) (cddr expr)))
+                              (bindings->vals x))
+                        env))
+          (else
+           (comp-body (cddr expr) env)))))
+
+(define (bindings->vars bindings)
+  (if (pair? bindings)
+    (let ((binding (car bindings)))
+      (shape binding 2)
+      (let ((x (car binding)))
+        (variable x)
+        (cons x (bindings->vars (cdr bindings)))))
+    '()))
+
+(define (bindings->vals bindings)
+  (if (pair? bindings)
+    (let ((binding (car bindings)))
+      (cons (cadr binding) (bindings->vals (cdr bindings))))
+    '()))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-let* expr env)
+  (shape expr 3)
+  (let ((bindings (cadr expr)))
+    (if (pair? bindings)
+      (scheme-comp (list 'let
+                         (list (car bindings))
+                         (cons 'let* (cons (cdr bindings) (cddr expr))))
+                   env)
+      (comp-body (cddr expr) env))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-letrec expr env)
+  (shape expr 3)
+  (let ((bindings (cadr expr)))
+    (comp-letrec-aux (bindings->vars bindings)
+                     (bindings->vals bindings)
+                     (cddr expr)
+                     env)))
+
+(define (comp-letrec-aux vars vals body env)
+  (if (pair? vars)
+    (let ((new-env (push-frame vars env)))
+      (gen-letrec (comp-vals vals new-env)
+                  (comp-body body new-env)))
+    (comp-body body env)))
+
+(define (comp-vals l env)
+  (if (pair? l)
+    (cons (scheme-comp (car l) env) (comp-vals (cdr l) env))
+    '()))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-begin expr env)
+  (shape expr 2)
+  (comp-sequence (cdr expr) env))
+
+(define (comp-sequence exprs env)
+  (if (pair? exprs)
+    (comp-sequence-aux exprs env)
+    (gen-cst '())))
+
+(define (comp-sequence-aux exprs env)
+  (let ((code (scheme-comp (car exprs) env))
+        (rest (cdr exprs)))
+    (if (pair? rest) (gen-sequence code (comp-sequence-aux rest env)) code)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-do expr env)
+  (shape expr 3)
+  (let ((bindings (cadr expr))
+        (exit (caddr expr)))
+    (shape exit 1)
+    (let* ((vars (bindings->vars bindings))
+           (new-env1 (push-frame '(#f) env))
+           (new-env2 (push-frame vars new-env1)))
+      (gen-letrec
+        (list
+          (gen-lambda
+            (length vars)
+            (gen-if
+              (scheme-comp (car exit) new-env2)
+              (comp-sequence (cdr exit) new-env2)
+              (gen-sequence
+                (comp-sequence (cdddr expr) new-env2)
+                (gen-combination
+                  (gen-var-ref '(1 . 1))
+                  (comp-vals (bindings->steps bindings) new-env2))))))
+        (gen-combination
+          (gen-var-ref '(0 . 1))
+          (comp-vals (bindings->vals bindings) new-env1))))))
+
+(define (bindings->steps bindings)
+  (if (pair? bindings)
+    (let ((binding (car bindings)))
+      (cons (if (pair? (cddr binding)) (caddr binding) (car binding))
+            (bindings->steps (cdr bindings))))
+    '()))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-define expr env)
+  (shape expr 3)
+  (let ((pattern (cadr expr)))
+    (let ((x (if (pair? pattern) (car pattern) pattern)))
+      (variable x)
+      (gen-sequence
+        (gen-var-set (lookup-var x env)
+                     (scheme-comp (if (pair? pattern)
+                                    (cons 'lambda (cons (cdr pattern) (cddr expr)))
+                                    (caddr expr))
+                                  env))
+        (gen-cst x)))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-define-macro expr env)
+  (let ((x (definition-name expr)))
+    (gen-macro x (scheme-eval (definition-value expr)))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (comp-combination expr env)
+  (gen-combination (scheme-comp (car expr) env) (comp-vals (cdr expr) env)))
+
+;------------------------------------------------------------------------------
+
+(define (gen-var-ref var)
+  (if (pair? var)
+    (gen-rte-ref (car var) (cdr var))
+    (gen-glo-ref (scheme-global-var var))))
+
+(define (gen-rte-ref up over)
+  (case up
+    ((0)  (gen-slot-ref-0 over))
+    ((1)  (gen-slot-ref-1 over))
+    (else (gen-slot-ref-up-2 (gen-rte-ref (- up 2) over)))))
+
+(define (gen-slot-ref-0 i)
+  (case i
+    ((0)  (lambda (rte) (vector-ref rte 0)))
+    ((1)  (lambda (rte) (vector-ref rte 1)))
+    ((2)  (lambda (rte) (vector-ref rte 2)))
+    ((3)  (lambda (rte) (vector-ref rte 3)))
+    (else (lambda (rte) (vector-ref rte i)))))
+
+(define (gen-slot-ref-1 i)
+  (case i
+    ((0)  (lambda (rte) (vector-ref (vector-ref rte 0) 0)))
+    ((1)  (lambda (rte) (vector-ref (vector-ref rte 0) 1)))
+    ((2)  (lambda (rte) (vector-ref (vector-ref rte 0) 2)))
+    ((3)  (lambda (rte) (vector-ref (vector-ref rte 0) 3)))
+    (else (lambda (rte) (vector-ref (vector-ref rte 0) i)))))
+
+(define (gen-slot-ref-up-2 code)
+  (lambda (rte) (code (vector-ref (vector-ref rte 0) 0))))
+
+(define (gen-glo-ref i)
+  (lambda (rte) (scheme-global-var-ref i)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-cst val)
+  (case val
+    ((()) (lambda (rte) '()))
+    ((#f) (lambda (rte) #f))
+    ((#t) (lambda (rte) #t))
+    ((-2) (lambda (rte) -2))
+    ((-1) (lambda (rte) -1))
+    ((0)  (lambda (rte) 0))
+    ((1)  (lambda (rte) 1))
+    ((2)  (lambda (rte) 2))
+    (else (lambda (rte) val))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-append-form code1 code2)
+  (lambda (rte) (append (code1 rte) (code2 rte))))
+
+(define (gen-cons-form code1 code2)
+  (lambda (rte) (cons (code1 rte) (code2 rte))))
+
+(define (gen-vector-form code)
+  (lambda (rte) (lst->vector (code rte))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-var-set var code)
+  (if (pair? var)
+    (gen-rte-set (car var) (cdr var) code)
+    (gen-glo-set (scheme-global-var var) code)))
+
+(define (gen-rte-set up over code)
+  (case up
+    ((0)  (gen-slot-set-0 over code))
+    ((1)  (gen-slot-set-1 over code))
+    (else (gen-slot-set-n (gen-rte-ref (- up 2) 0) over code))))
+
+(define (gen-slot-set-0 i code)
+  (case i
+    ((0)  (lambda (rte) (vector-set! rte 0 (code rte))))
+    ((1)  (lambda (rte) (vector-set! rte 1 (code rte))))
+    ((2)  (lambda (rte) (vector-set! rte 2 (code rte))))
+    ((3)  (lambda (rte) (vector-set! rte 3 (code rte))))
+    (else (lambda (rte) (vector-set! rte i (code rte))))))
+
+(define (gen-slot-set-1 i code)
+  (case i
+    ((0)  (lambda (rte) (vector-set! (vector-ref rte 0) 0 (code rte))))
+    ((1)  (lambda (rte) (vector-set! (vector-ref rte 0) 1 (code rte))))
+    ((2)  (lambda (rte) (vector-set! (vector-ref rte 0) 2 (code rte))))
+    ((3)  (lambda (rte) (vector-set! (vector-ref rte 0) 3 (code rte))))
+    (else (lambda (rte) (vector-set! (vector-ref rte 0) i (code rte))))))
+
+(define (gen-slot-set-n up i code)
+  (case i
+    ((0)  (lambda (rte) (vector-set! (up (vector-ref rte 0)) 0 (code rte))))
+    ((1)  (lambda (rte) (vector-set! (up (vector-ref rte 0)) 1 (code rte))))
+    ((2)  (lambda (rte) (vector-set! (up (vector-ref rte 0)) 2 (code rte))))
+    ((3)  (lambda (rte) (vector-set! (up (vector-ref rte 0)) 3 (code rte))))
+    (else (lambda (rte) (vector-set! (up (vector-ref rte 0)) i (code rte))))))
+
+(define (gen-glo-set i code)
+  (lambda (rte) (scheme-global-var-set! i (code rte))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-lambda-rest nb-vars body)
+  (case nb-vars
+    ((1)  (gen-lambda-1-rest body))
+    ((2)  (gen-lambda-2-rest body))
+    ((3)  (gen-lambda-3-rest body))
+    (else (gen-lambda-n-rest nb-vars body))))
+
+(define (gen-lambda-1-rest body)
+  (lambda (rte)
+    (lambda a
+      (body (vector rte a)))))
+
+(define (gen-lambda-2-rest body)
+  (lambda (rte)
+    (lambda (a . b)
+      (body (vector rte a b)))))
+
+(define (gen-lambda-3-rest body)
+  (lambda (rte)
+    (lambda (a b . c)
+      (body (vector rte a b c)))))
+
+(define (gen-lambda-n-rest nb-vars body)
+  (lambda (rte)
+    (lambda (a b c . d)
+      (let ((x (make-vector (+ nb-vars 1))))
+        (vector-set! x 0 rte)
+        (vector-set! x 1 a)
+        (vector-set! x 2 b)
+        (vector-set! x 3 c)
+        (let loop ((n nb-vars) (x x) (i 4) (l d))
+          (if (< i n)
+            (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l)))
+            (vector-set! x i l)))
+        (body x)))))
+
+(define (gen-lambda nb-vars body)
+  (case nb-vars
+    ((0)  (gen-lambda-0 body))
+    ((1)  (gen-lambda-1 body))
+    ((2)  (gen-lambda-2 body))
+    ((3)  (gen-lambda-3 body))
+    (else (gen-lambda-n nb-vars body))))
+
+(define (gen-lambda-0 body)
+  (lambda (rte)
+    (lambda ()
+      (body rte))))
+
+(define (gen-lambda-1 body)
+  (lambda (rte)
+    (lambda (a)
+      (body (vector rte a)))))
+
+(define (gen-lambda-2 body)
+  (lambda (rte)
+    (lambda (a b)
+      (body (vector rte a b)))))
+
+(define (gen-lambda-3 body)
+  (lambda (rte)
+    (lambda (a b c)
+      (body (vector rte a b c)))))
+
+(define (gen-lambda-n nb-vars body)
+  (lambda (rte)
+    (lambda (a b c . d)
+      (let ((x (make-vector (+ nb-vars 1))))
+        (vector-set! x 0 rte)
+        (vector-set! x 1 a)
+        (vector-set! x 2 b)
+        (vector-set! x 3 c)
+        (let loop ((n nb-vars) (x x) (i 4) (l d))
+          (if (<= i n)
+            (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l)))))
+        (body x)))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-sequence code1 code2)
+  (lambda (rte) (code1 rte) (code2 rte)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-when code1 code2)
+  (lambda (rte)
+    (if (code1 rte)
+      (code2 rte)
+      '())))
+
+(define (gen-if code1 code2 code3)
+  (lambda (rte)
+    (if (code1 rte)
+      (code2 rte)
+      (code3 rte))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-cond-send code1 code2 code3)
+  (lambda (rte)
+    (let ((temp (code1 rte)))
+      (if temp
+        ((code2 rte) temp)
+        (code3 rte)))))
+              
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-and code1 code2)
+  (lambda (rte)
+    (let ((temp (code1 rte)))
+      (if temp
+        (code2 rte)
+        temp))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-or code1 code2)
+  (lambda (rte)
+    (let ((temp (code1 rte)))
+      (if temp
+        temp
+        (code2 rte)))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-case code1 code2)
+  (lambda (rte) (code2 rte (code1 rte))))
+
+(define (gen-case-clause datums code1 code2)
+  (lambda (rte key) (if (memv key datums) (code1 rte) (code2 rte key))))
+
+(define (gen-case-else code)
+  (lambda (rte key) (code rte)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-letrec vals body)
+  (let ((nb-vals (length vals)))
+    (case nb-vals
+      ((1)  (gen-letrec-1 (car vals) body))
+      ((2)  (gen-letrec-2 (car vals) (cadr vals) body))
+      ((3)  (gen-letrec-3 (car vals) (cadr vals) (caddr vals) body))
+      (else (gen-letrec-n nb-vals vals body)))))
+
+(define (gen-letrec-1 val1 body)
+  (lambda (rte)
+    (let ((x (vector rte #f)))
+      (vector-set! x 1 (val1 x))
+      (body x))))
+
+(define (gen-letrec-2 val1 val2 body)
+  (lambda (rte)
+    (let ((x (vector rte #f #f)))
+      (vector-set! x 1 (val1 x))
+      (vector-set! x 2 (val2 x))
+      (body x))))
+
+(define (gen-letrec-3 val1 val2 val3 body)
+  (lambda (rte)
+    (let ((x (vector rte #f #f #f)))
+      (vector-set! x 1 (val1 x))
+      (vector-set! x 2 (val2 x))
+      (vector-set! x 3 (val3 x))
+      (body x))))
+
+(define (gen-letrec-n nb-vals vals body)
+  (lambda (rte)
+    (let ((x (make-vector (+ nb-vals 1))))
+      (vector-set! x 0 rte)
+      (let loop ((x x) (i 1) (l vals))
+        (if (pair? l)
+          (begin (vector-set! x i ((car l) x)) (loop x (+ i 1) (cdr l)))))
+      (body x))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-macro name proc)
+  (lambda (rte) (scheme-add-macro name proc)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (gen-combination oper args)
+  (case (length args)
+    ((0)  (gen-combination-0 oper))
+    ((1)  (gen-combination-1 oper (car args)))
+    ((2)  (gen-combination-2 oper (car args) (cadr args)))
+    ((3)  (gen-combination-3 oper (car args) (cadr args) (caddr args)))
+    (else (gen-combination-n oper args))))
+
+(define (gen-combination-0 oper)
+  (lambda (rte) ((oper rte))))
+
+(define (gen-combination-1 oper arg1)
+  (lambda (rte) ((oper rte) (arg1 rte))))
+
+(define (gen-combination-2 oper arg1 arg2)
+  (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte))))
+
+(define (gen-combination-3 oper arg1 arg2 arg3)
+  (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte) (arg3 rte))))
+
+(define (gen-combination-n oper args)
+  (lambda (rte)
+    (define (evaluate l rte)
+      (if (pair? l)
+        (cons ((car l) rte) (evaluate (cdr l) rte))
+        '()))
+    (apply (oper rte) (evaluate args rte))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (scheme-comp expr env)
+  (cond ((symbol? expr)
+         (comp-var expr env))
+        ((not (pair? expr))
+         (comp-self-eval expr env))
+        ((macro? (car expr) env)
+         (scheme-comp (macro-expand expr env) env))
+        (else
+         (cond
+           ((eq? (car expr) 'quote)            (comp-quote expr env))
+           ((eq? (car expr) 'quasiquote)       (comp-quasiquote expr env))
+           ((eq? (car expr) 'unquote)          (comp-unquote expr env))
+           ((eq? (car expr) 'unquote-splicing) (comp-unquote-splicing expr env))
+           ((eq? (car expr) 'set!)             (comp-set! expr env))
+           ((eq? (car expr) 'lambda)           (comp-lambda expr env))
+           ((eq? (car expr) 'if)               (comp-if expr env))
+           ((eq? (car expr) 'cond)             (comp-cond expr env))
+           ((eq? (car expr) 'and)              (comp-and expr env))
+           ((eq? (car expr) 'or)               (comp-or expr env))
+           ((eq? (car expr) 'case)             (comp-case expr env))
+           ((eq? (car expr) 'let)              (comp-let expr env))
+           ((eq? (car expr) 'let*)             (comp-let* expr env))
+           ((eq? (car expr) 'letrec)           (comp-letrec expr env))
+           ((eq? (car expr) 'begin)            (comp-begin expr env))
+           ((eq? (car expr) 'do)               (comp-do expr env))
+           ((eq? (car expr) 'define)           (comp-define expr env))
+           ((eq? (car expr) 'define-macro)     (comp-define-macro expr env))
+           (else                               (comp-combination expr env))))))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define (scheme-global-var name)
+  (let ((x (assq name scheme-global-variables)))
+    (if x
+      (cdr x)
+      (let ((y (vector '())))
+        (set! scheme-global-variables (cons (cons name y) scheme-global-variables))
+        y))))
+
+(define (scheme-global-var-ref i)
+  (vector-ref i 0))
+
+(define (scheme-global-var-set! i val)
+  (vector-set! i 0 val)
+  '())
+
+(define scheme-global-variables '())
+
+(define (def-proc name value)
+  (scheme-global-var-set!
+    (scheme-global-var name)
+    value))
+
+(define nothing
+  (begin
+(def-proc 'not                            (lambda (x) (not x)))
+(def-proc 'boolean?                       boolean?)
+(def-proc 'eqv?                           eqv?)
+(def-proc 'eq?                            eq?)
+(def-proc 'equal?                         equal?)
+(def-proc 'pair?                          (lambda (obj) (pair? obj)))
+(def-proc 'cons                           (lambda (x y) (cons x y)))
+(def-proc 'car                            (lambda (x) (car x)))
+(def-proc 'cdr                            (lambda (x) (cdr x)))
+;(def-proc 'set-car!                       set-car!)
+;(def-proc 'set-cdr!                       set-cdr!)
+(def-proc 'caar                           caar)
+(def-proc 'cadr                           cadr)
+(def-proc 'cdar                           cdar)
+(def-proc 'cddr                           cddr)
+(def-proc 'caaar                          caaar)
+(def-proc 'caadr                          caadr)
+(def-proc 'cadar                          cadar)
+(def-proc 'caddr                          caddr)
+(def-proc 'cdaar                          cdaar)
+(def-proc 'cdadr                          cdadr)
+(def-proc 'cddar                          cddar)
+(def-proc 'cdddr                          cdddr)
+(def-proc 'caaaar                         caaaar)
+(def-proc 'caaadr                         caaadr)
+(def-proc 'caadar                         caadar)
+(def-proc 'caaddr                         caaddr)
+(def-proc 'cadaar                         cadaar)
+(def-proc 'cadadr                         cadadr)
+(def-proc 'caddar                         caddar)
+(def-proc 'cadddr                         cadddr)
+(def-proc 'cdaaar                         cdaaar)
+(def-proc 'cdaadr                         cdaadr)
+(def-proc 'cdadar                         cdadar)
+(def-proc 'cdaddr                         cdaddr)
+(def-proc 'cddaar                         cddaar)
+(def-proc 'cddadr                         cddadr)
+(def-proc 'cdddar                         cdddar)
+(def-proc 'cddddr                         cddddr)
+(def-proc 'null?                          (lambda (x) (null? x)))
+(def-proc 'list?                          list?)
+(def-proc 'list                           list)
+(def-proc 'length                         length)
+(def-proc 'append                         append)
+(def-proc 'reverse                        reverse)
+(def-proc 'list-ref                       list-ref)
+(def-proc 'memq                           memq)
+(def-proc 'memv                           memv)
+(def-proc 'member                         member)
+(def-proc 'assq                           assq)
+(def-proc 'assv                           assv)
+(def-proc 'assoc                          assoc)
+(def-proc 'symbol?                        symbol?)
+(def-proc 'symbol->string                 symbol->string)
+(def-proc 'string->symbol                 string->symbol)
+(def-proc 'number?                        number?)
+(def-proc 'complex?                       complex?)
+(def-proc 'real?                          real?)
+(def-proc 'rational?                      rational?)
+(def-proc 'integer?                       integer?)
+(def-proc 'exact?                         exact?)
+(def-proc 'inexact?                       inexact?)
+;(def-proc '=                              =)
+;(def-proc '<                              <)
+;(def-proc '>                              >)
+;(def-proc '<=                             <=)
+;(def-proc '>=                             >=)
+;(def-proc 'zero?                          zero?)
+;(def-proc 'positive?                      positive?)
+;(def-proc 'negative?                      negative?)
+;(def-proc 'odd?                           odd?)
+;(def-proc 'even?                          even?)
+(def-proc 'max                            max)
+(def-proc 'min                            min)
+;(def-proc '+                              +)
+;(def-proc '*                              *)
+;(def-proc '-                              -)
+(def-proc '/                              /)
+(def-proc 'abs                            abs)
+;(def-proc 'quotient                       quotient)
+;(def-proc 'remainder                      remainder)
+;(def-proc 'modulo                         modulo)
+(def-proc 'gcd                            gcd)
+(def-proc 'lcm                            lcm)
+;(def-proc 'numerator                      numerator)
+;(def-proc 'denominator                    denominator)
+(def-proc 'floor                          floor)
+(def-proc 'ceiling                        ceiling)
+(def-proc 'truncate                       truncate)
+(def-proc 'round                          round)
+;(def-proc 'rationalize                    rationalize)
+(def-proc 'exp                            exp)
+(def-proc 'log                            log)
+(def-proc 'sin                            sin)
+(def-proc 'cos                            cos)
+(def-proc 'tan                            tan)
+(def-proc 'asin                           asin)
+(def-proc 'acos                           acos)
+(def-proc 'atan                           atan)
+(def-proc 'sqrt                           sqrt)
+(def-proc 'expt                           expt)
+;(def-proc 'make-rectangular               make-rectangular)
+;(def-proc 'make-polar                     make-polar)
+;(def-proc 'real-part                      real-part)
+;(def-proc 'imag-part                      imag-part)
+;(def-proc 'magnitude                      magnitude)
+;(def-proc 'angle                          angle)
+(def-proc 'exact->inexact                 exact->inexact)
+(def-proc 'inexact->exact                 inexact->exact)
+(def-proc 'number->string                 number->string)
+(def-proc 'string->number                 string->number)
+(def-proc 'char?                          char?)
+(def-proc 'char=?                         char=?)
+(def-proc 'char<?                         char<?)
+(def-proc 'char>?                         char>?)
+(def-proc 'char<=?                        char<=?)
+(def-proc 'char>=?                        char>=?)
+(def-proc 'char-ci=?                      char-ci=?)
+(def-proc 'char-ci<?                      char-ci<?)
+(def-proc 'char-ci>?                      char-ci>?)
+(def-proc 'char-ci<=?                     char-ci<=?)
+(def-proc 'char-ci>=?                     char-ci>=?)
+(def-proc 'char-alphabetic?               char-alphabetic?)
+(def-proc 'char-numeric?                  char-numeric?)
+(def-proc 'char-whitespace?               char-whitespace?)
+(def-proc 'char-lower-case?               char-lower-case?)
+(def-proc 'char->integer                  char->integer)
+(def-proc 'integer->char                  integer->char)
+(def-proc 'char-upcase                    char-upcase)
+(def-proc 'char-downcase                  char-downcase)
+(def-proc 'string?                        string?)
+(def-proc 'make-string                    make-string)
+(def-proc 'string                         string)
+(def-proc 'string-length                  string-length)
+(def-proc 'string-ref                     string-ref)
+(def-proc 'string-set!                    string-set!)
+(def-proc 'string=?                       string=?)
+(def-proc 'string<?                       string<?)
+(def-proc 'string>?                       string>?)
+(def-proc 'string<=?                      string<=?)
+(def-proc 'string>=?                      string>=?)
+(def-proc 'string-ci=?                    string-ci=?)
+(def-proc 'string-ci<?                    string-ci<?)
+(def-proc 'string-ci>?                    string-ci>?)
+(def-proc 'string-ci<=?                   string-ci<=?)
+(def-proc 'string-ci>=?                   string-ci>=?)
+(def-proc 'substring                      substring)
+(def-proc 'string-append                  string-append)
+(def-proc 'vector?                        vector?)
+(def-proc 'make-vector                    make-vector)
+(def-proc 'vector                         vector)
+(def-proc 'vector-length                  vector-length)
+(def-proc 'vector-ref                     vector-ref)
+(def-proc 'vector-set!                    vector-set!)
+(def-proc 'procedure?                     procedure?)
+(def-proc 'apply                          apply)
+(def-proc 'map                            map)
+(def-proc 'for-each                       for-each)
+;(def-proc 'call-with-current-continuation call-with-current-continuation)
+(def-proc 'call-with-input-file           call-with-input-file)
+(def-proc 'call-with-output-file          call-with-output-file)
+(def-proc 'input-port?                    input-port?)
+(def-proc 'output-port?                   output-port?)
+(def-proc 'current-input-port             current-input-port)
+(def-proc 'current-output-port            current-output-port)
+(def-proc 'open-input-file                open-input-file)
+(def-proc 'open-output-file               open-output-file)
+(def-proc 'close-input-port               close-input-port)
+(def-proc 'close-output-port              close-output-port)
+(def-proc 'eof-object?                    eof-object?)
+(def-proc 'read                           read)
+(def-proc 'read-char                      read-char)
+(def-proc 'peek-char                      peek-char)
+(def-proc 'write                          write)
+(def-proc 'display                        display)
+(def-proc 'newline                        newline)
+(def-proc 'write-char                     write-char)))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define expr1
+  '(let ()
+
+     (define (sort-list obj pred)
+
+       (define (loop l)
+         (if (and (pair? l) (pair? (cdr l)))
+             (split l '() '())
+             l))
+
+       (define (split l one two)
+         (if (pair? l)
+             (split (cdr l) two (cons (car l) one))
+             (merge (loop one) (loop two))))
+
+       (define (merge one two)
+         (cond ((null? one) two)
+               ((pred (car two) (car one))
+                (cons (car two)
+                      (merge (cdr two) one)))
+               (else
+                (cons (car one)
+                      (merge (cdr one) two)))))
+
+       (loop obj))
+
+     (sort-list '("one" "two" "three" "four" "five" "six"
+                  "seven" "eight" "nine" "ten" "eleven" "twelve")
+                string<?)))
+
+
+(let ((input (with-input-from-file "input.txt" read)))
+  (time
+   (let loop ((n 3000) (v 0))
+     (if (zero? n)
+         v
+         (loop (- n 1) (scheme-eval (if input expr1 '(+ 1 2))))))))
diff --git a/benchmarks/gabriel/sort1.sch b/benchmarks/gabriel/sort1.sch
new file mode 100644
index 00000000..49fa82b8
--- /dev/null
+++ b/benchmarks/gabriel/sort1.sch
@@ -0,0 +1,147 @@
+; This benchmark uses the code for Larceny's standard sort procedure.
+;
+; Usage:
+; (sort-benchmark sorter n)
+;
+; where
+; sorter is a sort procedure (usually sort or sort1) whose calling
+;     convention is compatible with Larceny's
+; n is the number of fixnums to sort
+
+(define sort1
+  (let ()
+
+;;; File   : sort.scm
+;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
+;;; Updated: 11 June 1991
+;
+; $Id: sort.sch 264 1998-12-14 16:44:08Z lth $
+;
+; Code originally obtained from Scheme Repository, since hacked.
+;
+; Sort and Sort! will sort lists and vectors.  The former returns a new
+; data structure; the latter sorts the data structure in-place.  A 
+; mergesort algorithm is used.
+
+; Destructive merge of two sorted lists.
+
+(define (merge!! a b less?)
+
+  (define (loop r a b)
+    (if (less? (car b) (car a))
+	(begin (set-cdr! r b)
+	       (if (null? (cdr b))
+		   (set-cdr! b a)
+		   (loop b a (cdr b)) ))
+	;; (car a) <= (car b)
+	(begin (set-cdr! r a)
+	       (if (null? (cdr a))
+		   (set-cdr! a b)
+		   (loop a (cdr a) b)) )) )
+
+  (cond ((null? a) b)
+	((null? b) a)
+	((less? (car b) (car a))
+	 (if (null? (cdr b))
+	     (set-cdr! b a)
+	     (loop b a (cdr b)))
+	 b)
+	(else				; (car a) <= (car b)
+	 (if (null? (cdr a))
+	     (set-cdr! a b)
+	     (loop a (cdr a) b))
+	 a)))
+
+; Sort procedure which copies the input list and then sorts the
+; new list imperatively. Due to Richard O'Keefe; algorithm
+; attributed to D.H.D. Warren
+
+(define (sort!! seq less?)
+  
+  (define (step n)
+    (cond ((> n 2)
+	   (let* ((j (quotient n 2))
+		  (a (step j))
+		  (k (- n j))
+		  (b (step k)))
+	     (merge!! a b less?)))
+	  ((= n 2)
+	   (let ((x (car seq))
+		 (y (cadr seq))
+		 (p seq))
+	     (set! seq (cddr seq))
+	     (if (less? y x)
+		 (begin
+		   (set-car! p y)
+		   (set-car! (cdr p) x)))
+	     (set-cdr! (cdr p) '())
+	     p))
+	  ((= n 1)
+	   (let ((p seq))
+	     (set! seq (cdr seq))
+	     (set-cdr! p '())
+	     p))
+	  (else
+	   '())))
+  
+  (step (length seq)))
+
+(define (sort! seq less?)
+  (cond ((null? seq)
+	 seq)
+	((pair? seq)
+	 (sort!! seq less?))
+	((vector? seq)
+	 (do ((l (sort!! (vector->list seq) less?) (cdr l))
+	      (i 0 (+ i 1)))
+	     ((null? l) seq)
+	   (vector-set! seq i (car l))))
+	(else
+	 (error "sort!: not a valid sequence: " seq))))
+
+(define (sort seq less?)
+  (cond ((null? seq)
+	 seq)
+	((pair? seq)
+	 (sort!! (list-copy seq) less?))
+	((vector? seq)
+	 (list->vector (sort!! (vector->list seq) less?)))
+	(else
+	 (error "sort: not a valid sequence: " seq))))
+
+; eof
+
+    ; This is pretty much optimal for Larceny.
+
+    (define (list-copy l)
+      (define (loop l prev)
+        (if (null? l)
+            #t
+            (let ((q (cons (car l) '())))
+              (set-cdr! prev q)
+              (loop (cdr l) q))))
+      (if (null? l)
+          l
+          (let ((first (cons (car l) '())))
+            (loop (cdr l) first)
+            first)))
+
+    sort))
+
+(define *rand* 21)
+(define (randm m)
+  (set! *rand* (remainder (* *rand* 17) m))
+  *rand*)
+
+(define (rgen n m)
+  (let loop ((n n) (l '()))
+    (if (zero? n) 
+	l
+	(loop (- n 1) (cons (randm m) l)))))
+
+(define (sort-benchmark sorter n)
+  (let ((l (rgen n 1000000)))
+    (time (length (sorter l <)))))
+
+(sort-benchmark sort1 1000000)
+
diff --git a/benchmarks/gabriel/tak.sch b/benchmarks/gabriel/tak.sch
new file mode 100644
index 00000000..a795edce
--- /dev/null
+++ b/benchmarks/gabriel/tak.sch
@@ -0,0 +1,28 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File:         tak.sch
+; Description:  TAK benchmark from the Gabriel tests
+; Author:       Richard Gabriel
+; Created:      12-Apr-85
+; Modified:     12-Apr-85 09:58:18 (Bob Shaw)
+;               22-Jul-87 (Will Clinger)
+; Language:     Scheme
+; Status:       Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ 
+;;; TAK -- A vanilla version of the TAKeuchi function
+
+(define (tak x y z)
+  (if (not (< y x))
+      z
+      (tak (tak (- x 1) y z)
+           (tak (- y 1) z x)
+           (tak (- z 1) x y))))
+ 
+;;; call: (tak 18 12 6)
+
+(let ((input (with-input-from-file "input.txt" read)))
+  (time
+   (let loop ((n 500) (v 0))
+     (if (zero? n)
+         v
+         (loop (- n 1) (tak 18 12 (if input 6 0)))))))
diff --git a/benchmarks/gabriel/takl.sch b/benchmarks/gabriel/takl.sch
new file mode 100644
index 00000000..79df0c0a
--- /dev/null
+++ b/benchmarks/gabriel/takl.sch
@@ -0,0 +1,43 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File:         takl.sch
+; Description:  TAKL benchmark from the Gabriel tests
+; Author:       Richard Gabriel
+; Created:      12-Apr-85
+; Modified:     12-Apr-85 10:07:00 (Bob Shaw)
+;               22-Jul-87 (Will Clinger)
+; Language:     Scheme
+; Status:       Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ 
+;;; TAKL -- The TAKeuchi function using lists as counters.
+
+(define (listn n)
+  (if (not (= 0 n))
+      (cons n (listn (- n 1)))
+      '()))
+ 
+(define l18l (listn 18))
+(define l12l (listn 12))
+(define  l6l (listn 2))
+ 
+(define (mas x y z)
+  (if (not (shorterp y x))
+      z
+      (mas (mas (cdr x)
+                 y z)
+            (mas (cdr y)
+                 z x)
+            (mas (cdr z)
+                 x y))))
+ 
+(define (shorterp x y)
+  (and (not (null? y))
+       (or (null? x)
+           (shorterp (cdr x)
+                     (cdr y)))))
+ 
+;;; call: (mas 18l 12l 6l)
+
+
+(let ((v (if (with-input-from-file "input.txt" read) l6l '())))
+  (time (mas l18l l12l v)))
diff --git a/benchmarks/gabriel/takr.sch b/benchmarks/gabriel/takr.sch
new file mode 100644
index 00000000..ef46d387
--- /dev/null
+++ b/benchmarks/gabriel/takr.sch
@@ -0,0 +1,525 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File:         takr.sch
+; Description:  TAKR benchmark
+; Author:       Richard Gabriel
+; Created:      12-Apr-85
+; Modified:     12-Apr-85 10:12:43 (Bob Shaw)
+;               22-Jul-87 (Will Clinger)
+; Language:     Scheme
+; Status:       Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ 
+;;; TAKR  -- 100 function (count `em) version of TAK that tries to defeat cache
+;;; memory effects.  Results should be the same as for TAK on stack machines.
+;;; Distribution of calls is not completely flat.
+
+(define (tak0 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak1 (tak37 (- x 1) y z)
+                 (tak11 (- y 1) z x)
+                 (tak17 (- z 1) x y)))))
+(define (tak1 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak2 (tak74 (- x 1) y z)
+                 (tak22 (- y 1) z x)
+                 (tak34 (- z 1) x y)))))
+(define (tak2 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak3 (tak11 (- x 1) y z)
+                 (tak33 (- y 1) z x)
+                 (tak51 (- z 1) x y)))))
+(define (tak3 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak4 (tak48 (- x 1) y z)
+                 (tak44 (- y 1) z x)
+                 (tak68 (- z 1) x y)))))
+(define (tak4 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak5 (tak85 (- x 1) y z)
+                 (tak55 (- y 1) z x)
+                 (tak85 (- z 1) x y)))))
+(define (tak5 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak6 (tak22 (- x 1) y z)
+                 (tak66 (- y 1) z x)
+                 (tak2 (- z 1) x y)))))
+(define (tak6 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak7 (tak59 (- x 1) y z)
+                 (tak77 (- y 1) z x)
+                 (tak19 (- z 1) x y)))))
+(define (tak7 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak8 (tak96 (- x 1) y z)
+                 (tak88 (- y 1) z x)
+                 (tak36 (- z 1) x y)))))
+(define (tak8 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak9 (tak33 (- x 1) y z)
+                 (tak99 (- y 1) z x)
+                 (tak53 (- z 1) x y)))))
+(define (tak9 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak10 (tak70 (- x 1) y z)
+                  (tak10 (- y 1) z x)
+                  (tak70 (- z 1) x y)))))
+(define (tak10 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak11 (tak7 (- x 1) y z)
+                  (tak21 (- y 1) z x)
+                  (tak87 (- z 1) x y)))))
+(define (tak11 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak12 (tak44 (- x 1) y z)
+                  (tak32 (- y 1) z x)
+                  (tak4 (- z 1) x y)))))
+(define (tak12 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak13 (tak81 (- x 1) y z)
+                  (tak43 (- y 1) z x)
+                  (tak21 (- z 1) x y)))))
+ 
+(define (tak13 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak14 (tak18 (- x 1) y z)
+                  (tak54 (- y 1) z x)
+                  (tak38 (- z 1) x y)))))
+(define (tak14 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak15 (tak55 (- x 1) y z)
+                  (tak65 (- y 1) z x)
+                  (tak55 (- z 1) x y)))))
+(define (tak15 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak16 (tak92 (- x 1) y z)
+                  (tak76 (- y 1) z x)
+                  (tak72 (- z 1) x y)))))
+(define (tak16 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak17 (tak29 (- x 1) y z)
+                  (tak87 (- y 1) z x)
+                  (tak89 (- z 1) x y)))))
+(define (tak17 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak18 (tak66 (- x 1) y z)
+                  (tak98 (- y 1) z x)
+                  (tak6 (- z 1) x y)))))
+(define (tak18 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak19 (tak3 (- x 1) y z)
+                  (tak9 (- y 1) z x)
+                  (tak23 (- z 1) x y)))))
+(define (tak19 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak20 (tak40 (- x 1) y z)
+                  (tak20 (- y 1) z x)
+                  (tak40 (- z 1) x y)))))
+(define (tak20 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak21 (tak77 (- x 1) y z)
+                  (tak31 (- y 1) z x)
+                  (tak57 (- z 1) x y)))))
+(define (tak21 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak22 (tak14 (- x 1) y z)
+                  (tak42 (- y 1) z x)
+                  (tak74 (- z 1) x y)))))
+(define (tak22 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak23 (tak51 (- x 1) y z)
+                  (tak53 (- y 1) z x)
+                  (tak91 (- z 1) x y)))))
+(define (tak23 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak24 (tak88 (- x 1) y z)
+                  (tak64 (- y 1) z x)
+                  (tak8 (- z 1) x y)))))
+(define (tak24 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak25 (tak25 (- x 1) y z)
+                  (tak75 (- y 1) z x)
+                  (tak25 (- z 1) x y)))))
+(define (tak25 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak26 (tak62 (- x 1) y z)
+                  (tak86 (- y 1) z x)
+                  (tak42 (- z 1) x y)))))
+(define (tak26 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak27 (tak99 (- x 1) y z)
+                  (tak97 (- y 1) z x)
+                  (tak59 (- z 1) x y)))))
+(define (tak27 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak28 (tak36 (- x 1) y z)
+                  (tak8 (- y 1) z x)
+                  (tak76 (- z 1) x y)))))
+(define (tak28 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak29 (tak73 (- x 1) y z)
+                  (tak19 (- y 1) z x)
+                  (tak93 (- z 1) x y)))))
+(define (tak29 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak30 (tak10 (- x 1) y z)
+                  (tak30 (- y 1) z x)
+                  (tak10 (- z 1) x y)))))
+(define (tak30 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak31 (tak47 (- x 1) y z)
+                  (tak41 (- y 1) z x)
+                  (tak27 (- z 1) x y)))))
+(define (tak31 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak32 (tak84 (- x 1) y z)
+                  (tak52 (- y 1) z x)
+                  (tak44 (- z 1) x y)))))
+(define (tak32 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak33 (tak21 (- x 1) y z)
+                  (tak63 (- y 1) z x)
+                  (tak61 (- z 1) x y)))))
+(define (tak33 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak34 (tak58 (- x 1) y z)
+                  (tak74 (- y 1) z x)
+                  (tak78 (- z 1) x y)))))
+(define (tak34 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak35 (tak95 (- x 1) y z)
+                  (tak85 (- y 1) z x)
+                  (tak95 (- z 1) x y)))))
+(define (tak35 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak36 (tak32 (- x 1) y z)
+                  (tak96 (- y 1) z x)
+                  (tak12 (- z 1) x y)))))
+(define (tak36 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak37 (tak69 (- x 1) y z)
+                  (tak7 (- y 1) z x)
+                  (tak29 (- z 1) x y)))))
+(define (tak37 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak38 (tak6 (- x 1) y z)
+                  (tak18 (- y 1) z x)
+                  (tak46 (- z 1) x y)))))
+(define (tak38 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak39 (tak43 (- x 1) y z)
+                  (tak29 (- y 1) z x)
+                  (tak63 (- z 1) x y)))))
+(define (tak39 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak40 (tak80 (- x 1) y z)
+                  (tak40 (- y 1) z x)
+                  (tak80 (- z 1) x y)))))
+(define (tak40 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak41 (tak17 (- x 1) y z)
+                  (tak51 (- y 1) z x)
+                  (tak97 (- z 1) x y)))))
+(define (tak41 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak42 (tak54 (- x 1) y z)
+                  (tak62 (- y 1) z x)
+                  (tak14 (- z 1) x y)))))
+(define (tak42 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak43 (tak91 (- x 1) y z)
+                  (tak73 (- y 1) z x)
+                  (tak31 (- z 1) x y)))))
+(define (tak43 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak44 (tak28 (- x 1) y z)
+                  (tak84 (- y 1) z x)
+                  (tak48 (- z 1) x y)))))
+(define (tak44 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak45 (tak65 (- x 1) y z)
+                  (tak95 (- y 1) z x)
+                  (tak65 (- z 1) x y)))))
+(define (tak45 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak46 (tak2 (- x 1) y z)
+                  (tak6 (- y 1) z x)
+                  (tak82 (- z 1) x y)))))
+(define (tak46 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak47 (tak39 (- x 1) y z)
+                  (tak17 (- y 1) z x)
+                  (tak99 (- z 1) x y)))))
+(define (tak47 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak48 (tak76 (- x 1) y z)
+                  (tak28 (- y 1) z x)
+                  (tak16 (- z 1) x y)))))
+(define (tak48 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak49 (tak13 (- x 1) y z)
+                  (tak39 (- y 1) z x)
+                  (tak33 (- z 1) x y)))))
+(define (tak49 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak50 (tak50 (- x 1) y z)
+                  (tak50 (- y 1) z x)
+                  (tak50 (- z 1) x y)))))
+(define (tak50 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak51 (tak87 (- x 1) y z)
+                  (tak61 (- y 1) z x)
+                  (tak67 (- z 1) x y)))))
+(define (tak51 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak52 (tak24 (- x 1) y z)
+                  (tak72 (- y 1) z x)
+                  (tak84 (- z 1) x y)))))
+(define (tak52 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak53 (tak61 (- x 1) y z)
+                  (tak83 (- y 1) z x)
+                  (tak1 (- z 1) x y)))))
+(define (tak53 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak54 (tak98 (- x 1) y z)
+                  (tak94 (- y 1) z x)
+                  (tak18 (- z 1) x y)))))
+(define (tak54 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak55 (tak35 (- x 1) y z)
+                  (tak5 (- y 1) z x)
+                  (tak35 (- z 1) x y)))))
+(define (tak55 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak56 (tak72 (- x 1) y z)
+                  (tak16 (- y 1) z x)
+                  (tak52 (- z 1) x y)))))
+(define (tak56 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak57 (tak9 (- x 1) y z)
+                  (tak27 (- y 1) z x)
+                  (tak69 (- z 1) x y)))))
+(define (tak57 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak58 (tak46 (- x 1) y z)
+                  (tak38 (- y 1) z x)
+                  (tak86 (- z 1) x y)))))
+(define (tak58 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak59 (tak83 (- x 1) y z)
+                  (tak49 (- y 1) z x)
+                  (tak3 (- z 1) x y)))))
+(define (tak59 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak60 (tak20 (- x 1) y z)
+                  (tak60 (- y 1) z x)
+                  (tak20 (- z 1) x y)))))
+(define (tak60 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak61 (tak57 (- x 1) y z)
+                  (tak71 (- y 1) z x)
+                  (tak37 (- z 1) x y)))))
+(define (tak61 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak62 (tak94 (- x 1) y z)
+                  (tak82 (- y 1) z x)
+                  (tak54 (- z 1) x y)))))
+(define (tak62 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak63 (tak31 (- x 1) y z)
+                  (tak93 (- y 1) z x)
+                  (tak71 (- z 1) x y)))))
+(define (tak63 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak64 (tak68 (- x 1) y z)
+                  (tak4 (- y 1) z x)
+                  (tak88 (- z 1) x y)))))
+(define (tak64 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak65 (tak5 (- x 1) y z)
+                  (tak15 (- y 1) z x)
+                  (tak5 (- z 1) x y)))))
+(define (tak65 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak66 (tak42 (- x 1) y z)
+                  (tak26 (- y 1) z x)
+                  (tak22 (- z 1) x y)))))
+(define (tak66 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak67 (tak79 (- x 1) y z)
+                  (tak37 (- y 1) z x)
+                  (tak39 (- z 1) x y)))))
+(define (tak67 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak68 (tak16 (- x 1) y z)
+                  (tak48 (- y 1) z x)
+                  (tak56 (- z 1) x y)))))
+(define (tak68 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak69 (tak53 (- x 1) y z)
+                  (tak59 (- y 1) z x)
+                  (tak73 (- z 1) x y)))))
+(define (tak69 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak70 (tak90 (- x 1) y z)
+                  (tak70 (- y 1) z x)
+                  (tak90 (- z 1) x y)))))
+(define (tak70 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak71 (tak27 (- x 1) y z)
+                  (tak81 (- y 1) z x)
+                  (tak7 (- z 1) x y)))))
+(define (tak71 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak72 (tak64 (- x 1) y z)
+                  (tak92 (- y 1) z x)
+                  (tak24 (- z 1) x y)))))
+(define (tak72 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak73 (tak1 (- x 1) y z)
+                  (tak3 (- y 1) z x)
+                  (tak41 (- z 1) x y)))))
+(define (tak73 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak74 (tak38 (- x 1) y z)
+                  (tak14 (- y 1) z x)
+                  (tak58 (- z 1) x y)))))
+(define (tak74 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak75 (tak75 (- x 1) y z)
+                  (tak25 (- y 1) z x)
+                  (tak75 (- z 1) x y)))))
+(define (tak75 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak76 (tak12 (- x 1) y z)
+                  (tak36 (- y 1) z x)
+                  (tak92 (- z 1) x y)))))
+(define (tak76 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak77 (tak49 (- x 1) y z)
+                  (tak47 (- y 1) z x)
+                  (tak9 (- z 1) x y)))))
+(define (tak77 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak78 (tak86 (- x 1) y z)
+                  (tak58 (- y 1) z x)
+                  (tak26 (- z 1) x y)))))
+(define (tak78 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak79 (tak23 (- x 1) y z)
+                  (tak69 (- y 1) z x)
+                  (tak43 (- z 1) x y)))))
+(define (tak79 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak80 (tak60 (- x 1) y z)
+                  (tak80 (- y 1) z x)
+                  (tak60 (- z 1) x y)))))
+(define (tak80 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak81 (tak97 (- x 1) y z)
+                  (tak91 (- y 1) z x)
+                  (tak77 (- z 1) x y)))))
+(define (tak81 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak82 (tak34 (- x 1) y z)
+                  (tak2 (- y 1) z x)
+                  (tak94 (- z 1) x y)))))
+(define (tak82 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak83 (tak71 (- x 1) y z)
+                  (tak13 (- y 1) z x)
+                  (tak11 (- z 1) x y)))))
+(define (tak83 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak84 (tak8 (- x 1) y z)
+                  (tak24 (- y 1) z x)
+                  (tak28 (- z 1) x y)))))
+(define (tak84 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak85 (tak45 (- x 1) y z)
+                  (tak35 (- y 1) z x)
+                  (tak45 (- z 1) x y)))))
+(define (tak85 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak86 (tak82 (- x 1) y z)
+                  (tak46 (- y 1) z x)
+                  (tak62 (- z 1) x y)))))
+(define (tak86 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak87 (tak19 (- x 1) y z)
+                  (tak57 (- y 1) z x)
+                  (tak79 (- z 1) x y)))))
+(define (tak87 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak88 (tak56 (- x 1) y z)
+                  (tak68 (- y 1) z x)
+                  (tak96 (- z 1) x y)))))
+(define (tak88 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak89 (tak93 (- x 1) y z)
+                  (tak79 (- y 1) z x)
+                  (tak13 (- z 1) x y)))))
+(define (tak89 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak90 (tak30 (- x 1) y z)
+                  (tak90 (- y 1) z x)
+                  (tak30 (- z 1) x y)))))
+(define (tak90 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak91 (tak67 (- x 1) y z)
+                  (tak1 (- y 1) z x)
+                  (tak47 (- z 1) x y)))))
+(define (tak91 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak92 (tak4 (- x 1) y z)
+                  (tak12 (- y 1) z x)
+                  (tak64 (- z 1) x y)))))
+(define (tak92 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak93 (tak41 (- x 1) y z)
+                  (tak23 (- y 1) z x)
+                  (tak81 (- z 1) x y)))))
+(define (tak93 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak94 (tak78 (- x 1) y z)
+                  (tak34 (- y 1) z x)
+                  (tak98 (- z 1) x y)))))
+(define (tak94 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak95 (tak15 (- x 1) y z)
+                  (tak45 (- y 1) z x)
+                  (tak15 (- z 1) x y)))))
+(define (tak95 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak96 (tak52 (- x 1) y z)
+                  (tak56 (- y 1) z x)
+                  (tak32 (- z 1) x y)))))
+(define (tak96 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak97 (tak89 (- x 1) y z)
+                  (tak67 (- y 1) z x)
+                  (tak49 (- z 1) x y)))))
+(define (tak97 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak98 (tak26 (- x 1) y z)
+                  (tak78 (- y 1) z x)
+                  (tak66 (- z 1) x y)))))
+(define (tak98 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak99 (tak63 (- x 1) y z)
+                  (tak89 (- y 1) z x)
+                  (tak83 (- z 1) x y)))))
+(define (tak99 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak0 (tak0 (- x 1) y z)
+                 (tak0 (- y 1) z x)
+                 (tak0 (- z 1) x y)))))
+ 
+;;; call:  (tak0 18 12 6)
+
+(let ((input (with-input-from-file "input.txt" read)))
+  (time
+   (let loop ((n 500) (v 0))
+     (if (zero? n)
+         v
+         (loop (- n 1) (tak0 18 12 (if input 6 0)))))))
diff --git a/benchmarks/gabriel/takr2.sch b/benchmarks/gabriel/takr2.sch
new file mode 100644
index 00000000..c6deb8dc
--- /dev/null
+++ b/benchmarks/gabriel/takr2.sch
@@ -0,0 +1,528 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File:         takr.sch
+; Description:  TAKR benchmark
+; Author:       Richard Gabriel
+; Created:      12-Apr-85
+; Modified:     12-Apr-85 10:12:43 (Bob Shaw)
+;               22-Jul-87 (Will Clinger)
+; Language:     Scheme
+; Status:       Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ 
+;;; TAKR  -- 100 function (count `em) version of TAK that tries to defeat cache
+;;; memory effects.  Results should be the same as for TAK on stack machines.
+;;; Distribution of calls is not completely flat.
+
+(define (tak x y z)
+  (define (tak0 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak1 (tak37 (- x 1) y z)
+                      (tak11 (- y 1) z x)
+                      (tak17 (- z 1) x y)))))
+  (define (tak1 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak2 (tak74 (- x 1) y z)
+                      (tak22 (- y 1) z x)
+                      (tak34 (- z 1) x y)))))
+  (define (tak2 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak3 (tak11 (- x 1) y z)
+                      (tak33 (- y 1) z x)
+                      (tak51 (- z 1) x y)))))
+  (define (tak3 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak4 (tak48 (- x 1) y z)
+                      (tak44 (- y 1) z x)
+                      (tak68 (- z 1) x y)))))
+  (define (tak4 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak5 (tak85 (- x 1) y z)
+                      (tak55 (- y 1) z x)
+                      (tak85 (- z 1) x y)))))
+  (define (tak5 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak6 (tak22 (- x 1) y z)
+                      (tak66 (- y 1) z x)
+                      (tak2 (- z 1) x y)))))
+  (define (tak6 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak7 (tak59 (- x 1) y z)
+                      (tak77 (- y 1) z x)
+                      (tak19 (- z 1) x y)))))
+  (define (tak7 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak8 (tak96 (- x 1) y z)
+                      (tak88 (- y 1) z x)
+                      (tak36 (- z 1) x y)))))
+  (define (tak8 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak9 (tak33 (- x 1) y z)
+                      (tak99 (- y 1) z x)
+                      (tak53 (- z 1) x y)))))
+  (define (tak9 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak10 (tak70 (- x 1) y z)
+                       (tak10 (- y 1) z x)
+                       (tak70 (- z 1) x y)))))
+  (define (tak10 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak11 (tak7 (- x 1) y z)
+                       (tak21 (- y 1) z x)
+                       (tak87 (- z 1) x y)))))
+  (define (tak11 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak12 (tak44 (- x 1) y z)
+                       (tak32 (- y 1) z x)
+                       (tak4 (- z 1) x y)))))
+  (define (tak12 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak13 (tak81 (- x 1) y z)
+                       (tak43 (- y 1) z x)
+                       (tak21 (- z 1) x y)))))
+  
+  (define (tak13 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak14 (tak18 (- x 1) y z)
+                       (tak54 (- y 1) z x)
+                       (tak38 (- z 1) x y)))))
+  (define (tak14 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak15 (tak55 (- x 1) y z)
+                       (tak65 (- y 1) z x)
+                       (tak55 (- z 1) x y)))))
+  (define (tak15 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak16 (tak92 (- x 1) y z)
+                       (tak76 (- y 1) z x)
+                       (tak72 (- z 1) x y)))))
+  (define (tak16 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak17 (tak29 (- x 1) y z)
+                       (tak87 (- y 1) z x)
+                       (tak89 (- z 1) x y)))))
+  (define (tak17 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak18 (tak66 (- x 1) y z)
+                       (tak98 (- y 1) z x)
+                       (tak6 (- z 1) x y)))))
+  (define (tak18 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak19 (tak3 (- x 1) y z)
+                       (tak9 (- y 1) z x)
+                       (tak23 (- z 1) x y)))))
+  (define (tak19 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak20 (tak40 (- x 1) y z)
+                       (tak20 (- y 1) z x)
+                       (tak40 (- z 1) x y)))))
+  (define (tak20 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak21 (tak77 (- x 1) y z)
+                       (tak31 (- y 1) z x)
+                       (tak57 (- z 1) x y)))))
+  (define (tak21 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak22 (tak14 (- x 1) y z)
+                       (tak42 (- y 1) z x)
+                       (tak74 (- z 1) x y)))))
+  (define (tak22 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak23 (tak51 (- x 1) y z)
+                       (tak53 (- y 1) z x)
+                       (tak91 (- z 1) x y)))))
+  (define (tak23 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak24 (tak88 (- x 1) y z)
+                       (tak64 (- y 1) z x)
+                       (tak8 (- z 1) x y)))))
+  (define (tak24 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak25 (tak25 (- x 1) y z)
+                       (tak75 (- y 1) z x)
+                       (tak25 (- z 1) x y)))))
+  (define (tak25 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak26 (tak62 (- x 1) y z)
+                       (tak86 (- y 1) z x)
+                       (tak42 (- z 1) x y)))))
+  (define (tak26 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak27 (tak99 (- x 1) y z)
+                       (tak97 (- y 1) z x)
+                       (tak59 (- z 1) x y)))))
+  (define (tak27 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak28 (tak36 (- x 1) y z)
+                       (tak8 (- y 1) z x)
+                       (tak76 (- z 1) x y)))))
+  (define (tak28 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak29 (tak73 (- x 1) y z)
+                       (tak19 (- y 1) z x)
+                       (tak93 (- z 1) x y)))))
+  (define (tak29 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak30 (tak10 (- x 1) y z)
+                       (tak30 (- y 1) z x)
+                       (tak10 (- z 1) x y)))))
+  (define (tak30 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak31 (tak47 (- x 1) y z)
+                       (tak41 (- y 1) z x)
+                       (tak27 (- z 1) x y)))))
+  (define (tak31 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak32 (tak84 (- x 1) y z)
+                       (tak52 (- y 1) z x)
+                       (tak44 (- z 1) x y)))))
+  (define (tak32 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak33 (tak21 (- x 1) y z)
+                       (tak63 (- y 1) z x)
+                       (tak61 (- z 1) x y)))))
+  (define (tak33 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak34 (tak58 (- x 1) y z)
+                       (tak74 (- y 1) z x)
+                       (tak78 (- z 1) x y)))))
+  (define (tak34 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak35 (tak95 (- x 1) y z)
+                       (tak85 (- y 1) z x)
+                       (tak95 (- z 1) x y)))))
+  (define (tak35 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak36 (tak32 (- x 1) y z)
+                       (tak96 (- y 1) z x)
+                       (tak12 (- z 1) x y)))))
+  (define (tak36 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak37 (tak69 (- x 1) y z)
+                       (tak7 (- y 1) z x)
+                       (tak29 (- z 1) x y)))))
+  (define (tak37 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak38 (tak6 (- x 1) y z)
+                       (tak18 (- y 1) z x)
+                       (tak46 (- z 1) x y)))))
+  (define (tak38 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak39 (tak43 (- x 1) y z)
+                       (tak29 (- y 1) z x)
+                       (tak63 (- z 1) x y)))))
+  (define (tak39 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak40 (tak80 (- x 1) y z)
+                       (tak40 (- y 1) z x)
+                       (tak80 (- z 1) x y)))))
+  (define (tak40 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak41 (tak17 (- x 1) y z)
+                       (tak51 (- y 1) z x)
+                       (tak97 (- z 1) x y)))))
+  (define (tak41 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak42 (tak54 (- x 1) y z)
+                       (tak62 (- y 1) z x)
+                       (tak14 (- z 1) x y)))))
+  (define (tak42 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak43 (tak91 (- x 1) y z)
+                       (tak73 (- y 1) z x)
+                       (tak31 (- z 1) x y)))))
+  (define (tak43 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak44 (tak28 (- x 1) y z)
+                       (tak84 (- y 1) z x)
+                       (tak48 (- z 1) x y)))))
+  (define (tak44 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak45 (tak65 (- x 1) y z)
+                       (tak95 (- y 1) z x)
+                       (tak65 (- z 1) x y)))))
+  (define (tak45 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak46 (tak2 (- x 1) y z)
+                       (tak6 (- y 1) z x)
+                       (tak82 (- z 1) x y)))))
+  (define (tak46 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak47 (tak39 (- x 1) y z)
+                       (tak17 (- y 1) z x)
+                       (tak99 (- z 1) x y)))))
+  (define (tak47 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak48 (tak76 (- x 1) y z)
+                       (tak28 (- y 1) z x)
+                       (tak16 (- z 1) x y)))))
+  (define (tak48 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak49 (tak13 (- x 1) y z)
+                       (tak39 (- y 1) z x)
+                       (tak33 (- z 1) x y)))))
+  (define (tak49 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak50 (tak50 (- x 1) y z)
+                       (tak50 (- y 1) z x)
+                       (tak50 (- z 1) x y)))))
+  (define (tak50 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak51 (tak87 (- x 1) y z)
+                       (tak61 (- y 1) z x)
+                       (tak67 (- z 1) x y)))))
+  (define (tak51 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak52 (tak24 (- x 1) y z)
+                       (tak72 (- y 1) z x)
+                       (tak84 (- z 1) x y)))))
+  (define (tak52 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak53 (tak61 (- x 1) y z)
+                       (tak83 (- y 1) z x)
+                       (tak1 (- z 1) x y)))))
+  (define (tak53 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak54 (tak98 (- x 1) y z)
+                       (tak94 (- y 1) z x)
+                       (tak18 (- z 1) x y)))))
+  (define (tak54 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak55 (tak35 (- x 1) y z)
+                       (tak5 (- y 1) z x)
+                       (tak35 (- z 1) x y)))))
+  (define (tak55 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak56 (tak72 (- x 1) y z)
+                       (tak16 (- y 1) z x)
+                       (tak52 (- z 1) x y)))))
+  (define (tak56 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak57 (tak9 (- x 1) y z)
+                       (tak27 (- y 1) z x)
+                       (tak69 (- z 1) x y)))))
+  (define (tak57 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak58 (tak46 (- x 1) y z)
+                       (tak38 (- y 1) z x)
+                       (tak86 (- z 1) x y)))))
+  (define (tak58 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak59 (tak83 (- x 1) y z)
+                       (tak49 (- y 1) z x)
+                       (tak3 (- z 1) x y)))))
+  (define (tak59 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak60 (tak20 (- x 1) y z)
+                       (tak60 (- y 1) z x)
+                       (tak20 (- z 1) x y)))))
+  (define (tak60 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak61 (tak57 (- x 1) y z)
+                       (tak71 (- y 1) z x)
+                       (tak37 (- z 1) x y)))))
+  (define (tak61 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak62 (tak94 (- x 1) y z)
+                       (tak82 (- y 1) z x)
+                       (tak54 (- z 1) x y)))))
+  (define (tak62 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak63 (tak31 (- x 1) y z)
+                       (tak93 (- y 1) z x)
+                       (tak71 (- z 1) x y)))))
+  (define (tak63 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak64 (tak68 (- x 1) y z)
+                       (tak4 (- y 1) z x)
+                       (tak88 (- z 1) x y)))))
+  (define (tak64 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak65 (tak5 (- x 1) y z)
+                       (tak15 (- y 1) z x)
+                       (tak5 (- z 1) x y)))))
+  (define (tak65 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak66 (tak42 (- x 1) y z)
+                       (tak26 (- y 1) z x)
+                       (tak22 (- z 1) x y)))))
+  (define (tak66 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak67 (tak79 (- x 1) y z)
+                       (tak37 (- y 1) z x)
+                       (tak39 (- z 1) x y)))))
+  (define (tak67 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak68 (tak16 (- x 1) y z)
+                       (tak48 (- y 1) z x)
+                       (tak56 (- z 1) x y)))))
+  (define (tak68 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak69 (tak53 (- x 1) y z)
+                       (tak59 (- y 1) z x)
+                       (tak73 (- z 1) x y)))))
+  (define (tak69 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak70 (tak90 (- x 1) y z)
+                       (tak70 (- y 1) z x)
+                       (tak90 (- z 1) x y)))))
+  (define (tak70 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak71 (tak27 (- x 1) y z)
+                       (tak81 (- y 1) z x)
+                       (tak7 (- z 1) x y)))))
+  (define (tak71 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak72 (tak64 (- x 1) y z)
+                       (tak92 (- y 1) z x)
+                       (tak24 (- z 1) x y)))))
+  (define (tak72 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak73 (tak1 (- x 1) y z)
+                       (tak3 (- y 1) z x)
+                       (tak41 (- z 1) x y)))))
+  (define (tak73 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak74 (tak38 (- x 1) y z)
+                       (tak14 (- y 1) z x)
+                       (tak58 (- z 1) x y)))))
+  (define (tak74 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak75 (tak75 (- x 1) y z)
+                       (tak25 (- y 1) z x)
+                       (tak75 (- z 1) x y)))))
+  (define (tak75 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak76 (tak12 (- x 1) y z)
+                       (tak36 (- y 1) z x)
+                       (tak92 (- z 1) x y)))))
+  (define (tak76 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak77 (tak49 (- x 1) y z)
+                       (tak47 (- y 1) z x)
+                       (tak9 (- z 1) x y)))))
+  (define (tak77 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak78 (tak86 (- x 1) y z)
+                       (tak58 (- y 1) z x)
+                       (tak26 (- z 1) x y)))))
+  (define (tak78 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak79 (tak23 (- x 1) y z)
+                       (tak69 (- y 1) z x)
+                       (tak43 (- z 1) x y)))))
+  (define (tak79 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak80 (tak60 (- x 1) y z)
+                       (tak80 (- y 1) z x)
+                       (tak60 (- z 1) x y)))))
+  (define (tak80 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak81 (tak97 (- x 1) y z)
+                       (tak91 (- y 1) z x)
+                       (tak77 (- z 1) x y)))))
+  (define (tak81 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak82 (tak34 (- x 1) y z)
+                       (tak2 (- y 1) z x)
+                       (tak94 (- z 1) x y)))))
+  (define (tak82 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak83 (tak71 (- x 1) y z)
+                       (tak13 (- y 1) z x)
+                       (tak11 (- z 1) x y)))))
+  (define (tak83 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak84 (tak8 (- x 1) y z)
+                       (tak24 (- y 1) z x)
+                       (tak28 (- z 1) x y)))))
+  (define (tak84 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak85 (tak45 (- x 1) y z)
+                       (tak35 (- y 1) z x)
+                       (tak45 (- z 1) x y)))))
+  (define (tak85 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak86 (tak82 (- x 1) y z)
+                       (tak46 (- y 1) z x)
+                       (tak62 (- z 1) x y)))))
+  (define (tak86 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak87 (tak19 (- x 1) y z)
+                       (tak57 (- y 1) z x)
+                       (tak79 (- z 1) x y)))))
+  (define (tak87 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak88 (tak56 (- x 1) y z)
+                       (tak68 (- y 1) z x)
+                       (tak96 (- z 1) x y)))))
+  (define (tak88 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak89 (tak93 (- x 1) y z)
+                       (tak79 (- y 1) z x)
+                       (tak13 (- z 1) x y)))))
+  (define (tak89 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak90 (tak30 (- x 1) y z)
+                       (tak90 (- y 1) z x)
+                       (tak30 (- z 1) x y)))))
+  (define (tak90 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak91 (tak67 (- x 1) y z)
+                       (tak1 (- y 1) z x)
+                       (tak47 (- z 1) x y)))))
+  (define (tak91 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak92 (tak4 (- x 1) y z)
+                       (tak12 (- y 1) z x)
+                       (tak64 (- z 1) x y)))))
+  (define (tak92 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak93 (tak41 (- x 1) y z)
+                       (tak23 (- y 1) z x)
+                       (tak81 (- z 1) x y)))))
+  (define (tak93 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak94 (tak78 (- x 1) y z)
+                       (tak34 (- y 1) z x)
+                       (tak98 (- z 1) x y)))))
+  (define (tak94 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak95 (tak15 (- x 1) y z)
+                       (tak45 (- y 1) z x)
+                       (tak15 (- z 1) x y)))))
+  (define (tak95 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak96 (tak52 (- x 1) y z)
+                       (tak56 (- y 1) z x)
+                       (tak32 (- z 1) x y)))))
+  (define (tak96 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak97 (tak89 (- x 1) y z)
+                       (tak67 (- y 1) z x)
+                       (tak49 (- z 1) x y)))))
+  (define (tak97 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak98 (tak26 (- x 1) y z)
+                       (tak78 (- y 1) z x)
+                       (tak66 (- z 1) x y)))))
+  (define (tak98 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak99 (tak63 (- x 1) y z)
+                       (tak89 (- y 1) z x)
+                       (tak83 (- z 1) x y)))))
+  (define (tak99 x y z)
+    (cond ((not (< y x)) z)
+          (else (tak0 (tak0 (- x 1) y z)
+                      (tak0 (- y 1) z x)
+                      (tak0 (- z 1) x y)))))
+
+  (tak0 x y z))
+ 
+;;; call:  (tak0 18 12 6)
+
+(let ((input (with-input-from-file "input.txt" read)))
+  (time
+   (let loop ((n 500) (v 0))
+     (if (zero? n)
+         v
+         (loop (- n 1) (tak 18 12 (if input 6 0)))))))
diff --git a/benchmarks/gabriel/triangle.sch b/benchmarks/gabriel/triangle.sch
new file mode 100644
index 00000000..baeddd27
--- /dev/null
+++ b/benchmarks/gabriel/triangle.sch
@@ -0,0 +1,85 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File:         triangle.sch
+; Description:  TRIANGLE benchmark
+; Author:       Richard Gabriel
+; Created:      12-Apr-85
+; Modified:     12-Apr-85 10:30:32 (Bob Shaw)
+;               11-Aug-87 (Will Clinger)
+;               22-Jan-88 (Will Clinger)
+; Language:     Scheme
+; Status:       Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; TRIANG -- Board game benchmark.
+
+(define *board* (make-vector 16 1))
+(define *sequence* (make-vector 14 0))
+(define *a* (make-vector 37))
+(define *b* (make-vector 37))
+(define *c* (make-vector 37))
+(define *answer* '())
+(define *final* '())
+
+(define (last-position)
+  (do ((i 1 (+ i 1)))
+      ((or (= i 16) (= 1 (vector-ref *board* i)))
+       (if (= i 16) 0 i))))
+ 
+(define (ttry i depth)
+  (cond ((= depth 14)
+         (let ((lp (last-position)))
+           (if (not (member lp *final*))
+             (set! *final* (cons lp *final*))))
+         (set! *answer*
+               (cons (cdr (vector->list *sequence*)) *answer*))
+         #t)
+        ((and (= 1 (vector-ref *board* (vector-ref *a* i)))
+              (= 1 (vector-ref *board* (vector-ref *b* i)))
+              (= 0 (vector-ref *board* (vector-ref *c* i))))
+         (vector-set! *board* (vector-ref *a* i) 0)
+         (vector-set! *board* (vector-ref *b* i) 0)
+         (vector-set! *board* (vector-ref *c* i) 1)
+         (vector-set! *sequence* depth i)
+         (do ((j 0 (+ j 1))
+              (depth (+ depth 1)))
+             ((or (= j 36) (ttry j depth)) #f))
+         (vector-set! *board* (vector-ref *a* i) 1)
+         (vector-set! *board* (vector-ref *b* i) 1)
+         (vector-set! *board* (vector-ref *c* i) 0) '())
+        (else #f)))
+ 
+(define (gogogo i)
+  (let ((*answer* '())
+        (*final* '()))
+    (ttry i 1)))
+ 
+(for-each (lambda (i x) (vector-set! *a* i x))
+          '(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)
+          '(1 2 4 3 5 6 1 3 6 2 5 4 11 12
+            13 7 8 4 4 7 11 8 12 13 6 10
+            15 9 14 13 13 14 15 9 10
+             6 6))
+(for-each (lambda (i x) (vector-set! *b* i x))
+          '(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)
+          '(2 4 7 5 8 9 3 6 10 5 9 8
+            12 13 14 8 9 5 2 4 7 5 8
+            9 3 6 10 5 9 8 12 13 14
+            8 9 5 5))
+(for-each (lambda (i x) (vector-set! *c* i x))
+          '(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)
+          '(4 7 11 8 12 13 6 10 15 9 14 13
+            13 14 15 9 10 6 1 2 4 3 5 6 1
+            3 6 2 5 4 11 12 13 7 8 4 4))
+(vector-set! *board* 5 0)
+ 
+;;; call:  (gogogo 22))
+ 
+(time (let loop ((n 100000))
+        (if (zero? n)
+            'done
+            (begin
+              (gogogo 22)
+              (loop (- n 1))))))
diff --git a/benchmarks/shootout/binarytrees.chibi b/benchmarks/shootout/binarytrees.chibi
new file mode 100755
index 00000000..c0d6b637
--- /dev/null
+++ b/benchmarks/shootout/binarytrees.chibi
@@ -0,0 +1,46 @@
+#! /usr/bin/env chibi-scheme
+
+;;; The Computer Language Benchmarks Game
+;;; http://shootout.alioth.debian.org/
+
+(import (chibi) (srfi 9))
+
+(define-record-type node
+  (make-node value left right)
+  node?
+  (value node-value node-value-set!)
+  (left node-left node-left-set!)
+  (right node-right node-right-set!))
+
+(define (make value depth)
+  (if (zero? depth)
+      (make-node value #f #f)
+      (let ((v (* value 2))
+            (d (- depth 1)))
+        (make-node value (make (- v 1) d) (make v d)))))
+
+(define (check n)
+  (if n
+      (+ (node-value n) (- (check (node-left n)) (check (node-right n))))
+      0))
+
+(define (print . args) (for-each display args) (newline))
+
+(let* ((args (command-line))
+       (n (string->number (cadr args)))
+       (min-depth 4)
+       (max-depth (max (+ min-depth 2) n))
+       (stretch-depth (+ max-depth 1)))
+  (print "stretch tree of depth " stretch-depth "\t check: "
+         (check (make 0 stretch-depth)))
+  (let ((long-lived-tree (make 0 max-depth)))
+    (do ((d min-depth (+ d 2)))
+        ((>= d max-depth))
+      (let ((iterations (* 2 (+ (- max-depth d) min-depth))))
+        (print (* 2 iterations) "\t trees of depth " d "\t check: "
+               (do ((i 0 (+ i 1))
+                    (c 0 (+ c (check (make i d)) (check (make (- i) d)))))
+                   ((>= i iterations)
+                    c)))))
+    (print "long lived tree of depth " max-depth "\t check: "
+           (check long-lived-tree))))
diff --git a/benchmarks/shootout/chameneos-redux.chibi b/benchmarks/shootout/chameneos-redux.chibi
new file mode 100644
index 00000000..113d2afd
--- /dev/null
+++ b/benchmarks/shootout/chameneos-redux.chibi
@@ -0,0 +1,107 @@
+#! /usr/bin/env chibi-scheme
+
+;;; The Computer Language Benchmarks Game
+;;; http://shootout.alioth.debian.org/
+
+;;; based on Racket version by Matthew Flatt
+
+(import (chibi)
+        (srfi 18)
+        (chibi match))
+
+(define (print . args)
+  (for-each display args)
+  (newline))
+
+(define (change c1 c2)
+  (case c1
+    ((red)
+     (case c2 ((blue) 'yellow) ((yellow) 'blue) (else c1)))
+    ((yellow)
+     (case c2 ((blue) 'red) ((red) 'blue) (else c1)))
+    ((blue)
+     (case c2 ((yellow) 'red) ((red) 'yellow) (else c1)))))
+
+(let ((colors '(blue red yellow)))
+  (for-each
+   (lambda (a)
+     (for-each
+      (lambda (b)
+        (print a " + " b " -> " (change a b)))
+      colors))
+   colors))
+
+(define (place meeting-ch n)
+  (thread-start!
+   (make-thread
+    (lambda ()
+      (let loop ((n n))
+        (if (<= n 0)
+            ;; Fade all:
+            (let loop ()
+              (let ((c (channel-get meeting-ch)))
+                (channel-put (car c) #f)
+                (loop)))
+            ;; Let two meet:
+            (match-let (((ch1 . v1) (channel-get meeting-ch))
+                        ((ch2 . v2) (channel-get meeting-ch)))
+                       (channel-put ch1 v2)
+                       (channel-put ch2 v1)
+                       (loop (- n 1)))))))))
+
+(define (creature color meeting-ch result-ch)
+  (thread-start!
+   (make-thread
+    (lambda ()
+      (let ((ch (make-channel))
+            (name (gensym)))
+        (let loop ((color color) (met 0) (same 0))
+          (channel-put meeting-ch (cons ch (cons color name)))
+          (match (channel-get ch)
+                 ((other-color . other-name)
+                  ;; Meet:
+                  (sleep)         ; avoid imbalance from weak fairness
+                  (loop (change color other-color)
+                        (add1 met)
+                        (+ same (if (eq? name other-name)
+                                    1
+                                    0))))
+                 (#f
+                  ;; Done:
+                  (channel-put result-ch (cons met same))))))))))
+
+(define (spell n)
+  (for-each
+   (lambda (i)
+     (display " ")
+     (display (vector-ref digits (- (char->integer i) (char->integer #\0)))))
+   (string->list (number->string n))))
+
+(define digits
+  '#("zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"))
+
+(define (go n inits)
+  (let ((result-ch (make-channel))
+        (meeting-ch (make-channel)))
+    (place meeting-ch n)
+    (newline)
+    (for-each
+     (lambda (init)
+       (print " " init)
+       (creature init meeting-ch result-ch))
+     inits)
+    (newline)
+    (let ((results (map (lambda (i) (channel-get result-ch)) inits)))
+      (for-each
+       (lambda (r)
+         (display (car r))
+         (spell (cdr r))
+         (newline))
+       results)
+      (spell (apply + (map car results)))
+      (newline))))
+
+(let ((n (string->number (cadr (command-line)))))
+  (go n '(blue red yellow))
+  (go n '(blue red yellow red yellow blue red yellow red blue))
+  (newline))
diff --git a/benchmarks/shootout/knucleotide-input.txt b/benchmarks/shootout/knucleotide-input.txt
new file mode 100644
index 00000000..fd4414b1
--- /dev/null
+++ b/benchmarks/shootout/knucleotide-input.txt
@@ -0,0 +1,4171 @@
+>ONE Homo sapiens alu
+GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGA
+TCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACT
+AAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAG
+GCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCG
+CCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGT
+GGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCA
+GGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAA
+TTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAG
+AATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCA
+GCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGT
+AATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACC
+AGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTG
+GTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACC
+CGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAG
+AGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTT
+TGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACA
+TGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCT
+GTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGG
+TTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGT
+CTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGG
+CGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCG
+TCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTA
+CTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCG
+AGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCG
+GGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACC
+TGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAA
+TACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGA
+GGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACT
+GCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTC
+ACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGT
+TCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGC
+CGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCG
+CTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTG
+GGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCC
+CAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCT
+GGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGC
+GCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGA
+GGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGA
+GACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGA
+GGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTG
+AAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAAT
+CCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCA
+GTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAA
+AAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGC
+GGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCT
+ACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGG
+GAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATC
+GCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGC
+GGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGG
+TCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAA
+AAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAG
+GAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACT
+CCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCC
+TGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAG
+ACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGC
+GTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGA
+ACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGA
+CAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCA
+CTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCA
+ACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCG
+CCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGG
+AGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTC
+CGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCG
+AGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACC
+CCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAG
+CTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAG
+CCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGG
+CCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATC
+ACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAA
+AAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGC
+TGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCC
+ACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGG
+CTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGG
+AGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATT
+AGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAA
+TCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGC
+CTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAA
+TCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAG
+CCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGT
+GGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCG
+GGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAG
+CGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTG
+GGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATG
+GTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGT
+AATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTT
+GCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCT
+CAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCG
+GGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTC
+TCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACT
+CGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAG
+ATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGG
+CGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTG
+AGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATA
+CAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGG
+CAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGC
+ACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCAC
+GCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTC
+GAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCG
+GGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCT
+TGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGG
+CGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCA
+GCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGG
+CCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGC
+GCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGG
+CGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGA
+CTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGG
+CCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAA
+ACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCC
+CAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGT
+GAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAA
+AGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGG
+ATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTAC
+TAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGA
+GGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGC
+GCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGG
+TGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTC
+AGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAA
+ATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGA
+GAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC
+AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTG
+TAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGAC
+CAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGT
+GGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAAC
+CCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACA
+GAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACT
+TTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAAC
+ATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCC
+TGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAG
+GTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCG
+TCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAG
+GCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCC
+GTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCT
+ACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCC
+GAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCC
+GGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCAC
+CTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAA
+ATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTG
+AGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCAC
+TGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCT
+CACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAG
+TTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAG
+CCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATC
+GCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCT
+GGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATC
+CCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCC
+TGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGG
+CGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG
+AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCG
+AGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGG
+AGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGT
+GAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAA
+TCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGC
+AGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCA
+AAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGG
+CGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTC
+TACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCG
+GGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGAT
+CGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCG
+CGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAG
+GTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACA
+AAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCA
+GGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCAC
+TCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGC
+CTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGA
+GACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGG
+CGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTG
+AACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCG
+ACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGC
+ACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCC
+AACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGC
+GCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCG
+GAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACT
+CCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCC
+GAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAAC
+CCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA
+GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGA
+GCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAG
+GCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGAT
+CACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTA
+AAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGG
+CTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGC
+CACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTG
+GCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAG
+GAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAAT
+TAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGA
+ATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAG
+CCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTA
+ATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCA
+GCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGG
+TGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCC
+GGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGA
+GCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTT
+GGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACAT
+GGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTG
+TAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGT
+TGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTC
+TCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGC
+GGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGT
+CTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTAC
+TCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGA
+GATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGG
+GCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCT
+GAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT
+ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAG
+GCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTG
+CACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCA
+CGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTT
+CGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCC
+GGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGC
+TTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGG
+GCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCC
+AGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTG
+GCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCG
+CGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAG
+GCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAG
+ACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAG
+GCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGA
+AACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATC
+CCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAG
+TGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAA
+AAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCG
+GATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTA
+CTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGG
+AGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCG
+CGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCG
+GTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGT
+CAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAA
+AATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGG
+AGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTC
+CAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCT
+GTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA
+CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCG
+TGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAA
+CCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGAC
+AGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCAC
+TTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAA
+CATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGC
+CTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGA
+GGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCC
+GTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGA
+GGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCC
+CGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGC
+TACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGC
+CGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGC
+CGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCA
+CCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAA
+AATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCT
+GAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCA
+CTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGC
+TCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGA
+GTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTA
+GCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAAT
+CGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCC
+TGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAAT
+CCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGC
+CTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTG
+GCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGG
+GAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGC
+GAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG
+GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGG
+TGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTA
+ATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTG
+CAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTC
+AAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGG
+GCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCT
+CTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTC
+GGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGA
+TCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGC
+GCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGA
+GGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATAC
+AAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGC
+AGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCA
+CTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACG
+CCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCG
+AGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGG
+GCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTT
+GAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGC
+GACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAG
+CACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGC
+CAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCG
+CGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGC
+GGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGAC
+TCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGC
+CGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAA
+CCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCC
+AGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTG
+AGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA
+GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGA
+TCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACT
+AAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAG
+GCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCG
+CCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGT
+GGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCA
+GGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAA
+TTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAG
+AATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCA
+GCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGT
+AATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACC
+AGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTG
+GTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACC
+CGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAG
+AGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTT
+TGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACA
+TGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCT
+GTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGG
+TTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGT
+CTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGG
+CGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCG
+TCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTA
+CTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCG
+AGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCG
+GGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACC
+TGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAA
+TACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGA
+GGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACT
+GCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTC
+ACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGT
+TCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGC
+CGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCG
+CTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTG
+GGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCC
+CAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCT
+GGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGC
+GCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGA
+GGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGA
+GACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGA
+GGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTG
+AAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAAT
+CCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCA
+GTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAA
+AAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGC
+GGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCT
+ACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGG
+GAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATC
+GCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGC
+GGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGG
+TCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAA
+AAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAG
+GAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACT
+CCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCC
+TGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAG
+ACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGC
+GTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGA
+ACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGA
+CAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCA
+CTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCA
+ACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCG
+CCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGG
+AGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTC
+CGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCG
+AGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACC
+CCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAG
+CTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAG
+CCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGG
+CCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATC
+ACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAA
+AAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGC
+TGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCC
+ACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGG
+CTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGG
+AGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATT
+AGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAA
+TCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGC
+CTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAA
+TCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAG
+CCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGT
+GGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCG
+GGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAG
+CGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTG
+GGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATG
+GTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGT
+AATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTT
+GCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCT
+CAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCG
+GGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTC
+TCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACT
+CGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAG
+ATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGG
+CGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTG
+AGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATA
+CAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGG
+CAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGC
+ACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCAC
+GCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTC
+GAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCG
+GGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCT
+TGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGG
+CGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCA
+GCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGG
+CCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGC
+GCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGG
+CGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGA
+CTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGG
+CCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAA
+ACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCC
+CAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGT
+GAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAA
+AGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGG
+ATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTAC
+TAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGA
+GGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGC
+GCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGG
+TGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTC
+AGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAA
+ATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGA
+GAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC
+AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTG
+TAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGAC
+CAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGT
+GGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAAC
+CCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACA
+GAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACT
+TTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAAC
+ATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCC
+TGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAG
+GTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCG
+TCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAG
+GCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCC
+GTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCT
+ACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCC
+GAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCC
+GGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCAC
+CTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAA
+ATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTG
+AGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCAC
+TGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCT
+CACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAG
+TTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAG
+CCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATC
+GCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCT
+GGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATC
+CCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCC
+TGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGG
+CGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG
+AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCG
+AGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGG
+AGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGT
+GAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAA
+TCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGC
+AGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCA
+AAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGG
+CGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTC
+TACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCG
+GGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGAT
+CGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCG
+CGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAG
+GTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACA
+AAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCA
+GGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCAC
+TCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGC
+CTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGA
+GACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGG
+CGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTG
+AACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCG
+ACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGC
+ACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCC
+AACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGC
+GCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCG
+GAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACT
+CCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCC
+GAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAAC
+CCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA
+GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGA
+GCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAG
+GCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGAT
+CACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTA
+AAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGG
+CTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGC
+CACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTG
+GCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAG
+GAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAAT
+TAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGA
+ATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAG
+CCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTA
+ATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCA
+GCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGG
+TGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCC
+GGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGA
+GCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTT
+GGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACAT
+GGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTG
+TAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGT
+TGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTC
+TCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGC
+GGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGT
+CTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTAC
+TCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGA
+GATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGG
+GCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCT
+GAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT
+ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAG
+GCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTG
+CACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCA
+CGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTT
+CGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCC
+GGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGC
+TTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGG
+GCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCC
+AGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTG
+GCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCG
+CGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAG
+GCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAG
+ACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAG
+GCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGA
+AACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATC
+CCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAG
+TGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAA
+AAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCG
+GATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTA
+CTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGG
+AGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCG
+CGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCG
+GTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGT
+CAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAA
+AATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGG
+AGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTC
+CAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCT
+GTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA
+CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCG
+TGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAA
+CCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGAC
+AGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCAC
+TTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAA
+CATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGC
+CTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGA
+GGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCC
+GTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGA
+GGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCC
+CGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGC
+TACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGC
+CGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGC
+CGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCA
+CCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAA
+AATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCT
+GAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCA
+CTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGC
+TCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGA
+GTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTA
+GCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAAT
+CGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCC
+TGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAAT
+CCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGC
+CTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTG
+GCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGG
+GAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGC
+GAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG
+GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGG
+TGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTA
+ATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTG
+CAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTC
+AAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGG
+GCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCT
+CTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTC
+GGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGA
+TCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGC
+GCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGA
+GGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATAC
+AAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGC
+AGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCA
+CTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACG
+CCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCG
+AGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGG
+GCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTT
+GAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGC
+GACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAG
+CACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGC
+CAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCG
+CGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGC
+GGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGAC
+TCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGC
+CGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAA
+CCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCC
+AGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTG
+AGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA
+GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGA
+TCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACT
+AAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAG
+GCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCG
+CCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGT
+GGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCA
+GGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAA
+TTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAG
+AATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCA
+GCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGT
+AATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACC
+AGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTG
+GTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACC
+CGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAG
+AGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTT
+TGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACA
+TGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCT
+GTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGG
+TTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGT
+CTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGG
+CGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCG
+TCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTA
+CTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCG
+AGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCG
+GGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACC
+TGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAA
+TACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGA
+GGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACT
+GCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTC
+ACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGT
+TCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGC
+CGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCG
+CTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTG
+GGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCC
+CAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCT
+GGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGC
+GCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGA
+GGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGA
+GACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGA
+GGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTG
+AAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAAT
+CCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCA
+GTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAA
+AAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGC
+GGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCT
+ACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGG
+GAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATC
+GCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGC
+GGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGG
+TCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAA
+AAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAG
+GAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACT
+CCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCC
+TGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAG
+ACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGC
+GTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGA
+ACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGA
+CAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCA
+CTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCA
+ACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCG
+CCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGG
+AGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTC
+CGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCG
+AGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACC
+CCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAG
+CTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAG
+CCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGG
+CCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATC
+ACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAA
+AAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGC
+TGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCC
+ACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGG
+CTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGG
+AGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATT
+AGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAA
+TCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGC
+CTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAA
+TCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAG
+CCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGT
+GGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCG
+GGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAG
+CGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTG
+GGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATG
+GTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGT
+AATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTT
+GCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCT
+CAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCG
+GGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTC
+TCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACT
+CGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAG
+ATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGG
+CGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTG
+AGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATA
+CAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGG
+CAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGC
+ACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCAC
+GCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTC
+GAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCG
+GGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCT
+TGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGG
+CGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCA
+GCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGG
+CCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGC
+GCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGG
+CGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGA
+CTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGG
+CCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAA
+ACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCC
+CAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGT
+GAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAA
+AGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGG
+ATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTAC
+TAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGA
+GGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGC
+GCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGG
+TGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTC
+AGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAA
+ATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGA
+GAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC
+AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTG
+TAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGAC
+CAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGT
+GGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAAC
+CCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACA
+GAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACT
+TTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAAC
+ATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCC
+TGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAG
+GTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCG
+TCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAG
+GCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCC
+GTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCT
+ACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCC
+GAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCC
+GGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCAC
+CTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAA
+ATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTG
+AGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCAC
+TGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCT
+CACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAG
+TTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAG
+CCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATC
+GCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCT
+GGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATC
+CCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCC
+TGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGG
+CGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG
+AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCG
+AGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGG
+AGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGT
+GAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAA
+TCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGC
+AGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCA
+AAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGG
+CGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTC
+TACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCG
+GGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGAT
+CGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCG
+CGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAG
+GTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACA
+AAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCA
+GGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCAC
+TCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGC
+CTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGA
+GACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGG
+CGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTG
+AACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCG
+ACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGC
+ACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCC
+AACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGC
+GCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCG
+GAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACT
+CCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCC
+GAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAAC
+CCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA
+GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGA
+GCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAG
+GCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGAT
+CACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTA
+AAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGG
+CTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGC
+CACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTG
+GCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAG
+GAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAAT
+TAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGA
+ATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAG
+CCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTA
+ATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCA
+GCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGG
+TGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCC
+GGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGA
+GCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTT
+GGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACAT
+GGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTG
+TAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGT
+TGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTC
+TCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGC
+GGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGT
+CTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTAC
+TCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGA
+GATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGG
+GCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCT
+GAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT
+ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAG
+GCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTG
+CACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCA
+CGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTT
+CGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCC
+GGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGC
+TTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGG
+GCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCC
+AGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTG
+GCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCG
+CGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAG
+GCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAG
+ACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAG
+GCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGA
+AACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATC
+CCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAG
+TGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAA
+AAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCG
+GATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTA
+CTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGG
+AGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCG
+CGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCG
+GTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGT
+CAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAA
+AATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGG
+AGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTC
+CAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCT
+GTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA
+CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCG
+TGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAA
+CCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGAC
+AGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCAC
+TTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAA
+CATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGC
+CTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGA
+GGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCC
+GTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGA
+GGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCC
+CGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGC
+TACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGC
+CGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGC
+CGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCA
+CCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAA
+AATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCT
+GAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCA
+CTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGC
+TCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGA
+GTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTA
+GCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAAT
+CGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCC
+TGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAAT
+CCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGC
+CTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTG
+GCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGG
+GAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGC
+GAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG
+GAGGCCGAGGCGGGCGGATC
+>TWO IUB ambiguity codes
+cttBtatcatatgctaKggNcataaaSatgtaaaDcDRtBggDtctttataattcBgtcg
+tactDtDagcctatttSVHtHttKtgtHMaSattgWaHKHttttagacatWatgtRgaaa
+NtactMcSMtYtcMgRtacttctWBacgaaatatagScDtttgaagacacatagtVgYgt
+cattHWtMMWcStgttaggKtSgaYaaccWStcgBttgcgaMttBYatcWtgacaYcaga
+gtaBDtRacttttcWatMttDBcatWtatcttactaBgaYtcttgttttttttYaaScYa
+HgtgttNtSatcMtcVaaaStccRcctDaataataStcYtRDSaMtDttgttSagtRRca
+tttHatSttMtWgtcgtatSSagactYaaattcaMtWatttaSgYttaRgKaRtccactt
+tattRggaMcDaWaWagttttgacatgttctacaaaRaatataataaMttcgDacgaSSt
+acaStYRctVaNMtMgtaggcKatcttttattaaaaagVWaHKYagtttttatttaacct
+tacgtVtcVaattVMBcttaMtttaStgacttagattWWacVtgWYagWVRctDattBYt
+gtttaagaagattattgacVatMaacattVctgtBSgaVtgWWggaKHaatKWcBScSWa
+accRVacacaaactaccScattRatatKVtactatatttHttaagtttSKtRtacaaagt
+RDttcaaaaWgcacatWaDgtDKacgaacaattacaRNWaatHtttStgttattaaMtgt
+tgDcgtMgcatBtgcttcgcgaDWgagctgcgaggggVtaaScNatttacttaatgacag
+cccccacatYScaMgtaggtYaNgttctgaMaacNaMRaacaaacaKctacatagYWctg
+ttWaaataaaataRattagHacacaagcgKatacBttRttaagtatttccgatctHSaat
+actcNttMaagtattMtgRtgaMgcataatHcMtaBSaRattagttgatHtMttaaKagg
+YtaaBataSaVatactWtataVWgKgttaaaacagtgcgRatatacatVtHRtVYataSa
+KtWaStVcNKHKttactatccctcatgWHatWaRcttactaggatctataDtDHBttata
+aaaHgtacVtagaYttYaKcctattcttcttaataNDaaggaaaDYgcggctaaWSctBa
+aNtgctggMBaKctaMVKagBaactaWaDaMaccYVtNtaHtVWtKgRtcaaNtYaNacg
+gtttNattgVtttctgtBaWgtaattcaagtcaVWtactNggattctttaYtaaagccgc
+tcttagHVggaYtgtNcDaVagctctctKgacgtatagYcctRYHDtgBattDaaDgccK
+tcHaaStttMcctagtattgcRgWBaVatHaaaataYtgtttagMDMRtaataaggatMt
+ttctWgtNtgtgaaaaMaatatRtttMtDgHHtgtcattttcWattRSHcVagaagtacg
+ggtaKVattKYagactNaatgtttgKMMgYNtcccgSKttctaStatatNVataYHgtNa
+BKRgNacaactgatttcctttaNcgatttctctataScaHtataRagtcRVttacDSDtt
+aRtSatacHgtSKacYagttMHtWataggatgactNtatSaNctataVtttRNKtgRacc
+tttYtatgttactttttcctttaaacatacaHactMacacggtWataMtBVacRaSaatc
+cgtaBVttccagccBcttaRKtgtgcctttttRtgtcagcRttKtaaacKtaaatctcac
+aattgcaNtSBaaccgggttattaaBcKatDagttactcttcattVtttHaaggctKKga
+tacatcBggScagtVcacattttgaHaDSgHatRMaHWggtatatRgccDttcgtatcga
+aacaHtaagttaRatgaVacttagattVKtaaYttaaatcaNatccRttRRaMScNaaaD
+gttVHWgtcHaaHgacVaWtgttScactaagSgttatcttagggDtaccagWattWtRtg
+ttHWHacgattBtgVcaYatcggttgagKcWtKKcaVtgaYgWctgYggVctgtHgaNcV
+taBtWaaYatcDRaaRtSctgaHaYRttagatMatgcatttNattaDttaattgttctaa
+ccctcccctagaWBtttHtBccttagaVaatMcBHagaVcWcagBVttcBtaYMccagat
+gaaaaHctctaacgttagNWRtcggattNatcRaNHttcagtKttttgWatWttcSaNgg
+gaWtactKKMaacatKatacNattgctWtatctaVgagctatgtRaHtYcWcttagccaa
+tYttWttaWSSttaHcaaaaagVacVgtaVaRMgattaVcDactttcHHggHRtgNcctt
+tYatcatKgctcctctatVcaaaaKaaaagtatatctgMtWtaaaacaStttMtcgactt
+taSatcgDataaactaaacaagtaaVctaggaSccaatMVtaaSKNVattttgHccatca
+cBVctgcaVatVttRtactgtVcaattHgtaaattaaattttYtatattaaRSgYtgBag
+aHSBDgtagcacRHtYcBgtcacttacactaYcgctWtattgSHtSatcataaatataHt
+cgtYaaMNgBaatttaRgaMaatatttBtttaaaHHKaatctgatWatYaacttMctctt
+ttVctagctDaaagtaVaKaKRtaacBgtatccaaccactHHaagaagaaggaNaaatBW
+attccgStaMSaMatBttgcatgRSacgttVVtaaDMtcSgVatWcaSatcttttVatag
+ttactttacgatcaccNtaDVgSRcgVcgtgaacgaNtaNatatagtHtMgtHcMtagaa
+attBgtataRaaaacaYKgtRccYtatgaagtaataKgtaaMttgaaRVatgcagaKStc
+tHNaaatctBBtcttaYaBWHgtVtgacagcaRcataWctcaBcYacYgatDgtDHccta
+aagacYRcaggattHaYgtKtaatgcVcaataMYacccatatcacgWDBtgaatcBaata
+cKcttRaRtgatgaBDacggtaattaaYtataStgVHDtDctgactcaaatKtacaatgc
+gYatBtRaDatHaactgtttatatDttttaaaKVccYcaaccNcBcgHaaVcattHctcg
+attaaatBtatgcaaaaatYMctSactHatacgaWacattacMBgHttcgaatVaaaaca
+BatatVtctgaaaaWtctRacgBMaatSgRgtgtcgactatcRtattaScctaStagKga
+DcWgtYtDDWKRgRtHatRtggtcgaHgggcgtattaMgtcagccaBggWVcWctVaaat
+tcgNaatcKWagcNaHtgaaaSaaagctcYctttRVtaaaatNtataaccKtaRgtttaM
+tgtKaBtRtNaggaSattHatatWactcagtgtactaKctatttgRYYatKatgtccgtR
+tttttatttaatatVgKtttgtatgtNtataRatWYNgtRtHggtaaKaYtKSDcatcKg
+taaYatcSRctaVtSMWtVtRWHatttagataDtVggacagVcgKWagBgatBtaaagNc
+aRtagcataBggactaacacRctKgttaatcctHgDgttKHHagttgttaatgHBtatHc
+DaagtVaBaRccctVgtgDtacRHSctaagagcggWYaBtSaKtHBtaaactYacgNKBa
+VYgtaacttagtVttcttaatgtBtatMtMtttaattaatBWccatRtttcatagVgMMt
+agctStKctaMactacDNYgKYHgaWcgaHgagattacVgtttgtRaSttaWaVgataat
+gtgtYtaStattattMtNgWtgttKaccaatagNYttattcgtatHcWtctaaaNVYKKt
+tWtggcDtcgaagtNcagatacgcattaagaccWctgcagcttggNSgaNcHggatgtVt
+catNtRaaBNcHVagagaaBtaaSggDaatWaatRccaVgggStctDaacataKttKatt
+tggacYtattcSatcttagcaatgaVBMcttDattctYaaRgatgcattttNgVHtKcYR
+aatRKctgtaaacRatVSagctgtWacBtKVatctgttttKcgtctaaDcaagtatcSat
+aWVgcKKataWaYttcccSaatgaaaacccWgcRctWatNcWtBRttYaattataaNgac
+acaatagtttVNtataNaYtaatRaVWKtBatKagtaatataDaNaaaaataMtaagaaS
+tccBcaatNgaataWtHaNactgtcDtRcYaaVaaaaaDgtttRatctatgHtgttKtga
+aNSgatactttcgagWaaatctKaaDaRttgtggKKagcDgataaattgSaacWaVtaNM
+acKtcaDaaatttctRaaVcagNacaScRBatatctRatcctaNatWgRtcDcSaWSgtt
+RtKaRtMtKaatgttBHcYaaBtgatSgaSWaScMgatNtctcctatttctYtatMatMt
+RRtSaattaMtagaaaaStcgVgRttSVaScagtgDtttatcatcatacRcatatDctta
+tcatVRtttataaHtattcYtcaaaatactttgVctagtaaYttagatagtSYacKaaac
+gaaKtaaatagataatSatatgaaatSgKtaatVtttatcctgKHaatHattagaaccgt
+YaaHactRcggSBNgtgctaaBagBttgtRttaaattYtVRaaaattgtaatVatttctc
+ttcatgBcVgtgKgaHaaatattYatagWacNctgaaMcgaattStagWaSgtaaKagtt
+ttaagaDgatKcctgtaHtcatggKttVDatcaaggtYcgccagNgtgcVttttagagat
+gctaccacggggtNttttaSHaNtatNcctcatSaaVgtactgBHtagcaYggYVKNgta
+KBcRttgaWatgaatVtagtcgattYgatgtaatttacDacSctgctaaaStttaWMagD
+aaatcaVYctccgggcgaVtaaWtStaKMgDtttcaaMtVgBaatccagNaaatcYRMBg
+gttWtaaScKttMWtYataRaDBMaDataatHBcacDaaKDactaMgagttDattaHatH
+taYatDtattDcRNStgaatattSDttggtattaaNSYacttcDMgYgBatWtaMagact
+VWttctttgYMaYaacRgHWaattgRtaagcattctMKVStatactacHVtatgatcBtV
+NataaBttYtSttacKgggWgYDtgaVtYgatDaacattYgatggtRDaVDttNactaSa
+MtgNttaacaaSaBStcDctaccacagacgcaHatMataWKYtaYattMcaMtgSttDag
+cHacgatcaHttYaKHggagttccgatYcaatgatRaVRcaagatcagtatggScctata
+ttaNtagcgacgtgKaaWaactSgagtMYtcttccaKtStaacggMtaagNttattatcg
+tctaRcactctctDtaacWYtgaYaSaagaWtNtatttRacatgNaatgttattgWDDcN
+aHcctgaaHacSgaataaRaataMHttatMtgaSDSKatatHHaNtacagtccaYatWtc
+actaactatKDacSaStcggataHgYatagKtaatKagStaNgtatactatggRHacttg
+tattatgtDVagDVaRctacMYattDgtttYgtctatggtKaRSttRccRtaaccttaga
+gRatagSaaMaacgcaNtatgaaatcaRaagataatagatactcHaaYKBctccaagaRa
+BaStNagataggcgaatgaMtagaatgtcaKttaaatgtaWcaBttaatRcggtgNcaca
+aKtttScRtWtgcatagtttWYaagBttDKgcctttatMggNttattBtctagVtacata
+aaYttacacaaRttcYtWttgHcaYYtaMgBaBatctNgcDtNttacgacDcgataaSat
+YaSttWtcctatKaatgcagHaVaacgctgcatDtgttaSataaaaYSNttatagtaNYt
+aDaaaNtggggacttaBggcHgcgtNtaaMcctggtVtaKcgNacNtatVaSWctWtgaW
+cggNaBagctctgaYataMgaagatBSttctatacttgtgtKtaattttRagtDtacata
+tatatgatNHVgBMtKtaKaNttDHaagatactHaccHtcatttaaagttVaMcNgHata
+tKtaNtgYMccttatcaaNagctggacStttcNtggcaVtattactHaSttatgNMVatt
+MMDtMactattattgWMSgtHBttStStgatatRaDaagattttctatMtaaaaaggtac
+taaVttaSacNaatactgMttgacHaHRttgMacaaaatagttaatatWKRgacDgaRta
+tatttattatcYttaWtgtBRtWatgHaaattHataagtVaDtWaVaWtgStcgtMSgaS
+RgMKtaaataVacataatgtaSaatttagtcgaaHtaKaatgcacatcggRaggSKctDc
+agtcSttcccStYtccRtctctYtcaaKcgagtaMttttcRaYDttgttatctaatcata
+NctctgctatcaMatactataggDaHaaSttMtaDtcNatataattctMcStaaBYtaNa
+gatgtaatHagagSttgWHVcttatKaYgDctcttggtgttMcRaVgSgggtagacaata
+aDtaattSaDaNaHaBctattgNtaccaaRgaVtKNtaaYggHtaKKgHcatctWtctDt
+ttctttggSDtNtaStagttataaacaattgcaBaBWggHgcaaaBtYgctaatgaaatW
+cDcttHtcMtWWattBHatcatcaaatctKMagtDNatttWaBtHaaaNgMttaaStagt
+tctctaatDtcRVaYttgttMtRtgtcaSaaYVgSWDRtaatagctcagDgcWWaaaBaa
+RaBctgVgggNgDWStNaNBKcBctaaKtttDcttBaaggBttgaccatgaaaNgttttt
+tttatctatgttataccaaDRaaSagtaVtDtcaWatBtacattaWacttaSgtattggD
+gKaaatScaattacgWcagKHaaccaYcRcaRttaDttRtttHgaHVggcttBaRgtccc
+tDatKaVtKtcRgYtaKttacgtatBtStaagcaattaagaRgBagSaattccSWYttta
+ttVaataNctgHgttaaNBgcVYgtRtcccagWNaaaacaDNaBcaaaaRVtcWMgBagM
+tttattacgDacttBtactatcattggaaatVccggttRttcatagttVYcatYaSHaHc
+ttaaagcNWaHataaaRWtctVtRYtagHtaaaYMataHYtNBctNtKaatattStgaMc
+BtRgctaKtgcScSttDgYatcVtggaaKtaagatWccHccgKYctaNNctacaWctttt
+gcRtgtVcgaKttcMRHgctaHtVaataaDtatgKDcttatBtDttggNtacttttMtga
+acRattaaNagaactcaaaBBVtcDtcgaStaDctgaaaSgttMaDtcgttcaccaaaag
+gWtcKcgSMtcDtatgtttStaaBtatagDcatYatWtaaaBacaKgcaDatgRggaaYc
+taRtccagattDaWtttggacBaVcHtHtaacDacYgtaatataMagaatgHMatcttat
+acgtatttttatattacHactgttataMgStYaattYaccaattgagtcaaattaYtgta
+tcatgMcaDcgggtcttDtKgcatgWRtataatatRacacNRBttcHtBgcRttgtgcgt
+catacMtttBctatctBaatcattMttMYgattaaVYatgDaatVagtattDacaacDMa
+tcMtHcccataagatgBggaccattVWtRtSacatgctcaaggggYtttDtaaNgNtaaB
+atggaatgtctRtaBgBtcNYatatNRtagaacMgagSaSDDSaDcctRagtVWSHtVSR
+ggaacaBVaccgtttaStagaacaMtactccagtttVctaaRaaHttNcttagcaattta
+ttaatRtaaaatctaacDaBttggSagagctacHtaaRWgattcaaBtctRtSHaNtgta
+cattVcaHaNaagtataccacaWtaRtaaVKgMYaWgttaKggKMtKcgWatcaDatYtK
+SttgtacgaccNctSaattcDcatcttcaaaDKttacHtggttHggRRaRcaWacaMtBW
+VHSHgaaMcKattgtaRWttScNattBBatYtaNRgcggaagacHSaattRtttcYgacc
+BRccMacccKgatgaacttcgDgHcaaaaaRtatatDtatYVtttttHgSHaSaatagct
+NYtaHYaVYttattNtttgaaaYtaKttWtctaNtgagaaaNctNDctaaHgttagDcRt
+tatagccBaacgcaRBtRctRtggtaMYYttWtgataatcgaataattattataVaaaaa
+ttacNRVYcaaMacNatRttcKatMctgaagactaattataaYgcKcaSYaatMNctcaa
+cgtgatttttBacNtgatDccaattattKWWcattttatatatgatBcDtaaaagttgaa
+VtaHtaHHtBtataRBgtgDtaataMttRtDgDcttattNtggtctatctaaBcatctaR
+atgNacWtaatgaagtcMNaacNgHttatactaWgcNtaStaRgttaaHacccgaYStac
+aaaatWggaYaWgaattattcMaactcBKaaaRVNcaNRDcYcgaBctKaacaaaaaSgc
+tccYBBHYaVagaatagaaaacagYtctVccaMtcgtttVatcaatttDRtgWctagtac
+RttMctgtDctttcKtWttttataaatgVttgBKtgtKWDaWagMtaaagaaattDVtag
+gttacatcatttatgtcgMHaVcttaBtVRtcgtaYgBRHatttHgaBcKaYWaatcNSc
+tagtaaaaatttacaatcactSWacgtaatgKttWattagttttNaggtctcaagtcact
+attcttctaagKggaataMgtttcataagataaaaatagattatDgcBVHWgaBKttDgc
+atRHaagcaYcRaattattatgtMatatattgHDtcaDtcaaaHctStattaatHaccga
+cNattgatatattttgtgtDtRatagSacaMtcRtcattcccgacacSattgttKaWatt
+NHcaacttccgtttSRtgtctgDcgctcaaMagVtBctBMcMcWtgtaacgactctcttR
+ggRKSttgYtYatDccagttDgaKccacgVatWcataVaaagaataMgtgataaKYaaat
+cHDaacgataYctRtcYatcgcaMgtNttaBttttgatttaRtStgcaacaaaataccVg
+aaDgtVgDcStctatatttattaaaaRKDatagaaagaKaaYYcaYSgKStctccSttac
+agtcNactttDVttagaaagMHttRaNcSaRaMgBttattggtttaRMggatggcKDgWR
+tNaataataWKKacttcKWaaagNaBttaBatMHtccattaacttccccYtcBcYRtaga
+ttaagctaaYBDttaNtgaaaccHcaRMtKtaaHMcNBttaNaNcVcgVttWNtDaBatg
+ataaVtcWKcttRggWatcattgaRagHgaattNtatttctctattaattaatgaDaaMa
+tacgttgggcHaYVaaNaDDttHtcaaHtcVVDgBVagcMacgtgttaaBRNtatRtcag
+taagaggtttaagacaVaaggttaWatctccgtVtaDtcDatttccVatgtacNtttccg
+tHttatKgScBatgtVgHtYcWagcaKtaMYaaHgtaattaSaHcgcagtWNaatNccNN
+YcacgVaagaRacttctcattcccRtgtgtaattagcSttaaStWaMtctNNcSMacatt
+ataaactaDgtatWgtagtttaagaaaattgtagtNagtcaataaatttgatMMYactaa
+tatcggBWDtVcYttcDHtVttatacYaRgaMaacaStaatcRttttVtagaDtcacWat
+ttWtgaaaagaaagNRacDtttStVatBaDNtaactatatcBSMcccaSttccggaMatg
+attaaWatKMaBaBatttgataNctgttKtVaagtcagScgaaaDggaWgtgttttKtWt
+atttHaatgtagttcactaaKMagttSYBtKtaYgaactcagagRtatagtVtatcaaaW
+YagcgNtaDagtacNSaaYDgatBgtcgataacYDtaaactacagWDcYKaagtttatta
+gcatcgagttKcatDaattgattatDtcagRtWSKtcgNtMaaaaacaMttKcaWcaaSV
+MaaaccagMVtaMaDtMaHaBgaacataBBVtaatVYaNSWcSgNtDNaaKacacBttta
+tKtgtttcaaHaMctcagtaacgtcgYtactDcgcctaNgagagcYgatattttaaattt
+ccattttacatttDaaRctattttWctttacgtDatYtttcagacgcaaVttagtaaKaa
+aRtgVtccataBggacttatttgtttaWNtgttVWtaWNVDaattgtatttBaagcBtaa
+BttaaVatcHcaVgacattccNggtcgacKttaaaRtagRtctWagaYggtgMtataatM
+tgaaRttattttgWcttNtDRRgMDKacagaaaaggaaaRStcccagtYccVattaNaaK
+StNWtgacaVtagaagcttSaaDtcacaacgDYacWDYtgtttKatcVtgcMaDaSKStV
+cgtagaaWaKaagtttcHaHgMgMtctataagBtKaaaKKcactggagRRttaagaBaaN
+atVVcgRcKSttDaactagtSttSattgttgaaRYatggttVttaataaHttccaagDtg
+atNWtaagHtgcYtaactRgcaatgMgtgtRaatRaNaacHKtagactactggaatttcg
+ccataacgMctRgatgttaccctaHgtgWaYcactcacYaattcttaBtgacttaaacct
+gYgaWatgBttcttVttcgttWttMcNYgtaaaatctYgMgaaattacNgaHgaacDVVM
+tttggtHtctaaRgtacagacgHtVtaBMNBgattagcttaRcttacaHcRctgttcaaD
+BggttKaacatgKtttYataVaNattccgMcgcgtagtRaVVaattaKaatggttRgaMc
+agtatcWBttNtHagctaatctagaaNaaacaYBctatcgcVctBtgcaaagDgttVtga
+HtactSNYtaaNccatgtgDacgaVtDcgKaRtacDcttgctaagggcagMDagggtBWR
+tttSgccttttttaacgtcHctaVtVDtagatcaNMaVtcVacatHctDWNaataRgcgt
+aVHaggtaaaaSgtttMtattDgBtctgatSgtRagagYtctSaKWaataMgattRKtaa
+catttYcgtaacacattRWtBtcggtaaatMtaaacBatttctKagtcDtttgcBtKYYB
+aKttctVttgttaDtgattttcttccacttgSaaacggaaaNDaattcYNNaWcgaaYat
+tttMgcBtcatRtgtaaagatgaWtgaccaYBHgaatagataVVtHtttVgYBtMctaMt
+cctgaDcYttgtccaaaRNtacagcMctKaaaggatttacatgtttaaWSaYaKttBtag
+DacactagctMtttNaKtctttcNcSattNacttggaacaatDagtattRtgSHaataat
+gccVgacccgatactatccctgtRctttgagaSgatcatatcgDcagWaaHSgctYYWta
+tHttggttctttatVattatcgactaagtgtagcatVgtgHMtttgtttcgttaKattcM
+atttgtttWcaaStNatgtHcaaaDtaagBaKBtRgaBgDtSagtatMtaacYaatYtVc
+KatgtgcaacVaaaatactKcRgtaYtgtNgBBNcKtcttaccttKgaRaYcaNKtactt
+tgagSBtgtRagaNgcaaaNcacagtVtttHWatgttaNatBgtttaatNgVtctgaata
+tcaRtattcttttttttRaaKcRStctcggDgKagattaMaaaKtcaHacttaataataK
+taRgDtKVBttttcgtKaggHHcatgttagHggttNctcgtatKKagVagRaaaggaaBt
+NatttVKcRttaHctaHtcaaatgtaggHccaBataNaNaggttgcWaatctgatYcaaa
+HaatWtaVgaaBttagtaagaKKtaaaKtRHatMaDBtBctagcatWtatttgWttVaaa
+ScMNattRactttgtYtttaaaagtaagtMtaMaSttMBtatgaBtttaKtgaatgagYg
+tNNacMtcNRacMMHcttWtgtRtctttaacaacattattcYaMagBaacYttMatcttK
+cRMtgMNccattaRttNatHaHNaSaaHMacacaVaatacaKaSttHatattMtVatWga
+ttttttaYctttKttHgScWaacgHtttcaVaaMgaacagNatcgttaacaaaaagtaca
+HBNaattgttKtcttVttaaBtctgctacgBgcWtttcaggacacatMgacatcccagcg
+gMgaVKaBattgacttaatgacacacaaaaaatRKaaBctacgtRaDcgtagcVBaacDS
+BHaaaaSacatatacagacRNatcttNaaVtaaaataHattagtaaaaSWccgtatWatg
+gDttaactattgcccatcttHaSgYataBttBaactattBtcHtgatcaataSttaBtat
+KSHYttWggtcYtttBttaataccRgVatStaHaKagaatNtagRMNgtcttYaaSaact
+cagDSgagaaYtMttDtMRVgWKWtgMaKtKaDttttgactatacataatcNtatNaHat
+tVagacgYgatatatttttgtStWaaatctWaMgagaRttRatacgStgattcttaagaD
+taWccaaatRcagcagaaNKagtaaDggcgccBtYtagSBMtactaaataMataBSacRM
+gDgattMMgtcHtcaYDtRaDaacggttDaggcMtttatgttaNctaattaVacgaaMMt
+aatDccSgtattgaRtWWaccaccgagtactMcgVNgctDctaMScatagcgtcaactat
+acRacgHRttgctatttaatgaattataYKttgtaagWgtYttgcHgMtaMattWaWVta
+RgcttgYgttBHtYataSccStBtgtagMgtDtggcVaaSBaatagDttgBgtctttctc
+attttaNagtHKtaMWcYactVcgcgtatMVtttRacVagDaatcttgctBBcRDgcaac
+KttgatSKtYtagBMagaRtcgBattHcBWcaactgatttaatttWDccatttatcgagS
+KaWttataHactaHMttaatHtggaHtHagaatgtKtaaRactgtttMatacgatcaagD
+gatKaDctataMggtHDtggHacctttRtatcttYattttgacttgaaSaataaatYcgB
+aaaaccgNatVBttMacHaKaataagtatKgtcaagactcttaHttcggaattgttDtct
+aaccHttttWaaatgaaatataaaWattccYDtKtaaaacggtgaggWVtctattagtga
+ctattaagtMgtttaagcatttgSgaaatatccHaaggMaaaattttcWtatKctagDtY
+tMcctagagHcactttactatacaaacattaacttaHatcVMYattYgVgtMttaaRtga
+aataaDatcaHgtHHatKcDYaatcttMtNcgatYatgSaMaNtcttKcWataScKggta
+tcttacgcttWaaagNatgMgHtctttNtaacVtgttcMaaRatccggggactcMtttaY
+MtcWRgNctgNccKatcttgYDcMgattNYaRagatHaaHgKctcataRDttacatBatc
+cattgDWttatttaWgtcggagaaaaatacaatacSNtgggtttccttacSMaagBatta
+caMaNcactMttatgaRBacYcYtcaaaWtagctSaacttWgDMHgaggatgBVgcHaDt
+ggaactttggtcNatNgtaKaBcccaNtaagttBaacagtatacDYttcctNgWgcgSMc
+acatStctHatgRcNcgtacacaatRttMggaNKKggataaaSaYcMVcMgtaMaHtgat
+tYMatYcggtcttcctHtcDccgtgRatcattgcgccgatatMaaYaataaYSggatagc
+gcBtNtaaaScaKgttBgagVagttaKagagtatVaactaSacWactSaKatWccaKaaa
+atBKgaaKtDMattttgtaaatcRctMatcaaMagMttDgVatggMaaWgttcgaWatga
+aatttgRtYtattaWHKcRgctacatKttctaccaaHttRatctaYattaaWatVNccat
+NgagtcKttKataStRaatatattcctRWatDctVagttYDgSBaatYgttttgtVaatt
+taatagcagMatRaacttBctattgtMagagattaaactaMatVtHtaaatctRgaaaaa
+aaatttWacaacaYccYDSaattMatgaccKtaBKWBattgtcaagcHKaagttMMtaat
+ttcKcMagNaaKagattggMagaggtaatttYacatcWaaDgatMgKHacMacgcVaaca
+DtaDatatYggttBcgtatgWgaSatttgtagaHYRVacaRtctHaaRtatgaactaata
+tctSSBgggaaHMWtcaagatKgagtDaSatagttgattVRatNtctMtcSaagaSHaat
+aNataataRaaRgattctttaataaagWaRHcYgcatgtWRcttgaaggaMcaataBRaa
+ccagStaaacNtttcaatataYtaatatgHaDgcStcWttaacctaRgtYaRtataKtgM
+ttttatgactaaaatttacYatcccRWtttHRtattaaatgtttatatttgttYaatMca
+RcSVaaDatcgtaYMcatgtagacatgaaattgRtcaaYaaYtRBatKacttataccaNa
+aattVaBtctggacaagKaaYaaatatWtMtatcYaaVNtcgHaactBaagKcHgtctac
+aatWtaDtSgtaHcataHtactgataNctRgttMtDcDttatHtcgtacatcccaggStt
+aBgtcacacWtccNMcNatMVaVgtccDYStatMaccDatggYaRKaaagataRatttHK
+tSaaatDgataaacttaHgttgVBtcttVttHgDacgaKatgtatatNYataactctSat
+atatattgcHRRYttStggaactHgttttYtttaWtatMcttttctatctDtagVHYgMR
+BgtHttcctaatYRttKtaagatggaVRataKDctaMtKBNtMtHNtWtttYcVtattMc
+gRaacMcctNSctcatttaaagDcaHtYccSgatgcaatYaaaaDcttcgtaWtaattct
+cgttttScttggtaatctttYgtctaactKataHacctMctcttacHtKataacacagcN
+RatgKatttttSaaatRYcgDttaMRcgaaattactMtgcgtaagcgttatBtttttaat
+taagtNacatHgttcRgacKcBBtVgatKttcgaBaatactDRgtRtgaNacWtcacYtt
+aaKcgttctHaKttaNaMgWgWaggtctRgaKgWttSttBtDcNtgtttacaaatYcDRt
+gVtgcctattcNtctaaaDMNttttNtggctgagaVctDaacVtWccaagtaacacaNct
+gaScattccDHcVBatcgatgtMtaatBgHaatDctMYgagaatgYWKcctaatNaStHa
+aaKccgHgcgtYaaYtattgtStgtgcaaRtattaKatattagaWVtcaMtBagttatta
+gNaWHcVgcaattttDcMtgtaRHVYtHtctgtaaaaHVtMKacatcgNaatttMatatg
+ttgttactagWYtaRacgataKagYNKcattataNaRtgaacKaYgcaaYYacaNccHat
+MatDcNgtHttRaWttagaaDcaaaaaatagggtKDtStaDaRtaVtHWKNtgtattVct
+SVgRgataDaRaWataBgaagaaKtaataaYgDcaStaNgtaDaaggtattHaRaWMYaY
+aWtggttHYgagVtgtgcttttcaaDKcagVcgttagacNaaWtagtaataDttctggtt
+VcatcataaagtgKaaaNaMtaBBaattaatWaattgctHaVKaSgDaaVKaHtatatat
+HatcatSBagNgHtatcHYMHgttDgtaHtBttWatcgtttaRaattgStKgSKNWKatc
+agDtctcagatttctRtYtBatBgHHtKaWtgYBgacVVWaKtacKcDttKMaKaVcggt
+gttataagaataaHaatattagtataatMHgttYgaRttagtaRtcaaVatacggtcMcg
+agtaaRttacWgactKRYataaaagSattYaWgagatYagKagatgSaagKgttaatMgg
+tataatgttWYttatgagaaacctNVataatHcccKtDctcctaatactggctHggaSag
+gRtKHaWaattcgSatMatttagaggcYtctaMcgctcataSatatgRagacNaaDagga
+VBagaYttKtacNaKgtSYtagttggaWcatcWttaatctatgaVtcgtgtMtatcaYcg
+tRccaaYgDctgcMgtgtWgacWtgataacacgcgctBtgttaKtYDtatDcatcagKaV
+MctaatcttgVcaaRgcRMtDcgattaHttcaNatgaatMtactacVgtRgatggaWttt
+actaaKatgagSaaKggtaNtactVaYtaaKRagaacccacaMtaaMtKtatBcttgtaa
+WBtMctaataaVcDaaYtcRHBtcgttNtaaHatttBNgRStVDattBatVtaagttaYa
+tVattaagaBcacggtSgtVtatttaRattgatgtaHDKgcaatattKtggcctatgaWD
+KRYcggattgRctatNgatacaatMNttctgtcRBYRaaaHctNYattcHtaWcaattct
+BtMKtVgYataatMgYtcagcttMDataVtggRtKtgaatgccNcRttcaMtRgattaac
+attRcagcctHtWMtgtDRagaKaBtgDttYaaaaKatKgatctVaaYaacWcgcatagB
+VtaNtRtYRaggBaaBtgKgttacataagagcatgtRattccacttaccatRaaatgWgD
+aMHaYVgVtaSctatcgKaatatattaDgacccYagtgtaYNaaatKcagtBRgagtcca
+tgKgaaaccBgaagBtgSttWtacgatWHaYatcgatttRaaNRgcaNaKVacaNtDgat
+tgHVaatcDaagcgtatgcNttaDataatcSataaKcaataaHWataBtttatBtcaKtK
+tatagttaDgSaYctacaRatNtaWctSaatatttYaKaKtaccWtatcRagacttaYtt
+VcKgSDcgagaagatccHtaattctSttatggtKYgtMaHagVaBRatttctgtRgtcta
+tgggtaHKgtHacHtSYacgtacacHatacKaaBaVaccaDtatcSaataaHaagagaat
+ScagactataaRttagcaaVcaHataKgDacatWccccaagcaBgagWatctaYttgaaa
+tctVNcYtttWagHcgcgcDcVaaatgttKcHtNtcaatagtgtNRaactttttcaatgg
+WgBcgDtgVgtttctacMtaaataaaRggaaacWaHttaRtNtgctaaRRtVBctYtVta
+tDcattDtgaccYatagatYRKatNYKttNgcctagtaWtgaactaMVaacctgaStttc
+tgaKVtaaVaRKDttVtVctaDNtataaaDtccccaagtWtcgatcactDgYaBcatcct
+MtVtacDaaBtYtMaKNatNtcaNacgDatYcatcgcaRatWBgaacWttKttagYtaat
+tcggttgSWttttDWctttacYtatatWtcatDtMgtBttgRtVDggttaacYtacgtac
+atgaattgaaWcttMStaDgtatattgaDtcRBcattSgaaVBRgagccaaKtttcDgcg
+aSMtatgWattaKttWtgDBMaggBBttBaatWttRtgcNtHcgttttHtKtcWtagHSt
+aacagttgatatBtaWSaWggtaataaMttaKacDaatactcBttcaatatHttcBaaSa
+aatYggtaRtatNtHcaatcaHtagVtgtattataNggaMtcttHtNagctaaaggtaga
+YctMattNaMVNtcKtactBKcaHHcBttaSagaKacataYgctaKaYgttYcgacWVtt
+WtSagcaacatcccHaccKtcttaacgaKttcacKtNtacHtatatRtaaatacactaBt
+ttgaHaRttggttWtatYagcatYDatcggagagcWBataagRtacctataRKgtBgatg
+aDatataSttagBaHtaatNtaDWcWtgtaattacagKttcNtMagtattaNgtctcgtc
+ctcttBaHaKcKccgtRcaaYagSattaagtKataDatatatagtcDtaacaWHcaKttD
+gaaRcgtgYttgtcatatNtatttttatggccHtgDtYHtWgttatYaacaattcaWtat
+NgctcaaaSttRgctaatcaaatNatcgtttaBtNNVtgttataagcaaagattBacgtD
+atttNatttaaaDcBgtaSKgacgtagataatttcHMVNttgttBtDtgtaWKaaRMcKM
+tHtaVtagataWctccNNaSWtVaHatctcMgggDgtNHtDaDttatatVWttgttattt
+aacctttcacaaggaSaDcggttttttatatVtctgVtaacaStDVaKactaMtttaSNa
+gtgaaattaNacttSKctattcctctaSagKcaVttaagNaVcttaVaaRNaHaaHttat
+gtHttgtgatMccaggtaDcgaccgtWgtWMtttaHcRtattgScctatttKtaaccaag
+tYagaHgtWcHaatgccKNRtttagtMYSgaDatctgtgaWDtccMNcgHgcaaacNDaa
+aRaStDWtcaaaaHKtaNBctagBtgtattaactaattttVctagaatggcWSatMaccc
+ttHttaSgSgtgMRcatRVKtatctgaaaccDNatYgaaVHNgatMgHRtacttaaaRta
+tStRtDtatDttYatattHggaBcttHgcgattgaKcKtttcRataMtcgaVttWacatN
+catacctRataDDatVaWNcggttgaHtgtMacVtttaBHtgagVttMaataattatgtt
+cttagtttgtgcDtSatttgBtcaacHattaaBagVWcgcaSYttMgcttacYKtVtatc
+aYaKctgBatgcgggcYcaaaaacgNtctagKBtattatctttKtaVttatagtaYtRag
+NtaYataaVtgaatatcHgcaaRataHtacacatgtaNtgtcgYatWMatttgaactacR
+ctaWtWtatacaatctBatatgYtaagtatgtgtatSttactVatcttYtaBcKgRaSgg
+RaaaaatgcagtaaaWgtaRgcgataatcBaataccgtatttttccatcNHtatWYgatH
+SaaaDHttgctgtccHtggggcctaataatttttctatattYWtcattBtgBRcVttaVM
+RSgctaatMagtYtttaaaaatBRtcBttcaaVtaacagctccSaaSttKNtHtKYcagc
+agaaaccccRtttttaaDcDtaStatccaagcgctHtatcttaDRYgatDHtWcaaaBcW
+gKWHttHataagHacgMNKttMKHccaYcatMVaacgttaKgYcaVaaBtacgcaacttt
+MctaaHaatgtBatgagaSatgtatgSRgHgWaVWgataaatatttccKagVgataattW
+aHNcYggaaatgctHtKtaDtctaaagtMaatVDVactWtSaaWaaMtaHtaSKtcBRaN
+cttStggtBttacNagcatagRgtKtgcgaacaacBcgKaatgataagatgaaaattgta
+ctgcgggtccHHWHaaNacaBttNKtKtcaaBatatgctaHNgtKcDWgtttatNgVDHg
+accaacWctKaaggHttgaRgYaatHcaBacaatgagcaaattactgtaVaaYaDtagat
+tgagNKggtggtgKtWKaatacagDRtatRaMRtgattDggtcaaYRtatttNtagaDtc
+acaaSDctDtataatcgtactaHttatacaatYaacaaHttHatHtgcgatRRttNgcat
+SVtacWWgaaggagtatVMaVaaattScDDKNcaYBYaDatHgtctatBagcaacaagaa
+tgagaaRcataaKNaRtBDatcaaacgcattttttaaBtcSgtacaRggatgtMNaattg
+gatatWtgagtattaaaVctgcaYMtatgatttttYgaHtgtcttaagWBttHttgtctt
+attDtcgtatWtataataSgctaHagcDVcNtaatcaagtaBDaWaDgtttagYctaNcc
+DtaKtaHcttaataacccaRKtacaVaatNgcWRaMgaattatgaBaaagattVYaHMDc
+aDHtcRcgYtcttaaaWaaaVKgatacRtttRRKYgaatacaWVacVcRtatMacaBtac
+tggMataaattttHggNagSctacHgtBagcgtcgtgattNtttgatSaaggMttctttc
+ttNtYNagBtaaacaaatttMgaccttacataattgYtcgacBtVMctgStgMDtagtaR
+ctHtatgttcatatVRNWataDKatWcgaaaaagttaaaagcacgHNacgtaatctttMR
+tgacttttDacctataaacgaaatatgattagaactccSYtaBctttaataacWgaaaYa
+tagatgWttcatKtNgatttttcaagHtaYgaaRaDaagtaggagcttatVtagtctttc
+attaaaatcgKtattaRttacagVaDatgcatVgattgggtctttHVtagKaaRBtaHta
+aggccccaaaaKatggtttaMWgtBtaaacttcactttKHtcgatctccctaYaBacMgt
+cttBaBaNgcgaaacaatctagtHccHtKttcRtRVttccVctttcatacYagMVtMcag
+aMaaacaataBctgYtaatRaaagattaaccatVRatHtaRagcgcaBcgDttStttttc
+VtttaDtKgcaaWaaaaatSccMcVatgtKgtaKgcgatatgtagtSaaaDttatacaaa
+catYaRRcVRHctKtcgacKttaaVctaDaatgttMggRcWaacttttHaDaKaDaBctg
+taggcgtttaHBccatccattcNHtDaYtaataMttacggctNVaacDattgatatttta
+cVttSaattacaaRtataNDgacVtgaacataVRttttaDtcaaacataYDBtttaatBa
+DtttYDaDaMccMttNBttatatgagaaMgaNtattHccNataattcaHagtgaaggDga
+tgtatatatgYatgaStcataaBStWacgtcccataRMaaDattggttaaattcMKtctM
+acaBSactcggaatDDgatDgcWctaacaccgggaVcacWKVacggtaNatatacctMta
+tgatagtgcaKagggVaDtgtaacttggagtcKatatcgMcttRaMagcattaBRaStct
+YSggaHYtacaactMBaagDcaBDRaaacMYacaHaattagcattaaaHgcgctaaggSc
+cKtgaaKtNaBtatDDcKBSaVtgatVYaagVtctSgMctacgttaacWaaattctSgtD
+actaaStaaattgcagBBRVctaatatacctNttMcRggctttMttagacRaHcaBaacV
+KgaataHttttMgYgattcYaNRgttMgcVaaacaVVcDHaatttgKtMYgtatBtVVct
+WgVtatHtacaaHttcacgatagcagtaaNattBatatatttcVgaDagcggttMaagtc
+ScHagaaatgcYNggcgtttttMtStggtRatctacttaaatVVtBacttHNttttaRca
+aatcacagHgagagtMgatcSWaNRacagDtatactaaDKaSRtgattctccatSaaRtt
+aaYctacacNtaRtaactggatgaccYtacactttaattaattgattYgttcagDtNKtt
+agDttaaaaaaaBtttaaNaYWKMBaaaacVcBMtatWtgBatatgaacVtattMtYatM
+NYDKNcKgDttDaVtaaaatgggatttctgtaaatWtctcWgtVVagtcgRgacttcccc
+taDcacagcRcagagtgtWSatgtacatgttaaSttgtaaHcgatgggMagtgaacttat
+RtttaVcaccaWaMgtactaatSSaHtcMgaaYtatcgaaggYgggcgtgaNDtgttMNg
+aNDMtaattcgVttttaacatgVatgtWVMatatcaKgaaattcaBcctccWcttgaaWH
+tWgHtcgNWgaRgctcBgSgaattgcaaHtgattgtgNagtDttHHgBttaaWcaaWagc
+aSaHHtaaaVctRaaMagtaDaatHtDMtcVaWMtagSagcttHSattaacaaagtRacM
+tRtctgttagcMtcaBatVKtKtKacgagaSNatSactgtatatcBctgagVtYactgta
+aattaaaggcYgDHgtaacatSRDatMMccHatKgttaacgactKtgKagtcttcaaHRV
+tccttKgtSataatttacaactggatDNgaacttcaRtVaagDcaWatcBctctHYatHa
+DaaatttagYatSatccaWtttagaaatVaacBatHcatcgtacaatatcgcNYRcaata
+YaRaYtgattVttgaatgaVaactcRcaNStgtgtattMtgaggtNttBaDRcgaaaagc
+tNgBcWaWgtSaDcVtgVaatMKBtttcgtttctaaHctaaagYactgMtatBDtcStga
+ccgtSDattYaataHctgggaYYttcggttaWaatctggtRagWMaDagtaacBccacta
+cgHWMKaatgatWatcctgHcaBaSctVtcMtgtDttacctaVgatYcWaDRaaaaRtag
+atcgaMagtggaRaWctctgMgcWttaagKBRtaaDaaWtctgtaagYMttactaHtaat
+cttcataacggcacBtSgcgttNHtgtHccatgttttaaagtatcgaKtMttVcataYBB
+aKtaMVaVgtattNDSataHcagtWMtaggtaSaaKgttgBtVtttgttatcatKcgHac
+acRtctHatNVagSBgatgHtgaRaSgttRcctaacaaattDNttgacctaaYtBgaaaa
+tagttattactcttttgatgtNNtVtgtatMgtcttRttcatttgatgacacttcHSaaa
+ccaWWDtWagtaRDDVNacVaRatgttBccttaatHtgtaaacStcVNtcacaSRttcYa
+gacagaMMttttgMcNttBcgWBtactgVtaRttctccaaYHBtaaagaBattaYacgat
+ttacatctgtaaMKaRYtttttactaaVatWgctBtttDVttctggcDaHaggDaagtcg
+aWcaagtagtWttHtgKtVataStccaMcWcaagataagatcactctHatgtcYgaKcat
+cagatactaagNSStHcctRRNtattgtccttagttagMVgtatagactaactctVcaat
+MctgtttgtgttgccttatWgtaBVtttctggMcaaKgDWtcgtaaYStgSactatttHg
+atctgKagtagBtVacRaagRtMctatgggcaaaKaaaatacttcHctaRtgtDcttDat
+taggaaatttcYHaRaaBttaatggcacKtgctHVcaDcaaaVDaaaVcgMttgtNagcg
+taDWgtcgttaatDgKgagcSatatcSHtagtagttggtgtHaWtaHKtatagctgtVga
+ttaBVaatgaataagtaatVatSttaHctttKtttgtagttaccttaatcgtagtcctgB
+cgactatttVcMacHaaaggaatgDatggKtaHtgStatattaaSagctWcctccRtata
+BaDYcgttgcNaagaggatRaaaYtaWgNtSMcaatttactaacatttaaWttHtatBat
+tgtcgacaatNgattgcNgtMaaaKaBDattHacttggtRtttaYaacgVactBtaBaKt
+gBttatgVttgtVttcaatcWcNctDBaaBgaDHacBttattNtgtDtatttVSaaacag
+gatgcRatSgtaSaNtgBatagttcHBgcBBaaattaHgtDattatDaKaatBaaYaaMa
+ataaataKtttYtagtBgMatNcatgtttgaNagtgttgtgKaNaSagtttgaSMaYBca
+aaacDStagttVacaaaaactaaWttBaagtctgtgcgtMgtaattctcctacctcaNtt
+taaccaaaaVtBcacataacaccccBcWMtatVtggaatgaWtcaaWaaaaaaaaWtDta
+atatRcctDWtcctaccMtVVatKttaWaaKaaatataaagScHBagaggBaSMtaWaVt
+atattactSaaaKNaactatNatccttgaYctattcaaaVgatttYHcRagattttaSat
+aggttattcVtaaagaKgtattattKtRttNcggcRgtgtgtWYtaacHgKatKgatYta
+cYagDtWcHBDctctgRaYKaYagcactKcacSaRtBttttBHKcMtNtcBatttatttt
+tgSatVgaaagaWtcDtagDatatgMacaacRgatatatgtttgtKtNRaatatNatgYc
+aHtgHataacKtgagtagtaacYttaNccaaatHcacaacaVDtagtaYtccagcattNt
+acKtBtactaaagaBatVtKaaHBctgStgtBgtatgaSNtgDataaccctgtagcaBgt
+gatcttaDataStgaMaccaSBBgWagtacKcgattgaDgNNaaaacacagtSatBacKD
+gcgtataBKcatacactaSaatYtYcDaactHttcatRtttaatcaattataRtttgtaa
+gMcgNttcatcBtYBagtNWNMtSHcattcRctttttRWgaKacKttgggagBcgttcgc
+MaWHtaatactgtctctatttataVgtttaBScttttaBMaNaatMacactYtBMggtHa
+cMagtaRtctgcatttaHtcaaaatttgagKtgNtactBacaHtcgtatttctMaSRagc
+agttaatgtNtaaattgagagWcKtaNttagVtacgatttgaatttcgRtgtWcVatcgt
+taaDVctgtttBWgaccagaaagtcSgtVtatagaBccttttcctaaattgHtatcggRa
+ttttcaaggcYSKaagWaWtRactaaaacccBatMtttBaatYtaagaactSttcgaaSc
+aatagtattgaccaagtgttttctaacatgtttNVaatcaaagagaaaNattaaRtttta
+VaaaccgcaggNMtatattVctcaagaggaacgBgtttaacaagttcKcYaatatactaa
+ccBaaaSggttcNtattctagttRtBacgScVctcaatttaatYtaaaaaaatgSaatga
+tagaMBRatgRcMcgttgaWHtcaVYgaatYtaatctttYttatRaWtctgBtDcgatNa
+tcKaBaDgatgtaNatWKctccgatattaacattNaaacDatgBgttctgtDtaaaMggt
+gaBaSHataacgccSctaBtttaRBtcNHcDatcDcctagagtcRtaBgWttDRVHagat
+tYatgtatcWtaHtttYcattWtaaagtctNgtStggRNcgcggagSSaaagaaaatYcH
+DtcgctttaatgYcKBVSgtattRaYBaDaaatBgtatgaHtaaRaRgcaSWNtagatHa
+acttNctBtcaccatctMcatattccaSatttgcgaDagDgtatYtaaaVDtaagtttWV
+aagtagYatRttaagDcNgacKBcScagHtattatcDaDactaaaaaYgHttBcgaDttg
+gataaaKSRcBMaBcgaBSttcWtgNBatRaccgattcatttataacggHVtaattcaca
+agagVttaaRaatVVRKcgWtVgacctgDgYaaHaWtctttcacMagggatVgactagMa
+aataKaaNWagKatagNaaWtaaaatttgaattttatttgctaaVgaHatBatcaaBWcB
+gttcMatcgBaaNgttcgSNaggSaRtttgHtRtattaNttcDcatSaVttttcgaaaaa
+ttgHatctaRaggSaNatMDaaatDcacgattttagaHgHaWtYgattaatHNSttatMS
+gggNtcKtYatRggtttgtMWVtttaYtagcagBagHaYagttatatggtBacYcattaR
+SataBatMtttaaatctHcaaaSaaaagttNSaaWcWRccRtKaagtBWtcaaattSttM
+tattggaaaccttaacgttBtWatttatatWcDaatagattcctScacctaagggRaaYt
+aNaatgVtBcttaaBaacaMVaaattatStYgRcctgtactatcMcVKatttcgSgatRH
+MaaaHtagtaaHtVgcaaataatatcgKKtgccaatBNgaaWcVttgagttaKatagttc
+aggKDatDtattgaKaVcaKtaataDataataHSaHcattagttaatRVYcNaHtaRcaa
+ggtNHcgtcaaccaBaaagYtHWaaaRcKgaYaaDttgcWYtataRgaatatgtYtgcKt
+aNttWacatYHctRaDtYtattcBttttatcSataYaYgttWaRagcacHMgtttHtYtt
+YaatcggtatStttcgtRSattaaDaKMaatatactaNBaWgctacacYtgaYVgtgHta
+aaRaaRgHtagtWattataaaSDaaWtgMattatcgaaaagtaYRSaWtSgNtBgagcRY
+aMDtactaacttaWgtatctagacaagNtattHggataatYttYatcataDcgHgttBtt
+ctttVttgccgaaWtaaaacgKgtatctaaaaaNtccDtaDatBMaMggaatNKtatBaa
+atVtccRaHtaSacataHattgtttKVYattcataVaattWtcgtgMttcttKtgtctaa
+cVtatctatatBRataactcgKatStatattcatHHRttKtccaacgtgggtgRgtgaMt
+attattggctatcgtgacMtRcBDtcttgtactaatRHttttaagatcgVMDStattatY
+BtttDttgtBtNttgRcMtYtgBacHaWaBaatDKctaagtgaaactaatgRaaKgatcc
+aagNaaaatattaggWNtaagtatacttttKcgtcggSYtcttgRctataYcttatataa
+agtatattaatttataVaacacaDHatctatttttKYVatHRactttaBHccaWagtact
+BtcacgaVgcgttRtttttttSVgtSagtBaaattctgaHgactcttgMcattttagVta
+agaattHctHtcaDaaNtaacRggWatagttcgtSttgaDatcNgNagctagDgatcNtt
+KgttgtaDtctttRaaYStRatDtgMggactSttaDtagSaVtBDttgtDgccatcacaM
+attaaaMtNacaVcgSWcVaaDatcaHaatgaattaMtatccVtctBtaattgtWattat
+BRcWcaatgNNtactWYtDaKttaaatcactcagtRaaRgatggtKgcgccaaHgaggat
+StattYcaNMtcaBttacttatgagDaNtaMgaaWtgtttcttctaHtMNgttatctaWW
+atMtBtaaatagDVatgtBYtatcggcttaagacMRtaHScgatatYgRDtcattatSDa
+HggaaataNgaWSRRaaaBaatagBattaDctttgHWNttacaataaaaaaatacggttt
+gHgVtaHtWMttNtBtctagtMcgKMgHgYtataHaNagWtcaacYattaataYRgtaWK
+gaBctataaccgatttaHaNBRaRaMtccggtNgacMtctcatttgcaattcWgMactta
+caaDaaNtactWatVtttagccttMaatcagVaagtctVaaDaBtattaattaYtNaYtg
+gattaKtaKctYaMtattYgatattataatKtVgDcttatatNBtcgttgtStttttMag
+aggttaHYSttcKgtcKtDNtataagttataagSgttatDtRttattgttttSNggRtca
+aKMNatgaatattgtBWtaMacctgggYgaSgaagYataagattacgagaatBtggtRcV
+HtgYggaDgaYaKagWagctatagacgaaHgtWaNgacttHRatVaWacKYtgRVNgVcS
+gRWctacatcKSactctgWYtBggtataagcttNRttVtgRcaWaaatDMatYattaact
+ttcgaagRatSctgccttgcRKaccHtttSNVagtagHagBagttagaccaRtataBcca
+taatSHatRtcHagacBWatagcaMtacaRtgtgaaBatctKRtScttccaNaatcNgta
+atatWtcaMgactctBtWtaaNactHaaaaRctcgcatggctMcaaNtcagaaaaacaca
+gtggggWttRttagtaagaVctVMtcgaatcttcMaaaHcaHBttcgattatgtcaDagc
+YRtBtYcgacMgtDcagcgaNgttaataatagcagKYYtcgtaBtYctMaRtaRtDagaa
+aacacatgYaBttgattattcgaaNttBctSataaMataWRgaHtttccgtDgaYtatgg
+tDgHKgMtatttVtMtVagttaRatMattRagataaccctKctMtSttgaHagtcStcta
+tttccSagatgttccacgaggYNttHRacgattcDatatDcataaaatBBttatcgaHtN
+HaaatatDNaggctgaNcaaggagttBttMgRagVatBcRtaWgatgBtSgaKtcgHttt
+gaatcaaDaHttcSBgHcagtVaaSttDcagccgttNBtgttHagYtattctttRWaaVt
+SttcatatKaaRaaaNacaVtVctMtSDtDtRHRcgtaatgctcttaaatSacacaatcg
+HattcaWcttaaaatHaaatcNctWttaNMcMtaKctVtcctaagYgatgatcYaaaRac
+tctaRDaYagtaacgtDgaggaaatctcaaacatcaScttcKttNtaccatNtaNataca
+tttHaaDHgcaDatMWaaBttcRggctMaagctVYcacgatcaDttatYtaatcKatWat
+caatVYtNagatttgattgaYttttYgacttVtcKaRagaaaHVgDtaMatKYagagttN
+atWttaccNtYtcDWgSatgaRgtMatgKtcgacaagWtacttaagtcgKtgatccttNc
+ttatagMatHVggtagcgHctatagccctYttggtaattKNaacgaaYatatVctaataM
+aaaYtgVtcKaYtaataacagaatHcacVagatYWHttagaaSMaatWtYtgtaaagNaa
+acaVgaWtcacNWgataNttcaSagctMDaRttgNactaccgataMaaatgtttattDtc
+aagacgctDHYYatggttcaagccNctccttcMctttagacBtaaWtaWVHggaaaaNat
+ttaDtDtgctaaHHtMtatNtMtagtcatttgcaaaRatacagRHtatDNtgtDgaatVg
+tVNtcaaatYBMaaaagcaKgtgatgatMgWWMaHttttMgMagatDtataaattaacca
+actMtacataaattgRataatacgBtKtaataattRgtatDagDtcRDacctatRcagag
+cSHatNtcaScNtttggacNtaaggaccgtgKNttgttNcttgaaRgYgRtNtcagttBc
+ttttcHtKtgcttYaaNgYagtaaatgaatggWaMattBHtatctatSgtcYtgcHtaat
+tHgaaMtHcagaaSatggtatgccaHBtYtcNattWtgtNgctttaggtttgtWatNtgH
+tgcDttactttttttgcNtactKtWRaVcttcatagtgSNKaNccgaataaBttataata
+YtSagctttaaatSttggctaaKSaatRccgWHgagDttaaatcatgagMtcgagtVtaD
+ggaBtatttgDacataaacgtagYRagBWtgDStKDgatgaagttcattatttaKWcata
+aatWRgatataRgttRacaaNKttNtKagaaYaStaactScattattaacgatttaaatg
+DtaattagatHgaYataaactatggggatVHtgccgtNgatNYcaStRtagaccacWcaM
+tatRagHgVactYtWHtcttcatgatWgagaKggagtatgaWtDtVtNaNtcgYYgtaaa
+ctttaDtBactagtaDctatagtaatatttatatataacgHaaaRagKattSagttYtSt
+atatatagtcttaaaaMtcatgttcaaDactgRttctaagagDtatttttagcgacttgt
+gRtgNctgSgRaaaaatgcaMtYtDcatcaaYKttHcatSWgaaaatDataggttatgBD
+MtgttataacaaYSgagttacgttatgtDStttaaatctcgWKtcSacgagagaSgttat
+BMDgtcggtgtgcgaNtaSHBatBtttVMgVcagaNatcaDDaKMtMYtatagaBccctc
+tDtgtatttatatKNtgggtatgtRaacttgaWaaYgcaHatccctggtttStatMtcgc
+MtaaaWKttMVtWctVtgttaKDWctgWaVttaDVatgKtagagtcatctaKWgtaaMtt
+SacBaMattaKaaHDataattgWtgttttgtcatBacacgtStacaaagtNctNtgtgat
+cHtWttcKaagagttttaaaaWacgRacatctNatVStgaatDHgttWcgtRKcatatat
+ctcaNttaaBDcctgaaaaaDtaYaHaKttNtaYVaVtttaDtctacttctWttaactaa
+ttttMagWcaatcccNKYtBaacatgttgaKgKcgcBHaatDMttatatcSWacatDatR
+cWaMtDgatBctHgScttaaaHtSgKtDtttattgtRStWgttccatatttcacWttcat
+attgtaHVgaBtacaMtgMaaagDaataactDatattagMaNBagcttcattcgtaaKtg
+tatttcacMtgBaVtaattStcttagtYgtgtcgccttKatgggtgaWaataggaatacM
+MagaSKRttBgatgacRtgMtagaSRataggtatcaccgaNaaaWSWacDgatacttgat
+tagcttgtgVMttatYctaRgHVcDtVRRtSaMtcaVtVtatcaYaHatattaaVaatct
+aBtgtacRatNtatttgaYatSaHctaNgNtYtYaYagattVgatcRtaacgYggtgtat
+KttaatMagatgRtatatgHaKccHaaaaYtgaacgaWaNgtYHgacagaYtctaVtacc
+cgatttttaaagcDttatNRgattKaaattttcatctaatgccgcaataataattgttat
+YtagtRNtaagttggtHaKttWMtDKgatSagBYcgRggtWaVaattHtatgtaaaMgSa
+aagataaKaaKgttDttttRaagaacaWRcaacDgtgttaatattaKtatcaWacacatt
+tVtctgatHRcagtttNcaaatcNctNttttataactWacBBttgBttaaaRaWtBKaaa
+cgtatcRcaMaatgYacaaaagtgBataStWYtggtatgacaKWtctSgcKHgtcNaMNc
+ataSatattgactacMcataattNVtDaRccaaatcagttttYttagYaacgtaatMtMV
+atNgKaaMaaBgattaKttatDaBcttKtccttttacDagaYtacHgttggacaaaVaat
+agtYatcataSgatcaaWVttcgaatgaccctccttNtaSBWaatttDttttcaatatYg
+gctatDcttatNctttagDcMttcaacWaaNattSYgctttcaHcRaattaataaaatcV
+ccRaattactctaMaVRattacagtgRcDtcgtgctcttNtWVtacagtHtatHaBDtcW
+ggtgctcaaRHtatgtDgacStgcaaaVKtagttataatactaatatgtagScaatRSac
+aattgtattgcagatHHtgBcaatKKtaaMMcaRcgactatKBaMaYatgKatttDaaNt
+RatattgtatWttagcaaaaacaWgcacaaHcataYtDaHgttataaSacgcagggggtY
+atgcKctaaaHgcVgctBDaVttccStagNgcSgtatgVYaMatcaWRBtVtgYttgtgR
+cYttcgctgaacNttgtgtctattWttttcctagMtagaWtaKgatStScatMaBtaSta
+SactattYNatctgtacRatYDaatgatgatatgaatYaaaaSHttaaYMaWtDcaNHaB
+caYtgVgcatVaacattMRatBtaatttaDacRtagtaaaNYVSMtcagaaDtttDHtRc
+YatacSNKaaMcHgatBaaVttactggBYgaYatttttgcDacHctWatcgtagagtact
+cattDggtcatKaSgctttatttagtDtRBacttaWYaaaattttgaccttaaWtaatgc
+RgccacttMtaggKtcBtgacgaHctttatcgtcStatMHDNagattatNagVaaaWcgg
+aaaYcaVactDYactaStattgBHtcYctgggtacatataaYcgaYagaggaggacaVat
+acHRtYtctgtaVgaYcNgaaaNatacVgcNgtaatttDcatttttcaacttSNcaaDat
+VYctSgcaccttagMgacgcttgaSttaaaatagttaggRHttaaacMatagcaWgMgag
+tcgctagtgtKgactaaHttattaWgcaaaaaaSatatgcgttaBNggttaYVatgaact
+ttttgccatataaataRatSaBctagttataBccgaaacaagatacttaattttgaHgHM
+gtaaKctttaYtaaRacBMtBaYgaBaaacaYtVtagcRgWatHaWagattWSacStMHa
+tttaDagacaatcgtgtKtttggaMtgtWtgtgcaaNaaaaWtKaaBcMWtcttctatga
+cVgagcgaggHaYYtttWgSaaYYaWtRYHHaMDtctttacaatggaaMctataagcttB
+cgHcNWaatttgtatatYtStatctagcactgtVttccagaaattaDtttaRtVataBtt
+WagcatDMVactYtgcatWtttgaaMggKaatgaaaaHtataDtgYcMggVaaatSMHtt
+tgVttaYaWaataRttgttaYttattttRtWtataaBgtDtttatatcVgaaBcaDtatg
+tcaDagaWtgaYtWctcVagctcagctatatagcRVtcaKtaataatHgNaccgaaaatV
+HBaatattcgttaVYttatttctBYaatKaagaccVStttcattgaMagSaaaaccccWK
+caaNtMYacctaDStagaaatttatcatVgtcaatacccKattgtaaagtggWgtatatV
+tagBcttDaBacaattWtDYKtatRKggStRtaaaWatBtaagtaattDaaaaBRacWta
+agtacaSttaaatccgctaaccKaattgVWttDattatttattKaMtcYtMRWagMtcgK
+gBagacgggVaaNaaatgctKcgtaataaKtaaagtccWcttHMatSYgataaatDttBa
+HccattgBttSgaaHYtaataaaMtgaagatgtttBgRcattaRaDHcttBgaMaWaaVM
+MattaatttgtgBRctattgKMagNcMtatttaaaWttgaaacatWgcScgYYDYgttYt
+VtattgcKcWtagcggtgBaSctaKatacaaVtcaRDccccgtgttBgKgggtHagcgaa
+ttaaagMMttScggtDttttaHcSaagaacactcacactBcVgaKNaDHacacttatSag
+aattSKHtcagtataaatKaaHtgaaRagaaVcBtaHtaaatcgatcWcaRtaaaattta
+WttaagtcaggRctgaWcttDttgactttaVSaaaatggtaWDaRMtBtaaaaaKatBga
+tMtctatatcaVaMgatttgNagtDRttDatcttttaMtYaaatcggagttctctaYatN
+tagaNcgMMactacHcaagtaaaatStaSaacaHcacSgggtNKatggaaagcggaaKgg
+gtaYtacSgccgBaggcRacgtVgDtggaMcYaaaMatggacgYStKKatgaBcaaRtSt
+ccSagcRccgccgcSDtgcggBDgaDtBtSSggacMttttaWcatcMatgtNMBWgataa
+tcaaVtgaataataaNatgcaaNttNctgacDMcaHccgatgKgWVttccaStggattct
+cDacttttttctttaaNcWaMWccWKWttgaaaMctDaaBactRtVattttBtcMaNttW
+cKacagttKSttaYaWSactHSaBtHgatgttacatgcatatMtttgtaacScWHBatHa
+ctggatatatctgagMgRSatctaaSttaVagcaRcttggaYaatKHtagBBactattcg
+taaagaagttgtVcgatgaVatHMtcaggtcgKSgWattgaaaVctccVgtDcaaatgaa
+HgMYactcaMatatatattNVttWtWaatttacRagKataaaNtttacaaWgMVactatt
+aSgaggVaaagVtaccDRHaaataRaHaRgcattMttcaatcaKaaataDcaDKtctcga
+ggBggacctDtttatHacWVaWgatDctaNaNcgKatcMtcMaatBtttggacgtgataa
+tagaaacRactcBtattttaKtgSaaggKtaggRaVtatagcccaNRttaccttSMaaga
+tcggDacNBatWcgaactacactaactNBtaStgVtNagcatctaVtaKatKgaBtcgtt
+tWaagWMgagRaNatHaaaaDtacagacaBagtgcaHaNatctcBccNttaagttDgaat
+aaNtcgctaacRBgtaatSttaatatgcataacccaSattKcccttDttggtcaatgggt
+tWaacgatacattBtgMaYgaRttatgatKaKgtattDtKWgataacgNBtaccgaKWat
+cttcttKtgtcttagcattcctWcaaHgagtatDMSgKtcagcttgVHaKcttDaataaa
+VaatttDgtgaaataaRgtcaVaatacttagtVatatgggcatgtDDtMtgtatBggatt
+HtgcVtgtgatcaaSattatKYVaacSNNttNWcgaHttKDaaMYHatcgttaattaStt
+gctWaacHtaKBtaaaaKHttcRWgaaWcRtBtttggBcDtgtacNttaagcKtaHgtag
+aaaaRttgaaacatagtWRaacYggtaaatcgctYaBtWDRtgttgSctaaKatNcattg
+tgtMttatccatatagctSacgccSNaaactacgNtgtgcttMatSKtcaaBaNaaacat
+aacagaaatagtagctcNcatcVgaagStaataVcDKKttcagDHDtattctaatgaggg
+RgBMctatacaagYactctMaaagtcgctttctcgtgaattatNcgatMtttaggcBaaa
+tctNtactaaRKtgKactattgtcatatgtacgagttMaaHSSgHgBatatcgcaSaata
+aaWgaagtatagaHgcttctttatgaccWaatttaRtaDaatttaatcgaaattgattMc
+atcaWaMtaWaKactttctBacactatNgtccttaWgtctgaccKatStaKtgagtacgg
+gcgcgtYNtatttagacctctKcatgatKWStcaataactaWgMSgHtgatctttttgtc
+gacgtSacttaYgcctWctcctctacaagVtttMaBactWVaccaYtgtSgcgttattcK
+tatStgaaKaccgNaataaHtatWtYtRacggcaDaScagcagHaYWRtRNcDtHtcVWt
+ggaataaaYttgVaNtgttagtYttgtagSaaatDgaggccDcgBRYStattatttaagg
+ccgHgggYRaaccMaagttatSttctttagcMtgcgMtgaSagaNaDagttSatgattWa
+tttagtDgcttgagtgMKaYWaYccagcaHatKctaKaDgctagacttattgattaaYtt
+atcttattattStaattWaRaYBWagYaatatgttRgScttgBagDaWgcgtgcVDaggc
+ttgtctaDRKacttgcaKBWRtaaVaSctKtacttMaaSVaWWcgSaNtttSWgtcggtc
+acttggVVtgagaataaataaDttgaaccaaaaMttaaaagaaaaaaaatcNBtatMgcc
+WagcaNgaVaNaaaaaaYaMgttaWtatHaagtNtacgacaBtMMattttWNaRtaaata
+gYaScKattacagctVKBtWNSKgYtYgtWatHaVatDaaatWgDatcctggSRagagta
+aaaMgatttRtaHacatggtaKagVcctgatgaMtaaYgatgtattattttHggBaccaD
+ctctggNNtYaatctVttgVtRtVcRacttNctttataggHSRtaRacaaattaacHaHg
+tgttgtttcBtBtatWtgtattttgcKagMcaaagaMtattagtStagcBacYaaHcagV
+gWtgtttcgtgDHaVtagDatcRaRtggtWtaactgcacgaggaaaRttSDaaVaSttaa
+aaacSMttactaNtcaacaattDtacttttYatVSacYtWtMttaattatcKtcttctat
+caKDtctStSaaacggtYccatgtgagagtWtagWKgcaBaaaaKttgNactaatcgagg
+cWtcDDaaaaaacactHattaattcactatYttaagacactaKaagRtRataaattttca
+tHggtaataaatgataHtggctaacBacDgtaatattRtYgtDNDBgKtcaggcHatttt
+gHNgWtaatttccgactactgacatVNttYYgactcgctctatttagaMcgggatHcgtt
+tatBaDSagBaaaagRttBggttaaBactVHgatgaatttattcaaaattgcacttcDga
+cttYcVttactVtttatBaKHagaWgtgaatggBtaaSggcagacNcttaDttVgMtWag
+attggVatttacHtctNcMatacttSatMagcttgtNcYaaScaYactcKctKtagScSt
+cagtttcatWaatggtgagaggHaggggcaacgcRKtaRcMaNtHaatRaRaaactVtBt
+gttaatRtWWcaaagKttccaaKaaatacgVttcacaaacgcggtgagaRaatggtgDMW
+atcWVScacaaaDaggaaHtgttSMaaaaaccYccDBtatYgtMagcSagaccaVcctcg
+gtVWaaagttatcNaagataataSaataaaKccgtaDtYttatYcttHttaagKcMctaa
+atggaatRgaaaVaaVtcKYaggatWcaBtDaggDatccttcYNtgcSMRgaRtNgaatc
+gttRttatDVMtagctttacatDVtatatatcagctaDagMtataccYgaggYaaatgDa
+aaatSgctctgatgtttVaaBcctgataKtagaaaccaKatatgttaDtgaDtatagata
+atacagtaDtatcNtgtDMtYcattRVtctataNtWttggNaSgtMgaaYctctDggHtg
+gHDccaccacKKaaacaaaatRatttccctttaagcRattMHctattHaRtataVattgg
+atcSttaaHaHgaaHNDtacattSaaggDatttcaaaYgctBcatattaaaKagtgccca
+tSctcgatRtaaaMtgWactttNMaWctYgRatDggaactcDcaattaKaactgagtatc
+tataagYaaaSRctggtacWtttccWtaYRtKHattatagWtKttaNgcDtatHacccat
+taatttataacgctMgaagtaacaacagMgtaYHYVtKMHtacMgKcaaatctgRYataN
+tcgttcaatacggWtMcaatYcBWaagYtVaDNagtatagDaaNtaaaYtttcYWttttS
+tgggataaMgatattagaaYtNctcttcBagactaYDcgtacHDWccKaHgttcttHgVg
+gVDttatcatKaMttttacWaaSattctatagaHaggKaDagBtaaagtcYccattgtYc
+atctaNgRgVtgaagtDKttatBKcggDtattRYgHccgtgcgBNMtttVRgacaYctSc
+taRacgtagagccgtacRaagtaHKagStSttttgYSatattaaaWHaaWagttDKaaNa
+NHaaHttaYcttMtcaaatgKttBtSgtccaaVaattSaacgttgNattgatatNctaWt
+VcagtactKcWacgVagggHaaRgaDaatcMttattaataacaBMaaVtgYtKgRgHact
+gtactatcBaMtVggtagKcYtHtBSaattagtaatgMcaVVagYYgWtactttccaaSt
+tDgaaMaMttcacttYtRgacttcagcttWtttagtgataMaattaagVtagaatatKat
+aagtagttaagHMRaDattaHaaVcctDtagtcVYcaataaYcNttNaaaHctcaRaatt
+tcaNRgatSHgVatagctRtcatgaBttMaaagRtcgHVtgRgStgatttgtagaKagaR
+WRctgNaHYgaaatBctgtttRttNWagaccgagKgtgcggHKVttaatattaatataat
+aDtaNcctacaaRgcaNMctctgaaSHWWHcttagtNagtWgWaaKtYaNgcBattatcc
+aaaSctRRHKaNtKcBgtgagaDRWBttactaaattSMctatatagaaYacDgatttccV
+taagRtgRataatatagtctttttatgtMgtcaacaaNtaaaaactctWtagaVaaaDta
+attatagtBStcgaatDtgattVaatMtcaDattVKWaagatagggttgtMRSgtcYgWM
+aatgNtagtcBttagtttctctWaaMtVgctWgSgtHagaSagactagKtagWggcattt
+HgttgacaaactcggggHggcWBgVgtatgggagVgagtcVcBtDctttagtctaagVWt
+HtgtttaScatacMBtKgattatRtgtttgtctttDggcHaBtRtgtaataNataattta
+taWctgaYWataStcHaatcRtaaVagDWaSatagtaccNDgaagtatacgttttacgac
+gKRtattgDctatRRattVtStaaactagatgVatttagaMaSaaaattVtatYtgttgt
+RMagtHaatttSttaaYNaggWagtgcacgaMcactgHgtgtgggHMgtKacttaaYgtc
+gcatcSatattgBaagtttacMtYagSatttatttaVtaaDtaWaHcgNatactgactHt
+ggWtataDcDScatactcStcDtgtcgtgtatgaggtHaaNKgDattgcBccaagKgtat
+gacKSMtttttgttcaaatcaaYtagtaSatgDaaaMccKNaMaatagaataagcaatta
+ttataaMgagtgaSgtctNYttattHaNaYYtcDDtaatNRgtatttaaYtaaatcactH
+VaHcStccttcccaaVatcVggatKtatgRaaDBgaYtttacttYggactSDtaBcaaNg
+gggtattatattBDcttagagYNMatBgttYaagactMatgttRgatacccgtaacacBH
+tatKacWgatRcHttaattYtKtStccaaatVDcaNKHHaaataatagtagtatcttgct
+NDggVaVVtaVaRaaagSaccgttctcMtVtgNBgtDtttctYgttactBctcRtStWtW
+DScMtcWSaRatgaataRHctaNtcStctYtWacagatgtatYBtHaHWBtacggtDcaa
+BtatcaggtcaVattaNctactgaaaatWaDgactNWtMtggagaattBaataYcMWYcg
+atMYatWtgattSatgaRtDaRgccagtSttatatRaBtattRcWtagtVgaagttMcta
+ttatatDttaggtctKtgtgtBagacgttatRKtgatctatttBtataactgataacKcg
+gagtgHgtVttcttgtKDgcDtaYatBDatcaatattgttNtaBacatcgcNcaKcaWcR
+ataWcVgtacgScaWgttcggHcMttcRccatgaRStYgNacagatacYacWWtggNaDc
+WagttHatMaNaatNtcDMDcMaKgHNatScVgatKWatatgNRgtccgYgaagattDHg
+tMtcHaSNaaattBatRagtaaatttacaagHWtKatcaagtccHtYcctgttKDMSgta
+ctactVctgacaaaaHgatatacataatKtStHgctScSatNatacaYttaaWHtctgaa
+tYtagtHtKaggccWBaStaDctaagagNtaatcaatcgttNgaYDaagtaaaaHataga
+atcgcgBaYaBgaacSaaWaaaaactccgcMttHttYgtaagaMctKBtacSagattcBa
+aWtaattttacRttatcgaRtacaRHgtgRagaaBcttaVgacVDgggaatVatagaact
+RRtacgYttNattVHgaHttacaaaaaaaYtcRWtgtgattatgccaSDtttatKWgaat
+atSNDgattttaacgtcSRtatggttcttcBtWtttMtBtMScttaHatBattHacYtaY
+acattcgttKgtcStSctcKtatatttcaKSgagcttccaacaccRDtttDaccattata
+tSgtcWtVaaagttgtagccattDtYaatattDaccatcVDaaRccagttttgtcHacMa
+ttcHgaNcatgttKcVttcctgtgcSataaatattgaKtctaWctMRaKggtaYcaagtt
+DttcgttacRtatgatggHNaWMtKttcatattaaDaSaBaaaMtMatBgKtttgHtHac
+taatcatcgtWaatKaaWcaWtcctVttaaNaggaaaagtaaagaDctNttaDBaBgata
+gMgaataacRcYggatcRaaaHaagatRDtVRactaYagttcaccaaWtctcSSaaatcS
+KattctggDgaacagDtaDagacagtgtaattcaStYttNaStgtaHgccttaScatMRc
+accWtcatttatRtaagatWtNataaWtMNtDVgWttgcWgtgaRttttRgWcttMtcta
+HacaaYtKctgaBagtRagacttDatNttaaaDgRtatNcHatcSDgtBatcttacVcYa
+cNgaattaacgagttgYgacttDattatacBattMgctagcctagatVcaactNttccta
+atgtDaacgYaNatagMatSWtYBaaaRtgMtatSRgaataYaScaVgtaScMagatNNt
+ttacaaHBaWtNtRtctaaacDaaaaWMcaNtcVaDNcagaDtgcWKYgagttaHtgcDY
+ataaacataBaWWtcggtatgtgaaScaacctttRNatcgttaaagcaDctaatgcBatt
+tacaattVaMgSMMtccYaaaBYtggattttcataWttgBtatDtBgactaatgtccWaa
+HataaScHttWttDtcgtcaagMctMDtaaaatRtBaaaacaatgtcagcatBgNNBVtt
+ttttcBacWtttWtSWWtgaaaaSacgBtaaataaagtcDStaagaactgttaatYatgD
+ctattactgaHtaaatStHaagacaKtagDtaaHaDgttccaaDtaaggacactctDggc
+gtDagtcWaHgRcHgDgaSctttattgtcttttccttRYaDgNactaaatcaWggcNSBa
+gttttatatStKgtcRtgattaaggtcaSBttaacaaKatgggatcaaattgRgcBagtN
+tcgDcatttWcctttgtNagDgctgcatttactttgtgtcaBgSatttNHaMcggcagSc
+tcKDtWBaagSagWatggYtVatSRgKagattgaVatKttcgatYatKYSgDaacNtcVg
+tttaWataWtgVctgcgSggMgatccatgagttgtWcatYWWcctVcNHagtNtgtKttt
+gatcaacttaSttattgatNcatWaVgNHcagStVHcggHacaaDttgDttWcaaRaKga
+aatKaattagtaWacattgaaatgtgaatgacagtgaRVtaaYagYtcggcatMttgaag
+gDgagDRcaKgHtacacaaaMcaBtagHactgKaatRtNttcttcatcatNgYgStggac
+tatgSMttgKtDaDgacRRgtWaVattgatttaagYctatatagactaagaggtatWtat
+aaactaYaHRctStgKWcgtRtKtYtYtagacgattRaaYBtaStcttaWataatcHtta
+taRcactgagtgggagccaattctcDtgDaggHcDRVaVVggaaBtRttaataaRRttgt
+aagKNcaVWWgtatacctgatcttBtcttRgaWcaVRKcagttSacttagcgtKtgtYWa
+tatcgNttcKaccacacVKctgattBtggacgtctgacaDtWKttattttgMBgKaacaD
+ataattWtBtBRtVtacataaatatttgtWtttatagtDtgcctagctHYaatgcaNaaR
+caatVtacctgggggKtagBgagaBgRaaNttttMtMagMtgtgattNctcNaKggWtMa
+tcttagWgtaatatatNctaYBggKaataBattYtaattataVtggNtcgtgtctaatta
+aacctHtacaaactDctDtctgatatgMtgataacWctgtgYSaaNScgDYaWtatDatM
+KgcaatttctgNcgtHtaWtagatatcYBttaattactcaaaVattYRWtatttDtaNMY
+MttgattataatgcgNggWaatYagttgBagNcaagaaaDtRgtaaaagctgcatctagc
+ttaVgtBttatagcKMSaattYtHcMaBttcagtcttgKatgVSVttKgttttttagtgt
+DHgNggtcaVtatttaacNtgaatatgctatMcatgaaaBtgBSaWctaataaattatYt
+tagtaDtaccggaatgagtaattggatttaacBtctSMgWYtgKgattacgRctctccaa
+tgtaggcctgaNaatScgYataaBBacaKtHtttcatgaaHtgBtagaKHVtacctVtca
+accaDaaWNHNaatgataattgatgWcagggtcMBtgSgRataHctMctgMHHtKaBtaa
+MtMgataaRWtagYtgaaMaSgctYtgcgaaHatDtatgtcWRatKatatYDcBgNtRaR
+acattMcagaHgaaagRccgcgWttggSatBagagcHgYtatctVtcatYaaVRtcaSac
+aMYDcgRtcaaWgaRgataMtaaaacaggtgtaaYcattgWgDHcWgttaVatttgcatc
+taatccacaaagaagSatgcgtagRgagtHDgaVcgtgcttatggMttttcatKSctNac
+HcctMaKRatttgatctaaatgHaaScataataatgtttgtgtHaVcaaaaNHaaaatcg
+ctgSVtattVttagaaNWcacagtgKtatgattHcYcttgDaWVataBatBttttWtaac
+tNaattttctttaaYHaMtttaaaccgStcHaVBaatcRacaaWactgtagVKtNRtcct
+agcWaatNgctKccttctcDaBDcatYHatatgcaataaBaagaatgDMttaHcaaYYtc
+actgttRtgacRaacctaWtBtBMagBctaaBaWtgatgVtttattataggttaattgta
+atYcaRtVctcttgcacSaaMaatactRSgcataKcagcaVNKttcgSatcaaactaatt
+DtaHtNaVtgttttttaWVtatNccagWttcgtatBcgttVctcBttaaaaMSaDattKR
+cctttcataHaattaatWaaataKcaHVaggaatataBYKHVtgVcVgtcHcttccgcct
+attDtMMgWaacttgWttYtttcMcgtcctaaVHtgWtggtgacKtcaWaYMttacttag
+VWtacgSatatcgWcKaaatHKaaaYttgtagtcaacWtttggtcaagttgaaBBaSHac
+VcgYgttWBSRWggtattttaYDtHatattcgatNttacaaaaVacaMccaaYStaataR
+ttVtcttagaVKaacaWcgccgtRatcatctaaatccMcctttaMggccHgYcDgaKcta
+tgMRYBagcaNDtgMtcRttgtgHaRttacatgaWcDtgctgtataggNggtgaatagBg
+agYNtatcagKtHcatBatgVKgaHWagattRDatatcgYcHagRtaatgWtcStagcVa
+tNaaaaKttgRaRBYNgtaaDtStaVRgcMccatMWaaattBDatttaatttataaHtag
+tVVaDRMKBtaacaatttttttDaRSgaaKDtVaBatcagtaaMttaagcctRgaNVggg
+ttcataatagNatcctacactacgcatgtcggaYgtaKcatggattgactttHtaattWN
+RaaWYggttcaaaggaaNtaatgcHcaaaattBtagcttattcaagVtatttWgcctaKt
+atBttDYcattagDacKVaYNccgYaYRaaMaattRaagaHtatgcttgcRagcgctSaa
+tagaaRacaRacSccagcacVMataatHgRtagcgaKgYRaDcVWSDVgRaMgcDgtaat
+tttaYttggtaaWcttKDaaYtatMRcgKccYcagtYcBgRccattcaKtgaSSRtactg
+acgHtgtaaaaBatWgcaMcBcYcgccagactcttcSatYattgatgaNccaaaaWaKat
+VgcaggtWtBcgttaRMagcaaagtgttcacatataaagaHWtKatctacttatatcacY
+RaaVagataagtaattttgatgtBctaataggtaRtaaHaattgtaRcStYSYaWRgMta
+caHcNSttVNScattNKaaKgBtagtgatYcaaaStactggttggggaBggtNtgtcaaW
+BaYVSNgtaataBNtagtatatcacMcScccVcgtVRRtttNcKaSRNaNtHRttattta
+ttgacaatggSaBagataaccgttcctaDNaattgctVtatNtHtatagSccaagctKtt
+aaacaaattattgtSHgMWgStttNaccattBMYatRtccStNgttgaaBcctVagcaaa
+atgatattcRaBccMWaagKtttttcMtgaRYNaataDttgttWRttattggHtNtataa
+tggttgtStYgaMcYVtcattaggtaatVcaNggaRtNataMWcctcYgcgagagRgcHM
+gcWtgaYtVSttgDaacgaaaatMttYWtWttcctgaKNttatttattRaattaagaccM
+KtttcWgtcaBagKSaWaaacaNtaYaDtBNaaagWtHgacaaagtgVtcatKcgcaatV
+aactatgcgaaactccNctatatMgactatttatSaaVttNttRttagHtccKtHtaaaN
+atttYVctaatttaaaatHWaNtSacgaaaHggaaatcacagVYcctaattcMNtgtYtg
+agttatttaBtcRgBHNacBtactctagaacgcKaaDWYYgcattactVagaYtgaVVcg
+caNctttBagKRcSgaaatttgtatccattgtggHcaatRtaVtaSaBtcYYcatcgtgt
+cHaVttaHattctgtcaBSNYaKBBattaatggctgtHatattgtBacDcBgatttaaaN
+tggaaaaYtNcaKagRRtRgttRtMtWgggatcNtacacctgtWKagatataaYVMtaaD
+taaacctctgtgtgccttScacWaggaYacttttKacgtttgtgataKYagaYaVatcWc
+SattaMcatBYttYaaatgStKagWattKtttaWgtagaaSgtRattcSaDagVaMatta
+ttYaagccSgcNaaDgaaSaggtaNgtWactaWcgHctgaNatttttcaatgtaMHSWaR
+tggtaNtaHBtttWWaaatattcVtBtctStWtaWMaBcatttcDagttDtttatatgtt
+WBtNaYatcccSgtgagcgaRYtBtagaDacBtaagaataWactaaaagKtaKaWaataa
+cKcccgDtagccaaagcggaatcgctSRtacKgcactacccHaactMgtgccaBaRaaaB
+VtcgSacRKtttStgatcaaHgKtaaKaccHaccacccKttgagcttcSttttKKcgacB
+gggtYMaatcBStcgDBtMcataWtaWaMtgaataagaaDatccSYDtgBatgactBaVt
+aagatctcNMgtcaWKtgcWggcgatacgtgtttatttWaDaNWBNaaNtNttcaaatag
+taatScgHtMWttgttgaBaDtgNatSaagtttHttaNaNKaattKatttgatcgtVcat
+gaatatBtttctaacKaNttVttSagccatRtatatcactcHHatctWSKttaMacaaDa
+ttccaRaYttttagttaatattcctYaacVactgctMcgagcaMYtttgaagctagtKgN
+WttgaaaMatcaMcttcSVatcaatgtNactaaBagatagagtDMgtNtNWatttSaHac
+tagaaaDggtaaaaNctMaatagtaHgacgMaaacMtacatHtaSagaHatYDccagtBt
+gaWatcYtVaagataattgatcgacctgcaacgttttattacNMWNcattataDVDacta
+tattatYattttgcgaagtgagYVtagYaWaHaatctgWttttatgcHaacgttaccDaK
+tatagaccaDDttaacgtHBaacatccgtYaBtVtNccaaataaaatVactDttSKtcMt
+DSgaagctaMtatattgattactgtNaagNBcagHaDattaaaWttacacaaatactcaa
+tSDatagctcaDttWactttgaStaaDtagatSaaDtgtaatKtgVataggaagWSaaaa
+KatttaaagtttgcgtaaagcccggNWaacatacatgttctaRcaHttVtcattatctag
+ttttNcataaacDttWaagVtNYtaggctttggtatgagaWgtactNaVatcactVttBK
+cttaaccttcMtatcggtaataYaMaYggttgtcaaagSWHctaRMSatVcggactMata
+tccgaatcttttttcgagtccagtttgaMtcgcatcaaKagtattRMaaaKDBttDNcca
+tttttaaBNtVtccgtaatgaKgtcagMVSattatttaWaattttaHNcaaMaHttgtgg
+ctattctacDtgaagattatcgacaaVRHttcSaSaatactNHWaaNcgtWaWgaccgRS
+ttNtHtcttcKatYatatBaagtcgctBtgagccatatScctKaagaaKDaWactWagBg
+ctgattBagKtgaaataBaaaaagSacScaaagagtagcgaDaYtaMcaYcKtaataMat
+ttttaactttgYgtcgaaggacgcHctBcgYgaaVacRYagagBaaYgtagattgcgagt
+caagtStDagatBgtgaccctaSWtctDgactaSHttctWatWttctaWtatctYacact
+gBWatKKctgtatYgacaaHSatYSaNgSagtatagatgagtatttatgaccMaatgtaH
+tStaWttgYagccaWattcagtBaYtaaNaBtaNatactggcttWcaagatDctacggaN
+ctatcacatSgKgattgacgacccccgagtNDtattgagaaatattaatcVttNKtaaWt
+YacgSNcBHgttgWtatgtttcgccaactKaattaRgacgNataatctacaacKgttBat
+YatNMSaaaNtctKgacttatgcttatKtcaVtVcagDaataattYgNtRtHaagcaata
+HcacaVgtaNNHtHDatgttaMNtggWagSVaRttcMVDtcttWgtRttctacKaaVttc
+VcgcatcctHRKtattSgttSacgaagtcccRDVaacBWagtgYtKtgattgSgaBtgcc
+BtcaKacaDatacttHatcattNatttacgtcagtgaggcBtaRNaRcaSgcatattatS
+tatgctYcacgtattcattaaRtgStcttWgtattKtSYttNaHaRtNYcRaYtVtggtD
+cKcttctactaMcacggcMtacgcttctatatHtaatggcattMDtaaMaKattgaagtB
+aaKMVMNacKaDtttKNcgagctaaagtccMMtgagaagVaataatggcaWaaaaVaBgt
+aSaVgaaaSaaaataDttVtBccaNagcSBgaMaDaVaVYYRVBgttYMtagtaactDta
+agWaattBtattttMDYHtSaStScRaKatattacacctMttgNBKtcRtRggNagtYMa
+ttaaatMctYgaatgcKHagSggaaaaBcaggtHtatWcatcgtStagMcctcatgatta
+WRcStcgWtgRgttttcctaacatcgctcgDDtRaatatMgtcMtHtMaDYatgDattta
+tagctKDtYHaaaaattaSatatctggtctttattttatMtgtYttgtcatactcaaVcY
+BgatgSctKtYcctWaRaataWcMgNgcgggagtcttRMgactataHaHtgctNtVaatc
+aaccacgSRaDtgKtaaMSKgtaaaaWaKtttVagSDtaaaaaatgttYattttNagMHa
+aRtNgBttWattatatgcttatatcatttatKtKaaaagctRaaatcgcYgacgNtacNt
+ccVtSaaatttcDVctaatacWgcaMtcttSaaWaaaWagtagtaattaactagRttaVc
+SaaatataacHgHatWaattggaagtgcgSSgaaVtgYgSttccatWVataatcgaatat
+gHtRcgtBttcttaaggatatgttgtBcNtaatgtcacVatactgaaatMBttRRcRatc
+catagagggacatcgccWttagttgWttatKagtaaaagHtttccttSatVatKtgagca
+atttattaaYVattcaaattctgSattRaMtgaatMgttattattacaNcggVagcctta
+aKgccYcaaDattWtggMcttMacWttccMVgtgaattctDaBYgacttKYtBacatgct
+DcRaaKaaRaatatctttagKcKtaactttaatNaaggctgScacctYgcgcaaaccaHt
+tVHcBaDgtaatHaHVaaatMgttggtSatHtNNaaVagtgtacaataaagacgKttcaa
+aWVacagctcacWHaatcctgtBNWtaNMKcVcVSWtSgcaattctgKtVVaaacaRaat
+tgatRcgBacaKacVccVMactagcgMNaaactgataDaSgagaatVHaatVSVtccgga
+tgRgtagRatttgtaactaBataVaggcaagHgaaSMSaKgctRagcStNcatttVgcta
+tacttcNDtcaKBDcaHtDcaatagttHttattMBgagctgtaaagtMgatStStcagat
+atYcBtataacRcaggRaaaggtaWSatKgatatgagcgtgMYatcagcatVttSgaaaa
+aatatatgttYttcattatacataatVcacgattataDggttBtRaagtHMtatagaDgN
+ttggDaKctBcaaRcgattcgtgccttacaaaWattYWVcaaWagDattgaaagggaaga
+HattBtatVggtaHtWtaMagtccagaKttSatatcaStDtgWaagtKWaggtatttaWa
+aRcattaatStgaaVtacggaacatKctacatHtaaaBtcNWatttBBaNatRcDattcg
+aactataaattataactcagtSgatataagRaYaKHctggtaaNtttaaNgaRHtttatt
+atacNttttaDccttYgtaaacaggaagtgataaacatBgaSgtaaaaaaVcBgtWNtRM
+ttBttaaBgtaaaatatcHNStaBtaggtaVatYaccNtBaWagRctNSacRtMatDact
+StVctaaDtaYSRgttaRNttttKggccagaaBcatagtYcaYNtDatcgtatVcaatWR
+taggaattMcatRtgggatgtcMggMtttataagtaBgtggacNaaKYtgctWgagYtWc
+ctWtVcttaaactaRacatggtRcatctSDcHcMgcaactttttagttaccttattHRgt
+acggcactDBggtMHcVaaRatKctSHacctacaccactaaHaacgSttagKtKttttgN
+HVgagtaYaMtVYNVcggttaSBaBtaatttSRcgtBgaWaatctttttKggacaWKaat
+tKSaccttgDRgtcatatDatVMtMaVcgaattaNaagMWccctaaHgataatatgtatt
+WataaaatBaaMtgRttcHctaagctaagatatattMcggactaRttttKaSttactWYt
+gBcaMMacRRgNtactttaaaSKtttcaYBaBttaVagtRtHcWaggaVccttNgtgagt
+catataWttYScMtWgVRgattWtaSggacggWWctBHatattataaKaagttactaMRa
+aataSRaDttDaaatataVHaatggaaBDgWgHtcKStVcatHtaatcatggBWaagHta
+gtMtgHcHtcatggggWcatacaHNHagcDatRcaaattcgcttgDggDNVcaacgSgtg
+gcaccttMttaatattVYtVgaagRttaBcagVaYaHcaRDBagatgaVHtNMtcttact
+DaggMgMaattRWDcctVtgagaaaaSKatHHttVDgtctgtcacatHNttgaatSaagt
+KBatatagacaaRVctcWtgtacKtaacHtgHataSgVtactaggtttatggBgtcaaaY
+aDgaaaaaatcgMtagaKaYatgaattatYcttKtacaatttgWttMaatBgaatSttMt
+NaVgVtScgcttctBHKgtaRcNBaatcDtacgattgacgtgctatNaaBtMgagNgKct
+tWcWKacactYgttVgNcgaattttcttgaaaaactacccctcgcNtgMctatcccacMc
+actcMatttatttagtagaacMNtttcttgYKaWtaaBtttcWttagHtgtttctcttgt
+ggctatgDgctaatWDataatttagaNcgcRRNataKtctaataHgaaMYctNaKWtact
+aacDtgaVcgagaactggtaccaactHgaggctagagHHagtMgKtaaactacaggMatg
+tYgSBaKaaaattMgatRtggggtHBVgttaattgKttaaRDacgMactcaaacStaaag
+ctctgtgccttcgtSagtSaRctacaataKatattctaVgtgtaattRacKagttattga
+MtaatgaNatacDataaggactttccNtStatatKaagaataKtatggtcctctatgagg
+ttaaDtgtattgataaaactggatcactKBtttggcgtcaaagaaaNtagtWKatctaaW
+BactDaBaYtacaWtaSgcaattattWgaaBgactgaKctatBRgtagttaBaRRgattt
+aagBHctStgtVYRtaaataaagtMWtcHgcattcacaaMWtcMccWttgVgcHaWttca
+NtgtVaggNgcVatKttataaWDcccctatgatVttttattacagRBBWttcttRaWgaa
+tBVgcgtHgWgaccagtYacaattgSttaaMcVtDatttaVttRgttKtcaYWatKtaaD
+tttWaYtaatYctSctatagtcctBtccMaMMtaMYHaSSgKaaacttctcBtMtgDtgt
+ttttagRcgtacttataHgKtNtMtKcBtaNKaHStgSagYHtataDtcKtagRtNWaac
+VgctVtRtttStNtgaaccttaVatgagaaggtcaKSttaDataagcYaSatNStcaatD
+NgttcgacaatttaSgaRaBNNacattRatNtgSttHVtgWHgtSHccaactKttYtatH
+YttVtgHcNgactMcaacttBatatgSgattttacgtatttgtggtScaacggYtHtgca
+tctatttttWtaSatcagaYatcgcagtgtgtMgtattctttcattaRatttStcaatat
+gcttDtStaaagaccDcVtaWNcHYtWMaMcgaacKcaNcttacctaBtgcDacatcaHK
+tRcDaaacataaRacNNtccDataNactttatBSDYatDtctBtaBatctDatKaMcatt
+MatatcDHctaagRgYVcatgttcgtgataHDYaagttSgHYctaaatgtaaaactNgta
+gaaactaattRaatcttttBKcgaatSctMaggVaVaaatgagataaataSgttKgtcat
+KaKatDYtaaaRttYaMtgctcSatRtagttttagcaaNtaKgatcgWYcacDgaatcaa
+tactgBgaNtaactaaWatatacaatacactaNatcaVaKaaMaaaaaatcaccBtgttg
+NctaacaBattttaaKWcaggataWMtaattgtaaHtgVtcgaHtScaHtctcHacVata
+gtaMcaaKtcccSagMYtWcaaatHHtaagRttDagtMtcYtttaaWWaaaVaRtcHNtc
+tcSttagcacaKttgtagtNgWYtatKDtcatttgaacctcKHtatccttattcttNggt
+BgtgtKaggWtYgtStgtVaRtaRaaagtagtgtcgcKtKagatgagYtttaatKcScct
+gaaaaaRaaHtttttaaaVgtatagKctaNtKaSVgttcgagacattttRSatagttSac
+ataMtaYHccacttttctatactagtatgaBaagctttaMtgaatgtcaKYtaaatatgg
+attataNcgBHatcctaRaaactgttgacttYaHtStcatcctDaMBttgtaWgagtaat
+WKataaaBgBattcttttctttaatWStaatacgNaagtWaMaaNgactMtgaaDaggaa
+aSctaSSgatatDttattatcatagBcaataVcHcRgcStaHaaatWagatHttMHacta
+RacttaYaaaaNtataHKVaataKtatgatcgtcVaaWgttYtVcaaYggctRWttaaKt
+RttDaKtgtatcaattWKaatBHaaaaNgaatggStHgVVgatMgBYtaRNgBDttMcNt
+ggaNgtcaHtgttDcNaggBtatYtacVaNttctcWtactHYcSctgtYtDtgWaatcHg
+atDatatcHtcttatattaaKaRYaDgaatgSYcgactgcRgaagttagtStYatYtttc
+cgacactacagKcaaagDttaatVatcttaaacRaDatRcBatKNtNtaaaHtcBgatKH
+cWStSRaKaSMgtaKaBacWgDDttgYaaYttaNtDgHtatSaSataaaaMBaaDtaMat
+DaagWtggaMtRcacttatggctNataaaaatatWNMtacctatgtcaYKaRacagttHD
+agccgtaaYcaatataatcatagggaaSatgMYBcKBBtaaRVRatRtccVtgtgaagVN
+ttcttagtgtcWataVggtaaNaatVgVaKctttNgtttagtaaagBatBtgaYSagHtt
+SYaacaStcgcagaSttcDBtKtttggtctacNttgNgKNNtcaaaaKWactgaaYgaYa
+ctatHtaWcaactgttSatNVtgtctSttYctgattVaatKgtaYcaaattSgttaStat
+ggtccaatgSWccaaactattgccgttacgcNatcHctctcaKatgtagtctattttaag
+gHRatcDaagSaVgaVNccaBKtacgtttStagKgtctaHtcattaYcctaVKtttaYaa
+atYtccgataaaVttcDgatWcgBtcctaatttNaattgctDYgtgatcaatttaagggc
+tctcatcKattgBtaBagcaYcKctctttNtaacHacNStggRtMatHHgtacatgcaMa
+gtgtccatRWttRKctaaaDtcMctttaNVgaNtcMatcacHcctgWtaaStcacgtctN
+aagRNNaagMaDtactDgctttttcatcYacttaKttatgcStDaStNaMgDtaacKtMt
+acctaaWattggtttNaaVHatgaaattaattacgVNaaWtggaWatctgVatcacYctc
+VHMtVaNacNtcccaWtttgcaacctcWctHaatcttWcaaaYaBaattSctYatctaag
+DgBttagtaSgaWtBcRcKtccYatatcKBgtctttatgaaHDcgNaMatggatgtWagR
+ctStagagaagaacagctWtNtataaaataRatHatKgctNactHgttRgRgVcRacatg
+HYaNttaHtattaNStaagatgtagaHcVctcYgggccYcaaaatgatcttctagctctH
+MaMMgcaVtgHgtaagaWHHtggtaactBcaMNNctagaacggWtctttgaggHcYNaaM
+HtaYcttKaagtSccgttgggNMStatacDttataaaVaYcKtcgcattttcgacctctc
+acVttNtttattgtcttctaVcatagaattMttgtHtMgacataaatagttctMtgtWgW
+ctttcaagYgcgtNaagcaaDaVHaaStMtaaagccccgtgVgtcacatcHVaDtgttBt
+BacBtcggYttDagaDYtccMttagcttacNcgaagatRtDataRtgctaatatatgRtW
+VttatWKtgcBgactcgagaSgtaaaaagttaaWaaagtatttctcWtatcBtcataacN
+cgctcRKaaDKactRaNtagtatBtgaaatttcgcDactttaNtYgagagaNttgaatta
+ataaaSMattRHNtYtgttgaDBRBttgWttagSatgacDggNVagRWcggctacDaYSg
+aaattHgtYaaagctccVtatacattaMctttgSgacatBKaattRgtaBRtttaactat
+tctagcMKMtttctgtgtgVgtctttcDcgtaaMtaggtaaaDtcaYtatccgattcYtg
+aaRttctKaNctaYgYaattYgRttWctWttaaaccaatcactVatgcgYttgaaatgat
+KBcNRgctcatgaccHagcgaaaatgtVgccatcaBSatKccRStSattaaatttggtaa
+gcVattctgVcattMtacatMgaaaaaataYNDtDaatcatWattcaggNcaccctcBtg
+cKcHagYtatBatgBttgtVttaYBgBgataaHNtacRtcaaBaKcagNtcagaatYgtt
+WgggaNDagtatagRtctcDtDaHScagttcYcatcSYacHcagagNgtgcHagtacagc
+tgRtatatMtaatRaWMHgaaKacaBRtagHtaaaNcVHcatWBgWaaacWccggtaaRc
+attgMgttaNgttVMVttgcaagagaatcaaaaaagYScKVtgccgacHgacgttcaMcc
+tcattatgcBttttaagtKatDactccgBatHYgttcatcgaaatctSaKaagaatWVtc
+gttgtcttaMaaYaSDtaaaataccgcKMtatgKtgScaaDMaaaactgtgagcVtttaR
+cttgtaNMatatatttggtMgYVatDaatttgctttaaRtaBgttaYaaagKtataMtWS
+tcHaaaaNacgctacMttDDgactacaNaatBcagtcattatatSttaVgRtWgSggcaa
+tSataVgSYgctBttataaYRRgaactgtgHtgacHWSactYNgtttBactatWStaNtc
+StcMttgattStacctgaattctWatNaaHgMatattcaaaKWaBaataatHKgaWgata
+YcaWMBtgtacKagaaaaagaattttWttDaMtggttgtgaNMtVtDcaacNttactatt
+acggKctatttaaaaBKatagttHaatggaatatYWgtaVtNaaYgataatMaccWagag
+atRttMtgKaMcgatattaacaagatgttBBcNaYattcNgtRttgaBcctaagaSMttc
+MtcctcYattcaNaRBttaatgVcMNgaacKagatcgNctaWVgttaaYRtgctSctaaa
+aNtttgctaaScttcVattaHtaaMacNgttNtKHMcctattttaRtttVtSgtacatBg
+tVaaSSaMVaRBcaSaRHtaWtWHttMtattVcaMtWaaaNaccccgHYtcatagaaRta
+aBaatttaBccaatcRctcatagWgcBHRtacaaDttcBgaHggcgctaHtgacagcSNa
+ttcctcgagaccBggtcaagWctgVcRDgVtaagtttaattatcMtgatNagYttHtYta
+gccRatagDtaatcNtaKtacaMSgDaaaatttgHaHtRDgtaattKtaMHgaBcaWtBN
+YaWgtttStttaSttgataatgactMKatHBtttaVcYatgggttttaDKcSatttMata
+tcagtYaBtgVacaatHcaDMcccgtaataatagDataatVaaagaagaVtctccgaRgt
+RtaatcgagtcacttgttSatgNDHaSNRcggtaSaagcSaBgWSgcatcaaWatgttac
+atgattcWacMtagtgNcacgatgatttttRcWttSgtaatMRRBaacNWRHaaBaattD
+aagStgatccttcaDacccctKaagScSSHaaYHWcHcaWcaaaMBataattgDtagccW
+tcRHataMNKtMgHaBcatcgaagtgtaRgtgggaVMatgttaWRtStBHactaaRaact
+NctcHaaaggcatgcVHKHgaatcSccttggSaWatWtNcaaBctaRagaaacacgcttc
+KatRattcWtgYDaaaaaaNatWtKgaacgtNttactgWHBaccaWacggttcaaVgaga
+aacVtMttatagaagtatWtaaaNHYaMacagWagtaatttgcatcttcgaatacggaHt
+aatVattctaDaHtRKRaNHcttacatcDKttMDKaWggDtaatcttYctcWtRaaaaKt
+aatcctgccccatgcgDtctaaVMtWRKKDctaatatDgactagWtaaaBcKcacMactM
+HHttgDataKHDaDttHttatttagtcaaVatccKWtacWtSVcaggtaatatDSatgcc
+tKtatDtttagacKaaaagcgtttaaSaaaYtgattgtKtgBMcKttgDaaaagttBRat
+HgcaKgDgtgcWataatMWgcVaVatcYgWttaDatcatNaVgtttgggcttgaHRDaWg
+atttctgMHgtVtgccttBtWtaatcgttcgKgRcaBaRMtaattWgctaatMaVBccaH
+tDagaBNaataRcacYcYcHcatBgaNtgaNgKHttctYaacaaaYgBttRNtNggaagc
+WtDggattgagtHaWttVacaaaBtgttaNctaatactKaMaaaaaDtaRatttDaaagN
+ttcYcaaactcMgaYgtacaaatMaaatYtcacVaacgaaDagatWgBgaataggtWtKa
+aMtgDttHtgagttaatttgVaaDagttNMataatttaSVattNaDtKVccaaatcgaYV
+taaaacKRaataatgaBDtctRtgVcttatttYtgaHgttBWatgaatatacSaacctSa
+tNNRccagtactKagaRtgSKMcgaaDattttagtHcKcaaagtggtataaaggctccta
+SatHtaMtRKattaNRcWtccgctataKggatWttaggtaatHDRatttattRWgcgatc
+ttagSgtcttactatgYgttYaVBtgcaYaaRtDaatacHHtDcttHgBgNcccataDta
+aaaatctNtacatatWaRMBgaattaaaacgctctctcaagtKcacNacgVRVcttttta
+acttgctcStatRScaRaMataNaKagtatcattRttNaVatcKgtacNatttttgaNcg
+acaaKctHWtgaKStacMaBatgWttNSacaaKcaDaatcWaKaccgYBggMScgaMcct
+agcaDatgtttcVatgtRBtKNWHtcctWDtatttttNNSaatattcMttgatKgNgaNB
+atcSggtctRcttttttatatggtNttDYNYgaaaKctcacacYHRgttacatacttYac
+aataNaagaaaagttataNaataSatacagttScacVaScaccSWtccagKHtaatcaaa
+tVacatWacgBctccaataHaaYtMtacKacHttttKtcataWWtgtgaatWaataaaaa
+catttcaccttaHtttgttccaatcccgRBaWgatKgagtttBaVgaNtaNVBgcaataa
+gaatagcaKRttgtatcaattaMtaacatataDBgtaaNttcaNcgagatYactggttat
+gtNVtaBNtDaaDtDttaSaWtactaVtHactttNttcttcatWttcDatKaacgtttgg
+VDaDtVagttatgtcagactKaatcaYtSgttttataaataDttKttKagacWgHgatat
+aaatcttagatNKtttWtWaaatattacSHaRgtttScttaatWttacgRRaaMactcat
+BacaccatRtttgaacctacttcDMggcVaSBagaatcttaKMagcaVtctDVataWtSg
+atagacttBctDtBNWgtgKatWctYgaaStccgVaaaDattYatagtatcaacBaWYct
+gaaatttaKVgYtStNtcaVggtggaNYgaRtMaacataSttcagacVactcaVaagtgg
+tattaaDBNDaagtatatMtactatatgatRSgtttgccaacgcacRMtacRYNataaga
+tcMgttgatcataaacttVcatatgWtacaaaWttggaaactttaScataactRattMtD
+acVYataaaagMaattttKtgaBttKcaacatattVtagtcatgactcgDaacDtaWcta
+tRttSSYNtgWaScaaataagaaatKtagacataatggNaatttcSKtVWtgacagKWat
+tcgVatttcKWgagcaWgNKaaaatatgtaaacgttcactaaWgacaccBNaacagaaSt
+ctgctaHcVtttMtcYttStagYcgtttBcRtaYacttgNaacMtDRtagcatgtgcgag
+cScaMgtaatBaKataactMttttattaRcattattatacgtaagSNatVRgcttcgaVa
+acHNtctaHBKYgKaccYcttagagcccaVgatttgttagactaaacgtgcaBgccaWga
+VataggattDBWaattttgtBacWtttttaatDtMgaactaagcVtctcagBMKatgatt
+gaNaVttggatDaSaBatttcgccatatgctaattgYacatgatccacaaMHtttcKYKa
+WtYcgDtNaaDccgNaNcacacHKttDtttaggctagRVtYgtaactagctttcacaaat
+YtHaattYacaattaMSagMactcctcatgtScttcaaYtataaaaScHYaKcaYacact
+VcacataNtaBcaRatgYagVBatttgtaactttgRggacaagcVacctattacRcaaMa
+cHRagagtaVNctacagtgagacgaaaggKttacattgggacaataKNtattcaagWKtt
+gatNagNtgctaNgagatNacSatctNatttatctatRgaaaatKatNKSBcKactatac
+StcagtaggtVtcaaaBYYgctattKtWNttcRacaaaNatgaacttaRtaaDSttVBYt
+aatccagtNaaacRttagaaccRBatataWaatKctcattcSacWaacaacactDttVtt
+gacYaagagtaSgcMttBttaVNgRVagKDcttcttcNtaggttgcgacYacttaaggVH
+caagDagaagataaVaatctgtatRatDtKaaSDgattcaattYtcatgYgtgaVMtMaa
+ctaagaatgRgDtHttaaccaatStaaaaMctVDDtgttatcttaBBgccNacKMaHggc
+BMttctgNctHggagaataYMgtaMccaataattHttYttKggtKaccaactcccHtMSa
+atNactcRtttcatgcKcatgcacttcatSaatatactttVtaYttDattgWcctcactc
+YccattaDDaHaaKcaatSttagKtWtcatRcaactattaattYaDggKtagtNcgSgtt
+tKRgtDWtVHtDNcHWNtKtccgtctagtatSctaBcacgcaBtaacatgagatVtttaa
+ggcaVttBttaStWtattgYaggtSatBMBDactVtggttDagacataaactactBgcac
+aacMaagaStccaWNaaSYMYtgtaKaMcYSaHaaaatatttMgtcaaDScaKtcaBVta
+MVMRRDMtcttRBgWctaacttgaacNaatgttWgtggBtRttHVKgKcHVtatattSaa
+aatBttcBtttcDgHccBagtRBRttaVagBctRcaagcattacKccaWVWtaVcggtta
+tNaSgccgKtYcBaagcWgcatgaNHaKtagNgcHcgtgtcataaaatagagacttgHYa
+tattctaBgtttatRatctatttagacattttNtWaaSagtaHatRtctcggatttatgt
+gatBtctRggggcatWctaSVMaRtcatgKattgRcatMaHaataNcBcDcaggcactat
+tHBgaatStatattcatBgMVataaSacVacKHatggttaaBKtgtaSaWMattttMacK
+tgaaWaaWgctgRatgtgDacBtSaHtDgtgtMVttagatgattagagaSttgattgtSa
+aacagHaaatacaRcaccBtaaDtcaMtKaaStttatKagaataaNcaaBtattKaVNaW
+aNactagtYattaaagWgHttaMcKaSagatSactctatMSagtggaYctcacKKgaSMg
+cRgKtgccagNMataatccaVgatcttHagttttcttaaccataggggcttaDtYatcga
+aaMataagcaaatBttgHHcHagacagagaggcacWtacccMttacgtgNttattYctVa
+aactgttaagtKatMagttcacaaagggatgaVNMatgcaSattatcKagtHaBtgaagB
+cggagtWttVaaDaccMScactgVatccaRaSatattNtgcBatgBaaNgtcaBMgggaa
+tgagtatRgaatgtNttacaggcttaHaataaHSagatagtgVctattaaagggaagDWV
+ccatcKaaaatRccccaSVaaatttMtatStgtWagtStMaaatBctgcctKWgttDDaS
+KactctaaVRtaSWcVactggaaaaNMaaaccgcacNtaVgaagcttDNgaDBtaMaMKN
+tKccaVtgctcttMMYaaaaHaattcWgHcgtacatWaMaaKtaataccgBDaYRaggat
+atSKcScYagMtaatKHMtaaccatgHgtagDaggtgtaaatatagaKVgccRYctcRaK
+BKWtgatHYcaHgBaYtttMcatataatgaDttcatttaStgtcVSgacggtggVgtBtg
+acatgtaaSgtBgatKtKtaYcatVtNattataaaHaSccHaaagctSMKattcatagca
+cagtgBRataacaatMttKcWaaaaatagStcggRttaattatWaataatMaYagatgVt
+atccttttHaScgtBgagWcatgBtgcctatcgtaaWHacagtactgaattaaaaaNatt
+RNMaSSNSctattcaaagccVVcatattttagMcgtattNtVBactacScattgKVtata
+aKtttgNaWcttNacctagtgaNaaDcagtaWgKggaaKtacgcaaaYttatacSttgYa
+YttcDNagggttVDagHatSgtacYVatataVattataSataacgKgatVtVacHYRWtt
+atcctaaDtgtaaDgRDttttattWtaaDttggatcattNgtVaaaVggaaggcYgSWaa
+attcWHcgaSaVWaMatctMDtHBgttttaatctaWaagatatDKtVttaccgaMatRaa
+aBttaNagHatDHWcDtBVttaatKtMataYttSRHHcgtaHDtggttccaaagRRtaWt
+VctRcaNDttatacgatMcaatNHtacgaattBaatHtcccatctctccBtgtataYcta
+tgtcgaaDYWtNggatNcacRtMaatNtKcttSYSctaDaaaggctDaStatKtataBgc
+VaatttggYcttaaatgatgtHctaaccaactttgggttcMaaDattatKtVacgVcSca
+actSataSccHttYctttgtggcDtMcactaNSBtMRBMaggttWKtattaatgtKHact
+tcaMVatctgttgtccaaYNtaagttKaacttctHcgcWtYttatMBgBaMacaattaDa
+actNaaatSatcVtSSgatctatgNatSYaattRatgcDgtctataagagaagRgatatt
+tcccaataHgttttWKtgaagNRtctaaBtWcHHcDgaattgaaaKtgttaaRtatgtaM
+aggDttcMaccaMaattDctgYctaWtStaNtgRKaBtNcMHcSttMtaKccYacgNNct
+ttatStgVtaYtaagttaagaBHaaStVKHatgttRVWtataMtSatgcaattcMcttat
+KgMcagtgaatcYtcctNaYcttactttctcttcatggcgNcatScStBtagctWtHaaW
+attaccgtctcgtBMcaaacKctcccaacttBgtWStVttMRgKcVagHttVtaagMaNa
+tcaHttacatcYKttDBtatgSattVcgBcBVYttHNtcatKgcYgaaSaKtatttttMt
+ctatctaSaattDttcWagHSacgttagYgacWaSaDKatcNgctaatgVSctgctYgaK
+gKtaataggtggagcgtcgaaaaRYtgYWYSaatacBgacWtaNStcaattWtRctttta
+aSYgttcNgtBWWgtgaatHttttBaMcMtKccagtattttcgaHaDtSVgatgaacatg
+cacgtcagagDYattBcagDctcttNcNtaaaatRctgMcDacaagtttagtcaaSSaag
+aaacatacaDtctctYgcaaacBcaagaBatgtattgacgagYacBDgttcgtgRtaMga
+attttcNtgVcttctgtctagtgtccatatctgatYatNtatVWgttacaDacaHDDagW
+tgataWtatcaaBRatDRtMgVcgaaattcSMagYgWacgggtaacaaattcagcatagS
+gttactBctgSVWatYcYgcBWgggRcHtataSaattBcagHgcgcctttKcttWaggct
+ttaaDtRacBactaaVaaKtaaacctcgcgccattactKactKSDcgacaVtatatagga
+taKctcgSatgHSatVcgtagtgaBtSYtgaBataatStaaccaagttcaDtHtatatta
+acYatattatcctacgagatcaccgtVSttctYgtcataaVactcgWtaVatttgttgga
+ctaaaVcaSaDtYcgNtYtctVaMtaattatWRtWcaNtaKcaaYggatgNgaatcaatc
+RtcgagtHcgVgttataHDcatttaagttctHtcgMRHtaaagaVactBMtatgaagtaa
+aaaBNtataaNttcKcctaNttaaDtcgMacgDcaMatttgYtaaNtcaccgatgagMtg
+ttaggWcacHttNgtcttHYMcaattKcagttcNcaaaacgNaaSattgKttaaBaKtta
+tttaMggHcttttaaRNVgttaYttttMVRtYVgRatKcgVtacgaatttccBatBgYBR
+tSKKctaaaatgatatgBtcttcgtttgacHagtaattatatctgDtBttatgaDtatKt
+cKRcRttagattattagHgDNaaaKgcgMtHtttKtDtgaaaagtaMatcagaaccgaat
+KgtatatVaccRaKYtDHtcSagtBgtgccWaaaggtYKcaHatDDaaattDStDtcKgg
+tMgcMtgtHtcaaVcgtttNtagtNtgKgctaDcScgBcWSatgtatagcKgWgttgaac
+gagtgcgcgtKaaaacgRtttccatatatttttMgaKagcVcVRataccWctctcgBcga
+ggcgttaatgaHYtttHtaSWtagcagtttKtYaacaaataMtaNDatRgMBaBacSaat
+aSDctgaactattgataaRtaVtttHatWaacWtVaHaaBDtactYtaDactttSgtKtR
+attgatttatatattattataattBatagattctaacDcRMaaggttcgtcatattRVYc
+ttKgtRcgWaatcgaaWWatDctacaaaagaattHaatctgttttacYatKatBaccMaM
+aaVtcacStaaYgYKgtttctcattatattNgSaaHtgRaBtcataKYtHtacttgtaca
+aaDtYtgatagNRcYatgaStaaagactgtcWDtYaatVaNStagaaaWtaaaataDYtc
+aMatSVBVaaaYagaaaattgtgcDagWSaStattttaatNcacgataNBtaattggaat
+gcMgacattHaattctctaaMatactaBaaattacaHWgBNtNaaSattttaacHtgtag
+tBtcRtttSaNNaYaMaDtatDtagaKggYgcaaSttgctactDcNRtWgtttaVtggca
+aactattgSgaagtattatgDgcgtgtcttagcNtRctKggtMaHgaDaaagtactgtcg
+atttagatcagNggtaattaKaatgaaYaaHaattggttVaaMggatactctaBgtYHMc
+ttccVcaaWtgttHHRgagttKaaagaBtaRtaaWaggttctatRatSgtatcYtaWcat
+gtaBtcaatctaatRgaYYtWtccattataBacttWtcctaHaaaaggttgacgtRattK
+gaagcattSBtttctaNcSctSStNtYtWaWtgtagtcttgtctttaagNKgaagacgDa
+RgtNaBaVDgaattggaYtaccSVYKctSKKcatagttgSttatcStactcaatSMataH
+caKgatWVYtNacagtttBtRagYHaagtaNaaVVDgatattMaagattagcatcctaMa
+aMctgNtMcSaRcgctHMttaattDtttYttcgataaagtMtaagttaWaaDcaatccKg
+tgMMcatBgtRtaHBcttgtBaBggcaDcgaWttgggtaDaggtgatRtYaMWDttatcN
+tVcttRaKagctRgtgcNaatctgattatagattagtatatgaataDNatcYaggKRaca
+atcaHcaagttagtKgRatRgttaagaaaatacVctaaaagtgtaagKVgcttSWaaHat
+agHctagtDgDtSaVtgatcatttaNKgKHataKBctatatWaNgtttgcRaVNttaDgt
+cttagHYKatYaVaBtaatgaBattaYcNtgcaBtHaacttVtccatDagVaaaYgWtND
+BgacagVgctcaRtaHaaacttttacaaggaSRaaatagaagaatacccVaHatcBRtct
+tttaaDMHWtHgacMtctcaagKDttctgYctctcNagaMgcgaaDWatMcMatatttDc
+tttactaVSctagttcaRKWgtttKRaVaaKtacaacaKttatttttggcctataaDgtc
+BctBDgcYYaatNactcaaRgaRWcgattgVNcWaatctgKagDMgctatKttRatcatt
+MaagtctaRaVaattKctgaKtatccgaaRatcHMaaaaaagattccacgtacgaDStat
+atctcataggtacgcgatgtgaaggtHYtatWagKVKgaMDcaatttWccttgKgagtct
+agatgaatgVRcctaMttgtaRaaYtRtaacWgaaaMttatcatNcgttactaaggtDaa
+ggcagtRctcatcaatggYagccagcgaatatagtgttWtaccaRctagatttDtaaatR
+cDKtccHtBWgttctWaagccYBSgtggaaagHNttHtctaaattaBatggaDMgaBgat
+atcaatactcMtaaKtcYccgatDaYgHDBaagBattWattgatttttaagaRaaggatg
+gYggaKttaKtBVBcttaWcttBtacctYaNYttgctgtBaaMtWtcWaagtaaggWcgM
+DaaNtccWMWtatcMVgaSaRctaKtBgKWDacDgaaaaNgttcaaaaataMcttaWtat
+gNaVaaRataWtgKctRatataagtgttgacgaKgaNgtaHattaaRagSgattctatgt
+YtcaattagBYBatccYtgtNacHagHtacVcVacaacaccgNgBtataYaatWHSttat
+tgctDacttgtgHgHcMcHacagctRSDtgattaggaDHtYagatggagWtaMatcRccc
+acRaaaYagcagatgatacatatttVBBcaaMtctctaWgaNtttcctaVcttaYBDBct
+RgSaagcNgatttcacgtcRDaVBttaRaggtaaggHcacttccgDBKgagaatttataa
+aMaRattagcVgtttacaaagagaaaMtgDtttYttggcttataKaStacaVttBttctt
+gBcVaataaagagtgagBgcgNcNattgaaacRcactDaaccaatWMtaaHtBgaaacaa
+ccctcMctcaaatctMWttggttttacttagcRtttacatRtccBttVcatgaaBacaYg
+agHttatWDtcctSatRtYggHtNMttRgNtgcatcacgacagaHgtYaSaactgaaNWV
+agtagttagaNgatctgcatWYaDacataHtaWttaatHaDgactYgttcaSVtttacct
+aatttaDgRcagacaDtgcYVttaagaSSKBYtgHtDtNtcgtcWttDtgtcNtgacKag
+cactccDMacDNcccctWataRKcaaatttctRVaacagcaMtataaattWBctttgKgV
+catttaVgtDgtatHtgtaSctagtatagcBtBtgtatgtcgcMcgagttctacgaaBgW
+ccgaWatgcaRtWtaagYttaNtcWaHtgattYDatWRgRWagtRcHggNatNttWaaac
+aSgcaatMatgacNgggaSatgatttcBHcctaaggWactacagaaaagctMcaaagaYt
+HVgtaaHKgKattVaWtttcctaWgaKattatgMaattBgaaagtgaSaaaWtSNBtttY
+ataVgNatgaSgcBaaccatattcctctagRtattatctttctMtgaRtctcYgaatDtR
+cHgcRVtWtaacDtcacYatRcttNgcgaDtVctWtacHtatatgtatKaaggtaNcata
+KRaataacacDctcctWgtSaWcatcDgatatBtaatHSNBtcaataaStHtacttaYaD
+aMtaagMtgNaaaaNccccgYWHaatgcBcttaBcgtMBKggccaVgacaWgaaaaaVYc
+RKctMgcaccWctcSacttcVtacgaagtYtcctttttaYgttattaataactSttRggt
+cVgagWRStatKataYcaatNMtacttcgcttVBaYRaKttaaYatacagctBgagcttc
+HcaatBaaaVcgctcacaMgttaHaggctaDtSgatattggggBgRMagtaattggattg
+YYHtVtcttSRYaacttataBtNKgatVaWSDWacatVcttgttgaagScaDaSttcact
+aattagatKttaMcHtMgKccaYatKataMcKNgattgtYtaaRHHcaWagctgtgcYat
+MHaatRDgtgttYctatNKtSDtaKgcBttgagtKtacatgaaggcgMatDaWtcBatag
+taaaatNYtSVgVatttcaNgRtaRaaNBttggaatVgaaaaagaaggtgNtttVBgcct
+tgtgaBtgMgtaaacBgtactWgtaacctatatggaSYattYtVgtttaagccaRtatRM
+cgWMgDVSNgataatBRccNagagStHttBgctaBagatattaacaagaggttttcDaRa
+gtcDgtHttcataagaacaKBttaBgactaRatgaaDYHttgVagcMcBDgYactWgSga
+cBataMMcttSaRHgcagKcgaaYaDgttcataYKcttcMWttattaaBacDcttDtttB
+catVggttVHtgtMgKcgaaVgtcgMaaHHYBMaHtaaKaDttaNgNtttttaggMcWtt
+NaaaDaaaaactRgaatagSVHtaataagttStccaatcHataatacMcattHtacaatt
+tctgatggacatatgcaaacaKBatgcagacagVcctccgcaacNatcMaHtcMtaSctg
+taYgtStcBtcatDacRggttRgagaaHatVcttYWgaDtatgYcaBKgtSWVYtttctW
+ttHtctaYttttaBtcataaNgtBRaNcgttKgtgVKgggVtWatcWagttSttttttaM
+aRWtccgttttattaHatttBVtataSctRWtgcMacaattaStBcacggaatRatactV
+gaagMaaagWacaMgctaacaHctHtaatacacgaYagtcttKagcDttaKBHccgtaHa
+acaKVtcMKcaataaaNaggttSaatcatgaNaaBtacggBcaagatcRgttttHaNgtK
+ctYatBHHtaaaDNHtaVtVagttVacKtcYgcattcatacaaagtaacKaKKtaaNtNa
+taaNaaSaBtagaattctgacacNtaHtataBDttBctataatagYSctgtaHcgccgaM
+BaggttaMHtKgttactaaHaacgDatataaagcaWtgaMtttgVatcKaattcgHVNat
+NgDaaYtataHacaaacaagagtatatDStgcNgcRtaaWVVaDStNgtcaaacgDttaa
+ggNttWcaVNaccctgaaaMcagVYVaMtBgtatacSacgSgNtaaaDtRaBSaWcNacg
+YaggtcaYtattagVStaccgatgSStMattctWtattHtHaDtatgYaatattgtttta
+NggttVatcttRcgaNtHaVaStgaagactcacaaatcactgataaKBtNHtttctWWta
+ttgactacNtaWatataaaBaatBttgggtatYtttYtgttttVttgagtcVaMVgaatN
+taaNgKMaacgtaatattKWggcagtgRttgtgacactaaYacactggaaKaWYRgcatg
+cgttctBcttggtVaaWgtttHagtcaatctcggaNWtaatBNcaMVKStaNcMtgatat
+aatDYMctttcgcatgcYtHtVNgStggagcBtggMgccctgtgNtVatactgcctcHca
+taDBtaStgNcagaYttaMtcaYtgtagatDaagaHaaaRcRataattcaDtcaDgttgt
+atRaaaaYaRgtttDBgDcgaagcNttgcVttcacttaMgtMWaYaattcggaDcgaVtY
+attaBYaaaattaHVttttWaacDttaRaSWactcBgaRctacaVStBaaatRgaacMSa
+agaatagYtNctcaatagctNttaVtgctgtttgYcttaatgtgMaStactgDBagVSgg
+tSKMYttDatgtMaaSaVtccSRMgaaaactHaatWWtcatttctDgcMcggVtgtRtca
+tctttNatcaatatYaKaaaatKWtDDDaaactaagtacRHtcKttacaataggttWctt
+ataSaYctgctVtaaVggatcctaHVttgWtgHtWttaDHaNgaccctatatgcWtNtta
+cctaYtttDWtttaggHNgccatattacKggattVatatcRcggRWMtgcaVRaaHgtaa
+taattttaggtctcDccaatatgSaaaagatDtaaVtYgNaHBtcaYttaaaaacagata
+taaagttaaaDWccMHMattggtaaagtccgaKtatDKaVHaBagaBatactataVttDt
+tDaMagctctaaDSggtttgaDacacVatcttNtgatKtVaBStatgNtgDKYcaatcat
+aWtcNatYccgRtcgBHacaBaatagaVtagcttgaKagcgHtttDNtgaagMttStttt
+gDDKRWtagtaBgtgagtgBcaDtWtaHcctatHatttgttWgagcggDtgtRDRcaaat
+agcacacRtDgtgVaWtaattRacVataBWacSYWVctgYtWDaVtaKataaacttKaaa
+MVHaaaaKNtaaacttgVataaaatMaaatMaagtatcaaRtatSYRtBtaataattgtt
+tgaWtaNNtctcaatNaataaaaaaattgaaaattattgtgttaaYatccccHtaNcatt
+cacttttaMgVDtaDMtcaWSgYWcSYtSgaatHtgctagaVattaBtaaaYgatattcg
+aaBtgaaDacacatRaagcgggagggDMtatDttaatttggaKSNtactRMttactgtBg
+gcgtcatNttctattaVacgttccKtVttMacttWtctaYcacgtaVtaaRgKcttggat
+SYatattttgttacaaMgtgagagaSatattWcagDttggNtNaaYtaggaaKtYHcttg
+KattWagNgtaagHHVatYatcattaaaaaYtHgttcaaaataattatBgcaKWKtagaa
+tagtatBagaaMtattMagaMtHcWgYcacgttagtgtDNggctatNatRcYYHtaacMa
+SStattRagRcgataaaatWNNatgaaatttVtKcRtKtDtaaMcctccaDRcaHtBSWc
+YtaKttcacaaMaataaMaactccgSgtYattDtaWctagatBtaatSgatgatHKgttg
+caaaaagaScHtgaaHRDatSagatcBcggcatcatYVaatgMaatStgNgWaaaaMttg
+cYaaagttSHaYgaaatHattBgtaaMRagSaSacBaagtttttcatgttaaYcagYtgK
+tYctaStcaagcgtaVattaNatWtHgtHKNDtcNaKaVaStSacaaStttagaaataat
+gcDSatgtaKtgMMtcaaagtNattacMYgtgctNgVcaaNcDtaaaVtYggtaaaactg
+caagaWNcaaacctDSaaSgVaKtctcatataMtggBtaRttKtagRcctgttaHgWRaa
+ttgDaaatttHtaccagctcagaccKaaBctaagtatWtaVagBgtttatgaHaaggatt
+StaactWacKDVtMHccgtacaMWYctDtagatttRctaccRagtWcWgaaaaMcagttc
+tgacSctaaaactgaatcacaNcaMWtWccYgtttNaatttggttaaNtggttSattttc
+aacgYVccMtcgaactBtatcYttcYDVMttcgattaKWtatttagcaatatcagWatgc
+RVaatgRtacWaVVBttggatRtaNgRagttDYataacDVBcaaactttgtttgaccata
+gHMtRctaWcgacagtgcVcaaVgRgtaagtRaaaattSBKacBaatcagaatgtHattc
+aVRtatVSSaKatNataWRVaaagMaacataDgataWHatcNYcMtatttggaSatttcH
+cgacaYcaKaaatattacHcSaBVatHacactaMDataaaggcacaacaSacctgtaaRg
+tcccaaaatWtDtagtcaagNtttgatDacDgcagaDcWgatDaaKagctDWtttatatW
+gDcaaaWttStDtKtatSagVgaaKtaacgaccgMgaSaatRRcagYtgttNDggcHSca
+aYDWtcaacgtaHgaStKtgMtRtaatccagtDaaacHgtacaaccHtagataNaattat
+cVtgaKaaNaaaaaaaagttgMgtcRaNaacagtaKcaBgtttgaMDgDMacttattatg
+aDgagcgtcacaaRaagtYaggMtaaactagaacagVaMWataggtatHagtttaaHtca
+gtaaatgRgcatgRctgaMttBaaataagWVtcHctgtgtYaaaaVtKtaSaaBatMttt
+gttatattattcaaBYctBWtggatBtgaggDagtgcacVataRBctaBaaaataatttt
+tNggtccgtVaaaaataaattBHaatBaagaHgttaagcctaatcaaatgaYtKaatYta
+aggtMgaRggtWgggNactaacgaRaaattSttWtaataaVtHgtacttNtaagHaSacg
+WggaYggNStcctgacgDcgHggtttHggtNtMtttDatNDgtgacgtatacgatKatat
+aaacaattSaaagcagatKtttSagcaaMttttgaKtMtagtcRacctKSttBttaatMt
+gcgttacaaagaVaataattcaSaaWcBVacYKtacaNBaaKRtRtcgWtWBaRKVtYWW
+WgattgBctaaatKaattaYtMtSBMBHDtBtaggDtcNctWYagtgSaaBaVtcttNgt
+cgttHtgtMtctatKtatVggKaSaagtttattttatgtactactHtHttSMactatHca
+agaattVataaaMKNtaMccgtgatDaHcaacttRataacaNgaatcSBtatgacBcctc
+gggtaatWaaWtacacaattctRVgattctatgtgtatHagatagggacVaattttDtNa
+WKagtatatHtagacgaggtatgtcagtgagHccccaatNataKMBaHtcWgctagtgHa
+atBatSataDatatcacccaagattttcSatKgatWtgaagtcBMataaHaaMaattatg
+cttWWtttcgVKYNBattggtacttcaaMaVNcctcHatcgctVcttKatgtctctBMgg
+acatcaggacSgaKttgagtctKVYaaagtaaSgaaaHaWactgRattaaBttVaHtgga
+ttagRWtaaDaaatgatttSMBWMaDactScgRYtgaVagNctgtSBataKacStHRatc
+tVgBKaggccaRctaacttcYKtcaDcttgaaacBBataatacYMgWgctgtacttttat
+gaSaaatYcccgattattRStccaaaBagaacaaaVtttgcttatagaaacacScccSaN
+taaaaBgtaaggcDgtSttRatMYSWatcgtaacgtStBagttaVaaaScccSggaMDBS
+gcaaKaggatatacgtatgcWactccgVctNttMaYtaaatKaaatgKStaaaHaKatat
+gBtcctatgtVaBggaatBcgcaatgagtatHcYagctDgtWaaccagtatWWtaRtKag
+atagtgKatatgaaaggcaWgtNKaaagataWaatHaaaaaKMaaatttBtatHtctNac
+tKtBVVagtatcacgtMgtgttaKtaatcgaaMHtYKNcMaatgcaSaaDBaaaaagaWa
+DtWMgaacatttDcatttaBaBtDttaaSMtcagcttttRWWaataattcNctactWaat
+NaBaattaagaaacttYRHaccatatKtaKcNVgttYagttBtaaaaVtctcgVctagct
+cgSVatatagVtMcaaHRctaHStttNtcattRaatgtaRtgttaatYtaagcattgaat
+ttaKtctaKKgaaggtcgMctttcWaagcgWaKcttcYttgtgaRaagMtDatgWgYaat
+aKaatSWScatKBtYgtaagagaVcacgctHStaacaSgBtgtaNRYaaWtWcKgaccDt
+gaWtgagMaYgVVgBaRacYtcKgatcagttgtaKcgttgagNaStctggaatVtactaS
+NtaaagtaatcaattaaVaaDattHDBaHKDHctVggcaaacccKMaatVtgttacBcct
+StgBgMtScgaaHcatgctMtStaVttttcDaNagtDVaatYcggaDaYtaactaNgtcc
+aattSacaaaaRgtagaaKgtcRSNtgatBacccttMtactatKgtaaRMagataMatgV
+tVKagaRagtcagMgMaatRHNttagaagaatgggaatcHtttttSgtNgYatgtgcYta
+atgDctMaaaMccVScgcRgKNaaagtaMtacaKaMNaBatagBttttcttttYatataN
+aWcagatttgMtgaaacaBYtHaaatgtaDactatttNatttKttSattgBatSRtgKHt
+tacgattgcggtaaaaacHHtaNgMcgHaVDtgtagaagatBaaagDttaacSatttaat
+ttaccagatataattggVgaRctRtcgccVatRNtDgcagBcVaHtBaatDttatgKRKa
+gataaRgcagtaKgagttatatcaMSagttccRcttaaatgatcttataaacaaatttcc
+cttaBaWtagtagttMaacMaKaaaagHatYKactttRatgtctcgattBcSagaDKttt
+HtBaccttNttVttVVtggttacgtaaBMRgatcgtctacaaNBtaVggttYaaggattc
+caNgRgtagBtgtaBacaagtataaatBaaatKRtaMtKHgatcgYggDSgKRaSttHSt
+catgtatatWacacRacHcatYtttaacYatatgtgttNtgcSagDHgataYttNattat
+cVattcaaYttggtaRHtWtcgaBacgtttaBaccaBaatgtcgcNagaNtKtaDtgDta
+tgDaBtcKgtBgatacNaccDDatttYtKggMtYNtaactgVacattaaHgMttatcgtH
+MNtataBtKSgccaVttaBcttattcBaagtgaWtaRtcctDVRatgaattgatatgaWg
+ccacDaatKaHtttacatNttaWNWgtacaggctacttBaYaaatatacaaaatttcgNH
+gMgttHctcKYcttgMtaacBaDVtaatttacagaRttttttagcKagtKactatMRtgt
+DtaattccRcaaKSttagttttBtctatagaKaVttttgcNagtKVccttagRgWaNaKW
+ttataDgcgaatgMKatgatRcYtctgVagaccgcgVgactagaWaaHNtcRNRKaatac
+tcYaNtSDKtcVVggNgDagtttaaKRgttaDcgtNNgtcaYttggtttYtatgtaaagg
+attttagatattKMcatgYaaatcaVactcagagtRYtgtaactatagtBaDtVaWatDa
+tctataaaSgggtactaYaKKWagaaaaataaattatagRcaaaVataVagatatgtagg
+cWagacRWattctgacgcDtaBcYattgtaDggMatgagcgagaggctaaatVtctcagR
+agDtSgKNcgtVcStacatttagNtgatSNgatcYVtHattHtBgMacRaattaHBacRc
+NaaccctVaaYaattcVccatacKcttSagtctgKMNagRaNcatNgcgHattStSKYRg
+gtcagtcaccattttagtMaccctggVattHaatVagaaMaattaVacatacacaaatta
+attacgtKtagaaaMgatWgWccatYtagacKatctKatMcggYcgcatgHRtcStVtaa
+tHgSaaaVagtgaatgtgYtattaYcRagatgatcataacacSgaYaactMKttatRcga
+ataaMSatacNgaMatttcggccacgaYYMcaKattRagDtRtatMVBtaattWtMHgNa
+WDgStaaSNggStcBcVYtaYagaHtacagttccMcgtYtYttcattgSWcttagttcgt
+HtgVRYgaMacttBtatcaactaaaaVtDgataaDgtatcatYDttaStgccBacctaaB
+agttgRtaSBtaaaagWgcacBggttagcMaYatttBgtaggtRBaSagttcacgtaDaY
+aaaacDSaKattctgtSatatgtatggVBcctctgtgaaHDKgttaRttttBMHgRMgHa
+gtagMgacgaagttaatattgRtHtHttatYaaagcagatgtgattagtggcactactVa
+ttagatctctgtttatcattYttgatHcHttagStgatgactctDaaatcagtgttgttt
+ttcYaaagtatatcYcaSaacaVttcgWtatKaaaHWtRgtttaKacttctgaaNaYacc
+tNtcStatttaaagttKgtgatcctBcaBtctttaaaKagttgDtWctDtgtgctataKa
+gtaNHatctagYgatcMgtggYaagactgacacttaRaaccHgttcaYtagWtggtgBcS
+tacaMcMHataaaNagatactccaggagttaatcatRttttgaKNgSgcaggtgttRaYc
+aaataBtaDtatHgBtatacKaataKtaggaaatatgcataaHgaKttttatMaaaNgMa
+tYattgaatNtatVaggtKctttHattcatttatYtattagtataYtttagYcattagaa
+ataHtaaccttactcatYttHMRagttctDagNSVgcgVaNNattctVcaaVagaattta
+agaggttttacRagtagtaaaBaBaaMtaScKgVaRcNtctgtataagtatVgtDgHaYt
+tcHYttaagatRgtgaattctYaaaattRtcWtacDDaRatcaKtaSacaagctaNttRY
+agMSDKtWgWaYNgaaaatatNtaatatHMtMWRaRacaaaatgctgctacNKaKtagtt
+gVatDaVccatSDtgaSggcgWatccBgaaVtgtaWttagatVaBWtacgWtaYattaaa
+tMctDgDaaKatttgaaatgctWctttaHtggHaBBSRVBWtgattgagatccNcaaaHt
+>THREE Homo sapiens frequency
+gcactagtattgtcgggatcccattaacaggctcaaccacgagctcacgcgaggacatgt
+agtccgtatctttaacgaagcgacagcgacagaactcccatggataaccaattataaggc
+ccgtaatcctctagacatcgtttaccaataaatccgctttctccgtaatcatgttgaata
+ccccagagtagtccagatgataaccgatgaaacacaagtctttctcaatgcacttacggt
+gaacttattaccgccaacgtagctcatcaaggttgcgacatctagttgtgtgtttgcgac
+gagcccagcgaacttcatcaactttcgtatattcaacgccttgtaattttactttaagac
+gcctggtgatgtagattcttagataatcagtttgttatcggctgtactttaccataattt
+cacaggtttcaggtcaagaagattatagctgtatatacagttccatgctcggtgcacaga
+aacgtgatcggataataatcaatcgcttatgtcgtctttaggcgtatccaatacatgccc
+cgataccgcagtgtatttcgacatgtaggtataccgtcgcatttgagctcgagtcaggac
+gtcagctagattagattccttaatagaatataccgacctctagtccgaactaaactatag
+ataacgccaacttcaggttaattgtctagtcgtctgtttgcagatgggattcttagatga
+gtgagtatcggccatattggttcgagcactttagtttttgatgcataggatatgcaatgt
+atagctgaaagtactttatctgtttcaaactcacattgattaaaccggtaaacctttaaa
+gactacaagaaaatattcagtgagggcaattttgtcaatcacaatcttccagctagagat
+acttcacaatttgtcttgaggctacgcaacattagacggattttcgcgttttattgaaat
+aatcgaggggcccaagagtatccatagttcattttgtaagatttctttacaggcttatta
+cagcttcttcagactcctacatgcttacgagttatatgctagcatgtgaacaatagatta
+atatacaggaaaacgtacattgagagagatgaccctacacagcgcaaccgttgagtactt
+tcattaaagggtaacgctctcgagacagcatccttaagatggccttattgtcaaatcatt
+tgcagaagtacgcaagatccctaaccaacgtagaagaatccctacaaacacatgagacgc
+ggtgaaaatagacagggtgttagtattcaatcttcggagtatcaatttcgccaatcttgg
+tgagaaagcataccctttcttcagagaaagaagatcaatcataacactatctttaacgag
+gtacgcacgcgcatcattacctgcctccatggatctttaggatagcggaaagtattggca
+gcgtattgtgatttcgttcctactttatcaatttcacattcatatacatgtcttttatca
+aaatcgccaataagataggatgagctatattagatgctagtagagttcgcgccaacatca
+tcgataggaatactcaggacagcgtgataggacttttcaatccctaatactctctataat
+tataactctctcttaagtttggaggcagtaacgcgctctatataatcagtttgctgcacc
+attcttcagcctctgatacatacaaataaattccacagcagtaagagggtttaattgaga
+catcttgggaacttaggattttactctaacatcaccgaaacgattattggataccgtacc
+taaacgaactttctcaaggcagtaatataggacatccgcaataacacaaatgctgcctcc
+ccaggagttatgtcttcctggaggctatatcttacacccactcactataggcaaactaaa
+gtttaaatgttgattgtctaaaaaaaagatagataagagttggccggcgtagcacatgcg
+aaagtgaatcgtaagctataattctctggacttgaagttctgtcctgttcctctgcaaga
+aacaaacttcctttaaagctatttacgacgcacatctcagcaagttataaacatgttgga
+agtttctagtcggaattcccaaagaacggatctatctaatgcattcctacatttttcctg
+tctgccgatggtgccatcctattcaaagaatttcttaaaagtagattaaatgggactttt
+aacaatgagtaaccttacgcctctaagggttcctcgagtgccatacaccagtcaggtccg
+agccacatacacggagaacattctaacatagcattctcaactcgatcatttgcaggttac
+ttctttcctatcctagtgctaaaaatcatacttgcaatcccatagcacggattaagaacc
+taagaaacaattcagtaaaacatgttcgaattcttggtatgggaacatcattgcagctat
+ggtctaacgcattaatgtttgggtacatcttccatcatataaacaggaagagtctgacga
+cagggagtgcttgcgatcatgtctatcattgtgaaatcaaattgtagctcacatgtcgtc
+tatgagagcgtgtatccgataagatttagaaaaatagaagtcgtataagatctcactgaa
+cttttgaatgaatgtgaagcatatatgatctgctttaataaaactttatccataggatac
+gtttccaaatcaattcaataattattagtcaaaatagataaggatgaacaacctgaaggc
+cgatcggacgtagaaagtggtcccatcactttgagttgatattgttgaaccacacgttat
+tatggttttcaaacagtctcaggatattgtatatacagataatccgataccagttgtctg
+acgcccctcttacgtaccccaccctttgtgacgtttaaagcagttgttcagtattttaaa
+ctaggcggcaactaatttggaaagaagcacagtggatatgtctaaattcttgttattcag
+gcctgaatttaatacaccgcatagttaacttcgcggtagagttgttcatcatgcctcctc
+taagctaccacttctatgatacaccaatagttgttctacggaatctgataattggccaag
+tcataaacttccgctgcgttcaacccccttgctcgaatatccaactcgaaaagacagcct
+tttggtgtccggaacaaatcagttacttcttttctgatgttaattctctgtggtcagata
+cagaccaaaaactccgcggatttaccatcctccaagaacaaatttgcatcaacatagcat
+tttggctacatattctaagtctcaatagtttaggttttcaactacattatcccaacatta
+ggattggaggaataatagctgggtaagtccccttgcgtctacaatcgactattttttatg
+aatatgcttctgccgcacctatggttattaaaaaagtcatgactttgaagaaccctgaaa
+agatagatgaatcaggtgtaatggcagcagccaaagagcatataattagcaacactctaa
+gaacattatagatatgatgatagcgatcgtcatgatgttatccggtcacaatagtagctt
+catcagctaattcgttttgccagtggtgacttgcgctggaagaatcgttatacggtccct
+tccctcttgatacggtgggggcttattcaaccgcgtggattgggttgtcatacttgcatt
+aaacgatgtaaaccatctagtagtcaactatactaaatcacaaaatagtgatcaatacat
+acccgcttcatggttttaaccatttaattgattaaagatattccgctaagaaccattatc
+tacctaaactgatcgccgtatcctagtagtttgaaatttgatgtaccgtaatgatcaacg
+aagtaaaacgttatattgtatgtagaataataggtcttggagctaaatgatgtgattggt
+agtgaagacttacccttacaactttaccggtttctcggaagaatatactagagaatcaat
+gcatgggctacataagcactttagtctaatgagataaaaaatacacgagtcttccatcat
+gaattttttgtcgaaaaactcgaacctggtaatttaaaccatatatctttatgtcgtcaa
+taactctcatatgttttatataacttcccaatcacgacttgtaactgcttgttcgactga
+gctgtttgagctatgaggccgggatccggttgagctacatctatttgctacaagaaaaat
+gaaagcacatttgttgggagttctggctacactcatagagaaataagtggcccgagtggg
+tgcggcctgcctccatattcaagtgtatcttaaaccaagtggttccaacgctcgcgctaa
+agaattaaagcctttatttcctccacggagtagcccgtaatccggttcgaaagagaccat
+tgaagttaattttcatatccagtgaagtttaggcacaagcatgtgttctgccacatgcct
+caaagcgctcttcaaccaagatatgattcatcctaacttcgatgaatgcgtctgtaacat
+aaatatagaaggaatgattcggcgagttaattttcgccttctccaacatggcatccctac
+gttcgttataaggaccatacatgtaggttttaaaggtttgcggttaatcgatatttacat
+catagaaattctatagtcaaatttacaagactctagatactcactcgttgcagccggcta
+ggaagcgctttgtaccttacttcccttttcgttgcgtaatatgaatttcatatagtaagt
+tcaaggcactcatacctccgtgaagagggtagatagactattaaagttgtttaatagtac
+gtattgatggaaatgacccgtaggagatttaccactcaatccacaagattcgctgctgtg
+cattatcaaaacagtgcatgtcgaaacatgggttgggtccttcaaacacgaatccaggta
+gagatacctttgcaatttttcgatgaaggcgaccgagataaatgagctataacactgtat
+gtcttttgattgctataaaacacagaaacggatattaatttaggccgtaaccaacatctg
+ttatttgacatagaacagatggtcctttacagcgtattccggccttaatattgaggtcca
+gtgtattgtcctcctttaaagaagttgattgtaactgacttaaataagacatgtcaccca
+ttcactgggttgcaactgctggccctttttgtccatcgcacgctaatgtgataacagtac
+cgccctcacacctgcgtttaaaagacataaatgtcgctatgaaggttattcattaatttt
+agctgttttcttagaaaaggtaaatttaaaattgaaaaggctagaaaactaaagttacga
+caaatgtgtttgtcaagtaggcgggcatcattgagattgtaagaaataaagccataacca
+gccccggaatagaaaatgttaaggaaaggcgatcttctttgaattcttattgtcaagtgc
+agtcatacgttcttatcagaggacattgcaataaaatctaacaccctcccttgtgtggtt
+gggccatttgtacttcgaagcgtccaccatgtgcagaggataacggaatgtggttccgtc
+ccataaacgatcattctcgcccacttagtggcgcggtaaatcgctctcatagaggtaact
+ggcctgtaatgtccaatgttaggctaccttctccaactttagtacaacgaataatgtccg
+attaacaaggagtcaatttgtcatgaccagttcattcaggtacttgtatctatacggacg
+cgttccagagtagtatttgaaattttgaggttctactgataagtttagctatcgctgtat
+gtctgaataagaatttaatgtttatcttcgataaataacaattaacaactcctaggtgat
+acactgtgaagtctgctgttccccaaattacatatgctattttgttcacataccatgaag
+ttaagctaagtgctctataatggcataaacggttatcaaactagctcgaatttcttttat
+tacgccggaagcggattaactgctgtagatcaaacacgttaggatagtgtcgttttcata
+tatatctaaattcggtctaacatgcattacccatgcttgataacgtagcacttcgcagtc
+taattatgtaatgtccgtttaaccaaactttaaaaaagtttatctatcaccagtgatgcc
+tcatcgtgactacccggatctttagcctttagggtctaaacagaactaatattactacgt
+gtcatactccggagcttaaccaggtgaaacttatttgttaaccaaatttagtgacagggt
+agaaatacgtatcaaattaacccagcaatacaataagcatgaaaataattgtaatcgggt
+ttgggccggaatcccgcttggcgaaaacttaatgacatagtgtgatgcattttgcactgg
+attgagccacaaactcaactagcattatgctcaatatttggccagtgttctacggtttga
+aatttataaaggccgcgcaaaagtcttgtagttacaaacgcataaatctcgaacgtaata
+ggtttaattagaacatccgtaggatttctgtttatagtagatttatactaaatgttctga
+ttagattctgacggccttacccatacaattaataaagacgaatatattagttatagttta
+ctatccaaataaattaagcgaatcgaaataaactgtcacgatactgggcagttatcaact
+tatcacttatacagttcggacactctatattggtctgtgagtactctatcaaactaactc
+ataagttaactgcgcttccattaaatttcaatacgttcttgtgctgtgtacaaacctata
+atcgaataaatgacacatatggagatgcataataaaaaaaacggctccatatttctcgtt
+aatcgggcattcttaaggaggagcatctcaccaaaaataacgttcctgataagtcttaac
+tattagaccgtcttcgggaatgaacgaaacctcaagctagcatggtatagttcttgatag
+cgcgtaaattctgataatactgggcggacagctggaaattagttgccagtgcacctacgc
+aaatagtttacataaatcaacgggctccgaacgtaaatacaaagggttagttacatcgca
+acaagatgaaaagcatgtatgtctaccgtcatccgtccctaacaaacataaaggtggtga
+agaatctcgtaggtcaactataactccatccttgaagcaactactccgcgtccgtgtgcg
+tagttcgcaacgagaacactactgaaaaaagctaaacaactctcggtacaaatgcggctt
+gtgtcgataaagttggtggtagtgcacggaataacataacaaggaatattatttattcaa
+attttttgtgactgttatttgttttctgcctagaatgtaaggatgtgttttttgtgacct
+gatagttacgcttatttcaggtccacggtgcgtgagagtgtgtcctataacggcagggga
+gcgaagtagtgtcctttagactattcaaggtagaattttgataacgctctataaaaggta
+gaaaatcatgattgagcaataagaccccaacttatcaaaaaaggagttctcgacagcgcg
+tgtacagtccctataacggctgtatttcctgtgtcacaacaccctcccatcgcactcaaa
+atgtagatttatgatcagacgctaacttgttcttagagaaaaatacacgggatactctgt
+gcaacgatttcattaataaggtgcagcttgggacttttttggccgtaggctttattaaca
+ttcacagtaggtagcgagacttcctatgaaccaatcatgccacgcgttttaacgtttcaa
+atataagctaggaagcgtttgccaggacttctataatgcaccgttttttttagtacttcc
+ttactagccttagtttatgttagagtctttccaattacaaaggattgaatagccaaaatt
+tctacaattctcagcgaacgccagcttaatctaaacacgagcttcaaatattctacatat
+cggcaggagtcaatatataaatatgaaaatcgtaccatcctcgtacttttagaccaaacg
+tcttcggataattaaatcctttttcaattaccacagtacgtgcattagaactactgctat
+gaaagtaaaccttgaaatatagtcctcaagagcgtatccaagtacattgcacgtgtatac
+agtcgtataaacgagttgatgttctgacgctagagcttaccattcgttaaacagataact
+aaaatttaatggctgagtgacttagtgttttcgacaaacgtcgcggatgtagactattgt
+ttataagcaatttttaaaaacatatgttcaaaacggtatgggatatgtcgaattccacag
+gggtttatgtaccatagaagtatgtataaggtactaaaggtttaaatctgtgatattcgg
+ttcggtgaaaatcagactagtcacacttagtgtctgtaaattagattgggtgaaggtaag
+cgatcccgaactctacaaggcatgggatgagattctaccgactccggataacactttacg
+atcgcgcataactctagctcttagataagtttaacttgtcgatctcataaacagttcaaa
+atctgcgatttattgtatcaaatccatcctctatcttctataatcatctgaaccgcgata
+cggcactatgagccaagtgaagattgaatccaagaaagctataattggtttattttagtc
+catttaaattaagtccggtataagtgctctgtacaatatgcagtctcatgggcatatacg
+ttaactaccttttgatacttcgaattggtaaaatatcgactatcgatttgcagtaaaagg
+tgtagagtccaattactctttcctgttacatacgatctcttagtttggacaactagccca
+tgatggcgctcctctagcgcatgaacctactttataattacatctttatcgatgaatttt
+tttagactgcggaggccttgagttttaacagggctgctaaatttcttaagcgattagacg
+gtagcgtcgtacgctacttgcttggaacaggcaccgaaaatattgatctactattgcgtc
+aactctattctgctaatagcgatggcaaatcacagaagccctcttagtgacaatagttgt
+caactatatctaagtcgacctttactgtatcaacgatcacggagagaattaccgaatacg
+aaacctcaggactaaaaaacggaaaggatttgtcgacggtaaatataatacttgttaagg
+gtagcgacacaggtatactttgggtgtaaacgtggtgcttcccggaacgattttcagacc
+agaaaattgttccggtaaccaggaaatctcgtctgcgttaattcgtgttagtaaacttga
+tcttcagactccttcttttcgttgcagcgagacttaaattatatctgcgaaatagtgccc
+cgtgcatacttcagatggtaggagataccatttggcccattgtgactttacgcgattaat
+taaccgacatacatctgttcctgagctatgatcgtctgaataaattacggtctcctcttg
+atacctaatggtttctggagacgtttctcatgttcaaatggatagcaggagatcgcttca
+tcaagtttagctacgcagagcatcaaaatatgtatgggaaagtcgatttccaaaccagaa
+gggataaagagaaataacggacttctccgtagattagcctgatattttgatgggaatcat
+ggcggcacatacgtaagagttgcgtgaacgaatattttggacggcgggagacacatatcg
+gccattcgttaaggtctctatattggacatcacaagcttagcagtatgagctactaacac
+tcaagacattattgattttttcaagatatgtttcattcctctaccgctattcccatacgt
+tcgattcgccgggtgagcgaaaccacgggactgaggttaagctaatcaataacaactcgt
+tgcgatagagacctatgtatactagagagaattccccaacatttttacaaaaacaaagca
+gactaaaatagatacagtccctccatacaattaggaccaacatgttattgccgatcctag
+cacacacaccacaaactcagaacttctgtcttacctatgaaagggtctgcacttctgatt
+gtacgtgtctaattagcattaatattaaaactaattaggataaactataggtacgagctt
+tactataagtcactaggtgttttccgatcgaaaaacgggaccttcaagccttggtaagta
+catttaggataaagaaaaaaaggaaggtacgtgactaatctgtctaaactgacaatagag
+tagtacctacatgcttcatgtcaagtcttaatacgcaagcgctctcgttatactgctcaa
+caaaactcataaagttggactccatcatttagaatcatagggaccaaaacatttatttgc
+tactgtcactttgtaggtgttctattctgaattcctcatattgatacatgaatcggaata
+cctgtggatcccttaggacgcacgtgctttctttacgtcagaatacatattgtcagaatc
+gagaagttccatgcaattaagaattcgcctctttgaaaactcatatccccacatataggg
+tccaccgttattcggaaacgatataataattattccagcgttgagcgtcccttaagagcg
+cattttcgcttggcctttcttctacgactctacaacgcaagtggctgtgtggagtttacc
+acagcgcagcaccccatagaactacctctgagagcgcgagatggtggcagtatgctctgc
+agctagcgtttagaacgcgcccgcgcattaaccagtcatattaaaatggactgtcttaat
+tgtcggcattaggagcaatattaactgatgagggtatcggtcgcagaagtaatgacggaa
+atacgcctctagtccgcagagatacgattacagactcagatcccctaacaagcaaaacga
+ttaaatcggaatcactccccctatgacatatttgaaatacacaagaaaccacgcaacatg
+tcccgcattctcaaccgcgctttataagatgttgagtctgagaattagatgacctaactg
+caagaatcatggcgagtttatctagtaggcaagtctgtaccctagggttcgaacgctgtg
+acgtcgtgatcggtctaaggacttagatgataaccaagaactggtttaccgagtactttc
+actattaggagtaattacatgcgttcaccgcggaatacgacgaaattttttcatatcttt
+atgagcgagatcgtgtcgtctttgcattgcaacagtcgctaccagtaattgctgatcaat
+tatagattcattatacagatgcttacttttctctattcaatactgtcatgagttgttttt
+aaataagcaccagaattatgtcgcctagtataatcttgcttccacttgaatcaatgcgat
+ggacagtattctactgattgcaaagtagtctatttcggcttagcagtacgcatgcctatt
+tttttgcaggcacagaataatatgcaactaggattctcggcatccaattaacaggctaaa
+acaccaccgaaagacaggtaatctacgaagttgatgtttactacagaaagcgaatgatat
+cacttggagaacattttagatgcccccttttaatctagactgagtgtaccaatatatcac
+cggtctaccgaatcagcttgaataaaccactctagtactcatgataaccgagcatacaca
+tgtatttctcaatgcactgaaggtgaactgtttacaccataccttgcgaatcaacgtggc
+gacttatacttctgtctttgagtacagcacaccctaatgaatctaagttagttgttgata
+cgaattgtaatttgactggatctcgcctcctcatctagattcttagagaagatgtttctt
+atagccggtactgtaactttattgatctggtttatggtaatcaacattttacctctattt
+aaacgtccttgcgccgtgcactcaatcctgatcggtttagattcaagcgattatcgagtc
+tggaggccgagaaaagaaatgcacagagtaagctctctattgcgacatctacgtagaaac
+tcgcatttcagatcgagtaagcaactctcattgtgttgattcagtaatacaagattacct
+acgcttctacgaaatatactatagatttagcctacgtcacctttagtgtcgagtcggagc
+tttgaagatcggatgcggtgtggactgtgtataggcaattttgctgcgagctcgtgactt
+ttggttgatgtcgatatcaatgggatacctcaaacgtctttatctctggataactcacat
+tgagtataccggtaaaaatttattctattcatctaaatagtcagtgagggctagggtcgc
+aatcacattaggccacatacacatacttaacatgttctattgacccgacccaactttagt
+agcattgtagccgtttatgcaaatatgccaggcgccaaacactagccagagggcattttg
+ttacatttatttaatcgattattacacagtcggaacacgcctacatgcgttcgacttatt
+tgcgacatggtcaacaattcagtaatttaatccaaaacctaaagtcagagacatgacact
+aaaatcacattaaggtcagttagtgaaggaatggctaaccagctagagaatgcatcatta
+acaggcacttattgtcaaatattttccagatctaagcaacatcacgttaaaaagtacaac
+aatcacttaaaacacatcagtccaggtgtaattagaaagccgcttagtaggcaagcgtag
+gagtataaatgtagacaatagtcgggacttagcagacactggatgcagtcatagaagatc
+ttgcataacacgttagggttagagctacgaacgcccatcattaactgcctaaagcgtgcg
+tgagcttagcgctaacttttccaacacgtttgtgatttcgttcataatgtatcaatttca
+cagtcatatacagggagtgtagaaaaatcgcaattaacatacgttgacctatttttgttc
+agagttcagttagagcctaatgattcgagagcaataatcaggacagcctcataggaagtg
+tcaatcacttagaagctatattattataaatcgctctttactgtcgtcgaaggaacgagc
+gagagagaatcagttgcctgcaactggcttaacaatatgatacataaaaatattttcatc
+accactaagacggtggaattcagacttattggcaacttaggatgggactattaaataacc
+cataagatgttgggataaagttacgaaacgaaagggatatagcctgttagataggaaatc
+cccaataaaacatagccggcctccacagcagtgatctattccgccacgcgatatctttat
+accacgcaatataccaataataaaggttaaatgtggttgcgatttaaaaaagatacatat
+cagttgcaccgcgtagcaaatccgtatgtgaagcgtaacctagaattatagcgtctgcaa
+gttctctaagcttcctctgcaagatacaatatgactttttagcttttttactaccaaatc
+tcagaatcttagaaacaggttggtacgtgctactcggaattcccaaagtaccctgctata
+tatgccattccttcattggtccgggctcaccatggggccatcatagtaatagaaggtagt
+aaaactagttgatttccgacttttaacaatcactatcctgacccagatatgggttccgac
+tggcccttactccagtaagggcagacacacagacaacgagaacttgataactttgaattc
+tcaaatcgatcattgcaacgtgacttatttactagcctactcctataattcatacgtcaa
+atacatttcaacggaggaagataataagtaaatattcactaaataatggtcgaaggagtc
+ctttgccaacataagtccacatatgcgctatagattttttcttggggttcatattcaata
+agataaacagcaagagtatcacgtcagcgagtcattgagatcttggctagcattgtgata
+gcatattctacctaaatggtagtctagcacagagtggataagatatcagttagatataga
+caagtactataacagatctcgcttcgttggattgtatggctagctttgatgatatgattt
+tataaaaattgatccagacctgacctggccaattatattcattttttatgagtaaaaata
+gataaccatgaaaatactcaagccccttaggacgtacaaagtggtaacataaatttcagg
+tgttattctgcaaccacacctgttttgggttttcaaaaaggctaagcagattggttttac
+agataatccctgaacactggtatctcccaacgatgtcgttcccaacccttgctgaccttt
+taagctctgctgaagttttgtaaactaggcggaaaatatgttcgatagatccactcgcct
+gaggtagaaattcgtcttagtaacgcctctttggattacacagaatagtgtactgacacg
+tacactgctgcagcagccatacgctaacattaaaattcgttgagtctacatttgttgtta
+ttcggattatgttattgggaatagtatttttattcccctgcgtgaaaccacatggataga
+ttagcctactcctaaagactcccttttggtctacggttcaattctcttactgagtttatg
+ttcgtaattatatcggcgcagtgaatctcctaattatcaccggagttaccagacgccatg
+aacttatggccagaaacattgcatgtggcctacataggattagtatcaagagtttacgtt
+tgcaacgacatttgaccaacttgaccattcctgcttgtagaccgcgggaactcccctgca
+cgcgactatagaagttggtggtggatgtggcttatgccgcaaatatggttttgaaaaaag
+taatctattgcttgatacctgaattgagacatgtataagggctattgccagatgaaaaac
+tgcatataaggtcaaacaatataagaacattatacataggatcttagcgttcctcaggat
+ggtatacgctataaagtctagcttcagcagctaaggagttttgccagtgcggacttccgc
+tggaagattaggtttaaccgccctgacatcttcataaggtcgggcctgattcaaacccct
+ggagtgccgtctcatacttgaattaatcgatggaaaacttcttctagtctaatattatta
+ttaacaaatgacggttcaataaataacaccgtaagggtgggaaactgttaagtgatgaat
+cattttaacctatcatccattagctacagataatgataccccgatccgactagggggtaa
+gtggttgttccgttaggataaaccatgtaaaacgttagagggtttgtagattaattggta
+ttccagataaatgaggtcagggcgagtgatcaattacactgaaaaattgtcagcttgcgc
+ggtagttgttaagacagtataaatgaaggggattcagaagcaagtttctcgattgactga
+atttataaaccagtcgtcaatcatgatttttgtgtcgattaaagcctaaatggtaattta
+aaccattgatatttatcgagtctataaatatctttggttgtatattacttcacaatcacc
+aattctaaatgattcttccactgtgcgggtggagatatcaggacgggttaaggttgacct
+acatcgttttgatacaacaaaaatcaaagcacatggctggggacttctcgatactatctt
+tgagatagtacgggcaagagtgggtgacgcctccctacattttcaagtctatcggataac
+ttctcggtaaaacgctcgcgatatagttttaaagcattgatttaatccacgcaggagcaa
+gttttaccggtcgaatgagaaaattcaacgtaagtgtcatatccagtcatggttagccaa
+aagcatgggttatccaaaaggaataaaacagctcttcaacaaagagatgaggcttcataa
+cttcgatgaatgcgtatggttctgatatatagatcgatgcatgaggacactttattttag
+ccggcgaattaatggaatccatacgttacttatttggacatgacttctaggtgtttttgc
+tgtcccgtttagcgatatttacagattagtatttcgtttctcatagttaattgtatctag
+atactaactcgttgaagacgcataccttgccatttgtacaggacttaactgttccgtgcg
+taatttgaatttcttataggttcttcaaggcacgaatacctcactcatgaccgttcatac
+tctagttaaggtcgggaatactacgtatgcagggaattgtaacctaggagatttacaact
+ctttaaacaagagtcgctgaggtccaggatcaaaacactgaatctcctaacttcgggtgc
+ctccgtaaatcacctagaaacctactcatacatttgcaattttgagatgtaggcgaaaga
+gagaaatctgctttttaacggtatctcttgggattccttttaaaaacacataacgatagt
+aatgtaccaagtaaccaaaagctgggatgtgtctgtgtactgatccgccgtgtcagagta
+gtccgccatgaatattgacgtcaaggctagtgtcatcaggtattgatgttcattgtaaat
+gaaggaatgaactaatgtcaccaagtaaagggggtgaaaatgctccccagggttctacag
+acatagagatggtcagaacacgacccccctctcaacgcagtgtatttgaaatatatggac
+atatctaccttattctgtaattttagatgtgttctgtgtataccgatattgataagtcaa
+taggcttgattacgtatcttaagacaaatctgtttcgcaagtaggaccgcatctttcaga
+ttgtttctttttatgccataacctgcccaggaattcaaaaggttatcgatacccgatatg
+ctgtgaattattattctaatggccactcattcctgcttatatctggaattggcatgaata
+tcttacaacctaaagtctggcgttgcgccagttctacttcgtaccggacaccatctccag
+tcgttaaccgaaggtgggtacgtcacataaaagttcattagaccacactttgtgccgacg
+tatatagatatattacacgtatagggaatgttttctcctaggtgacccgaccttctacta
+aggttgtacatcgtataatggcccattaactacgaggaaagtggtattgacctggtaatg
+cacgttcttcgatatataccgacgaggtaaagtctactattgcaaagtttgacgttatac
+tgataagtttagatttccctggatcgcgcatgaacaatgtatgcgttatctgccatatat
+aacatgttacaaatccttggggatactatcgctactatcatcggaccaaaattaaatagg
+ctagtgtcttatcagaacatcatgtttaccgaactgatctattttccaatttaagctgat
+attacgtccgcgtatttattttagttccccggatgacgattatctgagctacatcataca
+agttagcatactcgccggtgcattgatttcttatttcgctatatcttcaagttcacaggc
+ttcatatagttccaattagcagtataattaggttttgtaactttaaccatactttataaa
+aggttatattgcacaactgatcaagcatccgctataacccgagctttaccagttagcggc
+taataacaaataagatgacttcgtgtcatacgaccgtcatgatcatgctctaacttaggt
+gggaaccaaatttaggcaatgggtagtaataagtataaaatgataccacatatactataa
+caatgaaattatttgtaatccggtttgccaacgtatcccccttcgcgataaattaatgac
+atagggtcatccatgtgccaatcgtgtgtgccaaaatctcaaattcaattatcatcaata
+ttggccaagtgttataagcgttgaaagtgatataggccgccaaaaagtagtctacttaaa
+aaccaatatttatcgttcgttattgctggtagtacaacatcacgagcatttctcttttga
+gttgatttatactatatctgctgatgtgattatgtcccacttacccagaatattaagaaa
+gtcctagattgtaggtatacttgactataaatataatttaagactatacaaataatctgg
+ctacattatgccatcgtagaaactgataacgtagtaacgtcggacactagattttggtcg
+gggagtaatctagcatactaacgaatttgttaaatccgctgaaagtatatgtcattacct
+gcttggcctgtcttcaatacgtttagactattaaggactcatttcgagatccagtattaa
+ttatacgcatccatatttatactgaagacggattgagttaggacgacaagctaaacaaat
+attaagttaaggattagtattatattgtagaaactcgtcgggttggaacgattcatcatc
+atagaatgcgttacttattcagagagacttaattcggttatgactggcagctcacctgga
+aagtaggtgaaaggcaacagaagaatattgttgactgaattctacgggctacgaacgtaa
+ttacaaagcggttcgtaaagagcataaagatcaatacaatggatctctacagtattacgt
+aaataacatacataaacctggtgttgattcgactagctcatagattaatcattaattgaa
+gctacgaagacgcggaagtctgcggagtgagcaaacagtaatcgactgataaatgcttat
+aatatcgcgcttaaatgccgcatggtgtacattaacgtgggggtagtcaaaggaatatat
+ttactaggaatattagttatgcaaatgttgtgtcaatgtgatgtgttttatccagacatt
+ggatgcatggctgtgggggcacaggatacttaccattagttcacctacaagcggcgtgag
+agggtctcagttttagccagcgcagagaagtacgggcctttagacgattaatgctagaat
+tgtcataaacctcgtgaaaagctagttaataatcatggtgctagaagaacacaacttttc
+tataaaccagttctcgactgacagtcgtaactcactatatcgccgctttgtactgtcgca
+aaaaaacctcacatagaaagaaaaatctactgggtgcatcagtagagatcgtgttctgag
+agataaatacaccggatacgatctgcatcgagttcatgtattaggtcaagcttgggactg
+ttgtgccagtagcattttttaacagtcaaagtagggtgagacacgtcatatcataatata
+tgccatcgaggtttaaagtttatatgataagctagcatgcgttgcaatcgtattcttgaa
+tgctccgtggtttgtactaattcctttatagactgagtgtatcgtacactcggtacaatt
+acaaaggatggaagagcaaataggtcttcaattataacagtaccccaccttaatctaaaa
+accagcttcaattagtattaatttcgccaggagtatatatataaatatctaaagactaaa
+agactcgtacttttacaacttacgtcgtagcataattaaatcatgggtaaatgtcatcag
+taagtgcattagaaatactcctttgtaaggatacagtgaatgtgtctcagcaagtcagta
+gaaatggaaattcatactcgattaaggcctataaaactgttgttggtatctacagagtga
+ttaaaattagtgaatcagattacgaaaatgttttcccgctcgcacttacgcgtttagaca
+aaagtacaggtggtacaattggctgtagtagaattttggtataaaataggtgataaaccg
+gatgggtgtgggcgaattcaaaagcggtttttgttccatagaactatgtagttggttata
+aaggttgtaatctcggagattaggttagggcttaatcagaatagtaacaatttctctatg
+taaagtacagtgggtgatcgtatgagttcacgaactcttaatgccatgcctggacaggat
+aaacaatacgcatataacttgacgatcgagcttatatcgacctatttgagaagtttaacg
+ggtcgatataatatacaggtcttaatagccgattttttctagaaaagcaatcctatatct
+tagttaatcagatcaaccccgtgaacgatatatcagcaaactgaacattgtatacaacat
+tcctttttgtccgggtggggactccatttaaagtatctcacctagaactcagcggtaata
+gatgcagtctcttgcccagttacggtaactaaatgttgatacttagaattgctaaatttt
+agtctagacatttccaggtaaaccggtagacgacaatttctctgtcatctgtcataagat
+cgcttagtgtgctcaaattgcaattgagggccctactatagacaatcatcagacttttta
+attaaatagttttccatgaatgtgttgtcaaggcggaccccttcacttttatcacggctc
+ataaatgtcgtatgactgtagtcggtagcggccttcgagtcttcaggggaaatggaaaag
+aaattaggcttctaagatggactataatcgattaggctaattccgttcgcaaatcacaga
+agcaatcttactcaaaattgttggaatcgatagcgaacgcgaccgtgaatgtttaaaagt
+gctcgcacagaattacccaatacctatcatcacgacttaaatacccaaagcagttgtagt
+cgcgtaatagattaagtctgaagcctagagacaaagggatactgggcggggaaacctgct
+ccttcacggtaacatggtaacaacagaatttggttaaggttaaaacgaaatatactcgga
+gtgaattactgttaggtttcgtcatcggatcaataagtagtttccgtgaagacactctta
+tattagatctccgaaattctgacccgtgcattaggcacttggtaggagattccatttgga
+acttgctcaatgtaagccagtaatgttccgaaataattcgctgcaggagcgaggagccgc
+tgaataaaggaccctcgcatcttgttaccttatggttgagggtcaccgttctctgcgtca
+attccagagctggagatacattcatcaacgttacctacgcacagaataaaaagatcgagc
+gctaactcgttttcctaaacacaacggatttagacaaattaccgaatgcgccggagagta
+gcatcttagtgtcatgcctatcatggcggctcagtacgaagagttcaggcatcgaatatt
+gtggtagcccgcactcaaagttccgccattaggtaagctatatattgtggtcagaacttg
+aggacaactatgagctactaaaaataaacaattttgtcatttgttctagatatgtggcat
+tcatcgaacgcttgtaccagaagttacattcgcagcgtgagcgaataaacccgaatgagc
+gtaacattatcaataacatatagttcagatagagaacgaggtattcgacagagaattacc
+caacattggttattaatctatgcagaataatttagataatgtcactacataatattagga
+ccaaaaggtgattccccagaagacaaaacaataaacaatctcacatattcgctagtacct
+atgtatgggtatgatcttctgattggacggggataatttccaggtatattaaaacttatt
+accataatctagacctaagagaggttatataagtaaagagctgtgttccgatagaaaaac
+ccgaccttaaagacttgcgaagtaaattttgctttaacaaaaaaacctacgtaagggaat
+attctgtataaactgaaaagtcaggtgtaactacatgagtcatgtcttcgattaattaca
+atgcgatctcgttattctgatcaactaatatcataaactgccactacatcttgtacaatc
+attcgcaacaatacttttatgtgctaaggtcacgtgcttcctctgctatgctgatttaat
+cagattcataaaggaatacgaataactctggatccattaccacgcaagggatttatttac
+ggctgattactttttggctgttgacagaactgccatgaaagtaagatgtcgcatcttgca
+taaataatagcacctaatatagccgacaaagtgattccgataacagattttaagttgtcc
+agccttgagactccatgaagaccgcttgggagcttccccgtgattagaagaatctaaatc
+ccaagtggatggggggagtttaaatctcagcaccaacaaatagtacttcctctcagagcg
+cgtcatggtcgaaggagcctatcctgatagaggtttgaaagcgcacgcgcatttaactgt
+catattaaattggaatctcgtaagtgtcggcagtacgacaaattttaactgatgtcggta
+tacggagaagaaggaagcacgcattgaagcagctacgcagaactgagaagatgacactct
+aagatacaattaatacaaaaacgttttaagcccaatctatcaacagatgtaagatgtcta
+atacacaagaataaaaccttcatgtcccgatgtataataacagctttatttctgctggtc
+gaggtgaagtagtggaaattactccatcttgctgcgcgtctttatagtgttggctactct
+gtaaccgacgcgtccatccctctctcctagtgatccgtatatccaattagaggataacca
+acatctgcgttaccgacgaatttaaatttttcgactatttaattccgttcaaacccgtat
+tcgtagtaagtgtttcatagatttatgaccgacatcgtgtacgagttgcagtgcatatgt
+agataccactaattgctgatctaggatacatgctttataaacatgcttacttggctattt
+tatttactgtcatgtgggggtttttattttcaacaagtatgtgctaccattggataatct
+ggcttcaaattgaagatatgcgttccaaacttgtctactgtttgctaagtaggagttgtc
+ccattagaactacgcagcacgtggtttgtgatcgaaaagaataattggcaaatacgaggc
+tagccttcaaatttaatgcagattactcctcagaaacacacgtaagcgacgaacgtgatg
+tttactacacaatgcgtatcatagaaattcgtgataatttttgttccaacctttgaatct
+agactgagtggaaaaagatttcaccgggataccgtttatgctggttttaaaaactcgtcg
+aatcatcttataactgcattcaaatggatttctcaatcatctgtacgtcaactgttttaa
+caataacgtcagaataaaccggcacaatgagacggcggtctttcactacaccacaccctt
+aggattataagtgacgtgtggattcgaattctaaggtgacgggatctacaagcctcagct
+acattaggtctgaagatctttcgtatagccgcgtatgttactgtttggatatgggttatg
+ctaatcaacagttgacagcgagtgaaacggccttgcgacctgaaatctttacggttacct
+tttgattcaagacaggatcgacgatggaccacgtgaaatgaattcaaaactgtaacatcg
+cttgtgcctcagcgaccgagtaacgacaagttcacatcctctatgcaactatcattgtgg
+tcattaaggtattcaagattaactaagagtcgaccatatattctagagttttacaattag
+gaaccgttagtctagactaggagcgtgcaacatcgcaggaggtgtggactgtcttgaccc
+aagttgcctgacacatagtgtcttttgcttcatgtccttagcaatgcgatacctcaatcg
+tagttttatcgggataaataacatggtgtttaaccctattaatggtttctattaatctaa
+attgtaaggcagcccttgggtcgaaagcacattaggccacatacacagtatgaaattgtt
+cgagtgtccagaccataattgactaccatggtacacggtgttgctattatgactcccgca
+aaactcttgacagagggaattttggtacattgatgtaatcgatgatttaacagtaggaac
+tagacgtcatccgttagactgagttccgacatgctcaaattgtcaggatttttatccaat
+aactaatggctctcacatgtaaataaaatcacattaacgtcacttagtgatggattcgct
+aaacagatagactatcattcatgaactggcactgtttcgattatatttgcaacatcgaac
+atacttaaagttaaatacgacatcattcaattaaaaaaattcagtacacctctaatgagt
+atcccgctttggaggaaagagtagcactttaaatggacaatttaggccggactttcctgt
+aaatggatgaagtcattgtacagcttgaataaatcgttagggttagtccttacatccacc
+atatgttaatgaataaagcctgagggaccttagagctaacttgtccaacacgttgctcat
+ttacttaataaggttgaaatgtatcagtaagtgacagcgagtgtagattttgaccattta
+actgaccttcacagttttgtcttcagacgtcacttacaccataatgatgacagagcttgt
+agatgcacacactcattcctagtgtaaatcaagtagtagctagattattataaagagata
+ttttctggcgtcgaacgtaacacagagagagtataaggggcatgataatggcttatcaat
+atgtgtaagaaaaagtttttaatatcatctaactcggtggaatgcacacttatggccaac
+tgaccttgggacgagttaagataccataagaggttgcctgtaagttaagataacaaaggg
+atattccatctttgtgtgctaagaacctatttatatttgcagccataaaaacctctgtgc
+tatgcagccaccagagttatttatacaaagaaagagaccatttagatacgttaattctgc
+ttgcgatttattaaacagacatttcacgtccaaccactacaaaagccctatcgcaagacg
+atcattgtattatagcctatgcaacgtagctaagcggccgaggaatcataaaatatgaat
+tgttacattgtttactacatatgatcacaatctttgtaaaaggttcgttcgtgatactac
+catgtacctaactaacctgagatatatgcaatgacttatggggtcagcgcgcaacatccg
+caaagcatagtaatacaaggtaggaaaacttctggatttcccaaggttataatgctctat
+actgaccaagagatccgttacgactcgcaatgaatactctaagggcactcacaaagaaaa
+ccactaattgataaatttcaatgataatatcctgaattgcatcgtgtatgagttacgaga
+agtcgcatttaatgaattagtcatagaaatgtcatagcaggaacataattactatatttt
+aacgatttaatcgtagttggagtcctttcccaaattatgtcatcagttccgatttagatg
+ttttcgggcccttcttagtaaagaagttaatatccaagactagctcctcacccacgcatg
+cacatattcgcgagaagtctgatagaatattcgacagaaatgcgactctagctcacactc
+gttaactgatcaggtacttatagacaagtacgttatcagatatcgcttcggggcattgtt
+gcgctacctttgtgcatagcagttttgaaaaattgttcaagacctgaacgggaaaatgat
+attatttttttaggaggaataatacagtaccatgtaaatactcaaccaccttacgtactt
+cttacgccgaacatatatggcacgtgttattcggctaacaaaactgttgtgccttttcta
+taaggataagcagattcgttttaaacatatgacctgtaaactgggatctacaaaagaggt
+acttaaaataaattgcgcaacggtttagatctgcggatctttggttaaagagcaccatta
+gatgtgccatacttcctatcgcctgagcgagaatttagtctgaggaaccactcttgggat
+ttaaaacaattcggttaggacacctactcggcggatgaagcaatacgataacattaaaag
+tcgttcagtctaattttggtcgtagtacgatgagctgatggccaattgtatttttattaa
+cagcactgaaacaaaatggagactttagactaatactaaagtctcaatgttcgtcgaacc
+ttaaatgctcggaatgaggggatcttcggaagtatagcgccgaagtgtatctcattatta
+taacaccagtgtacagacgacatctaattatggccagaaactgtcattgtgccattaaga
+ggattagtagatagtctggaccgtggaatagaattttgaccaaattgaccagtcctgctt
+gtagacagcgcgatctaaactgcacgagaatatacaagttggtggtgcttgtggctgagc
+acgctaagatgcgtttgtttttacgattctagtgcttcttaacgcaattcagtcttctag
+atccgctattccaacatcaatatctcaatttaaggtcaatatatataacaaaattagaca
+gagcagctgacacttacgaagcatcgtagaaccgatatagtcgaccttatgatgatatgg
+acgtgtccaagtccgcacttccgatgcatcttgacggtgaaccgaaatgaaatcttcatt
+agggcccccatgtgtcaaaccactcgagtcccgtctctgaagtcaagtattactgcgaaa
+aattcgtctactattagtttattatgaacttatgacgcttaaataaattaaacagtaagc
+ctgggaaaatgttaaggcaggaatctttgtaacagttcataatgttgctaaagattatca
+gaccccgtgaagacttcgggctttgggcttcgtaccgtagcataatacatctatatagtt
+agaggcttgcgtgttgttgtgctattccacatatagcagctctgggcgactcttcaatga
+aaatgaaaaatggtaacctggcgacctacttgttaagtcagtttaattcaaggggattaa
+gtaccaagggtcgagtttctctgtatttattatactgtaggcaagaagcttttttggcga
+gatttaagacttaagcctatggtaaaaatttgatagtgagcgactatagtaagagatttg
+ggtggttagtaattaaaattctcctatgctaaatcaggcgtacaatctgagggtgcacat
+ttctcgacgcgtgaaccttcaccgaaagcgtgtggattatacaaatttcaaacatattgg
+cggggcacttatccataatagatttctgtttgtacgccaaactctgcctcacccctccat
+aaattgtattggctagaggttaaattctccgtaaatagagacacatatagttttatacaa
+ttgtttgaatcaaagcacgagaaacttttaaccgtacattgacaaatgtcttcggatggg
+gcagagcatctcttcgtgacccaaatcaatcgctgagcaataagcaagaaaacacagatt
+atacaaagagatctggatgaagatattcgtgcaatcactatcgttatgttagagagttcc
+atgcatgaggactcgttttttgaccaggagaattaagccaagaaataactgacgtatttc
+caaatgaattctacgtgtttttcctgtcacctttagccagtgttaaagatgactatggag
+tttcgaataggttattctatagacattataacgagtggaacacccataccttcacagtgc
+taaaggtaggaacgggtacgtcaggtagttcaagggattttaggttcttaatccaacgaa
+gaaataacgcatcacccgtcattctattgttttcgtcgggattacttagtaggcagggta
+ttctaacctacctgagttacaaatctttaaaaaactggccatgaggtcatggtgataaaa
+tctgaatcgcctaaattcgcgtccctaaggaaatatactagaatccgtctcagaaagtgc
+aaaggttgacttcttcccctaacacagaattctcagttttatagctatctagtggcattc
+ctttttataaaactttacgtttgtaagggtccaactttacaaaagctcggatgtgtatgt
+gtaatcttccgccgtgtaagacttggaacccatgtatattgacggcatggcgtggctaag
+caggtattgatcttcagtgtaaagcaaggtatgttctaatctaacaatgtaaagccgggg
+attagccgccaaaggggtctaatgacatagagatgctctgaaatcgtaccaactataaaa
+gcacgggatttgaaatatagcgacagatcttccgtattctgttagttgacatctgtgctg
+tctttaccgattgtgatttggctttagcagtcatttagtttcgttactcattgctcgtgc
+gatagttccaccgaatatggcacattcgttctttttttccattttactgcaaaccttttc
+aaaagctgatcgataccactgatgatggcattgattagtcgattggcaactatgtcctgc
+ttatatctccaattgcattgaatatagtaaaaaataaaggctcgccttcccaatgggcta
+cggagtacacgaaaaaatcgcaactcgtttaaccaagcgccgtacctaacatataagtga
+ttgagacaaatagttctccagacgtattgagatatatgtctcctataggcaagcgtttct
+aattgctgaccagaaattagaattaggttgttaatactatattcgaccattttattccac
+gaatgtgctattctactggtattgctccgtatgcgatatataaccaacacggaaagtcgt
+cgattgcaaagtggctccgtagaatcatttctggtcatttaccgggagcgcgcttgaaca
+atggatgcggtatctgccatattgttattgttaaaaagacttccgcttactatcgcttcg
+atcatcggaaaaatattaatgaggattgggtcgtataagaaaatcatcttttcagttcgc
+agatttttgccaatttaaccggttatttcgtcagacttggtagtgtagttacaagcatca
+cgattatatcagctacagaattaaactgtcctgactcgacggggcagtgtgtgagtattg
+cgctatatattcaaggtaacaggaggcatataggtcatagtacaaggataatgaggtttg
+ctaactttaaaaattattgatttaacggttgattgaaaatctctgcaagatgacgctaga
+acacctgatgttcaagtttgccgataataacatataagatgaattactgtctttagaccc
+tcatgttaatccgctaacttagggcggaaacaatgttaggctatgcggagtaagtactat
+attatgataccacatagaatttaacattcatatgatgtctaatacccgttcccaaccttg
+caaccgtcccgattaattaagcaattacggtcatcaatgggccaatcctgtctcaaaaat
+tatcatattcaaggttcagctattttggcaatgggtgagtaccgttcttagtgatttacg
+aacccataatctaggcgacttaatatacaagatttagagttacgttttccgggtagtaca
+tattaacgaccatggatcgggtgaggtgttgtattagttatctgatcttgtcagtagctc
+ccaatgtcccagaatattatgtttctactagagtgttcgtatactggaatttaaatatta
+tgtaagactagacaaattttatggatacattaggccatcgtagaatatgatatagttgta
+acgtccctctatagattttcggagggcaggtatattgcttaataaagatgttcggaaatc
+agcggaaaggatttgtaattaactgatgcgcagcgcttaaataagtttagactattaagc
+tatatgttcgacagcatgtagttttttttaccagaaagtgttatactgatgacccatgga
+ggtagctcctcatgataaaaatattgttacttaagcattactattatagtgttcaaacta
+gtaccgttgcatactttaagaatcagacatggcgtttcttatgcagacacacttttttag
+ctgttgacgcccacctcacatccatagtaggtcaatcgcataagaacaatattctggact
+gttttattacccagaagaaagttttttctttccggttcgttaagacaataaagatcattt
+cattcgttctcttaacgatgaactaaagtacttaaagtatccgcctcttgtttcgactag
+cgcatagtgtaataattaaggcaagataagaagaacaggaacgcgcacgtcggagataac
+tctaatagtctctttattccgtttaatatagcccgtaattgcaccatgcgctacagtaac
+ggccgccttcgcaaacctatttatgtaattccaagtttaggtatgcaatggttggggcaa
+tgtgaggggttttatcaagactttcgttgcttcgcggggggcgcaaagcagactttacag
+tagttaaccgaaaaccgcagggagtcgctctaagtgttaccaacccctcactactacgcg
+aaggtactcgattattccttgaatgggctgaaacatcgtgattagcgtcttatgattcag
+gctgatagaagaaaacttattttctatattccacgtatacaatcacactcgtaactaaat
+agttcccagcgttgtaatgtcgctataataaataaaatacaaagaaaattcgtctgggtg
+cataagtacagttagtcgtctgtcacataaataatccgcagtcgatctcattacaggtat
+tgttgttggtcaaccttcgcaaggtggtccaagtagcattgttgaacagtaaaactaccg
+tcacacaaggaatatcataatagatgccatacacggttttacttgatatgtttacagtcc
+ttgagttgcaatcgtagtattgtttcatccggggtgtgtacgaagtaatttagacaaggt
+gtgtagcggtcactaggtaaaatgacttaggatggatgagcatttaggtattctatgata
+acactaaccatcatgtttctaaaatcctcaggaaatttgtattattttaccaacctgtat
+ttatagaaagtgcttttgacttaaagaagccgaagtgttcaaattaaggagtacctgatt
+gaaagaatggggaattgtaatctgtaactcaattacaaataagccgttctaaggattaag
+gctttgtgtctaagcaactcacgtgaattcgaaattcatactcgattaacgactttaata
+ctcttctgcgtatctacagactcatttaaattacggaatatgttttcgtttttggtttcc
+agctcgcacgtacgcgtttacaaataaggacacctggtacaattggctggagtacaatgt
+tggtttttatttgctgattatcccgatccctgtgggcgttggcataaccgggttttcttc
+aagactactttcgtgttgcttatatacctggtaatatcggtgagtagcttagggcttaat
+cacaatactaacaagttctctatggattggacagggcggcatccgttgactgaacgatct
+attaatccattccctgcactggataaacaagacccatttaaattgaccatagagatgtta
+gcgtcatatttctgttcgtgatagggtacatatattataaacggattatgagcagtggtt
+ttctagaaaagcattcatagttaggagtgtatcagatcataccactgaaccatagagcac
+aattctctactggctatacttcattcctttttgtccgggtggggacgaaatttaaaggtt
+ctaacctagaacgcagagcgaattgatcaaggcgctggccaagtgaacggttctaaatgt
+tcttaatgagaattgcgtattttgactattgacagggcatcgtaaaccgctactcgactt
+ggtatctgtaatctgtatgtagatagagtacgggcctataattcaaattcagccaccgaa
+gattcacaatcttcagacgtttgaaggaaagaggtttactggtatgtggtgtcaagcccc
+acccattctctgttatatccgagcattaatgtagtttcactgtactacggtcacgccgta
+gagtcggcagggcaaatccaaaacaatttaggctgagaagtggcactataatagtttagc
+ctaagtcccttcgctaataactcaacaaagatgacgcaaaagtcggcgaatagattgcgt
+tcgcgtaagggtatcttgaatactgatagctctcatggtaccaagaactttcataacctc
+tttatttaccaaacctgttctactagcgttagtgttttagtctgtagccgacacaaaaac
+cgagaatggccggcgtaaccggcgcctgcaagctaacatgggatcaaaactattggctta
+acgtttaatcgaatgagactagcactgtattactctttcgtttcggcagcggatcaataa
+ggaggtgacggcatcactctcttatagtagatatcacttattctcacaacggaagtagga
+tcttccgtcctcattaaatttgcaactggctcaatgtaacactgtaatgttaacaaagta
+tgagctgaaggtcagagcagacgatgtagtaaggtccctcgaagctgcttacagtatcct
+tgaggctcaacgggctatgcggaaattccagacctcgagttacattatgaaacgtgtcat
+tccatctcattaaatagttcgtgccctatcgccttgtaatataaacaaccgtttttgtct
+attttcccaaggagaaggagagtagcagcttagtggcttgcctatatggccccctaagta
+cgtactcggcacgcttagaagattgggctaccccgcactatatgttcccaaagtaggtaa
+cctagatagtgtcgtatgaaattcaggtcatcgatgagagtataaaaatatacaattttg
+gcaggggttatacattgcgggcatgaagagtaacattggacatgaacggacattcgaacc
+ctgtgagtttaataccctatctccggatcattataaagtaaatatacgtcacttactcta
+cgtgcgtttagacagtctttgaaactaaattggttatttttctttcatctagatttgtct
+gtatctaactaaattatagttccacataaagctgattcaactgaagacataaatataaac
+tttctaacatagtagcgaggaaagagctatgcctagcatcggatcatgcgtccgcgagta
+gttcctggtagagttaaaagtttttccagaatctagaccgaacacagggtagtgaacgaa
+agtgcgcggtgaacatacataataccgaacgtaaacaattccgttcgtattgttgctgta
+tctatatttcctacgtaaggctatttgatctataatatgaaaagtcacgtcgaaataaat
+caggaagcgcttcgagtatgtacattcagatctccttagtatcatcaaattatagatttt
+acggccacgaattattggtctagatgtcccaaaaataatttgatgtcagtagcgatcgtg
+cttcctcggagttgaggttggaagaagagtcattatgctataccaagaactctccatcca
+gtacctagaaaggcaggtatgtaccgctcattaattttgcgatcttgacagatctgcatg
+caaagtaacttgtaccagatggcttttataatagaaactaagtttcccgaataacggtgt
+acgataacagatttttaggtgtacagacgtctgactcaatgaacacacattgggacctgc
+cccgggaggagtagtagataattaccttctccagcgcgggtcttttaatatcacaacata
+aaaatactaattaatatcacacaccctcatcctcgatggagcctagcatcatacacgttt
+gatagacaacgccaattttactgtaatatgatattcgaatctagtatgtggacgctgtac
+cacattgtttaaaggagctccctttaccgacatgaacgaagcaagctttgtacaagatac
+gaagaactcagtactggtaactataagagacaatttatacataaaagtgttaagaccatt
+atataaaaagaggtatgaggtctttgtaactacaataatacattcatcgaacgatggaga
+ataacagagttatttctgctgctcgagctctagttctgctaatttctcaatcttgatgcc
+actcgtttgagtcttccattcgctcttaacgacgcgtacatccctctctcctactcttac
+ctatatcctattactggttaacctacatctccgggaaagacgtaggtaaagtggtccacg
+attgtattcacttataacacctagtagtactatgtgttgctgagagtgaggacacactta
+ctctacgagttcaagtccatatggacattacactttttcagcatctaggtgtcatgatgt
+attaacagccgttaggggctatttgattttatcgattgtcggcgtgtgtattttcaacaa
+ctaggtgctacaattcgtgaataggcatgaaaattcaagattgcagttcctatcttgtat
+aatctttcctttggacgagttgtaccatttcaactaacctgcaagtggggggtcatccat
+atgaagatttgccaaatacctggagaccctgaaaagtttatccagattaataataacaaa
+caaacctaagcgaagaacgtcagctttaataaactatcactatcatagaaattcctgtta
+attgttcttccaaacgttgaatagactatcacgggtaatagattgaacacggagaacgtt
+tatccggcttgtaaaatatcgtcgaatctgctgataactcaattatattcgatggagaat
+tcatatctaccgcttagcttttaaaaattaagtcagattattccgccacaatgagaaggc
+gcgagtgcactaatcaaatcacttaggattattacggacgtctgcattacaatgctttgg
+ggtagggttatacaagcatatgattctttaggtctcttgatcgggcgtttaccaccgtag
+cttaatgttggcatatccgtgatcctaatattctgttgtcagcgtgtgtataggaatgca
+caacgcaaatctttaagctgacctgttcatgaaagacaggagacacgaggcaccacctca
+attctatgcaaaactctaacatagcgtggcactatgagtacgtgtaacgacaaggtctca
+tactcgatcctaagataattctcgtctggaaggttttaatctttaactaagagtagaact
+tagtttattgacttttacaattaggatacggttcgcgactctaccacagggcatcatacc
+tggagctctgctatctcgtgaccaaagtggcagcacacatagggtcgggtcctgcatcta
+ctgagcaatccctttaagcattcctagtttgagagccatttagatattgctgtttaaacc
+gattaatggtttctattattataaagtgtaacgctcccattcgggacattgaaaattagc
+aataagacaatgtatgatattcggcgagtctcaacaacattatggtctaccatgggacaa
+ggggttgatatgatgaatccacaaaaaatagtcaaacacccatggttcgttaagtgaggg
+tatccaggtgttataaggacgatctagaagtattcaggtacacggtgttcagacatgctc
+taattgtcaggttgtttataatttaacgtatcgctctctattctaaataatataaaatta
+accgctcgtagggatgctttccagtaaaagatacactatcattaaggttatgcaaatgtg
+gcgatttgatttgaatcttagtacattcttaaacttaaatacgtattatttaaagtaaat
+atattatctaaaccgcttttgtctatccacatttcgtcgaatcacgacctcgttaatgcg
+acaatttacgaccctctttcatctaaagcgatcatctatttcttctgattgatgtaatac
+tgacccttactccgtacatacaaatgatggtaagcaagaatgactgacgctcctgtcacc
+tttcgtggcaatcaactggcgctggtactgaagtagcttgaaagggatatggatgtgtat
+gccaggcttcattttgacaatttttctgtcctgctcagtgttgtctgaagtcgtatcgta
+cacaataatgatgactctcattgtagatccaatcacgctttcctacgctaatgaaagttc
+tagatagtgtaggtgttagacagaggttagcgcctacatccttacacacacagtgttgaa
+cggcaagcataatcgagtatcaatagctgtatgtatttgtttggaatatcatatttctcc
+cgcctttgaacaatgatgccaaaatgtcctgccctagagttatgataaaataactgctgc
+cctgtaacttaagtttacaaaccgatattcaatcgttgtgtcctatgaaaatatttatat
+ttgcaccaagaaaatcatctgtgcgatgaacaaaacacagtgatttataaatacaaagag
+tacatttagttaccggattgcggcttgacatttattttacagaattttatcggcaaaaca
+cttcatatgaactatcgcttcacgataagtctatgatagactagcattcgtagagaacag
+gaagagcaatcattatatatgaagtgttacagtgggtactacatatgagatcattaggtc
+tatatccggccttcctcataagaccttggaaatatcttacatcagagatatcaaaggaag
+tatgggcgaacccagaaaaagccccaaagaatagtaattcatcggacgtaatagtctggt
+tttaactaggggttattgatatttaagctaaaagagttccctgaacactcgaaatgtata
+atctatcccaactaaaaaagtatacctctaattcagaaatgtcattgagattagactgat
+gtcaatacgctaggaggtaagacaagtagaagtttttgatttaggaattgaaatgtaata
+cctccatcttaagttctatattttaaagttttatgcggacttcgagtaagtgcacaaatg
+atggcataagtgcccagttacatgtttgcggccccgtatgagtaatgatctgtttatcaa
+tctctagctactatcccacgaatgcactgatgccagtcatggcgcttacattagtcgaca
+gaaatccgacgatacctatcacgcgtgaactgttctggttcttattcaattcgaagtgat
+ctcagatacattacggccatgcttgcccttcatgtctgctgagcagttttgttataggct
+gaatctcctctaagcgaaattgataggatttttggtggtcgatttagtctgtacctgctt
+attaagattcaaaatgacctacttcttacgccgaaatgatagggatcggctgaggaggat
+aaatatacgctggtgcctggtatttatccagaacaagttgcctgtgtatcagatgaactc
+taatctccgagataaaaaacaggtacgtaaaataaaggccgcaaagggttacatctcagg
+atcgtggcgtatagtccaccattagttctgacttacttaatatagactgaccgagattgt
+agtatgtggatccaagcttgccatgtaaaacatgtcggttagcaaaacgtataggagcat
+gatcaaagaagagttaattaatagtactgcactataattgtcggcggagtaccatgagct
+gttgcccaattcgatgtttattaacagcacgcataaaaaatccagacttttcaattagaa
+ttaactataaatggtccgcgaaccttaaatgatcggaaggacgggatctgccgttgtata
+gaccccaactctatctaatttttataacacctctgtaatcaacaaatcttattatgccat
+cattatgtcattcgccaagtaagtccagttcgagattctctggaccgtgcaatagtattg
+tcaaattatggtaatggaatccttcttctaacacccttagaaaagccacgagaattgaca
+agttgggcgtgcttgtccaggagcaacataagtgccgtttctttttacgatgatagggat
+tcttaaagcttttctctattctagatcccagttgccatcatcaatatctcaattgatgct
+cattatatagttcttatttagtatgtccagatgtcactgaagatcctgcctagaaccgat
+attctcgacaggatcatcagttcgacggggcaaacgcacctatgcacatccatcttgacc
+gtgaaacgaaaggaaagagtcagtaccgacccaatgtggaaaaaaactcctgtccacgat
+atgtaggcaagttttactgcctttaattagtagtcgattagtgtagtttgatattatcta
+ccttatagaatgtaaacagtaacccggccttaatggtttggcaggattctttgtaaaagt
+taataatgttcataaactttatcagaaaacctgaagtagtccgcctttcgcctgcgtaac
+gttgcagattaattcgttttacggagtggcttgcgtcttgttgtccgagtacacatattg
+ctcctctcccccactcttctaggaaaatcaattatgctaacctgcagaccttcttcttta
+ctatctttaatgcatgcccagtatgttcatagggtagacttgctatctattttgtataat
+ctacgaatgatgcttggggcgcgacttttaacaattaagccgttgggtataatttgagag
+ggtgccacgatagtaagagatttccggcgtgagtaaggaaaatgataataggattaagca
+ggcgtaatagctcaccctcctcagttctccaaccctgaaccggctaagtatgactgtgca
+gtattaattttgaatacatattgcagcccctaggatacattatagatgtctctttcttac
+ccaaactcgcccgcaccaagaaagaatgtggattcgattgaggttaaattagccggaatt
+acagacacagattcttgtttacaattgtgggaagaaaaccacctcaaacgttgaaaccta
+cattcacaaatggattacgttggggatgagaatcgattccggtcaaaaatcatgcccgga
+gcaataaccaagaattcacagaggattaatacacttctccatgaagataggactgcttgc
+actatccttatctttgtgtcttccttcaagcaccaatcgtttggggacaaccacaattat
+gccaagaaataacggaaggtgttccaaatctatgagtccgcggtttcatcgcaacgtttc
+actgtgggtatcatgactttggactttagatttgggtattctagagactgtagaaagact
+gcaacaacaagacattcacagggcgaaacctaggaaaggggaccgcacgttgtgctaggg
+atgtttccttaggaatccatacatgtaagaaagaatcaaccgtaattatagtgttttcgg
+ccccttgaattacgtgcatgcctttgctaaaagacctctgggaaatagattgaatattct
+ggacagcagcgaatcctgattatatctcaagcgaatatatgacccgcaagaaggatttat
+actagaataagtctaagaaagggcattgggtcacttcttccactaacacacttttatcag
+ttttataccttgagagtcccatgcatttttatatatatttaactttcgttgcgtaaaact
+ttaaatatgatccgtgctctatctctaatctgaacaacggtatcacgtcgaacaaatcta
+gtggctacgaatcgcgtcgctaagaacggtttcttctgctggcgttagctacgtatcttc
+tatgctaaaaatgtatagccccgcattagcagcaaaaccgggagaatcaaatacacatcc
+gatgaaatcgtaacaaagataaaacaacgcgatttctatgtttgccaaagtgattaagtt
+gtatcgtaggggtcagcgctgatgtcttttcagtttgggttttggatttaccagtctttt
+agtttcggtactatttgatcgggacattcgtccaaacatgatggctcattcgttcttttt
+ttcaattttaatcaaaaccttgtatttacctgatacattaaactgagcatcgcatggagg
+tggagattcccatatatgtaatcatttgatatcctattccattctttttagttataaata
+aacgctccactgcacaatgggagtaggacttcaccaataattagcatctactgtaaacaa
+gcgccgtaacgaaatgattactgattgagaaaaataggtctcaacaacttttgacagata
+tgtatccgatacccaagcgttgctaattgcgcaaaagtaagtagaattacggtcgtatta
+cttgttgccaaatggttattactccaatgggctattctaatccgatggatacgtaggaga
+gagtgtacctacaccgaaactcgtagtgggcttagtggctacgtagaagctgttcgggtc
+agttacagcgtgcgaccttgtaaaatcgatcacggtgatgaattattgttattgtttaaa
+agaagtcccctgaatagcccttagataatacgaaaatttgttatgtccagtcgctcgtat
+atcaaaagattcggttaagttcgcagagttttgccaagtttacaggtgatttactaacac
+ttgggagggtacgtacaaccatcacctggttagcagagaatgaattatacggtcatgtcg
+cgaagggcaagtgtgtgagtattgaccgagttattaaacgtaaatgcaggcatttacgtc
+ataggacatcgagtttgtcctttgcgaaatgttaaatttatggttttttccgttgagtga
+taatagctgcaacatgaagatagtaaaactgaggttaaactttcaccatattaaattata
+tgttcaattacgcgatgtacaaactaatgttaatcagatttaggagcgcgcttaatatgg
+gtccctatcccgactttgtacgagattttgataaaaaatagtattgtaaattcatttgat
+ggcgtagaaccgggcaaaaccttgaaaaaggacacatttaggatgctatttccctaagaa
+agcggaaaatcctggctcaatatttataatagtaatggttaagattgtggcccaatcgct
+gagtacccgtcttacgctttttccaacacataatcgacgagaatgtatttaaatgtttga
+gacttacgttttccgcgtacttattattaaagtcattggagagggtgtcgtctgggtgta
+gttttctcatctgctcaggagctaaaaatgtaaatctattggttgtttctaattctgtcg
+tccgtgtaggctatttaatttttatggtacacttgaatatgtttagccataatgtagcca
+atactacaatatcagatacttgtatacgacctatagacttttgccgaccgctcgtagagt
+gatttagaaagatgttcggatagcacagcaatcgtttgcgaatgtaagcatgcgaagcga
+gtatttaactgttgactattttgctatatgttactctgaatgttgttttttttaccagaa
+tgtgttataatgatcaaccatgcacgttcctactaatcatataaattttgttacgtaagc
+ttttctatgatagtggtctaaagactacccttgcatactttaagattaagacatgcactt
+taggaggaactcacacgttttgagctgttctagcccacctataagccattcgtccgcaat
+cccataactacaatagtcggcaatcttttattacccagaactaacgtttttatttcccgg
+tacgtatcacattaatcttaatttaatgcgtgagagtaacgatgaacgaaagttatttat
+gtttaagccgcttcttgagaatacagattactgttagaatgaaggcatcataactagaac
+accaacgcgcacctcgcacattactctaatagtagctttattcagtttaatatagacagt
+atttgaaccaggcgctaatgttaaggcccccttcgaaaaccttgttatgttattccatgt
+ggtcggaggatttgcggggcgatagcgctgggcggggatcaacaatttcgttcatgcgag
+cgcccccataaccagtaggtacagttcggaaaagaaaaccccacgcactcgctagaagtg
+ttacaatcacatcacttcgtaccgaagggactactgtattccgtcttggggatgtaacag
+actgattacagtcttatgatgaagcctcattcatctaaaattagttgatttattccacgg
+atactatcacactcctatagaaagagttaccaccgtgggaagctagatataataaataaa
+agacatacaatattagtatggctcatgatctacacttactcggatctctctttttttata
+accagtagatcgcattacacgtattgttgttccgcatcaggccctaggggctcaaacttc
+catggtggataactaaaacgtccgtcactaaacgaagatattaatagatgaaatacacgg
+gtttacttgatttctgttcagtcattcacgggaaatcctaggagtctttcataacggcgg
+tcttagtaggaatgtagtcaagctctgtagaggtctcgacggaattggtatttcctggca
+tcacaatttacctagtattggagatcacttaaaataatgttgagataataatcaggatat
+ttctagtatgtgacaaacctctatttagtgattgtgattttcaattaaacaagacgtagg
+ggtcaaattaacgactacatgttggaaagaaggccgaattgtaatatctaactcatgtac
+taagaagaagtgctttcgtttaaggctttctgtctaacattctaacgtcaattcctatgt
+aatactactgtaaccaagttattactcggctgcgtagataaagtctcatgtaaatgacgg
+tttatctgttacttttgggtttcaacctagctaggacgccggtactaattacgacacctg
+cgtatagtgcagggtgttcaatgtgcctttttatgtccggattataaccatccctctccc
+acttggaatatcaccgggttcttaatgacttagttcgtcttccttattttccgggtaaga
+tcgctgtggaccggacccattttgatctagtctaaaaaggtatatagcgtttcgtctggc
+ccgcttacgttcactgaaacttagattaatcaatgcactgcactggattaacaagaacat
+gttatagtgtactgacacatgttagactaagaggtctgttcgggttagccgacttatatg
+tttaaccgattttgacaactgggttgagagataacaatgaagagtgaggactgtagaaga
+tcttaaaactgtaccatagtgctcaattcgctaatggcttgaattatttaattgttctaa
+ccctggcgtcgaatttttttggttcgaaaatacttagcacagcgtattgttcaacgagat
+gcacaactgtaccgttagaaagcggcttaatgacaaggcagtattgtgactattgacagg
+gaatcctaaaaagctactcgaattggtatatggaagaggtatgtactgagaggtcgcgcc
+tattagtcaaattctgccaaagaagagtcaaaagcttaactagtttgatggtatgaggtt
+taatgctaggtggtctataccaccaaaaagtatatgggatatcccagaatttatcgactt
+tcaatcgtctaccgtcacgacgtacactaggcagccctaatccaaaacttttgaggatga
+gtactgccactattatactgtaccatttgtaacttacattttatatcttcaaagaggtag
+atattgtcggccattactgtcacttacactaagggtagcttgattactgatacctctcat
+ggtaaaaagtaatttaagaacctatttttttacataacctctgctactaccgttagtgtt
+ttagtcggttcaagtcacaaaatccctgtagcgcacccctataagcagaaggaaacctta
+atgcggataaaaacttttgccggaaccgttaatcctatgagaataccactcttggaatcg
+gtcctttaggctgaggatatagaacgaggggaacgcatcaatctaggttaggtgagagaa
+ctttgtatcaaaacgcaagtaccatatgccgtcctcagtaaattgccaaatgcagaaatc
+ttacactcttttcttaactaagtatgagagcaacctcactcctgaacagcttgttaccta
+acgagaagaggctttaagtagcctggagcctcaaccggatatccggatttgactctcatc
+cacttacatgatgattacggtcattacatctcatgattttctgagtgccctatagactgg
+gaatttaatctaccctgtttctatttgttaacaaggagaaccactggtcaagatgacgcg
+cttccatttatgccaccataagtaagttctcggaacccttacatgattggcctaccaacc
+tatatatgtgaccaatgtacggtacatagagtgtggcctatcatattcaggtcatcgagc
+tcagtatttaaagattatatggtcgctgggggtattcagtgcgcgatggaagactaacat
+tggaaatcaacggaattgacaacacgctcactttaataacctatctcaggataagtttaa
+tgtaattagacggaactttctctaactccgtgtactaactctttgaaaataatgtgggta
+tttttatttcatctagatttgtctgtatcgaaagaaagtattggtccaaataatcctcag
+taaaatcaagtcataaatataaaatttagatcttaggacagaggaaagtgctttcccgag
+cataggatctggcctacgccagtagttcatgcttgtgttaaaagttgttactgtttatag
+tccgtactcagggtagtgttcgatactcagcggggaactgacatattacactaaggaatc
+aaggcccttcgtatgggtcatgtttatatatttaattacttacgctatttgatcgagaat
+agctatagtaacgtcgtaagaatgcaggatgcgattcgagtttgtaaattcacagatact
+gtgtatcatattattatagatgttaaggcatagaattattggtattgatgtacaaaaaat
+tatgggtgggcagtaccgataggcattacgagcagtgcagcttggaagaactggatgtat
+cctataactagtaagagccttaaaggtactacatacccagggatgttaccatcattaatt
+tggccatcttcaatcttcgcaatgcatactttcttctacaagatgccttttagaagacaa
+aataagtgtcaacaataacgctgtaacttaactctgttgtacgtggaatcaagtctcact
+aaagcaactaacattccgacatgcaaacgcaggactactagattattaaattcgccagcc
+cgcctcgtttaatataacatcataaaaattctaagtaatatctcacacactaatccgcca
+tcgtccatagcatcagtcacctgtcttacacaaacacatgtttaatcgatgttgttatgc
+caagctagtttcgcgaccatgtaactaattgtggaaagctgctaccttgaacgacatcaa
+ccatcctacctttgtacaacagaccaacatctctgtactggtaaatagatctgaaaagtt
+ataaatataactgttttcacattgatagaaaaacagctatgtgctatttgtatatactat
+aataaattaagcgaaacatggagattaaaacagtgttttctcatcctccacctcttgttc
+tgctaatttataattcttgatgccactcgtgtgagtcgtccattcgatcgtaaagaaccc
+gacataaatagatacgacgctgaacgagatcctatttctcctgaaaattattagcacggt
+aactcctagggatagtggtactagttggtatgaacgtataaaaacttgtactactttctc
+gggatgtgagggagcaaactattactcgaccagtgcaacgcattatcgacagtaaaagtt
+ttcagctgatacctgtctggatggattatatgcaggtaggcgagagtggattgtagcgat
+gctcggcgggggtattttaaaaatctaggtgataaaagtcctgtttagccaggaaaagtc
+atcattgcactgcatatcgtcgattagctgtcatttcgtccactggtaccagttcaacgt
+acatcaaagtccgggcgcatccatatcaagttttgcaatagtactccagaccatgaaatg
+gttatccagattaataataacttaatatactttcactacatactcagcgggtattaaatt
+tcactttatgtcaaaggactcttatgtggtcttcaaaaaggtctagagtctatcacgcct
+aattgtgtgaaaaccgagtaacttgatcagccttgtaaaatatagtagaatatgatgtta
+aatcatttatattccagggagattgaatagcttacgattagctggtataatttaactcac
+atgattaagcaaatatctgtaggaccgagggaaagaataaaataaagtaccatgagttcg
+gaacgctgcattacatggcgttgggctagcctgatacaagaagatgagtatggagctctc
+ttcatcgggacgtgacaaccctagcgtaatcttggcagatcccggagcagatgattatcg
+tctaacactgtctttaccaatgcacaacgcatagatttaacctgaactgttctggattca
+ctcctgactacagcctacaactcatttctatgcataactcttaaagacagtcgcaatatc
+agtacctctatacacatcggatcagactagatcataagataagtctcctctggatccttg
+tattctgttaagtacactacaaatttgtttagtgtctgggacaattacgataagggtcgc
+gactagaccacagggcatatgacctccaccgctcctagcgagtctccaatctgcaagcac
+tcatacgctaggggcatgaatcgactgtcaatgcactgtaagatttacgagggtgagacc
+catttagatatgcctcgtttaaccgttttaggcttgataggatgagtttgtcgatccatc
+aaattcccgacattcatattgtccaataagtatatctagcttattcggactcgctaaact
+aaattatggtataaatgccgtcaaccggtgcatttgttcaatcaacaaattatagtcaat
+ctcccatggggccttatggcagcgtatacagctggtataacgaccatatacaactatgaa
+cggactagctgtgaactaagcagattattggatccttgtgtataattttaagtttcgatc
+tatatgctatagtatagaaaatgttccgatcgtacgcttcctttacagttaaacagtcta
+tatcatgaagcttatccaaagctggacatttgatggcaatcttacttaattatgaaactt
+aattacctattattgaaagtatttatatgatcgaataagatttgctctataaacaggtcg
+tccattcacgacctagtgattgcgtaaattgaccaacctaggtaatctaaagcctgcatc
+tatttcttatcattcatgttatactgacccgttctcagtacttaaaaatgatcgtaagca
+agaatcactcacgctcatgtcacatttagtcgaaataaactgccgatgggaaggaagttc
+cgtcattgcgatatcgatgtctatcccacgcgtcattttcaaattggttatctacggata
+actgtgcgatgaactactataggtcaaaattatcttcaatctcattctagatcatataaa
+gatgtccttcgcgattgatacgtctacagtgtgttggtgttacacagagggtagcgacta
+cttacttactaactctctcttgatccgcaagcataagccaggttaaagtgctctatcttt
+ttctgtggattataatagttataccgccttgcatctaggtgcccattaggtaatgcccta
+gtgttttcataaatttactcctgccatctaacgttactttaatttcccagattcaatagg
+tctctcatttgaaaattgttatatgtcaacaaagaatataatagctgagtggaacaatac
+actgtgagggagtaatacatactctaaattttctttacggtttgcgcctgcacagttttt
+tttatctatgtgatccgcataaaaagtaatttcaacgttccattcaagttaagtcttggt
+gacactagcattaggagagatcaccaagaccattatttatttagctagggtttaagtcgg
+ttagaaatatcagataatgaggtctttatccggccttacgcagtagaaattggaaatttc
+gtaaagcactgagttcaatggaagtatggccgaacccacataatgcacaaatcaagtcga
+tttcttccgtccttttagtctcctgggaactacgggttattcatagttaagctaaatcag
+ttaacggaactagacaaatgtataatagttcccaaatatatatctataaatcttatgcag
+ttagggaatgcagatttgaatcatggcaatacgctagctcggaactcaactacaagtgtt
+ggatgtacgaattcaaaggtattacatccttatgatgttcttttttggatacttttatga
+cgacttccacgaagtgaaattatgttcgaatatctgaacagttacttggttgagcccaag
+gatgacgaatgttctgtttataattctcgtcataatataaatacaagcatatgaggccag
+tcatggagctttcatttggactaacatttccgtagagtcatatcacgcctgtaatctgat
+ccgtctttttctattcgaagtgttatcagatacatgacgcccttgcgtgacattcatggc
+tcctgacatcgggtcttttaggctgaatctaatctaacccaatttgtttggattgtgggt
+cctccattttgtctgttaatgcttattaagattaaaaatgtactacgtatttagacctaa
+tgattgcgatacgctgtggaccattaatataagctgcgccaggggatttttccagatcat
+ctggcctgtgtatatgttcaaatctaatagccgagagaaattactccgacggaaaataaa
+ggcagataagcgtttcagagcaccatcgtggcgtttagtcaacctttagttcggaattta
+ttaatatacaatctcactctttggacgagctccttaaaagatgcccttgtatatcatgtc
+ccgtacctaaaagtataccagcatcatcaaagaacagttaaggaatacgactgctctata
+attgtccgaggagtaccttctcatctgccaatagtcgttgggttggaaaacaacgcatta
+atatgccacacttgtcaattagaagtttctataaaggggacgagtaactgatttgagacc
+tagcacggcagaggacgttcgtgtgacaacatctctttataagtttgagataaaatcgct
+aatctacaatgattatttgccaatcattatcgaatgcgcaaagtatctcctgttcgtgat
+tctagcctaaggccattactatggtcaaattatgctaatcgaagcagtcttctaacaccc
+ttagaaaagcaaacactattgaatactgccgccgcattcgccagcaccaacataactgca
+cgtgcttttttccatgattggcattatgaaagatttgatctatgattcttaccagttgca
+atattcaatttagcatgtgttcctaattattgtgttattatggtctatctcatcatgtaa
+atgaagatcatgacgtcaacacagattctagtcaggatcatcagttcctcggggaaatcg
+cacctaggaacagccttatgcaaccgctaaacaaagcaatgaggatgtaccgacaaaagc
+tcgatttaaaagcctcgaaacgagatgtacgaatcgtttactgccttttatgaggagtcg
+agtactgttggttcatatttgctacatgattgtatgtaataacgatcccgccctttatcg
+gttcgatcctttatggcgataagttatgaatcgtcagtatctttagatcaaaaactcaac
+tagtacccagttccccggaggaacggtcatgattaatgcgttttacggtctcccgtccct
+cttcttgtcagaggaatcagtttcatccgatcccactcgatgattggtatagctatttgc
+cgaaaagccacaacgtattcggtactatcttgtttgattcccctgtatcttaattcgcga
+cacttgatatcttttgtgtttaatcgacgaatcatcctgggggcgacacttgttacaatt
+atccagttgcgtttaatggctgtgggtcacaagattgttagacaggtcccgcgtgtcgta
+ggaaattgataattggagtttgcaggacgaatagctcacccgcctaagtgatccaaccct
+catcaggataactatcactgggcagtattatttttgatttcatatgccaccccctaggag
+actgtagtcatgtatctttcttacccaatctagcccgaaacaagaaagaatgtcgattcc
+agtcaccttttattagaccgatttacacacaaagtgtcttggtttaaaggctggcatgaa
+tacatactcaaaagttgaaaacgacttgctctattcgattaccttcgcgatctcaatcga
+ttacgctaaattttaatgcccgctgaaatatccaacatttaaaacaggattaattctctg
+atccatgaacttaggactcattgcacgtgacttatctttctctcttaattcatgctccaa
+tacggtgggctaaaccacttttatcacatgaatgtacgcaacgtgttaataagctatgag
+tacgcgggggcagcgaaacgggtcaatctgggtatcttctattgggacggtacatttcgg
+ttttatagactatgtagttacacggcatcaacatgtaattaaaacggcgtaacctaggaa
+agccgaacgcaccttgggattgccatgtgtccggaggattacatacatctaagaaacatt
+ctaaactatgtatagtcgtttacgacccttgtagtacgtgcatcccttggcgaaaagtac
+tctgggtattagagtgtatattatcgacagcaccgaatcctcattttatagcttgacaat
+ttatgacccgaaagaaccttttataagtctataagtatatctaacgcaattgcggcactg
+agtccactaactatctttgagcagtgttatacagtgagacgccatggaaggggtttatat
+attttactgtcgttccctaaaaagttaattatcagacctgcgcgatctcgtagatgaaca
+acgcgatctagtcgaaaaatgcttgtggctaccattccagtcgagatcaaccgtttctgc
+ggatcgcgttacattccttgcttatttgcgataaatcgatacaaccccattaccagaaaa
+acccggagaatcaattactctgcagatcttatactaaaaaagagattacaacccctgttc
+tatgtgtcccaaagtgagtaacgtggagcgttggggtaagagcggagcgattttaacttt
+cgcttttccattttccagtattgtactttacgttatatttgagcggcacattcgtcaaaa
+catgatccatatggactgaggtgtttaaatgttaatcaaataattgtattttcagctgac
+tttaaaatctgcagccattggaggtggagattccaatagatgtaagcaggtgatatcata
+tgcaattcttgtgacttattaagataccagacacggcacaatcgcagtagcacgtaaaca
+ataatgacaatcgacggttaaattccgaacgtaagatatgtttacggatgcactaaaata
+ggtagcaacaacgtttctctgagatgtataagttaccaaacactggagaattccgctaaa
+ctaaggacaatttccgtcgtattaattgttgacaaatggttagtaatacattcgcagtgg
+ataatccgttgcatacctagcactgagtgtaaataaaaccaatcgactactggcatttcg
+ggctaacgactagatgttagcctatgtgaaagcctcacacatgcttattgccttcacggt
+gagcaatgtttcttattcgttattagaagtcacctgtagagacagtagagatgacctaaa
+tttggtttgtccagtcccgaggtgatctaatgattaggttaacttagaacagtggtcaat
+tggttaaagctgatttacgaacacttccgaggggtcgtaaaacattaaactggtgagaac
+agtatgatgtattcggtcatctagacaaccccatcgctgggagtttggacagtgttatga
+ttcgtaaatccaccatgtgtccgaattcgaaatcctgttgctccggggagatagggttaa
+tttaggcttttttacggtgtggcatattagctcaaacatcaacattcttaaaatcagcgt
+aaacggtcaccagttgatatttgttctgctaggaagcgatgtacaaaataagcttaataa
+gatttaggtccgaccttaatttcggtccatagcacctctttctaagtgttttgcttaaat
+aattgtattgttattgattttctgcgagttgaacacggaaaataagtcaaaaaggacact
+tttaggttcatatgtaccgatgaatgcgcaatagaatcgagaaatttttagattagtaat
+cgtgatgattgtggccaaatcccgcactaaacggctttcgctgtttccaaaaaattttag
+tccactaggtatttaaatgttggacactgaacgtggaagccgtcgtattatgaaactaat
+ggcagaggggctcctctgcgtgtactttgagcagatgctatcgtcagaaaaaggtaaatc
+ttttggttctttataattctggcgtccgtgtagcctagtgaatgtgtttggttcaagtga
+atttgtttagccagaatggaccaattacgtcattagctgttacgtctatacgaaatatag
+actgtggacgacccatcgtagagtcatgtagttacatgtgaccttagaacaccaatcgtg
+tgcgattgtaagcaggacaacacagtattgtactggtcaattggttcatagatctgacta
+tgaatcttcgtttttgtacaacaatctcggtgaagcttcaaaaagcctccttcctaataa
+tcagttaatttttcgtaaggttcctgttcgaggttagtcgtataaagacgaaacggcctt
+aatgtaacattaactattccactgtaggtggatctaacaaggttggacatgtgctaccaa
+taagataagaatttcgtccgcaatacaatatctacttttgtagcctatcttggattaaca
+acaacttacgttggtatttcaccggacgtatcaaatgattctgattttaatgactgagag
+taaacatcaacgaatcttatgtatctttaagccgctgcttgacaagtcacattactgtta
+gaatgaacgcttcattactacaaaacctaccaccaactcccacattaatattatactaga
+tgtttgaagtttatttgacaaaggttttcaaaaagcacagaatcgttacgaacacgtaca
+ttaaattgttagggtattaattgtggtcggtgcatttccggccccatagcgctccgcggg
+gagaaactatggccttcatgacagcccccccataacatctaggtaatggtcggataacta
+taaacaaccctctccagagaactgtgaaaataaaatctcttagtacacaagcgtatactg
+gtttaagtcttgcccatcttaaagactcttttcactattttcttgatgcctcattcttct
+aatattaggtgattttttaatccgagaatataaaaagacgatagaaagtgttaaaacacg
+gcgtagcgacatattttaaagaaatgaaatactttttgactatccctcatgatctaaact
+tacgcggagctatctttttgtataacatgtacagagaattaatccgatgcttcttccgat
+taaggacatagcgccgaaaacgtcatggcggcttatcgatatcgtaacgcactataccaa
+gtgattaagtgatcaatgaatacgggtttcgggatttctgttaagtcatgcacggcaaat
+acttggagtcttgaataacgccgcgcgtagtacgaaggttctcaagctcgcgtgacgtat
+agaccgtattgctatttcctgccttctcaattgtccgaggattgctgataacttaaaata
+aggttgagtttttaataacgatttgtcgagtttgggaaaatcctcgtttgtgtgtttgtc
+attttcaagttatcaagaactacgggtataatttacgacgtaatgttggtttgatgcccg
+attgcgaatatcgtacgaatggtatttgtacaactgctttcctttatcgattgctcgaga
+acattataaagtctattactatggattaagactgtatacaagtgtttaagcggagcccgt
+gataatctataaggttttggtacctttatctgttacttttgccttgaaacatacatacgt
+acacgggaatatttacctaaacgccgtatagtccagcctcgtatttgggccgtgttttgt
+cagcattttaaactgaaagcgcccacttgcattataacccggtgcggaatctcttagtga
+ctcgtcaggagtttacgcctttgagacctctcgacaggacccattttgatctagtcgtta
+taggtagagtgcctttcctatcgcaccattaccttctagcaaacttagagtattcaatga
+aatcatatcctgtttatactaaatgttataggctaatgacacagctgacactaagaggtc
+tcttcgggttacccgaatgagttgtttatacgatgttgacaactcgggggagtcatttca
+atgaagactgaggactcttgatcagattaaaacgcttaatgactgataatttagattatg
+ccgtgtattatttaagtgggcgaaccctcccctagaatgggtttcctgagaaaagtctta
+gaacacagtattctgaatccagatgcaaatcgctaacgttagtaagcggctgtagctctt
+ggcagtttggtcaatagtcaatcgcaatccgtttaaccgtctactattcctagagcgaag
+agctatgttctgacacgtccccaatattaggcaaaggctccaaaagaacagtcaattgat
+taactacgggcttggtttctccgtgaatccttgcgccgctataccacataaaaggatagc
+ggtgataccacaagtttgcgacgttaaagcgtcgaccctcaacaagtacactagcaaccc
+cttagcaattaattttgtccatcactactgccaagagttgactggaccagttggaaatga
+catttgatatattaatagagctacatattgtaccactttactgtcacttacactaaccct
+agcgtgattactcatacatatattcgtaaattctaagttatgatactagttttgtaaatt
+taatcggcgaagacacgttctcttgtacgagcttcaactaaatatttcactgtagccaac
+cactttaaccagaaggataccttaatgccgatataatattgtccaggaaacgttaatact
+ttcacaagacaaagcttggaagaggtactttacgatcacctgatagatcgaccggaacga
+ttctatataggtttggtctgagaaatttgtagctaaaaccatgttccataggaactcctc
+tgtaatgggcaaaatgcagatagcgttcaatcgttgcttaactatctatcacagcatcct
+aactcctcaacagcttctttcctaaagacatcagcaggtaagttgacggcacccgataac
+ccagagcacgattggaatctaatactctgtatggatcattacgctaagtaaatataatga
+ttttctgactcaaagttacactgcgaattttatattaactggttctatttgttaaatacc
+acaacctctcgtcaacaggtcgcgatgcaagtgatccaaaaatatctaacttataccaac
+cattacttctggcgcagaaaaacatagatatctgaacaatcgaccgttaagactgtctcg
+ccgatcttaggaacctaatactgctcagtagttattgtttatttgggccatccccggatt
+atgtcagccatggaacactaaaagtcctaatctaacctatggacaaaaagctcactttta
+taaaattgctcaccttatgttgattgttatttgtccgaaatgtctataactcagtgtact
+atctattggaaaattatggccggagttttattgaatatacttttgtatgttgagaaagaa
+tgttgtcgtaataattatcagctggaaaatcatctaatatatattatattgagatattac
+gacagacctaagtgctttcccgtcatgagcagatggactaacactcttggtaatccttct
+cgttttagttggtaatgtttagtctaagtaatatcccgactcttacttactcagagcgga
+aatgactttttaaactaacgtttaaaggcacttagtatgcgtcagggttatttttttaat
+tacgtacccttgtgcagagagtttagctattcgatcctacttagtatgaaccatgagagt
+acaggttggtaattcacagagaaggtcgagaagattatttttgatgtttaccaatactat
+gaggcgtattcatcgaaataattttatggctgcgcacttcacatacgcaggaagaccact
+gcagcttgctagatctggatgtatcattgtacttctaagagcctgaaaggtaatacattc
+ccagcgagcgtaacagattgtatggggacatattcaatcttagcaatgcattcgttcttc
+gaaatcaggcatttttgatgtcataagttctgtcaactataaccctggaactttaatctg
+ttgttcgtcgaatcaaggatcaagaaagcttctaaaaggcccaaagcaaaacccaccact
+acttcagttttaaattagaatcacaccctagggtattagataataattaaatgtcttagg
+aagagatatcaaaagatgcagacatcctcaagtgaataagtctccggtctttcacaaaca
+catggttaagcgatgtggttttgactagagacgttcgccaccatcgtaatatttctggtt
+acctgcgaacgtgaaccaaatcttacttcatacattgcttaaacagtacaacttatctct
+tatcctatagagatctcaaaagtttgtatttttactggtttcaaattgagagaaaaactg
+cgttctccgatttctatattattgtttaaatgatgccaaacatccagtttaaaacacggt
+gtgatcagccgactcagattcgtatcctatgttagaatgagtcatcaaactacggtcacg
+cgtacattacagagtaaactacacgaatgaaagagataagaagatgaaagagttaatagg
+tctcctgttaattatgagaaccctaactactacggattggcctactagtgggttggaacg
+gatataaaattcgactaagttcgcggcatgtcaggctcctaaatatgaagagaactcggc
+atcgaattatccacagtaatagttggaacatgattcctctatgcatggtgtatatccacg
+tacgccagtgtgcagtgtagccatgcgaccacgggcgttgtgaatattcttcctcagaaa
+aggactgttgagcaaggaattggattctgtgaacggaatatagtcgagtagatggaattt
+cctacactgcgaaaaggtcatagtaaatcaaacgccgcgcgcagacatatcttcttggca
+attagtactccactaaatcaattggttataaacttttagaatatctttatataagttcac
+tacttacgctgcgggtagtatatttaaagtgatgtcttaggaatcttatggcggcggaat
+aaacggcttgactatagataccctaattctggcataaccctgtaacgtgtgaagcatgct
+ttaatagacgactagatcagcttatagaatggatatgactgccacattgaagagattaac
+attagcgggtataatgttacgaacttgtttaacaaaatagctctaccacacacgcatagt
+ataatataaaggtcctggagttcgctacgagcctggaattgcagttcccctaccctgagt
+aaacaagatcagtatggacctatcttctgacccacgtgtaaaaactaccgttagcggccc
+tgagaacggtgaagttgattatcggctaacactcgctttaccaaggaacaaacaattgat
+ggaacaggtaagcggctggattctatcctgaatacagcataataatatttgctttcaata
+tatagttatgacactcccaatatcactaactctttacaaatcggatatgaagagtgaatt
+agagatggagccgatcgttccttgtattctggtaagtactcgactaatgtgtgtagtcta
+ggggtaaaggtccttaaccgtcgagtctagaactcacgcattatgaaatcctccgagcat
+agagactctaaattcgccaagcaataagtcccgacgcgaaggatgagaagctcattgaac
+tgtaacatttacgtcgggctcaccatgttacatatgcagcgggtaaaagtttttgcctgg
+agtggttgagtttcgcgatacataaaaggccccactttcatatggtcaaatatctatatc
+gtgctttggacgactcgataaactaaagtagcctagtaatgccctaaaccgctgcatttg
+tgcaataaaaaatttagagtatatataacttccggacgtatggctgccttgaatcctcgg
+atatcgtccttatacaacgatgaacggtatagctcggaactatgcagattaggcgatcct
+tgggttgaatttttagtttccatagatatgagttagttttgatatggttaccatacgtcc
+ctgcattgaaacttaatctgtatattgattgatccttagcaatagcggcacatttctggg
+caatatgacttaattaggttacggtttttactatgatggatacgttttatatgatagaat
+aacagttgctatttaaacaggtactacattcaactaatactgtttcactattgtgtccaa
+catagggaatatattgcctgaatagatgtattatcaggcatcttttacgctccaggtaga
+actaattaaaaatgatccttagaaactttcaagcaacataagctaaaagttacgccaatt
+ataagccacatcggtaggatcttcaggcattcccatatccttctctatcaatcccgtctg
+ttgctaattggttatctaagcatatcgcggcgagcatctacgataggtataaagttgctg
+ctatctaattcgtcataatatatacatggaattacagattcatacgtcttcagtctcgtg
+gtgtttctaagagcggacccaagaattacgtaatatctctctcgtgttacccaagaagtt
+gacacgtgattgtcagctatctttttctggcgatgttaatagttataaacaattgcatat
+agctgcaaattagctaatcaaatactcgtttcttaaatgttatcagcaaagctttaggtt
+ctgtaatttcactgtgtaaagagggcgctaagttcaaaattggtttttggcaacaaacaa
+tttaatagcgcagtgcaaaaataatatctcagggtgtaattatttctctaattggtcttt
+acggttggaccaggcaatgggttttttatctatgtgataccaattaaaagtaatttcaaa
+gtgacattaaacttaagtattgctgtcaagaccattacgacacttcaccaacacatttat
+gtattgtgctacgcggtatggcccgtagtaatttctgatattgaccgcgttatcagcaag
+tacgctgtacaaatgccaaatttagtaaagctctgtgtgcattccaaggtgcccacatca
+cacattatcaacatatcatgtcgttgtattacgtccttttactagcctgggaaataccgg
+tgattcagagtgaacataaatctctgaaagctactagacaaagctagtatagttaaaata
+tatatttcttttaatattaggatctttgcgattgcacatttcaagcatcgcattaaccta
+cctccgtactcttctacaacggttgcatgtacgatttctatgcgatgaaatacttatgtt
+cttagtttggggttactttgttcacctagtcctcgaacgcaaattagcttcgaatatctg
+aaaagtgtatgcgggcaccaaaacgatctcgattcttaggtttataattatagtcagaag
+ataaatacatgcatatctggacactcttccacatgtcatgtcgactaactttgaactaca
+gtcatatatagactgttatctgatccgtatgtgtctattactactcttatctgagaaagg
+acccaatggagtcacagtaagcgatcatgtcatcggggctttttccctgattataagatt
+acactattgctgtgcttggggcctcctactttttctatcttaatcattttgtacattaaa
+aagctaagaagtaggtacaacttatctttcccatacgagctggaccattaatttaacagc
+cgcaaggcgagttttaatgttaatctggaagggctttatgttctaagcttttagcactga
+gaaattaatccgtaggaaattaatcccacataacccggtaagagaaccttacgccccgtt
+actaataatgttctgcgcaatgtaggaagtgacaagctcactcttgcgacgagctcctta
+atacaggccctgcgttatattcgaccgtacctataactagaccaccatcttaaatgtaca
+gttatggttttcgacgcatagagtatgggaccacctcgaaatgctcagctgcaaattgta
+ctgggggtggttatcaaacatttaatatgaatctatggtaaagtactagtttatagatag
+ccgaacactaaaggtttgcagaccttcctcccctgaggaacttcgtgtcacaaattagat
+tgagaaggtggtgataaaatcgcgtatctacaatgatttggtgcaaatatttatcgattg
+cccaatcgttctactcgtactctttatagcctaacgccttttcttggcgctaattagcct
+aatccaagaaggagtctaacaaaattacttaaccatactcttgtctattcggcccacgca
+tgcgcaagctcaaaaagttctcaacgggcgtttttacttgagtcccaggaggtaacattg
+gatctatgagtcttaacagtggaaatatgatttttagattgtgttcagatttattgtctt
+attttggtctatctcatcagctatagctacataatgacgtcttaactgtttcgactaacc
+ttcagatctgactaccccaaatacaacatagcaaaagaatgatgctaacgcttaactatc
+ctttcacgatcttaacaaaaaagctccatttaaaagaatcgaaaacagatctaccattcg
+tggaatcaatttttggacgagtactggtcgggtcgtgcttatttgctacaggattgtttc
+gtataacgttcaagcactttagcggttccatccttgatggcgttaactgatgatgcgtaa
+gtttatggtgatctaaaactctactacgaaccaggtcccagcacgaaacgtcatctttaa
+tgagtttttaggtctccaggcactaggctgcgaagtggaatatgtgtcatcagagacaaa
+tagatgattcctatagctttttgcagttaagccactaagtaggcggttctatagggtttc
+attcaaatcgatcgtaattcccgactctgcatagcgtgggtcttgtatagaccattcttc
+aggcccgccacaatggtttcaagtttcaacttccgtttattggctgtccctcaatagagt
+cgttctcagggcacgactctcgttcgttattcataagtccagtttgatccacgaatacag
+aacacgcatatctgataataaaagcttaacgataactttcacgcgcatggtttatttttg
+atttattaggcaaccaaataccagaatgtagtcagcgatatgtagtaaaatttagacaaa
+cataaaacaaagtatcgccattacagtctcctgttaggagaacctttttatcaatatgtg
+taggcgtgtattggcgcccttgatttaataataattacggctaaacgtattgatattttc
+caggaactgccccatctcatgagatgaccctaaattttattcacacctcatttttaattc
+ttttatatcacgattatttatctgagcaagcatctttgcaagcattcatagtgacggtgc
+tgtctctatgaatgcatgctaatatacggtgcgctaaacatattggttcaattcaatgta
+agctacctcggaatttgcttgcactaagacggggaagccaaaacggtaaatcgccgtata
+tgctagtgccaagggacttgtccgttggagtcactatggagttacaagcattataaatct
+aaggaaatcgcagtatcagtccttaccccaaagatacttcgcattccctggggtacggac
+catgaaatacttctttcatacatgataaacgatggagactcggttaccaccctggtagtt
+actccatcaattggagttaactaagatcgctattacaggctttattagccaatcatcaca
+agcctctttttagagattcacaagttagcaaaccaaagttcctttgataagtctttaacg
+agatctatcccaattccggctaggagtaaaatttatatatttgagatcggggttaaagtc
+acacgcaatgcaaggggtttttatatggtaatgtccttccctaattaggtaattttcaga
+cctccgagagagagtagatcaacaacgcgttatactcctaaaatgcttgtcgataacatg
+acactacagatcatccctggatgagcatcgactttcattacttgattagttcagttaatt
+cgtttcaaaccattttcaacaaaatcccccagtagatatgtatatgcacatcttagacta
+aataacagttttcataccctgggatttgtgtcactatctcaggaacgtcgagacgtcccc
+tatcaccgcagcgagggtaactggccctgttccattgtaatcgatgggacgggacgttat
+attgcagacccaaagtagtaataaattcagccatatggacggagggggggaattgttaag
+aatataattcgattttcagctgaatgtaaaagctccagccattcctcctccacttgacat
+tagttcgaagaaggtctgagaattggaattgcttgtgacgttttttgtttccagacaagg
+aaatagcccagtaccaagtataatattatgacaatagaagcttaaattcacaacgtaaca
+tatctgttagcatgctctaatagaccgagaaaataagtgtctatgtgtgcgagaactgtc
+aattcacggcagtagtcacctaatctaacgtctagttcccgactatgaagtcttcacaaa
+tggttagtaataatttcccagtggagtagaagtggcataacgtgcactctctgttaataa
+tacctttagactactcccatttcgccagaacgtcttgatggtaccctatgggaaacactc
+acacatgcttattgcctgcaacctcagcaatgtgtcgtatgcggtatttctacgaacagc
+tagtgaaaggactgatgacctaattttggtttctcaagtccagacgtgatattttgatga
+ccgtatctgacatctctgggcaattcggttaacctctggtacgaaatagtccgtcgcgta
+ggtaaaaatgataatgctgtcatcactatcatgttttagctaagctacactaccccatcg
+ctcgcacgtggcaaagtgtgaggattccgatatcatccatgtgtacgaattcctaatact
+cttgctcagggcacttagggttattgtagcctgtgttaccgtctcgcatattagatcatt
+aatcaacagtcttataatcaccgtaatcggtaaacagttgttatttgttctgataggtag
+acagctaataaagatgctgttgaacagttacgtcccacctttattgccctacagtgaaac
+tagttcttactctgttgctgtaatatgtctagggttattgatttgctgccacttcaaaac
+ggaaattaagtcattaacgaaaatggttccttcataggtaaagatcaatccccaattgaa
+gccagaaattttgagatgtcgattcctgatcattcgccaaatttacagctcgtaaacgag
+ttccatgtgtaaaaaaatgttgagtccactagcttgtttattctggctcaaggtacgtgg
+aacacgtagtattttgatactaatgccagacccgctacgatccctgtactgtgagcagag
+ccgatcctcagaaatagctaaatcttgtgcttcgttagaagtctcgactacgtgtagcct
+agtgtttgtgttgcgttatagtctatttgtggacacagtatggtcaaatgacgtcttttg
+atctgacggcgttaacaaagatactctgggcaacacacatacttctctcatgttgtttct
+tcggacctttcataacctttcctggcacatggttagctgcacatcacaggattgtaaggg
+tctagtggttcagtgagcggaatatcattcgtcggtggtgttaatctatctcggtgtagc
+ttataaatgcatccgtaagaatattatgtttatttgtcggtacgttcatggtagtggtgt
+cgccgatttagacgtaaaggcatgtatggatcttgatctatgcaaaggtaggtccatcta
+tatacgttgcacagcggatacaaataagataagaatttactaacatttaaattttcttat
+tgtcgagcatagattggaggaaaaacttatttacttggtatttaaacggaagtttctaat
+gtttatgattggatgcacggacagtttactgcttactttcttaggtttcttgaacaacag
+gatgcactagtaacatgtctcgttcatgcttccattaagttcttcttaaacttacacaaa
+ctacctaatttagagttgacgagatggttgaacgtgttgtgacaaacgtttgcaaaatgc
+acagtatcgttaccaaaaagtacatttaagtgtgtgcgtaggaattctgctacgtccatt
+gcaggccacattcacatcccacccctgaatatatggactgaatcacacacaccaaatttc
+atctaccttatcgtagcataactattaacaaacatatacagacttcgcggtaaataaaat
+atattagtacacaaccgtatactggttgaactattgcccagctttaagacgcttttaact
+aggtgcttgatcaagaagtattattatatgacggcagtgtgtaatacctgaatagatata
+gacgttagattgtctgaaaacacgccgtagagacatttttgttagatatgtatttctttt
+tgacgagccagcatcttagtatctgaagacgagctatatgtttgtagaaaatcgactgac
+attgtatacgaggcggcgtaagattaaccaaattccccagaattagtaatggcgccttat
+cgatttactaacgatatataacttgtgatgttgtctgcaatgtatacccgtgtaggctgt
+gctcttatcgaaggaaacgcattgaagtccaggctggatgaaaccaccgcgtacttccat
+gcgtctatacatagcgtcaccgatactacgttttgctatgtaatccattctaatgggtaa
+gaggattcctcttatagtaaaatatgcttgactttttaagaaccattgggagtggttggc
+aaaataatagtgggtgtctttctcagtgtatagttttctacaactacccctattaggtta
+caagtaatctggctttcttgccacttggcgatgatagttagattcgtatttctacaacgc
+agttactgtatccatggcgcgagataattagatacgatttgaatttggatgtagactcgt
+tactactgttgtagaccagcacgtgagtatctagatgggtttgctaccttgttagcggac
+ttttgccgggaaaaagacatacgtacaaccgtatattttactataagcagtattggccac
+cctcgtattgcggcagggtgtgctcacctggttaaaatgaaagagaaaaattccatttta
+aaacccggaggaatctattactgacgaggaaggtgtttaacccgttgagacatctcctaa
+cgtaaaaggttcatattctagttattccgagagtcactttcctatccaaacatgaactga
+tagcataatgacaggttgaatggaaagcatatcctgtttattctaaatctgtttcgctaa
+tcaatatgctgtcacgaactcggagcttacccttacaactatgtgttctgtttaccaggt
+gctaatatcccggcactcttttcatgcatgtcgctcctagcgtcatctgatttaatagct
+taatgtctcatattttacagtagccagtgtagtatggaaggcggcgaaccagcccctaca
+ttgggtttcctgacataagtattacatatcacttgtctgattacacagcaaaatcgctaa
+ccttactttgcgcatgtagctattggaactttgggctagtgtctatcccattaagtttaa
+cagtagactagtccgtgagcgatcaccgagcttatgtctcgtacccaagttttggatttg
+gatcaaaaactactcgatattcatgatctacgggcttcctttctccgggtatcattgcgc
+cgagattaaaaataaaacgatagcgctgtgaaaacatgtttgacacgggatagcgtagaa
+actaaacaacgaatagaccatccaatttgaattttattgggtccagcacttcgccatagt
+gttgaatggtaaagttcgaaaggaaatttgttatattaattctgctacattttcgaccac
+ttgtatctcaaggacaatatcccttgaggcttttagcagaaagagatgccgtaattctaa
+gggatgataataggttgggaaatttaagagcagtagtaacggtcgcgggttcgaccttaa
+actatatatttaaatctagccaaacaagttaacaacaaccataaagttatgaccttatta
+tattggcaagcttaacgttttaattgctctagtaatagagtggtagaggtaagggaccat
+cacctgattcttcctccgcaaccattatatagacgtgtcgtctgacaaatttcgagataa
+aacattcgtccttagcaacgaatatcgaatggcaattagccacattgagttaaatagttg
+aggatatttcttgcacagaatcagatctaatctaatgattcgttactaaacacttcacca
+ggtatcgtgaaggctcaagattacccagagaacctttgcaatataagaatatgtatgcag
+cattaccctaagtaattatattctttttctgactcaaagtgacaagccctagtgtatatt
+aaatcggtatatttgggaaattcctcaaactatcctaatcaggtagccatgaaagtgatc
+aaaaaagttcgtacttataccatacatgaattctggccaagtaaaaaatagattgcgcaa
+aattcgtaccttaagtctctcgccaagatattaggatcctattactcatatcgtgttttt
+ctttattgccgccatccccggagtatctcacccatccttctcttaaaggcctaatattac
+ctatgcaaataaacatatattgttgaaaattgagaacctgatcgtgattcttatgtgtac
+catatgtatagtaatcacgcgactatatagtgctttagtatcgcccgtgggtgagtgaat
+attctgggctagcgtgagatagtttcttgtcctaatatttttcagatcgaatagcttcta
+tttttgtgtttattgacatatgtcgaaactccttactcagtgaaagtcatgaccagatcc
+acgaacaatcttcggaatcagtctcgttttacggcggaatcttgagtctaacttatatcc
+cgtcgcttactttctaacaccccttatgtatttttaaaattacgtttattcgaacgtact
+tggcggaagcgttattttttgaagtaagttacattgggcagactcttgacattttcgata
+cgactttctttcatccatcacaggactcgttcgtattgatatcagaagctcgtgatgatt
+agttgtcttctttaccaatactttgaggcctattctgcgaaatttttgttgccctgcgaa
+cttcacataccaaggaacacctcgcaacatgccttcatatccatcgttcattgtaattct
+tacacaatgaatcctaagtaattacatccctgcgtaaaagatggtaggggcactgaggat
+atattaccaagcatttagttatgagtaatcagcaatgtttcttgtattaagttctctaaa
+atagttacatcgtaatgttatctcgggttccgcgaataaacgagatagattcattatata
+tggccctaagcaaaaacctcctcgtattctgttggtaattagaatcacacaatacgggtt
+gagatattaattatttgtagtacgaagagatataaaaagatgaacaattactcaagtcaa
+gatgtatacgggatttataataaaaatcgggtagagatctgctttgcaattcagacgtgc
+cactaaatcgtaatatgtcgcgttacatcagaaagggtaactattattaattaataaagg
+gcttaatcactacatattagatcttatccgatagtcttatctattcgttgtatttttaag
+cggttctaattcagtcattatatcagtgctccgagttctttattattgttttaaggatga
+caaaatgcctcttgttataacgctgggagaagcagactaagagtcggagcagttggtaga
+atgaggctgcaaaagacggtctcgacgaatggacagactttactaaaccaatgaaagaca
+gaagtagagcaaagtctgaagtggtatcagcttaattatgacaacccttaatacttccct
+ttcgccgaatactggcgtggaaaggttttaaaagtcgaagtagttagaggcatctctcgc
+tcataaataggtagactactcgcaatccaatgtgactatgtaatactgggaacatcagtc
+cgcgatgcagcgtgtttatcaaccgtccccactcgcctggggagacatgagaccaccccc
+gtggggattattagtccgcagtaatcgactcttgacaatccttttcgattatgtcatagc
+aatttacgacagttcagcgaagtgactactcggcgaaatggtattactaaagcattcgaa
+cccacatgaatgtgattcttggcaatttctaatccactaaagcttttccgttgaatctgg
+ttgtagatatttatataagttcactaattaagatcacggtagtatattgatagtgatgtc
+tttgcaagaggttggccgaggaatttacggattctctattgatacaatttgtctggctta
+taactcttaaggctgaaccaggcgtttttagacgacttgatcagctgttagaatggtttg
+gactccctctttcatgtcagtaacatttcagccgttattgttacgatatgcttgaacaat
+attgatctaccacacacccatagtatattttataggtcatgctgttacctacgagcatgg
+tattccacttcccattcaatgagtattcaacatcactagcctcagagatgatgacccacc
+tctaataacgtcacgttgcggccatgtgaaacctgaacttgagtagacgatatcaagcgc
+tttaaattgcatataacatttgagggtaaagctaagcggatgctttatataatcaatact
+caataataagatttgattgcattttagagttatgacacgacatagttcactaacgagtta
+ctattcccagatctagactgaagtactgatcgagacgatccttacgtcgatgatcgttag
+ttatcgacttaggtcgggtctctagcggtattggtacttaaccggacactatactaataa
+cccatgatcaaagcataacagaatacagacgataatttcgccaacatatatgtacagacc
+ccaagcatgagaagctcattgaaagctatcattgaagtcccgctcacaatgtgtcttttc
+cagacggtttaactggttcccgggagtcctggagtttcgacttacataaatggaaacaat
+gtattttgctaatttatctatagcgtcatttggaccaatacagaatattatgttgcctag
+taatccactataacccgcaagtgctgatagaaaatttttagacgatttataaatgcccca
+agtatccctcccgtgaatcctccgttatactaattagtattcgttcatacgtataccgcg
+catatatgaacatttggcgataaggcgcgtgaattgttacgtgacagagatagcagtttc
+ttgtgatatggttaacagacgtacatgaagggaaactttatatctatagtgatgcttccg
+tagaaataccgccactggtctgccaatgatgaagtatgtagctttaggtttgtactatga
+ggctttcgtttgtttgcagagtataacagttgcgagtgaaaaaccgacgaatttatacta
+atacgctttcactattggctacaaaatagggaagagtttcaatcatgagagggagtatat
+ggatgctttgtagctaaaggtagaacgtatgtatatgctgccgttcattcttgaaagata
+cataagcgataagttacgacaattataagcaacatccctaccttcgtaacgatttcactg
+ttactgcgcttgaaatacactatggggctattggcggagagaagcagatcgcgccgagca
+tatacgagacctataatgttgatgatagagaaggcgtctgaattgatacatcgaagtaca
+ctttctttcgtagtatctctcgtcctctttctatctccggacacaagaattaagttatat
+atatagagtcttaccaatcatgttgaatcctgattctcagagttctttggcgggccttgt
+gatgactgagaaacaatgcaatattgctccaaatttcctaagcaaattctcggttatgtt
+atgttatcagcaaagcgttacgttatgttatttaaatctggaatgacggagcgaagttct
+tatgtcggtgtgggaataattcttttgaagacagcactccttaaataatatcgctccgtg
+tttgtatttatcgaatgggtctgtaaccttgcacaagcaaatcggtggtgtatatatcgg
+ataacaattaatacgatgttcatagtgacagtatactgatcgagtcctctaaagtcaatt
+acctcacttaacaatctcattgatgttgtgtcattcccggtatcgcccgtagtatgtgct
+ctgattgaccgagtgtgaaccaaggaacatctactaatgcctttgttaggtaagatctct
+ctgaattccttcgtgccaacttaaaacattatcaaaatttcttctacttggattaactac
+ttttacgagcatggcaaattcccctgtggaagacggttcattattatcggaaaccttata
+gaaattgcgtgttgactgaaattagatttttattgtaagagttgcatctttgcgattcct
+ctggtctagcttccaatgaacagtcctcccttctattcgacatcgggtccttcgtacatg
+tctttgcgatgtaataattaggttcggagtgtggccttaatgggtgcaactaggaataca
+acgcaaatttgctgacatgatagcaaatcggtatgccggcaccaaaacgtgctccttgct
+tagcttgtgaatgagactcagtagttaaataaatccatatctgcaatcgattccacaggt
+attgtccactatctttgaactactctaagagatacaagcttagctgagaccgaggtgtat
+atgactacgctgatatctgtaaggtaccaatgcaggcaaagtatgcgagaagctaatacc
+ggctgtttccagctttataagattaaaatttggctgtcctggcggcctcagaattgttct
+atcgtaatcagttggttcattaattagctaagtacgaggtacaacttatctgtcccagaa
+cagctccacaagtttttttacagccgaaacccctgtgtgaatcttaatatccaagcgcgt
+tatctgattagagtttacaactcagtattttatcagtacgttttgtttccaacattaccc
+ggtatgacaaaatgacgccacgtgtcgaataatggtctgaccaatgtaggaagtgaaaag
+ataaatattgcctacacatactgaattcaggcaatgcgttttattcgaaaggtcatataa
+ctagaaaacatgatgaattcttatcggatccttttactagcatagtgttggcgaacacct
+cgtaatgctcagcggcaaattggactgcgggtccttatcatacattttttttcaatatag
+gcgattggtctaggttagtgattccccaacacttaaggtttgctgacattcataccctca
+gcaacttcctctcaaaaattagagtgagttggtggtcttataagaccgttgattatttga
+ggtggtcaaatgatggtgcgatgcacaaatcgttataatcgtactctgtagacaataacc
+cattgtagtgccgattttgtgcataatacaagaaggaggatataaaaatgacttttcaat
+aatattggctattagcaacaagaaggagaatcctcattaagttagcaaccgcagggggta
+ctgcagtccaaggaggtttcattggagagagcagtatgaaaacggcaattatgattgtga
+gattcgctgaagattgtgtctctgattttcctagatagaataagctatagctacttaatc
+aactcttaactgtggagactatcctgatgatctgaataccccatttacaaaattccatat
+caatgaggctaacgcttaaatttcatttctccatcgtaacaaaaatcagcctttttatac
+aagacaaaacactgcttccattacgggtagcaatggttgctcgactactggtagcgtcgt
+gatgtggtgataaagctgtcttgcgtttatacttaaacaaattttgacctgacataatgg
+agcgacttatcggatgttgccgatctttagggtcatctattaagcttatacgaaaaaggg
+acaagcacgttacgtaatctggtaggactgggtacctagaaacgcaagaggaggcgaact
+ccaatatctgtaagaacagaaaaatacaggagtccttttcatttttcaagttaacaatat
+aagtaggagcttagagaggcttgcatgaaaatcgttaggaattacagaataggcagagag
+tggggcgtgtagactacattcttcaggccccacaatatgggttataggttaaactgcact
+ttttgcgatctcccgaaatactgtcgttctctgcgaaccacgctcgttccttttgctgta
+gtccacgttcatccaactattcagataaacaagatcgcagaattaaagcttaaccatatc
+ttgatagcccatcgtgtatggggcatgtatgtgcaaacaaaagacctcaatcttgtctgc
+gagagggaggaaaatttagacaaacataattcattctttcgactggacacgctaaggttt
+ggacaaactttgtatctatatctggaggcctgtattccagcccttcttttaataagattt
+acggcttaaactatggatatttgccaggaaatgacactgctattgacaggaacataattt
+tgattcaaacctcattgttaattattttatatctcctgtttttatatcagaatgcttctg
+tcctagaaggcatactcaaggtgagggctcgaggaatgaatcataatagaccggccccta
+ttaatattggttcaattctttcttacataacgcggaatttgattgcacgaacaccgggaa
+cacataaccgtatagcgcccgttatgctagtgcctagcgactgggaccgtggagtctata
+tcgtctttctaccattattaatctaaggatataccactttaagtcctttcaactaacata
+aggcgcattccatgcgctaaggaccttgaatttattatttcttacatgataaaagatcga
+gtcgacgggaacaaaaggctacgtactcaataaagtgcagtttactaagagccctttttc
+tggcttgtggagactatcataacatgaagatgttttgacattcaatagtttgcaaaacaa
+acttactttgtgtagtattgaacgagatctttccaattgccccatagcaggaatagttat
+atattgcagatcgcggtgtaacgcactccaaatccatcgcggtgtgtgagggtaagcgac
+ttaaagaattacggtttttgatcaaagcacagtgagagttgagcaaattacagttatacg
+acttaattcagtctccataaattgaaacgacacttcttaacgggaggaccagacacgttc
+attaagtgaggagtgcactttttgactttaaaaacatggtaatcaatttaaaccacttga
+tatgtatatgaacagatttgaagttatttctgttttaatacactgggagttctgtcaata
+tcgcaggaaccgcctgacgtcccctatcacacctcagagggtaaagggacaggggaaagg
+gtaatcgaggggtagggaacgtagttggcacacccaatggacgaataaatgctgccatat
+ccacggagggcgggattgcggttgattttaaggcgatggtaacctgaatgtaatagatca
+tcaaatgcctcctccactggaaattactgcgtacatccgctgagaattgcaatggagtgt
+ctcggtttttctttaaacaaaaccaaattgacaacttcatagtataatttttgcacatta
+caagcgttaattaacaaacttactttgctgttagctgcctatatttgtccgacaatataa
+ctggatatctctgcgagaactgtaaattaacggcacttggaacataatagttcctattgg
+taacgacgttgtaggcggcaattatccggtggaagaattgacaactgcagttgaactgca
+tgaaagtcaaatctctcgtaagtataactttagaagactccaaggtacccagaacctctt
+cagcggacacgatcgctatcaatcaataaggattattcactgaaaccgctcatatctgga
+ggtggacgtttttcttcgaaaagcttgtcaaaggactcatcaaatttttggccgtgctaa
+tcgacacacctgttattttcatgaccggataggacatctcgcggaaattcgggtaacagc
+tgggtagatataggacctcccctacgtattaatgataagcctgtcataactagcttggtt
+taccgaagagacaataaacattcgagcgctcgtgccaaactcggtgcattacgtttgaat
+aaatcggtaacatgtactattactctgcctaacggcacttacccgtttgggtccatgggg
+taaccgctcgatgttgacagaattatgctaaagtcgtttaagatcccgattaccgaaaat
+ctggttatgtctgagcattcgtacactgcgtattaagatcaggttgaacaggttcctaac
+aaattttgtgacctaaagtgaaactaggtcgtactctgggcatgttttatgtcgtggcgt
+atgcatgtgctgacacttctaaaaccaaattaaggctttatccaatatgggtccttaagt
+gctaaacatcattcacaatttcaagacagattgttggtcttgtcgattccgcatctgtcg
+ccaaattgacacatcgtaaaccaggtacatcggtaattatatgttgactaaactaccgtg
+tgtattctggctctaggtacggcgaacaagtacgatgtgcttaagaagccctcaccccag
+acgagcccgcgtaggtcacatcagcagatcctaagtaattccgttttattgtcctgaggg
+agtaggatcgacgaactctacaagtcgctttgtcgtgccttataggctatttcgggtcaa
+tgtagcgtcaaatgaactattgtcatctgtacgagttaactaagtgtctatcgccaacta
+aaagacgtctcgatggttctttatgcggacctgtcatatcattgactggcacttgcttac
+atccaaataacacgtttgttagcggatagtcgttaagtgtgcgcaagatcatgaggcggg
+gggggtaatatttcgccctctacatgataaatgaataagtaagaagatgatctttttgtg
+gcggtaccttaagcgtactcctgtcgacgagttactactaaaggaatgtagggttctgga
+tctatgaaaagcgacctccatatatatacgggcctaagcggagtaaaataagtgatcaat
+ggactaacattgaaatgttagtattgtcgaccattgagggctggtaaatcttatttacgg
+gcgtgggaaaacgaacgtgatatggtttagcatgggatgcaagcactcgttaatgcttac
+tttagttggttgcgggaacaacaggaggctatactaactggtagcgttcttgcttccatt
+atgttattattataattaaaaataagacatatggtagagttgtagtcagggtggatcggg
+ttgtctataacgttggaataatcaaaactatcgttaacaaaaacgaaatttaagtcggtg
+cggtggaatgcgcctacctcatgtgcaccacacattcacagcacacccctcattataggc
+aaggaagcaaacaaaaaaaagttaatcgaccgtatccgaccttaaattttaaaataaata
+gaaacacttagcggtaatgaaaagataggactaaaattcactagtatcctggaacgaggc
+aacagagttatctagatggtaacgaggtgctgcatcaagatgtatgatttttggtccgct
+gtgtggaatacctctattgatatacaagtgactttctcggtaataacgcacttcacaatg
+tgttgtttcttttctatgtattttgcaagagaaagaagcttagtataggtacacctcaga
+gatgtttcgtgtaaatcgtatcacatggtataactgcaggaggaacattatccaaattca
+ccacaattactaatccacccttttacttttactaaagatatattaattctcatgttgtct
+gaattgtataacccggtaccctgggagcgtatcgaaggataccaattgaagtcctcgagg
+catgttacaacacacgacttccttccgtctattcagacactcaacgagactaacttttcc
+taggtaatcaatgatattgggtaactcgtggcatcttatagttattgatccggctctttt
+gtagatcctgtgcgactcgtgcgctaattaagactggctctcttgcgcaggggatacgtt
+tattctacgtacccgatttggttactactaagcggcctttcttcaaacttgcagttgtga
+cttacattcctatttcttcaaagcagggaagggttacagggagagacttattgagatacg
+attggaatttccatgtacaatcgttaatacgcttgtagaccagcaactcagtatagagat
+ccgtttcctaaagggtgagcggtaggggcaaggcaataagaaattactaaaaccctagtt
+gttaatataagaacgattcgaaacaataggattgcccaagggggtgcgaacatggtgtaa
+atcaaagagaaataggcattgttaaaacccgcacgtttctagtacgcaagaggaacgtcg
+gtaaccagttctcaaagatcctaacctaaaaggggcttattctactttttccgacactca
+atggacgagacaaacatgaacggatagctttaggtctcgttgaatgcaaagaatagaatc
+gttattattaatcggtttccattatctatatgcggtatagatctccgagaggaccctgta
+aactagctctgcggtttaactggtgctaatagaccgccactatgttattgcttctagctc
+ctagcgtcttatcatgttatacattaatgtcgcatattggacagtagccaggcttggatg
+gatcgccgacaaaaagaaaagactttccctgtaaggacttaactattacatataacttgg
+atcattaatctgcaaattagagtaacggtctttcaccagcttcatattccaacgtggcgc
+tagtcgatatcccatgaagtttaaaactagaattggcagtctcacttcacagtgcgtatc
+tatacgacaaaagtggtcgatttgcataaatatcttatcgatattcaggttattaccgat
+tccttgctaacgctagaagtcacaccagagtaataataattccagacacctgtgaaataa
+tcggtcactacggatagactagtaacgataatacgtatagtccataaaagttgaatttta
+ggggctaaagatattagcaatactggtctagcctaatcgtcgatagcaaagggctgtgag
+gatttctcctacattttcgaccaattgtatcgataggaatagttacagtcacgcttgtag
+atgtaagagatgacgttattcttagggttcttaagtcggggggtaatttaagaccactag
+taaaggtagaggcgtacacagtaaacgatattttgaaatcgtcaaaaaaaagtttacaac
+atcctttaagttagcaactgattttagtggcaaccttaacggttgaattgatctactaat
+acaggcctacaccgaagggtacagataatgattcttactaccctaacatgatagagtcct
+gtcctatctcataggtcgacattttaaattcgtaatgagcaacgaagatcgtttcccaat
+ttgcaacattcacttatagacttcaggttatttcgtgctaacattaagatagaatataat
+cagtcgttaagaaactattatccagctttcgtcaaccataaagattaaaaactgaaactt
+ggcaagatatgaatagctatcctgctttaaccgatcgtatgagatgctttgtagcaagaa
+aagtgactagcacttgtgtttagtaaagcgggagagtgcggtaattaatattaatatact
+attaagctacacagcaaaggctgcaataatgttagtaagtagaacataaaggtattctcc
+acaagtaataaatagtgtgagctaattgactaacttaactctcgcgacaagtgatgtgga
+taagatgactcatatcgtctttttctgtagtgccgacatcccacctggatcgaacaattc
+cttctagttatcgactttgattacctatcctattaaacagatagggttgtaaagtcagaa
+aatgatcggcttgcgttggtctaccatagctagagttagaacgcgtagatagaggccttt
+tgttgccaacgtgggggtgggatgagtctgggcgagcgtgactttctttcgtgtccgaat
+ttgtttaacatccattagattagatgtttgtgttttgggtctgatgtcctaactactttc
+tcagtgaaactaatgtcatcatccaagtaaaatagtccgatgaagtctccgttttcggcc
+gaagcttgtctataacgtatataaagtcgctgaatttagaacacaccttatctatgttgt
+aaagttactttattccaaaggacgtgcacgaagcgtgagtgtgggaaggaacttaaagtc
+ggatcactcttgtcagtgtagataagaatttctttcatacttcactggaatccggcgtat
+ggatatctctaccgcgtcatctggtggtgtctgcggtaaaaagtcttgctgcacgagtct
+gagaaatttttggtgccatcacatcgtaactgtacaacgaacaaatagcatcaggccttc
+ttatccagcgtgaagtctaattatttcacaagctttcctaagtatgtaaatccctcactt
+aatgatgcttgcgccaatgaggatagaggacattgcatgtacgtaggactattctccaag
+gggtcttctattttgttagcgaaaattgttacagcctaatgttagagcggcgtacgactt
+tataccagatactttcattagatatgcaaatatccaattaaatcatagtagtatcgtggt
+atggacaatcaaaaaagacccgttgtgatatgatgtttttctagttcgttctcatatata
+tagatcaacaatgaataatctcatgatctataaccgatgtatatttatattccggttgac
+tgctccggtgcaattcactacggacactaatgactaatatggcgcctttcatcagaaacg
+ctaaatatgattaatgaattaagggagtattatctaattattagagagtagcagttagtc
+tgatattttcggtgtatgtgttagccgttataatgctgtctttttatcagtgagaacagg
+gagtgtgtagtgttgtatgcttcactttatgactctggttatatccctcggagaacaaga
+ataagagtacgagaagttcggtcattgaggatgaaatagaaccgctagacgaatggactc
+acgtttataaaactatgtatcacagtactacagctaactctgaagtccgagaagcttttg
+taggacaaaacgttataagtacctttcgcagaatacggccgtgcatacctgttataaggc
+gtagtagggacaccatgctatccctcatatagagctacactaataccattacatggtgac
+tatcgtttacggccatcatctgtaagcgatcatgcctcgttagcatccgtacaatctcgc
+atggcgtcactgcagaaaaaccccgtgcggattttgagtcagaactattcgaagcttctc
+aatccttttccattatggcatagcaagtgacgactcgtcagccatgggaataatagcact
+aatccgattacttatgaattagaacccacatgaatgtgattctgcgaattgtctaagaat
+ctaatgattttccggtgaatatggttgttgttatttattgaacttatattattaacatca
+cccttcgttagtgatagtcagctatttccaagaggttccccgagcatttttaccattctc
+tagtcatacaagttggagcgcttttaaatctttaggctgatcaaggcgttttgtctagaa
+ttctgcagatgttagattcgtgtgcaatccctcttgcatgtcagtaacaggtcacccgtt
+tttcgttacatatgctggtaaaatattcatagtaataactacaatacttgatttgttacg
+taatgctcgtacataacacaatcgtattccacggaacagtaaagctctattattctgatc
+gagcctaagagaggatcacactacgctattaaagtcacgttcacgaaatctcaaacctca
+actgctggtgaccagttatagacagtgtaattccatattacatgtcaggcttaagctaac
+ccgagcctttatataagctataatcaagaattagattggagtgcattttagacttatcta
+tcgaaatagtgatagtaagagtttatatgacctgatctagactgatgttctcttccacaa
+cagccttaaggcgtggagcctttcttatactattaggtcgcgtcgagagccctattcgta
+atgttaacgacactagactaatatacaatgagctaagaataacacaagtcacaagataat
+ttacaaatcatatatctacagtccacaaccatcactagcgattgcaaagcgttattggta
+ctaccgctctaaatcggtatgtgcaagacgcgttaactggttcaagcctctcctgctcgt
+gagactgaaagaaatcgaaaatatggatgtgcctaattgttcttgtgagtcatgtgcaac
+tatacagtttagtttggtcaagactatgcaactattaacagcatgtgcgcattgaatatt
+tggtgtcgattgataaatgccccaacgttccatcacgtctataagccgtgttactaatgt
+gtattagtgcatacctattcagaccatagttcaactgttggactgaaggcccgtcttggg
+gttcgtgaatgagagtgcagtttcttgtcttttccttaactgacctaaatgaaggcaatc
+ggtttatctagagtcatgcttaaggtgaatttcagccaatgggctcccattgagctagta
+tggtgctttacctttgtaagtggtggctttccttggtgtgctgactttaacacggcagag
+tgattatccgaagaatggataataagacgctggcaatattggctaataaagtccgatgag
+tttcaatcatgactgcgaggagatccatgcggtgtacctaaacctacatcgtatgtattt
+gctgacgttcattcttgatacataaagatccgatatcggtccactttgtttaccaaaagc
+cctaccttcgtaacgatggaaatgtgaatgagagtgaaatacacgatggggatattgccg
+gtgagtacaagttagaccacacattagaactgacctatattcgtcatcatagagatggag
+tatgaattgattctgcgaagtacactggctttacgagtatctagacgccgcggtatatct
+cccgtcaatactatgaaggtatatatatagaggctgaaaattcatgttcaatcctctttc
+taagagtgagtgggagccccttctgttgtcggagtaaaaaggcattattcctcaaattgt
+cagaagcaaagtatacgtgatgtttgcttagaacaaaagagttaccttagggtaggtaaa
+tctcgattcaccgagagaagtgattttggcggtgtgcgattaattcttttgatgacagat
+ctcattattttatatagctccctctttgtatttagagtttgcgtaggtaacctggcaaaa
+ccatatcccggggggagagtgcgctgaacattttatacgatgtgattactcaaaggataa
+ggttcgaggcctctatactcatggaactatcttataattataatggatcgtggctcattc
+cacctatccaaacttctttgtgatctgatgctacgagtgtgaacaaacgtacatcttcta
+aggaatttgggacgtttcatagctcgcatttcattcctgaaaacttaaatatttttaaaa
+attgattctactgcgaggaactaaggtgtagacaagcccttagtaaccggtggatgtcgc
+ttcagttttatagcaaacattattcaatttcagtcttgactgaaattagtttgttagtgt
+tagaggtccatatgtcacatgcatatggtctagatgccattgtacagtaataccttagat
+tagtattagcggcatgcgtacttggatttcacttgtaagaatgagcttaggacggtcgcc
+tgtagggctgcaaataggaatacttacaatttttgatgacttgttagcatatcgctatca
+cccataaaaaacctgatacttgatgagcgggtgattgagactatgtactgatataattca
+atagctccaatagatgaaacagctatgcgcctatttatgtcaaataatcgatgtgataca
+agcttagagctgaacgagcgcgagtggaattagcggtgatctctatcctaaaaagccacg
+aaatcgatcccagaagctaatacccgaggtgtcaagcttgagttcagttaaatttgcatc
+tcatgccccacgaagaatgggtagagagtttgaaggtgcttctggattttcctaagtacg
+tggtaaaaatttgatgtaaatgaacacctcctaatggttgtgttaaccacaaacccctgg
+gtgaatctgattagccaacccagtgatctgatttcagttgtcaaatctcttttttataac
+taccttttgtttccataatttaaccggatctcataatgaacaaacgggtagaataatggt
+agcacatagcgagcttgtctattcagaaatatggcctactcagaatgtattctccaaatc
+agtgttatgcgaaacgtaattttacgtgtaataatgatgatttcttatcggttccttgta
+ctacaatactcttgcccaacaaatactaagcataacagcaaaattcgaatccccctcctt
+ttaataaatggtttttcaatatagccgattcgtattcgttagtctttcaccaactattaa
+cctggcatctaattaataaaatcaccaaaggactctataatatgacagtcacttcggcct
+cttttaagacagttgattattgcaggtccgcaattgatggtgacatgcacaattagttag
+aatccgactatggagacaattaacaattgtagtgcccatttggtccagttgacttcaacc
+acgagttataaaggtattttaatttatagtcgatagtaccaacaacaagcacaatcataa
+ttatgttagaaaacccagggggtaatgctctaaatccagctttaaggccagagtgcacta
+tgaaatcgccattgatcattgtgtcattcgctgaacttggtgtctaggaggtgccgagtg
+agaatatcagataccttatgaagcaacgattatatctggactagatcatgatgatcggaa
+taaaacattgaaataagtccttatcaaggagcataaacattttatttaatttatacttcg
+taaataaattcagaattttttttcaagacattaatctgagtaaatgacggctagaaaggg
+ttcctactcgaatcgtagcctacgcatgtgggcagtaacctggcttgcgtttttactgaa
+acaaaggttcaccggaaagaaggctgccacttttagcttcttgacgatctttagcgtcat
+atttttagattagtcgaaaaacggaaaacaaacttaacgaagctggttgcacggggtacc
+gagaaaccaaagagcaggacaactccttgatcgggaagaactgaaatagacagctgtcat
+tttcattggtcaacttatcaatataacgaccaccgtagtgacgcttgcatgaaaatactg
+aggatgtaaactatagccagtcaggcccgcgtgttgactaattgatgaagcaaacaaaat
+agccggtattcgttaaaaggaacgggttgccagctacagatatactctaggtatatccca
+aacaagagacgtcctttggctgttgtaatcggtcataatacttgtcacataaacaagatc
+gctgaattaaacattaaacagttagtgatacacaatcgtggttggggctgggatgtgcaa
+taaaaagtcatctatcgtctatcacagagcgacgtaaatttagacaaacattattatttc
+ttgacaatggaatcgataagcgttcctctaacttggtatatatatctcgaccccgggatt
+ccagccattcttgtatgaagatttaaccatttaactatgcatagttgaatggtaaggaaa
+atgatattgactgcaacagattttggatgcaaaaatatttgtgaattattggttatatac
+tggttgtatagcacaatcattaggtcctagaaggcatactcaacctcagcgagagagcta
+gcatgcataattgtaccgcccatattaatattcctgaaatgatttcttacattacgccca
+atttcagtcatcgaacacccccatcaatttacccgatagagaacgtgatcatacgcaata
+ccctatgcgaacgtccactctatagcgtctgtatacaatgattattcgttccatttacaa
+cgttaagtaatttaaacttacataaggacaaggaaatccgcgaacctcctggaatgtatg
+agttatttatgcagttaacttcgtctcgaccggaactaaaggcgtcgtacgaatgaaagg
+ccacttttagaagagacctttgtatccattgtggagaatatcataaattcaagatggggt
+gtcatgctattcggtcctaaacattcttaatggctgttctattgttagtctgatttaaaa
+tggaaccatagcacgaatagttagatagggctcatacccctgtaacgatctacaaatcct
+tccccgggtgtgtgcgttagcgacggaaagttttacggtttgtgatcaaagaacactcac
+acgtcagattattacactgatacgaattatttcagtcgacagtaattgaatagaaactta
+ttaacgccagcacctgacacggtaagtaaggcaggtctgaactgtttgactgtaaaaaaa
+tggtaatatttttaaaaatcttgatttctatatcaaatgatgtgtagttttttctctgtt
+attaaaatcccagtgcgcgaaatttagatcgttacgactcacgtacaagatcacacatca
+cacgcgttagcgaaagcggaatggctaatacagccctacgcaacgtagtgggatcaacat
+atggacgaatttatgctcaatgagccaacctcccccgcattgcggttcattttaaggcct
+gggtaacatctatcgtttagataatcaaaggaatccgactatgcaattgtctgacttcat
+ccgctctcaagtccaatgcaggcgctacgtgtttctttaatcaataccatattgaaatcg
+taatacgataattgttgctattgactacaggttatgaaaaaacttactttgcgggtacat
+gcatatttttgtaccacattattacgcgatatctctcagtgtactctaaattaaaccctc
+ttcgaacattttagttcctattcgtaaacacgtgctacgcggcaatttgccggtcgtaga
+atggacaactccagttcaactgcatgtaactcatagctcgcgttagtataaattgactag
+tagccatgggacaaagtaactagtcagcggaaaagatccctttaaagatatatgcaggtt
+gcaagcataaagctcattgctcgaggtgcaccgtggtattccaaaagcgtctctatcgta
+tcttctaattttgggccgtgagaatcgaaactactctgatttgctgcacacgttaggtaa
+tatcgcccattttcccgtataagctccgtacttatacgaactacacgaccttttaagcat
+tagccgctcatatcgtgattcgtgtacagatgagtctattaaaattacagacatactcca
+tatctcgctccttgaactttgaataatgcgctaacttgtactatgaataggcagaaccca
+actttcccgtttgcgtcaagcggggaaacgatacatgttgtcagatttatgattatctag
+ttttagatcacgtttaccgataatcggctgtggtctgagcagtcctacactgagtattta
+cttcagcttcatatcggtccgaaaaaaggttgtgaccgaatgtcaaaatacggagtacga
+tgggcatcttttttcgagtcgcggttgcagggcagcaaaaggcttaaaccatttttacga
+tttttactatagcggtcatgaagtgcgaaactgcttgcaaattttctacacacattgtgg
+ctcttgtccttgaagcttatggcgaaaatttgaaacatagtataccagggaaagcgcgaa
+ttatttggtgactaatagtccgtgggtttgagccatatacctaacgccataaactacgtg
+gtgctttagatgcaatctaaacagaacagaaagcgtagcgctcatcagcacagactaact
+ttttcagtttgagtcgccggagggacttcgagacaagaacgcgtcaagtcgcttgcgcgg
+cacggattcgattgggcggctcaatcttgcctaatttctactattgtcagctgtacgact
+gtactaagtgtatagccccaaataaaagaagtatcgatgcgtctttatgaccaaaggtct
+tataattgaagcgcacttccgttcatcaaattaaatcctggcttacccgattctccggaa
+gtctgacctagagattgacgacggccgcgtattattgagacctcttcaggattaatcaat
+aacgaagtagttgatctgtttggcgacgtaccttaagccgactccgctacacgagtttct
+actaaaccaatgtagccttatgcttagatgaataccgtcctaattagatattccggcata
+acagcagtaaattatctgttcaatggacgaacattgaattgttagtattctacacaagtc
+aggcctcgtaaatattaggtaaggccgtgggataacctacgtgatatgcttgagcttgcg
+ttgcaagctctcgttaatcattaatttaggtgcgtgagggttaaacaccagcatattcta
+tatgctagacgtcttccttaaaggatcgtagtattataattaataataagaaatatggtt
+gacgtctagtcagcgggcatacgctgctctatatactggcattattcaaaacttgacggt
+aaaaaaacgaattttaaggcgctcacgtcgaatgagccgaactcatgggaaccaaaatgt
+cacagaaaacacctctttattgccaagcatgcaataaaaaaaatgttaatagtacgttta
+cgacattttattttataataaagagaaactattacacctattgatatgataggacgtaaa
+ttaacgagtagcctgcatagaggcaaatgaggtttctacatggtatagacctgatgctga
+aacatcgatgagttttggtcccctcgctcgttgaaatctagtcatttactactgtctttc
+gagctattataccacttcactatgtggtgtttctttgctatgtatggggctagtcaaaca
+tgatgactatagctacaactcagagagcgggcgtgttaagagtatctcatgctagaactg
+cacgacgaacttgatacaaagtaacaacatttacgattccacaaggtgactttgaagaaa
+catagtttaattctctgcttcgatcatttctataaaccggtaccatcgcagcggatagat
+gcataacatttctactactccaggcatcttaaaacacacgtagtacttcactagattaag
+acacgataagtgtataacttggcagtgggaagcaaggagattggcgaactcctggcatct
+gttacgttttgttcaggctcggttgttgataatgtccgactcctgccatattgaagactc
+gctcgagggagatcgggattcgttgattataagtacacgtgttccgtaatactatgaggc
+agtgattcaaaatggcacttctgacttacatgactaggtattattaccacggaagcgtta
+aaggcacactcttatggacttaagattgcaagtgccttcttctagcctgaattcgcgggt
+tcaacacaaactctctttagacatccgttgcctaaaggctgagacgtaggggcaaccctt
+taactatgtactaaaaaactagttggtaatttaacaacgtgtccaatcaagacgatgcac
+caacgcggtgcgaaaatcgggttaagcaaacacaaataggaattgtgataaaccccacct
+tgagaggtcgcaagaccaacctcgggaacaacggctctaagagaataacctaaatccgga
+tgagtagactgtgtaactctctaaagggaagtgaaaaaaagctaagcatacatttaggtc
+tcctgcattgcattcaattgaatcgtttgtattatgagctgtacagtagctatatcagct
+atagttatcccagaggaacaggtaaactagctctgagcgtgaaatccggatattagaacc
+cctagatgggattgattctagctaatacaggcttatctggttttacagttatctagatga
+ttggtaaggtgaaacgcttggtgccttccaccacttaaacaaaagtattgcccgggaagc
+tattttctaggtattataaagtcgagcattaatatcaatttgacagtaaaggtctttcac
+cagcttcatatgccatagggcccatactcgatttaaattgaacggtttaacgagtattgg
+aactctcacttataactgagtagctatacgaaaaatctggtccatttccagaaatttatt
+atcgatttgctgcttagtacccaggaagtgataacccttgaaggcacaacactgtaataa
+gttttcctgtcacatctgtaatattcggtcactacgcattcacgactaaagataattact
+atactaattaaaagttcaatgttagggccgaatcatagtagaaattctcgtctagcctaa
+tcggacttacctatgggctgtgaggatttatcagtatgtggacaaaaatgctagagatag
+gtatagttaaagtcaccatggtacatctatgtgaggaagtttgtagttcgcttctttagt
+ccgggcgtttgggatgacaactactatacgtagagccgtactcaggattagatagtgtga
+aagagtcaaataaaagggttaatattaatttaacgttgcaaatgtgtttaggccaaacat
+taaccgttgtagggatattctaatacaggccttcaccgaaccctaatgataatctgtctt
+aataacattaaatgattgtctccgctacgagctcttagggcctcattttaaatgactaat
+gtccaaagaagagactttcccaatttcaatctgtcacgtatagacggcaccttagtgagt
+catatcattaagatagaagattatcaggagggaagtttctattatcaaccgttacgcaac
+cataaacttttaaatctcataatggcattgagatcaagagctttcatgatggtaaagttc
+gtatgtgatgctggggagctagatatcggtataccacttcggttgtggtaagcccgagtg
+ggccgttagtaatattaatagacgattatccgacaatgcattcgctgaaataatcttact
+taggagaaattaatgctatgagccaaaactatttatgtctgtcacattattgactaaagt
+atctatcgacaaaactgatgtccataagttgtagcagatagtcggtgtatggtgtcacca
+atgaaaacctcgagcgaaaaatgaattatagttatccaatttgagtaaattgcctattat
+acagataggcttgtttagtcagataaggttccgcttgaggtgctctaacttagcgagagt
+tagaaagcctagtgagaggcattttggtgccaaactccggctcgcatgagtaggccagag
+agtcactttctttcgtcgaagaagttggtgaacagccttttgattagttgtttgtcttgt
+ggctatgtgctactatataagttagaacgcaaactaatctaatcagcaaagtaaaatagg
+accttgaacgagacggggtacgccgttgaggctcgagatagtagataaactagaggaatg
+tagataaaacattagctagggggtttagttactggattacataggaagtgcaccatcacg
+gtgtgggggttcgtacgtaaagtcgcatcaatattgtcagtggacttaacaagttcgtgc
+ataatgaaatcctatacggactttgcatatctctaccgactcatctggtcgtctatgcgg
+gtaattgtattgctccaagtggatgactattttggcgtcccagcacatagtaaatgtaaa
+tccttataatagcataagcaattattagactgcgtgaagtcttagtagttctcaagcttt
+acgttgtatgtaaataactcacgtaatcagccgtccccaaatcaccattgaggtcattga
+atgtacggagcactattatcaatgcggtatgcgattttctgagcgattattgttaaagac
+ttagcgttgagccccggaacacttgattacagattctttaaggagttatccaaatatcat
+tttaaataatagtagtatcgtgctttggacaataaaaaaagacccgttctcttatgttgt
+tttgcgacgtacttctctgatatatacttcaactatgaagattctattcatcgataaccc
+aggtatatttatatgcccgttcactgcgcagggcaaattatctacggacaataatgacgt
+agttggacccggtaagaactaacgcttaatatgattaaggatgtatgccagtattatctt
+attatgtcagagtagaagtttctctgagattttccgtcgttgtggtacaccggatttggc
+tctctttttagaactgagaactcggagtgtgtagtcttgtttccttcaatttatcaatat
+gcttttataccgccctcatcaactataacaggacgacaagttccgtcttgctccatcata
+tactaccgatacaccaatcgtatcaagtttagtatacttgctttctctcttctacagctt
+actcgcttgtccgagaagcggttggtgctcataaagttagtagtaaatgtacaactagta
+gccagtccttacctgtttttacgactactacggacaccatgagatacagaagttagtgct
+acaattataccattacatgctcaatatcgttgtcggccataagatcgaagagtgcatcac
+gcgtgtgaatacgtaaaatctaccatcccgtcaatgcacaaaaacacactccccttgttg
+actaacatcttttacaagaggctaaatcattgtccaggatcgaataccttgtgtacaatc
+gtcacccatcggaagaataccacttttccgatgtagtatgatttacaaaaaacatctatg
+tgagtaggccaattgtagtagaatatattcatttgaccgtcattagccttcttcttaggt
+tgtgtacggatagtaggtacataaaccgtcgtgtggcatacgctgcgatttcatacagct
+gccaacaccttttttaccaggctagagtcagaaaagttggagccatgttaaatagttacc
+atcataaaccactgttgtctactagtctgatcagctttcatgcctgtgcaagcaatatgg
+attctcacgtaatggtaacaactgttgcgttacttaggctggttaatttgtcagagtaat
+aaatacatgtcttgttgtgtttcctaatcctcggaaagtacacaagcctaggaataggaa
+aagtaaagctcttttattctgatagtgactaactcaggatctaaatacgcgattatacta
+accttcaccaaagctcaaaaatcatctgctggtgaccagttatagacagggtaattcaat
+atttaatgtctcccttaacatttcaccagcatggattgaagatagtataaagttttacat
+ggcagtcattgtgtcacggttctatacaaattctgatagttagacggtatttgaaatgtg
+cttctagcatggtatcttacacaactgaatgaacgactggagccgttcgtatactatttg
+cgagcctcgagaccccgtttcctaatgttaacgaatatagtataatataaattgtgatat
+gaataacacaagtaactacagtttggacaattaattgttctaaactaaaaatcattcact
+tcagatggcatagagttatggctactacacatataaagcggtatgtgaaacacccgtttt
+agccggaaaccctctactgctcgggacaatgaatgatttccaaaatatggatgtgcagaa
+ttgttagtgtgactcaggtccaaatagacactttagtttcgtcaagtcgttgcaaagttt
+aaaaccatcgcagcattctttatttggtctacattgagaaatgaaaaaacgtgacagaaa
+gtctagaagaactgtgaataatgtctattactgattaactagtaagacattagtgcatct
+ggtccactgaagcacccgcttggcgttaggcaatctctgtgaactgtcgtggctgttccg
+gtaatgtacgaaagcaagcctataggttgatcgagtcgcttcattaaggtcaatttcaca
+atatccgatcacattgtgctaggttcgtcctttaccttgcttagtgctgcatgtacgggg
+tgtcatgacttgttatcggcagactctttatcccaagaatggataatatgtacatggaaa
+gtgtccataattaagtcccttcactgtaaagaatgactgccacgtgatccatgaggtcta
+cagaaaccgacttacttgctttttgatcaacttaattatggattcataaagttcagatat
+cggtacaattggtgtacaatatgaaattaatgaggaaacatggaaatctgaatgacagtg
+atagaaaagatccccatttgcccggtcagttcatgttacaccactcattagtactgtaag
+tgtttcgtcagcattgagatccacgatcatgtgtttatgccttcgaaactggatgtacga
+cgatcgagacgaagaggtatatataacctaaatactaggtacgttgttagagagacgatg
+aaaattaatcgtcaatacgctggcgaacactgagggggacccaatgctcttctcggtcta
+aaaaggaatgtgtcagaaattggtcagttcaaaagtagaccggatctttgcggagaacaa
+ttcacggaacgtagcgttgggaaatatcctttctaccacacatcggattttcgccctctc
+ccattatttattgtgttctcacatagaattattgtttagacatccctcgttgtatggaga
+gttgcccgagcgtaaaggcataatccatataccgccgggtgagtgacctgaaattgtttt
+tagttgggatttcgctatggattagcttacacgaagagattctaatggtactataggata
+attataatgctgcgtggcgcagtacaccgttacaaacgtcgttcgcatatgtggctaaca
+cggtgaaaatacctacatcgtatttgcaatttcggtcgtttcatagagcgcattgaatta
+ctcaaaaattatatatgttgattatttgattagactgcgtggaaagaaggggtactcaag
+ccatttgtaaaagctgcatctcgcttaagtttgagagcttacattagtctatttcagtct
+tctaggaaatgtctgtgtgagtggttgtcgtccataggtcactggcatatgcgattcatg
+acatgctaaactaagaaagtagattactattaccggcatgcctaatgcgattgcactgct
+atgaaggtgcggacgtcgcgcccatgtagccctgataataccaatacttacatttggtca
+gcaattctgacattatacctagcacccataaatttactcagacttgaggacaggctcttg
+gagtcgatcttctgtttgtatgcatgtgatcatatagatgaataagcgatgcgactagtt
+agggcatagtatagatctgtgtatacagttcagctgaacgtccgcgagtggaagtacagc
+tgagatctatcctaaaatgcaaccatatcgttcacacatgatatgaacccagggggaaac
+attgagttcagttaaattggcagcgaatcccccaagaagaaggcggagtgacgttgaacg
+ggcttatggtttttcagtacttcctccgtataagttgagcgaaatgtaaacagaataatc
+gttgtgttaacaacattaaaatcgcggaatatgatgagaatacacagtgtgagcatttca
+cttgtaaaatatctttggtagaacttactttgctttaaatatgttaaaccgatctaataa
+tctacaaaacggtagattttgcctagcacattgcgtccttctctattcagatagaggcaa
+tactcagaaggttttatccaaagcactgtgttgactaacctaagttttagtctaataatc
+atgattgattataggtgccgtggactacatgactcgtccacaaataatacttagcagatc
+agcaattggccaagcacccgacttttatttaatggttgtgcaatagtccagattcgtatt
+cgggactctttcaaataatagtttcctggcatctaagtaagaaaagctcataaggaagcg
+atattatgacacgctcttccgccgctgttttgaaacttgagtattgctcgtccgaaattg
+agggtcacttcaaaatttactgagaagacgaagatcgactaaagttaaaatgctagtcca
+cagttggtcaagttgaattcatccacgagttatatagctattttaatttatagtcgagtg
+tacaaaaaacatccacaataagatttatcttagaataacaacccccgtatcatcgaaatc
+ctccgttatggcctgactcctcgagcttatagcatttgtgctggcgctcttgccaggaac
+ttgctcgcgaggtggtgacgagtgagatgatcagtttcattatgatgatacgattttatc
+gcgactagttaatcatcatagcaagtaaaatttgaattatgtcattatcatgctccatta
+acaggttatttaattgatactgacgaaattttttcacaatgggttttctagaatttaata
+tcagtaattgaagccttcataggggtcctactagtatcctacacgacgcaggtccgcagt
+atcctggagggacgtgttactgattaaaagggtcaaaggaatgaaggctcacaatgttac
+ctgcttcaccatagtgagccgatgagttttacattagtactaaatcccaaatcatacttt
+acgatgaggcttgctagcgctaaagagaatacatacaccaccacatagaattgttagcga
+tgatatcaaatagactcctggaagtgtcagggggaaactgttcaatatttcgtccacagg
+actgaccaggcatggaaaagactgacgttggaaactataccatctcacgcccgacgcttc
+actaattgatgatccaaaaaatatagcccggattcctgattagcaaagggttcacagaga
+aagatattatcgacgtatatcccaaaaaacagacgtaatgtgcatcttcgaatcgggatg
+aatacttgtatcataaaaatgtgacctctagtatacaggttaatgttagtgatacacaat
+actcgtgggccatgggttctcaaataaaatgtaatattgcgtcgatcactcacccacgta
+tttggtctaattatgttttatttagtgacaatccaatagataaccggtcctattaagggc
+tatatttttagcgaccacgcgtttaaacaaaggattgtatgtagatggtaccagtttaat
+tgccagtgggcaatcctaagcaaaatgagattctatcctaaagtttgggcttgatataag
+atttcggatgtatgggttttataatcgttggagagctcaatcatgagctaatacatggat
+ttcgctacctcaccgagagaccttgcatgaagaattctaaccaaaagtttaataggccgg
+attggattgagttaattaagaccttgttcagtcatagtaaaaacccttaaattttaccga
+ttgacaaagtgagcagtcgcaataccctatgcgaaacgcctcgatagtgactaggtatac
+aaggtttttgagttcctttgaaatagttaactaatttaaaattaattaacgacatggaaa
+tcacagaacctaatgctttgtaggagttatttatgctgtttactgcctctacaaccctaa
+taaagcagtcctaagaatgaaacgcatcttttagttcagaaagtggtatccagggtggtc
+aatttaataaattcaacatcgggtctcaggatattcggtcatataatttattaagggctc
+ttcgagtcttactctgagtgaaattggaaacagtcatccttttcgttgtgaggcatctta
+caccgctatcgatatacaatgcattccaccgcggtgtcccgtacacaaggaaacttgtta
+ccttggggatataagaaaactcacacgtctcattattaaactgagtacaatttttgcacg
+agaaagtaatgcaatacaatatgatgaaagccagctaatgaaaagggatggaacgcacct
+cggatctgttgcactggattaaaatccgattatttttaaaaatattcagtgctagagcat
+atcaggtctacttttttatctggtatgtaaagcccacggagcgatagtgagatccttacg
+actcaacgaaaagttataacataactcccgttagccaaagcccaatcccgattactgccc
+taccctaacgtctgccatctaaatatcgaacttgttatgatcaatgtgactacctcccac
+cctttccccttcatttgttccactggggataagctagcgttttcagaatcaatgcaataa
+gaatagccaattgtctcacttcatcagagctcttggcaattccaggcgctacgtggttct
+ggaatatattcatttttcaaatagtaatacgtttagtgttgctattgtctacacgtttgg
+atattacgttatgtgagcggacatcaatagttgtctaactctttagtaagccagagatag
+cactcttagcgaatggataccatcttccataagtttagttaatagtccgaaacaactgct
+tcgagcatatttgaacctccttgtaggcaaatagcctcttcaaagcaatcttactaatag
+atagagtttgttttaagggactactagaaatgggacaatcttaatagtatgacctaaact
+gacatttaaagatatatccaggtggcaagcataaagatcattgcgccacctccaccgtgg
+gattacttatcagtcgatatcctatatgctaagtttgcgacggcagaatacaaactaagc
+tgagttgatgctaaccttacctatgataccccattggaccggttaacagccctacttatt
+ccaaataaaagaacttttatgctgtagaagctattatagtgatgcctggtaacttcagta
+tattaaaatgacacacatacgccatatagagctcctggaactttgaataatgagcgaact
+tcgaagttgaagagcaagaaaccatatgtcacggttgcctaaagcccggtaaccagacat
+gtgctatcattgatcattatcgaggttttcataaccttgacccattatcggctgtgcgcg
+gacaagtacttaaatcactagtttcttcacctgcttatcggtaagaaataaggttggcaa
+agaatcgcataagacggacgtagagccgcagcgttgtgcgagtccaggtgcatgcgcagc
+aataggattttaaattttgttccatttttaatttagccgtaaggatgtccgtaaatgatt
+gaaaattggattcaatctttgggcctatgctactggaacctgatcgacaaaatttcaaac
+atacgttaactccgaaagaccgtatttttgcggctagaatagtcagtcgcttggagccat
+ataccttaccacttaaacgacgtgctcctgtagttgaaatataaacagaacacaaagact
+accgatcatatcaactgaagatctttgtaactttgaggcgaagcaccctcttcgagacaa
+ctaagagtaaagtaccgggcgccgcaaggagtcgattgggaccctaaatcttgacgaatt
+gctaagaggctcagagctaccactgtaatttctctagagcccataataaatgaacgatac
+atccgtaggtagcacctaagggattataatggaagccaaatgcagttaataatattatat
+actggcgtacacgattcgacggatctctcacatagtgattcacgacccccccctttgatt
+gacacagcgtcagcattttgcaagaacgatcttctgcatagggtgcgccaccgtaaggat
+gacgtcgaagctacaactgggtataatttaccatgcttccctgatgctgagtgcaataca
+ctaagaatgagtttttaccccatatcaccagtatttgttctgttattgcgaagaaatggc
+tatgctgagttggcgactaaagtcacccatcctttttattaggtaaccccctcccttaaa
+ctaactgatttgctggagctgccctgcatacatatactttatcatttatggacgtccgtg
+acgcttattatccaccatagtcgatatgctacacggattcattaatggatcgtaggagtt
+taagttatatttactaagatcggtctcggctactatcccgccttacccggcgctatttac
+ggccatttttaatatattgacggtaattattcctatggtttcgaccgcacgtccttggac
+aagaaagaatggcaaaaaaaatgtaaaagaaaaaaaatattgagtccctaccatcatata
+aaaaatatgtgatgagtaacttgacgaaatgttagtggttattaaagactatctattaca
+ccttttgttttctgtcgtagtatattaaagtctagaagccttacaggaaaatcagggtta
+tacagccgatactccgcagcatgaatcatcgaggaggtgtcctaccatcgcgccttgtaa
+tcttgtctgtgtatactgtatttagaccttttatacaaagtaaatatctcggctttatgt
+gattgggaggggcctactcaaacatgatgacttgacctaataatcactgtgcgggcgtct
+tatgactagctattccttgaaatccaccaccaaatggttaatatgtaaaaactttgacga
+tgaaacaaggtgaatgtgtagttactttgtgtaattagctgcgtcgagcattgcttgtaa
+aaccgtcaatcgcacacgttacttccataaaatttctacgaatacacccttcttaaaaaa
+aacgtaggaattcacgagtttaacaaacgataactgtataaagtggaagtccgaagaaag
+cagatgcccgaactactcgaagatgtttcgttttcttaaccataggggcttcttaatggc
+ccactacgcacattttgttcaagcccgagagggacatccccattacgggagtattactaa
+aactgttccgtaatacgttcagcaagggatgaaaaaggccactgctcaagttattgacgt
+gggagtattacatcggaagcctgaatcccacactatgatggtctgtacaggcctagggac
+tgcgtctagacggtattaccggcttctaatcatacgatcgtgagtcttaacgggaagtaa
+ggctcacacctaccccaaaccatttatctatgtaagtataaaattgtgcgtaagtgttca
+aagtggacaataaagacgtggcaaaaacccccgcacataagccgctttagatttcacaaa
+taccaatgcggttaaaaacatccttgagtcgtacatacaccatactcgcgttaaacggat
+ataacagaagataataaatccggatgtggagtcggtgtaactatagaaagccaagtgaaa
+taatgcttaccagtcatttagctatacggctttcatttcatgtcaagagggtggagtttg
+acctgtacagttgatatatcaccgatacttagaactcacctaaagctaaaattgctcgca
+gcgtgtaatccgcatattacaaacaatagatgggattcattatacataagacacgatgat
+ctgctttttcaggttgcgagatgttgcctatcgtcaatcgagtcctgccttacaccactt
+aaacaaaagtattgacagggaacctattttcgaggtattatatagtccagcttgaatatc
+aatttgacagttaacctagtgaaaatcagtaagaggaaatacgccacattctccagtgaa
+attctacgggttatcgtctagtccaactatcaattataactcacgagatataagtaaatt
+ctcgtacttggcctgatttttattatactttggatccttagtaaacaggaagggagaaac
+cttcaacgaaaaacactggattttgttttactctcaaagctcttatatgacggaaatacc
+ctgtcaagtcttaactttattactagactaatgaaatgggcttggggtggccagaatcat
+agtacaatttagcggatacactattcggactttcctatcggctgtctggttggataagta
+tggggactaataggctagacatacctatacttaaactatacaggcgtcatctatctctgc
+aactttggagttccctgatgttctcccgccctttgggttcacatcttctataccgacacc
+cctaataacgattagtttgtgggttagagtaaattaatacggttaatattaatgtatcgt
+tgaaaagctggtgtcgccaataaggtaaccggctaggcagagtatatgtcacgaagtata
+actaccctaatgataagctgtaggaataaaattaatgctgtctctaagcgaagagatatt
+tccgactctgttttaatgacgaatctcattacttctgacttgcaaatgttcaatatggca
+cggtttcacggcacctttgtgacgcatataatgaacttagaagattataacgacggaact
+ttatatgataatccgttacgattaaagaatctgttaaatatcataatggcattcagttct
+agaccgtgcatcatggtaaacttactttctctgcatggcgacatacatttcgctattcaa
+attcgcgtgtggttacacccactcgcacctttggaatattaagagaagatgatcagaaaa
+tccattcgctcaatttttctgacgtacgtctaatttatcctaggagacaaatcgttttat
+gtctctcacatttttgaagaaaggttcgagagacaatactcaggtcctgaactgctagaa
+gatactcggtggagcgtggcaacaatgaaaaactcgtgacataaatgaatgatacttttc
+caagttcagttaagtgaatatgtttaacatacccggcttttcgatcttaagctgacgctg
+gacgtgcgagtaatgtcagtctcttacatacactagtgactccaagtttcgtcaaaaacg
+ccccctcccttctcgagcccactcacgctatgtattgacgcgaacttgttcgggatcaga
+cttttcaggagttcggtcgcgtgtccctatgtgctaatatataagttagatcgcattaga
+tgctaatctgaatacttatagacgaccttcaacgagaacgggtaccaccttgaggctaga
+gttaggtgtgaaacgacaggtagggacatataaaatttgagtgcggctttagttaagggt
+ttaattacctactcaaacatcacgctcgcgcccttcgtacgtaatcgaccatctagaggc
+taaggggactgtactaggtagtgattaatgatatcctagacgcacgtgccttagatcttc
+agactctgatggtccgcgatcaccgtaattgtagtcctccaactcgatcactttgttggc
+gtcaaagaaattacgatatctaaatacttataatacaataaccaaggatgagaatgactc
+atcgcgttggagttatattgcttgaagttctatggaatgaaagcacgttatctgccgtcc
+caatatctccagtgagctaattcattggacggtccactttgatcaatccccgaggagatg
+ttcggacactttagtctgtaacacttagcgttgagaccacgaacaattgattactcagtc
+ttgaaggtgttttccaaagttcattttaaataagactacgataggcctttcctattgata
+taaactacccggctctgttgttcgtgtgagtcgtacttctctgtgtttttctgattatag
+caagattcgattcttagtgtaaacagcgatttttatttgacccgtcaatgagaagcgcat
+aggatctaagcaaaattatcaagttgtgccacaaggtaagatctttccagttattgcagg
+taggatgtatcccacgttgatagtatgaggtctgacgtcaactgtctaggagagttgacc
+gcgtgcgggtacaccggatttgcatcgatgttgagaacgcagaactcccactgtcgtggc
+ggcgttcctgatatttagcaagaggcgttgataaagccctcatcatctagatctcgacct
+catctgccctcttgctccatcattttctacacagactactttcctatctacgttagtata
+attgctttctatcttagtatcatttagagcttctccgtcaacaggttcgtgctattaaag
+ttagtacgaaagggacaacttgtagcaacgcatttaatcggttttcgactacttcgcaca
+aaatcagataaagaagtttgtcattctattagacattgaattgcgcaattgacttgtacc
+acttatgatcgaacactgaatcaagactgtgattaactaaaatagacaagccactatatc
+aactaataaaaacgcccctggtggtcgaacatagttgactacaggataattaattggact
+ggagccattacattctctacaatcgtatcacttcccaagtagacaactttgaccttgtag
+tttcatgtacaaaaaaatgctttcgcaggagcacattggtagttcaatagtttcatggga
+acctcttgagccgtcttctgtgggtgtgttcggatagtaggtactgataaagtcgtgtcg
+ctttcgatgagagggaattcaccggaaaacaccttggttaacaggatagtctatgtaaac
+ttcgagacatgtttaagagttaccagcttaatccacggtgctctactagtatcatcagct
+gtcttgcctcgcctagaaatatgcattctatcgttatcctatcaacggttgccgtactga
+gcagccttattgtggaagagtaatatataaatgtagtcttgtctttacgaagcagacgta
+agtaataatgacttggaataccaaaactaaacatagtggattatcatactcaagaactct
+ccagataaataacagtttttacgatacgtcaccaatgagcttaaagattaggatcctcaa
+aactgatacaaacgctaattcatttgttattggatccagtatcagttaaactgaatggag
+tgaagattgtagaatgttgttctggcctcgcatggggtctaggtgatatacaatttctca
+tacttacacggtagtggaaatctgattctagcttcgtagctgactatactcaaggaacca
+ctgctcaaggtaggagactagttccgaccctacagtcaaagtggccgaagcttaaactat
+agactagttgttaaatgctgatttcaagatatcatctatatacagtttggacaattatgt
+gtgcgaaactaaaattcatgctattcagatggatttcacttatgccttagaaacagatat
+tgcccgagctcaatcaacagttttagccggaaacaatcgaagcatagggacaatgtatct
+tttcctaaattgccatgtgcagatttctgagtgtcacgaagcgcataatagaatcttgtg
+ttgcctcaactcgttgaaaagtttaaaacaatcgcagcagtctttttggggtctactgtg
+tgtttgcaaaataactgaaagaaacgcttgaacaactctgaagtagctcgagtactcatt
+aaagtgtaacacattagtgaatatcggccaatgaaccaaacgcttcccggtacgctatct
+ctctcatcgggaggcgatgtgcaggttatctacgaaagcatccctttacgttgagagtgt
+cgatgcatgaacctcattgtaacaatagcccagcaaattctcatacgtgcctcagggtcc
+gggcgtactcctccatggaagggcgcgcatctagtgttataccaactcgctttttaacta
+ctatgctgtagttctacaggcatagtggccagtattttctaacttctctggatagatgct
+ctcactcctcatccatcacggcttcagtttacgtcttacttgcttgttcagcaacggatg
+gaggcattaagtatcttcactgttccctaaaattgctgttcaatatcaaagtaaggacga
+tacagggaaagctcaagcacactcattgaatactgccccagttgcaacctcacttaatct
+gacaaaaataatgactactctaagtgttgcggaagcagtctcttccacgagcttgtctgt
+atcacttcgtataggcatgtaactcgatagacacgaacaccgagtgagaaactatattct
+tgcttccgtgtgtgtgacaccaggtaattgatgcggatataagctggagatcactcacgc
+ccacacaaggcgctgctacctctttattccaatgtgtaagaatttgctaacttcatttct
+agaccgcagctttgcggtcataatttcacggtacggacccttgggttagagacttgataa
+cacacttcgcagtttccaccgcgcacatgttttagtggcttctaacatagaatttttgtt
+gtgacataaagagtgcgtgggagacttgcccgaccgttaagccataatcaattgaaagcc
+ccgtgagtcacatctaattggttgtactgcgcatttagctatcctttagctgactcgaag
+agattcgattcctaatataggttaattagatggctgccgcgcgaagtaaaacgtgaaaaa
+cgtagtgcgcagatctgcataactcgcgcttaattacttatgagtagttccaagttcgct
+acgttatgagagagattggaattaagcaaatatgttttatggtgattttgggatgagaag
+gactgctaagtacggctactaaacaaatttctaaaaccgccatctaccttatcttggaga
+catttaagttgtatatgtcactagtctagcttttgtctgtgggacgcgttctcggaatga
+gggaaatgcaagagccgattcatcaaatgcttatctaagaaagtagtggactattacacc
+aagcacgaatgccagggaactgctttcttgctcaggacctcgcgacaaggtaccccgcat
+aagtcctagaattacatttggtcagcaatgctgacatttgaccgtgaaaacataatttta
+atcagaaggcagctcacccgcttgctctagatcttatctttgtatgaatgtcagaattta
+ctgcaatatccgttccgaatagtgagggcttagtatagttctctgtatacaggtcacatc
+aaactccccctgtcctagtacagctctgagctttaattaattgcatacatttccttcaat
+catcagatgaaaacaccgcgaatcatgctcttctcgtatagggcaagagaagcaacaaac
+aactagcccgactcacgttcatccgccgtatccttgttcagttcttactccgtattaggt
+cagcgaaatctaatcagaataatcggtcgcgtatcaaaattaaaatcccgcttgaggttg
+acaattaaaacgctgagcagttatcggctattagatagtggggtgaaagtaattggctgg
+aattatgttaaaacgtgatattaagctaaaatacgctacttgttgccgacctaattcagt
+cattcgatattcagttagagccaagaataacaagcttgtataaattgaacggggtgcact
+aaacgatgtgttactctaatattcagcttggagtatacctgaaggcgaattcatgtatcg
+gccaataataagacgttgaagatcacaatttggactagcaaaagaaggtgatttatgcgt
+ggggattgagtccactgtacgagtacggtctctggaaaattataggttcagggaatataa
+ggaagtaaagataattaccaagagatttttggtatcgctatgacccagaggtgttctaac
+gtctgttttgatccgcagaatttctgcctcaatgcatatttgacggacttgaactagagc
+ctctaaagttaaatggcgacgcaactgttcctaaacttcaattattactactcttttttt
+cctagggtattgtagaggccagtggacaaaataaatcaaatttaagatgtttcggacatt
+aacatcccccgtagcatagaaatcatcagttatccaatctctcatcgagcttttacaatt
+tctgctggcgctatggacagcatatgccgcgagacctccgcaagactcacttgatcactg
+taagtatcttcattagaggttagagcctatagttaagctgctgacctagtaaaattggta
+ttttctaattttattgctcaagttaaaggttagtgaagggataatgacgttatttttgaa
+caatgggttgtattcaattttatatcacgaatggaacccttcattcccggcataatacta
+gacgacacgaacaagctccgatctatcagccaggcacgtgttaaggtttaattccggcaa
+accaatgaagcatcaaaaggtgacctgatgcaacttagggtcacgatgagtttttcagga
+ctacttattacctattaataagttaacatgagccttcataccccgtaagacaatacatac
+tccaccaattagaattctgagccatcttatctttttgtatcatcgaagggtatggccgaa
+taggttaattagttactcctaacgtctctacaggcatgcatttgacgcaccttcgaaaat
+agtcaatctctcgccacacgcgtctagtatgcagcatcaaaaatatagtccacggtttcc
+ggattaccaaacgcggcaaagagaaacattgtatcgacggagataacttaatacagaagg
+aaggggcatcttcgaatacggatgaataattctatctgtttattctgacatcttgttttc
+aggttaatcttacgcattcaaatgacgcctgccccatgcgtgcgcaattattttctaata
+ttgacgagagcaatctcactccttttgggtctatttatgttttattgaggcacaagccta
+tacagaacaggtactattaaggccgtgagtgtgagactcaaaccgtggaaacaaaggatg
+ggttgttcttggtacaagttttagtgcatgtgggcaatccttaccaaaatcagatgctat
+ccttaactttgggctgcatttaagatggcggttggaggcctgtgagaatcctgcgtgtca
+tctttaatgaccgaattcatccatgtagattcagatcacacactcattccttgatgttgt
+ctaaacaaaagttgttgtggacgcattggagggagttaagtaacaacttgggatcgcata
+cttataaaaattatatgttaaactttcacaaacgctgaagtccaaagtaactagcccaaa
+cgcctcgagagtcactaggtattaatggtgtttgagttcctgtgaaatagtgttcgaagg
+taaaatttatgtaccaaatcgaaagaacacttaataaggcttgcttgcacggaggtatga
+tgtttactgactctacaaccctaattttccagtacgtacattcattccaataggttagtt
+ctcaaagtgctatacaggctcctcaattgatgatatgcttcagccgctctatggatatta
+gctcattttatttaggaagcccgcttagaggcttactatgagggaaatgccaaaatgtca
+tacttttcggtgtgtcccatatgacaccgctttacatagaatttgaattaaaacgcgctc
+tcccgttcactaccatacttggtaccgtgcgcatattacatatagatataggatcatttt
+ttaaagctgtactaggtttgatcgacaatcttatgctatactatatgatgtaaccctcat
+aatcaataccgatcgtacgatcctagcataggtggcaagcgattttatgccgattattgt
+gttaaatagtctgtgagtgtgattatcagggctacgttggtagaggggttgtatagacct
+cgcacacattgtgacatacttaacaatatacgaaaactgatataataaatccccttaccc
+aaacaccaatcccgttgaatcaactaccataacgtctcccatataaattgcctacttgtt
+tgcataaatctgaatacataacaccattgcaccttcttgtgttccaatcccgttaagatt
+gccttgtcagatgatatgcaagaacaatagcatttgctagcaattattaacagctcttcg
+aattgcctccacataacgcgggagggtatattttaatttggcaaatactaagtactgttg
+gcgtcatatgctattaacggttggatattaagttatgtcagccgtaagcaagagtgggcg
+aaatattttgttacccagtgagagcactcttagagtttggatacaataggccatatgttg
+acttaagaggacgtaactacgccgtacaccattgttcaaccgacttcttggcaaatagaa
+tcgtattagcaatcttaagaatagagacacgttcgtgttagggtatactacaaatccgaa
+aatcttaagaggatcacctaaactgaaatttatacatatttcaacgtggatagatttaac
+ataattcagccacctccaacctgggagtaattttcagtagatttactagatgattagtgg
+cccaacgcacttgactatataagatctggggatcctaacctgacctatgagacaaaattg
+gaaacgttaacagcccttatgtgtacaaagaaaagtaagttgttgctgttcaacagatga
+tagtcatgacgcgtaacttcactatagtaaattgaaacaaatacgcaatttagacagaat
+ggtacggtcatgaatgacagtaattcgaagtgctagaccaacttaaaataggtaaacgtg
+cccgaaaccccccttaacagaaagctgctatcatggtgcagtatcgacgtgttcagaaac
+ttgtaacttttgagcaggtccgagcacatggaagtatatcacgtgtttctgaaccggctt
+atccctaagatatatccgtcgcaaactttcgatttagtcccacgtagagcccaagcgttg
+tgcgactccacgtgcatgcccagaaatacgagtttaaatttggttacatggttaattttg
+accgaagcatcgcactttatgattgataattggattcaatatgtcgccctatgcgaatgc
+aacatgatccacaatttggctataagacgtttaatccgtatcacactttgtttgcggcta
+gtatagtaacgcccgtgcaccaagagtcagtaacaattataagtactccgcaggtacttc
+aaatataaaaactaatcaaacacgacccatatgatcatctgaagatatttggaactttct
+cgacaaccaccctcgtactcaatacttacactaatcgacaggcacacgcaacgtgtacag
+tcgcaccatattgagtcaagatttgcttagtggcgatgagcgtacacgcttatttctcta
+gtcacaattagttatctacgagacatcacgagggagcaaataagcgatgttatggctaca
+cataggcacgtatgaatatgatataagccagttaaacagtcgaaccatcgagcaaattct
+catgcaccaacccacacgttgaggcacaaagagtaagctgtttgaatgtaacttcttctg
+ctgagcgggccccaacgtaaggatcaactagaagagaaaactcggtattagtttaaatgc
+gtcacggagcatgagtgcatttcactaagaatgtctgtgtaaccaatataacatctattt
+gttatctgattgcctacttatggctttgcggtcgtggcgactaatgtctccaatcctttt
+gaggtcggtaccaactccctttaaattacgctgtgcaggctcatgcactgcatacatata
+cggtagcaggtagggacctcacgcacccttattataatcaatagtagttatcagtcaacg
+aggcaggaatgctgaggtcgaggtgttggtatattttctatgtgccgtctaggcgactat
+cacgcattaccaggcgagatttaagccaattttgaatatagtcaacgtaatttttactat
+gggttccaccgaaacgccttgcacaactaagaatcccataaaatatcgatatcaaataaa
+agattgtgtcaataccttcatatatattttttcggttgactaacgtgaactaaggttagg
+ggttttgtatgtctatataggaaacagtttcttttctgtcctactttagtaaagtcttca
+agccttactccaaaatcacggtgattaagccgttactcagcagcatgattctgcctgctc
+gggtcctaaaatccagccttgtaagagtcgctgtgtattagctagggagacctttgttaa
+aaaggatatatcgcggcgggatgtgagtgcgtggcgcatactcaatcttcagctcgtgtc
+attataatatctctcccccacgcttttcactagatatgccgtgtaagcaaacaccttatg
+cttaatttcgaaaatattggtacttgaaaaaagctgtaggggtacttaatgtctggtagg
+agatcaggagagaattgagtgtaaaaccgtaaagccctcacctgacttcatgtaaatggc
+ttagaagactccatgatttaataaatactacgaaggaaagactggatctaaagataactc
+tagtaaggccaactcccttcaatgctgttgccagttataatccaagagctgtccttttct
+gaaccatagcggcttctgaagcgaactagaagcaaagttggttctagccagacagccaca
+taccctgtacgggtgtattactaaaactggtccggtattagttcaccaagggaggaatta
+ggcaaaggatctaggtatgcaagtcggagtattacatccctaccctgaatccatcaatag
+gttcctctgtactggccttcgcaatgagtattcaaggttgtacagccgtataataataag
+atagtgactatgaacgggaagtaacccgctcaccttccccaaaacattgttatatctaag
+tattaaagtctgccgtagtgttaatactcgaaaataaacaactggcaaattacaccgcac
+ttaagccgcttttgatttatatttttccaatgcgcttttaaaaataattcagtcctacat
+actaattaagacccttaaacggagatatcacaagttaagttttaaccatctcgactaggt
+ggaactatagatacccaactcaatttatcattacctgtaatgttcctagaaggattgcat
+ttcatgtcaagacggtggagtttcacagcgaaacttcagtgtgaacagattctgagaaat
+cacctaaacctattagtcagagcacccggttagaaccagttgtcaaaaaatagagcggtt
+gcatgagacagaagtaacgatgagatccgttgtaacgttgagacatctggcctatcgtca
+atacagtcctcccttaaaaatatttttaaatactaggcaaacccaacataggttagtcct
+atgtgatacgccacatggtatatcattttgtaacgttacctagggataatcaggaagtgg
+aattacgcaaaagtagacagtgaaatgcttagggttatagtctagtccaaagataaagga
+taaagcacgtcagagaactatattagccgaatgggaatcattgttaggagactgtggatc
+atgtctaaaaagcaacgcagaaacagtcatcgaaaaaatctcgtttttgtttgaatctaa
+aagagctttgatgaccgatagtacctgtatactagttactgtattacgtgtctaatgatt
+tcggattggggtccccagaatcagacgtcattgtagacgattcaagtttaccaatttaat
+ttcccagctctccttggagaactatcgccaataattgcagtcactttccttttctgaaac
+gataaagccgtcagagttctctgcaacgttggacttacctgaggttctaacccactttcg
+gttctaatagtagttaacgacacaacgaataacctttactgtggggctttcacgatattt
+tttcgcttattattaatggttacgtcataagctggtgtccaaattaaggttaccggcttc
+gcagagtagttgtatccaagtataacttccctaatcataagatcgaggtagaaaattaat
+gctgtctctaaccgaacagatatgtcccactatgtggtatggacgttgctaattacttct
+gaagggaaattggtcattatggatacgtgtctaccatcaggtcggacgcagatatggttc
+tgtcttcagttgatccaccgttctttataggataataactgacgattaaagattatggta
+aatagattaagccaattctcttcttgtcagtgaagcatccttaactgacttgctctgcag
+cccctcatacatttagctattcaaagtaccggctcgtttcaaactctcccacctttggaa
+gaggttgtcaacttgataagtatatcatttacagcattttttcggacgtacctctaatgt
+ttcattgcagaaaattagttttttctatcgcacattttgcaagtaacgttagagacacaa
+ttatctgcgaatgaactgctagatctgacgaccgggagcctcgcaaatatcaaaaaagac
+tgacatatatcaaggagtcgttgacaagtgctggtaagtcaattggtttatctgtcccgg
+cgtttcgatcttaagctgaccatgcacggcagagtaatgtcactctcgttcttacaagtc
+tgtctccaagggtcggcaaaaaagacccctccattctcgagcccactcacgatatgtagg
+gacgacaacttgtgcggcttatgaattgtctggactgcgggcgagggtccatatctccga
+agttagaagggacatacctttagatgataagatcaattcttattgacgaaattcatccac
+aacggggaacaacttcaccctagacttacgtctgaaaagacacctagcgtcttataaaag
+gtcagtgccccgtttcgtaaggctggaattacctacgcaaacttaaacctcgcgcccttc
+cttacgtatcgacaagatagaggctatcgcgaatgtactacggaggcatgaatcatatac
+tagaaccaagtgcctgtgatattaacaagatgatccgacgcgagcaccgtaattctaggc
+ataaaactccagcaatttgggggccgaaaacaaatgacgttagctaattaattatatgac
+atgatcaaaggaggtcaatcacgcatcgagttcgacgtatattcattgaacttcgtgcgt
+ttgaaagaaacttttatgaaggcaaaattgatcctgtctcctatttcatgcgtacctcct
+agttgataattccccgagcagtggttaggacacttttgtcggtatcaagttccggtctca
+aaacgtaaaattctgtaatctgtatggatggtctgtgaattagttaatttttatgaagtc
+gtcgagacgcagttcctattgatttattctaaacggagatgtgcttcgtgggactcggaa
+gtagatctgtgtttatgattattgctactttagatgctgactgttaactccgtgttgttt
+ttcaaccgtatatcacaaccgaattggatagaacctatagtttcaagttctgccacaagg
+tatcatatttacagttagtgctggttgcttctttcaaacgtggtgagtttgtgctatcac
+gtcaacggtagagctcagtggaccgagtgcgcgttcaaccctgttccagagagggtgtga
+tagcacatataccacgctcgtcgaggcgttcatgatagtttgcaagagccggtgttaaac
+acatattattattgttatccaactaatcggacctatgcataaagcattgtctaaacagaa
+taattgcctatatacggtagttttagtgatttatatcttagtatcagttagagcttcgaa
+ctcttcaggttcctcatatttaacgttcttcgaaagcgaaaacttctacaaacgaatgta
+agcggttttccaagtagtacctataaatcacagaaagatctgtctcagtatagttgaaat
+ggtattcagctagtgacgtgtaccaattatcatagttcactcaagcaagacgctcattaa
+cgaatatagacaagacactatatcatataataaaaaagaacatggtgctcgaacatagtt
+gaattcaccatattgaaggggaatgctgacatgtaattcgctactagacgatcaattccc
+tacttgtcaaagttgaactggtacgttcttggaattaaatatgattgcgctggaccaaat
+tgcgacttcttgagtttcagggcaaacgattgagccggaggatgtccgtctcttaccttt
+cttgcttatgataaacgacggtccctgtacatcactgggaattctcagcaaaaataattg
+ggtaaatcgagactcgatgtattcggccacaaaggtgttagacgttaaagattattcaac
+ggggcgataataggatcataaccggtatgcaagcgcattgaaagagccatgagatcctta
+tccgataaacgctgcacggtatgtgcagccttattgtcgatcacgaatttataaatgtag
+tctgggctgtaagttgaagacctaagttataatgaagtgcaataccaaatcgattcatag
+tggattatcagactcaagatatctcctgataaattacagttgttaagatacggataaaat
+gagatttaagattagcagcctctaatctgtttcaatcccgttggaatgtggtatgcgatc
+aaggttaagttaaaatcaagcctgtcttcagtcttgattcttgttctgccatcgcatgcg
+gtctacgtgagttaatatgtagcttacgttctagcttgtgctaatctgagtatagattcg
+tagaggaatattatcaagcttccacgcctcaacgtacgtgtattggtcacacaagacact
+aaaagtggaagtagcgtaaactatagtctagttgttaaatgctcagttcttgttatattc
+gatatactcttggctaatttatgtctgagtatataaaattaatgatattaacttgcattt
+cacggatcccttagaaaaagattttgaccgagcgcattataaacggttacaccgaatcaa
+tagaagcatacccaatagctttctttgaatttattgcctgcgcaacttggctgactctct
+agatccgaataattctatatggtcgtgacgaaactagttcattactgtttaaaatgccaa
+catgtcttttgggccgataatggctctttgcaaaattactcaatgatacgattgatcaaa
+gcggtagttgctagtggtagcatgtaagtctatcaaatgtctgattatccgaaaatcttc
+caaaagagtccacgtaccatatctatctcatagcgacgcgaggggaaccttatctaacta
+tcattccatttaccgggtgactctcgatgcaggatccgattgggataaattgcccagaaa
+tggctcattcctgactaagggtaaggccgttctcagcaagggaaccccgcgaatctaggc
+ttataccatctagattgttaactacttgcctgtagttctacagccatactggacagttgt
+ttctaaatgatcgggattcatgctagcactcctctgaatgcaccgcgtaagtttaactat
+tacgtccgtgggcagataaggatggaggctgtatgtatcttaactgttacctaatatggc
+tggtaattatcaaagtaaggaccttaatgccatagcgctagcaatcgctttgtatactga
+ccatgtgccaacctctcttaatctgtaaaatataatgtcttagctaactgtggacgatca
+tgtctctgcctagagcttcgctgtatcaattcctatagccagcgtactagtgacacaaca
+acaccgtgtgagaaaagatattagtccttacgtctgtctctctacagcttattgatgagg
+attgaacatggacatatagctccccctcaaaagcagatgctacctctttattccattctc
+gaacatttgccgaacttaatttcgacaaacctgaggtcacgtcttaatttatcggtaacg
+tcacgtccctttgagactggataaatatattaccaggggccaacgagcaattgttggagg
+cgcttctataatacaaggtgtcttgtcaaagaaagacggcgtgcgtctcgtgcaactcac
+ttaaccaatattaatgtgaaacccccctctctcacatcttatgcggtgtactgccctggt
+acatttcctgtacaggactccaacagtgtagattcctaagatagctgttggagttgcctc
+acgccagatcgaaaaactgaataaactagtgagctgagctgcagaaataccgcttaatta
+cttatgactagttcaaagggacctacgtgatgtcagacattgcaaggaagaaattaggtt
+tgtgcgtcattttggctggactagcactccttacttcccctactattcaaatgtcgtaaa
+cagcatgagacaggatcgtgctgacatttaaggtctattgggaacgaggctacctttggt
+cgcgcgctcgcgttctccgaatgaccgaaatgcatgagcacagtatgcaattgcttatag
+atctaaggtctggtcgttgaaaccaagcacgtaggcctgggaaatcagttcttcctcagc
+aactacacaaaagcgtccaagcattagtacttgtagtaaatgtccgaacctatgcgctca
+tttgaaagtcaaaaaatatttttaagcagtaggcacctaacccgattcctctacttagta
+gctttctttgattctcagaattgactgcaatatcactgcacaattctgtgccattactag
+acttctctgtattaacgtctcatcttactaacactcgcctaggacacatctgagagtgaa
+gtatttcaatacatttactgaaatcttcagttctaaaatccccgaataaggctcttatcg
+gtttggccaacacaagaaaaaaacttcttgcaccactcaccttcatacgcaggagcctgg
+ggaacttagtaataactatttcggcagacaaagcttataacaagttgccggcgcgtataa
+tatttaaaagaccccttgagctgctcaattaaaacgctcacctggtataggctattagat
+agtgccgtcttagtaaggggcgggaattatcggataaactgatattttgataaaataacc
+gacttgttcacgacataagtcactaaggagattttatctttctccaaagtatatcttcct
+tggataatttcaaagcgctgcaatttaagttctgttactagtttatgctgctgggaggtg
+accggaaggcgtagtaatctagaggcaaattataagaagttcatcatatcattttcgact
+acaaaaacaaggtgttgtatgccggcgcattgtgtaaactggacgagtaccctagatgga
+aaattatacgttaagccaagatttcgatgtaatgataattacctacacatttttgctatc
+cataggaacaagagctgttctataggctcgtggcatacgaacatttgctgccgctatgaa
+tattggaagctcttcaactacagactctattcttaattgccgtcgaaaatgggccgaatc
+ggctattattaatactcggtttttccgaggggattgttgtcgacagtcgtaattattatt
+aatattgatgttggtgaggtcatttaaatacaaccttgcagacaatgaataagggatcca
+atctctcatactccttttacaattgctcatgcccctatgcaaaccttatgccgccacacc
+tccgcaactctctcttctgaactgtaagtagcttcattactggtttgagactatactgaa
+gctgatgacattctaaaatggctattttcgaatgtgattcataatgtttatcgtttggga
+tggcagaatcacgttatttttgatatagcccgggtattctattgtatagaacgtatgcta
+caagtcattccccgaagaagactagaagtaaacaacatgcgaccatcgttaagccacgca
+aggctgtagctttatttcccgataacctatcttccataaatagcggacagcaggatactg
+acgctcaacatcagtggttatggtctaatttttaacttttaataaggtaacttcagcagg
+catacacagtaactctttaatttataatcaaattagaagtctgacacttcttatattttt
+ctatcatccaacgcgatcgcccattagcttattgtgttactaataacgtatctaaaccaa
+tccttttcaagctactgcctatattgtcaatatatacaaacaacaggatagtaggctgct
+taaaaaatattgtcaaccgtgtacgctttacaatacccggaaatcacaaactttgtagac
+aacgagtgaaatttatacactacgaagggccagcgtacaagacccatgaattaggcgata
+tgtttattctgacatattggtttatccttaatctgtcgctgtaaaatgaagccgccccca
+tccctgcgaattttttttcgaagattcacgactgaaatataaatacgtttggctatattt
+atgttggagggaggcaatagcctttactgttaaccgaagatttagccagtgagtgtgaca
+ctaaaacactggaataaatgcaggcgttcttctgggtaaaaggtttagtcaatctcgcct
+ataagttcatatagctctggatataattatctggcccatgcatttatcatggcgcttggt
+gccctgtgtgaagccggcctctcatattgaaggtccgaagtattccatgtacattaagat
+cactctctcattcatgcatcttggcttaacaaatctggttgtccaagctttccaggcacg
+tatggtacaaattcggatcgaatacttataaaaatgatatgttaaactgtctaaaacgct
+catctacaaagtaaagtgcactaaccaatagagtctcaagaccgtgtaatgctggtgcac
+tgaatgtgtaatacggttagaagggattagttatgttacaaatccattgaaaacttaaga
+agcattgcgtgctcggagggtgcatcttttatcaagagactaacattattttcaacgacg
+tacatgctttacaatagggtacttatcaaacgccgagaaacgcgcctatagtgatgttat
+gattatgacccgatatccattggaccgaattttatgtaggttcccagcgtactcgcgtaa
+tatctcggtattgccataatgtaatacttgtcggtctctcccagatgaaaaagcgttaca
+gagtatttcaatgaaaaacagcgcgcaacgtcaatacctttaggggtaacggccgctgat
+ttcatatagatatacgataagttggtatagctctactaggtggcatccacaatcgttgca
+tttactatagctggttacaatcataatctataccgttccttacatactaccatagcggga
+tagcgtttttttgccgttgattgggtttaagaggatgtcagtctcattatatccgattcg
+gtgggagagccgttgttttcaaatcgcacactttgtgacataatgtacaagataacaaaa
+ctgatataagatataaactgtcaatatcaccttgacacttgaatcaaagtaaattaactc
+gcaaatataatttgactaattgggtgcagatttctcaattaataaaaaaatggcaccgga
+tgggcttacaagccccttatcattcacttgtatcatgatttccaagaacaatagaatttg
+ctagcaagtatgaacagagattcgaattgcatccacagtacgccggagcgtttattttaa
+tgtggatatgacgatgtactgttggcggcatttgctagtaaccggtccttatttacgtag
+cgcacacgtaagcatgtctgggagaaatatggtggtacaatctcagagaaagattacagt
+ttggtttaaataggacttatcgggtcggaagtggaacttaataagcagtacacaattggg
+caacagacgtcttgcctattacaataggattacaatgcgttagatttcagacacgttcgt
+gtttggctattcgtcaattccctaaatagttagacgatcaactattatcaaagtgattct
+ttgttcatcctccattcatgtaacagatggcacactacgcataacgccgaggaattttaa
+cgagatttaagagagcagttcgggcacaacccacttgactttataacagctcggcagcat
+aaacggtaatatgtgacaaatttccaaacgttataagaacgtatgtgtacttagaaaact
+aagtggttcatgttcaacagatgtgacgcagcaagcctaacttatctattggttttgcta
+taaaagaacaaagttacacagaatcctaagggcttgtttcacacttatgcctagtgcttc
+accatcttaaaatagcgaaaccggcacgaatcaaaccttaaaacaatgcgcagatattgg
+tgatggtgactccgggtatgataatggtaactgttgaccagcgcccacctcatcgaagta
+tagaaagtggttaggataaggatgagaccgaacttatttccggccataactttagatttt
+ctacctagtacacaacatcagggcggacacgaaaccgccatcacatcatataccaggttt
+aatttgcttaatgggggaagtgtcaacgaaccttcgaactttagcaggcatatggccatt
+atatatggccccagagcagaatgctacagcagacaaaatttggatttatgtagtttaata
+cctatcaaacttggtgtgaccatacttgtctaacgacagtgcacaaagtgtaagttacaa
+ttattactactcagcagcttctgcaatgataaaatcttatcatacacgtcacatatgata
+atatctacttagggggaacgggctccacaacctacatagtactcaatacttacactattc
+gacaggcacaccaaacctgtacagtcccaaaagattgagtcaactttgcagtactgcaga
+tcacagtaatagcttagttagcgagtcaaaattagttttctacgagactgcacgaccgtg
+caaatttccgatgtgttggctacaaatagcaacgtatgaatttgtttgaagccacgtaaa
+ctgtacaaccttagagataagtctcaggctactaaaaacacgttgtggcactaacaggat
+catggttgattcttacttattcggctgaccggcccaataagtaaccttcaactagaacag
+aataatcgggagtagtttaattcagtcaaggtgcaggtctcattgtaactaacaagctct
+gtgtaaccaagttaaaatcgttttcttagcggattccctacttatggatttgagctcgtc
+cacaatattcgatacaagaagtttgtggtccgtaacaacgaaattttaattacgctgtgc
+agcctcatccaaggaattaatagaaggttgatggtaggctccgaacgctccatgattata
+atcaagtggactgtgcagtaaacgaggaaggtatcctgacgtcgtggtgttcgtttttgt
+tatttgtgccctatacgagtagataaaccatgaacagcacagtgtgaacccatggttgat
+tttaggctaccttatttttaatttccgttacacagaaacgaattccacaactaacatgcc
+attaatttttcgatatcttataaaagatggtcgaaattcattcatttattttttttcggt
+tctcgaaagtcaactaagctgtcgcgttttgtttctctttagaggtaaaagtggctttga
+tctcctacgtttggatactagtcaaccattactccatttgatccgtgagtatcacctgtc
+taacatccagcattatgactcctcggcgaagaaaagacacacttcttagagtcgatgtgt
+attagctagggacacagttgtttaatacgatagtgagcccagggagggcagtgcgtcccc
+cagtagatttattcagctagtgtaagtataagatatctcacccacgaggttcaagtgata
+tgcagtcttagaataatacttatcctgaatttcgatattatgggtacttcaataatccgc
+tagcgctactttatgtctcgttggacagcaggacacatggcagtcttaaacactaaagac
+atcacctgaatgaatgtaatgggattacaagaatcaatgaggtattatatacgacgtagg
+aaactctggatatatacagtaatctagttacgccatcgcacttcattcctctggaaactt
+agaagacatcagctgtacgtggaggaaccagacccccgtatgtagccaaatagaaccaaa
+gttgcttatacaaacacacccaatgacaatggaccgctggagttcgtaaactcggaacgt
+agtactgcacaaacccagcatttagcaataggagctacgtatgcaactcccacgtggtaa
+taccttcaagctatcaatatataggtgcctagctaatcgcattcgcaagcagtattcaag
+cttgtaaaccagtataataattacagaggctctatgaaacccaactttccagctaaaagt
+cccaattaaatggttatttc
diff --git a/benchmarks/shootout/knucleotide-output.txt b/benchmarks/shootout/knucleotide-output.txt
new file mode 100644
index 00000000..072e3660
--- /dev/null
+++ b/benchmarks/shootout/knucleotide-output.txt
@@ -0,0 +1,27 @@
+A 30.279
+T 30.113
+G 19.835
+C 19.773
+
+AA 9.161
+AT 9.138
+TA 9.108
+TT 9.060
+CA 6.014
+GA 5.996
+AG 5.993
+AC 5.988
+TG 5.987
+GT 5.967
+TC 5.958
+CT 5.948
+GG 3.944
+GC 3.928
+CG 3.910
+CC 3.899
+
+1474	GGT
+459	GGTA
+49	GGTATT
+1	GGTATTTTAATT
+1	GGTATTTTAATTTATAGT
diff --git a/benchmarks/shootout/knucleotide.chibi b/benchmarks/shootout/knucleotide.chibi
new file mode 100644
index 00000000..6aee05bc
--- /dev/null
+++ b/benchmarks/shootout/knucleotide.chibi
@@ -0,0 +1,86 @@
+#! /usr/bin/env chibi-scheme
+
+;;; The Computer Language Benchmarks Game
+;;; http://shootout.alioth.debian.org/
+
+;;; based on Racket version by Matthew Flatt
+
+(import (chibi)
+        (srfi 69)
+        (srfi 95)
+        (chibi io))
+
+(define (print . args)
+  (for-each display args)
+  (newline))
+
+(define (string-copy! dst dstart src start end)
+  (do ((i dstart (+ i 1))
+       (j start (+ j 1)))
+      ((>= j end))
+    (string-set! dst i (string-ref src j))))
+
+(define (string-upcase str)
+  (let* ((len (string-length str))
+         (res (make-string len)))
+    (do ((i 0 (+ i 1)))
+        ((>= i len) res)
+      (string-set! res i (char-upcase (string-ref str i))))))
+
+(define (all-counts len dna)
+  (let ((table (make-hash-table eq?))
+        (seq (make-string len)))
+    (do ((s (- (string-length dna) len) ( - s 1)))
+        ((< s 0) table)
+      (string-copy! seq 0 dna s (+ s len))
+      (let ((key (string->symbol seq)))
+        (let ((cnt (hash-table-ref/default table key 0)))
+          (hash-table-set! table key (+ cnt 1)))))))
+
+(define (write-freqs table)
+  (let* ((content (hash-table->alist table))
+         (total (exact->inexact (apply + (map cdr content)))))
+    (for-each
+     (lambda (a)
+       (print (car a) " "
+              (/ (round (* 100000.0 (/ (cdr a) total))) 1000.0)))
+     (sort content > cdr))))
+
+(define (write-one-freq table key)
+  (print (hash-table-ref/default table key 0) "\t" key))
+
+(define dna
+  (let ((in (current-input-port)))
+    ;; Skip to ">THREE ..."
+    (let lp ()
+      (let ((line (read-line in)))
+        (cond ((eof-object? line))
+              ((and (>= (string-length line) 6)
+                    (eqv? #\> (string-ref line 0))
+                    (equal? (substring line 0 6) ">THREE")))
+              (else (lp)))))
+    (let ((out (open-output-string)))
+      ;; Copy everything but newlines to out:
+      (let lp ()
+        (let ((line (read-line in)))
+          (cond ((eof-object? line))
+                (else
+                 (display line out)
+                 (lp)))))
+      ;; Extract the string from out:
+      (string-upcase (get-output-string out)))))
+
+;; 1-nucleotide counts:
+(write-freqs (all-counts 1 dna))
+(newline)
+
+;; 2-nucleotide counts:
+(write-freqs (all-counts 2 dna))
+(newline)
+
+;; Specific sequences:
+(for-each
+ (lambda (seq)
+   (write-one-freq (all-counts (string-length seq) dna)
+                   (string->symbol seq)))
+ '("GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT"))
diff --git a/bignum.c b/bignum.c
new file mode 100644
index 00000000..da24dff4
--- /dev/null
+++ b/bignum.c
@@ -0,0 +1,1804 @@
+/*  bignum.c -- bignum support                                */
+/*  Copyright (c) 2009-2013 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include "chibi/sexp.h"
+
+#if SEXP_USE_BIGNUMS
+
+#define SEXP_INIT_BIGNUM_SIZE 2
+
+static int digit_value (int c) {
+  return (((c)<='9') ? ((c) - '0') : ((sexp_toupper(c) - 'A') + 10));
+}
+
+static int hex_digit (int n) {
+  return ((n<=9) ? ('0' + n) : ('A' + n - 10));
+}
+
+sexp sexp_make_bignum (sexp ctx, sexp_uint_t len) {
+  sexp_uint_t size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t);
+  sexp res = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM);
+  if (!sexp_exceptionp(res)) {
+    sexp_bignum_length(res) = len;
+    sexp_bignum_sign(res) = 1;
+  }
+  return res;
+}
+
+sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) {
+  sexp res = sexp_make_bignum(ctx, 1);
+  if (!sexp_exceptionp(res)) {
+    sexp_bignum_data(res)[0] = sexp_unbox_fixnum(sexp_fx_abs(a));
+    sexp_bignum_sign(res) = sexp_fx_sign(a);
+  }
+  return res;
+}
+
+sexp sexp_make_integer (sexp ctx, sexp_lsint_t x) {
+  sexp res;
+  if ((SEXP_MIN_FIXNUM <= x) && (x <= SEXP_MAX_FIXNUM)) {
+    res = sexp_make_fixnum(x);
+  } else {
+    res = sexp_make_bignum(ctx, 1);
+    if (x < 0) {
+      sexp_bignum_sign(res) = -1;
+      sexp_bignum_data(res)[0] = -x;
+    } else {
+      sexp_bignum_sign(res) = 1;
+      sexp_bignum_data(res)[0] = x;
+    }
+  }
+  return res;
+}
+
+sexp sexp_make_unsigned_integer (sexp ctx, sexp_luint_t x) {
+  sexp res;
+  if (x <= SEXP_MAX_FIXNUM) {
+    res = sexp_make_fixnum(x);
+  } else {
+    res = sexp_make_bignum(ctx, 1);
+    sexp_bignum_sign(res) = 1;
+    sexp_bignum_data(res)[0] = x;
+  }
+  return res;
+}
+
+#define double_trunc_10s_digit(f) (trunc((f)/10.0)*10.0)
+#define double_10s_digit(f) ((f)-double_trunc_10s_digit(f))
+
+sexp sexp_double_to_bignum (sexp ctx, double f) {
+  int sign;
+  sexp_gc_var3(res, scale, tmp);
+  sexp_gc_preserve3(ctx, res, scale, tmp);
+  res = sexp_fixnum_to_bignum(ctx, SEXP_ZERO);
+  scale = sexp_fixnum_to_bignum(ctx, SEXP_ONE);
+  sign = (f < 0 ? -1 : 1);
+  for (f=fabs(f); f >= 1.0; f=trunc(f/10)) {
+    tmp = sexp_bignum_fxmul(ctx, NULL, scale, double_10s_digit(f), 0);
+    res = sexp_bignum_add(ctx, res, res, tmp);
+    scale = sexp_bignum_fxmul(ctx, NULL, scale, 10, 0);
+  }
+  sexp_bignum_sign(res) = sign;
+  sexp_gc_release3(ctx);
+  return res;
+}
+
+sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len0) {
+  sexp_uint_t len = (len0 > 0) ? len0 : sexp_bignum_length(a), size;
+  size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t);
+  if (! dst || sexp_bignum_length(dst) < len) {
+    dst = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM);
+    sexp_bignum_length(dst) = len;
+  }
+  if (sexp_bignum_length(a) < len)
+    len = sexp_bignum_length(a);
+
+  sexp_bignum_sign(dst) = sexp_bignum_sign(a);
+  memset(sexp_bignum_data(dst), 0,
+         sexp_bignum_length(dst)*sizeof(sexp_uint_t));
+  memmove(sexp_bignum_data(dst), sexp_bignum_data(a),
+          len*sizeof(sexp_uint_t));
+  return dst;
+}
+
+int sexp_bignum_zerop (sexp a) {
+  int i;
+  sexp_uint_t *data = sexp_bignum_data(a);
+  for (i=sexp_bignum_length(a)-1; i>=0; i--)
+    if (data[i])
+      return 0;
+  return 1;
+}
+
+sexp_uint_t sexp_bignum_hi (sexp a) {
+  sexp_uint_t i=sexp_bignum_length(a)-1;
+  while ((i>0) && ! sexp_bignum_data(a)[i])
+    i--;
+  return i+1;
+}
+
+sexp_sint_t sexp_bignum_compare_abs (sexp a, sexp b) {
+  int ai=sexp_bignum_hi(a), bi=sexp_bignum_hi(b);
+  sexp_uint_t *adata=sexp_bignum_data(a), *bdata=sexp_bignum_data(b);
+  if (ai != bi)
+    return ai - bi;
+  for (--ai; ai >= 0; ai--) {
+    if (adata[ai] > bdata[ai])
+      return 1;
+    else if (adata[ai] < bdata[ai])
+      return -1;
+  }
+  return 0;
+}
+
+sexp_sint_t sexp_bignum_compare (sexp a, sexp b) {
+  if (sexp_bignum_sign(a) != sexp_bignum_sign(b))
+    return sexp_bignum_sign(a);
+  return sexp_bignum_compare_abs(a, b);
+}
+
+sexp sexp_bignum_normalize (sexp a) {
+  sexp_uint_t *data;
+  if ((! sexp_bignump(a)) || (sexp_bignum_hi(a)>1))
+    return a;
+  data = sexp_bignum_data(a);
+  if ((data[0] > SEXP_MAX_FIXNUM)
+      && ! ((sexp_bignum_sign(a) == -1) && (data[0] == SEXP_MAX_FIXNUM+1)))
+    return a;
+  return sexp_make_fixnum((sexp_sint_t)data[0] * sexp_bignum_sign(a));
+}
+
+double sexp_bignum_to_double (sexp a) {
+  double res = 0;
+  sexp_sint_t i;
+  sexp_uint_t *data=sexp_bignum_data(a);
+  for (i=sexp_bignum_hi(a)-1; i>=0; i--)
+    res = res * ((double)SEXP_UINT_T_MAX+1) + data[i];
+  return res * sexp_bignum_sign(a);
+}
+
+sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b) {
+  sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a),
+    carry=b, i=0, n;
+  do { n = data[i];
+       data[i] += carry;
+       carry = (n > (SEXP_UINT_T_MAX - carry));
+  } while (++i<len && carry);
+  if (carry) {
+    a = sexp_copy_bignum(ctx, NULL, a, len+1);
+    sexp_bignum_data(a)[len] = 1;
+  }
+  return a;
+}
+
+sexp sexp_bignum_fxsub (sexp ctx, sexp a, sexp_uint_t b) {
+  sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), borrow, i=0, n;
+  if ((len == 1) && (b > data[0])) {
+    data[0] = b - data[0];
+    sexp_bignum_sign(a) = -sexp_bignum_sign(a);
+  } else {
+    for (borrow=b; borrow; i++) {
+      n = data[i];
+      data[i] -= borrow;
+      borrow = (n < borrow);
+    }
+  }
+  return a;
+}
+
+sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset) {
+  sexp_uint_t len=sexp_bignum_length(a), *data, *adata=sexp_bignum_data(a),
+    carry=0, i;
+  sexp_luint_t n;
+  sexp_gc_var1(tmp);
+  sexp_gc_preserve1(ctx, tmp);
+  if ((! d) || (sexp_bignum_length(d) < len+offset))
+    d = sexp_make_bignum(ctx, len+offset);
+  tmp = d;
+  data = sexp_bignum_data(d);
+  for (i=0; i<len; i++) {
+    n = (sexp_luint_t)adata[i]*b + carry;
+    data[i+offset] = (sexp_uint_t)n;
+    carry = n >> (sizeof(sexp_uint_t)*8);
+  }
+  if (carry) {
+    if (sexp_bignum_length(d) <= len+offset)
+      d = sexp_copy_bignum(ctx, NULL, d, len+offset+1);
+    sexp_bignum_data(d)[len+offset] = carry;
+  }
+  sexp_gc_release1(ctx);
+  return d;
+}
+
+sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) {
+  sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, r=0;
+  int i;
+  sexp_luint_t n = 0;
+  for (i=len-1; i>=offset; i--) {
+    n = (n << sizeof(sexp_uint_t)*8) + data[i];
+    q = n / b;
+    r = n - (sexp_luint_t)q * b;
+    data[i] = q;
+    n = r;
+  }
+  return r;
+}
+
+sexp sexp_bignum_fxrem (sexp ctx, sexp a, sexp_sint_t b) {
+  sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, b0;
+  int i;
+  sexp_luint_t n = 0;
+  if (b > 0) {
+    q = b - 1;
+    if ((b & q) == 0)
+      return sexp_make_fixnum(sexp_bignum_sign(a) * (data[0] & q));
+  }
+  b0 = (b >= 0) ? b : -b;
+  for (i=len-1; i>=0; i--) {
+    n = (n << sizeof(sexp_uint_t)*8) + data[i];
+    q = n / b0;
+    n -= (sexp_luint_t)q * b0;
+  }
+  return sexp_make_fixnum(sexp_bignum_sign(a) * (sexp_sint_t)n);
+}
+
+sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init,
+                       signed char sign, sexp_uint_t base) {
+  int c, digit;
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  res = sexp_make_bignum(ctx, SEXP_INIT_BIGNUM_SIZE);
+  sexp_bignum_sign(res) = sign;
+  sexp_bignum_data(res)[0] = init;
+  for (c=sexp_read_char(ctx, in); sexp_isxdigit(c); c=sexp_read_char(ctx, in)) {
+    digit = digit_value(c);
+    if ((digit < 0) || (digit >= base))
+      break;
+    res = sexp_bignum_fxmul(ctx, res, res, base, 0);
+    res = sexp_bignum_fxadd(ctx, res, digit);
+  }
+  if (c=='.' || c=='e' || c=='E') {
+    if (base != 10) {
+      res = sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in);
+    } else {
+      if (c!='.') sexp_push_char(ctx, c, in); /* push the e back */
+      res = sexp_read_float_tail(ctx, in, sexp_bignum_to_double(res), (sign==-1));
+    }
+#if SEXP_USE_RATIOS
+  } else if (c=='/') {
+    res = sexp_bignum_normalize(res);
+    res = sexp_make_ratio(ctx, res, SEXP_ONE);
+    sexp_ratio_denominator(res) = sexp_read_number(ctx, in, 10, 0);
+    res = sexp_ratio_normalize(ctx, res, in);
+#endif
+#if SEXP_USE_COMPLEX
+  } else if (c=='i' || c=='i' || c=='+' || c=='-') {
+    sexp_push_char(ctx, c, in);
+    res = sexp_bignum_normalize(res);
+    res = sexp_read_complex_tail(ctx, in, res);
+#endif
+  } else if ((c!=EOF) && ! sexp_is_separator(c)) {
+    res = sexp_read_error(ctx, "invalid numeric syntax",
+                          sexp_make_character(c), in);
+  } else {
+    sexp_push_char(ctx, c, in);
+  }
+  sexp_gc_release1(ctx);
+  return sexp_bignum_normalize(res);
+}
+
+static int log2i(int v) {
+  int i;
+  for (i = 0; i < sizeof(v)*8; i++)
+    if ((1<<(i+1)) > v)
+      break;
+  return i;
+}
+
+sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) {
+  int i, str_len, lg_base = log2i(base);
+  char *data;
+  sexp_gc_var2(b, str);
+  sexp_gc_preserve2(ctx, b, str);
+  b = sexp_copy_bignum(ctx, NULL, a, 0);
+  sexp_bignum_sign(b) = 1;
+  i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1)
+    / lg_base + 1;
+  str = sexp_make_string(ctx, sexp_make_fixnum(str_len),
+                         sexp_make_character(' '));
+  data = sexp_string_data(str);
+  while (! sexp_bignum_zerop(b))
+    data[--i] = hex_digit(sexp_bignum_fxdiv(ctx, b, base, 0));
+  if (i == str_len)
+    data[--i] = '0';
+  else if (sexp_bignum_sign(a) == -1)
+    data[--i] = '-';
+  sexp_write_string(ctx, data + i, out);
+  sexp_gc_release2(ctx);
+  return SEXP_VOID;
+}
+
+/****************** bignum arithmetic *************************/
+
+sexp sexp_bignum_add_fixnum (sexp ctx, sexp a, sexp b) {
+  sexp_gc_var1(c);
+  sexp_gc_preserve1(ctx, c);
+  c = sexp_copy_bignum(ctx, NULL, a, 0);
+  if (sexp_bignum_sign(c) == sexp_fx_sign(b))
+    c = sexp_bignum_fxadd(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b)));
+  else
+    c = sexp_bignum_fxsub(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b)));
+  sexp_gc_release1(ctx);
+  return c;
+}
+
+sexp sexp_bignum_sub_digits (sexp ctx, sexp dst, sexp a, sexp b) {
+  sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b),
+    borrow=0, i, *adata, *bdata, *cdata;
+  sexp_gc_var1(c);
+  if ((alen < blen) || ((alen == blen) && (sexp_bignum_compare_abs(a, b) < 0)))
+    return sexp_bignum_sub_digits(ctx, dst, b, a);
+  sexp_gc_preserve1(ctx, c);
+  c = ((dst && sexp_bignum_hi(dst) >= alen)
+       ? dst : sexp_copy_bignum(ctx, NULL, a, 0));
+  adata = sexp_bignum_data(a);
+  bdata = sexp_bignum_data(b);
+  cdata = sexp_bignum_data(c);
+  for (i=0; i<blen; i++) {
+    if (adata[i] > bdata[i] || (adata[i] == bdata[i] && !borrow)) {
+      cdata[i] = adata[i] - bdata[i] - borrow;
+      borrow = 0;
+    } else {
+      cdata[i] = (SEXP_UINT_T_MAX - bdata[i]);
+      cdata[i] += 1;
+      cdata[i] -= borrow;
+      cdata[i] += adata[i];
+      borrow = 1;
+    }
+  }
+  for ( ; borrow && (i<alen); i++) {
+    borrow = (cdata[i] == 0 ? 1 : 0);
+    cdata[i]--;
+  }
+  sexp_gc_release1(ctx);
+  return c;
+}
+
+sexp sexp_bignum_add_digits (sexp ctx, sexp dst, sexp a, sexp b) {
+  sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b),
+    carry=0, i, n, *adata, *bdata, *cdata;
+  sexp_gc_var1(c);
+  if (alen < blen) return sexp_bignum_add_digits(ctx, dst, b, a);
+  sexp_gc_preserve1(ctx, c);
+  c = ((dst && sexp_bignum_hi(dst) >= alen)
+       ? dst : sexp_copy_bignum(ctx, NULL, a, 0));
+  adata = sexp_bignum_data(a);
+  bdata = sexp_bignum_data(b);
+  cdata = sexp_bignum_data(c);
+  for (i=0; i<blen; i++) {
+    n = adata[i];
+    cdata[i] = n + bdata[i] + carry;
+    carry = (n > (SEXP_UINT_T_MAX - bdata[i] - carry) ? 1 : 0);
+  }
+  for ( ; carry && (i<alen); i++) {
+    carry = (cdata[i] == SEXP_UINT_T_MAX ? 1 : 0);
+    cdata[i]++;
+  }
+  if (carry) {
+    c = sexp_copy_bignum(ctx, NULL, c, alen+1);
+    sexp_bignum_data(c)[alen] = 1;
+  }
+  sexp_gc_release1(ctx);
+  return c;
+}
+
+sexp sexp_bignum_add (sexp ctx, sexp dst, sexp a, sexp b) {
+  sexp res;
+  if (sexp_bignum_sign(a) == sexp_bignum_sign(b)) {
+    res = sexp_bignum_add_digits(ctx, dst, a, b);
+    sexp_bignum_sign(res) = sexp_bignum_sign(a);
+  } else {
+    res = sexp_bignum_sub_digits(ctx, dst, a, b);
+    sexp_bignum_sign(res)
+      = sexp_bignum_sign(sexp_bignum_compare_abs(a, b) >= 0 ? a : b);
+  }
+  return res;
+}
+
+sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b) {
+  sexp res;
+  int sign;
+  if (sexp_bignum_sign(a) == sexp_bignum_sign(b)) {
+    sign = (sexp_bignum_compare_abs(a, b) >= 0 ? sexp_bignum_sign(a)
+            : -sexp_bignum_sign(a));
+    res = sexp_bignum_sub_digits(ctx, dst, a, b);
+  } else {
+    sign = sexp_bignum_sign(a);
+    res = sexp_bignum_add_digits(ctx, dst, a, b);
+  }
+  sexp_bignum_sign(res) = sign;
+  return res;
+}
+
+static void sexp_bignum_split (sexp ctx, sexp a, sexp_uint_t k, sexp* lo, sexp* hi) {
+  sexp_uint_t alen=sexp_bignum_hi(a), i, *adata=sexp_bignum_data(a),
+    *lodata, *hidata;
+  *lo = sexp_make_bignum(ctx, k);        /* must be gc protected by caller */
+  *hi = sexp_make_bignum(ctx, alen-k+1);
+  lodata = sexp_bignum_data(*lo);
+  hidata = sexp_bignum_data(*hi);
+  for (i=0; i<k; i++)                    /* split into a[0..k-1], a[k..] */
+    lodata[i] = adata[i];
+  for (i=k; i<alen; i++)
+    hidata[i-k] = adata[i];
+}
+
+static sexp sexp_bignum_shift (sexp ctx, sexp a, sexp_uint_t k) {
+  sexp res;
+  sexp_uint_t alen = sexp_bignum_hi(a), i;
+  res = sexp_make_bignum(ctx, alen + k + 1);
+  for (i=0; i<alen; i++)
+    sexp_bignum_data(res)[i+k] = sexp_bignum_data(a)[i];
+  return res;
+}
+
+sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b) {
+  sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), k,
+    *bdata=sexp_bignum_data(b);
+  sexp_gc_var7(a0, a1, b0, b1, z0, z1, z2);
+  if (alen < blen) return sexp_bignum_mul(ctx, dst, b, a);
+  if (blen == 1) {
+    z1 = sexp_bignum_fxmul(ctx, dst, a, bdata[0], 0);
+  } else {
+    /* karatsuba:                             */
+    /*   ab = (a1B^k + a0) * (b1B^k + b0)     */
+    /*      = z2B^2k + z1B^k + z0             */
+    /* where:                                 */
+    /*   z2 = a1b1                            */
+    /*   z1 = a1b0 + a0b1                     */
+    /*   z0 = a0b0                            */
+    /* then optimize further:                 */
+    /*   z1 = (a1 + a0)(b1 + b0) - z2 - z0    */
+    sexp_gc_preserve7(ctx, a0, a1, b0, b1, z0, z1, z2);
+    k = blen / 2;
+    sexp_bignum_split(ctx, a, k, &a0, &a1);
+    sexp_bignum_split(ctx, b, k, &b0, &b1);
+    z0 = sexp_bignum_add(ctx, NULL, a1, a0);  /* temp */
+    z1 = sexp_bignum_add(ctx, NULL, b1, b0);
+    z1 = sexp_bignum_mul(ctx, NULL, z1, z0);  /* 1 */
+    z0 = sexp_bignum_mul(ctx, NULL, a0, b0);  /* 2 */
+    z2 = sexp_bignum_mul(ctx, NULL, a1, b1);  /* 3 */
+    z1 = sexp_bignum_sub(ctx, NULL, z1, z0);
+    z1 = sexp_bignum_sub(ctx, NULL, z1, z2);
+    z2 = sexp_bignum_shift(ctx, z2, 2*k);
+    z1 = sexp_bignum_shift(ctx, z1, k);
+    z1 = sexp_bignum_add(ctx, z1, z1, z0);
+    z1 = sexp_bignum_add(ctx, z1, z1, z2);
+    sexp_gc_release7(ctx);
+  }
+  sexp_bignum_sign(z1) = sexp_bignum_sign(a) * sexp_bignum_sign(b);
+  return z1;
+}
+
+sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) {
+  sexp_luint_t d, dn, dd;
+  sexp_uint_t dlo, dhi;
+  sexp_sint_t alen, blen=sexp_bignum_hi(b), sign=1, off=0;
+  sexp_gc_var5(q, x, y, a1, b1);
+  if (blen == 1 && sexp_bignum_data(b)[0] == 0)
+    return sexp_xtype_exception(ctx, NULL, "divide by zero", a);
+  sexp_gc_preserve5(ctx, q, x, y, a1, b1);
+  a1 = sexp_copy_bignum(ctx, NULL, a, 0);
+  sexp_bignum_sign(a1) = 1;
+  /* fast path for single bigit divisor */
+  if (blen == 1) {
+    b1 = sexp_make_bignum(ctx, 1);
+    sexp_bignum_data(b1)[0] = sexp_bignum_fxdiv(ctx, a1, sexp_bignum_data(b)[0], 0);
+    *rem = sexp_bignum_normalize(b1);
+    if (sexp_bignum_sign(a) * sexp_bignum_sign(b) < 0) {
+      sexp_negate_exact(a1);
+    }
+    if (sexp_bignum_sign(a) < 0) {
+      sexp_negate_exact(*rem);
+    }
+    sexp_gc_release5(ctx);
+    return a1;
+  }
+  /* general case */
+  b1 = sexp_copy_bignum(ctx, NULL, b, 0);
+  sexp_bignum_sign(b1) = 1;
+  q = SEXP_ZERO;
+  x = sexp_make_bignum(ctx, sexp_bignum_length(a));
+  while (sexp_bignum_compare_abs(a1, b1) > 0) { /* a1, b1 at least 2 bigits */
+    /* guess divisor x */
+    alen = sexp_bignum_hi(a1);
+    sexp_bignum_data(x)[off] = 0;
+    if (off > 0) sexp_bignum_data(x)[off-1] = 0;
+    off = alen - blen + 1;
+    dn = (((sexp_luint_t)sexp_bignum_data(a1)[alen-1]
+           << (sizeof(sexp_uint_t)*8))
+          + sexp_bignum_data(a1)[alen-2]);
+    dd = (((sexp_luint_t)sexp_bignum_data(b1)[blen-1]
+           << (sizeof(sexp_uint_t)*8))
+          + sexp_bignum_data(b1)[blen-2]);
+    if (alen > 2 && blen > 2 &&
+        sexp_bignum_data(a1)[alen-1] < (1uL<<(sizeof(sexp_uint_t)*4)) &&
+        sexp_bignum_data(b1)[blen-1] < (1uL<<(sizeof(sexp_uint_t)*4))) {
+      dn = (dn << (sizeof(sexp_uint_t)*4))
+        + (sexp_bignum_data(a1)[alen-3] >> (sizeof(sexp_uint_t)*4));
+      dd = (dd << (sizeof(sexp_uint_t)*4))
+        + (sexp_bignum_data(b1)[blen-3] >> (sizeof(sexp_uint_t)*4));
+    }
+    d = dn / dd;
+    if (d == 0) {
+      dn = (((sexp_luint_t)sexp_bignum_data(a1)[alen-1]
+             << (sizeof(sexp_uint_t)*8))
+            + sexp_bignum_data(a1)[alen-2]);
+      dd = sexp_bignum_data(b1)[blen-1];
+      if (sexp_bignum_data(a1)[alen-1] < (1uL<<(sizeof(sexp_uint_t)*4)) &&
+          sexp_bignum_data(b1)[blen-1] < (1uL<<(sizeof(sexp_uint_t)*4))) {
+        dn = (dn << (sizeof(sexp_uint_t)*4))
+          + (sexp_bignum_data(a1)[alen-3] >> (sizeof(sexp_uint_t)*4));
+        dd = (dd << (sizeof(sexp_uint_t)*4))
+          + (sexp_bignum_data(b1)[blen-2] >> (sizeof(sexp_uint_t)*4));
+      }
+      d = dn / dd;
+      off--;
+    }
+    dhi = d >> (sizeof(sexp_uint_t)*8);
+    dlo = d & (((sexp_luint_t)1<<(sizeof(sexp_uint_t)*8))-1);
+    sexp_bignum_data(x)[off] = dhi;
+    if (off > 0) sexp_bignum_data(x)[off-1] = dlo;
+    /* update quotient q and remainder a1 estimates */
+    y = sexp_bignum_mul(ctx, NULL, b1, x);
+    if (sign < 0) {
+      a1 = sexp_bignum_add(ctx, NULL, a1, y);
+      q = sexp_sub(ctx, q, x);
+    } else {
+      a1 = sexp_bignum_sub(ctx, NULL, a1, y);
+      q = sexp_add(ctx, q, x);
+    }
+    /* flip the sign if we overshot in our estimate */
+    if (sexp_bignum_sign(a1) != sign) {
+      sexp_bignum_sign(a1) = -sign;
+      sign *= -1;
+    }
+  }
+  /* adjust signs */
+  if (sign < 0) {
+    q = sexp_sub(ctx, q, SEXP_ONE);
+    a1 = sexp_add(ctx, a1, b1);
+  }
+  *rem = a1;
+  if (sexp_bignum_sign(a) * sexp_bignum_sign(b) < 0) {
+    sexp_negate_exact(q);
+  }
+  if (sexp_bignum_sign(a) < 0) {
+    sexp_negate_exact(*rem);
+  }
+  sexp_gc_release5(ctx);
+  return q;
+}
+
+sexp sexp_bignum_quotient (sexp ctx, sexp a, sexp b) {
+  sexp res;
+  sexp_gc_var1(rem);
+  sexp_gc_preserve1(ctx, rem);
+  res = sexp_bignum_quot_rem(ctx, &rem, a, b);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_bignum_remainder (sexp ctx, sexp a, sexp b) {
+  sexp_gc_var1(rem);
+  sexp_gc_preserve1(ctx, rem);
+  sexp_bignum_quot_rem(ctx, &rem, a, b); /* discard quotient */
+  sexp_gc_release1(ctx);
+  return rem;
+}
+
+sexp sexp_bignum_expt (sexp ctx, sexp a, sexp b) {
+  sexp_sint_t e = sexp_unbox_fixnum(sexp_fx_abs(b));
+  sexp_gc_var2(res, acc);
+  sexp_gc_preserve2(ctx, res, acc);
+  res = sexp_fixnum_to_bignum(ctx, SEXP_ONE);
+  acc = sexp_copy_bignum(ctx, NULL, a, 0);
+  for (; e; e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc))
+    if (e & 1)
+      res = sexp_bignum_mul(ctx, NULL, res, acc);
+  sexp_gc_release2(ctx);
+  return sexp_bignum_normalize(res);
+}
+
+#if SEXP_USE_MATH
+
+/*
+ * a = x * 2^2n, with 0.1 <= x < 1.0 (base 2)  =>  sqrt(a) ~ 2^n
+ */
+sexp sexp_bignum_sqrt_estimate (sexp ctx, sexp a) {
+  sexp_uint_t alen=sexp_bignum_hi(a), adata_hi;
+  int nbits, i;
+  sexp_gc_var1(res);
+
+  adata_hi = sexp_bignum_data(a)[alen - 1];
+  for (i = sizeof(sexp_uint_t)*8-1; i > 0; i--)
+    if (adata_hi & (1ul << i))
+      break;
+  nbits = sizeof(sexp_uint_t) * 8 * (alen - 1) + i + 1;
+
+  sexp_gc_preserve1(ctx, res);
+  res = sexp_fixnum_to_bignum(ctx, SEXP_TWO);
+  res = sexp_bignum_expt(ctx, res, sexp_make_fixnum(nbits / 2));
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+#define SEXP_MAX_ACCURATE_FLONUM_SQRT 1073741824.0 /* 2^30 */
+
+/* Babylonian method */
+sexp sexp_bignum_sqrt (sexp ctx, sexp a, sexp* rem_out) {
+  sexp_gc_var4(res, rem, tmp, tmpa);
+  if (! sexp_bignump(a)) return sexp_type_exception(ctx, NULL, SEXP_BIGNUM, a);
+  sexp_gc_preserve4(ctx, res, rem, tmp, tmpa);
+  /* initial estimate via flonum, ignoring signs */
+  if (sexp_negativep(a)) {
+    tmpa = sexp_copy_bignum(ctx, NULL, a, 0);
+    a = tmpa;
+    sexp_negate(a);
+  }
+  res = sexp_make_flonum(ctx, sexp_bignum_to_double(a));
+  res = sexp_inexact_sqrt(ctx, NULL, 1, res);
+  if (sexp_flonump(res) &&
+      sexp_flonum_value(res) > SEXP_MAX_ACCURATE_FLONUM_SQRT) {
+    if (isinf(sexp_flonum_value(res)))
+      res = sexp_bignum_sqrt_estimate(ctx, a);
+    else
+      res = sexp_double_to_bignum(ctx, sexp_flonum_value(res));
+  loop:                           /* until 0 <= a - res*res < 2*res + 1 */
+    rem = sexp_mul(ctx, res, res);
+    tmp = rem = sexp_sub(ctx, a, rem);
+    if (!sexp_positivep(tmp)) goto adjust;
+    tmp = sexp_sub(ctx, tmp, SEXP_ONE);
+    tmp = sexp_quotient(ctx, tmp, SEXP_TWO);
+    tmp = sexp_compare(ctx, tmp, res);
+    if (sexp_positivep(tmp)) {
+    adjust:
+      tmp = sexp_quotient(ctx, a, res);
+      res = sexp_add(ctx, res, tmp);
+      res = sexp_quotient(ctx, res, SEXP_TWO);
+      goto loop;
+    }
+  } else {
+    if (sexp_flonump(res))
+      res = sexp_bignum_normalize(sexp_double_to_bignum(ctx, sexp_flonum_value(res)));
+    tmp = sexp_mul(ctx, res, res);
+    rem = sexp_sub(ctx, a, tmp);
+  }
+  *rem_out = sexp_bignum_normalize(rem);
+  sexp_gc_release4(ctx);
+  return sexp_bignum_normalize(res);
+}
+
+#endif  /* SEXP_USE_MATH */
+
+/************************ ratios ******************************/
+
+#if SEXP_USE_RATIOS
+
+double sexp_ratio_to_double (sexp rat) {
+  sexp num = sexp_ratio_numerator(rat), den = sexp_ratio_denominator(rat);
+  return (sexp_bignump(num) ? sexp_bignum_to_double(num)
+          : sexp_fixnum_to_double(num))
+    / (sexp_bignump(den) ? sexp_bignum_to_double(den)
+       : sexp_fixnum_to_double(den));
+}
+
+sexp sexp_double_to_ratio (sexp ctx, double f) {
+  int sign, i;
+  sexp_gc_var3(res, whole, scale);
+  if (f == trunc(f))
+    return sexp_bignum_normalize(sexp_double_to_bignum(ctx, f));
+  sexp_gc_preserve3(ctx, res, whole, scale);
+  whole = sexp_double_to_bignum(ctx, trunc(f));
+  res = sexp_fixnum_to_bignum(ctx, SEXP_ZERO);
+  scale = SEXP_ONE;
+  sign = (f < 0 ? -1 : 1);
+  for (i=0, f=fabs(f-trunc(f)); f != trunc(f) && i < 15; i++) {
+    res = sexp_bignum_fxmul(ctx, NULL, res, 10, 0);
+    f = f * 10;
+    res = sexp_bignum_fxadd(ctx, res, double_10s_digit(f));
+    f = f - trunc(f);
+    scale = sexp_mul(ctx, scale, SEXP_TEN);
+  }
+  sexp_bignum_sign(res) = sign;
+  res = sexp_bignum_normalize(res);
+  scale = sexp_bignum_normalize(scale);
+  res = sexp_make_ratio(ctx, res, scale);
+  res = sexp_ratio_normalize(ctx, res, SEXP_FALSE);
+  res = sexp_add(ctx, res, whole);
+  sexp_gc_release3(ctx);
+  return res;
+}
+
+sexp sexp_ratio_add (sexp ctx, sexp a, sexp b) {
+  sexp_gc_var3(res, num, den);
+  sexp_gc_preserve3(ctx, res, num, den);
+  num = sexp_mul(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(b));
+  den = sexp_mul(ctx, sexp_ratio_numerator(b), sexp_ratio_denominator(a));
+  num = sexp_add(ctx, num, den);
+  den = sexp_mul(ctx, sexp_ratio_denominator(a), sexp_ratio_denominator(b));
+  res = sexp_make_ratio(ctx, num, den);
+  res = sexp_ratio_normalize(ctx, res, SEXP_FALSE);
+  sexp_gc_release3(ctx);
+  return res;
+}
+
+sexp sexp_ratio_mul (sexp ctx, sexp a, sexp b) {
+  sexp_gc_var3(res, num, den);
+  sexp_gc_preserve3(ctx, res, num, den);
+  num = sexp_mul(ctx, sexp_ratio_numerator(a), sexp_ratio_numerator(b));
+  den = sexp_mul(ctx, sexp_ratio_denominator(a), sexp_ratio_denominator(b));
+  res = sexp_make_ratio(ctx, num, den);
+  res = sexp_ratio_normalize(ctx, res, SEXP_FALSE);
+  sexp_gc_release3(ctx);
+  return res;
+}
+
+sexp sexp_ratio_div (sexp ctx, sexp a, sexp b) {
+  sexp_gc_var3(res, num, den);
+  sexp_gc_preserve3(ctx, res, num, den);
+  num = sexp_mul(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(b));
+  den = sexp_mul(ctx, sexp_ratio_denominator(a), sexp_ratio_numerator(b));
+  res = sexp_make_ratio(ctx, num, den);
+  res = sexp_ratio_normalize(ctx, res, SEXP_FALSE);
+  sexp_gc_release3(ctx);
+  return res;
+}
+
+sexp sexp_ratio_compare (sexp ctx, sexp a, sexp b) {
+  sexp_gc_var2(a2, b2);
+  sexp_gc_preserve2(ctx, a2, b2);
+  a2 = sexp_mul(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(b));
+  b2 = sexp_mul(ctx, sexp_ratio_numerator(b), sexp_ratio_denominator(a));
+  a2 = sexp_compare(ctx, a2, b2);
+  sexp_gc_release2(ctx);
+  return a2;
+}
+
+sexp sexp_ratio_round (sexp ctx, sexp a) {
+  sexp_gc_var2(q, r);
+  sexp_gc_preserve2(ctx, q, r);
+  q = sexp_quotient(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a));
+  if ((sexp_ratio_denominator(a) == SEXP_TWO) && sexp_oddp(q)) {
+    q = sexp_add(ctx, q, (sexp_positivep(q) ? SEXP_ONE : SEXP_NEG_ONE));
+  } else {
+    r = sexp_remainder(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a));
+    r = sexp_mul(ctx, r, SEXP_TWO);
+    if (sexp_negativep(r)) {sexp_negate(r);}
+    if (sexp_unbox_fixnum(sexp_compare(ctx, r, sexp_ratio_denominator(a))) > 0)
+      q = sexp_add(ctx, q, (sexp_positivep(q) ? SEXP_ONE : SEXP_NEG_ONE));
+  }
+  sexp_gc_release2(ctx);
+  return q;
+}
+
+sexp sexp_ratio_trunc (sexp ctx, sexp a) {
+  return sexp_quotient(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a));
+}
+
+sexp sexp_ratio_floor (sexp ctx, sexp a) {
+  sexp_gc_var1(q);
+  sexp_gc_preserve1(ctx, q);
+  q = sexp_quotient(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a));
+  if (sexp_negativep(sexp_ratio_numerator(a)))
+    q = sexp_add(ctx, q, SEXP_NEG_ONE);
+  sexp_gc_release1(ctx);
+  return q;
+}
+
+sexp sexp_ratio_ceiling (sexp ctx, sexp a) {
+  sexp_gc_var1(q);
+  sexp_gc_preserve1(ctx, q);
+  q = sexp_quotient(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a));
+  if (sexp_positivep(sexp_ratio_numerator(a)))
+    q = sexp_add(ctx, q, SEXP_ONE);
+  sexp_gc_release1(ctx);
+  return q;
+}
+
+#endif
+
+/************************ complex numbers ****************************/
+
+#if SEXP_USE_COMPLEX
+
+static sexp sexp_complex_copy (sexp ctx, sexp a) {
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  res = sexp_make_complex(ctx, sexp_complex_real(a), sexp_complex_imag(a));
+  if (sexp_flonump(sexp_complex_real(a)))
+    sexp_complex_real(a) = sexp_make_flonum(ctx, sexp_flonum_value(sexp_complex_real(a)));
+  else if (sexp_bignump(sexp_complex_real(a)))
+    sexp_complex_real(a) = sexp_copy_bignum(ctx, NULL, sexp_complex_real(a), 0);
+  if (sexp_flonump(sexp_complex_imag(a)))
+    sexp_complex_imag(a) = sexp_make_flonum(ctx, sexp_flonum_value(sexp_complex_imag(a)));
+  else if (sexp_bignump(sexp_complex_imag(a)))
+    sexp_complex_imag(a) = sexp_copy_bignum(ctx, NULL, sexp_complex_imag(a), 0);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_complex_add (sexp ctx, sexp a, sexp b) {
+  sexp_gc_var3(res, real, imag);
+  sexp_gc_preserve3(ctx, res, real, imag);
+  real = sexp_add(ctx, sexp_complex_real(a), sexp_complex_real(b));
+  imag = sexp_add(ctx, sexp_complex_imag(a), sexp_complex_imag(b));
+  res = sexp_make_complex(ctx, real, imag);
+  sexp_gc_release3(ctx);
+  return sexp_complex_normalize(res);
+}
+
+sexp sexp_complex_sub (sexp ctx, sexp a, sexp b) {
+  sexp_gc_var2(res, tmp);
+  sexp_gc_preserve2(ctx, res, tmp);
+  tmp = sexp_complex_copy(ctx, b);
+  sexp_negate(sexp_complex_real(tmp));
+  sexp_negate(sexp_complex_imag(tmp));
+  res = sexp_complex_add(ctx, a, tmp);
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+sexp sexp_complex_mul (sexp ctx, sexp a, sexp b) {
+  sexp_gc_var3(res, real, imag);
+  sexp_gc_preserve3(ctx, res, real, imag);
+  real = sexp_mul(ctx, sexp_complex_real(a), sexp_complex_real(b));
+  res = sexp_mul(ctx, sexp_complex_imag(a), sexp_complex_imag(b));
+  real = sexp_sub(ctx, real, res);
+  imag = sexp_mul(ctx, sexp_complex_real(a), sexp_complex_imag(b));
+  res = sexp_mul(ctx, sexp_complex_imag(a), sexp_complex_real(b));
+  imag = sexp_add(ctx, imag, res);
+  res = sexp_make_complex(ctx, real, imag);
+  sexp_gc_release3(ctx);
+  return sexp_complex_normalize(res);
+}
+
+/* (a + bi)    (ac + bd)      (bc - ad)    */
+/* -------- = -----------  + ----------- i */
+/* (c + di)   (c^2 + d^2)    (c^2 + d^2)   */
+
+sexp sexp_complex_div (sexp ctx, sexp a, sexp b) {
+  sexp_gc_var4(res, real, imag, denom);
+  sexp_gc_preserve4(ctx, res, real, imag, denom);
+  /* c^2 + d^2 */
+  denom = sexp_mul(ctx, sexp_complex_real(b), sexp_complex_real(b));
+  res = sexp_mul(ctx, sexp_complex_imag(b), sexp_complex_imag(b));
+  denom = sexp_add(ctx, denom, res);
+  /* ac + bd */
+  real = sexp_mul(ctx, sexp_complex_real(a), sexp_complex_real(b));
+  res = sexp_mul(ctx, sexp_complex_imag(a), sexp_complex_imag(b));
+  real = sexp_add(ctx, real, res);
+  real = sexp_div(ctx, real, denom);
+  /* bc - ad */
+  imag = sexp_mul(ctx, sexp_complex_imag(a), sexp_complex_real(b));
+  res = sexp_mul(ctx, sexp_complex_real(a), sexp_complex_imag(b));
+  imag = sexp_sub(ctx, imag, res);
+  imag = sexp_div(ctx, imag, denom);
+  res = sexp_make_complex(ctx, real, imag);
+  sexp_gc_release4(ctx);
+  return sexp_complex_normalize(res);
+}
+
+static double sexp_to_double (sexp x) {
+  if (sexp_flonump(x))
+    return sexp_flonum_value(x);
+  else if (sexp_fixnump(x))
+    return sexp_fixnum_to_double(x);
+  else if (sexp_bignump(x))
+    return sexp_bignum_to_double(x);
+#if SEXP_USE_RATIOS
+  else if (sexp_ratiop(x))
+    return sexp_ratio_to_double(x);
+#endif
+  else
+    return 0.0;
+}
+
+static sexp sexp_to_complex (sexp ctx, sexp x) {
+#if SEXP_USE_RATIOS
+  sexp_gc_var1(tmp);
+#endif
+  if (sexp_flonump(x) || sexp_fixnump(x) || sexp_bignump(x)) {
+    return sexp_make_complex(ctx, x, SEXP_ZERO);
+#if SEXP_USE_RATIOS
+  } else if (sexp_ratiop(x)) {
+    sexp_gc_preserve1(ctx, tmp);
+    tmp = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
+    sexp_complex_real(tmp) = sexp_make_flonum(ctx, sexp_to_double(x));
+    sexp_gc_release1(ctx);
+    return tmp;
+#endif
+  } else {
+    return x;
+  }
+}
+
+sexp sexp_complex_exp (sexp ctx, sexp z) {
+  double e2x = exp(sexp_to_double(sexp_complex_real(z))),
+    y = sexp_to_double(sexp_complex_imag(z));
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
+  sexp_complex_real(res) = sexp_make_flonum(ctx, e2x*cos(y));
+  sexp_complex_imag(res) = sexp_make_flonum(ctx, e2x*sin(y));
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_complex_log (sexp ctx, sexp z) {
+  double x = sexp_to_double(sexp_complex_real(z)),
+    y = sexp_to_double(sexp_complex_imag(z));
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
+  sexp_complex_real(res) = sexp_make_flonum(ctx, log(sqrt(x*x + y*y)));
+  sexp_complex_imag(res) = sexp_make_flonum(ctx, atan2(y, x));
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_complex_expt (sexp ctx, sexp a, sexp b) {
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  res = sexp_to_complex(ctx, a);
+  res = sexp_complex_log(ctx, res);
+  res = sexp_mul(ctx, b, res);
+  res = sexp_complex_exp(ctx, res);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+#if SEXP_USE_MATH
+
+sexp sexp_complex_sqrt (sexp ctx, sexp z) {
+  double x = sexp_to_double(sexp_complex_real(z)),
+    y = sexp_to_double(sexp_complex_imag(z)), r;
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  r = sqrt(x*x + y*y);
+  res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
+  sexp_complex_real(res) = sexp_make_flonum(ctx, sqrt((x+r)/2));
+  sexp_complex_imag(res) = sexp_make_flonum(ctx, (y<0?-1:1)*sqrt((-x+r)/2));
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_complex_sin (sexp ctx, sexp z) {
+  double x = sexp_to_double(sexp_complex_real(z)),
+    y = sexp_to_double(sexp_complex_imag(z));
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
+  sexp_complex_real(res) = sexp_make_flonum(ctx, sin(x)*cosh(y));
+  sexp_complex_imag(res) = sexp_make_flonum(ctx, cos(x)*sinh(y));
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_complex_cos (sexp ctx, sexp z) {
+  double x = sexp_to_double(sexp_complex_real(z)),
+    y = sexp_to_double(sexp_complex_imag(z));
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
+  sexp_complex_real(res) = sexp_make_flonum(ctx, cos(x)*cosh(y));
+  sexp_complex_imag(res) = sexp_make_flonum(ctx, -sin(x)*sinh(y));
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_complex_tan (sexp ctx, sexp z) {
+  sexp res;
+  sexp_gc_var2(sin, cos);
+  sexp_gc_preserve2(ctx, sin, cos);
+  sin = sexp_complex_sin(ctx, z);
+  cos = sexp_complex_cos(ctx, z);
+  res = sexp_complex_div(ctx, sin, cos);
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+sexp sexp_complex_asin (sexp ctx, sexp z) {
+  sexp_gc_var2(res, tmp);
+  sexp_gc_preserve2(ctx, res, tmp);
+  res = sexp_complex_mul(ctx, z, z);
+  tmp = sexp_make_complex(ctx, SEXP_ONE, SEXP_ZERO);
+  res = sexp_complex_sub(ctx, tmp, res);
+  res = sexp_complex_sqrt(ctx, res);
+  /* tmp = iz */
+  sexp_complex_real(tmp) = sexp_complex_imag(z);
+  sexp_negate(sexp_complex_real(tmp));
+  sexp_complex_imag(tmp) = sexp_complex_real(z);
+  res = sexp_complex_add(ctx, tmp, res);
+  tmp = sexp_complex_log(ctx, res);
+  /* res = -i*tmp */
+  res = sexp_complex_copy(ctx, tmp);
+  sexp_negate(sexp_complex_imag(res));
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+sexp sexp_complex_acos (sexp ctx, sexp z) {
+  sexp_gc_var2(res, tmp);
+  sexp_gc_preserve2(ctx, res, tmp);
+  res = sexp_complex_asin(ctx, z);
+  tmp = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
+  sexp_complex_real(tmp) = sexp_make_flonum(ctx, acos(-1)/2);
+  res = sexp_sub(ctx, tmp, res);
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+sexp sexp_complex_atan (sexp ctx, sexp z) {
+  sexp_gc_var3(res, tmp1, tmp2);
+  sexp_gc_preserve3(ctx, res, tmp1, tmp2);
+  tmp1 = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ONE);
+  tmp1 = sexp_complex_mul(ctx, z, tmp1);
+  res = sexp_make_complex(ctx, SEXP_ONE, SEXP_ZERO);
+  res = sexp_complex_sub(ctx, res, tmp1);
+  res = sexp_complex_log(ctx, res);
+  tmp2 = sexp_make_complex(ctx, SEXP_ONE, SEXP_ZERO);
+  tmp2 = sexp_complex_add(ctx, tmp2, tmp1);
+  tmp2 = sexp_complex_log(ctx, tmp2);
+  res = sexp_complex_sub(ctx, res, tmp2);
+  tmp1 = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ONE);
+  sexp_complex_imag(tmp1) = sexp_make_flonum(ctx, 0.5);
+  res = sexp_complex_mul(ctx, res, tmp1);
+  sexp_gc_release3(ctx);
+  return res;
+}
+
+#endif
+#endif
+
+/****************** generic arithmetic ************************/
+
+enum sexp_number_types {
+  SEXP_NUM_NOT = 0,
+  SEXP_NUM_FIX,
+  SEXP_NUM_FLO,
+  SEXP_NUM_BIG,
+#if SEXP_USE_RATIOS
+  SEXP_NUM_RAT,
+#endif
+#if SEXP_USE_COMPLEX
+  SEXP_NUM_CPX,
+#endif
+};
+
+enum sexp_number_combs {
+  SEXP_NUM_NOT_NOT = 0,
+  SEXP_NUM_NOT_FIX,
+  SEXP_NUM_NOT_FLO,
+  SEXP_NUM_NOT_BIG,
+#if SEXP_USE_RATIOS
+  SEXP_NUM_NOT_RAT,
+#endif
+#if SEXP_USE_COMPLEX
+  SEXP_NUM_NOT_CPX,
+#endif
+  SEXP_NUM_FIX_NOT,
+  SEXP_NUM_FIX_FIX,
+  SEXP_NUM_FIX_FLO,
+  SEXP_NUM_FIX_BIG,
+#if SEXP_USE_RATIOS
+  SEXP_NUM_FIX_RAT,
+#endif
+#if SEXP_USE_COMPLEX
+  SEXP_NUM_FIX_CPX,
+#endif
+  SEXP_NUM_FLO_NOT,
+  SEXP_NUM_FLO_FIX,
+  SEXP_NUM_FLO_FLO,
+  SEXP_NUM_FLO_BIG,
+#if SEXP_USE_RATIOS
+  SEXP_NUM_FLO_RAT,
+#endif
+#if SEXP_USE_COMPLEX
+  SEXP_NUM_FLO_CPX,
+#endif
+  SEXP_NUM_BIG_NOT,
+  SEXP_NUM_BIG_FIX,
+  SEXP_NUM_BIG_FLO,
+  SEXP_NUM_BIG_BIG,
+#if SEXP_USE_RATIOS
+  SEXP_NUM_BIG_RAT,
+#endif
+#if SEXP_USE_COMPLEX
+  SEXP_NUM_BIG_CPX,
+#endif
+#if SEXP_USE_RATIOS
+  SEXP_NUM_RAT_NOT,
+  SEXP_NUM_RAT_FIX,
+  SEXP_NUM_RAT_FLO,
+  SEXP_NUM_RAT_BIG,
+  SEXP_NUM_RAT_RAT,
+#if SEXP_USE_COMPLEX
+  SEXP_NUM_RAT_CPX,
+#endif
+#endif
+#if SEXP_USE_COMPLEX
+  SEXP_NUM_CPX_NOT,
+  SEXP_NUM_CPX_FIX,
+  SEXP_NUM_CPX_FLO,
+  SEXP_NUM_CPX_BIG,
+#if SEXP_USE_RATIOS
+  SEXP_NUM_CPX_RAT,
+#endif
+  SEXP_NUM_CPX_CPX,
+#endif
+};
+
+static int sexp_number_types[] =
+#if SEXP_USE_RATIOS && SEXP_USE_COMPLEX
+  {0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 2, 3, 4, 5, 0, 0};
+#else
+#if SEXP_USE_RATIOS || SEXP_USE_COMPLEX
+  {0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 2, 3, 4, 0, 0, 0};
+#else
+  {0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0};
+#endif
+#endif
+
+#define SEXP_NUM_NUMBER_TYPES (4 + SEXP_USE_RATIOS + SEXP_USE_COMPLEX)
+
+static int sexp_number_type (sexp a) {
+  return sexp_pointerp(a) ?
+    (sexp_pointer_tag(a)<(sizeof(sexp_number_types)/sizeof(sexp_number_types[0]))
+     ? sexp_number_types[sexp_pointer_tag(a)] : 0)
+#if SEXP_USE_IMMEDIATE_FLONUMS
+    : sexp_flonump(a) ? 2
+#endif
+    : sexp_fixnump(a);
+}
+
+sexp sexp_add (sexp ctx, sexp a, sexp b) {
+  sexp_sint_t sum;
+  int at=sexp_number_type(a), bt=sexp_number_type(b), t;
+  sexp r=SEXP_VOID;
+  sexp_gc_var1(tmp);
+  sexp_gc_preserve1(ctx, tmp);
+  if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;}
+  switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) {
+  case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
+  case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_NOT_RAT:
+#endif
+#if SEXP_USE_COMPLEX
+  case SEXP_NUM_NOT_CPX:
+#endif
+    r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a);
+    break;
+  case SEXP_NUM_FIX_FIX:
+    sum = sexp_unbox_fixnum(a) + sexp_unbox_fixnum(b);
+    if ((sum < SEXP_MIN_FIXNUM) || (sum > SEXP_MAX_FIXNUM))
+      r = sexp_add(ctx, tmp=sexp_fixnum_to_bignum(ctx, a), b);
+    else
+      r = sexp_make_fixnum(sum);
+    break;
+  case SEXP_NUM_FIX_FLO:
+    r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)+sexp_flonum_value(b));
+    break;
+  case SEXP_NUM_FIX_BIG:
+    r = sexp_bignum_normalize(sexp_bignum_add_fixnum(ctx, b, a));
+    break;
+  case SEXP_NUM_FLO_FLO:
+    r = sexp_fp_add(ctx, a, b);
+    break;
+  case SEXP_NUM_FLO_BIG:
+    r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_bignum_to_double(b));
+    break;
+  case SEXP_NUM_BIG_BIG:
+    r = sexp_bignum_normalize(sexp_bignum_add(ctx, NULL, b, a));
+    break;
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_FLO_RAT:
+    r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_ratio_to_double(b));
+    break;
+  case SEXP_NUM_FIX_RAT:
+  case SEXP_NUM_BIG_RAT:
+    a = tmp = sexp_make_ratio(ctx, a, SEXP_ONE);
+    /* ... FALLTHROUGH ... */
+  case SEXP_NUM_RAT_RAT:
+    r = sexp_ratio_add(ctx, a, b);
+    break;
+#endif
+#if SEXP_USE_COMPLEX
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_RAT_CPX:
+#endif
+  case SEXP_NUM_FLO_CPX:
+  case SEXP_NUM_FIX_CPX:
+  case SEXP_NUM_BIG_CPX:
+    a = tmp = sexp_make_complex(ctx, a, SEXP_ZERO);
+    /* ... FALLTHROUGH ... */
+  case SEXP_NUM_CPX_CPX:
+    r = sexp_complex_add(ctx, a, b);
+    break;
+#endif
+  }
+  sexp_gc_release1(ctx);
+  return r;
+}
+
+sexp sexp_sub (sexp ctx, sexp a, sexp b) {
+#if SEXP_USE_FLONUMS
+  int negatep=0;
+#endif
+  int at=sexp_number_type(a), bt=sexp_number_type(b);
+  sexp r=SEXP_VOID;
+  sexp_gc_var2(tmp1, tmp2);
+  sexp_gc_preserve2(ctx, tmp1, tmp2);
+  switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) {
+  case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
+  case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_NOT_RAT:
+#endif
+#if SEXP_USE_COMPLEX
+  case SEXP_NUM_NOT_CPX:
+#endif
+    r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a);
+    break;
+  case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT:
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_RAT_NOT:
+#endif
+#if SEXP_USE_COMPLEX
+  case SEXP_NUM_CPX_NOT:
+#endif
+    r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, b);
+    break;
+  case SEXP_NUM_FIX_FIX:
+    r = sexp_fx_sub(a, b);      /* VM catches this case */
+    break;
+  case SEXP_NUM_FIX_FLO:
+    r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)-sexp_flonum_value(b));
+    break;
+  case SEXP_NUM_FIX_BIG:
+    tmp1 = sexp_fixnum_to_bignum(ctx, a);
+    r = sexp_bignum_sub(ctx, NULL, b, tmp1);
+    sexp_negate_exact(r);
+    r = sexp_bignum_normalize(r);
+    break;
+  case SEXP_NUM_FLO_FIX:
+    r = sexp_make_flonum(ctx, sexp_flonum_value(a) - sexp_fixnum_to_double(b));
+    break;
+  case SEXP_NUM_FLO_FLO:
+    r = sexp_fp_sub(ctx, a, b);
+    break;
+  case SEXP_NUM_FLO_BIG:
+    r = sexp_make_flonum(ctx, sexp_flonum_value(a) - sexp_bignum_to_double(b));
+    break;
+  case SEXP_NUM_BIG_FIX:
+    tmp1 = sexp_fixnum_to_bignum(ctx, b);
+    r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, tmp1));
+    break;
+  case SEXP_NUM_BIG_FLO:
+    r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) - sexp_flonum_value(b));
+    break;
+  case SEXP_NUM_BIG_BIG:
+    r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, b));
+    break;
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_FLO_RAT:
+    r = sexp_make_flonum(ctx, sexp_flonum_value(a) - sexp_ratio_to_double(b));
+    break;
+  case SEXP_NUM_RAT_FLO:
+    r = sexp_make_flonum(ctx, sexp_ratio_to_double(a) - sexp_flonum_value(b));
+    break;
+  case SEXP_NUM_RAT_FIX:
+  case SEXP_NUM_RAT_BIG:
+    tmp1 = a; a = b; b = tmp1;
+    negatep = 1;
+    /* ... FALLTHROUGH ... */
+  case SEXP_NUM_FIX_RAT:
+  case SEXP_NUM_BIG_RAT:
+    a = tmp1 = sexp_make_ratio(ctx, a, SEXP_ONE);
+    /* ... FALLTHROUGH ... */
+  case SEXP_NUM_RAT_RAT:
+    tmp2 = sexp_make_ratio(ctx, sexp_ratio_numerator(b), sexp_ratio_denominator(b));
+    if (sexp_bignump(sexp_ratio_numerator(tmp2)))
+      sexp_ratio_numerator(tmp2) = sexp_copy_bignum(ctx, NULL, sexp_ratio_numerator(tmp2), 0);
+    sexp_negate_exact(sexp_ratio_numerator(tmp2));
+    r = sexp_ratio_add(ctx, a, tmp2);
+    if (negatep) {
+      if (sexp_ratiop(r)) {
+        sexp_negate_exact(sexp_ratio_numerator(r));
+      } else {
+        sexp_negate_exact(r);
+      }
+    }
+    break;
+#endif
+#if SEXP_USE_COMPLEX
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_RAT_CPX:
+    a = tmp1 = sexp_make_flonum(ctx, sexp_ratio_to_double(a));
+    goto complex_sub;
+  case SEXP_NUM_CPX_RAT:
+    b = tmp1 = sexp_make_flonum(ctx, sexp_ratio_to_double(b));
+    /* ... FALLTHROUGH ... */
+#endif
+  case SEXP_NUM_CPX_FLO:
+  case SEXP_NUM_CPX_FIX:
+  case SEXP_NUM_CPX_BIG:
+    tmp1 = a; a = b; b = tmp1;
+    negatep = 1;
+    /* ... FALLTHROUGH ... */
+  case SEXP_NUM_FLO_CPX:
+  case SEXP_NUM_FIX_CPX:
+  case SEXP_NUM_BIG_CPX:
+    a = tmp1 = sexp_make_complex(ctx, a, SEXP_ZERO);
+    /* ... FALLTHROUGH ... */
+  case SEXP_NUM_CPX_CPX:
+#if SEXP_USE_RATIOS
+  complex_sub:
+#endif
+    r = sexp_complex_sub(ctx, a, b);
+    if (negatep) {
+      if (sexp_complexp(r)) {
+        r = sexp_complex_copy(ctx, r);
+        sexp_negate(sexp_complex_real(r));
+        sexp_negate(sexp_complex_imag(r));
+      } else {
+        sexp_negate(r);
+      }
+    }
+    break;
+#endif
+  }
+  sexp_gc_release2(ctx);
+  return r;
+}
+
+sexp sexp_mul (sexp ctx, sexp a, sexp b) {
+  sexp_lsint_t prod;
+  int at=sexp_number_type(a), bt=sexp_number_type(b), t;
+  sexp r=SEXP_VOID;
+  sexp_gc_var1(tmp);
+  sexp_gc_preserve1(ctx, tmp);
+  if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;}
+  switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) {
+  case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
+  case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_NOT_RAT:
+#endif
+    r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a);
+    break;
+  case SEXP_NUM_FIX_FIX:
+    prod = (sexp_lsint_t)sexp_unbox_fixnum(a) * sexp_unbox_fixnum(b);
+    if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM))
+      r = sexp_mul(ctx, tmp=sexp_fixnum_to_bignum(ctx, a), b);
+    else
+      r = sexp_make_fixnum(prod);
+    break;
+  case SEXP_NUM_FIX_FLO:
+    r = (a==SEXP_ZERO ? a : sexp_make_flonum(ctx, sexp_fixnum_to_double(a)*sexp_flonum_value(b)));
+    break;
+  case SEXP_NUM_FIX_BIG:
+    r = sexp_bignum_fxmul(ctx, NULL, b, sexp_unbox_fixnum(sexp_fx_abs(a)), 0);
+    sexp_bignum_sign(r) = sexp_fx_sign(a) * sexp_bignum_sign(b);
+    r = sexp_bignum_normalize(r);
+    break;
+  case SEXP_NUM_FLO_FLO:
+    r = sexp_fp_mul(ctx, a, b);
+    break;
+  case SEXP_NUM_FLO_BIG:
+    r = sexp_make_flonum(ctx, sexp_flonum_value(a) * sexp_bignum_to_double(b));
+    break;
+  case SEXP_NUM_BIG_BIG:
+    r = sexp_bignum_normalize(sexp_bignum_mul(ctx, NULL, a, b));
+    break;
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_FLO_RAT:
+    r = sexp_make_flonum(ctx, sexp_flonum_value(a) * sexp_ratio_to_double(b));
+    break;
+  case SEXP_NUM_FIX_RAT:
+  case SEXP_NUM_BIG_RAT:
+    a = tmp = sexp_make_ratio(ctx, a, SEXP_ONE);
+    /* ... FALLTHROUGH ... */
+  case SEXP_NUM_RAT_RAT:
+    r = sexp_ratio_mul(ctx, a, b);
+    break;
+#endif
+#if SEXP_USE_COMPLEX
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_RAT_CPX:
+#endif
+  case SEXP_NUM_FLO_CPX:
+  case SEXP_NUM_FIX_CPX:
+  case SEXP_NUM_BIG_CPX:
+    a = tmp = sexp_make_complex(ctx, a, SEXP_ZERO);
+    /* ... FALLTHROUGH ... */
+  case SEXP_NUM_CPX_CPX:
+    r = sexp_complex_mul(ctx, a, b);
+    break;
+#endif
+  }
+  sexp_gc_release1(ctx);
+  return r;
+}
+
+sexp sexp_div (sexp ctx, sexp a, sexp b) {
+  int at=sexp_number_type(a), bt=sexp_number_type(b);
+#if ! SEXP_USE_RATIOS
+  double f;
+#endif
+  sexp r=SEXP_VOID;
+  sexp_gc_var1(tmp);
+  sexp_gc_preserve1(ctx, tmp);
+  switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) {
+  case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
+  case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_NOT_RAT:
+#endif
+    r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a);
+    break;
+  case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT:
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_RAT_NOT:
+#endif
+    r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, b);
+    break;
+  case SEXP_NUM_FIX_FIX:
+#if SEXP_USE_RATIOS
+    tmp = sexp_make_ratio(ctx, a, b);
+    r = sexp_ratio_normalize(ctx, tmp, SEXP_FALSE);
+#else
+    f = sexp_fixnum_to_double(a) / sexp_fixnum_to_double(b);
+    r = ((f == trunc(f)) ? sexp_make_fixnum((sexp_sint_t)f)
+         : sexp_make_flonum(ctx, f));
+#endif
+    break;
+  case SEXP_NUM_FIX_FLO:
+    r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_flonum_value(b));
+    break;
+  case SEXP_NUM_FIX_BIG:
+#if SEXP_USE_RATIOS
+    tmp = sexp_make_ratio(ctx, a, b);
+    r = sexp_ratio_normalize(ctx, tmp, SEXP_FALSE);
+#else
+    r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_bignum_to_double(b)); 
+#endif
+    break;
+  case SEXP_NUM_FLO_FIX:
+    r = sexp_make_flonum(ctx, sexp_flonum_value(a)/sexp_fixnum_to_double(b));
+    break;
+  case SEXP_NUM_FLO_FLO:
+    r = sexp_fp_div(ctx, a, b);
+    break;
+  case SEXP_NUM_FLO_BIG:
+    r = sexp_make_flonum(ctx, sexp_flonum_value(a) / sexp_bignum_to_double(b));
+    break;
+  case SEXP_NUM_BIG_FIX:
+#if SEXP_USE_RATIOS
+    tmp = sexp_make_ratio(ctx, a, b);
+    r = sexp_ratio_normalize(ctx, tmp, SEXP_FALSE);
+    break;
+#else
+    b = tmp = sexp_fixnum_to_bignum(ctx, b);
+#endif
+    /* ... FALLTHROUGH if ! SEXP_USE_RATIOS ... */
+  case SEXP_NUM_BIG_BIG:
+#if SEXP_USE_RATIOS
+    tmp = sexp_make_ratio(ctx, a, b);
+    r = sexp_ratio_normalize(ctx, tmp, SEXP_FALSE);
+#else
+    r = sexp_bignum_quot_rem(ctx, &tmp, a, b);
+    if (sexp_bignum_normalize(tmp) != SEXP_ZERO)
+      r = sexp_make_flonum(ctx, sexp_bignum_to_double(a)
+                           / sexp_bignum_to_double(b));
+    else
+      r = sexp_bignum_normalize(r);
+#endif
+    break;
+  case SEXP_NUM_BIG_FLO:
+    r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) / sexp_flonum_value(b));
+    break;
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_FLO_RAT:
+    r = sexp_make_flonum(ctx, sexp_flonum_value(a) / sexp_ratio_to_double(b));
+    break;
+  case SEXP_NUM_RAT_FLO:
+    r = sexp_make_flonum(ctx, sexp_ratio_to_double(a) / sexp_flonum_value(b));
+    break;
+  case SEXP_NUM_RAT_FIX:
+  case SEXP_NUM_RAT_BIG:
+    b = tmp = sexp_make_ratio(ctx, b, SEXP_ONE);
+    /* ... FALLTHROUGH ... */
+  case SEXP_NUM_FIX_RAT:
+  case SEXP_NUM_BIG_RAT:
+    if (!sexp_ratiop(a))
+      a = tmp = sexp_make_ratio(ctx, a, SEXP_ONE);
+    /* ... FALLTHROUGH ... */
+  case SEXP_NUM_RAT_RAT:
+    r = sexp_ratio_div(ctx, a, b);
+    break;
+#endif
+#if SEXP_USE_COMPLEX
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_CPX_RAT:
+    b = tmp = sexp_make_flonum(ctx, sexp_ratio_to_double(b));
+    /* ... FALLTHROUGH ... */
+#endif
+  case SEXP_NUM_CPX_FLO:
+  case SEXP_NUM_CPX_FIX:
+  case SEXP_NUM_CPX_BIG:
+    b = tmp = sexp_make_complex(ctx, b, SEXP_ZERO);
+    /* ... FALLTHROUGH ... */
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_RAT_CPX:
+    if (sexp_ratiop(a))
+      a = tmp = sexp_make_flonum(ctx, sexp_ratio_to_double(a));
+    /* ... FALLTHROUGH ... */
+#endif
+  case SEXP_NUM_FLO_CPX:
+  case SEXP_NUM_FIX_CPX:
+  case SEXP_NUM_BIG_CPX:
+    if (!sexp_complexp(a))
+      a = tmp = sexp_make_complex(ctx, a, SEXP_ZERO);
+    /* ... FALLTHROUGH ... */
+  case SEXP_NUM_CPX_CPX:
+    r = sexp_complex_div(ctx, a, b);
+    break;
+#endif
+  }
+  sexp_gc_release1(ctx);
+  return r;
+}
+
+sexp sexp_to_inexact (sexp ctx, sexp a) {
+  if (sexp_fixnump(a)) return sexp_fixnum_to_flonum(ctx, a);
+  if (sexp_bignump(a)) return sexp_make_flonum(ctx, sexp_bignum_to_double(a));
+  return a;
+}
+
+sexp sexp_quotient (sexp ctx, sexp a, sexp b) {
+  int at=sexp_number_type(a), bt=sexp_number_type(b);
+  sexp r=SEXP_VOID;
+  sexp_gc_var1(tmp);
+  if (b == SEXP_ONE) return a;
+  sexp_gc_preserve1(ctx, tmp);
+  switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) {
+  case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
+  case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
+    r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a);
+    break;
+  case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT:
+    r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b);
+    break;
+  case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG:
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_FLO_RAT:
+#endif
+    if (sexp_flonum_value(a) != trunc(sexp_flonum_value(a))) {
+      r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a);
+    } else {
+      tmp = sexp_bignum_normalize(sexp_double_to_bignum(ctx, sexp_flonum_value(a)));
+      tmp = sexp_quotient(ctx, tmp, b);
+      r = sexp_to_inexact(ctx, tmp);
+    }
+    break;
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_RAT_FIX: case SEXP_NUM_RAT_BIG: case SEXP_NUM_RAT_RAT:
+#endif
+#if SEXP_USE_COMPLEX
+  case SEXP_NUM_FLO_CPX: case SEXP_NUM_CPX_FIX: case SEXP_NUM_CPX_FLO:
+  case SEXP_NUM_CPX_BIG: case SEXP_NUM_CPX_CPX:
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_CPX_RAT:
+#endif
+#endif
+    r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a);
+    break;
+  case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO:
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_RAT_FLO:
+#endif
+    if (sexp_flonum_value(b) != trunc(sexp_flonum_value(b))) {
+      r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b);
+    } else {
+      tmp = sexp_bignum_normalize(sexp_double_to_bignum(ctx, sexp_flonum_value(b)));
+      tmp = sexp_quotient(ctx, a, tmp);
+      r = sexp_to_inexact(ctx, tmp);
+    }
+    break;
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_FIX_RAT: case SEXP_NUM_BIG_RAT:
+#endif
+#if SEXP_USE_COMPLEX
+  case SEXP_NUM_FIX_CPX: case SEXP_NUM_BIG_CPX:
+#endif
+    r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b);
+    break;
+  case SEXP_NUM_FIX_FIX:
+    r = sexp_fx_div(a, b);
+    break;
+  case SEXP_NUM_FIX_BIG:
+    r = SEXP_ZERO;
+    break;
+  case SEXP_NUM_BIG_FIX:
+    b = tmp = sexp_fixnum_to_bignum(ctx, b);
+    /* ... FALLTHROUGH ... */
+  case SEXP_NUM_BIG_BIG:
+    r = sexp_bignum_normalize(sexp_bignum_quotient(ctx, a, b));
+    break;
+  }
+  sexp_gc_release1(ctx);
+  return r;
+}
+
+sexp sexp_remainder (sexp ctx, sexp a, sexp b) {
+  int at=sexp_number_type(a), bt=sexp_number_type(b);
+  sexp r=SEXP_VOID;
+  sexp_gc_var1(tmp);
+  if (b == SEXP_ONE) return SEXP_ZERO;
+  sexp_gc_preserve1(ctx, tmp);
+  switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) {
+  case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
+  case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
+    r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a);
+    break;
+  case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT:
+    r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b);
+    break;
+  case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG:
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_FLO_RAT:
+#endif
+    if (sexp_flonum_value(a) != trunc(sexp_flonum_value(a))) {
+      r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a);
+    } else {
+      tmp = sexp_bignum_normalize(sexp_double_to_bignum(ctx, sexp_flonum_value(a)));
+      tmp = sexp_remainder(ctx, tmp, b);
+      r = sexp_to_inexact(ctx, tmp);
+    }
+    break;
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_RAT_FIX: case SEXP_NUM_RAT_BIG: case SEXP_NUM_RAT_RAT:
+#endif
+#if SEXP_USE_COMPLEX
+  case SEXP_NUM_FLO_CPX: case SEXP_NUM_CPX_FIX: case SEXP_NUM_CPX_FLO:
+  case SEXP_NUM_CPX_BIG: case SEXP_NUM_CPX_CPX:
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_CPX_RAT:
+#endif
+#endif
+    r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a);
+    break;
+  case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO:
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_RAT_FLO:
+#endif
+    if (sexp_flonum_value(b) != trunc(sexp_flonum_value(b))) {
+      r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b);
+    } else {
+      tmp = sexp_bignum_normalize(sexp_double_to_bignum(ctx, sexp_flonum_value(b)));
+      tmp = sexp_remainder(ctx, a, tmp);
+      r = sexp_to_inexact(ctx, tmp);
+    }
+    break;
+#if SEXP_USE_RATIOS
+  case SEXP_NUM_FIX_RAT: case SEXP_NUM_BIG_RAT:
+#endif
+#if SEXP_USE_COMPLEX
+  case SEXP_NUM_FIX_CPX: case SEXP_NUM_BIG_CPX:
+#endif
+    r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b);
+    break;
+  case SEXP_NUM_FIX_FIX:
+    r = sexp_fx_rem(a, b);
+    break;
+  case SEXP_NUM_FIX_BIG:
+    r = a;
+    break;
+  case SEXP_NUM_BIG_FIX:
+    r = sexp_bignum_fxrem(ctx, a, sexp_unbox_fixnum(b));
+    break;
+  case SEXP_NUM_BIG_BIG:
+    r = sexp_bignum_normalize(sexp_bignum_remainder(ctx, a, b));
+    break;
+  }
+  sexp_gc_release1(ctx);
+  return r;
+}
+
+sexp sexp_compare (sexp ctx, sexp a, sexp b) {
+  int at=sexp_number_type(a), bt=sexp_number_type(b);
+  sexp r=SEXP_VOID;
+  double f, g;
+  sexp_gc_var1(tmp);
+  sexp_gc_preserve1(ctx, tmp);
+  if (at > bt) {
+    r = sexp_compare(ctx, b, a);
+    sexp_negate(r);
+  } else {
+    switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) {
+    case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
+    case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
+#if SEXP_USE_COMPLEX
+    case SEXP_NUM_CPX_CPX: case SEXP_NUM_CPX_FIX:
+    case SEXP_NUM_CPX_FLO: case SEXP_NUM_CPX_BIG:
+#if SEXP_USE_RATIOS
+    case SEXP_NUM_CPX_RAT:
+#endif
+#endif
+      r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a);
+      break;
+    case SEXP_NUM_FIX_FIX:
+      r = sexp_make_fixnum(sexp_unbox_fixnum(a) - sexp_unbox_fixnum(b));
+      break;
+    case SEXP_NUM_FIX_FLO:
+      f = sexp_fixnum_to_double(a);
+      g = sexp_flonum_value(b);
+      r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
+      break;
+    case SEXP_NUM_FIX_BIG:
+      if ((sexp_bignum_hi(b) > 1) ||
+          (sexp_bignum_data(b)[0] > SEXP_MAX_FIXNUM))
+        r = sexp_make_fixnum(sexp_bignum_sign(b) < 0 ? 1 : -1);
+      else
+        r = sexp_make_fixnum(sexp_unbox_fixnum(a) - (sexp_sint_t)sexp_bignum_data(b)[0]);
+      break;
+    case SEXP_NUM_FLO_FLO:
+      f = sexp_flonum_value(a);
+      g = sexp_flonum_value(b);
+      r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
+      break;
+    case SEXP_NUM_FLO_BIG:
+      f = sexp_flonum_value(a);
+      if (isinf(f)) {
+        r = f > 0 ? SEXP_ONE : SEXP_NEG_ONE;
+        break;
+      } else if (isnan(f)) {
+        r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", a);
+        break;
+      } else {
+        a = tmp = sexp_double_to_bignum(ctx, f);
+      }
+      /* ... FALLTHROUGH ... */
+    case SEXP_NUM_BIG_BIG:
+      r = sexp_make_fixnum(sexp_bignum_compare(a, b));
+      break;
+#if SEXP_USE_RATIOS
+    case SEXP_NUM_FLO_RAT:
+      f = sexp_flonum_value(a);
+      if (isinf(f)) {
+        r = f > 0 ? SEXP_ONE : SEXP_NEG_ONE;
+      } else if (isnan(f)) {
+        r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", a);
+      } else {
+        g = sexp_ratio_to_double(b);
+        r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
+      }
+      break;
+    case SEXP_NUM_FIX_RAT:
+    case SEXP_NUM_BIG_RAT:
+      a = tmp = sexp_make_ratio(ctx, a, SEXP_ONE);
+      /* ... FALLTHROUGH ... */
+    case SEXP_NUM_RAT_RAT:
+      r = sexp_ratio_compare(ctx, a, b);
+      break;
+#endif
+    }
+  }
+  sexp_gc_release1(ctx);
+  return r;
+}
+
+#endif
diff --git a/build-lib/chibi/char-set/compute.scm b/build-lib/chibi/char-set/compute.scm
new file mode 100644
index 00000000..73b7a816
--- /dev/null
+++ b/build-lib/chibi/char-set/compute.scm
@@ -0,0 +1,20 @@
+
+(define char-set:letter+digit
+  (immutable-char-set (char-set-union char-set:letter char-set:digit)))
+
+(define char-set:hex-digit
+  (immutable-char-set
+   (char-set-union (string->char-set "0123456789abcdefABCDEF"))))
+
+(define char-set:iso-control
+  (immutable-char-set
+   (char-set-union (ucs-range->char-set 0 #x20)
+                   (ucs-range->char-set #x7F #xA0))))
+
+(define char-set:graphic
+  (immutable-char-set
+   (char-set-union
+    char-set:letter char-set:digit char-set:punctuation char-set:symbol)))
+
+(define char-set:printing
+  (immutable-char-set (char-set-union char-set:whitespace char-set:graphic)))
diff --git a/build-lib/chibi/char-set/compute.sld b/build-lib/chibi/char-set/compute.sld
new file mode 100644
index 00000000..767c37c4
--- /dev/null
+++ b/build-lib/chibi/char-set/compute.sld
@@ -0,0 +1,22 @@
+
+;; Don't import this - it's temporarily used to compute optimized
+;; char-set representations.
+
+(define-library (chibi char-set compute)
+  (import (chibi) (chibi iset) (chibi char-set))
+  (include "derived.scm" "compute.scm")
+  (export
+   char-set:lower-case
+   char-set:upper-case
+   char-set:title-case
+   char-set:letter
+   char-set:punctuation
+   char-set:symbol
+   char-set:blank
+   char-set:whitespace
+   char-set:digit
+   char-set:letter+digit
+   char-set:hex-digit
+   char-set:iso-control
+   char-set:graphic
+   char-set:printing))
diff --git a/chibi-scheme.pc.in b/chibi-scheme.pc.in
new file mode 100644
index 00000000..82dcd9ed
--- /dev/null
+++ b/chibi-scheme.pc.in
@@ -0,0 +1,7 @@
+Name: chibi-scheme
+URL: http://synthcode.com/scheme/chibi/
+Description: Minimal Scheme Implementation for use as an Extension Language
+Version: ${version}
+Libs: -L${libdir} -lchibi-scheme
+Libs.private: -dl -lm
+Cflags: -I${includedir}
diff --git a/chibi-scheme.vcproj b/chibi-scheme.vcproj
new file mode 100644
index 00000000..86bd69e9
--- /dev/null
+++ b/chibi-scheme.vcproj
@@ -0,0 +1,206 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<VisualStudioProject
+	ProjectType="Visual C++"
+	Version="9.00"
+	Name="chibi-scheme"
+	ProjectGUID="{38DC39DA-5328-4FFE-84E2-E16FF1864945}"
+	RootNamespace="chibi-scheme"
+	Keyword="Win32Proj"
+	TargetFrameworkVersion="0"
+	>
+	<Platforms>
+		<Platform
+			Name="Win32"
+		/>
+	</Platforms>
+	<ToolFiles>
+	</ToolFiles>
+	<Configurations>
+		<Configuration
+			Name="Debug|Win32"
+			OutputDirectory="Debug"
+			IntermediateDirectory="Debug"
+			ConfigurationType="2"
+			>
+			<Tool
+				Name="VCPreBuildEventTool"
+			/>
+			<Tool
+				Name="VCCustomBuildTool"
+			/>
+			<Tool
+				Name="VCXMLDataGeneratorTool"
+			/>
+			<Tool
+				Name="VCWebServiceProxyGeneratorTool"
+			/>
+			<Tool
+				Name="VCMIDLTool"
+			/>
+			<Tool
+				Name="VCCLCompilerTool"
+				Optimization="0"
+				AdditionalIncludeDirectories="include"
+				PreprocessorDefinitions="WIN32;_DEBUG;_WINDOWS;_USRDLL;CHIBISCHEME_EXPORTS"
+				MinimalRebuild="true"
+				BasicRuntimeChecks="3"
+				RuntimeLibrary="3"
+				UsePrecompiledHeader="0"
+				WarningLevel="3"
+				Detect64BitPortabilityProblems="true"
+				DebugInformationFormat="4"
+			/>
+			<Tool
+				Name="VCManagedResourceCompilerTool"
+			/>
+			<Tool
+				Name="VCResourceCompilerTool"
+			/>
+			<Tool
+				Name="VCPreLinkEventTool"
+			/>
+			<Tool
+				Name="VCLinkerTool"
+				LinkIncremental="2"
+				GenerateDebugInformation="true"
+				SubSystem="2"
+				TargetMachine="1"
+			/>
+			<Tool
+				Name="VCALinkTool"
+			/>
+			<Tool
+				Name="VCManifestTool"
+			/>
+			<Tool
+				Name="VCXDCMakeTool"
+			/>
+			<Tool
+				Name="VCBscMakeTool"
+			/>
+			<Tool
+				Name="VCFxCopTool"
+			/>
+			<Tool
+				Name="VCAppVerifierTool"
+			/>
+			<Tool
+				Name="VCPostBuildEventTool"
+			/>
+		</Configuration>
+		<Configuration
+			Name="Release|Win32"
+			OutputDirectory="Release"
+			IntermediateDirectory="Release"
+			ConfigurationType="2"
+			>
+			<Tool
+				Name="VCPreBuildEventTool"
+			/>
+			<Tool
+				Name="VCCustomBuildTool"
+			/>
+			<Tool
+				Name="VCXMLDataGeneratorTool"
+			/>
+			<Tool
+				Name="VCWebServiceProxyGeneratorTool"
+			/>
+			<Tool
+				Name="VCMIDLTool"
+			/>
+			<Tool
+				Name="VCCLCompilerTool"
+				PreprocessorDefinitions="WIN32;NDEBUG;_WINDOWS;_USRDLL;CHIBISCHEME_EXPORTS;"
+				RuntimeLibrary="2"
+				UsePrecompiledHeader="0"
+				WarningLevel="3"
+				Detect64BitPortabilityProblems="true"
+				DebugInformationFormat="3"
+			/>
+			<Tool
+				Name="VCManagedResourceCompilerTool"
+			/>
+			<Tool
+				Name="VCResourceCompilerTool"
+			/>
+			<Tool
+				Name="VCPreLinkEventTool"
+			/>
+			<Tool
+				Name="VCLinkerTool"
+				LinkIncremental="2"
+				GenerateDebugInformation="true"
+				SubSystem="2"
+				OptimizeReferences="2"
+				EnableCOMDATFolding="2"
+				TargetMachine="1"
+			/>
+			<Tool
+				Name="VCALinkTool"
+			/>
+			<Tool
+				Name="VCManifestTool"
+			/>
+			<Tool
+				Name="VCXDCMakeTool"
+			/>
+			<Tool
+				Name="VCBscMakeTool"
+			/>
+			<Tool
+				Name="VCFxCopTool"
+			/>
+			<Tool
+				Name="VCAppVerifierTool"
+			/>
+			<Tool
+				Name="VCPostBuildEventTool"
+			/>
+		</Configuration>
+	</Configurations>
+	<References>
+	</References>
+	<Files>
+		<Filter
+			Name="Header Files"
+			Filter="h;hpp;hxx;hm;inl;inc;xsd"
+			UniqueIdentifier="{93995380-89BD-4b04-88EB-625FBE52EBFB}"
+			>
+		</Filter>
+		<Filter
+			Name="Resource Files"
+			Filter="rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe;resx"
+			UniqueIdentifier="{67DA6AB6-F800-4c08-8B7A-83BB121AAD01}"
+			>
+		</Filter>
+		<Filter
+			Name="Source Files"
+			Filter="cpp;c;cc;cxx;def;odl;idl;hpj;bat;asm;asmx"
+			UniqueIdentifier="{4FC737F1-C7A5-4376-A066-2A32D752A2FF}"
+			>
+			<File
+				RelativePath=".\eval.c"
+				>
+			</File>
+			<File
+				RelativePath=".\main.c"
+				>
+			</File>
+			<File
+				RelativePath=".\sexp.c"
+				>
+				<FileConfiguration
+					Name="Debug|Win32"
+					>
+					<Tool
+						Name="VCCLCompilerTool"
+						PreprocessorDefinitions="-DPLATFORM=mingw;-DSEXP_USE_STRING_STREAMS=0;-DSEXP_USE_DEBUG=0;-DSEXP_USE_DL=0;-DBUILDING_DLL"
+					/>
+				</FileConfiguration>
+			</File>
+		</Filter>
+	</Files>
+	<Globals>
+	</Globals>
+</VisualStudioProject>
diff --git a/contrib/bash_completion b/contrib/bash_completion
new file mode 100644
index 00000000..021a4d65
--- /dev/null
+++ b/contrib/bash_completion
@@ -0,0 +1,69 @@
+# bash -*- shell-script -*- completion for chibi-scheme
+
+type chibi-scheme >/dev/null 2>/dev/null && {
+
+_chibi-modules() {
+  for dir in ./lib/ /usr/local/share/chibi/ "$@" \
+    $(echo $CHIBI_MODULE_PATH | tr ':' ' '); do
+    find "$dir" -name \*.sld 2>/dev/null \
+      | sed 's!'"$dir"'/*!!;s!\.sld$!!;s!/!.!g'
+  done | sort -u
+}
+
+_chibi-scheme() {
+  local cur prev
+  # Just some likely sample sizes, you're not limited to these.
+  local sizes="1M 2M 4M 8M 16M 32M 64M 128M 256M 512M 1G 2G 4G"
+
+  COMPREPLY=()
+
+  # We don't require a space between single-char options and the value.
+  cur=`_get_cword`
+  case "$cur" in
+    -m*)
+      COMPREPLY=( $( compgen -W "$(_chibi-modules | sed 's!^!-m!')" -- "$cur") )
+      return 0;;
+    -x*)
+      COMPREPLY=( $( compgen -W "$(_chibi-modules | sed 's!^!-x!')" -- "$cur") )
+      return 0;;
+    -l*)
+      compopt -o nospace
+      _filedir
+      return 0;;
+    -A*)
+      compopt -o nospace
+      COMPREPLY=( $( compgen -d -- "${cur#-A}" | sed 's!^!-A!' ) )
+      return 0;;
+    -I*)
+      compopt -o nospace
+      COMPREPLY=( $( compgen -d -- "${cur#-I}" | sed 's!^!-I!' ) )
+      return 0;;
+    -h*)
+      COMPREPLY=( $( compgen -W "$(echo $sizes | tr ' ' '\n' | sed 's!^!-h!')" -- "${cur}" ) )
+      return 0;;
+    -)
+      COMPREPLY=( $( compgen -W '-d -e -f -h -i -l -m -p -q -x -A -I -V' \
+        -- "$cur") )
+      return 0;;
+    -*)
+      return 0;;
+  esac
+
+  # Not connected to the option, check the previous word.
+  prev=${COMP_WORDS[COMP_CWORD-1]}
+  case "$prev" in
+    -[mx])
+      COMPREPLY=( $( compgen -W "$(_chibi-modules)" -- "$cur") )
+      return 0;;
+    -[AIl])
+      _filedir
+      return 0;;
+    -h)
+      COMPREPLY=( $( compgen -W "$sizes" -- "$cur" ) )
+      return 0;;
+  esac
+}
+
+complete -f -F _chibi-scheme chibi-scheme
+
+}
diff --git a/data/.hgignore b/data/.hgignore
new file mode 100644
index 00000000..9acc7fcd
--- /dev/null
+++ b/data/.hgignore
@@ -0,0 +1,2 @@
+syntax: glob
+*.txt
diff --git a/doc/chibi-doc.1 b/doc/chibi-doc.1
new file mode 100644
index 00000000..1c95de76
--- /dev/null
+++ b/doc/chibi-doc.1
@@ -0,0 +1,55 @@
+.TH "chibi-doc" "1" "" ""
+.UC 4
+.SH NAME
+.PP
+chibi-doc \- generate docs from Scheme scribble syntax
+
+.SH SYNOPSIS
+.B chibi-doc
+[-hst]
+[
+.I file
+]
+.BR
+
+.B chibi-doc
+.I dotted-name.of.module
+[
+.I identifier
+]
+.BR
+.SP 0.4
+
+.SH DESCRIPTION
+.I chibi-doc
+is a tool to generate documentation from the Scheme scribble syntax
+from Racket.  It works like a Unix filter, translating from the
+current input or a file to standard output.  You can also specify a
+module name, with components separated with dots, and it will search
+for the module and generate documentation from it automatically from
+literate comments in the module or any of its source files.  These
+comments are any line beginning with the characters
+.I ;;>
+
+The scribble syntax is described in the manual.
+
+.SH OPTIONS
+.TP 5
+.BI -h
+Outputs in HTML format (the default).
+.TP
+.BI -s
+Outputs in SXML format.
+.TP
+.BI -t
+Outputs in text format (the default for describing a single variable).
+
+.SH AUTHORS
+.PP
+Alex Shinn (alexshinn @ gmail . com)
+
+.SH SEE ALSO
+.PP
+The chibi-scheme home-page:
+.BR
+http://code.google.com/p/chibi-scheme/
diff --git a/doc/chibi-ffi.1 b/doc/chibi-ffi.1
new file mode 100644
index 00000000..00bca31a
--- /dev/null
+++ b/doc/chibi-ffi.1
@@ -0,0 +1,45 @@
+.TH "chibi-ffi" "1" "" ""
+.UC 4
+.SH NAME
+.PP
+chibi-ffi \- generate C from Scheme stub files
+
+.SH SYNOPSIS
+.B chibi-ffi
+[-c]
+[-f
+.I
+cflags
+]
+input.stub
+[
+.I output.c
+]
+.BR
+.SP 0.4
+
+.SH DESCRIPTION
+.I chibi-ffi
+reads in the C function FFI definitions from an input file and outputs
+the appropriate C wrappers into a file with the same base name and the
+".c" extension.  You can then compile that C file into a shared
+library:
+
+  chibi-ffi file.stub
+  cc -fPIC -shared file.c -lchibi-scheme
+
+If the -c option is specified then chibi-ffi attempts to compile the
+generated C code for you in one step.  In this case, additional flags
+for the C compiler may be given with the -f option.
+
+The FFI syntax is described in the manual.
+
+.SH AUTHORS
+.PP
+Alex Shinn (alexshinn @ gmail . com)
+
+.SH SEE ALSO
+.PP
+The chibi-scheme home-page:
+.BR
+http://code.google.com/p/chibi-scheme/
diff --git a/doc/chibi-scheme.1 b/doc/chibi-scheme.1
new file mode 100644
index 00000000..583f6673
--- /dev/null
+++ b/doc/chibi-scheme.1
@@ -0,0 +1,239 @@
+.TH "chibi-scheme" "1" "" ""
+.UC 4
+.SH NAME
+.PP
+chibi-scheme \- a tiny Scheme interpreter
+
+.SH SYNOPSIS
+.B chibi-scheme
+[-qQrRfV]
+[-I
+.I path
+]
+[-A
+.I path
+]
+[-m
+.I module
+]
+[-x
+.I module
+]
+[-l
+.I file
+]
+[-e
+.I expr
+]
+[-p
+.I expr
+]
+[-t
+.I module.id
+]
+[-d
+.I image-file
+]
+[-i
+.I image-file
+]
+[--]
+[
+.I script argument ...
+]
+.br
+.sp 0.4
+
+.SH DESCRIPTION
+.I chibi-scheme
+is a sample interactive Scheme interpreter for the
+.I chibi-scheme
+library.  It serves as an example of how to embed
+.I chibi-scheme
+in applications, and can be useful on its own for writing
+scripts and interactive development.
+
+When
+.I script
+is given, the script will be loaded with SRFI-22 semantics,
+calling the procedure
+.I main
+(if defined) with a single parameter as a list of the
+command-line arguments beginning with the script name.  This
+works as expected with shell #! semantics.
+
+Otherwise, if no script is given and no -e or -p options
+are given an interactive repl is entered, reading, evaluating,
+then printing expressions until EOF is reached.  The repl
+provided is very minimal - if you want readline
+completion you may want to wrap it with the
+.I rlwrap(1)
+program.  Signals aren't caught either - to enable handling keyboard
+interrupts you can use the (chibi process) module.  For a more
+sophisticated REPL with readline support, signal handling, module
+management and smarter read/write you may want to use the (chibi repl)
+module.  This can be launched automatically with:
+.I chibi-scheme -R
+\[char46]
+
+The default language the R7RS
+(scheme base) module.  To get a mostly R5RS-compatible language, use
+.I chibi-scheme -xscheme.r5rs
+or to get just the core language used for bootstrapping, use
+.I chibi-scheme -xchibi
+or its shortcut
+.I chibi-scheme -q
+\[char46]
+
+.SH OPTIONS
+
+Space is optional between options and their arguments.  Options
+without arguments may not be chained together.
+
+To reduce the need for shell escapes, options with module arguments
+(
+.I -m
+,
+.I -x
+and
+.I -R
+) are written in a dot notation, so that the module
+.I (foo bar)
+is written as
+.I foo.bar
+\[char46]
+
+.TP 5
+.BI -V
+Prints the version information and exits.
+.TP
+.BI -q
+"Quick" load, shortcut for
+.I chibi-scheme -xchibi
+This is a slightly different language from (scheme base),
+which may load faster, and is guaranteed not to load any
+additional shared libraries.
+.TP
+.BI -Q
+Extra "quick" load, shortcut for
+.I chibi-scheme -xchibi.primitive
+The resulting environment will only contain the core syntactic
+forms and primitives coded in C.  This is very fast and guaranteed
+not to load any external files, but is also very limited.
+.TP
+.BI -r [main]
+Run the "main" procedure when the script finishes loading as in SRFI-22.
+.TP
+.BI -R [module]
+Loads the given module and runs the "main" procedure it defines (which
+need not be exported) with a single argument of the list of command-line
+arguments as in SRFI-22.  The name "main" can be overridden with the -r
+option.
+.I [module]
+may be omitted, in which case it default to chibi.repl.  Thus
+.I chibi-scheme -R
+is the recommended means to obtain the advanced REPL.
+.TP
+.BI -s
+Strict mode, escalating warnings to fatal errors.
+.TP
+.BI -f
+Change the reader to case-fold symbols as in R5RS.
+.TP
+.BI -h size[/max_size]
+Specifies the initial size of the heap, in bytes,
+optionally followed by the maximum size the heap can
+grow to.
+.I size
+can be any integer value, optionally suffixed by
+"K", for kilobytes, "M" for megabytes, or "G" for gigabytes.
+.I -h
+must be specified before any options which load or
+evaluate Scheme code.
+.TP
+.BI -I path
+Inserts
+.I path
+on front of the load path list.  
+.TP
+.BI -A path
+Appends
+.I path
+to the load path list.  
+.TP
+.BI -m module
+.TP
+.BI -x module
+Imports
+.I module
+as though "(import
+.I module
+)" were evaluated.
+If the
+.BI -x
+version is used, then
+.I module
+replaces the current environment instead of being added to it.
+.TP
+.BI -l file
+Loads the Scheme source from the file
+.I file
+searched for in the default load path.
+.TP
+.BI -e expr
+Evaluates the Scheme expression
+.I expr.
+.TP
+.BI -p expr
+Evaluates the Scheme expression
+.I expr
+then prints the result to stdout.
+.TP
+.BI -t module.id
+Enables tracing for the given identifier
+.I id
+in the module
+.I module.
+.TP
+.BI -d image-file
+Dumps the current Scheme heap to
+.I image-file
+and exits.  This feature is still experimental.
+.TP
+.BI -i image-file
+Loads the Scheme heap from
+.I image-file
+instead of compiling the init file on the fly.
+This feature is still experimental.
+
+.SH ENVIRONMENT
+.TP
+.B CHIBI_MODULE_PATH
+A colon separated list of directories to search for module
+files, inserted before the system default load paths.  chibi-scheme
+searchs for modules in directories in the following order:
+
+.TP
+          directories included with the -I path option
+.TP
+          directories included from CHIBI_MODULE_PATH
+.TP
+          system directories 
+.TP
+          directories included with -A path option
+
+If CHIBI_MODULE_PATH is unset, the directoriese "./lib", and "." are
+search in order.
+
+.SH AUTHORS
+.PP
+Alex Shinn (alexshinn @ gmail . com)
+
+.SH SEE ALSO
+.PP
+More detailed information can be found in the manuale included in
+doc/chibi.scrbl included in the distribution.
+
+The chibi-scheme home-page:
+.br
+http://code.google.com/p/chibi-scheme/
diff --git a/doc/chibi.scrbl b/doc/chibi.scrbl
new file mode 100755
index 00000000..43e990ff
--- /dev/null
+++ b/doc/chibi.scrbl
@@ -0,0 +1,1317 @@
+\; #lang scribble/manual
+
+\title{Chibi-Scheme}
+\author{Alex Shinn}
+
+\centered{\smaller{Minimal Scheme Implementation for use as an Extension Language}}
+\centered{\url{http://synthcode.com/wiki/chibi-scheme/}}
+
+\section{Introduction}
+
+Chibi-Scheme is a very small library with no external dependencies,
+intended for use as an extension and scripting language in C programs.
+In addition to support for lightweight VM-based threads, each VM
+itself runs in an isolated heap allowing multiple VMs to run
+simultaneously in different OS threads.
+
+The default language is the R7RS (scheme base) library, with support
+for all libraries from the small language.  Support for additional
+languages such as JavaScript, Go, Lua and Bash are planned for future
+releases.  Scheme is chosen as a substrate because its first class
+continuations and guaranteed tail-call optimization makes implementing
+other languages easy.
+
+The system is designed in optional layers, beginning with a VM based
+on a small set of opcodes, a set of primitives implemented in C, a
+default language, a module system implementation, and a set of
+standard modules.  You can choose whichever layer suits your needs
+best and customize the rest.  Adding your own primitives or wrappers
+around existing C libraries is easy with the C FFI.
+
+Chibi is known to build and run on 32 and 64-bit Linux, FreeBSD,
+DragonFly, OS X, iOS, Windows (under Cygwin) and Plan9.
+
+\section{Installation}
+
+To build, just run "make".  This will provide a shared library
+"libchibi-scheme", as well as a sample "chibi-scheme" command-line
+repl.  The "chibi-scheme-static" make target builds an equivalent
+static executable.  If your make doesn't support GNU make
+conditionals, then you'll need to edit the top of the Makefile to
+choose the appropriate settings.  On Plan9 just run "mk".  You can
+test the build with "make test".
+
+To install run "make install".  If you want to try the executable out
+without installing, you will probably need to set LD_LIBRARY_PATH,
+depending on your platform.  If you have an old version installed,
+run "make uninstall" first, or manually delete the directory.
+
+You can edit the file chibi/features.h for a number of settings,
+mostly disabling features to make the executable smaller.  You can
+specify standard options directly as arguments to make, for example
+
+\command{make CFLAGS=-Os CPPFLAGS=-DSEXP_USE_NO_FEATURES=1}
+
+to optimize for size, or
+
+\command{make LDFLAGS=-L/usr/local/lib CPPFLAGS=-I/usr/local/include}
+
+to compile against a library installed in /usr/local.
+
+By default Chibi uses a custom, precise, non-moving GC (non-moving is
+important so you can maintain references from C code).  You can link
+against the Boehm conservative GC by editing the features.h file, or
+directly from make with:
+
+\command{make SEXP_USE_BOEHM=1}
+
+To compile a static executable, use
+
+\command{make chibi-scheme-static SEXP_USE_DL=0}
+
+To compile a static executable with all C libraries statically
+included, first you need to create a clibs.c file, which can be done
+with:
+
+\command{make clibs.c}
+
+or edited manually.  Be sure to run this with a non-static
+chibi-scheme.  Then you can make the static executable with:
+
+\command{
+make -B chibi-scheme-static SEXP_USE_DL=0 CPPFLAGS=-DSEXP_USE_STATIC_LIBS
+}
+
+By default files are installed in /usr/local.  You can optionally
+specify a PREFIX for the installation directory:
+
+\command{
+make PREFIX=/path/to/install/
+sudo make PREFIX=/path/to/install/ install
+}
+
+\subsection{Compile-Time Options}
+
+The include file \ccode{"chibi/features.h"} describes a number of
+C preprocessor values which can be enabled or disabled by setting to
+1 or 0 respectively.  For example, the above commands used the
+features \ccode{SEXP_USE_BOEHM}, \ccode{SEXP_USE_DL} and
+\ccode{SEXP_USE_STATIC_LIBS}.  Many features are still experimental
+and may be removed from future releases, but the important features
+are listed below.
+
+\itemlist[
+\item{\ccode{SEXP_USE_BOEHM} - link with the Boehm GC instead of the native Chibi GC}
+\item{\ccode{SEXP_USE_DL} - allow dynamic linking (enabled by default)}
+\item{\ccode{SEXP_USE_STATIC_LIBS} - compile the standard C libs statically}
+\item{\ccode{SEXP_USE_MODULES} - use the module system}
+\item{\ccode{SEXP_USE_GREEN_THREADS} - use lightweight threads (enabled by default)}
+\item{\ccode{SEXP_USE_SIMPLIFY} - use a simplification optimizer pass (enabled by default)}
+\item{\ccode{SEXP_USE_BIGNUMS} - use bignums (enabled by default)}
+\item{\ccode{SEXP_USE_FLONUMS} - use flonums (enabled by default)}
+\item{\ccode{SEXP_USE_RATIOS} - use exact ratios (enabled by default)}
+\item{\ccode{SEXP_USE_COMPLEX} - use complex numbers (enabled by default)}
+\item{\ccode{SEXP_USE_UTF8_STRINGS} - Unicode support (enabled by default)}
+\item{\ccode{SEXP_USE_NO_FEATURES} - disable almost all features}
+]
+
+\subsection{Installed Programs}
+
+The command-line programs \ccode{chibi-scheme}, \ccode{chibi-doc} and
+\ccode{chibi-ffi} are installed by default, along with manpages.
+\ccode{chibi-scheme} provides a REPL and way to run scripts.  Run -?
+for a brief list of options, or see the man page for more details.
+\ccode{chibi-doc} is the command-line interface to the literate
+documentation system described in
+\hyperlink["lib/chibi/scribble.html"]{(chibi scribble)}, and used to
+build this manual.  \ccode{chibi-ffi} is a tool to build wrappers for
+C libraries, described in the FFI section below.
+
+\section{Default Language}
+
+\subsection{Scheme Standard}
+
+The default language is the \scheme{(scheme base)} library from
+\hyperlink["http://scheme-reports.org/"]{R7RS}, which is mostly a
+superset of
+\hyperlink["http://www.schemers.org/Documents/Standards/R5RS/HTML/"]{R5RS}.
+
+The reader defaults to case-sensitive, like R6RS and R7RS but unlike
+R5RS.  The default configuration includes the full numeric tower:
+fixnums, flonums, bignums, exact rationals and complex numbers, though
+this can be customized at compile time.
+
+Full continuations are supported, but currently continuations don't
+take C code into account.  This means that you can call from Scheme to
+C and then from C to Scheme again, but continuations passing through
+this chain may not do what you expect.  The only higher-order C
+functions (thus potentially running afoul of this) in the standard
+environment are \scheme{load} and \scheme{eval}.  The result of
+invoking a continuation created by a different thread is also
+currently unspecified.
+
+In R7RS (and R6RS) semantics it is impossible to use two macros from
+different modules which both use the same auxiliary keywords (like
+\scheme{else} in \scheme{cond} forms) without renaming one of the
+keywords.  By default Chibi considers all top-level bindings
+effectively unbound when matching auxiliary keywords, so this case
+will "just work".  This decision was made because the chance of
+different modules using the same keywords seems more likely than user
+code unintentionally matching a top-level keyword with a different
+binding, however if you want to use R7RS semantics you can compile
+with \ccode{SEXP_USE_STRICT_TOPLEVEL_BINDINGS=1}.
+
+\scheme{load} is extended to accept an optional environment argument, like
+\scheme{eval}.  You can also \scheme{load} shared libraries in addition to
+Scheme source files - in this case the function \cfun{sexp_init_library} is
+automatically called with the following signature:
+
+\ccode{
+  sexp_init_library(sexp context, sexp self, sexp_sint_t n, sexp environment,
+                    const char* version, sexp_abi_identifier_t abi);
+}
+
+Note, as R7RS (and earlier reports) states, "in contrast to other
+dialects of Lisp, the order of evaluation is unspecified [...]".
+Chibi is one of the few implementations which use a right-to-left
+evaluation order, which can be surprising to programmers coming from
+other languages.
+
+\subsection{Module System}
+
+Chibi uses the R7RS module system natively, which is a simple static
+module system in the style of the
+\hyperlink["http://s48.org/"]{Scheme48} module system.  As with most
+features this is optional, and can be ignored or completely disabled
+at compile time.
+
+Modules names are hierarchical lists of symbols or numbers.  A module
+definition uses the following form:
+
+\schemeblock{
+  (define-library (foo bar baz)
+    <library-declarations> ...)
+}
+
+where \var{<library-declarations>} can be any of
+
+\schemeblock{
+  (export <id> ...)                    ;; specify an export list
+  (import <import-spec> ...)           ;; specify one or more imports
+  (begin <expr> ...)                   ;; inline Scheme code
+  (include <file> ...)                 ;; load one or more files
+  (include-ci <file> ...)              ;; as include, with case-folding
+  (include-shared <file> ...)          ;; dynamic load a library
+}
+
+\var{<import-spec>} can either be a module name or any of
+
+\schemeblock{
+  (only <import-spec> <id> ...)
+  (except <import-spec> <id> ...)
+  (rename <import-spec> (<from-id> <to-id>) ...)
+  (prefix <prefix-id> <import-spec>)
+}
+
+These forms perform basic selection and renaming of individual
+identifiers from the given module. They may be composed to perform
+combined selection and renaming.
+
+Some modules can be statically included in the initial configuration,
+and even more may be included in image files, however in general
+modules are searched for in a module load path.  The definition of the
+module \scheme{(foo bar baz)} is searched for in the file
+\scheme{"foo/bar/baz.sld"}.  The default module path includes the
+installed directories, \scheme{"."} and \scheme{"./lib"}.  Additional
+directories can be specified with the command-line options \ccode{-I}
+and \ccode{-A} (see the command-line options below) or with the
+\scheme{add-modue-directory} procedure at runtime.  You can search for
+a module file with \scheme{(find-module-file <file>)}, or load it with
+\scheme{(load-module-file <file> <env>)}.
+
+Within the module definition, files are loaded relative to the .sld
+file, and are written with their extension (so you can use whatever
+suffix you prefer - .scm, .ss, .sls, etc.).
+
+Shared modules, on the other hand, should be specified \emph{without} the
+extension - the correct suffix will be added portably (e.g. .so for Unix and
+.dylib for OS X).
+
+You may also use \scheme{cond-expand} and arbitrary macro expansions in a
+module definition to generate \var{<module-declarations>}.
+
+\subsection{Macro System}
+
+\scheme{syntax-rules} macros are provided by default, with the extensions from
+\hyperlink["http://srfi.schemers.org/srfi-46/srfi-46.html"]{SRFI-46}.
+In addition, low-level hygienic macros are provided with a
+syntactic-closures interface, including \scheme{sc-macro-transformer},
+\scheme{rsc-macro-transformer}, and \scheme{er-macro-transformer}.  A good
+introduction to syntactic-closures can be found at
+\url{http://community.schemewiki.org/?syntactic-closures}.
+
+\scheme{identifier?}, \scheme{identifier->symbol}, \scheme{identifier=?}, and
+\scheme{make-syntactic-closure} and \scheme{strip-syntactic-closures} are
+also available.
+
+\subsection{Types}
+
+You can define new record types with
+\hyperlink["http://srfi.schemers.org/srfi-9/srfi-9.html"]{SRFI-9}, or
+inherited record types with
+\hyperlink["http://srfi.schemers.org/srfi-99/srfi-99.html"]{SRFI-99}.
+These are just syntactic sugar for the following more primitive type
+constructors:
+
+\schemeblock{
+(register-simple-type <name-string> <parent> <num-fields>)
+ => <type>
+
+(make-type-predicate <opcode-name-string> <type>)
+ => <opcode>  ; takes 1 arg, returns #t iff that arg is of the type
+
+(make-constructor <constructor-name-string> <type>)
+ => <opcode>  ; takes 0 args, returns a newly allocated instance of type
+
+(make-getter <getter-name-string> <type> <field-index>)
+ => <opcode>  ; takes 1 args, retrieves the field located at the index
+
+(make-setter <setter-name-string> <type> <field-index>)
+ => <opcode>  ; takes 2 args, sets the field located at the index
+}
+
+\subsection{Unicode}
+
+Chibi supports Unicode strings, encoding them as utf8.  This provides easy
+interoperability with many C libraries, but means that \scheme{string-ref} and
+\scheme{string-set!} are O(n), so they should be avoided in
+performance-sensitive code.
+
+In general you should use high-level APIs such as \scheme{string-map}
+to ensure fast string iteration.  String ports also provide a simple
+way to efficiently iterate and construct strings, by looping over an
+input string or accumulating characters in an output string.
+
+The \scheme{in-string} and \scheme{in-string-reverse} iterators in the
+\scheme{(chibi loop)} module will also iterate over strings
+efficiently while hiding the low-level details.
+
+In the event that you do need a low-level interface, such as when
+writing your own iterator protocol, you should use the following
+string cursor API instead of indexes.
+
+\itemlist[
+\item{\scheme{(string-cursor-start str)}
+\p{returns a start cursor for the string}}
+\item{\scheme{(string-cursor-end str)}
+\p{returns a cursor one past the last valid cursor}}
+\item{\scheme{(string-cursor-ref str cursor)}
+\p{get the char at the given cursor}}
+\item{\scheme{(string-cursor-next str cursor)}
+\p{increment to the next cursor}}
+\item{\scheme{(string-cursor-prev str cursor)}
+\p{decrement to the previous cursor}}
+\item{\scheme{(substring-cursor str cs1 [cs2])}
+\p{take a substring from the given cursors}}
+\item{\scheme{(string-cursor<? cs1 cs2)}
+\p{cs1 is before cs2}}
+\item{\scheme{(string-cursor<=? cs1 cs2)}
+\p{cs1 is before or the same as cs2}}
+\item{\scheme{(string-cursor=? cs1 cs2)}
+\p{cs1 is the same as cs2}}
+\item{\scheme{(string-cursor>? cs1 cs2)}
+\p{cs1 is after cs2}}
+\item{\scheme{(string-cursor>=? cs1 cs2)}
+\p{cs1 is the same or after cs2}}
+]
+
+\section{Embedding in C}
+
+\subsection{Quick Start}
+
+To use Chibi-Scheme in a program you need to link against the
+"libchibi-scheme" library and include the "eval.h" header file:
+
+\ccode{#include <chibi/eval.h>}
+
+All definitions begin with a "sexp_" prefix, or "SEXP_" for constants.
+In addition to the prototypes and utility macros, this includes the
+following type definitions:
+
+\itemlist[
+\item{\ctype{sexp} - an s-expression, used to represent all Scheme objects}
+\item{\ctype{sexp_uint_t} - an unsigned integer using as many bits as sexp}
+\item{\ctype{sexp_sint_t} - a signed integer using as many bits as sexp}
+]
+
+A simple program might look like:
+
+\ccodeblock{
+void dostuff(sexp ctx) {
+  /* declare and preserve local variables */
+  sexp_gc_var2(obj1, obj2);
+  sexp_gc_preserve2(ctx, obj1, obj2);
+
+  /* load a file containing Scheme code */
+  obj1 = sexp_c_string(ctx, "/path/to/source/file.scm", -1);
+  sexp_load(ctx, obj1, NULL);
+
+  /* eval a C string as Scheme code */
+  sexp_eval_string(ctx, "(some scheme expression)", -1, NULL);
+
+  /* construct a Scheme expression to eval */
+  obj1 = sexp_intern(ctx, "my-procedure", -1);
+  obj2 = sexp_cons(ctx, obj1, SEXP_NULL);
+  sexp_eval(ctx, obj2, NULL);
+
+  /* release the local variables */
+  sexp_gc_release2(ctx);
+}
+
+int main(int argc, char** argv) {
+  sexp ctx;
+  ctx = sexp_make_eval_context(NULL, NULL, NULL, 0, 0);
+  sexp_load_standard_env(ctx, NULL, SEXP_SEVEN);
+  sexp_load_standard_ports(ctx, NULL, stdin, stdout, stderr, 0);
+  dostuff(ctx);
+  sexp_destroy_context(ctx);
+}
+}
+
+Looking at \cfun{main}, \cfun{sexp_make_eval_context} and
+\cfun{sexp_destroy_context} create and destroy a "context", which
+manages the heap and VM state.  The meaning of the arguments is
+explained in detail below, but these values will give reasonable
+defaults, in this case constructing an environment with the core
+syntactic forms, opcodes, and standard C primitives.
+
+This is still a fairly bare environment, so we call
+\cfun{sexp_load_standard_env} to find and load the default
+initialization file.
+
+The resulting context can then be used to construct objects, call
+functions, and most importantly evaluate code, as is done in
+\cfun{dostuff}.  The default garbage collector for Chibi is precise,
+which means we need to declare and preserve references to any
+temporary values we may generate, which is what the
+\cmacro{sexp_gc_var2}, \cmacro{sexp_gc_preserve2} and
+\cmacro{sexp_gc_release2} macros do (there are similar macros for
+values 1-6).  Precise GCs prevent a class of memory leaks (and
+potential attackes based thereon), but if you prefer convenience then
+Chibi can be compiled with a conservative GC and you can ignore these.
+
+The interesting part is then the calls to \cfun{sexp_load},
+\cfun{eval_string} and \cfun{eval} which evaluate code stored in
+files, C strings, or represented as s-expressions respectively.
+
+Destroying a context runs any finalizers for all objects in the heap
+and then frees the heap memory (but has no effect on other contexts
+you or other users of the library may have created).
+
+\subsection{Contexts and Evaluation}
+
+Contexts represent the state needed to perform evaluation.  This includes
+keeping track of the heap (when using precise GC), a default environment,
+execution stack, and any global values.  A program being evaluated in one
+context may spawn multiple child contexts, such as when you call \scheme{eval},
+and each child will share the same heap and globals.  When using multiple
+interpreter threads, each thread has its own context.
+
+You can also create independent contexts with their own separate heaps.  These
+can run simultaneously in multiple OS threads without any need for
+synchronization.
+
+\itemlist[
+
+\item{\ccode{sexp_make_context(sexp ctx, size_t size, size_t max_size)}
+\p{
+Creates a new context object.  The context has no associated environment, and
+so cannot be used for evaluation, but can be used to construct Scheme objects
+and call primitive C functions on them.
+
+If \var{ctx} is non-NULL it becomes the "parent" context.  The resulting
+context will share the same heap as its parent, and when using a precise GC
+preserve any variables preserved by the parent, but the parent will not
+preserve the child context by default.  Typically you either preserve the child
+manually or use it to perform a single sub-task then discard it and return to
+using only the parent.
+
+Otherwise, a new heap is allocated with \var{size} bytes, expandable to a
+maximum of \var{max_size} bytes, using the system defaults if either is 0.
+}}
+
+\item{\ccode{sexp_make_eval_context(sexp ctx, sexp stack, sexp env, sexp_uint_t size, sexp_uint_t max_size)}
+\p{
+Similar to sexp_make_context, but also associates a stack, environment, and
+additional globals necessary to evaluate code.  Either or both of \var{stack}
+and \var{env} may be NULL, in which case defaults will be generated.  The
+default environment includes the compiled-in C primitives, as well as the 10
+core forms: \scheme{define}, \scheme{set!}, \scheme{lambda}, \scheme{if},
+\scheme{begin}, \scheme{quote}, \scheme{syntax-quote}, \scheme{define-syntax},
+\scheme{let-syntax}, and \scheme{letrec-syntax}.
+}}
+
+\item{\ccode{sexp_load_standard_env(sexp ctx, sexp env, sexp version)}
+\p{
+Loads the standard parameters for \var{env}, constructs the feature list from
+pre-compiled defaults, and loads the installed initialization file for
+\var{version}, which should be the value \var{SEXP_SEVEN}.
+Also creates an \scheme{interaction-environment} parameter
+and sets \var{env} itself to that.
+}}
+
+\item{\ccode{sexp_load_standard_ports(sexp ctx, sexp env, FILE* in, FILE* out, FILE* err, int leave_open)}
+\p{
+Creates \scheme{current-input-port}, \scheme{current-output-port}, and
+\scheme{current-error-port} parameters from \var{in}, \var{out} and
+\var{err}, and binds them in \var{env}.  If \var{env} is \cvar{NULL}
+the default context environment is used.  Any of the \ctype{FILE*} may
+be \cvar{NULL}, in which case the corresponding port is not set.  If
+\var{leave_open} is true, then the underlying \ctype{FILE*} is left
+open after the Scheme port is closed, otherwise they are both closed
+together.
+}}
+
+\item{\ccode{sexp_load(sexp ctx, sexp file, sexp env)}
+\p{
+Searches the installation path for the \var{file} and loads it in the
+environment \var{env}.  \var{file} may be a dynamic library or source code.
+}}
+
+\item{\ccode{sexp_eval(sexp ctx, sexp obj, sexp env)}
+\p{
+Evaluates \var{obj} as a source form in the environment \var{env} and
+returns the result.
+}}
+
+\item{\ccode{sexp_eval_string(sexp ctx, const char* str, int len, sexp env)}
+\p{
+Reads a s-expression from the C string \var{str} (or the first \var{len} bytes
+if \var{len} is non-negative), evaluates the resulting form in the environment
+\var{env}, and returns the result.
+}}
+
+\item{\ccode{sexp_apply(sexp ctx, sexp proc, sexp args)}
+\p{
+Applies the procedure \var{proc} to the arguments in the list \var{args} and
+returns the result.
+}}
+
+\item{\ccode{sexp_context_env(sexp ctx)}
+\p{
+Returns the current default environment associated with the context \var{ctx}.
+}}
+
+\item{\ccode{sexp_env_define(sexp ctx, sexp env, sexp sym, sexp val)}
+\p{
+Adds a new binding for \var{sym} in \var{env} with value \var{val}.
+}}
+
+\item{\ccode{sexp_env_ref(sexp env, sexp sym, sexp dflt)}
+\p{
+Returns the current binding of \var{sym} in \var{env}, or \var{dflt} if there
+is no binding.
+}}
+
+\item{\ccode{sexp_parameter_ref(sexp ctx, sexp param)}
+\p{
+Returns the current dynamic value of the parameter \var{param} in the
+given context.
+}}
+
+]
+
+\subsection{Garbage Collection}
+
+Chibi uses a precise garbage collector by default, which means when performing
+multiple computations on the C side you must explicitly preserve any temporary
+values.  You can declare variables to be preserved with sexp_gc_var\italic{n},
+for n from 1 to 6.\margin-note{You can declare additional macros for larger
+values of n if needed.}
+
+\ccode{
+sexp_gc_var\italic{n}(obj\subscript{1}, obj\subscript{2}, ..., obj\subscript{n})
+}
+
+This is equivalent to the declaration
+
+\ccode{
+sexp obj\subscript{1}, obj\subscript{2}, ..., obj\subscript{n};
+}
+
+except it makes preservation possible.  Because it is a declaration it must
+occur at the beginning of your function, and because it includes assignments
+(in the macro-expanded form) it should occur after all other declarations.
+
+To preserve these variables for a given context, you can then use
+sexp_gc_preserve\italic{n}:
+
+\ccode{
+sexp_gc_preserve\italic{n}(ctx, obj\subscript{1}, obj\subscript{2}, ..., obj\subscript{n})
+}
+
+This can be delayed in your code until you know a potentially memory-allocating
+computation will be performed, but once you call sexp_gc_preserve\italic{n} it
+\emph{must} be paired with a matching sexp_gc_release\italic{n}:
+
+\ccode{
+sexp_gc_release\italic{n}(ctx);
+}
+
+Note each of these have different signatures. sexp_gc_var\italic{n} just lists
+the variables to be declared.  sexp_gc_preserve\italic{n} prefixes these with
+the context in which they are to be preserved, and sexp_gc_release\italic{n}
+just needs the context.
+
+A typical usage for these is:
+
+\ccodeblock{
+sexp foo(sexp ctx, sexp bar, sexp baz) {
+  /* variable declarations */
+  int i, j;
+  ...
+  sexp_gc_var3(tmp1, tmp2, res);
+
+  /* asserts or other shortcut returns */
+  sexp_assert_type(ctx, sexp_barp, SEXP_BAR, bar);
+  sexp_assert_type(ctx, sexp_bazp, SEXP_BAZ, baz);
+
+  /* preserve the variables in ctx */
+  sexp_gc_preserve3(ctx, tmp1, tmp2, res);
+
+  /* perform your computations */
+  tmp1 = ...
+  tmp2 = ...
+  res = ...
+
+  /* release before returning */
+  sexp_gc_release3(ctx);
+
+  return res;
+}
+}
+
+If compiled with the Boehm GC, sexp_gc_var\italic{n} just translates to the
+plain declaration, while sexp_gc_preserve\italic{n} and
+sexp_gc_release\italic{n} become noops.
+
+When interacting with a garbage collection system from another
+language, or communicating between different Chibi managed heaps, you
+may want to manually ensure objects are preserved irrespective of any
+references to it from other objects in the same heap.  This can be
+done with the \ccode{sexp_preserve_object} and
+\ccode{sexp_release_object} utilities.
+
+\ccode{
+sexp_preserve_object(ctx, obj)
+}
+
+Increment the absolute reference count for \var{obj}.  So long as the
+reference count is above 0, \var{obj} will not be reclaimed even if
+there are no references to it from other object in the Chibi managed
+heap.
+
+\ccode{
+sexp_release_object(ctx, obj)
+}
+
+Decrement the absolute reference count for \var{obj}.
+
+\subsection{API Index}
+
+The above sections describe most everything you need for embedding in
+a typical application, notably creating environments and evaluating
+code from sexps, strings or files.  The following sections expand on
+additional macros and utilities for inspecting, accessing and creating
+different Scheme types, and for performing port and string I/O.
+
+Being able to convert from C string to sexp, evaluate it, and convert
+the result back to a C string forms the basis of the C API.  Because
+Chibi is aimed primarily at minimal size, there are relatively few
+other utilities or helpers.  It is expected most high-level code will
+be written in Scheme, and most low-level code will be written in pure,
+Scheme-agnostic C and wrapped via the FFI.
+
+\subsubsection{Type Predicates}
+
+The sexp represents different Scheme types with the use of tag bits for
+so-called "immediate" values, and a type tag for heap-allocated values.  The
+following predicates can be used to distinguish these types.  Note the
+predicates in C all end in "p".  For efficiency they are implemented as macros,
+and so may evaluate their arguments multiple times.
+
+Note also that the non-immediate type checks will segfault if passed a
+NULL value.  At the Scheme level (and the return values of any
+exported primitives) NULLs are never exposed, however some unexposed
+values in C can in certain cases be NULL.  If you're not sure you'll
+need to check manually before applying the predicate.
+
+\itemlist[
+\item{\ccode{sexp_booleanp(obj)} - \var{obj} is \scheme{#t} or \scheme{#f}}
+\item{\ccode{sexp_fixnump(obj)} - \var{obj} is an immediate integer}
+\item{\ccode{sexp_flonump(obj)} - \var{obj} is an inexact real}
+\item{\ccode{sexp_bignump(obj)} - \var{obj} is a heap-allocated integer}
+\item{\ccode{sexp_integerp(obj)} - \var{obj} is an integer}
+\item{\ccode{sexp_numberp(obj)} - \var{obj} is any kind of number}
+\item{\ccode{sexp_charp(obj)} - \var{obj} is a character}
+\item{\ccode{sexp_stringp(obj)} - \var{obj} is a string}
+\item{\ccode{sexp_bytesp(obj)} - \var{obj} is a bytevector}
+\item{\ccode{sexp_symbolp(obj)} - \var{obj} is a symbol}
+\item{\ccode{sexp_idp(obj)} - \var{obj} is a symbol or hygienic identifier}
+\item{\ccode{sexp_nullp(obj)} - \var{obj} is the null value}
+\item{\ccode{sexp_pairp(obj)} - \var{obj} is a pair}
+\item{\ccode{sexp_vectorp(obj)} - \var{obj} is a vector}
+\item{\ccode{sexp_iportp(obj)} - \var{obj} is an input port}
+\item{\ccode{sexp_oportp(obj)} - \var{obj} is an output port}
+\item{\ccode{sexp_portp(obj)} - \var{obj} is any kind of port}
+\item{\ccode{sexp_procedurep(obj)} - \var{obj} is a procedure}
+\item{\ccode{sexp_opcodep(obj)} - \var{obj} is a primitive opcode}
+\item{\ccode{sexp_applicablep(obj)} - \var{obj} is valid as the first arg to apply}
+\item{\ccode{sexp_typep(obj)} - \var{obj} is a type}
+\item{\ccode{sexp_exceptionp(obj)} - \var{obj} is an exception}
+\item{\ccode{sexp_contextp(obj)} - \var{obj} is a context}
+\item{\ccode{sexp_envp(obj)} - \var{obj} is an environment}
+\item{\ccode{sexp_corep(obj)} - \var{obj} is a special form}
+\item{\ccode{sexp_macrop(obj)} - \var{obj} is a macro}
+\item{\ccode{sexp_synclop(obj)} - \var{obj} is a syntactic closure}
+\item{\ccode{sexp_bytecodep(obj)} - \var{obj} is compiled bytecode}
+\item{\ccode{sexp_cpointerp(obj)} - \var{obj} is an opaque C pointer}
+]
+
+\subsubsection{Constants}
+
+The following shortcuts for various immediate values are available.
+
+\itemlist[
+\item{\ccode{SEXP_FALSE} - the false boolean}
+\item{\ccode{SEXP_TRUE} - the true boolean}
+\item{\ccode{SEXP_NULL} - the empty list}
+\item{\ccode{SEXP_EOF} - the end-of-file object}
+\item{\ccode{SEXP_VOID} - an undefined value often returned by mutators}
+\item{\ccode{SEXP_ZERO} - shortcut for sexp_make_fixnum(0)}
+\item{\ccode{SEXP_ONE} - shortcut for sexp_make_fixnum(1)}
+\item{...}
+\item{\ccode{SEXP_TEN} - shortcut for sexp_make_fixnum(10)}
+\item{\ccode{SEXP_NEG_ONE} - shortcut for sexp_make_fixnum(-1)}
+]
+
+\subsubsection{String Handling}
+
+Scheme strings are length bounded C strings which can be accessed with
+the following macros:
+
+\itemlist[
+\item{\ccode{char* sexp_string_data(sexp s)} - the raw bytes of the string}
+\item{\ccode{sexp_uint_t sexp_string_size(sexp s)} - the number of raw bytes in the string}
+\item{\ccode{sexp_uint_t sexp_string_length(sexp s)} - the number of characters encoded in \var{s}}
+]
+
+Currently all Scheme strings also happen to be NULL-terminated, but
+you should not rely on this and be sure to use the size as a bounds
+check.  The runtime does not prevent embedded NULLs inside strings,
+however data after the NULL may be ignored.
+
+By default (unless you compile with -DSEXP_USE_UTF8_STRING=0), strings
+are interpreted as utf8 encoded on the Scheme side, as describe in
+section Unicode above.  In many cases you can ignore this on the C
+side and just treat the string as an opaque sequence of bytes.
+However, if you need to you can use the following macros to safely
+access the contents of the string regardless of the options Chibi was
+compiled with:
+
+\itemlist[
+\item{\ccode{sexp sexp_string_ref(sexp ctx, sexp s, sexp i)} - returns the character at index i}
+\item{\ccode{sexp sexp_string_set(sexp ctx, sexp s, sexp i, sexp ch)} - sets the character at index i}
+\item{\ccode{sexp sexp_string_cursor_ref(sexp ctx, sexp s, sexp i)} - returns the character at raw offset i (a fixnum)}
+\item{\ccode{sexp sexp_string_cursor_set(sexp ctx, sexp s, sexp i, sexp ch)} - sets the character at raw offset i (a fixnum)}
+\item{\ccode{sexp sexp_string_cursor_next(sexp s, sexp i)} - returns the next cursor after raw offset \var{i}}
+\item{\ccode{sexp sexp_string_cursor_prev(sexp s, sexp i)} - returns the previous cursor before raw offset \var{i}}
+\item{\ccode{sexp sexp_substring(sexp ctx, sexp s, sexp i, sexp j)} - returns the substring between indices \var{i} and \var{j}}
+\item{\ccode{sexp sexp_substring_cursor(sexp ctx, sexp s, sexp i, sexp j)} - returns the substring between raw offsets \var{i} and \var{j}}
+]
+
+When UTF8 support is not compiled in the cursor and non-cursor
+variants are equivalent.
+
+\subsubsection{Accessors}
+
+The following macros provide access to the different components of the
+Scheme types.  They do no type checking, essentially translating
+directly to pointer offsets, so you should be sure to use the above
+predicates to check types first.  They only evaluate their arguments
+once.
+
+\itemlist[
+\item{\ccode{sexp_make_boolean(n)} - \scheme{#f} if \var{n} is 0, \scheme{#t} otherwise}
+\item{\ccode{sexp_unbox_boolean(obj)} - 1 if \var{obj} is \scheme{#t}, 0 otherwise}
+\item{\ccode{sexp_make_fixnum(n)} - creates a new fixnum representing int \var{n}}
+\item{\ccode{sexp_unbox_fixnum(obj)} - converts a fixnum to a C integer}
+\item{\ccode{sexp_make_character(ch)} - creates a new character representing char \var{ch}}
+\item{\ccode{sexp_unbox_character(obj)} - converts a character to a C char}
+\item{\ccode{sexp_car(pair)} - the car of \var{pair}}
+\item{\ccode{sexp_cdr(pair)} - the cdr of \var{pair}}
+\item{\ccode{sexp_ratio_numerator(q)} - the numerator of the ratio \var{q}}
+\item{\ccode{sexp_ratio_denominator(q)} - the denominator of the ratio \var{q}}
+\item{\ccode{sexp_complex_real(z)} - the real part of the complex \var{z}}
+\item{\ccode{sexp_complex_imag(z)} - the imaginary part of the complex \var{z}}
+\item{\ccode{sexp_string_length(str)} - the byte length of \var{str} as an int}
+\item{\ccode{sexp_string_ref(str, i)} - the \var{i}'th byte of string \var{str}}
+\item{\ccode{sexp_string_set(str, i, ch)} - set the \var{i}'th byte of string \var{str}}
+\item{\ccode{sexp_bytes_length(bv)} - the length of \var{bv} as an int}
+\item{\ccode{sexp_bytes_data(bv)} - the raw char* data of \var{bv}}
+\item{\ccode{sexp_vector_length(vec)} - the length of \var{vec} as an int}
+\item{\ccode{sexp_vector_ref(vec, i)} - the \var{i}'th object of vector \var{vec}}
+\item{\ccode{sexp_vector_set(vec, i, obj)} - set the \var{i}'th object of vector \var{vec}}
+\item{\ccode{sexp_bytes_length(bv)} - the number of bytes in bytevector \var{bv}}
+\item{\ccode{sexp_bytes_ref(bv, i)} - the \var{i}'th byte of bytevector \var{bv}}
+\item{\ccode{sexp_bytes_set(bv, i, k)} - set the \var{i}'th byte of bytevector \var{bv}}
+]
+
+\subsubsection{Constructors}
+
+Constructors allocate memory and so must be passed a context argument.
+Any of these may fail and return the OOM exception object.
+
+\itemlist[
+\item{\ccode{sexp_cons(sexp ctx, sexp obj1, sexp obj2)} - create a new pair whose car is \var{obj1} and whose cdr is \var{obj2}}
+\item{\ccode{sexp_list1(sexp ctx, sexp obj)} - alias for sexp_cons(ctx, obj, SEXP_NULL)}
+\item{\ccode{sexp_list2(sexp ctx, sexp obj1, sexp obj2)} - create a list of two elements}
+\item{\ccode{sexp_make_string(sexp ctx, sexp len, sexp ch)} - create a new Scheme string of \var{len} characters, all initialized to \var{ch}}
+\item{\ccode{sexp_c_string(sexp ctx, const char* str, int len)} - create a new Scheme string copying the first \var{len} characters of the C string \var{str}.  If \var{len} is -1, uses strlen(\var{str}).}
+\item{\ccode{sexp_intern(sexp ctx, const char* str, int len)} - interns a symbol from the first \var{len} characters of the C string \var{str}.  If \var{len} is -1, uses strlen(\var{str}).}
+\item{\ccode{sexp_make_bytes(sexp ctx, sexp len, sexp i)} - create a new Scheme bytevector of \var{len} bytes, all initialized to \var{i}}
+\item{\ccode{sexp_make_vector(sexp ctx, sexp len, sexp obj)} - create a new vector of \var{len} elements, all initialized to \var{obj}}
+\item{\ccode{sexp_make_integer(sexp ctx, sexp_sint_t n)} - create an integer, heap allocating as a bignum if needed}
+\item{\ccode{sexp_make_unsigned_integer(sexp ctx, sexp_uint_t n)} - create an unsigned integer, heap allocating as a bignum if needed}
+]
+
+\subsubsection{I/O}
+
+\itemlist[
+\item{\ccode{sexp_read(sexp ctx, sexp in)} - read a single datum from port \var{in}}
+\item{\ccode{sexp_write(sexp ctx, sexp obj, sexp out)} - write \var{obj} to port \var{out}}
+\item{\ccode{sexp_write_string(sexp ctx, char* str, sexp out)} - write the characters in \var{str} to port \var{out}}
+\item{\ccode{sexp_display(sexp ctx, sexp obj, sexp out)} - display \var{obj} to port \var{out}}
+\item{\ccode{sexp_newline(sexp ctx, sexp out)} - write a newline to port \var{out}}
+\item{\ccode{sexp_print_exception(sexp ctx, sexp exn, sexp out)} - print an error message for \var{exn} to port \var{out}}
+\item{\ccode{sexp_current_input_port(sexp ctx)} - the \scheme{current-input-port}}
+\item{\ccode{sexp_current_output_port(sexp ctx)} - the \scheme{current-output-port}}
+\item{\ccode{sexp_current_error_port(sexp ctx)} - the \scheme{current-error-port}}
+\item{\ccode{sexp_debug(sexp ctx, char* msg, sexp obj)} - write \var{obj} with a debug message prefix to \scheme{current-error-port}}
+\item{\ccode{sexp_read_from_string(sexp ctx, char* str, int len)} - read a single datum from \var{str}, using at most \var{len} bytes if \var{len} is non-negative}
+\item{\ccode{sexp_write_to_string(sexp ctx, sexp obj)} - return a Scheme string representation of \var{obj}}
+\item{\ccode{sexp_open_input_string(sexp ctx, sexp str)} - equivalent to \scheme{open-input-string}}
+\item{\ccode{sexp_open_output_string(sexp ctx)} - equivalent to \scheme{open-output-string}}
+\item{\ccode{sexp_get_output_string(sexp ctx, sexp port)} - equivalent to \scheme{open-output-string}}
+]
+
+\subsubsection{Utilities}
+
+\itemlist[
+\item{\ccode{sexp_equalp(sexp ctx, sexp x, sexp y)} - \scheme{equal?}}
+\item{\ccode{sexp_length(sexp ctx, sexp ls)} - \scheme{length}}
+\item{\ccode{sexp_listp(sexp ctx, sexp x)} - \scheme{list?}}
+\item{\ccode{sexp_memq(sexp ctx, sexp x, sexp ls)} - \scheme{memq}}
+\item{\ccode{sexp_assq(sexp ctx, sexp x, sexp ls)} - \scheme{assq}}
+\item{\ccode{sexp_reverse(sexp ctx, sexp ls)} - \scheme{reverse}}
+\item{\ccode{sexp_nreverse(sexp ctx, sexp ls)} - \scheme{reverse!}}
+\item{\ccode{sexp_append2(sexp ctx, sexp ls)} - \scheme{append} for two arguments}
+\item{\ccode{sexp_copy_list(sexp ctx, sexp ls)} - return a shallow copy of \var{ls}}
+\item{\ccode{sexp_list_to_vector(sexp ctx, sexp ls)} - \scheme{list->vector}}
+\item{\ccode{sexp_symbol_to_string(sexp ctx, sexp sym)} - \scheme{symbol->string}}
+\item{\ccode{sexp_string_to_symbol(sexp ctx, sexp str)} - \scheme{string->symbol}}
+\item{\ccode{sexp_string_to_number(sexp ctx, sexp str)} - \scheme{string->number}}
+]
+
+\subsection{Exceptions}
+
+Exceptions can be created with the following:
+
+\itemlist[
+
+\item{\ccode{sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source)}
+\p{Create an exception of the given \var{kind} (a symbol), with the
+string \var{message}, and \var{irritants} list.  \var{procedure} and
+\var{source} provide information about the error location.  From a C
+function, \var{procedure} should generally be \ccode{self}.}}
+
+\item{\ccode{sexp sexp_user_exception (sexp ctx, sexp self, const char *msg, sexp x)}
+\p{Shortcut for an exception of kind \ccode{user}, with the given message and single irritant.}}
+
+\item{\ccode{sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp x)}
+\p{Shortcut for an exception of kind \ccode{type}, where \var{x} was
+expected to be of type \var{type_id} but wasn't.}}
+
+\item{\ccode{sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp x)}
+\p{Shortcut for an exception of kind \ccode{type}, for more general
+domain errors, where \var{x} failed to meet the restrictions in \var{msg}.}}
+
+]
+
+Returning an exception from a C function by default \emph{raises} that
+exception in the VM.  If you want to pass an exception as a first
+class value, you have to wrap it first:
+
+\ccode{sexp sexp_maybe_wrap_error (sexp ctx, sexp obj)}
+
+\subsection{Customizing}
+
+You can add your own types and primitives with the following functions.
+
+\itemlist[
+
+\item{\ccode{sexp sexp_define_foreign(sexp ctx, sexp env, const char* name, int num_args, sexp_proc1 func)}
+\p{
+Defines a new primitive procedure with the name \var{name} in the
+environment \var{env}.  The procedure takes \var{num_args} arguments
+and passes them to the C function \var{func}.  The C function must
+take the standard calling convention:
+
+\ccode{sexp func(sexp ctx, sexp self, sexp n, sexp arg\sub{1}, ..., sexp arg\sub{num_args})}
+
+where \var{ctx} is the current context, \var{self} is the procedure
+itself, and \var{n} is the number of arguments passed.
+
+\var{func} is responsible for checking its own argument types.
+}}
+
+\item{\ccode{sexp sexp_define_foreign_opt(sexp ctx, sexp env, const char* name, int num_args, sexp_proc1 func, sexp dflt)}
+\p{
+Equivalent to \cfun{sexp_define_foreign}, except the final argument is
+optional and defaults to the value \var{dflt}.
+}}
+
+\item{\ccode{sexp sexp_define_foreign_param(sexp ctx, sexp env, const char* name, int num_args, sexp_proc1 func, const char* param)}
+\p{
+Equivalent to \cfun{sexp_define_foreign_opt}, except instead of a fixed
+default argument \var{param} should be the name of a parameter bound in
+\var{env}.
+}}
+
+\item{\ccode{sexp sexp_register_simple_type(sexp ctx, sexp name, sexp parent, sexp slots)}
+\p{
+Defines a new simple record type having \var{slots} new slots in addition
+to any inherited from the parent type \var{parent}.  If \var{parent} is false,
+inherits from the default \var{object} record type.
+}}
+
+]
+
+See the C FFI for an easy way to automate adding bindings for C
+functions.
+
+\section{C FFI}
+
+The "chibi-ffi" script reads in the C function FFI definitions from an
+input file and outputs the appropriate C wrappers into a file with the
+same base name and the ".c" extension.  You can then compile that C
+file into a shared library:
+
+\command{
+chibi-ffi file.stub
+cc -fPIC -shared file.c -lchibi-scheme
+}
+
+(or using whatever flags are appropriate to generate shared libs on
+your platform) and the generated .so file can be loaded directly with
+\scheme{load}, or portably using \scheme{(include-shared "file")} in a
+module definition (note that include-shared uses no suffix).
+
+The goal of this interface is to make access to C types and functions
+easy, without requiring the user to write any C code.  That means the
+stubber needs to be intelligent about various C calling conventions
+and idioms, such as return values passed in actual parameters.
+Writing C by hand is still possible, and several of the core modules
+provide C interfaces directly without using the stubber.
+
+\subsection{Includes and Initializations}
+
+\itemlist[
+\item{\scheme{(c-include header)} - includes the file \var{header}}
+\item{\scheme{(c-system-include header)} - includes the system file \var{header}}
+\item{\scheme{(c-declare args ...)} - outputs \var{args} directly in the top-level C source}
+\item{\scheme{(c-init args ...)} - evaluates \var{args} as C code after all other library initializations have been performed, with \cvar{ctx} and \cvar{env} in scope}
+]
+
+\subsection{Struct Interface}
+
+C structs can be bound as Scheme types with the
+\scheme{define-c-struct} form:
+
+\schemeblock{
+(define-c-struct struct_name
+  [predicate: predicate-name]
+  [constructor: constructor-name]
+  [finalizer: c_finalizer_name]
+  (type c_field_name getter-name setter-name) ...)
+}
+
+\var{struct_name} should be the name of a C struct type.  If provided,
+\var{predicate-name} is bound to a procedure which takes one object
+and returns \scheme{#t} iff the object is of type \var{struct_name}.
+
+If provided, \var{constructor-name} is bound to a procedure of zero
+arguments which creates and returns a newly allocated instance of the
+type.
+
+If a finalizer is provided, \var{c_finalizer_name} must be a C
+function which takes one argument, a pointer to the struct, and
+performs any cleanup or freeing of resources necessary.
+
+The remaining slots are similar to the
+\hyperlink["http://srfi.schemers.org/srfi-9/srfi-9.html"]{SRFI-9} syntax,
+except they are prefixed with a C type (described below).  The
+\var{c_field_name} should be a field name of \var{struct_name}.
+\var{getter-name} will then be bound to a procedure of one argument, a
+\{struct_name} type, which returns the given field.  If provided,
+\var{setter-name} will be bound to a procedure of two arguments to
+mutate the given field.
+
+The variants \scheme{define-c-class} and \scheme{define-c-union} take
+the same syntax but define types with the \ccode{class} and
+\ccode{union} keywords respectively.  \scheme{define-c-type} just
+defines accessors to an opaque type without any specific struct-like
+keyword.
+
+\schemeblock{
+;; Example: the struct addrinfo returned by getaddrinfo.
+
+(c-system-include "netdb.h")
+
+(define-c-struct addrinfo
+  finalizer: freeaddrinfo
+  predicate: address-info?
+  (int              ai_family    address-info-family)
+  (int              ai_socktype  address-info-socket-type)
+  (int              ai_protocol  address-info-protocol)
+  ((link sockaddr)  ai_addr      address-info-address)
+  (size_t           ai_addrlen   address-info-address-length)
+  ((link addrinfo)  ai_next      address-info-next))
+}
+
+\subsection{Function and Constant Interface}
+
+C functions are defined with:
+
+\scheme{(define-c return-type name-spec (arg-type ...))}
+
+where \var{name-space} is either a symbol name, or a list of
+\scheme{(scheme-name c_name)}.  If just a symbol is used, the C name
+is generated automatically by replacing any dashes (-) in the Scheme
+name with underscores (_).
+
+Each \var{arg-type} is a type suitable for input validation and
+conversion as discussed below.
+
+\schemeblock{
+;; Example: define connect(2) in Scheme
+(define-c int connect (int sockaddr int))
+}
+
+Constants can be defined with:
+
+\scheme{(define-c-const type name-space)}
+
+where \var{name-space} is the same form as in \scheme{define-c}.  This
+defines a Scheme variable with the same value as the C constant.
+
+\schemeblock{
+;; Example: define address family constants in Scheme
+(define-c-const int (address-family/unix "AF_UNIX"))
+(define-c-const int (address-family/inet "AF_INET"))
+}
+
+\subsection{C Types}
+
+\subsubsection{Basic Types}
+
+\itemlist[
+\item{\rawcode{void}}
+\item{\rawcode{boolean}}
+\item{\rawcode{char}}
+\item{\rawcode{sexp} (no conversions)}
+]
+
+\subsubsection{Integer Types}
+
+\itemlist[
+\item{\rawcode{signed-char}}
+\item{\rawcode{short}}
+\item{\rawcode{int}}
+\item{\rawcode{long}}
+\item{\rawcode{unsigned-char}}
+\item{\rawcode{unsigned-short}}
+\item{\rawcode{unsigned-int}}
+\item{\rawcode{unsigned-long}}
+\item{\rawcode{size_t}}
+\item{\rawcode{pid_t}}
+\item{\rawcode{uid_t}}
+\item{\rawcode{gid_t}}
+\item{\rawcode{time_t} (in seconds, but using the chibi epoch of 2010/01/01)}
+\item{\rawcode{errno} (as a return type returns \scheme{#f} on error)}
+]
+
+\subsubsection{Float Types}
+
+\itemlist[
+\item{\rawcode{float}}
+\item{\rawcode{double}}
+\item{\rawcode{long-double}}
+]
+
+\subsubsection{String Types}
+
+\itemlist[
+\item{\rawcode{string} - a null-terminated char*}
+\item{\rawcode{env-string} - a \rawcode{VAR=VALUE} string represented as a \scheme{(VAR . VALUE)} pair in Scheme}
+\item{\scheme{(array char)} is equivalent to \rawcode{string}}
+]
+
+\subsubsection{Port Types}
+
+\itemlist[
+\item{\rawcode{input-port}}
+\item{\rawcode{output-port}}
+]
+
+\subsubsection{Struct Types}
+
+Struct types are by default just referred to by the bare
+\var{struct_name} from \scheme{define-c-struct}, and it is assumed you
+want a pointer to that type.  To refer to the full struct, use the
+struct modifier, as in \scheme{(struct struct-name)}.
+
+\subsubsection{Type modifiers}
+
+Any type may also be written as a list of modifiers followed by the
+type itself.  The supported modifiers are:
+
+\itemlist[
+
+\item{\rawcode{const}
+\p{Prepends the "const" C type modifier.
+As a return or result parameter, makes non-immediates immutable.}}
+
+\item{\rawcode{free}
+\p{It's Scheme's responsibility to "free" this resource.
+As a return or result parameter, registers the freep flag
+this causes the type finalizer to be run when GCed.}}
+
+\item{\rawcode{maybe-null}
+\p{This pointer type may be NULL.
+As a result parameter, NULL is translated to #f
+normally this would just return a wrapped NULL pointer.
+As an input parameter, #f is translated to NULL
+normally this would be a type error.}}
+
+\item{\rawcode{pointer}
+\p{Create a pointer to this type.
+As a return parameter, wraps the result in a vanilla cpointer.
+As a result parameter, boxes then unboxes the value.}}
+
+\item{\rawcode{reference}
+\p{A stack-allocated pointer to this type.
+As a result parameter, passes a stack-allocated pointer to
+the value, then returns the dereferenced pointer.}}
+
+\item{\rawcode{struct}
+\p{Treat this struct type as a struct, not a pointer.
+As an input parameter, dereferences the pointer.
+As a type field, indicates a nested struct.}}
+
+\item{\rawcode{link}
+\p{Add a gc link.
+As a field getter, link to the parent object, so the
+parent won't be GCed so long as we have a reference
+to the child.  This behavior is automatic for nested structs.}}
+
+\item{\rawcode{result}
+\p{Return a result in this parameter.
+If there are multiple results (including the return type),
+they are all returned in a list.
+If there are any result parameters, a return type
+of errno returns #f on failure, and as eliminated
+from the list of results otherwise.}}
+
+\item{\scheme{(value <expr>)}
+\p{Specify a fixed value.
+As an input parameter, this parameter is not provided
+in the Scheme API but always passed as <expr>.}}
+
+\item{\scheme{(default <expr>)}
+\p{Specify a default value.
+As the final input parameter, makes the Scheme parameter
+optional, defaulting to <expr>.}}
+
+\item{\scheme{(array <type> [<length>])}
+\p{An array type.
+Length must be specified for return and result parameters.
+If specified, length can be either an integer, indicating a fixed size,
+or the symbol null, indicating a NULL-terminated array.}}
+
+]
+
+\section{Standard Modules}
+
+A number of SRFIs are provided in the default installation.  Note that
+SRFIs 0, 6, 23, 46 and 62 are built into the default environment so
+there's no need to import them.  SRFI 22 is available with the "-r"
+command-line option.  This list includes popular SRFIs or SRFIs used
+in standard Chibi modules
+
+\itemlist[
+
+\item{\hyperlink["http://srfi.schemers.org/srfi-0/srfi-0.html"]{(srfi 0)  - cond-expand}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-1/srfi-1.html"]{(srfi 1)  - list library}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-2/srfi-2.html"]{(srfi 2)  - and-let*}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-6/srfi-6.html"]{(srfi 6)  - basic string ports}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-8/srfi-8.html"]{(srfi 8)  - receive}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-9/srfi-9.html"]{(srfi 9)  - define-record-type}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-11/srfi-11.html"]{(srfi 11) - let-values/let*-values}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-16/srfi-16.html"]{(srfi 16) - case-lambda}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-18/srfi-18.html"]{(srfi 18) - multi-threading support}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-22/srfi-22.html"]{(srfi 22) - running scheme scripts on Unix}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-23/srfi-23.html"]{(srfi 23) - error reporting mechanism}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-26/srfi-26.html"]{(srfi 26) - cut/cute partial application}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-27/srfi-27.html"]{(srfi 27) - sources of random bits}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-33/srfi-33.html"]{(srfi 33) - bitwise operators}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-38/srfi-38.html"]{(srfi 38) - read/write shared structures}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-39/srfi-39.html"]{(srfi 39) - parameter objects}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-46/srfi-46.html"]{(srfi 46) - basic syntax-rules extensions}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-55/srfi-55.html"]{(srfi 55) - require-extension}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-62/srfi-62.html"]{(srfi 62) - s-expression comments}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-69/srfi-69.html"]{(srfi 69) - basic hash tables}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-95/srfi-95.html"]{(srfi 95) - sorting and merging}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-98/srfi-98.html"]{(srfi 98) - environment access}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-99/srfi-99.html"]{(srfi 99) - ERR5RS records}}
+
+]
+
+Additional non-standard modules are put in the \scheme{(chibi)} module
+namespace.
+
+\itemlist[
+
+\item{\hyperlink["lib/chibi/ast.html"]{(chibi ast) - Abstract Syntax Tree and other internal data types}}
+
+\item{\hyperlink["lib/chibi/config.html"]{(chibi config) - General configuration management}}
+
+\item{\hyperlink["lib/chibi/disasm.html"]{(chibi disasm) - Disassembler for the virtual machine}}
+
+\item{\hyperlink["lib/chibi/equiv.html"]{(chibi equiv) - A version of \scheme{equal?} which is guaranteed to terminate}}
+
+\item{\hyperlink["lib/chibi/filesystem.html"]{(chibi filesystem) - Interface to the filesystem and file descriptor objects}}
+
+\item{\hyperlink["lib/chibi/generic.html"]{(chibi generic) - Generic methods for CLOS-style object oriented programming}}
+
+\item{\hyperlink["lib/chibi/heap-stats.html"]{(chibi heap-stats) - Utilities for gathering statistics on the heap}}
+
+\item{\hyperlink["lib/chibi/io.html"]{(chibi io) - Various I/O extensions and custom ports}}
+
+\item{\hyperlink["lib/chibi/loop.html"]{(chibi loop) - Fast and extensible loop syntax}}
+
+\item{\hyperlink["lib/chibi/match.html"]{(chibi match) - Intuitive and widely supported pattern matching syntax}}
+
+\item{\hyperlink["lib/chibi/mime.html"]{(chibi mime) - Parse MIME files into SXML}}
+
+\item{\hyperlink["lib/chibi/modules.html"]{(chibi modules) - Introspection for the module system itself}}
+
+\item{\hyperlink["lib/chibi/net.html"]{(chibi net) - Simple networking interface}}
+
+\item{\hyperlink["lib/chibi/pathname.html"]{(chibi pathname) - Utilities to decompose and manipulate pathnames}}
+
+\item{\hyperlink["lib/chibi/process.html"]{(chibi process) - Interface to spawn processes and handle signals}}
+
+\item{\hyperlink["lib/chibi/repl.html"]{(chibi repl) - A full-featured Read/Eval/Print Loop}}
+
+\item{\hyperlink["lib/chibi/scribble.html"]{(chibi scribble) - A parser for the scribble syntax used to write this manual}}
+
+\item{\hyperlink["lib/chibi/show.html"]{(chibi show) - A combinator formatting library}}
+
+\item{\hyperlink["lib/chibi/show/base.scm"]{(chibi show base) - Base combinator formatting}}
+
+\item{\hyperlink["lib/chibi/stty.html"]{(chibi stty) - A high-level interface to ioctl}}
+
+\item{\hyperlink["lib/chibi/system.html"]{(chibi system) - Access to the host system and current user information}}
+
+\item{\hyperlink["lib/chibi/test.html"]{(chibi test) - A simple unit testing framework}}
+
+\item{\hyperlink["lib/chibi/time.html"]{(chibi time) - An interface to the current system time}}
+
+\item{\hyperlink["lib/chibi/trace.html"]{(chibi trace) - A utility to trace procedure calls}}
+
+\item{\hyperlink["lib/chibi/type-inference.html"]{(chibi type-inference) - An easy-to-use type inference system}}
+
+\item{\hyperlink["lib/chibi/uri.html"]{(chibi uri) - Utilities to parse and construct URIs}}
+
+\item{\hyperlink["lib/chibi/weak.html"]{(chibi weak) - Data structures with weak references}}
+
+]
+
+\section{Snow Package Manager}
+
+Beyond the distributed modules, Chibi comes with a package manager
+based on \hyperlink["http://trac.sacrideo.us/wg/wiki/Snow"]{Snow2}
+which can be used to share R7RS libraries.  Packages are distributed
+as tar gzipped files called "snowballs," and may contain multiple
+libraries.  The program is installed as \scheme{snow-chibi} and takes
+the following subcommands:
+
+\subsubsection{Querying Packages}
+
+\itemlist[
+
+\item{search terms ... - search for packages
+\p{Prints a list of available packages matching the given keywords.}}
+
+\item{show names ... - show package descriptions
+\p{Show detailed information for the listed packages, which can
+be sexp library names or the dotted shorthand used by chibi.}}
+
+\item{status names ... - print package status
+\p{Print the installed version of the given packages.}}
+
+]
+
+\subsubsection{Managing Packages}
+
+\itemlist[
+
+\item{install names ... - install packages
+\p{Install the given packages.}}
+
+\item{upgrade names ... - upgrade installed packages
+\p{Upgrade the packages if new versions are available.
+If no names are given, upgrades all eligible packages.}}
+
+\item{remove names ... - remove packages
+\p{Uninstalls the given packages.}}
+
+]
+
+\subsubsection{Creating Packages}
+
+\itemlist[
+
+\item{package files ... - create a package
+\p{Create a package snowball from the given files, which should
+be R7RS library files containing \scheme{define-library} forms.
+Include files are inferred and packaged automatically.}}
+
+\item{gen-key - create an RSA key pair
+\p{Create a new private key pair.}}
+
+\item{sign file - sign a package
+\p{Sign a file with your private key and write it to the .sig file.}}
+
+\item{verify file - verify a signature
+\p{Print a message verifying if a signature is valid.}}
+
+\item{reg-key - register an RSA key pair
+\p{Register your key on the default snow host.}}
+
+\item{upload files ... - upload a package
+\p{Sign and upload to the default snow host.
+A private key must be generated first.}}
+
+]
diff --git a/doc/lib/chibi/README b/doc/lib/chibi/README
new file mode 100644
index 00000000..b6e02ce1
--- /dev/null
+++ b/doc/lib/chibi/README
@@ -0,0 +1 @@
+Auto-generated module documentation with tools/chibi-doc.
diff --git a/eval.c b/eval.c
new file mode 100644
index 00000000..448f8122
--- /dev/null
+++ b/eval.c
@@ -0,0 +1,2539 @@
+/*  eval.c -- evaluator library implementation                */
+/*  Copyright (c) 2009-2013 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include "chibi/eval.h"
+
+#if SEXP_USE_DEBUG_VM || SEXP_USE_PROFILE_VM || SEXP_USE_STATIC_LIBS
+#include "opt/opcode_names.h"
+#endif
+
+/************************************************************************/
+
+static int scheme_initialized_p = 0;
+
+static sexp analyze (sexp ctx, sexp x, int depth, int defok);
+
+#if SEXP_USE_MODULES
+sexp sexp_load_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file, sexp env);
+sexp sexp_find_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file);
+sexp sexp_current_environment (sexp ctx, sexp self, sexp_sint_t n);
+#endif
+
+sexp sexp_compile_error (sexp ctx, const char *message, sexp o) {
+  sexp exn;
+  sexp_gc_var3(sym, irritants, msg);
+  sexp_gc_preserve3(ctx, sym, irritants, msg);
+  irritants = sexp_list1(ctx, o);
+  msg = sexp_c_string(ctx, message, -1);
+  exn = sexp_make_exception(ctx, sym = sexp_intern(ctx, "compile", -1),
+                            msg, irritants, SEXP_FALSE,
+                            (sexp_pairp(o)?sexp_pair_source(o):SEXP_FALSE));
+  sexp_gc_release3(ctx);
+  return exn;
+}
+
+void sexp_warn (sexp ctx, const char *msg, sexp x) {
+  sexp_gc_var1(out);
+  int strictp = sexp_truep(sexp_global(ctx, SEXP_G_STRICT_P));
+  sexp_gc_preserve1(ctx, out);
+  out = sexp_current_error_port(ctx);
+  if (sexp_not(out)) {          /* generate a throw-away port */
+    out = sexp_make_output_port(ctx, stderr, SEXP_FALSE);
+    sexp_port_no_closep(out) = 1;
+  }
+  if (sexp_oportp(out)) {
+    sexp_write_string(ctx, strictp ? "ERROR: " : "WARNING: ", out);
+    sexp_write_string(ctx, msg, out);
+    sexp_write(ctx, x, out);
+    sexp_write_char(ctx, '\n', out);
+    if (strictp) sexp_stack_trace(ctx, out);
+  }
+  sexp_gc_release1(ctx);
+  if (strictp) exit(1);
+}
+
+sexp sexp_warn_undefs_op (sexp ctx, sexp self, sexp_sint_t n, sexp from, sexp to, sexp res) {
+  sexp x, ignore = (res && sexp_exceptionp(res)) ? sexp_exception_irritants(res) : SEXP_NULL;
+  if (sexp_envp(from)) from = sexp_env_bindings(from);
+  for (x=from; sexp_pairp(x) && x!=to; x=sexp_env_next_cell(x))
+    if (sexp_cdr(x) == SEXP_UNDEF && sexp_car(x) != ignore
+        && sexp_not(sexp_memq(ctx, sexp_car(x), ignore)))
+      sexp_warn(ctx, "reference to undefined variable: ", sexp_car(x));
+  return SEXP_VOID;
+}
+
+sexp sexp_maybe_wrap_error (sexp ctx, sexp obj) {
+  sexp_gc_var2(tmp, res);
+  if (sexp_exceptionp(obj)) {
+    sexp_gc_preserve2(ctx, tmp, res);
+    tmp = obj;
+    tmp = sexp_list1(ctx, tmp);
+    res = sexp_make_trampoline(ctx, SEXP_FALSE, tmp);
+    sexp_gc_release2(ctx);
+    return res;
+  }
+  return obj;
+}
+
+/********************** environment utilities ***************************/
+
+static sexp sexp_env_cell_loc1 (sexp env, sexp key, int localp, sexp *varenv) {
+  sexp ls;
+  do {
+#if SEXP_USE_RENAME_BINDINGS
+    for (ls=sexp_env_renames(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
+      if (sexp_car(ls) == key) {
+        if (varenv) *varenv = env;
+        return sexp_cdr(ls);
+      }
+#endif
+    for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
+      if (sexp_car(ls) == key) {
+        if (varenv) *varenv = env;
+        return ls;
+      }
+    env = (localp ? NULL : sexp_env_parent(env));
+  } while (env && sexp_envp(env));
+  return NULL;
+}
+
+static sexp sexp_env_cell_loc (sexp ctx, sexp env, sexp key, int localp, sexp *varenv) {
+  sexp cell = sexp_env_cell_loc1(env, key, localp, varenv);
+  while (!cell && sexp_synclop(key)) {
+    if (sexp_not(sexp_memq(ctx, sexp_synclo_expr(key), sexp_context_fv(ctx)))
+        && sexp_not(sexp_memq(ctx, sexp_synclo_expr(key), sexp_synclo_free_vars(key))))
+      env = sexp_synclo_env(key);
+    key = sexp_synclo_expr(key);
+    cell = sexp_env_cell_loc1(env, key, 0, varenv);
+  }
+  return cell;
+}
+
+sexp sexp_env_cell (sexp ctx, sexp env, sexp key, int localp) {
+  return sexp_env_cell_loc(ctx, env, key, localp, NULL);
+}
+
+static sexp sexp_env_undefine (sexp ctx, sexp env, sexp key) {
+  sexp ls1=NULL, ls2;
+  for (ls2=sexp_env_bindings(env); sexp_pairp(ls2);
+       ls1=ls2, ls2=sexp_env_next_cell(ls2))
+    if (sexp_car(ls2) == key) {
+      if (ls1) sexp_env_next_cell(ls1) = sexp_env_next_cell(ls2);
+      else sexp_env_bindings(env) = sexp_env_next_cell(ls2);
+      return SEXP_TRUE;
+    }
+  return SEXP_FALSE;
+}
+
+sexp sexp_env_cell_define (sexp ctx, sexp env, sexp key,
+                           sexp value, sexp *varenv) {
+  sexp_gc_var2(cell, ls);
+  while (sexp_env_lambda(env) || sexp_env_syntactic_p(env))
+    env = sexp_env_parent(env);
+  if (varenv) *varenv = env;
+#if SEXP_USE_RENAME_BINDINGS
+  /* remove any existing renamed definition */
+  for (ls=sexp_env_renames(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
+    if (sexp_car(ls) == key) {
+      sexp_car(ls) = SEXP_FALSE;
+      break;
+    }
+#endif
+  for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
+    if (sexp_car(ls) == key) {
+      if (sexp_cdr(ls) == SEXP_UNDEF)
+        sexp_cdr(ls) = value;
+      return ls;
+    }
+  sexp_gc_preserve2(ctx, cell, ls);
+  sexp_env_push(ctx, env, cell, key, value);
+  sexp_gc_release2(ctx);
+  return cell;
+}
+
+static sexp sexp_env_cell_create (sexp ctx, sexp env, sexp key,
+                                  sexp value, sexp *varenv) {
+  sexp cell = sexp_env_cell_loc(ctx, env, key, 0, varenv);
+  if (!cell) cell = sexp_env_cell_define(ctx, env, key, value, varenv);
+  return cell;
+}
+
+sexp sexp_env_ref (sexp ctx, sexp env, sexp key, sexp dflt) {
+  sexp cell = sexp_env_cell(ctx, env, key, 0);
+  return (cell ? sexp_cdr(cell) : dflt);
+}
+
+sexp sexp_env_define (sexp ctx, sexp env, sexp key, sexp value) {
+  sexp cell, tmp, res = SEXP_VOID;
+  if (sexp_immutablep(env))
+    return sexp_user_exception(ctx, NULL, "immutable binding", key);
+  cell = sexp_env_cell(ctx, env, key, 1);
+  if (!cell) {
+    sexp_env_push(ctx, env, tmp, key, value);
+  } else if (sexp_immutablep(cell)) {
+    res = sexp_user_exception(ctx, NULL, "immutable binding", key);
+  } else if (sexp_syntacticp(value) && !sexp_syntacticp(sexp_cdr(cell))) {
+    sexp_env_undefine(ctx, env, key);
+    sexp_env_push(ctx, env, tmp, key, value);
+  } else {
+    sexp_cdr(cell) = value;
+  }
+  return res;
+}
+
+#if SEXP_USE_RENAME_BINDINGS
+sexp sexp_env_rename (sexp ctx, sexp env, sexp key, sexp value) {
+  sexp tmp;
+  sexp_env_push_rename(ctx, env, tmp, key, value);
+  return SEXP_VOID;
+}
+#endif
+
+sexp sexp_env_exports_op (sexp ctx, sexp self, sexp_sint_t n, sexp env) {
+  sexp ls;
+  sexp_gc_var1(res);
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
+  sexp_gc_preserve1(ctx, res);
+  res = SEXP_NULL;
+#if SEXP_USE_RENAME_BINDINGS
+  for (ls=sexp_env_renames(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
+    sexp_push(ctx, res, sexp_cadr(ls));
+#endif
+  for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
+    if (sexp_env_value(ls) != SEXP_UNDEF)
+      sexp_push(ctx, res, sexp_car(ls));
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) {
+  sexp_gc_var2(e, tmp);
+  sexp_gc_preserve2(ctx, e, tmp);
+  e = sexp_alloc_type(ctx, env, SEXP_ENV);
+  sexp_env_parent(e) = env;
+  sexp_env_bindings(e) = SEXP_NULL;
+#if SEXP_USE_RENAME_BINDINGS
+  sexp_env_renames(e) = SEXP_NULL;
+#endif
+  for ( ; sexp_pairp(vars); vars = sexp_cdr(vars))
+    sexp_env_push(ctx, e, tmp, sexp_car(vars), value);
+  sexp_gc_release2(ctx);
+  return e;
+}
+
+sexp sexp_extend_synclo_env (sexp ctx, sexp env) {
+  sexp e1, e2;
+  sexp_gc_var1(e);
+  sexp_gc_preserve1(ctx, e);
+  e = env;
+  if (sexp_pairp(sexp_context_fv(ctx))) {
+    e = sexp_alloc_type(ctx, env, SEXP_ENV);
+    for (e1=env, e2=NULL; e1; e1=sexp_env_parent(e1)) {
+      e2 = e2 ? (sexp_env_parent(e2) = sexp_alloc_type(ctx, env, SEXP_ENV)) : e;
+      sexp_env_bindings(e2) = sexp_env_bindings(e1);
+      sexp_env_syntactic_p(e2) = 1;
+#if SEXP_USE_RENAME_BINDINGS
+      sexp_env_renames(e2) = sexp_env_renames(e1);
+#endif
+    }
+    sexp_env_parent(e2) = sexp_context_env(ctx);
+  }
+  sexp_gc_release1(ctx);
+  return e;
+}
+
+static sexp sexp_reverse_flatten_dot (sexp ctx, sexp ls) {
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls))
+    sexp_push(ctx, res, sexp_car(ls));
+  if (!sexp_nullp(ls))
+    res = sexp_cons(ctx, ls, res);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+static sexp sexp_flatten_dot (sexp ctx, sexp ls) {
+  return sexp_nreverse(ctx, sexp_reverse_flatten_dot(ctx, ls));
+}
+
+int sexp_param_index (sexp ctx, sexp lambda, sexp name) {
+  sexp ls;
+  int i;
+  while (1) {
+    i = 0;
+    ls = sexp_lambda_params(lambda);
+    for (i=0; sexp_pairp(ls); ls=sexp_cdr(ls), i++)
+      if (sexp_car(ls) == name)
+        return i;
+    if (ls == name)
+      return i;
+    ls = sexp_lambda_locals(lambda);
+    for (i=-1; sexp_pairp(ls); ls=sexp_cdr(ls), i--)
+      if (sexp_car(ls) == name)
+        return i-4;
+    if (sexp_synclop(name))
+      name = sexp_synclo_expr(name);
+    else
+      break;
+  }
+  sexp_warn(ctx, "can't happen: no argument: ", name);
+  return -10000;
+}
+
+/************************* bytecode utilities ***************************/
+
+void sexp_shrink_bcode (sexp ctx, sexp_uint_t i) {
+  sexp tmp;
+  if (sexp_bytecode_length(sexp_context_bc(ctx)) != i) {
+    tmp = sexp_alloc_bytecode(ctx, i);
+    if (!sexp_exceptionp(tmp)) {
+      sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx));
+      sexp_bytecode_length(tmp) = i;
+      sexp_bytecode_literals(tmp)
+        = sexp_bytecode_literals(sexp_context_bc(ctx));
+      sexp_bytecode_source(tmp)
+        = sexp_bytecode_source(sexp_context_bc(ctx));
+      memcpy(sexp_bytecode_data(tmp),
+             sexp_bytecode_data(sexp_context_bc(ctx)),
+             i);
+      sexp_context_bc(ctx) = tmp;
+    }
+  }
+}
+
+void sexp_expand_bcode (sexp ctx, sexp_uint_t size) {
+  sexp tmp;
+  if (sexp_bytecode_length(sexp_context_bc(ctx))
+      < (sexp_unbox_fixnum(sexp_context_pos(ctx)))+size) {
+    tmp=sexp_alloc_bytecode(ctx, sexp_bytecode_length(sexp_context_bc(ctx))*2);
+    if (sexp_exceptionp(tmp)) {
+      sexp_context_exception(ctx) = tmp;
+    } else {
+      sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx));
+      sexp_bytecode_length(tmp)
+        = sexp_bytecode_length(sexp_context_bc(ctx))*2;
+      sexp_bytecode_literals(tmp)
+        = sexp_bytecode_literals(sexp_context_bc(ctx));
+      sexp_bytecode_source(tmp)
+        = sexp_bytecode_source(sexp_context_bc(ctx));
+      memcpy(sexp_bytecode_data(tmp),
+             sexp_bytecode_data(sexp_context_bc(ctx)),
+             sexp_bytecode_length(sexp_context_bc(ctx)));
+      sexp_context_bc(ctx) = tmp;
+    }
+  }
+}
+
+void sexp_emit (sexp ctx, unsigned char c)  {
+  sexp_expand_bcode(ctx, 1);
+  if (sexp_exceptionp(sexp_context_exception(ctx)))
+    return;
+  sexp_bytecode_data(sexp_context_bc(ctx))[sexp_unbox_fixnum(sexp_context_pos(ctx))] = c;
+  sexp_context_pos(ctx) = sexp_fx_add(sexp_context_pos(ctx), SEXP_ONE);
+}
+
+sexp sexp_complete_bytecode (sexp ctx) {
+  sexp bc;
+  sexp_emit_return(ctx);
+  sexp_shrink_bcode(ctx, sexp_unbox_fixnum(sexp_context_pos(ctx)));
+  bc = sexp_context_bc(ctx);
+  if (sexp_pairp(sexp_bytecode_literals(bc))) { /* compress literals */
+    if (sexp_nullp(sexp_cdr(sexp_bytecode_literals(bc))))
+      sexp_bytecode_literals(bc) = sexp_car(sexp_bytecode_literals(bc));
+    else if (sexp_nullp(sexp_cddr(sexp_bytecode_literals(bc))))
+      sexp_cdr(sexp_bytecode_literals(bc)) = sexp_cadr(sexp_bytecode_literals(bc));
+    else
+      sexp_bytecode_literals(bc) = sexp_list_to_vector(ctx, sexp_bytecode_literals(bc));
+    if (sexp_exceptionp(sexp_bytecode_literals(bc)))
+      return sexp_bytecode_literals(bc);
+  }
+  sexp_bytecode_max_depth(bc) = sexp_unbox_fixnum(sexp_context_max_depth(ctx));
+#if SEXP_USE_FULL_SOURCE_INFO
+  if (sexp_bytecode_source(bc) && sexp_pairp(sexp_bytecode_source(bc))) {
+    sexp_bytecode_source(bc) = sexp_nreverse(ctx, sexp_bytecode_source(bc));
+    sexp_bytecode_source(bc) = sexp_list_to_vector(ctx, sexp_bytecode_source(bc));
+  }
+#endif
+  sexp_bless_bytecode(ctx, bc);
+  if (sexp_exceptionp(sexp_context_exception(ctx)))
+    return sexp_context_exception(ctx);
+  return bc;
+}
+
+sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags,
+                             sexp num_args, sexp bc, sexp vars) {
+  sexp proc = sexp_alloc_type(ctx, procedure, SEXP_PROCEDURE);
+  sexp_procedure_flags(proc) = (char) (sexp_uint_t) flags;
+  sexp_procedure_num_args(proc) = sexp_unbox_fixnum(num_args);
+  sexp_procedure_code(proc) = bc;
+  sexp_procedure_vars(proc) = vars;
+  return proc;
+}
+
+static sexp sexp_make_macro (sexp ctx, sexp p, sexp e) {
+  sexp mac = sexp_alloc_type(ctx, macro, SEXP_MACRO);
+  sexp_macro_env(mac) = e;
+  sexp_macro_proc(mac) = p;
+  return mac;
+}
+
+sexp sexp_make_synclo_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp fv, sexp expr) {
+  sexp res;
+  if (! (sexp_symbolp(expr) || sexp_pairp(expr) || sexp_synclop(expr)))
+    return expr;
+  res = sexp_alloc_type(ctx, synclo, SEXP_SYNCLO);
+  if (SEXP_USE_FLAT_SYNTACTIC_CLOSURES && sexp_synclop(expr)) {
+    sexp_synclo_env(res) = sexp_synclo_env(expr);
+    sexp_synclo_free_vars(res) = sexp_synclo_free_vars(expr);
+    sexp_synclo_expr(res) = sexp_synclo_expr(expr);
+  } else {
+    sexp_synclo_env(res) = env;
+    sexp_synclo_free_vars(res) = fv;
+    sexp_synclo_expr(res) = expr;
+  }
+  return res;
+}
+
+/* internal AST */
+
+sexp sexp_make_lambda (sexp ctx, sexp params) {
+  sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA);
+  sexp_lambda_name(res) = SEXP_FALSE;
+  sexp_lambda_params(res) = params;
+  sexp_lambda_fv(res) = SEXP_NULL;
+  sexp_lambda_sv(res) = SEXP_NULL;
+  sexp_lambda_locals(res) = SEXP_NULL;
+  sexp_lambda_defs(res) = SEXP_NULL;
+  sexp_lambda_return_type(res) = SEXP_FALSE;
+  sexp_lambda_param_types(res) = SEXP_NULL;
+  return res;
+}
+
+sexp sexp_make_ref (sexp ctx, sexp name, sexp cell) {
+  sexp res = sexp_alloc_type(ctx, ref, SEXP_REF);
+  sexp_ref_name(res) = name;
+  sexp_ref_cell(res) = cell;
+  return res;
+}
+
+static sexp sexp_make_set (sexp ctx, sexp var, sexp value) {
+  sexp res = sexp_alloc_type(ctx, set, SEXP_SET);
+  sexp_set_var(res) = var;
+  sexp_set_value(res) = value;
+  return res;
+}
+
+static sexp sexp_make_cnd (sexp ctx, sexp test, sexp pass, sexp fail) {
+  sexp res = sexp_alloc_type(ctx, cnd, SEXP_CND);
+  sexp_cnd_test(res) = test;
+  sexp_cnd_pass(res) = pass;
+  sexp_cnd_fail(res) = fail;
+  return res;
+}
+
+sexp sexp_make_lit (sexp ctx, sexp value) {
+  sexp res = sexp_alloc_type(ctx, lit, SEXP_LIT);
+  sexp_lit_value(res) = value;
+  return res;
+}
+
+/****************************** contexts ******************************/
+
+#define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*SEXP_INIT_STACK_SIZE)
+
+static void sexp_add_path (sexp ctx, const char *str) {
+  const char *colon;
+  if (str && *str) {
+    colon = strchr(str, ':');
+    if (colon)
+      sexp_add_path(ctx, colon+1);
+    else
+      colon = str + strlen(str);
+    sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), SEXP_VOID);
+    sexp_car(sexp_global(ctx, SEXP_G_MODULE_PATH))
+      = sexp_c_string(ctx, str, colon-str);
+    sexp_immutablep(sexp_global(ctx, SEXP_G_MODULE_PATH)) = 1;
+  }
+}
+
+#if ! SEXP_USE_NATIVE_X86
+static void sexp_init_eval_context_bytecodes (sexp ctx) {
+  sexp_gc_var3(tmp, vec, ctx2);
+  sexp_gc_preserve3(ctx, tmp, vec, ctx2);
+  sexp_emit(ctx, SEXP_OP_RESUMECC);
+  sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE) = sexp_complete_bytecode(ctx);
+  ctx2 = sexp_make_child_context(ctx, NULL);
+  sexp_emit(ctx2, SEXP_OP_DONE);
+  tmp = sexp_complete_bytecode(ctx2);
+  vec = sexp_make_vector(ctx, 0, SEXP_VOID);
+  sexp_global(ctx, SEXP_G_FINAL_RESUMER)
+    = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, tmp, vec);
+  sexp_bytecode_name(sexp_procedure_code(sexp_global(ctx, SEXP_G_FINAL_RESUMER)))
+    = sexp_intern(ctx, "final-resumer", -1);
+  sexp_gc_release3(ctx);
+}
+#endif
+
+void sexp_init_eval_context_globals (sexp ctx) {
+  const char* user_path;
+  ctx = sexp_make_child_context(ctx, NULL);
+#if ! SEXP_USE_NATIVE_X86
+  sexp_init_eval_context_bytecodes(ctx);
+#endif
+  sexp_global(ctx, SEXP_G_MODULE_PATH) = SEXP_NULL;
+  sexp_add_path(ctx, sexp_default_module_path);
+  user_path = getenv(SEXP_MODULE_PATH_VAR);
+  if (!user_path) user_path = sexp_default_user_module_path;
+  sexp_add_path(ctx, user_path);
+#if SEXP_USE_GREEN_THREADS
+  sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR)
+    = sexp_user_exception(ctx, SEXP_FALSE, "I/O would block", SEXP_NULL);
+  sexp_global(ctx, SEXP_G_IO_BLOCK_ONCE_ERROR)
+    = sexp_user_exception(ctx, SEXP_FALSE, "I/O would block once", SEXP_NULL);
+  sexp_global(ctx, SEXP_G_THREAD_TERMINATE_ERROR)
+    = sexp_user_exception(ctx, SEXP_FALSE, "thread terminated", SEXP_NULL);
+  sexp_global(ctx, SEXP_G_THREADS_FRONT) = SEXP_NULL;
+  sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL;
+  sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = SEXP_ZERO;
+  sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = SEXP_FALSE;
+  sexp_global(ctx, SEXP_G_ATOMIC_P) = SEXP_FALSE;
+#endif
+}
+
+sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size, sexp_uint_t max_size) {
+  sexp_gc_var1(res);
+  res = sexp_make_context(ctx, size, max_size);
+  if (!res || sexp_exceptionp(res))
+    return res;
+  if (ctx) sexp_gc_preserve1(ctx, res);
+  sexp_context_env(res) = (env ? env : sexp_make_primitive_env(res, SEXP_SEVEN));
+  sexp_context_specific(res) = sexp_make_vector(res, SEXP_SEVEN, SEXP_ZERO);
+  sexp_context_lambda(res) = SEXP_FALSE;
+  sexp_context_fv(res) = SEXP_NULL;
+  sexp_context_bc(res) = sexp_alloc_bytecode(res, SEXP_INIT_BCODE_SIZE);
+  if (sexp_exceptionp(sexp_context_env(res))) {
+    res = sexp_context_env(res);
+  } else if (sexp_exceptionp(sexp_context_specific(res))) {
+    res = sexp_context_specific(res);
+  } else if (sexp_exceptionp(sexp_context_bc(res))) {
+    res = sexp_context_bc(res);
+  } else {
+    sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE;
+    sexp_bytecode_length(sexp_context_bc(res)) = SEXP_INIT_BCODE_SIZE;
+    sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL;
+    sexp_bytecode_source(sexp_context_bc(res)) = SEXP_NULL;
+    if ((! stack) || (stack == SEXP_FALSE)) {
+      stack = sexp_alloc_tagged(res, SEXP_STACK_SIZE, SEXP_STACK);
+      if (sexp_exceptionp(stack)) {
+        if (ctx) sexp_gc_release1(ctx);
+        return stack;
+      } else {
+        sexp_stack_length(stack) = SEXP_INIT_STACK_SIZE;
+        sexp_stack_top(stack) = 0;
+      }
+    }
+    sexp_context_stack(res) = stack;
+    if (! ctx) sexp_init_eval_context_globals(res);
+    if (ctx) {
+      sexp_context_params(res) = sexp_context_params(ctx);
+      sexp_context_tracep(res) = sexp_context_tracep(ctx);
+      sexp_context_dk(res) = sexp_context_dk(ctx);
+      sexp_gc_release1(ctx);
+    } else {
+      /* TODO: make the root a global (with friendly error in/out) */
+      sexp_context_dk(res) = sexp_make_vector(res, SEXP_FOUR, SEXP_FALSE);
+      sexp_vector_set(sexp_context_dk(res), SEXP_ZERO, SEXP_ZERO);
+    }
+  }
+  return res;
+}
+
+sexp sexp_make_child_context (sexp ctx, sexp lambda) {
+  sexp res = sexp_make_eval_context(ctx,
+                                    sexp_context_stack(ctx),
+                                    sexp_context_env(ctx),
+                                    0,
+                                    sexp_context_max_size(ctx));
+  if (! sexp_exceptionp(res)) {
+    sexp_context_lambda(res) = lambda;
+    sexp_context_top(res) = sexp_context_top(ctx);
+    sexp_context_fv(res) = sexp_context_fv(ctx);
+    sexp_context_tracep(res) = sexp_context_tracep(ctx);
+  }
+  return res;
+}
+
+/**************************** identifiers *****************************/
+
+int sexp_idp (sexp x) {
+  while (sexp_synclop(x)) x = sexp_synclo_expr(x);
+  return sexp_symbolp(x);
+}
+
+sexp sexp_identifierp_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  return sexp_make_boolean(sexp_idp(x));
+}
+
+sexp sexp_syntactic_closure_expr_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  return (sexp_synclop(x) ? sexp_synclo_expr(x) : x);
+}
+
+sexp sexp_strip_synclos (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  sexp_gc_var3(res, kar, kdr);
+  sexp_gc_preserve3(ctx, res, kar, kdr);
+ loop:
+  if (sexp_synclop(x)) {
+    x = sexp_synclo_expr(x);
+    goto loop;
+  } else if (sexp_pairp(x) && sexp_truep(sexp_length(ctx, x))) {
+    kar = sexp_strip_synclos(ctx, self, n, sexp_car(x));
+    kdr = sexp_strip_synclos(ctx, self, n, sexp_cdr(x));
+    res = sexp_cons(ctx, kar, kdr);
+    sexp_pair_source(res) = sexp_pair_source(x);
+    sexp_immutablep(res) = 1;
+  } else {
+    res = x;
+  }
+  sexp_gc_release3(ctx);
+  return res;
+}
+
+sexp sexp_identifier_eq_op (sexp ctx, sexp self, sexp_sint_t n, sexp e1, sexp id1, sexp e2, sexp id2) {
+  sexp cell1, cell2;
+  cell1 = sexp_env_cell(ctx, e1, id1, 0);
+  cell2 = sexp_env_cell(ctx, e2, id2, 0);
+  if (cell1 && (cell1 == cell2))
+    return SEXP_TRUE;
+  else if (!cell1 && !cell2 && (id1 == id2))
+    return SEXP_TRUE;
+  /* If the symbols are the same and the cells are either unbound or
+   * (optionally) bound to top-level variables, consider them the
+   * same.  Local (non-toplevel) bindings must still match exactly.
+   */
+  while (sexp_synclop(id1))
+    id1 = sexp_synclo_expr(id1);
+  while (sexp_synclop(id2))
+    id2 = sexp_synclo_expr(id2);
+  if ((id1 == id2)
+      && ((!cell1 && !cell2)
+#if !SEXP_USE_STRICT_TOPLEVEL_BINDINGS
+          || ((cell1 && cell2)
+              && (!sexp_lambdap(sexp_cdr(cell1)) && !sexp_env_cell_syntactic_p(cell1))
+              && (!sexp_lambdap(sexp_cdr(cell2)) && !sexp_env_cell_syntactic_p(cell2)))
+#endif
+              ))
+    return SEXP_TRUE;
+  return SEXP_FALSE;
+}
+
+/************************* the compiler ***************************/
+
+static sexp analyze_list (sexp ctx, sexp x, int depth, int defok) {
+  sexp_gc_var2(res, tmp);
+  sexp_gc_preserve2(ctx, res, tmp);
+  for (res=SEXP_NULL; sexp_pairp(x); x=sexp_cdr(x)) {
+    sexp_push(ctx, res, SEXP_FALSE);
+    tmp = analyze(ctx, sexp_car(x), depth, defok);
+    if (sexp_exceptionp(tmp)) {
+      res = tmp;
+      break;
+    } else {
+      sexp_pair_source(res) = sexp_pair_source(x);
+      sexp_car(res) = tmp;
+    }
+  }
+  if (sexp_pairp(res)) res = sexp_nreverse(ctx, res);
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+static sexp analyze_app (sexp ctx, sexp x, int depth) {
+  sexp p, res, tmp;
+  res = analyze_list(ctx, x, depth, 0);
+  if (sexp_lambdap(sexp_car(res))) {       /* fill in lambda names */
+    p=sexp_lambda_params(sexp_car(res));
+    for (tmp=sexp_cdr(res); sexp_pairp(tmp)&&sexp_pairp(p); tmp=sexp_cdr(tmp), p=sexp_cdr(p))
+      if (sexp_lambdap(sexp_car(tmp)))
+        sexp_lambda_name(sexp_car(tmp)) = sexp_car(p);
+  }
+  return res;
+}
+
+static sexp analyze_seq (sexp ctx, sexp ls, int depth, int defok) {
+  sexp_gc_var2(res, tmp);
+  sexp_gc_preserve2(ctx, res, tmp);
+  if (sexp_nullp(ls))
+    res = SEXP_VOID;
+  else if (sexp_nullp(sexp_cdr(ls)))
+    res = analyze(ctx, sexp_car(ls), depth, defok);
+  else {
+    res = sexp_alloc_type(ctx, seq, SEXP_SEQ);
+    sexp_seq_source(res) = sexp_pair_source(ls);
+    tmp = analyze_list(ctx, ls, depth, defok);
+    if (sexp_exceptionp(tmp))
+      res = tmp;
+    else
+      sexp_seq_ls(res) = tmp;
+  }
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) {
+  sexp env = sexp_context_env(ctx), res;
+  sexp_gc_var1(cell);
+  sexp_gc_preserve1(ctx, cell);
+  cell = sexp_env_cell_loc(ctx, env, x, 0, varenv);
+  if (! cell) {
+    while (sexp_synclop(x)) x = sexp_synclo_expr(x);
+    cell = sexp_env_cell_create(ctx, env, x, SEXP_UNDEF, varenv);
+  }
+  if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell))) {
+    res = sexp_compile_error(ctx, "invalid use of syntax as value", x);
+  } else {
+    res = sexp_make_ref(ctx, sexp_car(cell), cell);
+  }
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+static sexp analyze_set (sexp ctx, sexp x, int depth) {
+  sexp res, varenv;
+  sexp_gc_var2(ref, value);
+  sexp_gc_preserve2(ctx, ref, value);
+  if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x))
+         && sexp_nullp(sexp_cdddr(x)) && sexp_idp(sexp_cadr(x)))) {
+    res = sexp_compile_error(ctx, "bad set! syntax", x);
+  } else {
+    ref = analyze_var_ref(ctx, sexp_cadr(x), &varenv);
+    if (sexp_lambdap(sexp_ref_loc(ref)))
+      sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref));
+    value = analyze(ctx, sexp_caddr(x), depth, 0);
+    if (sexp_exceptionp(ref)) {
+      res = ref;
+    } else if (sexp_exceptionp(value)) {
+      res = value;
+    } else if (sexp_immutablep(sexp_ref_cell(ref))
+               || (varenv && sexp_immutablep(varenv))) {
+      res = sexp_compile_error(ctx, "immutable binding", sexp_cadr(x));
+    } else {
+      res = sexp_make_set(ctx, ref, value);
+      sexp_set_source(res) = sexp_pair_source(x);
+    }
+  }
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+#define sexp_return(res, val) do {res=val; goto cleanup;} while (0)
+
+static sexp analyze_lambda (sexp ctx, sexp x, int depth) {
+  int trailing_non_procs;
+  sexp name, ls, ctx3;
+  sexp_gc_var6(res, body, tmp, value, defs, ctx2);
+  sexp_gc_preserve6(ctx, res, body, tmp, value, defs, ctx2);
+  /* verify syntax */
+  if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x))))
+    sexp_return(res, sexp_compile_error(ctx, "bad lambda syntax", x));
+  for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls))
+    if (! sexp_idp(sexp_car(ls)))
+      sexp_return(res, sexp_compile_error(ctx, "non-symbol parameter", x));
+    else if (sexp_truep(sexp_memq(ctx, sexp_car(ls), sexp_cdr(ls))))
+      sexp_return(res, sexp_compile_error(ctx, "duplicate parameter", x));
+  /* build lambda and analyze body */
+  res = sexp_make_lambda(ctx, tmp=sexp_copy_list(ctx, sexp_cadr(x)));
+  if (sexp_exceptionp(res)) sexp_return(res, res);
+  sexp_lambda_source(res) = sexp_pair_source(x);
+  if (! (sexp_lambda_source(res) && sexp_pairp(sexp_lambda_source(res))))
+    sexp_lambda_source(res) = sexp_pair_source(sexp_cdr(x));
+  if (! (sexp_lambda_source(res) && sexp_pairp(sexp_lambda_source(res))))
+    sexp_lambda_source(res) = sexp_pair_source(sexp_cddr(x));
+  ctx2 = sexp_make_child_context(ctx, res);
+  if (sexp_exceptionp(ctx2)) sexp_return(res, ctx2);
+  tmp = sexp_flatten_dot(ctx2, sexp_lambda_params(res));
+  sexp_context_env(ctx2) = sexp_extend_env(ctx2, sexp_context_env(ctx2), tmp, res);
+  if (sexp_exceptionp(sexp_context_env(ctx2))) sexp_return(res, sexp_context_env(ctx2));
+  sexp_env_lambda(sexp_context_env(ctx2)) = res;
+  body = analyze_seq(ctx2, sexp_cddr(x), depth, 1);
+  if (sexp_exceptionp(body)) sexp_return(res, body);
+  /* delayed analyze internal defines */
+  trailing_non_procs = 0;
+  defs = SEXP_NULL;
+  for (ls=sexp_lambda_defs(res); sexp_pairp(ls); ls=sexp_cdr(ls)) {
+    tmp = sexp_car(ls);
+    ctx3 = sexp_cdr(tmp);
+    if (sexp_pairp(sexp_caar(tmp))) {
+      name = sexp_caaar(tmp);
+      tmp = sexp_cons(ctx3, sexp_cdaar(tmp), sexp_cdar(tmp));
+      tmp = sexp_cons(ctx3, SEXP_VOID, tmp);
+      sexp_pair_source(tmp) = sexp_pair_source(sexp_caar(ls));
+      value = analyze_lambda(ctx3, tmp, depth);
+    } else {
+      name = sexp_caar(tmp);
+      value = analyze(ctx3, sexp_cadar(tmp), depth, 0);
+    }
+    if (sexp_exceptionp(value)) sexp_return(res, value);
+    if (sexp_lambdap(value)) sexp_lambda_name(value) = name;
+    tmp = analyze_var_ref(ctx3, name, NULL);
+    if (sexp_exceptionp(tmp)) sexp_return(res, tmp);
+    tmp = sexp_make_set(ctx3, tmp, value);
+    if (sexp_exceptionp(tmp)) sexp_return(res, tmp);
+    sexp_push(ctx3, defs, tmp);
+    if (!sexp_lambdap(value)) trailing_non_procs = 1;
+    if (trailing_non_procs || !SEXP_USE_UNBOXED_LOCALS)
+      sexp_insert(ctx3, sexp_lambda_sv(res), name);
+  }
+  if (sexp_pairp(defs)) {
+    if (! sexp_seqp(body)) {
+      tmp = sexp_alloc_type(ctx2, seq, SEXP_SEQ);
+      sexp_seq_ls(tmp) = sexp_list1(ctx2, body);
+      body = tmp;
+    }
+    sexp_seq_ls(body) = sexp_append2(ctx2, defs, sexp_seq_ls(body));
+    if (sexp_exceptionp(sexp_seq_ls(body))) sexp_return(res, sexp_seq_ls(body));
+  }
+  if (sexp_exceptionp(body)) res = body;
+  else sexp_lambda_body(res) = body;
+ cleanup:
+  sexp_gc_release6(ctx);
+  return res;
+}
+
+static sexp analyze_if (sexp ctx, sexp x, int depth) {
+  sexp res, fail_expr;
+  sexp_gc_var3(test, pass, fail);
+  sexp_gc_preserve3(ctx, test, pass, fail);
+  if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
+    res = sexp_compile_error(ctx, "bad if syntax", x);
+  } else {
+    test = analyze(ctx, sexp_cadr(x), depth, 0);
+    pass = analyze(ctx, sexp_caddr(x), depth, 0);
+    fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID;
+    fail = analyze(ctx, fail_expr, depth, 0);
+    res = (sexp_exceptionp(test) ? test : sexp_exceptionp(pass) ? pass :
+           sexp_exceptionp(fail) ? fail : sexp_make_cnd(ctx, test, pass, fail));
+    if (sexp_cndp(res)) sexp_cnd_source(res) = sexp_pair_source(x);
+  }
+  sexp_gc_release3(ctx);
+  return res;
+}
+
+static sexp analyze_define (sexp ctx, sexp x, int depth) {
+  sexp name, res, varenv;
+  sexp_gc_var4(ref, value, tmp, env);
+  sexp_gc_preserve4(ctx, ref, value, tmp, env);
+  env = sexp_context_env(ctx);
+  while (sexp_env_syntactic_p(env) && sexp_env_parent(env))
+    env = sexp_env_parent(env);
+  if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
+    res = sexp_compile_error(ctx, "bad define syntax", x);
+  } else {
+    name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x));
+    if (! sexp_idp(name)) {
+      res = sexp_compile_error(ctx, "can't define a non-symbol", x);
+    } else if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) {
+      sexp_env_push(ctx, env, tmp, name, sexp_context_lambda(ctx));
+      sexp_push(ctx, sexp_lambda_locals(sexp_env_lambda(env)), name);
+      tmp = sexp_cons(ctx, sexp_cdr(x), ctx);
+      sexp_pair_source(sexp_cdr(x)) = sexp_pair_source(x);
+      sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), tmp);
+      res = SEXP_VOID;
+    } else {
+#if SEXP_USE_UNWRAPPED_TOPLEVEL_BINDINGS
+      if (sexp_synclop(name)) name = sexp_synclo_expr(name);
+#endif
+      sexp_env_cell_define(ctx, env, name, SEXP_VOID, &varenv);
+      if (sexp_pairp(sexp_cadr(x))) {
+        tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x));
+        tmp = sexp_cons(ctx, SEXP_VOID, tmp);
+        sexp_pair_source(tmp) = sexp_pair_source(x);
+        value = analyze_lambda(ctx, tmp, depth);
+      } else
+        value = analyze(ctx, sexp_caddr(x), depth, 0);
+      tmp = sexp_env_cell_loc(ctx, env, name, 0, &varenv);
+      ref = sexp_make_ref(ctx, name, tmp);
+      if (sexp_exceptionp(ref)) {
+        res = ref;
+      } else if (sexp_exceptionp(value)) {
+        res = value;
+      } else if (varenv && sexp_immutablep(varenv)) {
+        res = sexp_compile_error(ctx, "immutable binding", name);
+      } else {
+        if (sexp_lambdap(value)) sexp_lambda_name(value) = name;
+        res = sexp_make_set(ctx, ref, value);
+        if (sexp_setp(res)) sexp_set_source(res) = sexp_pair_source(x);
+      }
+    }
+  }
+  sexp_gc_release4(ctx);
+  return res;
+}
+
+static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx, int localp) {
+  sexp res = SEXP_VOID, name;
+  sexp_gc_var1(mac);
+  sexp_gc_preserve1(eval_ctx, mac);
+  for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) {
+    if (! (sexp_pairp(sexp_car(ls)) && sexp_pairp(sexp_cdar(ls))
+           && sexp_idp(sexp_caar(ls)) && sexp_nullp(sexp_cddar(ls)))) {
+      res = sexp_compile_error(eval_ctx, "bad syntax binding", sexp_pairp(ls) ? sexp_car(ls) : ls);
+      break;
+    }
+    if (sexp_idp(sexp_cadar(ls)))
+      mac = sexp_env_ref(eval_ctx, sexp_context_env(eval_ctx), sexp_cadar(ls), SEXP_FALSE);
+    else
+      mac = sexp_eval(eval_ctx, sexp_cadar(ls), NULL);
+    if (sexp_procedurep(mac))
+      mac = sexp_make_macro(eval_ctx, mac, sexp_context_env(eval_ctx));
+    if (!(sexp_macrop(mac)||sexp_corep(mac))) {
+      res = (sexp_exceptionp(mac) ? mac
+             : sexp_compile_error(eval_ctx, "non-procedure macro", mac));
+      break;
+    }
+    name = sexp_caar(ls);
+    if (sexp_synclop(name) && sexp_env_global_p(sexp_context_env(bind_ctx)))
+      name = sexp_synclo_expr(name);
+    if (sexp_macrop(mac) && sexp_pairp(sexp_cadar(ls)))
+      sexp_macro_source(mac) = sexp_pair_source(sexp_cadar(ls));
+    sexp_env_define(eval_ctx, sexp_context_env(bind_ctx), name, mac);
+#if !SEXP_USE_STRICT_TOPLEVEL_BINDINGS
+    if (localp)
+      sexp_env_cell_syntactic_p(sexp_env_cell(eval_ctx, sexp_context_env(bind_ctx), name, 0)) = 1;
+#endif
+  }
+  sexp_gc_release1(eval_ctx);
+  return res;
+}
+
+static sexp analyze_define_syntax (sexp ctx, sexp x) {
+  sexp res;
+  sexp_gc_var1(tmp);
+  sexp_gc_preserve1(ctx, tmp);
+  tmp = sexp_list1(ctx, sexp_cdr(x));
+  res = sexp_exceptionp(tmp) ? tmp : analyze_bind_syntax(tmp, ctx, ctx, 0);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+static sexp analyze_let_syntax_aux (sexp ctx, sexp x, int recp, int depth) {
+  sexp res;
+  sexp_gc_var3(env, ctx2, tmp);
+  sexp_gc_preserve3(ctx, env, ctx2, tmp);
+  if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
+    res = sexp_compile_error(ctx, "bad let(rec)-syntax", x);
+  } else {
+    env = sexp_alloc_type(ctx, env, SEXP_ENV);
+    sexp_env_syntactic_p(env) = 1;
+    sexp_env_parent(env) = sexp_context_env(ctx);
+    sexp_env_bindings(env) = SEXP_NULL;
+#if SEXP_USE_RENAME_BINDINGS
+    sexp_env_renames(env) = SEXP_NULL;
+#endif
+    ctx2 = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
+    sexp_context_env(ctx2) = env;
+    tmp = analyze_bind_syntax(sexp_cadr(x), (recp ? ctx2 : ctx), ctx2, 1);
+    res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx2, sexp_cddr(x), depth, 1));
+  }
+  sexp_gc_release3(ctx);
+  return res;
+}
+
+static sexp analyze_let_syntax (sexp ctx, sexp x, int depth) {
+  return analyze_let_syntax_aux(ctx, x, 0, depth);
+}
+
+static sexp analyze_letrec_syntax (sexp ctx, sexp x, int depth) {
+  return analyze_let_syntax_aux(ctx, x, 1, depth);
+}
+
+static sexp analyze (sexp ctx, sexp object, int depth, int defok) {
+  sexp op;
+  sexp_gc_var4(res, tmp, x, cell);
+  sexp_gc_preserve4(ctx, res, tmp, x, cell);
+  x = object;
+
+  if (++depth > SEXP_MAX_ANALYZE_DEPTH) {
+    res = sexp_compile_error(ctx, "SEXP_MAX_ANALYZE_DEPTH exceeded", x);
+    goto error;
+  }
+
+ loop:
+  if (sexp_pairp(x)) {
+    cell = sexp_idp(sexp_car(x)) ? sexp_env_cell(ctx, sexp_context_env(ctx), sexp_car(x), 0) : NULL;
+    if (sexp_not(sexp_listp(ctx, x))
+        && !(cell && sexp_macrop(sexp_cdr(cell)))) {
+      res = sexp_compile_error(ctx, "dotted list in source", x);
+    } else if (sexp_idp(sexp_car(x))) {
+      if (! cell) {
+        res = analyze_app(ctx, x, depth);
+        if (sexp_exceptionp(res))
+          sexp_warn(ctx, "exception inside undefined operator: ", sexp_car(x));
+      } else {
+        op = sexp_cdr(cell);
+        if (sexp_corep(op)) {
+          switch (sexp_core_code(op)) {
+          case SEXP_CORE_DEFINE:
+            res = defok ? analyze_define(ctx, x, depth)
+              : sexp_compile_error(ctx, "unexpected define", x);
+            break;
+          case SEXP_CORE_SET:
+            res = analyze_set(ctx, x, depth); break;
+          case SEXP_CORE_LAMBDA:
+            res = analyze_lambda(ctx, x, depth); break;
+          case SEXP_CORE_IF:
+            res = analyze_if(ctx, x, depth); break;
+          case SEXP_CORE_BEGIN:
+            res = analyze_seq(ctx, sexp_cdr(x), depth, defok); break;
+          case SEXP_CORE_QUOTE:
+          case SEXP_CORE_SYNTAX_QUOTE:
+            if (! (sexp_pairp(sexp_cdr(x)) && sexp_nullp(sexp_cddr(x))))
+              res = sexp_compile_error(ctx, "bad quote form", x);
+            else
+              res = sexp_make_lit(ctx,
+                                  (sexp_core_code(op) == SEXP_CORE_QUOTE) ?
+                                  tmp=sexp_strip_synclos(ctx , NULL, 1, sexp_cadr(x)) :
+                                  sexp_cadr(x));
+            break;
+          case SEXP_CORE_DEFINE_SYNTAX:
+            res = defok ? analyze_define_syntax(ctx, x)
+              : sexp_compile_error(ctx, "unexpected define-syntax", x);
+            break;
+          case SEXP_CORE_LET_SYNTAX:
+            res = analyze_let_syntax(ctx, x, depth); break;
+          case SEXP_CORE_LETREC_SYNTAX:
+            res = analyze_letrec_syntax(ctx, x, depth); break;
+          default:
+            res = sexp_compile_error(ctx, "unknown core form", op); break;
+          }
+        } else if (sexp_macrop(op)) {
+          tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL);
+          tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp);
+          tmp = sexp_cons(ctx, x, tmp);
+          x = sexp_exceptionp(tmp) ? tmp : sexp_make_child_context(ctx, sexp_context_lambda(ctx));
+          if (!sexp_exceptionp(x) && !sexp_exceptionp(sexp_context_exception(ctx)))
+            x = sexp_apply(x, sexp_macro_proc(op), tmp);
+          if (sexp_exceptionp(x) && sexp_not(sexp_exception_source(x)))
+            sexp_exception_source(x) = sexp_pair_source(sexp_car(tmp));
+          goto loop;
+        } else if (sexp_opcodep(op)) {
+          res = sexp_length(ctx, sexp_cdr(x));
+          if (sexp_unbox_fixnum(res) < sexp_opcode_num_args(op)) {
+            sexp_warn(ctx, "not enough args for opcode: ", x);
+            op = analyze_var_ref(ctx, sexp_car(x), NULL);
+          } else if ((sexp_unbox_fixnum(res) > sexp_opcode_num_args(op))
+                     && (! sexp_opcode_variadic_p(op))) {
+            sexp_warn(ctx, "too many args for opcode: ", x);
+            op = analyze_var_ref(ctx, sexp_car(x), NULL);
+          }
+          res = analyze_list(ctx, sexp_cdr(x), 0, 0);
+          if (! sexp_exceptionp(res)) {
+            /* push op, which will be a direct opcode if the call is valid */
+            sexp_push(ctx, res, op);
+            if (sexp_pairp(res))
+              sexp_pair_source(res) = sexp_pair_source(x);
+          }
+        } else {
+          res = analyze_app(ctx, x, depth);
+        }
+      }
+    } else {
+      res = analyze_app(ctx, x, depth);
+      if (!sexp_exceptionp(res)
+          && !(sexp_pairp(sexp_car(x))
+               || (sexp_synclop(sexp_car(x))
+                   && sexp_pairp(sexp_synclo_expr(sexp_car(x))))))
+        sexp_warn(ctx, "invalid operator in application: ", x);
+    }
+  } else if (sexp_idp(x)) {
+    res = analyze_var_ref(ctx, x, NULL);
+  } else if (sexp_synclop(x)) {
+    tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
+    sexp_context_fv(tmp) = sexp_append2(tmp,
+                                        sexp_synclo_free_vars(x),
+                                        sexp_context_fv(tmp));
+    sexp_context_env(tmp) = sexp_extend_synclo_env(tmp, sexp_synclo_env(x));
+    x = sexp_synclo_expr(x);
+    res = analyze(tmp, x, depth, defok);
+  } else if (sexp_nullp(x)) {
+    res = sexp_compile_error(ctx, "empty application in source", x);
+  } else {
+    if (sexp_pointerp(x))      /* accept vectors and other literals directly, */
+      sexp_immutablep(x) = 1;  /* but they must be immutable */
+    res = x;
+  }
+
+error:
+  if (sexp_exceptionp(res) && sexp_not(sexp_exception_source(res))
+      && sexp_pairp(x))
+    sexp_exception_source(res) = sexp_pair_source(x);
+  sexp_gc_release4(ctx);
+  return res;
+}
+
+sexp sexp_analyze (sexp ctx, sexp x) {return analyze(ctx, x, 0, 1);}
+
+/********************** free varable analysis *************************/
+
+static sexp insert_free_var (sexp ctx, sexp x, sexp fv) {
+  sexp name=sexp_ref_name(x), loc=sexp_ref_loc(x), ls;
+  for (ls=fv; sexp_pairp(ls); ls=sexp_cdr(ls))
+    if ((name == sexp_ref_name(sexp_car(ls)))
+        && (loc == sexp_ref_loc(sexp_car(ls))))
+      return fv;
+  return sexp_cons(ctx, x, fv);
+}
+
+static sexp union_free_vars (sexp ctx, sexp fv1, sexp fv2) {
+  sexp_gc_var1(res);
+  if (sexp_nullp(fv2))
+    return fv1;
+  sexp_gc_preserve1(ctx, res);
+  for (res=fv2; sexp_pairp(fv1); fv1=sexp_cdr(fv1))
+    res = insert_free_var(ctx, sexp_car(fv1), res);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+static sexp diff_free_vars (sexp ctx, sexp lambda, sexp fv, sexp params) {
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  res = SEXP_NULL;
+  for ( ; sexp_pairp(fv); fv=sexp_cdr(fv))
+    if ((sexp_ref_loc(sexp_car(fv)) != lambda)
+        || (sexp_memq(NULL, sexp_ref_name(sexp_car(fv)), params)
+            == SEXP_FALSE))
+      sexp_push(ctx, res, sexp_car(fv));
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_free_vars (sexp ctx, sexp x, sexp fv) {
+  sexp_gc_var2(fv1, fv2);
+  sexp_gc_preserve2(ctx, fv1, fv2);
+  fv1 = fv;
+  if (sexp_lambdap(x)) {
+    fv1 = sexp_free_vars(ctx, sexp_lambda_body(x), SEXP_NULL);
+    fv2 = sexp_flatten_dot(ctx, sexp_lambda_params(x));
+    fv2 = sexp_append2(ctx, sexp_lambda_locals(x), fv2);
+    fv2 = diff_free_vars(ctx, x, fv1, fv2);
+    sexp_lambda_fv(x) = fv2;
+    fv1 = union_free_vars(ctx, fv2, fv);
+  } else if (sexp_pairp(x)) {
+    for ( ; sexp_pairp(x); x=sexp_cdr(x))
+      fv1 = sexp_free_vars(ctx, sexp_car(x), fv1);
+  } else if (sexp_cndp(x)) {
+    fv1 = sexp_free_vars(ctx, sexp_cnd_test(x), fv);
+    fv1 = sexp_free_vars(ctx, sexp_cnd_pass(x), fv1);
+    fv1 = sexp_free_vars(ctx, sexp_cnd_fail(x), fv1);
+  } else if (sexp_seqp(x)) {
+    for (x=sexp_seq_ls(x); sexp_pairp(x); x=sexp_cdr(x))
+      fv1 = sexp_free_vars(ctx, sexp_car(x), fv1);
+  } else if (sexp_setp(x)) {
+    fv1 = sexp_free_vars(ctx, sexp_set_value(x), fv);
+    fv1 = sexp_free_vars(ctx, sexp_set_var(x), fv1);
+  } else if (sexp_refp(x) && sexp_lambdap(sexp_ref_loc(x))) {
+    fv1 = insert_free_var(ctx, x, fv);
+  } else if (sexp_synclop(x)) {
+    fv1 = sexp_free_vars(ctx, sexp_synclo_expr(x), fv);
+  }
+  sexp_gc_release2(ctx);
+  return fv1;
+}
+
+/************************ library procedures **************************/
+
+sexp sexp_open_input_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp path) {
+  FILE *in;
+  int count = 0;
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path);
+  do {
+    if (count != 0) sexp_gc(ctx, NULL);
+    in = fopen(sexp_string_data(path), "r");
+  } while (!in && sexp_out_of_file_descriptors() && !count++);
+  if (!in)
+    return sexp_file_exception(ctx, self, "couldn't open input file", path);
+#if SEXP_USE_GREEN_THREADS
+  fcntl(fileno(in), F_SETFL, O_NONBLOCK);
+#endif
+  return sexp_make_input_port(ctx, in, path);
+}
+
+sexp sexp_open_output_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp path) {
+  FILE *out;
+  int count = 0;
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path);
+  do {
+    if (count != 0) sexp_gc(ctx, NULL);
+    out = fopen(sexp_string_data(path), "w");
+  } while (!out && sexp_out_of_file_descriptors() && !count++);
+  if (!out)
+    return sexp_file_exception(ctx, self, "couldn't open output file", path);
+#if SEXP_USE_GREEN_THREADS
+  fcntl(fileno(out), F_SETFL, O_NONBLOCK);
+#endif
+  return sexp_make_output_port(ctx, out, path);
+}
+
+sexp sexp_open_binary_input_file (sexp ctx, sexp self, sexp_sint_t n, sexp path) {
+  sexp res = sexp_open_input_file_op(ctx, self, n, path);
+  if (sexp_portp(res)) sexp_port_binaryp(res) = 1;
+  return res;
+}
+
+sexp sexp_open_binary_output_file (sexp ctx, sexp self, sexp_sint_t n, sexp path) {
+  sexp res = sexp_open_output_file_op(ctx, self, n, path);
+  if (sexp_portp(res)) sexp_port_binaryp(res) = 1;
+  return res;
+}
+
+sexp sexp_close_port_op (sexp ctx, sexp self, sexp_sint_t n, sexp port) {
+  sexp res = SEXP_VOID;
+  sexp_assert_type(ctx, sexp_portp, SEXP_OPORT, port);
+  /* we can't run arbitrary scheme code in the finalizer, so we need */
+  /* to flush and run the closer here */
+  if (sexp_port_customp(port)) {
+    if (sexp_oportp(port)) res = sexp_flush_output(ctx, port);
+    if (sexp_exceptionp(res)) return res;
+    if (sexp_applicablep(sexp_port_closer(port)))
+      res = sexp_apply1(ctx, sexp_port_closer(port), port);
+    if (sexp_exceptionp(res)) return res;
+  }
+  return sexp_finalize_port(ctx, self, n, port);
+}
+
+sexp sexp_set_port_line_op (sexp ctx, sexp self, sexp_sint_t n, sexp port, sexp line) {
+  sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, port);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, line);
+  sexp_port_sourcep(port) = 1;
+  sexp_port_line(port) = sexp_unbox_fixnum(line);
+  return SEXP_VOID;
+}
+
+#ifndef PLAN9
+sexp sexp_get_port_fileno (sexp ctx, sexp self, sexp_sint_t n, sexp port) {
+  int fd;
+  sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, port);
+  fd = sexp_port_fileno(port);
+  if (fd >= 0)
+    return sexp_make_fixnum(fd);
+  return SEXP_FALSE;
+}
+#endif
+
+#if SEXP_USE_STATIC_LIBS
+#if SEXP_USE_STATIC_LIBS_NO_INCLUDE
+extern struct sexp_library_entry_t* sexp_static_libraries;
+#else
+#include "clibs.c"
+#endif
+static struct sexp_library_entry_t *sexp_find_static_library(const char *file)
+{
+  size_t base_len;
+  struct sexp_library_entry_t *entry;
+
+  if (file[0] == '.' && file[1] == '/')
+    file += 2;
+  base_len = strlen(file) - strlen(sexp_so_extension);
+  if (strcmp(file + base_len, sexp_so_extension))
+    return NULL;
+  for (entry = &sexp_static_libraries[0]; entry->name; entry++)
+    if (! strncmp(file, entry->name, base_len))
+      return entry;
+  return NULL;
+}
+static sexp sexp_load_builtin (sexp ctx, sexp file, sexp env) {
+  struct sexp_library_entry_t *entry = sexp_find_static_library(sexp_string_data(file));
+  if (! entry)
+    return sexp_compile_error(ctx, "couldn't find builtin library", file);
+  return entry->init(ctx, NULL, 3, env, sexp_version, SEXP_ABI_IDENTIFIER);
+}
+#else
+#define sexp_find_static_library(path) NULL
+#define sexp_load_builtin(ctx, file, env) SEXP_UNDEF
+#endif
+
+#if SEXP_USE_DL
+#ifdef __MINGW32__
+#include <windows.h>
+static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) {
+  sexp res;
+  sexp_init_proc init;
+  HINSTANCE handle = LoadLibraryA(sexp_string_data(file));
+  if (!handle)
+    return sexp_compile_error(ctx, "couldn't load dynamic library", file);
+  init = (sexp_init_proc) GetProcAddress(handle, "sexp_init_library");
+  if (!init) {
+    FreeLibrary(handle);
+    return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file);
+  }
+  res = init(ctx, NULL, 3, env, sexp_version, SEXP_ABI_IDENTIFIER);
+  if (res == SEXP_ABI_ERROR) res = sexp_global(ctx, SEXP_G_ABI_ERROR);
+  return res;
+}
+#else
+static sexp sexp_make_dl (sexp ctx, sexp file, void* handle) {
+  sexp res = sexp_alloc_type(ctx, dl, SEXP_DL);
+  sexp_dl_file(res) = file;
+  sexp_dl_handle(res) = handle;
+  return res;
+}
+static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) {
+  sexp_init_proc init;
+  sexp_gc_var2(res, old_dl);
+  void *handle = dlopen(sexp_string_data(file), RTLD_LAZY);
+  if (! handle) {
+    return sexp_compile_error(ctx, "couldn't load dynamic library", file);
+  }
+  init = dlsym(handle, "sexp_init_library");
+  if (! init) {
+    dlclose(handle);
+    return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file);
+  }
+  sexp_gc_preserve2(ctx, res, old_dl);
+  old_dl = sexp_context_dl(ctx);
+  sexp_context_dl(ctx) = sexp_make_dl(ctx, file, handle);
+  res = init(ctx, NULL, 3, env, sexp_version, SEXP_ABI_IDENTIFIER);
+  /* If the ABI is incompatible the library may not even be able to
+     properly reference a global, so it returns a special immediate
+     which we need to translate. */
+  if (res == SEXP_ABI_ERROR) res = sexp_global(ctx, SEXP_G_ABI_ERROR);
+  sexp_context_dl(ctx) = old_dl;
+  sexp_gc_release2(ctx);
+  return res;
+}
+#endif
+#else
+#define sexp_load_dl(ctx, file, env) SEXP_UNDEF
+#endif
+
+#if SEXP_USE_DL || SEXP_USE_STATIC_LIBS
+static sexp sexp_load_binary(sexp ctx, sexp source, sexp env) {
+  sexp res = sexp_load_dl(ctx, source, env);
+  if (res == SEXP_UNDEF || sexp_exceptionp(res))
+    res = sexp_load_builtin(ctx, source, env);
+  return res;
+}
+#endif
+
+sexp sexp_load_op (sexp ctx, sexp self, sexp_sint_t n, sexp source, sexp env) {
+#if SEXP_USE_DL || SEXP_USE_STATIC_LIBS
+  const char *suffix;
+#endif
+  sexp_gc_var5(ctx2, x, in, res, out);
+  if (!env) env = sexp_context_env(ctx);
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
+#if SEXP_USE_DL || SEXP_USE_STATIC_LIBS
+  suffix = sexp_stringp(source) ? sexp_string_data(source)
+    + sexp_string_size(source) - strlen(sexp_so_extension) : "...";
+  if (strcmp(suffix, sexp_so_extension) == 0) {
+    res = sexp_load_binary(ctx, source, env);
+  } else {
+#endif
+  res = SEXP_VOID;
+  if (sexp_iportp(source)) {
+    in = source;
+  } else {
+    sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, source);
+    in = sexp_open_input_file(ctx, source);
+  }
+  sexp_gc_preserve5(ctx, ctx2, x, in, res, out);
+  if (sexp_exceptionp(in)) {
+    out = sexp_current_error_port(ctx);
+    if (sexp_not(out)) out = sexp_current_error_port(ctx);
+    if (sexp_oportp(out))
+      sexp_print_exception(ctx, in, out);
+    res = in;
+  } else {
+    sexp_port_sourcep(in) = 1;
+    ctx2 = sexp_make_eval_context(ctx, NULL, env, 0, 0);
+    sexp_context_parent(ctx2) = ctx;
+    sexp_context_tailp(ctx2) = 0;
+    while ((x=sexp_read(ctx2, in)) != (sexp) SEXP_EOF) {
+      res = sexp_exceptionp(x) ? x : sexp_eval(ctx2, x, env);
+      if (sexp_exceptionp(res))
+        break;
+    }
+    sexp_context_last_fp(ctx) = sexp_context_last_fp(ctx2);
+    if (x == SEXP_EOF)
+      res = SEXP_VOID;
+    sexp_close_port(ctx, in);
+  }
+  sexp_gc_release5(ctx);
+#if SEXP_USE_DL || SEXP_USE_STATIC_LIBS
+  }
+#endif
+  return res;
+}
+
+sexp sexp_register_optimization (sexp ctx, sexp self, sexp_sint_t n, sexp f, sexp priority) {
+  sexp_assert_type(ctx, sexp_applicablep, SEXP_PROCEDURE, f);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, priority);
+  sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), SEXP_VOID);
+  sexp_car(sexp_global(ctx, SEXP_G_OPTIMIZATIONS)) = sexp_cons(ctx, priority, f);
+  return SEXP_VOID;
+}
+
+#if SEXP_USE_MATH
+
+#if SEXP_USE_BIGNUMS
+#define maybe_convert_bignum(z)                                 \
+  else if (sexp_bignump(z)) d = sexp_bignum_to_double(z);
+#else
+#define maybe_convert_bignum(z)
+#endif
+
+#if SEXP_USE_RATIOS
+#define maybe_convert_ratio(z)                          \
+  else if (sexp_ratiop(z)) d = sexp_ratio_to_double(z);
+#else
+#define maybe_convert_ratio(z)
+#endif
+
+#if SEXP_USE_COMPLEX
+#define maybe_convert_complex(z, f)                                     \
+  else if (sexp_complexp(z)) return sexp_complex_normalize(f(ctx, z));
+#define sexp_complex_dummy(ctx, z) 0
+#else
+#define maybe_convert_complex(z, f)
+#endif
+
+#define define_math_op(name, cname, f)                                  \
+  sexp name (sexp ctx, sexp self, sexp_sint_t n, sexp z) {              \
+    double d;                                                           \
+    if (sexp_flonump(z))                                                \
+      d = sexp_flonum_value(z);                                         \
+    else if (sexp_fixnump(z))                                           \
+      d = (double)sexp_unbox_fixnum(z);                                 \
+    maybe_convert_ratio(z)                                              \
+    maybe_convert_bignum(z)                                             \
+    maybe_convert_complex(z, f)                                         \
+    else                                                                \
+      return sexp_type_exception(ctx, self, SEXP_NUMBER, z);            \
+    return sexp_make_flonum(ctx, cname(d));                             \
+  }
+
+define_math_op(sexp_exp, exp, sexp_complex_exp)
+define_math_op(sexp_sin, sin, sexp_complex_sin)
+define_math_op(sexp_cos, cos, sexp_complex_cos)
+define_math_op(sexp_tan, tan, sexp_complex_tan)
+define_math_op(sexp_asin, asin, sexp_complex_asin)
+define_math_op(sexp_acos, acos, sexp_complex_acos)
+define_math_op(sexp_atan, atan, sexp_complex_atan)
+
+#if SEXP_USE_RATIOS
+#define maybe_round_ratio(ctx, q, f)            \
+  if (sexp_ratiop(q)) return f(ctx, q);
+#else
+#define maybe_round_ratio(ctx, q, f)
+#endif
+
+#define define_math_rounder(name, cname, f)                             \
+  sexp name (sexp ctx, sexp self, sexp_sint_t n, sexp z) {              \
+    maybe_round_ratio(ctx, z, f)                                        \
+    if (sexp_flonump(z))                                                \
+      return sexp_make_flonum(ctx, cname(sexp_flonum_value(z)));        \
+    else if (sexp_fixnump(z) || sexp_bignump(z))                        \
+      return z;                                                         \
+    return sexp_type_exception(ctx, self, SEXP_NUMBER, z);              \
+  }
+
+static double even_round (double d) {
+  double res = round(d);
+  if (fabs(d - res) == 0.5 && ((long)res & 1))
+    res += (res < 0) ? 1 : -1;
+  return res;
+}
+
+define_math_rounder(sexp_round, even_round, sexp_ratio_round)
+define_math_rounder(sexp_trunc, trunc, sexp_ratio_trunc)
+define_math_rounder(sexp_floor, floor, sexp_ratio_floor)
+define_math_rounder(sexp_ceiling, ceil, sexp_ratio_ceiling)
+
+sexp sexp_log (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
+  double d;
+#if SEXP_USE_COMPLEX
+  sexp_gc_var1(tmp);
+  if (sexp_complexp(z))
+    return sexp_complex_log(ctx, z);
+#endif
+  if (sexp_flonump(z))
+    d = sexp_flonum_value(z);
+  else if (sexp_fixnump(z))
+    d = (double)sexp_unbox_fixnum(z);
+  maybe_convert_ratio(z)
+  maybe_convert_bignum(z)
+  else
+    return sexp_type_exception(ctx, self, SEXP_NUMBER, z);
+#if SEXP_USE_COMPLEX
+  if (d < 0) {
+    sexp_gc_preserve1(ctx, tmp);
+    tmp = sexp_make_flonum(ctx, d);
+    tmp = sexp_make_complex(ctx, tmp, SEXP_ZERO);
+    tmp = sexp_complex_log(ctx, tmp);
+    sexp_gc_release1(ctx);
+    return tmp;
+  }
+#endif
+  return sexp_make_flonum(ctx, log(d));
+}
+
+sexp sexp_inexact_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
+#if SEXP_USE_COMPLEX
+  int negativep = 0;
+#endif
+  double d, r;
+  sexp_gc_var1(res);
+  if (sexp_flonump(z))
+    d = sexp_flonum_value(z);
+  else if (sexp_fixnump(z))
+    d = (double)sexp_unbox_fixnum(z);
+  maybe_convert_ratio(z)        /* XXXX add ratio sqrt */
+  maybe_convert_complex(z, sexp_complex_sqrt)
+  else
+    return sexp_type_exception(ctx, self, SEXP_NUMBER, z);
+#if SEXP_USE_COMPLEX
+  if (d < 0) {
+    negativep = 1;
+    d = -d;
+  }
+#endif
+  sexp_gc_preserve1(ctx, res);
+  r = sqrt(d);
+  if (sexp_fixnump(z)
+      && (((sexp_uint_t)r*(sexp_uint_t)r)==abs(sexp_unbox_fixnum(z))))
+    res = sexp_make_fixnum(round(r));
+  else
+    res = sexp_make_flonum(ctx, r);
+#if SEXP_USE_COMPLEX
+  if (negativep)
+    res = sexp_make_complex(ctx, SEXP_ZERO, res);
+#endif
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+#if SEXP_USE_BIGNUMS
+sexp sexp_exact_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
+  sexp_gc_var2(res, rem);
+  sexp_gc_preserve2(ctx, res, rem);
+  if (sexp_bignump(z)) {
+    res = sexp_bignum_sqrt(ctx, z, &rem);
+    res = sexp_cons(ctx, res, rem);
+  } else {
+    res = sexp_inexact_sqrt(ctx, self, n, z);
+    if (sexp_flonump(res)) {
+      res = sexp_bignum_normalize(sexp_double_to_bignum(ctx, trunc(sexp_flonum_value(res))));
+    }
+    if (!sexp_exceptionp(res)) {
+      rem = sexp_mul(ctx, res, res);
+      rem = sexp_sub(ctx, z, rem);
+      res = sexp_cons(ctx, res, rem);
+    }
+  }
+  sexp_gc_release2(ctx);
+  return res;
+}
+#endif
+
+sexp sexp_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
+#if SEXP_USE_BIGNUMS
+  sexp_gc_var2(res, rem);
+  if (sexp_bignump(z)) {
+    sexp_gc_preserve2(ctx, res, rem);
+    res = sexp_bignum_sqrt(ctx, z, &rem);
+    rem = sexp_bignum_normalize(rem);
+    if (rem != SEXP_ZERO)
+      res = sexp_make_flonum(ctx, sexp_fixnump(res) ? sexp_unbox_fixnum(res) : sexp_bignum_to_double(res));
+    sexp_gc_release2(ctx);
+    return res;
+  }
+#endif
+  return sexp_inexact_sqrt(ctx, self, n, z);
+}
+
+#endif  /* SEXP_USE_MATH */
+
+#if SEXP_USE_RATIOS || !SEXP_USE_FLONUMS
+sexp sexp_generic_expt (sexp ctx, sexp x, sexp_sint_t e) {
+  sexp_gc_var2(res, tmp);
+  sexp_gc_preserve2(ctx, res, tmp);
+  for (res = SEXP_ONE, tmp = x; e > 0; e >>= 1) {
+    if (e&1) res = sexp_mul(ctx, res, tmp);
+    tmp = sexp_mul(ctx, tmp, tmp);
+  }
+  sexp_gc_release2(ctx);
+  return res;
+}
+#endif
+
+sexp sexp_expt_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) {
+#if !SEXP_USE_FLONUMS
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, x);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, e);
+  return sexp_generic_expt(ctx, x, sexp_unbox_fixnum(e));
+#else
+  long double f, x1, e1;
+  sexp res;
+#if SEXP_USE_BIGNUMS
+  sexp_gc_var1(tmp);
+#endif
+#if SEXP_USE_COMPLEX
+  if (sexp_complexp(x) || sexp_complexp(e))
+    return sexp_complex_expt(ctx, x, e);
+#endif
+#if SEXP_USE_BIGNUMS
+  if (sexp_bignump(e)) {        /* bignum exponent needs special handling */
+    if ((x == SEXP_ZERO) || (x == SEXP_NEG_ONE))
+      res = sexp_make_flonum(ctx, pow(0, 0));          /* +nan.0 */
+    else if (x == SEXP_ONE)
+      res = SEXP_ONE;                                  /* 1.0    */
+    else if (sexp_flonump(x))
+      res = sexp_make_flonum(ctx, pow(sexp_flonum_value(x), sexp_bignum_to_double(e)));
+    else
+      res = sexp_make_flonum(ctx, pow(10.0, 1e100));   /* +inf.0 */
+  } else if (sexp_bignump(x)) {
+    res = sexp_bignum_expt(ctx, x, e);
+  } else {
+#endif
+  if (sexp_fixnump(x))
+    x1 = sexp_unbox_fixnum(x);
+  else if (sexp_flonump(x))
+    x1 = sexp_flonum_value(x);
+#if SEXP_USE_RATIOS
+  else if (sexp_ratiop(x)) {
+    if (sexp_fixnump(e)) {
+      return sexp_generic_expt(ctx, x, sexp_unbox_fixnum(e));
+    } else {
+      x1 = sexp_ratio_to_double(x);
+    }
+  }
+#endif
+  else
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
+  if (sexp_fixnump(e))
+    e1 = sexp_unbox_fixnum(e);
+  else if (sexp_flonump(e))
+    e1 = sexp_flonum_value(e);
+#if SEXP_USE_RATIOS
+  else if (sexp_ratiop(e))
+    e1 = sexp_ratio_to_double(e);
+#endif
+  else
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, e);
+  f = pow(x1, e1);
+  if ((f*1000.0 > SEXP_MAX_FIXNUM) || (f*1000.0 < SEXP_MIN_FIXNUM)
+      || (! sexp_fixnump(x)) || (! sexp_fixnump(e))) {
+#if SEXP_USE_BIGNUMS
+    if (sexp_fixnump(x) && sexp_fixnump(e)) {
+      sexp_gc_preserve1(ctx, tmp);
+      tmp = sexp_fixnum_to_bignum(ctx, x);
+      res = sexp_bignum_expt(ctx, tmp, e);
+      sexp_gc_release1(ctx);
+    } else
+#endif
+      res = sexp_make_flonum(ctx, f);
+  } else
+    res = sexp_make_fixnum((sexp_sint_t)round(f));
+#if SEXP_USE_BIGNUMS
+  }
+#endif
+  return res;
+#endif  /* !SEXP_USE_FLONUMS */
+}
+
+#if SEXP_USE_RATIOS
+sexp sexp_ratio_numerator_op (sexp ctx, sexp self, sexp_sint_t n, sexp rat) {
+  sexp_assert_type(ctx, sexp_ratiop, SEXP_RATIO, rat);
+  return sexp_ratio_numerator(rat);
+}
+sexp sexp_ratio_denominator_op (sexp ctx, sexp self, sexp_sint_t n, sexp rat) {
+  sexp_assert_type(ctx, sexp_ratiop, SEXP_RATIO, rat);
+  return sexp_ratio_denominator(rat);
+}
+#endif
+
+#if SEXP_USE_COMPLEX
+sexp sexp_complex_real_op (sexp ctx, sexp self, sexp_sint_t n, sexp cpx) {
+  sexp_assert_type(ctx, sexp_complexp, SEXP_COMPLEX, cpx);
+  return sexp_complex_real(cpx);
+}
+sexp sexp_complex_imag_op (sexp ctx, sexp self, sexp_sint_t n, sexp cpx) {
+  sexp_assert_type(ctx, sexp_complexp, SEXP_COMPLEX, cpx);
+  return sexp_complex_imag(cpx);
+}
+#endif
+
+sexp sexp_exact_to_inexact (sexp ctx, sexp self, sexp_sint_t n, sexp i) {
+  sexp_gc_var1(res);
+  res = i;
+  if (sexp_fixnump(i))
+    res = sexp_fixnum_to_flonum(ctx, i);
+#if SEXP_USE_FLONUMS
+  else if (sexp_flonump(i))
+    res = i;
+#endif
+#if SEXP_USE_BIGNUMS
+  else if (sexp_bignump(i))
+    res = sexp_make_flonum(ctx, sexp_bignum_to_double(i));
+#endif
+#if SEXP_USE_RATIOS
+  else if (sexp_ratiop(i))
+    res = sexp_make_flonum(ctx, sexp_ratio_to_double(i));
+#endif
+#if SEXP_USE_COMPLEX
+  else if (sexp_complexp(i)) {
+    sexp_gc_preserve1(ctx, res);
+    res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
+    sexp_complex_real(res) = sexp_exact_to_inexact(ctx, self, 1, sexp_complex_real(i));
+    sexp_complex_imag(res) = sexp_exact_to_inexact(ctx, self, 1, sexp_complex_imag(i));
+    sexp_gc_release1(ctx);
+  }
+#endif
+  else
+    res = sexp_type_exception(ctx, self, SEXP_FIXNUM, i);
+  return res;
+}
+
+sexp sexp_inexact_to_exact (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
+  sexp_gc_var1(res);
+  if (sexp_exactp(z)) {
+    res = z;
+  }
+#if SEXP_USE_FLONUMS
+  else if (sexp_flonump(z)) {
+    if (isinf(sexp_flonum_value(z)) || isnan(sexp_flonum_value(z))) {
+      res = sexp_xtype_exception(ctx, self, "exact: not an finite number", z);
+    } else if (sexp_flonum_value(z) != trunc(sexp_flonum_value(z))) {
+#if SEXP_USE_RATIOS
+      res = sexp_double_to_ratio(ctx, sexp_flonum_value(z));
+#else
+      res = sexp_xtype_exception(ctx, self, "exact: not an integer", z);
+#endif
+#if SEXP_USE_BIGNUMS
+    } else if ((sexp_flonum_value(z) > SEXP_MAX_FIXNUM)
+               || sexp_flonum_value(z) < SEXP_MIN_FIXNUM) {
+      res = sexp_double_to_bignum(ctx, sexp_flonum_value(z));
+#endif
+    } else {
+      res = sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(z));
+    }
+  }
+#endif
+#if SEXP_USE_COMPLEX
+  else if (sexp_complexp(z)) {
+    sexp_gc_preserve1(ctx, res);
+    res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
+    sexp_complex_real(res) = sexp_inexact_to_exact(ctx, self, 1, sexp_complex_real(z));
+    sexp_complex_imag(res) = sexp_inexact_to_exact(ctx, self, 1, sexp_complex_imag(z));
+    sexp_gc_release1(ctx);
+  }
+#endif
+  else {
+    res = sexp_type_exception(ctx, self, SEXP_FLONUM, z);
+  }
+  return res;
+}
+
+sexp sexp_string_cmp_op (sexp ctx, sexp self, sexp_sint_t n, sexp str1, sexp str2, sexp ci) {
+  sexp_sint_t len1, len2, len, diff;
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str1);
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str2);
+  len1 = sexp_string_size(str1);
+  len2 = sexp_string_size(str2);
+  len = ((len1<len2) ? len1 : len2);
+  if (ci==SEXP_FALSE)
+    diff = strncmp(sexp_string_data(str1), sexp_string_data(str2), len);
+  else
+    diff = strncasecmp(sexp_string_data(str1), sexp_string_data(str2), len);
+  if (! diff)
+    diff = len1 - len2;
+  return sexp_make_fixnum(diff);
+}
+
+#if SEXP_USE_UTF8_STRINGS
+
+sexp sexp_string_utf8_index_ref (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i) {
+  sexp off;
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
+  off = sexp_string_index_to_offset(ctx, self, n, str, i);
+  if (sexp_exceptionp(off)) return off;
+  if (sexp_unbox_fixnum(off) >= sexp_string_size(str))
+    return sexp_user_exception(ctx, self, "string-ref: index out of range", i);
+  return sexp_string_utf8_ref(ctx, str, off);
+}
+
+sexp sexp_read_utf8_char (sexp ctx, sexp port, int i) {
+  if (i >= 0x80) {
+    if ((i < 0xC0) || (i > 0xF7)) {
+      return sexp_user_exception(ctx, NULL, "read-char: invalid utf8 byte", sexp_make_fixnum(i));
+    } else if (i < 0xE0) {
+      i = ((i&0x3F)<<6) + (sexp_read_char(ctx, port)&0x3F);
+    } else if (i < 0xF0) {
+      i = ((i&0x1F)<<12) + ((sexp_read_char(ctx, port)&0x3F)<<6);
+      i += sexp_read_char(ctx, port)&0x3F;
+    } else {
+      i = ((i&0x0F)<<18) + ((sexp_read_char(ctx, port)&0x3F)<<12);
+      i += (sexp_read_char(ctx, port)&0x3F)<<6;
+      i += sexp_read_char(ctx, port)&0x3F;
+    }
+  }
+  return sexp_make_character(i);
+}
+
+#if SEXP_USE_MUTABLE_STRINGS
+
+void sexp_string_utf8_set (sexp ctx, sexp str, sexp index, sexp ch) {
+  sexp b;
+  unsigned char *p, *q;
+  int i = sexp_unbox_fixnum(index), c = sexp_unbox_character(ch),
+    old_len, new_len, len;
+  p = (unsigned char*)sexp_string_data(str) + i;
+  old_len = sexp_utf8_initial_byte_count(*p);
+  new_len = sexp_utf8_char_byte_count(c);
+  if (old_len != new_len) { /* resize bytes if needed */
+    len = sexp_string_size(str)+(new_len-old_len);
+    b = sexp_make_bytes(ctx, sexp_make_fixnum(len), SEXP_VOID);
+    if (! sexp_exceptionp(b)) {
+      q = (unsigned char*)sexp_bytes_data(b);
+      memcpy(q, sexp_string_data(str), i);
+      memcpy(q+i+new_len, p+old_len, len-i-new_len+1);
+      sexp_string_bytes(str) = b;
+      p = q + i;
+    }
+    sexp_string_size(str) += new_len - old_len;
+  }
+  sexp_utf8_encode_char(p, new_len, c);
+}
+
+sexp sexp_string_utf8_index_set (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i, sexp ch) {
+  sexp off;
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
+  sexp_assert_type(ctx, sexp_charp, SEXP_CHAR, ch);
+  off = sexp_string_index_to_offset(ctx, self, n, str, i);
+  if (sexp_exceptionp(off)) return off;
+  if (sexp_unbox_fixnum(off) >= sexp_string_size(str))
+    return sexp_user_exception(ctx, self, "string-set!: index out of range", i);
+  sexp_string_utf8_set(ctx, str, off, ch);
+  return SEXP_VOID;
+}
+
+#endif
+#endif
+
+#if SEXP_USE_AUTO_FORCE
+sexp sexp_make_promise (sexp ctx, sexp self, sexp_sint_t n, sexp done, sexp val) {
+  sexp res = sexp_alloc_type(ctx, promise, SEXP_PROMISE);
+  sexp_promise_donep(res) = sexp_unbox_boolean(done);
+  sexp_promise_value(res) = val;
+  return res;
+}
+#endif
+
+/***************************** opcodes ********************************/
+
+#if SEXP_USE_TYPE_DEFS
+
+sexp sexp_type_slot_offset_op (sexp ctx , sexp self, sexp_sint_t n, sexp type, sexp slot) {
+  sexp cpl, slots, *v;
+  int i, offset=0, len;
+  sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, type);
+  cpl = sexp_type_cpl(type);
+  if (sexp_vectorp(cpl)) {
+    v = sexp_vector_data(cpl);
+    len = sexp_vector_length(cpl);
+  } else {
+    v = &sexp_type_slots(type);
+    len = 1;
+  }
+  len = sexp_vectorp(cpl) ? sexp_vector_length(cpl) : 1;
+  for (i=0; i<len; i++)
+    for (slots=sexp_type_slots(v[i]); sexp_pairp(slots); slots=sexp_cdr(slots), offset++)
+      if (sexp_car(slots) == slot)
+        return sexp_make_fixnum(offset);
+  return SEXP_FALSE;
+}
+
+sexp sexp_make_type_predicate_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type) {
+  if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type);
+  return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE),
+                          sexp_make_fixnum(SEXP_OP_TYPEP), SEXP_ONE, SEXP_ZERO,
+                          SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, NULL, NULL);
+}
+
+sexp sexp_make_constructor_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type) {
+  sexp_uint_t type_size;
+  if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type);
+  type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type)));
+  return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR),
+                          sexp_make_fixnum(SEXP_OP_MAKE), SEXP_ZERO, SEXP_ZERO,
+                          SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type,
+                          sexp_make_fixnum(type_size), NULL);
+}
+
+sexp sexp_make_getter_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type, sexp index) {
+  if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
+  if ((! sexp_fixnump(type))  || (sexp_unbox_fixnum(type) < 0))
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, type);
+  if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0))
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, index);
+  return
+    sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_GETTER),
+                     sexp_make_fixnum(SEXP_OP_SLOT_REF), SEXP_ONE, SEXP_ZERO,
+                     type, SEXP_ZERO, SEXP_ZERO, type, index, NULL);
+}
+
+sexp sexp_make_setter_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type, sexp index) {
+  sexp res;
+  if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
+  if ((! sexp_fixnump(type))  || (sexp_unbox_fixnum(type) < 0))
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, type);
+  if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0))
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, index);
+  res
+    = sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_SETTER),
+                       sexp_make_fixnum(SEXP_OP_SLOT_SET), SEXP_TWO, SEXP_ZERO,
+                       type, SEXP_ZERO, SEXP_ZERO, type, index, NULL);
+  if (!sexp_exceptionp(res)) sexp_opcode_return_type(res) = SEXP_VOID;
+  return res;
+}
+
+#endif
+
+static sexp sexp_copy_core (sexp ctx, struct sexp_core_form_struct *core) {
+  sexp res = sexp_alloc_type(ctx, core, SEXP_CORE);
+  memcpy(&(res->value), core, sizeof(core[0]));
+  return res;
+}
+
+static sexp sexp_copy_opcode (sexp ctx, struct sexp_opcode_struct *op) {
+  sexp res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE);
+  memcpy(&(res->value), op, sizeof(op[0]));
+  return res;
+}
+
+sexp sexp_make_opcode (sexp ctx, sexp self, sexp name, sexp op_class, sexp code,
+                       sexp num_args, sexp flags, sexp arg1t, sexp arg2t,
+                       sexp invp, sexp data, sexp data2, sexp_proc1 func) {
+  sexp res;
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, num_args);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, flags);
+  if ((! sexp_fixnump(op_class)) || (sexp_unbox_fixnum(op_class) <= 0)
+      || (sexp_unbox_fixnum(op_class) >= SEXP_OPC_NUM_OP_CLASSES))
+    res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode class", op_class);
+  else if ((! sexp_fixnump(code)) || (sexp_unbox_fixnum(code) <= 0)
+      || (sexp_unbox_fixnum(code) >= SEXP_OP_NUM_OPCODES))
+    res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode", code);
+  else {
+    res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE);
+    sexp_opcode_class(res) = sexp_unbox_fixnum(op_class);
+    sexp_opcode_code(res) = sexp_unbox_fixnum(code);
+    sexp_opcode_num_args(res) = sexp_unbox_fixnum(num_args);
+    sexp_opcode_flags(res) = sexp_unbox_fixnum(flags);
+    sexp_opcode_arg1_type(res) = arg1t;
+    sexp_opcode_arg2_type(res) = arg2t;
+    sexp_opcode_inverse(res) = sexp_unbox_fixnum(invp);
+    sexp_opcode_data(res) = data;
+    sexp_opcode_data2(res) = data2;
+    sexp_opcode_func(res) = func;
+    sexp_opcode_name(res) = name;
+#if SEXP_USE_DL
+    sexp_opcode_dl(res) = sexp_context_dl(ctx);
+#endif
+  }
+  return res;
+}
+
+sexp sexp_make_foreign (sexp ctx, const char *name, int num_args,
+                        int flags, sexp_proc1 f, sexp data) {
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+#if ! SEXP_USE_EXTENDED_FCALL
+  if (num_args > 4)
+    return sexp_user_exception(ctx, NULL, "make-foreign: exceeded foreign arg limit",
+                               sexp_make_fixnum(num_args));
+#endif
+  res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE);
+  sexp_opcode_class(res) = SEXP_OPC_FOREIGN;
+#if SEXP_USE_EXTENDED_FCALL
+  if (num_args > 4)
+    sexp_opcode_code(res) = SEXP_OP_FCALLN;
+  else
+#endif
+    sexp_opcode_code(res) = SEXP_OP_FCALL1+num_args-1;
+  if (flags & 1) num_args--;
+  sexp_opcode_num_args(res) = num_args;
+  sexp_opcode_flags(res) = flags;
+  sexp_opcode_name(res) = sexp_c_string(ctx, name, -1);
+  sexp_opcode_data(res) = data;
+  sexp_opcode_func(res) = f;
+#if SEXP_USE_DL
+  sexp_opcode_dl(res) = sexp_context_dl(ctx);
+#endif
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args,
+                              int flags, sexp_proc1 f, sexp data) {
+  sexp_gc_var2(sym, res);
+  sexp_gc_preserve2(ctx, sym, res);
+  res = sexp_make_foreign(ctx, name, num_args, flags, f, data);
+  if (!sexp_exceptionp(res))
+    sexp_env_define(ctx, env, sym = sexp_intern(ctx, name, -1), res);
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name,
+                                int num_args, sexp_proc1 f, const char *param) {
+  sexp res = SEXP_FALSE;
+  sexp_gc_var1(tmp);
+  sexp_gc_preserve1(ctx, tmp);
+  tmp = sexp_intern(ctx, param, -1);
+  tmp = sexp_env_ref(ctx, env, tmp, SEXP_FALSE);
+  if (sexp_opcodep(tmp))
+    res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, f, tmp);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+/*********************** standard environment *************************/
+
+/* The 10 core forms.  Note quote can be defined as derived syntax: */
+
+/*  (define-syntax quote */
+/*    (lambda (expr use-env mac-env) */
+/*      (list */
+/*       (make-syntactic-closure mac-env (list) (syntax-quote syntax-quote)) */
+/*       (strip-syntactic-closures (car (cdr expr)))))) */
+
+static struct sexp_core_form_struct core_forms[] = {
+  {SEXP_CORE_DEFINE, (sexp)"define"},
+  {SEXP_CORE_SET, (sexp)"set!"},
+  {SEXP_CORE_LAMBDA, (sexp)"lambda"},
+  {SEXP_CORE_IF, (sexp)"if"},
+  {SEXP_CORE_BEGIN, (sexp)"begin"},
+  {SEXP_CORE_QUOTE, (sexp)"quote"},
+  {SEXP_CORE_SYNTAX_QUOTE, (sexp)"syntax-quote"},
+  {SEXP_CORE_DEFINE_SYNTAX, (sexp)"define-syntax"},
+  {SEXP_CORE_LET_SYNTAX, (sexp)"let-syntax"},
+  {SEXP_CORE_LETREC_SYNTAX, (sexp)"letrec-syntax"},
+};
+
+sexp sexp_make_env_op (sexp ctx, sexp self, sexp_sint_t n) {
+  sexp e = sexp_alloc_type(ctx, env, SEXP_ENV);
+  sexp_env_lambda(e) = NULL;
+  sexp_env_parent(e) = NULL;
+  sexp_env_bindings(e) = SEXP_NULL;
+#if SEXP_USE_RENAME_BINDINGS
+  sexp_env_renames(e) = SEXP_NULL;
+#endif
+  return e;
+}
+
+sexp sexp_make_null_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp version) {
+  sexp_uint_t i;
+  sexp_gc_var2(e, core);
+  sexp_gc_preserve2(ctx, e, core);
+  e = sexp_make_env(ctx);
+  for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) {
+    core = sexp_copy_core(ctx, &core_forms[i]);
+    sexp_env_define(ctx, e, sexp_intern(ctx, (char*)sexp_core_name(core), -1), core);
+    sexp_core_name(core) = sexp_c_string(ctx, (char*)sexp_core_name(core), -1);
+  }
+  sexp_gc_release2(ctx);
+  return e;
+}
+
+sexp sexp_make_primitive_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp version) {
+  int i;
+  sexp_gc_var4(e, op, sym, name);
+  sexp_gc_preserve4(ctx, e, op, sym, name);
+  e = sexp_make_null_env(ctx, version);
+  for (i=0; sexp_primitive_opcodes[i].op_class; i++) {
+    op = sexp_copy_opcode(ctx, &sexp_primitive_opcodes[i]);
+    name = sexp_intern(ctx, (char*)sexp_opcode_name(op), -1);
+    sexp_opcode_name(op) = sexp_c_string(ctx, (char*)sexp_opcode_name(op), -1);
+    if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) {
+      sym = sexp_intern(ctx, (char*)sexp_opcode_data(op), -1);
+      sexp_opcode_data(op) = sexp_env_ref(ctx, e, sym, SEXP_FALSE);
+    } else if (sexp_opcode_class(op) == SEXP_OPC_PARAMETER) {
+      sexp_opcode_data(op) = sexp_cons(ctx, name, SEXP_FALSE);
+    }
+    if (sexp_opcode_class(op) == SEXP_OPC_FOREIGN && sexp_opcode_data2(op)) {
+      sexp_opcode_data2(op) = sexp_c_string(ctx, (char*)sexp_opcode_data2(op), -1);
+    }
+    sexp_env_define(ctx, e, name, op);
+  }
+  sexp_gc_release4(ctx);
+  return e;
+}
+
+sexp sexp_find_module_file (sexp ctx, const char *file) {
+  sexp res=SEXP_FALSE, ls;
+  char *dir, *path;
+  sexp_uint_t slash, dirlen, filelen, len;
+#ifdef PLAN9
+#define file_exists_p(path, buf) (stat(path, buf, 128) >= 0)
+  unsigned char buf[128];
+#else
+#define file_exists_p(path, buf) (! stat(path, buf))
+  struct stat buf_str;
+  struct stat *buf = &buf_str;
+#endif
+
+  filelen = strlen(file);
+
+  ls = sexp_global(ctx, SEXP_G_MODULE_PATH);
+  for ( ; sexp_pairp(ls) && sexp_not(res); ls=sexp_cdr(ls)) {
+    dir = sexp_string_data(sexp_car(ls));
+    dirlen = sexp_string_size(sexp_car(ls));
+    slash = dir[dirlen-1] == '/';
+    len = dirlen+filelen+2-slash;
+    path = (char*) sexp_malloc(len);
+    if (! path) return sexp_global(ctx, SEXP_G_OOM_ERROR);
+    memcpy(path, dir, dirlen);
+    if (! slash) path[dirlen] = '/';
+    memcpy(path+len-filelen-1, file, filelen);
+    path[len-1] = '\0';
+    if (sexp_find_static_library(path) || file_exists_p(path, buf))
+      res = sexp_c_string(ctx, path, len-1);
+    free(path);
+  }
+
+  return res;
+}
+
+#define sexp_file_not_found "couldn't find file in module path"
+
+sexp sexp_load_module_file (sexp ctx, const char *file, sexp env) {
+  sexp res;
+  sexp_gc_var1(path);
+  sexp_gc_preserve1(ctx, path);
+  path = sexp_find_module_file(ctx, file);
+  if (sexp_stringp(path)) {
+    res = sexp_load(ctx, path, env);
+  } else {
+    path = sexp_c_string(ctx, file, -1);
+    res = sexp_user_exception(ctx, SEXP_FALSE, sexp_file_not_found, path);
+  }
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+#if SEXP_USE_MODULES
+sexp sexp_current_module_path_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  if (sexp_pairp(x) && sexp_stringp(sexp_car(x))) {
+    sexp_global(ctx, SEXP_G_MODULE_PATH) = sexp_reverse(ctx, x);
+    sexp_global(ctx, SEXP_G_MODULE_PATH) = sexp_reverse(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH));
+  }
+  return sexp_global(ctx, SEXP_G_MODULE_PATH);
+}
+sexp sexp_find_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file) {
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file);
+  return sexp_find_module_file(ctx, sexp_string_data(file));
+}
+sexp sexp_load_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file, sexp env) {
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file);
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
+  return sexp_load_module_file(ctx, sexp_string_data(file), env);
+}
+sexp sexp_current_environment (sexp ctx, sexp self, sexp_sint_t n) {
+  return sexp_context_env(ctx);
+}
+sexp sexp_set_current_environment (sexp ctx, sexp self, sexp_sint_t n, sexp env) {
+  sexp oldenv;
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
+  oldenv = sexp_context_env(ctx);
+  sexp_context_env(ctx) = env;
+  return oldenv;
+}
+sexp sexp_meta_environment (sexp ctx, sexp self, sexp_sint_t n) {
+  return sexp_global(ctx, SEXP_G_META_ENV);
+}
+#endif
+
+sexp sexp_add_module_directory_op (sexp ctx, sexp self, sexp_sint_t n, sexp dir, sexp appendp) {
+  sexp ls;
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, dir);
+  if (sexp_truep(appendp)) {
+    if (sexp_pairp(ls=sexp_global(ctx, SEXP_G_MODULE_PATH))) {
+      for ( ; sexp_pairp(sexp_cdr(ls)); ls=sexp_cdr(ls))
+        ;
+      sexp_cdr(ls) = sexp_list1(ctx, dir);
+    } else {
+      sexp_global(ctx, SEXP_G_MODULE_PATH) = sexp_list1(ctx, dir);
+    }
+  } else {
+    sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), dir);
+  }
+  return SEXP_VOID;
+}
+
+sexp sexp_parameter_ref (sexp ctx, sexp param) {
+#if SEXP_USE_GREEN_THREADS
+  sexp ls;
+  for (ls=sexp_context_params(ctx); sexp_pairp(ls); ls=sexp_cdr(ls))
+    if (sexp_caar(ls) == param)
+      return sexp_cdar(ls);
+#endif
+  return sexp_opcodep(param) && sexp_opcode_data(param) && sexp_pairp(sexp_opcode_data(param))
+    ? sexp_cdr(sexp_opcode_data(param)) : SEXP_FALSE;
+}
+
+#if SEXP_USE_GREEN_THREADS
+sexp sexp_dk (sexp ctx, sexp self, sexp_sint_t n, sexp val) {
+  if (sexp_not(val)) {
+    return sexp_context_dk(ctx) ? sexp_context_dk(ctx) : SEXP_FALSE;
+  } else {
+    sexp_context_dk(ctx) = val;
+    return SEXP_VOID;
+  }
+}
+#endif
+
+sexp sexp_thread_parameters (sexp ctx, sexp self, sexp_sint_t n) {
+  sexp res = sexp_context_params(ctx);
+  return res ? res : SEXP_NULL;
+}
+
+sexp sexp_thread_parameters_set (sexp ctx, sexp self, sexp_sint_t n, sexp new) {
+  sexp_context_params(ctx) = new;
+  return SEXP_VOID;
+}
+
+void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value) {
+  sexp param = sexp_env_ref(ctx, env, name, SEXP_FALSE);
+  if (sexp_opcodep(param)) {
+    if (! sexp_pairp(sexp_opcode_data(param)))
+      sexp_opcode_data(param) = sexp_cons(ctx, name, value);
+    else
+      sexp_cdr(sexp_opcode_data(param)) = value;
+  } else {
+    sexp_warn(ctx, "can't set non-parameter: ", name);
+  }
+}
+
+sexp sexp_load_standard_ports (sexp ctx, sexp env, FILE* in, FILE* out,
+                               FILE* err, int no_close) {
+  sexp_gc_var1(p);
+  sexp_gc_preserve1(ctx, p);
+  if (!env) env = sexp_context_env(ctx);
+  if (in) {
+    p = sexp_make_input_port(ctx, in, SEXP_FALSE);
+    sexp_port_no_closep(p) = no_close;
+    sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), p);
+  }
+  if (out) {
+    p = sexp_make_output_port(ctx, out, SEXP_FALSE);
+    sexp_port_no_closep(p) = no_close;
+    sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), p);
+  }
+  if (err) {
+    p = sexp_make_output_port(ctx, err, SEXP_FALSE);
+    sexp_port_no_closep(p) = no_close;
+    sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), p);
+  }
+  sexp_gc_release1(ctx);
+  return SEXP_VOID;
+}
+
+static const char* sexp_initial_features[] = {
+  sexp_platform,
+#if SEXP_BSD
+  "bsd",
+#endif
+#if defined(_WIN32) || defined(__MINGW32__)
+  "windows",
+#endif
+#if SEXP_USE_DL
+  "dynamic-loading",
+#endif
+#if SEXP_USE_BIDIRECTIONAL_PORTS
+  "bidir-ports",
+#endif
+#if SEXP_USE_STRING_STREAMS
+  "string-streams",
+#endif
+#if SEXP_USE_MODULES
+  "modules",
+#endif
+#if SEXP_USE_BOEHM
+  "boehm-gc",
+#endif
+#if SEXP_USE_UTF8_STRINGS
+  "full-unicode",
+#endif
+#if SEXP_USE_GREEN_THREADS
+  "threads",
+#endif
+#if SEXP_USE_NTP_GETTIME
+  "ntp",
+#endif
+#if SEXP_USE_AUTO_FORCE
+  "auto-force",
+#endif
+#if SEXP_USE_COMPLEX
+  "complex",
+#endif
+#if SEXP_USE_RATIOS
+  "ratios",
+#endif
+  "r7rs",
+  "chibi",
+  NULL,
+};
+
+sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) {
+  int len;
+  char init_file[128];
+  const char** features;
+  int endianess_check = 1;
+  sexp_gc_var3(op, tmp, sym);
+  sexp_gc_preserve3(ctx, op, tmp, sym);
+  if (!e) e = sexp_context_env(ctx);
+  sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*shared-object-extension*", -1),
+                  tmp=sexp_c_string(ctx, sexp_so_extension, -1));
+  tmp = SEXP_NULL;
+  sexp_push(ctx, tmp, sym=sexp_intern(ctx, (*(unsigned char*) &endianess_check) ? "little-endian" : "big-endian", -1));
+  for (features=sexp_initial_features; *features; features++)
+    sexp_push(ctx, tmp, sym=sexp_intern(ctx, *features, -1));
+  sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*features*", -1), tmp);
+  sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL;
+#if SEXP_USE_SIMPLIFY
+  op = sexp_make_foreign(ctx, "sexp_simplify", 1, 0,
+                         (sexp_proc1)sexp_simplify, SEXP_VOID);
+  tmp = sexp_cons(ctx, sexp_make_fixnum(500), op);
+  sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp);
+#endif
+  sexp_global(ctx, SEXP_G_ERR_HANDLER)
+    = sexp_env_ref(ctx, e, sym=sexp_intern(ctx, "current-exception-handler", -1), SEXP_FALSE);
+  /* load init-7.scm */
+  len = strlen(sexp_init_file);
+  strncpy(init_file, sexp_init_file, len);
+  init_file[len] = sexp_unbox_fixnum(version) + '0';
+  strncpy(init_file + len + 1, sexp_init_file_suffix, strlen(sexp_init_file_suffix));
+  init_file[len + 1 + strlen(sexp_init_file_suffix)] = 0;
+  tmp = sexp_load_module_file(ctx, init_file, e);
+  sexp_set_parameter(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e);
+  /* load and bind meta-7.scm env */
+#if SEXP_USE_MODULES
+  if (!sexp_exceptionp(tmp)) {
+    if (!sexp_envp(tmp=sexp_global(ctx, SEXP_G_META_ENV))) {
+      tmp = sexp_make_env(ctx);
+      if (! sexp_exceptionp(tmp)) {
+        sexp_global(ctx, SEXP_G_META_ENV) = tmp;
+        sexp_env_parent(tmp) = e;
+        op = sexp_load_module_file(ctx, sexp_meta_file, tmp);
+        if (sexp_exceptionp(op))
+          sexp_print_exception(ctx, op, sexp_current_error_port(ctx));
+      }
+    }
+    if (!sexp_exceptionp(tmp)) {
+      sym = sexp_intern(ctx, "repl-import", -1);
+      tmp = sexp_env_ref(ctx, tmp, sym, SEXP_VOID);
+      sym = sexp_intern(ctx, "import", -1);
+      /* splice import in place to mutate both this env and the */
+      /* frozen version in the meta env) */
+      tmp = sexp_cons(ctx, sym, tmp);
+      sexp_env_next_cell(tmp) = sexp_env_next_cell(sexp_env_bindings(e));
+      sexp_env_next_cell(sexp_env_bindings(e)) = tmp;
+    }
+  }
+#endif
+  sexp_gc_release3(ctx);
+  return sexp_exceptionp(tmp) ? tmp : e;
+}
+
+sexp sexp_make_standard_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp version) {
+  sexp_gc_var1(env);
+  sexp_gc_preserve1(ctx, env);
+  env = sexp_make_primitive_env(ctx, version);
+  if (! sexp_exceptionp(env)) env = sexp_load_standard_env(ctx, env, SEXP_SEVEN);
+  sexp_gc_release1(ctx);
+  return env;
+}
+
+sexp sexp_env_parent_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
+  return sexp_env_parent(e) ? sexp_env_parent(e) : SEXP_FALSE;
+}
+
+#if SEXP_USE_RENAME_BINDINGS
+#define sexp_same_bindingp(x, y) ((x) == (y))
+#else
+#define sexp_same_bindingp(x, y) (sexp_env_value(x) == sexp_env_value(y))
+#endif
+
+/* Rewrite to in place: to => empty->imports->to */
+sexp sexp_env_import_op (sexp ctx, sexp self, sexp_sint_t n, sexp to, sexp from, sexp ls, sexp immutp) {
+  sexp oldname, newname;
+  sexp_gc_var3(value, oldcell, tmp);
+  sexp_gc_preserve3(ctx, value, oldcell, tmp);
+  if (! sexp_envp(to)) to = sexp_context_env(ctx);
+  if (! sexp_envp(from)) from = sexp_context_env(ctx);
+  /* create an empty imports env frame */
+  value = sexp_make_env(ctx);
+  sexp_env_parent(value) = sexp_env_parent(to);
+  sexp_env_parent(to) = value;
+  sexp_env_lambda(value) = sexp_env_lambda(to);
+  sexp_env_lambda(to) = NULL;
+  sexp_env_bindings(value) = sexp_env_bindings(to);
+  sexp_env_bindings(to) = SEXP_NULL;
+#if SEXP_USE_RENAME_BINDINGS
+  sexp_env_renames(value) = sexp_env_renames(to);
+  sexp_env_renames(to) = SEXP_NULL;
+#endif
+  sexp_immutablep(value) = sexp_immutablep(to);
+  sexp_immutablep(to) = sexp_truep(immutp);
+  /* import the bindings, one at a time or in bulk */
+  if (sexp_not(ls)) {
+    sexp_env_bindings(to) = sexp_env_bindings(from);
+#if SEXP_USE_RENAME_BINDINGS
+    sexp_env_renames(to) = sexp_env_renames(from);
+#endif
+  } else {
+    for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) {
+      if (sexp_pairp(sexp_car(ls))) {
+        newname = sexp_caar(ls); oldname = sexp_cdar(ls);
+      } else {
+        newname = oldname = sexp_car(ls);
+      }
+      oldcell = sexp_env_cell(ctx, to, newname, 0);
+      value = sexp_env_cell(ctx, from, oldname, 0);
+      if (value) {
+#if SEXP_USE_RENAME_BINDINGS
+        sexp_env_rename(ctx, to, newname, value);
+#else
+        sexp_env_push(ctx, to, tmp, newname, sexp_cdr(value));
+#endif
+#if SEXP_USE_WARN_UNDEFS
+        if (oldcell
+            && sexp_cdr(oldcell) != SEXP_UNDEF
+            && !sexp_same_bindingp(oldcell, value))
+          sexp_warn(ctx, "importing already defined binding: ", newname);
+      } else {
+        sexp_warn(ctx, "importing undefined variable: ", oldname);
+#endif
+      }
+    }
+  }
+  /* create a new empty frame for future defines */
+  value = sexp_make_env(ctx);
+  sexp_env_parent(value) = sexp_env_parent(to);
+  sexp_env_lambda(value) = sexp_env_lambda(to);
+  sexp_env_bindings(value) = sexp_env_bindings(to);
+#if SEXP_USE_RENAME_BINDINGS
+  sexp_env_renames(value) = sexp_env_renames(to);
+  sexp_env_renames(to) = SEXP_NULL;
+#endif
+  sexp_env_parent(to) = value;
+  sexp_env_bindings(to) = SEXP_NULL;
+  sexp_immutablep(to) = 0;
+  sexp_gc_release3(ctx);
+  return SEXP_VOID;
+}
+
+/************************** eval interface ****************************/
+
+sexp sexp_generate_op (sexp ctx, sexp self, sexp_sint_t n, sexp ast, sexp env) {
+  sexp_gc_var3(ctx2, vec, res);
+  if (sexp_contextp(env)) {
+    ctx2 = env;
+  } else {
+    sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
+    ctx2 = sexp_make_eval_context(ctx, NULL, env, 0, 0);
+  }
+  sexp_gc_preserve3(ctx, ctx2, vec, res);
+  sexp_free_vars(ctx2, ast, SEXP_NULL);    /* should return SEXP_NULL */
+  sexp_emit_enter(ctx2);
+  sexp_generate(ctx2, 0, 0, 0, ast);
+  res = sexp_complete_bytecode(ctx2);
+  if (!sexp_exceptionp(res)) {
+    sexp_context_specific(ctx2) = SEXP_FALSE;
+    vec = sexp_make_vector(ctx2, 0, SEXP_VOID);
+    if (sexp_exceptionp(vec)) res = vec;
+    else res = sexp_make_procedure(ctx2, SEXP_ZERO, SEXP_ZERO, res, vec);
+  }
+  sexp_gc_release3(ctx);
+  return res;
+}
+
+sexp sexp_compile_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp env) {
+  sexp_gc_var3(ast, tmp, res);
+  sexp ctx2;
+  if (! env) env = sexp_context_env(ctx);
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
+  sexp_gc_preserve3(ctx, ast, tmp, res);
+  ctx2 = sexp_make_eval_context(ctx, NULL, env, 0, 0);
+  if (sexp_exceptionp(ctx2)) {
+    res = ctx2;
+  } else {
+    tmp = sexp_context_child(ctx);
+    sexp_context_child(ctx) = ctx2;
+    ast = sexp_analyze(ctx2, obj);
+    if (sexp_exceptionp(ast)) {
+      res = ast;
+    } else {
+      res = sexp_global(ctx2, SEXP_G_OPTIMIZATIONS);
+      for ( ; sexp_pairp(res) && !sexp_exceptionp(ast); res=sexp_cdr(res))
+        ast = sexp_apply1(ctx2, sexp_cdar(res), ast);
+      if (sexp_exceptionp(ast)) {
+        res = ast;
+      } else {
+        res = sexp_generate_op(ctx2, self, n, ast, ctx2);
+      }
+    }
+    sexp_context_child(ctx) = tmp;
+    sexp_context_last_fp(ctx) = sexp_context_last_fp(ctx2);
+  }
+  sexp_gc_release3(ctx);
+  return res;
+}
+
+sexp sexp_eval_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp env) {
+  sexp_sint_t top;
+  sexp ctx2;
+  sexp_gc_var3(res, tmp, params);
+  if (! env) env = sexp_context_env(ctx);
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
+  sexp_gc_preserve3(ctx, res, tmp, params);
+  top = sexp_context_top(ctx);
+  params = sexp_context_params(ctx);
+  sexp_context_params(ctx) = SEXP_NULL;
+  ctx2 = sexp_make_eval_context(ctx, NULL, env, 0, 0);
+  tmp = sexp_context_child(ctx);
+  sexp_context_child(ctx) = ctx2;
+  res = sexp_exceptionp(ctx2) ? ctx2 : sexp_compile_op(ctx2, self, n, obj, env);
+  if (! sexp_exceptionp(res))
+    res = sexp_apply(ctx2, res, SEXP_NULL);
+  sexp_context_child(ctx) = tmp;
+  sexp_context_params(ctx) = params;
+  sexp_context_top(ctx) = top;
+  sexp_context_last_fp(ctx) = sexp_context_last_fp(ctx2);
+  sexp_gc_release3(ctx);
+  return res;
+}
+
+sexp sexp_eval_string (sexp ctx, const char *str, sexp_sint_t len, sexp env) {
+  sexp res;
+  sexp_gc_var1(obj);
+  sexp_gc_preserve1(ctx, obj);
+  obj = sexp_read_from_string(ctx, str, len);
+  res = sexp_eval(ctx, obj, env);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+void sexp_scheme_init (void) {
+  if (! scheme_initialized_p) {
+    scheme_initialized_p = 1;
+    sexp_init();
+  }
+}
diff --git a/examples/echo-server-inet6.scm b/examples/echo-server-inet6.scm
new file mode 100644
index 00000000..2a853d19
--- /dev/null
+++ b/examples/echo-server-inet6.scm
@@ -0,0 +1,29 @@
+#!/usr/bin/env chibi-scheme
+
+(import (scheme base) (scheme write) (chibi net) (chibi net server))
+
+;; Copy each input line to output.
+(define (echo-handler in out sock addr)
+  (let ((line (read-line in)))
+    (cond
+     ((not (or (eof-object? line) (equal? line "")))
+      ;; log the request to stdout
+      (display "read: ") (write line)
+      (display " from ")
+      (display (sockaddr-name (address-info-address addr)))
+      (display " port ") (write (sockaddr-port (address-info-address addr)))
+      (newline)
+      ;; write and flush the response
+      (display line out)
+      (newline out)
+      (flush-output-port out)
+      (echo-handler in out sock addr)))))
+
+(define (get-inet6-address-info host service)
+  (let ((hints (make-address-info address-family/inet6
+                                  socket-type/stream
+                                  ip-proto/tcp)))
+    (get-address-info host service hints)))
+
+;; Start the server on local ipv6 addresses on port 5556.
+(run-net-server (get-inet6-address-info #f 5556) echo-handler)
diff --git a/examples/echo-server-udp.scm b/examples/echo-server-udp.scm
new file mode 100755
index 00000000..0e1077a8
--- /dev/null
+++ b/examples/echo-server-udp.scm
@@ -0,0 +1,22 @@
+#!/usr/bin/env chibi-scheme
+
+(import (scheme base) (chibi net))
+
+(define (get-udp-address-info host service)
+  (let ((hints (make-address-info address-family/inet
+                                  socket-type/datagram
+                                  ip-proto/udp)))
+    (get-address-info host service hints)))
+
+;; create and bind a udp socket
+(let* ((addr (get-udp-address-info #f 5556))
+       (sock (socket (address-info-family addr)
+                     (address-info-socket-type addr)
+                     (address-info-protocol addr))))
+  (bind sock (address-info-address addr) (address-info-address-length addr))
+  ;; for every packet we receive, just send it back
+  (let lp ()
+    (cond
+     ((receive sock 512 0 addr)
+      => (lambda (bv) (send sock bv 0 addr))))
+    (lp)))
diff --git a/examples/echo-server.scm b/examples/echo-server.scm
new file mode 100755
index 00000000..eb3c9a6d
--- /dev/null
+++ b/examples/echo-server.scm
@@ -0,0 +1,26 @@
+#!/usr/bin/env chibi-scheme
+
+;; Simple R7RS echo server, using the run-net-server utility from
+;; (chibi net server).
+
+(import (scheme base) (scheme write) (chibi net) (chibi net server))
+
+;; Copy each input line to output.
+(define (echo-handler in out sock addr)
+  (let ((line (read-line in)))
+    (cond
+     ((not (or (eof-object? line) (equal? line "")))
+      ;; log the request to stdout
+      (display "read: ") (write line)
+      (display " from ")
+      (display (sockaddr-name (address-info-address addr)))
+      (display ":") (write (sockaddr-port (address-info-address addr)))
+      (newline)
+      ;; write and flush the response
+      (display line out)
+      (newline out)
+      (flush-output-port out)
+      (echo-handler in out sock addr)))))
+
+;; Start the server on *:5556 dispatching clients to echo-handler.
+(run-net-server 5556 echo-handler)
diff --git a/examples/repl-server.scm b/examples/repl-server.scm
new file mode 100644
index 00000000..eaa9ab44
--- /dev/null
+++ b/examples/repl-server.scm
@@ -0,0 +1,26 @@
+#!/usr/bin/env chibi-scheme
+
+(import (scheme base) (scheme read) (scheme write) (scheme eval)
+        (chibi net) (chibi net server))
+
+(define (repl-handler in out sock addr)
+  (let ((env (environment '(scheme base)
+                          '(only (chibi) import))))
+    (let lp ()
+      (let ((expr (read in)))
+        (cond
+         ((not (eof-object? expr))
+          (let ((result (guard (exn (else
+                                     (display "ERROR: " out)
+                                     (write exn out)
+                                     (newline out)
+                                     (if #f #f)))
+                          (eval expr env))))
+            (cond
+             ((not (eq? result (if #f #f)))
+              (write result out)
+              (newline out)))
+            (flush-output-port out)
+            (lp))))))))
+
+(run-net-server 5556 repl-handler)
diff --git a/fedora.spec b/fedora.spec
new file mode 100644
index 00000000..e9beb325
--- /dev/null
+++ b/fedora.spec
@@ -0,0 +1,59 @@
+Summary:                 A small-footprint Scheme for use as a C Extension Language
+Name:                    chibi-scheme
+Version:                 0.4
+Release:                 1%{?dist}
+
+
+Source0:                 http://chibi-scheme.googlecode.com/files/chibi-scheme-0.4.tgz
+Patch1:                  chibi-scheme.Makefile.patch
+Group:                   Development/Tools
+License:                 BSD
+URL:                     http://code.google.com/p/chibi-scheme/
+BuildRoot:               %{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n)
+# BuildRequires:
+
+
+%description
+Chibi-Scheme is a very small library intended for use as an extension
+and scripting language in C programs.  In addition to support for
+lightweight VM-based threads, each VM itself runs in an isolated heap
+allowing multiple VMs to run simultaneously in different OS threads.
+
+%prep
+%setup -q -n %{name}-%{version}
+%patch1
+
+%build
+%{__make} PREFIX=%{_prefix} DESTDIR=%{RPM_BUILD_ROOT}  LIBDIR=%{_libdir} SOLIBDIR=%{_libdir} MODDIR=%{_datarootdir}/chibi-scheme doc all
+
+%install
+rm -rf $RPM_BUILD_ROOT
+
+mkdir -p ${RPM_BUILD_ROOT}
+%{__make} PREFIX=%{_prefix} DESTDIR=${RPM_BUILD_ROOT} LIBDIR=%{_libdir} SOLIBDIR=%{_libdir} LDFLAGS="-C ${RPM_BUILD_ROOT}%{_sysconfdir}/ld.so.conf.d" MODDIR=%{_datarootdir}/chibi-scheme  install
+
+%clean
+rm -rf $RPM_BUILD_ROOT
+
+%files
+%defattr(-,root,root,-)
+%{_bindir}/chibi-scheme
+%{_datarootdir}/chibi-scheme
+%{_datarootdir}/man
+%{_libdir}/libchibi-scheme.so
+
+
+%package devel
+Summary:                 Development files for the %{name} package.
+%description devel
+This package contains development and include
+files for %{name} package.
+
+%files devel
+%defattr(-,root,root,-)
+%{_includedir}
+
+%changelog
+* Sat May 28 2011 Alex Shinn <alexshinn[AT]gmail.com> - 0.4
+* Wed Apr 22 2011 Rajesh Krishnan <devel[AT]krishnan.cc> - 0.3
+- Initial release
diff --git a/gc.c b/gc.c
new file mode 100644
index 00000000..5f8cf0fc
--- /dev/null
+++ b/gc.c
@@ -0,0 +1,742 @@
+/*  gc.c -- simple mark&sweep garbage collector               */
+/*  Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#if ! SEXP_USE_BOEHM && ! SEXP_USE_MALLOC
+
+#include "chibi/sexp.h"
+
+#if SEXP_USE_MMAP_GC
+#include <sys/mman.h>
+#endif
+
+#ifdef __APPLE__
+#define SEXP_RTLD_DEFAULT RTLD_SELF
+#else
+#define SEXP_RTLD_DEFAULT RTLD_DEFAULT
+#endif
+
+#define SEXP_BANNER(x) ("**************** GC "x"\n")
+
+#define SEXP_MINIMUM_OBJECT_SIZE (sexp_heap_align(1))
+
+#if SEXP_USE_GLOBAL_HEAP
+sexp_heap sexp_global_heap;
+#endif
+
+#if SEXP_USE_CONSERVATIVE_GC
+static sexp* stack_base;
+#endif
+
+#if SEXP_USE_DEBUG_GC
+#define sexp_debug_printf(fmt, ...) fprintf(stderr, SEXP_BANNER(fmt),__VA_ARGS__)
+#else
+#define sexp_debug_printf(fmt, ...)
+#endif
+
+static sexp_heap sexp_heap_last (sexp_heap h) {
+  while (h->next) h = h->next;
+  return h;
+}
+
+static size_t sexp_heap_total_size (sexp_heap h) {
+  size_t total_size = 0;
+  for (; h; h=h->next)
+    total_size += h->size;
+  return total_size;
+}
+
+#if ! SEXP_USE_GLOBAL_HEAP
+void sexp_free_heap (sexp_heap heap) {
+#if SEXP_USE_MMAP_GC
+  munmap(heap, sexp_heap_pad_size(heap->size));
+#else
+  free(heap);
+#endif
+}
+#endif
+
+#if SEXP_USE_LIMITED_MALLOC
+static sexp_sint_t allocated_bytes=0, max_allocated_bytes=-1;
+void* sexp_malloc(size_t size) {
+  char* max_alloc;
+  void* res;
+  if (max_allocated_bytes < 0) {
+    max_alloc = getenv("CHIBI_MAX_ALLOC");
+    max_allocated_bytes = max_alloc ? atoi(max_alloc) : 8192000; /* 8MB */
+  }
+  if (max_allocated_bytes > 0 && allocated_bytes + size > max_allocated_bytes)
+    return NULL;
+  if (!(res = malloc(size))) return NULL;
+  allocated_bytes += size;
+  return res;
+}
+/* TODO: subtract freed memory from max_allocated_bytes */
+void sexp_free(void* ptr) {
+  free(ptr);
+}
+#endif
+
+void sexp_preserve_object(sexp ctx, sexp x) {
+  sexp_global(ctx, SEXP_G_PRESERVATIVES) = sexp_cons(ctx, x, sexp_global(ctx, SEXP_G_PRESERVATIVES));
+}
+
+void sexp_release_object(sexp ctx, sexp x) {
+  sexp ls1, ls2;
+  for (ls1=NULL, ls2=sexp_global(ctx, SEXP_G_PRESERVATIVES); sexp_pairp(ls2);
+       ls1=ls2, ls2=sexp_cdr(ls2))
+    if (sexp_car(ls2) == x) {
+      if (ls1) sexp_cdr(ls1) = sexp_cdr(ls2);
+      else sexp_global(ctx, SEXP_G_PRESERVATIVES) = sexp_cdr(ls2);
+      break;
+    }
+}
+
+sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) {
+  sexp_uint_t res;
+  sexp t;
+  if (!sexp_pointerp(x) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx)))
+    return sexp_heap_align(1);
+  t = sexp_object_type(ctx, x);
+  res = sexp_type_size_of_object(t, x) + SEXP_GC_PAD;
+#if SEXP_USE_DEBUG_GC
+  if (res == 0) {
+    fprintf(stderr, SEXP_BANNER("%p zero-size object: %p"), ctx, x);
+    return 1;
+  }
+#endif
+  return res;
+}
+
+#if SEXP_USE_SAFE_GC_MARK
+
+#if SEXP_USE_DEBUG_GC > 2
+int sexp_valid_heap_position(sexp ctx, sexp_heap h, sexp x) {
+  sexp p = sexp_heap_first_block(h), end = sexp_heap_end(h);
+  sexp_free_list q = h->free_list, r;
+  while (p < end) {
+    for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
+      ;
+    if ((char*)r == (char*)p) {
+      p = (sexp) (((char*)p) + r->size);
+      continue;
+    }
+    if (p == x) {
+      return 1;
+    } else if (p > x) {
+      fprintf(stderr, SEXP_BANNER("bad heap position: %p free: %p-%p : %p-%p"),
+              x, q, ((char*)q)+q->size, r, ((char*)r)+r->size);
+      return 0;
+    }
+    p = (sexp) (((char*)p)+sexp_heap_align(sexp_allocated_bytes(ctx, p)));
+  }
+  fprintf(stderr, SEXP_BANNER("bad heap position: %p heap: %p-%p"), x, h, end);
+  return 0;
+}
+#else
+#define sexp_valid_heap_position(ctx, h, x) 1
+#endif
+
+int sexp_in_heap_p(sexp ctx, sexp x) {
+  sexp_heap h;
+  if ((sexp_uint_t)x & (sexp_heap_align(1)-1)) {
+    fprintf(stderr, SEXP_BANNER("invalid heap alignment: %p"), x);
+    return 0;
+  }
+  for (h=sexp_context_heap(ctx); h; h=h->next)
+    if (((sexp)h < x) && (x < (sexp)(h->data + h->size)))
+      return sexp_valid_heap_position(ctx, h, x);
+  fprintf(stderr, SEXP_BANNER("invalid object outside heap: %p"), x);
+  return 0;
+}
+#endif
+
+#if SEXP_USE_DEBUG_GC > 1
+int sexp_valid_object_type_p (sexp ctx, sexp x) {
+  if (sexp_pointer_tag(x)<=0 || sexp_pointer_tag(x)>sexp_context_num_types(ctx)){
+    fprintf(stderr, SEXP_BANNER("%p mark: bad object at %p: tag: %d"),
+            ctx, x, sexp_pointer_tag(x));
+    return 0;
+  }
+  return 1;
+}
+#else
+#define sexp_valid_object_type_p(ctx, x) 1
+#endif
+
+#if SEXP_USE_HEADER_MAGIC
+int sexp_valid_header_magic_p (sexp ctx, sexp x) {
+  if (sexp_pointer_magic(x)  != SEXP_POINTER_MAGIC
+      && sexp_pointer_tag(x) != SEXP_TYPE && sexp_pointer_tag(x) != SEXP_OPCODE
+      && sexp_pointer_tag(x) != SEXP_CORE && sexp_pointer_tag(x) != SEXP_STACK) {
+    fprintf(stderr, SEXP_BANNER("%p mark: bad magic at %p: %x"),
+            ctx, x, sexp_pointer_magic(x));
+    return 0;
+  }
+  return 1;
+}
+#else
+#define sexp_valid_header_magic_p(ctx, x) 1
+#endif
+
+#if SEXP_DEBUG_GC > 1 || SEXP_USE_SAFE_GC_MARK || SEXP_USE_HEADER_MAGIC
+int sexp_valid_object_p (sexp ctx, sexp x) {
+  return sexp_in_heap_p(ctx, x) && sexp_valid_object_type_p(ctx, x)
+    && sexp_valid_header_magic_p(ctx, x);
+}
+#endif
+
+void sexp_mark (sexp ctx, sexp x) {
+  sexp_sint_t len;
+  sexp t, *p, *q;
+  struct sexp_gc_var_t *saves;
+ loop:
+  if (!x || !sexp_pointerp(x) || !sexp_valid_object_p(ctx, x) || sexp_markedp(x))
+    return;
+  sexp_markedp(x) = 1;
+  if (sexp_contextp(x)) {
+    for (saves=sexp_context_saves(x); saves; saves=saves->next)
+      if (saves->var) sexp_mark(ctx, *(saves->var));
+  }
+  t = sexp_object_type(ctx, x);
+  len = sexp_type_num_slots_of_object(t, x) - 1;
+  if (len >= 0) {
+    p = (sexp*) (((char*)x) + sexp_type_field_base(t));
+    q = p + len;
+    while (p < q && ! (*q && sexp_pointerp(*q)))
+      q--;                      /* skip trailing immediates */
+    while (p < q && *q == q[-1])
+      q--;                      /* skip trailing duplicates */
+    while (p < q)
+      sexp_mark(ctx, *p++);
+    x = *p;
+    goto loop;
+  }
+}
+
+#if SEXP_USE_CONSERVATIVE_GC
+
+int stack_references_pointer_p (sexp ctx, sexp x) {
+  sexp *p;
+  for (p=(&x)+1; p<stack_base; p++)
+    if (*p == x)
+      return 1;
+  return 0;
+}
+
+#if SEXP_USE_TRACK_ALLOC_BACKTRACE
+void sexp_print_gc_trace(sexp ctx, sexp p) {
+  int i;
+  char **debug_text = backtrace_symbols(p->backtrace, SEXP_BACKTRACE_SIZE);
+  for (i=0; i < SEXP_BACKTRACE_SIZE; i++)
+    fprintf(stderr, SEXP_BANNER("    : %s"), debug_text[i]);
+  free(debug_text);
+}
+#else
+#define sexp_print_gc_trace(ctx, p)
+#endif
+
+void sexp_conservative_mark (sexp ctx) {
+  sexp_heap h = sexp_context_heap(ctx);
+  sexp p, end;
+  sexp_free_list q, r;
+  for ( ; h; h=h->next) {   /* just scan the whole heap */
+    p = sexp_heap_first_block(h);
+    q = h->free_list;
+    end = sexp_heap_end(h);
+    while (p < end) {
+      for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
+        ;
+      if ((char*)r == (char*)p) {
+        p = (sexp) (((char*)p) + r->size);
+        continue;
+      }
+      if (!sexp_markedp(p) && stack_references_pointer_p(ctx, p)) {
+#ifdef SEXP_USE_CONSERVATIVE_GC_PRESERVE_TAG
+        if (sexp_pointer_tag(p) == SEXP_USE_CONSERVATIVE_GC_PRESERVE_TAG)
+#endif
+        if (1) {
+#if SEXP_USE_DEBUG_GC > 3
+          if (p && sexp_pointerp(p)) {
+            fprintf(stderr, SEXP_BANNER("MISS: %p [%d]: %s"), p,
+                    sexp_pointer_tag(p), sexp_pointer_source(p));
+            sexp_print_gc_trace(ctx, p);
+            fflush(stderr);
+          }
+#endif
+          sexp_mark(ctx, p);
+        }
+      }
+      p = (sexp) (((char*)p)+sexp_heap_align(sexp_allocated_bytes(ctx, p)));
+    }
+  }
+}
+
+#else
+#define sexp_conservative_mark(ctx)
+#endif
+
+#if SEXP_USE_WEAK_REFERENCES
+void sexp_reset_weak_references(sexp ctx) {
+  int i, len, all_reset_p;
+  sexp_heap h = sexp_context_heap(ctx);
+  sexp p, t, end, *v;
+  sexp_free_list q, r;
+  for ( ; h; h=h->next) {   /* just scan the whole heap */
+    p = sexp_heap_first_block(h);
+    q = h->free_list;
+    end = sexp_heap_end(h);
+    while (p < end) {
+      /* find the preceding and succeeding free list pointers */
+      for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
+        ;
+      if ((char*)r == (char*)p) { /* this is a free block, skip it */
+        p = (sexp) (((char*)p) + r->size);
+        continue;
+      }
+      if (sexp_valid_object_p(ctx, p) && sexp_markedp(p)) {
+        t = sexp_object_type(ctx, p);
+        if (sexp_type_weak_base(t) > 0) {
+          all_reset_p = 1;
+          v = (sexp*) ((char*)p + sexp_type_weak_base(t));
+          len = sexp_type_num_weak_slots_of_object(t, p);
+          for (i=0; i<len; i++) {
+            if (v[i] && sexp_pointerp(v[i]) && ! sexp_markedp(v[i])) {
+              v[i] = SEXP_FALSE;
+              sexp_brokenp(p) = 1;
+            } else {
+              all_reset_p = 0;
+            }
+          }
+          if (all_reset_p) {      /* ephemerons */
+            len += sexp_type_weak_len_extra(t);
+            for ( ; i<len; i++) v[i] = SEXP_FALSE;
+          }
+        }
+      }
+      p = (sexp) (((char*)p)+sexp_heap_align(sexp_allocated_bytes(ctx, p)));
+    }
+  }
+}
+#else
+#define sexp_reset_weak_references(ctx)
+#endif
+
+sexp sexp_finalize (sexp ctx) {
+  size_t size;
+  sexp p, t, end;
+  sexp_free_list q, r;
+  sexp_proc2 finalizer;
+  sexp_sint_t finalize_count = 0;
+  sexp_heap h = sexp_context_heap(ctx);
+#if SEXP_USE_DL
+  sexp_sint_t free_dls = 0, pass = 0;
+ loop:
+#endif
+  /* scan over the whole heap */
+  for ( ; h; h=h->next) {
+    p = sexp_heap_first_block(h);
+    q = h->free_list;
+    end = sexp_heap_end(h);
+    while (p < end) {
+      /* find the preceding and succeeding free list pointers */
+      for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
+        ;
+      if ((char*)r == (char*)p) { /* this is a free block, skip it */
+        p = (sexp) (((char*)p) + r->size);
+        continue;
+      }
+      size = sexp_heap_align(sexp_allocated_bytes(ctx, p));
+      if (!sexp_markedp(p)) {
+        t = sexp_object_type(ctx, p);
+        finalizer = sexp_type_finalize(t);
+        if (finalizer) {
+          finalize_count++;
+#if SEXP_USE_DL
+          if (sexp_type_tag(t) == SEXP_DL && pass <= 0)
+            free_dls = 1;
+          else
+#endif
+            finalizer(ctx, NULL, 1, p);
+        }
+      }
+      p = (sexp) (((char*)p)+size);
+    }
+  }
+#if SEXP_USE_DL
+  if (free_dls && pass++ <= 0) goto loop;
+#endif
+  return sexp_make_fixnum(finalize_count);
+}
+
+sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) {
+  size_t freed, max_freed=0, sum_freed=0, size;
+  sexp_heap h = sexp_context_heap(ctx);
+  sexp p, end;
+  sexp_free_list q, r, s;
+  /* scan over the whole heap */
+  for ( ; h; h=h->next) {
+    p = sexp_heap_first_block(h);
+    q = h->free_list;
+    end = sexp_heap_end(h);
+    while (p < end) {
+      /* find the preceding and succeeding free list pointers */
+      for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
+        ;
+      if ((char*)r == (char*)p) { /* this is a free block, skip it */
+        p = (sexp) (((char*)p) + r->size);
+        continue;
+      }
+      size = sexp_heap_align(sexp_allocated_bytes(ctx, p));
+#if SEXP_USE_DEBUG_GC
+      if (!sexp_valid_object_p(ctx, p))
+        fprintf(stderr, SEXP_BANNER("%p sweep: invalid object at %p"), ctx, p);
+      if ((char*)q + q->size > (char*)p)
+        fprintf(stderr, SEXP_BANNER("%p sweep: bad size at %p < %p + %lu"),
+                ctx, p, q, q->size);
+      if (r && ((char*)p)+size > (char*)r)
+        fprintf(stderr, SEXP_BANNER("%p sweep: bad size at %p + %lu > %p"),
+                ctx, p, size, r);
+#endif
+      if (!sexp_markedp(p)) {
+        /* free p */
+        sum_freed += size;
+        if (((((char*)q) + q->size) == (char*)p) && (q != h->free_list)) {
+          /* merge q with p */
+          if (r && r->size && ((((char*)p)+size) == (char*)r)) {
+            /* ... and with r */
+            q->next = r->next;
+            freed = q->size + size + r->size;
+            p = (sexp) (((char*)p) + size + r->size);
+          } else {
+            freed = q->size + size;
+            p = (sexp) (((char*)p)+size);
+          }
+          q->size = freed;
+        } else {
+          s = (sexp_free_list)p;
+          if (r && r->size && ((((char*)p)+size) == (char*)r)) {
+            /* merge p with r */
+            s->size = size + r->size;
+            s->next = r->next;
+            q->next = s;
+            freed = size + r->size;
+          } else {
+            s->size = size;
+            s->next = r;
+            q->next = s;
+            freed = size;
+          }
+          p = (sexp) (((char*)p)+freed);
+        }
+        if (freed > max_freed)
+          max_freed = freed;
+      } else {
+        sexp_markedp(p) = 0;
+        p = (sexp) (((char*)p)+size);
+      }
+    }
+  }
+  if (sum_freed_ptr) *sum_freed_ptr = sum_freed;
+  return sexp_make_fixnum(max_freed);
+}
+
+#if SEXP_USE_GLOBAL_SYMBOLS
+void sexp_mark_global_symbols(sexp ctx) {
+  int i;
+  for (i=0; i<SEXP_SYMBOL_TABLE_SIZE; i++)
+    sexp_mark(ctx, sexp_symbol_table[i]);
+}
+#else
+#define sexp_mark_global_symbols(ctx)
+#endif
+
+sexp sexp_gc (sexp ctx, size_t *sum_freed) {
+  sexp res, finalized SEXP_NO_WARN_UNUSED;
+  sexp_debug_printf("%p (heap: %p size: %lu)", ctx, sexp_context_heap(ctx),
+                    sexp_heap_total_size(sexp_context_heap(ctx)));
+  sexp_mark_global_symbols(ctx);
+  sexp_mark(ctx, ctx);
+  sexp_conservative_mark(ctx);
+  sexp_reset_weak_references(ctx);
+  finalized = sexp_finalize(ctx);
+  res = sexp_sweep(ctx, sum_freed);
+  sexp_debug_printf("%p (freed: %lu max_freed: %lu finalized: %lu)", ctx,
+                    (sum_freed ? *sum_freed : 0), sexp_unbox_fixnum(res),
+                    sexp_unbox_fixnum(finalized));
+  return res;
+}
+
+sexp_heap sexp_make_heap (size_t size, size_t max_size) {
+  sexp_free_list free, next;
+  sexp_heap h;
+#if SEXP_USE_MMAP_GC
+  h =  mmap(NULL, sexp_heap_pad_size(size), PROT_READ|PROT_WRITE|PROT_EXEC,
+            MAP_ANON|MAP_PRIVATE, 0, 0);
+#else
+  h =  sexp_malloc(sexp_heap_pad_size(size));
+#endif
+  if (! h) return NULL;
+  h->size = size;
+  h->max_size = max_size;
+  h->data = (char*) sexp_heap_align(sizeof(h->data)+(sexp_uint_t)&(h->data));
+  free = h->free_list = (sexp_free_list) h->data;
+  h->next = NULL;
+  next = (sexp_free_list) (((char*)free)+sexp_heap_align(sexp_free_chunk_size));
+  free->size = 0; /* actually sexp_heap_align(sexp_free_chunk_size) */
+  free->next = next;
+  next->size = size - sexp_heap_align(sexp_free_chunk_size);
+  next->next = NULL;
+#if SEXP_USE_DEBUG_GC
+  fprintf(stderr, SEXP_BANNER("heap: %p-%p data: %p-%p"),
+          h, ((char*)h)+sexp_heap_pad_size(size), h->data, h->data + size);
+  fprintf(stderr, SEXP_BANNER("first: %p end: %p"),
+          sexp_heap_first_block(h), sexp_heap_end(h));
+  fprintf(stderr, SEXP_BANNER("free1: %p-%p free2: %p-%p"),
+          free, ((char*)free)+free->size, next, ((char*)next)+next->size);
+#endif
+  return h;
+}
+
+int sexp_grow_heap (sexp ctx, size_t size) {
+  size_t cur_size, new_size;
+  sexp_heap h = sexp_heap_last(sexp_context_heap(ctx));
+  cur_size = h->size;
+  new_size = sexp_heap_align(((cur_size > size) ? cur_size : size) * 2);
+  h->next = sexp_make_heap(new_size, h->max_size);
+  return (h->next != NULL);
+}
+
+void* sexp_try_alloc (sexp ctx, size_t size) {
+  sexp_free_list ls1, ls2, ls3;
+  sexp_heap h;
+  for (h=sexp_context_heap(ctx); h; h=h->next)
+    for (ls1=h->free_list, ls2=ls1->next; ls2; ls1=ls2, ls2=ls2->next)
+      if (ls2->size >= size) {
+#if SEXP_USE_DEBUG_GC
+        ls3 = (sexp_free_list) sexp_heap_end(h);
+        if (ls2 >= ls3)
+          fprintf(stderr, "alloced %lu bytes past end of heap: %p (%lu) >= %p"
+                  " next: %p (%lu)\n", size, ls2, ls2->size, ls3, ls2->next,
+                  (ls2->next ? ls2->next->size : 0));
+#endif
+        if (ls2->size >= (size + SEXP_MINIMUM_OBJECT_SIZE)) {
+          ls3 = (sexp_free_list) (((char*)ls2)+size); /* the tail after ls2 */
+          ls3->size = ls2->size - size;
+          ls3->next = ls2->next;
+          ls1->next = ls3;
+        } else {                  /* take the whole chunk */
+          ls1->next = ls2->next;
+        }
+        memset((void*)ls2, 0, size);
+        return ls2;
+      }
+  return NULL;
+}
+
+void* sexp_alloc (sexp ctx, size_t size) {
+  void *res;
+  size_t max_freed, sum_freed, total_size;
+  sexp_heap h = sexp_context_heap(ctx);
+  size = sexp_heap_align(size) + SEXP_GC_PAD;
+  res = sexp_try_alloc(ctx, size);
+  if (! res) {
+    max_freed = sexp_unbox_fixnum(sexp_gc(ctx, &sum_freed));
+    total_size = sexp_heap_total_size(sexp_context_heap(ctx));
+    if (((max_freed < size)
+         || ((total_size > sum_freed)
+             && (total_size - sum_freed) > (total_size*SEXP_GROW_HEAP_RATIO)))
+        && ((!h->max_size) || (total_size < h->max_size)))
+      sexp_grow_heap(ctx, size);
+    res = sexp_try_alloc(ctx, size);
+    if (! res) {
+      res = sexp_global(ctx, SEXP_G_OOM_ERROR);
+      sexp_debug_printf("ran out of memory allocating %lu bytes => %p", size, res);
+    }
+  }
+  return res;
+}
+
+#if ! SEXP_USE_GLOBAL_HEAP
+
+void sexp_offset_heap_pointers (sexp_heap heap, sexp_heap from_heap, sexp* types, sexp flags) {
+  sexp_sint_t i, off, len, freep, loadp;
+  sexp_free_list q;
+  sexp p, t, end, *v;
+#if SEXP_USE_DL
+  sexp name;
+#endif
+  freep = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_FREEP);
+  loadp = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_LOADP);
+
+  off = (sexp_sint_t)((sexp_sint_t)heap - (sexp_sint_t)from_heap);
+  heap->data += off;
+  end = (sexp) (heap->data + heap->size);
+
+  /* adjust the free list */
+  heap->free_list = (sexp_free_list) ((char*)heap->free_list + off);
+  for (q=heap->free_list; q->next; q=q->next)
+    q->next = (sexp_free_list) ((char*)q->next + off);
+
+  /* adjust data by traversing over the new heap */
+  p = (sexp) (heap->data + sexp_heap_align(sexp_free_chunk_size));
+  q = heap->free_list;
+  while (p < end) {
+    /* find the next free list pointer */
+    for ( ; q && ((char*)q < (char*)p); q=q->next)
+      ;
+    if ((char*)q == (char*)p) { /* this is a free block, skip it */
+      p = (sexp) (((char*)p) + q->size);
+    } else {
+      t = (sexp)((char*)(types[sexp_pointer_tag(p)])
+                 + ((char*)types > (char*)p ? off : 0));
+      len = sexp_type_num_slots_of_object(t, p);
+      v = (sexp*) ((char*)p + sexp_type_field_base(t));
+      /* offset any pointers in the _destination_ heap */
+      for (i=0; i<len; i++)
+        if (v[i] && sexp_pointerp(v[i]))
+          v[i] = (sexp) ((char*)v[i] + off);
+      /* don't free unless specified - only the original cleans up */
+      if (! freep)
+        sexp_freep(p) = 0;
+      /* adjust context heaps, don't copy saved sexp_gc_vars */
+      if (sexp_contextp(p)) {
+#if SEXP_USE_GREEN_THREADS
+        sexp_context_ip(p) += off;
+#endif
+        sexp_context_last_fp(p) += off;
+        sexp_stack_top(sexp_context_stack(p)) = 0;
+        sexp_context_saves(p) = NULL;
+        sexp_context_heap(p) = heap;
+      } else if (sexp_bytecodep(p) && off != 0) {
+        for (i=0; i<sexp_bytecode_length(p); ) {
+          switch (sexp_bytecode_data(p)[i++]) {
+            case SEXP_OP_FCALL0:      case SEXP_OP_FCALL1:
+            case SEXP_OP_FCALL2:      case SEXP_OP_FCALL3:
+            case SEXP_OP_FCALL4:      case SEXP_OP_CALL:
+            case SEXP_OP_TAIL_CALL:   case SEXP_OP_PUSH:
+            case SEXP_OP_GLOBAL_REF:  case SEXP_OP_GLOBAL_KNOWN_REF:
+#if SEXP_USE_GREEN_THREADS
+            case SEXP_OP_PARAMETER_REF:
+#endif
+#if SEXP_USE_EXTENDED_FCALL
+            case SEXP_OP_FCALLN:
+#endif
+              v = (sexp*)(&(sexp_bytecode_data(p)[i]));
+              if (v[0] && sexp_pointerp(v[0])) v[0] = (sexp) (((char*)v[0]) + off);
+              /* ... FALLTHROUGH ... */
+            case SEXP_OP_JUMP:        case SEXP_OP_JUMP_UNLESS:
+            case SEXP_OP_STACK_REF:   case SEXP_OP_CLOSURE_REF:
+            case SEXP_OP_LOCAL_REF:   case SEXP_OP_LOCAL_SET:
+            case SEXP_OP_TYPEP:
+#if SEXP_USE_RESERVE_OPCODE
+            case SEXP_OP_RESERVE:
+#endif
+              i += sizeof(sexp); break;
+            case SEXP_OP_MAKE: case SEXP_OP_SLOT_REF: case SEXP_OP_SLOT_SET:
+              i += 2*sizeof(sexp); break;
+            case SEXP_OP_MAKE_PROCEDURE:
+              v = (sexp*)(&(sexp_bytecode_data(p)[i]));
+              if (v[2] && sexp_pointerp(v[2])) v[2] = (sexp) (((char*)v[2]) + off);
+              i += 3*sizeof(sexp); break;
+          }
+        }
+      } else if (sexp_portp(p) && sexp_port_stream(p)) {
+        sexp_port_stream(p) = 0;
+        sexp_port_openp(p) = 0;
+        sexp_freep(p) = 0;
+#if SEXP_USE_DL
+      } else if (loadp && sexp_dlp(p)) {
+        sexp_dl_handle(p) = NULL;
+#endif
+      }
+      p = (sexp) (((char*)p)+sexp_heap_align(sexp_type_size_of_object(t, p))+SEXP_GC_PAD);
+    }
+  }
+
+  /* make a second pass to fix code references */
+  if (loadp) {
+    p = (sexp) (heap->data + sexp_heap_align(sexp_free_chunk_size));
+    q = heap->free_list;
+    while (p < end) {
+      /* find the next free list pointer */
+      for ( ; q && ((char*)q < (char*)p); q=q->next)
+        ;
+      if ((char*)q == (char*)p) { /* this is a free block, skip it */
+        p = (sexp) (((char*)p) + q->size);
+      } else {
+#if SEXP_USE_DL
+        if (sexp_opcodep(p) && sexp_opcode_func(p)) {
+          name = (sexp_opcode_data2(p) && sexp_stringp(sexp_opcode_data2(p))) ? sexp_opcode_data2(p) : sexp_opcode_name(p);
+          if (sexp_dlp(sexp_opcode_dl(p))) {
+            if (!sexp_dl_handle(sexp_opcode_dl(p)))
+              sexp_dl_handle(sexp_opcode_dl(p)) = dlopen(sexp_string_data(sexp_dl_file(sexp_opcode_dl(p))), RTLD_LAZY);
+            sexp_opcode_func(p) = dlsym(sexp_dl_handle(sexp_opcode_dl(p)), sexp_string_data(name));
+          } else {
+            sexp_opcode_func(p) = dlsym(SEXP_RTLD_DEFAULT, sexp_string_data(name));
+          }
+        } else
+#endif
+        if (sexp_typep(p)) {
+          if (sexp_type_finalize(p)) {
+            /* TODO: handle arbitrary finalizers in images */
+#if SEXP_USE_DL
+            if (sexp_type_tag(p) == SEXP_DL)
+              sexp_type_finalize(p) = SEXP_FINALIZE_DL;
+            else
+#endif
+              sexp_type_finalize(p) = SEXP_FINALIZE_PORT;
+          }
+        }
+        t = types[sexp_pointer_tag(p)];
+        p = (sexp) (((char*)p)+sexp_heap_align(sexp_type_size_of_object(t, p)+SEXP_GC_PAD));
+      }
+    }
+  }
+}
+
+sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) {
+  sexp_sint_t off;
+  sexp_heap to, from = sexp_context_heap(ctx);
+
+  /* validate input, creating a new heap if needed */
+  if (from->next) {
+    return sexp_user_exception(ctx, NULL, "can't copy a non-contiguous heap", ctx);
+  } else if (! dst || sexp_not(dst)) {
+    to = sexp_make_heap(from->size, from->max_size);
+    if (!to) return sexp_global(ctx, SEXP_G_OOM_ERROR);
+    dst = (sexp) ((char*)ctx + ((char*)to - (char*)from));
+  } else if (! sexp_contextp(dst)) {
+    return sexp_type_exception(ctx, NULL, SEXP_CONTEXT, dst);
+  } else if (sexp_context_heap(dst)->size < from->size) {
+    return sexp_user_exception(ctx, NULL, "destination context too small", dst);
+  } else {
+    to = sexp_context_heap(dst);
+  }
+
+  /* copy the raw data */
+  off = (char*)to - (char*)from;
+  memcpy(to, from, sexp_heap_pad_size(from->size));
+
+  /* adjust the pointers */
+  sexp_offset_heap_pointers(to, from, sexp_context_types(ctx) + off, flags);
+
+  return dst;
+}
+
+#endif
+
+void sexp_gc_init (void) {
+#if SEXP_USE_GLOBAL_HEAP || SEXP_USE_CONSERVATIVE_GC
+  sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE);
+#endif
+#if SEXP_USE_GLOBAL_HEAP
+  sexp_global_heap = sexp_make_heap(size, SEXP_MAXIMUM_HEAP_SIZE);
+#endif
+#if SEXP_USE_CONSERVATIVE_GC
+  /* the +32 is a hack, but this is just for debugging anyway */
+  stack_base = ((sexp*)&size) + 32;
+#endif
+}
+
+#endif
diff --git a/include/chibi/bignum.h b/include/chibi/bignum.h
new file mode 100644
index 00000000..1c8402c6
--- /dev/null
+++ b/include/chibi/bignum.h
@@ -0,0 +1,72 @@
+/*  bignum.h -- header for bignum utilities                   */
+/*  Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#ifndef SEXP_BIGNUM_H
+#define SEXP_BIGNUM_H
+
+#include "chibi/eval.h"
+
+#if (SEXP_64_BIT) && defined(__GNUC__)
+typedef unsigned int uint128_t __attribute__((mode(TI)));
+typedef int sint128_t __attribute__((mode(TI)));
+typedef uint128_t sexp_luint_t;
+typedef sint128_t sexp_lsint_t;
+#else
+typedef unsigned long long sexp_luint_t;
+typedef long long sexp_lsint_t;
+#endif
+
+SEXP_API sexp_sint_t sexp_bignum_compare (sexp a, sexp b);
+SEXP_API sexp sexp_compare (sexp ctx, sexp a, sexp b);
+SEXP_API sexp sexp_make_bignum (sexp ctx, sexp_uint_t len);
+SEXP_API sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len);
+SEXP_API sexp sexp_bignum_normalize (sexp a);
+SEXP_API sexp_uint_t sexp_bignum_hi (sexp a);
+SEXP_API sexp sexp_fixnum_to_bignum (sexp ctx, sexp a);
+SEXP_API double sexp_bignum_to_double (sexp a);
+SEXP_API sexp sexp_double_to_bignum (sexp ctx, double f);
+SEXP_API sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b);
+SEXP_API sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset);
+SEXP_API sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset);
+SEXP_API sexp sexp_bignum_add (sexp ctx, sexp dst, sexp a, sexp b);
+SEXP_API sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b);
+SEXP_API sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b);
+SEXP_API sexp sexp_bignum_div (sexp ctx, sexp dst, sexp a, sexp b);
+SEXP_API sexp sexp_bignum_expt (sexp ctx, sexp n, sexp e);
+SEXP_API sexp sexp_bignum_sqrt (sexp ctx, sexp a, sexp* rem);
+SEXP_API sexp sexp_add (sexp ctx, sexp a, sexp b);
+SEXP_API sexp sexp_sub (sexp ctx, sexp a, sexp b);
+SEXP_API sexp sexp_mul (sexp ctx, sexp a, sexp b);
+SEXP_API sexp sexp_div (sexp ctx, sexp a, sexp b);
+SEXP_API sexp sexp_quotient (sexp ctx, sexp a, sexp b);
+SEXP_API sexp sexp_remainder (sexp ctx, sexp a, sexp b);
+#if SEXP_USE_RATIOS
+SEXP_API sexp sexp_double_to_ratio (sexp ctx, double f);
+SEXP_API double sexp_ratio_to_double (sexp rat);
+SEXP_API sexp sexp_make_ratio (sexp ctx, sexp num, sexp den);
+SEXP_API sexp sexp_ratio_normalize (sexp ctx, sexp rat, sexp in);
+SEXP_API sexp sexp_ratio_round (sexp ctx, sexp a);
+SEXP_API sexp sexp_ratio_trunc (sexp ctx, sexp a);
+SEXP_API sexp sexp_ratio_floor (sexp ctx, sexp a);
+SEXP_API sexp sexp_ratio_ceiling (sexp ctx, sexp a);
+SEXP_API sexp sexp_ratio_compare (sexp ctx, sexp a, sexp b);
+#endif
+#if SEXP_USE_COMPLEX
+SEXP_API sexp sexp_make_complex (sexp ctx, sexp real, sexp image);
+SEXP_API sexp sexp_complex_normalize (sexp real);
+SEXP_API sexp sexp_complex_math_error (sexp ctx, sexp z);
+SEXP_API sexp sexp_complex_sqrt (sexp ctx, sexp z);
+SEXP_API sexp sexp_complex_exp (sexp ctx, sexp z);
+SEXP_API sexp sexp_complex_expt (sexp ctx, sexp a, sexp b);
+SEXP_API sexp sexp_complex_log (sexp ctx, sexp z);
+SEXP_API sexp sexp_complex_sin (sexp ctx, sexp z);
+SEXP_API sexp sexp_complex_cos (sexp ctx, sexp z);
+SEXP_API sexp sexp_complex_tan (sexp ctx, sexp z);
+SEXP_API sexp sexp_complex_asin (sexp ctx, sexp z);
+SEXP_API sexp sexp_complex_acos (sexp ctx, sexp z);
+SEXP_API sexp sexp_complex_atan (sexp ctx, sexp z);
+#endif
+
+#endif  /* ! SEXP_BIGNUM_H */
+
diff --git a/include/chibi/eval.h b/include/chibi/eval.h
new file mode 100644
index 00000000..e82f8fa2
--- /dev/null
+++ b/include/chibi/eval.h
@@ -0,0 +1,271 @@
+/*  eval.h -- headers for eval library                        */
+/*  Copyright (c) 2009-2011 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#ifndef SEXP_EVAL_H
+#define SEXP_EVAL_H
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#include "chibi/sexp.h"
+
+/************************* additional types ***************************/
+
+#define sexp_init_file "init-"
+#define sexp_init_file_suffix ".scm"
+#define sexp_meta_file "meta-7.scm"
+#define sexp_leap_seconds_file "leap.txt"
+
+enum sexp_core_form_names {
+  SEXP_CORE_DEFINE = 1,
+  SEXP_CORE_SET,
+  SEXP_CORE_LAMBDA,
+  SEXP_CORE_IF,
+  SEXP_CORE_BEGIN,
+  SEXP_CORE_QUOTE,
+  SEXP_CORE_SYNTAX_QUOTE,
+  SEXP_CORE_DEFINE_SYNTAX,
+  SEXP_CORE_LET_SYNTAX,
+  SEXP_CORE_LETREC_SYNTAX
+};
+
+enum sexp_opcode_classes {
+  SEXP_OPC_GENERIC = 1,
+  SEXP_OPC_TYPE_PREDICATE,
+  SEXP_OPC_PREDICATE,
+  SEXP_OPC_ARITHMETIC,
+  SEXP_OPC_ARITHMETIC_CMP,
+  SEXP_OPC_IO,
+  SEXP_OPC_CONSTRUCTOR,
+  SEXP_OPC_GETTER,
+  SEXP_OPC_SETTER,
+  SEXP_OPC_PARAMETER,
+  SEXP_OPC_FOREIGN,
+  SEXP_OPC_NUM_OP_CLASSES
+};
+
+SEXP_API struct sexp_opcode_struct* sexp_primitive_opcodes;
+
+#if SEXP_USE_DEBUG_VM || SEXP_USE_PROFILE_VM || SEXP_USE_STATIC_LIBS
+SEXP_API const char** sexp_opcode_names;
+#endif
+
+/**************************** prototypes ******************************/
+
+SEXP_API void sexp_warn (sexp ctx, const char *msg, sexp x);
+SEXP_API void sexp_scheme_init (void);
+SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env, sexp_uint_t size, sexp_uint_t max_size);
+SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda);
+SEXP_API sexp sexp_compile_error (sexp ctx, const char *message, sexp obj);
+SEXP_API sexp sexp_maybe_wrap_error (sexp ctx, sexp obj);
+SEXP_API sexp sexp_analyze (sexp context, sexp x);
+SEXP_API sexp sexp_simplify (sexp ctx, sexp self, sexp_sint_t n, sexp ast);
+SEXP_API sexp sexp_make_lambda (sexp ctx, sexp params);
+SEXP_API sexp sexp_make_ref (sexp ctx, sexp name, sexp cell);
+SEXP_API void sexp_generate (sexp ctx, sexp name, sexp loc, sexp lam, sexp x);
+SEXP_API void sexp_emit (sexp ctx, unsigned char c);
+SEXP_API void sexp_emit_return (sexp ctx);
+#if SEXP_USE_NATIVE_X86
+SEXP_API void sexp_emit_enter (sexp ctx);
+SEXP_API void sexp_bless_bytecode (sexp ctx, sexp bc);
+#else
+#define sexp_emit_enter(ctx)
+#define sexp_bless_bytecode(ctx, bc)
+#endif
+SEXP_API sexp sexp_complete_bytecode (sexp ctx);
+SEXP_API void sexp_shrink_bcode (sexp ctx, sexp_uint_t i);
+SEXP_API void sexp_expand_bcode (sexp ctx, sexp_uint_t size);
+SEXP_API void sexp_stack_trace (sexp ctx, sexp out);
+SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv);
+SEXP_API int sexp_param_index (sexp ctx, sexp lambda, sexp name);
+SEXP_API sexp sexp_compile_op (sexp context, sexp self, sexp_sint_t n, sexp obj, sexp env);
+SEXP_API sexp sexp_generate_op (sexp context, sexp self, sexp_sint_t n, sexp obj, sexp env);
+SEXP_API sexp sexp_eval_op (sexp context, sexp self, sexp_sint_t n, sexp obj, sexp env);
+SEXP_API sexp sexp_eval_string (sexp context, const char *str, sexp_sint_t len, sexp env);
+SEXP_API sexp sexp_load_op (sexp context, sexp self, sexp_sint_t n, sexp expr, sexp env);
+SEXP_API sexp sexp_exception_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn);
+SEXP_API sexp sexp_make_env_op (sexp context, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_make_null_env_op (sexp context, sexp self, sexp_sint_t n, sexp version);
+SEXP_API sexp sexp_env_cell_define (sexp ctx, sexp env, sexp name, sexp value, sexp* varenv);
+SEXP_API sexp sexp_make_primitive_env_op (sexp context, sexp self, sexp_sint_t n, sexp version);
+SEXP_API sexp sexp_make_standard_env_op (sexp context, sexp self, sexp_sint_t n, sexp version);
+SEXP_API void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value);
+SEXP_API sexp sexp_load_standard_ports (sexp context, sexp env, FILE* in, FILE* out, FILE* err, int no_close);
+SEXP_API sexp sexp_load_standard_env (sexp context, sexp env, sexp version);
+SEXP_API sexp sexp_find_module_file (sexp ctx, const char *file);
+SEXP_API sexp sexp_load_module_file (sexp ctx, const char *file, sexp env);
+SEXP_API sexp sexp_current_module_path_op (sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_find_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file);
+SEXP_API sexp sexp_load_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file, sexp env);
+SEXP_API sexp sexp_add_module_directory_op (sexp ctx, sexp self, sexp_sint_t n, sexp dir, sexp appendp);
+SEXP_API sexp sexp_current_environment (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_set_current_environment (sexp ctx, sexp self, sexp_sint_t n, sexp env);
+SEXP_API sexp sexp_meta_environment (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value);
+SEXP_API sexp sexp_env_import_op (sexp ctx, sexp self, sexp_sint_t n, sexp to, sexp from, sexp ls, sexp immutp);
+SEXP_API sexp sexp_env_exports_op (sexp ctx, sexp self, sexp_sint_t n, sexp env);
+SEXP_API sexp sexp_identifierp_op(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_identifier_eq_op(sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b, sexp c, sexp d);
+SEXP_API sexp sexp_make_synclo_op(sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp fv, sexp expr);
+SEXP_API sexp sexp_strip_synclos(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_syntactic_closure_expr_op(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_open_input_file_op(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_open_output_file_op(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_open_binary_input_file(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_open_binary_output_file(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_close_port_op(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_set_port_line_op (sexp ctx, sexp self, sexp_sint_t n, sexp port, sexp line);
+SEXP_API sexp sexp_env_define (sexp ctx, sexp env, sexp sym, sexp val);
+SEXP_API sexp sexp_env_cell (sexp ctx, sexp env, sexp sym, int localp);
+SEXP_API sexp sexp_env_ref (sexp ctx, sexp env, sexp sym, sexp dflt);
+SEXP_API sexp sexp_env_parent_op (sexp ctx, sexp self, sexp_sint_t n, sexp env);
+SEXP_API sexp sexp_parameter_ref (sexp ctx, sexp param);
+#if SEXP_USE_RENAME_BINDINGS
+SEXP_API sexp sexp_env_rename (sexp ctx, sexp env, sexp key, sexp value);
+#endif
+SEXP_API sexp sexp_warn_undefs_op (sexp ctx, sexp self, sexp_sint_t n, sexp from, sexp to, sexp res);
+SEXP_API sexp sexp_make_lit (sexp ctx, sexp value);
+SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1);
+SEXP_API sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags, sexp num_args, sexp bc, sexp vars);
+SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data);
+SEXP_API sexp sexp_register_optimization(sexp ctx, sexp self, sexp_sint_t n, sexp f, sexp i);
+#if SEXP_USE_AUTO_FORCE
+SEXP_API sexp sexp_make_promise (sexp ctx, sexp self, sexp_sint_t n, sexp done, sexp val);
+#endif
+#if SEXP_USE_UTF8_STRINGS
+SEXP_API sexp sexp_read_utf8_char (sexp ctx, sexp port, int i);
+SEXP_API void sexp_string_utf8_set (sexp ctx, sexp str, sexp index, sexp ch);
+SEXP_API sexp sexp_string_utf8_index_ref (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i);
+SEXP_API sexp sexp_string_utf8_index_set (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i, sexp ch);
+#endif
+#if SEXP_USE_GREEN_THREADS
+SEXP_API sexp sexp_dk (sexp ctx, sexp self, sexp_sint_t n, sexp val);
+#endif
+SEXP_API sexp sexp_thread_parameters (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_thread_parameters_set (sexp ctx, sexp self, sexp_sint_t n, sexp val);
+SEXP_API sexp sexp_string_cmp_op (sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b, sexp ci);
+#if SEXP_USE_RATIOS
+SEXP_API sexp sexp_ratio_numerator_op (sexp ctx, sexp self, sexp_sint_t n, sexp rat);
+SEXP_API sexp sexp_ratio_denominator_op (sexp ctx, sexp self, sexp_sint_t n, sexp rat);
+#endif
+#if SEXP_USE_COMPLEX
+SEXP_API sexp sexp_complex_real_op (sexp ctx, sexp self, sexp_sint_t n, sexp rat);
+SEXP_API sexp sexp_complex_imag_op (sexp ctx, sexp self, sexp_sint_t n, sexp rat);
+#endif
+#if SEXP_USE_PROFILE_VM
+SEXP_API sexp sexp_reset_vm_profile (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_print_vm_profile (sexp ctx, sexp self, sexp_sint_t n);
+#endif
+
+#if SEXP_USE_MATH
+SEXP_API sexp sexp_exp(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_log(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_sin(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_cos(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_tan(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_asin(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_acos(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_atan(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_sqrt(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_exact_sqrt(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_inexact_sqrt(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_round(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_trunc(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_floor(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_ceiling(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+#endif
+SEXP_API sexp sexp_expt_op(sexp ctx, sexp self, sexp_sint_t n, sexp z1, sexp z2);
+SEXP_API sexp sexp_exact_to_inexact(sexp ctx, sexp self, sexp_sint_t n, sexp i);
+SEXP_API sexp sexp_inexact_to_exact(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+
+#if SEXP_USE_NATIVE_X86
+SEXP_API sexp sexp_write_char_op(sexp ctx, sexp self, sexp_sint_t n, sexp ch, sexp out);
+SEXP_API sexp sexp_newline_op(sexp ctx, sexp self, sexp_sint_t n, sexp out);
+SEXP_API sexp sexp_read_char_op(sexp ctx, sexp self, sexp_sint_t n, sexp in);
+SEXP_API sexp sexp_peek_char_op(sexp ctx, sexp self, sexp_sint_t n, sexp in);
+SEXP_API sexp sexp_char_upcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch);
+SEXP_API sexp sexp_char_downcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch);
+#endif
+
+#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(sexp_proc1)f,NULL)
+#define sexp_define_foreign_opt(c,e,s,n,f,d) sexp_define_foreign_aux(c,e,s,n,1,(sexp_proc1)f,d)
+
+SEXP_API sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_args, sexp_proc1 f, const char *param);
+
+#define sexp_env_key(x) sexp_car(x)
+#define sexp_env_value(x) sexp_cdr(x)
+#define sexp_env_next_cell(x) sexp_pair_source(x)
+#define sexp_env_push(ctx, env, tmp, name, value) (tmp=sexp_cons(ctx,name,value), sexp_env_next_cell(tmp)=sexp_env_bindings(env), sexp_env_bindings(env)=tmp)
+#define sexp_env_push_rename(ctx, env, tmp, name, value) (tmp=sexp_cons(ctx,name,value), sexp_env_next_cell(tmp)=sexp_env_renames(env), sexp_env_renames(env)=tmp)
+
+#if SEXP_USE_TYPE_DEFS
+SEXP_API sexp sexp_make_type_predicate_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type);
+SEXP_API sexp sexp_make_constructor_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type);
+SEXP_API sexp sexp_make_getter_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type, sexp index);
+SEXP_API sexp sexp_make_setter_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type, sexp index);
+SEXP_API sexp sexp_type_slot_offset_op (sexp ctx, sexp self, sexp_sint_t n, sexp type, sexp index);
+#endif
+
+#ifdef PLAN9
+SEXP_API sexp sexp_rand (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_srand (sexp ctx, sexp self, sexp_sint_t n, sexp seed);
+SEXP_API sexp sexp_file_exists_p (sexp ctx, sexp self, sexp_sint_t n, sexp path);
+SEXP_API sexp sexp_fdopen (sexp ctx, sexp self, sexp_sint_t n, sexp fd, sexp mode);
+SEXP_API sexp sexp_fileno (sexp ctx, sexp self, sexp_sint_t n, sexp port);
+SEXP_API sexp sexp_fork (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_exec (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp args);
+SEXP_API void sexp_exits (sexp ctx, sexp self, sexp_sint_t n, sexp msg);
+SEXP_API sexp sexp_dup (sexp ctx, sexp self, sexp_sint_t n, sexp oldfd, sexp newfd);
+SEXP_API sexp sexp_pipe (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_sleep (sexp ctx, sexp self, sexp_sint_t n, sexp msecs);
+SEXP_API sexp sexp_getenv (sexp ctx, sexp self, sexp_sint_t n, sexp name);
+SEXP_API sexp sexp_getwd (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_chdir (sexp ctx, sexp self, sexp_sint_t n, sexp path);
+SEXP_API sexp sexp_getuser (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_sysname (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_wait (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_postnote (sexp ctx, sexp self, sexp_sint_t n, sexp pid, sexp note);
+SEXP_API sexp sexp_postmountsrv (sexp ctx, sexp self, sexp_sint_t n, sexp ls, sexp name, sexp mtpt, sexp flags);
+SEXP_API sexp sexp_9p_req_offset (sexp ctx, sexp self, sexp_sint_t n, sexp req);
+SEXP_API sexp sexp_9p_req_count (sexp ctx, sexp self, sexp_sint_t n, sexp req);
+SEXP_API sexp sexp_9p_req_fid (sexp ctx, sexp self, sexp_sint_t n, sexp req);
+SEXP_API sexp sexp_9p_req_newfid (sexp ctx, sexp self, sexp_sint_t n, sexp req);
+SEXP_API sexp sexp_9p_respond (sexp ctx, sexp self, sexp_sint_t n, sexp req, sexp err);
+SEXP_API sexp sexp_9p_responderror (sexp ctx, sexp self, sexp_sint_t n, sexp req);
+#else
+SEXP_API sexp sexp_get_port_fileno (sexp ctx, sexp self, sexp_sint_t n, sexp port);
+#endif
+
+#if SEXP_USE_SIMPLIFY
+SEXP_API int sexp_rest_unused_p (sexp lambda);
+#else
+#define sexp_rest_unused_p(lambda) 0
+#endif
+
+/* simplify primitive API interface */
+#define sexp_make_synclo(ctx, a, b, c) sexp_make_synclo_op(ctx, NULL, 3, a, b, c)
+#define sexp_make_procedure(ctx, f, n, b, v) sexp_make_procedure_op(ctx, NULL, 4, f, n, b, v)
+#define sexp_make_env(ctx) sexp_make_env_op(ctx, NULL, 0)
+#define sexp_make_null_env(ctx, v) sexp_make_null_env_op(ctx, NULL, 0, v)
+#define sexp_make_primitive_env(ctx, v) sexp_make_primitive_env_op(ctx, NULL, 1, v)
+#define sexp_make_standard_env(ctx, v) sexp_make_standard_env_op(ctx, NULL, 1, v)
+#define sexp_add_module_directory(ctx, d, a) sexp_add_module_directory_op(ctx, NULL, 1, d, a)
+#define sexp_eval(ctx, x, e) sexp_eval_op(ctx, NULL, 2, x, e)
+#define sexp_load(ctx, f, e) sexp_load_op(ctx, NULL, 2, f, e)
+#define sexp_env_import(ctx, a, b, c, d) sexp_env_import_op(ctx, NULL, 4, a, b, c, d)
+#define sexp_identifierp(ctx, x) sexp_identifierp_op(ctx, NULL, 1, x)
+#define sexp_identifier_to_symbol(ctx, x) sexp_syntactic_closure_expr_op(ctx, NULL, 1, x)
+#define sexp_identifier_eq(ctx, a, b, c, d) sexp_identifier_eq_op(ctx, NULL, 4, a, b, c, d)
+#define sexp_open_input_file(ctx, x) sexp_open_input_file_op(ctx, NULL, 1, x)
+#define sexp_open_output_file(ctx, x) sexp_open_output_file_op(ctx, NULL, 1, x)
+#define sexp_close_port(ctx, x) sexp_close_port_op(ctx, NULL, 1, x)
+#define sexp_warn_undefs(ctx, from, to, res) sexp_warn_undefs_op(ctx, NULL, 3, from, to, res)
+#define sexp_string_cmp(ctx, a, b, c) sexp_string_cmp_op(ctx, NULL, 3, a, b, c)
+
+#ifdef __cplusplus
+} /* extern "C" */
+#endif
+
+#endif /* ! SEXP_EVAL_H */
diff --git a/include/chibi/features.h b/include/chibi/features.h
new file mode 100644
index 00000000..9103df2a
--- /dev/null
+++ b/include/chibi/features.h
@@ -0,0 +1,835 @@
+/*  features.h -- general feature configuration               */
+/*  Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+/* uncomment this to disable most features */
+/*   Most features are enabled by default, but setting this */
+/*   option will disable any not explicitly enabled. */
+/* #define SEXP_USE_NO_FEATURES 1 */
+
+/* uncomment this to disable interpreter-based threads */
+/* #define SEXP_USE_GREEN_THREADS 0 */
+
+/* uncomment this to enable the experimental native x86 backend */
+/* #define SEXP_USE_NATIVE_X86 1 */
+
+/* uncomment this to disable the module system */
+/*   Currently this just loads the meta.scm from main and */
+/*   sets up an (import (module name)) macro. */
+/* #define SEXP_USE_MODULES 0 */
+
+/* uncomment this to disable dynamic loading */
+/*   If enabled, you can LOAD .so files with a */
+/*   sexp_init_library(ctx, env) function provided. */
+/* #define SEXP_USE_DL 0 */
+
+/* uncomment this to statically compile all C libs */
+/*   If set, this will statically include the clibs.c file */
+/*   into the standard environment, so that you can have */
+/*   access to a predefined set of C libraries without */
+/*   needing dynamic loading.  The clibs.c file is generated */
+/*   automatically by searching the lib directory for */
+/*   modules with include-shared, but can be hand-tailored */
+/*   to your needs. */
+/* #define SEXP_USE_STATIC_LIBS 1 */
+
+/* uncomment this to disable detailed source info for debugging */
+/*   By default Chibi will associate source info with every */
+/*   bytecode offset.  By disabling this only lambda-level source */
+/*   info will be recorded (the line of the opening paren for the */
+/*   lambda). */
+/* #define SEXP_USE_FULL_SOURCE_INFO 0 */
+
+/* uncomment this to disable a simplifying optimization pass */
+/*   This performs some simple optimizations such as dead-code */
+/*   elimination, constant-folding, and directly propagating */
+/*   non-mutated let values bound to constants or non-mutated */
+/*   references.  More than performance, this is aimed at reducing the */
+/*   size of the compiled code, especially as the result of macro */
+/*   expansions, so it's a good idea to leave it enabled. */
+/* #define SEXP_USE_SIMPLIFY 0 */
+
+/* uncomment this to disable dynamic type definitions */
+/*   This enables register-simple-type and related */
+/*   opcodes for defining types, needed by the default */
+/*   implementation of (srfi 9). */
+/* #define SEXP_USE_TYPE_DEFS 0 */
+
+/* uncomment this to use the Boehm conservative GC */
+/*   Conservative GCs make it easier to write extensions, */
+/*   since you don't have to keep track of intermediate */
+/*   variables, but can leak memory.  Boehm is also a */
+/*   very large library to link in.  You may want to */
+/*   enable this when debugging your own extensions, or */
+/*   if you suspect a bug in the native GC. */
+/* #define SEXP_USE_BOEHM 1 */
+
+/* uncomment this to disable weak references */
+/* #define SEXP_USE_WEAK_REFERENCES 0 */
+
+/* uncomment this to just malloc manually instead of any GC */
+/*   Mostly for debugging purposes, this is the no GC option. */
+/*   You can use just the read/write API and */
+/*   explicitly free sexps, though. */
+/* #define SEXP_USE_MALLOC 1 */
+
+/* uncomment this to allocate heaps with mmap instead of malloc */
+/* #define SEXP_USE_MMAP_GC 1 */
+
+/* uncomment this to add conservative checks to the native GC */
+/*   Please mail the author if enabling this makes a bug */
+/*   go away and you're not working on your own C extension. */
+/* #define SEXP_USE_CONSERVATIVE_GC 1 */
+
+/* uncomment this to add additional native checks to only mark objects in the heap */
+/* #define SEXP_USE_SAFE_GC_MARK 1 */
+
+/* uncomment this to track what C source line each object is allocated from */
+/* #define SEXP_USE_TRACK_ALLOC_SOURCE 1 */
+
+/* uncomment this to take a short backtrace of where each object is */
+/* allocated from */
+/* #define SEXP_USE_TRACK_ALLOC_BACKTRACE 1 */
+
+/* uncomment this to add additional native gc checks to verify a magic header */
+/* #define SEXP_USE_HEADER_MAGIC 1 */
+
+/* uncomment this to add very verbose debugging stats to the native GC */
+/* #define SEXP_USE_DEBUG_GC 1 */
+
+/* uncomment this to enable "safe" field accessors for primitive types */
+/*   The sexp union type fields are abstracted away with macros of the */
+/*   form sexp_<type>_<field>(<obj>), however these are just convenience */
+/*   macros equivalent to directly accessing the union field, and will */
+/*   return incorrect results (or segfault) if <obj> isn't of the correct */
+/*   <type>.  Thus you're required to check the types manually before */
+/*   accessing them.  However, to detect errors earlier you can enable */
+/*   SEXP_USE_SAFE_ACCESSORS, and on invalid accesses chibi will print */
+/*   a friendly error message and immediately segfault itself so you */
+/*   can see where the invalid access was made. */
+/*   Note this is only intended for debugging, and mostly for user code. */
+/*   If you want to build chibi itself with this option, compilation */
+/*   may be very slow and using CFLAGS=-O0 is recommended. */
+/* #define SEXP_USE_SAFE_ACCESSORS 1 */
+
+/* uncomment to install a default signal handler in main() for segfaults */
+/*   This will print a helpful backtrace. */
+/* #define SEXP_USE_PRINT_BACKTRACE_ON_SEGFAULT 1 */
+
+/* uncomment this to make the heap common to all contexts */
+/*   By default separate contexts can have separate heaps, */
+/*   and are thus thread-safe and independant. */
+/* #define SEXP_USE_GLOBAL_HEAP 1 */
+
+/* uncomment this to make the symbol table common to all contexts */
+/*   Will still be restricted to all contexts sharing the same */
+/*   heap, of course. */
+/* #define SEXP_USE_GLOBAL_SYMBOLS 1 */
+
+/* uncomment this to disable foreign function bindings with > 6 args */
+/* #define SEXP_USE_EXTENDED_FCALL 0 */
+
+/* uncomment this if you don't need flonum support */
+/*   This is only for EVAL - you'll still be able to read */
+/*   and write flonums directly through the sexp API. */
+/* #define SEXP_USE_FLONUMS 0 */
+
+/* uncomment this to disable reading/writing IEEE infinities */
+/*   By default you can read/write +inf.0, -inf.0 and +nan.0 */
+/* #define SEXP_USE_INFINITIES 0 */
+
+/* uncomment this if you want immediate flonums */
+/*   This is experimental, enable at your own risk. */
+/* #define SEXP_USE_IMMEDIATE_FLONUMS 1 */
+
+/* uncomment this if you don't want bignum support */
+/*   Bignums are implemented with a small, custom library  */
+/*   in opt/bignum.c. */
+/* #define SEXP_USE_BIGNUMS 0 */
+
+/* uncomment this if you don't want exact ratio support */
+/*   Ratios are part of the bignum library and imply bignums. */
+/* #define SEXP_USE_RATIOS 0 */
+
+/* uncomment this if you don't want imaginary number support */
+/* #define SEXP_USE_COMPLEX 0 */
+
+/* uncomment this if you don't want 1## style approximate digits */
+/* #define SEXP_USE_PLACEHOLDER_DIGITS 0 */
+
+/* uncomment this if you don't need extended math operations */
+/*   This includes the trigonometric and expt functions. */
+/*   Automatically disabled if you've disabled flonums. */
+/* #define SEXP_USE_MATH 0 */
+
+/* uncomment this to disable warning about references to undefined variables */
+/*   This is something of a hack, but can be quite useful. */
+/*   It's very fast and doesn't involve any separate analysis */
+/*   passes. */
+/* #define SEXP_USE_WARN_UNDEFS 0 */
+
+/* uncomment this to disable huffman-coded immediate symbols */
+/*   By default (this may change) small symbols are represented */
+/*   as immediates using a simple huffman encoding.  This keeps */
+/*   the symbol table small, and minimizes hashing when doing a */
+/*   lot of reading. */
+/* #define SEXP_USE_HUFF_SYMS 0 */
+
+/* uncomment this to just use a single list for hash tables */
+/*   You can trade off some space in exchange for longer read */
+/*   times by disabling hashing and just putting all */
+/*   non-immediate symbols in a single list. */
+/* #define SEXP_USE_HASH_SYMS 0 */
+
+/* uncomment this to disable extended char names as defined in R7RS */
+/* #define SEXP_USE_EXTENDED_CHAR_NAMES 0 */
+
+/* uncomment this to disable UTF-8 string support */
+/*   The default settings store strings in memory as UTF-8, */
+/*   and assumes strings passed to/from the C FFI are UTF-8.  */
+/* #define SEXP_USE_UTF8_STRINGS 0 */
+
+/* uncomment this to disable the string-set! opcode */
+/*   By default (non-literal) strings are mutable. */
+/*   Making them immutable allows for packed UTF-8 strings. */
+/* #define SEXP_USE_MUTABLE_STRINGS 0 */
+
+/* uncomment this to base string ports on C streams */
+/*   This historic option enables string and custom ports backed */
+/*   by FILE* objects using memstreams and funopen/fopencookie. */
+/* #define SEXP_USE_STRING_STREAMS 1 */
+
+/* uncomment this to disable automatic closing of ports */
+/*   If enabled, the underlying FILE* for file ports will be */
+/*   automatically closed when they're garbage collected.  Doesn't */
+/*   apply to stdin/stdout/stderr. */
+/* #define SEXP_USE_AUTOCLOSE_PORTS 0 */
+
+/* uncomment this to use the normal 1970 unix epoch */
+/*   By default chibi uses an datetime epoch starting at */
+/*   2010/01/01 00:00:00 in order to be able to represent */
+/*   more common times as fixnums. */
+/* #define SEXP_USE_2010_EPOCH 0 */
+
+/* uncomment this to disable stack overflow checks */
+/*   By default stacks are fairly small, so it's good to leave */
+/*   this enabled. */
+/* #define SEXP_USE_CHECK_STACK 0 */
+
+/* uncomment this to disable growing the stack on overflow */
+/*   If enabled, chibi attempts to grow the stack on overflow, */
+/*   up to SEXP_MAX_STACK_SIZE, otherwise a failed stack check */
+/*   will just raise an error immediately. */
+/* #define SEXP_USE_GROW_STACK 0 */
+
+/* #define SEXP_USE_DEBUG_VM 0 */
+/*   Experts only. */
+/*   For *very* verbose output on every VM operation. */
+
+/* uncomment this to make the VM adhere to alignment rules */
+/*   This is required on some platforms, e.g. ARM */
+/* #define SEXP_USE_ALIGNED_BYTECODE */
+
+/************************************************************************/
+/* These settings are configurable but only recommended for */
+/* experienced users, and only apply when using the native GC.  */
+/************************************************************************/
+
+/* the initial heap size in bytes */
+#ifndef SEXP_INITIAL_HEAP_SIZE
+#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024)
+#endif
+
+/* the maximum heap size in bytes - if 0 there is no limit */
+#ifndef SEXP_MAXIMUM_HEAP_SIZE
+#define SEXP_MAXIMUM_HEAP_SIZE 0
+#endif
+#ifndef SEXP_MINIMUM_HEAP_SIZE
+#define SEXP_MINIMUM_HEAP_SIZE 8*1024
+#endif
+
+/* if after GC more than this percentage of memory is still in use, */
+/* and we've not exceeded the maximum size, grow the heap */
+#ifndef SEXP_GROW_HEAP_RATIO
+#define SEXP_GROW_HEAP_RATIO 0.75
+#endif
+
+/* the default number of opcodes to run each thread for */
+#ifndef SEXP_DEFAULT_QUANTUM
+#define SEXP_DEFAULT_QUANTUM 500
+#endif
+
+#ifndef SEXP_MAX_ANALYZE_DEPTH
+#define SEXP_MAX_ANALYZE_DEPTH 8192
+#endif
+
+/************************************************************************/
+/*         DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE            */
+/************************************************************************/
+
+#ifndef SEXP_64_BIT
+#if defined(__amd64) || defined(__x86_64) || defined(_WIN64) || defined(_Wp64) || defined(__LP64__) || defined(__PPC64__)
+#define SEXP_64_BIT 1
+#else
+#define SEXP_64_BIT 0
+#endif
+#endif
+
+#if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__)
+#define SEXP_BSD 1
+#else
+#define SEXP_BSD 0
+#if ! defined(_GNU_SOURCE) && ! defined(_WIN32) && ! defined(PLAN9)
+#define _GNU_SOURCE
+#endif
+#endif
+
+#ifndef SEXP_USE_NO_FEATURES
+#define SEXP_USE_NO_FEATURES 0
+#endif
+
+#ifndef SEXP_USE_PEDANTIC
+#define SEXP_USE_PEDANTIC 0
+#endif
+
+#ifndef SEXP_USE_GREEN_THREADS
+#define SEXP_USE_GREEN_THREADS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_DEBUG_THREADS
+#define SEXP_USE_DEBUG_THREADS 0
+#endif
+
+#ifndef SEXP_USE_AUTO_FORCE
+#define SEXP_USE_AUTO_FORCE 0
+#endif
+
+#ifndef SEXP_USE_NATIVE_X86
+#define SEXP_USE_NATIVE_X86 0
+#endif
+
+#ifndef SEXP_USE_MODULES
+#define SEXP_USE_MODULES ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef sexp_default_user_module_path
+#define sexp_default_user_module_path "./lib:."
+#endif
+
+#ifndef SEXP_USE_TYPE_DEFS
+#define SEXP_USE_TYPE_DEFS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_MAXIMUM_TYPES
+#define SEXP_MAXIMUM_TYPES ((sexp_tag_t)-1)
+#endif
+
+#ifndef SEXP_USE_DL
+#if defined(PLAN9) || defined(_WIN32)
+#define SEXP_USE_DL 0
+#else
+#define SEXP_USE_DL ! SEXP_USE_NO_FEATURES
+#endif
+#endif
+
+#ifndef SEXP_USE_STATIC_LIBS
+#define SEXP_USE_STATIC_LIBS 0
+#endif
+
+/* don't include clibs.c - include separately or link */
+#ifndef SEXP_USE_STATIC_LIBS_NO_INCLUDE
+#define SEXP_USE_STATIC_LIBS_NO_INCLUDE defined(PLAN9)
+#endif
+
+#ifndef SEXP_USE_FULL_SOURCE_INFO
+#define SEXP_USE_FULL_SOURCE_INFO ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_SIMPLIFY
+#define SEXP_USE_SIMPLIFY ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_BOEHM
+#define SEXP_USE_BOEHM 0
+#endif
+
+#ifndef SEXP_USE_WEAK_REFERENCES
+#define SEXP_USE_WEAK_REFERENCES ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_MALLOC
+#define SEXP_USE_MALLOC 0
+#endif
+
+#ifndef SEXP_USE_LIMITED_MALLOC
+#define SEXP_USE_LIMITED_MALLOC 0
+#endif
+
+#ifndef SEXP_USE_MMAP_GC
+#define SEXP_USE_MMAP_GC 0
+#endif
+
+#ifndef SEXP_USE_DEBUG_GC
+#define SEXP_USE_DEBUG_GC 0
+#endif
+
+#ifndef SEXP_USE_SAFE_GC_MARK
+#define SEXP_USE_SAFE_GC_MARK SEXP_USE_DEBUG_GC > 1
+#endif
+
+#ifndef SEXP_USE_CONSERVATIVE_GC
+#define SEXP_USE_CONSERVATIVE_GC 0
+#endif
+
+#ifndef SEXP_USE_TRACK_ALLOC_SOURCE
+#define SEXP_USE_TRACK_ALLOC_SOURCE SEXP_USE_DEBUG_GC > 2
+#endif
+
+#ifndef SEXP_USE_TRACK_ALLOC_BACKTRACE
+#define SEXP_USE_TRACK_ALLOC_BACKTRACE SEXP_USE_TRACK_ALLOC_SOURCE
+#endif
+
+#ifndef SEXP_BACKTRACE_SIZE
+#define SEXP_BACKTRACE_SIZE 3
+#endif
+
+#ifndef SEXP_USE_HEADER_MAGIC
+#define SEXP_USE_HEADER_MAGIC 0
+#endif
+
+#ifndef SEXP_GC_PAD
+#define SEXP_GC_PAD 0
+#endif
+
+#ifndef SEXP_USE_SAFE_ACCESSORS
+#define SEXP_USE_SAFE_ACCESSORS 0
+#endif
+
+#ifndef SEXP_USE_SAFE_VECTOR_ACCESSORS
+#define SEXP_USE_SAFE_VECTOR_ACCESSORS 0
+#endif
+
+#ifndef SEXP_USE_GLOBAL_HEAP
+#if SEXP_USE_BOEHM || SEXP_USE_MALLOC
+#define SEXP_USE_GLOBAL_HEAP 1
+#else
+#define SEXP_USE_GLOBAL_HEAP 0
+#endif
+#endif
+
+#ifndef SEXP_USE_GLOBAL_SYMBOLS
+#if SEXP_USE_BOEHM || SEXP_USE_MALLOC
+#define SEXP_USE_GLOBAL_SYMBOLS 1
+#else
+#define SEXP_USE_GLOBAL_SYMBOLS 0
+#endif
+#endif
+
+#ifndef SEXP_USE_STRICT_TOPLEVEL_BINDINGS
+#define SEXP_USE_STRICT_TOPLEVEL_BINDINGS 0
+#endif
+
+#if SEXP_USE_STRICT_TOPLEVEL_BINDINGS
+#define SEXP_USE_RENAME_BINDINGS 1
+#else
+#ifndef SEXP_USE_RENAME_BINDINGS
+#define SEXP_USE_RENAME_BINDINGS 1
+#endif
+#endif
+
+#ifndef SEXP_USE_SPLICING_LET_SYNTAX
+#define SEXP_USE_SPLICING_LET_SYNTAX 0
+#endif
+
+#ifndef SEXP_USE_FLAT_SYNTACTIC_CLOSURES
+#define SEXP_USE_FLAT_SYNTACTIC_CLOSURES 0
+#endif
+
+#ifndef SEXP_USE_UNWRAPPED_TOPLEVEL_BINDINGS
+#define SEXP_USE_UNWRAPPED_TOPLEVEL_BINDINGS 0
+#endif
+
+#ifndef SEXP_USE_EXTENDED_FCALL
+#define SEXP_USE_EXTENDED_FCALL (!SEXP_USE_NO_FEATURES)
+#endif
+
+#ifndef SEXP_USE_FLONUMS
+#define SEXP_USE_FLONUMS (!SEXP_USE_NO_FEATURES)
+#endif
+
+#ifndef SEXP_USE_BIGNUMS
+#define SEXP_USE_BIGNUMS (!SEXP_USE_NO_FEATURES)
+#endif
+
+#ifndef SEXP_USE_RATIOS
+#define SEXP_USE_RATIOS SEXP_USE_FLONUMS
+#endif
+
+#ifndef SEXP_USE_COMPLEX
+#define SEXP_USE_COMPLEX SEXP_USE_FLONUMS
+#endif
+
+#if (SEXP_USE_RATIOS || SEXP_USE_COMPLEX)
+#undef SEXP_USE_BIGNUMS
+#define SEXP_USE_BIGNUMS 1
+#undef SEXP_USE_FLONUMS
+#define SEXP_USE_FLONUMS 1
+#endif
+
+#ifndef SEXP_USE_INFINITIES
+#if defined(PLAN9) || ! SEXP_USE_FLONUMS
+#define SEXP_USE_INFINITIES 0
+#else
+#define SEXP_USE_INFINITIES ! SEXP_USE_NO_FEATURES
+#endif
+#endif
+
+#ifndef SEXP_USE_IMMEDIATE_FLONUMS
+#define SEXP_USE_IMMEDIATE_FLONUMS 0
+#endif
+
+#ifndef SEXP_USE_IEEE_EQV
+#define SEXP_USE_IEEE_EQV SEXP_USE_FLONUMS
+#endif
+
+#ifndef SEXP_USE_PLACEHOLDER_DIGITS
+#define SEXP_USE_PLACEHOLDER_DIGITS 0
+#endif
+
+#ifndef SEXP_PLACEHOLDER_DIGIT
+#define SEXP_PLACEHOLDER_DIGIT '#'
+#endif
+
+#ifndef SEXP_USE_MATH
+#define SEXP_USE_MATH SEXP_USE_FLONUMS && ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_ESCAPE_NEWLINE
+#define SEXP_USE_ESCAPE_NEWLINE ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_ESCAPE_REQUIRES_TRAILING_SEMI_COLON
+#define SEXP_USE_ESCAPE_REQUIRES_TRAILING_SEMI_COLON SEXP_USE_PEDANTIC
+#endif
+
+#ifndef SEXP_USE_OBJECT_BRACE_LITERALS
+#define SEXP_USE_OBJECT_BRACE_LITERALS (SEXP_USE_TYPE_DEFS && !SEXP_USE_NO_FEATURES)
+#endif
+
+/* Dangerous without shared object detection. */
+#ifndef SEXP_USE_TYPE_PRINTERS
+#define SEXP_USE_TYPE_PRINTERS 0
+#endif
+
+#ifndef SEXP_USE_BYTEVECTOR_LITERALS
+#define SEXP_USE_BYTEVECTOR_LITERALS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_SELF_PARAMETER
+#define SEXP_USE_SELF_PARAMETER 1
+#endif
+
+#ifndef SEXP_USE_WARN_UNDEFS
+#define SEXP_USE_WARN_UNDEFS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_HUFF_SYMS
+#define SEXP_USE_HUFF_SYMS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_HASH_SYMS
+#define SEXP_USE_HASH_SYMS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_FOLD_CASE_SYMS
+#define SEXP_USE_FOLD_CASE_SYMS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_DEFAULT_FOLD_CASE_SYMS
+#define SEXP_DEFAULT_FOLD_CASE_SYMS 0
+#endif
+
+/* experimental optimization to use jumps instead of the TAIL-CALL opcode */
+#ifndef SEXP_USE_TAIL_JUMPS
+/* #define SEXP_USE_TAIL_JUMPS ! SEXP_USE_NO_FEATURES */
+#define SEXP_USE_TAIL_JUMPS 0
+#endif
+
+#ifndef SEXP_USE_RESERVE_OPCODE
+#define SEXP_USE_RESERVE_OPCODE SEXP_USE_TAIL_JUMPS
+#endif
+
+/* experimental optimization to avoid boxing locals which aren't set! */
+#ifndef SEXP_USE_UNBOXED_LOCALS
+/* #define SEXP_USE_UNBOXED_LOCALS ! SEXP_USE_NO_FEATURES */
+#define SEXP_USE_UNBOXED_LOCALS 0
+#endif
+
+#ifndef SEXP_USE_DEBUG_VM
+#define SEXP_USE_DEBUG_VM 0
+#endif
+
+#ifndef SEXP_USE_PROFILE_VM
+#define SEXP_USE_PROFILE_VM 0
+#endif
+
+#ifndef SEXP_USE_EXTENDED_CHAR_NAMES
+#define SEXP_USE_EXTENDED_CHAR_NAMES ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_UTF8_STRINGS
+#define SEXP_USE_UTF8_STRINGS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_MUTABLE_STRINGS
+#define SEXP_USE_MUTABLE_STRINGS 1
+#endif
+
+#if (SEXP_USE_UTF8_STRINGS && SEXP_USE_MUTABLE_STRINGS)
+#define SEXP_USE_PACKED_STRINGS 0
+#endif
+#ifndef SEXP_USE_PACKED_STRINGS
+#define SEXP_USE_PACKED_STRINGS 1
+#endif
+
+#ifndef SEXP_USE_STRING_STREAMS
+#define SEXP_USE_STRING_STREAMS 0
+#endif
+
+#ifndef SEXP_USE_AUTOCLOSE_PORTS
+#define SEXP_USE_AUTOCLOSE_PORTS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_GC_FILE_DESCRIPTORS
+#define SEXP_USE_GC_FILE_DESCRIPTORS (SEXP_USE_AUTOCLOSE_PORTS &&!SEXP_USE_BOEHM && !defined(PLAN9))
+#endif
+
+#ifndef SEXP_USE_BIDIRECTIONAL_PORTS
+#define SEXP_USE_BIDIRECTIONAL_PORTS 0
+#endif
+
+#ifndef SEXP_PORT_BUFFER_SIZE
+#define SEXP_PORT_BUFFER_SIZE 4096
+#endif
+
+#ifndef SEXP_USE_NTP_GETTIME
+#define SEXP_USE_NTP_GETTIME 0
+#endif
+
+#ifndef SEXP_USE_2010_EPOCH
+#define SEXP_USE_2010_EPOCH ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_EPOCH_OFFSET
+#if SEXP_USE_2010_EPOCH
+#define SEXP_EPOCH_OFFSET 1262271600
+#else
+#define SEXP_EPOCH_OFFSET 0
+#endif
+#endif
+
+#ifndef SEXP_USE_CHECK_STACK
+#define SEXP_USE_CHECK_STACK ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_GROW_STACK
+#define SEXP_USE_GROW_STACK SEXP_USE_CHECK_STACK && ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_LONG_PROCEDURE_ARGS
+#define SEXP_USE_LONG_PROCEDURE_ARGS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_INIT_BCODE_SIZE
+#define SEXP_INIT_BCODE_SIZE 128
+#endif
+#ifndef SEXP_INIT_STACK_SIZE
+#if SEXP_USE_CHECK_STACK
+#define SEXP_INIT_STACK_SIZE 1024
+#else
+#define SEXP_INIT_STACK_SIZE 8192
+#endif
+#endif
+#ifndef SEXP_MAX_STACK_SIZE
+#define SEXP_MAX_STACK_SIZE SEXP_INIT_STACK_SIZE*1000
+#endif
+
+#ifndef SEXP_DEFAULT_EQUAL_DEPTH
+#define SEXP_DEFAULT_EQUAL_DEPTH 10000
+#endif
+
+#ifndef SEXP_DEFAULT_EQUAL_BOUND
+#define SEXP_DEFAULT_EQUAL_BOUND 100000000
+#endif
+
+#ifndef SEXP_USE_IMAGE_LOADING
+#define SEXP_USE_IMAGE_LOADING SEXP_USE_DL && !SEXP_USE_GLOBAL_HEAP && !SEXP_USE_BOEHM && !SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_UNSAFE_PUSH
+#define SEXP_USE_UNSAFE_PUSH 0
+#endif
+
+#ifndef SEXP_USE_MAIN_HELP
+#define SEXP_USE_MAIN_HELP ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_MAIN_ERROR_ADVISE
+#define SEXP_USE_MAIN_ERROR_ADVISE ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_SEND_FILE
+#define SEXP_USE_SEND_FILE 0
+/* #define SEXP_USE_SEND_FILE (__linux || SEXP_BSD) */
+#endif
+
+#if SEXP_USE_NATIVE_X86
+#undef SEXP_USE_BOEHM
+#define SEXP_USE_BOEHM 1
+#undef SEXP_USE_FLONUMS
+#define SEXP_USE_FLONUMS 0
+#undef SEXP_USE_BIGNUMS
+#define SEXP_USE_BIGNUMS 0
+#undef SEXP_USE_RATIOS
+#define SEXP_USE_RATIOS 0
+#undef SEXP_USE_COMPLEX
+#define SEXP_USE_COMPLEX 0
+#undef SEXP_USE_UTF8_STRINGS
+#define SEXP_USE_UTF8_STRINGS 0
+#undef SEXP_USE_SIMPLIFY
+#define SEXP_USE_SIMPLIFY 0
+#endif
+
+#ifndef SEXP_USE_ALIGNED_BYTECODE
+#if defined(__arm__)
+#define SEXP_USE_ALIGNED_BYTECODE 1
+#else
+#define SEXP_USE_ALIGNED_BYTECODE 0
+#endif
+#endif
+
+#ifdef PLAN9
+#define strcasecmp cistrcmp
+#define strncasecmp cistrncmp
+#define strcasestr cistrstr
+#define round(x) floor((x)+0.5)
+#define trunc(x) floor((x)+0.5*(((x)<0)?1:0))
+#define isinf(x) (isInf(x,1) || isInf(x,-1))
+#define isnan(x) isNaN(x)
+#elif defined(_WIN32)
+#define snprintf(buf, len, fmt, val) sprintf(buf, fmt, val)
+#define strcasecmp lstrcmpi
+#define strncasecmp(s1, s2, n) lstrcmpi(s1, s2)
+#define round(x) floor((x)+0.5)
+#define trunc(x) floor((x)+0.5*(((x)<0)?1:0))
+#define isnan(x) (x!=x)
+#define isinf(x) (x > DBL_MAX || x < -DBL_MAX)
+#endif
+
+#ifdef _WIN32
+#define sexp_pos_infinity (DBL_MAX*DBL_MAX)
+#define sexp_neg_infinity -sexp_pos_infinity
+#define sexp_nan log(-2)
+#elif PLAN9
+#define sexp_pos_infinity Inf(1)
+#define sexp_neg_infinity Inf(-1)
+#define sexp_nan NaN()
+#else
+#define sexp_pos_infinity (1.0/0.0)
+#define sexp_neg_infinity -sexp_pos_infinity
+#define sexp_nan (0.0/0.0)
+#endif
+
+#ifdef __MINGW32__
+#ifdef BUILDING_DLL
+#define SEXP_API    __declspec(dllexport)
+#else
+#define SEXP_API    __declspec(dllimport)
+#endif
+#else
+#define SEXP_API    extern
+#endif
+
+/************************************************************************/
+/* Feature signature.  Used for image files and dynamically loaded      */
+/* libraries to verify they are compatible with the compiled options .  */
+/************************************************************************/
+
+typedef char sexp_abi_identifier_t[8];
+
+#if SEXP_USE_BOEHM
+#define SEXP_ABI_GC "b"
+#elif (SEXP_USE_HEADER_MAGIC && SEXP_USE_TRACK_ALLOC_SOURCE)
+#define SEXP_ABI_GC "d"
+#elif SEXP_USE_HEADER_MAGIC
+#define SEXP_ABI_GC "m"
+#elif SEXP_USE_TRACK_ALLOC_SOURCE
+#define SEXP_ABI_GC "s"
+#else
+#define SEXP_ABI_GC "c"
+#endif
+
+#if SEXP_USE_NATIVE_X86
+#define SEXP_ABI_BACKEND "x"
+#else
+#define SEXP_ABI_BACKEND "v"
+#endif
+
+#if (SEXP_USE_RESERVE_OPCODE && SEXP_USE_AUTO_FORCE)
+#define SEXP_ABI_INSTRUCTIONS "*"
+#elif SEXP_USE_RESERVE_OPCODE
+#define SEXP_ABI_INSTRUCTIONS "r"
+#elif SEXP_USE_AUTO_FORCE
+#define SEXP_ABI_INSTRUCTIONS "f"
+#else
+#define SEXP_ABI_INSTRUCTIONS "-"
+#endif
+
+#if SEXP_USE_GREEN_THREADS
+#define SEXP_ABI_THREADS "g"
+#else
+#define SEXP_ABI_THREADS "-"
+#endif
+
+#if SEXP_USE_MODULES
+#define SEXP_ABI_MODULES "m"
+#else
+#define SEXP_ABI_MODULES "-"
+#endif
+
+#if (SEXP_USE_COMPLEX && SEXP_USE_RATIOS)
+#define SEXP_ABI_NUMBERS "*"
+#elif SEXP_USE_COMPLEX
+#define SEXP_ABI_NUMBERS "c"
+#elif SEXP_USE_RATIOS
+#define SEXP_ABI_NUMBERS "r"
+#elif SEXP_USE_BIGNUMS
+#define SEXP_ABI_NUMBERS "b"
+#elif SEXP_USE_INFINITIES
+#define SEXP_ABI_NUMBERS "i"
+#elif SEXP_USE_FLONUMS
+#define SEXP_ABI_NUMBERS "f"
+#else
+#define SEXP_ABI_NUMBERS "-"
+#endif
+
+#if SEXP_USE_UTF8_STRINGS
+#define SEXP_ABI_STRINGS "u"
+#elif SEXP_USE_PACKED_STRINGS
+#define SEXP_ABI_STRINGS "p"
+#else
+#define SEXP_ABI_STRINGS "-"
+#endif
+
+#if SEXP_USE_HUFF_SYMS
+#define SEXP_ABI_SYMS "h"
+#else
+#define SEXP_ABI_SYMS "-"
+#endif
+
+#define SEXP_ABI_IDENTIFIER \
+  (SEXP_ABI_GC SEXP_ABI_BACKEND SEXP_ABI_INSTRUCTIONS SEXP_ABI_THREADS \
+   SEXP_ABI_MODULES SEXP_ABI_NUMBERS SEXP_ABI_STRINGS SEXP_ABI_SYMS)
+
+#define sexp_version_compatible(ctx, subver, genver) (strcmp((subver), (genver)) == 0)
+#define sexp_abi_compatible(ctx, subabi, genabi) (strncmp((subabi), (genabi), sizeof(sexp_abi_identifier_t)) == 0)
diff --git a/include/chibi/sexp-huff.c b/include/chibi/sexp-huff.c
new file mode 100644
index 00000000..abf6bc9f
--- /dev/null
+++ b/include/chibi/sexp-huff.c
@@ -0,0 +1,128 @@
+ {12, 0x0C00},   /* '\x00' */
+ {15, 0x0000},   /* '\x01' */
+ {15, 0x4000},   /* '\x02' */
+ {15, 0x2000},   /* '\x03' */
+ {15, 0x6000},   /* '\x04' */
+ {15, 0x0800},   /* '\x05' */
+ {15, 0x4800},   /* '\x06' */
+ {15, 0x2800},   /* '\x07' */
+ {15, 0x6800},   /* '\x08' */
+ {15, 0x1800},   /* '\x09' */
+ {15, 0x5800},   /* '\x0a' */
+ {15, 0x3800},   /* '\x0b' */
+ {15, 0x7800},   /* '\x0c' */
+ {15, 0x0100},   /* '\x0d' */
+ {15, 0x4100},   /* '\x0e' */
+ {15, 0x2100},   /* '\x0f' */
+ {15, 0x6100},   /* '\x10' */
+ {15, 0x1100},   /* '\x11' */
+ {15, 0x5100},   /* '\x12' */
+ {15, 0x3100},   /* '\x13' */
+ {15, 0x7100},   /* '\x14' */
+ {15, 0x0900},   /* '\x15' */
+ {15, 0x4900},   /* '\x16' */
+ {15, 0x2900},   /* '\x17' */
+ {15, 0x6900},   /* '\x18' */
+ {15, 0x1900},   /* '\x19' */
+ {15, 0x5900},   /* '\x1a' */
+ {15, 0x3900},   /* '\x1b' */
+ {15, 0x7900},   /* '\x1c' */
+ {15, 0x0500},   /* '\x1d' */
+ {15, 0x4500},   /* '\x1e' */
+ {15, 0x2500},   /* '\x1f' */
+ {15, 0x6500},   /* '\x20' */
+ { 8, 0x0040},   /* '!'   */
+ {15, 0x1500},   /* '"'   */
+ {15, 0x5500},   /* '#'   */
+ {15, 0x3500},   /* '$'   */
+ {15, 0x7500},   /* '%'   */
+ {15, 0x0D00},   /* '&'   */
+ {15, 0x4D00},   /* '\''  */
+ {15, 0x2D00},   /* '('   */
+ {15, 0x6D00},   /* ')'   */
+ {11, 0x0300},   /* '*'   */
+ {10, 0x0180},   /* '+'   */
+ {15, 0x1D00},   /* ','   */
+ { 4, 0x000D},   /* '-'   */
+ {15, 0x5D00},   /* '.'   */
+ {10, 0x0380},   /* '/'   */
+ {15, 0x3D00},   /* '0'   */
+ {15, 0x7D00},   /* '1'   */
+ {14, 0x0080},   /* '2'   */
+ {14, 0x2080},   /* '3'   */
+ {14, 0x1080},   /* '4'   */
+ {14, 0x3080},   /* '5'   */
+ {14, 0x0880},   /* '6'   */
+ {14, 0x2880},   /* '7'   */
+ {14, 0x1880},   /* '8'   */
+ {14, 0x3880},   /* '9'   */
+ {14, 0x0480},   /* ':'   */
+ {14, 0x2480},   /* ';'   */
+ { 7, 0x0050},   /* '<'   */
+ { 7, 0x0042},   /* '='   */
+ { 7, 0x0022},   /* '>'   */
+ { 5, 0x0009},   /* '?'   */
+ {14, 0x1480},   /* '@'   */
+ {14, 0x3480},   /* 'A'   */
+ {14, 0x0C80},   /* 'B'   */
+ {14, 0x2C80},   /* 'C'   */
+ {14, 0x1C80},   /* 'D'   */
+ {14, 0x3C80},   /* 'E'   */
+ {14, 0x0280},   /* 'F'   */
+ {14, 0x2280},   /* 'G'   */
+ {14, 0x1280},   /* 'H'   */
+ {14, 0x3280},   /* 'I'   */
+ {14, 0x0A80},   /* 'J'   */
+ {14, 0x2A80},   /* 'K'   */
+ {14, 0x1A80},   /* 'L'   */
+ {14, 0x3A80},   /* 'M'   */
+ {14, 0x0680},   /* 'N'   */
+ {14, 0x2680},   /* 'O'   */
+ {14, 0x1680},   /* 'P'   */
+ {14, 0x3680},   /* 'Q'   */
+ {14, 0x0E80},   /* 'R'   */
+ {14, 0x2E80},   /* 'S'   */
+ {14, 0x1E80},   /* 'T'   */
+ {14, 0x3E80},   /* 'U'   */
+ {14, 0x0200},   /* 'V'   */
+ {14, 0x2200},   /* 'W'   */
+ {14, 0x1200},   /* 'X'   */
+ {14, 0x3200},   /* 'Y'   */
+ {14, 0x0A00},   /* 'Z'   */
+ {14, 0x2A00},   /* '['   */
+ {14, 0x1A00},   /* '\\'  */
+ {14, 0x3A00},   /* ']'   */
+ {14, 0x0600},   /* '^'   */
+ {14, 0x2600},   /* '_'   */
+ {14, 0x1600},   /* '`'   */
+ { 3, 0x0007},   /* 'a'   */
+ { 7, 0x0020},   /* 'b'   */
+ { 4, 0x0004},   /* 'c'   */
+ { 5, 0x001A},   /* 'd'   */
+ { 4, 0x0006},   /* 'e'   */
+ { 7, 0x0002},   /* 'f'   */
+ { 5, 0x0011},   /* 'g'   */
+ { 6, 0x0012},   /* 'h'   */
+ { 4, 0x000C},   /* 'i'   */
+ {12, 0x0400},   /* 'j'   */
+ { 8, 0x00C0},   /* 'k'   */
+ { 5, 0x0018},   /* 'l'   */
+ { 6, 0x0032},   /* 'm'   */
+ { 4, 0x0005},   /* 'n'   */
+ { 5, 0x000A},   /* 'o'   */
+ { 5, 0x0001},   /* 'p'   */
+ { 7, 0x0070},   /* 'q'   */
+ { 3, 0x0003},   /* 'r'   */
+ { 5, 0x0008},   /* 's'   */
+ { 4, 0x000E},   /* 't'   */
+ { 5, 0x0019},   /* 'u'   */
+ { 7, 0x0062},   /* 'v'   */
+ { 7, 0x0030},   /* 'w'   */
+ { 7, 0x0060},   /* 'x'   */
+ { 7, 0x0010},   /* 'y'   */
+ {11, 0x0700},   /* 'z'   */
+ {14, 0x3600},   /* '{'   */
+ {14, 0x0E00},   /* '|'   */
+ {14, 0x2E00},   /* '}'   */
+ {14, 0x1E00},   /* '~'   */
+ {14, 0x3E00},   /* '\x7f' */
diff --git a/include/chibi/sexp-huff.h b/include/chibi/sexp-huff.h
new file mode 100644
index 00000000..abf6bc9f
--- /dev/null
+++ b/include/chibi/sexp-huff.h
@@ -0,0 +1,128 @@
+ {12, 0x0C00},   /* '\x00' */
+ {15, 0x0000},   /* '\x01' */
+ {15, 0x4000},   /* '\x02' */
+ {15, 0x2000},   /* '\x03' */
+ {15, 0x6000},   /* '\x04' */
+ {15, 0x0800},   /* '\x05' */
+ {15, 0x4800},   /* '\x06' */
+ {15, 0x2800},   /* '\x07' */
+ {15, 0x6800},   /* '\x08' */
+ {15, 0x1800},   /* '\x09' */
+ {15, 0x5800},   /* '\x0a' */
+ {15, 0x3800},   /* '\x0b' */
+ {15, 0x7800},   /* '\x0c' */
+ {15, 0x0100},   /* '\x0d' */
+ {15, 0x4100},   /* '\x0e' */
+ {15, 0x2100},   /* '\x0f' */
+ {15, 0x6100},   /* '\x10' */
+ {15, 0x1100},   /* '\x11' */
+ {15, 0x5100},   /* '\x12' */
+ {15, 0x3100},   /* '\x13' */
+ {15, 0x7100},   /* '\x14' */
+ {15, 0x0900},   /* '\x15' */
+ {15, 0x4900},   /* '\x16' */
+ {15, 0x2900},   /* '\x17' */
+ {15, 0x6900},   /* '\x18' */
+ {15, 0x1900},   /* '\x19' */
+ {15, 0x5900},   /* '\x1a' */
+ {15, 0x3900},   /* '\x1b' */
+ {15, 0x7900},   /* '\x1c' */
+ {15, 0x0500},   /* '\x1d' */
+ {15, 0x4500},   /* '\x1e' */
+ {15, 0x2500},   /* '\x1f' */
+ {15, 0x6500},   /* '\x20' */
+ { 8, 0x0040},   /* '!'   */
+ {15, 0x1500},   /* '"'   */
+ {15, 0x5500},   /* '#'   */
+ {15, 0x3500},   /* '$'   */
+ {15, 0x7500},   /* '%'   */
+ {15, 0x0D00},   /* '&'   */
+ {15, 0x4D00},   /* '\''  */
+ {15, 0x2D00},   /* '('   */
+ {15, 0x6D00},   /* ')'   */
+ {11, 0x0300},   /* '*'   */
+ {10, 0x0180},   /* '+'   */
+ {15, 0x1D00},   /* ','   */
+ { 4, 0x000D},   /* '-'   */
+ {15, 0x5D00},   /* '.'   */
+ {10, 0x0380},   /* '/'   */
+ {15, 0x3D00},   /* '0'   */
+ {15, 0x7D00},   /* '1'   */
+ {14, 0x0080},   /* '2'   */
+ {14, 0x2080},   /* '3'   */
+ {14, 0x1080},   /* '4'   */
+ {14, 0x3080},   /* '5'   */
+ {14, 0x0880},   /* '6'   */
+ {14, 0x2880},   /* '7'   */
+ {14, 0x1880},   /* '8'   */
+ {14, 0x3880},   /* '9'   */
+ {14, 0x0480},   /* ':'   */
+ {14, 0x2480},   /* ';'   */
+ { 7, 0x0050},   /* '<'   */
+ { 7, 0x0042},   /* '='   */
+ { 7, 0x0022},   /* '>'   */
+ { 5, 0x0009},   /* '?'   */
+ {14, 0x1480},   /* '@'   */
+ {14, 0x3480},   /* 'A'   */
+ {14, 0x0C80},   /* 'B'   */
+ {14, 0x2C80},   /* 'C'   */
+ {14, 0x1C80},   /* 'D'   */
+ {14, 0x3C80},   /* 'E'   */
+ {14, 0x0280},   /* 'F'   */
+ {14, 0x2280},   /* 'G'   */
+ {14, 0x1280},   /* 'H'   */
+ {14, 0x3280},   /* 'I'   */
+ {14, 0x0A80},   /* 'J'   */
+ {14, 0x2A80},   /* 'K'   */
+ {14, 0x1A80},   /* 'L'   */
+ {14, 0x3A80},   /* 'M'   */
+ {14, 0x0680},   /* 'N'   */
+ {14, 0x2680},   /* 'O'   */
+ {14, 0x1680},   /* 'P'   */
+ {14, 0x3680},   /* 'Q'   */
+ {14, 0x0E80},   /* 'R'   */
+ {14, 0x2E80},   /* 'S'   */
+ {14, 0x1E80},   /* 'T'   */
+ {14, 0x3E80},   /* 'U'   */
+ {14, 0x0200},   /* 'V'   */
+ {14, 0x2200},   /* 'W'   */
+ {14, 0x1200},   /* 'X'   */
+ {14, 0x3200},   /* 'Y'   */
+ {14, 0x0A00},   /* 'Z'   */
+ {14, 0x2A00},   /* '['   */
+ {14, 0x1A00},   /* '\\'  */
+ {14, 0x3A00},   /* ']'   */
+ {14, 0x0600},   /* '^'   */
+ {14, 0x2600},   /* '_'   */
+ {14, 0x1600},   /* '`'   */
+ { 3, 0x0007},   /* 'a'   */
+ { 7, 0x0020},   /* 'b'   */
+ { 4, 0x0004},   /* 'c'   */
+ { 5, 0x001A},   /* 'd'   */
+ { 4, 0x0006},   /* 'e'   */
+ { 7, 0x0002},   /* 'f'   */
+ { 5, 0x0011},   /* 'g'   */
+ { 6, 0x0012},   /* 'h'   */
+ { 4, 0x000C},   /* 'i'   */
+ {12, 0x0400},   /* 'j'   */
+ { 8, 0x00C0},   /* 'k'   */
+ { 5, 0x0018},   /* 'l'   */
+ { 6, 0x0032},   /* 'm'   */
+ { 4, 0x0005},   /* 'n'   */
+ { 5, 0x000A},   /* 'o'   */
+ { 5, 0x0001},   /* 'p'   */
+ { 7, 0x0070},   /* 'q'   */
+ { 3, 0x0003},   /* 'r'   */
+ { 5, 0x0008},   /* 's'   */
+ { 4, 0x000E},   /* 't'   */
+ { 5, 0x0019},   /* 'u'   */
+ { 7, 0x0062},   /* 'v'   */
+ { 7, 0x0030},   /* 'w'   */
+ { 7, 0x0060},   /* 'x'   */
+ { 7, 0x0010},   /* 'y'   */
+ {11, 0x0700},   /* 'z'   */
+ {14, 0x3600},   /* '{'   */
+ {14, 0x0E00},   /* '|'   */
+ {14, 0x2E00},   /* '}'   */
+ {14, 0x1E00},   /* '~'   */
+ {14, 0x3E00},   /* '\x7f' */
diff --git a/include/chibi/sexp-hufftabdefs.h b/include/chibi/sexp-hufftabdefs.h
new file mode 100644
index 00000000..3bf05f3f
--- /dev/null
+++ b/include/chibi/sexp-hufftabdefs.h
@@ -0,0 +1,7 @@
+
+char _huff_tab1[8], _huff_tab2[8], _huff_tab3[2], _huff_tab4[2],
+  _huff_tab5[4], _huff_tab6[2], _huff_tab7[4], _huff_tab8[4],
+  _huff_tab9[4], _huff_tab10[4], _huff_tab11[4], _huff_tab12[2],
+  _huff_tab13[8], _huff_tab14[2], _huff_tab15[8], _huff_tab16[8],
+  _huff_tab17[8], _huff_tab18[8], _huff_tab19[4], _huff_tab20[8],
+  _huff_tab21[8];
diff --git a/include/chibi/sexp-hufftabs.c b/include/chibi/sexp-hufftabs.c
new file mode 100644
index 00000000..7704184f
--- /dev/null
+++ b/include/chibi/sexp-hufftabs.c
@@ -0,0 +1,92 @@
+/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */
+
+char _huff_tab21[] = {
+  '\x01',  '\x00',  '\x03',  '\x00',  '\x02',  '\x00',  '\x04',  '\x00',
+};
+
+char _huff_tab19[] = {
+  '\x01',     'j',  '\x01',  '\x00',
+};
+
+char _huff_tab20[] = {
+  '\x05',  '\x09',  '\x07',  '\x0b',  '\x06',  '\x0a',  '\x08',  '\x0c',
+};
+
+char _huff_tab18[] = {
+     '2',     ':',     '6',     'B',     '4',     '@',     '8',     'D',
+     '3',     ';',     '7',     'C',     '5',     'A',     '9',     'E',
+};
+
+char _huff_tab17[] = {
+  '\x0d',  '\x1d',  '\x15',     '&',  '\x11',     '"',  '\x19',     ',',
+  '\x0f',  '\x1f',  '\x17',     '(',  '\x13',     '$',  '\x1b',     '0',
+  '\x0e',  '\x1e',  '\x16',    '\'',  '\x12',     '#',  '\x1a',     '.',
+  '\x10',  '\x20',  '\x18',     ')',  '\x14',     '%',  '\x1c',     '1',
+};
+
+char _huff_tab16[] = {
+     'V',     '^',     'Z',     '|',     'X',     '`',    '\\',     '~',
+     'W',     '_',     '[',     '}',     'Y',     '{',     ']',  '\x7f',
+};
+
+char _huff_tab15[] = {
+     'F',     'N',     'J',     'R',     'H',     'P',     'L',     'T',
+     'G',     'O',     'K',     'S',     'I',     'Q',     'M',     'U',
+};
+
+char _huff_tab13[] = {
+  '\x00',  '\x00',  '\x00',     '+',  '\x00',  '\x00',  '\x00',     '/',
+};
+
+char _huff_tab14[] = {
+     '*',     'z',
+};
+
+char _huff_tab11[] = {
+  '\x00',     'b',  '\x00',     'x',
+};
+
+char _huff_tab12[] = {
+     '!',     'k',
+};
+
+char _huff_tab9[] = {
+  '\x00',     's',  '\x00',     'l',
+};
+
+char _huff_tab10[] = {
+     'y',     'w',     '<',     'q',
+};
+
+char _huff_tab8[] = {
+     'p',     '?',     'g',     'u',
+};
+
+char _huff_tab7[] = {
+     'f',     '>',     '=',     'v',
+};
+
+char _huff_tab5[] = {
+  '\x00',     'o',  '\x00',     'd',
+};
+
+char _huff_tab6[] = {
+     'h',     'm',
+};
+
+char _huff_tab4[] = {
+     'c',     'i',
+};
+
+char _huff_tab3[] = {
+     'n',     '-',
+};
+
+char _huff_tab1[] = {
+  '\x00',  '\x00',  '\x00',     'r',  '\x00',  '\x00',  '\x00',     'a',
+};
+
+char _huff_tab2[] = {
+     'e',     't',
+};
+
diff --git a/include/chibi/sexp-hufftabs.h b/include/chibi/sexp-hufftabs.h
new file mode 100644
index 00000000..7704184f
--- /dev/null
+++ b/include/chibi/sexp-hufftabs.h
@@ -0,0 +1,92 @@
+/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */
+
+char _huff_tab21[] = {
+  '\x01',  '\x00',  '\x03',  '\x00',  '\x02',  '\x00',  '\x04',  '\x00',
+};
+
+char _huff_tab19[] = {
+  '\x01',     'j',  '\x01',  '\x00',
+};
+
+char _huff_tab20[] = {
+  '\x05',  '\x09',  '\x07',  '\x0b',  '\x06',  '\x0a',  '\x08',  '\x0c',
+};
+
+char _huff_tab18[] = {
+     '2',     ':',     '6',     'B',     '4',     '@',     '8',     'D',
+     '3',     ';',     '7',     'C',     '5',     'A',     '9',     'E',
+};
+
+char _huff_tab17[] = {
+  '\x0d',  '\x1d',  '\x15',     '&',  '\x11',     '"',  '\x19',     ',',
+  '\x0f',  '\x1f',  '\x17',     '(',  '\x13',     '$',  '\x1b',     '0',
+  '\x0e',  '\x1e',  '\x16',    '\'',  '\x12',     '#',  '\x1a',     '.',
+  '\x10',  '\x20',  '\x18',     ')',  '\x14',     '%',  '\x1c',     '1',
+};
+
+char _huff_tab16[] = {
+     'V',     '^',     'Z',     '|',     'X',     '`',    '\\',     '~',
+     'W',     '_',     '[',     '}',     'Y',     '{',     ']',  '\x7f',
+};
+
+char _huff_tab15[] = {
+     'F',     'N',     'J',     'R',     'H',     'P',     'L',     'T',
+     'G',     'O',     'K',     'S',     'I',     'Q',     'M',     'U',
+};
+
+char _huff_tab13[] = {
+  '\x00',  '\x00',  '\x00',     '+',  '\x00',  '\x00',  '\x00',     '/',
+};
+
+char _huff_tab14[] = {
+     '*',     'z',
+};
+
+char _huff_tab11[] = {
+  '\x00',     'b',  '\x00',     'x',
+};
+
+char _huff_tab12[] = {
+     '!',     'k',
+};
+
+char _huff_tab9[] = {
+  '\x00',     's',  '\x00',     'l',
+};
+
+char _huff_tab10[] = {
+     'y',     'w',     '<',     'q',
+};
+
+char _huff_tab8[] = {
+     'p',     '?',     'g',     'u',
+};
+
+char _huff_tab7[] = {
+     'f',     '>',     '=',     'v',
+};
+
+char _huff_tab5[] = {
+  '\x00',     'o',  '\x00',     'd',
+};
+
+char _huff_tab6[] = {
+     'h',     'm',
+};
+
+char _huff_tab4[] = {
+     'c',     'i',
+};
+
+char _huff_tab3[] = {
+     'n',     '-',
+};
+
+char _huff_tab1[] = {
+  '\x00',  '\x00',  '\x00',     'r',  '\x00',  '\x00',  '\x00',     'a',
+};
+
+char _huff_tab2[] = {
+     'e',     't',
+};
+
diff --git a/include/chibi/sexp-unhuff.c b/include/chibi/sexp-unhuff.c
new file mode 100644
index 00000000..fa142e16
--- /dev/null
+++ b/include/chibi/sexp-unhuff.c
@@ -0,0 +1,71 @@
+/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */
+
+res = c & 7;
+c = c >> 3;
+if (res == 0) {
+  res = c & 3;
+  c = c >> 2;
+  if (res == 0) {
+    res = c & 3;
+    c = c >> 2;
+    if (res == 0) {
+      res = c & 7;
+      c = c >> 3;
+      if (res == 0) {
+        res = c & 3;
+        c = c >> 2;
+        if (res == 0) {
+          res = _huff_tab21[c & 7];
+          c = c >> 3;
+        } else if ((res = _huff_tab19[res]) == '\x01') {
+          res = _huff_tab20[c & 7];
+          c = c >> 3;
+        }
+      } else if (res == 1) {
+        res = _huff_tab18[c & 15];
+        c = c >> 4;
+      } else if (res == 2) {
+        res = _huff_tab17[c & 31];
+        c = c >> 5;
+      } else if (res == 4) {
+        res = _huff_tab16[c & 15];
+        c = c >> 4;
+      } else if (res == 5) {
+        res = _huff_tab15[c & 15];
+        c = c >> 4;
+      } else if ((res = _huff_tab13[res]) == '\x00') {
+        res = _huff_tab14[c & 1];
+        c = c >> 1;
+      }
+    } else if ((res = _huff_tab11[res]) == '\x00') {
+      res = _huff_tab12[c & 1];
+      c = c >> 1;
+    }
+  } else if ((res = _huff_tab9[res]) == '\x00') {
+    res = _huff_tab10[c & 3];
+    c = c >> 2;
+  }
+ } else if (res == 1) {
+  res = _huff_tab8[c & 3];
+  c = c >> 2;
+ } else if (res == 2) {
+  res = c & 3;
+  c = c >> 2;
+  if (res == 0) {
+    res = _huff_tab7[c & 3];
+    c = c >> 2;
+  } else if ((res = _huff_tab5[res]) == '\x00') {
+    res = _huff_tab6[c & 1];
+    c = c >> 1;
+  }
+ } else if (res == 4) {
+  res = _huff_tab4[c & 1];
+  c = c >> 1;
+ } else if (res == 5) {
+  res = _huff_tab3[c & 1];
+  c = c >> 1;
+ } else if ((res = _huff_tab1[res]) == '\x00') {
+  res = _huff_tab2[c & 1];
+  c = c >> 1;
+ }
+
diff --git a/include/chibi/sexp-unhuff.h b/include/chibi/sexp-unhuff.h
new file mode 100644
index 00000000..fa142e16
--- /dev/null
+++ b/include/chibi/sexp-unhuff.h
@@ -0,0 +1,71 @@
+/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */
+
+res = c & 7;
+c = c >> 3;
+if (res == 0) {
+  res = c & 3;
+  c = c >> 2;
+  if (res == 0) {
+    res = c & 3;
+    c = c >> 2;
+    if (res == 0) {
+      res = c & 7;
+      c = c >> 3;
+      if (res == 0) {
+        res = c & 3;
+        c = c >> 2;
+        if (res == 0) {
+          res = _huff_tab21[c & 7];
+          c = c >> 3;
+        } else if ((res = _huff_tab19[res]) == '\x01') {
+          res = _huff_tab20[c & 7];
+          c = c >> 3;
+        }
+      } else if (res == 1) {
+        res = _huff_tab18[c & 15];
+        c = c >> 4;
+      } else if (res == 2) {
+        res = _huff_tab17[c & 31];
+        c = c >> 5;
+      } else if (res == 4) {
+        res = _huff_tab16[c & 15];
+        c = c >> 4;
+      } else if (res == 5) {
+        res = _huff_tab15[c & 15];
+        c = c >> 4;
+      } else if ((res = _huff_tab13[res]) == '\x00') {
+        res = _huff_tab14[c & 1];
+        c = c >> 1;
+      }
+    } else if ((res = _huff_tab11[res]) == '\x00') {
+      res = _huff_tab12[c & 1];
+      c = c >> 1;
+    }
+  } else if ((res = _huff_tab9[res]) == '\x00') {
+    res = _huff_tab10[c & 3];
+    c = c >> 2;
+  }
+ } else if (res == 1) {
+  res = _huff_tab8[c & 3];
+  c = c >> 2;
+ } else if (res == 2) {
+  res = c & 3;
+  c = c >> 2;
+  if (res == 0) {
+    res = _huff_tab7[c & 3];
+    c = c >> 2;
+  } else if ((res = _huff_tab5[res]) == '\x00') {
+    res = _huff_tab6[c & 1];
+    c = c >> 1;
+  }
+ } else if (res == 4) {
+  res = _huff_tab4[c & 1];
+  c = c >> 1;
+ } else if (res == 5) {
+  res = _huff_tab3[c & 1];
+  c = c >> 1;
+ } else if ((res = _huff_tab1[res]) == '\x00') {
+  res = _huff_tab2[c & 1];
+  c = c >> 1;
+ }
+
diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h
new file mode 100755
index 00000000..949aa17d
--- /dev/null
+++ b/include/chibi/sexp.h
@@ -0,0 +1,1661 @@
+/*  sexp.h -- header for sexp library                         */
+/*  Copyright (c) 2009-2013 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#ifndef SEXP_H
+#define SEXP_H
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#define SEXP_MODULE_PATH_VAR "CHIBI_MODULE_PATH"
+
+#include "chibi/features.h"
+#include "chibi/install.h"
+
+#if defined(_WIN32) || defined(__MINGW32__)
+#include <windows.h>
+#define sexp_isalpha(x) ((isalpha)((int)(x)))
+#define sexp_isxdigit(x) ((isxdigit)((int)(x)))
+#define sexp_isdigit(x) ((isdigit)((int)(x)))
+#define sexp_tolower(x) ((tolower)((int)(x)))
+#define sexp_toupper(x) ((toupper)((int)(x)))
+#else
+#if SEXP_USE_DL
+#include <dlfcn.h>
+#endif
+#ifndef PLAN9
+#include <errno.h>
+#include <unistd.h>
+#endif
+#if SEXP_USE_GREEN_THREADS
+#include <sys/time.h>
+#include <fcntl.h>
+#include <poll.h>
+#endif
+#define sexp_isalpha(x) (isalpha(x))
+#define sexp_isxdigit(x) (isxdigit(x))
+#define sexp_isdigit(x) (isdigit(x))
+#define sexp_tolower(x) (tolower(x))
+#define sexp_toupper(x) (toupper(x))
+#endif
+
+#if SEXP_USE_GC_FILE_DESCRIPTORS
+#define sexp_out_of_file_descriptors() (errno == EMFILE)
+#else
+#define sexp_out_of_file_descriptors() (0)
+#endif
+
+#ifdef __GNUC__
+#define SEXP_NO_WARN_UNUSED __attribute__((unused))
+#else
+#define SEXP_NO_WARN_UNUSED
+#endif
+
+#ifdef PLAN9
+#include <u.h>
+#include <libc.h>
+#include <fcall.h>
+#include <thread.h>
+#include <9p.h>
+typedef unsigned long size_t;
+#else
+#include <stddef.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdarg.h>
+#include <sys/socket.h>
+#include <sys/stat.h>
+#include <sys/types.h>
+#include <math.h>
+#if SEXP_USE_FLONUMS
+#include <float.h>
+#include <limits.h>
+#endif
+#endif
+
+#if SEXP_USE_TRACK_ALLOC_BACKTRACE
+#include <execinfo.h>
+#endif
+
+#include <ctype.h>
+#include <stdio.h>
+
+/* tagging system
+ *   bits end in    00:  pointer
+ *                  01:  fixnum
+ *                 011:  immediate flonum (optional)
+ *                 111:  immediate symbol (optional)
+ *              000110:  char
+ *              001110:  unique immediate (NULL, TRUE, FALSE)
+ */
+
+#define SEXP_FIXNUM_BITS 2
+#define SEXP_IMMEDIATE_BITS 3
+#define SEXP_EXTENDED_BITS 6
+
+#define SEXP_FIXNUM_MASK 3
+#define SEXP_IMMEDIATE_MASK 7
+#define SEXP_EXTENDED_MASK 63
+
+#define SEXP_POINTER_TAG 0
+#define SEXP_FIXNUM_TAG 1
+#define SEXP_ISYMBOL_TAG 7
+#define SEXP_IFLONUM_TAG 3
+#define SEXP_CHAR_TAG 6
+#define SEXP_EXTENDED_TAG 14
+
+#ifndef SEXP_POINTER_MAGIC
+#define SEXP_POINTER_MAGIC 0xFDCA9764uL /* arbitrary */
+#endif
+
+#if SEXP_USE_HASH_SYMS
+#define SEXP_SYMBOL_TABLE_SIZE 389
+#else
+#define SEXP_SYMBOL_TABLE_SIZE 1
+#endif
+
+enum sexp_types {
+  SEXP_OBJECT,
+  SEXP_TYPE,
+  SEXP_FIXNUM,
+  SEXP_NUMBER,
+  SEXP_CHAR,
+  SEXP_BOOLEAN,
+  SEXP_PAIR,
+  SEXP_SYMBOL,
+  SEXP_BYTES,
+  SEXP_STRING,
+  SEXP_VECTOR,
+  SEXP_FLONUM,
+  SEXP_BIGNUM,
+#if SEXP_USE_RATIOS
+  SEXP_RATIO,
+#endif
+#if SEXP_USE_COMPLEX
+  SEXP_COMPLEX,
+#endif
+  SEXP_IPORT,
+  SEXP_OPORT,
+  SEXP_FILENO,
+  SEXP_EXCEPTION,
+  SEXP_PROCEDURE,
+  SEXP_MACRO,
+  SEXP_SYNCLO,
+  SEXP_ENV,
+  SEXP_BYTECODE,
+  SEXP_CORE,
+#if SEXP_USE_DL
+  SEXP_DL,
+#endif
+  SEXP_OPCODE,
+  SEXP_LAMBDA,
+  SEXP_CND,
+  SEXP_REF,
+  SEXP_SET,
+  SEXP_SEQ,
+  SEXP_LIT,
+  SEXP_STACK,
+  SEXP_CONTEXT,
+  SEXP_CPOINTER,
+#if SEXP_USE_AUTO_FORCE
+  SEXP_PROMISE,
+#endif
+#if SEXP_USE_WEAK_REFERENCES
+  SEXP_EPHEMERON,
+#endif
+  SEXP_NUM_CORE_TYPES
+};
+
+/* procedure flags */
+#define SEXP_PROC_NONE 0uL
+#define SEXP_PROC_VARIADIC 1uL
+#define SEXP_PROC_UNUSED_REST 2uL
+
+#ifdef _WIN32
+typedef unsigned short sexp_tag_t;
+typedef SIZE_T sexp_uint_t;
+typedef SSIZE_T sexp_sint_t;
+#define sexp_heap_align(n) sexp_align(n, 5)
+#elif SEXP_64_BIT
+typedef unsigned int sexp_tag_t;
+typedef unsigned long sexp_uint_t;
+typedef long sexp_sint_t;
+#define sexp_heap_align(n) sexp_align(n, 5)
+#elif defined(__CYGWIN__)
+typedef unsigned short sexp_tag_t;
+typedef unsigned int sexp_uint_t;
+typedef int sexp_sint_t;
+#define sexp_heap_align(n) sexp_align(n, 5)
+#else
+typedef unsigned short sexp_tag_t;
+typedef unsigned int sexp_uint_t;
+typedef int sexp_sint_t;
+#define sexp_heap_align(n) sexp_align(n, 4)
+#endif
+
+#if SEXP_USE_LONG_PROCEDURE_ARGS
+typedef int sexp_proc_num_args_t;
+#else
+typedef short sexp_proc_num_args_t;
+#endif
+
+typedef struct sexp_struct *sexp;
+
+#define sexp_heap_pad_size(s) (sizeof(struct sexp_heap_t) + (s) + sexp_heap_align(1))
+#define sexp_free_chunk_size (sizeof(struct sexp_free_list_t))
+#define sexp_heap_first_block(h) ((sexp)(h->data + sexp_heap_align(sexp_free_chunk_size)))
+#define sexp_heap_last_block(h) ((sexp)((char*)h->data + h->size - sexp_heap_align(sexp_free_chunk_size)))
+#define sexp_heap_end(h) ((sexp)((char*)h->data + h->size))
+
+#define __HALF_MAX_SIGNED(type) ((type)1 << (sizeof(type)*8-2))
+#define __MAX_SIGNED(type) (__HALF_MAX_SIGNED(type) - 1 + __HALF_MAX_SIGNED(type))
+#define __MIN_SIGNED(type) (-1 - __MAX_SIGNED(type))
+
+#define SEXP_UINT_T_MAX ((sexp_uint_t)-1)
+#define SEXP_UINT_T_MIN (0)
+#define SEXP_SINT_T_MAX __MAX_SIGNED(sexp_sint_t)
+#define SEXP_SINT_T_MIN __MIN_SIGNED(sexp_sint_t)
+
+#define SEXP_MAX_FIXNUM ((((sexp_sint_t)1)<<(sizeof(sexp_sint_t)*8-SEXP_FIXNUM_BITS-1))-1)
+#define SEXP_MIN_FIXNUM (-SEXP_MAX_FIXNUM-1)
+
+#if SEXP_USE_SELF_PARAMETER
+#define sexp_api_params(self, n) , sexp self, sexp_sint_t n
+#define sexp_api_pass(self, n) , self, n
+#else
+#define sexp_api_params(self, n)
+#define sexp_api_pass(self, n)
+#endif
+
+/* procedure types */
+typedef sexp (*sexp_proc1) (sexp, sexp, sexp_sint_t);
+typedef sexp (*sexp_proc2) (sexp, sexp, sexp_sint_t, sexp);
+typedef sexp (*sexp_proc3) (sexp, sexp, sexp_sint_t, sexp, sexp);
+typedef sexp (*sexp_proc4) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp);
+typedef sexp (*sexp_proc5) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp);
+typedef sexp (*sexp_proc6) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp);
+typedef sexp (*sexp_proc7) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp);
+typedef sexp (*sexp_init_proc)(sexp, sexp, sexp_sint_t, sexp, const char*, const sexp_abi_identifier_t);
+
+typedef struct sexp_free_list_t *sexp_free_list;
+struct sexp_free_list_t {
+  sexp_uint_t size;
+  sexp_free_list next;
+};
+
+typedef struct sexp_heap_t *sexp_heap;
+struct sexp_heap_t {
+  sexp_uint_t size, max_size;
+  sexp_free_list free_list;
+  sexp_heap next;
+  /* note this must be aligned on a proper heap boundary, */
+  /* so we can't just use char data[] */
+  char *data;
+};
+
+struct sexp_gc_var_t {
+  sexp *var;
+#if SEXP_USE_DEBUG_GC
+  char *name;
+#endif
+  struct sexp_gc_var_t *next;
+};
+
+struct sexp_library_entry_t {   /* for static builds */
+  const char *name;
+  sexp_init_proc init;
+};
+
+struct sexp_type_struct {
+  sexp_tag_t tag;
+  short field_base, field_eq_len_base, field_len_base, field_len_off;
+  unsigned short field_len_scale;
+  short size_base, size_off;
+  unsigned short size_scale;
+  short weak_base, weak_len_base, weak_len_off, weak_len_scale, weak_len_extra;
+  short depth;
+  sexp name, cpl, slots, getters, setters, dl, id, print;
+  sexp_proc2 finalize;
+};
+
+struct sexp_opcode_struct {
+  unsigned char op_class, code, num_args, flags, inverse;
+  sexp name, data, data2, proc, ret_type, arg1_type, arg2_type, arg3_type,
+    argn_type, methods, dl;
+  sexp_proc1 func;
+};
+
+struct sexp_core_form_struct {
+  char code;
+  sexp name;
+};
+
+struct sexp_struct {
+  sexp_tag_t tag;
+  char markedp;
+  unsigned int immutablep:1;
+  unsigned int freep:1;
+  unsigned int brokenp:1;
+  unsigned int syntacticp:1;
+#if SEXP_USE_TRACK_ALLOC_SOURCE
+  const char* source;
+  void* backtrace[SEXP_BACKTRACE_SIZE];
+#endif
+#if SEXP_USE_HEADER_MAGIC
+  unsigned int magic;
+#endif
+  union {
+    /* basic types */
+    double flonum;
+    char flonum_bits[sizeof(double)];  /* for eqv? comparison on flonums */
+    struct sexp_type_struct type;
+    struct {
+      sexp car, cdr;
+      sexp source;
+    } pair;
+    struct {
+      sexp_uint_t length;
+      sexp data[];
+    } vector;
+    struct {
+      sexp_uint_t length;
+      char data[];
+    } bytes;
+    struct {
+#if SEXP_USE_PACKED_STRINGS
+      sexp_uint_t length;
+      char data[];
+#else
+      sexp_uint_t offset, length;
+      sexp bytes;
+#endif
+    } string;
+    struct {
+      sexp_uint_t length;
+      char data[];
+    } symbol;
+    struct {
+      FILE *stream;
+      char *buf;
+      char openp, bidirp, binaryp, shutdownp, no_closep, sourcep,
+        blockedp, fold_casep;
+      sexp_uint_t offset, line, flags;
+      size_t size;
+      sexp name;
+      sexp cookie;
+      sexp fd;
+    } port;
+    struct {
+      char openp, no_closep;
+      sexp_sint_t fd, count;
+    } fileno;
+    struct {
+      sexp kind, message, irritants, procedure, source;
+    } exception;
+    struct {
+      signed char sign;
+      sexp_uint_t length;
+      sexp_uint_t data[];
+    } bignum;
+    struct {
+      sexp numerator, denominator;
+    } ratio;
+    struct {
+      sexp real, imag;
+    } complex;
+    struct {
+      sexp_uint_t length;
+      void *value;
+      sexp parent;
+      char body[];
+    } cpointer;
+    /* runtime types */
+    struct {
+      sexp parent, lambda, bindings;
+#if SEXP_USE_RENAME_BINDINGS
+      sexp renames;
+#endif
+    } env;
+    struct {
+      sexp_uint_t length, max_depth;
+      sexp name, literals, source;
+      unsigned char data[];
+    } bytecode;
+    struct {
+      char flags;
+      sexp_proc_num_args_t num_args;
+      sexp bc, vars;
+    } procedure;
+    struct {
+      sexp proc, env, source;
+    } macro;
+    struct {
+      sexp env, free_vars, expr;
+    } synclo;
+    struct {
+      sexp file;
+      void* handle;
+    } dl;
+    struct sexp_opcode_struct opcode;
+    struct sexp_core_form_struct core;
+    /* ast types */
+    struct {
+      sexp name, params, body, defs, locals, flags, fv, sv, ret, types, source;
+    } lambda;
+    struct {
+      sexp test, pass, fail, source;
+    } cnd;
+    struct {
+      sexp var, value, source;
+    } set;
+    struct {
+      sexp name, cell, source;
+    } ref;
+    struct {
+      sexp ls, source;
+    } seq;
+    struct {
+      sexp value, source;
+    } lit;
+    /* compiler state */
+    struct {
+      sexp_uint_t length, top;
+      sexp data[];
+    } stack;
+    struct {
+      sexp_heap heap;
+      struct sexp_gc_var_t *saves;
+#if SEXP_USE_GREEN_THREADS
+      sexp_sint_t refuel;
+      unsigned char* ip;
+      struct timeval tval;
+#endif
+      char tailp, tracep, timeoutp, waitp, errorp;
+      sexp_uint_t last_fp;
+      sexp stack, env, parent, child,
+        globals, dk, params, proc, name, specific, event, result;
+#if SEXP_USE_DL
+      sexp dl;
+#endif
+    } context;
+#if SEXP_USE_AUTO_FORCE
+    struct {
+      int donep;
+      sexp value;
+    } promise;
+#endif
+  } value;
+};
+
+#define SEXP_MAKE_IMMEDIATE(n)  ((sexp) ((n<<SEXP_EXTENDED_BITS) \
+                                          + SEXP_EXTENDED_TAG))
+
+#define SEXP_FALSE  SEXP_MAKE_IMMEDIATE(0) /* 14 0x0e */
+#define SEXP_TRUE   SEXP_MAKE_IMMEDIATE(1) /* 30 0x1e */
+#define SEXP_NULL   SEXP_MAKE_IMMEDIATE(2) /* 46 0x2e */
+#define SEXP_EOF    SEXP_MAKE_IMMEDIATE(3) /* 62 0x3e */
+#define SEXP_VOID   SEXP_MAKE_IMMEDIATE(4) /* the unspecified value */
+#define SEXP_UNDEF  SEXP_MAKE_IMMEDIATE(5) /* internal use */
+#define SEXP_CLOSE  SEXP_MAKE_IMMEDIATE(6) /* internal use */
+#define SEXP_RAWDOT SEXP_MAKE_IMMEDIATE(7) /* internal use */
+#define SEXP_STRING_OPORT SEXP_MAKE_IMMEDIATE(8)  /* internal use */
+#define SEXP_TRAMPOLINE   SEXP_MAKE_IMMEDIATE(9)  /* internal use */
+#define SEXP_ABI_ERROR    SEXP_MAKE_IMMEDIATE(10) /* internal use */
+#if SEXP_USE_OBJECT_BRACE_LITERALS
+#define SEXP_CLOSE_BRACE  SEXP_MAKE_IMMEDIATE(11) /* internal use */
+#endif
+
+#if SEXP_USE_LIMITED_MALLOC
+void* sexp_malloc(size_t size);
+void sexp_free(void* ptr);
+#else
+#define sexp_malloc malloc
+#define sexp_free free
+#endif
+
+#if SEXP_USE_BOEHM
+
+#define sexp_gc(ctx, sum)
+
+#define sexp_gc_var(x, y)            sexp x = SEXP_VOID;
+#define sexp_gc_preserve(ctx, x, y)
+#define sexp_gc_release(ctx, x, y)
+
+#define sexp_preserve_object(ctx, x)
+#define sexp_release_object(ctx, x)
+
+#include "gc/gc.h"
+#define sexp_alloc(ctx, size)        GC_malloc(size)
+#define sexp_alloc_atomic(ctx, size) GC_malloc_atomic(size)
+
+#else
+
+SEXP_API sexp sexp_gc(sexp ctx, size_t *sum_freed);
+
+#define sexp_gc_var(x, y)                       \
+  sexp x = SEXP_VOID;                           \
+  struct sexp_gc_var_t y = {NULL, NULL};
+
+#if SEXP_USE_DEBUG_GC
+#define sexp_gc_preserve_name(ctx, x, y) (y).name = #x
+#else
+#define sexp_gc_preserve_name(ctx, x, y)
+#endif
+
+#define sexp_gc_preserve(ctx, x, y)     \
+  do {                                  \
+    sexp_gc_preserve_name(ctx, x, y);   \
+    (y).var = &(x);                     \
+    (y).next = sexp_context_saves(ctx); \
+    sexp_context_saves(ctx) = &(y);     \
+  } while (0)
+
+#define sexp_gc_release(ctx, x, y)   (sexp_context_saves(ctx) = y.next)
+
+SEXP_API void sexp_preserve_object(sexp ctx, sexp x);
+SEXP_API void sexp_release_object(sexp ctx, sexp x);
+
+#if SEXP_USE_MALLOC
+#define sexp_alloc(ctx, size)        sexp_malloc(size)
+#define sexp_alloc_atomic(ctx, size) sexp_malloc(size)
+#else  /* native gc */
+void* sexp_alloc(sexp ctx, size_t size);
+#define sexp_alloc_atomic            sexp_alloc
+#endif
+#endif
+
+#define sexp_gc_var1(x) sexp_gc_var(x, __sexp_gc_preserver1)
+#define sexp_gc_var2(x, y) sexp_gc_var1(x) sexp_gc_var(y, __sexp_gc_preserver2)
+#define sexp_gc_var3(x, y, z) sexp_gc_var2(x, y) sexp_gc_var(z, __sexp_gc_preserver3)
+#define sexp_gc_var4(x, y, z, w) sexp_gc_var3(x, y, z) sexp_gc_var(w, __sexp_gc_preserver4)
+#define sexp_gc_var5(x, y, z, w, v) sexp_gc_var4(x, y, z, w) sexp_gc_var(v, __sexp_gc_preserver5)
+#define sexp_gc_var6(x, y, z, w, v, u) sexp_gc_var5(x, y, z, w, v) sexp_gc_var(u, __sexp_gc_preserver6)
+#define sexp_gc_var7(x, y, z, w, v, u, t) sexp_gc_var6(x, y, z, w, v, u) sexp_gc_var(t, __sexp_gc_preserver7)
+
+#define sexp_gc_preserve1(ctx, x) sexp_gc_preserve(ctx, x, __sexp_gc_preserver1)
+#define sexp_gc_preserve2(ctx, x, y) sexp_gc_preserve1(ctx, x); sexp_gc_preserve(ctx, y, __sexp_gc_preserver2)
+#define sexp_gc_preserve3(ctx, x, y, z) sexp_gc_preserve2(ctx, x, y); sexp_gc_preserve(ctx, z, __sexp_gc_preserver3)
+#define sexp_gc_preserve4(ctx, x, y, z, w) sexp_gc_preserve3(ctx, x, y, z); sexp_gc_preserve(ctx, w, __sexp_gc_preserver4)
+#define sexp_gc_preserve5(ctx, x, y, z, w, v) sexp_gc_preserve4(ctx, x, y, z, w); sexp_gc_preserve(ctx, v, __sexp_gc_preserver5)
+#define sexp_gc_preserve6(ctx, x, y, z, w, v, u) sexp_gc_preserve5(ctx, x, y, z, w, v); sexp_gc_preserve(ctx, u, __sexp_gc_preserver6)
+#define sexp_gc_preserve7(ctx, x, y, z, w, v, u, t) sexp_gc_preserve6(ctx, x, y, z, w, v, u); sexp_gc_preserve(ctx, t, __sexp_gc_preserver7)
+
+#define sexp_gc_release1(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1)
+#define sexp_gc_release2(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1)
+#define sexp_gc_release3(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1)
+#define sexp_gc_release4(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1)
+#define sexp_gc_release5(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1)
+#define sexp_gc_release6(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1)
+#define sexp_gc_release7(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1)
+
+#define sexp_align(n, bits) (((n)+(1<<(bits))-1)&(((sexp_uint_t)-1)-((1<<(bits))-1)))
+
+#if SEXP_64_BIT
+#define sexp_word_align(n) sexp_align((n), 3)
+#else
+#define sexp_word_align(n) sexp_align((n), 2)
+#endif
+
+#define sexp_sizeof(x) (offsetof(struct sexp_struct, value) \
+                         + sizeof(((sexp)0)->value.x))
+#define sexp_offsetof(type, f) (offsetof(struct sexp_struct, value.type.f))
+#define sexp_offsetof_slot0 (offsetof(struct sexp_struct, value))
+#define sexp_sizeof_header (sexp_sizeof(flonum) - sizeof(double))
+
+#if SEXP_USE_TRACK_ALLOC_SOURCE
+#define sexp_with_current_source0(file, line) file ": " #line
+#define sexp_with_current_source(file, line) , sexp_with_current_source0(file, line)
+#else
+#define sexp_with_current_source(file, line)
+#endif
+
+#define sexp_alloc_tagged(ctx, size, tag) sexp_alloc_tagged_aux(ctx, size, tag sexp_with_current_source(__FILE__, __LINE__))
+
+#define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag)
+#define sexp_alloc_bytecode(ctx, i) sexp_alloc_tagged(ctx, sexp_sizeof(bytecode) + i, SEXP_BYTECODE)
+
+#if SEXP_USE_BIGNUMS
+#include "chibi/bignum.h"
+#endif
+
+/***************************** predicates *****************************/
+
+#define sexp_truep(x)    ((x) != SEXP_FALSE)
+#define sexp_not(x)      ((x) == SEXP_FALSE)
+
+#define sexp_nullp(x)    ((x) == SEXP_NULL)
+#define sexp_pointerp(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG)
+#define sexp_fixnump(x)  (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_FIXNUM_TAG)
+#define sexp_isymbolp(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_ISYMBOL_TAG)
+#define sexp_charp(x)    (((sexp_uint_t)(x) & SEXP_EXTENDED_MASK) == SEXP_CHAR_TAG)
+#define sexp_booleanp(x) (((x) == SEXP_TRUE) || ((x) == SEXP_FALSE))
+
+#define sexp_pointer_tag(x)      ((x)->tag)
+#define sexp_markedp(x)          ((x)->markedp)
+#define sexp_flags(x)            ((x)->flags)
+#define sexp_immutablep(x)       ((x)->immutablep)
+#define sexp_freep(x)            ((x)->freep)
+#define sexp_brokenp(x)          ((x)->brokenp)
+#define sexp_pointer_magic(x)    ((x)->magic)
+
+#if SEXP_USE_TRACK_ALLOC_SOURCE
+#define sexp_pointer_source(x)   ((x)->source)
+#else
+#define sexp_pointer_source(x)   ""
+#endif
+
+#define sexp_check_tag(x,t)  (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t)))
+
+#define sexp_slot_ref(x,i)   (((sexp*)&((x)->value))[i])
+#define sexp_slot_set(x,i,v) (((sexp*)&((x)->value))[i] = (v))
+
+#define sexp_isa(a, b) (sexp_pointerp(a) && sexp_typep(b) && (sexp_pointer_tag(a) == sexp_type_tag(b)))
+
+#if SEXP_USE_IMMEDIATE_FLONUMS
+union sexp_flonum_conv {
+  float flonum;
+  unsigned int bits;
+};
+#define sexp_flonump(x)      (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_IFLONUM_TAG)
+SEXP_API sexp sexp_flonum_predicate (sexp ctx, sexp x);
+#if SEXP_64_BIT
+SEXP_API float sexp_flonum_value (sexp x);
+#define sexp_flonum_bits(f) ((char*)&f)
+SEXP_API sexp sexp_make_flonum(sexp ctx, float f);
+#else
+#define sexp_make_flonum(ctx, x)  ((sexp) ((((union sexp_flonum_conv)((float)(x))).bits & ~SEXP_IMMEDIATE_MASK) + SEXP_IFLONUM_TAG))
+#define sexp_flonum_value(x) (((union sexp_flonum_conv)(((unsigned int)(x)) & ~SEXP_IMMEDIATE_MASK)).flonum)
+#endif
+#else
+#define sexp_flonump(x)      (sexp_check_tag(x, SEXP_FLONUM))
+#define sexp_flonum_value(f) ((f)->value.flonum)
+#define sexp_flonum_bits(f) ((f)->value.flonum_bits)
+sexp sexp_make_flonum(sexp ctx, double f);
+#endif
+
+#define sexp_typep(x)       (sexp_check_tag(x, SEXP_TYPE))
+#define sexp_pairp(x)       (sexp_check_tag(x, SEXP_PAIR))
+#define sexp_stringp(x)     (sexp_check_tag(x, SEXP_STRING))
+#define sexp_lsymbolp(x)    (sexp_check_tag(x, SEXP_SYMBOL))
+#define sexp_bytesp(x)      (sexp_check_tag(x, SEXP_BYTES))
+#define sexp_vectorp(x)     (sexp_check_tag(x, SEXP_VECTOR))
+#define sexp_iportp(x)      (sexp_check_tag(x, SEXP_IPORT))
+#if SEXP_USE_BIDIRECTIONAL_PORTS
+#define sexp_oportp(x)      (sexp_check_tag(x, SEXP_OPORT) || (sexp_check_tag(x, SEXP_IPORT) && sexp_port_bidirp(x)))
+#else
+#define sexp_oportp(x)      (sexp_check_tag(x, SEXP_OPORT))
+#endif
+#define sexp_filenop(x)     (sexp_check_tag(x, SEXP_FILENO))
+#if SEXP_USE_BIGNUMS
+#define sexp_bignump(x)     (sexp_check_tag(x, SEXP_BIGNUM))
+#else
+#define sexp_bignump(x)     0
+#endif
+#if SEXP_USE_RATIOS
+#define sexp_ratiop(x)      (sexp_check_tag(x, SEXP_RATIO))
+#else
+#define sexp_ratiop(x)      0
+#endif
+#if SEXP_USE_COMPLEX
+#define sexp_complexp(x)    (sexp_check_tag(x, SEXP_COMPLEX))
+#else
+#define sexp_complexp(x)    0
+#endif
+#define sexp_cpointerp(x)   (sexp_check_tag(x, SEXP_CPOINTER))
+#define sexp_exceptionp(x)  (sexp_check_tag(x, SEXP_EXCEPTION))
+#define sexp_procedurep(x)  (sexp_check_tag(x, SEXP_PROCEDURE))
+#define sexp_envp(x)        (sexp_check_tag(x, SEXP_ENV))
+#define sexp_bytecodep(x)   (sexp_check_tag(x, SEXP_BYTECODE))
+#define sexp_corep(x)       (sexp_check_tag(x, SEXP_CORE))
+#define sexp_dlp(x)         (sexp_check_tag(x, SEXP_DL))
+#define sexp_opcodep(x)     (sexp_check_tag(x, SEXP_OPCODE))
+#define sexp_macrop(x)      (sexp_check_tag(x, SEXP_MACRO))
+#define sexp_syntacticp(x)  (sexp_corep(x) || sexp_macrop(x))
+#define sexp_synclop(x)     (sexp_check_tag(x, SEXP_SYNCLO))
+#define sexp_lambdap(x)     (sexp_check_tag(x, SEXP_LAMBDA))
+#define sexp_cndp(x)        (sexp_check_tag(x, SEXP_CND))
+#define sexp_refp(x)        (sexp_check_tag(x, SEXP_REF))
+#define sexp_setp(x)        (sexp_check_tag(x, SEXP_SET))
+#define sexp_seqp(x)        (sexp_check_tag(x, SEXP_SEQ))
+#define sexp_litp(x)        (sexp_check_tag(x, SEXP_LIT))
+#define sexp_contextp(x)    (sexp_check_tag(x, SEXP_CONTEXT))
+#define sexp_promisep(x)    (sexp_check_tag(x, SEXP_PROMISE))
+#define sexp_ephemeronp(x)  (sexp_check_tag(x, SEXP_EPHEMERON))
+
+#define sexp_applicablep(x) (sexp_procedurep(x) || sexp_opcodep(x))
+
+#if SEXP_USE_HUFF_SYMS
+#define sexp_symbolp(x)     (sexp_isymbolp(x) || sexp_lsymbolp(x))
+#else
+#define sexp_symbolp(x)     (sexp_lsymbolp(x))
+#endif
+
+SEXP_API int sexp_idp(sexp x);
+
+#define sexp_portp(x) (sexp_check_tag(x, SEXP_IPORT) || sexp_check_tag(x, SEXP_OPORT))
+
+#if SEXP_USE_STRING_STREAMS
+#define sexp_stream_portp(x) 1
+#else
+#define sexp_stream_portp(x) (sexp_port_stream(x) != NULL)
+#endif
+
+#define sexp_port_customp(x) (sexp_vectorp(sexp_port_cookie(x)) && sexp_vector_length(sexp_port_cookie(x)) == 6)
+
+/* only valid on custom ports */
+#define sexp_port_buffer(x)  (sexp_vector_ref(sexp_port_cookie(x), SEXP_ONE))
+#define sexp_port_reader(x)  (sexp_vector_ref(sexp_port_cookie(x), SEXP_TWO))
+#define sexp_port_writer(x)  (sexp_vector_ref(sexp_port_cookie(x), SEXP_THREE))
+#define sexp_port_seeker(x)  (sexp_vector_ref(sexp_port_cookie(x), SEXP_FOUR))
+#define sexp_port_closer(x)  (sexp_vector_ref(sexp_port_cookie(x), SEXP_FIVE))
+
+/***************************** constructors ****************************/
+
+#define sexp_make_boolean(x) ((x) ? SEXP_TRUE : SEXP_FALSE)
+#define sexp_unbox_boolean(x) (((x) == SEXP_FALSE) ? 0 : 1)
+
+#define sexp_make_fixnum(n)    ((sexp) ((((sexp_sint_t)(n))<<SEXP_FIXNUM_BITS) + SEXP_FIXNUM_TAG))
+#define sexp_unbox_fixnum(n)   (((sexp_sint_t)(n))>>SEXP_FIXNUM_BITS)
+
+#define SEXP_NEG_ONE sexp_make_fixnum(-1)
+#define SEXP_ZERO    sexp_make_fixnum(0)
+#define SEXP_ONE     sexp_make_fixnum(1)
+#define SEXP_TWO     sexp_make_fixnum(2)
+#define SEXP_THREE   sexp_make_fixnum(3)
+#define SEXP_FOUR    sexp_make_fixnum(4)
+#define SEXP_FIVE    sexp_make_fixnum(5)
+#define SEXP_SIX     sexp_make_fixnum(6)
+#define SEXP_SEVEN   sexp_make_fixnum(7)
+#define SEXP_EIGHT   sexp_make_fixnum(8)
+#define SEXP_NINE    sexp_make_fixnum(9)
+#define SEXP_TEN     sexp_make_fixnum(10)
+
+#define sexp_make_character(n)  ((sexp) ((((sexp_sint_t)(n))<<SEXP_EXTENDED_BITS) + SEXP_CHAR_TAG))
+#define sexp_unbox_character(n) ((int) (((sexp_sint_t)(n))>>SEXP_EXTENDED_BITS))
+
+#define sexp_fixnum_to_double(x) ((double)sexp_unbox_fixnum(x))
+
+#if SEXP_USE_PLACEHOLDER_DIGITS
+#define sexp_placeholder_digit_p(c) ((c) == SEXP_PLACEHOLDER_DIGIT)
+#else
+#define sexp_placeholder_digit_p(c) 0
+#endif
+
+#define sexp_placeholder_digit_value(base) ((base)/2)
+
+#if SEXP_USE_FLONUMS
+#define sexp_fp_integerp(x) (sexp_flonum_value(x) == trunc(sexp_flonum_value(x)))
+#define _or_integer_flonump(x) || (sexp_flonump(x) && sexp_fp_integerp(x))
+#else
+#define _or_integer_flonump(x)
+#endif
+
+#if SEXP_USE_BIGNUMS
+SEXP_API sexp sexp_make_integer(sexp ctx, sexp_lsint_t x);
+SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
+#define sexp_exact_integerp(x) (sexp_fixnump(x) || sexp_bignump(x))
+#else
+#define sexp_make_integer(ctx, x) sexp_make_fixnum(x)
+#define sexp_make_unsigned_integer(ctx, x) sexp_make_fixnum(x)
+#define sexp_exact_integerp(x) sexp_fixnump(x)
+#endif
+
+#define sexp_integerp(x) (sexp_exact_integerp(x) _or_integer_flonump(x))
+
+#if SEXP_USE_RATIOS
+#define sexp_exactp(x) (sexp_exact_integerp(x) || sexp_ratiop(x))
+#else
+#define sexp_exactp(x) sexp_exact_integerp(x)
+#endif
+
+#if SEXP_USE_FLONUMS
+#define sexp_fixnum_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_fixnum(x)))
+#if SEXP_USE_RATIOS
+#define sexp_realp(x) (sexp_exact_integerp(x) || sexp_flonump(x) || sexp_ratiop(x))
+#else
+#define sexp_realp(x) (sexp_exact_integerp(x) || sexp_flonump(x))
+#endif
+#else
+#define sexp_fixnum_to_flonum(ctx, x) (x)
+#define sexp_realp(x) sexp_exact_integerp(x)
+#endif
+
+#if SEXP_USE_COMPLEX
+#define sexp_numberp(x) (sexp_realp(x) || sexp_complexp(x))
+#else
+#define sexp_numberp(x) (sexp_realp(x))
+#endif
+
+#define sexp_exact_negativep(x) (sexp_fixnump(x) ? (sexp_unbox_fixnum(x) < 0) \
+                                 : ((SEXP_USE_BIGNUMS && sexp_bignump(x)) \
+                                    && (sexp_bignum_sign(x) < 0)))
+#define sexp_negativep(x) (sexp_exact_negativep(x) ||                   \
+                           (sexp_flonump(x) && sexp_flonum_value(x) < 0))
+#define sexp_positivep(x) (!(sexp_negativep(x)))
+
+#if SEXP_USE_BIGNUMS
+#define sexp_oddp(x) (sexp_fixnump(x) ? sexp_unbox_fixnum(x) & 1 : \
+                      sexp_bignump(x) && (sexp_bignum_data(x)[0] & 1))
+#else
+#define sexp_oddp(x) (sexp_fixnump(x) && (sexp_unbox_fixnum(x) & 1))
+#endif
+#define sexp_evenp(x) (!(sexp_oddp(x)))
+
+#define sexp_negate_exact(x)                            \
+  if (sexp_bignump(x))                                  \
+    sexp_bignum_sign(x) = -sexp_bignum_sign(x);         \
+  else if (sexp_fixnump(x))                             \
+    x = sexp_fx_neg(x);
+
+#if SEXP_USE_IMMEDIATE_FLONUMS
+#define sexp_negate_flonum(x) (x) = sexp_make_flonum(NULL, -(sexp_flonum_value(x)))
+#else
+#define sexp_negate_flonum(x) sexp_flonum_value(x) = -(sexp_flonum_value(x))
+#endif
+
+#define sexp_negate(x)                                  \
+  if (sexp_flonump(x))                                  \
+    sexp_negate_flonum(x);                              \
+  else                                                  \
+    sexp_negate_exact(x)
+
+#if SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS
+#define sexp_uint_value(x) ((sexp_uint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_data(x)[0]))
+#define sexp_sint_value(x) ((sexp_sint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_sign(x)*sexp_bignum_data(x)[0]))
+#else
+#define sexp_uint_value(x) ((sexp_uint_t)sexp_unbox_fixnum(x))
+#define sexp_sint_value(x) ((sexp_sint_t)sexp_unbox_fixnum(x))
+#endif
+
+#define sexp_shift_epoch(x) ((x)-SEXP_EPOCH_OFFSET)
+#define sexp_unshift_epoch(x) ((x)+SEXP_EPOCH_OFFSET)
+
+#define sexp_infp(x) (sexp_flonump(x) && isinf(sexp_flonum_value(x)))
+#define sexp_nanp(x) (sexp_flonump(x) && isnan(sexp_flonum_value(x)))
+
+#if SEXP_USE_IEEE_EQV
+#define sexp_flonum_eqv(x, y) (memcmp(sexp_flonum_bits(x), sexp_flonum_bits(y), sizeof(double)) == 0)
+#else
+#define sexp_flonum_eqv(x, y) (sexp_flonum_value(x) == sexp_flonum_value(y))
+#endif
+
+/*************************** field accessors **************************/
+
+#if SEXP_USE_SAFE_ACCESSORS
+#if 0
+#define sexp_field(x, type, id, field) (*(((x) && sexp_check_tag(x, id)) ? &((x)->value.type.field) : (fprintf(stderr, "invalid field access in %s line %d: %p (%d) isn't a "#type"\n", __FILE__, __LINE__, x, (int)(sexp_pointerp(x) ? sexp_pointer_tag(x) : -1)), &(((sexp)NULL)->value.type.field))))
+#define sexp_pred_field(x, type, pred, field) (*(((x) && pred(x)) ? &((x)->value.type.field) : (fprintf(stderr, "invalid field access in %s line %d: %p (%d) isn't a "#type"\n", __FILE__, __LINE__, x, (int)(sexp_pointerp(x) ? sexp_pointer_tag(x) : -1)), &(((sexp)NULL)->value.type.field))))
+#define sexp_cpointer_field(x, field) (*(((x) && sexp_pointerp(x) && sexp_pointer_tag(x) >= SEXP_CPOINTER) ? &((x)->value.cpointer.field) : (fprintf(stderr, "invalid field access in %s line %d: %p (%d) isn't a cpointer\n", __FILE__, __LINE__, x, (int)(sexp_pointerp(x) ? sexp_pointer_tag(x) : -1)), &(((sexp)NULL)->value.cpointer.field))))
+#else
+#define sexp_field(x, type, id, field) (*({sexp _x=x; (((_x) && sexp_check_tag(_x, id)) ? &((_x)->value.type.field) : (fprintf(stderr, "invalid field access in %s line %d: %p (%d) isn't a "#type"\n", __FILE__, __LINE__, _x, (int)(sexp_pointerp(_x) ? sexp_pointer_tag(_x) : -1)), &(((sexp)NULL)->value.type.field)));}))
+#define sexp_pred_field(x, type, pred, field) (*({sexp _x=x; (((_x) && pred(_x)) ? &((_x)->value.type.field) : (fprintf(stderr, "invalid field access in %s line %d: %p (%d) isn't a "#type"\n", __FILE__, __LINE__, _x, (int)(sexp_pointerp(_x) ? sexp_pointer_tag(_x) : -1)), &(((sexp)NULL)->value.type.field)));}))
+#define sexp_cpointer_field(x, field) (*({sexp _x=x; (((_x) && sexp_pointerp(_x) && sexp_pointer_tag(_x) >= SEXP_CPOINTER) ? &((_x)->value.cpointer.field) : (fprintf(stderr, "invalid field access in %s line %d: %p (%d) isn't a cpointer\n", __FILE__, __LINE__, _x, (int)(sexp_pointerp(_x) ? sexp_pointer_tag(_x) : -1)), &(((sexp)NULL)->value.cpointer.field)));}))
+#endif
+#else
+#define sexp_field(x, type, id, field) ((x)->value.type.field)
+#define sexp_pred_field(x, type, pred, field) ((x)->value.type.field)
+#define sexp_cpointer_field(x, field) ((x)->value.cpointer.field)
+#endif
+
+#define sexp_vector_length(x) (sexp_field(x, vector, SEXP_VECTOR, length))
+#define sexp_vector_data(x)   (sexp_field(x, vector, SEXP_VECTOR, data))
+
+#if SEXP_USE_SAFE_VECTOR_ACCESSORS
+#define sexp_vector_ref(x,i)   (sexp_unbox_fixnum(i)>=0 && sexp_unbox_fixnum(i)<sexp_vector_length(x) ? sexp_vector_data(x)[sexp_unbox_fixnum(i)] : (fprintf(stderr, "vector-ref length out of range %s on line %d: vector %p (length %lu): %ld\n", __FILE__, __LINE__, x, sexp_vector_length(x), sexp_unbox_fixnum(i)), SEXP_VOID))
+#define sexp_vector_set(x,i,v) (sexp_unbox_fixnum(i)>=0 && sexp_unbox_fixnum(i)<sexp_vector_length(x) ? sexp_vector_data(x)[sexp_unbox_fixnum(i)]=(v) : (fprintf(stderr, "vector-set! length out of range in %s on line %d: vector %p (length %lu): %ld\n", __FILE__, __LINE__, x, sexp_vector_length(x), sexp_unbox_fixnum(i)), SEXP_VOID))
+#else
+#define sexp_vector_ref(x,i)   (sexp_vector_data(x)[sexp_unbox_fixnum(i)])
+#define sexp_vector_set(x,i,v) (sexp_vector_data(x)[sexp_unbox_fixnum(i)]=(v))
+#endif
+
+#define sexp_procedure_num_args(x)   (sexp_field(x, procedure, SEXP_PROCEDURE, num_args))
+#define sexp_procedure_flags(x)      (sexp_field(x, procedure, SEXP_PROCEDURE, flags))
+#define sexp_procedure_variadic_p(x) (sexp_unbox_fixnum(sexp_procedure_flags(x)) & SEXP_PROC_VARIADIC)
+#define sexp_procedure_unused_rest_p(x) (sexp_unbox_fixnum(sexp_procedure_flags(x)) & SEXP_PROC_UNUSED_REST)
+#define sexp_procedure_code(x)       (sexp_field(x, procedure, SEXP_PROCEDURE, bc))
+#define sexp_procedure_vars(x)       (sexp_field(x, procedure, SEXP_PROCEDURE, vars))
+#define sexp_procedure_source(x)     sexp_bytecode_source(sexp_procedure_code(x))
+
+#define sexp_bytes_length(x)  (sexp_field(x, bytes, SEXP_BYTES, length))
+#define sexp_bytes_data(x)    (sexp_field(x, bytes, SEXP_BYTES, data))
+#define sexp_bytes_maybe_null_data(x) (sexp_not(x) ? NULL : sexp_bytes_data(x))
+
+#define sexp_string_size(x)   (sexp_field(x, string, SEXP_STRING, length))
+#if SEXP_USE_PACKED_STRINGS
+#define sexp_string_data(x)   (sexp_field(x, string, SEXP_STRING, data))
+#define sexp_string_bytes(x)  (x)
+#else
+#define sexp_string_bytes(x)  (sexp_field(x, string, SEXP_STRING, bytes))
+#define sexp_string_offset(x) (sexp_field(x, string, SEXP_STRING, offset))
+#define sexp_string_data(x)   (sexp_bytes_data(sexp_string_bytes(x))+sexp_string_offset(x))
+#endif
+#define sexp_string_maybe_null_data(x) (sexp_not(x) ? NULL : sexp_string_data(x))
+
+#if SEXP_USE_PACKED_STRINGS
+#define sexp_string_to_bytes(ctx, x)  ((x)->tag = SEXP_BYTES, x)
+#else
+#define sexp_string_to_bytes(ctx, x)  sexp_string_bytes(x)
+#endif
+
+#define sexp_bytes_ref(x, i)    (sexp_make_fixnum((unsigned char)sexp_bytes_data(x)[sexp_unbox_fixnum(i)]))
+#define sexp_bytes_set(x, i, v) (sexp_bytes_data(x)[sexp_unbox_fixnum(i)] = sexp_unbox_fixnum(v))
+
+#define sexp_lsymbol_data(x)   (sexp_field(x, symbol, SEXP_SYMBOL, data))
+#define sexp_lsymbol_length(x) (sexp_field(x, symbol, SEXP_SYMBOL, length))
+
+#define sexp_port_stream(p)     (sexp_pred_field(p, port, sexp_portp, stream))
+#define sexp_port_name(p)       (sexp_pred_field(p, port, sexp_portp, name))
+#define sexp_port_line(p)       (sexp_pred_field(p, port, sexp_portp, line))
+#define sexp_port_openp(p)      (sexp_pred_field(p, port, sexp_portp, openp))
+#define sexp_port_bidirp(p)     (sexp_pred_field(p, port, sexp_portp, bidirp))
+#define sexp_port_binaryp(p)    (sexp_pred_field(p, port, sexp_portp, binaryp))
+#define sexp_port_shutdownp(p)  (sexp_pred_field(p, port, sexp_portp, shutdownp))
+#define sexp_port_no_closep(p)  (sexp_pred_field(p, port, sexp_portp, no_closep))
+#define sexp_port_sourcep(p)    (sexp_pred_field(p, port, sexp_portp, sourcep))
+#define sexp_port_blockedp(p)   (sexp_pred_field(p, port, sexp_portp, blockedp))
+#define sexp_port_fold_casep(p) (sexp_pred_field(p, port, sexp_portp, fold_casep))
+#define sexp_port_cookie(p)     (sexp_pred_field(p, port, sexp_portp, cookie))
+#define sexp_port_buf(p)        (sexp_pred_field(p, port, sexp_portp, buf))
+#define sexp_port_size(p)       (sexp_pred_field(p, port, sexp_portp, size))
+#define sexp_port_offset(p)     (sexp_pred_field(p, port, sexp_portp, offset))
+#define sexp_port_flags(p)      (sexp_pred_field(p, port, sexp_portp, flags))
+#define sexp_port_fd(p)         (sexp_pred_field(p, port, sexp_portp, fd))
+
+#define sexp_fileno_fd(f)        (sexp_pred_field(f, fileno, sexp_filenop, fd))
+#define sexp_fileno_count(f)     (sexp_pred_field(f, fileno, sexp_filenop, count))
+#define sexp_fileno_openp(f)     (sexp_pred_field(f, fileno, sexp_filenop, openp))
+#define sexp_fileno_socketp(f)   (sexp_pred_field(f, fileno, sexp_filenop, socketp))
+#define sexp_fileno_no_closep(f) (sexp_pred_field(f, fileno, sexp_filenop, no_closep))
+
+#define sexp_ratio_numerator(q)   (sexp_pred_field(q, ratio, sexp_ratiop, numerator))
+#define sexp_ratio_denominator(q) (sexp_pred_field(q, ratio, sexp_ratiop, denominator))
+
+#define sexp_complex_real(q)   (sexp_pred_field(q, complex, sexp_complexp, real))
+#define sexp_complex_imag(q)   (sexp_pred_field(q, complex, sexp_complexp, imag))
+
+#define sexp_exception_kind(x)      (sexp_field(x, exception, SEXP_EXCEPTION, kind))
+#define sexp_exception_message(x)   (sexp_field(x, exception, SEXP_EXCEPTION, message))
+#define sexp_exception_irritants(x) (sexp_field(x, exception, SEXP_EXCEPTION, irritants))
+#define sexp_exception_procedure(x) (sexp_field(x, exception, SEXP_EXCEPTION, procedure))
+#define sexp_exception_source(x)    (sexp_field(x, exception, SEXP_EXCEPTION, source))
+
+#define sexp_trampolinep(x) (sexp_exceptionp(x) && sexp_exception_kind(x) == SEXP_TRAMPOLINE)
+#define sexp_trampoline_procedure(x) sexp_exception_procedure(x)
+#define sexp_trampoline_args(x) sexp_exception_irritants(x)
+
+#define sexp_cpointer_freep(x)      (sexp_freep(x))
+#define sexp_cpointer_length(x)     (sexp_cpointer_field(x, length))
+#define sexp_cpointer_body(x)       (sexp_cpointer_field(x, body))
+#define sexp_cpointer_parent(x)     (sexp_cpointer_field(x, parent))
+#define sexp_cpointer_value(x)      (sexp_cpointer_field(x, value))
+#define sexp_cpointer_maybe_null_value(x) (sexp_not(x) ? NULL : sexp_cpointer_value(x))
+
+#define sexp_bytecode_length(x)   (sexp_field(x, bytecode, SEXP_BYTECODE, length))
+#define sexp_bytecode_max_depth(x) (sexp_field(x, bytecode, SEXP_BYTECODE, max_depth))
+#define sexp_bytecode_name(x)     (sexp_field(x, bytecode, SEXP_BYTECODE, name))
+#define sexp_bytecode_literals(x) (sexp_field(x, bytecode, SEXP_BYTECODE, literals))
+#define sexp_bytecode_source(x)   (sexp_field(x, bytecode, SEXP_BYTECODE, source))
+#define sexp_bytecode_data(x)     (sexp_field(x, bytecode, SEXP_BYTECODE, data))
+
+#define sexp_env_cell_syntactic_p(x)   ((x)->syntacticp)
+
+#define sexp_env_syntactic_p(x)   ((x)->syntacticp)
+#define sexp_env_parent(x)        (sexp_field(x, env, SEXP_ENV, parent))
+#define sexp_env_bindings(x)      (sexp_field(x, env, SEXP_ENV, bindings))
+#define sexp_env_renames(x)       (sexp_field(x, env, SEXP_ENV, renames))
+#define sexp_env_local_p(x)       (sexp_env_parent(x))
+#define sexp_env_global_p(x)      (! sexp_env_local_p(x))
+#define sexp_env_lambda(x)        (sexp_field(x, env, SEXP_ENV, lambda))
+
+#define sexp_macro_proc(x)        (sexp_field(x, macro, SEXP_MACRO, proc))
+#define sexp_macro_env(x)         (sexp_field(x, macro, SEXP_MACRO, env))
+#define sexp_macro_source(x)      (sexp_field(x, macro, SEXP_MACRO, source))
+
+#define sexp_synclo_env(x)        (sexp_field(x, synclo, SEXP_SYNCLO, env))
+#define sexp_synclo_free_vars(x)  (sexp_field(x, synclo, SEXP_SYNCLO, free_vars))
+#define sexp_synclo_expr(x)       (sexp_field(x, synclo, SEXP_SYNCLO, expr))
+
+#define sexp_core_code(x)         (sexp_field(x, core, SEXP_CORE, code))
+#define sexp_core_name(x)         (sexp_field(x, core, SEXP_CORE, name))
+
+#define sexp_dl_file(x)            (sexp_field(x, dl, SEXP_DL, file))
+#define sexp_dl_handle(x)          (sexp_field(x, dl, SEXP_DL, handle))
+
+#define sexp_opcode_class(x)       (sexp_field(x, opcode, SEXP_OPCODE, op_class))
+#define sexp_opcode_code(x)        (sexp_field(x, opcode, SEXP_OPCODE, code))
+#define sexp_opcode_num_args(x)    (sexp_field(x, opcode, SEXP_OPCODE, num_args))
+#define sexp_opcode_flags(x)       (sexp_field(x, opcode, SEXP_OPCODE, flags))
+#define sexp_opcode_inverse(x)     (sexp_field(x, opcode, SEXP_OPCODE, inverse))
+#define sexp_opcode_dl(x)          (sexp_field(x, opcode, SEXP_OPCODE, dl))
+#define sexp_opcode_name(x)        (sexp_field(x, opcode, SEXP_OPCODE, name))
+#define sexp_opcode_data(x)        (sexp_field(x, opcode, SEXP_OPCODE, data))
+#define sexp_opcode_data2(x)       (sexp_field(x, opcode, SEXP_OPCODE, data2))
+#define sexp_opcode_proc(x)        (sexp_field(x, opcode, SEXP_OPCODE, proc))
+#define sexp_opcode_return_type(x) (sexp_field(x, opcode, SEXP_OPCODE, ret_type))
+#define sexp_opcode_arg1_type(x)   (sexp_field(x, opcode, SEXP_OPCODE, arg1_type))
+#define sexp_opcode_arg2_type(x)   (sexp_field(x, opcode, SEXP_OPCODE, arg2_type))
+#define sexp_opcode_arg3_type(x)   (sexp_field(x, opcode, SEXP_OPCODE, arg3_type))
+#define sexp_opcode_argn_type(x)   (sexp_field(x, opcode, SEXP_OPCODE, argn_type))
+#define sexp_opcode_methods(x)     (sexp_field(x, opcode, SEXP_OPCODE, methods))
+#define sexp_opcode_func(x)        (sexp_field(x, opcode, SEXP_OPCODE, func))
+
+#define sexp_opcode_variadic_p(x)  (sexp_opcode_flags(x) & 1)
+#define sexp_opcode_opt_param_p(x) (sexp_opcode_flags(x) & 2)
+#define sexp_opcode_ref_trans_p(x) (sexp_opcode_flags(x) & 4)
+#define sexp_opcode_static_param_p(x) (sexp_opcode_flags(x) & 8)
+#define sexp_opcode_tail_call_p(x) (sexp_opcode_flags(x) & 16)
+
+#define sexp_lambda_name(x)        (sexp_field(x, lambda, SEXP_LAMBDA, name))
+#define sexp_lambda_params(x)      (sexp_field(x, lambda, SEXP_LAMBDA, params))
+#define sexp_lambda_locals(x)      (sexp_field(x, lambda, SEXP_LAMBDA, locals))
+#define sexp_lambda_defs(x)        (sexp_field(x, lambda, SEXP_LAMBDA, defs))
+#define sexp_lambda_flags(x)       (sexp_field(x, lambda, SEXP_LAMBDA, flags))
+#define sexp_lambda_body(x)        (sexp_field(x, lambda, SEXP_LAMBDA, body))
+#define sexp_lambda_fv(x)          (sexp_field(x, lambda, SEXP_LAMBDA, fv))
+#define sexp_lambda_sv(x)          (sexp_field(x, lambda, SEXP_LAMBDA, sv))
+#define sexp_lambda_return_type(x) (sexp_field(x, lambda, SEXP_LAMBDA, ret))
+#define sexp_lambda_param_types(x) (sexp_field(x, lambda, SEXP_LAMBDA, types))
+#define sexp_lambda_source(x)      (sexp_field(x, lambda, SEXP_LAMBDA, source))
+
+#define sexp_cnd_test(x)      (sexp_field(x, cnd, SEXP_CND, test))
+#define sexp_cnd_pass(x)      (sexp_field(x, cnd, SEXP_CND, pass))
+#define sexp_cnd_fail(x)      (sexp_field(x, cnd, SEXP_CND, fail))
+#define sexp_cnd_source(x)    (sexp_field(x, cnd, SEXP_CND, source))
+
+#define sexp_set_var(x)       (sexp_field(x, set, SEXP_SET, var))
+#define sexp_set_value(x)     (sexp_field(x, set, SEXP_SET, value))
+#define sexp_set_source(x)    (sexp_field(x, set, SEXP_SET, source))
+
+#define sexp_ref_name(x)      (sexp_field(x, ref, SEXP_REF, name))
+#define sexp_ref_cell(x)      ((x)->value.ref.cell)
+#define sexp_ref_loc(x)       (sexp_cdr(sexp_ref_cell(x)))
+#define sexp_ref_source(x)    (sexp_field(x, ref, SEXP_REF, source))
+
+#define sexp_seq_ls(x)        (sexp_field(x, seq, SEXP_SEQ, ls))
+#define sexp_seq_source(x)    (sexp_field(x, seq, SEXP_SEQ, source))
+
+#define sexp_lit_value(x)     (sexp_field(x, lit, SEXP_LIT, value))
+#define sexp_lit_source(x)    (sexp_field(x, lit, SEXP_LIT, source))
+
+#define sexp_stack_length(x)  (sexp_field(x, stack, SEXP_STACK, length))
+#define sexp_stack_top(x)     (sexp_field(x, stack, SEXP_STACK, top))
+#define sexp_stack_data(x)    (sexp_field(x, stack, SEXP_STACK, data))
+
+#define sexp_promise_donep(x) (sexp_field(x, promise, SEXP_PROMISE, donep))
+#define sexp_promise_value(x) (sexp_field(x, promise, SEXP_PROMISE, value))
+
+#define sexp_ephemeron_key(x)   (sexp_field(x, pair, SEXP_EPHEMERON, car))
+#define sexp_ephemeron_value(x) (sexp_field(x, pair, SEXP_EPHEMERON, cdr))
+
+#define sexp_context_env(x)      (sexp_field(x, context, SEXP_CONTEXT, env))
+#define sexp_context_stack(x)    (sexp_field(x, context, SEXP_CONTEXT, stack))
+#define sexp_context_parent(x)   (sexp_field(x, context, SEXP_CONTEXT, parent))
+#define sexp_context_child(x)    (sexp_field(x, context, SEXP_CONTEXT, child))
+#define sexp_context_saves(x)    (sexp_field(x, context, SEXP_CONTEXT, saves))
+#define sexp_context_tailp(x)    (sexp_field(x, context, SEXP_CONTEXT, tailp))
+#define sexp_context_tracep(x)   (sexp_field(x, context, SEXP_CONTEXT, tracep))
+#define sexp_context_globals(x)  (sexp_field(x, context, SEXP_CONTEXT, globals))
+#define sexp_context_dk(x)       (sexp_field(x, context, SEXP_CONTEXT, dk))
+#define sexp_context_params(x)   (sexp_field(x, context, SEXP_CONTEXT, params))
+#define sexp_context_last_fp(x)  (sexp_field(x, context, SEXP_CONTEXT, last_fp))
+#define sexp_context_refuel(x)   (sexp_field(x, context, SEXP_CONTEXT, refuel))
+#define sexp_context_ip(x)       (sexp_field(x, context, SEXP_CONTEXT, ip))
+#define sexp_context_proc(x)     (sexp_field(x, context, SEXP_CONTEXT, proc))
+#define sexp_context_timeval(x)  (sexp_field(x, context, SEXP_CONTEXT, tval))
+#define sexp_context_name(x)     (sexp_field(x, context, SEXP_CONTEXT, name))
+#define sexp_context_specific(x) (sexp_field(x, context, SEXP_CONTEXT, specific))
+#define sexp_context_event(x)    (sexp_field(x, context, SEXP_CONTEXT, event))
+#define sexp_context_timeoutp(x) (sexp_field(x, context, SEXP_CONTEXT, timeoutp))
+#define sexp_context_waitp(x)    (sexp_field(x, context, SEXP_CONTEXT, waitp))
+#define sexp_context_dl(x)       (sexp_field(x, context, SEXP_CONTEXT, dl))
+
+#define sexp_context_result(x)   (sexp_field(x, context, SEXP_CONTEXT, result))
+#define sexp_context_errorp(x)   (sexp_field(x, context, SEXP_CONTEXT, errorp))
+
+/* during compilation, sexp_context_specific is set to a vector */
+/* containing the following elements: */
+
+#define sexp_context_bc(x)       (sexp_vector_ref(sexp_context_specific(x), SEXP_ZERO))
+#define sexp_context_fv(x)       (sexp_vector_ref(sexp_context_specific(x), SEXP_ONE))
+#define sexp_context_lambda(x)   (sexp_vector_ref(sexp_context_specific(x), SEXP_TWO))
+#define sexp_context_pos(x)      (sexp_vector_ref(sexp_context_specific(x), SEXP_THREE))
+#define sexp_context_depth(x)    (sexp_vector_ref(sexp_context_specific(x), SEXP_FOUR))
+#define sexp_context_max_depth(x) (sexp_vector_ref(sexp_context_specific(x), SEXP_FIVE))
+#define sexp_context_exception(x) (sexp_vector_ref(sexp_context_specific(x), SEXP_SIX))
+
+#if SEXP_USE_ALIGNED_BYTECODE
+#define sexp_context_align_pos(ctx) sexp_context_pos(ctx) = (sexp)sexp_make_fixnum(sexp_word_align((sexp_uint_t)sexp_unbox_fixnum(sexp_context_pos(ctx))))
+#else
+#define sexp_context_align_pos(ctx)
+#endif
+
+#define sexp_global(ctx,x)      (sexp_vector_data(sexp_context_globals(ctx))[x])
+
+#if SEXP_USE_GLOBAL_HEAP
+#if ! SEXP_USE_BOEHM
+SEXP_API sexp_heap sexp_global_heap;
+#endif
+#define sexp_context_heap(ctx)     sexp_global_heap
+#define sexp_context_max_size(ctx) 0
+#else
+#define sexp_context_heap(ctx)     ((ctx)->value.context.heap)
+#define sexp_context_max_size(ctx) sexp_context_heap(ctx)->max_size
+#endif
+
+#if SEXP_USE_GLOBAL_SYMBOLS
+#define sexp_context_symbols(ctx) sexp_symbol_table
+SEXP_API sexp sexp_symbol_table[SEXP_SYMBOL_TABLE_SIZE];
+#else
+#define sexp_context_symbols(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_SYMBOLS))
+#endif
+
+#define sexp_context_types(ctx)    sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES))
+#define sexp_type_by_index(ctx,i)  (sexp_context_types(ctx)[i])
+#define sexp_context_num_types(ctx)             \
+  sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_NUM_TYPES))
+#define sexp_context_type_array_size(ctx)                               \
+  sexp_vector_length(sexp_global(ctx, SEXP_G_TYPES))
+
+#define sexp_object_type(ctx,x)        (sexp_type_by_index(ctx, ((x)->tag)))
+#define sexp_object_type_name(ctx,x)   (sexp_type_name(sexp_object_type(ctx, x)))
+#define sexp_type_name_by_index(ctx,i) (sexp_type_name(sexp_type_by_index(ctx,i)))
+
+#define sexp_type_size_of_object(t, x)                                  \
+  (((sexp_uint_t*)((char*)x + sexp_type_size_off(t)))[0]                \
+   * sexp_type_size_scale(t)                                            \
+   + sexp_type_size_base(t))
+#define sexp_type_num_slots_of_object(t, x)                             \
+  (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0]           \
+   * sexp_type_field_len_scale(t)                                       \
+   + sexp_type_field_len_base(t))
+#define sexp_type_num_eq_slots_of_object(t, x)                          \
+  (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0]           \
+   * sexp_type_field_len_scale(t)                                       \
+   + sexp_type_field_eq_len_base(t))
+#define sexp_type_num_weak_slots_of_object(t, x)                        \
+  (((sexp_uint_t*)((char*)x + sexp_type_weak_len_off(t)))[0]            \
+   * sexp_type_weak_len_scale(t)                                        \
+   + sexp_type_weak_len_base(t))
+
+#define sexp_context_top(x)     (sexp_stack_top(sexp_context_stack(x)))
+
+#define sexp_type_tag(x)               (sexp_field(x, type, SEXP_TYPE, tag))
+#define sexp_type_field_base(x)        (sexp_field(x, type, SEXP_TYPE, field_base))
+#define sexp_type_field_eq_len_base(x) (sexp_field(x, type, SEXP_TYPE, field_eq_len_base))
+#define sexp_type_field_len_base(x)    (sexp_field(x, type, SEXP_TYPE, field_len_base))
+#define sexp_type_field_len_off(x)     (sexp_field(x, type, SEXP_TYPE, field_len_off))
+#define sexp_type_field_len_scale(x)   (sexp_field(x, type, SEXP_TYPE, field_len_scale))
+#define sexp_type_size_base(x)         (sexp_field(x, type, SEXP_TYPE, size_base))
+#define sexp_type_size_off(x)          (sexp_field(x, type, SEXP_TYPE, size_off))
+#define sexp_type_size_scale(x)        (sexp_field(x, type, SEXP_TYPE, size_scale))
+#define sexp_type_weak_base(x)         (sexp_field(x, type, SEXP_TYPE, weak_base))
+#define sexp_type_weak_len_base(x)     (sexp_field(x, type, SEXP_TYPE, weak_len_base))
+#define sexp_type_weak_len_off(x)      (sexp_field(x, type, SEXP_TYPE, weak_len_off))
+#define sexp_type_weak_len_scale(x)    (sexp_field(x, type, SEXP_TYPE, weak_len_scale))
+#define sexp_type_weak_len_extra(x)    (sexp_field(x, type, SEXP_TYPE, weak_len_extra))
+#define sexp_type_depth(x)             (sexp_field(x, type, SEXP_TYPE, depth))
+#define sexp_type_name(x)              (sexp_field(x, type, SEXP_TYPE, name))
+#define sexp_type_cpl(x)               (sexp_field(x, type, SEXP_TYPE, cpl))
+#define sexp_type_slots(x)             (sexp_field(x, type, SEXP_TYPE, slots))
+#define sexp_type_getters(x)           (sexp_field(x, type, SEXP_TYPE, getters))
+#define sexp_type_setters(x)           (sexp_field(x, type, SEXP_TYPE, setters))
+#define sexp_type_finalize(x)          (sexp_field(x, type, SEXP_TYPE, finalize))
+#define sexp_type_print(x)             (sexp_field(x, type, SEXP_TYPE, print))
+#define sexp_type_dl(x)                (sexp_field(x, type, SEXP_TYPE, dl))
+#define sexp_type_id(x)                (sexp_field(x, type, SEXP_TYPE, id))
+
+#define sexp_bignum_sign(x)            (sexp_field(x, bignum, SEXP_BIGNUM, sign))
+#define sexp_bignum_length(x)          (sexp_field(x, bignum, SEXP_BIGNUM, length))
+#define sexp_bignum_data(x)            (sexp_field(x, bignum, SEXP_BIGNUM, data))
+
+/****************************** arithmetic ****************************/
+
+#define sexp_fx_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG))
+#define sexp_fx_sub(a, b) ((sexp)(((sexp_sint_t)a)-((sexp_sint_t)b)+SEXP_FIXNUM_TAG))
+#define sexp_fx_mul(a, b) ((sexp)((((((sexp_sint_t)a)-SEXP_FIXNUM_TAG)*(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG)))
+#define sexp_fx_div(a, b) (sexp_make_fixnum(sexp_unbox_fixnum(a) / sexp_unbox_fixnum(b)))
+#define sexp_fx_rem(a, b) (sexp_make_fixnum(sexp_unbox_fixnum(a) % sexp_unbox_fixnum(b)))
+#define sexp_fx_sign(a)   (+1 | (((sexp_sint_t)(a)) >> (sizeof(sexp_sint_t)*8 - 1)))
+#define sexp_fx_neg(a)    (sexp_make_fixnum(-(sexp_unbox_fixnum(a))))
+#define sexp_fx_abs(a)    ((((sexp_sint_t)a) < 0) ? sexp_fx_neg(a) : a)
+
+#define sexp_fp_add(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) + sexp_flonum_value(b)))
+#define sexp_fp_sub(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) - sexp_flonum_value(b)))
+#define sexp_fp_mul(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) * sexp_flonum_value(b)))
+#define sexp_fp_div(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) / sexp_flonum_value(b)))
+
+#if ! (SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS)
+#define sexp_add(ctx, a, b) sexp_fx_add(a, b)
+#define sexp_sub(ctx, a, b) sexp_fx_sub(a, b)
+#define sexp_mul(ctx, a, b) sexp_fx_mul(a, b)
+#define sexp_div(ctx, a, b) sexp_fx_div(a, b)
+#endif
+
+/****************************** utilities *****************************/
+
+enum sexp_context_globals {
+#if ! SEXP_USE_GLOBAL_SYMBOLS
+  SEXP_G_SYMBOLS,
+#endif
+  SEXP_G_TYPES,
+  SEXP_G_NUM_TYPES,
+  SEXP_G_OOM_ERROR,             /* out of memory exception object */
+  SEXP_G_OOS_ERROR,             /* out of stack exception object */
+  SEXP_G_ABI_ERROR,             /* incompatible ABI loading library */
+  SEXP_G_OPTIMIZATIONS,
+  SEXP_G_SIGNAL_HANDLERS,
+  SEXP_G_META_ENV,
+  SEXP_G_MODULE_PATH,
+  SEXP_G_QUOTE_SYMBOL,
+  SEXP_G_QUASIQUOTE_SYMBOL,
+  SEXP_G_UNQUOTE_SYMBOL,
+  SEXP_G_UNQUOTE_SPLICING_SYMBOL,
+  SEXP_G_EMPTY_VECTOR,
+  SEXP_G_CUR_IN_SYMBOL,
+  SEXP_G_CUR_OUT_SYMBOL,
+  SEXP_G_CUR_ERR_SYMBOL,
+  SEXP_G_INTERACTION_ENV_SYMBOL,
+  SEXP_G_CONTINUABLE_SYMBOL,
+  SEXP_G_ERR_HANDLER,
+  SEXP_G_RESUMECC_BYTECODE,
+  SEXP_G_FINAL_RESUMER,
+  SEXP_G_STRICT_P,
+#if SEXP_USE_FOLD_CASE_SYMS
+  SEXP_G_FOLD_CASE_P,
+#endif
+#if SEXP_USE_WEAK_REFERENCES
+  SEXP_G_FILE_DESCRIPTORS,
+  SEXP_G_NUM_FILE_DESCRIPTORS,
+#endif
+#if ! SEXP_USE_BOEHM
+  SEXP_G_PRESERVATIVES,
+#endif
+#if SEXP_USE_GREEN_THREADS
+  SEXP_G_IO_BLOCK_ERROR,
+  SEXP_G_IO_BLOCK_ONCE_ERROR,
+  SEXP_G_THREAD_TERMINATE_ERROR,
+  SEXP_G_THREADS_SCHEDULER,
+  SEXP_G_THREADS_FRONT,
+  SEXP_G_THREADS_BACK,
+  SEXP_G_THREADS_PAUSED,
+  SEXP_G_THREADS_SIGNALS,
+  SEXP_G_THREADS_SIGNAL_RUNNER,
+  SEXP_G_THREADS_POLL_FDS,
+  SEXP_G_THREADS_FD_THREADS,
+  SEXP_G_THREADS_BLOCKER,
+  SEXP_G_THREADS_MUTEX_ID,
+  SEXP_G_THREADS_POLLFDS_ID,
+  SEXP_G_ATOMIC_P,
+#endif
+  SEXP_G_NUM_GLOBALS
+};
+
+#define sexp_list1(x,a)        sexp_cons((x), (a), SEXP_NULL)
+
+SEXP_API sexp sexp_push_op(sexp ctx, sexp* loc, sexp x);
+
+#if SEXP_USE_UNSAFE_PUSH
+#define sexp_push(ctx, ls, x)    ((ls) = sexp_cons((ctx), (x), (ls)))
+#else
+#define sexp_push(ctx, ls, x)    (sexp_push_op((ctx), &(ls), (x)))
+#endif
+#define sexp_insert(ctx, ls, x)  ((sexp_memq(ctx, (x), (ls)) != SEXP_FALSE) ? (ls) : sexp_push((ctx), (ls), (x)))
+
+#define sexp_pair_source(x) (sexp_field(x, pair, SEXP_PAIR, source))
+
+#define sexp_car(x)         (sexp_field(x, pair, SEXP_PAIR, car))
+#define sexp_cdr(x)         (sexp_field(x, pair, SEXP_PAIR, cdr))
+
+#define sexp_caar(x)      (sexp_car(sexp_car(x)))
+#define sexp_cadr(x)      (sexp_car(sexp_cdr(x)))
+#define sexp_cdar(x)      (sexp_cdr(sexp_car(x)))
+#define sexp_cddr(x)      (sexp_cdr(sexp_cdr(x)))
+#define sexp_caaar(x)     (sexp_car(sexp_caar(x)))
+#define sexp_caadr(x)     (sexp_car(sexp_cadr(x)))
+#define sexp_cadar(x)     (sexp_car(sexp_cdar(x)))
+#define sexp_caddr(x)     (sexp_car(sexp_cddr(x)))
+#define sexp_cdaar(x)     (sexp_cdr(sexp_caar(x)))
+#define sexp_cdadr(x)     (sexp_cdr(sexp_cadr(x)))
+#define sexp_cddar(x)     (sexp_cdr(sexp_cdar(x)))
+#define sexp_cdddr(x)     (sexp_cdr(sexp_cddr(x)))
+#define sexp_cadddr(x)    (sexp_cadr(sexp_cddr(x))) /* just these two */
+#define sexp_cddddr(x)    (sexp_cddr(sexp_cddr(x)))
+
+/***************************** general API ****************************/
+
+#if SEXP_USE_STRING_STREAMS
+
+#define sexp_read_char(x, p) (getc(sexp_port_stream(p)))
+#define sexp_push_char(x, c, p) (ungetc(c, sexp_port_stream(p)))
+#define sexp_write_char(x, c, p) (putc(c, sexp_port_stream(p)))
+#define sexp_write_string(x, s, p) (fputs(s, sexp_port_stream(p)))
+#define sexp_write_string_n(x, s, n, p) (fwrite(s, 1, n, sexp_port_stream(p)))
+#define sexp_flush(x, p) (fflush(sexp_port_stream(p)))
+#define sexp_flush_forced sexp_flush
+
+#else
+
+#define sexp_read_char(x, p) (sexp_port_buf(p) ? ((sexp_port_offset(p) < sexp_port_size(p)) ? ((unsigned char*)sexp_port_buf(p))[sexp_port_offset(p)++] : sexp_buffered_read_char(x, p)) : getc(sexp_port_stream(p)))
+#define sexp_push_char(x, c, p) ((c!=EOF) && (sexp_port_buf(p) ? (sexp_port_buf(p)[--sexp_port_offset(p)] = ((char)(c))) : ungetc(c, sexp_port_stream(p))))
+#define sexp_write_char(x, c, p) (sexp_port_buf(p) ? ((sexp_port_offset(p) < sexp_port_size(p)) ? ((((sexp_port_buf(p))[sexp_port_offset(p)++]) = (char)(c)), 0) : sexp_buffered_write_char(x, c, p)) : putc(c, sexp_port_stream(p)))
+#define sexp_write_string(x, s, p) (sexp_port_buf(p) ? sexp_buffered_write_string(x, s, p) : fputs(s, sexp_port_stream(p)))
+#define sexp_write_string_n(x, s, n, p) (sexp_port_buf(p) ? sexp_buffered_write_string_n(x, s, n, p) : fwrite(s, 1, n, sexp_port_stream(p)))
+#define sexp_flush(x, p) (sexp_port_buf(p) ? sexp_buffered_flush(x, p, 0) : fflush(sexp_port_stream(p)))
+#define sexp_flush_forced(x, p) (sexp_port_buf(p) ? sexp_buffered_flush(x, p, 1) : fflush(sexp_port_stream(p)))
+
+SEXP_API int sexp_buffered_read_char (sexp ctx, sexp p);
+SEXP_API int sexp_buffered_write_char (sexp ctx, int c, sexp p);
+SEXP_API int sexp_buffered_write_string_n (sexp ctx, const char *str, sexp_uint_t len, sexp p);
+SEXP_API int sexp_buffered_write_string (sexp ctx, const char *str, sexp p);
+SEXP_API int sexp_buffered_flush (sexp ctx, sexp p, int forcep);
+
+#endif
+
+#define sexp_newline(ctx, p) sexp_write_char((ctx), '\n', (p))
+#define sexp_at_eofp(p)      (feof(sexp_port_stream(p)))
+#define sexp_port_fileno(p)  (sexp_port_stream(p) ? fileno(sexp_port_stream(p)) : sexp_filenop(sexp_port_fd(p)) ? sexp_fileno_fd(sexp_port_fd(p)) : -1)
+
+#if SEXP_USE_AUTOCLOSE_PORTS
+#define SEXP_FINALIZE_PORT sexp_finalize_port
+#define SEXP_FINALIZE_FILENO sexp_finalize_fileno
+#else
+#define SEXP_FINALIZE_PORT NULL
+#define SEXP_FINALIZE_FILENO NULL
+#endif
+
+#if SEXP_USE_DL
+sexp sexp_finalize_dl (sexp ctx, sexp self, sexp_sint_t n, sexp dl);
+#define SEXP_FINALIZE_DL sexp_finalize_dl
+#else
+#define SEXP_FINALIZE_DL NULL
+#endif
+
+#if SEXP_USE_TRACK_ALLOC_SOURCE
+#define sexp_current_source_param , const char* source
+#else
+#define sexp_current_source_param
+#endif
+
+SEXP_API sexp sexp_alloc_tagged_aux(sexp ctx, size_t size, sexp_uint_t tag sexp_current_source_param);
+SEXP_API sexp sexp_make_context(sexp ctx, size_t size, size_t max_size);
+SEXP_API sexp sexp_cons_op(sexp ctx, sexp self, sexp_sint_t n, sexp head, sexp tail);
+SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b);
+SEXP_API sexp sexp_equalp_bound (sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b, sexp depth, sexp bound);
+SEXP_API sexp sexp_equalp_op (sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b);
+SEXP_API sexp sexp_listp_op(sexp ctx, sexp self, sexp_sint_t n, sexp obj);
+SEXP_API sexp sexp_reverse_op(sexp ctx, sexp self, sexp_sint_t n, sexp ls);
+SEXP_API sexp sexp_nreverse_op(sexp ctx, sexp self, sexp_sint_t n, sexp ls);
+SEXP_API sexp sexp_copy_list_op(sexp ctx, sexp self, sexp_sint_t n, sexp ls);
+SEXP_API sexp sexp_append2_op(sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b);
+SEXP_API sexp sexp_memq_op(sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp ls);
+SEXP_API sexp sexp_assq_op(sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp ls);
+SEXP_API sexp sexp_length_op(sexp ctx, sexp self, sexp_sint_t n, sexp ls);
+SEXP_API sexp sexp_c_string(sexp ctx, const char *str, sexp_sint_t slen);
+SEXP_API sexp sexp_make_ephemeron_op(sexp ctx, sexp self, sexp_sint_t n, sexp key, sexp value);
+SEXP_API sexp sexp_make_bytes_op(sexp ctx, sexp self, sexp_sint_t n, sexp len, sexp i);
+SEXP_API sexp sexp_make_string_op(sexp ctx, sexp self, sexp_sint_t n, sexp len, sexp ch);
+SEXP_API sexp sexp_substring_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp start, sexp end);
+SEXP_API sexp sexp_subbytes_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp start, sexp end);
+SEXP_API sexp sexp_string_concatenate_op (sexp ctx, sexp self, sexp_sint_t n, sexp str_ls, sexp sep);
+SEXP_API sexp sexp_intern (sexp ctx, const char *str, sexp_sint_t len);
+SEXP_API sexp sexp_string_to_symbol_op (sexp ctx, sexp self, sexp_sint_t n, sexp str);
+SEXP_API sexp sexp_symbol_to_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp sym);
+SEXP_API sexp sexp_string_to_number_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp b);
+SEXP_API sexp sexp_flonump_op (sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_make_vector_op (sexp ctx, sexp self, sexp_sint_t n, sexp len, sexp dflt);
+SEXP_API sexp sexp_list_to_vector_op (sexp ctx, sexp self, sexp_sint_t n, sexp ls);
+SEXP_API sexp sexp_make_cpointer (sexp ctx, sexp_uint_t type_id, void* value, sexp parent, int freep);
+SEXP_API int sexp_is_separator(int c);
+SEXP_API sexp sexp_write_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp out);
+SEXP_API sexp sexp_display_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp out);
+SEXP_API sexp sexp_flush_output_op (sexp ctx, sexp self, sexp_sint_t n, sexp out);
+SEXP_API sexp sexp_read_string (sexp ctx, sexp in, int sentinel);
+SEXP_API sexp sexp_read_symbol (sexp ctx, sexp in, int init, int internp);
+SEXP_API sexp sexp_read_number (sexp ctx, sexp in, int base, int exactp);
+#if SEXP_USE_BIGNUMS
+SEXP_API sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init,
+				signed char sign, sexp_uint_t base);
+SEXP_API sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base);
+#endif
+SEXP_API sexp sexp_read_float_tail(sexp ctx, sexp in, double whole, int negp);
+#if SEXP_USE_COMPLEX
+SEXP_API sexp sexp_read_complex_tail(sexp ctx, sexp in, sexp res);
+#endif
+SEXP_API sexp sexp_read_raw (sexp ctx, sexp in);
+SEXP_API sexp sexp_read_op (sexp ctx, sexp self, sexp_sint_t n, sexp in);
+SEXP_API sexp sexp_char_ready_p (sexp ctx, sexp self, sexp_sint_t n, sexp in);
+SEXP_API sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len);
+SEXP_API sexp sexp_read_error (sexp ctx, const char *msg, sexp ir, sexp port);
+SEXP_API sexp sexp_write_to_string (sexp ctx, sexp obj);
+SEXP_API sexp sexp_write_simple_object (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp writer, sexp out);
+SEXP_API sexp sexp_finalize_port (sexp ctx, sexp self, sexp_sint_t n, sexp port);
+SEXP_API sexp sexp_make_fileno_op (sexp ctx, sexp self, sexp_sint_t n, sexp fd, sexp no_closep);
+SEXP_API sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name);
+SEXP_API sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name);
+SEXP_API sexp sexp_open_input_file_descriptor (sexp ctx, sexp self, sexp_sint_t n, sexp fileno, sexp socketp);
+SEXP_API sexp sexp_open_output_file_descriptor (sexp ctx, sexp self, sexp_sint_t n, sexp fileno, sexp socketp);
+SEXP_API sexp sexp_make_non_null_input_port (sexp ctx, FILE* in, sexp name);
+SEXP_API sexp sexp_make_non_null_output_port (sexp ctx, FILE* out, sexp name);
+SEXP_API sexp sexp_make_non_null_input_output_port (sexp ctx, FILE* io, sexp name);
+SEXP_API sexp sexp_port_outputp_op (sexp ctx, sexp self, sexp_sint_t n, sexp port);
+SEXP_API sexp sexp_port_binaryp_op (sexp ctx, sexp self, sexp_sint_t n, sexp port);
+SEXP_API sexp sexp_port_openp_op (sexp ctx, sexp self, sexp_sint_t n, sexp port);
+#if SEXP_USE_FOLD_CASE_SYMS
+SEXP_API sexp sexp_get_port_fold_case (sexp ctx, sexp self, sexp_sint_t n, sexp in);
+SEXP_API sexp sexp_set_port_fold_case (sexp ctx, sexp self, sexp_sint_t n, sexp in, sexp x);
+#endif
+#if SEXP_USE_OBJECT_BRACE_LITERALS
+SEXP_API sexp sexp_lookup_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp id);
+#endif
+SEXP_API sexp sexp_open_input_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp str);
+SEXP_API sexp sexp_open_output_string_op (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_get_output_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp port);
+SEXP_API sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source);
+SEXP_API sexp sexp_user_exception (sexp ctx, sexp self, const char *msg, sexp x);
+SEXP_API sexp sexp_file_exception (sexp ctx, sexp self, const char *msg, sexp x);
+SEXP_API sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp x);
+SEXP_API sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp x);
+SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end);
+SEXP_API sexp sexp_print_exception_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp out);
+SEXP_API sexp sexp_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp out);
+SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args);
+SEXP_API sexp sexp_apply1 (sexp ctx, sexp f, sexp x);
+SEXP_API sexp sexp_apply2 (sexp ctx, sexp f, sexp x, sexp y);
+SEXP_API sexp sexp_apply_no_err_handler (sexp ctx, sexp proc, sexp args);
+SEXP_API sexp sexp_make_trampoline (sexp ctx, sexp proc, sexp args);
+SEXP_API sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, sexp_proc1 f, sexp data);
+SEXP_API void sexp_init(void);
+
+#if SEXP_USE_UTF8_STRINGS
+SEXP_API int sexp_utf8_initial_byte_count (int c);
+SEXP_API int sexp_utf8_char_byte_count (int c);
+SEXP_API sexp_uint_t sexp_string_utf8_length (unsigned char *p, long len);
+SEXP_API char* sexp_string_utf8_prev (unsigned char *p);
+SEXP_API sexp sexp_string_utf8_ref (sexp ctx, sexp str, sexp i);
+SEXP_API sexp sexp_string_utf8_index_ref (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i);
+SEXP_API sexp sexp_string_index_to_offset (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp index);
+SEXP_API sexp sexp_string_offset_to_index (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp offset);
+SEXP_API sexp sexp_utf8_substring_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp start, sexp end);
+SEXP_API void sexp_utf8_encode_char (unsigned char* p, int len, int c);
+SEXP_API int sexp_write_utf8_char (sexp ctx, int c, sexp out);
+#define sexp_string_ref(ctx, s, i)    (sexp_string_utf8_index_ref(ctx, NULL, 2, s, i))
+#define sexp_string_set(ctx, s, i, ch) (sexp_string_utf8_index_set(ctx, NULL, 3, s, i, ch))
+#define sexp_string_cursor_ref(ctx, s, i)    (sexp_string_utf8_ref(ctx, s, i))
+#define sexp_string_cursor_set(ctx, s, i)    (sexp_string_utf8_set(ctx, s, i))
+#define sexp_string_cursor_next(s, i) sexp_make_fixnum(sexp_unbox_fixnum(i) + sexp_utf8_initial_byte_count(((unsigned char*)sexp_string_data(s))[sexp_unbox_fixnum(i)]))
+#define sexp_string_cursor_prev(s, i) sexp_make_fixnum(sexp_string_utf8_prev((unsigned char*)sexp_string_data(s)+sexp_unbox_fixnum(i)) - sexp_string_data(s))
+#define sexp_string_length(s) sexp_string_utf8_length((unsigned char*)sexp_string_data(s), sexp_string_size(s))
+#define sexp_substring(ctx, s, i, j) sexp_utf8_substring_op(ctx, NULL, 3, s, i, j)
+#define sexp_substring_cursor(ctx, s, i, j) sexp_substring_op(ctx, NULL, 3, s, i, j)
+#else  /* ASCII strings */
+#define sexp_string_ref(ctx, s, i)    (sexp_make_character((unsigned char)sexp_string_data(s)[sexp_unbox_fixnum(i)]))
+#define sexp_string_set(ctx, s, i, ch) (sexp_string_data(s)[sexp_unbox_fixnum(i)] = sexp_unbox_character(ch))
+#define sexp_string_cursor_ref(ctx, s, i) sexp_string_ref(ctx, s, i)
+#define sexp_string_cursor_set(ctx, s, i, ch) sexp_string_set(ctx, s, i, ch)
+#define sexp_string_cursor_next(s, i) sexp_make_fixnum(sexp_unbox_fixnum(i) + 1)
+#define sexp_string_cursor_prev(s, i) sexp_make_fixnum(sexp_unbox_fixnum(i) - 1)
+#define sexp_string_length(s) sexp_string_size(s)
+#define sexp_substring(ctx, s, i, j) sexp_substring_op(ctx, NULL, 3, s, i, j)
+#define sexp_substring_cursor(ctx, s, i, j) sexp_substring_op(ctx, NULL, 3, s, i, j)
+#endif
+
+#if SEXP_USE_GREEN_THREADS
+SEXP_API int sexp_maybe_block_port (sexp ctx, sexp in, int forcep);
+SEXP_API void sexp_maybe_unblock_port (sexp ctx, sexp in);
+#define sexp_check_block_port(ctx, in, forcep)          \
+  if (sexp_maybe_block_port(ctx, in, forcep))           \
+    return sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR)
+#else
+#define sexp_maybe_block_port(ctx, in, forcep)
+#define sexp_maybe_unblock_port(ctx, in)
+#define sexp_check_block_port(ctx, in, forcep)
+#endif
+
+#define SEXP_PORT_UNKNOWN_FLAGS -1uL
+
+#define sexp_assert_type(ctx, pred, type_id, obj) if (! pred(obj)) return sexp_type_exception(ctx, self, type_id, obj)
+
+#define SEXP_COPY_DEFAULT SEXP_ZERO
+#define SEXP_COPY_FREEP   SEXP_ONE
+#define SEXP_COPY_LOADP   SEXP_TWO
+
+#if ! SEXP_USE_BOEHM && ! SEXP_USE_MALLOC
+SEXP_API void sexp_gc_init (void);
+SEXP_API sexp_heap sexp_make_heap (size_t size, size_t max_size);
+SEXP_API void sexp_mark (sexp ctx, sexp x);
+SEXP_API sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr);
+SEXP_API sexp sexp_finalize (sexp ctx);
+#endif
+
+#if SEXP_USE_GLOBAL_HEAP
+#define sexp_free_heap(heap)
+#define sexp_destroy_context(ctx)
+#else
+SEXP_API void sexp_free_heap (sexp_heap heap);
+SEXP_API void sexp_destroy_context (sexp ctx);
+SEXP_API sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags);
+#endif
+
+#if SEXP_USE_SAFE_GC_MARK
+SEXP_API int sexp_in_heap_p(sexp ctx, sexp x);
+#else
+#define sexp_in_heap_p(ctx, x) 1
+#endif
+
+#if SEXP_DEBUG_GC > 1 || SEXP_USE_SAFE_GC_MARK || SEXP_USE_HEADER_MAGIC
+SEXP_API int sexp_valid_object_p(sexp ctx, sexp x);
+#else
+#define sexp_valid_object_p(ctx, x) 1
+#endif
+
+#if SEXP_USE_TYPE_DEFS
+SEXP_API sexp sexp_register_type_op (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2);
+SEXP_API sexp sexp_register_simple_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp parent, sexp slots);
+SEXP_API sexp sexp_finalize_c_type (sexp ctx, sexp self, sexp_sint_t n, sexp obj);
+#define sexp_register_c_type(ctx, name, finalizer)                      \
+  sexp_register_type(ctx, name, SEXP_FALSE, SEXP_FALSE, SEXP_ZERO, SEXP_ZERO, \
+                     SEXP_ZERO, SEXP_ZERO, SEXP_ZERO,                   \
+                     sexp_make_fixnum(sexp_sizeof(cpointer)),           \
+                     SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO,        \
+                     SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, NULL,             \
+                     (sexp_proc2)finalizer)
+#endif
+
+#define sexp_current_input_port(ctx) sexp_parameter_ref(ctx, sexp_env_ref(ctx, sexp_context_env(ctx), sexp_global(ctx,SEXP_G_CUR_IN_SYMBOL), SEXP_FALSE))
+#define sexp_current_output_port(ctx) sexp_parameter_ref(ctx, sexp_env_ref(ctx, sexp_context_env(ctx), sexp_global(ctx,SEXP_G_CUR_OUT_SYMBOL), SEXP_FALSE))
+#define sexp_current_error_port(ctx) sexp_parameter_ref(ctx, sexp_env_ref(ctx, sexp_context_env(ctx), sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL), SEXP_FALSE))
+#define sexp_debug(ctx, msg, obj) (sexp_portp(sexp_current_error_port(ctx)) ? (sexp_write_string(ctx, msg, sexp_current_error_port(ctx)), sexp_write(ctx, obj, sexp_current_error_port(ctx)), sexp_write_char(ctx, '\n', sexp_current_error_port(ctx))) : 0)
+
+/* simplify primitive API interface */
+
+#define sexp_read(ctx, in) sexp_read_op(ctx, NULL, 1, in)
+#define sexp_write(ctx, obj, out) sexp_write_op(ctx, NULL, 2, obj, out)
+#define sexp_display(ctx, obj, out) sexp_display_op(ctx, NULL, 2, obj, out)
+#define sexp_print_exception(ctx, e, out) sexp_print_exception_op(ctx, NULL, 2, e, out)
+#define sexp_flush_output(ctx, out) sexp_flush_output_op(ctx, NULL, 1, out)
+#define sexp_equalp(ctx, a, b) sexp_equalp_op(ctx, NULL, 2, a, b)
+#define sexp_listp(ctx, x) sexp_listp_op(ctx, NULL, 1, x)
+#define sexp_length(ctx, x) sexp_length_op(ctx, NULL, 1, x)
+#define sexp_reverse(ctx, x) sexp_reverse_op(ctx, NULL, 1, x)
+#define sexp_nreverse(ctx, x) sexp_nreverse_op(ctx, NULL, 1, x)
+#define sexp_copy_list(ctx, x) sexp_copy_list_op(ctx, NULL, 1, x)
+#define sexp_cons(ctx, a, b) sexp_cons_op(ctx, NULL, 2, a, b)
+#define sexp_append2(ctx, a, b) sexp_append2_op(ctx, NULL, 2, a, b)
+#define sexp_make_vector(ctx, a, b) sexp_make_vector_op(ctx, NULL, 2, a, b);
+#define sexp_list_to_vector(ctx, x) sexp_list_to_vector_op(ctx, NULL, 1, x)
+#define sexp_exception_type(ctx, x) sexp_exception_type_op(ctx, NULL, 1, x)
+#define sexp_string_to_symbol(ctx, s) sexp_string_to_symbol_op(ctx, NULL, 1, s)
+#define sexp_string_to_number(ctx, s, b) sexp_string_to_number_op(ctx, NULL, 2, s, b)
+#define sexp_symbol_to_string(ctx, s) sexp_symbol_to_string_op(ctx, NULL, 1, s)
+#define sexp_make_ephemeron(ctx, k, v) sexp_make_ephemeron_op(ctx, NULL, 2, k, v)
+#define sexp_make_bytes(ctx, l, i) sexp_make_bytes_op(ctx, NULL, 2, l, i)
+#define sexp_make_string(ctx, l, c) sexp_make_string_op(ctx, NULL, 2, l, c)
+#define sexp_subbytes(ctx, a, b, c) sexp_subbytes_op(ctx, NULL, 3, a, b, c)
+#define sexp_string_concatenate(ctx, ls, s) sexp_string_concatenate_op(ctx, NULL, 2, ls, s)
+#define sexp_memq(ctx, a, b) sexp_memq_op(ctx, NULL, 2, a, b)
+#define sexp_assq(ctx, a, b) sexp_assq_op(ctx, NULL, 2, a, b)
+#define sexp_open_output_string(ctx) sexp_open_output_string_op(ctx, NULL, 0)
+#define sexp_open_input_string(ctx, s) sexp_open_input_string_op(ctx, NULL, 1, s)
+#define sexp_get_output_string(ctx, out) sexp_get_output_string_op(ctx, NULL, 1, out)
+#define sexp_expt(ctx, a, b) sexp_expt_op(ctx, NULL, 2, a, b)
+#define sexp_register_simple_type(ctx, a, b, c) sexp_register_simple_type_op(ctx, NULL, 3, a, b, c)
+#define sexp_register_type(ctx, a, b, c, d, e, f, g, h, i, j, k, l, m, o, p, q, r, s) sexp_register_type_op(ctx, NULL, 18, a, b, c, d, e, f, g, h, i, j, k, l, m, o, p, q, r, s)
+#define sexp_make_type_predicate(ctx, a, b) sexp_make_type_predicate_op(ctx, NULL, 2, a, b)
+#define sexp_make_constructor(ctx, a, b) sexp_make_constructor_op(ctx, NULL, 2, a, b)
+#define sexp_make_getter(ctx, a, b, c) sexp_make_getter_op(ctx, NULL, 3, a, b, c)
+#define sexp_make_setter(ctx, a, b, c) sexp_make_setter_op(ctx, NULL, 3, a, b, c)
+#define sexp_lookup_type(ctx, name, id) sexp_lookup_type_op(ctx, NULL, 2, name, id)
+#define sexp_make_fileno(ctx, fd, no_closep) sexp_make_fileno_op(ctx, NULL, 2, fd, no_closep)
+
+enum sexp_opcode_names {
+  SEXP_OP_NOOP,
+  SEXP_OP_RAISE,
+  SEXP_OP_RESUMECC,
+  SEXP_OP_CALLCC,
+  SEXP_OP_APPLY1,
+  SEXP_OP_TAIL_CALL,
+  SEXP_OP_CALL,
+  SEXP_OP_FCALL0,
+  SEXP_OP_FCALL1,
+  SEXP_OP_FCALL2,
+  SEXP_OP_FCALL3,
+  SEXP_OP_FCALL4,
+  SEXP_OP_FCALLN,
+  SEXP_OP_JUMP_UNLESS,
+  SEXP_OP_JUMP,
+  SEXP_OP_PUSH,
+  SEXP_OP_RESERVE,
+  SEXP_OP_DROP,
+  SEXP_OP_GLOBAL_REF,
+  SEXP_OP_GLOBAL_KNOWN_REF,
+  SEXP_OP_PARAMETER_REF,
+  SEXP_OP_STACK_REF,
+  SEXP_OP_LOCAL_REF,
+  SEXP_OP_LOCAL_SET,
+  SEXP_OP_CLOSURE_REF,
+  SEXP_OP_CLOSURE_VARS,
+  SEXP_OP_VECTOR_REF,
+  SEXP_OP_VECTOR_SET,
+  SEXP_OP_VECTOR_LENGTH,
+  SEXP_OP_BYTES_REF,
+  SEXP_OP_BYTES_SET,
+  SEXP_OP_BYTES_LENGTH,
+  SEXP_OP_STRING_REF,
+  SEXP_OP_STRING_SET,
+  SEXP_OP_STRING_LENGTH,
+  SEXP_OP_STRING_CURSOR_NEXT,
+  SEXP_OP_STRING_CURSOR_PREV,
+  SEXP_OP_STRING_SIZE,
+  SEXP_OP_MAKE_PROCEDURE,
+  SEXP_OP_MAKE_VECTOR,
+  SEXP_OP_MAKE_EXCEPTION,
+  SEXP_OP_AND,
+  SEXP_OP_NULLP,
+  SEXP_OP_FIXNUMP,
+  SEXP_OP_SYMBOLP,
+  SEXP_OP_CHARP,
+  SEXP_OP_EOFP,
+  SEXP_OP_TYPEP,
+  SEXP_OP_MAKE,
+  SEXP_OP_SLOT_REF,
+  SEXP_OP_SLOT_SET,
+  SEXP_OP_ISA,
+  SEXP_OP_SLOTN_REF,
+  SEXP_OP_SLOTN_SET,
+  SEXP_OP_CAR,
+  SEXP_OP_CDR,
+  SEXP_OP_SET_CAR,
+  SEXP_OP_SET_CDR,
+  SEXP_OP_CONS,
+  SEXP_OP_ADD,
+  SEXP_OP_SUB,
+  SEXP_OP_MUL,
+  SEXP_OP_DIV,
+  SEXP_OP_QUOTIENT,
+  SEXP_OP_REMAINDER,
+  SEXP_OP_LT,
+  SEXP_OP_LE,
+  SEXP_OP_EQN,
+  SEXP_OP_EQ,
+  SEXP_OP_CHAR2INT,
+  SEXP_OP_INT2CHAR,
+  SEXP_OP_CHAR_UPCASE,
+  SEXP_OP_CHAR_DOWNCASE,
+  SEXP_OP_WRITE_CHAR,
+  SEXP_OP_WRITE_STRING,
+  SEXP_OP_READ_CHAR,
+  SEXP_OP_PEEK_CHAR,
+  SEXP_OP_YIELD,
+  SEXP_OP_FORCE,
+  SEXP_OP_RET,
+  SEXP_OP_DONE,
+  SEXP_OP_NUM_OPCODES
+};
+
+#ifdef __cplusplus
+} /* extern "C" */
+#endif
+
+#endif /* ! SEXP_H */
diff --git a/lib/chibi/accept.c b/lib/chibi/accept.c
new file mode 100644
index 00000000..d53abc4f
--- /dev/null
+++ b/lib/chibi/accept.c
@@ -0,0 +1,110 @@
+
+/* chibi-ffi should probably be able to detect these patterns automatically, */
+/* but for now we manually check two special cases - accept should check for */
+/* EWOULDBLOCK and block on the socket, and listen should automatically make */
+/* sockets non-blocking. */
+
+sexp sexp_accept (sexp ctx, sexp self, int sock, struct sockaddr* addr, socklen_t len) {
+#if SEXP_USE_GREEN_THREADS
+  sexp f;
+#endif
+  int res;
+  res = accept(sock, addr, &len);
+#if SEXP_USE_GREEN_THREADS
+  if (res < 0 && errno == EWOULDBLOCK) {
+    f = sexp_global(ctx, SEXP_G_THREADS_BLOCKER);
+    if (sexp_applicablep(f)) {
+      sexp_apply2(ctx, f, sexp_make_fixnum(sock), SEXP_FALSE);
+      return sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR);
+    }
+  }
+  if (res >= 0)
+    fcntl(res, F_SETFL, fcntl(res, F_GETFL) | O_NONBLOCK);
+#endif
+  return sexp_make_fileno(ctx, sexp_make_fixnum(res), SEXP_FALSE);
+}
+
+/* likewise sendto and recvfrom should suspend the thread gracefully */
+
+#define sexp_zerop(x) ((x) == SEXP_ZERO || (sexp_flonump(x) && sexp_flonum_value(x) == 0.0))
+
+sexp sexp_sendto (sexp ctx, sexp self, int sock, const void* buffer, size_t len, int flags, struct sockaddr* addr, socklen_t addr_len, sexp timeout) {
+#if SEXP_USE_GREEN_THREADS
+  sexp f;
+#endif
+  ssize_t res;
+  res = sendto(sock, buffer, len, flags, addr, addr_len);
+#if SEXP_USE_GREEN_THREADS
+  if (res < 0 && errno == EWOULDBLOCK && !sexp_zerop(timeout)) {
+    f = sexp_global(ctx, SEXP_G_THREADS_BLOCKER);
+    if (sexp_applicablep(f)) {
+      sexp_apply2(ctx, f, sexp_make_fixnum(sock), timeout);
+      return sexp_global(ctx, SEXP_G_IO_BLOCK_ONCE_ERROR);
+    }
+  }
+#endif
+  return sexp_make_fixnum(res);
+}
+
+sexp sexp_recvfrom (sexp ctx, sexp self, int sock, void* buffer, size_t len, int flags, struct sockaddr* addr, socklen_t addr_len, sexp timeout) {
+#if SEXP_USE_GREEN_THREADS
+  sexp f;
+#endif
+  ssize_t res;
+  res = recvfrom(sock, buffer, len, flags, addr, &addr_len);
+#if SEXP_USE_GREEN_THREADS
+  if (res < 0 && errno == EWOULDBLOCK && !sexp_zerop(timeout)) {
+    f = sexp_global(ctx, SEXP_G_THREADS_BLOCKER);
+    if (sexp_applicablep(f)) {
+      sexp_apply2(ctx, f, sexp_make_fixnum(sock), timeout);
+      return sexp_global(ctx, SEXP_G_IO_BLOCK_ONCE_ERROR);
+    }
+  }
+#endif
+  return sexp_make_fixnum(res);
+}
+
+/* If we're binding or listening on a socket from Scheme, we most */
+/* likely want it to be non-blocking. */
+
+sexp sexp_bind (sexp ctx, sexp self, int fd, struct sockaddr* addr, socklen_t addr_len) {
+  int res = bind(fd, addr, addr_len);
+#if SEXP_USE_GREEN_THREADS
+  if (res >= 0)
+    fcntl(fd, F_SETFL, fcntl(fd, F_GETFL) | O_NONBLOCK);
+#endif
+  return (res == 0) ? SEXP_TRUE : SEXP_FALSE;
+}
+
+sexp sexp_listen (sexp ctx, sexp self, sexp fileno, sexp backlog) {
+  int fd, res;
+  sexp_assert_type(ctx, sexp_filenop, SEXP_FILENO, fileno);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, backlog);
+  fd = sexp_fileno_fd(fileno);
+  res = listen(fd, sexp_unbox_fixnum(backlog));
+#if SEXP_USE_GREEN_THREADS
+  if (res >= 0)
+    fcntl(fd, F_SETFL, fcntl(fd, F_GETFL) | O_NONBLOCK);
+#endif
+  return (res == 0) ? SEXP_TRUE : SEXP_FALSE;
+}
+
+/* Additional utilities. */
+
+sexp sexp_sockaddr_name (sexp ctx, sexp self, struct sockaddr* addr) {
+  char buf[24];
+  /* struct sockaddr_in *sa = (struct sockaddr_in *)addr; */
+  /* unsigned char *ptr = (unsigned char *)&(sa->sin_addr); */
+  /* sprintf(buf, "%d.%d.%d.%d", ptr[0], ptr[1], ptr[2], ptr[3]); */
+  inet_ntop(addr->sa_family,
+            (addr->sa_family == AF_INET6 ?
+             (void*)(&(((struct sockaddr_in6 *)addr)->sin6_addr)) :
+             (void*)(&(((struct sockaddr_in *)addr)->sin_addr))),
+            buf, 24);
+  return sexp_c_string(ctx, buf, -1);
+}
+
+int sexp_sockaddr_port (sexp ctx, sexp self, struct sockaddr* addr) {
+  struct sockaddr_in *sa = (struct sockaddr_in *)addr;
+  return sa->sin_port;
+}
diff --git a/lib/chibi/app.scm b/lib/chibi/app.scm
new file mode 100644
index 00000000..315662f6
--- /dev/null
+++ b/lib/chibi/app.scm
@@ -0,0 +1,283 @@
+;; app.scm -- unified option parsing and config
+;; Copyright (c) 2012-2013 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> Parses command-line options into a config object.
+
+(define (parse-option prefix conf-spec args fail)
+  (define (parse-value type str)
+    (cond
+     ((not (string? str))
+      str)
+     ((and (pair? type) (eq? 'list (car type)))
+      (map (lambda (x) (parse-value (cadr type) x))
+           (string-split str #\,)))
+     (else
+      (case type
+        ((boolean) (not (member str '("#f" "#false" "#F" "#FALSE"))))
+        ((number) (string->number str))
+        ((symbol) (string->symbol str))
+        ((char) (string-ref str 0))
+        (else str)))))
+  (define (lookup-conf-spec conf-spec syms strs)
+    (let ((sym (car syms))
+          (str (car strs)))
+      (cond
+       ((= 1 (length syms))
+        (let lp ((ls conf-spec))
+          (and (pair? ls)
+               (let ((x (car ls)))
+                 (cond
+                  ((eq? sym (car x)) x)
+                  ((and (pair? (cddr x)) (member str (car (cddr x)))) x)
+                  ((and (pair? (cddr x)) (member `(not ,str) (car (cddr x))))
+                   `(not ,x))
+                  (else (lp (cdr ls))))))))
+       (else
+        (let lp ((ls conf-spec))
+          (and (pair? ls)
+               (let ((x (car ls)))
+                 (cond
+                  ((or (eq? sym (car x))
+                       (and (pair? (cddr x)) (member str (car (cddr x)))))
+                   (let ((type (cadr x)))
+                     (if (not (and (pair? type) (eq? 'conf (car type))))
+                         (error "option prefix not a subconf" sym)
+                         (lookup-conf-spec (cdr type) (cdr syms) (cdr strs)))))
+                  (else (lp (cdr ls)))))))))))
+  (define (lookup-short-option ch spec)
+    (let lp ((ls spec))
+      (and (pair? ls)
+           (let ((x (car ls)))
+             (cond
+              ((and (pair? (cddr x)) (memv ch (car (cddr x))))
+               x)
+              ((and (pair? (cddr x)) (member `(not ,ch) (car (cddr x))))
+               `(not ,x))
+              (else (lp (cdr ls))))))))
+  (define (parse-conf-spec str args)
+    (let* ((strs (string-split str #\.))
+           (syms (map string->symbol strs))
+           (spec (lookup-conf-spec conf-spec syms strs)))
+      (cond
+       ((not spec)
+        #f)
+       ((and (pair? spec) (eq? 'not (car spec)))
+        (cons (cons (append prefix (list (car spec))) #f) args))
+       ((eq? 'boolean (cadr spec))
+        (cons (cons (append prefix (list (car spec))) #t) args))
+       ((null? args)
+        (error "missing argument to option " str))
+       (else
+        (cons (cons (append prefix syms) (parse-value (cadr spec) (car args)))
+              (cdr args))))))
+  (define (parse-long-option str args)
+    (let* ((str+val (string-split str #\= 2))
+           (str (car str+val))
+           (args2 (if (pair? (cdr str+val)) (cons (cadr str+val) args) args)))
+      (or (parse-conf-spec str args2)
+          (and (string-prefix? "no-" str)
+               (let ((res (parse-long-option (substring str 3) args)))
+                 (cond
+                  ((not res)
+                   #f)
+                  ((not (boolean? (cdar res)))
+                   (error "'no-' prefix only valid on boolean options"))
+                  (else
+                   `(((,@prefix ,(caar res)) . ,(not (cdar res)))
+                     ,@(cdr res)))))))))
+  (define (parse-short-option str args)
+    (let* ((ch (string-ref str 0))
+           (x (lookup-short-option ch conf-spec)))
+      (cond
+       ((not x)
+        #f)
+       ((and (pair? x) (eq? 'not (car x)))
+        (cons (cons (append prefix (list (car (cadr x)))) #f)
+              (if (= 1 (string-length str))
+                  args
+                  (cons (string-append "-" (substring str 1)) args))))
+       ((eq? 'boolean (cadr x))
+        (cons (cons (append prefix (list (car x))) #t)
+              (if (= 1 (string-length str))
+                  args
+                  (cons (string-append "-" (substring str 1)) args))))
+       ((> (string-length str) 1)
+        (cons (cons (append prefix (list (car x)))
+                    (parse-value (cadr x) (substring str 1)))
+              args))
+       ((null? args)
+        (error "missing argument to option " x))
+       (else
+        (cons (cons (append prefix (list (car x))) (car args)) (cdr args))))))
+  (or (if (eqv? #\- (string-ref (car args) 1))
+          (parse-long-option (substring (car args) 2) (cdr args))
+          (parse-short-option (substring (car args) 1) (cdr args)))
+      (fail prefix conf-spec (car args) args)))
+
+(define (parse-options prefix conf-spec orig-args fail)
+  (let lp ((args orig-args)
+           (opts (make-conf '() #f (cons 'options orig-args) #f)))
+    (cond
+     ((null? args)
+      (cons opts args))
+     ((or (member (car args) '("" "-" "--"))
+          (not (eqv? #\- (string-ref (car args) 0))))
+      (cons opts (if (equal? (car args) "--") (cdr args) args)))
+     (else
+      (let ((val+args (parse-option prefix conf-spec args fail)))
+        (lp (cdr val+args)
+            (conf-set opts (caar val+args) (cdar val+args))))))))
+
+(define (parse-app prefix spec opt-spec args config init end . o)
+  (define (next-prefix prefix name)
+    (append (if (null? prefix) '(command) prefix) (list name)))
+  (define (prev-prefix prefix)
+    (cond ((and (= 2 (length prefix))))
+          ((null? prefix) '())
+          (else (reverse (cdr (reverse  prefix))))))
+  (let ((fail (if (pair? o)
+                  (car o)
+                  (lambda (prefix spec opt args)
+                    ;; TODO: search for closest option
+                    (error "unknown option: " opt)))))
+    (cond
+     ((null? spec)
+      (error "no procedure in application spec"))
+     ((pair? (car spec))
+      (case (caar spec)
+        ((@)
+         (let* ((new-opt-spec (cadr (car spec)))
+                (new-fail
+                 (lambda (new-prefix new-spec opt args)
+                   (parse-option (prev-prefix prefix) opt-spec args fail)))
+                (cfg+args (parse-options prefix new-opt-spec args new-fail))
+                (config (conf-append (car cfg+args) config))
+                (args (cdr cfg+args)))
+           (parse-app prefix (cdr spec) new-opt-spec args config init end new-fail)))
+        ((or)
+         (any (lambda (x) (parse-app prefix x opt-spec args config init end))
+              (cdar spec)))
+        ((begin:)
+         (parse-app prefix (cdr spec) opt-spec args config (cadr (car spec)) end fail))
+        ((end:)
+         (parse-app prefix (cdr spec) opt-spec args config init (cadr (car spec)) fail))
+        (else
+         (if (procedure? (caar spec))
+             (vector (caar spec) config args init end) ; TODO: verify
+             (parse-app prefix (car spec) opt-spec args config init end fail)))))
+     ((symbol? (car spec))
+      (and (pair? args)
+           (eq? (car spec) (string->symbol (car args)))
+           (let ((prefix (next-prefix prefix (car spec))))
+             (parse-app prefix (cdr spec) opt-spec (cdr args) config init end fail))))
+     ((procedure? (car spec))
+      (vector (car spec) config args init end))
+     (else
+      (if (not (string? (car spec)))
+          (error "unknown application spec" (car spec)))
+      (parse-app prefix (cdr spec) opt-spec args config init end fail)))))
+
+(define (print-command-help command out)
+  (cond
+   ((and (pair? command) (symbol? (car command)))
+    (display "  " out)
+    (display (car command) out)
+    (cond
+     ((find (lambda (x) (and (pair? x) (procedure? (car x)))) command)
+      => (lambda (x)
+           (let lp ((args (cdr x)) (opt-depth 0))
+             (cond
+              ((null? args)
+               (display (make-string opt-depth #\]) out))
+              ((pair? (car args))
+               (display " [" out)
+               (display (caar args) out)
+               (lp (cdr args) (+ opt-depth 1)))
+              (else
+               (display " " out)
+               (display (car args) out)
+               (lp (cdr args) opt-depth)))))))
+    (cond
+     ((find string? command)
+      => (lambda (doc-string) (display " - " out) (display doc-string out))))
+    (newline out))))
+
+(define (print-option-help option out)
+  (let* ((str (symbol->string (car option)))
+         (names (if (and (pair? (cdr option)) (pair? (cddr option)))
+                    (car (cddr option))
+                    '()))
+         (pref-str (cond ((find string? names) => values) (else str)))
+         (pref-ch (find char? names))
+         (doc (find string? (cdr option))))
+    ;; TODO: consider aligning these
+    (cond
+     (pref-ch (display "  -" out) (write-char pref-ch out))
+     (else (display "    " out)))
+    (cond
+     (pref-str
+      (display (if pref-ch ", " "  ") out)
+      (display "--" out) (display pref-str out)))
+    (cond (doc (display " - " out) (display doc out)))
+    (newline out)))
+
+(define (print-help name docs commands options . o)
+  (let ((out (if (pair? o) (car o) (current-output-port))))
+    (display "Usage: " out) (display name out)
+    (if (pair? options) (display " [options]" out))
+    (case (length commands)
+      ((0) (newline out))
+      (else
+       (display " <command>\nCommands:\n" out)
+       (for-each (lambda (c) (print-command-help c out)) commands))
+      ((1) (print-command-help (car commands) out)))
+    (if (pair? options) (display "Options:\n" out))
+    (for-each (lambda (o) (print-option-help o out)) options)))
+
+(define (app-help spec args . o)
+  (let ((out (if (pair? o) (car o) (current-output-port))))
+    (let lp ((ls (cdr spec))
+             (docs #f)
+             (commands '())
+             (options '()))
+      (cond
+       ((null? ls)
+        (print-help (car spec) docs commands options out))
+       ((or (string? (car ls))
+            (and (pair? (car ls)) (memq (caar ls) '(begin: end:) )))
+        (lp (cdr ls) (car ls) commands options))
+       ((and (pair? (car ls)) (eq? '@ (caar ls)))
+        (lp (cdr ls) docs commands (append options (cadr (car ls)))))
+       ((and (pair? (car ls)) (symbol? (caar ls)))
+        ;; don't print nested commands
+        (if (pair? commands)
+            (print-help (car spec) docs commands options out)
+            (if (eq? 'or (caar ls))
+                (lp (cdr ls) docs (cdar ls) options)
+                (lp (cdr ls) docs (list (car ls)) options))))
+       (else
+        (lp (cdr ls) docs commands options))))))
+
+(define (app-help-command config spec . args)
+  (app-help spec args (current-output-port)))
+
+(define (run-application spec . o)
+  (let ((args (or (and (pair? o) (car o)) (command-line)))
+        (config (and (pair? o) (pair? (cdr o)) (cadr o))))
+    (cond
+     ((parse-app '() (cdr spec) '() (cdr args) config #f #f)
+      => (lambda (v)
+           (let ((proc (vector-ref v 0))
+                 (cfg (vector-ref v 1))
+                 (args (vector-ref v 2))
+                 (init (vector-ref v 3))
+                 (end (vector-ref v 4)))
+             (if init (init cfg))
+             (apply proc cfg spec args)
+             (if end (end cfg)))))
+     ((null? (cdr args))
+      (apply app-help-command config spec args)
+      (error "Expected a command"))
+     (else
+      (error "Unknown command: " (cdr args))))))
diff --git a/lib/chibi/app.sld b/lib/chibi/app.sld
new file mode 100644
index 00000000..585cfc95
--- /dev/null
+++ b/lib/chibi/app.sld
@@ -0,0 +1,11 @@
+
+(define-library (chibi app)
+  (export parse-option parse-options parse-app run-application
+          app-help app-help-command)
+  (import (scheme base)
+          (scheme write)
+          (scheme process-context)
+          (srfi 1)
+          (chibi config)
+          (chibi string))
+  (include "app.scm"))
diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c
new file mode 100644
index 00000000..e29db840
--- /dev/null
+++ b/lib/chibi/ast.c
@@ -0,0 +1,656 @@
+/*  ast.c -- interface to the Abstract Syntax Tree            */
+/*  Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+
+#ifndef PLAN9
+#include <errno.h>
+#endif
+
+#if ! SEXP_USE_BOEHM
+extern sexp sexp_gc (sexp ctx, size_t *sum_freed);
+#endif
+
+static void sexp_define_type_predicate (sexp ctx, sexp env, const char *cname, sexp_uint_t type) {
+  sexp_gc_var2(name, op);
+  sexp_gc_preserve2(ctx, name, op);
+  name = sexp_c_string(ctx, cname, -1);
+  op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type));
+  sexp_env_define(ctx, env, name=sexp_intern(ctx, cname, -1), op);
+  sexp_gc_release2(ctx);
+}
+
+static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype,
+                                   sexp_uint_t cindex,
+                                   const char* get, const char *set) {
+  sexp type, index;
+  sexp_gc_var2(name, op);
+  sexp_gc_preserve2(ctx, name, op);
+  type = sexp_make_fixnum(ctype);
+  index = sexp_make_fixnum(cindex);
+  if (get) {
+    op = sexp_make_getter(ctx, name=sexp_c_string(ctx, get, -1), type, index);
+    sexp_env_define(ctx, env, name=sexp_intern(ctx, get, -1), op);
+  }
+  if (set) {
+    op = sexp_make_setter(ctx, name=sexp_c_string(ctx, set, -1), type, index);
+    sexp_env_define(ctx, env, name=sexp_intern(ctx, set, -1), op);
+  }
+  sexp_gc_release2(ctx);
+}
+
+static sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id, sexp createp) {
+  sexp cell;
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
+  cell = sexp_env_cell(ctx, env, id, 0);
+  if (! cell) {
+    if (sexp_synclop(id)) {
+      env = sexp_synclo_env(id);
+      id = sexp_synclo_expr(id);
+    }
+    cell = sexp_env_cell(ctx, env, id, 0);
+    if (!cell && createp)
+      cell = sexp_env_cell_define(ctx, env, id, SEXP_UNDEF, NULL);
+  }
+  return cell ? cell : SEXP_FALSE;
+}
+
+static sexp sexp_get_procedure_code (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
+  return sexp_procedure_code(proc);
+}
+
+static sexp sexp_get_procedure_vars (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
+  return sexp_procedure_vars(proc);
+}
+
+static sexp sexp_get_procedure_arity (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
+  return sexp_make_fixnum(sexp_procedure_num_args(proc));
+}
+
+static sexp sexp_get_procedure_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
+  return sexp_make_boolean(sexp_procedure_variadic_p(proc));
+}
+
+static sexp sexp_get_opcode_name (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+  if (! sexp_opcodep(op))
+    return sexp_type_exception(ctx, self, SEXP_OPCODE, op);
+  else if (! sexp_opcode_name(op))
+    return SEXP_FALSE;
+  else
+    return sexp_opcode_name(op);
+}
+
+static sexp sexp_translate_opcode_type (sexp ctx, sexp type) {
+  sexp_gc_var2(res, tmp);
+  res = type;
+  if (! res) {
+    res = sexp_type_by_index(ctx, SEXP_OBJECT);
+  } if (sexp_fixnump(res)) {
+    res = sexp_type_by_index(ctx, sexp_unbox_fixnum(res));
+  } else if (sexp_nullp(res)) {        /* opcode list types */
+    sexp_gc_preserve2(ctx, res, tmp);
+    tmp = sexp_intern(ctx, "or", -1);
+    res = sexp_cons(ctx, SEXP_NULL, SEXP_NULL);
+    res = sexp_cons(ctx, sexp_type_by_index(ctx, SEXP_PAIR), res);
+    res = sexp_cons(ctx, tmp, res);
+    sexp_gc_release2(ctx);
+  }
+  return res;
+}
+
+static sexp sexp_get_opcode_ret_type (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+  sexp res;
+  if (!op)
+    return sexp_type_by_index(ctx, SEXP_OBJECT);
+  if (! sexp_opcodep(op))
+    return sexp_type_exception(ctx, self, SEXP_OPCODE, op);
+  if (sexp_opcode_code(op) == SEXP_OP_RAISE)
+    return sexp_list1(ctx, sexp_intern(ctx, "error", -1));
+  res = sexp_opcode_return_type(op);
+  if (sexp_fixnump(res))
+    res = sexp_type_by_index(ctx, sexp_unbox_fixnum(res));
+  return sexp_translate_opcode_type(ctx, res);
+}
+
+static sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp op, sexp k) {
+  sexp res;
+  int p = sexp_unbox_fixnum(k);
+  if (! sexp_opcodep(op))
+    return sexp_type_exception(ctx, self, SEXP_OPCODE, op);
+  else if (! sexp_fixnump(k))
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, k);
+  if (p > sexp_opcode_num_args(op) && sexp_opcode_variadic_p(op))
+    p = sexp_opcode_num_args(op);
+  switch (p) {
+  case 0:
+    res = sexp_opcode_arg1_type(op);
+    break;
+  case 1:
+    res = sexp_opcode_arg2_type(op);
+    break;
+  default:
+    res = sexp_opcode_arg3_type(op);
+    if (res && sexp_vectorp(res)) {
+      if (sexp_vector_length(res) > (sexp_unbox_fixnum(k)-2))
+        res = sexp_vector_ref(res, sexp_fx_sub(k, SEXP_TWO));
+      else
+        res = sexp_type_by_index(ctx, SEXP_OBJECT);
+    }
+    break;
+  }
+  return sexp_translate_opcode_type(ctx, res);
+}
+
+static sexp sexp_get_opcode_class (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+  sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
+  return sexp_make_fixnum(sexp_opcode_class(op));
+}
+
+static sexp sexp_get_opcode_code (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+  sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
+  return sexp_make_fixnum(sexp_opcode_code(op));
+}
+
+static sexp sexp_get_opcode_data (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+  sexp data;
+  sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
+  data = sexp_opcode_data(op);
+  if (!data) return SEXP_VOID;
+  return sexp_opcode_class(op) == SEXP_OPC_TYPE_PREDICATE
+    && 0 <= sexp_unbox_fixnum(data)
+    && sexp_unbox_fixnum(data) <= sexp_context_num_types(ctx) ?
+    sexp_type_by_index(ctx, sexp_unbox_fixnum(data)) : data;
+}
+
+static sexp sexp_get_opcode_num_params (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+  sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
+  return sexp_make_fixnum(sexp_opcode_num_args(op));
+}
+
+static sexp sexp_get_opcode_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+  sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
+  return sexp_make_boolean(sexp_opcode_variadic_p(op));
+}
+
+static sexp sexp_get_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p) {
+  sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p);
+  return sexp_make_fixnum(sexp_port_line(p));
+}
+
+static sexp sexp_set_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p, sexp i) {
+  sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
+  sexp_port_line(p) = sexp_unbox_fixnum(i);
+  return SEXP_VOID;
+}
+
+static sexp sexp_type_of (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  if (!x)
+    return sexp_type_by_index(ctx, SEXP_OBJECT);
+  if (sexp_pointerp(x))
+    return sexp_object_type(ctx, x);
+  else if (sexp_fixnump(x))
+    return sexp_type_by_index(ctx, SEXP_FIXNUM);
+  else if (sexp_booleanp(x))
+    return sexp_type_by_index(ctx, SEXP_BOOLEAN);
+  else if (sexp_charp(x))
+    return sexp_type_by_index(ctx, SEXP_CHAR);
+#if SEXP_USE_HUFF_SYMS
+  else if (sexp_symbolp(x))
+    return sexp_type_by_index(ctx, SEXP_SYMBOL);
+#endif
+#if SEXP_USE_IMMEDIATE_FLONUMS
+  else if (sexp_flonump(x))
+    return sexp_type_by_index(ctx, SEXP_FLONUM);
+#endif
+  else
+    return sexp_type_by_index(ctx, SEXP_OBJECT);
+}
+
+static sexp sexp_env_parent_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
+  return sexp_env_parent(e) ? sexp_env_parent(e) : SEXP_FALSE;
+}
+
+static sexp sexp_env_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
+  return sexp_env_lambda(e) ? sexp_env_lambda(e) : SEXP_FALSE;
+}
+
+static sexp sexp_env_lambda_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp lam) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
+  sexp_assert_type(ctx, sexp_lambdap, SEXP_LAMBDA, lam);
+  sexp_env_lambda(e) = lam;
+  return SEXP_VOID;
+}
+
+static sexp sexp_env_syntactic_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
+  return sexp_make_boolean(sexp_env_syntactic_p(e));
+}
+
+static sexp sexp_env_syntactic_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp synp) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
+  sexp_env_syntactic_p(e) = sexp_truep(synp);
+  return SEXP_VOID;
+}
+
+static sexp sexp_env_define_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
+  sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name);
+  return sexp_env_cell_define(ctx, env, name, value, NULL);
+}
+
+static sexp sexp_env_push_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
+  sexp_gc_var1(tmp);
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
+  sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name);
+  sexp_gc_preserve1(ctx, tmp);
+  sexp_env_push(ctx, env, tmp, name, value);
+  sexp_gc_release1(ctx);
+  return SEXP_VOID;
+}
+
+static sexp sexp_core_code_op (sexp ctx, sexp self, sexp_sint_t n, sexp c) {
+  sexp_assert_type(ctx, sexp_corep, SEXP_CORE, c);
+  return sexp_make_fixnum(sexp_core_code(c));
+}
+
+static sexp sexp_type_name_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+  sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
+  return sexp_type_name(t);
+}
+
+static sexp sexp_type_cpl_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+  sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
+  return sexp_type_cpl(t);
+}
+
+static sexp sexp_type_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+  sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
+  return sexp_type_slots(t);
+}
+
+static sexp sexp_type_num_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+  sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
+  return sexp_truep(sexp_type_slots(t)) ? sexp_length(ctx, sexp_type_slots(t))
+    : sexp_make_fixnum(sexp_type_field_eq_len_base(t));
+}
+
+static sexp sexp_type_printer_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+  sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
+  return sexp_type_print(t) ? sexp_type_print(t) : SEXP_FALSE;
+}
+
+static sexp sexp_object_size (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  sexp t;
+  if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx)))
+    return SEXP_ZERO;
+  t = sexp_object_type(ctx, x);
+  return sexp_make_fixnum(sexp_type_size_of_object(t, x));
+}
+
+static sexp sexp_integer_to_immediate (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp dflt) {
+  sexp x = (sexp)sexp_unbox_fixnum(i);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
+  if (sexp_pointerp(x))
+    return dflt;
+  return x;
+}
+
+static sexp sexp_make_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp params, sexp body, sexp locals) {
+  sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA);
+  sexp_lambda_name(res) = name;
+  sexp_lambda_params(res) = params;
+  sexp_lambda_body(res) = body;
+  sexp_lambda_locals(res) = locals;
+  sexp_lambda_fv(res) = SEXP_NULL;
+  sexp_lambda_sv(res) = SEXP_NULL;
+  sexp_lambda_defs(res) = SEXP_NULL;
+  sexp_lambda_return_type(res) = SEXP_FALSE;
+  sexp_lambda_param_types(res) = SEXP_NULL;
+  return res;
+}
+
+static sexp sexp_copy_lambda (sexp ctx, sexp self, sexp_sint_t n, sexp lambda) {
+  sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA);
+  sexp_lambda_name(res) = sexp_lambda_name(lambda);
+  sexp_lambda_params(res) = sexp_lambda_params(lambda);
+  sexp_lambda_body(res) = sexp_lambda_body(lambda);
+  sexp_lambda_locals(res) = sexp_lambda_locals(lambda);
+  sexp_lambda_fv(res) = sexp_lambda_fv(lambda);
+  sexp_lambda_sv(res) = sexp_lambda_sv(lambda);
+  sexp_lambda_defs(res) = sexp_lambda_defs(lambda);
+  sexp_lambda_return_type(res) = sexp_lambda_return_type(lambda);
+  sexp_lambda_param_types(res) = sexp_lambda_param_types(lambda);
+  return res;
+}
+
+static sexp sexp_make_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp var, sexp value) {
+  sexp res = sexp_alloc_type(ctx, set, SEXP_SET);
+  sexp_set_var(res) = var;
+  sexp_set_value(res) = value;
+  return res;
+}
+
+static sexp sexp_make_ref_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp cell) {
+  sexp res = sexp_alloc_type(ctx, ref, SEXP_REF);
+  sexp_ref_name(res) = name;
+  sexp_ref_cell(res) = cell;
+  return res;
+}
+
+static sexp sexp_make_cnd_op (sexp ctx, sexp self, sexp_sint_t n, sexp test, sexp pass, sexp fail) {
+  sexp res = sexp_alloc_type(ctx, cnd, SEXP_CND);
+  sexp_cnd_test(res) = test;
+  sexp_cnd_pass(res) = pass;
+  sexp_cnd_fail(res) = fail;
+  return res;
+}
+
+static sexp sexp_make_seq (sexp ctx, sexp self, sexp_sint_t n, sexp ls) {
+  sexp res = sexp_alloc_type(ctx, seq, SEXP_SEQ);
+  sexp_seq_ls(res) = ls;
+  return res;
+}
+
+static sexp sexp_make_lit_op (sexp ctx, sexp self, sexp_sint_t n, sexp value) {
+  sexp res = sexp_alloc_type(ctx, lit, SEXP_LIT);
+  sexp_lit_value(res) = value;
+  return res;
+}
+
+static sexp sexp_make_macro_op (sexp ctx, sexp self, sexp_sint_t n, sexp proc, sexp env) {
+  sexp res = sexp_alloc_type(ctx, macro, SEXP_MACRO);
+  sexp_macro_proc(res) = proc;
+  sexp_macro_env(res) = env;
+  return res;
+}
+
+static sexp sexp_analyze_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) {
+  sexp ctx2 = ctx;
+  if (sexp_envp(e)) {
+    ctx2 = sexp_make_child_context(ctx, NULL);
+    sexp_context_env(ctx2) = e;
+  }
+  return sexp_analyze(ctx2, x);
+}
+
+static sexp sexp_extend_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp vars, sexp value) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
+  return sexp_extend_env(ctx, env, vars, value);
+}
+
+static sexp sexp_optimize (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  sexp_gc_var2(ls, res);
+  sexp_gc_preserve2(ctx, ls, res);
+  res = x;
+  ls = sexp_global(ctx, SEXP_G_OPTIMIZATIONS);
+  for ( ; sexp_pairp(ls); ls=sexp_cdr(ls))
+    res = sexp_apply1(ctx, sexp_cdar(ls), res);
+  sexp_free_vars(ctx, res, SEXP_NULL);
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+static sexp sexp_gc_op (sexp ctx, sexp self, sexp_sint_t n) {
+  size_t sum_freed=0;
+#if SEXP_USE_BOEHM
+  GC_gcollect();
+#else
+  sexp_gc(ctx, &sum_freed);
+#endif
+  return sexp_make_unsigned_integer(ctx, sum_freed);
+}
+
+#if SEXP_USE_GREEN_THREADS
+static sexp sexp_set_atomic (sexp ctx, sexp self, sexp_sint_t n, sexp new) {
+  sexp res = sexp_global(ctx, SEXP_G_ATOMIC_P);
+  sexp_global(ctx, SEXP_G_ATOMIC_P) = new;
+  return res;
+}
+#endif
+
+sexp sexp_thread_list (sexp ctx, sexp self, sexp_sint_t n) {
+  sexp ls;
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  res = SEXP_NULL;
+#if SEXP_USE_GREEN_THREADS
+  for (ls=sexp_global(ctx, SEXP_G_THREADS_FRONT); sexp_pairp(ls); ls=sexp_cdr(ls))
+    sexp_push(ctx, res, sexp_car(ls));
+  for (ls=sexp_global(ctx, SEXP_G_THREADS_PAUSED); sexp_pairp(ls); ls=sexp_cdr(ls))
+    sexp_push(ctx, res, sexp_car(ls));
+#endif
+  if (sexp_not(sexp_memq(ctx, ctx, res))) sexp_push(ctx, res, ctx);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+static sexp sexp_string_contains (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
+  const char *res;
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, x);
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, y);
+  res = strstr(sexp_string_data(x), sexp_string_data(y));
+  return res ? sexp_make_fixnum(res-sexp_string_data(x)) : SEXP_FALSE;
+}
+
+static sexp sexp_string_cursor_copy (sexp ctx, sexp self, sexp_sint_t n, sexp dst, sexp sfrom, sexp src, sexp sstart, sexp send) {
+  unsigned char *pfrom, *pto, *pstart, *pend, *prev, *p;
+  sexp_sint_t from = sexp_unbox_fixnum(sfrom), to = sexp_string_size(dst),
+    start = sexp_unbox_fixnum(sstart), end = sexp_unbox_fixnum(send);
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, dst);
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, src);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, sfrom);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, sstart);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, send);
+  if (from < 0 || from > to)
+    return sexp_user_exception(ctx, self, "string-cursor-copy!: from out of range", sfrom);
+  if (start < 0 || start > sexp_string_size(src))
+    return sexp_user_exception(ctx, self, "string-cursor-copy!: start out of range", sstart);
+  if (end < start || end > sexp_string_size(src))
+    return sexp_user_exception(ctx, self, "string-cursor-copy!: end out of range", send);
+  pfrom = (unsigned char*)sexp_string_data(dst) + from;
+  pto = (unsigned char*)sexp_string_data(dst) + to;
+  pstart = (unsigned char*)sexp_string_data(src) + start;
+  pend = (unsigned char*)sexp_string_data(src) + end;
+  for ( ; pfrom < pto && pstart < pend; ++pfrom, ++pstart)
+    *pfrom = *pstart;
+  /* adjust for incomplete trailing chars */
+  prev = (unsigned char*)sexp_string_utf8_prev(pfrom);
+  if (sexp_utf8_initial_byte_count(*prev) > pfrom - prev) {
+    for (p = prev; p < pfrom; ++p)
+      *p = '\0';
+    pstart -= pfrom - prev;
+  }
+  return sexp_make_fixnum(pstart - (unsigned char*)sexp_string_data(src));
+}
+
+static sexp sexp_errno (sexp ctx, sexp self, sexp_sint_t n) {
+#ifdef PLAN9
+  return SEXP_FALSE;
+#else
+  return sexp_make_fixnum(errno);
+#endif
+}
+
+static sexp sexp_error_string (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+#ifdef PLAN9
+  return SEXP_FALSE;
+#else
+  int err;
+  if (x == SEXP_FALSE) {
+    err = errno;
+  } else {
+    sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, x);
+    err = sexp_unbox_fixnum(x);
+  }
+  return sexp_c_string(ctx, strerror(err), -1);
+#endif
+}
+
+static sexp sexp_update_free_vars (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  return sexp_free_vars(ctx, x, SEXP_NULL);
+}
+
+static sexp sexp_setenv (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp value) {
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name);
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, value);
+  return sexp_make_boolean(setenv(sexp_string_data(name), sexp_string_data(value), 1));
+}
+
+static sexp sexp_unsetenv (sexp ctx, sexp self, sexp_sint_t n, sexp name) {
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name);
+  return sexp_make_boolean(unsetenv(sexp_string_data(name)));
+}
+
+#define sexp_define_type(ctx, name, tag) \
+  sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), sexp_type_by_index(ctx, tag));
+
+sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
+  if (!(sexp_version_compatible(ctx, version, sexp_version)
+        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
+    return SEXP_ABI_ERROR;
+  sexp_define_type(ctx, "Object", SEXP_OBJECT);
+  sexp_define_type(ctx, "Number", SEXP_NUMBER);
+  sexp_define_type(ctx, "Bignum", SEXP_BIGNUM);
+  sexp_define_type(ctx, "Flonum", SEXP_FLONUM);
+  sexp_define_type(ctx, "Integer", SEXP_FIXNUM);
+#if SEXP_USE_RATIOS
+  sexp_define_type(ctx, "Ratio", SEXP_RATIO);
+#endif
+#if SEXP_USE_COMPLEX
+  sexp_define_type(ctx, "Complex", SEXP_COMPLEX);
+#endif
+  sexp_define_type(ctx, "Symbol", SEXP_SYMBOL);
+  sexp_define_type(ctx, "Char", SEXP_CHAR);
+  sexp_define_type(ctx, "Boolean", SEXP_BOOLEAN);
+  sexp_define_type(ctx, "String", SEXP_STRING);
+  sexp_define_type(ctx, "Byte-Vector", SEXP_BYTES);
+  sexp_define_type(ctx, "Pair", SEXP_PAIR);
+  sexp_define_type(ctx, "Vector", SEXP_VECTOR);
+  sexp_define_type(ctx, "Input-Port", SEXP_IPORT);
+  sexp_define_type(ctx, "Output-Port", SEXP_OPORT);
+  sexp_define_type(ctx, "File-Descriptor", SEXP_FILENO);
+  sexp_define_type(ctx, "Opcode", SEXP_OPCODE);
+  sexp_define_type(ctx, "Procedure", SEXP_PROCEDURE);
+  sexp_define_type(ctx, "Bytecode", SEXP_BYTECODE);
+  sexp_define_type(ctx, "Env", SEXP_ENV);
+  sexp_define_type(ctx, "Macro", SEXP_MACRO);
+  sexp_define_type(ctx, "Lam", SEXP_LAMBDA);
+  sexp_define_type(ctx, "Cnd", SEXP_CND);
+  sexp_define_type(ctx, "Set", SEXP_SET);
+  sexp_define_type(ctx, "Ref", SEXP_REF);
+  sexp_define_type(ctx, "Seq", SEXP_SEQ);
+  sexp_define_type(ctx, "Lit", SEXP_LIT);
+  sexp_define_type(ctx, "Sc", SEXP_SYNCLO);
+  sexp_define_type(ctx, "Context", SEXP_CONTEXT);
+  sexp_define_type(ctx, "Exception", SEXP_EXCEPTION);
+  sexp_define_type(ctx, "Core", SEXP_CORE);
+  sexp_define_type_predicate(ctx, env, "environment?", SEXP_ENV);
+  sexp_define_type_predicate(ctx, env, "bytecode?", SEXP_BYTECODE);
+  sexp_define_type_predicate(ctx, env, "macro?", SEXP_MACRO);
+  sexp_define_type_predicate(ctx, env, "syntactic-closure?", SEXP_SYNCLO);
+  sexp_define_type_predicate(ctx, env, "lambda?", SEXP_LAMBDA);
+  sexp_define_type_predicate(ctx, env, "cnd?", SEXP_CND);
+  sexp_define_type_predicate(ctx, env, "set?", SEXP_SET);
+  sexp_define_type_predicate(ctx, env, "ref?", SEXP_REF);
+  sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ);
+  sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT);
+  sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE);
+  sexp_define_type_predicate(ctx, env, "type?", SEXP_TYPE);
+  sexp_define_type_predicate(ctx, env, "core?", SEXP_CORE);
+  sexp_define_type_predicate(ctx, env, "context?", SEXP_CONTEXT);
+  sexp_define_type_predicate(ctx, env, "file-descriptor?", SEXP_FILENO);
+  sexp_define_accessors(ctx, env, SEXP_SYNCLO, 0, "syntactic-closure-env", NULL);
+  sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", NULL);
+  sexp_define_accessors(ctx, env, SEXP_SYNCLO, 2, "syntactic-closure-expr", NULL);
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 0, "lambda-name", "lambda-name-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 1, "lambda-params", "lambda-params-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 2, "lambda-body", "lambda-body-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 3, "lambda-defs", "lambda-defs-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 4, "lambda-locals", "lambda-locals-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 5, "lambda-flags", "lambda-flags-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 6, "lambda-free-vars", "lambda-free-vars-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 7, "lambda-set-vars", "lambda-set-vars-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 8, "lambda-return-type", "lambda-return-type-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 9, "lambda-param-types", "lambda-param-types-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 10, "lambda-source", "lambda-source-set!");
+  sexp_define_accessors(ctx, env, SEXP_CND, 0, "cnd-test", "cnd-test-set!");
+  sexp_define_accessors(ctx, env, SEXP_CND, 1, "cnd-pass", "cnd-pass-set!");
+  sexp_define_accessors(ctx, env, SEXP_CND, 2, "cnd-fail", "cnd-fail-set!");
+  sexp_define_accessors(ctx, env, SEXP_SET, 0, "set-var", "set-var-set!");
+  sexp_define_accessors(ctx, env, SEXP_SET, 1, "set-value", "set-value-set!");
+  sexp_define_accessors(ctx, env, SEXP_REF, 0, "ref-name", "ref-name-set!");
+  sexp_define_accessors(ctx, env, SEXP_REF, 1, "ref-cell", "ref-cell-set!");
+  sexp_define_accessors(ctx, env, SEXP_SEQ, 0, "seq-ls", "seq-ls-set!");
+  sexp_define_accessors(ctx, env, SEXP_LIT, 0, "lit-value", "lit-value-set!");
+  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 2, "bytecode-name", "bytecode-name-set!");
+  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 3, "bytecode-literals", NULL);
+  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 4, "bytecode-source", NULL);
+  sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 1, "exception-message", NULL);
+  sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 4, "exception-source", NULL);
+  sexp_define_accessors(ctx, env, SEXP_MACRO, 0, "macro-procedure", NULL);
+  sexp_define_accessors(ctx, env, SEXP_MACRO, 1, "macro-env", NULL);
+  sexp_define_accessors(ctx, env, SEXP_MACRO, 2, "macro-source", NULL);
+  sexp_define_foreign(ctx, env, "procedure-code", 1, sexp_get_procedure_code);
+  sexp_define_foreign(ctx, env, "procedure-vars", 1, sexp_get_procedure_vars);
+  sexp_define_foreign(ctx, env, "procedure-arity", 1, sexp_get_procedure_arity);
+  sexp_define_foreign(ctx, env, "procedure-variadic?", 1, sexp_get_procedure_variadic_p);
+  sexp_define_foreign(ctx, env, "copy-lambda", 1, sexp_copy_lambda);
+  sexp_define_foreign_opt(ctx, env, "make-lambda", 4, sexp_make_lambda_op, SEXP_NULL);
+  sexp_define_foreign_opt(ctx, env, "make-cnd", 3, sexp_make_cnd_op, SEXP_VOID);
+  sexp_define_foreign(ctx, env, "make-ref", 2, sexp_make_ref_op);
+  sexp_define_foreign(ctx, env, "make-set", 2, sexp_make_set_op);
+  sexp_define_foreign(ctx, env, "make-lit", 1, sexp_make_lit_op);
+  sexp_define_foreign(ctx, env, "make-seq", 1, sexp_make_seq);
+  sexp_define_foreign(ctx, env, "make-macro", 2, sexp_make_macro_op);
+  sexp_define_foreign_opt(ctx, env, "analyze", 2, sexp_analyze_op, SEXP_FALSE);
+  sexp_define_foreign(ctx, env, "optimize", 1, sexp_optimize);
+  sexp_define_foreign(ctx, env, "extend-env", 3, sexp_extend_env_op);
+  sexp_define_foreign_opt(ctx, env, "env-cell", 3, sexp_get_env_cell, SEXP_FALSE);
+  sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name);
+  sexp_define_foreign(ctx, env, "opcode-class", 1, sexp_get_opcode_class);
+  sexp_define_foreign(ctx, env, "opcode-code", 1, sexp_get_opcode_code);
+  sexp_define_foreign(ctx, env, "opcode-data", 1, sexp_get_opcode_data);
+  sexp_define_foreign(ctx, env, "opcode-variadic?", 1, sexp_get_opcode_variadic_p);
+  sexp_define_foreign(ctx, env, "opcode-num-params", 1, sexp_get_opcode_num_params);
+  sexp_define_foreign(ctx, env, "opcode-return-type", 1, sexp_get_opcode_ret_type);
+  sexp_define_foreign(ctx, env, "opcode-param-type", 2, sexp_get_opcode_param_type);
+  sexp_define_foreign(ctx, env, "port-line", 1, sexp_get_port_line);
+  sexp_define_foreign(ctx, env, "port-line-set!", 2, sexp_set_port_line);
+  sexp_define_foreign(ctx, env, "type-of", 1, sexp_type_of);
+  sexp_define_foreign(ctx, env, "type-name", 1, sexp_type_name_op);
+  sexp_define_foreign(ctx, env, "type-cpl", 1, sexp_type_cpl_op);
+  sexp_define_foreign(ctx, env, "type-slots", 1, sexp_type_slots_op);
+  sexp_define_foreign(ctx, env, "type-num-slots", 1, sexp_type_num_slots_op);
+  sexp_define_foreign(ctx, env, "type-printer", 1, sexp_type_printer_op);
+  sexp_define_foreign(ctx, env, "env-parent-set!", 2, sexp_env_parent_set_op);
+  sexp_define_foreign(ctx, env, "env-lambda", 1, sexp_env_lambda_op);
+  sexp_define_foreign(ctx, env, "env-lambda-set!", 2, sexp_env_lambda_set_op);
+  sexp_define_foreign(ctx, env, "env-syntactic?", 1, sexp_env_syntactic_op);
+  sexp_define_foreign(ctx, env, "env-syntactic?-set!", 2, sexp_env_syntactic_set_op);
+  sexp_define_foreign(ctx, env, "env-define!", 3, sexp_env_define_op);
+  sexp_define_foreign(ctx, env, "env-push!", 3, sexp_env_push_op);
+  sexp_define_foreign(ctx, env, "core-code", 1, sexp_core_code_op);
+  sexp_define_foreign(ctx, env, "object-size", 1, sexp_object_size);
+  sexp_define_foreign_opt(ctx, env, "integer->immediate", 2, sexp_integer_to_immediate, SEXP_FALSE);
+  sexp_define_foreign(ctx, env, "gc", 0, sexp_gc_op);
+#if SEXP_USE_GREEN_THREADS
+  sexp_define_foreign(ctx, env, "%set-atomic!", 1, sexp_set_atomic);
+#endif
+  sexp_define_foreign(ctx, env, "thread-list", 0, sexp_thread_list);
+  sexp_define_foreign(ctx, env, "string-contains", 2, sexp_string_contains);
+  sexp_define_foreign(ctx, env, "string-cursor-copy!", 5, sexp_string_cursor_copy);
+  sexp_define_foreign(ctx, env, "errno", 0, sexp_errno);
+  sexp_define_foreign_opt(ctx, env, "integer->error-string", 1, sexp_error_string, SEXP_FALSE);
+  sexp_define_foreign(ctx, env, "update-free-vars!", 1, sexp_update_free_vars);
+  sexp_define_foreign(ctx, env, "setenv", 2, sexp_setenv);
+  sexp_define_foreign(ctx, env, "unsetenv", 1, sexp_unsetenv);
+  return SEXP_VOID;
+}
diff --git a/lib/chibi/ast.scm b/lib/chibi/ast.scm
new file mode 100644
index 00000000..81c62bf9
--- /dev/null
+++ b/lib/chibi/ast.scm
@@ -0,0 +1,390 @@
+;; ast.scm -- ast utilities
+;; Copyright (c) 2010-2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> Abstract Syntax Tree.  Interface to the types used by
+;;> the compiler, and other core types less commonly
+;;> needed in user code, plus related utilities.
+
+;;> \section{Analysis and Expansion}
+
+;;> \procedure{(analyze x [env])}
+
+;;> Expands and analyzes the expression \var{x} and returns the
+;;> resulting AST.
+
+;;> \procedure{(optimize ast)}
+
+;;> Runs an optimization pass on \var{ast} and returns the
+;;> resulting simplified expression.
+
+(define (ast-renames ast)
+  (define i 0)
+  (define renames '())
+  (define (rename-symbol id)
+    (set! i (+ i 1))
+    (string->symbol
+     (string-append (symbol->string (identifier->symbol id))
+                    "." (number->string i))))
+  (define (rename-lambda lam)
+    (or (assq lam renames)
+        (let ((res (list lam)))
+          (set! renames (cons res renames))
+          res)))
+  (define (rename! id lam)
+    (let ((cell (rename-lambda lam)))
+      (set-cdr! cell (cons (cons id (rename-symbol id)) (cdr cell)))))
+  (define (check-ref id lam env)
+    (let ((sym (identifier->symbol id)))
+      (let lp1 ((ls env))
+        (cond
+         ((pair? ls)
+          (let lp2 ((ls2 (car ls)) (found? #f))
+            (cond
+             ((null? ls2)
+              (if (not found?) (lp1 (cdr ls))))
+             ((and (eq? id (caar ls2)) (eq? lam (cdar ls2)))
+               (lp2 (cdr ls2) #t))
+             ((eq? sym (identifier->symbol (caar ls2)))
+              (rename! (caar ls2) (cdar ls2))
+              (lp2 (cdr ls2) found?))
+             (else
+              (lp2 (cdr ls2) found?)))))))))
+  (define (extend-env lam env)
+    (cons (map (lambda (x) (cons x lam)) (flatten-dot (lambda-params lam))) env))
+  (let lp ((x ast) (env '()))
+    (cond
+     ((lambda? x) (lp (lambda-body x) (extend-env x env)))
+     ((ref? x) (check-ref (ref-name x) (cdr (ref-cell x)) env))
+     ((cnd? x) (lp (cnd-test x) env) (lp (cnd-pass x) env) (lp (cnd-fail x) env))
+     ((set? x) (lp (set-var x) env) (lp (set-value x) env))
+     ((seq? x) (for-each (lambda (x) (lp x env)) (seq-ls x)))
+     ((pair? x) (for-each (lambda (x) (lp x env)) x))))
+  renames)
+
+(define (flatten-dot x)
+  (cond ((pair? x) (cons (car x) (flatten-dot (cdr x))))
+        ((null? x) x)
+        (else (list x))))
+
+(define (get-rename id lam renames)
+  (let ((ls (assq lam renames)))
+    (if (not ls)
+        (identifier->symbol id)
+        (cond ((assq id (cdr ls)) => cdr) (else (identifier->symbol id))))))
+
+(define (map* f ls)
+  (cond ((pair? ls) (cons (f (car ls)) (map* f (cdr ls))))
+        ((null? ls) '())
+        (else (f ls))))
+
+;;> Performs a full syntax expansion of the form \var{x} and
+;;> returns the resulting s-expression.
+
+(define (macroexpand x)
+  (ast->sexp (analyze x)))
+
+;;> Convert \var{ast} to a s-expression, renaming variables if
+;;> necessary.
+
+(define (ast->sexp ast)
+  (let ((renames (ast-renames ast)))
+    (let a2s ((x ast))
+      (cond
+       ((lambda? x)
+        `(lambda ,(map* (lambda (id) (get-rename id x renames)) (lambda-params x))
+           ,@(map (lambda (d) `(define ,(identifier->symbol (caar d)) #f))
+                  (lambda-defs x))
+           ,@(if (seq? (lambda-body x))
+                 (map a2s (seq-ls (lambda-body x)))
+                 (list (a2s (lambda-body x))))))
+       ((cnd? x) `(if ,(a2s (cnd-test x)) ,(a2s (cnd-pass x)) ,(a2s (cnd-fail x))))
+       ((set? x) `(set! ,(a2s (set-var x)) ,(a2s (set-value x))))
+       ((ref? x) (get-rename (ref-name x) (cdr (ref-cell x)) renames))
+       ((seq? x) `(begin ,@(map a2s (seq-ls x))))
+       ((lit? x)
+        (let ((v (lit-value x)))
+          (if (or (pair? v) (null? v) (symbol? v)) `',v v)))
+       ((pair? x) (cons (a2s (car x)) (a2s (cdr x))))
+       ((opcode? x) (cond ((opcode-name x) => string->symbol) (else x)))
+       (else x)))))
+
+;;> \section{Types}
+
+;;> All objects have an associated type, and types may have parent
+;;> types.  When using
+;;> \hyperlink["http://srfi.schemers.org/srfi-9/srfi-9/html"]{SRFI-9}
+;;> \scheme{define-record-type}, the name is bound to a first class
+;;> type object.
+
+;;> The following core types are also available by name, and may be
+;;> used in the \scheme{match} \scheme{($ ...)} syntax.
+
+;;> \itemlist[
+;;> \item{\scheme{<object>} - the parent of all types}
+;;> \item{\scheme{<number>} - abstract numeric type}
+;;> \item{\scheme{<bignum>} - arbitrary precision exact integers}
+;;> \item{\scheme{<flonum>} - inexact real numbers}
+;;> \item{\scheme{<integer>} - abstract integer type}
+;;> \item{\scheme{<symbol>} - symbols}
+;;> \item{\scheme{<char>} - character}
+;;> \item{\scheme{<boolean>} - \scheme{#t} or \scheme{#f}}
+;;> \item{\scheme{<string>} - strings of characters}
+;;> \item{\scheme{<byte-vector>} - uniform vector of octets}
+;;> \item{\scheme{<pair>} - a \var{car} and \var{cdr}, the basis for lists}
+;;> \item{\scheme{<vector>} - vectors}
+;;> \item{\scheme{<opcode>} - a primitive opcode or C function}
+;;> \item{\scheme{<procedure>} - a closure}
+;;> \item{\scheme{<bytecode>} - the compiled code for a closure}
+;;> \item{\scheme{<env>} - an environment structure}
+;;> \item{\scheme{<macro>} - a macro object, usually not first-class}
+;;> \item{\scheme{<lam>} - a lambda AST type}
+;;> \item{\scheme{<cnd>} - an conditional AST type (i.e. \scheme{if})}
+;;> \item{\scheme{<ref>} - a reference AST type}
+;;> \item{\scheme{<set>} - a mutation AST type (i.e. \scheme{set!})}
+;;> \item{\scheme{<seq>} - a sequence AST type}
+;;> \item{\scheme{<lit>} - a literal AST type}
+;;> \item{\scheme{<sc>} - a syntactic closure}
+;;> \item{\scheme{<context>} - a context object (including threads)}
+;;> \item{\scheme{<exception>} - an exception object}
+;;> ]
+
+;;> The following extended type predicates may also be used to test
+;;> individual objects for their type:
+
+;;> \itemlist[
+;;> \item{\scheme{environment?}}
+;;> \item{\scheme{bytecode?}}
+;;> \item{\scheme{macro?}}
+;;> \item{\scheme{syntactic-closure?}}
+;;> \item{\scheme{lambda?}}
+;;> \item{\scheme{cnd?}}
+;;> \item{\scheme{ref?}}
+;;> \item{\scheme{set?}}
+;;> \item{\scheme{seq?}}
+;;> \item{\scheme{lit?}}
+;;> \item{\scheme{opcode?}}
+;;> \item{\scheme{type?}}
+;;> \item{\scheme{context?}}
+;;> \item{\scheme{exception?}}
+;;> ]
+
+;;> \procedure{(type-of x)}
+
+;;> Returns the type of any object \var{x}.
+
+;;> \procedure{(type-name type)}
+
+;;> Returns the name of type \var{type}.
+
+;;> \procedure{(type-parent type)}
+
+;;> Returns the immediate parent of type \var{type},
+;;> or \scheme{#f} for a type with no parent.
+
+(define (type-parent type)
+  (let ((v (type-cpl type)))
+    (and (vector? v)
+         (> (vector-length v) 1)
+         (vector-ref v (- (vector-length v) 2)))))
+
+;;> \procedure{(type-cpl type)}
+
+;;> Returns the class precedence list of type \var{type} as a
+;;> vector, or \scheme{#f} for a type with no parent.
+
+;;> \procedure{(type-slots type)}
+
+;;> Returns the slot list of type \var{type}.
+
+;;> \section{Accessors}
+
+;;> This section describes additional accessors on AST and other core
+;;> types.
+
+;;> \subsection{Procedures}
+
+;;> \itemlist[
+;;> \item{\scheme{(procedure-code f)} - the compiled bytecode object}
+;;> \item{\scheme{(procedure-vars f)} - the variables closed over by \var{f}}
+;;> \item{\scheme{(procedure-name f)} - the name of \var{f} if known, else \scheme{#f}}
+;;> ]
+
+(define (procedure-name x)
+  (bytecode-name (procedure-code x)))
+
+(define (procedure-name-set! x name)
+  (bytecode-name-set! (procedure-code x) name))
+
+;;> \subsection{Macros}
+
+;;> \itemlist[
+;;> \item{\scheme{(macro-procedure f)} - the macro procedure}
+;;> \item{\scheme{(macro-env f)} - the environment the macro was defined in}
+;;> \item{\scheme{(macro-source f)} - the source location the macro was defined in}
+;;> ]
+
+;;> \subsection{Bytecode Objects}
+
+;;> \itemlist[
+;;> \item{\scheme{(bytecode-name bc)} - the macro procedure}
+;;> \item{\scheme{(bytecode-literals bc)} - literals the bytecode references}
+;;> \item{\scheme{(bytecode-source bc)} - the source location the procedure was defined in}
+;;> ]
+
+;;> \subsection{Syntactic Closures}
+
+;;> \itemlist[
+;;> \item{\scheme{(syntactic-closure-env sc)}}
+;;> \item{\scheme{(syntactic-closure-vars sc)}}
+;;> \item{\scheme{(syntactic-closure-expr sc)}}
+;;> ]
+
+;;> Return the environment, free variables, and expression
+;;> associated with \var{sc} respectively.
+
+;;> \subsection{Exceptions}
+
+;;> \itemlist[
+;;> \item{\scheme{(exception-kind exn)}}
+;;> \item{\scheme{(exception-message exn)}}
+;;> \item{\scheme{(exception-irritants exn)}}
+;;> ]
+
+;;> Return the kind, message, and irritants
+;;> associated with \var{exn} respectively.
+
+;;> \subsection{Lambdas}
+
+;;> \itemlist[
+;;> \item{\scheme{(lambda-name lam)} - the name of the lambda, if known}
+;;> \item{\scheme{(lambda-name-set! lam x)}}
+;;> \item{\scheme{(lambda-params lam)} - the lambda parameter list}
+;;> \item{\scheme{(lambda-params-set! lam x)}}
+;;> \item{\scheme{(lambda-body lam)} - the body of the lambda}
+;;> \item{\scheme{(lambda-body-set! lam x)}}
+;;> \item{\scheme{(lambda-defs lam)} - internal definitions of the lambda}
+;;> \item{\scheme{(lambda-defs-set! lam x)}}
+;;> \item{\scheme{(lambda-locals lam)} - local variables as a list of identifiers}
+;;> \item{\scheme{(lambda-locals-set! lam x)}}
+;;> \item{\scheme{(lambda-flags lam)} - various flags describing the lambda}
+;;> \item{\scheme{(lambda-flags-set! lam x)}}
+;;> \item{\scheme{(lambda-free-vars lam)} - free variables the lambda will need to close over}
+;;> \item{\scheme{(lambda-free-vars-set! lam x)}}
+;;> \item{\scheme{(lambda-set-vars lam)} - variables the lambda mutates}
+;;> \item{\scheme{(lambda-set-vars-set! lam x)}}
+;;> \item{\scheme{(lambda-return-type lam)} - the return type of the lambda}
+;;> \item{\scheme{(lambda-return-type-set! lam x)}}
+;;> \item{\scheme{(lambda-param-types lam)} - the types of the input parameters}
+;;> \item{\scheme{(lambda-param-types-set! lam x)}}
+;;> \item{\scheme{(lambda-source lam)} - the source code of the lambda}
+;;> \item{\scheme{(lambda-source-set! lam x)}}
+;;> ]
+
+;;> \subsection{Conditionals}
+
+;;> \itemlist[
+;;> \item{\scheme{(cnd-test cnd)} - the test for the conditional}
+;;> \item{\scheme{(cnd-test-set! cnd x)}}
+;;> \item{\scheme{(cnd-pass cnd)} - the success branch}
+;;> \item{\scheme{(cnd-pass-set! cnd x)}}
+;;> \item{\scheme{(cnd-fail cnd)} - the failure branch}
+;;> \item{\scheme{(cnd-fail-set! cnd x)}}
+;;> ]
+
+;;> \subsection{Sequences}
+
+;;> \itemlist[
+;;> \item{\scheme{(seq-ls seq)} - the list of sequence expressions}
+;;> \item{\scheme{(seq-ls-set! seq x)}}
+;;> ]
+
+;;> \subsection{References}
+
+;;> \itemlist[
+;;> \item{\scheme{(ref-name ref)} - the name of the referenced variable}
+;;> \item{\scheme{(ref-name-set! ref x)}}
+;;> \item{\scheme{(ref-cell ref)} - the environment cell the reference resolves to}
+;;> \item{\scheme{(ref-cell-set! ref x)}}
+;;> ]
+
+;;> \subsection{Mutations}
+
+;;> \itemlist[
+;;> \item{\scheme{(set-var set)} - a reference to the mutated variable}
+;;> \item{\scheme{(set-var-set! set x)}}
+;;> \item{\scheme{(set-value set)} - the value to set the variable to}
+;;> \item{\scheme{(set-value-set! set x)}}
+;;> ]
+
+;;> \subsection{Literals}
+
+;;> \itemlist[
+;;> \item{\scheme{(lit-value lit)} - the literal value}
+;;> \item{\scheme{(lit-value-set! lit x)}}
+;;> ]
+
+;;> \subsection{Pairs}
+
+;;> \itemlist[
+;;> \item{\scheme{(pair-source x)}}
+;;> \item{\scheme{(pair-source-set! x source)}}
+;;> ]
+
+;;> Set or return the source code info associated with a pair x.
+;;> Source info is represented as another pair whose \var{car} is
+;;> the source file name and whose \var{cdr} is the line number.
+
+;;> \section{Miscellaneous Utilities}
+
+;;> \procedure{(gc)}
+
+;;> Force a garbage collection.
+
+;;> \procedure{(object-size x)}
+
+;;> Returns the heap space directly used by \var{x}, not
+;;> counting any elements of \var{x}.
+
+;;> \procedure{(integer->immediate n)}
+
+;;> Returns the interpretation of the integer \var{n} as
+;;> an immediate object, useful for debugging.
+
+;;> \procedure{(string-contains str pat)}
+
+;;> Returns the first string cursor of \var{pat} in \var{str},
+;;> of \scheme{#f} if it's not found.
+
+;;> \procedure{(safe-setenv name value)}
+
+;;> Equivalent to \scheme{setenv} but does nothing and returns
+;;> \scheme{#f} if \var{value} is a function definition.  Used to
+;;> circumvent the vulnerability of the shellshock bug.
+
+(define (safe-setenv name value)
+  (define (function-def? str)
+    (and (> (string-size value) 5)
+         (equal? "() {" (substring value 0 4))))
+  (and (not (function-def? value))
+       (setenv name value)))
+
+;;> \procedure{(atomically expr)}
+
+;;> Run \var{expr} atomically, disabling yields.  Ideally should only be
+;;> used for brief, deterministic expressions.  If used incorrectly (e.g.
+;;> running an infinite loop) can render the system unusable.
+;;> Never expose to a sandbox.
+
+(cond-expand
+ (threads
+  (define-syntax atomically
+    (syntax-rules ()
+      ((atomically . body)
+       (let* ((atomic? (%set-atomic! #t))
+              (res (begin . body)))
+         (%set-atomic! atomic?)
+         res)))))
+ (else
+  (define-syntax atomically
+    (syntax-rules () ((atomically . body) (begin . body))))))
diff --git a/lib/chibi/ast.sld b/lib/chibi/ast.sld
new file mode 100644
index 00000000..b0091957
--- /dev/null
+++ b/lib/chibi/ast.sld
@@ -0,0 +1,42 @@
+
+(define-library (chibi ast)
+  (export
+   analyze optimize env-cell ast->sexp macroexpand type-of
+   Object Input-Port Output-Port Opcode Procedure Bytecode Macro Env
+   Number Bignum Flonum Integer Complex Char Boolean
+   Symbol String Byte-Vector Vector Pair File-Descriptor
+   Context Lam Cnd Set Ref Seq Lit Sc Exception Core
+   syntactic-closure? lambda? cnd? set? ref? seq? lit? type? core?
+   environment? bytecode? exception? macro? context? file-descriptor?
+   syntactic-closure-expr syntactic-closure-env syntactic-closure-vars
+   copy-lambda make-lambda make-cnd make-ref make-set make-seq make-lit
+   make-macro
+   lambda-name lambda-params lambda-body lambda-defs lambda-locals
+   lambda-flags lambda-free-vars lambda-set-vars lambda-return-type
+   lambda-param-types lambda-source
+   lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-set!
+   lambda-locals-set! lambda-flags-set! lambda-free-vars-set!
+   lambda-set-vars-set! lambda-return-type-set! lambda-param-types-set!
+   lambda-source-set!
+   cnd-test cnd-pass cnd-fail
+   cnd-test-set! cnd-pass-set! cnd-fail-set!
+   set-var set-value set-var-set! set-value-set!
+   ref-name ref-cell ref-name-set! ref-cell-set!
+   seq-ls seq-ls-set! lit-value lit-value-set!
+   exception-kind exception-message exception-irritants exception-source
+   opcode-name opcode-num-params opcode-return-type opcode-param-type
+   opcode-class opcode-code opcode-data opcode-variadic?
+   macro-procedure macro-env macro-source
+   procedure-code procedure-vars procedure-name procedure-name-set!
+   procedure-arity procedure-variadic?
+   bytecode-name bytecode-literals bytecode-source
+   port-line port-line-set!
+   extend-env env-parent env-parent-set! env-lambda env-lambda-set!
+   env-define! env-push! env-syntactic? env-syntactic?-set! core-code
+   type-name type-cpl type-parent type-slots type-num-slots type-printer
+   object-size integer->immediate gc atomically thread-list
+   string-contains string-cursor-copy! errno integer->error-string
+   flatten-dot update-free-vars! setenv unsetenv safe-setenv)
+  (import (chibi))
+  (include-shared "ast")
+  (include "ast.scm"))
diff --git a/lib/chibi/base64.scm b/lib/chibi/base64.scm
new file mode 100644
index 00000000..0d4b10e8
--- /dev/null
+++ b/lib/chibi/base64.scm
@@ -0,0 +1,366 @@
+;; Copyright (c) 2005-2014 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> RFC 3548 base64 encoding and decoding utilities.
+;;> This API is compatible with the Gauche library rfc.base64.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; string utils
+
+(define (string-chop str n)
+  (let ((len (string-length str)))
+    (let lp ((i 0) (res '()))
+      (let ((j (+ i n)))
+        (if (>= j len)
+            (reverse (cons (substring str i len) res))
+            (lp j (cons (substring str i j) res)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; constants and tables
+
+(define *default-max-col* 76)
+
+(define *outside-char* 99) ; luft-balloons
+(define *pad-char* 101)    ; dalmations
+
+(define *base64-decode-table*
+  (let ((res (make-vector #x100 *outside-char*)))
+    (let lp ((i 0)) ; map letters
+      (cond
+       ((<= i 25)
+        (vector-set! res (+ i 65) i)
+        (vector-set! res (+ i 97) (+ i 26))
+        (lp (+ i 1)))))
+    (let lp ((i 0)) ; map numbers
+      (cond
+       ((<= i 9)
+        (vector-set! res (+ i 48) (+ i 52))
+        (lp (+ i 1)))))
+    ;; extras (be liberal for different common base64 formats)
+    (vector-set! res (char->integer #\+) 62)
+    (vector-set! res (char->integer #\-) 62)
+    (vector-set! res (char->integer #\/) 63)
+    (vector-set! res (char->integer #\_) 63)
+    (vector-set! res (char->integer #\~) 63)
+    (vector-set! res (char->integer #\=) *pad-char*)
+    res))
+
+(define (base64-decode-u8 u8)
+  (vector-ref *base64-decode-table* u8))
+
+(define *base64-encode-table*
+  (let ((res (make-vector 64)))
+    (let lp ((i 0)) ; map letters
+      (cond
+       ((<= i 25)
+        (vector-set! res i (+ i 65))
+        (vector-set! res (+ i 26) (+ i 97))
+        (lp (+ i 1)))))
+    (let lp ((i 0)) ; map numbers
+      (cond
+       ((<= i 9)
+        (vector-set! res (+ i 52) (+ i 48))
+        (lp (+ i 1)))))
+    (vector-set! res 62 (char->integer #\+))
+    (vector-set! res 63 (char->integer #\/))
+    res))
+
+(define (enc i)
+  (vector-ref *base64-encode-table* i))
+
+;; try to match common boundaries
+(define decode-src-length
+  (lcm 76 78))
+
+(define decode-dst-length
+  (* 3 (arithmetic-shift (+ 3 decode-src-length) -2)))
+
+(define encode-src-length
+  (* 3 1024))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; decoding
+
+;;> Return a base64 decoded representation of string, also interpreting
+;;> the alternate 62 & 63 valued characters as described in RFC3548.
+;;> Other out-of-band characters are silently stripped, and = signals
+;;> the end of the encoded string.  No errors will be raised.
+
+;; Create a result buffer with the maximum possible length for the
+;; input, and pass it to the internal base64-decode-string! utility.
+;; If the resulting length used is exact, we can return that buffer,
+;; otherwise we return the appropriate substring.
+
+(define (base64-decode-string str)
+  (utf8->string (base64-decode-bytevector (string->utf8 str))))
+
+(define (base64-decode-bytevector src)
+  (let* ((len (bytevector-length src))
+         (dst-len (* 3 (arithmetic-shift (+ 3 len) -2)))
+         (dst (make-bytevector dst-len)))
+    (base64-decode-bytevector!
+     src 0 len dst
+     (lambda (src-offset res-len b1 b2 b3)
+       (let ((res-len (base64-decode-finish dst res-len b1 b2 b3)))
+         (if (= res-len dst-len)
+             dst
+             (bytevector-copy dst 0 res-len)))))))
+
+;; This is a little funky.
+;;
+;;   We want to skip over "outside" characters (e.g. newlines inside
+;;   base64-encoded data, as would be passed in mail clients and most
+;;   large base64 data).  This would normally mean two nested loops -
+;;   one for overall processing the input, and one for looping until
+;;   we get to a valid character.  However, many Scheme compilers are
+;;   really bad about optimizing nested loops of primitives, so we
+;;   flatten this into a single loop, using conditionals to determine
+;;   which character is currently being read.
+(define (base64-decode-bytevector! src start end dst kont)
+  (let lp ((i start)
+           (j 0)
+           (b1 *outside-char*)
+           (b2 *outside-char*)
+           (b3 *outside-char*))
+    (if (>= i end)
+        (kont i j b1 b2 b3)
+        (let ((c (base64-decode-u8 (bytevector-u8-ref src i))))
+          (cond
+           ((eqv? c *pad-char*)
+            (kont i j b1 b2 b3))
+           ((eqv? c *outside-char*)
+            (lp (+ i 1) j b1 b2 b3))
+           ((eqv? b1 *outside-char*)
+            (lp (+ i 1) j c b2 b3))
+           ((eqv? b2 *outside-char*)
+            (lp (+ i 1) j b1 c b3))
+           ((eqv? b3 *outside-char*)
+            (lp (+ i 1) j b1 b2 c))
+           (else
+            (bytevector-u8-set!
+             dst
+             j
+             (bitwise-ior (arithmetic-shift b1 2)
+                          (extract-bit-field 2 4 b2)))
+            (bytevector-u8-set!
+             dst
+             (+ j 1)
+             (bitwise-ior
+              (arithmetic-shift (extract-bit-field 4 0 b2) 4)
+              (extract-bit-field 4 2 b3)))
+            (bytevector-u8-set!
+             dst
+             (+ j 2)
+             (bitwise-ior
+              (arithmetic-shift (extract-bit-field 2 0 b3) 6)
+              c))
+            (lp (+ i 1) (+ j 3)
+                *outside-char* *outside-char* *outside-char*)))))))
+
+;; If requested, account for any "partial" results (i.e. trailing 2 or
+;; 3 chars) by writing them into the destination (additional 1 or 2
+;; bytes) and returning the adjusted offset for how much data we've
+;; written.
+(define (base64-decode-finish dst j b1 b2 b3)
+  (cond
+   ((eqv? b1 *outside-char*)
+    j)
+   ((eqv? b2 *outside-char*)
+    (bytevector-u8-set! dst j (arithmetic-shift b1 2))
+    (+ j 1))
+   (else
+    (bytevector-u8-set! dst
+                        j
+                        (bitwise-ior (arithmetic-shift b1 2)
+                                     (extract-bit-field 2 4 b2)))
+    (cond
+     ((eqv? b3 *outside-char*)
+      (+ j 1))
+     (else
+      (bytevector-u8-set! dst
+                          (+ j 1)
+                          (bitwise-ior
+                           (arithmetic-shift (extract-bit-field 4 0 b2) 4)
+                           (extract-bit-field 4 2 b3)))
+      (+ j 2))))))
+
+;;>  Variation of the above to read and write to ports.
+
+(define (base64-decode . o)
+  (let ((in (if (pair? o) (car o) (current-input-port)))
+        (out (if (and (pair? o) (pair? (cdr o)))
+                 (cadr o)
+                 (current-output-port))))
+    (cond
+     ((not (binary-port? in))
+      (write-string (base64-decode-string (port->string in)) out))
+     (else
+      (let ((src (make-bytevector decode-src-length))
+            (dst (make-bytevector decode-dst-length)))
+        (let lp ((offset 0))
+          (let ((src-len
+                 (+ offset
+                    (read-bytevector! decode-src-length src in offset))))
+            (cond
+             ((= src-len decode-src-length)
+              ;; read a full chunk: decode, write and loop
+              (base64-decode-bytevector!
+               src 0 decode-src-length dst
+               (lambda (src-offset dst-len b1 b2 b3)
+                 (cond
+                  ((and (< src-offset src-len)
+                        (eqv? #\= (string-ref src src-offset)))
+                   ;; done
+                   (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3)))
+                     (write-bytevector dst out 0 dst-len)))
+                  ((eqv? b1 *outside-char*)
+                   (write-string dst out 0 dst-len)
+                   (lp 0))
+                  (else
+                   (write-bytevector dst out 0 dst-len)
+                   ;; one to three chars left in buffer
+                   (bytevector-u8-set! src 0 (enc b1))
+                   (cond
+                    ((eqv? b2 *outside-char*)
+                     (lp 1))
+                    (else
+                     (bytevector-u8-set! src 1 (enc b2))
+                     (cond
+                      ((eqv? b3 *outside-char*)
+                       (lp 2))
+                      (else
+                       (bytevector-u8-set! src 2 (enc b3))
+                       (lp 3))))))))))
+             (else
+              ;; end of source - just decode and write once
+              (base64-decode-bytevector!
+               src 0 src-len dst
+               (lambda (src-offset dst-len b1 b2 b3)
+                 (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3)))
+                   (write-string dst out 0 dst-len)))))))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; encoding
+
+;;> Return a base64 encoded representation of string according to the
+;;> official base64 standard as described in RFC3548.
+
+(define (base64-encode-string str)
+  (utf8->string (base64-encode-bytevector (string->utf8 str))))
+
+(define (base64-encode-bytevector bv)
+  (let* ((len (bytevector-length bv))
+         (quot (quotient len 3))
+         (rem (- len (* quot 3)))
+         (res-len (arithmetic-shift (+ quot (if (zero? rem) 0 1)) 2))
+         (res (make-bytevector res-len)))
+    (base64-encode-bytevector! bv 0 len res)
+    res))
+
+(define (base64-encode-bytevector! bv start end res)
+  (let* ((res-len (bytevector-length res))
+         (limit (- end 2)))
+    (let lp ((i start) (j 0))
+      (if (>= i limit)
+          (case (- end i)
+            ((1)
+             (let ((b1 (bytevector-u8-ref bv i)))
+               (bytevector-u8-set! res j (enc (arithmetic-shift b1 -2)))
+               (bytevector-u8-set!
+                res
+                (+ j 1)
+                (enc (arithmetic-shift (bitwise-and #b11 b1) 4)))
+               (bytevector-u8-set! res (+ j 2) (char->integer #\=))
+               (bytevector-u8-set! res (+ j 3) (char->integer #\=))))
+            ((2)
+             (let ((b1 (bytevector-u8-ref bv i))
+                   (b2 (bytevector-u8-ref bv (+ i 1))))
+               (bytevector-u8-set! res j (enc (arithmetic-shift b1 -2)))
+               (bytevector-u8-set!
+                res
+                (+ j 1)
+                (enc (bitwise-ior
+                      (arithmetic-shift (bitwise-and #b11 b1) 4)
+                      (extract-bit-field 4 4 b2))))
+               (bytevector-u8-set!
+                res
+                (+ j 2)
+                (enc (arithmetic-shift (extract-bit-field 4 0 b2)
+                                       2)))
+               (bytevector-u8-set! res (+ j 3) (char->integer #\=)))))
+          (let ((b1 (bytevector-u8-ref bv i))
+                (b2 (bytevector-u8-ref bv (+ i 1)))
+                (b3 (bytevector-u8-ref bv (+ i 2))))
+            (bytevector-u8-set! res j (enc (arithmetic-shift b1 -2)))
+            (bytevector-u8-set!
+             res
+             (+ j 1)
+             (enc (bitwise-ior
+                   (arithmetic-shift (bitwise-and #b11 b1) 4)
+                   (extract-bit-field 4 4 b2))))
+            (bytevector-u8-set!
+             res
+             (+ j 2)
+             (enc (bitwise-ior
+                   (arithmetic-shift (extract-bit-field 4 0 b2) 2)
+                   (extract-bit-field 2 6 b3))))
+            (bytevector-u8-set! res (+ j 3) (enc (bitwise-and #b111111 b3)))
+            (lp (+ i 3) (+ j 4)))))))
+
+;;>  Variation of the above to read and write to ports.
+
+(define (base64-encode . o)
+  (let ((in (if (pair? o) (car o) (current-input-port)))
+        (out (if (and (pair? o) (pair? (cdr o)))
+                 (cadr o)
+                 (current-output-port))))
+    (cond
+     ((not (binary-port? in))
+      (write-string (base64-encode-string (port->string in)) out))
+     (else
+      (let ((src (make-string encode-src-length))
+            (dst (make-string
+                  (arithmetic-shift (quotient encode-src-length 3) 2))))
+        (let lp ()
+          (let ((n (read-bytevector! src in 0 2048)))
+            (base64-encode-bytevector! src 0 n dst)
+            (write-bytevector dst out 0 (* 3 (quotient (+ n 3) 4)))
+            (if (= n 2048)
+                (lp)))))))))
+
+;;> Return a base64 encoded representation of the string \var{str} as
+;;> above, wrapped in =?ENC?B?...?= as per RFC1522, split across
+;;> multiple MIME-header lines as needed to keep each lines length
+;;> less than \var{max-col}.  The string is encoded as is, and the
+;;> encoding \var{enc} is just used for the prefix, i.e. you are
+;;> responsible for ensuring \var{str} is already encoded according to
+;;> \var{enc}.  The optional argument \var{nl} is the newline
+;;> separator, defaulting to \var{crlf}.
+
+(define (base64-encode-header encoding str . o)
+  (define (round4 i) (arithmetic-shift (arithmetic-shift i -2) 2))
+  (let ((start-col (if (pair? o) (car o) 0))
+        (max-col (if (and (pair? o) (pair? (cdr o)))
+                     (car (cdr o))
+                     *default-max-col*))
+        (nl (if (and (pair? o) (pair? (cdr o)) (pair? (cdr (cdr o))))
+                (car (cdr (cdr o)))
+                "\r\n")))
+    (let* ((prefix (string-append "=?" encoding "?B?"))
+           (prefix-length (+ 2 (string-length prefix)))
+           (effective-max-col (round4 (- max-col prefix-length)))
+           (first-max-col (round4 (- effective-max-col start-col)))
+           (str (base64-encode-string str))
+           (len (string-length str)))
+      (if (<= len first-max-col)
+          (string-append prefix str "?=")
+          (string-append
+           (if (positive? first-max-col)
+               (string-append
+                prefix (substring str 0 first-max-col) "?=" nl "\t" prefix)
+               "")
+           (string-concatenate (string-chop (substring str first-max-col len)
+                                            effective-max-col)
+                               (string-append "?=" nl "\t" prefix))
+           "?=")))))
+
diff --git a/lib/chibi/base64.sld b/lib/chibi/base64.sld
new file mode 100644
index 00000000..a55f3bd5
--- /dev/null
+++ b/lib/chibi/base64.sld
@@ -0,0 +1,8 @@
+
+(define-library (chibi base64)
+  (export base64-encode base64-encode-string base64-encode-bytevector
+          base64-decode base64-decode-string base64-decode-bytevector
+          base64-encode-header)
+  (import (scheme base) (srfi 33) (chibi io)
+          (only (chibi) string-concatenate))
+  (include "base64.scm"))
diff --git a/lib/chibi/binary-record.scm b/lib/chibi/binary-record.scm
new file mode 100644
index 00000000..fd8b3c95
--- /dev/null
+++ b/lib/chibi/binary-record.scm
@@ -0,0 +1,300 @@
+
+(define (read-u16/be in)
+  (let* ((i (read-u8 in))
+         (j (read-u8 in)))
+    (if (eof-object? j)
+        (error "end of input")
+        (+ (arithmetic-shift i 8) j))))
+
+(define (read-u16/le in)
+  (let* ((i (read-u8 in))
+         (j (read-u8 in)))
+    (if (eof-object? j)
+        (error "end of input")
+        (+ (arithmetic-shift j 8) i))))
+
+;; Record types with user-specified binary formats.
+;; A work in progress, but sufficient for tar files.
+
+(define (assert-read-u8 in i)
+  (let ((i2 (read-u8 in)))
+    (if (not (eqv? i i2))
+        (error "unexpected value: " i i2)
+        i2)))
+
+(define (assert-read-char in ch)
+  (let ((ch2 (read-char in)))
+    (if (not (eqv? ch ch2))
+        (error "unexpected value: " ch ch2)
+        ch2)))
+
+(define (assert-read-string in s)
+  (let ((s2 (read-string (string-length s) in)))
+    (if (not (equal? s s2))
+        (error "unexpected value: " s s2)
+        s2)))
+
+(define (assert-read-bytevector in bv)
+  (let ((bv2 (read-bytevector (bytevector-length bv) in)))
+    (if (not (equal? bv bv2))
+        (error "unexpected value: " bv bv2)
+        bv2)))
+
+(define (assert-read-integer in len radix)
+  (let* ((s (string-trim (read-string len in)
+                         (lambda (ch) (or (eqv? ch #\space) (eqv? ch #\null)))))
+         (n (if (equal? s "") 0 (string->number s radix))))
+    (or n (error "invalid number syntax: " s))))
+
+(define (read-padded-string in len pad)
+  (string-trim-right (read-string len in) pad))
+
+(define (expand-read rename in spec)
+  (case (car spec)
+    ((literal)
+     (let ((val (cadr spec)))
+       (cond ((integer? val) `(,(rename 'assert-read-u8) ,in ,val))
+             ((char? val) `(,(rename 'assert-read-char) ,in ,val))
+             ((string? val) `(,(rename 'assert-read-string) ,in ,val))
+             ((bytevector? val) `(,(rename 'assert-read-bytevector) ,in ,val))
+             (else (error "unknown binary literal: " val)))))
+    ((u8)
+     `(,(rename 'read-u8) ,in))
+    ((u16/be)
+     `(,(rename 'read-u16/be) ,in))
+    ((u16/le)
+     `(,(rename 'read-u16/le) ,in))
+    ((octal)
+     `(,(rename 'assert-read-integer) ,in ,(cadr spec) 8))
+    ((decimal)
+     `(,(rename 'assert-read-integer) ,in ,(cadr spec) 10))
+    ((hexadecimal)
+     `(,(rename 'assert-read-integer) ,in ,(cadr spec) 16))
+    ((fixed-string)
+     (let ((len (cadr spec)))
+       `(,(rename 'read-string) ,len ,in)))
+    ((padded-string)
+     (let ((len (cadr spec))
+           (pad (if (pair? (cddr spec)) (car (cddr spec)) #\null)))
+       `(,(rename 'read-padded-string) ,in ,len ,pad)))
+    (else
+     (error "unknown binary format: " spec))))
+
+(define (string-pad-left str len . o)
+  (let ((diff (- len (string-length str)))
+        (pad-ch (if (pair? o) (car o) #\space)))
+    (if (positive? diff)
+        (string-append (make-string diff pad-ch) str)
+        str)))
+
+(define (string-pad-right str len . o)
+  (let ((diff (- len (string-length str)))
+        (pad-ch (if (pair? o) (car o) #\space)))
+    (if (positive? diff)
+        (string-append str (make-string diff pad-ch))
+        str)))
+
+(define (write-padded-integer out n radix len left-pad-ch right-pad-ch)
+  (let ((s (string-pad-left (number->string n radix) (- len 1) left-pad-ch)))
+    (cond
+     ((>= (string-length s) len)
+      (error "number too large for width" n radix len))
+     (else
+      (write-string s out)
+      (write-char right-pad-ch out)))))
+
+(define (write-u16/be n out)
+  (write-u8 (arithmetic-shift n -8) out)
+  (write-u8 (bitwise-and n #xFF) out))
+
+(define (write-u16/le n out)
+  (write-u8 (bitwise-and n #xFF) out)
+  (write-u8 (arithmetic-shift n -8) out))
+
+(define (expand-write rename out val spec)
+  (let ((_if (rename 'if))
+        (_not (rename 'not))
+        (_let (rename 'let))
+        (_string-length (rename 'string-length))
+        (_write-string (rename 'write-string))
+        (_write-bytevector (rename 'write-bytevector))
+        (_error (rename 'error))
+        (_> (rename '>))
+        (_= (rename '=)))
+    (case (car spec)
+      ((literal)
+       (let ((val (cadr spec)))
+         (cond ((integer? val) `(,(rename 'write-u8) ,val ,out))
+               ((char? val) `(,(rename 'write-char) ,val ,out))
+               ((string? val) `(,_write-string ,val ,out))
+               ((bytevector? val) `(,_write-bytevector ,val ,out))
+               (else (error "unknown binary literal: " val)))))
+      ((u8)
+       `(,(rename 'write-u8) ,val ,out))
+      ((u16/be)
+       `(,(rename 'write-u16/be) ,val ,out))
+      ((u16/le)
+       `(,(rename 'write-u16/le) ,val ,out))
+      ((octal)
+       `(,(rename 'write-padded-integer) ,out ,val 8 ,(cadr spec) #\0 #\null))
+      ((decimal)
+       `(,(rename 'write-padded-integer) ,out ,val 10 ,(cadr spec) #\0 #\null))
+      ((hexadecimal)
+       `(,(rename 'write-padded-integer) ,out ,val 16 ,(cadr spec) #\0 #\null))
+      ((fixed-string)
+       (let ((len (cadr spec)))
+         `(,_if (,_not (,_= ,len (,_string-length ,val)))
+              (,_error "wrong field length: " ,val ,len)
+              (,_write-string ,val ,out))))
+      ((padded-string)
+       (let ((len (cadr spec))
+             (pad (if (pair? (cddr spec)) (car (cddr spec)) #\null)))
+         `(,_let ((l (,_string-length ,val)))
+            (,_if (,_> l ,len)
+                (,_error "field too large: " ,val ,len)
+                (,_write-string (,(rename 'string-pad-right) ,val ,len ,pad)
+                                ,out)))))
+      (else
+       (error "unknown binary format: " spec)))))
+
+(define (expand-assert rename spec x v)
+  (let ((_if (rename 'if))
+        (_not (rename 'not))
+        (_error (rename 'error))
+        (_integer? (rename 'integer?))
+        (_string? (rename 'string?))
+        (_string-length (rename 'string-length))
+        (_> (rename '>)))
+    (case (car spec)
+      ((literal) #t)
+      ((u8 u16/be u16/le octal decimal hexadecimal)
+       `(,_if (,_not (,_integer? ,v))
+            (,_error "expected an integer" ,v)))
+      ((fixed-string padded-string)
+       (let ((len (cadr spec)))
+         `(,_if (,_not (,_string? ,v))
+              (,_error "expected a string" ,v)
+              (,_if (,_> (,_string-length ,v) ,len)
+                  (,_error "string too long" ,v ,len)))))
+      (else (error "unknown binary format: " spec)))))
+
+(define (expand-default rename spec)
+  (case (car spec)
+    ((literal) (cadr spec))
+    ((u8 u16/be u16/le octal decimal hexadecimal) 0)
+    ((fixed-string) (make-string (cadr spec) #\space))
+    ((padded-string) "")
+    (else (error "unknown binary format: " spec))))
+
+(define (param-ref ls key . o)
+  (cond ((assq key ls) => cadr) ((pair? o) (car o)) (else #f)))
+
+(define (symbol-append a b)
+  (string->symbol (string-append (symbol->string a) (symbol->string b))))
+
+(define-record-type Field
+  (make-field name get set raw-set spec)
+  field?
+  (name field-name)
+  (get field-get)
+  (set field-set)
+  (raw-set field-raw-set)
+  (spec field-spec))
+
+(define (extract-fields type ls)
+  (let lp ((ls ls) (res '()))
+    (cond
+     ((null? ls)
+      (reverse res))
+     ((not (pair? (car ls)))
+      (lp (cdr ls) (cons (make-field '_ #f #f #f `(literal ,(car ls))) res)))
+     (else
+      (let* ((name (caar ls))
+             (get (or (param-ref (car ls) 'getter)
+                      (and (not (eq? name '_))
+                           (symbol-append type (symbol-append '- name)))))
+             (set (or (param-ref (car ls) 'setter)
+                      (and (not (eq? name '_))
+                           (symbol-append (symbol-append type '-)
+                                          (symbol-append name '-set!)))))
+             (raw-set (and set (symbol-append '% set)))
+             (spec0 (cadr (car ls)))
+             (spec (if (pair? spec0) spec0 (list spec0))))
+        (lp (cdr ls) (cons (make-field name get set raw-set spec) res)))))))
+
+(define-syntax define-binary-record-type
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let ((name (cadr expr))
+           (ls (cddr expr)))
+       (if (not (and (identifier? name) (every list? ls)))
+           (error "invalid syntax: " expr))
+       (let* ((type (or (param-ref ls 'type) (symbol-append 'type- name)))
+              (pred (or (param-ref ls 'predicate) (symbol-append name '?)))
+              (make (or (param-ref ls 'make) (symbol-append 'make- name)))
+              (make-spec (if (pair? make) make (list make)))
+              (%make (rename (symbol-append '% (car make-spec))))
+              (%%make (rename (symbol-append '%% (car make-spec))))
+              (reader (or (param-ref ls 'read) (symbol-append 'read- name)))
+              (writer (or (param-ref ls 'write) (symbol-append 'write- name)))
+              (block (assq 'block ls))
+              (_begin (rename 'begin))
+              (_define (rename 'define))
+              (_define-record-type (rename 'define-record-type))
+              (_let (rename 'let)))
+         (if (not block)
+             (error "missing binary record block: " expr))
+         (let* ((fields (extract-fields name (cdr block)))
+                (named-fields (filter (lambda (f) (not (eq? '_ (field-name f))))
+                                      fields)))
+           `(,_begin
+             (,_define ,name ',ls)
+             (,_define-record-type
+              ,type (,%%make) ,pred
+              ,@(map
+                 (lambda (f)
+                   `(,(field-name f) ,(field-get f) ,(field-raw-set f)))
+                 named-fields))
+             ,@(map
+                (lambda (f)
+                  `(,_define (,(field-set f) x v)
+                     ,(expand-assert rename (field-spec f) 'x 'v)
+                     (,(field-raw-set f) x v)))
+                named-fields)
+             (,_define (,%make)
+               (let ((res (,%%make)))
+                 ,@(map
+                    (lambda (f)
+                      `(,(field-raw-set f)
+                        res
+                        ,(expand-default rename (field-spec f))))
+                    named-fields)
+                 res))
+             (,_define ,make-spec
+               (,_let ((res (,%make)))
+                 ,@(map
+                    (lambda (x)
+                      (let ((field (find (lambda (f) (eq? x (field-name f)))
+                                         fields)))
+                        `(,(field-set field) res ,x)))
+                    (cdr make-spec))
+                 res))
+             (,_define (,reader in)
+               (,_let ((res (,%make)))
+                 ,@(map
+                    (lambda (f)
+                      (if (eq? '_ (field-name f))
+                          (expand-read rename 'in (field-spec f))
+                          `(,(field-set f)
+                            res
+                            ,(expand-read rename 'in (field-spec f)))))
+                    fields)
+                 res))
+             (,_define (,writer x out)
+               ,@(map
+                  (lambda (f)
+                    (expand-write rename
+                                  'out
+                                  `(,(field-get f) x)
+                                  (field-spec f)))
+                  fields)))))))))
diff --git a/lib/chibi/binary-record.sld b/lib/chibi/binary-record.sld
new file mode 100644
index 00000000..cd84b3d3
--- /dev/null
+++ b/lib/chibi/binary-record.sld
@@ -0,0 +1,8 @@
+
+(define-library (chibi binary-record)
+  (import (scheme base)
+          (srfi 1) (srfi 9) (srfi 33)
+          (chibi io) (chibi string)
+          (only (chibi) identifier? er-macro-transformer))
+  (export define-binary-record-type)
+  (include "binary-record.scm"))
diff --git a/lib/chibi/bytevector.scm b/lib/chibi/bytevector.scm
new file mode 100644
index 00000000..7df61a3d
--- /dev/null
+++ b/lib/chibi/bytevector.scm
@@ -0,0 +1,84 @@
+
+;;> \section{Additional accessors}
+
+(define (bytevector-u16-ref-le str i)
+  (+ (bytevector-u8-ref str i)
+     (arithmetic-shift (bytevector-u8-ref str (+ i 1)) 8)))
+
+(define (bytevector-u16-ref-be str i)
+  (+ (arithmetic-shift (bytevector-u8-ref str i) 8)
+     (bytevector-u8-ref str (+ i 1))))
+
+(define (bytevector-u32-ref-le str i)
+  (+ (bytevector-u8-ref str i)
+     (arithmetic-shift (bytevector-u8-ref str (+ i 1)) 8)
+     (arithmetic-shift (bytevector-u8-ref str (+ i 2)) 16)
+     (arithmetic-shift (bytevector-u8-ref str (+ i 3)) 24)))
+
+(define (bytevector-u32-ref-be str i)
+  (+ (arithmetic-shift (bytevector-u8-ref str i) 24)
+     (arithmetic-shift (bytevector-u8-ref str (+ i 1)) 16)
+     (arithmetic-shift (bytevector-u8-ref str (+ i 2)) 8)
+     (bytevector-u8-ref str (+ i 3))))
+
+;;> \section{Integer conversion}
+
+(define (integer->bytevector n)
+  (cond
+   ((zero? n)
+    (make-bytevector 1 0))
+   ((negative? n)
+    (error "can't convert a negative integer to bytevector" n))
+   (else
+    (let lp ((n n) (res '()))
+      (if (zero? n)
+          (let* ((len (length res))
+                 (bv (make-bytevector len 0)))
+            (do ((i 0 (+ i 1))
+                 (ls res (cdr ls)))
+                ((= i len) bv)
+              (bytevector-u8-set! bv i (car ls))))
+          (lp (quotient n 256) (cons (remainder n 256) res)))))))
+
+(define (bytevector->integer bv)
+  (let ((len (bytevector-length bv)))
+    (let lp ((i 0) (n 0))
+      (if (>= i len)
+          n
+          (lp (+ i 1)
+              (+ (arithmetic-shift n 8)
+                 (bytevector-u8-ref bv i)))))))
+
+(define (bytevector-pad-left bv len)
+  (let ((diff (- len (bytevector-length bv))))
+    (if (positive? diff)
+        (bytevector-append bv (make-bytevector diff 0))
+        bv)))
+
+;;> \section{Hex string conversion}
+
+;;> Big-endian conversion, guaranteed padded to even length.
+
+(define (integer->hex-string n)
+  (let* ((res (number->string n 16))
+         (len (string-length res)))
+    (if (even? len)
+        res
+        (string-append "0" res))))
+
+(define (hex-string->integer str)
+  (string->number str 16))
+
+(define (bytevector->hex-string bv)
+  (let ((out (open-output-string))
+        (len (bytevector-length bv)))
+    (let lp ((i 0))
+      (cond
+       ((>= i len)
+        (get-output-string out))
+       (else
+        (write-string (integer->hex-string (bytevector-u8-ref bv i)) out)
+        (lp (+ i 1)))))))
+
+(define (hex-string->bytevector str)
+  (integer->bytevector (hex-string->integer str)))
diff --git a/lib/chibi/bytevector.sld b/lib/chibi/bytevector.sld
new file mode 100644
index 00000000..1923cc02
--- /dev/null
+++ b/lib/chibi/bytevector.sld
@@ -0,0 +1,11 @@
+
+(define-library (chibi bytevector)
+  (export
+   bytevector-u16-ref-le bytevector-u16-ref-be
+   bytevector-u32-ref-le bytevector-u32-ref-be
+   bytevector-pad-left
+   integer->bytevector bytevector->integer
+   integer->hex-string hex-string->integer
+   bytevector->hex-string hex-string->bytevector)
+  (import (scheme base) (srfi 33))
+  (include "bytevector.scm"))
diff --git a/lib/chibi/channel.scm b/lib/chibi/channel.scm
new file mode 100644
index 00000000..01112c3d
--- /dev/null
+++ b/lib/chibi/channel.scm
@@ -0,0 +1,44 @@
+;; channel.scm -- thread-safe channel (FIFO) library
+;; Copyright (c) 2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define-record-type Channel
+  (%make-channel mutex condvar front rear)
+  channel?
+  (mutex channel-mutex channel-mutex-set!)
+  (condvar channel-condvar channel-condvar-set!)
+  (front channel-front channel-front-set!)
+  (rear channel-rear channel-rear-set!))
+
+(define (make-channel)
+  (%make-channel (make-mutex) (make-condition-variable) '() '()))
+
+(define (channel-empty? chan)
+  (null? (channel-front chan)))
+
+(define (channel-send! chan obj)
+  (mutex-lock! (channel-mutex chan))
+  (let ((new (list obj))
+        (rear (channel-rear chan)))
+    (channel-rear-set! chan new)
+    (cond
+     ((pair? rear)
+      (set-cdr! rear new))
+     (else  ; sending to empty channel
+      (channel-front-set! chan new)
+      (condition-variable-broadcast! (channel-condvar chan)))))
+  (mutex-unlock! (channel-mutex chan)))
+
+(define (channel-receive! chan)
+  (mutex-lock! (channel-mutex chan))
+  (let ((front (channel-front chan)))
+    (cond
+     ((null? front)  ; receiving from empty channel
+      (mutex-unlock! (channel-mutex chan) (channel-condvar chan))
+      (channel-receive! chan))
+     (else
+      (channel-front-set! chan (cdr front))
+      (if (null? (cdr front))
+          (channel-rear-set! chan '()))
+      (mutex-unlock! (channel-mutex chan))
+      (car front)))))
diff --git a/lib/chibi/channel.sld b/lib/chibi/channel.sld
new file mode 100644
index 00000000..435aca1b
--- /dev/null
+++ b/lib/chibi/channel.sld
@@ -0,0 +1,6 @@
+
+(define-library (chibi channel)
+  (import (chibi) (srfi 9) (srfi 18))
+  (export Channel make-channel channel? channel-empty?
+          channel-send! channel-receive!)
+  (include "channel.scm"))
diff --git a/lib/chibi/char-set.sld b/lib/chibi/char-set.sld
new file mode 100644
index 00000000..4889e33a
--- /dev/null
+++ b/lib/chibi/char-set.sld
@@ -0,0 +1,13 @@
+
+(define-library (chibi char-set)
+  (import (chibi) (chibi char-set base) (chibi char-set extras))
+  (export
+   Char-Set char-set? char-set-contains?
+   char-set ucs-range->char-set char-set-copy char-set-size
+   char-set-fold char-set-for-each
+   list->char-set char-set->list string->char-set char-set->string
+   char-set-adjoin! char-set-adjoin char-set-union char-set-union!
+   char-set-intersection char-set-intersection!
+   char-set-difference char-set-difference!
+   immutable-char-set char-set-complement
+   char-set:empty char-set:ascii char-set:full))
diff --git a/lib/chibi/char-set/ascii.scm b/lib/chibi/char-set/ascii.scm
new file mode 100644
index 00000000..8096ea07
--- /dev/null
+++ b/lib/chibi/char-set/ascii.scm
@@ -0,0 +1,42 @@
+;; char-set:lower-case
+(define char-set:lower-case (immutable-char-set (%make-iset 97 122 #f #f #f)))
+
+;; char-set:upper-case
+(define char-set:upper-case (immutable-char-set (%make-iset 65 90 #f #f #f)))
+
+;; char-set:title-case
+(define char-set:title-case (immutable-char-set (%make-iset 0 0 0 #f #f)))
+
+;; char-set:letter
+(define char-set:letter (immutable-char-set (%make-iset 97 122 #f (%make-iset 65 90 #f #f #f) #f)))
+
+;; char-set:punctuation
+(define char-set:punctuation (immutable-char-set (%make-iset 63 64 #f (%make-iset 44 47 #f (%make-iset 37 42 #f (%make-iset 33 35 #f #f #f) #f) (%make-iset 58 59 #f #f #f)) (%make-iset 123 123 #f (%make-iset 95 95 #f (%make-iset 91 93 #f #f #f) #f) (%make-iset 125 125 #f #f #f)))))
+
+;; char-set:symbol
+(define char-set:symbol (immutable-char-set (%make-iset 94 94 #f (%make-iset 43 43 #f (%make-iset 36 36 #f #f #f) (%make-iset 60 62 #f #f #f)) (%make-iset 124 124 #f (%make-iset 96 96 #f #f #f) (%make-iset 126 126 #f #f #f)))))
+
+;; char-set:blank
+(define char-set:blank (immutable-char-set (%make-iset 32 32 #f (%make-iset 9 9 #f #f #f) #f)))
+
+;; char-set:whitespace
+(define char-set:whitespace (immutable-char-set (%make-iset 32 32 #f (%make-iset 9 13 #f #f #f) #f)))
+
+;; char-set:digit
+(define char-set:digit (immutable-char-set (%make-iset 48 57 #f #f #f)))
+
+;; char-set:letter+digit
+(define char-set:letter+digit (immutable-char-set (%make-iset 65 90 #f (%make-iset 48 57 #f #f #f) (%make-iset 97 122 #f #f #f))))
+
+;; char-set:hex-digit
+(define char-set:hex-digit (immutable-char-set (%make-iset 65 70 #f (%make-iset 48 57 #f #f #f) (%make-iset 97 102 #f #f #f))))
+
+;; char-set:iso-control
+(define char-set:iso-control (immutable-char-set (%make-iset 127 127 #f (%make-iset 0 31 #f #f #f) #f)))
+
+;; char-set:graphic
+(define char-set:graphic (immutable-char-set (%make-iset 33 126 #f #f #f)))
+
+;; char-set:printing
+(define char-set:printing (immutable-char-set (%make-iset 32 126 #f (%make-iset 9 13 #f #f #f) #f)))
+
diff --git a/lib/chibi/char-set/ascii.sld b/lib/chibi/char-set/ascii.sld
new file mode 100644
index 00000000..cd2e5433
--- /dev/null
+++ b/lib/chibi/char-set/ascii.sld
@@ -0,0 +1,9 @@
+
+(define-library (chibi char-set ascii)
+  (import (chibi) (chibi iset base) (chibi char-set base))
+  (export char-set:lower-case  char-set:upper-case  char-set:title-case
+          char-set:letter      char-set:digit       char-set:letter+digit
+          char-set:graphic     char-set:printing    char-set:whitespace
+          char-set:iso-control char-set:punctuation char-set:symbol
+          char-set:hex-digit   char-set:blank)
+  (include "ascii.scm"))
diff --git a/lib/chibi/char-set/base.sld b/lib/chibi/char-set/base.sld
new file mode 100644
index 00000000..62cde5a4
--- /dev/null
+++ b/lib/chibi/char-set/base.sld
@@ -0,0 +1,14 @@
+
+(define-library (chibi char-set base)
+  (import (chibi) (chibi iset base))
+  (export (rename Integer-Set Char-Set)
+          (rename iset? char-set?)
+          immutable-char-set
+          char-set-contains?)
+  (begin
+    (define-syntax immutable-char-set
+      (sc-macro-transformer
+       (lambda (expr use-env)
+         (eval (cadr expr) use-env))))
+    (define (char-set-contains? cset ch)
+      (iset-contains? cset (char->integer ch)))))
diff --git a/lib/chibi/char-set/boundary.scm b/lib/chibi/char-set/boundary.scm
new file mode 100644
index 00000000..c7b9f04f
--- /dev/null
+++ b/lib/chibi/char-set/boundary.scm
@@ -0,0 +1,24 @@
+;; Control
+(define char-set:control (immutable-char-set (char-set-union (ucs-range->char-set 0 10) (ucs-range->char-set 11 13) (ucs-range->char-set 14 32) (ucs-range->char-set 127 160) (ucs-range->char-set 1536 1541) (ucs-range->char-set 8206 8208) (ucs-range->char-set 8234 8239) (ucs-range->char-set 8288 8293) (ucs-range->char-set 8294 8304) (ucs-range->char-set 55296 57344) (ucs-range->char-set 65520 65529) (ucs-range->char-set 65529 65532) (ucs-range->char-set 119155 119163) (ucs-range->char-set 917506 917536) (ucs-range->char-set 917536 917632) (ucs-range->char-set 917632 917760) (ucs-range->char-set 918000 921600))))
+
+;; Extend,SpacingMark
+(define char-set:extend-or-spacing-mark (immutable-char-set (char-set-union (char-set-union (ucs-range->char-set 768 880) (ucs-range->char-set 1155 1160) (ucs-range->char-set 1160 1162) (ucs-range->char-set 1425 1470) (ucs-range->char-set 1473 1475) (ucs-range->char-set 1476 1478) (ucs-range->char-set 1552 1563) (ucs-range->char-set 1611 1632) (ucs-range->char-set 1750 1757) (ucs-range->char-set 1759 1765) (ucs-range->char-set 1767 1769) (ucs-range->char-set 1770 1774) (ucs-range->char-set 1840 1867) (ucs-range->char-set 1958 1969) (ucs-range->char-set 2027 2036) (ucs-range->char-set 2070 2074) (ucs-range->char-set 2075 2084) (ucs-range->char-set 2085 2088) (ucs-range->char-set 2089 2094) (ucs-range->char-set 2137 2140) (ucs-range->char-set 2276 2303) (ucs-range->char-set 2304 2307) (ucs-range->char-set 2369 2377) (ucs-range->char-set 2385 2392) (ucs-range->char-set 2402 2404) (ucs-range->char-set 2497 2501) (ucs-range->char-set 2530 2532) (ucs-range->char-set 2561 2563) (ucs-range->char-set 2625 2627) (ucs-range->char-set 2631 2633) (ucs-range->char-set 2635 2638) (ucs-range->char-set 2672 2674) (ucs-range->char-set 2689 2691) (ucs-range->char-set 2753 2758) (ucs-range->char-set 2759 2761) (ucs-range->char-set 2786 2788) (ucs-range->char-set 2881 2885) (ucs-range->char-set 2914 2916) (ucs-range->char-set 3134 3137) (ucs-range->char-set 3142 3145) (ucs-range->char-set 3146 3150) (ucs-range->char-set 3157 3159) (ucs-range->char-set 3170 3172) (ucs-range->char-set 3276 3278) (ucs-range->char-set 3285 3287) (ucs-range->char-set 3298 3300) (ucs-range->char-set 3393 3397) (ucs-range->char-set 3426 3428) (ucs-range->char-set 3538 3541) (ucs-range->char-set 3636 3643) (ucs-range->char-set 3655 3663) (ucs-range->char-set 3764 3770) (ucs-range->char-set 3771 3773) (ucs-range->char-set 3784 3790) (ucs-range->char-set 3864 3866) (ucs-range->char-set 3953 3967) (ucs-range->char-set 3968 3973) (ucs-range->char-set 3974 3976) (ucs-range->char-set 3981 3992) (ucs-range->char-set 3993 4029) (ucs-range->char-set 4141 4145) (ucs-range->char-set 4146 4152) (ucs-range->char-set 4153 4155) (ucs-range->char-set 4157 4159) (ucs-range->char-set 4184 4186) (ucs-range->char-set 4190 4193) (ucs-range->char-set 4209 4213) (ucs-range->char-set 4229 4231) (ucs-range->char-set 4957 4960) (ucs-range->char-set 5906 5909) (ucs-range->char-set 5938 5941) (ucs-range->char-set 5970 5972) (ucs-range->char-set 6002 6004) (ucs-range->char-set 6068 6070) (ucs-range->char-set 6071 6078) (ucs-range->char-set 6089 6100) (ucs-range->char-set 6155 6158) (ucs-range->char-set 6432 6435) (ucs-range->char-set 6439 6441) (ucs-range->char-set 6457 6460) (ucs-range->char-set 6679 6681) (ucs-range->char-set 6744 6751) (ucs-range->char-set 6757 6765) (ucs-range->char-set 6771 6781) (ucs-range->char-set 6912 6916) (ucs-range->char-set 6966 6971) (ucs-range->char-set 7019 7028) (ucs-range->char-set 7040 7042) (ucs-range->char-set 7074 7078) (ucs-range->char-set 7080 7082) (ucs-range->char-set 7144 7146) (ucs-range->char-set 7151 7154) (ucs-range->char-set 7212 7220) (ucs-range->char-set 7222 7224) (ucs-range->char-set 7376 7379) (ucs-range->char-set 7380 7393) (ucs-range->char-set 7394 7401) (ucs-range->char-set 7616 7655) (ucs-range->char-set 7676 7680) (ucs-range->char-set 8204 8206) (ucs-range->char-set 8400 8413) (ucs-range->char-set 8413 8417) (ucs-range->char-set 8418 8421) (ucs-range->char-set 8421 8433) (ucs-range->char-set 11503 11506) (ucs-range->char-set 11744 11776) (ucs-range->char-set 12330 12334) (ucs-range->char-set 12334 12336) (ucs-range->char-set 12441 12443) (ucs-range->char-set 42608 42611) (ucs-range->char-set 42612 42622) (ucs-range->char-set 42736 42738) (ucs-range->char-set 43045 43047) (ucs-range->char-set 43232 43250) (ucs-range->char-set 43302 43310) (ucs-range->char-set 43335 43346) (ucs-range->char-set 43392 43395) (ucs-range->char-set 43446 43450) (ucs-range->char-set 43561 43567) (ucs-range->char-set 43569 43571) (ucs-range->char-set 43573 43575) (ucs-range->char-set 43698 43701) (ucs-range->char-set 43703 43705) (ucs-range->char-set 43710 43712) (ucs-range->char-set 43756 43758) (ucs-range->char-set 65024 65040) (ucs-range->char-set 65056 65063) (ucs-range->char-set 65438 65440) (ucs-range->char-set 68097 68100) (ucs-range->char-set 68101 68103) (ucs-range->char-set 68108 68112) (ucs-range->char-set 68152 68155) (ucs-range->char-set 69688 69703) (ucs-range->char-set 69760 69762) (ucs-range->char-set 69811 69815) (ucs-range->char-set 69817 69819) (ucs-range->char-set 69888 69891) (ucs-range->char-set 69927 69932) (ucs-range->char-set 69933 69941) (ucs-range->char-set 70016 70018) (ucs-range->char-set 70070 70079) (ucs-range->char-set 71344 71350) (ucs-range->char-set 94095 94099) (ucs-range->char-set 119143 119146) (ucs-range->char-set 119150 119155) (ucs-range->char-set 119163 119171) (ucs-range->char-set 119173 119180) (ucs-range->char-set 119210 119214) (ucs-range->char-set 119362 119365) (ucs-range->char-set 917760 918000)) (char-set-union (ucs-range->char-set 2366 2369) (ucs-range->char-set 2377 2381) (ucs-range->char-set 2382 2384) (ucs-range->char-set 2434 2436) (ucs-range->char-set 2495 2497) (ucs-range->char-set 2503 2505) (ucs-range->char-set 2507 2509) (ucs-range->char-set 2622 2625) (ucs-range->char-set 2750 2753) (ucs-range->char-set 2763 2765) (ucs-range->char-set 2818 2820) (ucs-range->char-set 2887 2889) (ucs-range->char-set 2891 2893) (ucs-range->char-set 3009 3011) (ucs-range->char-set 3014 3017) (ucs-range->char-set 3018 3021) (ucs-range->char-set 3073 3076) (ucs-range->char-set 3137 3141) (ucs-range->char-set 3202 3204) (ucs-range->char-set 3264 3266) (ucs-range->char-set 3267 3269) (ucs-range->char-set 3271 3273) (ucs-range->char-set 3274 3276) (ucs-range->char-set 3330 3332) (ucs-range->char-set 3391 3393) (ucs-range->char-set 3398 3401) (ucs-range->char-set 3402 3405) (ucs-range->char-set 3458 3460) (ucs-range->char-set 3536 3538) (ucs-range->char-set 3544 3551) (ucs-range->char-set 3570 3572) (ucs-range->char-set 3902 3904) (ucs-range->char-set 4155 4157) (ucs-range->char-set 4182 4184) (ucs-range->char-set 6078 6086) (ucs-range->char-set 6087 6089) (ucs-range->char-set 6435 6439) (ucs-range->char-set 6441 6444) (ucs-range->char-set 6448 6450) (ucs-range->char-set 6451 6457) (ucs-range->char-set 6581 6584) (ucs-range->char-set 6681 6683) (ucs-range->char-set 6765 6771) (ucs-range->char-set 6973 6978) (ucs-range->char-set 6979 6981) (ucs-range->char-set 7078 7080) (ucs-range->char-set 7084 7086) (ucs-range->char-set 7146 7149) (ucs-range->char-set 7154 7156) (ucs-range->char-set 7204 7212) (ucs-range->char-set 7220 7222) (ucs-range->char-set 7410 7412) (ucs-range->char-set 43043 43045) (ucs-range->char-set 43136 43138) (ucs-range->char-set 43188 43204) (ucs-range->char-set 43346 43348) (ucs-range->char-set 43444 43446) (ucs-range->char-set 43450 43452) (ucs-range->char-set 43453 43457) (ucs-range->char-set 43567 43569) (ucs-range->char-set 43571 43573) (ucs-range->char-set 43758 43760) (ucs-range->char-set 44003 44005) (ucs-range->char-set 44006 44008) (ucs-range->char-set 44009 44011) (ucs-range->char-set 69808 69811) (ucs-range->char-set 69815 69817) (ucs-range->char-set 70067 70070) (ucs-range->char-set 70079 70081) (ucs-range->char-set 71342 71344) (ucs-range->char-set 94033 94079)))))
+
+;; Regional_Indicator
+(define char-set:regional-indicator (immutable-char-set (char-set-union (ucs-range->char-set 127462 127488))))
+
+;; :L
+(define char-set:hangul-l (immutable-char-set (char-set-union (ucs-range->char-set 4352 4448) (ucs-range->char-set 43360 43389))))
+
+;; :V
+(define char-set:hangul-v (immutable-char-set (char-set-union (ucs-range->char-set 4448 4520) (ucs-range->char-set 55216 55239))))
+
+;; :T
+(define char-set:hangul-t (immutable-char-set (char-set-union (ucs-range->char-set 4520 4608) (ucs-range->char-set 55243 55292))))
+
+;; :LV
+(define char-set:hangul-lv (immutable-char-set (char-set-union)))
+
+;; :LVT
+(define char-set:hangul-lvt (immutable-char-set (char-set-union (ucs-range->char-set 44033 44060) (ucs-range->char-set 44061 44088) (ucs-range->char-set 44089 44116) (ucs-range->char-set 44117 44144) (ucs-range->char-set 44145 44172) (ucs-range->char-set 44173 44200) (ucs-range->char-set 44201 44228) (ucs-range->char-set 44229 44256) (ucs-range->char-set 44257 44284) (ucs-range->char-set 44285 44312) (ucs-range->char-set 44313 44340) (ucs-range->char-set 44341 44368) (ucs-range->char-set 44369 44396) (ucs-range->char-set 44397 44424) (ucs-range->char-set 44425 44452) (ucs-range->char-set 44453 44480) (ucs-range->char-set 44481 44508) (ucs-range->char-set 44509 44536) (ucs-range->char-set 44537 44564) (ucs-range->char-set 44565 44592) (ucs-range->char-set 44593 44620) (ucs-range->char-set 44621 44648) (ucs-range->char-set 44649 44676) (ucs-range->char-set 44677 44704) (ucs-range->char-set 44705 44732) (ucs-range->char-set 44733 44760) (ucs-range->char-set 44761 44788) (ucs-range->char-set 44789 44816) (ucs-range->char-set 44817 44844) (ucs-range->char-set 44845 44872) (ucs-range->char-set 44873 44900) (ucs-range->char-set 44901 44928) (ucs-range->char-set 44929 44956) (ucs-range->char-set 44957 44984) (ucs-range->char-set 44985 45012) (ucs-range->char-set 45013 45040) (ucs-range->char-set 45041 45068) (ucs-range->char-set 45069 45096) (ucs-range->char-set 45097 45124) (ucs-range->char-set 45125 45152) (ucs-range->char-set 45153 45180) (ucs-range->char-set 45181 45208) (ucs-range->char-set 45209 45236) (ucs-range->char-set 45237 45264) (ucs-range->char-set 45265 45292) (ucs-range->char-set 45293 45320) (ucs-range->char-set 45321 45348) (ucs-range->char-set 45349 45376) (ucs-range->char-set 45377 45404) (ucs-range->char-set 45405 45432) (ucs-range->char-set 45433 45460) (ucs-range->char-set 45461 45488) (ucs-range->char-set 45489 45516) (ucs-range->char-set 45517 45544) (ucs-range->char-set 45545 45572) (ucs-range->char-set 45573 45600) (ucs-range->char-set 45601 45628) (ucs-range->char-set 45629 45656) (ucs-range->char-set 45657 45684) (ucs-range->char-set 45685 45712) (ucs-range->char-set 45713 45740) (ucs-range->char-set 45741 45768) (ucs-range->char-set 45769 45796) (ucs-range->char-set 45797 45824) (ucs-range->char-set 45825 45852) (ucs-range->char-set 45853 45880) (ucs-range->char-set 45881 45908) (ucs-range->char-set 45909 45936) (ucs-range->char-set 45937 45964) (ucs-range->char-set 45965 45992) (ucs-range->char-set 45993 46020) (ucs-range->char-set 46021 46048) (ucs-range->char-set 46049 46076) (ucs-range->char-set 46077 46104) (ucs-range->char-set 46105 46132) (ucs-range->char-set 46133 46160) (ucs-range->char-set 46161 46188) (ucs-range->char-set 46189 46216) (ucs-range->char-set 46217 46244) (ucs-range->char-set 46245 46272) (ucs-range->char-set 46273 46300) (ucs-range->char-set 46301 46328) (ucs-range->char-set 46329 46356) (ucs-range->char-set 46357 46384) (ucs-range->char-set 46385 46412) (ucs-range->char-set 46413 46440) (ucs-range->char-set 46441 46468) (ucs-range->char-set 46469 46496) (ucs-range->char-set 46497 46524) (ucs-range->char-set 46525 46552) (ucs-range->char-set 46553 46580) (ucs-range->char-set 46581 46608) (ucs-range->char-set 46609 46636) (ucs-range->char-set 46637 46664) (ucs-range->char-set 46665 46692) (ucs-range->char-set 46693 46720) (ucs-range->char-set 46721 46748) (ucs-range->char-set 46749 46776) (ucs-range->char-set 46777 46804) (ucs-range->char-set 46805 46832) (ucs-range->char-set 46833 46860) (ucs-range->char-set 46861 46888) (ucs-range->char-set 46889 46916) (ucs-range->char-set 46917 46944) (ucs-range->char-set 46945 46972) (ucs-range->char-set 46973 47000) (ucs-range->char-set 47001 47028) (ucs-range->char-set 47029 47056) (ucs-range->char-set 47057 47084) (ucs-range->char-set 47085 47112) (ucs-range->char-set 47113 47140) (ucs-range->char-set 47141 47168) (ucs-range->char-set 47169 47196) (ucs-range->char-set 47197 47224) (ucs-range->char-set 47225 47252) (ucs-range->char-set 47253 47280) (ucs-range->char-set 47281 47308) (ucs-range->char-set 47309 47336) (ucs-range->char-set 47337 47364) (ucs-range->char-set 47365 47392) (ucs-range->char-set 47393 47420) (ucs-range->char-set 47421 47448) (ucs-range->char-set 47449 47476) (ucs-range->char-set 47477 47504) (ucs-range->char-set 47505 47532) (ucs-range->char-set 47533 47560) (ucs-range->char-set 47561 47588) (ucs-range->char-set 47589 47616) (ucs-range->char-set 47617 47644) (ucs-range->char-set 47645 47672) (ucs-range->char-set 47673 47700) (ucs-range->char-set 47701 47728) (ucs-range->char-set 47729 47756) (ucs-range->char-set 47757 47784) (ucs-range->char-set 47785 47812) (ucs-range->char-set 47813 47840) (ucs-range->char-set 47841 47868) (ucs-range->char-set 47869 47896) (ucs-range->char-set 47897 47924) (ucs-range->char-set 47925 47952) (ucs-range->char-set 47953 47980) (ucs-range->char-set 47981 48008) (ucs-range->char-set 48009 48036) (ucs-range->char-set 48037 48064) (ucs-range->char-set 48065 48092) (ucs-range->char-set 48093 48120) (ucs-range->char-set 48121 48148) (ucs-range->char-set 48149 48176) (ucs-range->char-set 48177 48204) (ucs-range->char-set 48205 48232) (ucs-range->char-set 48233 48260) (ucs-range->char-set 48261 48288) (ucs-range->char-set 48289 48316) (ucs-range->char-set 48317 48344) (ucs-range->char-set 48345 48372) (ucs-range->char-set 48373 48400) (ucs-range->char-set 48401 48428) (ucs-range->char-set 48429 48456) (ucs-range->char-set 48457 48484) (ucs-range->char-set 48485 48512) (ucs-range->char-set 48513 48540) (ucs-range->char-set 48541 48568) (ucs-range->char-set 48569 48596) (ucs-range->char-set 48597 48624) (ucs-range->char-set 48625 48652) (ucs-range->char-set 48653 48680) (ucs-range->char-set 48681 48708) (ucs-range->char-set 48709 48736) (ucs-range->char-set 48737 48764) (ucs-range->char-set 48765 48792) (ucs-range->char-set 48793 48820) (ucs-range->char-set 48821 48848) (ucs-range->char-set 48849 48876) (ucs-range->char-set 48877 48904) (ucs-range->char-set 48905 48932) (ucs-range->char-set 48933 48960) (ucs-range->char-set 48961 48988) (ucs-range->char-set 48989 49016) (ucs-range->char-set 49017 49044) (ucs-range->char-set 49045 49072) (ucs-range->char-set 49073 49100) (ucs-range->char-set 49101 49128) (ucs-range->char-set 49129 49156) (ucs-range->char-set 49157 49184) (ucs-range->char-set 49185 49212) (ucs-range->char-set 49213 49240) (ucs-range->char-set 49241 49268) (ucs-range->char-set 49269 49296) (ucs-range->char-set 49297 49324) (ucs-range->char-set 49325 49352) (ucs-range->char-set 49353 49380) (ucs-range->char-set 49381 49408) (ucs-range->char-set 49409 49436) (ucs-range->char-set 49437 49464) (ucs-range->char-set 49465 49492) (ucs-range->char-set 49493 49520) (ucs-range->char-set 49521 49548) (ucs-range->char-set 49549 49576) (ucs-range->char-set 49577 49604) (ucs-range->char-set 49605 49632) (ucs-range->char-set 49633 49660) (ucs-range->char-set 49661 49688) (ucs-range->char-set 49689 49716) (ucs-range->char-set 49717 49744) (ucs-range->char-set 49745 49772) (ucs-range->char-set 49773 49800) (ucs-range->char-set 49801 49828) (ucs-range->char-set 49829 49856) (ucs-range->char-set 49857 49884) (ucs-range->char-set 49885 49912) (ucs-range->char-set 49913 49940) (ucs-range->char-set 49941 49968) (ucs-range->char-set 49969 49996) (ucs-range->char-set 49997 50024) (ucs-range->char-set 50025 50052) (ucs-range->char-set 50053 50080) (ucs-range->char-set 50081 50108) (ucs-range->char-set 50109 50136) (ucs-range->char-set 50137 50164) (ucs-range->char-set 50165 50192) (ucs-range->char-set 50193 50220) (ucs-range->char-set 50221 50248) (ucs-range->char-set 50249 50276) (ucs-range->char-set 50277 50304) (ucs-range->char-set 50305 50332) (ucs-range->char-set 50333 50360) (ucs-range->char-set 50361 50388) (ucs-range->char-set 50389 50416) (ucs-range->char-set 50417 50444) (ucs-range->char-set 50445 50472) (ucs-range->char-set 50473 50500) (ucs-range->char-set 50501 50528) (ucs-range->char-set 50529 50556) (ucs-range->char-set 50557 50584) (ucs-range->char-set 50585 50612) (ucs-range->char-set 50613 50640) (ucs-range->char-set 50641 50668) (ucs-range->char-set 50669 50696) (ucs-range->char-set 50697 50724) (ucs-range->char-set 50725 50752) (ucs-range->char-set 50753 50780) (ucs-range->char-set 50781 50808) (ucs-range->char-set 50809 50836) (ucs-range->char-set 50837 50864) (ucs-range->char-set 50865 50892) (ucs-range->char-set 50893 50920) (ucs-range->char-set 50921 50948) (ucs-range->char-set 50949 50976) (ucs-range->char-set 50977 51004) (ucs-range->char-set 51005 51032) (ucs-range->char-set 51033 51060) (ucs-range->char-set 51061 51088) (ucs-range->char-set 51089 51116) (ucs-range->char-set 51117 51144) (ucs-range->char-set 51145 51172) (ucs-range->char-set 51173 51200) (ucs-range->char-set 51201 51228) (ucs-range->char-set 51229 51256) (ucs-range->char-set 51257 51284) (ucs-range->char-set 51285 51312) (ucs-range->char-set 51313 51340) (ucs-range->char-set 51341 51368) (ucs-range->char-set 51369 51396) (ucs-range->char-set 51397 51424) (ucs-range->char-set 51425 51452) (ucs-range->char-set 51453 51480) (ucs-range->char-set 51481 51508) (ucs-range->char-set 51509 51536) (ucs-range->char-set 51537 51564) (ucs-range->char-set 51565 51592) (ucs-range->char-set 51593 51620) (ucs-range->char-set 51621 51648) (ucs-range->char-set 51649 51676) (ucs-range->char-set 51677 51704) (ucs-range->char-set 51705 51732) (ucs-range->char-set 51733 51760) (ucs-range->char-set 51761 51788) (ucs-range->char-set 51789 51816) (ucs-range->char-set 51817 51844) (ucs-range->char-set 51845 51872) (ucs-range->char-set 51873 51900) (ucs-range->char-set 51901 51928) (ucs-range->char-set 51929 51956) (ucs-range->char-set 51957 51984) (ucs-range->char-set 51985 52012) (ucs-range->char-set 52013 52040) (ucs-range->char-set 52041 52068) (ucs-range->char-set 52069 52096) (ucs-range->char-set 52097 52124) (ucs-range->char-set 52125 52152) (ucs-range->char-set 52153 52180) (ucs-range->char-set 52181 52208) (ucs-range->char-set 52209 52236) (ucs-range->char-set 52237 52264) (ucs-range->char-set 52265 52292) (ucs-range->char-set 52293 52320) (ucs-range->char-set 52321 52348) (ucs-range->char-set 52349 52376) (ucs-range->char-set 52377 52404) (ucs-range->char-set 52405 52432) (ucs-range->char-set 52433 52460) (ucs-range->char-set 52461 52488) (ucs-range->char-set 52489 52516) (ucs-range->char-set 52517 52544) (ucs-range->char-set 52545 52572) (ucs-range->char-set 52573 52600) (ucs-range->char-set 52601 52628) (ucs-range->char-set 52629 52656) (ucs-range->char-set 52657 52684) (ucs-range->char-set 52685 52712) (ucs-range->char-set 52713 52740) (ucs-range->char-set 52741 52768) (ucs-range->char-set 52769 52796) (ucs-range->char-set 52797 52824) (ucs-range->char-set 52825 52852) (ucs-range->char-set 52853 52880) (ucs-range->char-set 52881 52908) (ucs-range->char-set 52909 52936) (ucs-range->char-set 52937 52964) (ucs-range->char-set 52965 52992) (ucs-range->char-set 52993 53020) (ucs-range->char-set 53021 53048) (ucs-range->char-set 53049 53076) (ucs-range->char-set 53077 53104) (ucs-range->char-set 53105 53132) (ucs-range->char-set 53133 53160) (ucs-range->char-set 53161 53188) (ucs-range->char-set 53189 53216) (ucs-range->char-set 53217 53244) (ucs-range->char-set 53245 53272) (ucs-range->char-set 53273 53300) (ucs-range->char-set 53301 53328) (ucs-range->char-set 53329 53356) (ucs-range->char-set 53357 53384) (ucs-range->char-set 53385 53412) (ucs-range->char-set 53413 53440) (ucs-range->char-set 53441 53468) (ucs-range->char-set 53469 53496) (ucs-range->char-set 53497 53524) (ucs-range->char-set 53525 53552) (ucs-range->char-set 53553 53580) (ucs-range->char-set 53581 53608) (ucs-range->char-set 53609 53636) (ucs-range->char-set 53637 53664) (ucs-range->char-set 53665 53692) (ucs-range->char-set 53693 53720) (ucs-range->char-set 53721 53748) (ucs-range->char-set 53749 53776) (ucs-range->char-set 53777 53804) (ucs-range->char-set 53805 53832) (ucs-range->char-set 53833 53860) (ucs-range->char-set 53861 53888) (ucs-range->char-set 53889 53916) (ucs-range->char-set 53917 53944) (ucs-range->char-set 53945 53972) (ucs-range->char-set 53973 54000) (ucs-range->char-set 54001 54028) (ucs-range->char-set 54029 54056) (ucs-range->char-set 54057 54084) (ucs-range->char-set 54085 54112) (ucs-range->char-set 54113 54140) (ucs-range->char-set 54141 54168) (ucs-range->char-set 54169 54196) (ucs-range->char-set 54197 54224) (ucs-range->char-set 54225 54252) (ucs-range->char-set 54253 54280) (ucs-range->char-set 54281 54308) (ucs-range->char-set 54309 54336) (ucs-range->char-set 54337 54364) (ucs-range->char-set 54365 54392) (ucs-range->char-set 54393 54420) (ucs-range->char-set 54421 54448) (ucs-range->char-set 54449 54476) (ucs-range->char-set 54477 54504) (ucs-range->char-set 54505 54532) (ucs-range->char-set 54533 54560) (ucs-range->char-set 54561 54588) (ucs-range->char-set 54589 54616) (ucs-range->char-set 54617 54644) (ucs-range->char-set 54645 54672) (ucs-range->char-set 54673 54700) (ucs-range->char-set 54701 54728) (ucs-range->char-set 54729 54756) (ucs-range->char-set 54757 54784) (ucs-range->char-set 54785 54812) (ucs-range->char-set 54813 54840) (ucs-range->char-set 54841 54868) (ucs-range->char-set 54869 54896) (ucs-range->char-set 54897 54924) (ucs-range->char-set 54925 54952) (ucs-range->char-set 54953 54980) (ucs-range->char-set 54981 55008) (ucs-range->char-set 55009 55036) (ucs-range->char-set 55037 55064) (ucs-range->char-set 55065 55092) (ucs-range->char-set 55093 55120) (ucs-range->char-set 55121 55148) (ucs-range->char-set 55149 55176) (ucs-range->char-set 55177 55204))))
+
diff --git a/lib/chibi/char-set/boundary.sld b/lib/chibi/char-set/boundary.sld
new file mode 100644
index 00000000..f4037786
--- /dev/null
+++ b/lib/chibi/char-set/boundary.sld
@@ -0,0 +1,21 @@
+;; Character sets for Unicode boundaries, TR29.
+
+(define-library (chibi char-set boundary)
+  (cond-expand
+   (chibi
+    (import (chibi) (chibi char-set)))
+   (else
+    (import (scheme base) (srfi 14))
+    (begin (define (immutable-char-set cs) cs))))
+  (export char-set:regional-indicator
+          char-set:extend-or-spacing-mark
+          char-set:hangul-l
+          char-set:hangul-v
+          char-set:hangul-t
+          char-set:hangul-lv
+          char-set:hangul-lvt)
+  ;; generated with:
+  ;; tools/extract-unicode-props.scm --derived GraphemeBreakProperty.txt
+  ;;   Control extend-or-spacing-mark=Extend,SpacingMark Regional_Indicator
+  ;;   hangul-l=:L hangul-v=:V hangul-t=:T hangul-lv=:LV hangul-lvt=:LVT
+  (include "boundary.scm"))
diff --git a/lib/chibi/char-set/extras.scm b/lib/chibi/char-set/extras.scm
new file mode 100644
index 00000000..96846e42
--- /dev/null
+++ b/lib/chibi/char-set/extras.scm
@@ -0,0 +1,53 @@
+
+(define (char-set . args)
+  (list->char-set args))
+
+;; This is a mistake in the SRFI-14 design - end should be inclusive.
+(define (ucs-range->char-set start end)
+  (make-iset start (- end 1)))
+
+(define char-set-copy iset-copy)
+
+(define char-set-size iset-size)
+
+(define (char-set-fold kons knil cset)
+  (iset-fold (lambda (i acc) (kons (integer->char i) acc)) knil cset))
+
+(define (char-set-for-each proc cset)
+  (iset-for-each (lambda (i) (proc (integer->char i))) cset))
+
+(define (list->char-set ls)
+  (list->iset (map char->integer ls)))
+(define (char-set->list cset)
+  (map integer->char (iset->list cset)))
+
+(define (string->char-set str)
+  (list->char-set (string->list str)))
+(define (char-set->string cset)
+  (list->string (char-set->list cset)))
+
+(define (char-set-adjoin! cset ch)
+  (iset-adjoin! cset (char->integer ch)))
+(define (char-set-adjoin cset ch)
+  (iset-adjoin cset (char->integer ch)))
+
+(define char-set-union iset-union)
+(define char-set-union! iset-union!)
+(define char-set-intersection iset-intersection)
+(define char-set-intersection! iset-intersection!)
+(define char-set-difference iset-difference)
+(define char-set-difference! iset-difference!)
+
+(define char-set:empty (immutable-char-set (%make-iset 0 0 0 #f #f)))
+(define char-set:ascii (immutable-char-set (%make-iset 0 #x7F #f #f #f)))
+
+(cond-expand
+ (full-unicode
+  (define char-set:full
+    (immutable-char-set
+     (%make-iset 0 #xD7FF #f #f (%make-iset #xE000 #x10FFFD #f #f #f)))))
+ (else
+  (define char-set:full (immutable-char-set (%make-iset 0 #xFF #f #f #f)))))
+
+(define (char-set-complement cset)
+  (char-set-difference char-set:full cset))
diff --git a/lib/chibi/char-set/extras.sld b/lib/chibi/char-set/extras.sld
new file mode 100644
index 00000000..ccfc812f
--- /dev/null
+++ b/lib/chibi/char-set/extras.sld
@@ -0,0 +1,12 @@
+
+(define-library (chibi char-set extras)
+  (import (chibi) (chibi iset) (chibi char-set base))
+  (include "extras.scm")
+  (export
+   char-set ucs-range->char-set char-set-copy char-set-size
+   char-set-fold char-set-for-each
+   list->char-set char-set->list string->char-set char-set->string
+   char-set-adjoin! char-set-adjoin char-set-union char-set-union!
+   char-set-intersection char-set-intersection!
+   char-set-difference char-set-difference!
+   char-set-complement char-set:empty char-set:ascii char-set:full))
diff --git a/lib/chibi/char-set/full.scm b/lib/chibi/char-set/full.scm
new file mode 100644
index 00000000..0240cf56
--- /dev/null
+++ b/lib/chibi/char-set/full.scm
@@ -0,0 +1,42 @@
+;; char-set:lower-case
+(define char-set:lower-case (immutable-char-set (%make-iset 11312 11557 113078212145405220956299481848306876004857152314519694622414813644330106879 (%make-iset 7424 7615 6277101735386680763834460195211881500229451637403754168319 (%make-iset 891 1231 3359617113266706315836163420852667279900761594669382740612734659380575149118011965863067042895076786183 (%make-iset 591 740 1382646202340133545564837515061266821645598719 (%make-iset 97 576 2365509536875796115271152425453441351280931286999514252096600828646551318540912334052744481790519950100366591329056407886414129454316222836375551 #f #f) #f) (%make-iset 1377 1415 #f #f #f)) (%make-iset 8336 8575 1766820104831717270911194217800685387968293958678012717949960101612756991 (%make-iset 7829 8183 63072327451413996121415570261819623312617164997438933550707549860292318813601613991411837156872431794651647 #f #f) (%make-iset 9424 9449 #f #f #f))) (%make-iset 65345 65370 #f (%make-iset 43000 43001 #f (%make-iset 42799 42872 18815678955183742648327 #f #f) (%make-iset 64256 64279 16253055 #f #f)) (%make-iset 119834 120327 51146727486231585908820696036815651831314948480676177501992199236163085036512359821035265912047941451080432971005274950492488384578638513597382131711 (%make-iset 66600 66639 #f #f #f) (%make-iset 120354 120777 42984503304530211461104808282321868720026385944674536297193504244060802094551012793517930744128497289034962077133152853331804159 #f #f))))))
+
+;; char-set:upper-case
+(define char-set:upper-case (immutable-char-set (%make-iset 9398 9423 #f (%make-iset 1216 1366 2854495385401535168399502283641929280107053059 (%make-iset 376 582 193510492298500594587530311832788051917914503280678853822825987 (%make-iset 65 222 363948161469878586209393690477933956061783392255 #f #f) (%make-iset 904 1071 374144419156711012060424995402076372759432889630407 #f #f)) (%make-iset 7944 8187 1736907842101479124536426275495535083658609664624882011531376654293716462141695 (%make-iset 4256 4293 #f #f #f) (%make-iset 8459 8559 2535262514830237892353053933799 #f #f))) (%make-iset 66560 66599 #f (%make-iset 42877 42878 #f (%make-iset 11264 11392 595503879886640614262110651042930622463 #f #f) (%make-iset 65313 65338 #f #f #f)) (%make-iset 120328 120744 338460645933693697560665215760249528245999403264098033404085806319476851798827321172475719366475085497933670543086984716353535 (%make-iset 119808 120301 51146727486231585908820696036815651831314948480394089408712024707913450654934185184668161964607423236491353583631673266179433585099917637254106841087 #f #f) #f)))))
+
+;; char-set:title-case
+(define char-set:title-case (immutable-char-set (%make-iset 8072 8188 83076749736557537208897815481090303 (%make-iset 453 498 35184372088905 #f #f) #f)))
+
+;; char-set:letter
+(define char-set:letter (immutable-char-set (%make-iset 44032 55203 #f (%make-iset 6912 7414 22886562555891042693710382455505074355841760073166317418421820388451117221729500954464088123708152923721508489525154758089698131078348046953168412606447 (%make-iset 3913 4346 44362715105927999221712262984342111652617098472873236058512408135598431308732685725527979136265102154321118707789398691204023975935 (%make-iset 1869 2380 13407424329480734270447878660048428920496373804417168083627602288254107168259292949124979141882146787383731347613928737074953757721179033264662499184082943 (%make-iset 880 1366 399583814438996167382020011346842847816169115710121343500162631807336209279770003226660543306154439487482399564906606488253101298916621286954252495 (%make-iset 452 740 963565667247331348724662781356953235953225866953231882562121816871620562685859362504703 (%make-iset 65 451 314600393224337169960540460799584166474933543237622550739399649019542269878494744694979332000092312996040451282698239 #f #f) #f) (%make-iset 1377 1855 1560874275157973934342501410334434064559112153595576892194119830209925249809262307688780388207250242577643819833026382406056630315346898446188543 #f #f)) (%make-iset 2908 3404 381991200485141231019756222367537226053710584749387702525493540482928266985181611648107653982490012918979831010671369935541658005339438249753284968699 (%make-iset 2382 2892 5366736463464336406706714106425487149575078127243771493347988908203826370682080174911419639786360015702762728603625228669492029470702181043482460663316355 #f #f) (%make-iset 3424 3911 796045880330578019002307293597294347346987043146984104137316595631780707567417231169995506839382805294177527833722740156565765733950441790015275023 #f #f))) (%make-iset 5121 5740 #f (%make-iset 4682 4822 2787528182814337039150675927861957382578127 (%make-iset 4349 4680 #f #f #f) (%make-iset 4824 5108 62165404551223330269422779455378792455782943721961461362086716517957521327837304324095 #f #f)) (%make-iset 6212 6683 12194330229244424385358936041275179229938106075909171049697737889247539090636773541118657721546749280855637804188578406358228684801308538961919 (%make-iset 5743 6210 762145642144808933311681242303344929266684400897434715282060471834151313118761625963263953770881497968694418657905208578955948716669007691775 #f #f) (%make-iset 6688 6772 38685487814037185985773567 #f #f)))) (%make-iset 19968 40908 #f (%make-iset 9398 9449 #f (%make-iset 7680 8188 1669429210027032353070387959902572074068251569912541634239543664469254840701605815586298160569854604812755249439701457169906905863833481177213265564925951 (%make-iset 7424 7615 6277101735386680763834460195211881500229451637403754168319 #f #f) (%make-iset 8336 8584 904625697166121400702423284964750605108746128179460890055734500600385118207 #f #f)) (%make-iset 12321 12799 1560850458106678397246853318509506420346053090363696722427379182288726125506853871807416126725592575693831523564009034418563951096328109074350591 (%make-iset 11264 11775 1716199415031085457304815023196129625190876140284840059163076939411632061379695825768761320243048559913035261692194332965927453391792248614786550156348096511 #f #f) (%make-iset 13312 19893 #f #f #f))) (%make-iset 42656 43137 9366007796590143684266426014173832021882860391206691228341429856634888413055477646498624449482500722743196759142345085250473767233032902320062463 (%make-iset 40982 42124 #f (%make-iset 40960 40980 #f #f #f) (%make-iset 42192 42647 186070703019498633361408888448075376716851403313694244648522839560594426772554545643464113891391655073968019319443321956603475346266783743 #f #f)) (%make-iset 43648 43822 47701954761756259097387504798417463778755529815359487 (%make-iset 43138 43638 6495633707107511592130816216430842683164567658071841769919061558009539875610149675919448576995054309973657727503245554791947025664158092800029345447935 #f #f) (%make-iset 43968 44010 7559142440959 #f #f))))) (%make-iset 71296 71349 17952825858326527 (%make-iset 65536 65908 354901720847464262643270080013918741494457029505007323037992842993478140487429303646626346434630199938330987804055257434518162763775 (%make-iset 64256 64433 383123885216472214589586756787576615644966064332734591 (%make-iset 63744 64109 #f (%make-iset 55216 55291 75557863725914197590015 #f #f) (%make-iset 64112 64217 #f #f #f)) (%make-iset 64848 64967 341611594916723379280938182270919901183 (%make-iset 64467 64829 #f #f #f) (%make-iset 65008 65500 23166459242184795109519745412560813317707843523172326996034783221158488630072272676325665038195628414381257440134258275967737233656228847161199038463 #f #f))) (%make-iset 67840 68220 4925250765375315437575115447282545225619899143486530057386523691675827454339457238250572167562730571287653355880447 (%make-iset 66640 66717 #f (%make-iset 66176 66639 878680692688788100968217104054132723536510135400456683066998889497980605885632024127229627367624962058724496859707859793938161524087860595782141042536975695871 #f #f) (%make-iset 67584 67669 77371243358065019892792383 #f #f)) (%make-iset 68608 68680 #f (%make-iset 68352 68466 1427247352465131255837309846865400673685471231 #f #f) (%make-iset 69635 70084 204586912993508730593563550625432944389072422914203271589172564161864958211730995356562955949992950450193086469961732181890394864571677076213876129791 #f #f)))) (%make-iset 120146 120485 #f (%make-iset 92160 92728 #f (%make-iset 74752 74850 #f (%make-iset 73728 74606 #f #f #f) (%make-iset 77824 78894 #f #f #f)) (%make-iset 110592 110593 #f (%make-iset 93952 94111 1461323231539455856679019361440445717580125044735 #f #f) (%make-iset 119808 120144 1221462192088229133428742507380976417683660481320862010013722843488511299179635651402650638514783282651558855669972991 #f #f))) (%make-iset 131072 173782 #f (%make-iset 120656 120779 21226109557071405325645863666178850815 (%make-iset 120488 120654 187072206790762423064706648907459429699768891211775 #f #f) (%make-iset 126464 126651 6421867392636242726356536395708148792154285362342779204665327 #f #f)) (%make-iset 177984 178205 #f (%make-iset 173824 177972 #f #f #f) (%make-iset 194560 195101 #f #f #f))))))))
+
+;; char-set:punctuation
+(define char-set:punctuation (immutable-char-set (%make-iset 10627 10749 7975367975289779630837864365545226239 (%make-iset 5120 5120 #f (%make-iset 2800 2800 #f (%make-iset 1370 1805 177440029682739492195629626423414285791075425806584367987188710887245779556727828964224741026149370230681856791701409903272452423743 (%make-iset 894 903 513 (%make-iset 33 191 6277101735777033378358367027585284040564796057489604901879 #f #f) #f) (%make-iset 2404 2416 4099 (%make-iset 2039 2142 10141204806548057579655195000839 #f #f) #f)) (%make-iset 4347 4347 #f (%make-iset 3844 4175 8612299728833109452216727519275634166367255279803428156814546022481552546661143084834195942383124479 (%make-iset 3572 3675 15214283082817323578510236712961 #f #f) #f) (%make-iset 4960 4968 #f #f #f))) (%make-iset 7002 7008 #f (%make-iset 6468 6469 #f (%make-iset 6100 6154 36011204832919671 (%make-iset 5741 5942 4820814132776970826626481771165599449877669887122490332807171 #f #f) #f) (%make-iset 6816 6829 16255 (%make-iset 6686 6687 #f #f #f) #f)) (%make-iset 9001 9002 #f (%make-iset 8208 8334 127607834706674478748244504138880122879 (%make-iset 7164 7379 52681756409358971006475467946070306489686807156907791211684691983 #f #f) #f) (%make-iset 10088 10223 87027215340059722591700904977272299077631 #f #f)))) (%make-iset 65281 65381 2521683860030948918624327334903 (%make-iset 43124 43615 11987514433213410168505333362405758614102799522152940711615041872404225459959956214682136066587259816913167135759024198010248565942507088814987542543 (%make-iset 12289 12539 1809251394333065553493296641491499378872794969502476229475819322195851214727 (%make-iset 11776 11835 1152780767118491647 (%make-iset 11513 11632 664613997892457936451903530140172399 #f #f) #f) (%make-iset 42509 42743 54351252480975689826048702415431575448442147475312362296571857733681159 (%make-iset 42238 42239 #f #f #f) #f)) (%make-iset 64830 64831 #f (%make-iset 44011 44011 #f (%make-iset 43742 43761 786435 #f #f) #f) (%make-iset 65040 65131 4037812089938908849547248639 #f #f))) (%make-iset 68176 68223 140737488355839 (%make-iset 67671 67671 #f (%make-iset 66463 66512 562949953421313 (%make-iset 65792 65794 #f #f #f) #f) (%make-iset 67871 67903 4294967297 #f #f)) (%make-iset 70085 70088 #f (%make-iset 69703 69955 13569385457497991651199724805705614201565294768222350139146883642703225028735 (%make-iset 68409 68415 #f #f #f) #f) (%make-iset 74864 74867 #f #f #f)))))))
+
+;; char-set:symbol
+(define char-set:symbol (immutable-char-set (%make-iset 10750 11084 #f (%make-iset 4254 4255 #f (%make-iset 2801 2928 170141183460469231731687303715884105729 (%make-iset 1423 1551 536343496299213554716686148823119036417 (%make-iset 706 1014 521481209941628438084722096232800884555162981189081790621504207040293760564100563907364454415 (%make-iset 36 247 3291009115408659855127328282852688335858940725263447471358476417 #f #f) (%make-iset 1154 1154 #f #f #f)) (%make-iset 2038 2038 #f (%make-iset 1758 1790 6442452993 #f #f) (%make-iset 2546 2555 771 #f #f))) (%make-iset 3647 3647 #f (%make-iset 3199 3199 #f (%make-iset 3059 3066 #f #f #f) (%make-iset 3449 3449 #f #f #f)) (%make-iset 4030 4056 126058239 (%make-iset 3841 3896 47287798208921607 #f #f) #f))) (%make-iset 8592 9000 #f (%make-iset 6622 6655 #f (%make-iset 6107 6107 #f (%make-iset 5008 5017 #f #f #f) (%make-iset 6464 6464 #f #f #f)) (%make-iset 8125 8527 15180504508302547082559792549452134039979727921597050291198905168453617261872958515620728168035045459212134851764818477085 (%make-iset 7009 7036 267912191 #f #f) #f)) (%make-iset 10224 10626 #f (%make-iset 9472 9983 #f (%make-iset 9003 9449 363419362147803445274660701490199886974208000930090554402992578672453439413725018135787913021374683400778402767997805117095404640403455 #f #f) (%make-iset 9985 10213 862718293047519590130783627714548701007576706064464912086123449155583 #f #f)) (%make-iset 10716 10749 4294967295 (%make-iset 10649 10711 #f #f #f) #f)))) (%make-iset 65020 65129 796084576943328064139929612976131 (%make-iset 19904 19967 #f (%make-iset 12443 12444 #f (%make-iset 11493 11498 #f (%make-iset 11088 11097 #f #f #f) (%make-iset 11904 12351 547258453716185545689710299454841531346882567525409776024515836385994490529377606833512566938465691840048809561654146263061905633443839 #f #f)) (%make-iset 13056 13311 #f (%make-iset 12688 13054 300613450595050653137261935414156179889591998741512647513967970216935158771592840931503642564904187380807827395 #f #f) #f)) (%make-iset 43639 43641 #f (%make-iset 42752 42890 522673715590561479879743397015208866086911 (%make-iset 42128 42182 #f #f #f) (%make-iset 43048 43065 245775 #f #f)) (%make-iset 64434 64449 #f (%make-iset 64297 64297 #f #f #f) #f))) (%make-iset 120513 120771 463168363851011130091785795673740600836767278013411671357985905734243019915265 (%make-iset 118784 119261 780437137578995458467560908739391556888996158179266522929460546508236933653296437157060350808521225678016835714111230592247297551268494937423871 (%make-iset 65504 65533 805339007 (%make-iset 65284 65374 1547425050547877224499904641 #f #f) (%make-iset 65847 66044 401734511064736150903948875408776876244564738538201663144447 #f #f)) (%make-iset 119552 119638 #f (%make-iset 119296 119365 664082786653543858175 #f #f) #f)) (%make-iset 127744 128252 1623601741516486367526542089626489179499454454837360135582644525057721907975405279813447049733043276512275822980244041212191896116171460908759068350349311 (%make-iset 126976 127386 5288447750321425141395456744287458546996189758388629186172721346534510152156602991240248150625623449590204448175840041107455 (%make-iset 126704 126705 #f #f #f) (%make-iset 127462 127569 244021541289521102071576548868095 #f #f)) (%make-iset 128507 128883 307828173409331868845930000782371979146838607456393061394578876014578854359990151589006733868359031372480153387007 (%make-iset 128256 128359 5104235524096485346957782767918670413823 #f #f) #f)))))))
+
+;; char-set:blank
+(define char-set:blank (immutable-char-set (%make-iset 6158 6158 #f (%make-iset 160 160 #f (%make-iset 9 32 8388609 #f #f) (%make-iset 5760 5760 #f #f #f)) (%make-iset 12288 12288 #f (%make-iset 8192 8287 39614081257132309534260332543 #f #f) #f))))
+
+;; char-set:whitespace
+(define char-set:whitespace (immutable-char-set (%make-iset 6158 6158 #f (%make-iset 160 160 #f (%make-iset 9 32 8388639 #f #f) (%make-iset 5760 5760 #f #f #f)) (%make-iset 12288 12288 #f (%make-iset 8192 8287 39614081257132312832795215871 #f #f) #f))))
+
+;; char-set:digit
+(define char-set:digit (immutable-char-set (%make-iset 6992 7097 81050410252092417358195461194751 (%make-iset 3430 3439 #f (%make-iset 1984 1993 #f (%make-iset 1632 1641 #f (%make-iset 48 57 #f #f #f) (%make-iset 1776 1785 #f #f #f)) (%make-iset 2918 3311 743556014954405849072266507808340190880121684743320383604969609548181369962480481034346862340233244904693236621235324859507752652901450751 (%make-iset 2406 2799 743556014954405849072266507808340190880121684743320383604969609548181369962480481034346862340233244904693236621235324859507752652901450751 #f #f) #f)) (%make-iset 6470 6479 #f (%make-iset 4160 4249 1236731113465765645724419071 (%make-iset 3664 3881 420844212009973745855555120560483693212126493377631139457593771007 #f #f) (%make-iset 6112 6169 287948901175002111 #f #f)) (%make-iset 6784 6809 67044351 (%make-iset 6608 6617 #f #f #f) #f))) (%make-iset 66720 66729 #f (%make-iset 43472 43609 6421475075300574421752121441301562791795741843089406187013119 (%make-iset 42528 42537 #f (%make-iset 7232 7257 67044351 #f #f) (%make-iset 43216 43273 287948901175002111 #f #f)) (%make-iset 65296 65305 #f (%make-iset 44016 44025 #f #f #f) #f)) (%make-iset 70096 70105 #f (%make-iset 69872 69951 1207745227993911763403775 (%make-iset 69734 69743 #f #f #f) #f) (%make-iset 120782 120831 #f (%make-iset 71360 71369 #f #f #f) #f))))))
+
+;; char-set:letter+digit
+(define char-set:letter+digit (immutable-char-set (%make-iset 44032 55203 #f (%make-iset 6912 7414 22886562555891042693710382458146756289377006471936556892838923982807328844367070294241793956553485968351753386046618718102707539530518625959993520685039 (%make-iset 3913 4346 44362715105927999221712262984621806339048726122702370012163096018033725502663463203116646689073826286574787756247207860776650932223 (%make-iset 1869 2380 13407424329480734270447878660048428920496373804417168083627602288254107168259292949124979141882146787383731347613928779568711247970208345158244457521348607 (%make-iset 880 1366 399583814438996167382020011346842847816169115710121343500162631807336209279770003226660543306154439487482399564906606488253101298916621286954252495 (%make-iset 452 740 963565667247331348724662781356953235953225866953231882562121816871620562685859362504703 (%make-iset 48 451 41235302740700321541067959277923095868202489379241662970514590796289444397514063176660331003916099649017014030525823583231 #f #f) #f) (%make-iset 1377 1855 1560874275157973934343822231147075518302721156252056432767839474782185051280962423908807488297855721715644480587704321413018649007858524599877631 #f #f)) (%make-iset 2908 3404 381991200485141231019756222408812876448756014237186533546277447507183436269917901262081454044646810274583365631168335787645676728618713947476107197691 (%make-iset 2382 2892 5366736463561891048904088864332422319078538891026511232750792789353571719231492410784884055633496549297705163924592108787908229198392583314950938978942851 #f #f) (%make-iset 3424 3911 796045881074145379721101485003658612742377112762910063541249941107066206101891013710754591976857025636790244447628442609572802972081506968078974927 #f #f))) (%make-iset 5121 5740 #f (%make-iset 4682 4822 2787528182814337039150675927861957382578127 (%make-iset 4349 4680 #f #f #f) (%make-iset 4824 5108 62165404551223330269422779455378792455782943721961461362086716517957521327837304324095 #f #f)) (%make-iset 6212 6683 12194330229244424385524038642855360947889231407969113621412693927197786728086255496979946034430370000318048005765115268416095504239842568437759 (%make-iset 5743 6210 762145642145155178562790324783619807494011846352632466837216562044788852063159421730556579887606746611010843054583947091606179550442951671807 #f #f) (%make-iset 6688 6809 5311800736730066244218093126239125503 #f #f)))) (%make-iset 19968 40908 #f (%make-iset 9398 9449 #f (%make-iset 7680 8188 1669429210027032353070387959902572074068251569912541634239543664469254840701605815586298160569854604812755249439701457169906905863833481177213265564925951 (%make-iset 7424 7615 6277101735386680763834460195211881500229451637403754168319 #f #f) (%make-iset 8336 8584 904625697166121400702423284964750605108746128179460890055734500600385118207 #f #f)) (%make-iset 12321 12799 1560850458106678397246853318509506420346053090363696722427379182288726125506853871807416126725592575693831523564009034418563951096328109074350591 (%make-iset 11264 11775 1716199415031085457304815023196129625190876140284840059163076939411632061379695825768761320243048559913035261692194332965927453391792248614786550156348096511 #f #f) (%make-iset 13312 19893 #f #f #f))) (%make-iset 42656 43137 9366007796590143684266426014173832021882860391206691228341429856634888413055477646498624449482500722743196759142345085250473767233032902320062463 (%make-iset 40982 42124 #f (%make-iset 40960 40980 #f #f #f) (%make-iset 42192 42647 186070703019498633361408888448075519920530856307050957164988653405500459175263525083868751559444797946410782900983767246458201399646748671 #f #f)) (%make-iset 43648 43822 47701954761756259097387504798417463778755529815359487 (%make-iset 43138 43638 224726016208531273348937437899872290007502680726266932355584409924411794087837267452460956059789185107995855861761463319664142696520594339463520992995707994505215 #f #f) (%make-iset 43968 44025 287956460317442047 #f #f))))) (%make-iset 71296 71369 348108861360120048141903260542929609949183 (%make-iset 65536 65908 354901720847464262643270080013918741494457029505007323037992842993478140487429303646626346434630199938330987804055257434518162763775 (%make-iset 64256 64433 383123885216472214589586756787576615644966064332734591 (%make-iset 63744 64109 #f (%make-iset 55216 55291 75557863725914197590015 #f #f) (%make-iset 64112 64217 #f #f #f)) (%make-iset 64848 64967 341611594916723379280938182270919901183 (%make-iset 64467 64829 #f #f #f) (%make-iset 65008 65500 23166459242184795109519745412560813317707843523172326996035291982829335841807197632365519235915051181023523126849199870616098935821672668804369354751 #f #f))) (%make-iset 67840 68220 4925250765375315437575115447282545225619899143486530057386523691675827454339457238250572167562730571287653355880447 (%make-iset 66640 66729 1237033344920669303018094591 (%make-iset 66176 66639 878680692688788100968217104054132723536510135400456683066998889497980605885632024127229627367624962058724496859707859793938161524087860595782141042536975695871 #f #f) (%make-iset 67584 67669 77371243358065019892792383 #f #f)) (%make-iset 68608 68680 #f (%make-iset 68352 68466 1427247352465131255837309846865400673685471231 #f #f) (%make-iset 69635 70105 204586912993508730593563550625432944389072422914203271855910203047007904292292283148049105766861891958292943578471947333866751571791177989246645436415 #f #f)))) (%make-iset 120146 120485 #f (%make-iset 92160 92728 #f (%make-iset 74752 74850 #f (%make-iset 73728 74606 #f #f #f) (%make-iset 77824 78894 #f #f #f)) (%make-iset 110592 110593 #f (%make-iset 93952 94111 1461323231539455856679019361440445717580125044735 #f #f) (%make-iset 119808 120144 1221462192088229133428742507380976417683660481320862010013722843488511299179635651402650638514783282651558855669972991 #f #f))) (%make-iset 131072 173782 #f (%make-iset 120656 120831 95780971304117989802914516033683783778383003373273087 (%make-iset 120488 120654 187072206790762423064706648907459429699768891211775 #f #f) (%make-iset 126464 126651 6421867392636242726356536395708148792154285362342779204665327 #f #f)) (%make-iset 177984 178205 #f (%make-iset 173824 177972 #f #f #f) (%make-iset 194560 195101 #f #f #f))))))))
+
+;; char-set:hex-digit
+(define char-set:hex-digit (immutable-char-set (%make-iset 48 102 35465847073801215 #f #f)))
+
+;; char-set:iso-control
+(define char-set:iso-control (immutable-char-set (%make-iset 0 159 1461501637160761734743215600984595715944343404543 #f #f)))
+
+;; char-set:graphic
+(define char-set:graphic (immutable-char-set (%make-iset 4960 4968 #f (%make-iset 64848 64967 341611594916723379280938182270919901183 (%make-iset 8336 8584 904625697166121400702423284964750605108746128179460890055734500600385118207 (%make-iset 4349 4680 #f (%make-iset 1869 2380 13407424329480734270447878660048428920496373804417168083627602288254107168259292949124979141882146787383731347613928779568711247970208345158244457521348607 (%make-iset 880 1366 399583814438996167382020011346842847816169115710121343500162631837690410720797019959777135600271922403770006425096286507812670201087000743294040271 (%make-iset 452 1014 15095849699286165408966218323953077744206039126039399880352876178469244380253667520073008553405383346474973778635124736918461513833545106799961749425123263291782871384063 (%make-iset 33 451 1351198400207268136257714889618984005409259171978990812217822137540885437287020053544046511735433817788139780300462983613513727 #f #f) #f) (%make-iset 1377 1855 1560874275157973934343822231147075518302721156252056432767839474782185051280962423908807488297855721715644480587704321413018649007858524599877631 #f #f)) (%make-iset 3424 3911 796045881074145379721101485003658612742377112762910063541249941107066206101891013710754591976857025636790244447628442609572802972081506968078974927 (%make-iset 2908 3404 381991200485141231019756222408812876448756014237186533546277447507183436269917901262081454044646810274583365631168335787645676728618713947476107197691 (%make-iset 2382 2892 5366736463561891048904088864332422319078538891026511232750792789353571719231492410784884055633496549297705163924592108787908229198392583314950938978942851 #f #f) #f) (%make-iset 3913 4346 44362715105927999221712262984621806339048726122702370012163096018033725502663463203116646689073826286574787756247207860776650932223 #f #f))) (%make-iset 6212 6683 12194330229244424385524038642855360947889231407969113621412693927197786728086255496979946034430370000318048005765115268416095504239842568437759 (%make-iset 5121 5740 #f (%make-iset 4824 5108 62165404551223330269422779455378792455782943721961461362086716517957521327837304324095 (%make-iset 4682 4822 2787528182814337039150675927861957382578127 #f #f) #f) (%make-iset 5743 6210 762145642145155178562790324783619807494011846352632466837216562044788852063159421730556579887606746611010843054583947091606179550442951671807 #f #f)) (%make-iset 7424 7615 6277101735386680763834460195211881500229451637403754168319 (%make-iset 6912 7414 22886562555891042693710382458146756289377006471936556892838923982807328844367070294241793956553485968351753386046618718102707539530518625959993520685039 (%make-iset 6688 6809 5311800736730066244218093126239125503 #f #f) #f) (%make-iset 7680 8188 1669429210027032353070387959902572074068251569912541634239543664469254840701605815586298160569854604812755249439701457169906905863833481177213265564925951 #f #f)))) (%make-iset 43138 43638 224726016208531273348937437899872290007502680726266932355584409924411794087837267452460956059789185107995855861761463319664142696520594339463520992995707994505215 (%make-iset 19968 40908 #f (%make-iset 12321 12799 1560850458106678397246853318509506420346053090363696722427379182288726125506853871807416126725592575693831523564009034418563951096328109074350591 (%make-iset 11264 11775 1716199415031085457304815023196129625190876140284840059163076939411632061379695825768761320243048559913035261692194332965927453391792248614786550156348096511 (%make-iset 9398 9449 #f #f #f) #f) (%make-iset 13312 19893 #f #f #f)) (%make-iset 42192 42647 186070703019498633361408888448075519920530856307050957164988653405500459175263525083868751559444797946410782900983767246458201399646748671 (%make-iset 40982 42124 #f (%make-iset 40960 40980 #f #f #f) #f) (%make-iset 42656 43137 9366007796590143684266426014173832021882860391206691228341429856634888413055477646498624449482500722743196759142345085250473767233032902320062463 #f #f))) (%make-iset 63744 64109 #f (%make-iset 44032 55203 #f (%make-iset 43968 44025 287956460317442047 (%make-iset 43648 43822 47701954761756259097387504798417463778755529815359487 #f #f) #f) (%make-iset 55216 55291 75557863725914197590015 #f #f)) (%make-iset 64256 64433 383123885216472214589586756787576615644966064332734591 (%make-iset 64112 64217 #f #f #f) (%make-iset 64467 64829 #f #f #f))))) (%make-iset 120488 120654 187072206790762423064706648907459429699768891211775 (%make-iset 71296 71369 348108861360120048141903260542929609949183 (%make-iset 67584 67669 77371243358065019892792383 (%make-iset 66176 66639 878680692688788100968217104054132723536510135400456683066998889497980605885632024127229627367624962058724496859707859793938161524087860595782141042536975695871 (%make-iset 65536 65908 354901720847464262643270080013918741494457029505007323037992842993478140487429303646626346434630199938330987804055257434518162763775 (%make-iset 65008 65500 23166459242184795109519745412560813317707843523172326996035291982829335841807197632365519235915051181023523126849199870616098935821672668804369354751 #f #f) #f) (%make-iset 66640 66729 1237033344920669303018094591 #f #f)) (%make-iset 68608 68680 #f (%make-iset 68352 68466 1427247352465131255837309846865400673685471231 (%make-iset 67840 68220 4925250765375315437575115447282545225619899143486530057386523691675827454339457238250572167562730571287653355880447 #f #f) #f) (%make-iset 69635 70105 204586912993508730593563550625432944389072422914203271855910203047007904292292283148049105766861891958292943578471947333866751571791177989246645436415 #f #f))) (%make-iset 93952 94111 1461323231539455856679019361440445717580125044735 (%make-iset 77824 78894 #f (%make-iset 74752 74850 #f (%make-iset 73728 74606 #f #f #f) #f) (%make-iset 92160 92728 #f #f #f)) (%make-iset 119808 120144 1221462192088229133428742507380976417683660481320862010013722843488511299179635651402650638514783282651558855669972991 (%make-iset 110592 110593 #f #f #f) (%make-iset 120146 120485 #f #f #f)))) (%make-iset 2404 2416 4099 (%make-iset 177984 178205 #f (%make-iset 131072 173782 #f (%make-iset 126464 126651 6421867392636242726356536395708148792154285362342779204665327 (%make-iset 120656 120831 95780971304117989802914516033683783778383003373273087 #f #f) #f) (%make-iset 173824 177972 #f #f #f)) (%make-iset 2038 2038 #f (%make-iset 1370 1805 177444091211903494854164183597562195186987239759942234703242934973005962356878807556430406995673757716803475823941853280674043134015 (%make-iset 194560 195101 #f #f #f) #f) (%make-iset 2039 2142 10141204806548057579655195000839 #f #f))) (%make-iset 3449 3449 #f (%make-iset 3059 3066 #f (%make-iset 2800 2928 340282366920938463463374607431768211459 (%make-iset 2546 2555 771 #f #f) #f) (%make-iset 3199 3199 #f #f #f)) (%make-iset 3844 4175 8612299728833109452216727519275634166367255279803428156814546022481552546661143084834195942383124479 (%make-iset 3572 3675 15214283120596255441467398422529 #f #f) (%make-iset 4347 4347 #f #f #f)))))) (%make-iset 6622 6655 #f (%make-iset 44011 44011 #f (%make-iset 9001 9002 #f (%make-iset 6686 6687 #f (%make-iset 6100 6154 36011204832919671 (%make-iset 5741 5942 4820814132776970826626481771165599449877669887122490332807171 (%make-iset 5120 5120 #f #f #f) #f) (%make-iset 6468 6469 #f #f #f)) (%make-iset 7164 7379 52681756409358971006475467946070306489686807156907791211684691983 (%make-iset 7002 7008 #f (%make-iset 6816 6829 16255 #f #f) #f) (%make-iset 8208 8334 127607834706674478748244504138880122879 #f #f))) (%make-iset 12289 12539 1809251394333065553493296641491499378872794969502476229475819322195851214727 (%make-iset 11513 11632 664613997892457936451903530140172399 (%make-iset 10627 10749 7975367975289779630837864365545226239 (%make-iset 10088 10223 87027215340059722591700904977272299077631 #f #f) #f) (%make-iset 11776 11835 1152780767118491647 #f #f)) (%make-iset 43124 43615 11987514433213410168505333362405758614102799522152940711615041872404225459959956214682136066587259816913167135759024198010248565942507088814987542543 (%make-iset 42509 42743 54351252480975689826048702415431575448442147475312362296571857733681159 (%make-iset 42238 42239 #f #f #f) #f) (%make-iset 43742 43761 786435 #f #f)))) (%make-iset 69703 69955 13569385457497991651199724805705614201565294768222350139146883642703225028735 (%make-iset 66463 66512 562949953421313 (%make-iset 65281 65381 2521683860030948918624327334903 (%make-iset 65040 65131 4037812089938908849547248639 (%make-iset 64830 64831 #f #f #f) #f) (%make-iset 65792 65794 #f #f #f)) (%make-iset 68176 68223 140737488355839 (%make-iset 67871 67903 4294967297 (%make-iset 67671 67671 #f #f #f) #f) (%make-iset 68409 68415 #f #f #f))) (%make-iset 4254 4255 #f (%make-iset 3841 3896 47287798208921607 (%make-iset 74864 74867 #f (%make-iset 70085 70088 #f #f #f) #f) (%make-iset 4030 4056 126058239 #f #f)) (%make-iset 6107 6107 #f (%make-iset 5008 5017 #f #f #f) (%make-iset 6464 6464 #f #f #f))))) (%make-iset 42752 42890 522673715590561479879743397015208866086911 (%make-iset 10750 11084 #f (%make-iset 9472 9983 #f (%make-iset 8592 9000 #f (%make-iset 8125 8527 15180504508302547082559792549452134039979727921597050291198905168453617261872958515620728168035045459212134851764818477085 (%make-iset 7009 7036 267912191 #f #f) #f) (%make-iset 9003 9449 363419362147803445274660701490199886974208000930090554402992578672453439413725018135787913021374683400778402767997805117095404640403455 #f #f)) (%make-iset 10649 10711 #f (%make-iset 10224 10626 #f (%make-iset 9985 10213 862718293047519590130783627714548701007576706064464912086123449155583 #f #f) #f) (%make-iset 10716 10749 4294967295 #f #f))) (%make-iset 12688 13054 300613450595050653137261935414156179889591998741512647513967970216935158771592840931503642564904187380807827395 (%make-iset 11904 12351 547258453716185545689710299454841531346882567525409776024515836385994490529377606833512566938465691840048809561654146263061905633443839 (%make-iset 11493 11498 #f (%make-iset 11088 11097 #f #f #f) #f) (%make-iset 12443 12444 #f #f #f)) (%make-iset 19904 19967 #f (%make-iset 13056 13311 #f #f #f) (%make-iset 42128 42182 #f #f #f)))) (%make-iset 119296 119365 664082786653543858175 (%make-iset 65020 65129 796084576943328064139929612976131 (%make-iset 64297 64297 #f (%make-iset 43639 43641 #f (%make-iset 43048 43065 245775 #f #f) #f) (%make-iset 64434 64449 #f #f #f)) (%make-iset 65847 66044 401734511064736150903948875408776876244564738538201663144447 (%make-iset 65504 65533 805339007 (%make-iset 65284 65374 1547425050547877224499904641 #f #f) #f) (%make-iset 118784 119261 780437137578995458467560908739391556888996158179266522929460546508236933653296437157060350808521225678016835714111230592247297551268494937423871 #f #f))) (%make-iset 127462 127569 244021541289521102071576548868095 (%make-iset 126704 126705 #f (%make-iset 120513 120771 463168363851011130091785795673740600836767278013411671357985905734243019915265 (%make-iset 119552 119638 #f #f #f) #f) (%make-iset 126976 127386 5288447750321425141395456744287458546996189758388629186172721346534510152156602991240248150625623449590204448175840041107455 #f #f)) (%make-iset 128256 128359 5104235524096485346957782767918670413823 (%make-iset 127744 128252 1623601741516486367526542089626489179499454454837360135582644525057721907975405279813447049733043276512275822980244041212191896116171460908759068350349311 #f #f) (%make-iset 128507 128883 307828173409331868845930000782371979146838607456393061394578876014578854359990151589006733868359031372480153387007 #f #f)))))))))
+
+;; char-set:printing
+(define char-set:printing (immutable-char-set (%make-iset 4347 4347 #f (%make-iset 63744 64109 #f (%make-iset 6688 6809 5311800736730066244218093126239125503 (%make-iset 4349 4680 #f (%make-iset 1869 2380 13407424329480734270447878660048428920496373804417168083627602288254107168259292949124979141882146787383731347613928779568711247970208345158244457521348607 (%make-iset 452 1366 276978483139049986878383159513059937866295390192563056831002732490712977617729827250930061495547874753339425272845057761345036295330752004396560217460615349388256052740008771052267223259379816261947173385923045218076729795326919802994234467957919553429350144124989345512816639 (%make-iset 160 160 #f (%make-iset 9 451 22669347419131782291913114369553852359296309528272676318593841051105143812618789434640033841431908014736263332293412376088380325232671 #f #f) #f) (%make-iset 1377 1855 1560874275157973934343822231147075518302721156252056432767839474782185051280962423908807488297855721715644480587704321413018649007858524599877631 #f #f)) (%make-iset 3424 3911 796045881074145379721101485003658612742377112762910063541249941107066206101891013710754591976857025636790244447628442609572802972081506968078974927 (%make-iset 2908 3404 381991200485141231019756222408812876448756014237186533546277447507183436269917901262081454044646810274583365631168335787645676728618713947476107197691 (%make-iset 2382 2892 5366736463561891048904088864332422319078538891026511232750792789353571719231492410784884055633496549297705163924592108787908229198392583314950938978942851 #f #f) #f) (%make-iset 3913 4346 44362715105927999221712262984621806339048726122702370012163096018033725502663463203116646689073826286574787756247207860776650932223 #f #f))) (%make-iset 6158 6158 #f (%make-iset 5121 5740 #f (%make-iset 4824 5108 62165404551223330269422779455378792455782943721961461362086716517957521327837304324095 (%make-iset 4682 4822 2787528182814337039150675927861957382578127 #f #f) #f) (%make-iset 5760 5760 #f #f #f)) (%make-iset 5743 6210 762145642145155178562790324783619807494011846352632466837216562044788852063159421730556579887606746611010843054583947091606179550442951671807 (%make-iset 12288 12288 #f (%make-iset 8192 8287 39614081257132312832795215871 #f #f) #f) (%make-iset 6212 6683 12194330229244424385524038642855360947889231407969113621412693927197786728086255496979946034430370000318048005765115268416095504239842568437759 #f #f)))) (%make-iset 40960 40980 #f (%make-iset 9398 9449 #f (%make-iset 7680 8188 1669429210027032353070387959902572074068251569912541634239543664469254840701605815586298160569854604812755249439701457169906905863833481177213265564925951 (%make-iset 7424 7615 6277101735386680763834460195211881500229451637403754168319 (%make-iset 6912 7414 22886562555891042693710382458146756289377006471936556892838923982807328844367070294241793956553485968351753386046618718102707539530518625959993520685039 #f #f) #f) (%make-iset 8336 8584 904625697166121400702423284964750605108746128179460890055734500600385118207 #f #f)) (%make-iset 13312 19893 #f (%make-iset 12321 12799 1560850458106678397246853318509506420346053090363696722427379182288726125506853871807416126725592575693831523564009034418563951096328109074350591 (%make-iset 11264 11775 1716199415031085457304815023196129625190876140284840059163076939411632061379695825768761320243048559913035261692194332965927453391792248614786550156348096511 #f #f) #f) (%make-iset 19968 40908 #f #f #f))) (%make-iset 43648 43822 47701954761756259097387504798417463778755529815359487 (%make-iset 42656 43137 9366007796590143684266426014173832021882860391206691228341429856634888413055477646498624449482500722743196759142345085250473767233032902320062463 (%make-iset 42192 42647 186070703019498633361408888448075519920530856307050957164988653405500459175263525083868751559444797946410782900983767246458201399646748671 (%make-iset 40982 42124 #f #f #f) #f) (%make-iset 43138 43638 224726016208531273348937437899872290007502680726266932355584409924411794087837267452460956059789185107995855861761463319664142696520594339463520992995707994505215 #f #f)) (%make-iset 44032 55203 #f (%make-iset 43968 44025 287956460317442047 #f #f) (%make-iset 55216 55291 75557863725914197590015 #f #f))))) (%make-iset 110592 110593 #f (%make-iset 67840 68220 4925250765375315437575115447282545225619899143486530057386523691675827454339457238250572167562730571287653355880447 (%make-iset 65008 65500 23166459242184795109519745412560813317707843523172326996035291982829335841807197632365519235915051181023523126849199870616098935821672668804369354751 (%make-iset 64467 64829 #f (%make-iset 64256 64433 383123885216472214589586756787576615644966064332734591 (%make-iset 64112 64217 #f #f #f) #f) (%make-iset 64848 64967 341611594916723379280938182270919901183 #f #f)) (%make-iset 66640 66729 1237033344920669303018094591 (%make-iset 66176 66639 878680692688788100968217104054132723536510135400456683066998889497980605885632024127229627367624962058724496859707859793938161524087860595782141042536975695871 (%make-iset 65536 65908 354901720847464262643270080013918741494457029505007323037992842993478140487429303646626346434630199938330987804055257434518162763775 #f #f) #f) (%make-iset 67584 67669 77371243358065019892792383 #f #f))) (%make-iset 73728 74606 #f (%make-iset 69635 70105 204586912993508730593563550625432944389072422914203271855910203047007904292292283148049105766861891958292943578471947333866751571791177989246645436415 (%make-iset 68608 68680 #f (%make-iset 68352 68466 1427247352465131255837309846865400673685471231 #f #f) #f) (%make-iset 71296 71369 348108861360120048141903260542929609949183 #f #f)) (%make-iset 92160 92728 #f (%make-iset 77824 78894 #f (%make-iset 74752 74850 #f #f #f) #f) (%make-iset 93952 94111 1461323231539455856679019361440445717580125044735 #f #f)))) (%make-iset 1370 1805 177444091211903494854164183597562195186987239759942234703242934973005962356878807556430406995673757716803475823941853280674043134015 (%make-iset 126464 126651 6421867392636242726356536395708148792154285362342779204665327 (%make-iset 120488 120654 187072206790762423064706648907459429699768891211775 (%make-iset 120146 120485 #f (%make-iset 119808 120144 1221462192088229133428742507380976417683660481320862010013722843488511299179635651402650638514783282651558855669972991 #f #f) #f) (%make-iset 120656 120831 95780971304117989802914516033683783778383003373273087 #f #f)) (%make-iset 177984 178205 #f (%make-iset 173824 177972 #f (%make-iset 131072 173782 #f #f #f) #f) (%make-iset 194560 195101 #f #f #f))) (%make-iset 3059 3066 #f (%make-iset 2546 2555 771 (%make-iset 2404 2416 4099 (%make-iset 2038 2142 20282409613096115159310390001679 #f #f) #f) (%make-iset 2800 2928 340282366920938463463374607431768211459 #f #f)) (%make-iset 3449 3675 161786008477555489129424138914539858559159520266627551066615690821633 (%make-iset 3199 3199 #f #f #f) (%make-iset 3844 4175 8612299728833109452216727519275634166367255279803428156814546022481552546661143084834195942383124479 #f #f)))))) (%make-iset 6464 6464 #f (%make-iset 43742 43761 786435 (%make-iset 8208 8334 127607834706674478748244504138880122879 (%make-iset 6468 6469 #f (%make-iset 5741 5942 4820814132776970826626481771165599449877669887122490332807171 (%make-iset 5120 5120 #f (%make-iset 4960 4968 #f #f #f) #f) (%make-iset 6100 6154 36011204832919671 #f #f)) (%make-iset 7002 7008 #f (%make-iset 6816 6829 16255 (%make-iset 6686 6687 #f #f #f) #f) (%make-iset 7164 7379 52681756409358971006475467946070306489686807156907791211684691983 #f #f))) (%make-iset 11776 11835 1152780767118491647 (%make-iset 10627 10749 7975367975289779630837864365545226239 (%make-iset 10088 10223 87027215340059722591700904977272299077631 (%make-iset 9001 9002 #f #f #f) #f) (%make-iset 11513 11632 664613997892457936451903530140172399 #f #f)) (%make-iset 42509 42743 54351252480975689826048702415431575448442147475312362296571857733681159 (%make-iset 42238 42239 #f (%make-iset 12289 12539 1809251394333065553493296641491499378872794969502476229475819322195851214727 #f #f) #f) (%make-iset 43124 43615 11987514433213410168505333362405758614102799522152940711615041872404225459959956214682136066587259816913167135759024198010248565942507088814987542543 #f #f)))) (%make-iset 68409 68415 #f (%make-iset 65792 65794 #f (%make-iset 65040 65131 4037812089938908849547248639 (%make-iset 64830 64831 #f (%make-iset 44011 44011 #f #f #f) #f) (%make-iset 65281 65381 2521683860030948918624327334903 #f #f)) (%make-iset 67871 67903 4294967297 (%make-iset 67671 67671 #f (%make-iset 66463 66512 562949953421313 #f #f) #f) (%make-iset 68176 68223 140737488355839 #f #f))) (%make-iset 4030 4056 126058239 (%make-iset 74864 74867 #f (%make-iset 70085 70088 #f (%make-iset 69703 69955 13569385457497991651199724805705614201565294768222350139146883642703225028735 #f #f) #f) (%make-iset 3841 3896 47287798208921607 #f #f)) (%make-iset 5008 5017 #f (%make-iset 4254 4255 #f #f #f) (%make-iset 6107 6107 #f #f #f))))) (%make-iset 42752 42890 522673715590561479879743397015208866086911 (%make-iset 10716 10749 4294967295 (%make-iset 9003 9449 363419362147803445274660701490199886974208000930090554402992578672453439413725018135787913021374683400778402767997805117095404640403455 (%make-iset 8125 8527 15180504508302547082559792549452134039979727921597050291198905168453617261872958515620728168035045459212134851764818477085 (%make-iset 7009 7036 267912191 (%make-iset 6622 6655 #f #f #f) #f) (%make-iset 8592 9000 #f #f #f)) (%make-iset 10224 10626 #f (%make-iset 9985 10213 862718293047519590130783627714548701007576706064464912086123449155583 (%make-iset 9472 9983 #f #f #f) #f) (%make-iset 10649 10711 #f #f #f))) (%make-iset 12443 12444 #f (%make-iset 11493 11498 #f (%make-iset 11088 11097 #f (%make-iset 10750 11084 #f #f #f) #f) (%make-iset 11904 12351 547258453716185545689710299454841531346882567525409776024515836385994490529377606833512566938465691840048809561654146263061905633443839 #f #f)) (%make-iset 19904 19967 #f (%make-iset 13056 13311 #f (%make-iset 12688 13054 300613450595050653137261935414156179889591998741512647513967970216935158771592840931503642564904187380807827395 #f #f) #f) (%make-iset 42128 42182 #f #f #f)))) (%make-iset 119296 119365 664082786653543858175 (%make-iset 65020 65129 796084576943328064139929612976131 (%make-iset 64297 64297 #f (%make-iset 43639 43641 #f (%make-iset 43048 43065 245775 #f #f) #f) (%make-iset 64434 64449 #f #f #f)) (%make-iset 65847 66044 401734511064736150903948875408776876244564738538201663144447 (%make-iset 65504 65533 805339007 (%make-iset 65284 65374 1547425050547877224499904641 #f #f) #f) (%make-iset 118784 119261 780437137578995458467560908739391556888996158179266522929460546508236933653296437157060350808521225678016835714111230592247297551268494937423871 #f #f))) (%make-iset 127462 127569 244021541289521102071576548868095 (%make-iset 126704 126705 #f (%make-iset 120513 120771 463168363851011130091785795673740600836767278013411671357985905734243019915265 (%make-iset 119552 119638 #f #f #f) #f) (%make-iset 126976 127386 5288447750321425141395456744287458546996189758388629186172721346534510152156602991240248150625623449590204448175840041107455 #f #f)) (%make-iset 128256 128359 5104235524096485346957782767918670413823 (%make-iset 127744 128252 1623601741516486367526542089626489179499454454837360135582644525057721907975405279813447049733043276512275822980244041212191896116171460908759068350349311 #f #f) (%make-iset 128507 128883 307828173409331868845930000782371979146838607456393061394578876014578854359990151589006733868359031372480153387007 #f #f)))))))))
+
diff --git a/lib/chibi/char-set/full.sld b/lib/chibi/char-set/full.sld
new file mode 100644
index 00000000..99aa740d
--- /dev/null
+++ b/lib/chibi/char-set/full.sld
@@ -0,0 +1,9 @@
+
+(define-library (chibi char-set full)
+  (import (chibi) (chibi iset base) (chibi char-set base))
+  (export char-set:lower-case  char-set:upper-case  char-set:title-case
+          char-set:letter      char-set:digit       char-set:letter+digit
+          char-set:graphic     char-set:printing    char-set:whitespace
+          char-set:iso-control char-set:punctuation char-set:symbol
+          char-set:hex-digit   char-set:blank)
+  (include "full.scm"))
diff --git a/lib/chibi/config.scm b/lib/chibi/config.scm
new file mode 100644
index 00000000..bc0c5d74
--- /dev/null
+++ b/lib/chibi/config.scm
@@ -0,0 +1,501 @@
+;; config.scm -- general configuration management
+;; Copyright (c) 2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> This is a library for unified configuration management.
+;;> Essentially it provides an abstract collection data type for
+;;> looking up named values, two or more of which can be chained
+;;> together.  Values from more recent collections can be preferred as
+;;> with an environment, or the values at multiple levels can be
+;;> flattened together.  Convenience routines are provided from
+;;> loading these collections from files while allowing extensions
+;;> such as configurations from command-line options.
+
+;;> \section{Background}
+;;>
+;;> As any application grows to sufficient complexity, it acquires
+;;> options and behaviors that one may want to modify at startup or
+;;> runtime.  The traditional approach is a combination of
+;;> command-line options, config files, environment variables, and/or
+;;> other specialized settings.  These all have various pros and cons:
+;;>
+;;> \table[(@ (border 1) (style border-collapse:collapse) (width "100%"))]{
+;;> \tr{\th{name} \th{pros} \th{cons}}
+;;> \tr{\td{environment variables}
+;;>     \td{implicit - no need to retype; can share between applications}
+;;>     \td{unclear when set; unexpected differences between users; limited size}}
+;;> \tr{\td{command-line options}
+;;>     \td{explicit - visible each time a command is run; }
+;;>     \td{verbose; limited size}}
+;;> \tr{\td{config files}
+;;>     \td{implicit; preserved - can be shared and version controlled}
+;;>     \td{requires a parser}}
+;;> }
+;;>
+;;> Environment variables are convenient for broad preferences, used
+;;> by many different applications, and unlikely to change per user.
+;;> Command-line options are best for settings that are likely to
+;;> change between invocations of a program.  Anything else is best
+;;> stored in a config file.  If there are settings that multiple
+;;> users of a group or whole system are likely to want to share, then
+;;> it makes sense to cascade multiple config files.
+
+;;> \section{Syntax}
+;;>
+;;> With any other language there is a question of config file syntax,
+;;> and a few popular choices exist such as .ini syntax.  With Scheme
+;;> the obvious choice is sexps, generally as an alist.  We use a
+;;> single alist for the whole file, with symbols for keys and
+;;> arbitrary sexps for values.  The alists are intended primarily for
+;;> editing by hand and need not be dotted, but the interface allows
+;;> dotted values.  Disambiguation is handled as with two separate
+;;> functions, \scheme{(conf-get config key)} and
+;;> \scheme{(conf-get-list config key)}, which both retrieve the value
+;;> associated with \var{key} from \var{config}, in the latter case
+;;> coercing to a list.  The result is determined according to the
+;;> structure of the alist cell as follows:
+;;>
+;;> \table[(@ (border 1) (style border-collapse:collapse) (width "100%"))]{
+;;> \tr{\th{Cell} \th{\scheme{conf-get} result} \th{\scheme{conf-get-list} result}}
+;;> \tr{\td{\scheme{(key)}} \td{\scheme{()}} \td{\scheme{()}}}
+;;> \tr{\td{\scheme{(key . non-list-value)}} \td{\scheme{non-list-value}} \td{\scheme{(non-list-value)}}}
+;;> \tr{\td{\scheme{(key non-list-value)}} \td{\scheme{non-list-value}} \td{\scheme{(non-list-value)}}}
+;;> \tr{\td{\scheme{(key (value1 value2 ...))}} \td{\scheme{(value1 value2 ...)}} \td{\scheme{(value1 value2 ...)}}}
+;;> \tr{\td{\scheme{(key value1 value2 ...)}} \td{\scheme{(value1 value2 ...)}} \td{\scheme{(value1 value2 ...)}}}
+;;> }
+;;>
+;;> Thus writing the non-dotted value will always do what you want.
+;;> Specifically, the only thing to be careful of is if you want a
+;;> single-element list value, even with \scheme{conf-get}, you should
+;;> write \scheme{(key (value))}.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> \section{Interface}
+
+;;> Returns true iff \var{x} is a config object.
+
+(define-record-type Config
+  (make-conf alist parent source timestamp)
+  conf?
+  (alist conf-alist conf-alist-set!)
+  (parent conf-parent conf-parent-set!)
+  (source conf-source conf-source-set!)
+  (timestamp conf-timestamp conf-timestamp-set!))
+
+(define (assq-tail key alist)
+  (let lp ((ls alist))
+    (and (pair? ls)
+         (if (and (pair? (car ls)) (eq? key (caar ls)))
+             ls
+             (lp (cdr ls))))))
+
+(define (assq-chain key alist)
+  (let ((x (assq-tail (car key) alist)))
+    (and x
+         (if (null? (cdr key))
+             (car x)
+             (or (assq-chain (cdr key) (cdar x))
+                 (assq-chain key (cdr x)))))))
+
+(define (assq-split key alist)
+  (let lp ((ls alist) (rev '()))
+    (cond
+     ((null? ls) #f)
+     ((and (pair? (car ls)) (eq? key (caar ls))) (cons (reverse rev) ls))
+     (else (lp (cdr ls) (cons (car ls) rev))))))
+
+(define (read-from-file file . opt)
+  (guard (exn (else (and (pair? opt) (car opt))))
+    (call-with-input-file file read)))
+
+(define (alist? x)
+  (and (list? x) (every pair? x)))
+
+;;> \procedure{(assoc-get alist key [equal? [default]])}
+
+;;> Utility analogous to \scheme{conf-get} on a pure alist.  Returns
+;;> the value of the cell in \var{alist} whose car is \var{equal?} to
+;;> \var{key}, where the value is determined as the \var{cadr} if the
+;;> cell is a proper list of two elements and the \var{cdr} otherwise.
+;;> If no cell is found, returns \var{default}, or \scheme{#f} if
+;;> unspecified.
+
+(define (assoc-get alist key . o)
+  (let ((equal (or (and (pair? o) (car o)) equal?)))
+    (let lp ((ls alist))
+      (cond
+       ((not (pair? ls)) (and (pair? o) (pair? (cdr o)) (cadr o)))
+       ((and (pair? (car ls)) (equal key (caar ls)))
+        (if (and (pair? (cdar ls)) (null? (cdr (cdar ls))))
+            (car (cdar ls))
+            (cdar ls)))
+       (else (lp (cdr ls)))))))
+
+;;> \procedure{(assoc-get-list alist key [default])}
+
+;;> Equivalent to \scheme{assoc-get} but coerces its result to a list
+;;> as described in the syntax section.
+
+(define (assoc-get-list alist key . o)
+  (let ((res (assoc-get alist key)))
+    (if res
+        (if (or (pair? res) (null? res)) res (list res))
+        (if (pair? o) (car o) '()))))
+
+;;> Returns just the base of \var{config} without any parent.
+
+(define (conf-head config)
+  (make-conf
+   (conf-alist config) #f (conf-source config) (conf-timestamp config)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Loading from files.
+
+;;> \procedure{(conf-load file [conf])}
+
+;;> Loads the config file \var{file}, prepending to \var{conf} if
+;;> provided.
+
+(define (conf-load file . o)
+  (make-conf
+   (read-from-file file '())
+   (and (pair? o) (car o))
+   file
+   (current-second)))
+
+;;> Search for and load any files named \var{file} in the
+;;> \var{config-path}, which should be a list of strings.
+
+(define (conf-load-in-path config-path file)
+  (cond
+   ((equal? file "")
+    (error "can't load from empty filename" file))
+   ((eqv? #\/ (string-ref file 0))
+    (conf-load file))
+   (else
+    (let lp ((ls (reverse config-path)) (res #f))
+      (if (null? ls)
+          (or res (make-conf '() #f #f (current-second)))
+          (let ((path (string-append (car ls) "/" file)))
+            (if (file-exists? path)
+                (lp (cdr ls) (conf-load path res))
+                (lp (cdr ls) res))))))))
+
+;;> \procedure{(conf-load-cascaded config-path file [include-keyword])}
+
+;;> Similar to conf-load-in-path, but also recursively loads any
+;;> "include" config files, indicated by a top-level
+;;> \var{include-keyword} with either a string or symbol value.
+;;> Includes are loaded relative to the current file, and cycles
+;;> automatically ignored.
+
+(define (conf-load-cascaded config-path file . o)
+  (define (path-directory file)
+    (let lp ((i (string-length file)))
+      (cond ((zero? i) "./")
+            ((eqv? #\/ (string-ref file (- i 1))) (substring file 0 i))
+            (else (lp (- i 1))))))
+  (define (path-relative file from)
+    (if (eqv? #\/ (string-ref file 0))
+        file
+        (string-append (path-directory from) file)))
+  (let ((include-keyword (if (pair? o) (car o) 'include)))
+    (let load ((ls (list (cons file (and (pair? o) (pair? (cdr o)) (cadr o)))))
+               (seen '())
+               (res '()))
+      (cond
+       ((null? ls)
+        res)
+       (else
+        (let ((file (if (symbol? (caar ls))
+                        (symbol->string (caar ls))
+                        (caar ls)))
+              (depth (cdar ls)))
+          (cond
+           ((member file seen)
+            (load (cdr ls) seen res))
+           ((and (number? depth) (<= depth 0))
+            (load (cdr ls) seen res))
+           (else
+            (let* ((config (conf-load-in-path config-path file))
+                   (includes (conf-get-list config include-keyword)))
+              (load (append (cdr ls)
+                            (map (lambda (x)
+                                   (cons (path-relative x file)
+                                         (and (number? depth) (- depth 1))))
+                                 includes))
+                    (cons file seen)
+                    (append res config)))))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (conf-get-cell config key)
+  (cond
+   ((pair? key)
+    (cond
+     ((null? (cdr key)) (conf-get-cell config (car key)))
+     ((assq-chain key (conf-alist config)))
+     ((conf-parent config) => (lambda (p) (conf-get-cell p key)))
+     (else #f)))
+   (else
+    (let search ((config config))
+      (and config
+           (or (assq key (conf-alist config))
+               (search (conf-parent config))))))))
+
+;;> \procedure{(conf-get config key [default])}
+
+;;> Basic config lookup - retrieves the value from \var{config}
+;;> associated with \var{key}.  If not present, return \var{default}.
+;;> In \scheme{conf-get} and related accessors \var{key} can be either
+;;> a symbol, or a list of symbols.  In the latter case, each symbol
+;;> is used as a key in turn, with the value taken as an alist to
+;;> further lookup values in.
+
+(define (conf-get config key . opt)
+  (let ((cell (conf-get-cell config key)))
+    (if (not cell)
+        (and (pair? opt) (car opt))
+        (if (and (pair? (cdr cell)) (null? (cddr cell)))
+            (cadr cell)
+            (cdr cell)))))
+
+;;> \procedure{(conf-get-list config key [default])}
+
+;;> Equivalent to \scheme{conf-get} but coerces its result to a list
+;;> as described in the syntax section.
+
+(define (conf-get-list config key . opt)
+  (let ((res (conf-get config key)))
+    (if res
+        (if (or (pair? res) (null? res)) res (list res))
+        (if (pair? opt) (car opt) '()))))
+
+;;> Equivalent to \scheme{conf-get} but always returns the
+;;> \scheme{cdr} as-is without possibly taking its \scheme{car}.
+
+(define (conf-get-cdr config key . opt)
+  (let ((cell (conf-get-cell config key)))
+    (if (not cell)
+        (and (pair? opt) (car opt))
+        (cdr cell))))
+
+;;> Equivalent to \scheme{conf-get-list} but returns a list of all
+;;> cascaded configs appended together.
+
+(define (conf-get-multi config key)
+  (if (not config)
+      '()
+      (append (conf-get-list (conf-head config))
+              (conf-get-multi (conf-parent config) key))))
+
+;;> Extends the config with anadditional alist.
+
+(define (conf-extend config alist . o)
+  (let ((source (and (pair? o) (car o))))
+    (if (pair? alist)
+        (make-conf alist config source (current-second))
+        config)))
+
+;;> Joins two configs.
+
+(define (conf-append a b)
+  (let ((parent (if (conf-parent a) (conf-append (conf-parent a) b) b)))
+    (make-conf (conf-alist a) parent (conf-source a) (conf-timestamp a))))
+
+;;> Utility to create an alist cell representing the chained key
+;;> \var{key} mapped to \var{value}.
+
+(define (conf-unfold-key key value)
+  (if (null? (cdr key))
+      (cons (car key) value)
+      (list (car key) (conf-unfold-key (cdr key) value))))
+
+;;> Replace a new definition into the first config alist.
+
+(define (conf-set config key value)
+  (make-conf
+   (let lp ((key (if (not (list? key)) (list key) key))
+            (alist (conf-alist config)))
+     (cond
+      ((null? (cdr key))
+       (cons (cons (car key) value)
+             (remove (lambda (x) (and (pair? x) (eq? (car key) (car x))))
+                     alist)))
+      ((assq-split (car key) alist)
+       => (lambda (x)
+            (let ((left (car x))
+                  (right (cdr x)))
+              (append left
+                      (cons (cons (car key) (lp (cdr key) (cdar right)))
+                            (cdr right))))))
+      (else
+       (cons (conf-unfold-key key value) alist))))
+   (conf-parent config)
+   (conf-source config)
+   (conf-timestamp config)))
+
+;;> Lift specialized sections to the top-level of a config.
+
+(define (conf-specialize config key name)
+  (let lp ((cfg config) (res '()))
+    (if (not cfg)
+        (make-conf (reverse res) config #f (current-second))
+        (let* ((specialized (assq key (conf-alist cfg)))
+               (named (and specialized (assq name (cdr specialized))))
+               (next (conf-parent cfg)))
+          (if named
+              (lp next (cons (cdr named) res))
+              (lp next res))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> \section{Config Verification}
+
+(define (conf-default-warn . args)
+  (for-each
+   (lambda (a) ((if (string? a) display write) a (current-error-port)))
+   args)
+  (newline (current-error-port))
+  #f)
+
+(define (conf-verify-symbol->predicate sym)
+  (case sym
+    ((integer) integer?)
+    ((number) number?)
+    ((list) list?)
+    ((alist) alist?)
+    ((boolean) boolean?)
+    ((char) char?)
+    ((string) string?)
+    ((symbol) symbol?)
+    ((pair) pair?)
+    ((filename dirname) string?)
+    (else (error "no known conf predicate for" sym))))
+
+;; non-short-circuit versions to report all warnings
+
+(define (and* . args)
+  (every (lambda (x) x) args))
+
+(define (every* pred ls)
+  (apply and* (map pred ls)))
+
+(define (conf-verify-match def cell warn)
+  (define (cell-value)
+    (if (and (pair? (cdr cell)) (null? (cddr cell))) (cadr cell) (cdr cell)))
+  (define (cell-list)
+    (if (and (pair? (cdr cell)) (null? (cddr cell)) (not (pair? (cadr cell))))
+        (list (cadr cell))
+        (cdr cell)))
+  (cond
+   ((procedure? def)
+    (or (def (cell-value))
+        (warn "bad conf value for " (car cell) ": " (cell-value))))
+   ((symbol? def)
+    (case def
+      ((existing-filename)
+       (cond
+        ((not (string? (cell-value)))
+         (warn "bad conf value for " (car cell)
+               ": expected a filename but got " (cell-value)))
+        ((not (file-exists? (cell-value)))
+         (warn "conf setting ~S references a non-existent file: ~S"
+               (car cell) (cell-value)))
+        (else
+         #t)))
+      ((existing-dirname)
+       (cond
+        ((not (string? (cell-value)))
+         (warn "bad conf value for " (car cell)
+               ": expected a dirname but got " (cell-value)))
+        ((not (file-directory? (cell-value)))
+         (cond
+          ((file-exists? (cell-value))
+           (warn "conf setting " (car cell)
+                 " expected a directory but found a file: " (cell-value)))
+          (else
+           (warn "conf setting " (car cell)
+                 " references a non-existent directory: " (cell-value)))))
+        (else
+         #t)))
+      ((integer number char string symbol filename dirname boolean pair)
+       (or ((conf-verify-symbol->predicate def) (cell-value))
+           (warn "bad conf value for " (car cell)
+                 ": expected " def " but got " (cell-value))))
+      ((list alist)
+       (or ((conf-verify-symbol->predicate def) (cell-list))
+           (warn "bad conf value for " (car cell)
+                 ": expected " def " but got " (cell-list))))
+      (else
+       (warn "bad conf spec list: " def))))
+   ((pair? def)
+    (case (car def)
+      ((cons)
+       (and*
+        (conf-verify-match
+         (cadr def) (cons `(car ,(car cell)) (car (cell-list))) warn)
+        (conf-verify-match
+         (car (cddr def)) (cons `(car ,(car cell)) (cdr (cell-list))) warn)))
+      ((list)
+       (and (list? (cell-list))
+            (every* (lambda (x)
+                      ;; (cons `(list ,(car cell)) x)
+                      (conf-verify-match (cadr def) x warn))
+                    (cell-list))))
+      ((alist)
+       (let ((key-def (cadr def))
+             (val-def (if (pair? (cddr def)) (car (cddr def)) (lambda (x) #t))))
+         (and (alist? (cell-list))
+              (every* (lambda (x)
+                        (and (pair? x)
+                             (conf-verify-match key-def (car x) warn)
+                             (conf-verify-match val-def (cell-value x) warn)))
+                      (cell-list)))))
+      ((conf)
+       (and (alist? (cell-list))
+            (conf-verify (cdr def) (list (cell-list)) warn)))
+      ((or)
+       (or (any (lambda (x) (conf-verify-match x cell (lambda (x) x)))
+                (cdr def))
+           (warn "bad spec value for " (car cell)
+                 ": expected " def " but got " (cell-value))))
+      ((member)
+       (or (member (cell-value) (cdr def))
+           (warn "bad spec value " (cell-value)
+                 " for " (car cell) ", expected one of " (cdr def))))
+      ((quote)
+       (or (equal? (cadr def) (cell-value))
+           (warn "bad conf value for " (car cell)
+                 ": expected '" (cadr def) " but got " (cell-value))))
+      (else
+       (warn "bad conf list spec name: " (car def)))))
+   (else
+    (or (equal? def (cell-value))
+        (warn "bad conf value for " (car cell)
+              ": expected " def " but got " (cell-value))))))
+
+(define (conf-verify-one spec cell warn)
+  (cond
+   ((not (pair? cell))
+    (warn "bad config entry: " cell))
+   ((not (symbol? (car cell)))
+    (warn "non-symbol config entry name: " (car cell)))
+   (else
+    (let ((def (assq (car cell) spec)))
+      (cond
+       ((not def)
+        (warn "unknown config entry: " (car cell)))
+       ((null? (cdr def)))
+       (else (conf-verify-match (cadr def) cell warn)))))))
+
+(define (conf-verify spec config . o)
+  (let ((warn (if (pair? o) (car o) conf-default-warn)))
+    (let lp ((config config))
+      (cond
+       (config
+        (for-each
+         (lambda (cell) (conf-verify-one spec cell warn))
+         (conf-alist config))
+        (lp (conf-parent config)))))))
diff --git a/lib/chibi/config.sld b/lib/chibi/config.sld
new file mode 100644
index 00000000..810f300c
--- /dev/null
+++ b/lib/chibi/config.sld
@@ -0,0 +1,15 @@
+
+(define-library (chibi config)
+  (export make-conf conf? conf-load conf-load-in-path conf-load-cascaded
+          conf-verify conf-extend conf-append conf-set conf-unfold-key
+          conf-get conf-get-list conf-get-cdr conf-get-multi
+          conf-specialize read-from-file conf-source conf-head conf-parent
+          assoc-get assoc-get-list)
+  (import (scheme base) (scheme read) (scheme write) (scheme file)
+          (scheme time) (srfi 1))
+  ;; This is only used for config verification, it's acceptable to
+  ;; substitute file existence for the stronger directory check.
+  (cond-expand
+   (chibi (import (only (chibi filesystem) file-directory?)))
+   (else (begin (define file-directory? file-exists?))))
+  (include "config.scm"))
diff --git a/lib/chibi/crypto/md5.scm b/lib/chibi/crypto/md5.scm
new file mode 100644
index 00000000..36e969b8
--- /dev/null
+++ b/lib/chibi/crypto/md5.scm
@@ -0,0 +1,362 @@
+;; md5.scm -- pure R7RS md5 implementation (originally from hato)
+;; Copyright (c) 2009-2014 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;; Break computations down into 16-bit words to keep everything in
+;; fixnum even on 32-bit machines.
+
+;; All values are in little-endian.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Utilities.
+
+(define (extract-byte n i)
+  (bitwise-and #xFF (arithmetic-shift n (* i -8))))
+
+;; integer->hex-string is big-endian, so we adjust here
+(define (hex-byte n)
+  (if (< n 16)
+      (string-append "0" (number->string n 16))
+      (number->string n 16)))
+
+(define (hex n)
+  (string-append (hex-byte (remainder n 256))
+                 (hex-byte (quotient n 256))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; 3. MD5 Algorithm Description
+
+;; We begin by supposing that we have a b-bit message as input, and that
+;; we wish to find its message digest. Here b is an arbitrary
+;; nonnegative integer; b may be zero, it need not be a multiple of
+;; eight, and it may be arbitrarily large. We imagine the bits of the
+;; message written down as follows:
+
+;;           m_0 m_1 ... m_{b-1}
+
+;; The following five steps are performed to compute the message digest
+;; of the message.
+
+;; 3.1 Step 1. Append Padding Bits
+
+;; The message is "padded" (extended) so that its length (in bits) is
+;; congruent to 448, modulo 512. That is, the message is extended so
+;; that it is just 64 bits shy of being a multiple of 512 bits long.
+;; Padding is always performed, even if the length of the message is
+;; already congruent to 448, modulo 512.
+
+;; Padding is performed as follows: a single "1" bit is appended to the
+;; message, and then "0" bits are appended so that the length in bits of
+;; the padded message becomes congruent to 448, modulo 512. In all, at
+;; least one bit and at most 512 bits are appended.
+
+;; 3.2 Step 2. Append Length
+
+;; A 64-bit representation of b (the length of the message before the
+;; padding bits were added) is appended to the result of the previous
+;; step. In the unlikely event that b is greater than 2^64, then only
+;; the low-order 64 bits of b are used. (These bits are appended as two
+;; 32-bit words and appended low-order word first in accordance with the
+;; previous conventions.)
+
+;; At this point the resulting message (after padding with bits and with
+;; b) has a length that is an exact multiple of 512 bits. Equivalently,
+;; this message has a length that is an exact multiple of 16 (32-bit)
+;; words. Let M[0 ... N-1] denote the words of the resulting message,
+;; where N is a multiple of 16.
+
+;; 3.3 Step 3. Initialize MD Buffer
+
+;; A four-word buffer (A,B,C,D) is used to compute the message digest.
+;; Here each of A, B, C, D is a 32-bit register. These registers are
+;; initialized to the following values in hexadecimal, low-order bytes
+;; first):
+
+;;           word A: 01 23 45 67
+;;           word B: 89 ab cd ef
+;;           word C: fe dc ba 98
+;;           word D: 76 54 32 10
+
+;; 3.4 Step 4. Process Message in 16-Word Blocks
+
+;; We first define four auxiliary functions that each take as input
+;; three 32-bit words and produce as output one 32-bit word.
+
+;;           F(X,Y,Z) = XY v not(X) Z
+;;           G(X,Y,Z) = XZ v Y not(Z)
+;;           H(X,Y,Z) = X xor Y xor Z
+;;           I(X,Y,Z) = Y xor (X v not(Z))
+
+;; In each bit position F acts as a conditional: if X then Y else Z.
+;; The function F could have been defined using + instead of v since XY
+;; and not(X)Z will never have 1's in the same bit position.) It is
+;; interesting to note that if the bits of X, Y, and Z are independent
+;; and unbiased, the each bit of F(X,Y,Z) will be independent and
+;; unbiased.
+
+;; The functions G, H, and I are similar to the function F, in that they
+;; act in "bitwise parallel" to produce their output from the bits of X,
+;; Y, and Z, in such a manner that if the corresponding bits of X, Y,
+;; and Z are independent and unbiased, then each bit of G(X,Y,Z),
+;; H(X,Y,Z), and I(X,Y,Z) will be independent and unbiased. Note that
+;; the function H is the bit-wise "xor" or "parity" function of its
+;; inputs.
+
+;; This step uses a 64-element table T[1 ... 64] constructed from the
+;; sine function. Let T[i] denote the i-th element of the table, which
+;; is equal to the integer part of 4294967296 times abs(sin(i)), where i
+;; is in radians. The elements of the table are given in the appendix.
+
+;; (define T
+;;   (do ((i 64 (- i 1))
+;;        (ls '()
+;;            (cons (u32 (exact (truncate (* 4294967296 (abs (sin i))))))
+;;                  ls)))
+;;       ((< i 0) (list->vector ls))))
+
+(define T
+  '#(0     0       #xd76a #xa478 #xe8c7 #xb756 #x2420 #x70db #xc1bd #xceee
+     #xf57c #x0faf #x4787 #xc62a #xa830 #x4613 #xfd46 #x9501 #x6980 #x98d8
+     #x8b44 #xf7af #xffff #x5bb1 #x895c #xd7be #x6b90 #x1122 #xfd98 #x7193
+     #xa679 #x438e #x49b4 #x0821 #xf61e #x2562 #xc040 #xb340 #x265e #x5a51
+     #xe9b6 #xc7aa #xd62f #x105d #x0244 #x1453 #xd8a1 #xe681 #xe7d3 #xfbc8
+     #x21e1 #xcde6 #xc337 #x07d6 #xf4d5 #x0d87 #x455a #x14ed #xa9e3 #xe905
+     #xfcef #xa3f8 #x676f #x02d9 #x8d2a #x4c8a #xfffa #x3942 #x8771 #xf681
+     #x6d9d #x6122 #xfde5 #x380c #xa4be #xea44 #x4bde #xcfa9 #xf6bb #x4b60
+     #xbebf #xbc70 #x289b #x7ec6 #xeaa1 #x27fa #xd4ef #x3085 #x0488 #x1d05
+     #xd9d4 #xd039 #xe6db #x99e5 #x1fa2 #x7cf8 #xc4ac #x5665 #xf429 #x2244
+     #x432a #xff97 #xab94 #x23a7 #xfc93 #xa039 #x655b #x59c3 #x8f0c #xcc92
+     #xffef #xf47d #x8584 #x5dd1 #x6fa8 #x7e4f #xfe2c #xe6e0 #xa301 #x4314
+     #x4e08 #x11a1 #xf753 #x7e82 #xbd3a #xf235 #x2ad7 #xd2bb #xeb86 #xd391))
+
+(define (md5 src)
+  (let ((in (cond ((string? src) (open-input-bytevector (string->utf8 src)))
+                  ((bytevector? src) (open-input-bytevector src))
+                  ((input-port? src) src)
+                  (else (error "unknown digest source: " src))))
+        ;; 3.3 Step 3. Initialize MD Buffer
+        (buf (make-bytevector 64 0))
+        (vec (make-vector 32))
+        (A1 #x6745) (A0 #x2301)
+        (B1 #xefcd) (B0 #xab89)
+        (C1 #x98ba) (C0 #xdcfe)
+        (D1 #x1032) (D0 #x5476))
+    ;; Process each 16-word block.
+    (let lp ((i 0)
+             (pad #x80))
+      (let* ((n (read-bytevector! buf in))
+             (n (if (eof-object? n) 0 n)))
+        (cond
+         ((< n 64)
+          (let ((len (* 8 (+ i n))))
+            ;; 3.1 Step 1. Append Padding Bits
+            (bytevector-u8-set! buf n pad)
+            (do ((j (+ n 1) (+ j 1))) ((>= j 64))
+              (bytevector-u8-set! buf j 0))
+            ;; 3.2 Step 2. Append Length
+            (cond
+             ((< n 56)
+              (bytevector-u8-set! buf 56 (extract-byte len 0))
+              (bytevector-u8-set! buf 57 (extract-byte len 1))
+              (bytevector-u8-set! buf 58 (extract-byte len 2))
+              (bytevector-u8-set! buf 59 (extract-byte len 3))
+              (bytevector-u8-set! buf 60 (extract-byte len 4))
+              (bytevector-u8-set! buf 61 (extract-byte len 5))
+              (bytevector-u8-set! buf 62 (extract-byte len 6))
+              (bytevector-u8-set! buf 63 (extract-byte len 7)))))))
+        ;; 3.4 Step 4. Process Message in 16-Word Blocks
+        ;;
+        ;; Copy block i into X.
+        (do ((j 0 (+ j 1)))
+            ((= j 16))
+          (vector-set! vec (* j 2) (bytevector-u16-ref-le buf (* j 4)))
+          (vector-set! vec
+                       (+ (* j 2) 1)
+                       (bytevector-u16-ref-le buf (+ (* j 4) 2))))
+        ;; Save A as AA, B as BB, C as CC, and D as DD.
+        (let ((AA0 A0) (AA1 A1)
+              (BB0 B0) (BB1 B1)
+              (CC0 C0) (CC1 C1)
+              (DD0 D0) (DD1 D1)
+              (T1 0)   (T0 0))
+          (letrec-syntax
+              ((add
+                (syntax-rules ()
+                  ((add d1 d0 a1 a0 b1 b0)
+                   (begin
+                     (set! d0 (+ a0 b0))
+                     (set! d1 (bitwise-and
+                               (+ a1 b1 (arithmetic-shift d0 -16))
+                               #xFFFF))
+                     (set! d0 (bitwise-and d0 #xFFFF))))))
+               (rot
+                (syntax-rules ()
+                  ((rot d1 d0 a1 a0 s)
+                   (let ((tmp a1))
+                     (set! d1 (bitwise-and
+                               (bitwise-ior (arithmetic-shift a1 s)
+                                            (arithmetic-shift a1 (- s 32))
+                                            (arithmetic-shift a0 (- s 16)))
+                               #xFFFF))
+                     (set! d0 (bitwise-and
+                               (bitwise-ior (arithmetic-shift a0 s)
+                                            (arithmetic-shift a0 (- s 32))
+                                            (arithmetic-shift tmp (- s 16)))
+                               #xFFFF))))))
+               (bit-not
+                (syntax-rules ()
+                  ((bit-not a) (- (expt 2 16) a 1))))
+               (FF
+                (syntax-rules ()
+                  ((FF d1 d0 x1 x0 y1 y0 z1 z0)
+                   (begin
+                     (set! d1 (bitwise-ior (bitwise-and x1 y1)
+                                           (bitwise-and (bit-not x1) z1)))
+                     (set! d0 (bitwise-ior (bitwise-and x0 y0)
+                                           (bitwise-and (bit-not x0) z0)))
+                     ))))
+               (GG
+                (syntax-rules ()
+                  ((GG d1 d0 x1 x0 y1 y0 z1 z0)
+                   (begin
+                     (set! d1 (bitwise-ior (bitwise-and x1 z1)
+                                           (bitwise-and y1 (bit-not z1))))
+                     (set! d0 (bitwise-ior (bitwise-and x0 z0)
+                                           (bitwise-and y0 (bit-not z0))))
+                     ))))
+               (HH
+                (syntax-rules ()
+                  ((HH d1 d0 x1 x0 y1 y0 z1 z0)
+                   (begin (set! d1 (bitwise-xor x1 y1 z1))
+                          (set! d0 (bitwise-xor x0 y0 z0))))))
+               (II
+                (syntax-rules ()
+                  ((II d1 d0 x1 x0 y1 y0 z1 z0)
+                   (begin
+                     (set! d1 (bitwise-xor y1 (bitwise-ior x1 (bit-not z1))))
+                     (set! d0 (bitwise-xor y0 (bitwise-ior x0 (bit-not z0))))
+                     ))))
+               (R
+                (syntax-rules ()
+                  ((R op T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i)
+                   (begin
+                     (op T1 T0 b1 b0 c1 c0 d1 d0)
+                     (add T1 T0 T1 T0
+                          (vector-ref vec (+ (* k 2) 1))
+                          (vector-ref vec (* k 2)))
+                     (add T1 T0 T1 T0
+                          (vector-ref T (* i 2))
+                          (vector-ref T (+ (* i 2) 1)))
+                     (add a1 a0 a1 a0 T1 T0)
+                     (rot a1 a0 a1 a0 s)
+                     (add a1 a0 a1 a0 b1 b0)))))
+               (R1 (syntax-rules ()
+                     ((R1 T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i)
+                      (R FF T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i))))
+               (R2 (syntax-rules ()
+                     ((R2 T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i)
+                      (R GG T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i))))
+               (R3 (syntax-rules ()
+                     ((R3 T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i)
+                      (R HH T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i))))
+               (R4 (syntax-rules ()
+                     ((R4 T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i)
+                      (R II T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i)))))
+            ;; Round 1: Let [abcd k s i] denote the operation
+            ;;   a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
+            (R1 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 0 7 1)
+            (R1 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 1 12 2)
+            (R1 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 2 17 3)
+            (R1 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 3 22 4)
+            (R1 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 4 7 5)
+            (R1 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 5 12 6)
+            (R1 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 6 17 7)
+            (R1 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 7 22 8)
+            (R1 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 8 7 9)
+            (R1 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 9 12 10)
+            (R1 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 10 17 11)
+            (R1 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 11 22 12)
+            (R1 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 12 7 13)
+            (R1 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 13 12 14)
+            (R1 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 14 17 15)
+            (R1 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 15 22 16)
+            ;; Round 2: Let [abcd k s i] denote the operation
+            ;;   a = b + ((a + G(b,c,d) + X[k] + T[i]) <<< s)
+            (R2 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 1 5 17)
+            (R2 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 6 9 18)
+            (R2 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 11 14 19)
+            (R2 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 0 20 20)
+            (R2 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 5 5 21)
+            (R2 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 10 9 22)
+            (R2 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 15 14 23)
+            (R2 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 4 20 24)
+            (R2 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 9 5 25)
+            (R2 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 14 9 26)
+            (R2 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 3 14 27)
+            (R2 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 8 20 28)
+            (R2 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 13 5 29)
+            (R2 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 2 9 30)
+            (R2 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 7 14 31)
+            (R2 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 12 20 32)
+            ;; Round 3: Let [abcd k s i] denote the operation
+            ;;   a = b + ((a + H(b,c,d) + X[k] + T[i]) <<< s)
+            (R3 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 5 4 33)
+            (R3 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 8 11 34)
+            (R3 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 11 16 35)
+            (R3 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 14 23 36)
+            (R3 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 1 4 37)
+            (R3 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 4 11 38)
+            (R3 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 7 16 39)
+            (R3 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 10 23 40)
+            (R3 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 13 4 41)
+            (R3 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 0 11 42)
+            (R3 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 3 16 43)
+            (R3 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 6 23 44)
+            (R3 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 9 4 45)
+            (R3 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 12 11 46)
+            (R3 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 15 16 47)
+            (R3 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 2 23 48)
+            ;; Round 4: Let [abcd k s i] denote the operation
+            ;;   a = b + ((a + I(b,c,d) + X[k] + T[i]) <<< s)
+            (R4 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 0 6 49)
+            (R4 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 7 10 50)
+            (R4 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 14 15 51)
+            (R4 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 5 21 52)
+            (R4 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 12 6 53)
+            (R4 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 3 10 54)
+            (R4 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 10 15 55)
+            (R4 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 1 21 56)
+            (R4 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 8 6 57)
+            (R4 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 15 10 58)
+            (R4 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 6 15 59)
+            (R4 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 13 21 60)
+            (R4 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 4 6 61)
+            (R4 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 11 10 62)
+            (R4 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 2 15 63)
+            (R4 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 9 21 64)
+            ;; Then in increment each of the four registers by the
+            ;; value it had before this block was started.
+            (add A1 A0 A1 A0 AA1 AA0)
+            (add B1 B0 B1 B0 BB1 BB0)
+            (add C1 C0 C1 C0 CC1 CC0)
+            (add D1 D0 D1 D0 DD1 DD0)
+            (cond
+             ((< n 64)
+              ;; 3.5 Step 5. Output
+              ;;
+              ;;    The message digest produced as output is A, B, C,
+              ;;    D. That is, we begin with the low-order byte of A,
+              ;;    and end with the high-order byte of D.
+              (if (>= n 56)
+                  (lp (+ i n) 0)
+                  (string-append
+                   (hex A0) (hex A1)
+                   (hex B0) (hex B1)
+                   (hex C0) (hex C1)
+                   (hex D0) (hex D1))))
+             (else
+              (lp (+ i 64) pad)))))))))
+
+;; This completes the description of MD5. A reference implementation in
+;; C is given in the appendix.
diff --git a/lib/chibi/crypto/md5.sld b/lib/chibi/crypto/md5.sld
new file mode 100644
index 00000000..08851ef3
--- /dev/null
+++ b/lib/chibi/crypto/md5.sld
@@ -0,0 +1,5 @@
+
+(define-library (chibi crypto md5)
+  (import (scheme base) (srfi 33) (chibi bytevector))
+  (export md5)
+  (include "md5.scm"))
diff --git a/lib/chibi/crypto/rsa.scm b/lib/chibi/crypto/rsa.scm
new file mode 100644
index 00000000..98527580
--- /dev/null
+++ b/lib/chibi/crypto/rsa.scm
@@ -0,0 +1,128 @@
+;; rsa.scm -- RSA public key cryptography library
+;; Copyright (c) 2014 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;; The RSA key type.  The public fields are always present, but the
+;; private key d may be #f.
+(define-record-type Rsa-Key
+  (make-rsa-key bits n e d)
+  rsa-key?
+  (bits rsa-key-bits)
+  (n rsa-key-n)         ; public modulus, the product of two primes
+  (e rsa-key-e)         ; public exponent, coptime to (totient n)
+  (d rsa-key-d))        ; private exponent, the inverse of e mod (totient n)
+
+(define (rsa-key-gen-from-primes bit-length p q . o)
+  (define (choose-exponent phi e)
+    (cond ((>= e phi) (error "couldn't find an exponent for " p q))
+          ((= 1 (gcd e phi)) e)
+          (else (choose-exponent phi (+ e 2)))))
+  (let* ((n (* p q))
+         (phi (* (- p 1) (- q 1)))
+         ;; Default to Fermat's number F4, or if too large the number
+         ;; 3, as suggested by RFC 1423.  Ensure it's coprime to phi.
+         (e (choose-exponent phi (cond ((pair? o) (car o))
+                                       ((< 65537 phi) 65537)
+                                       (else 3))))
+         (d (modular-inverse e phi)))
+    (make-rsa-key bit-length n e d)))
+
+(define (rsa-key-gen . o)
+  (let* ((bit-length (if (pair? o) (car o) 128))
+         (lo (max 3 (expt 2 (- bit-length 1))))
+         (hi (expt 2 bit-length))
+         (p (random-prime lo hi))
+         (q (random-prime-distinct-from lo hi p)))
+    (rsa-key-gen-from-primes bit-length p q)))
+
+;;> Returns a copy of the given key with the private key, if any,
+;;> removed.
+(define (rsa-pub-key priv-key)
+  (make-rsa-key (rsa-key-bits priv-key) (rsa-key-n priv-key)
+                (rsa-key-e priv-key) #f))
+
+;; From RFC-1423
+(define (pkcs1-pad bv)
+  (let ((pad (- 8 (modulo (bytevector-length bv) 8))))
+    (bytevector-append bv (make-bytevector pad pad))))
+
+(define (pkcs1-unpad bv)
+  (let* ((len (bytevector-length bv))
+         (pad (bytevector-u8-ref bv (- len 1))))
+    (if (not (<= 1 pad 8))
+        (error "not pkcs1 padded" bv)
+        (bytevector-copy bv 0 (- len pad)))))
+
+;; Actual encryption and decryption are trivially defined as modular
+;; exponentiation.
+
+(define (rsa-encrypt-integer pub-key msg)
+  (if (>= msg (rsa-key-n pub-key))
+      (error "message larger than modulus" msg (rsa-key-n pub-key)))
+  (modular-expt msg (rsa-key-e pub-key) (rsa-key-n pub-key)))
+
+(define (rsa-decrypt-integer priv-key cipher)
+  (if (>= cipher (rsa-key-n priv-key))
+      (error "cipher larger than modulus"))
+  (modular-expt cipher (rsa-key-d priv-key) (rsa-key-n priv-key)))
+
+;; Arbitrary messages are encrypted by converting encoded bytevectors
+;; to and from integers.
+;; TODO: user emsa-pss encoding
+
+(define (convert-plain f key msg)
+  (cond
+   ((bytevector? msg)
+    (integer->bytevector (f key (bytevector->integer (pkcs1-pad msg)))))
+   ((string? msg)
+    (convert-plain f key (string->utf8 msg)))
+   (else
+    (f key msg))))
+
+(define (convert-cipher f key cipher)
+  (cond
+   ((bytevector? cipher)
+    (pkcs1-unpad (integer->bytevector (f key (bytevector->integer cipher)))))
+   ((string? cipher)
+    (convert-cipher f key (string->utf8 cipher)))
+   (else
+    (f key cipher))))
+
+;; General API can handle integers, bytevectors, or strings which are
+;; converted to utf8 bytevectors.
+
+;;> Encrypts \var{msg} for the given public key \var{pub-key}.
+;;> \var{msg} may be an integer or bytevector, in which case the
+;;> result is of the same type, or a string, in which case the string
+;;> is first coerced to a utf8 encoded bytevector.
+(define (rsa-encrypt pub-key msg)
+  (if (not (rsa-key-e pub-key))
+      (error "can't encrypt without a public key" pub-key)
+      (convert-plain rsa-encrypt-integer pub-key msg)))
+
+;;> Decrypts \var{cipher} using the given private key \var{priv-key}.
+;;> \var{cipher} may be an integer or bytevector, in which case the
+;;> result is of the same type, or a string, in which case the string
+;;> is first coerced to a utf8 encoded bytevector.
+(define (rsa-decrypt priv-key cipher)
+  (if (not (rsa-key-d priv-key))
+      (error "can't decrypt without a private key" priv-key)
+      (convert-cipher rsa-decrypt-integer priv-key cipher)))
+
+;;> Signs \var{msg} using the given private key \var{priv-key}.
+(define (rsa-sign priv-key msg)
+  (if (not (rsa-key-d priv-key))
+      (error "can't sign without a private key" priv-key)
+      (convert-plain rsa-decrypt-integer priv-key msg)))
+
+;;> Returns the verified (decrypted) message for the signature \var{sig}.
+(define (rsa-verify pub-key sig)
+  (if (not (rsa-key-e pub-key))
+      (error "can't verify without a public key" pub-key)
+      (convert-cipher rsa-encrypt-integer pub-key sig)))
+
+;;> Returns true iff \var{sig} is a valid signature of \var{msg} for
+;;> the given public key \var{pub-key}.
+(define (rsa-verify? pub-key msg sig)
+  (equal? (if (string? msg) (string->utf8 msg) msg)
+          (rsa-verify pub-key sig)))
diff --git a/lib/chibi/crypto/rsa.sld b/lib/chibi/crypto/rsa.sld
new file mode 100644
index 00000000..484c6170
--- /dev/null
+++ b/lib/chibi/crypto/rsa.sld
@@ -0,0 +1,9 @@
+
+(define-library (chibi crypto rsa)
+  (import (scheme base) (srfi 27) (srfi 33)
+          (chibi bytevector) (chibi math prime))
+  (export make-rsa-key rsa-key-gen rsa-key-gen-from-primes rsa-pub-key
+          rsa-encrypt rsa-decrypt rsa-sign rsa-verify rsa-verify?
+          rsa-key? rsa-key-bits rsa-key-n rsa-key-e rsa-key-d
+          pkcs1-pad pkcs1-unpad)
+  (include "rsa.scm"))
diff --git a/lib/chibi/crypto/sha2.scm b/lib/chibi/crypto/sha2.scm
new file mode 100644
index 00000000..2378b0e6
--- /dev/null
+++ b/lib/chibi/crypto/sha2.scm
@@ -0,0 +1,182 @@
+;; sha2.scm -- SHA2 digest algorithms
+;; Copyright (c) 2014 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;; http://csrc.nist.gov/groups/STM/cavp/documents/shs/sha256-384-512.pdf
+;; http://tools.ietf.org/html/rfc6234
+
+;; Note 1: All variables are 32 bit unsigned integers and addition is
+;;   calculated modulo 32
+;; Note 2: For each round, there is one round constant k[i] and one entry
+;;   in the message schedule array w[i], 0 ≤ i ≤ 63
+;; Note 3: The compression function uses 8 working variables, a through h
+;; Note 4: Big-endian convention is used when expressing the constants in
+;;   this pseudocode, and when parsing message block data from bytes to
+;;   words, for example, the first word of the input message "abc" after
+;;   padding is #x61626380
+
+;; On a 32-bit machine, these will involve bignum computations
+;; resulting in poor performance.  Breaking this down into separate
+;; 16-bit computations may help.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Utilities.
+
+;; We fake 32-bit arithmetic by ANDing out the low 32 bits.
+(define (u32 n)
+  (bitwise-and n #xFFFFFFFF))
+
+;; 32-bit addition.
+(define (u32+ a b)
+  (u32 (+ a b)))
+
+;; Extract bytes 0..3 of a big-endian 32-bit value.
+(define (extract-byte n i)
+  (bitwise-and #xFF (arithmetic-shift n (* i -8))))
+
+;; Rotate right in 32 bits.
+(define (bitwise-rot-u32 n k)
+  (bitwise-ior
+   (u32 (arithmetic-shift n (- 32 k)))
+   (arithmetic-shift n (- k))))
+
+(define hex integer->hex-string)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; The first 32 bits of the fractional parts of the square roots of
+;; the first 8 primes 2..19:
+
+(define sha-224-inits
+  '#(#xc1059ed8 #x367cd507 #x3070dd17 #xf70e5939
+     #xffc00b31 #x68581511 #x64f98fa7 #xbefa4fa4))
+
+;; The second 32 bits of the fractional parts of the square roots of
+;; the 9th through 16th primes 23..53.
+
+(define sha-256-inits
+  '#(#x6a09e667 #xbb67ae85 #x3c6ef372 #xa54ff53a
+     #x510e527f #x9b05688c #x1f83d9ab #x5be0cd19))
+
+;; First 32 bits of the fractional parts of the cube roots of the
+;; first 64 primes 2..311:
+
+(define k
+  '#(#x428a2f98 #x71374491 #xb5c0fbcf #xe9b5dba5
+     #x3956c25b #x59f111f1 #x923f82a4 #xab1c5ed5
+     #xd807aa98 #x12835b01 #x243185be #x550c7dc3
+     #x72be5d74 #x80deb1fe #x9bdc06a7 #xc19bf174
+     #xe49b69c1 #xefbe4786 #x0fc19dc6 #x240ca1cc
+     #x2de92c6f #x4a7484aa #x5cb0a9dc #x76f988da
+     #x983e5152 #xa831c66d #xb00327c8 #xbf597fc7
+     #xc6e00bf3 #xd5a79147 #x06ca6351 #x14292967
+     #x27b70a85 #x2e1b2138 #x4d2c6dfc #x53380d13
+     #x650a7354 #x766a0abb #x81c2c92e #x92722c85
+     #xa2bfe8a1 #xa81a664b #xc24b8b70 #xc76c51a3
+     #xd192e819 #xd6990624 #xf40e3585 #x106aa070
+     #x19a4c116 #x1e376c08 #x2748774c #x34b0bcb5
+     #x391c0cb3 #x4ed8aa4a #x5b9cca4f #x682e6ff3
+     #x748f82ee #x78a5636f #x84c87814 #x8cc70208
+     #x90befffa #xa4506ceb #xbef9a3f7  #xc67178f2))
+
+(define (sha-224-256 src inits full?)
+  (let ((in (cond ((string? src) (open-input-bytevector (string->utf8 src)))
+                  ((bytevector? src) (open-input-bytevector src))
+                  ((input-port? src) src)
+                  (else (error "unknown digest source: " src))))
+        (buf (make-bytevector 64 0))
+        (w (make-vector 64 0)))
+    (let chunk ((i 0)
+                (pad #x80)
+                (h0 (vector-ref inits 0))
+                (h1 (vector-ref inits 1))
+                (h2 (vector-ref inits 2))
+                (h3 (vector-ref inits 3))
+                (h4 (vector-ref inits 4))
+                (h5 (vector-ref inits 5))
+                (h6 (vector-ref inits 6))
+                (h7 (vector-ref inits 7)))
+      (let* ((n (read-bytevector! buf in))
+             (n (if (eof-object? n) 0 n)))
+        ;; Maybe pad.
+        (cond
+         ((< n 64)
+          (let ((len (* 8 (+ i n))))
+            (bytevector-u8-set! buf n pad)
+            (do ((j (+ n 1) (+ j 1))) ((>= j 64))
+              (bytevector-u8-set! buf j 0))
+            (cond
+             ((< n 56)
+              (bytevector-u8-set! buf 63 (extract-byte len 0))
+              (bytevector-u8-set! buf 62 (extract-byte len 1))
+              (bytevector-u8-set! buf 61 (extract-byte len 2))
+              (bytevector-u8-set! buf 60 (extract-byte len 3))
+              (bytevector-u8-set! buf 59 (extract-byte len 4))
+              (bytevector-u8-set! buf 58 (extract-byte len 5))
+              (bytevector-u8-set! buf 57 (extract-byte len 6))
+              (bytevector-u8-set! buf 56 (extract-byte len 7)))))))
+        ;; Copy block i into the buffer.
+        (do ((j 0 (+ j 1)))
+            ((= j 16))
+          (vector-set! w j (bytevector-u32-ref-be buf (* j 4))))
+        ;; Extend the first 16 words into the remaining 48 words
+        ;; w[16..63] of the message schedule array:
+        (do ((j 16 (+ j 1)))
+            ((= j 64))
+          (let* ((w15 (vector-ref w (- j 15)))
+                 (w2 (vector-ref w (- j 2)))
+                 (s0 (bitwise-xor (bitwise-rot-u32 w15 7)
+                                  (bitwise-rot-u32 w15 18)
+                                  (arithmetic-shift w15 -3)))
+                 (s1 (bitwise-xor (bitwise-rot-u32 w2 17)
+                                  (bitwise-rot-u32 w2 19)
+                                  (arithmetic-shift w2 -10))))
+            (vector-set! w j (u32 (+ (vector-ref w (- j 16))
+                                     s0
+                                     (vector-ref w (- j 7))
+                                     s1)))))
+        ;; Compression function main loop:
+        (let lp ((j 0)
+                 (a h0) (b h1)
+                 (c h2) (d h3)
+                 (e h4) (f h5)
+                 (g h6) (h h7))
+          (cond
+           ((= j 64)
+            (let ((a (u32+ h0 a)) (b (u32+ h1 b))
+                  (c (u32+ h2 c)) (d (u32+ h3 d))
+                  (e (u32+ h4 e)) (f (u32+ h5 f))
+                  (g (u32+ h6 g)) (h (u32+ h7 h)))
+              (cond
+               ((< n 64)
+                (if (>= n 56)
+                    (chunk (+ i n) 0 a b c d e f g h)
+                    (string-append
+                     (hex a) (hex b) (hex c) (hex d)
+                     (hex e) (hex f) (hex g) (if full? (hex h) ""))))
+               (else
+                (chunk (+ i 64) pad a b c d e f g h)))))
+           (else
+            ;; Step - compute the two sigmas and recurse on the new a-h.
+            (let* ((s1 (bitwise-xor (bitwise-rot-u32 e 6)
+                                    (bitwise-rot-u32 e 11)
+                                    (bitwise-rot-u32 e 25)))
+                   (ch (bitwise-xor (bitwise-and e f)
+                                    (bitwise-and (bitwise-not e) g)))
+                   (temp1 (u32 (+ h s1 ch (vector-ref k j) (vector-ref w j))))
+                   (s0 (bitwise-xor (bitwise-rot-u32 a 2)
+                                    (bitwise-rot-u32 a 13)
+                                    (bitwise-rot-u32 a 22)))
+                   (maj (bitwise-xor (bitwise-and a b)
+                                     (bitwise-and a c)
+                                     (bitwise-and b c)))
+                   (temp2 (u32+ s0 maj)))
+              (lp (+ j 1)
+                  (u32+ temp1 temp2) a b c
+                  (u32+ d temp1) e f g)))))))))
+
+(define (sha-224 src)
+  (sha-224-256 src sha-224-inits #f))
+
+(define (sha-256 src)
+  (sha-224-256 src sha-256-inits #t))
diff --git a/lib/chibi/crypto/sha2.sld b/lib/chibi/crypto/sha2.sld
new file mode 100644
index 00000000..412f5881
--- /dev/null
+++ b/lib/chibi/crypto/sha2.sld
@@ -0,0 +1,5 @@
+
+(define-library (chibi crypto sha2)
+  (import (scheme base) (srfi 33) (chibi bytevector))
+  (export sha-224 sha-256)
+  (include "sha2.scm"))
diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c
new file mode 100644
index 00000000..a364266a
--- /dev/null
+++ b/lib/chibi/disasm.c
@@ -0,0 +1,240 @@
+/*  disasm.c -- optional debugging utilities                  */
+/*  Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include "chibi/eval.h"
+#if ! SEXP_USE_STATIC_LIBS
+#include "../../opt/opcode_names.h"
+#endif
+
+#define SEXP_DISASM_MAX_DEPTH 16
+#define SEXP_DISASM_PAD_WIDTH 4
+
+#if SEXP_64_BIT
+#define SEXP_PRId "%ld"
+#else
+#define SEXP_PRId "%d"
+#endif
+
+static void sexp_write_pointer (sexp ctx, void *p, sexp out) {
+  char buf[32];
+  sprintf(buf, "%p", p);
+  sexp_write_string(ctx, buf, out);
+}
+
+static void sexp_write_integer (sexp ctx, sexp_sint_t n, sexp out) {
+  char buf[32];
+  sprintf(buf, SEXP_PRId, n);
+  sexp_write_string(ctx, buf, out);
+}
+
+static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
+  unsigned char *ip, opcode, i;
+  sexp tmp=NULL, src;
+  sexp_sint_t *labels, label=1, off;
+#if SEXP_USE_FULL_SOURCE_INFO
+  sexp src_here=NULL;
+  sexp_sint_t src_off=0;
+#endif
+
+  if (sexp_procedurep(bc)) {
+    bc = sexp_procedure_code(bc);
+  } else if (sexp_opcodep(bc)) {
+    sexp_write(ctx, sexp_opcode_name(bc), out);
+    sexp_write_string(ctx, " is a primitive\n", out);
+    return SEXP_VOID;
+  } else if (! sexp_bytecodep(bc)) {
+    return sexp_type_exception(ctx, self, SEXP_BYTECODE, bc);
+  }
+  if (! sexp_oportp(out)) {
+    return sexp_type_exception(ctx, self, SEXP_OPORT, out);
+  }
+
+  src = sexp_bytecode_source(bc);
+
+  for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++)
+    sexp_write_char(ctx, ' ', out);
+  sexp_write_string(ctx, "      -------------- ", out);
+  if (sexp_truep(sexp_bytecode_name(bc))) {
+    sexp_write(ctx, sexp_bytecode_name(bc), out);
+    sexp_write_char(ctx, ' ', out);
+  }
+  sexp_write_pointer(ctx, bc, out);
+#if SEXP_USE_FULL_SOURCE_INFO
+  if (!(src && sexp_vectorp(src)))
+    src_off = -1;
+  /* if (src) sexp_write(ctx, src, out); */
+#else
+  if (src && sexp_pairp(src)) {
+    sexp_write(ctx, sexp_car(src), out);
+    sexp_write_string(ctx, ":", out);
+    sexp_write(ctx, sexp_cdr(src), out);
+  }
+#endif
+  sexp_newline(ctx, out);
+
+  /* build a table of labels that are jumped to */
+  labels = calloc(sexp_bytecode_length(bc), sizeof(sexp_sint_t));
+  ip = sexp_bytecode_data(bc);
+  while (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) {
+    switch (*ip++) {
+    case SEXP_OP_JUMP:
+    case SEXP_OP_JUMP_UNLESS:
+      off = ip - sexp_bytecode_data(bc) + ((sexp_sint_t*)ip)[0];
+      if (off >= 0 && off < sexp_bytecode_length(bc) && labels[off] == 0)
+        labels[off] = label++;
+    case SEXP_OP_CALL:
+    case SEXP_OP_CLOSURE_REF:
+    case SEXP_OP_GLOBAL_KNOWN_REF:
+    case SEXP_OP_GLOBAL_REF:
+    case SEXP_OP_LOCAL_REF:
+    case SEXP_OP_LOCAL_SET:
+    case SEXP_OP_PARAMETER_REF:
+    case SEXP_OP_PUSH:
+    case SEXP_OP_RESERVE:
+    case SEXP_OP_STACK_REF:
+    case SEXP_OP_TAIL_CALL:
+    case SEXP_OP_TYPEP:
+      ip += sizeof(sexp);
+      break;
+    case SEXP_OP_SLOT_REF:
+    case SEXP_OP_SLOT_SET:
+    case SEXP_OP_MAKE:
+      ip += sizeof(sexp)*2;
+      break;
+    case SEXP_OP_MAKE_PROCEDURE:
+      ip += sizeof(sexp)*3;
+      break;
+    default:
+      /* opcode takes no additional instruction args */
+      break;
+    }
+  }
+
+  ip = sexp_bytecode_data(bc);
+ loop:
+  for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++)
+    sexp_write_char(ctx, ' ', out);
+  if (labels[ip - sexp_bytecode_data(bc)] == 0) {
+    sexp_write_string(ctx, "     ", out);
+  } else {
+    sexp_write_char(ctx, 'L', out);
+    sexp_write_integer(ctx, labels[ip - sexp_bytecode_data(bc)], out);
+    sexp_write_string(ctx, ": ", out);
+    if (labels[ip - sexp_bytecode_data(bc)] < 10)
+      sexp_write_char(ctx, ' ', out);
+  }
+#if SEXP_USE_FULL_SOURCE_INFO
+  if ((src_off >= 0)
+      && ((ip-sexp_bytecode_data(bc))
+          == sexp_unbox_fixnum(
+               sexp_car(sexp_vector_ref(src, sexp_make_fixnum(src_off)))))) {
+    src_here = sexp_cdr(sexp_vector_ref(src, sexp_make_fixnum(src_off)));
+    src_off = src_off < sexp_vector_length(src)-1 ? src_off + 1 : -1;
+  } else {
+    src_here = NULL;
+  }
+#endif
+  opcode = *ip++;
+  if (opcode < SEXP_OP_NUM_OPCODES) {
+    sexp_write_char(ctx, ' ', out);
+    sexp_write_string(ctx, sexp_opcode_names[opcode], out);
+    sexp_write_char(ctx, ' ', out);
+  } else {
+    sexp_write_string(ctx, "  <invalid> ", out);
+    sexp_write(ctx, sexp_make_fixnum(opcode), out);
+    sexp_write_char(ctx, ' ', out);
+  }
+  switch (opcode) {
+  case SEXP_OP_STACK_REF:
+  case SEXP_OP_LOCAL_REF:
+  case SEXP_OP_LOCAL_SET:
+  case SEXP_OP_CLOSURE_REF:
+  case SEXP_OP_TYPEP:
+  case SEXP_OP_RESERVE:
+    sexp_write_integer(ctx, ((sexp_sint_t*)ip)[0], out);
+    ip += sizeof(sexp);
+    break;
+  case SEXP_OP_JUMP:
+  case SEXP_OP_JUMP_UNLESS:
+    sexp_write_integer(ctx, ((sexp_sint_t*)ip)[0], out);
+    off = ip - sexp_bytecode_data(bc) + ((sexp_sint_t*)ip)[0];
+    if (off >= 0 && off < sexp_bytecode_length(bc) && labels[off] > 0) {
+      sexp_write_string(ctx, " L", out);
+      sexp_write_integer(ctx, labels[off], out);
+    }
+    ip += sizeof(sexp);
+    break;
+  case SEXP_OP_FCALL0:
+  case SEXP_OP_FCALL1:
+  case SEXP_OP_FCALL2:
+  case SEXP_OP_FCALL3:
+  case SEXP_OP_FCALL4:
+    sexp_write_pointer(ctx, ((sexp*)ip)[0], out);
+    sexp_write_char(ctx, ' ', out);
+    sexp_write(ctx, sexp_opcode_name(((sexp*)ip)[0]), out);
+    ip += sizeof(sexp);
+    break;
+  case SEXP_OP_SLOT_REF:
+  case SEXP_OP_SLOT_SET:
+  case SEXP_OP_MAKE:
+    ip += sizeof(sexp)*2;
+    break;
+  case SEXP_OP_MAKE_PROCEDURE:
+    sexp_write_integer(ctx, ((sexp_sint_t*)ip)[0], out);
+    sexp_write_char(ctx, ' ', out);
+    sexp_write_integer(ctx, ((sexp_sint_t*)ip)[1], out);
+    tmp = ((sexp*)ip)[2];
+    ip += sizeof(sexp)*3;
+    break;
+  case SEXP_OP_GLOBAL_REF:
+  case SEXP_OP_GLOBAL_KNOWN_REF:
+  case SEXP_OP_PARAMETER_REF:
+  case SEXP_OP_TAIL_CALL:
+  case SEXP_OP_CALL:
+  case SEXP_OP_PUSH:
+    tmp = ((sexp*)ip)[0];
+    if (((opcode == SEXP_OP_GLOBAL_REF) || (opcode == SEXP_OP_GLOBAL_KNOWN_REF))
+        && sexp_pairp(tmp))
+      tmp = sexp_car(tmp);
+    else if ((opcode == SEXP_OP_PARAMETER_REF)
+             && sexp_opcodep(tmp) && sexp_opcode_data(tmp)
+             && sexp_pairp(sexp_opcode_data(tmp)))
+      tmp = sexp_car(sexp_opcode_data(tmp));
+    else if ((opcode == SEXP_OP_PUSH) && (sexp_pairp(tmp) || sexp_idp(tmp)))
+      sexp_write_char(ctx, '\'', out);
+    sexp_write(ctx, tmp, out);
+    ip += sizeof(sexp);
+    break;
+  }
+#if SEXP_USE_FULL_SOURCE_INFO
+  if (src_here && sexp_pairp(src_here)) {
+    sexp_write_string(ctx, "    ; ", out);
+    sexp_write(ctx, sexp_car(src_here), out);
+    sexp_write_string(ctx, ":", out);
+    sexp_write(ctx, sexp_cdr(src_here), out);
+  }
+#endif
+  sexp_write_char(ctx, '\n', out);
+  if ((opcode == SEXP_OP_PUSH || opcode == SEXP_OP_MAKE_PROCEDURE)
+      && (depth < SEXP_DISASM_MAX_DEPTH)
+      && tmp && (sexp_bytecodep(tmp) || sexp_procedurep(tmp)))
+    disasm(ctx, self, tmp, out, depth+1);
+  if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc))
+    goto loop;
+
+  free(labels);
+  return SEXP_VOID;
+}
+
+static sexp sexp_disasm (sexp ctx, sexp self, sexp_sint_t n, sexp bc, sexp out) {
+  return disasm(ctx, self, bc, out, 0);
+}
+
+sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
+  if (!(sexp_version_compatible(ctx, version, sexp_version)
+        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
+    return SEXP_ABI_ERROR;
+  sexp_define_foreign_param(ctx, env, "disasm", 2, (sexp_proc1)sexp_disasm, "current-output-port");
+  return SEXP_VOID;
+}
diff --git a/lib/chibi/disasm.sld b/lib/chibi/disasm.sld
new file mode 100644
index 00000000..ad8a9a5b
--- /dev/null
+++ b/lib/chibi/disasm.sld
@@ -0,0 +1,10 @@
+
+;;> \subsubsubsection{\scheme{(disasm f [out])}}
+
+;;> Write a human-readable disassembly for the procedure \var{f} to
+;;> the port \var{out}, defaulting to \scheme{(current-output-port)}.
+
+(define-library (chibi disasm)
+  (export disasm)
+  (import (chibi))
+  (include-shared "disasm"))
diff --git a/lib/chibi/doc.scm b/lib/chibi/doc.scm
new file mode 100644
index 00000000..117654d9
--- /dev/null
+++ b/lib/chibi/doc.scm
@@ -0,0 +1,908 @@
+
+;;> A library for generating SXML docs from Scribble, directly or
+;;> extracted from literate docs.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utils
+
+(define (write-to-string x)
+  (call-with-output-string (lambda (out) (write x out))))
+
+(define (string-concatenate-reverse ls)
+  (string-concatenate (reverse ls)))
+
+(define (string-strip str . o)
+  (let ((bad (if (pair? o) (car o) " \t\n")))
+    (call-with-output-string
+      (lambda (out)
+        (call-with-input-string str
+          (lambda (in)
+            (let lp ()
+              (let ((ch (read-char in)))
+                (cond
+                 ((not (eof-object? ch))
+                  (if (not (string-find? bad ch))
+                      (write-char ch out))
+                  (lp)))))))))))
+
+(define (string-first-token str sep)
+  (let ((len (string-length str)))
+    (let lp ((i 0))
+      (cond ((= i len) str)
+            ((not (string-find? sep (string-ref str i))) (lp (+ i 1)))
+            (else
+             (let lp ((j (+ i 1)))
+               (cond ((= j len) "")
+                     ((string-find? sep (string-ref str j)) (lp (+ j 1)))
+                     (else
+                      (let lp ((k (+ j 1)))
+                        (cond
+                         ((or (= k len) (string-find? sep (string-ref str k)))
+                          (substring str j k))
+                         (else
+                          (lp (+ k 1)))))))))))))
+
+(define (intersperse ls x)
+  (if (or (null? ls) (null? (cdr ls)))
+      ls
+      (let lp ((ls (cdr ls)) (res (list (car ls))))
+        (let ((res (cons (car ls) (cons x res))))
+          (if (null? (cdr ls))
+              (reverse res)
+              (lp (cdr ls) res))))))
+
+(define (normalize-sxml x)
+  (cond
+   ((pair? x)
+    (let lp ((ls x) (res '()))
+      (cond ((null? ls)
+             (string-concatenate-reverse res))
+            ((string? (car ls))
+             (lp (cdr ls) (cons (car ls) res)))
+            ((pair? res)
+             (cons (string-concatenate-reverse res)
+                   (cons (car ls) (normalize-sxml (cdr ls)))))
+            (else
+             (cons (car ls) (normalize-sxml (cdr ls)))))))
+   (else x)))
+
+(define (map-sxml proc x)
+  (if (pair? x)
+      (cons (map-sxml proc (car x))  (map-sxml proc (cdr x)))
+      (proc x)))
+
+(define (sxml-body x)
+  (cond ((not (and (pair? x) (pair? (cdr x)))) '())
+        ((and (pair? (cadr x)) (eq? '@ (car (cadr x)))) (cddr x))
+        (else (cdr x))))
+
+(define (sxml->sexp-list x)
+  (call-with-input-string (sxml-strip x) port->sexp-list))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> Extract the literate Scribble docs for module \var{mod-name} and
+;;> print them to \var{out}, rendered with \var{render} which defaults
+;;> to \scheme{sxml-display-as-text}.
+
+(define (print-module-docs mod-name . o)
+  (let ((out (if (pair? o) (car o) (current-output-port)))
+        (render (or (and (pair? o) (pair? (cdr o)) (cadr o))
+                    sxml-display-as-text)))
+    (render
+     (generate-docs
+      `((title ,(write-to-string mod-name))
+        ,@(extract-module-docs mod-name #f))
+      (make-module-doc-env mod-name))
+     out)))
+
+;;> Extract the literate Scribble docs for just the binding for
+;;> \var{var} in module \var{mod-name}, and print them as in
+;;> \scheme{print-module-docs}.
+
+(define (print-module-binding-docs mod-name var . o)
+  (let ((out (if (pair? o) (car o) (current-output-port)))
+        (render (or (and (pair? o) (pair? (cdr o)) (cadr o))
+                    sxml-display-as-text)))
+    (render
+     (generate-docs
+      (extract-module-docs mod-name #t (list var))
+      (make-module-doc-env mod-name))
+     out)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> Extract the literate Scribble docs for \var{proc} which should be
+;;> a procedure and return them as sxml.
+
+(define (procedure-docs proc)
+  (let ((mod (and (procedure? proc) (containing-module proc))))
+    (and mod
+         (generate-docs
+          (extract-module-docs (car mod) #t (list (procedure-name proc)))
+          (make-module-doc-env (car mod))))))
+
+;;> Extract the literate Scribble docs for \var{proc} which should be
+;;> a procedure and render them as in \scheme{print-module-docs}.
+
+(define (print-procedure-docs proc . o)
+  (let ((out (if (pair? o) (car o) (current-output-port)))
+        (render (or (and (pair? o) (pair? (cdr o)) (cadr o))
+                    sxml-display-as-text))
+        (docs (procedure-docs proc)))
+    (if docs (render docs out))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; doc environments
+
+(define (env-ref env name . o)
+  (cond ((assq name (car env)) => cdr)
+        ((pair? o) (car o))
+        (else #f)))
+
+(define (env-set! env name value)
+  (cond ((assq name (car env)) => (lambda (cell) (set-cdr! cell value)))
+        (else (set-car! env (cons (cons name value) (car env))))))
+
+(define (env-extend env vars vals)
+  (list (append (map cons vars vals) (car env))))
+
+;;> Return a new document environment suitable for passing to
+;;> \scheme{expand-docs}, with default rules for sections, code
+;;> blocks, procedure and macro signatures, etc.
+
+(define (make-default-doc-env)
+  `(((title . ,(expand-section 'h1))
+     (section . ,(expand-section 'h2))
+     (subsection . ,(expand-section 'h3))
+     (subsubsection . ,(expand-section 'h4))
+     (subsubsubsection . ,(expand-section 'h5))
+     (procedure . ,expand-procedure)
+     (macro . ,expand-macro)
+     (centered . center)
+     (smaller . small)
+     (larger . large)
+     (bold . b)
+     (italic . i)
+     (emph . em)
+     (subscript . sub)
+     (superscript . sup)
+     (itemlist . ul)
+     (item . li)
+     (var . code)
+     (cfun . code)
+     (cmacro . code)
+     (ctype . code)
+     (url . ,expand-url)
+     (hyperlink . ,expand-hyperlink)
+     (rawcode . code)
+     (code . ,expand-code)
+     (codeblock . ,expand-codeblock)
+     (ccode
+      . ,(lambda (x env)
+           (expand-code `(,(car x) language: c ,@(cdr x)) env)))
+     (ccodeblock
+      . ,(lambda (x env)
+           (expand-codeblock `(,(car x) language: c ,@(cdr x)) env)))
+     (scheme
+      . ,(lambda (x env)
+           (expand-code `(,(car x) language: scheme ,@(cdr x)) env)))
+     (schemeblock
+      . ,(lambda (x env)
+           (expand-codeblock `(,(car x) language: scheme ,@(cdr x)) env)))
+     (command . ,expand-command)
+     (author . ,expand-author)
+     (margin-note . ,expand-note)
+     (example . ,expand-example)
+     (example-import . ,expand-example-import)
+     )))
+
+;;> Return a new document environment as in
+;;> \scheme{make-default-doc-env}, with an \scheme{example-env}
+;;> binding mapped to an environment importing \scheme{(scheme base)}
+;;> and the module \var{mod-name}.  This binding is used when
+;;> expanding examples in the docs.
+
+(define (make-module-doc-env mod-name)
+  (env-extend (make-default-doc-env)
+              '(example-env)
+              (list (environment '(scheme base)
+                                 '(only (chibi) import)
+                                 mod-name))))
+
+(define (section-name tag name)
+  (string-strip
+   (call-with-output-string
+     (lambda (out)
+       (display tag out)
+       (write-char #\_ out)
+       (display name out)))))
+
+(define (expand-section tag)
+  (lambda (sxml env)
+    (if (null? (cdr sxml))
+        (error "section must not be empty" sxml)
+        (let* ((name (and (eq? 'tag: (cadr sxml))
+                          (pair? (cddr sxml))
+                          (sxml-strip (car (cddr sxml)))))
+               (body (map (lambda (x) (expand-docs x env))
+                          (if name (cdr (cddr sxml)) (cdr sxml))))
+               (name (or name (sxml-strip (cons tag body)))))
+          `(div (a (@ (name . ,(section-name tag name)))) (,tag ,@body))))))
+
+(define (expand-url sxml env)
+  (if (not (= 2 (length sxml)))
+      (error "url expects one argument" sxml)
+      (let ((url (expand-docs (cadr sxml) env)))
+        `(a (@ (href . ,url)) ,url))))
+
+(define (expand-hyperlink sxml env)
+  (if (not (>= (length sxml) 3))
+      (error "hyperlink expects at least two arguments" sxml)
+      (let ((url (expand-docs (cadr sxml) env)))
+        `(a (@ (href . ,url))
+            ,(map (lambda (x) (expand-docs x env)) (cddr sxml))))))
+
+(define (expand-note sxml env)
+  `(div (@ (id . "notes"))
+        ,@(map (lambda (x) (expand-docs x env)) (cdr sxml))))
+
+(define (expand-author sxml env)
+  `(div (@ (id . "notes"))
+        ,@(map (lambda (x) (expand-docs x env)) (cdr sxml))
+        (br)
+        ,(seconds->string (current-seconds))))
+
+(define (expand-code sxml env)
+  (let* ((hl (if (and (pair? (cdr sxml)) (eq? 'language: (cadr sxml)))
+                 (highlighter-for (car (cddr sxml)))
+                 highlight))
+         (body (if (and (pair? (cdr sxml)) (eq? 'language: (cadr sxml)))
+                   (cdr (cddr sxml))
+                   (cdr sxml))))
+    `(code ,@(map-sxml (lambda (x) (if (string? x) (hl x) x))
+                       (normalize-sxml
+                        (map (lambda (x) (expand-docs x env)) body))))))
+
+(define (expand-codeblock sxml env)
+  `(pre ,(expand-code sxml env)))
+
+(define (expand-example x env)
+  (let ((expr `(begin ,@(sxml->sexp-list x)))
+        (example-env (or (env-ref env 'example-env) (current-environment))))
+    `(div
+      ,(expand-codeblock `(,(car x) language: scheme ,@(cdr x)) env)
+      (code
+       (div (@ (class . "result"))
+            ,(call-with-output-string
+               (lambda (out)
+                 (protect (exn (#t (print-exception exn out)))
+                   (let ((res (eval expr example-env)))
+                     (display "=> " out)
+                     (write res out))))))))))
+
+(define (expand-example-import x env)
+  (eval `(import ,@(cdr x))
+        (or (env-ref env 'example-env) (current-environment)))
+  "")
+
+(define (expand-command sxml env)
+  `(pre (@ (class . "command"))
+        (code ,@(map (lambda (x) (expand-docs x env)) (cdr sxml)))))
+
+(define (expand-tagged tag ls env)
+  (cons tag (map (lambda (x) (expand-docs x env)) ls)))
+
+;;> Given the sxml document \var{sxml}, expands macros defined in the
+;;> document environment \var{env} into standard html tags.
+
+(define (expand-docs sxml env)
+  (cond
+   ((pair? sxml)
+    (cond
+     ((symbol? (car sxml))
+      (let ((op (env-ref env (car sxml))))
+        (cond
+         ((procedure? op)
+          (op sxml env))
+         ((symbol? op)
+          (expand-tagged op (cdr sxml) env))
+         (else
+          (expand-tagged (car sxml) (cdr sxml) env)))))
+     (else
+      (map (lambda (x) (expand-docs x env)) sxml))))
+   (else
+    sxml)))
+
+(define (expand-procedure sxml env)
+  ((expand-section 'h3) `(,(car sxml) (rawcode ,@(cdr sxml))) env))
+
+(define (expand-macro sxml env)
+  (expand-procedure sxml env))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; adjustments for html
+
+(define header-index
+  (let* ((headers '(h1 h2 h3 h4 h5 h6))
+         (len (length headers)))
+    (lambda (h) (- len (length (memq h headers))))))
+
+;; return a list of (index . link-to-header) for all headers
+(define (extract-contents x)
+  (match x
+    (('div ('a ('@ ('name . name)) . _)
+           ((and h (or 'h1 'h2 'h3 'h4 'h5 'h6)) . section))
+     (let* ((raw-text (sxml-strip (cons h section)))
+            (text (if (string-prefix? "(" raw-text)
+                      (let ((end (string-find
+                                  raw-text
+                                  (lambda (ch)
+                                    (or (char-whitespace? ch)
+                                        (eqv? ch #\)))))))
+                        (substring raw-text 1 end))
+                      raw-text)))
+       `((,(header-index h)
+          (a (@ (href . ,(string-append "#" name)))
+             ,text)))))
+    ((a . b)
+     (append (extract-contents a) (extract-contents b)))
+    (else
+     '())))
+
+;; nest the (index . link-to-header)s into ol
+(define (get-contents x)
+  (if (null? x)
+      '()
+      (let ((d (caar x)))
+        (let lp ((ls (cdr x)) (parent (car (cdar x))) (kids '()) (res '()))
+          (define (collect)
+            (cons `(li ,parent ,(get-contents (reverse kids))) res))
+          ;; take a span of all sub-headers, recurse and repeat on next span
+          (cond
+           ((null? ls)
+            `(ol ,@(reverse (collect))))
+           ((> (caar ls) d)
+            (lp (cdr ls) parent (cons (car ls) kids) res))
+           (else
+            (lp (cdr ls) (car (cdar ls)) '() (collect))))))))
+
+(define (fix-header x)
+  `(html (head ,@(cond ((assq 'title x) => (lambda (x) (list x)))
+                       (else '()))
+               "\n"
+               (style (@ (type . "text/css"))
+                 "
+body {color: #000; background-color: #FFF}
+div#menu  {font-size: smaller; position: absolute; top: 50px; left: 0; width: 190px; height: 100%}
+div#main  {position: absolute; top: 0; left: 200px; width: 540px; height: 100%}
+div#notes {position: relative; top: 2em; left: 570px; max-width: 200px; height: 0px; font-size: smaller;}
+div#footer {padding-bottom: 50px}
+.result { color: #000; background-color: #FFEADF; width: 100%; padding: 3px}
+.command { color: #000; background-color: #FFEADF; width: 100%; padding: 5px}
+"
+                 ,(highlight-style))
+               "\n")
+         (body
+          (div (@ (id . "menu"))
+               ,(let ((contents (get-contents (extract-contents x))))
+                  (match contents
+                    ;; flatten if we have only a single heading
+                    (('ol (li y sections ...))
+                     sections)
+                    (else contents))))
+          (div (@ (id . "main"))
+               ,@(map (lambda (x)
+                        (if (and (pair? x) (eq? 'title (car x)))
+                            (cons 'h1 (cdr x))
+                            x))
+                      x)
+               (div (@ (id . "footer")))))))
+
+(define (fix-paragraphs x)
+  (let lp ((ls x) (p '()) (res '()))
+    (define (collect)
+      (if (pair? p) (cons `(p ,@(reverse p)) res) res))
+    (define (inline? x)
+      (or (string? x)
+          (and (pair? x) (symbol? (car x))
+               (memq (car x) '(a b i u span code small large sub sup em)))))
+    (define (enclosing? x)
+      (and (pair? x) (symbol? (car x))
+           (memq (car x) '(div body))))
+    (cond
+     ((null? ls)
+      (reverse (collect)))
+     ((equal? "\n" (car ls))
+      (if (and (pair? p) (equal? "\n" (car p)))
+          (let lp2 ((ls (cdr ls)))
+            (if (and (pair? ls) (equal? "\n" (car ls)))
+                (lp2 (cdr ls))
+                (lp ls '() (collect))))
+          (lp (cdr ls) (cons (car ls) p) res)))
+     ((inline? (car ls))
+      (lp (cdr ls) (cons (car ls) p) res))
+     ((enclosing? (car ls))
+      (lp (cdr ls) '() (cons (car ls) (collect))))
+     (else
+      (lp (cdr ls) '() (cons (car ls) (collect)))))))
+
+(define (fix-begins x)
+  x)
+
+;;> Resolves paragraphs and adds a header to convert \var{sxml} to a
+;;> standalone document renderable in html.
+
+(define (fixup-docs sxml)
+  (fix-header (fix-paragraphs (fix-begins sxml))))
+
+;;> Composes \scheme{expand-docs} and \scheme{fixup-docs}.
+
+(define (generate-docs sxml . o)
+  (let ((env (if (pair? o) (car o) (make-default-doc-env))))
+    (fixup-docs (expand-docs sxml env))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; extraction
+
+(define (skip-horizontal-whitespace in)
+  (cond ((memv (peek-char in) '(#\space #\tab))
+         (read-char in)
+         (skip-horizontal-whitespace in))))
+
+(define (external-clause? x)
+  (not (and (pair? (cdr x)) (pair? (cadr x)) (string? (car (cadr x))))))
+
+(define (contains? tree x)
+  (or (eq? tree x)
+      (and (pair? tree)
+           (or (contains? (car tree) x)
+               (contains? (cdr tree) x)))))
+
+(define (form-defined-name form)
+  (match form
+    (('define (name . x) . y) name)
+    (((or 'define 'define-syntax) name . x)
+     name)
+    (((or 'define-c 'define-c-const)
+      t (name . x) . y)
+     name)
+    (((or 'define-c 'define-c-const)
+      t name . x)
+     name)
+    (else #f)))
+
+;; Try to determine the names of optional parameters checking common
+;; patterns.
+(define (get-optionals ls body)
+  (let lp ((ls ls) (pre '()))
+    (cond
+     ((pair? ls) (lp (cdr ls) (cons (car ls) pre)))
+     ((null? ls) (reverse pre))
+     (else
+      (let* ((o ls)
+             (o? (lambda (x) (eq? x o))))
+        (let extract ((x body)
+                      (vars '())
+                      (i 0))
+          (match x
+            ((('define x val) . rest)
+             (if (contains? val o)
+                 (extract #f vars i)
+                 (extract rest vars i)))
+            ((((or 'let 'let* 'letrec 'letrec*) (y ...) . body))
+             (let ((ordered? (memq (car x) '(let* letrec*))))
+               (let lp ((ls y) (vars vars) (j i))
+                 (cond
+                  ((pair? ls)
+                   (match (car ls)
+                     (((? o?) ('if ('pair? (? o?)) ('cdr (? o?)) default))
+                      (lp (cdr ls) vars (+ j 1)))
+                     (((? o?) expr)
+                      (extract #f vars i))
+                     ((v ('if ('pair? (? o?)) ('car (? o?)) default))
+                      (lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j))
+                     ((v ('and ('pair? (? o?)) ('car (? o?))))
+                      (lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j))
+                     ((v ('if ('and ('pair? (? o?)) ('pair? ('cdr (? o?))))
+                             ('cadr (? o?))
+                             default))
+                      (lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j))
+                     (else
+                      (lp (cdr ls) vars j))))
+                  (else
+                   (extract body vars j))))))
+            ((((or 'let-optionals 'let-optionals*) ls ((var default) ...)
+               . body))
+             (let lp ((ls var) (vars vars) (i i))
+               (cond
+                ((pair? ls)
+                 (lp (cdr ls) (cons (cons (caar ls) i) vars) (+ i 1)))
+                (else
+                 (extract body vars i)))))
+            (else
+             (let ((opts (map car (sort vars < cdr)))
+                   (dotted? (contains? x o)))
+               (append (reverse pre)
+                       (cond
+                        ((and (pair? opts) dotted?)
+                         (list (append opts o)))
+                        (dotted?
+                         o)
+                        (else
+                         (list opts)))))))))))))
+
+(define (get-procedure-signature mod id proc)
+  (cond ((and (procedure? proc) (procedure-signature id mod))
+         => (lambda (sig)
+              (list (cons (or id (procedure-name proc)) (cdr sig)))))
+        (else '())))
+
+(define (get-value-signature mod id proc name value)
+  (match value
+    (('(or let let* letrec letrec*) vars body0 ... body)
+     (get-value-signature mod id proc name body))
+    (('lambda args . body) (list (cons name (get-optionals args body))))
+    ((('lambda args body0 ... body) vals ...)
+     (get-value-signature mod id proc name body))
+    (('begin body0 ... body) (get-value-signature mod id proc name body))
+    (else (get-procedure-signature mod id proc))))
+
+;; TODO: analyze and match on AST instead of making assumptions about
+;; bindings
+(define (get-signature mod id proc source form)
+  (match form
+    (('define (name args ...) . body)
+     (list (cons name args)))
+    (('define (name . args) . body)
+     (list (cons name (get-optionals args body))))
+    (('define name value)
+     (get-value-signature mod id proc name value))
+    (('define-syntax name ('syntax-rules () (clause . body) ...))
+     ;; TODO: smarter summary merging forms
+     (map (lambda (x) (cons name (cdr x)))
+          (filter external-clause? clause)))
+    (else
+     (get-procedure-signature mod id proc))))
+
+(define (get-ffi-signatures form)
+  (match form
+    (('define-c ret-type (or (name _) name) (args ...))
+     (list (cons name
+                 (map (lambda (x) (if (pair? x) (last x) x))
+                      (remove (lambda (x)
+                                (and (pair? x)
+                                     (memq (car x) '(value result))))
+                              args)))))
+    (('define-c-const type (or (name _) name))
+     (list (list 'const: type name)))
+    (((or 'define-c-struct 'define-c-class 'define-c-type) name . rest)
+     (let lp ((ls rest) (res '()))
+       (cond
+        ((null? ls)
+         (reverse res))
+        ((eq? 'predicate: (car ls))
+         (lp (cddr ls) (cons (list (cadr ls) 'obj) res)))
+        ((eq? 'constructor: (car ls))
+         (lp (cddr ls)
+             (cons (if (pair? (cadr ls)) (cadr ls) (list (cadr ls))) res)))
+        ((pair? (car ls))
+         (lp (cdr ls)
+             (append (if (pair? (cddr (cdar ls)))
+                         (list (list (car (cddr (cdar ls))) name (caar ls)))
+                         '())
+                     (list (list (cadr (cdar ls)) name))
+                     res)))
+        ((symbol? (car ls))
+         (lp (cddr ls) res))
+        (else
+         (lp (cdr ls) res)))))
+    (else
+     '())))
+
+(define section-number
+  (let ((sections '(section subsection subsubsection subsubsubsection)))
+    (lambda (x)
+      (cond ((memq x sections) => length)
+            ((memq x '(procedure macro)) (section-number 'subsection))
+            (else 0)))))
+
+(define (section>=? x n)
+  (and (pair? x)
+       (if (memq (car x) '(div))
+           (find (lambda (y) (section>=? y n)) (sxml-body x))
+           (>= (section-number (car x)) n))))
+
+(define (extract-sxml tag x)
+  (and (pair? x)
+       (cond ((if (pair? tag) (memq (car x) tag) (eq? tag (car x))) x)
+             ((memq (car x) '(div))
+              (any (lambda (y) (extract-sxml tag y)) (sxml-body x)))
+             (else #f))))
+
+(define (section-describes? x name)
+  (let ((name (symbol->string name)))
+    (and (pair? x) (pair? (cdr x))
+         (let* ((str (sxml-strip (cadr x)))
+                (op (string-first-token str " \t\r\n()#")))
+           (or (string=? op name)
+               ;; FIXME: hack for loop iterators
+               (and (string=? op "for")
+                    (string-contains str (string-append "(" name " "))))))))
+
+;; write a signature handling a trailing list as [optional] parameters
+(define (write-signature sig)
+  (if (and (list? sig)
+           (> (length sig) 1)
+           (pair? (last sig))
+           (not (any pair? (drop-right sig 1))))
+      (call-with-output-string
+        (lambda (out)
+          (display "(" out)
+          (write (car sig) out)
+          (let lp ((ls (cdr sig)))
+            (cond
+             ((pair? (car ls))
+              (display " [" out)
+              (write (caar ls) out)
+              (let lp ((ls (cdar ls)))
+                (cond
+                 ((pair? ls)
+                  (display " " out)
+                  (write (car ls) out)
+                  (lp (cdr ls)))
+                 ((not (null? ls))
+                  (display " . " out)
+                  (write ls out))))
+              (display "])" out))
+             (else
+              (display " " out)
+              (write (car ls) out)
+              (lp (cdr ls)))))))
+      (write-to-string sig)))
+
+(define (insert-signature orig-ls name sig)
+  (cond
+   ((not (pair? sig))
+    orig-ls)
+   (else
+    (let ((name
+           (cond
+            (name)
+            ((not (pair? (car sig))) (car sig))
+            ((eq? 'const: (caar sig)) (cadr (cdar sig)))
+            (else (caar sig)))))
+      (let lp ((ls orig-ls) (rev-pre '()))
+        (cond
+         ((or (null? ls)
+              (section>=? (car ls) (section-number 'subsection)))
+          `(,@(reverse rev-pre)
+            ,@(if (and (pair? ls)
+                       (section-describes?
+                        (extract-sxml '(subsection procedure macro)
+                                      (car ls))
+                        name))
+                  '()
+                  `((subsection
+                     tag: ,(write-to-string name)
+                     (rawcode
+                      ,@(if (and (pair? (car sig)) (eq? 'const: (caar sig)))
+                            `((i ,(write-to-string (car (cdar sig))) ": ")
+                              ,(write-to-string (cadr (cdar sig))))
+                            (intersperse (map write-signature sig) '(br)))))))
+            ,@ls))
+         (else
+          (lp (cdr ls) (cons (car ls) rev-pre)))))))))
+
+;;> Extract inline Scribble documentation (with the ;;> prefix) from
+;;> the source file \var{file}, associating any signatures from the
+;;> provided defs when available and not overridden in the docs.
+
+(define (extract-file-docs mod file all-defs strict? . o)
+  ;; extract (<file> . <line>) macro source or
+  ;; (<offset> <file . <line>>) procedure source
+  (define (source-line source)
+    (and (pair? source)
+         (if (string? (car source))
+             (and (equal? file (car source))
+                  (number? (cdr source))
+                  (cdr source))
+             (and (number? (car source))
+                  (pair? (cdr source))
+                  (equal? file (cadr source))
+                  (cddr source)))))
+  (define (read-to-paren in)
+    (let lp1 ((res '()))
+      (let ((ch (peek-char in)))
+        (cond
+         ((or (eof-object? ch) (eqv? #\) ch)) (read-char in) (reverse res))
+         ((char-whitespace? ch) (read-char in) (lp1 res))
+         ((eq? ch #\;)
+          (let lp2 ()
+            (let ((ch2 (read-char in)))
+              (if (or (eof-object? ch2) (eqv? #\newline ch2))
+                  (lp1 res)
+                  (lp2)))))
+         ;; TODO: support #; and #| comments at end of list
+         (else (lp1 (cons (read in) res)))))))
+  (call-with-input-file file
+    (lambda (in)
+      (let* ((lang (or (and (pair? o) (car o)) 'scheme))
+             ;; filter to only defs found in this file
+             (defs (filter-map
+                    (lambda (x)
+                      (let ((line (source-line (third x))))
+                        (and line 
+                             ;; (name value line)
+                             `(,(car x) ,(cadr x) ,line))))
+                    all-defs)))
+        (let lp ((lines '())
+                 (cur '())
+                 (res '())
+                 (ids '())
+                 (depth 0)
+                 (last-line 0))
+          (define (collect)
+            (if (pair? lines)
+                (append
+                 (reverse
+                  (call-with-input-string
+                      (string-concatenate (reverse lines) "\n")
+                    scribble-parse))
+                 cur)
+                cur))
+          (define (get-ids sxml)
+            (match sxml
+              (((or 'procedure 'macro) str)
+               (list
+                (string->symbol
+                 (string-trim (car (string-split str))
+                              (lambda (ch) (or (eq? ch #\() (eq? ch #\))))))))
+              ((x ...) (append-map get-ids x))
+              (else '())))
+          (skip-horizontal-whitespace in)
+          (cond
+           ((eof-object? (peek-char in))
+            (append (collect) res))
+           ((eqv? #\newline (peek-char in))
+            (read-char in)
+            (lp lines cur res ids depth last-line))
+           ((eqv? #\; (peek-char in))
+            (read-char in)
+            (cond
+             ((and (eqv? #\; (peek-char in))
+                   (begin (read-char in) (eqv? #\> (peek-char in))))
+              (read-char in)
+              (if (eqv? #\space (peek-char in)) (read-char in))
+              (lp (cons (read-line in) lines) cur res ids depth last-line))
+             (else
+              (let lp ()
+                (cond ((eqv? #\; (peek-char in))
+                       (read-char in)
+                       (lp))))
+              (let* ((line (read-line in))
+                     (cur (collect))
+                     (ids (append (get-ids cur) ids)))
+                ;; ";;/" attaches the docs to the preceding form
+                ;; rather than the next
+                (cond
+                 ((equal? line "/")
+                  (lp '() '() (append cur res) ids depth last-line))
+                 (else
+                  (cond
+                   ((and (not (equal? line ""))
+                         (eqv? #\/ (string-ref line 0)))
+                    (display "WARNING: ;;/ line should be empty"
+                             (current-error-port))
+                    (write line (current-error-port))
+                    (newline (current-error-port))))
+                  (lp '() cur res ids depth last-line)))))))
+           ((eqv? #\) (peek-char in))
+            (read-char in)
+            (if (zero? depth)
+                (error "unexpected ) at line" last-line)
+                (lp lines cur res ids (- depth 1) last-line)))
+           ((not (eqv? #\( (peek-char in)))
+            ;; ignore non-list top-level expression
+            (read in)
+            (lp lines cur res ids depth (port-line in)))
+           (else  ;; found a top-level expression
+            (read-char in)
+            (let ((op (read in)))
+              (case op
+                ((begin define-library)
+                 ;; allowed nested docs in these forms
+                 (lp lines cur res ids (+ depth 1) (port-line in)))
+                (else
+                 ;; read until closing paren
+                 (let* ((cur (collect))
+                        (ids (append (get-ids cur) ids))
+                        (form (cons op (read-to-paren in)))
+                        (id (form-defined-name form))
+                        (line (port-line in))
+                        ;; find all procedures defined by form
+                        (procs2 (filter (lambda (x) (<= last-line (third x) line))
+                                        (filter third defs)))
+                        (procs (if (= 2 (length procs2))
+                                   (cdr procs2)
+                                   procs2))
+                        ;; the the signature for the form
+                        (sigs
+                         (cond
+                          ((eq? lang 'ffi)
+                           (filter
+                            (lambda (x)
+                              (assq (if (eq? 'const: (car x)) (third x) (car x))
+                                    all-defs))
+                            (get-ffi-signatures form)))
+                          ((= 1 (length procs))
+                           (get-signature
+                            mod id (caar procs) (cdar procs) form))
+                          (else
+                           (get-signature
+                            mod id (and id (module-ref mod id)) #f form)))))
+                   (cond
+                    ((and strict?
+                          (or (not (pair? sigs)) (not (assq (caar sigs) defs))))
+                     ;; drop unrelated docs in strict mode
+                     (lp '() '() res ids depth line))
+                    ((and (eq? lang 'ffi) (pair? sigs))
+                     (lp '() '() (append (insert-signature cur #f sigs) res)
+                         ids depth line))
+                    ((and (memq lang '(scheme module)) (= 1 (length procs)))
+                     (lp '() '()
+                         (append (insert-signature cur (caar procs) sigs) res)
+                         ids depth line))
+                    ((and (null? procs)
+                          (and (not (memq id ids)) (assq id all-defs)))
+                     (let ((sigs (if (and (null? sigs) id)
+                                     (list id)
+                                     sigs)))
+                       (lp '() '() (append (insert-signature cur #f sigs) res)
+                           ids depth line)))
+                    (else
+                     (lp '() '() (append cur res) ids depth line))))))))))))))
+
+;; utility to get the source position of an object
+(define (object-source x)
+  (cond ((opcode? x) #f)
+        ((bytecode? x)
+         (let ((src (bytecode-source x)))
+           (if (and (vector? src) (positive? (vector-length src)))
+               (vector-ref src 0)
+               src)))
+        ((procedure? x) (object-source (procedure-code x)))
+        ((macro? x) (macro-source x))
+        (else #f)))
+
+;;> Extract the literate Scribble docs from module \var{mod-name} and
+;;> return them as sxml.  If \var{strict?} is true ignore docs for
+;;> unexported values, defined by the optional \var{exports} which
+;;> defaults to all the module exports.
+
+(define (extract-module-docs mod-name strict? . o)
+  (let ((mod (load-module mod-name)))
+    (if (not mod)
+        (error "couldn't find module" mod-name)
+        (let* ((exports (if (pair? o) (car o) (module-exports mod)))
+               (defs
+                 (map (lambda (x)
+                        (let ((val (module-ref mod x)))
+                          `(,x ,val ,(object-source val))))
+                      exports)))
+          (append
+           (cond
+            ((find-module-file (module-name->file mod-name))
+             => (lambda (f)
+                  (reverse (extract-file-docs mod f defs strict? 'module))))
+            (else '()))
+           (reverse
+            (append-map (lambda (x)
+                          (extract-file-docs mod x defs strict? 'module))
+                        (module-include-library-declarations mod)))
+           (reverse
+            (append-map (lambda (x) (extract-file-docs mod x defs strict?))
+                        (module-includes mod)))
+           (reverse
+            (append-map (lambda (x) (extract-file-docs mod x defs strict? 'ffi))
+                        (module-shared-includes mod))))))))
diff --git a/lib/chibi/doc.sld b/lib/chibi/doc.sld
new file mode 100644
index 00000000..634cd706
--- /dev/null
+++ b/lib/chibi/doc.sld
@@ -0,0 +1,14 @@
+
+(define-library (chibi doc)
+  (import
+   (except (chibi) eval) (scheme eval) (srfi 1) (srfi 95)
+   (chibi modules) (chibi ast) (chibi io) (chibi match)
+   (chibi time) (chibi filesystem) (chibi process)
+   (chibi string) (chibi scribble) (chibi sxml) (chibi highlight)
+   (chibi type-inference))
+  (export procedure-docs print-procedure-docs
+          print-module-docs print-module-binding-docs
+          generate-docs expand-docs fixup-docs
+          extract-module-docs extract-file-docs
+          make-default-doc-env make-module-doc-env)
+  (include "doc.scm"))
diff --git a/lib/chibi/equiv.scm b/lib/chibi/equiv.scm
new file mode 100644
index 00000000..6d88acce
--- /dev/null
+++ b/lib/chibi/equiv.scm
@@ -0,0 +1,49 @@
+
+;;> Cycle-aware equality.  Returns \scheme{#t} iff \scheme{a} and
+;;> \scheme{b} are \scheme{equal?}, including cycles.  Another way
+;;> to think of it is they are \scheme{equiv} if they print the
+;;> same, assuming all elements can be printed.
+
+(define (equiv? a b)
+  (let ((equivs (make-hash-table eq?)))
+    (define (get-equivs x)
+      (or (hash-table-ref/default equivs x #f)
+          (let ((tmp (make-hash-table eq?)))
+            (hash-table-set! equivs x tmp)
+            tmp)))
+    (define (merge! tab x)
+      (hash-table-set! tab x tab)
+      (cond ((hash-table-ref/default equivs x #f)
+             => (lambda (tab2)
+                  (hash-table-walk tab2 (lambda (key value)
+                                          (hash-table-set! tab key tab)))))))
+    (define (equiv? a b)
+      (cond
+       ((eq? a b))
+       ((pair? a)
+        (and (pair? b)
+             (let ((a-tab (get-equivs a)))
+               (hash-table-ref
+                a-tab
+                b
+                (lambda ()
+                  (merge! a-tab b)
+                  (and (equiv? (car a) (car b))
+                       (equiv? (cdr a) (cdr b))))))))
+       ((vector? a)
+        (and (vector? b)
+             (= (vector-length a) (vector-length b))
+             (let ((a-tab (get-equivs a)))
+               (hash-table-ref
+                a-tab
+                b
+                (lambda ()
+                  (merge! a-tab b)
+                  (let lp ((i (- (vector-length a) 1)))
+                    (or (< i 0)
+                        (and (equiv? (vector-ref a i) (vector-ref b i))
+                             (lp (- i 1))))))))))
+       (else
+        (equal? a b))))
+    (let ((res (equal?/bounded a b 100000 100000)))
+      (and res (or (> res 0) (equiv? a b)) #t))))
diff --git a/lib/chibi/equiv.sld b/lib/chibi/equiv.sld
new file mode 100644
index 00000000..463eec57
--- /dev/null
+++ b/lib/chibi/equiv.sld
@@ -0,0 +1,6 @@
+
+(define-library (chibi equiv)
+  (export equiv?)
+  (import (chibi))
+  (import (srfi 69))
+  (include "equiv.scm"))
diff --git a/lib/chibi/filesystem.scm b/lib/chibi/filesystem.scm
new file mode 100644
index 00000000..6dc71e94
--- /dev/null
+++ b/lib/chibi/filesystem.scm
@@ -0,0 +1,183 @@
+;; filesystem.scm -- additional filesystem utilities
+;; Copyright (c) 2009-2013 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> Creates the directory \var{dir}, including any parent directories
+;;> as needed.  Returns \scheme{#t} on success and \scheme{#f} on
+;;> failure.
+
+(define (create-directory* dir . o)
+  (let ((mode (if (pair? o) (car o) #o755)))
+    (or (file-directory? dir)
+        (create-directory dir mode)
+        (let ((slash
+               (string-find-right dir #\/ 0 (string-skip-right dir #\/))))
+          (and (> slash 0)
+               (let ((parent (substring-cursor dir 0 slash)))
+                 (and (not (equal? parent dir))
+                      (not (file-exists? parent))
+                      (create-directory* parent mode)
+                      (create-directory dir mode))))))))
+
+;;> The fundamental directory iterator.  Applies \var{kons} to
+;;> each filename in directory \var{dir} and the result of the
+;;> previous application, beginning with \var{knil}.  With
+;;> \var{kons} as \scheme{cons} and \var{knil} as \scheme{'()},
+;;> equivalent to \scheme{directory-files}.
+
+(define (directory-fold dir kons knil)
+  (let ((dir (opendir dir)))
+    (if (not dir)
+        knil
+        (let lp ((res knil))
+          (let ((file (readdir dir)))
+            (if file
+                (lp (kons (dirent-name file) res))
+                (begin (closedir dir) res)))))))
+
+;;> Returns a list of the files in \var{dir} in an unspecified
+;;> order.
+
+(define (directory-files dir)
+  (directory-fold dir cons '()))
+
+;;> The fundamental directory traverser.
+
+(define (directory-fold-tree file down up here . o)
+  ;; TODO: Use link count to reduce stats.
+  ;; TODO: Provide higher-level wrapper for filtering and avoids links.
+  (let ((knil (and (pair? o) (car o)))
+        (down (or down (lambda (f acc) acc)))
+        (up (or up (lambda (f acc) acc)))
+        (here (or here (lambda (f acc) acc))))
+    (let fold ((file file) (acc knil))
+      (cond
+       ((file-directory? file)
+        (let ((d (opendir file)))
+          (if (not d)
+              acc
+              (let lp ((acc (down file acc)))
+                (let ((e (readdir d)))
+                  (cond
+                   (e
+                    (let ((f (dirent-name e)))
+                      (if (member f '("." ".."))
+                          (lp acc)
+                          (let ((path (string-append file "/" f)))
+                            (lp (fold path acc))))))
+                   (else
+                    (closedir d)
+                    (up file acc))))))))
+       (else
+        (here file acc))))))
+
+;;> Unlinks the file named \var{string} from the filesystem.
+;;> Returns \scheme{#t} on success and \scheme{#f} on failure.
+
+(define (delete-file file)
+  (if (not (%delete-file file))
+      (raise-continuable
+       (make-exception 'file "couldn't delete file" file delete-file #f))))
+
+;;> Recursively delete all files and directories under \var{dir}.
+;;> Unless optional arg \var{ignore-errors?} is true, raises an error
+;;> if any file can't be deleted.
+
+(define (delete-file-hierarchy dir . o)
+  (let ((ignore-errors? (and (pair? o) (car o))))
+    (if (member dir '("" "/"))
+        (error "won't delete unsafe directory" dir))
+    (directory-fold-tree
+     dir
+     #f
+     (lambda (d acc)
+       (if (and (not (delete-directory d)) (not ignore-errors?))
+           (error "couldn't delete directory" d)))
+     (lambda (f acc)
+       (if (and (not (delete-file f)) (not ignore-errors?))
+           (error "couldn't delete file" f))))))
+
+;;> Runs \var{thunk} with the current directory of the process temporarily
+;;> set to \var{dir}.
+
+(define (with-directory dir thunk)
+  (let ((pwd (current-directory)))
+    (dynamic-wind
+      (lambda () (change-directory dir))
+      thunk
+      (lambda () (change-directory pwd)))))
+
+;;> Returns the \scheme{status} object for the given \var{file},
+;;> which should be a string indicating the path or a file
+;;> descriptor.
+
+(define (file-status file)
+  (if (string? file) (stat file) (fstat file)))
+
+(define (file-device x) (stat-dev (if (stat? x) x (file-status x))))
+(define (file-inode x) (stat-ino (if (stat? x) x (file-status x))))
+(define (file-mode x) (stat-mode (if (stat? x) x (file-status x))))
+(define (file-num-links x) (stat-nlinks (if (stat? x) x (file-status x))))
+(define (file-owner x) (stat-uid (if (stat? x) x (file-status x))))
+(define (file-group x) (stat-gid (if (stat? x) x (file-status x))))
+(define (file-represented-device x) (stat-rdev (if (stat? x) x (file-status x))))
+(define (file-size x) (stat-size (if (stat? x) x (file-status x))))
+(define (file-block-size x) (stat-blksize (if (stat? x) x (file-status x))))
+(define (file-num-blocks x) (stat-blocks (if (stat? x) x (file-status x))))
+(define (file-access-time x) (stat-atime (if (stat? x) x (file-status x))))
+(define (file-modification-time x) (stat-mtime (if (stat? x) x (file-status x))))
+(define (file-change-time x) (stat-ctime (if (stat? x) x (file-status x))))
+
+;;> File status accessors.  \var{x} should be a string indicating
+;;> the file to lookup the status for, or an existing status object.
+;;> Raises an error in the string case for non-existing files.
+;;/
+
+(define-syntax file-test-mode
+  (syntax-rules ()
+    ((file-test-mode op x)
+     (let* ((tmp x)
+            (st (if (stat? tmp) tmp (file-status tmp))))
+       (and st (op (stat-mode st)))))))
+
+(define (file-regular? x) (file-test-mode S_ISREG x))
+(define (file-directory? x) (file-test-mode S_ISDIR x))
+(define (file-character? x) (file-test-mode S_ISCHR x))
+(define (file-block? x) (file-test-mode S_ISBLK x))
+(define (file-fifo? x) (file-test-mode S_ISFIFO x))
+(define (file-link? x)
+  (let ((st (if (stat? x) x (file-link-status x))))
+    (and st (S_ISLNK (stat-mode st)))))
+(define (file-socket? x) (file-test-mode S_ISSOCK x))
+(define (file-exists? x) (and (if (stat? x) #t (file-status x)) #t))
+
+;;> File type tests.  \var{x} should be a string indicating the
+;;> file to lookup the status for, or an existing status object.
+;;> Returns \scheme{#t} if the file exists and the given type
+;;> is satisfied, and \scheme{#f} otherwise.
+;;/
+
+(define (file-is-readable? path) (zero? (file-access path access/read)))
+(define (file-is-writable? path) (zero? (file-access path access/write)))
+(define (file-is-executable? path) (zero? (file-access path access/execute)))
+
+;;> File access tests.  Returns true iff the current real UID and GID
+;;> have the corresponding permissions on path.  Equivalent to the
+;;> test -r, -w, -x operators in sh.
+;;/
+
+;;> Equivalent to duplicating the file descriptor \var{old} to
+;;> \var{new} and closing \var{old}.
+
+(define (renumber-file-descriptor old new)
+  (and (duplicate-file-descriptor-to old new)
+       (close-file-descriptor old)))
+
+;;> Returns the path the symbolic link \var{file} points to, or
+;;> \scheme{#f} on error.
+
+(define (read-link file)
+  (let* ((buf (make-string 512))
+         (res (readlink file buf 512)))
+    (and (positive? res)
+         (substring buf 0 res))))
diff --git a/lib/chibi/filesystem.sld b/lib/chibi/filesystem.sld
new file mode 100644
index 00000000..bbaa20f6
--- /dev/null
+++ b/lib/chibi/filesystem.sld
@@ -0,0 +1,40 @@
+
+;;> Interface to the filesystem and file descriptor objects.
+;;> Note that file descriptors are currently represented as
+;;> integers, but may be replaced with opaque (and gc-managed)
+;;> objects in a future release.
+
+(define-library (chibi filesystem)
+  (export duplicate-file-descriptor duplicate-file-descriptor-to
+          close-file-descriptor renumber-file-descriptor
+          open-input-file-descriptor open-output-file-descriptor
+          delete-file link-file symbolic-link-file rename-file
+          directory-files directory-fold directory-fold-tree
+          delete-file-hierarchy delete-directory
+          create-directory create-directory*
+          current-directory change-directory with-directory
+          open open-pipe make-fifo
+          read-link
+          file-status               file-link-status
+          file-device               file-inode
+          file-mode                 file-num-links
+          file-owner                file-group
+          file-represented-device   file-size
+          file-block-size           file-num-blocks
+          file-access-time file-modification-time file-change-time
+          file-regular?    file-directory?        file-character?
+          file-block?      file-fifo?             file-link?
+          file-socket?     file-exists?
+          get-file-descriptor-flags   set-file-descriptor-flags!
+          get-file-descriptor-status  set-file-descriptor-status!
+          open/read        open/write             open/read-write
+          open/create      open/exclusive         open/truncate
+          open/append      open/non-block
+          file-lock        file-truncate
+          file-is-readable? file-is-writable? file-is-executable?
+          lock/shared lock/exclusive lock/non-blocking lock/unlock
+          is-a-tty?)
+  (import (chibi) (chibi string))
+  (include-shared "filesystem")
+  (include "filesystem.scm"))
+
diff --git a/lib/chibi/filesystem.stub b/lib/chibi/filesystem.stub
new file mode 100644
index 00000000..f5dc1843
--- /dev/null
+++ b/lib/chibi/filesystem.stub
@@ -0,0 +1,218 @@
+;; filesystem.stub -- filesystem bindings
+;; Copyright (c) 2009-2013 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(c-system-include "sys/file.h")
+(c-system-include "sys/types.h")
+(c-system-include "unistd.h")
+(c-system-include "dirent.h")
+(c-system-include "fcntl.h")
+
+(define-c-type DIR
+  finalizer: closedir)
+
+(define-c-struct dirent
+  (string d_name dirent-name))
+
+(define-c-struct stat
+  predicate: stat?
+  (dev_t      st_dev      stat-dev)
+  (ino_t      st_ino      stat-ino)
+  (mode_t     st_mode     stat-mode)
+  (nlink_t    st_nlink    stat-nlinks)
+  (uid_t      st_uid      stat-uid)
+  (gid_t      st_gid      stat-gid)
+  (dev_t      st_rdev     stat-rdev)
+  (off_t      st_size     stat-size)
+  (blksize_t  st_blksize  stat-blksize)
+  (blkcnt_t   st_blocks   stat-blocks)
+  (time_t     st_atime    stat-atime)
+  (time_t     st_mtime    stat-mtime)
+  (time_t     st_ctime    stat-ctime))
+
+(define-c boolean S_ISREG (mode_t))
+(define-c boolean S_ISDIR (mode_t))
+(define-c boolean S_ISCHR (mode_t))
+(define-c boolean S_ISBLK (mode_t))
+(define-c boolean S_ISFIFO (mode_t))
+(define-c boolean S_ISLNK (mode_t))
+(define-c boolean S_ISSOCK (mode_t))
+
+;;(define-c-const int ("S_IFMT"))
+(define-c-const int (file/socket "S_IFSOCK"))
+(define-c-const int (file/link "S_IFLNK"))
+(define-c-const int (file/regular "S_IFREG"))
+(define-c-const int (file/block "S_IFBLK"))
+(define-c-const int (file/directory "S_IFDIR"))
+(define-c-const int (file/character "S_IFCHR"))
+(define-c-const int (file/fifo "S_IFIFO"))
+(define-c-const int (file/suid "S_ISUID"))
+(define-c-const int (file/sgid "S_ISGID"))
+(define-c-const int (file/sticky "S_ISVTX"))
+;;(define-c-const int ("S_IRWXU"))
+(define-c-const int (perm/user-read "S_IRUSR"))
+(define-c-const int (perm/user-write "S_IWUSR"))
+(define-c-const int (perm/user-execute "S_IXUSR"))
+;;(define-c-const int ("S_IRWXG"))
+(define-c-const int (perm/group-read "S_IRGRP"))
+(define-c-const int (perm/group-write "S_IWGRP"))
+(define-c-const int (perm/group-execute "S_IXGRP"))
+;;(define-c-const int ("S_IRWXO"))
+(define-c-const int (perm/others-read "S_IROTH"))
+(define-c-const int (perm/others-write "S_IWOTH"))
+(define-c-const int (perm/others-execute "S_IXOTH"))
+
+(define-c errno stat (string (result stat)))
+(define-c errno fstat (int (result stat)))
+(define-c errno (file-link-status "lstat") (string (result stat)))
+
+(define-c int readlink (string string int))
+
+;; Creates a new input-port from the file descriptor \var{int}.
+
+;; (define-c input-port (open-input-file-descriptor "fdopen")
+;;   (fileno (value "r" string)))
+
+;; Creates a new output-port from the file descriptor \var{int}.
+
+;; (define-c output-port (open-output-file-descriptor "fdopen")
+;;   (fileno (value "w" string)))
+
+;; Creates a new bidirectional port from the file descriptor \var{int}.
+
+;; (define-c input-output-port (open-input-output-file-descriptor "fdopen")
+;;   (fileno (value "r+" string)))
+
+(define-c errno (%delete-file "unlink") (string))
+
+;;> Creates a hard link to the first arg from the second.
+;;> Returns \scheme{#t} on success and \scheme{#f} on failure.
+
+(define-c errno (link-file "link") (string string))
+
+;;> Creates a symbolic link to the first arg from the second.
+;;> Returns \scheme{#t} on success and \scheme{#f} on failure.
+
+(define-c errno (symbolic-link-file "symlink") (string string))
+
+;;> Renames the first arg to the second.
+;;> Returns \scheme{#t} on success and \scheme{#f} on failure.
+
+(define-c errno (rename-file "rename") (string string))
+
+;;> Returns the current working directory of the process as a string.
+
+(define-c non-null-string (current-directory "getcwd")
+  ((result (array char (auto-expand arg1))) (value 256 int)))
+
+;;> Change the current working directory of the process.
+
+(define-c errno (change-directory "chdir") (string))
+
+;;> Creates a new directory with the given mode.
+;;> Returns \scheme{#t} on success and \scheme{#f} on failure.
+
+(define-c errno (create-directory "mkdir") (string (default #o775 int)))
+
+;;> Deletes the directory named \var{string} from the filesystem.
+;;> Does not attempt to delete recursively.
+;;> Returns \scheme{#t} on success and \scheme{#f} on failure.
+
+(define-c errno (delete-directory "rmdir") (string))
+
+(define-c (free DIR) opendir (string))
+(define-c dirent readdir ((link (pointer DIR))))
+
+;;> Duplicates the given file descriptor, returning he new value,
+;; or -1 on failure.
+
+(define-c fileno (duplicate-file-descriptor "dup") (fileno))
+
+;;> Copies the first file descriptor to the second, closing
+;;> it if needed.
+;;> Returns \scheme{#t} on success and \scheme{#f} on failure.
+
+(define-c errno (duplicate-file-descriptor-to "dup2") (fileno fileno))
+
+;;> Closes the given file descriptor.
+;;> Returns \scheme{#t} on success and \scheme{#f} on failure.
+
+(define-c errno (close-file-descriptor "close") (fileno))
+
+;;> Opens the given file and returns a file descriptor.
+
+(define-c fileno open (string int (default #o644 int)))
+
+;;> Returns a list of 2 new file descriptors, the input and
+;;> output end of a new pipe, respectively.
+
+(define-c errno (open-pipe "pipe") ((result (array fileno 2))))
+
+;;> Creates a new named pipe in the given path.
+;;> Returns \scheme{#t} on success and \scheme{#f} on failure.
+
+(define-c errno (make-fifo "mkfifo") (string (default #o664 int)))
+
+(define-c int (get-file-descriptor-flags "fcntl")
+  (port-or-fileno (value F_GETFD int)))
+(define-c errno (set-file-descriptor-flags! "fcntl")
+  (port-or-fileno (value F_SETFD int) long))
+
+;;> Get and set the flags for the given file descriptor.
+;;/
+
+(define-c int (get-file-descriptor-status "fcntl")
+  (port-or-fileno (value F_GETFL int)))
+(define-c errno (set-file-descriptor-status! "fcntl")
+  (port-or-fileno (value F_SETFL int) long))
+
+;;> Get and set the status for the given file descriptor.
+;;/
+
+;; (define-c int (get-file-descriptor-lock "fcntl")
+;;   (int (value F_GETLK int) flock))
+;; (define-c errno (set-file-descriptor-lock! "fcntl")
+;;   (int (value F_SETLK int) flock))
+;; (define-c errno (try-set-file-descriptor-lock! "fcntl")
+;;   (int (value F_SETLKW int) flock))
+
+(define-c-const int (open/read "O_RDONLY"))
+(define-c-const int (open/write "O_WRONLY"))
+(define-c-const int (open/read-write "O_RDWR"))
+(define-c-const int (open/create "O_CREAT"))
+(define-c-const int (open/exclusive "O_EXCL"))
+(define-c-const int (open/truncate "O_TRUNC"))
+(define-c-const int (open/append "O_APPEND"))
+(define-c-const int (open/non-block "O_NONBLOCK"))
+
+;;> File opening modes.
+;;/
+
+;;> Truncate the file to the given size.
+
+(define-c int (file-truncate "ftruncate")
+  (port-or-fileno off_t))
+
+;; Used for file-is-readable?, file-is-writable?, file-is-executable?.
+(define-c-const int (access/read "R_OK"))
+(define-c-const int (access/write "W_OK"))
+(define-c-const int (access/execute "X_OK"))
+(define-c int (file-access "access") (string int))
+
+;;> Applies the specified locking operation using flock(2) to the port
+;;> or file-descriptor.
+
+(define-c errno (file-lock "flock") (port-or-fileno int))
+
+(define-c-const int (lock/shared "LOCK_SH"))
+(define-c-const int (lock/exclusive "LOCK_EX"))
+(define-c-const int (lock/non-blocking "LOCK_NB"))
+(define-c-const int (lock/unlock "LOCK_UN"))
+
+;;> Locking operations.
+;;/
+
+;;> Returns \scheme{#t} if the given port of file descriptor
+;;> if backed by a TTY object, and \scheme{#f} otherwise.
+
+(define-c boolean (is-a-tty? "isatty") (port-or-fileno))
diff --git a/lib/chibi/generic.scm b/lib/chibi/generic.scm
new file mode 100644
index 00000000..512b45da
--- /dev/null
+++ b/lib/chibi/generic.scm
@@ -0,0 +1,104 @@
+
+;;> Define a new generic function named \var{name}.
+
+(define-syntax define-generic
+  (syntax-rules ()
+    ((define-generic name)
+     (define name (make-generic 'name)))))
+
+;; call-next-method needs to be unhygienic
+'(define-syntax define-method
+  (syntax-rules ()
+    ((define-method (name (param type) ...) . body)
+     (generic-add! name
+                   (list type ...)
+                   (lambda (next param ...)
+                     (let-syntax ((call))
+                       . body))))))
+
+;;> \macro{(define-method (name params ...) body ...)}
+
+;;> Each parameter should be either a single identifier or a list of the form
+;;> \scheme{(param type)} where \var{param} is the parameter name and
+;;> \var{type} is a predicate which returns true if it's argument is of the
+;;> correct type.
+;;> Parameters without a predicate will always match.
+
+;;> If multiple methods satisfy the arguments, the most recent method
+;;> will be used.  The special form \scheme{(call-next-method)} can be
+;;> invoked to call the next most recent method with the same arguments.
+
+(define-syntax define-method
+  (er-macro-transformer
+   (lambda (e r c)
+     (let ((name (car (cadr e)))
+           (params (map (lambda (param)
+                          (if (identifier? param)
+                              `(,param (lambda _ #t))
+                              param))
+                        (cdr (cadr e))))
+           (body (cddr e)))
+       `(,(r 'generic-add!) ,name
+         (,(r 'list) ,@(map cadr params))
+         (,(r 'lambda) (,(r 'next) ,@(map car params))
+          (,(r 'let-syntax) ((call-next-method
+                              (,(r 'syntax-rules) ()
+                               ((_) (,(r 'next))))))
+           ,@body)))))))
+
+(define (no-applicable-method-error name args)
+  (error "no applicable method" name args))
+
+(define (satisfied? preds args)
+  (cond ((null? preds) (null? args))
+        ((null? args) #f)
+        (((car preds) (car args)) (satisfied? (cdr preds) (cdr args)))
+        (else #f)))
+
+(define add-method-tag (list 'add-method-tag))
+
+;;> Create a new first-class generic function named \var{name}.
+
+(define (make-generic name)
+  (let ((name name)
+        (methods (make-vector 6 '())))
+    (vector-set! methods
+                 3
+                 (list (cons (list (lambda (x) (eq? x add-method-tag))
+                                   (lambda (x) (list? x))
+                                   procedure?)
+                             (lambda (next t p f)
+                               (set! methods (insert-method! methods p f))))))
+    (lambda args
+      (let ((len (length args)))
+        (cond
+         ((>= len (vector-length methods))
+          (no-applicable-method-error name args))
+         (else
+          (let lp ((ls (vector-ref methods len)))
+            (cond
+             ((null? ls)
+              (no-applicable-method-error name args))
+             ((satisfied? (car (car ls)) args)
+              (apply (cdr (car ls)) (lambda () (lp (cdr ls))) args))
+             (else
+              (lp (cdr ls)))))))))))
+
+(define (insert-method! vec preds f)
+  (let ((vlen (vector-length vec))
+        (plen (length preds)))
+    (let ((res (if (>= plen vlen)
+                   (let ((r (make-vector (+ vlen 1) '())))
+                     (do ((i 0 (+ i 1)))
+                         ((>= i vlen) r)
+                       (vector-set! r i (vector-ref vec i))))
+                   vec)))
+      (vector-set! res plen (cons (cons preds f) (vector-ref res plen)))
+      res)))
+
+;;> Extend the generic \var{g} with a new method \var{f}
+;;> that applies when all parameters match the given list
+;;> of predicates \var{preds}.
+
+(define (generic-add! g preds f)
+  (g add-method-tag preds f))
diff --git a/lib/chibi/generic.sld b/lib/chibi/generic.sld
new file mode 100644
index 00000000..ce0a9a89
--- /dev/null
+++ b/lib/chibi/generic.sld
@@ -0,0 +1,7 @@
+
+;;> Simple generic function interface.
+
+(define-library (chibi generic)
+  (export define-generic define-method make-generic generic-add!)
+  (import (chibi))
+  (include "generic.scm"))
diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c
new file mode 100644
index 00000000..921cf401
--- /dev/null
+++ b/lib/chibi/heap-stats.c
@@ -0,0 +1,138 @@
+/* heap-stats.c -- count or dump heap objects                */
+/* Copyright (c) 2009-2011 Alex Shinn.  All rights reserved. */
+/* BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+
+#define SEXP_HEAP_VECTOR_DEPTH 1
+
+#if ! SEXP_USE_BOEHM
+
+extern sexp sexp_gc (sexp ctx, size_t *sum_freed);
+extern sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x);
+
+static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) {
+  int i;
+  if ((!sexp_pointerp(x)) || sexp_symbolp(x) || sexp_stringp(x)
+      || sexp_flonump(x) || sexp_bignump(x)) {
+    sexp_write(ctx, x, out);
+  } else if (depth <= 0) {
+    goto print_name;
+  } else if (sexp_synclop(x)) {
+    sexp_write_string(ctx, "#<sc ", out);
+    sexp_print_simple(ctx, sexp_synclo_expr(x), out, depth);
+    sexp_write_string(ctx, ">", out);
+  } else if (sexp_pairp(x)) {
+    sexp_write_char(ctx, '(', out);
+    sexp_print_simple(ctx, sexp_car(x), out, depth-1);
+    sexp_write_string(ctx, " . ", out);
+    sexp_print_simple(ctx, sexp_cdr(x), out, depth-1);
+    sexp_write_char(ctx, ')', out);
+  } else if (sexp_vectorp(x)) {
+    sexp_write_string(ctx, "#(", out);
+    for (i=0; i<SEXP_HEAP_VECTOR_DEPTH && i<sexp_vector_length(x); i++) {
+      if (i>0)
+        sexp_write_char(ctx, ' ', out);
+      sexp_print_simple(ctx, sexp_vector_ref(x, i), out, depth-1);
+    }
+    if (i<sexp_vector_length(x))
+      sexp_write_string(ctx, " ...", out);
+    sexp_write_char(ctx, ')', out);
+  } else {
+  print_name:
+    sexp_write_string(ctx, "#<", out);
+    sexp_write(ctx, sexp_object_type_name(ctx, x), out);
+    sexp_write_string(ctx, ">", out);
+  }
+}
+
+static sexp sexp_heap_walk (sexp ctx, int depth, int printp) {
+  size_t freed;
+  sexp_uint_t stats[256], hi_type=0, i;
+  sexp_heap h = sexp_context_heap(ctx);
+  sexp p, out=SEXP_FALSE;
+  sexp_free_list q, r;
+  char *end;
+  sexp_gc_var3(res, tmp, name);
+
+  if (printp)
+    out = sexp_parameter_ref(ctx,
+                             sexp_env_ref(ctx,
+                                          sexp_context_env(ctx),
+                                          sexp_global(ctx,SEXP_G_CUR_OUT_SYMBOL),
+                                          SEXP_FALSE));
+
+  /* run gc once to remove unused variables */
+  sexp_gc(ctx, &freed);
+
+  /* initialize stats */
+  for (i=0; i<256; i++) stats[i]=0;
+
+  /* loop over each heap chunk */
+  for ( ; h; h=h->next) {
+    p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair)));
+    q = h->free_list;
+    end = (char*)h->data + h->size;
+    while (((char*)p) < end) {
+      /* find the preceding and succeeding free list pointers */
+      for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
+        ;
+      if ((char*)r == (char*)p) { /* this is a free block, skip */
+        p = (sexp) (((char*)p) + r->size);
+        continue;
+      }
+      /* otherwise maybe print, then increment the stat and continue */
+      if (sexp_oportp(out)) {
+        sexp_print_simple(ctx, p, out, depth);
+        sexp_write_char(ctx, '\n', out);
+      }
+      stats[sexp_pointer_tag(p)]++;
+      if (sexp_pointer_tag(p) > hi_type)
+        hi_type = sexp_pointer_tag(p);
+      p = (sexp) (((char*)p) + sexp_heap_align(sexp_allocated_bytes(ctx, p)));
+    }
+  }
+
+  /* build and return results */
+  sexp_gc_preserve3(ctx, res, tmp, name);
+  res = SEXP_NULL;
+  for (i=hi_type; i>0; i--)
+    if (stats[i]) {
+      name = sexp_string_to_symbol(ctx, sexp_type_name_by_index(ctx, i));
+      tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i]));
+      res = sexp_cons(ctx, tmp, res);
+    }
+  sexp_gc_release3(ctx);
+  return res;
+}
+
+static sexp sexp_heap_stats (sexp ctx, sexp self, sexp_sint_t n) {
+  return sexp_heap_walk(ctx, 0, 0);
+}
+
+static sexp sexp_heap_dump (sexp ctx, sexp self, sexp_sint_t n, sexp depth) {
+  if (! sexp_fixnump(depth) || (sexp_unbox_fixnum(depth) < 0))
+    return sexp_xtype_exception(ctx, self, "bad heap-dump depth", depth);
+  return sexp_heap_walk(ctx, sexp_unbox_fixnum(depth), 1);
+}
+
+#else
+
+static sexp sexp_heap_stats (sexp ctx, sexp self, sexp_sint_t n) {
+  return SEXP_NULL;
+}
+
+static sexp sexp_heap_dump (sexp ctx, sexp self, sexp_sint_t n, sexp depth) {
+  return SEXP_NULL;
+}
+
+#endif
+
+sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
+  if (!(sexp_version_compatible(ctx, version, sexp_version)
+        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
+    return SEXP_ABI_ERROR;
+  sexp_define_foreign(ctx, env, "heap-stats", 0, sexp_heap_stats);
+  sexp_define_foreign_opt(ctx, env, "heap-dump", 1, sexp_heap_dump, SEXP_ONE);
+  return SEXP_VOID;
+}
diff --git a/lib/chibi/heap-stats.sld b/lib/chibi/heap-stats.sld
new file mode 100644
index 00000000..5b8a2420
--- /dev/null
+++ b/lib/chibi/heap-stats.sld
@@ -0,0 +1,24 @@
+
+;;> Utilities for gathering statistics on the heap.  Just measuring
+;;> runtime memory usage doesn't give a good idea of how to optimize
+;;> that usage, so this module is provided for profiling.
+
+;;> \procedure{(heap-stats)}
+
+;;> Returns an alist summarizing all heap allocated objects.  The
+;;> \var{car} of each cell is the type-name, and the \var{cdr} is the
+;;> count of objects of that type in the heap.  Garbage is collected
+;;> before the counts are taken.
+
+;;> \procedure{(heap-dump [depth])}
+
+;;> Returns the same value as \scheme{(heap-stats)}, but also prints
+;;> all objects on the heap as it runs.  \var{depth} indicates the
+;;> printing depth for compound objects and defaults to 1.
+
+;;> These functions just return \scheme{'()} when using the Boehm GC.
+
+(define-library (chibi heap-stats)
+  (export heap-stats heap-dump)
+  (import (chibi))
+  (include-shared "heap-stats"))
diff --git a/lib/chibi/highlight.scm b/lib/chibi/highlight.scm
new file mode 100644
index 00000000..27878291
--- /dev/null
+++ b/lib/chibi/highlight.scm
@@ -0,0 +1,453 @@
+;; highlight.scm -- source code highlighting library
+;; Copyright (c) 2011 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> Library for highlighting source code in different
+;;> languages.  Currently supports Scheme, C and Assembly.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (string-concatenate-reverse ls)
+  (string-concatenate (reverse ls)))
+
+(define (reverse-list->string ls)
+  (list->string (reverse ls)))
+
+;;> Returns an sxml structure representing the code from source
+;;> with various language constructs wrapped in highlighting
+;;> forms.  \var{source} should be a string or port.  The
+;;> language to highlight for is auto-detected.
+
+(define (highlight source)
+  (let ((str (if (string? source) source (port->string source))))
+    ((highlighter-for (highlight-detect-language str)) str)))
+
+;;> Attempst to auto-detect which language \var{str} is code
+;;> for, and returns a symbol representing that language.
+
+(define (highlight-detect-language str)
+  (cond
+   ((protect (exn (else #f))
+      (call-with-input-string str
+        (lambda (in) (do ((x #f (read in))) ((eof-object? x)))))
+      #t)
+    'scheme)
+   (else
+    'c)))
+
+;;> Return a procedure for highlighting the given language.
+
+(define (highlighter-for language)
+  (case language
+    ((scheme) highlight-scheme)
+    ((asm) highlight-assembly)
+    ((none) (lambda (x) x))
+    (else highlight-c)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define highlight-themes
+  '((light
+     (keyword      . "#800080")
+     (type         . "#008000")
+     (function     . "#0000FF")
+     (variable     . "#B8860B")
+     (comment      . "#FF0000")
+     (string       . "#BC8F8F")
+     (attribute    . "#FF5000")
+     (preprocessor . "#FF00FF")
+     (builtin      . "#FF00FF")
+     (character    . "#0055AA")
+     (syntaxerror  . "#FF0000")
+     (diff-deleted . "#5F2121")
+     (diff-added   . "#215F21")
+     )))
+
+(define highlight-paren-styles
+  ;;'("#BAFFFF" "#FFCACA" "#FFFFBA" "#CACAFF" "#CAFFCA" "FFBAFF")
+  '("#AAAAAA" "#888888" "#666666" "#444444" "#222222" "#000000"))
+
+;;> Returns a string representing the CSS needed for the output
+;;> of \var{highlight}.  This should be included in a referenced
+;;> CSS file, or in a \var{<script>} section in the generated in
+;;> the generated HTML output.
+
+(define (highlight-style . theme)
+  (string-concatenate
+   (append
+    (map
+     (lambda (x)
+       (if (and (list? x) (= 3 (length x)))
+           (string-append
+            "." (symbol->string (car x)) " { color: " (cadr x)
+            "; background-color: " (car (cddr x)) "; }\n")
+           (string-append
+            "." (symbol->string (car x)) " { color: "
+            (if (pair? (cdr x)) (cadr x) (cdr x))
+            "; background-color: inherit; }\n")))
+     (cond ((assq (and (pair? theme) (car theme)) highlight-themes) => cdr)
+           (else (cdar highlight-themes))))
+    (map
+     (lambda (s i)
+       (string-append
+        ;;"span.paren" (number->string i)
+        ;;":hover { color: inherit; background-color: " s "; }\n"
+        "span.paren" (number->string i)
+        " { color: " s "; background-color: inherit; }\n"))
+     highlight-paren-styles
+     (cdr (iota (+ 1 (length highlight-paren-styles))))))))
+
+(define (highlight-class class x)
+  `(span (@ (class . ,class)) ,@(if (list? x) x (list x))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (read-whitespace in)
+  (let lp ((res '()))
+    (if (char-whitespace? (peek-char in))
+        (lp (cons (read-char in) res))
+        (reverse-list->string res))))
+
+(define (read-to-whitespace in res)
+  (let ((c (peek-char in)))
+    (cond
+     ((or (eof-object? c) (char-whitespace? c))
+      (reverse-list->string res))
+     (else
+      (read-to-whitespace in (cons (read-char in) res))))))
+
+(define (read-escaped in term ls)
+  (let ((c (read-char in)))
+    (cond
+     ((eof-object? c) (reverse-list->string ls))
+     ((eqv? c term) (reverse-list->string (cons c ls)))
+     ((eqv? c #\<) (read-escaped in term `(#\; #\t #\l #\& ,@ls)))
+     ;;((eqv? c #\>) (read-escaped in term `(#\; #\t #\g #\& ,@ls)))
+     ((eqv? c #\&) (read-escaped in term `(#\; #\p #\m #\a #\& ,@ls)))
+     ;;((eqv? c #\\) (read-escaped in term (cons (read-char in) (cons c ls))))
+     (else (read-escaped in term (cons c ls))))))
+
+(define (read-to-eol in ls)
+  (let ((c (read-char in)))
+    (cond
+     ((eof-object? c) (reverse-list->string ls))
+     ((eqv? c #\newline) (reverse-list->string (cons c ls)))
+     (else (read-to-eol in (cons c ls))))))
+
+(define (html-escape str)
+  (call-with-input-string str (lambda (in) (read-escaped in #f '()))))
+
+(define (collect str res)
+  (if (pair? str) (cons (reverse-list->string str) res) res))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (highlight-scheme-delimiter? ch)
+  (or (eof-object? ch)
+      (char-whitespace? ch)
+      (memq ch '(#\; #\# #\( #\) #\[ #\] #\{ #\} #\' #\` #\, #\"))))
+
+(define (highlight-scheme-definition? id)
+  (memq id '(define define-syntax define-module define-class
+             define-record define-record-type)))
+
+(define (highlight-scheme-syntax? id)
+  (memq id '(if lambda define set! cond case let let* letrec letrec*
+             let-values let-values* let-optionals let-optionals*
+             let-keywords let-keywords* and-let* rec receive do
+             loop rxmatch-cond rxmatch-case begin when unless
+             match match-lambda match-let match-let* dotimes dolist
+             quote quasiquote unquote unquote-splicing error errorf
+             define-syntax let-syntax letrec-syntax syntax-rules
+             syntax-case parameterize module library require
+             require-extension use use-modules import import-immutable
+             define-module select-module provide autoload export
+             only except rename prefix include include-shared
+             condition-case guard protect cond-expand for with to by
+             in-list in-lists in-string in-string-reverse
+             in-vector in-vector-reverse in-file listing appending
+             summing multpliying up-from down-from else
+             )))
+
+;;> Highlighter for Scheme source code.
+
+(define (highlight-scheme source)
+  (let ((in (if (string? source) (open-input-string source) source)))
+    (define (read-identifier ls)
+      (let ((c (peek-char in)))
+        (cond
+         ((highlight-scheme-delimiter? c)
+          (reverse-list->string ls))
+         (else
+          (read-char in)
+          (read-identifier (cons c ls))))))
+    (define (hash-mark)
+      (let ((c (read-char in)))
+        (case c
+          ((#\;)
+           (highlight-class "comment" (highlight 0 '(#\; #\#) '())))
+          ((#\\)
+           (highlight-class "string"
+                            (read-identifier (list (read-char in) #\\ #\#))))
+          (else
+           (string-append "#" (if (char? c) (string c) ""))))))
+    (define (highlight n str res)
+      (let ((c (read-char in)))
+        (if (eof-object? c)
+            (reverse (collect str res))
+            (case c
+              ((#\;)
+               (let lp ((ls '()))
+                 (let ((ls (cons (read-to-eol in (list #\;)) ls)))
+                   (cond
+                    ((eqv? #\; (peek-char in))
+                     (lp ls))
+                    (else
+                     (highlight n
+                                '()
+                                (cons (highlight-class
+                                       "comment"
+                                       (string-concatenate-reverse ls))
+                                      (collect str res))))))))
+              ((#\")
+               (let ((s (read-escaped in #\" (list #\"))))
+                 (highlight n
+                            '()
+                            (cons (highlight-class "string" s)
+                                  (collect str res)))))
+              ((#\()
+               ;;(highlight-start
+               ;; (string->symbol
+               ;;  (string-append
+               ;;   "paren"
+               ;;   (number->string
+               ;;    (+ 1 (modulo n (length highlight-paren-styles))))))
+               ;;out)
+               (let ((res (collect (cons #\( str) res)))
+                 (if (highlight-scheme-delimiter? (peek-char in))
+                     (highlight (+ n 1) '() res)
+                     (let* ((id (read-identifier '()))
+                            (sym (string->symbol id)))
+                       (cond
+                        ((highlight-scheme-definition? sym)
+                         (let* ((res (cons (highlight-class "keyword" id) res))
+                                (res (cons (read-whitespace in) res))
+                                (res (if (eqv? #\( (peek-char in))
+                                         (cons (string (read-char in)) res)
+                                         res)))
+                           (highlight
+                            (+ n 1)
+                            '()
+                            (cons
+                             (highlight-class "function" (read-identifier '()))
+                             res))))
+                        ((highlight-scheme-syntax? sym)
+                         (highlight (+ n 1)
+                                    '()
+                                    (cons (highlight-class "keyword" id) res)))
+                        (else
+                         (highlight (+ n 1) '() (cons id res))))))))
+              ((#\))
+               (cond
+                ((zero? n)
+                 (highlight n
+                            '()
+                            (cons (highlight-class "syntaxerror" ")")
+                                  (collect str res))))
+                (else
+                 ;;(highlight-end 'paren
+                 (highlight (- n 1) (cons c str) res))))
+              ((#\#)
+               (highlight n '() (cons (hash-mark) (collect str res))))
+              (else
+               (cond
+                ((highlight-scheme-delimiter? c)
+                 (highlight n (cons c str) res))
+                (else
+                 (let ((id (read-identifier (list c))))
+                   (highlight n '() (cons `(span ,id) (collect str res)))))))))))
+    (highlight 0 '() '())))
+
+(define (highlight-c-keyword? id)
+  (memq id '(asm break case catch const_cast continue default delete
+             do dynamic_cast else explicit export false for friend goto
+             if mutable namespace new operator private protected public
+             register reinterpret_cast return sizeof static_cast switch
+             template this throw true try typedef typeid typename using
+             virtual while)))
+
+(define (highlight-c-type? id)
+  (memq id '(auto bool char class const double enum extern float inline int long
+             short signed static struct union unsigned void volatile wchar_t
+             sexp sexp_uint_t sexp_sint_t)))
+
+;;> Highlighter for C source code.
+
+(define (highlight-c source)
+  (let ((in (if (string? source) (open-input-string source) source)))
+    (define (char-c-initial? c)
+      (and (char? c) (or (char-alphabetic? c) (eqv? c #\_) (eqv? c #\$))))
+    (define (char-c-identifier? c)
+      (and (char? c) (or (char-c-initial? c) (char-numeric? c))))
+    (define (read-identifier in ls)
+      (let ((c (peek-char in)))
+        (if (char-c-identifier? c)
+            (read-identifier in (cons (read-char in) ls))
+            (reverse-list->string ls))))
+    (define (highlight-identifier id)
+      (let ((sym (string->symbol id)))
+        (cond
+         ((highlight-c-keyword? sym)
+          (highlight-class "keyword" id))
+         ((highlight-c-type? sym)
+          (highlight-class "type" id))
+         (else
+          id))))
+    (define (highlight-line res)
+      (highlight
+       '()
+       (cond
+        ((eqv? #\# (peek-char in))
+         (read-char in)
+         (let* ((res (cons (read-whitespace in) (cons "#" res)))
+                (id (read-identifier in '()))
+                (res (cons (read-whitespace in)
+                           (cons (highlight-class "preprocessor" id) res))))
+           (case (string->symbol id)
+            ((define)
+             (cons (highlight-class "function" (read-to-whitespace in '())) res))
+            ((include import)
+             (cons (highlight-class "string" (read-to-whitespace in '())) res))
+            (else
+             res))))
+        ((char-c-initial? (peek-char in))
+         ;; line beginning w/ an identifier is probably a
+         ;; function declaration
+         (let ((id1 (read-identifier in '())))
+           (cond
+            ((eqv? #\: (peek-char in))
+             (cons (highlight-class "function" id1) res))
+            (else
+             (let lp ((decls '())
+                      (id id1))
+               (let ((space (read-whitespace in)))
+                 (cond
+                  ((char-c-initial? (peek-char in))
+                   (lp (cons space (cons id decls))
+                       (read-identifier in '())))
+                  ((eqv? #\( (peek-char in))
+                   `(,space
+                     ,(highlight-class "function" id)
+                     ,(highlight-class "type" (reverse decls))
+                     ,@res))
+                  (else
+                   `(,space ,id ,@decls ,@res)))))))))
+        (else
+         res))))
+    (define (highlight str res)
+      (let ((c (read-char in)))
+        (if (eof-object? c)
+            (reverse (collect str res))
+            (case c
+              ((#\/)
+               (case (peek-char in)
+                 ((#\/)
+                  (highlight
+                   '()
+                   (cons (highlight-class "comment" (read-to-eol in '(#\/ #\/)))
+                         (collect str res))))
+                 ((#\*)
+                  (let lp ((ls (cons (read-char in) '(#\/))))
+                    (let ((c (read-char in)))
+                      (if (not (and (eqv? (car ls) #\*) (eqv? c #\/)))
+                          (lp (cons c ls))
+                          (highlight
+                           '()
+                           (cons (highlight-class "comment"
+                                                  (reverse-list->string ls))
+                                 (collect str res)))))))
+                 (else
+                  (highlight (cons c str) res))))
+              ((#\" #\')
+               (let ((res (collect str res))
+                     (s (read-escaped in c (list c))))
+                 (highlight '() (cons (highlight-class "string" s) res))))
+              ((#\newline)
+               (highlight-line (collect (cons #\newline str) res)))
+              (else
+               (cond
+                ((char-c-initial? c)
+                 (highlight
+                  '()
+                  (cons
+                   (let ((id (read-identifier in (list c))))
+                     (if (eqv? #\: (peek-char in))
+                         (highlight-class "function" id)
+                         (highlight-identifier id)))
+                   (collect str res))))
+                (else
+                 (highlight (cons c str) res))))))))
+    (highlight-line '())))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> Highlighter for Assembly source code.
+
+(define (highlight-assembly source)
+  (let ((in (if (string? source) (open-input-string source) source)))
+    (define (char-asm-initial? c)
+      (and (char? c) (or (char-alphabetic? c) (memv c '(#\_ #\$ #\.)))))
+    (define (char-asm-identifier? c)
+      (and (char? c) (or (char-asm-initial? c) (char-numeric? c))))
+    (define (read-identifier in ls)
+      (let ((c (peek-char in)))
+        (if (char-asm-identifier? c)
+            (read-identifier (cons (read-char in) ls))
+            (reverse-list->string ls))))
+    (define (highlight str res)
+      (let ((c (read-char in)))
+        (cond
+         ((eof-object? c)
+          (reverse (collect str res)))
+         (else
+          (case c
+            ((#\newline)
+             (highlight-line (collect str res)))
+            ((#\")
+             (let ((s (read-escaped in c (list c))))
+               (highlight
+                '()
+                (cons (highlight-class "string" s) (collect str res)))))
+            ((#\%)
+             (highlight
+              '()
+              (cons (highlight-class "variable" (read-identifier in (list c)))
+                    (collect str res))))
+            ((#\;)
+             (highlight
+              '()
+              (cons (highlight-class "comment" (read-to-eol in (list c)))
+                    (collect str res))))
+            (else
+             (highlight (cons c str) res)))))))
+    (define (highlight-line res) 
+      (cond
+       ((eof-object? (peek-char in))
+        (highlight '() res))
+       ((char-asm-initial? (peek-char in))
+        (let ((id (read-identifier in '())))
+          (highlight
+           '()
+           (cons
+            (if (eqv? #\: (peek-char in))
+                (highlight-class "function" id)
+                (highlight-class "keyword" id))
+            res))))
+       ((eqv? #\tab (peek-char in))
+        (highlight
+         '()
+         (cons (highlight-class "keyword" (read-identifier in '()))
+               (cons "\t" res))))
+       (else
+        (highlight '() res))))
+    (highlight-line '())))
diff --git a/lib/chibi/highlight.sld b/lib/chibi/highlight.sld
new file mode 100644
index 00000000..0ab3fdb7
--- /dev/null
+++ b/lib/chibi/highlight.sld
@@ -0,0 +1,6 @@
+
+(define-library (chibi highlight)
+  (export highlight highlight-detect-language highlighter-for highlight-style
+          highlight-scheme highlight-c highlight-assembly)
+  (import (chibi) (srfi 1) (chibi io))
+  (include "highlight.scm"))
diff --git a/lib/chibi/io.sld b/lib/chibi/io.sld
new file mode 100644
index 00000000..1ee8ccbb
--- /dev/null
+++ b/lib/chibi/io.sld
@@ -0,0 +1,20 @@
+
+(define-library (chibi io)
+  (export read-string read-string! read-line write-line
+          port-fold port-fold-right port-map
+          port->list port->string-list port->sexp-list
+          port->string port->bytevector
+          file-position set-file-position! seek/set seek/cur seek/end
+          make-custom-input-port make-custom-output-port
+          make-custom-binary-input-port make-custom-binary-output-port
+          make-null-output-port make-null-input-port
+          make-broadcast-port make-concatenated-port
+          make-generated-input-port make-filtered-output-port
+          make-filtered-input-port string-count-chars
+          open-input-bytevector open-output-bytevector get-output-bytevector
+          string->utf8 utf8->string
+          write-string write-u8 read-u8 peek-u8 send-file
+          is-a-socket?)
+  (import (chibi) (chibi ast))
+  (include-shared "io/io")
+  (include "io/io.scm"))
diff --git a/lib/chibi/io/io.scm b/lib/chibi/io/io.scm
new file mode 100644
index 00000000..988dd670
--- /dev/null
+++ b/lib/chibi/io/io.scm
@@ -0,0 +1,395 @@
+;; io.scm -- various input/output utilities
+;; Copyright (c) 2010-2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utilities
+
+(define eof
+  (call-with-input-string " "
+    (lambda (in) (read-char in) (read-char in))))
+
+;; Copy whole characters from the given cursor positions.
+;; Return the src cursor position of the next unwritten char,
+;; which may be before `to' if the char would overflow.
+;; Now provided as a primitive from (chibi ast).
+;; (define (string-cursor-copy! dst start src from to)
+;;   (let lp ((i from)
+;;            (j (string-offset->index dst start)))
+;;     (let ((i2 (string-cursor-next src i)))
+;;       (cond ((> i2 to) i)
+;;             (else
+;;              (string-set! dst j (string-cursor-ref src i))
+;;              (lp i2 (+ j 1)))))))
+
+(define (utf8->string vec . o)
+  (if (pair? o)
+      (let ((start (car o))
+            (end (if (pair? (cdr o)) (cadr o) (bytevector-length vec))))
+        (utf8->string (subbytes vec start end)))
+      (string-copy (utf8->string! vec))))
+
+(define (string->utf8 str . o)
+  (if (pair? o)
+      (let ((start (car o))
+            (end (if (pair? (cdr o)) (cadr o) (string-length str))))
+        (string->utf8 (substring str start end)))
+      (%string->utf8 str)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; reading and writing
+
+;; Display \var{str} to the given output port, defaulting to
+;; \scheme{(current-output-port)}, followed by a newline.
+
+(define (write-line str . o)
+  (let ((out (if (pair? o) (car o) (current-output-port))))
+    (display str out)
+    (newline out)))
+
+;;> \procedure{(write-string str [out [start [end]]])}
+
+;;> Writes the characters from \var{start} to \var{end} of string
+;;> \var{str} to output port \var{out}, where \var{start} defaults
+;;> to 0 and \var{end} defaults to \scheme{(string-length \var{str})}.
+
+(define (write-string str . o)
+  (let ((out (if (pair? o) (car o) (current-output-port)))
+        (o (if (pair? o) (cdr o) o)))
+    (if (pair? o)
+        (let ((start (car o))
+              (end (if (pair? (cdr o)) (cadr o) (string-length str))))
+          (cond-expand
+           (string-streams
+            (if (zero? start)
+                (%write-string str end out)
+                (display (substring str start end) out)))
+           (else
+            (display (substring str start end) out))))
+        (display str out))))
+
+;;> \procedure{(read-line [in [n]])}
+
+;;> Read a line from the input port \var{in}, defaulting to
+;;> \scheme{(current-input-port)}, and return the result as
+;;> a string not including the newline.  Reads at most \var{n}
+;;> characters, defaulting to 8192.
+
+(cond-expand
+ ((not string-streams)
+  (define (%read-line n in)
+    (let ((out (open-output-string)))
+      (let lp ((i 0))
+        (let ((ch (peek-char in)))
+          (cond
+           ((eof-object? ch)
+            (let ((res (get-output-string out)))
+              (and (not (equal? res "")) res)))
+           ((eqv? ch #\newline)
+            (read-char in)
+            (get-output-string out))
+           ((eqv? ch #\return)
+            (read-char in)
+            (if (eqv? #\newline (peek-char in))
+                (read-char in))
+            (get-output-string out))
+           ((>= i n)
+            (get-output-string out))
+           (else
+            (write-char (read-char in) out)
+            (lp (+ i 1))))))))))
+
+(define (read-line . o)
+  (let ((in (if (pair? o) (car o) (current-input-port)))
+        (n (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) 8192)))
+    (let ((res (%read-line n in)))
+      (cond-expand
+       (string-streams
+        (port-line-set! in (+ 1 (port-line in)))))
+      (if (not res)
+          eof
+          (let ((len (string-length res)))
+            (cond
+             ((and (> len 0) (eqv? #\newline (string-ref res (- len 1))))
+              (if (and (> len 1) (eqv? #\return (string-ref res (- len 2))))
+                  (substring res 0 (- len 2))
+                  (substring res 0 (- len 1))))
+             ((and (> len 0) (eqv? #\return (string-ref res (- len 1))))
+              (substring res 0 (- len 1)))
+             (else
+              res)))))))
+
+;;> \procedure{(read-string n [in])}
+
+;;> Reads \var{n} characters from input-port \var{in},
+;;> defaulting to \scheme{(current-input-port)}, and
+;;> returns the result as a string.  Returns \scheme{""}
+;;> if \var{n} is zero.  May return a string with fewer
+;;> than \var{n} characters if the end of file is reached,
+;;> or the eof-object if no characters are available.
+
+(cond-expand
+ ((not string-streams)
+  (define (%read-string n in)
+    (let ((out (open-output-string)))
+      (let lp ((i 0))
+        (cond ((or (= i n) (eof-object? (peek-char in)))
+               (list i (get-output-string out)))
+              (else (write-char (read-char in) out) (lp (+ i 1)))))))))
+
+(define (read-string n . o)
+  (if (zero? n)
+      ""
+      (let ((in (if (pair? o) (car o) (current-input-port))))
+        (let ((res (%read-string n in)))
+          (cond
+           ((if (pair? res) (= 0 (car res)) #t)
+            eof)
+           (else
+            (port-line-set! in (+ (string-count-chars #\newline (cadr res) 0)
+                                  (port-line in)))
+            (cadr res)))))))
+
+;;> \procedure{(read-string! str n [in])}
+
+;;> Reads \var{n} characters from port \var{in}, which
+;;> defaults to \scheme{(current-input-port)}, and writes
+;;> them into the string \var{str} starting at index 0.
+;;> Returns the number of characters read.
+;;> An error is signalled if the length of \var{str} is smaller
+;;> than \var{n}.
+
+(cond-expand
+ ((not string-streams)
+  (define (%read-string! str n in)
+    (let lp ((i 0))
+      (cond ((or (= i n) (eof-object? (peek-char in))) i)
+            (else (string-set! str i (read-char in)) (lp (+ i 1))))))))
+
+(define (read-string! str n . o)
+  (if (> n (string-length str))
+      (error "string to small to read chars" str n))
+  (let* ((in (if (pair? o) (car o) (current-input-port)))
+         (res (%read-string! str n in)))
+    (port-line-set! in (+ (string-count-chars #\newline str 0 n) (port-line in)))
+    res))
+
+;;> Sends the entire contents of a file or input port to an output port.
+
+(define (send-file fd-port-or-filename . o)
+  (let* ((in (if (string? fd-port-or-filename)
+                 (open-input-file fd-port-or-filename)
+                 fd-port-or-filename))
+         (out (if (pair? o) (car o) (current-output-port)))
+         (fd (if (port? in) (port-fileno in) in))
+         (sock (if (port? out) (port-fileno out) out)))
+    (define (copy-bytes)
+      (let ((b (read-u8 in)))
+        (cond ((not (eof-object? b))
+               (write-u8 b out)
+               (copy-bytes)))))
+    (if (and fd sock (is-a-socket? sock))
+        (let lp ((start 0))
+          (let ((res (%send-file fd sock start)))
+            (cond
+             ((not res) (copy-bytes))
+             ((not (zero? res)) (lp (+ start res))))))
+        (copy-bytes))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; higher order port operations
+
+;;> The fundamental port iterator.
+
+(define (port-fold kons knil . o)
+  (let ((read (if (pair? o) (car o) read))
+        (in (if (and (pair? o) (pair? (cdr o)))
+                (car (cdr o))
+                (current-input-port))))
+    (let lp ((acc knil))
+      (let ((x (read in)))
+        (if (eof-object? x) acc (lp (kons x acc)))))))
+
+(define (port-fold-right kons knil . o)
+  (let ((read (if (pair? o) (car o) read))
+        (in (if (and (pair? o) (pair? (cdr o)))
+                (car (cdr o))
+                (current-input-port))))
+    (let lp ()
+      (let ((x (read in)))
+        (if (eof-object? x) knil (kons x (lp)))))))
+
+(define (port-map fn . o)
+  (reverse (apply port-fold (lambda (x ls) (cons (fn x) ls)) '() o)))
+
+(define (port->list read in)
+  (port-map (lambda (x) x) read in))
+
+(define (port->sexp-list in)
+  (port->list read in))
+
+(define (port->string-list in)
+  (port->list read-line in))
+
+(define (port->string in)
+  (string-concatenate (port->list (lambda (in) (read-string 1024 in)) in)))
+
+(define (port->bytevector in)
+  (let ((out (open-output-bytevector)))
+    (do ((c (read-u8 in) (read-u8 in)))
+        ((eof-object? c) (get-output-bytevector out))
+      (write-u8 c out))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; custom port utilities
+
+;;> \var{read} is a procedure of three arguments:
+;;> \scheme{(lambda (str start end) ...)} which should fill \var{str} from
+;;> \var{start} to \var{end} with bytes, returning the actual number
+;;> of bytes filled.
+
+(define (make-custom-input-port read . o)
+  (let ((seek (and (pair? o) (car o)))
+        (close (and (pair? o) (pair? (cdr o)) (car (cdr o)))))
+    (%make-custom-input-port read seek close)))
+
+;;> \var{write} is a procedure of three arguments:
+;;> \scheme{(lambda (str start end) ...)} which should write the bytes of
+;;> \var{str} from \var{start} to \var{end}, returning the actual
+;;> number of bytes written.
+
+(define (make-custom-output-port write . o)
+  (let ((seek (and (pair? o) (car o)))
+        (close (and (pair? o) (pair? (cdr o)) (car (cdr o)))))
+    (%make-custom-output-port write seek close)))
+
+;;> Similar to \scheme{make-custom-input-port} but returns a binary
+;;> port, and \var{read} receives a bytevector to fill instead of a
+;;> string.
+
+(define (make-custom-binary-input-port read . o)
+  (let ((seek (and (pair? o) (car o)))
+        (close (and (pair? o) (pair? (cdr o)) (car (cdr o)))))
+    (%make-custom-binary-input-port read seek close)))
+
+;;> Similar to \scheme{make-custom-output-port} but returns a binary
+;;> port, and \var{write} receives data from a bytevector instead of a
+;;> string.
+
+(define (make-custom-binary-output-port write . o)
+  (let ((seek (and (pair? o) (car o)))
+        (close (and (pair? o) (pair? (cdr o)) (car (cdr o)))))
+    (%make-custom-binary-output-port write seek close)))
+
+;;> A simple /dev/null port which accepts and does nothing with any
+;;> data written to it.
+
+(define (make-null-output-port)
+  (make-custom-output-port (lambda (str start end) 0)))
+
+;;> A port to broadcast everything written to it to multiple output
+;;> ports.
+
+(define (make-broadcast-port . ports)
+  (make-custom-output-port
+   (lambda (str start end)
+     (let ((str (if (zero? start) str (substring str start)))
+           (n (- end start)))
+       (for-each (lambda (p) (%write-string str n p)) ports)
+       n))))
+
+;;> An output port which runs all output (in arbitrary string chunks)
+;;> through the \var{filter} procedure.
+
+(define (make-filtered-output-port filter out)
+  (make-custom-output-port
+   (lambda (str start end)
+     (let* ((len (string-length str))
+            (s1 (if (and (zero? start) (= end len)) str (substring str start end)))
+            (s2 (filter s1)))
+       (if (string? s2)
+           (%write-string s2 (string-length s2) out))))))
+
+;;> An input port which acts as all of the \var{ports} concatenated
+;;> together in order.
+
+(define (make-concatenated-port . ports)
+  (make-custom-input-port
+   (lambda (str start end)
+     (if (null? ports)
+         0
+         (let ((str (if (zero? start) str (substring str start)))
+               (n (- end start)))
+           (let lp ((i (read-string! str n (car ports))))
+             (cond
+              ((>= i n)
+               i)
+              (else
+               (set! ports (cdr ports))
+               (cond
+                ((null? ports)
+                 i)
+                (else
+                 (let* ((s (read-string (- n i) (car ports)))
+                        (len (if (string? s) (string-length s) 0)))
+                   (if (and (string? str) (> len 0))
+                       (string-cursor-copy! str i s 0 len))
+                   (lp (+ i len)))))))))))))
+
+;;> A /dev/null input port which always returns \scheme{eof-object}.
+
+(define (make-null-input-port)
+  (make-concatenated-port))
+
+;;> A utility to represent a port generated in chunks by the thunk
+;;> \var{generator}, which should return a single string representing
+;;> the next input to buffer, or \scheme{#f} when there is no more
+;;> input.
+
+(define (make-generated-input-port generator)
+  (let ((buf "")
+        (len 0)
+        (offset 0))
+    (make-custom-input-port
+     (lambda (str start end)
+       (let ((n (- end start)))
+         (cond
+          ((>= (- len offset) n)
+           ;; buf contains enough to fill str
+           (let* ((offset2
+                   (string-cursor-copy! str start buf offset (+ offset n)))
+                  (end2 (+ (- offset2 offset) start)))
+             (set! offset offset2)
+             end2))
+          (else
+           ;; copy the rest of buf into str
+           (string-cursor-copy! str start buf offset len)
+           ;; i is the position to copy into str, from start to end
+           (let lp ((i (+ start (- len offset))))
+             (set! buf (generator))
+             (cond
+              ((not (string? buf))
+               (set! buf "")
+               (set! len 0)
+               (set! offset 0)
+               (+ i start))
+              (else
+               (set! len (string-size buf))
+               (cond
+                ((>= len (- n i))
+                 (let* ((offset2 (string-cursor-copy! str i buf 0 (- n i)))
+                        (end2 (+ i offset2)))
+                   (set! offset offset2)
+                   end2))
+                (else
+                 (let ((offset2 (string-cursor-copy! str i buf 0 len)))
+                   (lp (+ i offset2)))))))))))))))
+
+;;> An input port which runs all input (in arbitrary string chunks)
+;;> through the \var{filter} procedure.
+
+(define (make-filtered-input-port filter in)
+  (make-generated-input-port
+   (lambda ()
+     (let ((res (read-string 1024 in)))
+       (if (string? res) (filter res) res)))))
diff --git a/lib/chibi/io/io.stub b/lib/chibi/io/io.stub
new file mode 100644
index 00000000..1bb4871f
--- /dev/null
+++ b/lib/chibi/io/io.stub
@@ -0,0 +1,64 @@
+
+(cond-expand
+ (string-streams
+  (define-c non-null-string (%read-line "fgets")
+    ((result (array char arg1)) int (default (current-input-port) input-port)))
+
+  (define-c size_t (%read-string "fread")
+    ((result (array char (result arg2))) (value 1 size_t) size_t (default (current-input-port) input-port)))
+
+  (define-c size_t (%read-string! "fread")
+    (string (value 1 size_t) size_t (default (current-input-port) input-port)))
+  ))
+
+(c-include-verbatim "port.c")
+
+(define-c-const int (seek/set "SEEK_SET"))
+(define-c-const int (seek/cur "SEEK_CUR"))
+(define-c-const int (seek/end "SEEK_END"))
+
+;; (define-c off_t (file-position "ftell") (port))
+;; (define-c off_t (set-file-position! "fseek") (port off_t int))
+
+(define-c sexp (file-position "sexp_tell")
+  ((value ctx sexp) (value self sexp) sexp))
+(define-c sexp (set-file-position! "sexp_seek")
+  ((value ctx sexp) (value self sexp) sexp off_t int))
+
+(define-c boolean (is-a-socket? "sexp_is_a_socket_p") (fileno))
+
+(define-c errno (%send-file "sexp_send_file")
+  (fileno fileno off_t (default 0 off_t) (result off_t)))
+
+(define-c sexp (%make-custom-input-port "sexp_make_custom_input_port")
+  ((value ctx sexp) (value self sexp) sexp sexp sexp))
+
+(define-c sexp (%make-custom-output-port "sexp_make_custom_output_port")
+  ((value ctx sexp) (value self sexp) sexp sexp sexp))
+
+(define-c sexp (%make-custom-binary-input-port "sexp_make_custom_binary_input_port")
+  ((value ctx sexp) (value self sexp) sexp sexp sexp))
+
+(define-c sexp (%make-custom-binary-output-port "sexp_make_custom_binary_output_port")
+  ((value ctx sexp) (value self sexp) sexp sexp sexp))
+
+(define-c sexp (open-input-bytevector "sexp_open_input_bytevector")
+  ((value ctx sexp) (value self sexp) sexp))
+(define-c sexp (open-output-bytevector "sexp_open_output_bytevector")
+  ((value ctx sexp) (value self sexp)))
+(define-c sexp (get-output-bytevector "sexp_get_output_bytevector")
+  ((value ctx sexp) (value self sexp) sexp))
+
+(define-c sexp (string-count-chars "sexp_string_count")
+  ((value ctx sexp) (value self sexp) sexp sexp sexp (default NULL sexp)))
+(define-c sexp (%string->utf8 "sexp_string_to_utf8")
+  ((value ctx sexp) (value self sexp) sexp))
+(define-c sexp (utf8->string! "sexp_utf8_to_string_x")
+  ((value ctx sexp) (value self sexp) sexp))
+
+(define-c sexp (write-u8 "sexp_write_u8")
+  ((value ctx sexp) (value self sexp) sexp (default (current-output-port) sexp)))
+(define-c sexp (read-u8 "sexp_read_u8")
+  ((value ctx sexp) (value self sexp) (default (current-input-port) sexp)))
+(define-c sexp (peek-u8 "sexp_peek_u8")
+  ((value ctx sexp) (value self sexp) (default (current-input-port) sexp)))
diff --git a/lib/chibi/io/port.c b/lib/chibi/io/port.c
new file mode 100644
index 00000000..7e8b6812
--- /dev/null
+++ b/lib/chibi/io/port.c
@@ -0,0 +1,441 @@
+
+#include <stdio.h>
+#include <chibi/eval.h>
+
+#if SEXP_USE_SEND_FILE
+#include <sys/sendfile.h>
+#endif
+
+#define SEXP_LAST_CONTEXT_CHECK_LIMIT 256
+
+#define sexp_cookie_ctx(vec) sexp_vector_ref((sexp)vec, SEXP_ZERO)
+#define sexp_cookie_buffer(vec) sexp_vector_ref((sexp)vec, SEXP_ONE)
+#define sexp_cookie_read(vec) sexp_vector_ref((sexp)vec, SEXP_TWO)
+#define sexp_cookie_write(vec) sexp_vector_ref((sexp)vec, SEXP_THREE)
+#define sexp_cookie_seek(vec) sexp_vector_ref((sexp)vec, SEXP_FOUR)
+#define sexp_cookie_close(vec) sexp_vector_ref((sexp)vec, SEXP_FIVE)
+
+#define sexp_cookie_ctx_set(vec, x) sexp_vector_set((sexp)vec, SEXP_ZERO, x)
+#define sexp_cookie_buffer_set(vec, x) sexp_vector_set((sexp)vec, SEXP_ONE, x)
+#define sexp_cookie_read_set(vec, x) sexp_vector_set((sexp)vec, SEXP_TWO, x)
+#define sexp_cookie_write_set(vec, x) sexp_vector_set((sexp)vec, SEXP_THREE, x)
+#define sexp_cookie_seek_set(vec, x) sexp_vector_set((sexp)vec, SEXP_FOUR, x)
+#define sexp_cookie_close_set(vec, x) sexp_vector_set((sexp)vec, SEXP_FIVE, x)
+
+#if SEXP_USE_STRING_STREAMS
+#if ! SEXP_USE_BOEHM
+static int in_heap_p (sexp_heap h, sexp p) {
+  for ( ; h; h = h->next)
+    if (((sexp)h < p) && (p < (sexp)((char*)h + h->size)))
+      return 1;
+  return 0;
+}
+#endif
+
+static sexp sexp_last_context (sexp ctx, sexp *cstack) {
+  sexp res=SEXP_FALSE;
+#if ! SEXP_USE_BOEHM
+  sexp p;
+  sexp_sint_t i;
+  sexp_heap h = sexp_context_heap(ctx);
+  for (i=0; i<SEXP_LAST_CONTEXT_CHECK_LIMIT; i++) {
+    p = cstack[i];
+    if (p && (p != ctx) && sexp_pointerp(p) && in_heap_p(h, p)
+        && (sexp_pointer_tag(p) == SEXP_CONTEXT)
+        && (sexp_context_heap(p) == h)) {
+      res = p;
+      break;
+    }
+  }
+#endif
+  return res;
+}
+
+#if SEXP_BSD
+static int sexp_cookie_reader (void *cookie, char *buffer, int size)
+#else
+static ssize_t sexp_cookie_reader (void *cookie, char *buffer, size_t size)
+#endif
+{
+  sexp vec = (sexp)cookie, ctx, res;
+  if (! sexp_procedurep(sexp_cookie_read(vec))) return -1;
+  sexp_gc_var2(ctx2, args);
+  ctx = sexp_cookie_ctx(vec);
+  ctx2 = sexp_last_context(ctx, (sexp*)&cookie);
+  sexp_gc_preserve2(ctx, ctx2, args);
+  if (size > sexp_string_size(sexp_cookie_buffer(vec)))
+    sexp_cookie_buffer_set(vec, sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID));
+  args = sexp_list2(ctx, SEXP_ZERO, sexp_make_fixnum(size));
+  args = sexp_cons(ctx, sexp_cookie_buffer(vec), args);
+  res = sexp_apply(ctx, sexp_cookie_read(vec), args);
+  sexp_gc_release2(ctx);
+  if (sexp_fixnump(res)) {
+    memcpy(buffer, sexp_string_data(sexp_cookie_buffer(vec)), sexp_unbox_fixnum(res));
+    return sexp_unbox_fixnum(res);
+  } else {
+    return -1;
+  }
+}
+
+#if SEXP_BSD
+static int sexp_cookie_writer (void *cookie, const char *buffer, int size)
+#else
+static ssize_t sexp_cookie_writer (void *cookie, const char *buffer, size_t size)
+#endif
+{
+  sexp vec = (sexp)cookie, ctx, res;
+  if (! sexp_procedurep(sexp_cookie_write(vec))) return -1;
+  sexp_gc_var2(ctx2, args);
+  ctx = sexp_cookie_ctx(vec);
+  ctx2 = sexp_last_context(ctx, (sexp*)&cookie);
+  sexp_gc_preserve2(ctx, ctx2, args);
+  if (size > sexp_string_size(sexp_cookie_buffer(vec)))
+    sexp_cookie_buffer_set(vec, sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID));
+  memcpy(sexp_string_data(sexp_cookie_buffer(vec)), buffer, size);
+  args = sexp_list2(ctx, SEXP_ZERO, sexp_make_fixnum(size));
+  args = sexp_cons(ctx, sexp_cookie_buffer(vec), args);
+  res = sexp_apply(ctx, sexp_cookie_write(vec), args);
+  sexp_gc_release2(ctx);
+  return (sexp_fixnump(res) ? sexp_unbox_fixnum(res) : -1);
+}
+
+#if ! SEXP_BSD
+
+#ifdef __CYGWIN__
+#define off64_t off_t
+#endif
+
+static int sexp_cookie_seeker (void *cookie, off64_t *position, int whence) {
+  sexp vec = (sexp)cookie, ctx, res;
+  if (! sexp_procedurep(sexp_cookie_seek(vec))) return -1;
+  sexp_gc_var2(ctx2, args);
+  ctx = sexp_cookie_ctx(vec);
+  ctx2 = sexp_last_context(ctx, (sexp*)&cookie);
+  sexp_gc_preserve2(ctx, ctx2, args);
+  args = sexp_make_integer(ctx, *position);
+  args = sexp_list2(ctx, args, sexp_make_fixnum(whence));
+  res = sexp_apply(ctx, sexp_cookie_seek(vec), args);
+  if (sexp_fixnump(res))
+    *position = sexp_unbox_fixnum(res);
+  sexp_gc_release2(ctx);
+  return sexp_fixnump(res);
+}
+#endif  /* !SEXP_BSD */
+
+static int sexp_cookie_cleaner (void *cookie) {
+  sexp vec = (sexp)cookie, ctx, res;
+  if (! sexp_procedurep(sexp_cookie_close(vec))) return 0;
+  ctx = sexp_cookie_ctx(vec);
+  res = sexp_apply(ctx, sexp_cookie_close(vec), SEXP_NULL);
+  return (sexp_exceptionp(res) ? -1 : sexp_truep(res));
+}
+
+#if !SEXP_BSD
+
+static cookie_io_functions_t sexp_cookie = {
+  .read  = (cookie_read_function_t*)sexp_cookie_reader,
+  .write = (cookie_write_function_t*)sexp_cookie_writer,
+  .seek  = (cookie_seek_function_t*)sexp_cookie_seeker,
+  .close = (cookie_close_function_t*)sexp_cookie_cleaner,
+};
+
+static cookie_io_functions_t sexp_cookie_no_seek = {
+  .read  = (cookie_read_function_t*)sexp_cookie_reader,
+  .write = (cookie_write_function_t*)sexp_cookie_writer,
+  .seek  = NULL,
+  .close = (cookie_close_function_t*)sexp_cookie_cleaner,
+};
+
+#endif  /* !SEXP_BSD */
+
+static sexp sexp_make_custom_port (sexp ctx, sexp self, const char *mode,
+                                   sexp read, sexp write,
+                                   sexp seek, sexp close) {
+  FILE *in;
+  sexp res;
+  sexp_gc_var1(vec);
+  if (sexp_truep(read) && ! sexp_procedurep(read))
+    return sexp_type_exception(ctx, self, SEXP_PROCEDURE, read);
+  if (sexp_truep(write) && ! sexp_procedurep(write))
+    return sexp_type_exception(ctx, self, SEXP_PROCEDURE, write);
+  if (sexp_truep(seek) && ! sexp_procedurep(seek))
+    return sexp_type_exception(ctx, self, SEXP_PROCEDURE, seek);
+  if (sexp_truep(close) && ! sexp_procedurep(close))
+    return sexp_type_exception(ctx, self, SEXP_PROCEDURE, close);
+  sexp_gc_preserve1(ctx, vec);
+  vec = sexp_make_vector(ctx, SEXP_SIX, SEXP_VOID);
+  sexp_cookie_ctx_set(vec, ctx);
+  sexp_cookie_buffer_set(vec, sexp_make_string(ctx, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE), SEXP_VOID));
+  sexp_cookie_read_set(vec, read);
+  sexp_cookie_write_set(vec, write);
+  sexp_cookie_seek_set(vec, seek);
+  sexp_cookie_close_set(vec, close);
+#if SEXP_BSD
+  in = funopen(vec,
+               (sexp_procedurep(read) ? sexp_cookie_reader : NULL),
+               (sexp_procedurep(write) ? sexp_cookie_writer : NULL),
+               NULL, /* (sexp_procedurep(seek) ? sexp_cookie_reader : NULL), */
+               (sexp_procedurep(close) ? sexp_cookie_cleaner : NULL));
+#else
+  in = fopencookie(vec, mode, (sexp_truep(seek) ? sexp_cookie : sexp_cookie_no_seek));
+#endif
+  if (! in) {
+    res = sexp_user_exception(ctx, self, "couldn't make custom port", read);
+  } else {
+    res = sexp_make_input_port(ctx, in, SEXP_FALSE);
+    sexp_port_cookie(res) = vec;  /* for gc preserving */
+  }
+  if (mode && mode[0] == 'w')
+    sexp_pointer_tag(res) = SEXP_OPORT;
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+#else  /* ! SEXP_USE_STRING_STREAMS */
+
+static sexp sexp_make_custom_port (sexp ctx, sexp self,
+                                   const char *mode, sexp read, sexp write,
+                                   sexp seek, sexp close) {
+  sexp vec;
+  sexp_gc_var2(res, str);
+  sexp_gc_preserve2(ctx, res, str);
+  str = sexp_make_string(ctx, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE), SEXP_VOID);
+  if (sexp_exceptionp(str)) return str;
+  res = sexp_open_input_string(ctx, str);
+  if (sexp_exceptionp(res)) return res;
+  if (mode && mode[0] == 'w') {
+    sexp_pointer_tag(res) = SEXP_OPORT;
+    sexp_port_cookie(res) = str;
+  } else {
+    sexp_port_offset(res) = 0;
+    sexp_port_size(res) = 0;
+  }
+  vec = sexp_make_vector(ctx, SEXP_SIX, SEXP_VOID);
+  if (sexp_exceptionp(vec)) return vec;
+  sexp_vector_set(vec, SEXP_ZERO, SEXP_FALSE);
+  sexp_vector_set(vec, SEXP_ONE, sexp_port_cookie(res));
+  sexp_vector_set(vec, SEXP_TWO, read);
+  sexp_vector_set(vec, SEXP_THREE, write);
+  sexp_vector_set(vec, SEXP_FOUR, seek);
+  sexp_vector_set(vec, SEXP_FIVE, close);
+  sexp_port_cookie(res) = vec;
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+#endif
+
+sexp sexp_make_custom_input_port (sexp ctx, sexp self,
+                                  sexp read, sexp seek, sexp close) {
+  return sexp_make_custom_port(ctx, self, "r", read, SEXP_FALSE, seek, close);
+}
+
+sexp sexp_make_custom_output_port (sexp ctx, sexp self,
+                                   sexp write, sexp seek, sexp close) {
+  sexp res = sexp_make_custom_port(ctx, self, "w", SEXP_FALSE, write, seek, close);
+#if SEXP_USE_STRING_STREAMS
+  if (!sexp_exceptionp(res))
+    sexp_pointer_tag(res) = SEXP_OPORT;
+#endif
+  return res;
+}
+
+sexp sexp_make_custom_binary_input_port (sexp ctx, sexp self,
+                                         sexp read, sexp seek, sexp close) {
+  sexp res = sexp_make_custom_input_port(ctx, self, read, seek, close);
+  sexp_port_binaryp(res) = 1;
+  return res;
+}
+
+sexp sexp_make_custom_binary_output_port (sexp ctx, sexp self,
+                                          sexp write, sexp seek, sexp close) {
+  sexp res = sexp_make_custom_output_port(ctx, self, write, seek, close);
+  sexp_port_binaryp(res) = 1;
+  return res;
+}
+
+sexp sexp_bytes_to_string (sexp ctx, sexp vec) {
+  sexp res;
+#if SEXP_USE_PACKED_STRINGS
+  res = sexp_c_string(ctx, sexp_bytes_data(vec), sexp_bytes_length(vec));
+#else
+  res = sexp_alloc_type(ctx, string, SEXP_STRING);
+  sexp_string_bytes(res) = vec;
+  sexp_string_offset(res) = 0;
+  sexp_string_size(res) = sexp_bytes_length(vec);
+#endif
+  return res;
+}
+
+sexp sexp_open_input_bytevector (sexp ctx, sexp self, sexp vec) {
+  sexp_gc_var2(str, res);
+  sexp_assert_type(ctx, sexp_bytesp, SEXP_BYTES, vec);
+  sexp_gc_preserve2(ctx, str, res);
+  str = sexp_bytes_to_string(ctx, vec);
+  res = sexp_open_input_string(ctx, str);
+  sexp_port_binaryp(res) = 1;
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+sexp sexp_open_output_bytevector (sexp ctx, sexp self) {
+  sexp res = sexp_open_output_string(ctx);
+  sexp_port_binaryp(res) = 1;
+  return res;
+}
+
+sexp sexp_get_output_bytevector (sexp ctx, sexp self, sexp port) {
+  sexp_gc_var1(res);
+  sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, port);
+  if (!sexp_port_binaryp(port))
+    return sexp_xtype_exception(ctx, self, "not a binary port", port);
+  sexp_gc_preserve1(ctx, res);
+  res = sexp_get_output_string(ctx, port);
+  if (!sexp_exceptionp(res))
+    res = sexp_string_to_bytes(ctx, res);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_string_count (sexp ctx, sexp self, sexp ch, sexp str, sexp start, sexp end) {
+  const unsigned char *s, *e;
+  sexp_sint_t c, count = 0;
+#if SEXP_USE_UTF8_STRINGS
+  sexp_sint_t i;
+#endif
+  sexp_assert_type(ctx, sexp_charp, SEXP_CHAR, ch);
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, start);
+  if (sexp_not(end)) end = sexp_make_fixnum(sexp_string_size(str));
+  else sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, end);
+  c = sexp_unbox_character(ch);
+#if SEXP_USE_UTF8_STRINGS
+  if (c < 128) {
+#endif
+    s = (unsigned char*)sexp_string_data(str) + sexp_unbox_fixnum(start);
+    e = (unsigned char*)sexp_string_data(str) + sexp_unbox_fixnum(end);
+    if (e > (unsigned char*)sexp_string_data(str) + sexp_string_size(str))
+      return sexp_user_exception(ctx, self, "string-count: end index out of range", end);
+    /* fast case for ASCII chars */
+    while (s < e) if (*s++ == c) count++;
+#if SEXP_USE_UTF8_STRINGS
+  } else {
+    /* decode utf8 chars */
+    s = (unsigned char*)sexp_string_data(str);
+    for (i = sexp_unbox_fixnum(start); i < sexp_unbox_fixnum(end);
+         i += sexp_utf8_initial_byte_count(s[i]))
+      if (sexp_string_utf8_ref(ctx, str, sexp_make_fixnum(i)) == ch) count++;
+  }
+#endif
+  return sexp_make_fixnum(count);
+}
+
+sexp sexp_string_to_utf8 (sexp ctx, sexp self, sexp str) {
+  sexp res;
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
+  res = sexp_c_string(ctx, sexp_string_data(str), sexp_string_size(str));
+  return sexp_string_to_bytes(ctx, res);
+}
+
+/* TODO: add validation */
+sexp sexp_utf8_to_string_x (sexp ctx, sexp self, sexp vec) {
+  sexp_assert_type(ctx, sexp_bytesp, SEXP_BYTES, vec);
+  return sexp_bytes_to_string(ctx, vec);
+}
+
+sexp sexp_write_u8 (sexp ctx, sexp self, sexp u8, sexp out) {
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, u8);
+  if (sexp_unbox_fixnum(u8) < 0 || sexp_unbox_fixnum(u8) > 255)
+    return sexp_xtype_exception(ctx, self, "not a u8 value", u8);
+  sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out);
+  if (!sexp_port_binaryp(out))
+    return sexp_xtype_exception(ctx, self, "not a binary port", out);
+#if SEXP_USE_GREEN_THREADS
+  errno = 0;
+#endif
+  if (sexp_write_char(ctx, sexp_unbox_fixnum(u8), out) == EOF) {
+    if (sexp_port_stream(out))
+      clearerr(sexp_port_stream(out));
+#if SEXP_USE_GREEN_THREADS
+    if (errno == EAGAIN) {
+      if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER)))
+        sexp_apply2(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), out, SEXP_FALSE);
+      return sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR);
+    }
+#endif
+  }
+  return SEXP_VOID;
+}
+
+sexp sexp_read_u8 (sexp ctx, sexp self, sexp in) {
+  int c;
+  sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in);
+  if (!sexp_port_binaryp(in))
+    return sexp_xtype_exception(ctx, self, "not a binary port", in);
+#if SEXP_USE_GREEN_THREADS
+  errno = 0;
+#endif
+  c = sexp_read_char(ctx, in);
+#if SEXP_USE_GREEN_THREADS
+  if ((c == EOF)
+      && (errno == EAGAIN)) {
+    if (sexp_port_stream(in))
+      clearerr(sexp_port_stream(in));
+    if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER)))
+      sexp_apply2(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), in, SEXP_FALSE);
+    return sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR);
+  }
+#endif
+  if (c == '\n') sexp_port_line(in)++;
+  return (c==EOF) ? SEXP_EOF : sexp_make_fixnum(c);
+}
+
+sexp sexp_peek_u8 (sexp ctx, sexp self, sexp in) {
+  sexp res = sexp_read_u8(ctx, self, in);
+  if (sexp_fixnump(res))
+    sexp_push_char(ctx, sexp_unbox_fixnum(res), in);
+  return res;
+}
+
+int sexp_is_a_socket_p (int fd) {
+#if defined(PLAN9) || defined(_WIN32)
+  return 0;
+#else
+  struct stat statbuf;
+  fstat(fd, &statbuf);
+  return S_ISSOCK(statbuf.st_mode);
+#endif
+}
+
+sexp sexp_seek (sexp ctx, sexp self, sexp x, off_t offset, int whence) {
+  off_t res;
+  if (! (sexp_portp(x) || sexp_filenop(x)))
+    return sexp_type_exception(ctx, self, SEXP_IPORT, x);
+  if (sexp_filenop(x))
+    return sexp_make_integer(ctx, lseek(sexp_fileno_fd(x), offset, whence));
+  if (sexp_filenop(sexp_port_fd(x))) {
+    res = lseek(sexp_fileno_fd(sexp_port_fd(x)), offset, whence);
+    if (res >= 0 && !(whence == SEEK_CUR && offset == 0))
+      sexp_port_offset(x) = 0;
+    return sexp_make_integer(ctx, res);
+  }
+  if (sexp_stream_portp(x))
+    return sexp_make_integer(ctx, fseek(sexp_port_stream(x), offset, whence));
+  return sexp_xtype_exception(ctx, self, "not a seekable port", x);
+}
+
+sexp sexp_tell (sexp ctx, sexp self, sexp x) {
+  if (sexp_portp(x) && sexp_stream_portp(x))
+    return sexp_make_integer(ctx, ftell(sexp_port_stream(x)));
+  return sexp_seek(ctx, self, x, 0, SEEK_CUR);
+}
+
+int sexp_send_file (int fd, int s, off_t offset, off_t len, off_t* res) {
+#if SEXP_USE_SEND_FILE
+  *res = len;
+  return sendfile(fd, s, offset, res, NULL, 0);
+#else
+  *res = 0;
+  return 22; /* EINVAL */
+#endif
+}
diff --git a/lib/chibi/iset.sld b/lib/chibi/iset.sld
new file mode 100644
index 00000000..eb7e4763
--- /dev/null
+++ b/lib/chibi/iset.sld
@@ -0,0 +1,77 @@
+;; base.scm - base integer set operations
+;; Copyright (c) 2004-2012 Alex Shinn. All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;; An integer set (iset) is a set of exact integers optimized for
+;; minimal space usage and fast membership lookup.  General set
+;; operations are provided based on the character set operations found
+;; in SRFI-14.
+;;
+;; Creating isets:
+;;
+;; (make-iset)     ; an empty integer set
+;; (make-iset n)   ; a set of the single integer N
+;; (make-iset n m) ; a set of the range of all integers from N-M inclusive
+;;
+;; The following procedures are provided as direct analogs of the
+;; SRFI-14 procedures, accepting and returning isets and integers in
+;; place of char-sets and characters:
+;;
+;; Creating isets:
+;;
+;; (iset-copy is)            ; a new copy of IS
+;; (iset n ...)              ; an iset containing the elements N...
+;; (list->iset ls [base-is]) ; an iset containing all the integers in
+;;                           ; list LS, union BASE-IS if provided
+;; (list->iset! ls base-is)  ; same as above, allowed but not required to
+;;                           ; modify base-is
+;;
+;; Querying isets:
+;;
+;; (iset-size is)          ; return the # of elements in IS
+;; (iset-contains? is n)   ; test N for membership in IS
+;; (iset->list is)         ; returns a list of all integers in IS
+;;
+;; Predicates:
+;;
+;; (iset? obj)     ; #t iff obj is an integer set
+;; (iset= is ...)  ; #t iff all arguments are equivalent integer sets
+;; (iset<= is ...) ; #t iff the arguments are monotonically increasing sets
+;; (iset>= is ...) ; #t iff the arguments are monotonically decreasing sets
+;;
+;; Cursors:
+;;
+;; (iset-cursor iset)
+;; (iset-ref iset cursor)
+;; (iset-cursor-next iset cursor)
+;; (end-of-iset? iset)
+;;
+;; Set operations:
+;;
+;; (iset-adjoin is n ...)         ; char-set-adjoin
+;; (iset-delete is n ...)         ; char-set-delete
+;;
+;; (iset-adjoin! is n ...)        ; char-set-adjoin!
+;; (iset-delete! is n ...)        ; char-set-delete!
+;;
+;; (iset-union is1 ...)                  ; char-set-union
+;; (iset-intersection is1 ...)           ; char-set-intersection
+;; (iset-difference is1 is2 ...)         ; char-set-difference
+;;
+;; (iset-union! is1 ...)                 ; char-set-union!
+;; (iset-intersection! is1 ...)          ; char-set-intersection!
+;; (iset-difference! is1 is2 ...)        ; char-set-difference!
+
+(define-library (chibi iset)
+  (import (chibi iset base)
+          (chibi iset iterators)
+          (chibi iset constructors))
+  (export
+   %make-iset make-iset iset? iset-contains? Integer-Set
+   iset iset-copy list->iset list->iset! iset-map
+   iset-adjoin iset-adjoin! iset-delete iset-delete!
+   iset-union iset-union! iset-intersection iset-intersection!
+   iset-difference iset-difference!
+   iset-empty? iset-fold iset-fold-node iset-for-each iset-for-each-node
+   iset-map iset->list iset-size iset= iset<= iset>=
+   iset-cursor iset-cursor? iset-cursor-next iset-ref end-of-iset?))
diff --git a/lib/chibi/iset/base.scm b/lib/chibi/iset/base.scm
new file mode 100644
index 00000000..5f917ddc
--- /dev/null
+++ b/lib/chibi/iset/base.scm
@@ -0,0 +1,32 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; The most basic set interface.  We provide a data type, low-level
+;; constructor, and membership test.  This allows libraries to provide
+;; an iset API without needing to include the full iset library.
+
+(define-record-type Integer-Set
+  (%make-iset start end bits left right)
+  iset?
+  (start iset-start iset-start-set!)
+  (end   iset-end   iset-end-set!)
+  (bits  iset-bits  iset-bits-set!)
+  (left  iset-left  iset-left-set!)
+  (right iset-right iset-right-set!))
+
+(define (make-iset . opt)
+  (if (null? opt)
+      (%make-iset 0 0 0 #f #f)
+      (let ((end (if (pair? (cdr opt)) (cadr opt) (car opt))))
+        (%make-iset (car opt) end #f #f #f))))
+
+(define (iset-contains? iset n)
+  (let lp ((is iset))
+    (let ((start (iset-start is)))
+      (if (< n start)
+          (let ((left (iset-left is))) (and left (lp left)))
+          (let ((end (iset-end is)))
+            (if (> n end)
+                (let ((right (iset-right is))) (and right (lp right)))
+                (let ((bits (iset-bits is)))
+                  (or (not bits)
+                      (bit-set? (- n start) bits)))))))))
diff --git a/lib/chibi/iset/base.sld b/lib/chibi/iset/base.sld
new file mode 100644
index 00000000..28c3eefc
--- /dev/null
+++ b/lib/chibi/iset/base.sld
@@ -0,0 +1,8 @@
+
+(define-library (chibi iset base)
+  (import (chibi) (srfi 9) (srfi 33))
+  (include "base.scm")
+  (export
+   %make-iset make-iset iset? iset-contains? Integer-Set
+   iset-start iset-end iset-bits iset-left iset-right
+   iset-start-set! iset-end-set! iset-bits-set! iset-left-set! iset-right-set!))
diff --git a/lib/chibi/iset/constructors.scm b/lib/chibi/iset/constructors.scm
new file mode 100644
index 00000000..6c09d553
--- /dev/null
+++ b/lib/chibi/iset/constructors.scm
@@ -0,0 +1,284 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Utilities for constructing and joining isets.
+
+(define bits-thresh 128)  ; within 128 we join into a bitmap
+;;(define bits-max 512)     ; don't make bitmaps larger than this
+
+(define (bit-set n index)
+  (bitwise-ior n (arithmetic-shift 1 index)))
+
+(define (bit-clear n index)
+  (if (bit-set? index n)
+      (- n (arithmetic-shift 1 index))
+      n))
+
+(define (iset . args)
+  (list->iset args))
+
+(define (list->iset! ls iset)
+  (for-each (lambda (i) (iset-adjoin1! iset i)) ls)
+  iset)
+
+(define (list->iset ls . opt)
+  (list->iset! ls (if (pair? opt) (iset-copy (car opt)) (make-iset))))
+
+(define (iset-copy iset)
+  (and iset
+       (%make-iset
+        (iset-start iset)
+        (iset-end iset)
+        (iset-bits iset)
+        (iset-copy (iset-left iset))
+        (iset-copy (iset-right iset)))))
+
+(define (iset-copy-node iset)
+  (%make-iset (iset-start iset) (iset-end iset) (iset-bits iset) #f #f))
+
+(define (iset-max-end iset)
+  (cond ((iset-right iset) => iset-max-end)
+        (else (iset-end iset))))
+
+(define (iset-min-start iset)
+  (cond ((iset-left iset) => iset-min-start)
+        (else (iset-start iset))))
+
+(define (iset-insert-left! iset new)
+  (let ((left (iset-left iset)))
+    (if (and left (< (iset-end new) (iset-start left)))
+        (iset-right-set! new left)
+        (iset-left-set! new left)))
+  (iset-left-set! iset new))
+
+(define (iset-insert-right! iset new)
+  (let ((right (iset-right iset)))
+    (if (and right (< (iset-end new) (iset-start right)))
+        (iset-right-set! new right)
+        (iset-left-set! new right)))
+  (iset-right-set! iset new))
+
+(define (range->bits start end)
+  (- (arithmetic-shift 1 (+ 1 (- end start))) 1))
+
+(define (iset-squash-bits! iset)
+  (let ((bits (iset-bits iset)))
+    (if (and bits (= bits (range->bits (iset-start iset) (iset-end iset))))
+        (iset-bits-set! iset #f))))
+
+(define (iset-should-merge-left? a b)
+  (and (< (- (iset-start a) (iset-end b))
+          bits-thresh)
+       (or (not (iset-left a))
+           (> (iset-start b) (iset-max-end (iset-left a))))))
+
+(define (iset-should-merge-right? a b)
+  (and (< (- (iset-start b) (iset-end a))
+          bits-thresh)
+       (or (not (iset-right a))
+           (< (iset-end b) (iset-min-start (iset-right a))))))
+
+(define (iset-merge-left! a b)
+  (if (or (iset-bits a) (iset-bits b)
+          (< (+ 1 (iset-end b)) (iset-start a)))
+      (let* ((a-bits (or (iset-bits a)
+                         (range->bits (iset-start a) (iset-end a))))
+             (b-bits (or (iset-bits b)
+                         (range->bits (iset-start b) (iset-end b))))
+             (shift (- (iset-start a) (iset-start b)))
+             (bits (bitwise-ior b-bits (arithmetic-shift a-bits shift))))
+        (iset-bits-set! a bits)))
+  (iset-start-set! a (iset-start b)))
+
+(define (iset-merge-right! a b)
+  (if (or (iset-bits a) (iset-bits b)
+          (< (+ 1 (iset-end a)) (iset-start b)))
+      (let* ((a-bits (or (iset-bits a)
+                         (range->bits (iset-start a) (iset-end a))))
+             (b-bits (or (iset-bits b)
+                         (range->bits (iset-start b) (iset-end b))))
+             (shift (- (iset-start b) (iset-start a)))
+             (bits (bitwise-ior a-bits (arithmetic-shift b-bits shift))))
+        (iset-bits-set! a bits)))
+  (iset-end-set! a (iset-end b)))
+
+(define (iset-adjoin1! is n)
+  (iset-adjoin-node! is (%make-iset n n #f #f #f)))
+
+;; adjoin just the node b (ignoring left/right) to the full iset a
+(define (iset-adjoin-node! a b)
+  (cond
+   ((iset-empty? a)
+    (iset-start-set! a (iset-start b))
+    (iset-end-set! a (iset-end b))
+    (iset-bits-set! a (iset-bits b)))
+   ((not (iset-empty? b))
+    (let ((a-start (iset-start a))
+          (a-end (iset-end a))
+          (a-bits (iset-bits a))
+          (b-start (iset-start b))
+          (b-end (iset-end b))
+          (b-bits (iset-bits b)))
+      (cond
+       ;;         aaaa...
+       ;; ...bbbb
+       ((<= b-end a-start)
+        (if (iset-should-merge-left? a b)
+            (iset-merge-left! a b)
+            (iset-adjoin-node-left! a b)))
+       ;; ...aaaa
+       ;;         bbbb...
+       ((>= b-start a-end)
+        (if (iset-should-merge-right? a b)
+            (iset-merge-right! a b)
+            (iset-adjoin-node-right! a b)))
+       ;; ...aaaaa...
+       ;;  ...bb...
+       ((and (>= b-start a-start) (<= b-end a-end))
+        (if a-bits
+            (let ((b-bits (arithmetic-shift
+                           (or b-bits (range->bits b-start b-end))
+                           (- b-start a-start))))
+              (iset-bits-set! a (bitwise-ior a-bits b-bits))
+              (iset-squash-bits! a))))
+       (else
+        ;; general case: split, recurse, join sides
+        (let ((ls (iset-node-split b a-start a-end)))
+          (if (car ls)
+              (iset-adjoin-node-left! a (car ls)))
+          (iset-adjoin-node! a (cadr ls))
+          (if (car (cddr ls))
+              (iset-adjoin-node-right! a (car (cddr ls)))))))))))
+
+(define (iset-adjoin-node-left! iset node)
+  (if (iset-left iset)
+      (iset-adjoin-node! (iset-left iset) node)
+      (iset-left-set! iset node)))
+
+(define (iset-adjoin-node-right! iset node)
+  (if (iset-right iset)
+      (iset-adjoin-node! (iset-right iset) node)
+      (iset-right-set! iset node)))
+
+;; start and/or end are inside the node, split into:
+;;   1. node before start, if any
+;;   2. node between start and end
+;;   3. node after end, if any
+(define (iset-node-split node start end)
+  (list (and (< (iset-start node) start)
+             (iset-node-extract node (iset-start node) (- start 1)))
+        (iset-node-extract node start end)
+        (and (> (iset-end node) end)
+             (iset-node-extract node (+ end 1) (iset-end node)))))
+
+(define (iset-node-extract node start end)
+  (cond
+   ((iset-bits node)
+    => (lambda (node-bits)
+         (let* ((bits
+                 (bitwise-and
+                  (arithmetic-shift node-bits (- (iset-start node) start))
+                  (range->bits start end)))
+                (new-end (min end (+ start (integer-length bits)))))
+           (%make-iset start new-end bits #f #f))))
+   (else
+    (%make-iset (max start (iset-start node))
+                (min end (iset-end node))
+                #f #f #f))))
+
+(define (iset-adjoin! iset . ls)
+  (list->iset! ls iset))
+
+(define (iset-adjoin iset . ls)
+  (list->iset ls iset))
+
+;; delete directly in this node
+(define (%iset-delete1! iset n)
+  (let ((start (iset-start iset))
+        (end (iset-end iset))
+        (bits (iset-bits iset)))
+    (cond
+     (bits
+      (iset-bits-set! iset (bit-clear bits (- n start))))
+     ((= n start)
+      (if (= n end)
+          (iset-bits-set! iset 0)
+          (iset-start-set! iset (+ n 1))))
+     ((= n end)
+      (iset-end-set! iset (- n 1)))
+     (else
+      (iset-end-set! iset (- n 1))
+      (iset-insert-right! iset (make-iset (+ n 1) end))))))
+
+(define (iset-delete1! iset n)
+  (let lp ((is iset))
+    (let ((start (iset-start is)))
+      (if (< n start)
+          (let ((left (iset-left is)))
+            (if left (lp left)))
+          (let ((end (iset-end is)))
+            (if (> n end)
+                (let ((right (iset-right is)))
+                  (if right (lp right)))
+                (%iset-delete1! is n)))))))
+
+(define (iset-delete! iset . args)
+  (for-each (lambda (i) (iset-delete1! iset i)) args)
+  iset)
+
+(define (iset-delete iset . args)
+  (apply iset-delete! (iset-copy iset) args))
+
+(define (iset-map proc iset)
+  (iset-fold (lambda (i is) (iset-adjoin! is (proc i))) (make-iset) iset))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; High-level set operations.
+;;
+;; Union is optimized to work at the node level.  Intersection and
+;; difference iterate over individual elements and so have a lot of
+;; room for improvement, at the expense of the complexity of
+;; iset-adjoin-node!.
+
+(define (iset-union2! a b)
+  (iset-for-each-node
+   (lambda (is)
+     (iset-adjoin-node! a is))
+   b))
+
+(define (iset-union! . args)
+  (let* ((a (and (pair? args) (car args)))
+         (b (and (pair? args) (pair? (cdr args)) (cadr args))))
+    (cond
+     (b
+      (iset-union2! a b)
+      (apply iset-union! a (cddr args)))
+     (a a)
+     (else (make-iset)))))
+
+(define (iset-union . args)
+  (if (null? args)
+    (make-iset)
+    (apply iset-union! (iset-copy (car args)) (cdr args))))
+
+(define (iset-intersection! a . args)
+  (let ((b (and (pair? args) (car args))))
+    (cond
+     (b
+      (iset-for-each
+       (lambda (i) (if (not (iset-contains? b i)) (iset-delete1! a i)))
+       a)
+      (apply iset-intersection! a (cdr args)))
+     (else a))))
+
+(define (iset-intersection a . args)
+  (apply iset-intersection! (iset-copy a) args))
+
+(define (iset-difference! a . args)
+  (if (null? args)
+      a
+      (begin
+        (iset-for-each (lambda (i) (iset-delete1! a i)) (car args))
+        (apply iset-difference! a (cdr args)))))
+
+(define (iset-difference a . args)
+  (apply iset-difference! (iset-copy a) args))
diff --git a/lib/chibi/iset/constructors.sld b/lib/chibi/iset/constructors.sld
new file mode 100644
index 00000000..c0f82117
--- /dev/null
+++ b/lib/chibi/iset/constructors.sld
@@ -0,0 +1,11 @@
+
+(define-library (chibi iset constructors)
+  (import (chibi) (srfi 33) (chibi iset base) (chibi iset iterators))
+  (include "constructors.scm")
+  (export
+   iset iset-copy list->iset list->iset! iset-map
+   iset-adjoin iset-adjoin! iset-delete iset-delete!
+   iset-union iset-union! iset-intersection iset-intersection!
+   iset-difference iset-difference!
+   ;; low-level
+   iset-copy-node iset-squash-bits! iset-insert-left! iset-insert-right!))
diff --git a/lib/chibi/iset/iterators.scm b/lib/chibi/iset/iterators.scm
new file mode 100644
index 00000000..2814a969
--- /dev/null
+++ b/lib/chibi/iset/iterators.scm
@@ -0,0 +1,173 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Cursors
+
+(define (iset-empty? iset)
+  (and (iset? iset)
+       (cond ((iset-bits iset) => zero?) (else #f))
+       (let ((l (iset-left iset))) (or (not l) (iset-empty? l)))
+       (let ((r (iset-right iset))) (or (not r) (iset-empty? r)))))
+
+(define-record-type Iset-Cursor
+  (make-iset-cursor node pos stack)
+  iset-cursor?
+  (node iset-cursor-node iset-cursor-node-set!)
+  (pos iset-cursor-pos iset-cursor-pos-set!)
+  (stack iset-cursor-stack iset-cursor-stack-set!))
+
+;; Create a new iset cursor pointing to the first element of iset,
+;; with an optional stack argument.
+(define (%iset-cursor iset . o)
+  (iset-cursor-advance
+   (make-iset-cursor iset
+                     (or (iset-bits iset) (iset-start iset))
+                     (if (pair? o) (car o) '()))))
+
+(define (iset-cursor iset . o)
+  (let ((stack (if (pair? o) (car o) '())))
+    (if (iset-left iset)
+        (iset-cursor (iset-left iset) (cons iset stack))
+        (%iset-cursor iset stack))))
+
+;; Continue to the next node in the search stack.
+(define (iset-cursor-pop cur)
+  (let ((node (iset-cursor-node cur))
+        (stack (iset-cursor-stack cur)))
+    (cond
+     ((iset-right node)
+      (iset-cursor (iset-right node) stack))
+     ((pair? stack)
+      (%iset-cursor (car stack) (cdr stack)))
+     (else
+      cur))))
+
+;; Advance to the next node+pos that can be referenced if at the end
+;; of this node's range.
+(define (iset-cursor-advance cur)
+  (let ((node (iset-cursor-node cur))
+        (pos (iset-cursor-pos cur)))
+    (cond
+     ((if (iset-bits node) (zero? pos) (> pos (iset-end node)))
+      (iset-cursor-pop cur))
+     (else cur))))
+
+(define (iset-cursor-next iset cur)
+  (iset-cursor-advance
+   (let ((node (iset-cursor-node cur))
+         (pos (iset-cursor-pos cur))
+         (stack (iset-cursor-stack cur)))
+     (let ((pos (if (iset-bits node) (bitwise-and pos (- pos 1)) (+ pos 1))))
+       (make-iset-cursor node pos stack)))))
+
+(define (iset-ref iset cur)
+  (let ((node (iset-cursor-node cur))
+        (pos (iset-cursor-pos cur)))
+    (cond
+     ((iset-bits node)
+      (if (zero? pos)
+          (error "cursor reference past end of iset")
+          (+ (iset-start node)
+             (integer-length (- pos (bitwise-and pos (- pos 1))))
+             -1)))
+     (else
+      (if (> pos (iset-end node))
+          (error "cursor reference past end of iset")
+          pos)))))
+
+(define (end-of-iset? cur)
+  (let ((node (iset-cursor-node cur)))
+    (and (if (iset-bits node)
+             (zero? (iset-cursor-pos cur))
+             (> (iset-cursor-pos cur) (iset-end node)))
+         (not (iset-right node))
+         (null? (iset-cursor-stack cur)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Equality
+
+(define (iset2= is1 is2)
+  (let lp ((cur1 (iset-cursor is1))
+           (cur2 (iset-cursor is2)))
+    (cond ((end-of-iset? cur1) (end-of-iset? cur2))
+          ((end-of-iset? cur2) #f)
+          ((= (iset-ref is1 cur1) (iset-ref is2 cur2))
+           (lp (iset-cursor-next is1 cur1) (iset-cursor-next is2 cur2)))
+          (else
+           #f))))
+
+(define (iset2<= is1 is2)
+  (let lp ((cur1 (iset-cursor is1))
+           (cur2 (iset-cursor is2)))
+    (cond ((end-of-iset? cur1))
+          ((end-of-iset? cur2) #f)
+          (else
+           (let ((i1 (iset-ref is1 cur1))
+                 (i2 (iset-ref is1 cur2)))
+             (cond ((> i1 i2)
+                    (lp cur1 (iset-cursor-next is2 cur2)))
+                   ((= i1 i2)
+                    (lp (iset-cursor-next is1 cur1)
+                        (iset-cursor-next is2 cur2)))
+                   (else
+                    ;; (< i1 i2) - i1 won't occur in is2
+                    #f)))))))
+
+(define (iset= . o)
+  (or (null? o)
+      (let lp ((a (car o)) (ls (cdr o)))
+        (or (null? ls) (and (iset2= a (car ls)) (lp (car ls) (cdr ls)))))))
+
+(define (iset<= . o)
+  (or (null? o)
+      (let lp ((a (car o)) (ls (cdr o)))
+        (or (null? ls) (and (iset2<= a (car ls)) (lp (car ls) (cdr ls)))))))
+
+(define (iset>= . o)
+  (apply iset<= (reverse o)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Folding
+
+(define (iset-fold-node kons knil iset)
+  (let lp ((is iset) (acc knil))
+    (let* ((left (iset-left is))
+           (acc (kons is (if left (lp left acc) acc)))
+           (right (iset-right is)))
+      (if right (lp right acc) acc))))
+
+(define (iset-fold kons knil iset)
+  (iset-fold-node
+   (lambda (is acc)
+     (let ((start (iset-start is))
+           (end (iset-end is))
+           (bits (iset-bits is)))
+       (if bits
+           (let ((limit (+ 1 (- end start))))
+             (do ((n1 bits n2)
+                  (n2 (bitwise-and bits (- bits 1)) (bitwise-and n2 (- n2 1)))
+                  (acc acc (kons (+ start (integer-length (- n1 n2)) -1) acc)))
+                 ((zero? n1) acc)))
+           (do ((i start (+ i 1))
+                (acc acc (kons i acc)))
+               ((> i end) acc)))))
+   knil
+   iset))
+
+(define (iset-for-each-node proc iset)
+  (iset-fold-node (lambda (node acc) (proc node)) #f iset))
+
+(define (iset-for-each proc iset)
+  (iset-fold (lambda (i acc) (proc i)) #f iset))
+
+(define (iset->list iset)
+  (reverse (iset-fold cons '() iset)))
+
+(define (iset-size iset)
+  (iset-fold-node
+   (lambda (is acc)
+     (let ((bits (iset-bits is)))
+       (+ acc (if bits
+                  (bit-count bits)
+                  (+ 1 (- (iset-end is) (iset-start is)))))))
+   0
+   iset))
diff --git a/lib/chibi/iset/iterators.sld b/lib/chibi/iset/iterators.sld
new file mode 100644
index 00000000..f6abc637
--- /dev/null
+++ b/lib/chibi/iset/iterators.sld
@@ -0,0 +1,9 @@
+
+(define-library (chibi iset iterators)
+  (import (chibi) (srfi 9) (srfi 33) (chibi iset base))
+  (include "iterators.scm")
+  (export
+   iset-empty? iset-fold iset-fold-node iset-for-each iset-for-each-node
+   iset->list iset-size iset= iset<= iset>=
+   ;; low-level cursors
+   iset-cursor iset-cursor? iset-cursor-next iset-ref end-of-iset?))
diff --git a/lib/chibi/iset/optimize.scm b/lib/chibi/iset/optimize.scm
new file mode 100644
index 00000000..ad10bf0b
--- /dev/null
+++ b/lib/chibi/iset/optimize.scm
@@ -0,0 +1,170 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Optimizing Iset Representation
+
+(define (iset-balance iset)
+  (and iset
+       (let ((nodes '()))
+         (iset-for-each-node
+          (lambda (is) (set! nodes (cons (iset-copy-node is) nodes)))
+          iset)
+         (let reduce ((nodes (reverse nodes)))
+           (let ((len (length nodes)))
+             (case len
+               ((0) #f)
+               ((1) (car nodes))
+               (else
+                (let ((mid (quotient len 2)))
+                  (let lp ((i 0) (ls nodes) (left '()))
+                    (if (= i mid)
+                        (let ((res (car ls)))
+                          (iset-left-set! res (reduce (reverse left)))
+                          (iset-right-set! res (reduce (cdr ls)))
+                          res)
+                        (lp (+ i 1) (cdr ls) (cons (car ls) left))))))))))))
+
+(define (iset-balance! iset)
+  (iset-balance iset))
+
+;; remove leading 0's in bits before squashing
+(define (iset-trim-and-squash-bits! is)
+  (if (iset-bits is)
+      (let ((end (iset-end is)))
+        (let lp ((bits (iset-bits is))
+                 (start (iset-start is)))
+          (cond
+           ((zero? bits)
+            (iset-start-set! is start)
+            (iset-bits-set! is 0))
+           ((>= start end)
+            (iset-start-set! is start)
+            (iset-bits-set! is #f)
+            (if (even? (arithmetic-shift bits -1))
+                (iset-end-set! is start)))
+           ((even? bits)
+            (lp (arithmetic-shift bits -1) (+ start 1)))
+           (else
+            (iset-start-set! is start)
+            (iset-bits-set! is bits))))))
+  (iset-squash-bits! is)
+  is)
+
+;; overwrite a node in place
+(define (iset-set-node! a b)
+  (iset-start-set! a (iset-start b))
+  (iset-end-set! a (iset-end b))
+  (iset-bits-set! a (iset-bits b)))
+
+;; safe to insert left since we've already visited all left nodes
+(define (iset-node-replace! is nodes)
+  (cond
+   ((pair? nodes)
+    (iset-set-node! is (car nodes))
+    (let loop ((is is) (ls (cdr nodes)))
+      (cond
+       ((pair? ls)
+        (iset-insert-left! is (car ls))
+        (loop (iset-left is) (cdr ls))))))))
+
+;; compact a list of consecutive bit ranges for an iset
+(define (iset-node-split-ranges! is ranges)
+  (let ((start (iset-start is))
+        (end (iset-end is))
+        (bits (iset-bits is)))
+    (let lp ((ls (reverse ranges)) (nodes '()) (last 0))
+      (if (pair? ls)
+          (let ((lo (caar ls)) (hi (cdar ls)))
+            (lp (cdr ls)
+                (cons (make-iset (+ start lo) (+ start hi -1))
+                      (if (< last lo) ;; trailing bit range
+                          (cons (iset-trim-and-squash-bits!
+                                 (%make-iset
+                                  (+ start last)
+                                  (+ start lo -1)
+                                  (extract-bit-field (- lo last) last bits)
+                                  #f
+                                  #f))
+                                nodes)
+                          nodes))
+                hi))
+          (let ((nodes
+                 (if (< (+ start last) end) ;; trailing bit range
+                     (cons (iset-trim-and-squash-bits!
+                            (%make-iset (+ start last)
+                                        end
+                                        (arithmetic-shift bits (- last))
+                                        #f
+                                        #f))
+                           nodes)
+                     nodes)))
+            (iset-node-replace! is nodes))))))
+
+;; Compact bit ranges of long consecutive chars in a single node into
+;; ranges.  Loop over the bits, and convert any consecutive bit
+;; patterns longer than span into new start/end nodes.
+(define (iset-optimize-node! is span)
+  (iset-squash-bits! is)
+  (let* ((bits (iset-bits is))
+         (len (and bits (integer-length bits))))
+    (cond
+     (bits
+      (letrec
+          ((full  ;; in a full bit range from [since..i)
+            (lambda (i since ranges)
+              (cond
+               ((or (>= i len) (not (bit-set? i bits)))
+                ;; if the current span is long enough, push to ranges
+                (if (>= (- i since) span)
+                    (sparse (+ i 1) (cons (cons since i) ranges))
+                    (sparse (+ i 1) ranges)))
+               (else
+                (full (+ i 1) since ranges)))))
+           (sparse  ;; [i-1] is not set
+            (lambda (i ranges)
+              (cond
+               ((>= i len)
+                ;; done - if there are any ranges to compact, do so
+                (if (pair? ranges)
+                    (iset-node-split-ranges! is ranges)))
+               ((bit-set? i bits)
+                (full (+ i 1) i ranges))
+               (else
+                (sparse (+ i 1) ranges))))))
+        (sparse 0 '()))))))
+
+;; Remove empty nodes.
+(define (%iset-prune! is)
+  (cond
+   ((not is)
+    #f)
+   (else
+    (iset-left-set! is (%iset-prune! (iset-left is)))
+    (iset-right-set! is (%iset-prune! (iset-right is)))
+    (if (and (eq? 0 (iset-bits is))
+             (not (iset-left is))
+             (not (iset-right is)))
+        #f
+        is))))
+
+(define (iset-prune! is)
+  (or (%iset-prune! is) (iset)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (iset-optimize! is . opt)
+  (let ((span (if (pair? opt) (car opt) (* 40 8)))
+        (is (iset-prune! is)))
+    (iset-for-each-node (lambda (node) (iset-optimize-node! node span)) is)
+    (iset-prune! is)))
+
+(define (iset-optimize iset . opt)
+  (apply iset-optimize! (iset-copy iset) opt))
+
+;; write an efficient expression which evaluates to the iset
+(define (iset->code iset)
+  (and iset
+       `(%make-iset ,(iset-start iset)
+                    ,(iset-end iset)
+                    ,(iset-bits iset)
+                    ,(iset->code (iset-left iset))
+                    ,(iset->code (iset-right iset)))))
diff --git a/lib/chibi/iset/optimize.sld b/lib/chibi/iset/optimize.sld
new file mode 100644
index 00000000..e9165a00
--- /dev/null
+++ b/lib/chibi/iset/optimize.sld
@@ -0,0 +1,9 @@
+
+(define-library (chibi iset optimize)
+  (import (chibi) (srfi 9) (srfi 33)
+          (chibi iset base)
+          (chibi iset iterators)
+          (chibi iset constructors))
+  (include "optimize.scm")
+  (export
+   iset-balance iset-balance! iset-optimize iset-optimize! iset->code))
diff --git a/lib/chibi/log.scm b/lib/chibi/log.scm
new file mode 100644
index 00000000..4768d7c1
--- /dev/null
+++ b/lib/chibi/log.scm
@@ -0,0 +1,232 @@
+;; log.scm -- customizable logging with levels
+;; Copyright (c) 2005-2013 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define-record-type Logger
+  (make-logger levels level-abbrevs current-level prefix prefix-spec
+               counts file port locked? zipped?)
+  logger?
+  (levels logger-levels logger-levels-set!)
+  (level-abbrevs logger-level-abbrevs logger-level-abbrevs-set!)
+  (current-level logger-current-level %logger-current-level-set!)
+  (prefix logger-prefix %logger-prefix-set!)
+  (prefix-spec logger-prefix-spec logger-prefix-spec-set!)
+  (counts logger-counts logger-counts-set!)
+  (file logger-file logger-file-set!)
+  (port logger-port logger-port-set!)
+  (locked? logger-locked? logger-locked?-set!)
+  (zipped? logger-zipped? logger-zipped?-set!))
+
+(define (logger-prefix-set! logger prefix)
+  (%logger-prefix-set! logger (log-compile-prefix prefix))
+  (logger-prefix-set! logger prefix))
+
+(define (logger-current-level-set! logger level)
+  (%logger-current-level-set! logger (log-level-index logger level)))
+
+(define-syntax define-logger
+  (syntax-rules ()
+    ((define-logger logger (levels ...))
+     (def-logger logger (levels ...) log-default-prefix 0 () ()))))
+
+(define-syntax def-logger
+  (syntax-rules ()
+    ((def-logger logger ((#f name) . rest) prefix n (names ...) defs)
+     (def-logger logger rest prefix (+ n 1) (names ... name) defs))
+    ((def-logger logger ((level name) . rest) prefix n (names ...) (defs ...))
+     (def-logger logger rest prefix (+ n 1)
+       (names ... name)
+       (defs ...
+         (define-syntax level
+           (syntax-rules ()
+             ((level . args)
+              (if (<= n (logger-current-level logger))
+                  (log-show logger n . args))))))))
+    ((def-logger logger ((level name . x) . rest) . y)
+     (syntax-error "bad logger level: " (level name . x)))
+    ((def-logger logger (level . rest) prefix n names defs)
+     (def-logger logger ((level (log-normalize-name 'level)) . rest)
+       prefix n names defs))
+    ((def-logger logger () prefix n (names ...) (defs ...))
+     (begin
+       defs ...
+       (define logger
+         (let ((names-vec (vector names ...)))
+           (make-logger
+            names-vec
+            (log-generate-abbrevs names-vec)
+            n
+            (log-compile-prefix prefix)
+            prefix
+            '() #f (current-error-port) #f #f)))))))
+
+(define (log-normalize-name name)
+  (let ((str (symbol->string name)))
+    (if (string-prefix? "log-" str)
+        (string->symbol (substring str 4))
+        name)))
+
+(define (log-level-index logger level)
+  (if (integer? level)
+      level
+      (let ((len (vector-length (logger-levels logger))))
+        (let lp ((i 0))
+          (cond
+           ((= i len)
+            (error "unknown log level" (logger-levels logger) level))
+           ((eq? level (vector-ref (logger-levels logger) i)) i)
+           (else (lp (+ i 1))))))))
+
+(define (log-level-name logger level)
+  (cond
+   ((symbol? level)
+    level)
+   ((< level (vector-length (logger-levels logger)))
+    (vector-ref (logger-levels logger) level))
+   (else
+    (let ((len (vector-length (logger-levels logger))))
+      (string->symbol
+      (string-append
+       (symbol->string (vector-ref (logger-levels logger) (- len 1)))
+       "-" (number->string (- level len))))))))
+
+(define (log-level-abbrev logger level)
+  (cond
+   ((symbol? level)
+    (log-level-abbrev logger (log-level-index logger level)))
+   ((< level (vector-length (logger-level-abbrevs logger)))
+    (vector-ref (logger-level-abbrevs logger) level))
+   (else
+    (number->string level))))
+
+(define (log-generate-abbrevs abbrevs)
+  (let* ((len (vector-length abbrevs))
+         (res (make-vector len)))
+    (do ((i 0 (+ i 1)))
+        ((= i len) res)
+      (let ((name (symbol->string (vector-ref abbrevs i))))
+        (vector-set! res i (string (char-upcase (string-ref name 0))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; procedural interface
+
+(define (log-generate-output logger level args)
+  (let ((prefix ((logger-prefix logger) logger level))
+        (message (show #f (each-in-list args))))
+    (string-append
+     prefix
+     (string-concatenate (string-split message #\newline)
+                         (string-append "\n" prefix))
+     "\n")))
+
+(define (log-compile-prefix spec)
+  (define (pad2 n)
+    (if (< n 10)
+        (string-append "0" (number->string n))
+        (number->string n)))
+  (define (log-compile-one-prefix x)
+    (if (string? x)
+        (lambda (lg time level) x)
+        (case x
+          ((year)
+           (lambda (lg time level) (number->string (+ 1900 (time-year time)))))
+          ((month) (lambda (lg time level) (pad2 (+ 1 (time-month time)))))
+          ((day) (lambda (lg time level) (pad2 (time-day time))))
+          ((hour) (lambda (lg time level) (pad2 (time-hour time))))
+          ((minute) (lambda (lg time level) (pad2 (time-minute time))))
+          ((second) (lambda (lg time level) (pad2 (time-second time))))
+          ((level)
+           (lambda (lg time level) (symbol->string (log-level-name lg level))))
+          ((level-abbrev)
+           (lambda (lg time level) (log-level-abbrev lg level)))
+          ((pid) (lambda (lg time level) (number->string (current-process-id))))
+          ((uid) (lambda (lg time level) (number->string (current-group-id))))
+          ((gid) (lambda (lg time level) (number->string (current-user-id))))
+          (else (error "unknown logging spec" x)))))
+  (let ((procs (map log-compile-one-prefix spec)))
+    (lambda (logger level)
+      (let ((time (seconds->time (current-seconds))))
+        (let lp ((ls procs) (res '()))
+          (if (null? ls)
+              (string-concatenate (reverse res))
+              (lp (cdr ls) (cons ((car ls) logger time level) res))))))))
+
+(define log-default-prefix
+  '(year "-" month "-" day " " hour ":" minute ":" second " " level-abbrev " "))
+
+(define (log-open logger . o)
+  (if (pair? o)
+      (logger-file-set! logger (car o)))
+  (if (string? (logger-file logger))
+      (let ((fd (open (logger-file logger)
+                      (+ open/create open/write open/append open/non-block))))
+        (logger-port-set! logger (open-output-file-descriptor fd)))
+      (logger-port-set! logger (current-error-port))))
+
+(define (log-close logger)
+  (if (output-port? (logger-port logger))
+      (close-output-port (logger-port logger))))
+
+;; Use file-locking to let multiple processes write to the same log
+;; file.  On error try to re-open the log file.  We keep the port open
+;; so that even if you mv the file (e.g. when rotating logs) we keep
+;; writing to it in the new location.  To force writing to a new file
+;; in the original location, use cp+rm instead of mv, so that the
+;; logging will error and try to re-open.
+(define (log-show logger level . args)
+  (cond
+   ((<= level (logger-current-level logger))
+    (let ((str (log-generate-output logger level args)))
+      (let lp ((first? #t))
+        (let ((out (logger-port logger)))
+          (protect (exn
+                    (else
+                     (cond
+                      (first?  ; try to re-open log-file once
+                       (log-close logger)
+                       (log-open logger)
+                       (lp #f))
+                      (else    ; fall back to stderr
+                       (display str (current-error-port))))))
+            (let ((locked? (and (logger-locked? logger)
+                                (output-port? out)
+                                (file-lock out lock/exclusive))))
+              ;; this is redundant with POSIX O_APPEND
+              ;; (set-file-position! out 0 seek/end)
+              (display str out)
+              (flush-output out)
+              (if locked? (file-lock out lock/unlock))))))))))
+
+(define (log-show-every-n logger level id n . args)
+  (cond
+   ((assq id (logger-counts logger))
+    => (lambda (cell)
+         (if (zero? (modulo (cdr cell) n))
+             (apply log-show logger level args))))
+   (else
+    (logger-counts-set! logger (cons (cons id 0) (logger-counts logger)))
+    (apply log-show logger level args))))
+
+;; http://httpd.apache.org/docs/2.2/mod/core.html#loglevel
+
+(define-logger default-logger
+  (log-emergency ; the server is on fire!!!           
+   log-alert     ; couldn't write to user mailbox     
+   log-critical  ; couldn't run 'dig' executable      
+   log-error     ; error loading user filter          
+   log-warn      ; invalid smtp command; relay failed 
+   log-notice    ; saved to file/relayed to address   
+   log-info      ; loaded alias file                  
+   log-debug))   ; spam-probability: 0.5
+
+(define-syntax with-logged-errors
+  (syntax-rules ()
+    ((with-logged-errors . body)
+     (protect (exn (else (log-error exn)))
+       . body))))
+
+(define-syntax with-logged-and-reraised-errors
+  (syntax-rules ()
+    ((with-logged-errors . body)
+     (protect (exn (else (log-error exn) (raise exn)))
+       . body))))
diff --git a/lib/chibi/log.sld b/lib/chibi/log.sld
new file mode 100644
index 00000000..08f7b11b
--- /dev/null
+++ b/lib/chibi/log.sld
@@ -0,0 +1,26 @@
+
+(define-library (chibi log)
+  (export
+   ;; Logger record
+   Logger logger?
+   logger-levels logger-levels-set!
+   logger-level-abbrevs logger-level-abbrevs-set!
+   logger-current-level logger-current-level-set!
+   logger-prefix logger-prefix-set!
+   logger-counts logger-counts-set!
+   logger-file logger-file-set!
+   logger-port logger-port-set!
+   logger-locked? logger-locked?-set!
+   logger-zipped? logger-zipped?-set!
+   ;; syntax
+   define-logger with-logged-errors with-logged-and-reraised-errors
+   ;; procedural interface
+   log-open log-close log-show log-show-every-n log-compile-prefix
+   ;; levels introspection
+   log-level-index log-level-name log-level-abbrev
+   ;; the default logger
+   default-logger log-emergency log-alert log-critical log-error
+   log-warn log-notice log-info log-debug)
+  (import (chibi) (srfi 9) (chibi time) (chibi process) (chibi system)
+          (chibi filesystem) (chibi string) (chibi show base))
+  (include "log.scm"))
diff --git a/lib/chibi/loop.sld b/lib/chibi/loop.sld
new file mode 100644
index 00000000..fd5c2fe5
--- /dev/null
+++ b/lib/chibi/loop.sld
@@ -0,0 +1,9 @@
+
+(define-library (chibi loop)
+  (export loop in-list in-lists in-port in-file up-from down-from
+          listing listing-reverse appending appending-reverse
+          summing multiplying in-string in-string-reverse
+          in-vector in-vector-reverse)
+  (import (chibi))
+  (include "loop/loop.scm"))
+
diff --git a/lib/chibi/loop/loop.scm b/lib/chibi/loop/loop.scm
new file mode 100644
index 00000000..44ec3418
--- /dev/null
+++ b/lib/chibi/loop/loop.scm
@@ -0,0 +1,417 @@
+;;;; loop.scm - the chibi loop (aka foof-loop)
+;;
+;; Copyright (c) 2009-2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> The loop API is mostly compatible with Taylor Campbell's
+;;> \hyperlink["http://mumble.net/~campbell/scheme/foof-loop.txt"]{foof-loop},
+;;> but the iterator API is different and subject to change.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (assoc-pred equal elt ls)
+  (and (pair? ls)
+       (if (equal elt (car (car ls)))
+           (car ls)
+           (assoc-pred equal elt (cdr ls)))))
+
+(define-syntax let-keyword-form
+  (syntax-rules ()
+    ((let-keyword-form
+      ((labeled-arg-macro-name (positional-name . params)))
+      . body)
+     (let-syntax
+         ((labeled-arg-macro-name
+           (er-macro-transformer
+            (lambda (expr rename compare)
+              (let lp ((ls (cdr expr)) (named '()) (posns '()))
+                (cond
+                 ((pair? ls)
+                  (if (and (list? (car ls)) (compare (caar ls) (rename '=>)))
+                      (lp (cdr ls) (cons (cdar ls) named) posns)
+                      (lp (cdr ls) named (cons (car ls) posns))))
+                 (else
+                  (let lp ((ls (syntax-quote params))
+                           (posns (reverse posns))
+                           (args '()))
+                    (cond
+                     ((null? ls)
+                      (if (pair? posns)
+                          (error "let-keyword-form: too many args" expr)
+                          (cons (syntax-quote positional-name) (reverse args))))
+                     ((assoc-pred compare (caar ls) named)
+                      => (lambda (x) (lp (cdr ls) posns (cons (cadr x) args))))
+                     ((pair? posns)
+                      (lp (cdr ls) (cdr posns) (cons (car posns) args)))
+                     (else
+                      (lp (cdr ls) posns (cons (car (cdar ls)) args))))))))))))
+       . body))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> \subsubsubsection{\scheme{(loop [name] (vars ...) [=> result] body ...)}}
+
+(define-syntax loop
+  (syntax-rules ()
+    ;; unnamed, implicit recursion
+    ((loop (vars ...) body ...)
+     (%loop tmp-loop () () () () () (vars ...) body ... (tmp-loop)))
+    ;; named, explicit recursion
+    ((loop name (vars ...) body ...)
+     (%loop name () () () () () (vars ...) body ...))))
+
+;; Main LOOP macro. Separate the variables from the iterator and
+;; parameters, then walk through each parameter expanding the
+;; bindings, and build the final form.
+
+(define-syntax %loop
+  (syntax-rules (=> for with let while until)
+    ;; automatic iteration
+    ((_ name l v c r f ((for var1 (iterator source ...)) rest ...) . body)
+     (iterator ((var1) (source ...)) %loop-next name l v c r f (rest ...) . body))
+    ((_ name l v c r f ((for var1 var2 (iterator source ...)) rest ...) . body)
+     (iterator ((var1 var2) (source ...)) %loop-next name l v c r f (rest ...) . body))
+    ((_ name l v c r f ((for var1 var2 var3 (iterator source ...)) rest ...) . body)
+     (iterator ((var1 var2 var3) (source ...)) %loop-next name l v c r f (rest ...) . body))
+    ((_ name l v c r f ((for var1 var2 var3 var4 (iterator source ...)) rest ...) . body)
+     (iterator ((var1 var2 var3 var4) (source ...)) %loop-next name l v c r f (rest ...) . body))
+    ;; do equivalents, with optional guards
+    ((_ name l (vars ...) (checks ...) r f ((with var init step guard) rest ...) . body)
+     (%loop name l (vars ... (var init step)) (checks ... (guard var)) r f (rest ...) . body))
+    ((_ name l (vars ...) c r f ((with var init step) rest ...) . body)
+     (%loop name l (vars ... (var init step)) c r f (rest ...) . body))
+    ((_ name l (vars ...) c r f ((with var init) rest ...) . body)
+     (%loop name l (vars ... (var init var)) c r f (rest ...) . body))
+    ;; user-specified terminators
+    ((_ name l vars (checks ...) r f ((until expr) rest ...) . body)
+     (%loop name l vars (checks ... expr) r f (rest ...) . body))
+    ((_ name l vars (checks ...) r f ((while expr) rest ...) . body)
+     (%loop name l vars (checks ... (not expr)) r f (rest ...) . body))
+    ;; specify a default done?
+    ((_ name l v c r f ())
+     (%loop name l v c r f () (#f #f)))
+    ((_ name l v c r f () () . body)
+     (%loop name l v c r f () (#f #f) . body))
+    ;; final expansion
+    ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
+        => result
+        . body)
+     (let* (lets ...)
+       (letrec ((tmp (lambda (var ...)
+                       (if (or checks ...)
+                           (let-keyword-form ((name (tmp (var step) ...)))
+                             (let (finals ...) result))
+                           (let (refs ...)
+                             (let-keyword-form ((name (tmp (var step) ...)))
+                               (if #f #f)
+                               . body))))))
+         (tmp init ...))))
+    ;; unspecified return value case
+    ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
+        . body)
+     (%loop name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
+            => (if #f #f) . body))
+    ))
+
+(define-syntax %loop-next
+  (syntax-rules ()
+    ((_ (new-lets ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...)
+        name (lets ...) (vars ...) (checks ...) (refs ...) (finals ...)
+        . rest)
+     (%loop name (lets ... new-lets ...) (vars ... new-vars ...)
+                 (checks ... new-checks ...) (refs ... new-refs ...)
+                 (finals ... new-finals ...)
+        . rest))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;> \section{Iterators}
+
+;; Each gets passed two lists, those items left of the macro and those to
+;; the right, followed by a NEXT and REST continuation.
+;;
+;; Should finish with
+;;
+;; \schemeblock{
+;;  (next (outer-vars ...) (cursor-vars ...) (done?-tests ...)
+;;        (loop-vars ...) (final-vars ...) . rest)
+;; }
+;;
+;; \itemlist[
+;; \item{\var{outer-vars} - bound once outside the loop in a LET*}
+;; \item{\var{cursor-vars} - DO-style bindings of the form (name init update)}
+;; \item{\var{done?-tests} - possibly empty list of forms that terminate the loop on #t}
+;; \item{\var{loop-vars} - inner variables, updated in parallel after the cursors}
+;; \item{\var{final-vars} - final variables, bound only in the => result}
+;; ]
+
+;;> \subsubsubsection{\scheme{(for var [pair] (in-list ls [cdr]))}}
+
+;;> Basic list iterator.
+
+(define-syntax in-list                  ; called just "IN" in ITER
+  (syntax-rules ()
+    ((in-list ((var) source) next . rest)
+     (in-list ((var cursor) source) next . rest))
+    ((in-list ((var cursor) source) next . rest)
+     (in-list ((var cursor succ) source) next . rest))
+    ((in-list ((var cursor succ) (source)) next . rest)
+     (next ()                         ; outer let bindings
+           ((cursor source succ))     ; iterator, init, step
+           ((not (pair? cursor)))     ; finish tests for iterator vars
+           ;; step variables and values
+           ((var (car cursor))
+            (succ (cdr cursor)))
+           ()                           ; final result bindings
+           . rest))
+    ((in-list ((var cursor succ) (source step)) next . rest)
+     (next ()
+           ((cursor source succ))
+           ((not (pair? cursor)))
+           ((var (car cursor))
+            (succ (step cursor)))
+           ()
+           . rest))))
+
+;;> \macro{(for elts [pairs] (in-lists lol [cdr [done?]]))}
+
+;;> Iterator from Taylor R. Campbell.  If you know the number of lists
+;;> ahead of time it's much more efficient to iterate over each one
+;;> separately.
+
+(define-syntax in-lists
+  (syntax-rules ()
+    ((in-lists ((elts) lol) next . rest)
+     (in-lists ((elts pairs) lol) next . rest))
+    ((in-lists ((elts pairs) lol) next . rest)
+     (in-lists ((elts pairs succ) lol) next . rest))
+    ((in-lists ((elts pairs succ) (lol)) next . rest)
+     (in-lists ((elts pairs succ) (lol cdr)) next . rest))
+    ((in-lists ((elts pairs succ) (lol)) next . rest)
+     (in-lists ((elts pairs succ) (lol cdr)) next . rest))
+    ((in-lists ((elts pairs succ) (lol step)) next . rest)
+     (in-lists ((elts pairs succ) (lol step null?)) next . rest))
+    ((in-lists ((elts pairs succ) (lol step done?)) next . rest)
+     (next ()
+           ((pairs lol succ))
+           ((let lp ((ls pairs)) ; an in-lined ANY
+              (and (pair? ls) (if (done? (car ls)) #t (lp (cdr ls))))))
+           ((elts (map car pairs))
+            (succ (map step pairs)))
+           ()
+           . rest))
+    ))
+
+(define-syntax define-in-indexed
+  (syntax-rules ()
+    ((define-in-indexed in-type in-type-reverse length ref)
+     (begin
+       (define-syntax in-type
+         (syntax-rules ()
+           ((in-type seq next . rest)
+            (%in-idx >= (lambda (x i) (+ i 1)) (lambda (x) 0) length ref tmp seq next . rest))))
+       (define-syntax in-type-reverse
+         (syntax-rules ()
+           ((in-type-reverse seq next . rest)
+            (%in-idx < (lambda (x i) (- i 1)) (lambda (x) (- (length x) 1)) (lambda (x) 0) ref tmp seq next . rest))))
+       ))))
+
+;;> \macro{(for var [index] (in-vector vec))}
+;;> \macro{(for var [index] (in-vector-reverse vec))}
+
+(define-in-indexed in-vector in-vector-reverse vector-length vector-ref)
+
+;;> \macro{(for ch [cursor] (in-string str))}
+
+(define-syntax in-string
+  (syntax-rules ()
+    ((in-string s next . rest)
+     (%in-idx string-cursor>=? string-cursor-next
+              string-cursor-start string-cursor-end string-cursor-ref
+              tmp s next . rest))))
+
+;;> \macro{(for ch [cursor] (in-string-reverse str))}
+
+(define-syntax in-string-reverse
+  (syntax-rules ()
+    ((in-string-reverse s next . rest)
+     (%in-idx string-cursor<? string-cursor-prev
+              (lambda (x) (string-cursor-prev x (string-cursor-end x)))
+              string-cursor-start string-cursor-ref
+              tmp s next . rest))))
+
+;; helper for the above string and vector iterators
+(define-syntax %in-idx
+  (syntax-rules ()
+    ;;   cmp inc start end ref
+    ((%in-idx ge + s e r tmp ((var) (seq ...)) next . rest)
+     (%in-idx ge + s e r tmp ((var seq-index) (seq ...)) next . rest))
+    ((%in-idx ge + s e r tmp ((var index) (seq)) next . rest)
+     (%in-idx ge + s e r tmp ((var index) (seq (s tmp) (e tmp))) next . rest))
+    ((%in-idx ge + s e r tmp ((var index) (seq from)) next . rest)
+     (%in-idx ge + s e r tmp ((var index) (seq from (e tmp))) next . rest))
+    ((%in-idx ge + s e r tmp ((var index) (seq from to)) next . rest)
+     (next ((tmp seq) (end to))
+           ((index from (+ tmp index)))
+           ((ge index end))
+           ((var (r tmp index)))
+           ()
+       . rest))
+    ))
+
+;;> \macro{(for ch (in-port [input-port [reader [eof?]]]))}
+
+(define-syntax in-port
+  (syntax-rules ()
+    ((in-port ((var) source) next . rest)
+     (in-port ((var p) source) next . rest))
+    ((in-port ((var p) ()) next . rest)
+     (in-port ((var p) ((current-input-port))) next . rest))
+    ((in-port ((var p) (port)) next . rest)
+     (in-port ((var p) (port read-char)) next . rest))
+    ((in-port ((var p) (port read-char)) next . rest)
+     (in-port ((var p) (port read-char eof-object?)) next . rest))
+    ((in-port ((var p) (port reader eof?)) next . rest)
+     (next ((p port) (r reader) (e? eof?))
+           ((var (r p) (r p)))
+           ((e? var))
+           ()
+           ()
+       . rest))))
+
+;;> \macro{(for ch (in-file [input-port [reader [eof?]]]))}
+
+(define-syntax in-file
+  (syntax-rules ()
+    ((in-file ((var) source) next . rest)
+     (in-file ((var p) source) next . rest))
+    ((in-file ((var p) (file)) next . rest)
+     (in-file ((var p) (file read-char)) next . rest))
+    ((in-file ((var p) (file reader)) next . rest)
+     (in-file ((var p) (file reader eof-object?)) next . rest))
+    ((in-file ((var p) (file reader eof?)) next . rest)
+     (next ((p (open-input-file file)) (r reader) (e? eof?))
+           ((var (r p) (r p)))
+           ((e? var))
+           ()
+           ((dummy (close-input-port p)))
+       . rest))))
+
+;;> \macro{(for x (up-from [start] [(to limit)] [(by step)]))}
+
+(define-syntax up-from
+  (syntax-rules (to by)
+    ((up-from (() . args) next . rest)
+     (up-from ((var) . args) next . rest))
+    ((up-from ((var) (start (to limit) (by step))) next . rest)
+     (next ((s start) (l limit) (e step))
+           ((var s (+ var e)))
+           ((>= var l))
+           ()
+           ()
+           . rest))
+    ((up-from ((var) (start (to limit))) next . rest)
+     (next ((s start) (l limit))
+           ((var s (+ var 1)))
+           ((>= var l))
+           ()
+           ()
+           . rest))
+    ((up-from ((var) (start (by step))) next . rest)
+     (next ((s start) (e step)) ((var s (+ var e))) () () () . rest))
+    ((up-from ((var) (start)) next . rest)
+     (next ((s start)) ((var s (+ var 1))) () () () . rest))
+    ))
+
+;;> \macro{(for x (down-from [start] [(to limit)] [(by step)]))}
+
+(define-syntax down-from
+  (syntax-rules (to by)
+    ((down-from (() . args) next . rest)
+     (down-from ((var) . args) next . rest))
+    ((down-from ((var) (start (to limit) (by step))) next . rest)
+     (next ((s start) (l limit) (e step))
+           ((var (- s e) (- var e)))
+           ((< var l))
+           ()
+           ()
+           . rest))
+    ((down-from ((var) (start (to limit))) next . rest)
+     (next ((s start) (l limit))
+           ((var (- s 1) (- var 1)))
+           ((< var l))
+           ()
+           ()
+           . rest))
+    ((down-from ((var) (start (by step))) next . rest)
+     (next ((s start) (e step)) ((var (- s e) (- var e))) () () ()
+           . rest))
+    ((down-from ((var) (start)) next . rest)
+     (next ((s start)) ((var (- s 1) (- var 1))) () () ()
+           . rest))
+    ))
+
+(define-syntax accumulating
+  (syntax-rules (initial if)
+    ((accumulating (kons final init) ((var) . x) next . rest)
+     (accumulating (kons final init) ((var cursor) . x) next . rest))
+    ((accumulating (kons final init) ((var cursor) ((initial i) . x)) n . rest)
+     (accumulating (kons final i) ((var cursor) x) n . rest))
+    ((accumulating (kons final init) ((var cursor) (expr (if check))) n . rest)
+     (n ((tmp-kons kons))
+        ((cursor '() (if check (tmp-kons expr cursor) cursor)))
+        ()
+        ()
+        ((var (final cursor)))
+        . rest))
+    ((accumulating (kons final init) ((var cursor) (expr)) n . rest)
+     (n ((tmp-kons kons))
+        ((cursor '() (tmp-kons expr cursor)))
+        ()
+        ()
+        ((var (final cursor)))
+        . rest))))
+
+;;> \macro{(for x [pair] (listing expr))}
+
+(define-syntax listing
+  (syntax-rules ()
+    ((listing args next . rest)
+     (accumulating (cons reverse '()) args next . rest))))
+
+;;> \macro{(for x [pair] (listing-reverse expr))}
+
+(define-syntax listing-reverse
+  (syntax-rules ()
+    ((listing-reverse args next . rest)
+     (accumulating (cons (lambda (x) x) '()) args next . rest))))
+
+(define (append-reverse rev tail)
+  (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail))))
+
+;;> \macro{(for x [pair] (appending expr))}
+
+(define-syntax appending
+  (syntax-rules ()
+    ((appending args next . rest)
+     (accumulating (append-reverse reverse '()) args next . rest))))
+
+;;> \macro{(for x [pair] (appending-reverse expr))}
+
+(define-syntax appending-reverse
+  (syntax-rules ()
+    ((appending-reverse args next . rest)
+     (accumulating (append-reverse (lambda (x) x) '()) args next . rest))))
+
+;;> \macro{(for x (summing expr))}
+
+(define-syntax summing
+  (syntax-rules ()
+    ((summing args next . rest)
+     (accumulating (+ (lambda (x) x) 0) args next . rest))))
+
+;;> \macro{(for x (multiplying expr))}
+
+(define-syntax multiplying
+  (syntax-rules ()
+    ((multiplying args next . rest)
+     (accumulating (* (lambda (x) x) 1) args next . rest))))
diff --git a/lib/chibi/match.sld b/lib/chibi/match.sld
new file mode 100644
index 00000000..36a652b1
--- /dev/null
+++ b/lib/chibi/match.sld
@@ -0,0 +1,7 @@
+
+(define-library (chibi match)
+  (export match match-lambda match-lambda* match-let match-letrec match-let*)
+  (cond-expand
+   (chibi (import (chibi)))
+   (else (import (scheme base))))
+  (include "match/match.scm"))
diff --git a/lib/chibi/match/match.scm b/lib/chibi/match/match.scm
new file mode 100644
index 00000000..d3335bd6
--- /dev/null
+++ b/lib/chibi/match/match.scm
@@ -0,0 +1,971 @@
+;;;; match.scm -- portable hygienic pattern matcher -*- coding: utf-8 -*-
+;;
+;; This code is written by Alex Shinn and placed in the
+;; Public Domain.  All warranties are disclaimed.
+
+;;> \example-import[(srfi 9)]
+
+;;> A portable hygienic pattern matcher.
+
+;;> This is a full superset of the popular \hyperlink[
+;;> "http://www.cs.indiana.edu/scheme-repository/code.match.html"]{match}
+;;> package by Andrew Wright, written in fully portable \scheme{syntax-rules}
+;;> and thus preserving hygiene.
+
+;;> The most notable extensions are the ability to use \emph{non-linear}
+;;> patterns - patterns in which the same identifier occurs multiple
+;;> times, tail patterns after ellipsis, and the experimental tree patterns.
+
+;;> \section{Patterns}
+
+;;> Patterns are written to look like the printed representation of
+;;> the objects they match.  The basic usage is
+
+;;> \scheme{(match expr (pat body ...) ...)}
+
+;;> where the result of \var{expr} is matched against each pattern in
+;;> turn, and the corresponding body is evaluated for the first to
+;;> succeed.  Thus, a list of three elements matches a list of three
+;;> elements.
+
+;;> \example{(let ((ls (list 1 2 3))) (match ls ((1 2 3) #t)))}
+
+;;> If no patterns match an error is signalled.
+
+;;> Identifiers will match anything, and make the corresponding
+;;> binding available in the body.
+
+;;> \example{(match (list 1 2 3) ((a b c) b))}
+
+;;> If the same identifier occurs multiple times, the first instance
+;;> will match anything, but subsequent instances must match a value
+;;> which is \scheme{equal?} to the first.
+
+;;> \example{(match (list 1 2 1) ((a a b) 1) ((a b a) 2))}
+
+;;> The special identifier \scheme{_} matches anything, no matter how
+;;> many times it is used, and does not bind the result in the body.
+
+;;> \example{(match (list 1 2 1) ((_ _ b) 1) ((a b a) 2))}
+
+;;> To match a literal identifier (or list or any other literal), use
+;;> \scheme{quote}.
+
+;;> \example{(match 'a ('b 1) ('a 2))}
+
+;;> Analogous to its normal usage in scheme, \scheme{quasiquote} can
+;;> be used to quote a mostly literally matching object with selected
+;;> parts unquoted.
+
+;;> \example|{(match (list 1 2 3) (`(1 ,b ,c) (list b c)))}|
+
+;;> Often you want to match any number of a repeated pattern.  Inside
+;;> a list pattern you can append \scheme{...} after an element to
+;;> match zero or more of that pattern (like a regexp Kleene star).
+
+;;> \example{(match (list 1 2) ((1 2 3 ...) #t))}
+;;> \example{(match (list 1 2 3) ((1 2 3 ...) #t))}
+;;> \example{(match (list 1 2 3 3 3) ((1 2 3 ...) #t))}
+
+;;> Pattern variables matched inside the repeated pattern are bound to
+;;> a list of each matching instance in the body.
+
+;;> \example{(match (list 1 2) ((a b c ...) c))}
+;;> \example{(match (list 1 2 3) ((a b c ...) c))}
+;;> \example{(match (list 1 2 3 4 5) ((a b c ...) c))}
+
+;;> More than one \scheme{...} may not be used in the same list, since
+;;> this would require exponential backtracking in the general case.
+;;> However, \scheme{...} need not be the final element in the list,
+;;> and may be succeeded by a fixed number of patterns.
+
+;;> \example{(match (list 1 2 3 4) ((a b c ... d e) c))}
+;;> \example{(match (list 1 2 3 4 5) ((a b c ... d e) c))}
+;;> \example{(match (list 1 2 3 4 5 6 7) ((a b c ... d e) c))}
+
+;;> \scheme{___} is provided as an alias for \scheme{...} when it is
+;;> inconvenient to use the ellipsis (as in a syntax-rules template).
+
+;;> The \scheme{..1} syntax is exactly like the \scheme{...} except
+;;> that it matches one or more repetitions (like a regexp "+").
+
+;;> \example{(match (list 1 2) ((a b c ..1) c))}
+;;> \example{(match (list 1 2 3) ((a b c ..1) c))}
+
+;;> The boolean operators \scheme{and}, \scheme{or} and \scheme{not}
+;;> can be used to group and negate patterns analogously to their
+;;> Scheme counterparts.
+
+;;> The \scheme{and} operator ensures that all subpatterns match.
+;;> This operator is often used with the idiom \scheme{(and x pat)} to
+;;> bind \var{x} to the entire value that matches \var{pat}
+;;> (c.f. "as-patterns" in ML or Haskell).  Another common use is in
+;;> conjunction with \scheme{not} patterns to match a general case
+;;> with certain exceptions.
+
+;;> \example{(match 1 ((and) #t))}
+;;> \example{(match 1 ((and x) x))}
+;;> \example{(match 1 ((and x 1) x))}
+
+;;> The \scheme{or} operator ensures that at least one subpattern
+;;> matches.  If the same identifier occurs in different subpatterns,
+;;> it is matched independently.  All identifiers from all subpatterns
+;;> are bound if the \scheme{or} operator matches, but the binding is
+;;> only defined for identifiers from the subpattern which matched.
+
+;;> \example{(match 1 ((or) #t) (else #f))}
+;;> \example{(match 1 ((or x) x))}
+;;> \example{(match 1 ((or x 2) x))}
+
+;;> The \scheme{not} operator succeeds if the given pattern doesn't
+;;> match.  None of the identifiers used are available in the body.
+
+;;> \example{(match 1 ((not 2) #t))}
+
+;;> The more general operator \scheme{?} can be used to provide a
+;;> predicate.  The usage is \scheme{(? predicate pat ...)} where
+;;> \var{predicate} is a Scheme expression evaluating to a predicate
+;;> called on the value to match, and any optional patterns after the
+;;> predicate are then matched as in an \scheme{and} pattern.
+
+;;> \example{(match 1 ((? odd? x) x))}
+
+;;> The field operator \scheme{=} is used to extract an arbitrary
+;;> field and match against it.  It is useful for more complex or
+;;> conditional destructuring that can't be more directly expressed in
+;;> the pattern syntax.  The usage is \scheme{(= field pat)}, where
+;;> \var{field} can be any expression, and should result in a
+;;> procedure of one argument, which is applied to the value to match
+;;> to generate a new value to match against \var{pat}.
+
+;;> Thus the pattern \scheme{(and (= car x) (= cdr y))} is equivalent
+;;> to \scheme{(x . y)}, except it will result in an immediate error
+;;> if the value isn't a pair.
+
+;;> \example{(match '(1 . 2) ((= car x) x))}
+;;> \example{(match 4 ((= square x) x))}
+
+;;> The record operator \scheme{$} is used as a concise way to match
+;;> records defined by SRFI-9 (or SRFI-99).  The usage is
+;;> \scheme{($ rtd field ...)}, where \var{rtd} should be the record
+;;> type descriptor specified as the first argument to
+;;> \scheme{define-record-type}, and each \var{field} is a subpattern
+;;> matched against the fields of the record in order.  Not all fields
+;;> must be present.
+
+;;> \example{
+;;> (let ()
+;;>   (define-record-type employee
+;;>     (make-employee name title)
+;;>     employee?
+;;>     (name get-name)
+;;>     (title get-title))
+;;>   (match (make-employee "Bob" "Doctor")
+;;>     (($ employee n t) (list t n))))
+;;> }
+
+;;> For records with more fields it can be helpful to match them by
+;;> name rather than position.  For this you can use the \scheme{@}
+;;> operator, originally a Gauche extension:
+
+;;> \example{
+;;> (let ()
+;;>   (define-record-type employee
+;;>     (make-employee name title)
+;;>     employee?
+;;>     (name get-name)
+;;>     (title get-title))
+;;>   (match (make-employee "Bob" "Doctor")
+;;>     ((@ employee (title t) (name n)) (list t n))))
+;;> }
+
+;;> The \scheme{set!} and \scheme{get!} operators are used to bind an
+;;> identifier to the setter and getter of a field, respectively.  The
+;;> setter is a procedure of one argument, which mutates the field to
+;;> that argument.  The getter is a procedure of no arguments which
+;;> returns the current value of the field.
+
+;;> \example{(let ((x (cons 1 2))) (match x ((1 . (set! s)) (s 3) x)))}
+;;> \example{(match '(1 . 2) ((1 . (get! g)) (g)))}
+
+;;> The new operator \scheme{***} can be used to search a tree for
+;;> subpatterns.  A pattern of the form \scheme{(x *** y)} represents
+;;> the subpattern \var{y} located somewhere in a tree where the path
+;;> from the current object to \var{y} can be seen as a list of the
+;;> form \scheme{(x ...)}.  \var{y} can immediately match the current
+;;> object in which case the path is the empty list.  In a sense it's
+;;> a 2-dimensional version of the \scheme{...} pattern.
+
+;;> As a common case the pattern \scheme{(_ *** y)} can be used to
+;;> search for \var{y} anywhere in a tree, regardless of the path
+;;> used.
+
+;;> \example{(match '(a (a (a b))) ((x *** 'b) x))}
+;;> \example{(match '(a (b) (c (d e) (f g))) ((x *** 'g) x))}
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Notes
+
+;; The implementation is a simple generative pattern matcher - each
+;; pattern is expanded into the required tests, calling a failure
+;; continuation if the tests fail.  This makes the logic easy to
+;; follow and extend, but produces sub-optimal code in cases where you
+;; have many similar clauses due to repeating the same tests.
+;; Nonetheless a smart compiler should be able to remove the redundant
+;; tests.  For MATCH-LET and DESTRUCTURING-BIND type uses there is no
+;; performance hit.
+
+;; The original version was written on 2006/11/29 and described in the
+;; following Usenet post:
+;;   http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd
+;; and is still available at
+;;   http://synthcode.com/scheme/match-simple.scm
+;; It's just 80 lines for the core MATCH, and an extra 40 lines for
+;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar.
+;;
+;; A variant of this file which uses COND-EXPAND in a few places for
+;; performance can be found at
+;;   http://synthcode.com/scheme/match-cond-expand.scm
+;;
+;; 2014/11/24 - adding Gauche's `@' pattern for named record field matching
+;; 2012/12/26 - wrapping match-let&co body in lexical closure
+;; 2012/11/28 - fixing typo s/vetor/vector in largely unused set! code
+;; 2012/05/23 - fixing combinatorial explosion of code in certain or patterns
+;; 2011/09/25 - fixing bug when directly matching an identifier repeated in
+;;              the pattern (thanks to Stefan Israelsson Tampe)
+;; 2011/01/27 - fixing bug when matching tail patterns against improper lists
+;; 2010/09/26 - adding `..1' patterns (thanks to Ludovic Courtès)
+;; 2010/09/07 - fixing identifier extraction in some `...' and `***' patterns
+;; 2009/11/25 - adding `***' tree search patterns
+;; 2008/03/20 - fixing bug where (a ...) matched non-lists
+;; 2008/03/15 - removing redundant check in vector patterns
+;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell)
+;; 2007/09/04 - fixing quasiquote patterns
+;; 2007/07/21 - allowing ellipsis patterns in non-final list positions
+;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipsis
+;;              (thanks to Taylor Campbell)
+;; 2007/04/08 - clean up, commenting
+;; 2006/12/24 - bugfixes
+;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set!
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; force compile-time syntax errors with useful messages
+
+(define-syntax match-syntax-error
+  (syntax-rules ()
+    ((_) (match-syntax-error "invalid match-syntax-error usage"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> \section{Syntax}
+
+;;> \macro{(match expr (pattern . body) ...)\br{}
+;;> (match expr (pattern (=> failure) . body) ...)}
+
+;;> The result of \var{expr} is matched against each \var{pattern} in
+;;> turn, according to the pattern rules described in the previous
+;;> section, until the the first \var{pattern} matches.  When a match is
+;;> found, the corresponding \var{body}s are evaluated in order,
+;;> and the result of the last expression is returned as the result
+;;> of the entire \scheme{match}.  If a \var{failure} is provided,
+;;> then it is bound to a procedure of no arguments which continues,
+;;> processing at the next \var{pattern}.  If no \var{pattern} matches,
+;;> an error is signalled.
+
+;; The basic interface.  MATCH just performs some basic syntax
+;; validation, binds the match expression to a temporary variable `v',
+;; and passes it on to MATCH-NEXT.  It's a constant throughout the
+;; code below that the binding `v' is a direct variable reference, not
+;; an expression.
+
+(define-syntax match
+  (syntax-rules ()
+    ((match)
+     (match-syntax-error "missing match expression"))
+    ((match atom)
+     (match-syntax-error "no match clauses"))
+    ((match (app ...) (pat . body) ...)
+     (let ((v (app ...)))
+       (match-next v ((app ...) (set! (app ...))) (pat . body) ...)))
+    ((match #(vec ...) (pat . body) ...)
+     (let ((v #(vec ...)))
+       (match-next v (v (set! v)) (pat . body) ...)))
+    ((match atom (pat . body) ...)
+     (let ((v atom))
+       (match-next v (atom (set! atom)) (pat . body) ...)))
+    ))
+
+;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure
+;; thunk, which is expanded by recursing MATCH-NEXT on the remaining
+;; clauses.  `g+s' is a list of two elements, the get! and set!
+;; expressions respectively.
+
+(define-syntax match-next
+  (syntax-rules (=>)
+    ;; no more clauses, the match failed
+    ((match-next v g+s)
+     (error 'match "no matching pattern"))
+    ;; named failure continuation
+    ((match-next v g+s (pat (=> failure) . body) . rest)
+     (let ((failure (lambda () (match-next v g+s . rest))))
+       ;; match-one analyzes the pattern for us
+       (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ())))
+    ;; anonymous failure continuation, give it a dummy name
+    ((match-next v g+s (pat . body) . rest)
+     (match-next v g+s (pat (=> failure) . body) . rest))))
+
+;; MATCH-ONE first checks for ellipsis patterns, otherwise passes on to
+;; MATCH-TWO.
+
+(define-syntax match-one
+  (syntax-rules ()
+    ;; If it's a list of two or more values, check to see if the
+    ;; second one is an ellipsis and handle accordingly, otherwise go
+    ;; to MATCH-TWO.
+    ((match-one v (p q . r) g+s sk fk i)
+     (match-check-ellipsis
+      q
+      (match-extract-vars p (match-gen-ellipsis v p r  g+s sk fk i) i ())
+      (match-two v (p q . r) g+s sk fk i)))
+    ;; Go directly to MATCH-TWO.
+    ((match-one . x)
+     (match-two . x))))
+
+;; This is the guts of the pattern matcher.  We are passed a lot of
+;; information in the form:
+;;
+;;   (match-two var pattern getter setter success-k fail-k (ids ...))
+;;
+;; usually abbreviated
+;;
+;;   (match-two v p g+s sk fk i)
+;;
+;; where VAR is the symbol name of the current variable we are
+;; matching, PATTERN is the current pattern, getter and setter are the
+;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding
+;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure
+;; continuation (which is just a thunk call and is thus safe to expand
+;; multiple times) and IDS are the list of identifiers bound in the
+;; pattern so far.
+
+(define-syntax match-two
+  (syntax-rules (_ ___ ..1 *** quote quasiquote ? $ struct @ object = and or not set! get!)
+    ((match-two v () g+s (sk ...) fk i)
+     (if (null? v) (sk ... i) fk))
+    ((match-two v (quote p) g+s (sk ...) fk i)
+     (if (equal? v 'p) (sk ... i) fk))
+    ((match-two v (quasiquote p) . x)
+     (match-quasiquote v p . x))
+    ((match-two v (and) g+s (sk ...) fk i) (sk ... i))
+    ((match-two v (and p q ...) g+s sk fk i)
+     (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i))
+    ((match-two v (or) g+s sk fk i) fk)
+    ((match-two v (or p) . x)
+     (match-one v p . x))
+    ((match-two v (or p ...) g+s sk fk i)
+     (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ()))
+    ((match-two v (not p) g+s (sk ...) fk i)
+     (match-one v p g+s (match-drop-ids fk) (sk ... i) i))
+    ((match-two v (get! getter) (g s) (sk ...) fk i)
+     (let ((getter (lambda () g))) (sk ... i)))
+    ((match-two v (set! setter) (g (s ...)) (sk ...) fk i)
+     (let ((setter (lambda (x) (s ... x)))) (sk ... i)))
+    ((match-two v (? pred . p) g+s sk fk i)
+     (if (pred v) (match-one v (and . p) g+s sk fk i) fk))
+    ((match-two v (= proc p) . x)
+     (let ((w (proc v))) (match-one w p . x)))
+    ((match-two v (p ___ . r) g+s sk fk i)
+     (match-extract-vars p (match-gen-ellipsis v p r g+s sk fk i) i ()))
+    ((match-two v (p) g+s sk fk i)
+     (if (and (pair? v) (null? (cdr v)))
+         (let ((w (car v)))
+           (match-one w p ((car v) (set-car! v)) sk fk i))
+         fk))
+    ((match-two v (p *** q) g+s sk fk i)
+     (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ()))
+    ((match-two v (p *** . q) g+s sk fk i)
+     (match-syntax-error "invalid use of ***" (p *** . q)))
+    ((match-two v (p ..1) g+s sk fk i)
+     (if (pair? v)
+         (match-one v (p ___) g+s sk fk i)
+         fk))
+    ((match-two v ($ rec p ...) g+s sk fk i)
+     (if (is-a? v rec)
+         (match-record-refs v rec 0 (p ...) g+s sk fk i)
+         fk))
+    ((match-two v (struct rec p ...) g+s sk fk i)
+     (if (is-a? v rec)
+         (match-record-refs v rec 0 (p ...) g+s sk fk i)
+         fk))
+    ((match-two v (@ rec p ...) g+s sk fk i)
+     (if (is-a? v rec)
+         (match-record-named-refs v rec (p ...) g+s sk fk i)
+         fk))
+    ((match-two v (object rec p ...) g+s sk fk i)
+     (if (is-a? v rec)
+         (match-record-named-refs v rec (p ...) g+s sk fk i)
+         fk))
+    ((match-two v (p . q) g+s sk fk i)
+     (if (pair? v)
+         (let ((w (car v)) (x (cdr v)))
+           (match-one w p ((car v) (set-car! v))
+                      (match-one x q ((cdr v) (set-cdr! v)) sk fk)
+                      fk
+                      i))
+         fk))
+    ((match-two v #(p ...) g+s . x)
+     (match-vector v 0 () (p ...) . x))
+    ((match-two v _ g+s (sk ...) fk i) (sk ... i))
+    ;; Not a pair or vector or special literal, test to see if it's a
+    ;; new symbol, in which case we just bind it, or if it's an
+    ;; already bound symbol or some other literal, in which case we
+    ;; compare it with EQUAL?.
+    ((match-two v x g+s (sk ...) fk (id ...))
+     (let-syntax
+         ((new-sym?
+           (syntax-rules (id ...)
+             ((new-sym? x sk2 fk2) sk2)
+             ((new-sym? y sk2 fk2) fk2))))
+       (new-sym? random-sym-to-match
+                 (let ((x v)) (sk ... (id ... x)))
+                 (if (equal? v x) (sk ... (id ...)) fk))))
+    ))
+
+;; QUASIQUOTE patterns
+
+(define-syntax match-quasiquote
+  (syntax-rules (unquote unquote-splicing quasiquote)
+    ((_ v (unquote p) g+s sk fk i)
+     (match-one v p g+s sk fk i))
+    ((_ v ((unquote-splicing p) . rest) g+s sk fk i)
+     (if (pair? v)
+       (match-one v
+                  (p . tmp)
+                  (match-quasiquote tmp rest g+s sk fk)
+                  fk
+                  i)
+       fk))
+    ((_ v (quasiquote p) g+s sk fk i . depth)
+     (match-quasiquote v p g+s sk fk i #f . depth))
+    ((_ v (unquote p) g+s sk fk i x . depth)
+     (match-quasiquote v p g+s sk fk i . depth))
+    ((_ v (unquote-splicing p) g+s sk fk i x . depth)
+     (match-quasiquote v p g+s sk fk i . depth))
+    ((_ v (p . q) g+s sk fk i . depth)
+     (if (pair? v)
+       (let ((w (car v)) (x (cdr v)))
+         (match-quasiquote
+          w p g+s
+          (match-quasiquote-step x q g+s sk fk depth)
+          fk i . depth))
+       fk))
+    ((_ v #(elt ...) g+s sk fk i . depth)
+     (if (vector? v)
+       (let ((ls (vector->list v)))
+         (match-quasiquote ls (elt ...) g+s sk fk i . depth))
+       fk))
+    ((_ v x g+s sk fk i . depth)
+     (match-one v 'x g+s sk fk i))))
+
+(define-syntax match-quasiquote-step
+  (syntax-rules ()
+    ((match-quasiquote-step x q g+s sk fk depth i)
+     (match-quasiquote x q g+s sk fk i . depth))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Utilities
+
+;; Takes two values and just expands into the first.
+(define-syntax match-drop-ids
+  (syntax-rules ()
+    ((_ expr ids ...) expr)))
+
+(define-syntax match-tuck-ids
+  (syntax-rules ()
+    ((_ (letish args (expr ...)) ids ...)
+     (letish args (expr ... ids ...)))))
+
+(define-syntax match-drop-first-arg
+  (syntax-rules ()
+    ((_ arg expr) expr)))
+
+;; To expand an OR group we try each clause in succession, passing the
+;; first that succeeds to the success continuation.  On failure for
+;; any clause, we just try the next clause, finally resorting to the
+;; failure continuation fk if all clauses fail.  The only trick is
+;; that we want to unify the identifiers, so that the success
+;; continuation can refer to a variable from any of the OR clauses.
+
+(define-syntax match-gen-or
+  (syntax-rules ()
+    ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...))
+     (let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
+       (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...))))))
+
+(define-syntax match-gen-or-step
+  (syntax-rules ()
+    ((_ v () g+s sk fk . x)
+     ;; no OR clauses, call the failure continuation
+     fk)
+    ((_ v (p) . x)
+     ;; last (or only) OR clause, just expand normally
+     (match-one v p . x))
+    ((_ v (p . q) g+s sk fk i)
+     ;; match one and try the remaining on failure
+     (let ((fk2 (lambda () (match-gen-or-step v q g+s sk fk i))))
+       (match-one v p g+s sk (fk2) i)))
+    ))
+
+;; We match a pattern (p ...) by matching the pattern p in a loop on
+;; each element of the variable, accumulating the bound ids into lists.
+
+;; Look at the body of the simple case - it's just a named let loop,
+;; matching each element in turn to the same pattern.  The only trick
+;; is that we want to keep track of the lists of each extracted id, so
+;; when the loop recurses we cons the ids onto their respective list
+;; variables, and on success we bind the ids (what the user input and
+;; expects to see in the success body) to the reversed accumulated
+;; list IDs.
+
+(define-syntax match-gen-ellipsis
+  (syntax-rules ()
+    ((_ v p () g+s (sk ...) fk i ((id id-ls) ...))
+     (match-check-identifier p
+       ;; simplest case equivalent to (p ...), just bind the list
+       (let ((p v))
+         (if (list? p)
+             (sk ... i)
+             fk))
+       ;; simple case, match all elements of the list
+       (let loop ((ls v) (id-ls '()) ...)
+         (cond
+           ((null? ls)
+            (let ((id (reverse id-ls)) ...) (sk ... i)))
+           ((pair? ls)
+            (let ((w (car ls)))
+              (match-one w p ((car ls) (set-car! ls))
+                         (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
+                         fk i)))
+           (else
+            fk)))))
+    ((_ v p r g+s (sk ...) fk i ((id id-ls) ...))
+     ;; general case, trailing patterns to match, keep track of the
+     ;; remaining list length so we don't need any backtracking
+     (match-verify-no-ellipsis
+      r
+      (let* ((tail-len (length 'r))
+             (ls v)
+             (len (and (list? ls) (length ls))))
+        (if (or (not len) (< len tail-len))
+            fk
+            (let loop ((ls ls) (n len) (id-ls '()) ...)
+              (cond
+                ((= n tail-len)
+                 (let ((id (reverse id-ls)) ...)
+                   (match-one ls r (#f #f) (sk ...) fk i)))
+                ((pair? ls)
+                 (let ((w (car ls)))
+                   (match-one w p ((car ls) (set-car! ls))
+                              (match-drop-ids
+                               (loop (cdr ls) (- n 1) (cons id id-ls) ...))
+                              fk
+                              i)))
+                (else
+                 fk)))))))))
+
+;; This is just a safety check.  Although unlike syntax-rules we allow
+;; trailing patterns after an ellipsis, we explicitly disable multiple
+;; ellipsis at the same level.  This is because in the general case
+;; such patterns are exponential in the number of ellipsis, and we
+;; don't want to make it easy to construct very expensive operations
+;; with simple looking patterns.  For example, it would be O(n^2) for
+;; patterns like (a ... b ...) because we must consider every trailing
+;; element for every possible break for the leading "a ...".
+
+(define-syntax match-verify-no-ellipsis
+  (syntax-rules ()
+    ((_ (x . y) sk)
+     (match-check-ellipsis
+      x
+      (match-syntax-error
+       "multiple ellipsis patterns not allowed at same level")
+      (match-verify-no-ellipsis y sk)))
+    ((_ () sk)
+     sk)
+    ((_ x sk)
+     (match-syntax-error "dotted tail not allowed after ellipsis" x))))
+
+;; To implement the tree search, we use two recursive procedures.  TRY
+;; attempts to match Y once, and on success it calls the normal SK on
+;; the accumulated list ids as in MATCH-GEN-ELLIPSIS.  On failure, we
+;; call NEXT which first checks if the current value is a list
+;; beginning with X, then calls TRY on each remaining element of the
+;; list.  Since TRY will recursively call NEXT again on failure, this
+;; effects a full depth-first search.
+;;
+;; The failure continuation throughout is a jump to the next step in
+;; the tree search, initialized with the original failure continuation
+;; FK.
+
+(define-syntax match-gen-search
+  (syntax-rules ()
+    ((match-gen-search v p q g+s sk fk i ((id id-ls) ...))
+     (letrec ((try (lambda (w fail id-ls ...)
+                     (match-one w q g+s
+                                (match-tuck-ids
+                                 (let ((id (reverse id-ls)) ...)
+                                   sk))
+                                (next w fail id-ls ...) i)))
+              (next (lambda (w fail id-ls ...)
+                      (if (not (pair? w))
+                          (fail)
+                          (let ((u (car w)))
+                            (match-one
+                             u p ((car w) (set-car! w))
+                             (match-drop-ids
+                              ;; accumulate the head variables from
+                              ;; the p pattern, and loop over the tail
+                              (let ((id-ls (cons id id-ls)) ...)
+                                (let lp ((ls (cdr w)))
+                                  (if (pair? ls)
+                                      (try (car ls)
+                                           (lambda () (lp (cdr ls)))
+                                           id-ls ...)
+                                      (fail)))))
+                             (fail) i))))))
+       ;; the initial id-ls binding here is a dummy to get the right
+       ;; number of '()s
+       (let ((id-ls '()) ...)
+         (try v (lambda () fk) id-ls ...))))))
+
+;; Vector patterns are just more of the same, with the slight
+;; exception that we pass around the current vector index being
+;; matched.
+
+(define-syntax match-vector
+  (syntax-rules (___)
+    ((_ v n pats (p q) . x)
+     (match-check-ellipsis q
+                          (match-gen-vector-ellipsis v n pats p . x)
+                          (match-vector-two v n pats (p q) . x)))
+    ((_ v n pats (p ___) sk fk i)
+     (match-gen-vector-ellipsis v n pats p sk fk i))
+    ((_ . x)
+     (match-vector-two . x))))
+
+;; Check the exact vector length, then check each element in turn.
+
+(define-syntax match-vector-two
+  (syntax-rules ()
+    ((_ v n ((pat index) ...) () sk fk i)
+     (if (vector? v)
+         (let ((len (vector-length v)))
+           (if (= len n)
+               (match-vector-step v ((pat index) ...) sk fk i)
+               fk))
+         fk))
+    ((_ v n (pats ...) (p . q) . x)
+     (match-vector v (+ n 1) (pats ... (p n)) q . x))))
+
+(define-syntax match-vector-step
+  (syntax-rules ()
+    ((_ v () (sk ...) fk i) (sk ... i))
+    ((_ v ((pat index) . rest) sk fk i)
+     (let ((w (vector-ref v index)))
+       (match-one w pat ((vector-ref v index) (vector-set! v index))
+                  (match-vector-step v rest sk fk)
+                  fk i)))))
+
+;; With a vector ellipsis pattern we first check to see if the vector
+;; length is at least the required length.
+
+(define-syntax match-gen-vector-ellipsis
+  (syntax-rules ()
+    ((_ v n ((pat index) ...) p sk fk i)
+     (if (vector? v)
+       (let ((len (vector-length v)))
+         (if (>= len n)
+           (match-vector-step v ((pat index) ...)
+                              (match-vector-tail v p n len sk fk)
+                              fk i)
+           fk))
+       fk))))
+
+(define-syntax match-vector-tail
+  (syntax-rules ()
+    ((_ v p n len sk fk i)
+     (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ()))))
+
+(define-syntax match-vector-tail-two
+  (syntax-rules ()
+    ((_ v p n len (sk ...) fk i ((id id-ls) ...))
+     (let loop ((j n) (id-ls '()) ...)
+       (if (>= j len)
+         (let ((id (reverse id-ls)) ...) (sk ... i))
+         (let ((w (vector-ref v j)))
+           (match-one w p ((vector-ref v j) (vector-set! v j))
+                      (match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
+                      fk i)))))))
+
+(define-syntax match-record-refs
+  (syntax-rules ()
+    ((_ v rec n (p . q) g+s sk fk i)
+     (let ((w (slot-ref rec v n)))
+       (match-one w p ((slot-ref rec v n) (slot-set! rec v n))
+                  (match-record-refs v rec (+ n 1) q g+s sk fk) fk i)))
+    ((_ v rec n () g+s (sk ...) fk i)
+     (sk ... i))))
+
+(define-syntax match-record-named-refs
+  (syntax-rules ()
+    ((_ v rec ((f p) . q) g+s sk fk i)
+     (let ((w (slot-ref rec v 'f)))
+       (match-one w p ((slot-ref rec v 'f) (slot-set! rec v 'f))
+                  (match-record-named-refs v rec q g+s sk fk) fk i)))
+    ((_ v rec () g+s (sk ...) fk i)
+     (sk ... i))))
+
+;; Extract all identifiers in a pattern.  A little more complicated
+;; than just looking for symbols, we need to ignore special keywords
+;; and non-pattern forms (such as the predicate expression in ?
+;; patterns), and also ignore previously bound identifiers.
+;;
+;; Calls the continuation with all new vars as a list of the form
+;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely
+;; pair with the original variable (e.g. it's used in the ellipsis
+;; generation for list variables).
+;;
+;; (match-extract-vars pattern continuation (ids ...) (new-vars ...))
+
+(define-syntax match-extract-vars
+  (syntax-rules (_ ___ ..1 *** ? $ struct @ object = quote quasiquote and or not get! set!)
+    ((match-extract-vars (? pred . p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars ($ rec . p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (struct rec . p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (@ rec (f p) ...) . x)
+     (match-extract-vars (p ...) . x))
+    ((match-extract-vars (object rec (f p) ...) . x)
+     (match-extract-vars (p ...) . x))
+    ((match-extract-vars (= proc p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (quote x) (k ...) i v)
+     (k ... v))
+    ((match-extract-vars (quasiquote x) k i v)
+     (match-extract-quasiquote-vars x k i v (#t)))
+    ((match-extract-vars (and . p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (or . p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (not . p) . x)
+     (match-extract-vars p . x))
+    ;; A non-keyword pair, expand the CAR with a continuation to
+    ;; expand the CDR.
+    ((match-extract-vars (p q . r) k i v)
+     (match-check-ellipsis
+      q
+      (match-extract-vars (p . r) k i v)
+      (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
+    ((match-extract-vars (p . q) k i v)
+     (match-extract-vars p (match-extract-vars-step q k i v) i ()))
+    ((match-extract-vars #(p ...) . x)
+     (match-extract-vars (p ...) . x))
+    ((match-extract-vars _ (k ...) i v)    (k ... v))
+    ((match-extract-vars ___ (k ...) i v)  (k ... v))
+    ((match-extract-vars *** (k ...) i v)  (k ... v))
+    ((match-extract-vars ..1 (k ...) i v)  (k ... v))
+    ;; This is the main part, the only place where we might add a new
+    ;; var if it's an unbound symbol.
+    ((match-extract-vars p (k ...) (i ...) v)
+     (let-syntax
+         ((new-sym?
+           (syntax-rules (i ...)
+             ((new-sym? p sk fk) sk)
+             ((new-sym? any sk fk) fk))))
+       (new-sym? random-sym-to-match
+                 (k ... ((p p-ls) . v))
+                 (k ... v))))
+    ))
+
+;; Stepper used in the above so it can expand the CAR and CDR
+;; separately.
+
+(define-syntax match-extract-vars-step
+  (syntax-rules ()
+    ((_ p k i v ((v2 v2-ls) ...))
+     (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))
+    ))
+
+(define-syntax match-extract-quasiquote-vars
+  (syntax-rules (quasiquote unquote unquote-splicing)
+    ((match-extract-quasiquote-vars (quasiquote x) k i v d)
+     (match-extract-quasiquote-vars x k i v (#t . d)))
+    ((match-extract-quasiquote-vars (unquote-splicing x) k i v d)
+     (match-extract-quasiquote-vars (unquote x) k i v d))
+    ((match-extract-quasiquote-vars (unquote x) k i v (#t))
+     (match-extract-vars x k i v))
+    ((match-extract-quasiquote-vars (unquote x) k i v (#t . d))
+     (match-extract-quasiquote-vars x k i v d))
+    ((match-extract-quasiquote-vars (x . y) k i v (#t . d))
+     (match-extract-quasiquote-vars
+      x
+      (match-extract-quasiquote-vars-step y k i v d) i ()))
+    ((match-extract-quasiquote-vars #(x ...) k i v (#t . d))
+     (match-extract-quasiquote-vars (x ...) k i v d))
+    ((match-extract-quasiquote-vars x (k ...) i v (#t . d))
+     (k ... v))
+    ))
+
+(define-syntax match-extract-quasiquote-vars-step
+  (syntax-rules ()
+    ((_ x k i v d ((v2 v2-ls) ...))
+     (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d))
+    ))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Gimme some sugar baby.
+
+;;> Shortcut for \scheme{lambda} + \scheme{match}.  Creates a
+;;> procedure of one argument, and matches that argument against each
+;;> clause.
+
+(define-syntax match-lambda
+  (syntax-rules ()
+    ((_ (pattern . body) ...) (lambda (expr) (match expr (pattern . body) ...)))))
+
+;;> Similar to \scheme{match-lambda}.  Creates a procedure of any
+;;> number of arguments, and matches the argument list against each
+;;> clause.
+
+(define-syntax match-lambda*
+  (syntax-rules ()
+    ((_ (pattern . body) ...) (lambda expr (match expr (pattern . body) ...)))))
+
+;;> Matches each var to the corresponding expression, and evaluates
+;;> the body with all match variables in scope.  Raises an error if
+;;> any of the expressions fail to match.  Syntax analogous to named
+;;> let can also be used for recursive functions which match on their
+;;> arguments as in \scheme{match-lambda*}.
+
+(define-syntax match-let
+  (syntax-rules ()
+    ((_ ((var value) ...) . body)
+     (match-let/helper let () () ((var value) ...) . body))
+    ((_ loop ((var init) ...) . body)
+     (match-named-let loop ((var init) ...) . body))))
+
+;;> Similar to \scheme{match-let}, but analogously to \scheme{letrec}
+;;> matches and binds the variables with all match variables in scope.
+
+(define-syntax match-letrec
+  (syntax-rules ()
+    ((_ ((var value) ...) . body)
+     (match-let/helper letrec () () ((var value) ...) . body))))
+
+(define-syntax match-let/helper
+  (syntax-rules ()
+    ((_ let ((var expr) ...) () () . body)
+     (let ((var expr) ...) . body))
+    ((_ let ((var expr) ...) ((pat tmp) ...) () . body)
+     (let ((var expr) ...)
+       (match-let* ((pat tmp) ...)
+         . body)))
+    ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body)
+     (match-let/helper
+      let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body))
+    ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body)
+     (match-let/helper
+      let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body))
+    ((_ let (v ...) (p ...) ((a expr) . rest) . body)
+     (match-let/helper let (v ... (a expr)) (p ...) rest . body))))
+
+(define-syntax match-named-let
+  (syntax-rules ()
+    ((_ loop ((pat expr var) ...) () . body)
+     (let loop ((var expr) ...)
+       (match-let ((pat var) ...)
+         . body)))
+    ((_ loop (v ...) ((pat expr) . rest) . body)
+     (match-named-let loop (v ... (pat expr tmp)) rest . body))))
+
+;;> \macro{(match-let* ((var value) ...) body ...)}
+
+;;> Similar to \scheme{match-let}, but analogously to \scheme{let*}
+;;> matches and binds the variables in sequence, with preceding match
+;;> variables in scope.
+
+(define-syntax match-let*
+  (syntax-rules ()
+    ((_ () . body)
+     (let () . body))
+    ((_ ((pat expr) . rest) . body)
+     (match expr (pat (match-let* rest . body))))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Otherwise COND-EXPANDed bits.
+
+(cond-expand
+ (chibi
+  (define-syntax match-check-ellipsis
+    (er-macro-transformer
+     (lambda (expr rename compare)
+       (if (compare '... (cadr expr))
+           (car (cddr expr))
+           (cadr (cddr expr))))))
+  (define-syntax match-check-identifier
+    (er-macro-transformer
+     (lambda (expr rename compare)
+       (if (identifier? (cadr expr))
+           (car (cddr expr))
+           (cadr (cddr expr)))))))
+
+ (else
+  ;; Portable versions
+  ;;
+  ;; This *should* work, but doesn't :(
+  ;;   (define-syntax match-check-ellipsis
+  ;;     (syntax-rules (...)
+  ;;       ((_ ... sk fk) sk)
+  ;;       ((_ x sk fk) fk)))
+  ;;
+  ;; This is a little more complicated, and introduces a new let-syntax,
+  ;; but should work portably in any R[56]RS Scheme.  Taylor Campbell
+  ;; originally came up with the idea.
+  (define-syntax match-check-ellipsis
+    (syntax-rules ()
+      ;; these two aren't necessary but provide fast-case failures
+      ((match-check-ellipsis (a . b) success-k failure-k) failure-k)
+      ((match-check-ellipsis #(a ...) success-k failure-k) failure-k)
+      ;; matching an atom
+      ((match-check-ellipsis id success-k failure-k)
+       (let-syntax ((ellipsis? (syntax-rules ()
+                                 ;; iff `id' is `...' here then this will
+                                 ;; match a list of any length
+                                 ((ellipsis? (foo id) sk fk) sk)
+                                 ((ellipsis? other sk fk) fk))))
+         ;; this list of three elements will only match the (foo id) list
+         ;; above if `id' is `...'
+         (ellipsis? (a b c) success-k failure-k)))))
+
+  ;; This is portable but can be more efficient with non-portable
+  ;; extensions.  This trick was originally discovered by Oleg Kiselyov.
+  (define-syntax match-check-identifier
+    (syntax-rules ()
+      ;; fast-case failures, lists and vectors are not identifiers
+      ((_ (x . y) success-k failure-k) failure-k)
+      ((_ #(x ...) success-k failure-k) failure-k)
+      ;; x is an atom
+      ((_ x success-k failure-k)
+       (let-syntax
+           ((sym?
+             (syntax-rules ()
+               ;; if the symbol `abracadabra' matches x, then x is a
+               ;; symbol
+               ((sym? x sk fk) sk)
+               ;; otherwise x is a non-symbol datum
+               ((sym? y sk fk) fk))))
+         (sym? abracadabra success-k failure-k)))))))
diff --git a/lib/chibi/math/prime.scm b/lib/chibi/math/prime.scm
new file mode 100644
index 00000000..65ba56e3
--- /dev/null
+++ b/lib/chibi/math/prime.scm
@@ -0,0 +1,254 @@
+;; prime.scm -- prime number utilities
+;; Copyright (c) 2004-2014 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> Prime and number theoretic utilities.
+
+;;> Returns a pair whose car is the power of 2 in the factorization of
+;;> n, and whose cdr is the product of all remaining primes.
+(define (factor-twos n)
+  (do ((p 0 (+ p 1))
+       (r n (arithmetic-shift r -1)))
+      ((odd? r) (cons p r))))
+
+;;> Returns the multiplicative inverse of \var{a} modulo \var{b}.
+(define (modular-inverse a b)
+  (let lp ((a1 a) (b1 b) (x 0) (y 1) (last-x 1) (last-y 0))
+    (if (zero? b1)
+        (if (negative? last-x) (+ last-x b) last-x)
+        (let ((q (quotient a1 b1)))
+          (lp b1 (remainder a1 b1)
+              (- last-x (* q x)) (- last-y (* q y))
+              x y)))))
+
+;;> Returns (remainder (expt a e) m).
+(define (modular-expt a e m)
+  (let lp ((tmp a) (e e) (res 1))
+    (if (zero? e)
+        res
+        (lp (remainder (* tmp tmp) m)
+            (arithmetic-shift e -1)
+            (if (odd? e) (remainder (* res tmp) m) res)))))
+
+;;> Returns true iff n and m are coprime.
+(define (coprime? n m)
+  (= 1 (gcd n m)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Exact prime testing.
+
+;; All primes under 1000.
+(define prime-table
+  '#(  2   3   5   7  11  13  17  19  23  29  31  37  41  43  47  53  59
+      61  67  71  73  79  83  89  97 101 103 107 109 113 127 131 137 139
+     149 151 157 163 167 173 179 181 191 193 197 199 211 223 227 229 233
+     239 241 251 257 263 269 271 277 281 283 293 307 311 313 317 331 337
+     347 349 353 359 367 373 379 383 389 397 401 409 419 421 431 433 439
+     443 449 457 461 463 467 479 487 491 499 503 509 521 523 541 547 557
+     563 569 571 577 587 593 599 601 607 613 617 619 631 641 643 647 653
+     659 661 673 677 683 691 701 709 719 727 733 739 743 751 757 761 769
+     773 787 797 809 811 821 823 827 829 839 853 857 859 863 877 881 883
+     887 907 911 919 929 937 941 947 953 967 971 977 983 991 997 ))
+
+;;> Returns true iff \var{n} is definitely prime.  May take an
+;;> impossibly long time for large values.
+(define (provable-prime? n)
+  (if (or (even? n) (<= n 2))
+      (= 2 n)
+      (let ((limit (exact (ceiling (sqrt n)))))
+        (define (by-twos d)
+          (cond ((> d limit) #t)
+                ((zero? (remainder n d)) #f)
+                (else (by-twos (+ d 2)))))
+        (let ((len (vector-length prime-table)))
+          (let lp ((i 0))
+            (if (>= i len)
+                (by-twos (vector-ref prime-table (- len 1)))
+                (let ((d (vector-ref prime-table i)))
+                  (cond
+                   ((> d limit) #t)
+                   ((zero? (remainder n d)) #f)
+                   (else (lp (+ i 1)))))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Probable primes.
+
+(define (modular-root-of-one? twos odd a n neg1)
+  ;; Returns true iff any (modular-expt a odd*2^i n) for i=0..twos-1
+  ;; returns 1 modulo n.
+  (let ((b (modular-expt a odd n)))
+    (let lp ((i 0) (b b))
+      (cond ((or (= b 1) (= b neg1)))  ; in (= b 1) case we could factor
+            ((>= i twos) #f)
+            (else (lp (+ i 1) (remainder (* b b) n)))))))
+
+;;> Returns true if we can show \var{n} to be composite by finding an
+;;> exception to the Miller Rabin lemma.
+(define (miller-rabin-composite? n)
+  (let* ((neg1 (- n 1))
+         (factors (factor-twos neg1))
+         (twos (car factors))
+         (odd (cdr factors))
+         ;; Each iteration of Miller Rabin reduces the odds by 1/4, so
+         ;; this is a 1 in 2^40 probability of false positive,
+         ;; assuming good randomness from SRFI 27 and no bugs, further
+         ;; reduced by preliminary sieving.
+         (fixed-limit 16)
+         (rand-limit (if (< n 341550071728321) fixed-limit 20)))
+    (let try ((i 0))
+      (and (< i rand-limit)
+           (let ((a (if (< i fixed-limit)
+                        (vector-ref prime-table i)
+                        (+ (random-integer (- n 3)) 2))))
+             (or (not (modular-root-of-one? twos odd a n neg1))
+                 (try (+ i 1))))))))
+
+;;> Returns true if \var{n} has a very high probability (enough that
+;;> you can assume a false positive will never occur in your lifetime)
+;;> of being prime.
+(define (probable-prime? n)
+  (cond
+   ((< n 1) #f)
+   (else
+    (let ((len (vector-length prime-table)))
+      (let lp ((i 0))
+        (if (>= i len)
+            (not (miller-rabin-composite? n))
+            (let ((x (vector-ref prime-table i)))
+              (cond
+               ((>= x n) (= x n))
+               ((zero? (remainder n x)) #f)
+               (else (lp (+ i 1)))))))))))
+
+;;> Returns true iff \var{n} is prime.  Uses \scheme{provable-prime?}
+;;> for small \var{n}, falling back on \scheme{probable-prime?} for
+;;> large values.
+(define (prime? n)
+  (and (> n 1)
+       (if (< n #e1e10)
+           (provable-prime? n)
+           (probable-prime? n))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Prime iteration and factorization
+
+;;> Returns the nth prime, with 2 being the 0th prime.
+(define (nth-prime i)
+  (define (by-twos n j)
+    (if (prime? n)
+        (if (<= j 0) n (by-twos (+ n 2) (- j 1)))
+        (by-twos (+ n 2) j)))
+  (let ((len (vector-length prime-table)))
+    (if (< i len)
+        (vector-ref prime-table i)
+        (by-twos (+ 2 (vector-ref prime-table (- len 1))) (- i len)))))
+
+;;> Returns the first prime less than or equal to \var{n}, or #f if
+;;> there are no such primes.
+(define (prime-below n)
+  (and (>= n 3)
+       (let lp ((n (if (even? n) (- n 1) n)))
+         (if (prime? n) n (lp (- n 2))))))
+
+;;> Returns the first prime greater than or equal to \var{n}.  If the
+;;> optional \var{limit} is given and not false, returns \scheme{#f}
+;;> if no such primes exist below \var{limit}.
+(define (prime-above n . o)
+  (let ((limit (and (pair? o) (car o))))
+    (let lp ((n (if (even? n) (+ n 1) n)))
+      (cond
+       ((and limit (>= n limit)) #f)
+       ((prime? n) n)
+       (else (lp (+ n 2)))))))
+
+;;> Returns the factorization of \var{n} as a monotonically
+;;> increasing list of primes.
+(define (factor n)
+  (cond
+   ((negative? n)
+    (cons -1 (factor (- n))))
+   ((<= n 2)
+    (list n))
+   (else
+    (let lp ((n n)
+             (res (list)))
+      (cond
+       ((even? n)
+        (lp (quotient n 2) (cons 2 res)))
+       ((= n 1)
+        (reverse res))
+       (else
+        (let lp ((i 3) (n n) (limit (exact (ceiling (sqrt n)))) (res res))
+          (cond
+           ((= n 1)
+            (reverse res))
+           ((> i limit)
+            (reverse (cons n res)))
+           ((zero? (remainder n i))
+            (lp i (quotient n i) limit (cons i res)))
+           (else
+            (lp (+ i 2) n limit res))))))))))
+
+;;> Returns the Euler totient function, the number of positive
+;;> integers less than \var{n} that are relatively prime to \var{n}.
+(define (totient n)
+  (let ((limit (exact (ceiling (sqrt n)))))
+    (let lp ((i 2) (count 1))
+      (cond ((> i limit)
+             (if (= count (- i 1))
+                 (- n 1)                ; shortcut for prime
+                 (let lp ((i i) (count count))
+                   (cond ((>= i n) count)
+                         ((= 1 (gcd n i)) (lp (+ i 1) (+ count 1)))
+                         (else (lp (+ i 1) count))))))
+            ((= 1 (gcd n i)) (lp (+ i 1) (+ count 1)))
+            (else (lp (+ i 1) count))))))
+
+;;> The aliquot sum s(n), equal to the sum of proper divisors of an
+;;> integer n.
+(define (aliquot n)
+  (let ((limit (+ 1 (quotient n 2))))
+    (let lp ((i 2) (sum 1))
+      (cond ((> i limit) sum)
+            ((zero? (remainder n i)) (lp (+ i 1) (+ sum i)))
+            (else (lp (+ i 1) sum))))))
+
+;;> Returns true iff \var{n} is a perfect number, i.e. the sum of its
+;;> divisors other than itself equals itself.
+(define (perfect? n)
+  (and (> n 1) (= n (aliquot n))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Random prime generation
+
+;;> Returns a random prime between \var{lo}, inclusive, and \var{hi},
+;;> exclusive.
+(define (random-prime lo hi)
+  (if (> lo hi)
+      (error "bad range: " lo hi))
+  (let ((n (bitwise-ior 1 (+ lo (random-integer (- hi lo))))))
+    (or (prime-above n hi)
+        (prime-above lo n)
+        (error "couldn't find prime between: " lo hi))))
+
+;;> Variant of \scheme{random-prime} which ensures the result is
+;;> distinct from \var{p}.
+(define (random-prime-distinct-from lo hi p)
+  (let ((q (random-prime lo hi)))
+    (if (= q p)
+        (random-prime-distinct-from lo hi p)
+        q)))
+
+;;> Returns a random integer less than \var{n} relatively prime to
+;;> \var{n}.
+(define (random-coprime n)
+  (let ((init (+ 2 (random-integer (- n 1)))))
+    (let lp ((m init))
+      (cond ((>= m n)
+             (let lp ((m (- init 1)))
+               (cond
+                ((<= m 1) (error "couldn't find coprime to " n))
+                ((coprime? n m) m)
+                (else (lp (- m 1))))))
+            ((coprime? n m) m)
+            (else (lp (+ m 1)))))))
diff --git a/lib/chibi/math/prime.sld b/lib/chibi/math/prime.sld
new file mode 100644
index 00000000..61474975
--- /dev/null
+++ b/lib/chibi/math/prime.sld
@@ -0,0 +1,10 @@
+
+(define-library (chibi math prime)
+  (import (scheme base) (scheme inexact) (srfi 27) (srfi 33))
+  (export prime? nth-prime prime-above prime-below factor perfect?
+          totient aliquot
+          provable-prime? probable-prime?
+          random-prime random-prime-distinct-from
+          coprime? random-coprime modular-inverse modular-expt
+          miller-rabin-composite?)
+  (include "prime.scm"))
diff --git a/lib/chibi/memoize.scm b/lib/chibi/memoize.scm
new file mode 100644
index 00000000..f9ba0769
--- /dev/null
+++ b/lib/chibi/memoize.scm
@@ -0,0 +1,352 @@
+;; memoize.scm -- caching and memoization utilities
+;; Copyright (c) 2003-2013 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> Memory and persistent caching with various levels of control, based
+;;> on a combination of lru-cache from Hato and an older memoization
+;;> library for Gauche.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; types
+
+(define-record-type Lru-Cache
+  (%make-lru-cache table front back size size-limit compute-size)
+  lru-cache?
+  (table lru-table)
+  (front lru-front lru-front-set!)
+  (back lru-back lru-back-set!)
+  (size lru-size lru-size-set!)
+  (size-limit lru-size-limit)
+  (compute-size lru-compute-size))
+
+(define-record-type Lru-Entry
+  (make-lru-entry key value size prev)
+  lru-entry?
+  (key lru-entry-key)
+  (value lru-entry-value lru-entry-value-set!)
+  (size lru-entry-size lru-entry-size-set!)
+  (prev lru-entry-prev lru-entry-prev-set!))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; high-level interface
+
+;;> Analagous to the procedure form of \scheme{define} but
+;;> automatically memoizes the function.  Uses \scheme{equal?} for
+;;> equality comparisons and reasonable defaults - for finer grained
+;;> control use \scheme{memoize}.
+
+(define-syntax define-memoized
+  (syntax-rules ()
+    ((define-memoized (proc x ...) . body)
+     (define proc
+       (make-memoizer (lambda (x ...) . body) (length '(x ...)) (make-lru-cache))))
+    ((define-memoized (proc . x) . body)
+     (define proc
+       (make-memoizer (lambda x . body) #f (make-lru-cache ))))))
+
+(define (make-memoizer proc arity cache)
+  (let ((ref! (if (lru-cache? cache) lru-ref! hash-table-ref!)))
+    (case arity
+      ((0)
+       proc)
+      ((1)
+       (lambda (x) (ref! cache x proc)))
+      ((2)
+       (lambda (x y)
+         (ref! cache (cons x y) (lambda (xy) (proc (car xy) (cdr xy))))))
+      (else
+       (lambda args
+         (ref! cache args (lambda (args) (apply proc args))))))))
+
+;;> Returns a memoized version of the procedure \var{proc}.  By
+;;> default uses a least-recently-used (LRU) cache, which can be tuned
+;;> with the following keyword arguments:
+;;>
+;;> \items[
+;;> \item{cache: an explicit pre-existing cache (LRU or hash-table)}
+;;> \item{equal: an equality predicate defaulting to \scheme{equal?}}
+;;> \item{hash: a hash function to match the equality predicate, defaulting to \scheme{hash} from \scheme{(srfi 69)}}
+;;> \item{init-size: a hint for the initial size of the backing hash table}
+;;> \item{size-limit: the maximum size of the cache}
+;;> \item{compute-size: compute the size of a cache entry}
+;;> ]
+;;>
+;;> \var{compute-size} is a procedure of two arguments, the key and
+;;> value to be stored, and defaults to a constant 1 per entry.  After
+;;> every insertion the oldest elements will be removed until the size
+;;> is under \var{size-limit}.  You may find
+;;>
+;;>   \scheme{(lambda (k v) (+ (object-size k) (object-size v)))}
+;;>
+;;> using \scheme{object-size} from \scheme{(chibi ast)} to be a
+;;> useful \var{compute-size}.
+;;>
+;;> If \var{size-limit} is \scheme{#f} then the cache is unlimited,
+;;> and a simple hash-table will be used in place of an LRU cache.
+
+(define (memoize proc . o)
+  (let-keywords* o
+      ((equal equal: equal?)
+       (hash hash: hash)
+       (arity arity: (and (not (procedure-variadic? proc))
+                          (procedure-arity proc)))
+       (init-size init-size: 31)
+       (limit size-limit: 1000)
+       (compute-size compute-size: (lambda (k v) 1))
+       (cache-init cache: '()))
+    (let ((cache (cond ((lru-cache? cache-init)
+                        cache-init)
+                       (limit
+                        (make-lru-cache 'equal: equal
+                                        'hash: hash
+                                        'init-size: init-size
+                                        'size-limit: limit
+                                        'compute-size: compute-size))
+                       (else
+                        (make-hash-table equal hash)))))
+      ;; allow an alist initializer for the cache
+      (if (pair? cache-init)
+          (for-each (lambda (x) (lru-add! cache (car x) (cdr x)))
+                    cache-init))
+      (make-memoizer proc arity cache))))
+
+;;> Equivalent to memoize except that the procedure's first argument
+;;> must be a pathname.  If the corresponding file has been modified
+;;> since the memoized value, the value is recomputed.  Useful to
+;;> automatically reflect external changes to a file-backed resource.
+;;> The additional keyword argument \scheme{reloader?:}, if true,
+;;> indicates that the result of loading is itself a procedure which
+;;> should check for updates on each call.
+
+(define (memoize-file-loader proc . o)
+  (let* ((f (lambda (file . rest)
+              (let ((mtime (file-modification-time file)))
+                (cons mtime (apply proc file rest)))))
+         (g (apply memoize f o))
+         (reloader? (cond ((memq 'reloader?: o) => cdr) (else #f))))
+    (lambda (file . rest)
+      (let ((cell (apply g file rest)))
+        (let-syntax ((update!
+                      (syntax-rules ()
+                        ((update! default)
+                         (let ((mtime (file-modification-time file)))
+                           (if (> mtime (car cell))
+                               (let ((res (apply proc file rest)))
+                                 (set-car! cell mtime)
+                                 (set-cdr! cell res)
+                                 res)
+                               default))))))
+          (update! (if (and reloader? (procedure? (cdr cell)))
+                       (lambda args (apply (update! (cdr cell)) args))
+                       (cdr cell))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; persistent memoization
+
+(define (get-memo-directory proc-name)
+  (let ((uid (current-user-id)))
+    (if (zero? uid)
+        (make-path "/var/run/memo.d" proc-name)
+        (make-path (user-home (user-information uid)) ".memo.d" proc-name))))
+
+(define (encode-file-name str)
+  (define (file-name-safe-char? ch)
+    (or (char-alphabetic? ch) (char-numeric? ch)
+        (memv ch '(#\_ #\- #\+ #\. #\,))))
+  (define (encode-char ch)
+    (let* ((i (char->integer ch))
+           (hex (number->string i 16)))
+      (if (< i 16)
+          (string-append "%0" hex)
+          (string-append "%" hex))))
+  (define (collect str from to res)
+    (if (>= from to)
+        res
+        (cons (substring-cursor str from to) res)))
+  (let ((end (string-cursor-end str)))
+    (let lp ((from 0) (to 0) (res '()))
+      (if (string-cursor>=? to end)
+          (if (zero? from)
+              str
+              (string-concatenate (reverse (collect str from to res))))
+          (let* ((ch (string-cursor-ref str to))
+                 (next (string-cursor-next str to)))
+            (if (file-name-safe-char? ch)
+                (lp from next res)
+                (lp next next (cons (encode-char ch)
+                                    (collect str from to res)))))))))
+
+(define (default-args-encoder args)
+  (encode-file-name
+   (string-append (call-with-output-string (lambda (out) (write/ss args out)))
+                  ".memo")))
+
+;;> Returns a memoized version of the procedure \var{proc} which
+;;> stores the memoized results persistently in a file.  Garbage
+;;> collection of the files is left as an external task for monitoring
+;;> tools or cron jobs.
+;;>
+;;> Accepts the following keyword arguments:
+;;>
+;;> \items[
+;;> \item{args-encoder: procedure which takes the arguments as a single list, and returns a string representation suitable for use as a (base) file name}
+;;> \item{proc-name: the name of the procedure, to use a a subdir of memo-dir to distinguish from other memoized procedures}
+;;> \item{memo-dir: the directory to store results in, defaulting to ~/.memo/}
+;;> \item{file-validator: validator to run on the existing file - if it returns false, the file is considered bad and the result recomputed}
+;;> \item{validator: validator to run on the result of reading the file}
+;;> \item{read: the read procedure to extract the result from the file}
+;;> \item{write: the write procedure to write the result to the file}
+;;> ]
+
+(define (memoize-to-file proc . o)
+  (let-keywords* o
+      ((args-encoder args-encoder: default-args-encoder)
+       (proc-name proc-name: (or (procedure-name proc) "lambda"))
+       (memo-dir memo-dir: (get-memo-directory proc-name))
+       (file-validator file-validator: (lambda args #t))
+       (validator validator: (lambda args #t))
+       (read read: read/ss)
+       (write write: write/ss))
+    (lambda args
+      (let ((file (make-path memo-dir (apply args-encoder args))))
+        (define (compute)
+          (let ((res (apply proc args)))
+            (create-directory* (path-directory file))
+            (call-with-output-file file
+              (lambda (out) (write res out)))
+            res))
+        (if (and (file-exists? file)
+                 (apply file-validator file args))
+            (let ((res (call-with-input-file file read)))
+              (if (validator res)
+                  res
+                  (compute)))
+            (compute))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; low-level utilities
+
+;;> Creates a new empty LRU object.  The same keyword arguments as in
+;;> \scheme{memoize} are available, except of course for \var{cache}.
+
+(define (make-lru-cache . o)
+  (let-keywords* o ((equal equal: equal?)
+                    (hash hash: hash)
+                    (init-size init-size: 31)
+                    (compute-size compute-size: (lambda (k v) 1))
+                    (size-limit size-limit: 1000))
+    (let ((tab (make-hash-table equal hash init-size)))
+      (%make-lru-cache tab '() '() 0 size-limit compute-size))))
+
+;; add entry to the back of the queue
+(define (lru-enq! lru entry)
+  (let ((cell (list entry)))
+    (if (null? (lru-front lru))         ; empty
+        (lru-front-set! lru cell)
+        (set-cdr! (lru-back lru) cell))
+    (lru-back-set! lru cell)))
+
+;; pop the front of the queue
+(define (lru-deq! lru)
+  (let ((cell (lru-front lru)))
+    (if (null? cell)
+        (error "lru queue is empty")
+        (let ((rest (cdr cell)))
+          (lru-front-set! lru rest)
+          (if (null? rest)
+              (lru-back-set! lru '()))
+          (car cell)))))
+
+;; shift the given entry, anywhere in the queue, to the end
+(define (lru-shift-to-last! lru entry)
+  (let ((prev (lru-entry-prev entry))
+        (last-pair (lru-back lru)))
+    (cond
+     ((null? prev)
+      ;; first entry, just pop and re-queue it, and update prev pointers
+      (lru-enq! lru (lru-deq! lru))
+      (lru-entry-prev-set! entry last-pair)
+      (lru-entry-prev-set! (car (lru-front lru)) '()))
+     ((eq? (cdr prev) last-pair)
+      ;; already at the end, nothing to do
+      )
+     (else
+      ;; a middle element, splice it out and re-queue
+      (let ((cell (cdr prev)))
+        (set-cdr! prev (cdr cell))      ; splice out
+        (if (pair? (cdr cell))
+            (lru-entry-prev-set! (cadr cell) prev))
+        (lru-enq! lru entry)            ; reinsert at end
+        (lru-entry-prev-set! entry last-pair))))))
+
+(define (lru-shrink! lru)
+  (let ((size-limit (lru-size-limit lru))
+        (size (lru-size lru)))
+    (if (> size size-limit)
+        (let lp ((size size))
+          (if (> size size-limit)
+              (let ((x (lru-deq! lru)))
+                (let ((next (lru-front lru)))
+                  (if (pair? next)
+                      (lru-entry-prev-set! (car next) '())))
+                (hash-table-delete! (lru-table lru) (lru-entry-key x))
+                (lp (- size (lru-entry-size x))))
+              (lru-size-set! lru size))))))
+
+;;> Looks up \var{key} in the cache LRU.  If not found returns #f,
+;;> unless \var{compute} is given in which case \var{compute} is
+;;> applied to \var{key} to determine the return value.  This does not
+;;> update the cache.
+
+(define (lru-ref lru key . o)
+  (let ((entry (hash-table-ref/default (lru-table lru) key #f)))
+    (cond (entry
+           (lru-shift-to-last! lru entry)
+           (lru-entry-value entry))
+          ((pair? o)
+           ((car o) key))
+          (else
+           (error "no lru entry for" key)))))
+
+;;> Identical to lru-ref except that it updates the cache on a miss.
+
+(define (lru-ref! lru key compute)
+  (cond ((hash-table-ref/default (lru-table lru) key #f)
+         => (lambda (entry)
+              (lru-shift-to-last! lru entry)
+              (lru-entry-value entry)))
+        (else
+         (let ((value (compute key)))
+           (lru-add! lru key value)
+           value))))
+
+(define (lru-add! lru key value)
+  (let* ((size ((lru-compute-size lru) key value))
+         (last-pair (lru-back lru))
+         (entry (make-lru-entry key value size last-pair)))
+    (hash-table-set! (lru-table lru) key entry)
+    (lru-enq! lru entry)
+    (lru-size-set! lru (+ size (lru-size lru)))
+    (lru-shrink! lru)))
+
+;;> Directly set a value in the cache.
+
+(define (lru-set! lru key value)
+  (let ((entry (hash-table-ref/default (lru-table lru) key #f)))
+    (cond (entry
+           (lru-shift-to-last! lru entry)
+           (lru-entry-value-set! entry value)
+           (let ((prev-size (lru-entry-size entry))
+                 (size ((lru-compute-size lru) key value)))
+             (lru-entry-size-set! entry size)
+             (lru-size-set! lru (+ (lru-size lru) (- size prev-size)))))
+          (else
+           (lru-add! lru key value)))
+    (lru-shrink! lru)))
+
+(define (hash-table-ref! table key proc)
+  (hash-table-ref table key
+                  (lambda ()
+                    (let ((res (proc key)))
+                      (hash-table-set! table key res)
+                      res))))
diff --git a/lib/chibi/memoize.sld b/lib/chibi/memoize.sld
new file mode 100644
index 00000000..c205824e
--- /dev/null
+++ b/lib/chibi/memoize.sld
@@ -0,0 +1,17 @@
+
+(define-library (chibi memoize)
+  (import (chibi) (chibi optional) (chibi time) (chibi io)
+          (chibi pathname) (chibi filesystem) (chibi system)
+          (srfi 9) (srfi 38) (srfi 69))
+  (cond-expand
+   (chibi
+    (import (chibi ast)))
+   (else
+    (begin
+      (define (procedure-name x) #f)
+      (define (procedure-arity x) #f)
+      (define (procedure-variadic? x) #f))))
+  (export define-memoized memoize memoize-to-file memoize-file-loader
+          make-lru-cache lru-cache? lru-ref lru-ref! lru-set!
+          hash-table-ref!)
+  (include "memoize.scm"))
diff --git a/lib/chibi/mime.scm b/lib/chibi/mime.scm
new file mode 100644
index 00000000..83866f13
--- /dev/null
+++ b/lib/chibi/mime.scm
@@ -0,0 +1,426 @@
+;; mime.scm -- RFC2045 MIME library
+;; Copyright (c) 2005-2013 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> A library to parse MIME headers and bodies into SXML.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define mime-line-length-limit 4096)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; association lists
+
+;;> \procedure{(assq-ref ls key [default])}
+;;> Returns the \scheme{cdr} of the cell in \var{ls} whose
+;;> \scheme{car} is \scheme{eq?} to \var{key}, or \var{default}
+;;> if not found.  Useful for retrieving values associated with
+;;> MIME headers.
+
+(define (assq-ref ls key . o)
+  (cond ((assq key ls) => cdr) (else (and (pair? o) (car o)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; simple matching instead of regexps
+
+(define (match-mbox-from-line line)
+  (let ((len (string-length line)))
+    (and (> len 5)
+         (string=? (substring line 0 5) "From ")
+         (let lp ((i 6))
+           (cond
+             ((= i len) (list (substring line 5 len) ""))
+             ((memq (string-ref line i) '(#\space #\tab))
+              (list (substring line 5 i) (substring line (+ i 1) len)))
+             (else (lp (+ i 1))))))))
+
+(define (string-scan-colon-or-maybe-equal str)
+  (let ((len (string-length str)))
+    (let lp ((i 0) (best #f))
+      (if (= i len)
+          best
+          (let ((c (string-ref str i)))
+            (cond ((or (char-alphabetic? c)
+                       (char-numeric? c)
+                       (memv c '(#\- #\_)))
+                   (lp (+ i 1) best))
+                  ((eq? c #\:)
+                   (if (= i 0) #f i))
+                  ((eqv? c #\=)
+                   (lp (+ i 1) (or best i)))
+                  (else
+                   best)))))))
+
+(define (string-skip-white-space str i)
+  (let ((lim (string-length str)))
+    (let lp ((i i))
+      (cond ((>= i lim) lim)
+            ((char-whitespace? (string-ref str i)) (lp (+ i 1)))
+            (else i)))))
+
+(define (match-mime-header-line line)
+  (let ((i (string-scan-colon-or-maybe-equal line)))
+    (and i
+         (let ((j (string-skip-white-space line (+ i 1))))
+           (list (string->symbol (string-downcase-ascii (substring line 0 i)))
+                 (substring line j (string-length line)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; dummy encoder
+
+(define (ces-convert bv . o)
+  (let ((enc (if (pair? o) (car o) "utf8")))
+    ;; TODO: add conversion routines for non-utf8 encodings
+    (utf8->string bv)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;> \section{RFC2822 Headers}
+
+;;> \procedure{(mime-header-fold kons knil [source [limit [kons-from]]])}
+;;>
+;;> Performs a fold operation on the MIME headers of source which can be
+;;> either a string or port, and defaults to current-input-port.  \var{kons}
+;;> is called on the three values:
+;;>    \scheme{(kons header value accumulator)}
+;;> where accumulator begins with \var{knil}.  Neither the header nor the
+;;> value are modified, except wrapped lines are handled for the value.
+;;>
+;;> The optional procedure \var{kons-from} is a procedure to be called when
+;;> the first line of the headers is an "From <address> <date>" line, to
+;;> enable this procedure to be used as-is on mbox files and the like.
+;;> It defaults to \var{kons}, and if such a line is found the fold will begin
+;;> with \scheme{(kons-from '%from <address> (kons-from '%date <date> knil))}.
+;;>
+;;> The optional \var{limit} gives a limit on the number of headers to read.
+
+(define (mime-header-fold kons knil . o)
+  (let ((src (and (pair? o) (car o)))
+        (limit (and (pair? o) (pair? (cdr o)) (car (cdr o))))
+        (kons-from (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) (car (cddr o)) kons)))
+    ((if (string? src) mime-header-fold-string mime-header-fold-port)
+     kons knil (or src (current-input-port)) limit kons-from)))
+
+(define (mime-header-fold-string kons knil str limit kons-from)
+  (call-with-input-string str
+    (lambda (in) (mime-header-fold-port kons knil in limit kons-from))))
+
+(define (mime-header-fold-port kons knil port limit kons-from)
+  (define (out line acc count)
+    (cond
+     ((or (and limit (> count limit)) (eof-object? line) (string=? line ""))
+      acc)
+     ((match-mime-header-line line)
+      => (lambda (m) (in (car m) (list (cadr m)) acc (+ count 1))))
+     (else
+      ;;(warn "invalid header line: ~S\n" line)
+      (out (read-line port mime-line-length-limit) acc (+ count 1)))))
+  (define (in header value acc count)
+    (let ((line (read-line port mime-line-length-limit)))
+      (cond
+       ((and limit (> count limit))
+        acc)
+       ((or (eof-object? line) (string=? line ""))
+        (kons header (string-join (reverse value)) acc))
+       ((char-whitespace? (string-ref line 0))
+        (in header (cons line value) acc (+ count 1)))
+       (else
+        (out line
+             (kons header (string-join (reverse value)) acc)
+             (+ count 1))))))
+  (let ((first-line (read-line port mime-line-length-limit)))
+    (cond
+     ((eof-object? first-line)
+      knil)
+     ((and kons-from (match-mbox-from-line first-line))
+      => (lambda (m) ; special case check on first line for mbox files
+           (out (read-line port mime-line-length-limit)
+                (kons-from '%from (car m)
+                           (kons-from '%date (cadr m) knil))
+                0)))
+     (else
+      (out first-line knil 0)))))
+
+;;> \procedure{(mime-headers->list [source])}
+;;> Return an alist of the MIME headers from source with headers all
+;;> downcased.
+
+(define (mime-headers->list . o)
+  (reverse
+   (apply
+    mime-header-fold
+    (lambda (h v acc) (cons (cons h v) acc))
+    '()
+    o)))
+
+(define (mime-split-name+value s)
+  (let ((i (string-find s #\=)))
+    (if i
+        (cons (string->symbol
+               (string-downcase-ascii (string-trim (substring s 0 i))))
+              (if (= i (string-length s))
+                  ""
+                  (if (eqv? #\" (string-ref s (+ i 1)))
+                      (substring s (+ i 2) (- (string-length s) 1))
+                      (substring s (+ i 1) (string-length s)))))
+        (cons (string->symbol (string-downcase-ascii (string-trim s))) ""))))
+
+;;> \procedure{(mime-parse-content-type str)}
+;;> Parses \var{str} as a Content-Type style-value returning the list
+;;> \scheme{(type (attr . val) ...)}.
+
+;;> \example{
+;;> (mime-parse-content-type "text/html; CHARSET=UTF-8; filename=index.html")
+;;> }
+
+(define (mime-parse-content-type str)
+  (let ((res (map mime-split-name+value
+                  (string-split str (lambda (ch)
+                                      (or (eqv? ch #\;) (eqv? ch #\,)))))))
+    (if (and (pair? res) (pair? (car res)) (equal? "" (cdar res)))
+        (cons (caar res) (cdr res))
+        res)))
+
+;;> \procedure{(mime-decode-header str)}
+;;> Replace all occurrences of RFC1522 =?ENC?...?= escapes in \var{str} with
+;;> the appropriate decoded and charset converted value.
+
+(define (mime-decode-header str)
+  (let* ((len (string-length str))
+         (limit (- len 8))) ; need at least 8 chars: "=?Q?X??="
+    (let lp ((i 0) (from 0) (res '()))
+      (if (>= i limit)
+        (string-join (reverse (cons (substring str from len) res)))
+        (if (and (eqv? #\= (string-ref str i))
+                 (eqv? #\? (string-ref str (+ i 1))))
+          (let* ((j (string-find str #\? (+ i 3)))
+                 (k (string-find str #\? (+ j 3))))
+            (if (and j k (< (+ k 1) len)
+                     (eqv? #\? (string-ref str (+ j 2)))
+                     (memq (string-ref str (+ j 1)) '(#\Q #\B #\q #\b))
+                     (eqv? #\= (string-ref str (+ k 1))))
+              (let ((decode (if (memq (string-ref str (+ j 1)) '(#\Q #\q))
+                               quoted-printable-decode-string
+                               base64-decode-string))
+                    (cset (substring str (+ i 2) j))
+                    (content (substring str (+ j 3) k))
+                    (k2 (+ k 2)))
+                (lp k2 k2 (cons (ces-convert (decode content) cset)
+                                (cons (substring str from i) res))))
+              (lp (+ i 2) from res)))
+          (lp (+ i 1) from res))))))
+
+;;> Write out an alist of headers in mime format.
+
+(define (mime-write-headers headers out)
+  (for-each
+   (lambda (h)
+     (display (car h) out) (display ": " out)
+     (display (cdr h) out) (display "\r\n" out))
+   headers))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; message parsing
+
+(define (read-line/binary in)
+  (let ((out (open-output-bytevector)))
+    (let lp ()
+      (let ((ch (read-u8 in)))
+        (cond ((eof-object? ch)
+               (let ((res (get-output-bytevector out)))
+                 (if (zero? (bytevector-length res))
+                     ch
+                     res)))
+              ((eqv? ch 10)
+               (get-output-bytevector out))
+              (else
+               (write-u8 ch out)
+               (lp)))))))
+
+(define (bv-length-before-cr bv)
+  (let ((len (bytevector-length bv)))
+    (if (and (> len 0) (= 13 (bytevector-u8-ref bv (- len 1))))
+        (- len 1)
+        len)))
+
+(define (mime-read-to-boundary/binary port boundary next final)
+  (let* ((boundary (if (string? boundary) (string->utf8 boundary) boundary))
+         (boundary-cr (and boundary (bytevector-append boundary #u8(13))))
+         (final-boundary
+          (and boundary (bytevector-append boundary #u8(45 45))))
+         (final-boundary-cr
+          (and final-boundary (bytevector-append final-boundary #u8(13))))
+         (out (open-output-bytevector)))
+    (let lp ((prev #f))
+      (let ((line (read-line/binary port)))
+        (cond
+         ((or (eof-object? line)
+              (equal? line final-boundary)
+              (equal? line final-boundary-cr))
+          (if prev
+              (write-bytevector prev out 0 (bv-length-before-cr prev)))
+          (final (get-output-bytevector out)))
+         ((or (equal? line boundary) (equal? line boundary-cr))
+          (if prev
+              (write-bytevector prev out 0 (bv-length-before-cr prev)))
+          (next (get-output-bytevector out)))
+         (else
+          (cond (prev
+                 (write-bytevector prev out)
+                 (write-u8 10 out)))
+          (lp line)))))))
+
+(define (mime-read-to-boundary/text port boundary next final)
+  (let ((final-boundary (and boundary (string-append boundary "--"))))
+    (let lp ((res '()))
+      (let ((line (read-line port mime-line-length-limit)))
+        (cond
+         ((or (eof-object? line) (equal? line final-boundary))
+          (final (string-join (reverse res)
+                              (call-with-output-string newline))))
+         ((equal? line boundary)
+          (next (string-join (reverse res)
+                             (call-with-output-string newline))))
+         (else
+          (lp (cons line res))))))))
+
+(define (mime-read-to-boundary port boundary next final)
+  ((if (binary-port? port)
+       mime-read-to-boundary/binary
+       mime-read-to-boundary/text)
+   port boundary next final))
+
+(define (mime-convert-part part text? cte enc)
+  (let ((res (cond
+              ((and (string? cte) (string-ci=? cte "quoted-printable"))
+               (if text?
+                   (quoted-printable-decode-string part)
+                   (quoted-printable-decode-bytevector
+                    (if (string? part) (string->utf8 part) part))))
+              ((and (string? cte) (string-ci=? cte "base64"))
+               (if text?
+                   (base64-decode-string part)
+                   (base64-decode-bytevector
+                    (if (string? part) (string->utf8 part) part))))
+              ((and (not text?) (string? part))
+               (string->utf8 part))
+              (else
+               part))))
+    (cond
+     ((and text? (bytevector? res)) (ces-convert res enc))
+     (else res))))
+
+(define (mime-read-part port type cte enc boundary next final)
+  (let ((text? (and (symbol? type)
+                    (string-prefix? "text/" (symbol->string type)))))
+    (mime-read-to-boundary
+     port boundary
+     (lambda (x) (next (mime-convert-part x text? cte enc)))
+     (lambda (x) (final (mime-convert-part x text? cte enc))))))
+
+;;> \section{RFC2045 MIME Encoding}
+
+;;> \procedure{(mime-message-fold src kons knil [down up headers])}
+;;> Performs a tree fold operation on the given string or port
+;;> \var{src} as a MIME body corresponding to the headers give in
+;;> \var{headers}.  If \var{headers} are false or not provided they
+;;> are first read from \var{src}.
+;;>
+;;> \var{kons} is called on the successive values:
+;;>
+;;> \schemeblock{(kons parent-headers part-headers part-body accumulator)}
+;;>
+;;> where \var{part-headers} are the headers for the given MIME part (the
+;;> original headers for single-part MIME), \var{part-body} is the
+;;> appropriately decoded and charset-converted body of the message,
+;;> and the \var{accumulator} begins with \var{knil}.
+;;>
+;;> If a multipart body is found, then a tree fold is performed,
+;;> calling \var{down} once to get a new accumulator to pass to
+;;> \var{kons}, and \var{up} on the result when returning.  Their
+;;> signatures are:
+;;>
+;;> \schemeblock{(down headers seed)}
+;;> \schemeblock{(up headers parent-seed seed)}
+;;>
+;;> The default \var{down} simply returns null, and the default
+;;> \var{up} wraps the seed in the following sxml:
+;;>
+;;> \schemeblock{
+;;>  ((mime (@ headers ...)
+;;>     seed ...)
+;;>   parent-seed ...)
+;;> }
+
+(define (mime-message-fold src kons init-seed . o)
+  (let ((port (if (string? src) (open-input-string src) src)))
+    (let ((kons-down
+           (or (and (pair? o) (car o)) (lambda (headers seed) '())))
+          (kons-up
+           (or (and (pair? o) (pair? (cdr o)) (car (cdr o)))
+               (lambda (headers parent-seed seed)
+                 `((mime (@ ,@headers)
+                         ,@(if (pair? seed) (reverse seed) seed))
+                   ,@parent-seed))))
+          (headers
+           (or (and (pair? o) (pair? (cdr o)) (pair? (cdr (cdr o)))
+                    (car (cdr (cdr o))))
+               (mime-headers->list port))))
+      (let tfold ((parent-headers '())
+                  (headers headers)
+                  (seed init-seed)
+                  (boundary #f)
+                  (next (lambda (x) x))
+                  (final (lambda (x) x)))
+        (let* ((ctype (mime-parse-content-type
+                       (assq-ref headers 'content-type "text/plain")))
+               (type (car ctype))
+               (enc (string-trim
+                     (or (assq-ref ctype 'charset)
+                         (assq-ref headers 'charset "ascii"))))
+               (cte (string-trim
+                     (or (assq-ref headers 'content-transfer-encoding)
+                         (assq-ref headers 'encoding "7-bit")))))
+          (cond
+           ((and (symbol? type)
+                 (string-prefix? "multipart/" (symbol->string type))
+                 (assq-ref (cdr ctype) 'boundary))
+            => (lambda (boundary2)
+                 (let ((boundary2 (string-append "--" boundary2)))
+                   ;; skip preamble
+                   (mime-read-to-boundary port boundary2 (lambda (x) x) (lambda (x) x))
+                   (let lp ((part-seed (kons-down headers seed)))
+                     (let ((part-headers (mime-headers->list port)))
+                       (flush-output (current-error-port))
+                       (tfold headers part-headers
+                              part-seed boundary2
+                              lp
+                              (lambda (x)
+                                ;; skip epilogue
+                                (if boundary
+                                    (mime-read-to-boundary
+                                     port boundary
+                                     (lambda (x) x) (lambda (x) x)))
+                                (next (kons-up headers seed x)))))))))
+           (else
+            (mime-read-part
+             port type cte enc boundary
+             (lambda (x) (next (kons parent-headers headers x seed)))
+             (lambda (x) (final (kons parent-headers headers x seed)))))))))))
+
+;;> \procedure{(mime-message->sxml [src [headers]])}
+;;> 
+;;> Parse the given source as a MIME message and return
+;;> the result as an SXML object of the form:
+;;> \scheme{(mime (@ (header . value) ...) parts ...)}.
+
+(define (mime-message->sxml . o)
+  (car
+   (apply
+    mime-message-fold
+    (if (pair? o) (car o) (current-input-port))
+    (lambda (parent-headers headers body seed)
+      ;; Discard empty bodies.
+      (if (and (equal? body "") (null? headers))
+          seed
+          `((mime (@ ,@headers) ,body) ,@seed)))
+    '() #f #f (if (pair? o) (cdr o) '()))))
diff --git a/lib/chibi/mime.sld b/lib/chibi/mime.sld
new file mode 100644
index 00000000..e0f11d96
--- /dev/null
+++ b/lib/chibi/mime.sld
@@ -0,0 +1,9 @@
+
+(define-library (chibi mime)
+  (export assq-ref mime-header-fold mime-headers->list
+          mime-parse-content-type mime-decode-header
+          mime-message-fold mime-message->sxml mime-write-headers)
+  (import (chibi) (chibi base64) (chibi quoted-printable)
+          (chibi string) (chibi io)
+          (only (scheme base) bytevector-append write-bytevector))
+  (include "mime.scm"))
diff --git a/lib/chibi/modules.scm b/lib/chibi/modules.scm
new file mode 100644
index 00000000..0d991807
--- /dev/null
+++ b/lib/chibi/modules.scm
@@ -0,0 +1,221 @@
+;; modules.scm -- module introspection utilities
+;; Copyright (c) 2011-2013 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> Module introspection library.
+
+(define (file->sexp-list file)
+  (call-with-input-file file
+    (lambda (in)
+      (let lp ((res '()))
+        (let ((x (read in)))
+          (if (eof-object? x)
+              (reverse res)
+              (lp (cons x res))))))))
+
+(define (module? x)
+  (and (vector? x)
+       (>= (vector-length x) 4)
+       (or (list? (vector-ref x 0)) (not (vector-ref x 0)))))
+
+(define (module-ast mod) (vector-ref mod 3))
+(define (module-ast-set! mod x) (vector-set! mod 3 x))
+
+(define (module-name mod)
+  (if (pair? mod)
+      (car mod)
+      (let lp ((ls *modules*))
+        (and (pair? ls)
+             (if (eq? mod (cdar ls))
+                 (caar ls)
+                 (lp (cdr ls)))))))
+
+(define (module-dir mod)
+  (let ((name (module-name mod)))
+    (if (member name '((chibi) (meta)))
+        ""
+        (module-name-prefix name))))
+
+(define (module-metas mod metas)
+  (let ((mod (if (module? mod) mod (find-module mod))))
+    (let lp ((ls (module-meta-data mod)) (res '()))
+      (cond
+       ((not (pair? ls)) (reverse res))
+       ((and (pair? (car ls)) (memq (caar ls) metas))
+        (lp (cdr ls) (append (reverse (cdar ls)) res)))
+       (else (lp (cdr ls) res))))))
+
+(define (module-extract-declaration-files mod decls)
+  (let* ((mod (if (module? mod) mod (find-module mod)))
+         (dir (module-dir mod)))
+    (define (module-file f)
+      (find-module-file (string-append dir f)))
+    (map module-file (reverse (module-metas mod decls)))))
+
+(define (module-includes mod)
+  (module-extract-declaration-files mod '(include)))
+
+(define (module-include-library-declarations mod)
+  (module-extract-declaration-files mod '(include-library-declarations)))
+
+(define (module-shared-includes mod)
+  (let* ((mod (if (module? mod) mod (find-module mod)))
+         (dir (module-dir mod)))
+    (define (module-file f)
+      (find-module-file (string-append dir f ".stub")))
+    (let lp ((ls (reverse (module-metas mod '(include-shared)))) (res '()))
+      (cond ((null? ls) (reverse res))
+            ((module-file (car ls)) => (lambda (x) (lp (cdr ls) (cons x res))))
+            (else (lp (cdr ls) res))))))
+
+(define (analyze-module-source name mod recursive?)
+  (let ((env (module-env mod))
+        (dir (module-dir mod)))
+    (define (include-source file)
+      (cond ((find-module-file (string-append dir file))
+             => (lambda (x) (cons 'body (file->sexp-list x))))
+            (else (error "couldn't find include" file))))
+    (let lp ((ls (module-meta-data mod)) (res '()))
+      (cond
+       ((not (pair? ls))
+        (reverse res))
+       (else
+        (case (and (pair? (car ls)) (caar ls))
+          ((import import-immutable)
+           (for-each
+            (lambda (m)
+              (let* ((mod2-name+imports (resolve-import m))
+                     (mod2-name (car mod2-name+imports)))
+                (if recursive?
+                    (analyze-module mod2-name #t))))
+            (cdar ls))
+           (lp (cdr ls) res))
+          ((include)
+           (lp (append (map include-source (cdar ls)) (cdr ls)) res))
+          ((body begin)
+           (let lp2 ((ls2 (cdar ls)) (res res))
+             (cond
+              ((pair? ls2)
+               (lp2 (cdr ls2) (cons (analyze (car ls2) env) res)))
+              (else
+               (lp (cdr ls) res)))))
+          (else
+           (lp (cdr ls) res))))))))
+
+(define (analyze-module name . o)
+  (let ((recursive? (and (pair? o) (car o)))
+        (res (load-module name)))
+    (if (not (module-ast res))
+        (module-ast-set! res (analyze-module-source name res recursive?)))
+    res))
+
+(define (module-ref mod var-name . o)
+  (let ((cell (env-cell (module-env (if (module? mod) mod (load-module mod)))
+                        var-name)))
+    (if cell
+        (cdr cell)
+        (if (pair? o) (car o) (error "no binding in module" mod var-name)))))
+
+(define (module-contains? mod var-name)
+  (and (env-cell (module-env (if (module? mod) mod (load-module mod))) var-name)
+       #t))
+
+(define (module-defines? name mod var-name)
+  (if (not (module-ast mod))
+      (module-ast-set! mod (analyze-module-source name mod #f)))
+  (let lp ((ls (module-ast mod)))
+    (and (pair? ls)
+         (or (and (set? (car ls))
+                  (eq? var-name (ref-name (set-var (car ls)))))
+             (lp (cdr ls))))))
+
+(define (containing-module x)
+  (let lp1 ((ls (reverse *modules*)))
+    (and (pair? ls)
+         (let ((env (module-env (cdar ls))))
+           (let lp2 ((e-ls (if (environment? env) (env-exports env) '())))
+             (if (null? e-ls)
+                 (lp1 (cdr ls))
+                 (let ((cell (env-cell env (car e-ls))))
+                   (if (and (eq? x (cdr cell))
+                            (module-defines? (caar ls) (cdar ls) (car cell)))
+                       (car ls)
+                       (lp2 (cdr e-ls))))))))))
+
+(define (procedure-analysis x . o)
+  (let ((name (if (procedure? x) (procedure-name x) x))
+        (mod (or (and (pair? o) (car o)) (containing-module x))))
+    (and mod
+         (let lp ((ls (module-ast (analyze-module (module-name mod)))))
+           (and (pair? ls)
+                (cond
+                 ((and (set? (car ls))
+                       (eq? name (ref-name (set-var (car ls)))))
+                  (set-value (car ls)))
+                 ((seq? (car ls))
+                  (lp (append (seq-ls (car ls)) (cdr ls))))
+                 (else
+                  (lp (cdr ls)))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; finding all available modules
+
+(define (module-file? file)
+  (let ((len (string-length file)))
+    (and (> len 4) (equal? ".sld" (substring file (- len 4))))))
+
+(define (read-static-modules file)
+  (protect (exn (else '()))
+    (call-with-input-file file
+      (lambda (in)
+        (let lp ((res '()))
+          (let ((expr (read in)))
+            (cond
+             ((eof-object? expr)
+              res)
+             ((and (pair? expr) (eq? 'define-library (car expr)))
+              (let ((name (cadr expr))
+                    (exports (cond ((assq 'export (cddr expr)) => cdr)
+                                   (else '()))))
+                (lp (cons (cons name (make-module exports #f #f)) res))))
+             (else
+              (lp res)))))))))
+
+(define no-module-depth-limit 2)
+
+(define (available-modules-in-directory dir depth res)
+  (call-with-values
+      (lambda ()
+        (partition file-directory?
+                   (map (lambda (f) (string-append dir "/" f))
+                        (remove (lambda (f) (member f '("." "..")))
+                                (directory-files dir)))))
+    (lambda (dirs files)
+      (let ((mods (append-map read-static-modules
+                              (filter module-file? files))))
+        (if (and (null? mods) (>= depth no-module-depth-limit))
+            res
+            (let ((depth (if (pair? mods) 0 (+ 1 depth))))
+              (let lp ((ls dirs) (res (append mods res)))
+                (if (null? ls)
+                    res
+                    (lp (cdr ls)
+                        (available-modules-in-directory (car ls) depth res)
+                        )))))))))
+
+(define (available-modules)
+  (let lp ((ls (current-module-path)) (res *modules*))
+    (if (null? ls)
+        res
+        (lp (cdr ls)
+            (available-modules-in-directory (car ls) 0 res)))))
+
+(define (modules-exporting-identifier name)
+  (let lp ((ls (available-modules))
+           (res '()))
+    (cond
+     ((null? ls) (reverse res))
+     ((and (memq name (module-exports (cdar ls)))
+           (not (assoc (caar ls) res)))
+      (lp (cdr ls) (cons (car ls) res)))
+     (else (lp (cdr ls) res)))))
diff --git a/lib/chibi/modules.sld b/lib/chibi/modules.sld
new file mode 100644
index 00000000..03929b87
--- /dev/null
+++ b/lib/chibi/modules.sld
@@ -0,0 +1,11 @@
+
+(define-library (chibi modules)
+  (export module-name module-dir module-includes module-shared-includes
+          module-include-library-declarations
+          module-ast module-ast-set! module-ref module-contains?
+          analyze-module containing-module load-module module-exports
+          module-name->file procedure-analysis find-module
+          available-modules-in-directory available-modules
+          modules-exporting-identifier)
+  (import (chibi) (meta) (srfi 1) (chibi ast) (chibi filesystem))
+  (include "modules.scm"))
diff --git a/lib/chibi/monad/environment.scm b/lib/chibi/monad/environment.scm
new file mode 100644
index 00000000..355926e4
--- /dev/null
+++ b/lib/chibi/monad/environment.scm
@@ -0,0 +1,191 @@
+;; environment.scm - the environment (reader) monad for Scheme
+;; Copyright (c) 2013 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> A Scheme take on the environment (reader) monad, focusing more on
+;;> being efficient and convenient than pure.
+
+;;> \macro{(define-environment-monad name keyword: value ...)}
+;;>
+;;> Define a new environment monad.  This syntax hides the
+;;> implementation, allowing the use of records, dynamic parameters,
+;;> or explicit value passing.
+;;>
+;;> The \var{name} is used for description and may or may not be bound
+;;> to a value representing the monad.  All other parameters are
+;;> keywords, and with the exception of \scheme{fields} simply provide
+;;> binding names for the monad operators described below.
+;;>
+;;> The \scheme{fields:} keyword takes a list of field name
+;;> identifiers known to be used by the monad.  This is an
+;;> optimization hint, as the monad can be used to store and query
+;;> values for any identifier at runtime.
+;;>
+;;> The following keywords obey the definition of a monad:
+;;>
+;;> sequence: sequence (>>) - Essentially a semi-colon, this joins two
+;;>  operations together.
+;;>
+;;> bind: (>>=) - Runs a normal function.  As a syntactic convenience,
+;;>  \scheme{bind} looks and behaves like a lambda, but the parameters
+;;>  of the \scheme{bind} are bound as Scheme variables with the
+;;>  values of the corresponding environment variables.  Thus you
+;;>  fetch the values of foo and bar with:
+;;>
+;;>    \scheme{(bind (foo bar) ...)}
+;;>
+;;>  hiding the need for an explicit \scheme{ask}.  If you want to
+;;>  bind the values to some other name, you can use it like a
+;;>  \scheme{let}:
+;;>
+;;>    \scheme{(bind ((my-foo foo) (my-bar bar)) ...)}
+;;>
+;;> return: Returns a pure (non-monadic) value.
+;;>
+;;> run: Start the monad.
+;;>
+;;> The following are specific to the environment monad:
+;;>
+;;> ask: Ask the current value of an environment variable.  This is not
+;;>  meant to be used directly - use the `bind' syntax to query bindings.
+;;>
+;;> local: Shadow the value one or more environment variables,
+;;>  analogous to `let'.
+;;>
+;;> In addition, support for optional mutation is provided:
+;;>
+;;> local!: (local! (var val) ...) will update the environment with
+;;>  the corresponding variable bindings.  In a sequence, successive
+;;>  operations will see the result of the update, unlike with `local'.
+;;>  This is allowed, but not required, to perform mutation.
+;;>
+;;> bind-fork: \scheme{(bind-fork a b)} runs `a' followed by `b',
+;;>   passing `b' the original state before `a' was run.
+
+(define-syntax define-environment-monad
+  (syntax-rules ()
+    ((define-environment-monad name clauses ...)
+     (dem name (ask %ask) (tell %tell) c f! f s r w u z () clauses ...))))
+
+(define-syntax dem
+  (syntax-rules (fields: sequence: bind: bind-fork:
+                 local: local!: run: return: ask: tell: copy:)
+    ((dem n ask tell c f! f s r w u z (fls ...)
+          (fields: (fl get put) . fl-r) . x)
+     (dem n ask tell c f! f s r w u z (fls ... (fl #f get put))
+          (fields: . fl-r) . x))
+    ((dem n ask tell c f! f s r w u z (fls ...) (fields:) . x)
+     (dem n ask tell c f! f s r w u z (fls ...) . x))
+    ((dem n ask tell c f! f s r w u z ())
+     (syntax-error "missing fields clause in define-state-monad"))
+    ((dem n ask tell c f! f s r w u z fls (bind: fn!) . x)
+     (dem n ask tell c fn! f s r w u z fls . x))
+    ((dem n ask tell c f! f s r w u z fls (bind-fork: fn) . x)
+     (dem n ask tell c f! fn s r w u z fls . x))
+    ((dem n ask tell c f! f s r w u z fls (sequence: seq) . x)
+     (dem n ask tell c f! f seq r w u z fls . x))
+    ((dem n ask tell c f! f s r w u z fls (run: run) . x)
+     (dem n ask tell c f! f s run w u z fls . x))
+    ((dem n ask tell c f! f s r w u z fls (return: return) . x)
+     (dem n ask tell c f! f s r w u return fls . x))
+    ((dem n ask tell c f! f s r w u z fls (local: local) . x)
+     (dem n ask tell c f! f s r local u z fls . x))
+    ((dem n ask tell c f! f s r w u z fls (local!: local!) . x)
+     (dem n ask tell c f! f s r w local! z fls . x))
+    ((dem n ask tell c f! f s r w u z fls (ask: a %a) . x)
+     (dem n (a %a) tell c f! f s r w u z fls . x))
+    ((dem n ask tell c f! f s r w u z fls (tell: t %t) . x)
+     (dem n ask (t %t) c f! f s r w u z fls . x))
+    ((dem n ask tell c f! f s r w u z fls (copy: copy) . x)
+     (dem n ask tell copy f! f s r w u z fls . x))
+    ((dem n ask tell c f! f s r w u z fls clause . x)
+     (syntax-error "unknown clause" 'clause))
+    ((dem n (ask %ask) (tell %tell) c f! f s r w u z ((field init get put) ...))
+     (begin
+       ;; Internals
+       (define-record-type n
+         (make-state field ... %props)
+         state?
+         (field get put) ...
+         (%props get-props set-props!))
+       (define (%ask st x)
+         (case x
+           ((field) (get st)) ...
+           (else (cond ((assq x (get-props st)) => cdr) (else #f)))))
+       (define-syntax ask
+         (syntax-rules (quote field ...)
+           ((ask st 'field) (get st)) ...
+           ((ask st x) (%ask st x))))
+       (define (%tell st x val)
+         (case x
+           ((field) (put st val)) ...
+           (else
+            (cond
+             ((assq x (get-props st))
+              => (lambda (cell) (set-cdr! cell val)))
+             (else
+              (set-props! st (cons (cons x val) (get-props st))))))))
+       (define-syntax tell
+         (syntax-rules (quote field ...)
+           ((tell st 'field val) (put st val)) ...
+           ((tell st x val) (%tell st x val))))
+       ;; External API
+       ;;
+       ;; copy
+       (define (c st)
+         (make-state
+          (get st) ...
+          (map (lambda (x) (cons (car x) (cdr x))) (get-props st))))
+       ;; bind - a function
+       (define-syntax f!
+         (syntax-rules ::: ()
+           ((f! ("step") (params :::) ((p param) . rest) . body)
+            (f! ("step") (params ::: (p param)) rest . body))
+           ((f! ("step") (params :::) ((param) . rest) . body)
+            (f! ("step") (params ::: (param param)) rest . body))
+           ((f! ("step") (params :::) (param . rest) . body)
+            (f! ("step") (params ::: (param param)) rest . body))
+           ((f! ("step") ((p param) :::) () . body)
+            (lambda (st)
+              (let ((p (ask st 'param)) :::)
+                ((let () . body) st))))
+           ((f! params . body)
+            (f! ("step") () params . body))))
+       ;; fork - run on a copy of the state
+       (define-syntax f
+         (syntax-rules ()
+           ((f a) a)
+           ((f a b) (lambda (st) (a (c st)) (b st)))
+           ((f a b . c) (f a (f b . c)))))
+       ;; sequence
+       (define-syntax s
+         (syntax-rules ()
+           ((s f) f)
+           ((s f . g) (lambda (st) ((s . g) (f st))))))
+       ;; update in place
+       (define-syntax u
+         (syntax-rules ::: ()
+           ((u (prop value) :::)
+            (lambda (st)
+              (tell st 'prop value) :::
+              st))))
+       ;; local binding - update temporarily
+       (define-syntax w
+         (syntax-rules ::: ()
+           ((w ("step") ((p tmp v) :::) () . b)
+            (lambda (st)
+              (let ((tmp (ask st 'p)) :::)
+                (tell st 'p v) :::
+                (let ((st ((begin . b) st)))
+                  (tell st 'p tmp) :::
+                  st))))
+           ((w ("step") (props :::) ((p v) . rest) . b)
+            (w ("step") (props ::: (p tmp v)) rest . b))
+           ((w ((prop value) :::) . body)
+            (w ("step") () ((prop value) :::) . body))))
+       ;; run
+       (define (r proc)
+         (proc (make-state init ... '())))
+       ;; return
+       (define (z x)
+         (lambda (st) x))))))
diff --git a/lib/chibi/monad/environment.sld b/lib/chibi/monad/environment.sld
new file mode 100644
index 00000000..d8674453
--- /dev/null
+++ b/lib/chibi/monad/environment.sld
@@ -0,0 +1,5 @@
+
+(define-library (chibi monad environment)
+  (export define-environment-monad)
+  (import (scheme base))
+  (include "environment.scm"))
diff --git a/lib/chibi/net.scm b/lib/chibi/net.scm
new file mode 100644
index 00000000..5895994c
--- /dev/null
+++ b/lib/chibi/net.scm
@@ -0,0 +1,164 @@
+;; Copyright (c) 2010-2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> \procedure{(make-address-info family socktype proto [hints])}
+
+(define (make-address-info family socktype proto . o)
+  (%make-address-info family socktype proto (if (pair? o) (car o) 0)))
+
+;;> \procedure{(get-address-info host service [addrinfo])}
+
+;;> Create and return a new addrinfo structure for the given host
+;;> and service.  \var{host} should be a string and \var{service} a
+;;> string or integer.  The optional \var{addrinfo} defaults to
+;;> a TCP/IP stream setting.
+
+(define (get-address-info host service . o)
+  (%get-address-info host
+                     (if (integer? service) (number->string service) service)
+                     (if (and (pair? o) (car o))
+                         (car o)
+                         (make-address-info address-family/unspecified
+                                            socket-type/stream
+                                            ip-proto/ip
+                                            ai/passive))))
+
+;;> Opens a client net connection to \var{host}, a string,
+;;> on port \var{service}, which can be a string such as
+;;> \scheme{"http"} or an integer.  Returns a list of three
+;;> values on success - the socket, an input port, and an
+;;> output port - or \scheme{#f} on failure.
+
+(define (open-net-io host service)
+  (let lp ((addr (get-address-info host service)))
+    (if (not addr)
+        (error "couldn't find address" host service)
+        (let ((sock (socket (address-info-family addr)
+                            (address-info-socket-type addr)
+                            (address-info-protocol addr))))
+          (if (not (fileno? sock))
+              (lp (address-info-next addr))
+              (cond
+               ((negative?
+                 (connect sock
+                          (address-info-address addr)
+                          (address-info-address-length addr)))
+                (lp (address-info-next addr)))
+               (else
+                (cond-expand
+                 (threads (set-file-descriptor-status! sock open/non-block))
+                 (else #f))
+                (list sock
+                      (open-input-file-descriptor sock #t)
+                      (open-output-file-descriptor sock #t)))))))))
+
+;;> Convenience wrapper around \scheme{open-net-io}, opens
+;;> the connection then calls \var{proc} with two arguments,
+;;> the input port and the output port connected to the
+;;> service, then closes the connection.  Returns the result
+;;> of \var{proc}.  Raises an error if a connection can't
+;;> be made.
+
+(define (with-net-io host service proc)
+  (let ((io (open-net-io host service)))
+    (if (not (pair? io))
+        (error "couldn't find address" host service)
+        (let ((res (proc (cadr io) (car (cddr io)))))
+          (close-input-port (cadr io))
+          (close-output-port (car (cddr io)))
+          (close-file-descriptor (car io))
+          res))))
+
+;;> \procedure{(make-listener-socket addrinfo [max-conn])}
+
+;;> Convenience wrapper to call socket, bind and listen to return
+;;> a socket suitable for accepting connections on the given
+;;> \var{addrinfo}.  \var{max-conn} is the maximum number of pending
+;;> connections, and defaults to 128.  Automatically specifies
+;;> \scheme{socket-opt/reuseaddr}.
+
+(define (make-listener-socket addrinfo . o)
+  (let* ((max-connections (if (pair? o) (car o) 128))
+         (sock (socket (address-info-family addrinfo)
+                       (address-info-socket-type addrinfo)
+                       (address-info-protocol addrinfo))))
+    (cond
+     ((not sock)
+      (error "couldn't create socket for: " addrinfo))
+     ((not (set-socket-option! sock level/socket socket-opt/reuseaddr 1))
+      (error "couldn't set the socket to be reusable" addrinfo))
+     ((not (bind sock
+                 (address-info-address addrinfo)
+                 (address-info-address-length addrinfo)))
+      (close-file-descriptor sock)
+      (error "couldn't bind socket" sock addrinfo))
+     ((not (listen sock max-connections))
+      (close-file-descriptor sock)
+      (error "couldn't listen on socket" sock addrinfo))
+     (else
+      sock))))
+
+;;> Returns the socket option of the given \var{name} for \var{socket}.
+;;> \var{socket} should be a file descriptor, level the constant
+;;> \scheme{level/socket}, and name one of the constants beginning with
+;;> "socket-opt/".
+
+(define (get-socket-option socket level name)
+  (let ((res (getsockopt socket level name)))
+    (and (pair? res) (car res))))
+
+;;> Sends the bytevector \var{bv} to \var{socket} with sendto and
+;;> returns the number of bytes sent, or a negative value on error.
+;;> If \var{addrinfo} is unspecified, \var{socket} must previously
+;;> have had a default address specified with \scheme{connect}.
+
+(define (send socket bv . o)
+  (apply send/non-blocking socket bv #f o))
+
+;;> Equivalent to \scheme{send} but gives up and returns false if the
+;;> packet can't be sent within \var{timeout} seconds.
+
+(define (send/non-blocking socket bv timeout . o)
+  (let* ((flags (if (pair? o) (car o) 0))
+         (addrinfo (and (pair? o) (pair? (cdr o)) (cadr o)))
+         (sockaddr (and addrinfo (address-info-address addrinfo)))
+         (sockaddr-len (if addrinfo (address-info-address-length addrinfo) 0)))
+    (%send socket bv flags sockaddr sockaddr-len timeout)))
+
+;;> Recieves data from \var{socket} to fill the bytevector \var{bv} by
+;;> calling recvfrom.  Returns the number of bytes read, or a negative
+;;> value on error.  If \var{addrinfo} is unspecified, \var{socket}
+;;> must previously have had a default address specified with
+;;> \scheme{connect}.
+
+(define (receive! socket bv . o)
+  (apply receive!/non-blocking socket bv #f o))
+
+;;> Equivalent to \scheme{receive!} but gives up and returns false if
+;;> no packets are received within \var{timeout} seconds.
+
+(define (receive!/non-blocking socket bv timeout . o)
+  (let* ((flags (if (pair? o) (car o) 0))
+         (addrinfo (and (pair? o) (pair? (cdr o)) (cadr o)))
+         (sockaddr (and addrinfo (address-info-address addrinfo)))
+         (sockaddr-len (if addrinfo (address-info-address-length addrinfo) 0)))
+    (%receive! socket bv flags sockaddr sockaddr-len timeout)))
+
+;;> Shortcut for \scheme{receive}, returning a newly created
+;;> bytevector of length \var{n} on success and \scheme{#f} on
+;;> failure.
+
+(define (receive socket n . o)
+  (let* ((bv (make-bytevector n))
+         (m (apply receive! socket bv o)))
+    (and (>= m 0)
+         (subbytes bv 0 m))))
+
+;;> Equivalent to \scheme{receive} but gives up and returns false if
+;;> no packets are received within \var{timeout} seconds.
+
+(define (receive/non-blocking socket n timeout . o)
+  (let* ((bv (make-bytevector n))
+         (m (apply receive!/non-blocking socket bv timeout o)))
+    (and (>= m 0)
+         (subbytes bv 0 m))))
diff --git a/lib/chibi/net.sld b/lib/chibi/net.sld
new file mode 100644
index 00000000..011d954c
--- /dev/null
+++ b/lib/chibi/net.sld
@@ -0,0 +1,26 @@
+
+(define-library (chibi net)
+  (export sockaddr? address-info? get-address-info make-address-info
+          socket connect bind accept listen open-socket-pair
+          sockaddr-name sockaddr-port make-sockaddr
+          with-net-io open-net-io make-listener-socket
+          send receive! receive
+          send/non-blocking receive!/non-blocking receive/non-blocking
+          address-info-family address-info-socket-type address-info-protocol
+          address-info-address address-info-address-length address-info-next
+          address-family/unix address-family/inet address-family/inet6
+          address-family/unspecified
+          socket-type/stream socket-type/datagram socket-type/raw
+          ip-proto/ip ip-proto/icmp ip-proto/tcp ip-proto/udp
+          ai/passive ai/canonname ai/numeric-host
+          get-socket-option set-socket-option! level/socket
+          socket-opt/debug socket-opt/broadcast socket-opt/reuseaddr
+          socket-opt/keepalive socket-opt/oobinline socket-opt/sndbuf
+          socket-opt/rcvbuf socket-opt/dontroute socket-opt/rcvlowat
+          socket-opt/sndlowat
+          get-peer-name
+          ;; C structs
+          sockaddr addrinfo)
+  (import (chibi) (chibi filesystem))
+  (include-shared "net")
+  (include "net.scm"))
diff --git a/lib/chibi/net.stub b/lib/chibi/net.stub
new file mode 100644
index 00000000..f77228a2
--- /dev/null
+++ b/lib/chibi/net.stub
@@ -0,0 +1,130 @@
+
+(c-system-include "arpa/inet.h")
+(c-system-include "sys/types.h")
+(c-system-include "sys/socket.h")
+(c-system-include "netinet/in.h")
+(c-system-include "netdb.h")
+
+(define-c-int-type socklen_t)
+
+(define-c-struct sockaddr
+  constructor: (make-sockaddr)
+  predicate:   sockaddr?)
+
+(define-c-struct addrinfo
+  constructor: (%make-address-info ai_family ai_socktype ai_protocol ai_flags)
+  finalizer: freeaddrinfo
+  predicate: address-info?
+  (int              ai_family    address-info-family)
+  (int              ai_socktype  address-info-socket-type)
+  (int              ai_protocol  address-info-protocol)
+  (int              ai_flags     address-info-flags)
+  ((link sockaddr)  ai_addr      address-info-address)
+  (size_t           ai_addrlen   address-info-address-length)
+  ((link addrinfo)  ai_next      address-info-next))
+
+;;> The addrinfo struct accessors.
+;;/
+
+(define-c errno (%get-address-info getaddrinfo)
+  ((maybe-null string) (maybe-null string) (maybe-null addrinfo)
+   (result free addrinfo)))
+
+;;> Bind a name to a socket.
+
+(define-c sexp (bind "sexp_bind")
+  ((value ctx sexp) (value self sexp) fileno sockaddr int))
+
+;;> Listen on a socket.
+
+(define-c sexp (listen "sexp_listen")
+  ((value ctx sexp) (value self sexp) sexp sexp))
+
+;;> Accept a connection on a socket.
+
+(define-c sexp (accept "sexp_accept")
+  ((value ctx sexp) (value self sexp) fileno sockaddr int))
+
+;;> Create an endpoint for communication.
+
+(define-c fileno socket (int int int))
+
+;;> Initiate a connection on a socket.
+
+(define-c int connect (fileno sockaddr int))
+
+(define-c sexp (%send "sexp_sendto")
+  ((value ctx sexp) (value self sexp)
+   fileno bytevector (value (bytevector-length arg3) size_t) int
+   (maybe-null sockaddr) socklen_t sexp))
+
+(define-c sexp (%receive! "sexp_recvfrom")
+  ((value ctx sexp) (value self sexp)
+   fileno bytevector (value (bytevector-length arg3) size_t) int
+   (maybe-null sockaddr) socklen_t sexp))
+
+;;> Returns a list of 2 new sockets, the input and output end of a new
+;;> pipe, respectively.
+
+(define-c errno (open-socket-pair "socketpair")
+  (int int int (result (array fileno 2))))
+
+;;> Return the IP address of a sockaddr as an "N.N.N.N" string.
+
+(define-c sexp (sockaddr-name "sexp_sockaddr_name")
+  ((value ctx sexp) (value self sexp) sockaddr))
+
+;;> Return the port a sockaddr is connected on.
+
+(define-c int (sockaddr-port "sexp_sockaddr_port")
+  ((value ctx sexp) (value self sexp) sockaddr))
+
+(define-c-const int (address-family/unspecified "AF_UNSPEC"))
+(define-c-const int (address-family/unix "AF_UNIX"))
+(define-c-const int (address-family/inet "AF_INET"))
+(define-c-const int (address-family/inet6 "AF_INET6"))
+(define-c-const int (socket-type/stream "SOCK_STREAM"))
+(define-c-const int (socket-type/datagram "SOCK_DGRAM"))
+(define-c-const int (socket-type/raw "SOCK_RAW"))
+(define-c-const int (ip-proto/ip "IPPROTO_IP"))
+(define-c-const int (ip-proto/icmp "IPPROTO_ICMP"))
+(define-c-const int (ip-proto/tcp "IPPROTO_TCP"))
+(define-c-const int (ip-proto/udp "IPPROTO_UDP"))
+(define-c-const int (ai/passive "AI_PASSIVE"))
+(define-c-const int (ai/canonname "AI_CANONNAME"))
+(define-c-const int (ai/numeric-host "AI_NUMERICHOST"))
+
+;;> The constants for the addrinfo struct.
+;;/
+
+(c-include-verbatim "accept.c")
+
+(define-c errno (get-peer-name getpeername)
+  (fileno sockaddr (result (value (sizeof sockaddr) socklen_t))))
+
+(define-c errno getsockopt
+  (fileno int int (result int) (result (value (sizeof int) socklen_t))))
+
+;;> Set an option for the given socket.  For example, to make the
+;;> address reusable:
+;;> \scheme{(set-socket-option! sock level/socket socket-opt/reuseaddr 1)}
+
+(define-c errno (set-socket-option! "setsockopt")
+  (fileno int int (pointer int) (value (sizeof int) socklen_t)))
+
+(define-c-const int (level/socket "SOL_SOCKET"))
+
+(define-c-const int (socket-opt/debug "SO_DEBUG"))
+(define-c-const int (socket-opt/broadcast "SO_BROADCAST"))
+(define-c-const int (socket-opt/reuseaddr "SO_REUSEADDR"))
+(define-c-const int (socket-opt/keepalive "SO_KEEPALIVE"))
+(define-c-const int (socket-opt/oobinline "SO_OOBINLINE"))
+(define-c-const int (socket-opt/sndbuf "SO_SNDBUF"))
+(define-c-const int (socket-opt/rcvbuf "SO_RCVBUF"))
+(define-c-const int (socket-opt/dontroute "SO_DONTROUTE"))
+(define-c-const int (socket-opt/rcvlowat "SO_RCVLOWAT"))
+(define-c-const int (socket-opt/sndlowat "SO_SNDLOWAT"))
+
+;;> The constants for the \scheme{get-socket-option} and
+;;> \scheme{set-socket-option!}.
+;;/
diff --git a/lib/chibi/net/http-server.scm b/lib/chibi/net/http-server.scm
new file mode 100644
index 00000000..68c1566d
--- /dev/null
+++ b/lib/chibi/net/http-server.scm
@@ -0,0 +1,512 @@
+;; http-server.scm -- combinator-based http server
+;; Copyright (c) 2013-2014 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> Runs an http server listening at the given address, with the given
+;;> servlet.
+;;>
+;;> An servlet is a procedure which takes three arguments: an
+;;> \scheme{Http-Request} record, which contains the I/O ports and
+;;> parsed request and headers; a \scheme{next} procedure to call the
+;;> next available servlet if any, and a \scheme{restart} procedure to
+;;> restart the servlets with a new request.
+
+(define (run-http-server listener-or-addr servlet . o)
+  (let ((cfg (if (pair? o) (car o) (make-conf '() #f #f #f))))
+    (run-net-server
+     listener-or-addr
+     (command-handler
+      (lambda (command ls in out sock addr)
+        (cond
+         ((= 2 (length ls))
+          (let ((request
+                 (make-request command (car ls) (cadr ls) in out sock addr)))
+            (log-info `(request: ,command ,(car ls) ,(cadr ls)
+                                 ,(request-headers request)))
+            (protect (exn
+                      (else
+                       (log-error "internal error: " exn)
+                       (servlet-respond request 500 "Internal server error")))
+              (let restart ((request request))
+                (servlet cfg request servlet-bad-request restart)))))
+         (else
+          (let ((request (make-request command #f #f in out sock addr)))
+            (servlet-respond request 400 "bad request")))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Servlets.
+
+(define (http-chain-servlets f . o)
+  (let lp ((f f) (ls o))
+    (if (pair? ls)
+        (let ((g (lp (car ls) (cdr ls))))
+          (lambda (cfg request next restart)
+            (let ((next2 (lambda (cfg request) (g cfg request next restart))))
+              (f cfg request next2 restart))))
+        f)))
+
+(define (http-wrap-default servlet)
+  (http-chain-servlets servlet http-default-servlet))
+
+(define (http-guard-servlet cfg request next restart)
+  (let ((orig-out (request-out request))
+        (tmp-out (open-output-string))
+        (request2 (copy-request request)))
+    (request-out-set! request2 tmp-out)
+    (protect (exn (else (servlet-respond request 500 "Interal server error")))
+      (next cfg request2)
+      (display (get-output-string tmp-out) orig-out))))
+
+(define (http-parse-body-servlet cfg request next restart)
+  (let ((request2 (copy-request request)))
+    (servlet-parse-body! request2)
+    (next cfg request2)))
+
+(define (http-get*-servlet proc)
+  (lambda (cfg request next restart)
+    (if (memq (request-method request) '(GET POST))
+        (proc cfg request next restart)
+        (next cfg request))))
+
+;; Generate a simple page listing the linked files in a directory.
+(define (send-directory path out)
+  (display "<html><body bgcolor=white><pre>\n" out)
+  (for-each
+   (lambda (file)
+     (display "<a href=\"/" out)
+     (display (path-normalize (make-path path file)) out)
+     (display "\">" out)
+     (display file out)
+     (display "</a>\n" out))
+   (sort (directory-files path)))
+  (display "</pre></body></html>\n" out))
+
+;; TODO: If the index-rx is a short list of fixed strings, check
+;; individually to avoid the full directory lookup.
+(define (find-index-file dir index-rx)
+  (and index-rx
+       (any (lambda (f) (and (regexp-matches? index-rx f) (make-path dir f)))
+            (directory-files dir))))
+
+(define (http-send-directory request path index-rx restart)
+  (cond
+   ((find-index-file path index-rx)
+    => (lambda (index-file)
+         ;; Generate and restart a new request with explicit index file.
+         (let* ((uri (request-uri request))
+                (path2 (make-path (uri-path uri) index-file)))
+           (restart
+            (request-with-uri request (uri-with-path uri path2))))))
+   (else
+    (send-directory path (request-out request)))))
+
+(define (http-send-file request path)
+  (cond
+   ((file-exists? path)
+    (servlet-respond request 200 "OK")
+    (send-file path (request-out request)))
+   (else
+    (servlet-respond request 404 "Not Found"))))
+
+(define (http-file-servlet . o)
+  (let ((dir (if (pair? o) (car o) "."))
+        (index-rx (and (pair? o) (pair? (cdr o)) (cadr o))))
+    (http-get*-servlet
+     (lambda (cfg request next restart)
+       (let ((path (make-path dir (request-path request))))
+         (if (file-directory? path)
+             (http-send-directory request path index-rx restart)
+             (http-send-file request path)))))))
+
+(define (http-procedure-servlet path proc)
+  (http-get*-servlet
+   (lambda (cfg request next restart)
+     (cond
+      ((equal? path (path-normalize (request-path request)))
+       (servlet-respond request 200 "OK")
+       (proc request))
+      (else
+       (next cfg request))))))
+
+(define (http-regexp-servlet rules get-field)
+  (lambda (cfg request next restart)
+    (let ((str (get-field request)))
+      (let lp ((request request) (ls rules))
+        (cond
+         ((null? ls)
+          (next cfg request))
+         ((not (valid-sre? (caar ls)))
+          (log-warn "invalid sre: " (caar ls))
+          (lp request (cdr ls)))
+         ((regexp-matches? (caar ls) str)
+          => (lambda (m)
+               (let ((next (lambda (cfg request) (lp request (cdr ls)))))
+                 ((cdar ls) cfg request next restart))))
+         (else
+          (lp request (cdr ls))))))))
+
+(define (http-uri-regexp-servlet rules)
+  (http-regexp-servlet rules request-uri-string))
+
+(define (http-path-regexp-servlet rules)
+  (http-regexp-servlet
+   rules
+   (lambda (request) (uri-path (request-uri request)))))
+
+(define (http-host-regexp-servlet rules)
+  (http-regexp-servlet rules request-host))
+
+(define (http-regexp-replace-servlet rules helper)
+  (lambda (cfg request next restart)
+    (let ((uri (uri->string (request-uri request))))
+      (let lp ((ls rules))
+        (if (null? ls)
+            (next cfg request)
+            (let ((uri2 (regexp-replace (caar ls) uri (cdar ls))))
+              (cond
+               ((equal? uri uri2)
+                (lp (cdr ls)))
+               ((string->path-uri uri2)
+                => (lambda (uri)
+                     (helper (request-with-uri request uri) next restart)))
+               (else
+                (log-warn "invalid rewritten uri: " uri2)
+                (lp (cdr ls))))))))))
+
+(define (http-redirect-servlet rules)
+  (http-regexp-replace-servlet
+   rules
+   (lambda (cfg request next restart)
+     (let ((headers `(Location . ,(uri->string (request-uri request)))))
+       (servlet-respond request 302 "Found" headers)))))
+
+(define (http-rewrite-servlet rules)
+  (http-regexp-replace-servlet
+   rules
+   (lambda (cfg request next restart) (restart request))))
+
+(define (index-path-map-servlet from to index-rx servlet)
+  (http-get*-servlet
+   (lambda (cfg request next restart)
+     (let* ((path (path-normalize (uri-path (request-uri request))))
+            (rel-path (path-relative-to path from)))
+       (cond
+        (rel-path
+         (let* ((local-path (make-path to rel-path))
+                (local-path
+                 (if (and index-rx (file-directory? local-path))
+                     (find-index-file local-path index-rx)
+                     local-path)))
+           (if (file-exists? local-path)
+               (servlet cfg request local-path next restart)
+               (servlet-respond request 404 "Not found"))))
+        (else
+         (next cfg request)))))))
+
+(define (path-map-servlet from to servlet)
+  (index-path-map-servlet from to #f servlet))
+
+(define (http-cgi-bin-servlet request local-path next restart)
+  (call-with-temp-file "cgi.out"
+    (lambda (temp-file out)
+      (let ((pid (fork)))
+        (cond
+         ((zero? pid)
+          (duplicate-file-descriptor-to
+           (port-fileno (request-in request)) 0)
+          (duplicate-file-descriptor-to (port-fileno out) 1)
+          (safe-setenv "HTTP_HOST" (request-host request))
+          (safe-setenv "REQUEST_URI" (uri->string (request-uri request)))
+          (safe-setenv "REQUEST_METHOD"
+                       (symbol->string (request-method request)))
+          (safe-setenv "QUERY_STRING"
+                       (or (uri-query (request-uri request)) ""))
+          (let ((res (execute local-path (list local-path))))
+            (display "failed to execute program: " (current-error-port))
+            (write local-path (current-error-port))
+            (display " => " (current-error-port))
+            (write res (current-error-port))
+            (newline (current-error-port))
+            (exit 1)))
+         (else
+          (let ((status (waitpid pid 0)))
+            (cond
+             ((negative? (car status))
+              (servlet-respond request 500 "Internal server error"))
+             (else
+              (display "HTTP/1.0 200 OK\r\n" (request-out request))
+              (flush-output (request-out request))
+              (send-file temp-file (request-out request))
+              (close-output-port out))))))))))
+
+(define (http-cgi-bin-dir-servlet local-dir . o)
+  (let ((virtual-dir (if (pair? o) (car o) "/cgi-bin")))
+    (path-map-servlet
+     virtual-dir local-dir
+     (lambda (cfg request prog-path next restart)
+       (http-cgi-bin-servlet request prog-path next restart)))))
+
+(define (with-add-to-load-path dir thunk)
+  (if dir
+      (let* ((orig-path (current-module-path))
+             (new-path (cons dir (current-module-path))))
+        (dynamic-wind (lambda () (current-module-path new-path))
+                      thunk
+                      (lambda () (current-module-path orig-path))))
+      (thunk)))
+
+(define (make-import-environment)
+  (let ((env (make-environment)))
+    (%import env (current-environment) '(import) #t)
+    env))
+
+(define (load-scheme-script path . o)
+  (if (and (file-exists? path) (not (file-directory? path)))
+      (let ((env (make-import-environment)) 
+            (handle #f))
+        (protect (exn (else
+                       (log-error "failed to load servlet " exn)))
+          (let ((e1 (call-with-input-file path read)))
+            (cond
+             ((not (and (pair? e1) (eq? 'import (car e1))))
+              (log-error "not a scheme program (no import): " path))
+             (else
+              (parameterize ((servlet-handler (lambda (h) (set! handle h))))
+                (with-add-to-load-path (and (pair? o) (car o))
+                                       (lambda () (load path env))))))))
+        (cond ((not (procedure? handle))
+               (log-error "no servlet defined in " path)
+               (lambda (cfg request next restart)
+                 (servlet-respond request 500 "Internal server error")))
+              (else handle)))
+      (lambda (cfg request next restart)
+        (servlet-respond request 404 "Not found"))))
+
+(define load-scheme-script/memoized
+  (memoize-file-loader load-scheme-script))
+
+(define (http-scheme-script-dir-servlet local-dir . o)
+  (let ((virtual-dir (or (and (pair? o) (car o)) "/"))
+        (index-rx (and (pair? o) (pair? (cdr o)) (cadr o))))
+    (index-path-map-servlet
+     virtual-dir local-dir index-rx
+     (lambda (cfg request script-path next restart)
+       (let ((servlet (load-scheme-script/memoized script-path local-dir)))
+         (servlet cfg request next restart))))))
+
+(define (http-scheme-script-ext-servlet cfg request local-path next restart)
+  ((load-scheme-script/memoized local-path) cfg request next restart))
+
+(define (get-ext-servlet x file)
+  (if (procedure? x)
+      x
+      (case x
+        ((scheme) http-scheme-script-ext-servlet)
+        ((cgi) http-cgi-bin-servlet)
+        (else (error "unknown ext servlet" x)))))
+
+(define (http-ext-servlet rules local-dir . o)
+  (let ((virtual-dir (if (pair? o) (car o) "/")))
+    (path-map-servlet
+     virtual-dir local-dir
+     (lambda (cfg request local-path next restart)
+       (cond
+        ((assoc (path-extension local-path) rules)
+         => (lambda (cell)
+              (let ((name (if (pair? (cdr cell)) (cadr cell) (cdr cell))))
+                ((get-ext-servlet name local-path) cfg request local-path next restart))))
+        (else
+         (next cfg request)))))))
+
+(define (http-default-servlet cfg request next restart)
+  (case (request-method request)
+    ((HEAD)
+     (call-with-temp-file "get.out"
+       (lambda (temp-file out)
+         (let ((request2 (copy-request request)))
+           (request-method-set! request2 'GET)
+           (request-out-set! request2 out)
+           (restart request2)
+           (close-output-port out)
+           (call-with-input-file temp-file
+             (lambda (in)
+               (let* ((status (read-line in))
+                      (headers (mime-headers->list in))
+                      (out (request-out request)))
+                 (display status out)
+                 (display "\r\n" out)
+                 (mime-write-headers headers out)
+                 (display "\r\n" out))))))))
+    ((BREW)
+     (servlet-respond request 418 "I'm a teapot"))
+    (else
+     (servlet-bad-request cfg request next restart))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Config-based servlets.
+
+;; Utility to wrap SRE rules.
+(define (http-wrap-sre-config cfg clear ls)
+  (map
+   (lambda (x)
+     (cond
+      ((valid-sre? (car x))
+       `(,(regexp (car x))
+         . ,(http-config-servlet
+             (make-conf (cdr x) (make-conf `((,clear)) cfg #f #f) #f #f))))
+      (else
+       (log-error "invalid sre in config: " (car x))
+       `(,(regexp '(+ (~ any)))
+         . ,(lambda (request) (error "unreachable servlet"))))))
+   ls))
+
+;; Utility to wrap servlets which take a local path as the first arg.
+(define (http-wrap-doc-root f)
+  (lambda (args cfg)
+    (let* ((root (conf-get cfg 'doc-root "."))
+           (local-dir (if (pair? args) (car args) "/"))
+           (virtual-dir (if (and (pair? args) (pair? (cdr args)))
+                            (cadr args)
+                            (make-path "/" local-dir)))
+           (args (append (list (make-path root local-dir) virtual-dir)
+                         (if (and (pair? args) (pair? (cdr args)))
+                             (cddr args)
+                             '()))))
+      (f args cfg))))
+
+(define (http-config-file-servlet cfg . o)
+  (let* ((root (conf-get cfg 'doc-root "."))
+         (dir (make-path root (if (pair? o) (car o) ".")))
+         (index-rx (if (and (pair? o) (pair? (cdr o)))
+                       (cadr o)
+                       (conf-get cfg 'index-regexp "index.html"))))
+    (http-file-servlet dir index-rx)))
+
+;; Ordered list of servlets to try for a given config.  Generally
+;; gives the intuitive order, but manual ordering can be imposed with
+;; regexp rules.
+(define ordered-config-servlets
+  `((redirect . ,(lambda (rules cfg) (http-redirect-servlet rules)))
+    (rewrite . ,(lambda (rules cfg) (http-rewrite-servlet rules)))
+    (host . ,(lambda (hosts cfg)
+               (http-host-regexp-servlet
+                (http-wrap-sre-config cfg 'host hosts))))
+    (uri . ,(lambda (rules cfg)
+              (http-uri-regexp-servlet
+               (http-wrap-sre-config cfg 'uri rules))))
+    (path . ,(lambda (rules cfg)
+               (http-path-regexp-servlet
+                (http-wrap-sre-config cfg 'path rules))))
+    (file . ,(lambda (x cfg)
+               (apply http-config-file-servlet cfg x)))
+    (cgi . ,(http-wrap-doc-root
+             (lambda (dirs cfg) (apply http-cgi-bin-dir-servlet dirs))))
+    (scheme . ,(http-wrap-doc-root
+                (lambda (dirs cfg)
+                  (let ((local-dir (car dirs))
+                        (virtual-dir (cadr dirs))
+                        (index-rx (conf-get cfg 'index-regexp "index.scm")))
+                    (http-scheme-script-dir-servlet
+                     local-dir virtual-dir index-rx)))))
+    (ext . ,(lambda (rules cfg)
+              (http-ext-servlet rules (conf-get cfg 'doc-root "."))))
+    ))
+
+;; Config servlet for an already constructed config.
+(define (http-config-conf-servlet cfg . o)
+  (http-chain-servlets
+   (lambda (orig-cfg request next restart)
+     (next cfg request))
+   (let lp ((ls ordered-config-servlets))
+     (cond
+      ((null? ls)
+       (if (pair? o)
+           (http-chain-servlets (car o) http-default-servlet)
+           http-default-servlet))
+      ((conf-get-cdr cfg (caar ls))
+       => (lambda (x)
+            (let ((rest (lp (cdr ls))))
+              (if (or (pair? x) (null? x))
+                  (http-chain-servlets ((cdar ls) x cfg) rest) 
+                  rest))))
+      (else
+       (lp (cdr ls)))))))
+
+;; Config servlet to load a config from a file.
+(define (http-config-servlet-load file . o)
+  (let* ((cfg (conf-load file))
+         (cfg (if (and (pair? o) (conf? (car o)))
+                  (if (and (pair? (cdr o)) (conf? (cadr o)))
+                      (conf-append (car o) (conf-append cfg (cadr o)))
+                      (conf-append (car o) cfg))
+                  cfg)))
+    (http-config-conf-servlet cfg (http-config-file-servlet cfg))))
+
+;; Primary config servlet which dispatches on argument type.
+(define (http-config-servlet x)
+  (cond
+   ((procedure? x)
+    x)
+   ((list? x)
+    (http-config-conf-servlet (make-conf x #f #f (current-second))))
+   ((string? x)
+    (if (file-directory? x)
+        (http-file-servlet x)
+        (http-config-servlet (make-conf #f #f x -1))))
+   ((not (conf? x))
+    (error "unknown type for http-config-servlet" x))
+   ((and (string? (conf-source x))
+         (file-exists? (conf-source x)))
+    (let* ((f (conf-source x))
+           (mtime (file-modification-time f)))
+      ((memoize-file-loader
+        (lambda (f) (http-config-servlet-load f #f (conf-parent x)))
+        'reloader?: #true
+        'cache: `(((,mtime . ,f) . ,x)))
+       f)))
+   ((and (conf-parent x)
+         (string? (conf-source (conf-parent x)))
+         (file-exists? (conf-source (conf-parent x))))
+    (let* ((f (conf-source (conf-parent x)))
+           (mtime (file-modification-time f)))
+      ((memoize-file-loader
+        (lambda (f) (http-config-servlet-load f (conf-head x) (conf-parent x)))
+        'reloader?: #true
+        'cache: `(((,mtime . ,f) . ,x)))
+       f)))
+   (else
+    (http-config-conf-servlet x))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Sample main.  In chibi-scheme you can run:
+;;
+;; chibi-scheme -Rchibi.net.http-config-server -- [<cfg-file-or-directory>]
+;;
+;; which defaults to serving the current directory on port 8000.
+
+(define (run-app cfg spec . args)
+  (define (run cfg servlet)
+    (run-http-server (conf-get cfg 'port 8000) servlet cfg))
+  (cond
+   ((> (length args) 1)
+    (error "usage: httpd [<cfg-file-or-directory>]"))
+   ((or (null? args) (file-directory? (car args)))
+    (let ((dir (if (null? args) "." (car args))))
+      (run cfg (http-wrap-default (http-config-file-servlet cfg dir)))))
+   (else
+    (let* ((cfg-file (car args))
+           (last-cfg
+            (make-conf `((doc-root . ,(path-directory cfg-file))) #f #f #f))
+           (cfg (conf-append cfg (conf-append (conf-load cfg-file) last-cfg))))
+      (run cfg (http-config-servlet cfg))))))
+
+(define app-spec
+  `(http-config-server
+    "Config-based HTTP server"
+    (@
+     ((port integer)
+      (doc-root string)
+      (verbose? boolean (#\v "verbose"))))
+    ,run-app))
+
+(define (main args) (run-application app-spec args))
diff --git a/lib/chibi/net/http-server.sld b/lib/chibi/net/http-server.sld
new file mode 100644
index 00000000..f917907a
--- /dev/null
+++ b/lib/chibi/net/http-server.sld
@@ -0,0 +1,17 @@
+
+(define-library (chibi net http-server)
+  (export
+   ;; main interface
+   run-http-server
+   ;; basic servlets
+   http-chain-servlets http-default-servlet http-wrap-default
+   http-file-servlet http-procedure-servlet http-ext-servlet
+   http-regexp-servlet http-path-regexp-servlet http-uri-regexp-servlet
+   http-host-regexp-servlet http-redirect-servlet http-rewrite-servlet
+   http-cgi-bin-dir-servlet http-scheme-script-dir-servlet)
+  (import (scheme time) (srfi 39) (srfi 95)
+          (chibi) (chibi mime) (chibi regexp) (chibi pathname) (chibi uri)
+          (chibi filesystem) (chibi io) (chibi string) (chibi process)
+          (chibi net server) (chibi net server-util) (chibi net servlet)
+          (chibi app) (chibi ast) (chibi config) (chibi log) (chibi memoize))
+  (include "http-server.scm"))
diff --git a/lib/chibi/net/http.scm b/lib/chibi/net/http.scm
new file mode 100644
index 00000000..bb12be88
--- /dev/null
+++ b/lib/chibi/net/http.scm
@@ -0,0 +1,334 @@
+;; http.scm -- http client
+;; Copyright (c) 2009-2013 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; string utils
+
+(define (string-char-index str c . o)
+  (let ((start (if (pair? o) (car o) 0))
+        (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str))))
+    (let lp ((i start))
+      (cond
+       ((= i end) #f)
+       ((eq? c (string-ref str i)) i)
+       (else (lp (+ i 1)))))))
+
+(define (string-split str ch)
+  (let ((len (string-length str)))
+    (let lp ((i 0) (res '()))
+      (let ((j (string-char-index str ch i)))
+        (if j
+            (lp (+ j 1) (cons (substring str i j) res))
+            (reverse (cons (substring str i len) res)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; client utils
+
+(define http-user-agent "chibi")
+
+(define http-redirect-limit 10)
+(define http-chunked-buffer-size 4096)
+(define http-chunked-size-limit 409600)
+
+(define (string-scan str ch . o)
+  (let ((start (if (pair? o) (car o) 0))
+        (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str))))
+    (let lp ((i start))
+      (and (< i end)
+           (if (eqv? ch (string-ref str i))
+               i
+               (lp (+ i 1)))))))
+
+(define (http-parse-response line)
+  (let* ((len (string-length line))
+         (i (or (string-scan line #\space 0 len) len))
+         (j (or (string-scan line #\space (+ i 1) len) len))
+         (n (and (< i j) (string->number (substring line (+ i 1) j)))))
+    (if (not (integer? n))
+        (error "bad response" line i j)
+        (list (substring line 0 i)
+              n
+              (if (>= j len) "" (substring line (+ j 1) len))))))
+
+(define (make-generated-binary-input-port generator)
+  (let ((buf #u8())
+        (len 0)
+        (offset 0))
+    (make-custom-binary-input-port
+     (lambda (bv start end)
+       (let ((n (- end start)))
+         (cond
+          ((>= (- len offset) n)
+           (bytevector-copy! bv start buf offset (+ offset n))
+           (set! offset (+ offset n))
+           n)
+          (else
+           (bytevector-copy! bv start buf offset (+ offset len))
+           (let lp ((i (+ start (- len offset))))
+             (set! buf (generator))
+             (cond
+              ((not (bytevector? buf))
+               (set! buf #u8())
+               (set! len 0)
+               (set! offset 0)
+               (- i start))
+              (else
+               (set! len (bytevector-length buf))
+               (set! offset 0)
+               (cond
+                ((>= (- len offset) (- n i))
+                 (bytevector-copy! bv i buf offset (+ offset (- n i)))
+                 (set! offset (+ offset (- n i)))
+                 n)
+                (else
+                 (bytevector-copy! bv i buf offset len)
+                 (lp (+ i (- len offset)))))))))))))))
+
+(define (http-wrap-chunked-input-port in)
+  (define (read-chunk in)
+    (let* ((line (read-line in))
+           (n (and (string? line) (string->number line 16))))
+      (cond
+       ((not (and (integer? n) (<= 0 n http-chunked-size-limit)))
+        (error "invalid chunked size line" line))
+       ((zero? n) "")
+       (else (read-bytevector n in)))))
+  (make-generated-binary-input-port
+   (lambda () (read-chunk in))))
+
+(define (http-generate-boundary)
+  (string-append "chibi-boundary-"
+                 (number->string (random-integer 1000000000))))
+
+;; A body can be a raw string or bytevector, or an alist of name/value
+;; pairs.
+(define (http-send-body headers body out)
+  (cond
+   ((string? body)
+    (display body out))
+   ((bytevector? body)
+    (write-bytevector body out))
+   ((pair? body)
+    (let* ((ctype (cond ((or (assq 'Content-Type headers)
+                             (assq 'content-type headers))
+                         => (lambda (x)
+                              (mime-parse-content-type (cdr x))))
+                        (else #f)))
+           (boundary (and ctype (assq-ref (cdr ctype) 'boundary))))
+      (for-each
+       (lambda (x)
+         (display "\r\n--" out)
+         (if boundary (display boundary out))
+         (let* ((content
+                 (if (pair? (cdr x))
+                     (cond ((assq 'value (cdr x)) => cdr)
+                           ((assq 'file (cdr x)) =>
+                            (lambda (x)
+                              (port->bytevector
+                               (open-binary-input-file (cdr x)))))
+                           (else (error "unknown content: " x)))
+                     (cdr x)))
+                (content-type
+                 (cond ((and (pair? (cdr x))
+                             (or (assq 'content-type (cdr x))
+                                 (assq 'Content-Type (cdr x))))
+                        => cdr)
+                       ((string? content) "text/plain")
+                       (else "application/octet-stream"))))
+           (display "\r\nContent-Disposition: form-data; name=\"" out)
+           (display (car x) out)
+           (display "\"" out)
+           (cond ((and (pair? (cdr x)) (assq 'file (cdr x)))
+                  => (lambda (x)
+                       (display "; filename=\"" out)
+                       (display (cdr x) out)
+                       (display "\"" out))))
+           (display "\r\nContent-Type: " out)
+           (display content-type out)
+           (display "\r\n\r\n" out)
+           (http-send-body headers content out)))
+       body)
+      (display "\r\n--" out)
+      (if boundary (display boundary out))
+      (display "--\r\n" out)))
+   (body
+    (error "unknown body" body))))
+
+(define (http-call-method method url in-headers body limit)
+  (if (<= limit 0)
+      (error "http-get: redirect limit reached" (uri->string url))
+      (let* ((uri (if (uri? url) url (string->uri url)))
+             (host (and uri (uri-host uri))))
+        (if (not host)
+            (error "invalid url" url)
+            (let* ((io (open-net-io
+                        host
+                        (or (uri-port uri)
+                            (if (eq? 'https (uri-scheme uri)) 443 80))))
+                   (in (cadr io))
+                   (out (car (cddr io))))
+              (display method out)
+              (display " " out)
+              (display (or (uri-path uri) "/") out)
+              (display " HTTP/1.0\r\n" out)
+              (display "Host: " out) (display host out) (display "\r\n" out)
+              (cond
+               ((not (assq-ref in-headers 'user-agent))
+                (display "User-Agent: " out)
+                (display http-user-agent out)
+                (display "\r\n" out)))
+              (for-each
+               (lambda (x)
+                 (display (car x) out)  (display ": " out)
+                 (display (cdr x) out) (display "\r\n" out))
+               in-headers)
+              (display "Connection: close\r\n\r\n" out)
+              (http-send-body in-headers body out)
+              (flush-output-port out)
+              (let* ((resp (http-parse-response (read-line in)))
+                     (headers (mime-headers->list in))
+                     (status (quotient (cadr resp) 100)))
+                (case status
+                  ((2)
+                   (let ((enc (assq-ref headers 'transfer-encoding)))
+                     (cond
+                      ((equal? enc "chunked")
+                       (cons headers (http-wrap-chunked-input-port in)))
+                      (else
+                       (cons headers in)))))
+                  ((3)
+                   (close-input-port in)
+                   (close-output-port out)
+                   (let ((url2 (assq-ref headers 'location)))
+                     (if url2
+                         (http-get/raw url2 in-headers (- limit 1))
+                         (error "redirect with no location header" url url2))))
+                  (else
+                   (close-input-port in)
+                   (close-output-port out)
+                   (error "couldn't retrieve url" (uri->string url) resp)))))))))
+
+(define (http-get/raw url headers limit)
+  (http-call-method 'GET url headers #f limit))
+
+(define (http-get/headers url . headers)
+  (http-get/raw url
+                (if (pair? headers) (car headers) '())
+                http-redirect-limit))
+
+(define (http-get url . headers)
+  (cdr (apply http-get/headers url headers)))
+
+(define (http-head url . headers)
+  (car (http-call-method 'HEAD url
+                         (if (pair? headers) (car headers) '()) #f
+                         http-redirect-limit)))
+
+(define (http-post url body . o)
+  (let* ((headers (if (pair? o) (car o) '()))
+         (headers
+          (if (or (assq headers 'content-type)
+                  (assq headers 'Content-Type))
+              headers
+              (let ((boundary (http-generate-boundary)))
+                `((Content-Type . ,(string-append
+                                    "multipart/form-data; boundary="
+                                    boundary))
+                  ,@headers))))
+         (body
+          (let ((out (open-output-bytevector)))
+            (http-send-body headers body out)
+            (get-output-bytevector out)))
+         (headers
+          (if (or (assq headers 'content-length)
+                  (assq headers 'Content-Length))
+              headers
+              `((Content-Length . ,(bytevector-length body))
+                ,@headers))))
+    (cdr (http-call-method 'POST url headers body http-redirect-limit))))
+
+(define (http-put url body . headers)
+  (cdr (http-call-method 'PUT url
+                         (if (pair? headers) (car headers) '()) body
+                         http-redirect-limit)))
+
+(define (http-delete url . headers)
+  (cdr (http-call-method 'DELETE url
+                         (if (pair? headers) (car headers) '()) #f
+                         http-redirect-limit)))
+
+(define (call-with-input-url url proc)
+  (let* ((p (http-get url))
+         (res (proc p)))
+    (close-input-port p)
+    res))
+
+(define (call-with-input-url/headers url proc)
+  (let* ((h+p (http-get/headers url))
+         (res (proc (car h+p) (cdr h+p))))
+    (close-input-port (cdr h+p))
+    res))
+
+(define (with-input-from-url url thunk)
+  (let ((p (http-get url)))
+    (let ((res (parameterize ((current-input-port p)) (thunk))))
+      (close-input-port p)
+      res)))
+
+(define (http-get-to-file url path)
+  (call-with-input-url url
+    (lambda (in)
+      (let ((out (open-binary-output-file path)))
+        (let lp ()
+          (let ((c (read-u8 in)))
+            (cond ((not (eof-object? c))
+                   (write-u8 c out)
+                   (lp)))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; server utils
+
+;; read and parse a request line
+(define (http-parse-request . o)
+  (let ((line (string-split
+               (read-line (if (pair? o) (car o) (current-input-port)) 4096))))
+    (cons (string->symbol (car line)) (cdr line))))
+
+;; Parse a form body with a given URI and MIME headers (as parsed with
+;; mime-headers->list).  Returns an alist of (name . value) for every
+;; query or form parameter.
+(define (http-parse-form uri headers . o)
+  (let* ((in (if (pair? o) (car o) (current-input-port)))
+         (type (assq-ref headers
+                         'content-type
+                         "application/x-www-form-urlencoded")) 
+         (query0 (or (uri-query (if (string? uri) (string->uri uri) uri)) '()))
+         (query (if (string? query0) (uri-query->alist query0) query0)))
+    (cond
+     ((and (>= (string-length type) 10)
+           (string-ci=? "multipart/" (substring type 0 10)))
+      (let ((mime (mime-message->sxml in headers)))
+        (append
+         (let lp ((ls (cddr mime))
+                  (res '()))
+           (cond
+            ((null? ls)
+             res)
+            ((and (pair? (car ls))
+                  (eq? 'mime (caar ls))
+                  (pair? (cdar ls))
+                  (pair? (car (cdar ls)))
+                  (memq (caar (cdar ls)) '(^ @)))
+             (let* ((disp0 (assq-ref (cdar (cdar ls)) 'content-disposition ""))
+                    (disp (mime-parse-content-type disp0))
+                    (name (assq-ref disp 'name)))
+               (if name
+                   (lp (cdr ls) (cons (cons name (cadr (cdar ls))) res))
+                   (lp (cdr ls) res))))
+            (else
+             (lp (cdr ls) res))))
+         query)))
+     (else
+      query))))
+
diff --git a/lib/chibi/net/http.sld b/lib/chibi/net/http.sld
new file mode 100644
index 00000000..b34eb103
--- /dev/null
+++ b/lib/chibi/net/http.sld
@@ -0,0 +1,11 @@
+
+(define-library (chibi net http)
+  (export http-get http-get/headers http-get-to-file
+          http-head http-post http-put http-delete
+          call-with-input-url call-with-input-url/headers
+          with-input-from-url
+          http-parse-request http-parse-form)
+  (import (scheme base) (scheme write) (scheme char) (scheme file)
+          (srfi 27) (srfi 39)
+          (chibi net) (chibi io) (chibi uri) (chibi mime))
+  (include "http.scm"))
diff --git a/lib/chibi/net/server-util.scm b/lib/chibi/net/server-util.scm
new file mode 100644
index 00000000..7b735192
--- /dev/null
+++ b/lib/chibi/net/server-util.scm
@@ -0,0 +1,119 @@
+
+(define (get-host uri headers)
+  (cond
+   ((assq 'host headers)
+    => (lambda (x)
+         (let ((s (string-trim (cdr x))))
+           (substring-cursor s 0 (string-find s #\:)))))
+   ((uri-host uri))
+   (else "localhost")))
+
+(define (line-handler handler)
+  (lambda (in out sock addr)
+    (let ((line (read-line in)))
+      (if (eof-object? line)
+          #f
+          (handler line in out sock addr)))))
+
+(define (parse-command line)
+  (let ((ls (string-split line #\space)))
+    (cons (string->symbol (car ls)) (cdr ls))))
+
+(define (command-handler handler)
+  (line-handler
+   (cond
+    ((hash-table? handler)
+     (lambda (line in out sock addr)
+       (let ((ls (parse-command line)))
+         (cond
+          ((hash-table-ref/default handler (car ls))
+           => (lambda (handler)
+                (handler (car ls) (cdr ls) in out sock addr)))))))
+    ((list? handler)
+     (lambda (line in out sock addr)
+       (let ((ls (parse-command line)))
+         (cond
+          ((assq (car ls) handler)
+           => (lambda (cell)
+                ((cdr cell) (car ls) (cdr ls) in out sock addr)))))))
+    ((procedure? handler)
+     (lambda (line in out sock addr)
+       (let ((ls (parse-command line)))
+         (handler (car ls) (cdr ls) in out sock addr))))
+    (else
+     (error "invalid handler" handler)))))
+
+(define (load-mime-types ht file)
+  (protect
+      (exn
+       (else
+        (display "couldn't load mime types from " (current-error-port))
+        (write file (current-error-port))
+        (newline (current-error-port))
+        (print-exception exn)))
+    (call-with-input-file file
+      (lambda (in)
+        (let lp ()
+          (let ((line (read-line in)))
+            (cond
+             ((not (eof-object? line))
+              (let ((ls (string-split
+                         (cond ((string-find line #\#)
+                                => (lambda (i) (substring line 0 i)))
+                               (else line)))))
+                (if (and (pair? ls) (pair? (cdr ls)))
+                    (for-each
+                     (lambda (x)
+                       (hash-table-set! ht (string->symbol x) (car ls)))
+                     (cdr ls)))
+                (lp))))))))))
+
+(define file-mime-type
+  (let ((ext-types #f))
+    (lambda (file . o)
+      ;; set mime types on first use
+      (if (not ext-types)
+          (let ((ht (make-hash-table eq?)))
+            (cond
+             ((any file-exists? '("/etc/mime.types"
+                                  "/etc/httpd/mime.types"
+                                  "/etc/apache2/mime.types"))
+              => (lambda (file) (load-mime-types ht file))))
+            (set! ext-types ht)))
+      (let* ((ext (path-extension file))
+             (mtype (or (and ext (hash-table-ref/default
+                                  ext-types
+                                  (string->symbol
+                                   (string-downcase-ascii ext))
+                                  #f))
+                        "application/octet-stream")))
+        ;; TODO: auto-detect charset
+        (if (equal? mtype "text/html")
+            (string-append mtype "; charset=UTF-8")
+            mtype)))))
+
+(define (call-with-temp-file template proc)
+  (let ((base (string-append
+               "/tmp/" (path-strip-extension template)
+               "-" (number->string (current-process-id)) "-"
+               (number->string (round (current-seconds))) "-"))
+        (ext (path-extension template)))
+    (let lp ((i 0))
+      (let ((path (string-append base (number->string i) "." ext)))
+        (cond
+         ((> i 100)  ;; give up after too many tries regardless
+          (error "Repeatedly failed to generate temp file in /tmp"))
+         ((file-exists? path)
+          (lp (+ i 1)))
+         (else
+          (let ((fd (open path
+                          (bitwise-ior open/write open/create open/exclusive))))
+            (if (not fd)
+                (if (file-exists? path) ;; created between test and open
+                    (lp (+ i 1))
+                    (error "Couldn't generate temp file in /tmp " path))
+                (let* ((out (open-output-file-descriptor fd #o700))
+                       (res (proc path out)))
+                  (close-output-port out)
+                  (delete-file path)
+                  res)))))))))
diff --git a/lib/chibi/net/server-util.sld b/lib/chibi/net/server-util.sld
new file mode 100644
index 00000000..5a502724
--- /dev/null
+++ b/lib/chibi/net/server-util.sld
@@ -0,0 +1,8 @@
+
+(define-library (chibi net server-util)
+  (import (chibi) (chibi io) (chibi net) (chibi string) (chibi uri)
+          (chibi process) (chibi time) (chibi pathname) (chibi filesystem)
+          (srfi 33) (srfi 69))
+  (export line-handler command-handler parse-command
+          get-host file-mime-type call-with-temp-file)
+  (include "server-util.scm"))
diff --git a/lib/chibi/net/server.scm b/lib/chibi/net/server.scm
new file mode 100644
index 00000000..be569155
--- /dev/null
+++ b/lib/chibi/net/server.scm
@@ -0,0 +1,81 @@
+;; Copyright (c) 2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define default-max-requests 10000)
+
+(define (make-socket-listener-thunk listener port)
+  (lambda ()
+    (let ((addr (get-address-info #f port)))
+      (cond
+       ((accept listener
+                (address-info-address addr)
+                (address-info-address-length addr))
+        => (lambda (sock) (list sock addr)))
+       (else #f)))))
+
+(define (make-listener-thunk x)
+  (cond
+   ((integer? x)
+    (make-socket-listener-thunk
+     (make-listener-socket (get-address-info #f x))
+     x))
+   ((address-info? x)
+    (make-socket-listener-thunk (make-listener-socket x) 80))
+   ((fileno? x)
+    (make-socket-listener-thunk x 80))
+   ((procedure? x)
+    x)
+   (else
+    (error "expected a listener socket, fileno or thunk" x))))
+
+(define (run-net-server listener-or-addr handler . o)
+  (let ((listener-thunk (make-listener-thunk listener-or-addr))
+        (max-requests
+         (or
+          (cond ((pair? o) (car o))
+                ((get-environment-variable "CHIBI_NET_SERVER_MAX_THREADS")
+                 => string->number)
+                (else #f))
+          default-max-requests)))
+    (define (run sock addr count)
+      (log-debug "net-server: accepting request:" count)
+      (let ((ports
+             (protect (exn
+                       (else
+                        (log-error "net-server: couldn't create port:" sock)
+                        (close-file-descriptor sock)))
+               (cons (open-input-file-descriptor sock)
+                     (open-output-file-descriptor sock)))))
+        (protect (exn
+                  (else (log-error "net-server: error in request:" count)
+                        (print-exception exn)
+                        (print-stack-trace exn)
+                        (close-input-port (car ports))
+                        (close-output-port (cdr ports))
+                        (close-file-descriptor sock)))
+          (handler (car ports) (cdr ports) sock addr)
+          (flush-output (cdr ports))
+          (close-input-port (car ports))
+          (close-output-port (cdr ports))
+          (close-file-descriptor sock)))
+      (log-debug "net-server: finished: " count))
+    (let ((requests 0))
+      (let serve ((count 0))
+        (if (>= requests  max-requests)
+            (thread-yield!)
+            (let ((sock+addr (listener-thunk)))
+              (cond
+               ((not sock+addr)
+                (serve count))
+               ((= 1 max-requests)
+                (run (car sock+addr) (cadr sock+addr) count)
+                (serve (+ 1 count)))
+               (else
+                (thread-start!
+                 (make-thread
+                  (lambda ()
+                    (set! requests (+ requests 1))
+                    (run (car sock+addr) (cadr sock+addr) count)
+                    (set! requests (- requests 1)))
+                  (string-append "net-client-" (number->string count))))
+                (serve (+ 1 count))))))))))
diff --git a/lib/chibi/net/server.sld b/lib/chibi/net/server.sld
new file mode 100644
index 00000000..17632918
--- /dev/null
+++ b/lib/chibi/net/server.sld
@@ -0,0 +1,6 @@
+
+(define-library (chibi net server)
+  (import (chibi) (chibi net) (chibi filesystem) (chibi log)
+          (srfi 18) (srfi 98))
+  (export run-net-server make-listener-thunk)
+  (include "server.scm"))
diff --git a/lib/chibi/net/servlet.scm b/lib/chibi/net/servlet.scm
new file mode 100644
index 00000000..365d2405
--- /dev/null
+++ b/lib/chibi/net/servlet.scm
@@ -0,0 +1,262 @@
+;; servlet.scm -- basic web servlets and utilities
+;; Copyright (c) 2013-2014 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> Library for http and cgi servlets.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Uploads.
+
+(define-record-type Upload
+  (make-upload name filename sxml)
+  upload?
+  (name upload-name upload-name-set!)
+  (filename upload-filename upload-filename-set!)
+  (sxml upload-sxml upload-sxml-set!))
+
+;; Currently uploads are only represented as inlined strings, but may
+;; be saved to temp files in later versions so we provide only this
+;; abstract API.
+
+(define (upload-headers upload)
+  (cadr (upload-sxml upload)))
+
+(define (upload-content upload)
+  (car (cddr (upload-sxml upload))))
+
+(define (upload->string upload)
+  (let ((x (upload-content upload)))
+    (if (bytevector? x) (utf8->string x) x)))
+
+(define (upload->bytevector upload)
+  (let ((x (upload-content upload)))
+    (if (string? x) (string->utf8 x) x)))
+
+(define (upload->sexp upload)
+  (let* ((in (upload-input-port upload))
+         (res (read in)))
+    (close-input-port in)
+    res))
+
+(define (upload-input-port upload)
+  (open-input-string (upload->string upload)))
+
+(define (upload-binary-input-port upload)
+  (open-input-bytevector (upload->bytevector upload)))
+
+(define (upload-save upload path)
+  (let ((content (upload-content upload)))
+    (call-with-output-file path
+      (lambda (out)
+        (if (string? content)
+            (display content out)
+            (write-bytevector content out))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Requests.
+
+(define-record-type Request
+  (%make-request
+   method host uri version headers body params uploads in out sock addr status)
+  request?
+  (method request-method request-method-set!)
+  (host request-host request-host-set!)
+  (uri request-uri request-uri-set!)
+  (version request-version request-version-set!)
+  (headers request-headers request-headers-set!)
+  (body request-body request-body-set!)
+  (params request-params request-params-set!)
+  (uploads request-uploads request-uploads-set!)
+  (in request-in request-in-set!)
+  (out request-out request-out-set!)
+  (sock request-sock request-sock-set!)
+  (addr request-addr request-addr-set!)
+  (status request-status request-status-set!))
+
+(define (request-uri-string request)
+  (uri->string (request-uri request)))
+
+(define (request-path request)
+  (uri-path (request-uri request)))
+
+(define (copy-request r)
+  (%make-request
+   (request-method r) (request-host r) (request-uri r) (request-version r)
+   (request-headers r) (request-body r) (request-params r) (request-uploads r)
+   (request-in r) (request-out r) (request-sock r) (request-addr r)
+   (request-status r)))
+
+(define (request-with-uri request uri)
+  (let ((request2 (copy-request request)))
+    (request-uri-set! request2 (string->path-uri 'http uri))
+    request2))
+
+(define (request-param request name . o)
+  (cond ((assoc name (request-params request)) => cdr)
+        (else (and (pair? o) (car o)))))
+
+(define (assoc-multi ls key)
+  (let lp ((ls ls) (res '()))
+    (cond ((not (pair? ls)) (reverse res))
+          ((equal? key (caar ls)) (lp (cdr ls) (cons (cdar ls) res)))
+          (else (lp (cdr ls)res)))))
+
+(define (request-param-list request name)
+  (assoc-multi (request-params request) name))
+
+(define (request-upload request name . o)
+  (cond ((assoc name (request-uploads request)) => cdr)
+        (else (and (pair? o) (car o)))))
+
+(define (request-upload-list request name)
+  (assoc-multi (request-uploads request) name))
+
+(define (make-request method path version in out sock addr)
+  (let* ((uri (string->path-uri 'http path))
+         (headers (mime-headers->list in))
+         (host (get-host uri headers))
+         (params (uri-query->alist (or (uri-query uri) ""))))
+    (%make-request method host uri version headers #f params '()
+                   in out sock addr #f)))
+
+(define (make-cgi-request)
+  (let* ((method (or (get-environment-variable "REQUEST_METHOD") "GET"))
+         (uri (string->path-uri
+               'http (or (get-environment-variable "REQUEST_URI") "")))
+         (params (uri-query->alist (or (uri-query uri) "")))
+         (headers `((host . ,(or (get-environment-variable "HTTP_HOST")
+                                 ""))))
+         (host (get-host uri headers))
+         (version (or (get-environment-variable "SERVER_PROTOCOL")
+                      "HTTP/1.0")))
+    (%make-request method host uri version headers #f params '()
+                   (current-input-port) (current-output-port) #f #f #f)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Higher-level utilities.
+
+(define (servlet-write-status out status msg)
+  (display "HTTP/1.1 " out)
+  (display status out)
+  (display " " out)
+  (display msg out)
+  (display "\r\n" out))
+
+;;> Respond with a numeric status, string message and optional headers.
+
+(define (servlet-respond request status msg . o)
+  (cond
+   ((not (and (integer? status) (<= 0 status 999)))
+    (error "http status must be a 3-digit integer" status))
+   ((request-status request)
+    (error "can't set servlet status multiple times: "
+           (request-status request) status))
+   (else
+    (request-status-set! request status)
+    (let* ((out (request-out request))
+           (headers (if (pair? o) (car o) '()))
+           (headers
+            (cond
+             ;; Socket bound, not CGI, send normal status.
+             ((request-sock request)
+              (servlet-write-status out status msg)
+              headers)
+             ;; No socket bound, we're in CGI, send status as a header.
+             (else
+              (let ((str (string-append (number->string status) " " msg)))
+                `((Status . ,str)
+                  ,@headers))))))
+      (mime-write-headers headers out)
+      (display "\r\n" out)
+      (flush-output-port out)))))
+
+;;> Write the contents of a string to the request.  If no status has
+;;> been sent, assume a default of 200.
+
+(define (servlet-write request str . o)
+  (if (not (request-status request))
+      (apply servlet-respond request 200 "OK" o))
+  (display str (request-out request)))
+
+(define (extract-form-data sxml)
+  (define (form-data x)
+    (and (pair? x) (eq? 'mime (car x))
+         (pair? (cdr x)) (pair? (cadr x)) (eq? '@ (car (cadr x)))
+         (or (string? (car (cddr x)))
+             (bytevector? (car (cddr x))))
+         (assq 'content-disposition (cdr (cadr x)))))
+  (let lp ((ls sxml) (res '()) (files '()))
+    (cond
+     ((null? ls)
+      (cons (reverse res) (reverse files)))
+     ((form-data (car ls))
+      => (lambda (x)
+           (let ((disp (mime-parse-content-type (cdr x))))
+             (cond
+              ((and (pair? disp) (assq 'name (cdr disp)))
+               => (lambda (y)
+                    (let ((name (cdr y))
+                          (val (cadr (cdar ls))))
+                      (cond
+                       ((assq 'filename (cdr disp))
+                        => (lambda (z)
+                             ;; If it has a filename it's an upload,
+                             ;; we take the param value to be the
+                             ;; filename, and accumulate the file.
+                             (let ((upload (make-upload name (cdr z) (car ls))))
+                               (lp (cdr ls)
+                                   (cons (cons name (cdr z)) res)
+                                   (cons (cons name upload) files)))))
+                       (else
+                        (lp (cdr ls) (cons (cons name val) res) files))))))
+              (else
+               (log-warn "ignoring form-data with no name: " x)
+               (lp (cdr ls) res files))))))
+     (else
+      (lp (cdr ls) res files)))))
+
+(define (servlet-parse-body! request)
+  (let* ((headers (request-headers request))
+         (ctype
+          (mime-parse-content-type
+           (cond ((assq 'content-type headers) => cdr)
+                 (else ""))))
+         (in (request-in request)))
+    (cond
+     ((and (pair? ctype) (eq? 'multipart/form-data (car ctype)))
+      (let* ((sxml (mime-message->sxml in headers))
+             (vars+files (extract-form-data sxml))
+             (vars (append (request-params request) (car vars+files))))
+        (request-body-set! request sxml)
+        (request-params-set! request vars)
+        (request-uploads-set! request (cdr vars+files))))
+     ((and (pair? ctype) (eq? 'application/x-www-form-urlencoded (car ctype)))
+      (let ((line (read-line in)))
+        (request-body-set! request line)
+        (if (not (eof-object? line))
+            (request-params-set! request
+                                 (append (request-params request)
+                                         (uri-query->alist line)))))))))
+
+(define (make-status-servlet status msg . o)
+  (lambda (cfg request next restart)
+    (apply servlet-respond request status msg o)))
+
+(define servlet-bad-request
+  (make-status-servlet 400 "Bad request"))
+
+;; Generic interface.
+
+(define servlet-handler (make-parameter #f))
+
+(define (servlet-run servlet)
+  (let ((handler (servlet-handler)))
+    (cond
+     ((procedure? handler)
+      ;; A servlet handler has been set, so we're in a persistent server.
+      (handler servlet))
+     (else
+      ;; Otherwise this is basic CGI.
+      (let ((cfg (make-conf '() #f #f #f)))
+        (let restart ((request (make-cgi-request)))
+          (servlet cfg request servlet-bad-request restart)))))))
diff --git a/lib/chibi/net/servlet.sld b/lib/chibi/net/servlet.sld
new file mode 100644
index 00000000..75cb44e0
--- /dev/null
+++ b/lib/chibi/net/servlet.sld
@@ -0,0 +1,28 @@
+
+(define-library (chibi net servlet)
+  (export
+   ;; uploads
+   upload? upload-name upload-filename
+   upload-headers upload->string upload-input-port upload-save
+   upload->bytevector upload->sexp upload-binary-input-port
+   ;; requests
+   request? request-method request-host request-uploads
+   request-uri request-version request-headers request-body request-params
+   request-in request-out request-sock request-addr request-param
+   request-method-set! request-host-set! request-uri-set!
+   request-version-set! request-headers-set! request-body-set!
+   request-params-set! request-in-set! request-out-set!
+   request-sock-set! request-addr-set!
+   request-param request-param-list request-upload request-upload-list
+   request-uri-string request-with-uri request-path
+   copy-request make-request make-cgi-request
+   ;; servlets
+   servlet-write servlet-respond servlet-parse-body!
+   make-status-servlet servlet-handler servlet-run
+   servlet-bad-request)
+  (import
+   (scheme base) (scheme read) (scheme write) (scheme file)
+   (srfi 9) (srfi 39) (srfi 69) (srfi 98)
+   (chibi ast) (chibi io) (chibi uri) (chibi mime) (chibi log) (chibi config)
+   (chibi filesystem) (chibi net) (chibi net server-util))
+  (include "servlet.scm"))
diff --git a/lib/chibi/optimize.scm b/lib/chibi/optimize.scm
new file mode 100644
index 00000000..dc3b3f9a
--- /dev/null
+++ b/lib/chibi/optimize.scm
@@ -0,0 +1,52 @@
+
+(define (register-lambda-optimization! proc . o)
+  (define (optimize ast)
+    (match ast
+      (($ Set ref value)
+       (make-set ref (optimize value)))
+      (($ Cnd test pass fail)
+       (make-cnd (optimize test) (optimize pass) (optimize fail)))
+      (($ Seq ls)
+       (make-seq (map optimize ls)))
+      (($ Lam name params body)
+       (lambda-body-set! ast (optimize body))
+       (proc ast))
+      ((app ...)
+       (map optimize app))
+      (else
+       ast)))
+  (register-optimization! optimize (if (pair? o) (car o) 600)))
+
+(define (replace-references ast name lam new)
+  (let replace ((x ast))
+    (match x
+      (($ Ref _ (n . (? lambda? f)))
+       (if (and (eq? n name) (eq? f lam))
+           new
+           x))
+      (($ Set ref value)
+       (make-set (replace ref) (replace value)))
+      (($ Cnd test pass fail)
+       (make-cnd (replace test) (replace pass) (replace fail)))
+      (($ Seq ls)
+       (make-seq (map replace ls)))
+      (($ Lam name params body)
+       (lambda-body-set! x (replace body))
+       x)
+      ((app ...)
+       (map replace app))
+      (else
+       x))))
+
+(define (join-seq a b)
+  (make-seq (append (if (seq? a) (seq-ls a) (list a))
+                    (if (seq? b) (seq-ls b) (list b)))))
+
+(define (dotted-tail ls)
+  (if (pair? ls) (dotted-tail (cdr ls)) ls))
+
+(define (fold-every kons knil ls)
+  (if (null? ls)
+      knil
+      (let ((knil (kons (car ls) knil)))
+        (and knil (fold-every kons knil (cdr ls))))))
diff --git a/lib/chibi/optimize.sld b/lib/chibi/optimize.sld
new file mode 100644
index 00000000..241fc3bd
--- /dev/null
+++ b/lib/chibi/optimize.sld
@@ -0,0 +1,7 @@
+
+(define-library (chibi optimize)
+  (import (chibi) (chibi ast) (chibi match) (srfi 1))
+  (export register-lambda-optimization!
+          replace-references
+          fold-every join-seq dotted-tail)
+  (include "optimize.scm"))
diff --git a/lib/chibi/optimize/profile.c b/lib/chibi/optimize/profile.c
new file mode 100644
index 00000000..929a9d97
--- /dev/null
+++ b/lib/chibi/optimize/profile.c
@@ -0,0 +1,19 @@
+/*  profile.c -- low-level utilities for VM profiling         */
+/*  Copyright (c) 2011 Alex Shinn.  All rights reserved.      */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+
+static sexp sexp_increment_cdr (sexp ctx, sexp self, sexp_sint_t n, sexp pair) {
+  sexp_assert_type(ctx, sexp_pairp, SEXP_PAIR, pair);
+  sexp_cdr(pair) = sexp_make_fixnum(1 + sexp_unbox_fixnum(sexp_cdr(pair)));
+  return SEXP_VOID;
+}
+
+sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
+  if (!(sexp_version_compatible(ctx, version, sexp_version)
+        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
+    return SEXP_ABI_ERROR;
+  sexp_define_foreign(ctx, env, "increment-cdr!", 1, sexp_increment_cdr);
+  return SEXP_VOID;
+}
diff --git a/lib/chibi/optimize/profile.scm b/lib/chibi/optimize/profile.scm
new file mode 100644
index 00000000..7564eb93
--- /dev/null
+++ b/lib/chibi/optimize/profile.scm
@@ -0,0 +1,65 @@
+
+(define (ref=? a b)
+  (or (eq? a b)
+      (and (ref? a) (ref? b)
+           (eq? (ref-name a) (ref-name b))
+           (eq? (car (ref-cell a)) (car (ref-cell b)))
+           (eq? (cdr (ref-cell a)) (cdr (ref-cell b))))))
+
+(define profile-cells '())
+
+(define (profile-get-cell f)
+  (or (assoc f profile-cells ref=?)
+      (let ((cell (cons f 0)))
+        (set! profile-cells (cons cell profile-cells))
+        cell)))
+
+(define (profile-reset)
+  (for-each (lambda (x) (set-cdr! x 0)) profile-cells))
+
+(define (profile-report)
+  (define (report-op op)
+    (match op
+      (($ Ref name (p . (and ($ Lam lam-name) f)))
+       (write name)
+       (cond
+        ((not (eq? p name))
+         (display " ")
+         (write p)))
+       (cond
+        ((lambda-source f)
+         (display " [") (write (lambda-source f)) (display "]"))))
+      (($ Ref name (_ . f))
+       (write name) (display " (") (write f) (display ")"))
+      (else
+       (write op))))
+  (let ((ls (filter (lambda (x) (> (cdr x) 0))
+                    profile-cells)))
+    (for-each (lambda (x)
+                (write (cdr x)) (display ": ")
+                (report-op (car x)) (newline))
+              (sort ls > cdr))))
+
+(define (optimize-profile ast)
+  (let-syntax ((opt (syntax-rules () ((opt x) (optimize-profile x)))))
+    (match ast
+      (($ Set ref value)
+       (set-value-set! ast (opt value))
+       ast)
+      (($ Cnd test pass fail)
+       (make-cnd (opt test) (opt pass) (opt fail)))
+      (($ Seq ls)
+       (make-seq (map optimize-profile ls)))
+      (($ Lam name params body)
+       (lambda-body-set! ast (opt body))
+       ast)
+      ((($ Ref name cell) args ...)
+       (make-seq (list (list increment-cdr!
+                             (make-lit (profile-get-cell (car ast))))
+                       (cons (car ast) (map optimize-profile args)))))
+      ((app ...)
+       (map optimize-profile app))
+      (else
+       ast))))
+
+(register-lambda-optimization! optimize-profile)
diff --git a/lib/chibi/optimize/profile.sld b/lib/chibi/optimize/profile.sld
new file mode 100644
index 00000000..dd14c1b0
--- /dev/null
+++ b/lib/chibi/optimize/profile.sld
@@ -0,0 +1,7 @@
+
+(define-library (chibi optimize profile)
+  (export optimize-profile increment-cdr! profile-reset profile-report)
+  (import (chibi) (srfi 1) (srfi 69) (srfi 95)
+          (chibi ast) (chibi match) (chibi optimize))
+  (include-shared "profile")
+  (include "profile.scm"))
diff --git a/lib/chibi/optimize/rest.c b/lib/chibi/optimize/rest.c
new file mode 100644
index 00000000..96db0fdb
--- /dev/null
+++ b/lib/chibi/optimize/rest.c
@@ -0,0 +1,35 @@
+/*  rest.c -- low-level utilities for VM rest optimization    */
+/*  Copyright (c) 2011 Alex Shinn.  All rights reserved.      */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+
+static sexp sexp_num_parameters (sexp ctx, sexp self, sexp_sint_t n) {
+  return sexp_stack_data(sexp_context_stack(ctx))[sexp_context_last_fp(ctx)];
+}
+
+struct sexp_opcode_struct local_ref_op =
+  {SEXP_OPC_GENERIC, SEXP_OP_LOCAL_REF, 1, 8, 0, (sexp)"local-ref", SEXP_VOID,
+   NULL, NULL, sexp_make_fixnum(SEXP_OBJECT), sexp_make_fixnum(SEXP_FIXNUM),
+   0, 0, NULL};
+
+static sexp copy_opcode (sexp ctx, struct sexp_opcode_struct *op) {
+  sexp res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE);
+  memcpy(&(res->value), op, sizeof(op[0]));
+  return res;
+}
+
+sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
+  sexp_gc_var2(name, op);
+  if (!(sexp_version_compatible(ctx, version, sexp_version)
+        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
+    return SEXP_ABI_ERROR;
+  sexp_gc_preserve2(ctx, name, op);
+  sexp_define_foreign(ctx, env, "num-parameters", 0, sexp_num_parameters);
+  op = copy_opcode(ctx, &local_ref_op);
+  sexp_opcode_name(op) = sexp_c_string(ctx, (char*)sexp_opcode_name(op), -1);
+  name = sexp_string_to_symbol(ctx, sexp_opcode_name(op));
+  sexp_env_define(ctx, env, name, op);
+  sexp_gc_release2(ctx);
+  return SEXP_VOID;
+}
diff --git a/lib/chibi/optimize/rest.scm b/lib/chibi/optimize/rest.scm
new file mode 100644
index 00000000..bd888c67
--- /dev/null
+++ b/lib/chibi/optimize/rest.scm
@@ -0,0 +1,126 @@
+
+(define (optimize-rest ast)
+  (cond
+   ((and (lambda? ast)
+         (not (list? (lambda-params ast)))
+         (rest-parameter-cdrs ast))
+    => (lambda (cdrs)
+         (replace-rest-destructuring-with-stack-references
+          (length* (lambda-params ast))
+          ast
+          cdrs)))
+   (else
+    ast)))
+
+(define safe-primitives (list car cdr null? pair?))
+
+(define (adjust-cdrs cdrs f params args)
+  (filter-map
+   (lambda (p a)
+     (match a
+       (((? (lambda (op) (eq? op cdr))) ($ Ref name (_ . (? lambda? lam))))
+        (let ((x (find (lambda (r)
+                         (and (eq? name (car r)) (eq? lam (cadr r))))
+                       cdrs)))
+          (and x (list p f (+ (car (cddr x)) 1)))))
+       (($ Cnd
+           ((? (lambda (op) (eq? op pair?))) ($ Ref name (_ . (? lambda? lam))))
+           ((? (lambda (op) (eq? op cdr))) ($ Ref name (_ . (? lambda? lam))))
+           (or () ($ Lit ())))
+        (let ((x (find (lambda (r)
+                         (and (eq? name (car r)) (eq? lam (cadr r))))
+                       cdrs)))
+          (and x (list p f (+ (car (cddr x)) 1.0)))))
+       (else #f)))
+   params
+   args))
+
+(define (rest-parameter-cdrs ast)
+  (let analyze ((x (lambda-body ast))
+                (cdrs (list (list (dotted-tail (lambda-params ast)) ast 0)))
+                (safe? #t))
+    (define (recurse x cdrs) (analyze x cdrs safe?))
+    (match x
+      (($ Ref name (_ . (? lambda? f)))
+       (and (not (any (lambda (r) (and (eq? name (car r)) (eq? f (cadr r)))) cdrs))
+            cdrs))
+      (($ Set ref value)
+       (and (recurse ref cdrs) (recurse value cdrs)))
+      (($ Cnd test pass fail)
+       (fold-every recurse cdrs (list test pass fail)))
+      (($ Seq ls)
+       (fold-every recurse cdrs ls))
+      (($ Lam name params body)
+       (analyze body cdrs #f))
+      (((and ($ Lam _ (params ...) body) f) args ...)
+       (let ((cdrs (fold-every recurse cdrs args)))
+         (and (equal? (length params) (length args))
+              (recurse body (append (adjust-cdrs cdrs f params args) cdrs)))))
+      (((? opcode? op) ($ Ref _ (_ . (? lambda?))))
+       (if (and safe? (memq op safe-primitives))
+           cdrs
+           (recurse (cadr x) cdrs)))
+      ((app ...)
+       (fold-every recurse cdrs app))
+      (else
+       cdrs))))
+
+(define (replace-rest-destructuring-with-stack-references base ast cdrs)
+  (define (rename p)
+    (make-syntactic-closure
+     (current-environment) '() (strip-syntactic-closures p)))
+  (define (replace-param x)
+    (match x
+      (($ Cnd test pass fail)
+       (make-cnd (replace-param test)
+                 (replace-param pass)
+                 (replace-param fail)))
+      (($ Seq ls)
+       (let ((ls (map replace-param ls)))
+         (and ls (make-seq ls))))
+      (((? opcode? op) ($ Ref name (_ . (? lambda? f))))
+       (let ((r (and (memq op safe-primitives)
+                     (find (lambda (r) (and (eq? name (car r)) (eq? f (cadr r))))
+                           cdrs))))
+         (cond
+          ((not r)
+           x)
+          ((eq? op car)
+           `(,local-ref ,(+ 1 (inexact->exact (car (cddr r))))))
+          ((eq? op cdr)
+           (make-lit '()))
+          ((eq? op pair?)
+           `(,> (,num-parameters) ,(+ base (inexact->exact (car (cddr r))))))
+          ((eq? op null?)
+           `(,<= (,num-parameters) ,(+ base (inexact->exact (car (cddr r))))))
+          (else
+           x))))
+      (($ Set ref value)
+       #f)
+      (($ Lam name params body)
+       #f)
+      ((app ...)
+       #f)
+      (else
+       x)))
+  (lambda-body-set!
+   ast
+   (let replace ((x (lambda-body ast)))
+     (match x
+       ((($ Lam name (params ...) body) args ...)
+        (let* ((locals (map replace-param args))
+               (names (map rename params))
+               (refs (map (lambda (name) (make-ref name (cons name ast))) names)))
+          (let ((res (fold (lambda (p new res)
+                             (replace-references res p (car x) new))
+                           (replace body)
+                           params
+                           refs)))
+            (lambda-locals-set! ast (append names (lambda-locals ast)))
+            (join-seq (make-seq (map make-set refs locals))
+                      res))))
+       (else
+        x))))
+  ast)
+
+(register-lambda-optimization! optimize-rest)
diff --git a/lib/chibi/optimize/rest.sld b/lib/chibi/optimize/rest.sld
new file mode 100644
index 00000000..8dbb065e
--- /dev/null
+++ b/lib/chibi/optimize/rest.sld
@@ -0,0 +1,6 @@
+
+(define-library (chibi optimize rest)
+  (export optimize-rest rest-parameter-cdrs num-parameters local-ref)
+  (import (chibi) (srfi 1) (chibi ast) (chibi match) (chibi optimize))
+  (include-shared "rest")
+  (include "rest.scm"))
diff --git a/lib/chibi/optional.scm b/lib/chibi/optional.scm
new file mode 100644
index 00000000..ddc09969
--- /dev/null
+++ b/lib/chibi/optional.scm
@@ -0,0 +1,205 @@
+
+;;> Syntax to support optional and named keyword arguments.
+;;> \scheme{let-optionals[*]} is originally from SCSH, and
+;;> \scheme{let-keywords[*]} derived from Gauche.
+
+;; Wrap bindings in temp variables to convert a let* definition to a
+;; let definition.
+
+(define-syntax let*-to-let
+  (syntax-rules ()
+    ((let*-to-let letstar ls (vars ...) ((v . d) . rest) . body)
+     (let*-to-let letstar ls (vars ... (v tmp . d)) rest . body))
+    ((let*-to-let letstar ls ((var tmp . d) ...) rest . body)
+     (letstar ls ((tmp . d) ... . rest)
+       (let ((var tmp) ...) . body)))))
+
+;;> \macro{(let-optionals ls ((var default) ... [rest]) body ...)}
+;;>
+;;> Binding construct similar to \scheme{let}.  The \var{var}s are
+;;> bound to fresh locations holding values taken in order from the
+;;> list \var{ls}, \var{body} is evaluated in the resulting
+;;> environment, and the value(s) of the last expression of \var{body}
+;;> returned.  If the length of \var{ls} is shorter than the number of
+;;> \var{var}s, then the remaining \var{var}s taken their values from
+;;> their corresponding \var{default}s, evaluated in an unspecified
+;;> order.  Unused \var{default}s are not evaluated.  If a final
+;;> \var{rest} var is specified, then it is bound to any remaining
+;;> elements of \var{ls} beyond the length of \var{ls}, otherwise any
+;;> extra values are unused.
+;;>
+;;> Typically used on the dotted rest list at the start of a lambda,
+;;> \scheme{let-optionals} is more concise and more efficient than
+;;> \scheme{case-lambda} for simple optional argument uses.
+;;>
+;;> \emph{Example:}
+;;> \schemeblock{
+;;> (define (copy-port . o)
+;;>   (let-optionals o ((in (current-input-port))
+;;>                     (out (current-output-port))
+;;>                     (n-bytes #f))
+;;>     (do ((i 0 (+ i 1))
+;;>          (n (read-u8 in) (read-u8 in)))
+;;>         ((or (and n-bytes (>= i n-bytes))
+;;>              (eof-object? b)))
+;;>       (write-u8 b out)))}
+;;>
+;;> \emph{Example:}
+;;> \example{
+;;> (let-optionals '(0) ((a 10) (b 11) (c 12))
+;;>   (list a b c))}
+
+(define-syntax let-optionals
+  (syntax-rules ()
+    ((let-optionals ls ((var default) ...) body ...)
+     (let*-to-let let-optionals* ls () ((var default) ...) body ...))))
+
+;;> \macro{(let-optionals* ls ((var default) ... [rest]) body ...)}
+;;>
+;;> \scheme{let*} equivalent to \scheme{let-optionals}.  Any required
+;;> \var{default} values are evaluated in left-to-right order, with
+;;> all preceding \var{var}s in scope.
+
+;;> \macro{(opt-lambda ((var default) ... [rest]) body ...)}
+;;>
+;;> Shorthand for
+;;> \schemeblock{
+;;> (lambda o
+;;>   (let-optionals o ((var default) ... [rest])
+;;>      body ...))}
+
+(define-syntax opt-lambda
+  (syntax-rules ()
+    ((opt-lambda vars . body)
+     (lambda args (let-optionals args vars . body)))))
+
+;;> \procedure{(keyword-ref ls key [default])}
+;;>
+;;> Search for the identifier \var{key} in the list \var{ls}, treating
+;;> it as a property list of the form \scheme{(key1 val1 key2 val2
+;;> ...)}, and return the associated \var{val}.  If not found, return
+;;> \var{default}, or \scheme{#f}.
+
+(define (keyword-ref ls key . o)
+  (let lp ((ls ls))
+    (if (and (pair? ls) (pair? (cdr ls)))
+        (if (eq? key (car ls))
+            (cadr ls)
+            (lp (cddr ls)))
+        (and (pair? o) (car o)))))
+
+;;> \macro{(keyword-ref* ls key default)}
+;;>
+;;> Macro equivalent of \scheme{keyword-ref}, where \var{default} is
+;;> only evaluated if \var{key} is not found.
+
+(define-syntax keyword-ref*
+  (syntax-rules ()
+    ((keyword-ref* ls key default)
+     (cond ((memq key ls) => cadr) (else default)))))
+
+(define (symbol->keyword sym)
+  (string->symbol (string-append (symbol->string sym) ":")))
+
+(define-syntax let-key*-to-let
+  (syntax-rules ()
+    ((let-key*-to-let ls (vars ...) ((v d) . rest) . body)
+     (let-key*-to-let ls (vars ... (v tmp ,(symbol->keyword 'v) d)) rest
+                      . body))
+    ((let-key*-to-let ls (vars ...) ((v k d) . rest) . body)
+     (let-key*-to-let ls (vars ... (v tmp k d)) rest . body))
+    ((let-key*-to-let ls ((var tmp k d) ...) rest . body)
+     (let-keywords* ls ((tmp k d) ... . rest)
+       (let ((var tmp) ...) . body)))))
+
+;;> \macro{(let-keywords ls ((var [keyword] default) ... [rest]) body ...)}
+;;>
+;;> Analogous to \scheme{let-optionals}, except instead of binding the
+;;> \var{var}s by position they are bound by name, by searching in
+;;> \var{ls} with \scheme{keyword-ref*}.  If an optional \var{keyword}
+;;> argument is provided it must be an identifier to use as the name,
+;;> otherwise \var{var} is used, appending a ":" (colon).  If the name
+;;> is not found, \var{var} is bound to \var{default}, even if unused
+;;> names remain in \var{ls}.
+;;>
+;;> If an optional trailing identifier \var{rest} is provided, it is
+;;> bound to the list of unused arguments not bound to any \var{var}.
+;;>
+;;> Note R7RS does not have a disjoint keyword type or auto-quoting
+;;> syntax for keywords - they are simply identifiers.  Thus when
+;;> passing keyword arguments they must be quoted (or otherwise
+;;> dynamically evaluated).
+;;>
+;;> \emph{Example:}
+;;> \example{
+;;> (define (make-person . o)
+;;>   (let-keywords o ((name "John Doe")
+;;>                    (age 0)
+;;>                    (occupation job: 'unemployed))
+;;>     (vector name age occupation)))
+;;>
+;;> (list (make-person)
+;;>       (make-person 'name: "Methuselah" 'age: 969)
+;;>       (make-person 'name: "Dr. Who" 'job: 'time-lord 'age: 1500))
+;;> }
+;;>
+;;> \emph{Example:}
+;;> \example{
+;;> (let-keywords '(b: 2 a: 1 other: 9)
+;;>     ((a 0) (b 0) (c 0) rest)
+;;>   (list a b c rest))
+;;> }
+
+(define-syntax let-keywords
+  (syntax-rules ()
+    ((let-keywords ls vars . body)
+     (let-key*-to-let ls () vars . body))))
+
+(define (remove-keywords ls keywords)
+  (let lp ((ls ls) (res '()))
+    (if (and (pair? ls) (pair? (cdr ls)))
+        (if (memq (car ls) keywords)
+            (lp (cddr ls) res)
+            (lp (cddr ls) (cons (cadr ls) (cons (car ls) res))))
+        (reverse res))))
+
+(define-syntax remove-keywords*
+  (syntax-rules ()
+    ((remove-keywords* opt-ls (keys ...) ((var key default) . rest))
+     (remove-keywords* opt-ls (keys ... key) rest))
+    ((remove-keywords* opt-ls (keys ...) ((var default) . rest))
+     (remove-keywords* opt-ls (keys ... ,(symbol->keyword* 'var)) rest))
+    ((remove-keywords* opt-ls (keys ...) ())
+     (remove-keywords opt-ls `(keys ...)))))
+
+;;> \macro{(let-keywords* ls ((var [keyword] default) ... [rest]) body ...)}
+;;>
+;;> \scheme{let*} equivalent to \scheme{let-keywords*}.  Any required
+;;> \var{default} values are evaluated in left-to-right order, with
+;;> all preceding \var{var}s in scope.
+;;>
+;;> \emph{Example:}
+;;> \example{
+;;> (let-keywords* '(b: 5)
+;;>     ((a 1) (b (* a 2)) (c (* b 3)))
+;;>   (list a b c))
+;;> }
+
+(define-syntax let-keywords*
+  (syntax-rules ()
+    ((let-keywords* opt-ls () . body)
+     (begin . body))
+    ((let-keywords* (op . args) vars . body)
+     (let ((tmp (op . args)))
+       (let-keywords* tmp vars . body)))
+    ((let-keywords* opt-ls ((var) (vars . x) ...) . body)
+     (let-keywords* opt-ls ((var #f) (vars . x) ...) . body))
+    ((let-keywords* opt-ls ((var default) (vars . x) ...) . body)
+     (let ((var (keyword-ref* opt-ls (symbol->keyword* 'var) default)))
+       (let-keywords* opt-ls ((vars . x) ...) . body)))
+    ((let-keywords* opt-ls ((var key default) (vars . x) ...) . body)
+     (let ((var (keyword-ref* opt-ls `key default)))
+       (let-keywords* opt-ls ((vars . x) ...) . body)))
+    ((let-keywords* opt-ls ((vars . x) ... tail) . body)
+     (let ((tail (remove-keywords* opt-ls () ((vars . x) ...))))
+       (let-keywords* opt-ls ((vars . x) ...) . body)))))
diff --git a/lib/chibi/optional.sld b/lib/chibi/optional.sld
new file mode 100644
index 00000000..02084635
--- /dev/null
+++ b/lib/chibi/optional.sld
@@ -0,0 +1,42 @@
+
+(define-library (chibi optional)
+  (export let-optionals let-optionals* opt-lambda
+          let-keywords let-keywords* keyword-ref keyword-ref*)
+  (cond-expand
+   (chibi
+    (import (chibi))
+    (begin
+      (define-syntax symbol->keyword*
+        (er-macro-transformer
+         (lambda (expr rename compare)
+           (if (and (pair? (cdr expr)) (pair? (cadr expr))
+                    (compare 'quote (car (cadr expr))))
+               `(,(rename 'quote)
+                 ,(string->symbol
+                   (string-append
+                    (symbol->string
+                     (identifier->symbol (cadr (cadr expr)))) ":")))
+               `(string->symbol
+                 (string-append (symbol->string ,(cadr expr)) ":"))))))))
+   (else
+    (import (scheme base))
+    (begin
+      (define-syntax let-optionals*
+        (syntax-rules ()
+          ((let-optionals* opt-ls () . body)
+           (begin . body))
+          ((let-optionals* (op . args) vars . body)
+           (let ((tmp (op . args)))
+             (let-optionals* tmp vars . body)))
+          ((let-optionals* tmp ((var default) . rest) . body)
+           (let ((var (if (pair? tmp) (car tmp) default))
+                 (tmp2 (if (pair? tmp) (cdr tmp) '())))
+             (let-optionals* tmp2 rest . body)))
+          ((let-optionals* tmp tail . body)
+           (let ((tail tmp)) . body))))
+      (define-syntax symbol->keyword*
+        (syntax-rules ()
+          ((symbol->keyword* sym)
+           (string->symbol (string-append (symbol->string sym) ":")))
+          )))))
+  (include "optional.scm"))
diff --git a/lib/chibi/parse.sld b/lib/chibi/parse.sld
new file mode 100644
index 00000000..3106b1db
--- /dev/null
+++ b/lib/chibi/parse.sld
@@ -0,0 +1,80 @@
+
+(define-library (chibi parse)
+  (export grammar grammar/unmemoized define-grammar define-grammar/unmemoized
+          call-with-parse parse parse-fully parse-fold
+          parse->list parse-fully->list
+          file->parse-stream string->parse-stream parse-stream-substring
+          parse-stream-start? parse-stream-end? parse-stream-ref
+          parse-anything parse-nothing parse-epsilon
+          parse-seq parse-and parse-or parse-not
+          parse-repeat parse-repeat+ parse-optional
+          parse-map parse-map-substring parse-ignore parse-assert
+          parse-atomic parse-commit parse-memoize
+          parse-char parse-not-char parse-char-pred
+          parse-string parse-token parse-sre
+          parse-beginning parse-end
+          parse-beginning-of-line parse-end-of-line
+          parse-beginning-of-line parse-end-of-line
+          parse-beginning-of-word parse-end-of-word
+          parse-word parse-word+
+          parse-with-failure-reason
+          make-parse-stream)
+  (import (chibi) (chibi char-set) (srfi 9))
+  (include "parse/parse.scm")
+  (cond-expand
+   (chibi
+    (begin
+      (define-syntax grammar-bind
+        (er-macro-transformer
+         (lambda (expr rename compare)
+           (let ((name (cadr expr))
+                 (k (car (cddr expr)))
+                 (f (cadr (cddr expr)))
+                 (bindings (car (cddr (cddr expr)))))
+             (if (and (identifier? name)
+                      (not (assq name bindings)))
+                 (let ((new-tmp (rename 'new-tmp))
+                       (save-tmp (rename 'save-tmp))
+                       (lambda_ (rename 'lambda))
+                       (set!_ (rename 'set!))
+                       (s (rename 's))
+                       (i (rename 'i))
+                       (sk (rename 'sk))
+                       (fk (rename 'fk))
+                       (r (rename 'r)))
+                   (append
+                    k
+                    (list
+                     `(,lambda_
+                       (,s ,i ,sk ,fk)
+                       ((,lambda_ (,save-tmp)
+                                  (,f ,s ,i
+                                      (,lambda_ (,r ,s ,i ,fk)
+                                                (,set!_ ,new-tmp ,r)
+                                                (,sk ,r ,s ,i ,fk))
+                                      (,lambda_ (,s ,i ,r)
+                                                (,set!_ ,new-tmp ,save-tmp)
+                                                (,fk ,s ,i ,r))))
+                        ,new-tmp))
+                     (cons (list name new-tmp) bindings))))
+                 (append k (list f bindings)))))))))
+   (else
+    (begin
+      (define-syntax grammar-bind
+        (syntax-rules ()
+          ((grammar-bind name (k ...) f ((var tmp) ...))
+           (let-syntax ((new-symbol?
+                         (syntax-rules (var ...)
+                           ((new-symbol? name sk fk) sk)
+                           ((new-symbol? _ sk fk) fk))))
+             ;; Bind the name only to the first instance in the pattern.
+             (new-symbol?
+              random-symbol-to-match
+              (k ...
+                 (lambda (s i sk fk)
+                   (let ((save-tmp new-tmp))
+                     (f s i
+                        (lambda (r s i fk) (set! new-tmp r) (sk r s i fk))
+                        (lambda (s i r) (set! new-tmp save-tmp) (fk s i r)))))
+                 ((var tmp) ... (name new-tmp)))
+              (k ... f ((var tmp) ...)))))))))))
diff --git a/lib/chibi/parse/common.scm b/lib/chibi/parse/common.scm
new file mode 100644
index 00000000..2c504592
--- /dev/null
+++ b/lib/chibi/parse/common.scm
@@ -0,0 +1,315 @@
+
+(define (char-hex-digit? ch)
+  (or (char-numeric? ch)
+      (memv (char-downcase ch) '(#\a #\b #\c #\d #\e #\f))))
+
+(define (char-octal-digit? ch)
+  (and (char? ch) (char<=? #\0 ch #\7)))
+
+(define (parse-assert-range proc lo hi)
+  (if (or lo hi)
+      (parse-assert proc (lambda (n)
+                          (and (or (not lo) (<= lo n))
+                               (or (not hi) (<= n hi)))))
+      proc))
+
+(define (parse-unsigned-integer . o)
+  (let ((lo (and (pair? o) (car o)))
+        (hi (and (pair? o) (pair? (cdr o)) (cadr o))))
+    (parse-assert-range
+     (parse-map (parse-token char-numeric?) string->number)
+     lo hi)))
+
+(define (parse-sign+)
+  (parse-or (parse-char #\+) (parse-char #\-)))
+
+(define (parse-sign)
+  (parse-or (parse-sign+) parse-epsilon))
+
+(define (parse-integer . o)
+  (let ((lo (and (pair? o) (car o)))
+        (hi (and (pair? o) (pair? (cdr o)) (cadr o))))
+    (parse-assert-range
+     (parse-map-substring
+      (parse-seq (parse-sign) (parse-token char-numeric?)
+                 ;; (parse-not (parse-or (parse-sign) (parse-char #\.)))
+                 )
+      string->number)
+     lo hi)))
+
+(define (parse-c-integer)
+  (parse-or
+   (parse-map (parse-seq (parse-string "0x") (parse-token char-hex-digit?))
+              (lambda (x) (string->number (cadr x) 16)))
+   (parse-map (parse-seq (parse-string "0") (parse-token char-octal-digit?))
+              (lambda (x) (string->number (cadr x) 8)))
+   (parse-integer)))
+
+(define (parse-real)
+  (parse-map-substring
+   (parse-seq
+    (parse-or
+     (parse-seq (parse-sign) (parse-repeat+ (parse-char char-numeric?))
+                (parse-optional
+                 (parse-seq (parse-char #\.)
+                            (parse-repeat (parse-char char-numeric?)))))
+     (parse-seq (parse-sign) (parse-char #\.)
+                (parse-repeat+ (parse-char char-numeric?))))
+    (parse-optional
+     (parse-seq (parse-char (lambda (ch) (eqv? #\e (char-downcase ch))))
+                (parse-sign)
+                (parse-repeat+ (parse-char char-numeric?)))))
+   string->number))
+
+(define (parse-imag)
+  (parse-or (parse-char #\i) (parse-char #\I)))
+
+(define (parse-complex)
+  (parse-map-substring
+   (parse-or
+    (parse-seq (parse-real) (parse-sign+) (parse-real) (parse-imag))
+    (parse-seq (parse-real) (parse-imag))
+    (parse-real))
+   string->number))
+
+(define (parse-identifier . o)
+  ;; Slightly more complicated than mapping parse-token because the
+  ;; typical identifier syntax has different initial and subsequent
+  ;; char-sets.
+  (let* ((init?
+          (if (pair? o)
+              (car o)
+              (lambda (ch) (or (eqv? #\_ ch) (char-alphabetic? ch)))))
+         (init (parse-char init?))
+         (subsequent
+          (parse-char
+           (if (and (pair? o) (pair? (cdr o)))
+               (cadr o)
+               (lambda (ch) (or (init? ch) (char-numeric? ch)))))))
+    (lambda (source0 index0 sk0 fk0)
+      (init
+       source0
+       index0
+       (lambda (res source index fk2)
+         (let lp ((s source) (i index))
+           (subsequent
+            s i (lambda (r s i fk) (lp s i))
+            (lambda (s i r)
+              (sk0 (string->symbol (parse-stream-substring source0 index0 s i))
+                   s i fk0)))))
+       fk0))))
+
+(define (parse-delimited . o)
+  (let ((delim (if (pair? o) (car o) #\"))
+        (esc (if (and (pair? o) (pair? (cdr o))) (cadr o) #\\))
+        (parse-esc (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)))
+                       (car (cddr o))
+                       parse-anything)))
+    (parse-map
+     (parse-seq
+      (parse-char delim)
+      (parse-repeat
+       (parse-or (parse-char
+                  (lambda (ch)
+                    (and (not (eqv? ch delim)) (not (eqv? ch esc)))))
+                 (parse-map (parse-seq (parse-char esc)
+                                       (if (eqv? delim esc)
+                                           (parse-char esc)
+                                           parse-esc))
+                            cadr)))
+      (parse-char delim))
+     (lambda (res) (list->string (cadr res))))))
+
+(define (parse-separated . o)
+  (let* ((sep (if (pair? o) (car o) #\,))
+         (o1 (if (pair? o) (cdr o) '()))
+         (delim (if (pair? o1) (car o1) #\"))
+         (o2 (if (pair? o1) (cdr o1) '()))
+         (esc (if (pair? o2) (car o2) delim))
+         (o3 (if (pair? o2) (cdr o2) '()))
+         (ok?
+          (if (pair? o3)
+              (let ((pred (car o3)))
+                (lambda (ch)
+                  (and (not (eqv? ch delim))
+                       (not (eqv? ch sep))
+                       (pred ch))))
+              (lambda (ch) (and (not (eqv? ch delim)) (not (eqv? ch sep))))))
+         (parse-field
+          (parse-or (parse-delimited delim esc)
+                    (parse-map-substring
+                     (parse-repeat+ (parse-char ok?))))))
+    (parse-map
+     (parse-seq parse-field
+                (parse-repeat
+                 (parse-map (parse-seq (parse-char sep) parse-field) cadr)))
+     (lambda (res) (cons (car res) (cadr res))))))
+
+(define (parse-records . o)
+  (let* ((terms (if (pair? o) (car o) '("\r\n" "\n")))
+         (terms (if (list? terms) terms (list terms)))
+         (term-chars (apply append (map string->list terms)))
+         (ok? (lambda (ch) (not (memv ch term-chars))))
+         (o (if (pair? o) (cdr o) '()))
+         (sep (if (pair? o) (car o) #\,))
+         (o (if (pair? o) (cdr o) '()))
+         (delim (if (pair? o) (car o) #\"))
+         (o (if (pair? o) (cdr o) '()))
+         (esc (if (pair? o) (car o) delim)))
+    (parse-repeat
+     (parse-map
+      (parse-seq (parse-separated sep delim esc ok?)
+                 (apply parse-or parse-end (map parse-string terms)))
+      car))))
+
+(define parse-space (parse-char char-whitespace?))
+
+(define (op-value op) (car op))
+(define (op-prec op) (cadr op))
+(define (op-assoc op)
+  (let ((tail (cddr op))) (if (pair? tail) (car tail) 'left)))
+(define (op<? op1 op2)
+  (or (< (op-prec op1) (op-prec op2))
+      (and (= (op-prec op1) (op-prec op2))
+           (eq? 'right (op-assoc op1)))))
+
+;; rules are of the form ((op precedence [assoc=left]) ...)
+;; ls is of the forms (expr [op expr] ...)
+;; returns an sexp representation of the operator chain
+(define (resolve-operator-precedence rules ls)
+  (define (lookup op rules)
+    (or (assoc op rules)
+        (list op 0)))
+  (define (join exprs ops)
+    `((,(op-value (car ops)) ,(cadr exprs) ,(car exprs))
+      ,@(cddr exprs)))
+  (if (null? ls) (error "empty operator chain"))
+  (let lp ((ls (cdr ls)) (exprs (list (car ls))) (ops '((#f -1))))
+    ;; ls: trailing operations ([op expr] ...)
+    ;; exprs: list of expressions (expr expr ...)
+    ;; ops: operator chain, same len as exprs ((op prec [assoc]) ...)
+    (cond
+     ((and (null? ls) (null? (cdr exprs)))
+      (car exprs))
+     ((null? ls)
+      (lp ls (join exprs ops) (cdr ops)))
+     ((null? (cdr ls))
+      (error "unbalanced expression" ls))
+     (else
+      (let ((op (lookup (car ls) rules))
+            (expr (cadr ls)))
+        (if (or (null? (cdr ops)) (op<? op (car ops)))
+            (lp (cddr ls) (cons expr exprs) (cons op ops))
+            (lp ls (join exprs ops) (cdr ops))))))))
+
+(define (parse-binary-op op rules expr . o)
+  (let* ((ws (if (pair? o) (car o) (parse-repeat parse-space)))
+         (ws-right (if (and (pair? o) (pair? (cdr o))) (cadr o) ws)))
+    (parse-map
+     (parse-seq ws expr (parse-repeat (parse-seq ws-right op ws expr)))
+     (lambda (x)
+       (resolve-operator-precedence
+        rules
+        (cons (cadr x)
+              (apply append
+                     (map (lambda (y) (list (cadr y) (cadr (cddr y))))
+                          (car (cddr x))))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define parse-ipv4-digit (parse-integer 0 255))
+
+(define parse-ipv4-address
+  (parse-map-substring
+   (parse-seq parse-ipv4-digit
+              (parse-repeat (parse-seq (parse-char #\.) parse-ipv4-digit)
+                            3 3))))
+
+(define parse-ipv6-digit
+  (parse-repeat (parse-char char-hex-digit?) 0 4))
+
+(define parse-ipv6-address
+  (parse-map-substring
+   (parse-seq
+    parse-ipv6-digit
+    (parse-repeat (parse-seq (parse-repeat (parse-char #\:) 1 2)
+                             parse-ipv6-digit)
+                  1 7))))
+
+(define parse-ip-address
+  (parse-or parse-ipv4-address parse-ipv6-address))
+
+(define parse-domain-atom
+  (parse-token
+   (lambda (ch)
+     (or (char-alphabetic? ch) (char-numeric? ch) (memv ch '(#\- #\_))))))
+
+(define (parse-domain)
+  (parse-map-substring
+   (parse-or
+    parse-ip-address
+    (parse-seq (parse-repeat (parse-seq parse-domain-atom (parse-char #\.)))
+               parse-domain-atom))))
+
+(define parse-top-level-domain
+  (apply parse-or
+         (parse-repeat (parse-char char-alphabetic?) 2 2)
+         (map parse-string
+              '("arpa" "com" "gov" "mil" "net" "org" "aero" "biz" "coop"
+                "info" "museum" "name" "pro"))))
+
+(define (parse-common-domain)
+  (parse-map-substring
+   (parse-seq (parse-repeat+ (parse-seq parse-domain-atom (parse-char #\.)))
+              parse-top-level-domain)))
+
+(define parse-email-local-part
+  (parse-token
+   (lambda (ch)
+     (or (char-alphabetic? ch)
+         (char-numeric? ch)
+         (memv ch '(#\- #\_ #\. #\+))))))
+
+(define (parse-email)
+  ;; no quoted local parts or bang paths
+  (parse-seq parse-email-local-part
+             (parse-ignore (parse-char #\@))
+             (parse-domain)))
+
+(define (char-url-fragment? ch)
+  (or (char-alphabetic? ch) (char-numeric? ch)
+      (memv ch '(#\_ #\- #\+ #\\ #\= #\~ #\&))))
+
+(define (char-url? ch)
+  (or (char-url-fragment? ch) (memv ch '(#\. #\, #\;))))
+
+(define (parse-url-char pred)
+  (parse-or (parse-char pred)
+            (parse-seq (parse-char #\%)
+                       (parse-repeat (parse-char char-hex-digit?) 2 2))))
+
+(define (parse-uri)
+  (parse-seq
+   (parse-identifier)
+   (parse-ignore
+    (parse-seq (parse-char #\:) (parse-repeat (parse-char #\/))))
+   (parse-domain)
+   (parse-optional (parse-map (parse-seq (parse-char #\:)
+                                         (parse-integer 0 65536))
+                              cadr))
+   (parse-optional
+    (parse-map-substring
+     (parse-seq (parse-char #\/)
+                (parse-repeat (parse-url-char char-url?)))))
+   (parse-optional
+    (parse-map
+     (parse-seq (parse-ignore (parse-char #\?))
+                (parse-map-substring
+                 (parse-repeat (parse-url-char char-url?))))
+     car))
+   (parse-optional
+    (parse-map
+     (parse-seq (parse-ignore (parse-char #\#))
+                (parse-map-substring
+                 (parse-repeat (parse-url-char char-url-fragment?))))
+     car))))
diff --git a/lib/chibi/parse/common.sld b/lib/chibi/parse/common.sld
new file mode 100644
index 00000000..08a6ca4d
--- /dev/null
+++ b/lib/chibi/parse/common.sld
@@ -0,0 +1,11 @@
+
+(define-library (chibi parse common)
+  (export parse-integer parse-unsigned-integer parse-c-integer
+          parse-real parse-complex
+          parse-identifier parse-delimited parse-separated parse-records
+          parse-space parse-binary-op
+          parse-ipv4-address parse-ipv6-address parse-ip-address
+          parse-domain parse-common-domain parse-email parse-uri
+          char-hex-digit? char-octal-digit?)
+  (import (chibi) (chibi parse))
+  (include "common.scm"))
diff --git a/lib/chibi/parse/parse.scm b/lib/chibi/parse/parse.scm
new file mode 100644
index 00000000..cda61c73
--- /dev/null
+++ b/lib/chibi/parse/parse.scm
@@ -0,0 +1,772 @@
+;; parse.scm -- Parser Combinators
+;; Copyright (c) 2013 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; parse stream type
+;;
+;; Abstraction to treat ports as proper streams so that we can
+;; backtrack from previous states.  A single Parse-Stream record
+;; represents a single buffered chunk of text.
+
+(define-record-type Parse-Stream
+  (%make-parse-stream
+   filename port buffer cache offset prev-char line column tail)
+  parse-stream?
+  ;; The file the data came from, for debugging and error reporting.
+  (filename parse-stream-filename)
+  ;; The underlying port.
+  (port parse-stream-port)
+  ;; A vector of characters read from the port.  We use a vector
+  ;; rather than a string for guaranteed O(1) access.
+  (buffer parse-stream-buffer)
+  ;; A vector of caches corresponding to parser successes or failures
+  ;; starting from the corresponding char.  Currently each cache is
+  ;; just an alist, optimized under the assumption that the number of
+  ;; possible memoized parsers is relatively small.  Note that
+  ;; memoization is only enabled explicitly.
+  (cache parse-stream-cache)
+  ;; The current offset of filled characters in the buffer.
+  ;; If offset is non-zero, (vector-ref buffer (- offset 1)) is
+  ;; valid.
+  (offset parse-stream-offset parse-stream-offset-set!)
+  ;; The previous char before the beginning of this Parse-Stream.
+  ;; Used for line/word-boundary checks.
+  (prev-char parse-stream-prev-char)
+  ;; The debug info for the start line and column of this chunk.
+  (line parse-stream-line)
+  (column parse-stream-column)
+  ;; The successor Parse-Stream chunk, created on demand and filled
+  ;; from the same port.
+  (tail %parse-stream-tail %parse-stream-tail-set!))
+
+;; We want to balance avoiding reallocating buffers with avoiding
+;; holding many memoized values in memory.
+(define default-buffer-size 256)
+
+(define (make-parse-stream filename . o)
+  (let ((port (if (pair? o) (car o) (open-input-file filename)))
+        (len (if (and (pair? o) (pair? (cdr o))) (cadr o) default-buffer-size)))
+    (%make-parse-stream
+     filename port (make-vector len #f) (make-vector len '()) 0 #f 0 0 #f)))
+
+(define (file->parse-stream filename)
+  (make-parse-stream filename (open-input-file filename)))
+
+(define (string->parse-stream str)
+  (make-parse-stream #f (open-input-string str)))
+
+(define (parse-stream-tail source)
+  (or (%parse-stream-tail source)
+      (let* ((len (vector-length (parse-stream-buffer source)))
+             (line-info (parse-stream-count-lines source))
+             (line (+ (parse-stream-line source) (car line-info)))
+             (col (if (zero? (car line-info))
+                      (+ (parse-stream-column source) (cadr line-info))
+                      (cadr line-info)))
+             (tail (%make-parse-stream (parse-stream-filename source)
+                                       (parse-stream-port source)
+                                       (make-vector len #f)
+                                       (make-vector len '())
+                                       0
+                                       (parse-stream-last-char source)
+                                       line
+                                       col
+                                       #f)))
+        (%parse-stream-tail-set! source tail)
+        tail)))
+
+(define (parse-stream-fill! source i)
+  (let ((off (parse-stream-offset source))
+        (buf (parse-stream-buffer source)))
+    (if (<= off i)
+        (do ((off off (+ off 1)))
+            ((> off i) (parse-stream-offset-set! source off))
+          (vector-set! buf off (read-char (parse-stream-port source))))
+        #f)))
+
+(define (parse-stream-start? source i)
+  (and (zero? i) (not (parse-stream-prev-char source))))
+
+(define (parse-stream-end? source i)
+  (eof-object? (parse-stream-ref source i)))
+
+(define (parse-stream-ref source i)
+  (parse-stream-fill! source i)
+  (vector-ref (parse-stream-buffer source) i))
+
+(define (parse-stream-last-char source)
+  (let ((buf (parse-stream-buffer source)))
+    (let lp ((i (min (- (vector-length buf) 1) (parse-stream-offset source))))
+      (if (negative? i)
+          (parse-stream-prev-char source)
+          (let ((ch (vector-ref buf i)))
+            (if (eof-object? ch)
+                (lp (- i 1))
+                ch))))))
+
+(define (parse-stream-char-before source i)
+  (if (> i (parse-stream-offset source))
+      (parse-stream-ref source (- i 1))
+      (parse-stream-prev-char source)))
+
+(define (parse-stream-max-char source)
+  (let ((buf (parse-stream-buffer source)))
+    (let lp ((i (min (- (vector-length buf) 1)
+                     (parse-stream-offset source))))
+      (if (or (negative? i)
+              (char? (vector-ref buf i)))
+          i
+          (lp (- i 1))))))
+
+(define (parse-stream-count-lines source . o)
+  (let* ((buf (parse-stream-buffer source))
+         (end (if (pair? o) (car o) (vector-length buf))))
+    (let lp ((i 0) (from 0) (lines 0))
+      (if (>= i end)
+          (list lines (- i from) from)
+          (let ((ch (vector-ref buf i)))
+            (cond
+             ((not (char? ch))
+              (list lines (- i from) from))
+             ((eqv? ch #\newline)
+              (lp (+ i 1) i (+ lines 1)))
+             (else
+              (lp (+ i 1) from lines))))))))
+
+(define (parse-stream-end-of-line source i)
+  (let* ((buf (parse-stream-buffer source))
+         (end (vector-length buf)))
+    (let lp ((i i))
+      (if (>= i end)
+          i
+          (let ((ch (vector-ref buf i)))
+            (if (or (not (char? ch)) (eqv? ch #\newline))
+                i
+                (lp (+ i 1))))))))
+
+(define (parse-stream-debug-info s i)
+  ;; i is the failed parse index, but we want the furthest reached
+  ;; location
+  (if (%parse-stream-tail s)
+      (parse-stream-debug-info (%parse-stream-tail s) i)
+      (let* ((line-info
+              (parse-stream-count-lines s (parse-stream-max-char s)))
+             (line (+ (parse-stream-line s) (car line-info)))
+             (col (if (zero? (car line-info))
+                      (+ (parse-stream-column s) (cadr line-info))
+                      (cadr line-info)))
+             (from (car (cddr line-info)))
+             (to (parse-stream-end-of-line s (+ from 1)))
+             (str (parse-stream-substring s from s to)))
+        (list line col str))))
+
+(define (parse-stream-next-source source i)
+  (if (>= (+ i 1) (vector-length (parse-stream-buffer source)))
+      (parse-stream-tail source)
+      source))
+
+(define (parse-stream-next-index source i)
+  (if (>= (+ i 1) (vector-length (parse-stream-buffer source)))
+      0
+      (+ i 1)))
+
+(define (parse-stream-close source)
+  (close-input-port (parse-stream-port source)))
+
+(define (vector-substring vec start . o)
+  (let* ((end (if (pair? o) (car o) (vector-length vec)))
+         (res (make-string (- end start))))
+    (do ((i start (+ i 1)))
+        ((= i end) res)
+      (string-set! res (- i start) (vector-ref vec i)))))
+
+(define (parse-stream-in-tail? s0 s1)
+  (let ((s0^ (%parse-stream-tail s0)))
+    (or (eq? s0^ s1)
+        (and s0^ (parse-stream-in-tail? s0^ s1)))))
+
+(define (parse-stream< s0 i0 s1 i1)
+  (if (eq? s0 s1)
+      (< i0 i1)
+      (parse-stream-in-tail? s0 s1)))
+
+(define (parse-stream-substring s0 i0 s1 i1)
+  (cond
+   ((eq? s0 s1)
+    (parse-stream-fill! s0 i1)
+    (vector-substring (parse-stream-buffer s0) i0 i1))
+   (else
+    (let lp ((s (parse-stream-tail s0))
+             (res (list (vector-substring (parse-stream-buffer s0) i0))))
+      (let ((buf (parse-stream-buffer s)))
+        (cond
+         ((eq? s s1)
+          (apply string-append
+                 (reverse (cons (vector-substring buf 0 i1) res))))
+         (else
+          (lp (parse-stream-tail s)
+              (cons (vector-substring buf 0) res)))))))))
+
+(define (parse-stream-cache-cell s i f)
+  (assv f (vector-ref (parse-stream-cache s) i)))
+
+(define (parse-stream-cache-set! s i f x)
+  (let ((cache (vector-ref (parse-stream-cache s) i)))
+    (cond
+     ((assv f cache)
+      => (lambda (cell)
+           ;; prefer longer matches
+           (if (and (pair? (cdr cell))
+                    (parse-stream< (car (cddr cell)) (cadr (cddr cell)) s i))
+               (set-cdr! cell x))))
+     (else
+      (vector-set! (parse-stream-cache s) i (cons (cons f x) cache))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; the parser interface
+
+(define (parse-failure s i reason)
+  (let ((line+col (parse-stream-debug-info s i)))
+    (error "incomplete parse at" (append line+col (list reason)))))
+
+(define (call-with-parse f source index sk . o)
+  (let ((s (if (string? source) (string->parse-stream source) source))
+        (fk (if (pair? o) (car o) (lambda (s i reason) #f))))
+    (f s index sk fk)))
+
+(define (parse f source . o)
+  (let ((index (if (pair? o) (car o) 0)))
+    (call-with-parse f source index (lambda (r s i fk) r))))
+
+(define (parse-fully f source . o)
+  (let ((s (if (string? source) (string->parse-stream source) source))
+        (index (if (pair? o) (car o) 0)))
+    (call-with-parse
+     f s index
+     (lambda (r s i fk)
+       (if (parse-stream-end? s i) r (fk s i "incomplete parse")))
+     parse-failure)))
+
+(define (parse-fold f kons knil source . o)
+  (let lp ((p (if (string? source) (string->parse-stream source) source))
+           (index (if (pair? o) (car o) 0))
+           (acc knil))
+    (f p index (lambda (r s i fk) (lp s i (kons r acc))) (lambda (s i r) acc))))
+
+(define (parse->list f source . o)
+  (reverse (apply parse-fold cons '() f source o)))
+
+(define (parse-fully->list f source . o)
+  (let lp ((s (if (string? source) (string->parse-stream source) source))
+           (index (if (pair? o) (car o) 0))
+           (acc '()))
+    (f s index
+       (lambda (r s i fk)
+         (if (eof-object? r) (reverse acc) (lp s i (cons r acc))))
+       (lambda (s i reason) (error "incomplete parse")))))
+
+(define (parse-with-failure-reason f reason)
+  (lambda (r s i fk)
+    (f r s i (lambda (s i r) (fk s i reason)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; basic parsing combinators
+
+(define parse-epsilon
+  (lambda (source index sk fk)
+    (sk #t source index fk)))
+
+(define parse-anything
+  (lambda (source index sk fk)
+    (if (parse-stream-end? source index)
+        (fk source index "end of input")
+        (sk (parse-stream-ref source index)
+            (parse-stream-next-source source index)
+            (parse-stream-next-index source index)
+            fk))))
+
+(define parse-nothing
+  (lambda (source index sk fk)
+    (fk source index "nothing")))
+
+(define (parse-or f . o)
+  (if (null? o)
+      f
+      (let ((g (apply parse-or o)))
+        (lambda (source index sk fk)
+          (let ((fk2 (lambda (s i r)
+                       (g source index sk fk
+                          ;; (lambda (s2 i2 r2)
+                          ;;   (fk s2 i2 `(or ,r ,r2)))
+                          ))))
+            (f source index sk fk2))))))
+
+(define (parse-and f g)
+  (lambda (source index sk fk)
+    (f source index (lambda (r s i fk) (g source index sk fk)) fk)))
+
+(define (parse-not f)
+  (lambda (source index sk fk)
+    (f source index (lambda (r s i fk) (fk s i "not"))
+       (lambda (s i r) (sk #t source index fk)))))
+
+(define (parse-seq-list o)
+  (cond
+   ((null? o)
+    parse-epsilon)
+   ((null? (cdr o))
+    (let ((f (car o)))
+      (lambda (s i sk fk)
+        (f s i (lambda (r s i fk) (sk (list r) s i fk)) fk))))
+   (else
+    (let* ((f (car o))
+           (o (cdr o))
+           (g (car o))
+           (o (cdr o))
+           (g (if (pair? o)
+                  (apply parse-seq g o)
+                  (lambda (s i sk fk)
+                    (g s i (lambda (r s i fk) (sk (list r) s i fk)) fk)))))
+      (lambda (source index sk fk)
+        (f source
+           index
+           (lambda (r s i fk)
+             (g s i (lambda (r2 s i fk)
+                      (let ((r2 (if (eq? r ignored-value) r2 (cons r r2))))
+                        (sk r2 s i fk)))
+                fk))
+           fk))))))
+
+(define (parse-seq . o)
+  (parse-seq-list o))
+
+(define (maybe-parse-seq ls)
+  (if (null? (cdr ls)) (car ls) (parse-seq-list ls)))
+
+(define (parse-optional f . o)
+  (if (pair? o)
+      (parse-optional (apply parse-seq f o))
+      (lambda (source index sk fk)
+        (f source index sk (lambda (s i r) (sk #f source index fk))))))
+
+(define ignored-value (list 'ignore))
+
+(define (parse-repeat f . o)
+  (let ((lo (if (pair? o) (car o) 0))
+        (hi (and (pair? o) (pair? (cdr o)) (cadr o))))
+    (lambda (source0 index0 sk fk)
+      (let repeat ((source source0) (index index0) (fk fk) (j 0) (res '()))
+        (let ((fk (if (>= j lo)
+                      (lambda (s i r) (sk (reverse res) source index fk))
+                      fk)))
+          (if (and hi (= j hi))
+              (sk (reverse res) source index fk)
+              (f source
+                 index
+                 (lambda (r s i fk) (repeat s i fk (+ j 1) (cons r res)))
+                 fk)))))))
+
+(define (parse-repeat+ f)
+  (parse-repeat f 1))
+
+(define (parse-map f proc)
+  (lambda (source index sk fk)
+    (f source index (lambda (res s i fk) (sk (proc res) s i fk)) fk)))
+
+(define (parse-map-substring f . o)
+  (let ((proc (if (pair? o) (car o) (lambda (res) res))))
+    (lambda (source index sk fk)
+      (f source
+         index
+         (lambda (res s i fk)
+           (sk (proc (parse-stream-substring source index s i)) s i fk))
+         fk))))
+
+(define (parse-ignore f)
+  (parse-map f (lambda (res) ignored-value)))
+
+(define (parse-assert f check?)
+  (lambda (source index sk fk)
+    (f source
+       index
+       (lambda (res s i fk)
+         (if (check? res) (sk res s i fk) (fk s i "assertion failed")))
+       fk)))
+
+(define (parse-atomic f)
+  (lambda (source index sk fk)
+    (f source index (lambda (res s i fk2) (sk res s i fk)) fk)))
+
+(define (parse-commit f)
+  (lambda (source index sk fk)
+    (f source index (lambda (res s i fk) (sk res s i (lambda (s i r) #f))) fk)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; boundary checks
+
+(define parse-beginning
+  (lambda (source index sk fk)
+    (if (parse-stream-start? source index)
+        (sk #t source index fk)
+        (fk source index "expected beginning"))))
+
+(define parse-end
+  (lambda (source index sk fk)
+    (if (parse-stream-end? source index)
+        (sk #t source index fk)
+      (fk source index "expected end"))))
+
+(define parse-beginning-of-line
+  (lambda (source index sk fk)
+    (let ((before (parse-stream-char-before source index)))
+      (if (or (not before) (eqv? #\newline before))
+          (sk #t source index fk)
+          (fk source index "expected beginning of line")))))
+
+(define parse-end-of-line
+  (lambda (source index sk fk)
+    (if (or (parse-stream-end? source index)
+            (eqv? #\newline (parse-stream-ref source index)))
+        (sk #t source index fk)
+        (fk source index "expected end of line"))))
+
+(define (char-word? ch)
+  (or (char-alphabetic? ch) (eqv? ch #\_)))
+
+(define parse-beginning-of-word
+  (lambda (source index sk fk)
+    (let ((before (parse-stream-char-before source index)))
+      (if (and (or (not before) (not (char-word? before)))
+               (not (parse-stream-end? source index))
+               (char-word? (parse-stream-ref source index)))
+          (sk #t source index fk)
+          (fk source index "expected beginning of word")))))
+
+(define parse-end-of-word
+  (lambda (source index sk fk)
+    (let ((before (parse-stream-char-before source index)))
+      (if (and before
+               (char-word? before)
+               (or (parse-stream-end? source index)
+                   (not (char-word? (parse-stream-ref source index)))))
+          (sk #t source index fk)
+          (fk source index "expected end of word")))))
+
+(define (parse-word . o)
+  (let ((word (if (pair? o) (car o) (parse-token char-word?))))
+    (lambda (source index sk fk)
+      (parse-seq parse-beginning-of-word
+                 word
+                 parse-end-of-word))))
+
+(define (parse-word+ . o)
+  (let ((pred (if (pair? o)
+                  (lambda (ch) (and (char-word? ch) ((car o) ch)))
+                  char-word?)))
+    (parse-word (parse-token pred))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; constant parsers
+
+(define (parse-char-pred pred)
+  (lambda (source index sk fk)
+    (let ((ch (parse-stream-ref source index)))
+      (if (and (char? ch) (pred ch))
+          (sk ch
+              (parse-stream-next-source source index)
+              (parse-stream-next-index source index)
+              fk)
+          (fk source index "failed char pred")))))
+
+(define (x->char-predicate x)
+  (cond
+   ((char? x)
+    (lambda (ch) (eqv? ch x)))
+   ((char-set? x)
+    (lambda (ch) (and (char? ch) (char-set-contains? x ch))))
+   ((procedure? x)
+    (lambda (ch) (and (char? ch) (x ch))))
+   (else
+    (error "don't know how to handle char predicate" x))))
+
+(define (parse-char x)
+  (parse-char-pred (x->char-predicate x)))
+
+(define (parse-not-char x)
+  (let ((pred (x->char-predicate x)))
+    (parse-char-pred (lambda (ch) (not (pred ch))))))
+
+(define (parse-string x)
+  (parse-map (parse-with-failure-reason
+              (parse-seq-list (map parse-char (string->list x)))
+              `(expected ,x))
+             list->string))
+
+(define (parse-token x)
+  ;; (parse-map (parse-repeat+ (parse-char x)) list->string)
+  ;; Tokens are atomic - we don't want to split them at any point in
+  ;; the middle - so the implementation is slightly more complex than
+  ;; the above.  With a sane grammar the result would be the same
+  ;; either way, but this provides a useful optimization.
+  (let ((f (parse-char x)))
+    (lambda (source0 index0 sk fk)
+      (let lp ((source source0) (index index0))
+        (f source
+           index
+           (lambda (r s i fk) (lp s i))
+           (lambda (s i r)
+             (if (and (eq? source source0) (eqv? index index0))
+                 (fk s i r)
+                 (sk (parse-stream-substring source0 index0 source index)
+                     source index fk))))))))
+
+;; We provide a subset of SRE syntax, optionally interspersed with
+;; existing parsers.  These are just translated directly into parser
+;; combinators.  A future version may translate pieces into a
+;; non-backtracking engine where possible.
+(define (parse-sre x)
+  (define (ranges->char-set ranges)
+    (let lp ((ls ranges) (res (char-set)))
+      (cond
+       ((null? ls)
+        res)
+       ((string? (car ls))
+        (lp (append (string->list (car ls)) (cdr ls)) res))
+       ((null? (cdr ls))
+        (error "incomplete range in / char-set" ranges))
+       (else
+        (let ((cs (ucs-range->char-set (char->integer (car ls))
+                                       (+ 1 (char->integer (cadr ls))))))
+          (lp (cddr ls) (char-set-union cs res)))))))
+  (define (sre-list->char-set ls)
+    (apply char-set-union (map sre->char-set ls)))
+  (define (sre->char-set x)
+    (cond
+     ((char? x) (char-set x))
+     ((string? x) (if (= 1 (string-length x))
+                      (string->char-set x)
+                      (error "multi-element string in char-set" x)))
+     ((pair? x)
+      (if (and (string? (car x)) (null? (cdr x)))
+          (string->char-set (car x))
+          (case (car x)
+            ((/) (ranges->char-set (cdr x)))
+            ((~) (char-set-complement (sre-list->char-set (cdr x))))
+            ((-) (apply char-set-difference (map sre->char-set (cdr x))))
+            ((&) (apply char-set-intersection (map sre->char-set (cdr x))))
+            ((or) (sre-list->char-set (cdr x)))
+            (else (error "unknown SRE char-set operator" x)))))
+     (else (error "unknown SRE char-set" x))))
+  (cond
+   ((procedure? x)  ; an embedded parser
+    x)
+   ((or (char? x) (char-set? x))
+    (parse-char x))
+   ((string? x)
+    (parse-string x))
+   ((null? x)
+    parse-epsilon)
+   ((list? x)
+    (case (car x)
+      ((: seq) (parse-seq-list (map parse-sre (cdr x))))
+      ((or) (apply parse-or (map parse-sre (cdr x))))
+      ((and) (apply parse-and (map parse-sre (cdr x))))
+      ((not) (apply parse-not (map parse-sre (cdr x))))
+      ((*) (parse-repeat (maybe-parse-seq (map parse-sre (cdr x)))))
+      ((+) (parse-repeat+ (maybe-parse-seq (map parse-sre (cdr x)))))
+      ((?) (parse-optional (parse-seq-list (map parse-sre (cdr x)))))
+      ((=> ->) (maybe-parse-seq (map parse-sre (cddr x))))
+      ((word) (apply parse-word (cdr x)))
+      ((word+) (apply parse-word+ (cdr x)))
+      ((/ ~ & -) (parse-char (sre->char-set x)))
+      (else
+       (if (string? (car x))
+           (parse-char (sre->char-set x))
+           (error "unknown SRE operator" x)))))
+   (else
+    (case x
+      ((any) parse-anything)
+      ((nonl) (parse-char (lambda (ch) (not (eqv? ch #\newline)))))
+      ((space whitespace) (parse-char char-whitespace?))
+      ((digit numeric) (parse-char char-numeric?))
+      ((alpha alphabetic) (parse-char char-alphabetic?))
+      ((alnum alphanumeric)
+       (parse-char-pred (lambda (ch) (or (char-alphabetic? ch) (char-numeric? ch)))))
+      ((lower lower-case) (parse-char char-lower-case?))
+      ((upper upper-case) (parse-char char-upper-case?))
+      ((word) (parse-word))
+      ((bow) parse-beginning-of-word)
+      ((eow) parse-end-of-word)
+      ((bol) parse-beginning-of-line)
+      ((eol) parse-end-of-line)
+      ((bos) parse-beginning)
+      ((eos) parse-end)
+      (else (error "unknown SRE parser" x))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; delayed combinators for self-referentiality
+
+(define-syntax parse-lazy
+  (syntax-rules ()
+    ((parse-lazy f)
+     (let ((g (delay f)))
+       (lambda (source index sk fk)
+         ((force g) source index sk fk))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; memoization wrapper for packrat-like parsing
+
+;; debugging
+(define *procedures* '())
+(define (procedure-name f)
+  (cond ((assq f *procedures*) => cdr) (else #f)))
+(define (procedure-name-set! f name)
+  (set! *procedures* (cons (cons f name) *procedures*)))
+
+(define memoized-failure (list 'failure))
+
+(define (parse-memoize name f)
+  ;;(if (not (procedure-name f)) (procedure-name-set! f name))
+  (lambda (source index sk fk)
+    (cond
+     ((parse-stream-cache-cell source index f)
+      => (lambda (cell)
+           (if (and (pair? (cdr cell)) (eq? memoized-failure (cadr cell)))
+               (fk source index (cddr cell))
+               (apply sk (append (cdr cell) (list fk))))))
+     (else
+      (f source
+         index
+         (lambda (res s i fk)
+           (parse-stream-cache-set! source index f (list res s i))
+           (sk res s i fk))
+         (lambda (s i r)
+           (if (not (pair? (parse-stream-cache-cell source index f)))
+               (parse-stream-cache-set!
+                source index f (cons memoized-failure r)))
+           (fk s i r)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; syntactic sugar
+
+;; The four basic interfaces are grammar, define-grammar, and their
+;; unmemoized variants grammar/unmemoized and
+;; define-grammar/unmemoized.  This is optimized for the common case -
+;; generally you want to memoize grammars, and may or may not want to
+;; memoize the smaller lexical components.
+
+(define-syntax grammar/unmemoized
+  (syntax-rules ()
+    ((grammar/unmemoized init (rule (clause . action) ...) ...)
+     (letrec ((rule (parse-or (grammar-clause clause . action) ...))
+              ...)
+       init))))
+
+(define-syntax grammar
+  (syntax-rules ()
+    ((grammar init (rule (clause . action) ...) ...)
+     (letrec ((rule
+               (parse-memoize
+                'rule
+                (parse-or (grammar-clause clause . action) ...)))
+              ...)
+       init))))
+
+(define-syntax define-grammar/unmemoized
+  (syntax-rules ()
+    ((define-grammar/unmemoized name (rule (clause . action) ...) ...)
+     (begin
+       (define rule (parse-or (grammar-clause clause . action) ...))
+       ...
+       (define name (list (cons 'rule rule) ...))))))
+
+(define-syntax define-grammar
+  (syntax-rules ()
+    ((define-grammar name (rule (clause . action) ...) ...)
+     (begin
+       (define rule
+         (parse-memoize 'rule (parse-or (grammar-clause clause . action) ...)))
+       ...
+       (define name (list (cons 'rule rule) ...))))))
+
+;; Most of the implementation goes into how we parse a single grammar
+;; clause.  This is hard to read if you're not used to CPS macros.
+
+(define-syntax grammar-clause
+  (syntax-rules ()
+    ((grammar-clause clause . action)
+     (grammar-extract clause () (grammar-action action)))))
+
+(define-syntax grammar-extract
+  (syntax-rules (unquote -> => : seq * + ? or and)
+    ;; Named patterns
+    ((grammar-extract (-> name pattern) bindings k)
+     (grammar-extract pattern bindings (grammar-bind name k)))
+    ((grammar-extract (-> name pattern ...) bindings k)
+     (grammar-extract (: pattern ...) bindings (grammar-bind name k)))
+    ;; Allow => as an alias for -> for SRE compatibility.
+    ((grammar-extract (=> name pattern) bindings k)
+     (grammar-extract pattern bindings (grammar-bind name k)))
+    ((grammar-extract (=> name pattern ...) bindings k)
+     (grammar-extract (: pattern ...) bindings (grammar-bind name k)))
+    ((grammar-extract ,name bindings k)
+     (grammar-bind name k (parse-sre name) bindings))
+    ;; Walk container patterns.
+    ((grammar-extract (: x y ...) bindings k)
+     (grammar-extract x bindings (grammar-map parse-seq (y ...) () k)))
+    ((grammar-extract (* x) bindings k)
+     (grammar-extract x bindings (grammar-map parse-repeat () () k)))
+    ((grammar-extract (* x y ...) bindings k)
+     (grammar-extract (: x y ...) bindings (grammar-map parse-repeat () () k)))
+    ((grammar-extract (+ x) bindings k)
+     (grammar-extract x bindings (grammar-map parse-repeat+ () () k)))
+    ((grammar-extract (+ x y ...) bindings k)
+     (grammar-extract (: x y ...) bindings (grammar-map parse-repeat+ () () k)))
+    ((grammar-extract (? x y ...) bindings k)
+     (grammar-extract x bindings (grammar-map parse-optional (y ...) () k)))
+    ((grammar-extract (or x y ...) bindings k)
+     (grammar-extract x bindings (grammar-map parse-or (y ...) () k)))
+    ((grammar-extract (and x y ...) bindings k)
+     (grammar-extract x bindings (grammar-map parse-and (y ...) () k)))
+    ;; Anything else is an implicitly quasiquoted SRE
+    ((grammar-extract pattern bindings (k ...))
+     (k ... (parse-sre `pattern) bindings))))
+
+(define-syntax grammar-map
+  (syntax-rules ()
+    ((grammar-map f () (args ...) (k ...) x bindings)
+     (k ... (f args ... x) bindings))
+    ((grammar-map f (y . rest) (args ...) k x bindings)
+     (grammar-extract y bindings (grammar-map f rest (args ... x) k)))))
+
+(define-syntax grammar-action
+  (syntax-rules (=>)
+    ((grammar-action () parser bindings)
+     ;; By default just return the result.
+     (grammar-action (=> (lambda (r s i fk) r)) parser bindings))
+    ((grammar-action (=> receiver) parser ((var tmp) ...))
+     ;; Explicit => handler.
+     (lambda (source index sk fk)
+       (let ((tmp #f) ...)
+         (parser source
+                 index
+                 (lambda (r s i fk)
+                   (sk (receiver r s i fk) s i fk))
+                 fk))))
+    ((grammar-action (action-expr) parser ())
+     ;; Fast path - no named variables.
+     (let ((f parser))
+       (lambda (source index sk fk)
+         (f source index (lambda (r s i fk) (sk action-expr s i fk)) fk))))
+    ((grammar-action (action-expr) parser ((var tmp) ...))
+     (lambda (source index sk fk)
+       (let ((tmp #f) ...)
+         ;; TODO: Precompute static components of the parser.
+         ;; We need to bind fresh variables on each parse, so some
+         ;; components must be reified in this scope.
+         (parser source
+                 index
+                 (lambda (r s i fk)
+                   (sk (let ((var tmp) ...) action-expr) s i fk))
+                 fk))))))
diff --git a/lib/chibi/pathname.scm b/lib/chibi/pathname.scm
new file mode 100644
index 00000000..306a4d27
--- /dev/null
+++ b/lib/chibi/pathname.scm
@@ -0,0 +1,244 @@
+;; Copyright (c) 2009-2013 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> A general, non-filesystem-specific pathname library.
+
+;; POSIX basename
+;; (define (path-strip-directory path)
+;;   (if (string=? path "")
+;;       path
+;;       (let ((end (string-skip-right path #\/)))
+;;         (if (zero? end)
+;;             "/"
+;;             (let ((start (string-find-right path #\/ 0 end)))
+;;               (substring-cursor path start end))))))
+
+;;> Returns just the basename of \var{path}, with any directory
+;;> removed.  If \var{path} does not contain a directory separator,
+;;> return the whole \var{path}.  If \var{path} ends in a directory
+;;> separator (i.e. path is a directory), or is empty, return the
+;;> empty string.
+
+;; GNU basename
+(define (path-strip-directory path)
+  (substring-cursor path (string-find-right path #\/)))
+
+;;> Returns just the directory of \var{path}.
+;;> If \var{path} is relative (or empty), return \scheme{"."}.
+
+(define (path-directory path)
+  (if (string=? path "")
+      "."
+      (let ((end (string-skip-right path #\/)))
+        (if (zero? end)
+            "/"
+            (let ((start (string-find-right path #\/ 0 end)))
+              (if (zero? start)
+                  "."
+                  (let ((start2 (string-skip-right path #\/ 0 start)))
+                    (if (zero? start2)
+                        "/"
+                        (substring-cursor path 0 start2)))))))))
+
+(define (path-extension-pos path)
+  (let ((end (string-cursor-end path)))
+    (let lp ((i end) (dot #f))
+      (if (<= i 0)
+          #f
+          (let* ((i2 (string-cursor-prev path i))
+                 (ch (string-cursor-ref path i2)))
+            (cond ((eqv? #\. ch) (and (< i end) (lp i2 (or dot i))))
+                  ((eqv? #\/ ch) #f)
+                  (dot)
+                  (else (lp i2 #f))))))))
+
+;;> Returns the rightmost extension of \var{path}, not including the
+;;> \scheme{"."}.  If there is no extension, returns \scheme{#f}.  The
+;;> extension will always be non-empty and contain no \scheme{"."}s.
+
+(define (path-extension path)
+  (let ((i (path-extension-pos path)))
+    (and i
+         (substring-cursor path i))))
+
+;;> Returns \var{path} with the extension, if any, removed,
+;;> along with the \scheme{"."}.
+
+(define (path-strip-extension path)
+  (let ((i (path-extension-pos path)))
+    (if i
+        (substring-cursor path 0 (string-cursor-prev path i))
+        path)))
+
+;;> Returns \var{path} with the extension, if any, replaced
+;;> with \var{ext}.
+
+(define (path-replace-extension path ext)
+  (string-append (path-strip-extension path) "." ext))
+
+;;> Returns \var{path} with any leading ../ removed.
+
+(define (path-strip-leading-parents path)
+  (if (string-prefix? "../" path)
+      (path-strip-leading-parents (substring path 3))
+      (if (equal? path "..") "" path)))
+
+;;> Returns \scheme{#t} iff \var{path} is an absolute path,
+;;> i.e. begins with "/".
+
+(define (path-absolute? path)
+  (and (not (string=? "" path)) (eqv? #\/ (string-ref path 0))))
+
+;;> Returns \scheme{#t} iff \var{path} is a relative path.
+
+(define (path-relative? path) (not (path-absolute? path)))
+
+;;> Returns the suffix of \var{path} relative to the directory
+;;> \var{dir}, or \scheme{#f} if \var{path} is not contained in
+;;> \var{dir}.  If the two are the same (modulo a trailing
+;;> \scheme{"/"}), then \scheme{"."} is returned.
+
+(define (path-relative-to path dir)
+  (let* ((path (path-normalize path))
+         (path-end (string-cursor-end path))
+         (dir (path-normalize dir))
+         (dir-end (string-cursor-end dir))
+         (i (string-mismatch dir path)))
+    (cond
+     ((not (<= 1 dir-end i path-end))
+      (let ((i2 (string-cursor-next path i)))
+        (and (= i path-end)
+             (= i2 dir-end)
+             (eqv? #\/ (string-cursor-ref dir i))
+             ".")))
+     ((= i path-end)
+      ".")
+     ((eqv? #\/ (string-cursor-ref path i))
+      (let ((i2 (string-cursor-next path i)))
+        (if (= i2 path-end) "." (substring-cursor path i2))))
+     ((eqv? #\/ (string-cursor-ref path (string-cursor-prev path i)))
+      (substring-cursor path i))
+     (else
+      #f))))
+
+;;> Resolve \var{path} relative to the given directory.  Returns
+;;> \var{path} unchanged if already absolute.
+
+(define (path-resolve path dir)
+  (if (path-absolute? path) path (make-path dir path)))
+
+;; This looks big and hairy, but it's mutation-free and guarantees:
+;;   (string=? s (path-normalize s))  <=>  (eq? s (path-normalize s))
+;; i.e. fast and simple for already normalized paths.
+
+;;> Returns a normalized version of path, with duplicate directory
+;;> separators removed and "/./" and "x/../" references removed.
+;;> Does not take symbolic links into account - this is meant to
+;;> be abstract and applicable to paths on remote systems and in
+;;> URIs.  Returns \var{path} itself if \var{path} is already
+;;> normalized.
+
+(define (path-normalize path)
+  (let* ((len (string-length path)) (len-1 (- len 1)))
+    (define (collect i j res)
+      (if (>= i j) res (cons (substring path i j) res)))
+    (define (finish i res)
+      (if (zero? i)
+          path
+          (string-join (reverse (collect i len res)))))
+    ;; loop invariants:
+    ;;   - res is a list such that (string-concatenate-reverse res)
+    ;;     is always the normalized string up to j
+    ;;   - the tail of the string from j onward can be concatenated to
+    ;;     the above value to get a partially normalized path referring
+    ;;     to the same location as the original path
+    (define (inside i j res)
+      (if (>= j len)
+          (finish i res)
+          (if (eqv? #\/ (string-ref path j))
+              (boundary i (+ j 1) res)
+              (inside i (+ j 1) res))))
+    (define (boundary i j res)
+      (if (>= j len)
+          (finish i res)
+          (case (string-ref path j)
+            ((#\.)
+             (cond
+              ((or (= j len-1) (eqv? #\/ (string-ref path (+ j 1))))
+               (if (= i j)
+                   (boundary (+ j 2) (+ j 2) res)
+                   (let ((s (substring path i j)))
+                     (boundary (+ j 2) (+ j 2) (cons s res)))))
+              ((eqv? #\. (string-ref path (+ j 1)))
+               (if (or (>= j (- len 2))
+                       (eqv? #\/ (string-ref path (+ j 2))))
+                   (if (>= i (- j 1))
+                       (if (null? res)
+                           (backup j "" '())
+                           (backup j (car res) (cdr res)))
+                       (backup j (substring path i j) res))
+                   (inside i (+ j 2) res)))
+              (else
+               (inside i (+ j 1) res))))
+            ((#\/) (boundary (+ j 1) (+ j 1) (collect i j res)))
+            (else (inside i (+ j 1) res)))))
+    (define (backup j s res)
+      (let ((pos (+ j 3)))
+        (cond
+         ;; case 1: we're reduced to accumulating parents of the cwd
+         ((or (string=? s "/..") (string=? s ".."))
+          (boundary pos pos (cons "/.." (cons s res))))
+         ;; case 2: the string isn't a component itself, skip it
+         ((or (string=? s "") (string=? s ".") (string=? s "/"))
+          (if (pair? res)
+              (backup j (car res) (cdr res))
+              (boundary pos pos (if (string=? s "/") '("/") '("..")))))
+         ;; case3: just take the directory of the string
+         (else
+          (let ((d (path-directory s)))
+            (cond
+             ((string=? d "/")
+              (boundary pos pos (if (null? res) '("/") res)))
+             ((string=? d ".")
+              (boundary pos pos res))
+             (else (boundary pos pos (cons "/" (cons d res))))))))))
+    ;; start with boundary if abs path, otherwise inside
+    (if (zero? len)
+        path
+        ((if (eqv? #\/ (string-ref path 0)) boundary inside) 0 1 '()))))
+
+;;> Return a new string representing the path where each of \var{args}
+;;> is a path component, separated with the directory separator.
+;;> \var{args} may include symbols and integers, in addition to
+;;> strings.
+
+(define (make-path . args)
+  (define (x->string x)
+    (cond ((string? x) x)
+          ((symbol? x) (symbol->string x))
+          ((number? x) (number->string x))
+          (else (error "not a valid path component" x))))
+  (define (trim-trailing-slash s)
+    (substring-cursor s 0 (string-skip-right s #\/)))
+  (if (null? args)
+      ""
+      (let* ((args0 (x->string (car args)))
+             (start (trim-trailing-slash args0)))
+        (let lp ((ls (cdr args))
+                 (res (if (string=? "" start) '() (list start))))
+          (cond
+           ((null? ls)
+            (if (and (null? res) (not (string=? "" args0)))
+                "/"
+                (string-join (reverse res))))
+           ((pair? (car ls))
+            (lp (append (car ls) (cdr ls)) res))
+           (else
+            (let ((x (trim-trailing-slash (x->string (car ls)))))
+              (cond
+               ((string=? x "")
+                (lp (cdr ls) res))
+               ((eqv? #\/ (string-ref x 0))
+                (lp (cdr ls) (cons x res)))
+               (else
+                (lp (cdr ls) (cons x (cons "/" res))))))))))))
diff --git a/lib/chibi/pathname.sld b/lib/chibi/pathname.sld
new file mode 100644
index 00000000..4c0e950a
--- /dev/null
+++ b/lib/chibi/pathname.sld
@@ -0,0 +1,8 @@
+
+(define-library (chibi pathname)
+  (export path-strip-directory path-directory
+          path-extension path-strip-extension path-replace-extension
+          path-absolute? path-relative? path-strip-leading-parents
+          path-relative-to path-resolve path-normalize make-path)
+  (import (chibi) (chibi string))
+  (include "pathname.scm"))
diff --git a/lib/chibi/process.scm b/lib/chibi/process.scm
new file mode 100644
index 00000000..29607b19
--- /dev/null
+++ b/lib/chibi/process.scm
@@ -0,0 +1,143 @@
+
+(cond-expand
+ (plan9
+  (define (exit . o)
+    (%exit (if (pair? o)
+               (if (string? (car o))
+                   (car o)
+                   (if (eq? #t (car o)) "" "chibi error"))
+               ""))))
+ (else
+  (define (exit . o)
+    (%exit (if (pair? o)
+               (if (integer? (car o)) (car o) (if (eq? #t (car o)) 0 1))
+               0)))))
+
+(cond-expand
+ (bsd
+  (define (process-command-line pid)
+    (let ((res (%process-command-line pid)))
+      ;; TODO: get command-line arguments
+      (if (string? res) (list res) res))))
+ (else
+  (define (process-command-line pid)
+    (call-with-current-continuation
+     (lambda (return)
+       (with-exception-handler
+        (lambda (exn) (return #f))
+        (lambda ()
+          (let ((file (string-append "/proc/" (number->string pid) "/cmdline")))
+            (call-with-input-file file
+              (lambda (in)
+                (let lp ((arg '()) (res '()))
+                  (let ((ch (read-char in)))
+                    (if (or (eof-object? ch) (eqv? (char->integer ch) 0))
+                        (let ((res (cons (list->string (reverse arg)) res))
+                              (ch2 (peek-char in)))
+                          (if (or (eof-object? ch2)
+                                  (eqv? (char->integer ch2) 0))
+                              (reverse res)
+                              (lp '() res)))
+                        (lp (cons ch arg) res))))))))))))))
+
+(define (process-running? pid . o)
+  (let ((cmdline (process-command-line pid)))
+    (and (pair? cmdline)
+         (or (null? o)
+             (not (car o))
+             (equal? (car o) (car cmdline))))))
+
+(define (execute cmd args)
+  (define (->string x)
+    (cond ((symbol? x) (symbol->string x))
+          ((number? x) (number->string x))
+          (else x)))
+  (execvp (->string cmd) (map ->string args)))
+
+(define (system cmd . args)
+  (let ((pid (fork)))
+    (cond
+     ((zero? pid)
+      (let* ((res (execute cmd (cons cmd args)))
+             (err (current-error-port)))
+        ;; we only arrive here if execute fails
+        (cond
+         ((output-port? err)
+          (display "ERROR: couldn't execute: " (current-error-port))
+          (write cmd (current-error-port))
+          (newline (current-error-port))))
+        (exit 1)))
+     (else
+      (waitpid pid 0)))))
+
+(define (call-with-process-io command proc)
+  (define (set-non-blocking! fd)
+    (cond-expand
+     (threads
+      (set-file-descriptor-status!
+       fd
+       (bitwise-ior open/non-block (get-file-descriptor-status fd))))
+     (else
+      #f)))
+  (let ((command-ls (if (string? command) (string-split command) command))
+        (in-pipe (open-pipe))
+        (out-pipe (open-pipe))
+        (err-pipe (open-pipe)))
+    (and in-pipe out-pipe err-pipe
+         (let ((pid (fork)))
+           (cond
+            ((not pid)
+             (error "couldn't fork"))
+            ((zero? pid)  ;; child
+             (close-file-descriptor (cadr in-pipe))
+             (close-file-descriptor (car out-pipe))
+             (close-file-descriptor (car err-pipe))
+             (duplicate-file-descriptor-to (car in-pipe) 0)
+             (duplicate-file-descriptor-to (cadr out-pipe) 1)
+             (duplicate-file-descriptor-to (cadr err-pipe) 2)
+             (close-file-descriptor (car in-pipe))
+             (close-file-descriptor (cadr out-pipe))
+             (close-file-descriptor (cadr err-pipe))
+             (execute (car command-ls) command-ls))
+            (else         ;; parent
+             (close-file-descriptor (car in-pipe))
+             (close-file-descriptor (cadr out-pipe))
+             (close-file-descriptor (cadr err-pipe))
+             (set-non-blocking! (cadr in-pipe))
+             (set-non-blocking! (car out-pipe))
+             (set-non-blocking! (car err-pipe))
+             (proc pid
+                   (open-output-file-descriptor (cadr in-pipe))
+                   (open-input-file-descriptor (car out-pipe))
+                   (open-input-file-descriptor (car err-pipe)))))))))
+
+(define (process->string str)
+  (call-with-process-io
+   str
+   (lambda (pid in out err)
+     (close-output-port in)
+     (let ((res (port->string out)))
+       (waitpid pid 0)
+       res))))
+
+(define (process->sexp str)
+  (call-with-input-string (process->string str) read))
+
+(define (process->output+error str)
+  (call-with-process-io
+   str
+   (lambda (pid in out err)
+     (close-output-port in)
+     (let ((out (port->string out))
+           (err (port->string err)))
+       (waitpid pid 0)
+       (list out err)))))
+
+(define (process->string-list str)
+  (call-with-process-io
+   str
+   (lambda (pid in out err)
+     (close-output-port in)
+     (let ((res (port->string-list out)))
+       (waitpid pid 0)
+       res))))
diff --git a/lib/chibi/process.sld b/lib/chibi/process.sld
new file mode 100644
index 00000000..9508d74a
--- /dev/null
+++ b/lib/chibi/process.sld
@@ -0,0 +1,23 @@
+
+(define-library (chibi process)
+  (export exit sleep alarm %fork fork kill execute waitpid system
+          process-command-line  process-running?
+          set-signal-action! make-signal-set
+          signal-set? signal-set-contains?
+          signal-set-fill! signal-set-add! signal-set-delete!
+          current-signal-mask current-process-id parent-process-id
+          signal-mask-block! signal-mask-unblock! signal-mask-set!
+          signal/hang-up    signal/interrupt   signal/quit
+          signal/illegal    signal/abort       signal/fpe
+          signal/kill       signal/segv        signal/pipe
+          signal/alarm      signal/term        signal/user1
+          signal/user2      signal/child       signal/continue
+          signal/stop       signal/tty-stop    signal/tty-input
+          signal/tty-output wait/no-hang
+          call-with-process-io
+          process->string process->sexp
+          process->string-list process->output+error)
+  (import (chibi) (chibi io) (chibi string) (chibi filesystem))
+  (cond-expand (threads (import (srfi 18) (srfi 33))) (else #f))
+  (include-shared "process")
+  (include "process.scm"))
diff --git a/lib/chibi/process.stub b/lib/chibi/process.stub
new file mode 100644
index 00000000..fbfc1cf2
--- /dev/null
+++ b/lib/chibi/process.stub
@@ -0,0 +1,146 @@
+
+;;> An interface to spawning processes and sending and
+;;> receiving signals between processes.
+
+(c-system-include "sys/types.h")
+(c-system-include "sys/wait.h")
+(c-system-include "signal.h")
+(c-system-include "unistd.h")
+
+;;> The siginfo_t struct is used to return info about the status,
+;;> process and user info of a called signal handler.
+
+(define-c-type siginfo_t
+  predicate: signal-info?
+  (int      si_signo    signal-number)
+  (int      si_errno    signal-error-number)
+  (int      si_code     signal-code)
+  (pid_t    si_pid      signal-pid)
+  (uid_t    si_uid      signal-uid)
+  (int      si_status   signal-status)
+  ;;(clock_t  si_utime    signal-user-time)
+  ;;(clock_t  si_stime    signal-system-time)
+  )
+
+(define-c-const int (signal/hang-up "SIGHUP"))
+(define-c-const int (signal/interrupt "SIGINT"))
+(define-c-const int (signal/quit "SIGQUIT"))
+(define-c-const int (signal/illegal "SIGILL"))
+(define-c-const int (signal/abort "SIGABRT"))
+(define-c-const int (signal/fpe "SIGFPE"))
+(define-c-const int (signal/kill "SIGKILL"))
+(define-c-const int (signal/segv "SIGSEGV"))
+(define-c-const int (signal/pipe "SIGPIPE"))
+(define-c-const int (signal/alarm "SIGALRM"))
+(define-c-const int (signal/term "SIGTERM"))
+(define-c-const int (signal/user1"SIGUSR1"))
+(define-c-const int (signal/user2 "SIGUSR2"))
+(define-c-const int (signal/child "SIGCHLD"))
+(define-c-const int (signal/continue "SIGCONT"))
+(define-c-const int (signal/stop "SIGSTOP"))
+(define-c-const int (signal/tty-stop "SIGTSTP"))
+(define-c-const int (signal/tty-input "SIGTTIN"))
+(define-c-const int (signal/tty-output "SIGTTOU"))
+
+(c-include-verbatim "signal.c")
+
+;;> \procedure{(set-signal-action! signal handler)}
+
+;;> Sets the signal handler for \var{signal} to \var{handler}
+;;> and returns the old handler.  \var{handler} should be a procedure
+;;> of one argument, the signal number, the value \scheme{#t} for
+;;> the default signal handler, or \scheme{#f} for no handler.
+
+;;> Signal handlers are queued run in a dedicated thread after the
+;;> system handler has returned.
+
+(define-c sexp (set-signal-action! "sexp_set_signal_action")
+  ((value ctx sexp) (value self sexp) sexp sexp))
+
+;;> The sigset_t struct represents a set of signals for masking.
+
+(define-c-type sigset_t
+  predicate: signal-set?)
+
+(define-c errno (make-signal-set "sigemptyset") ((pointer result sigset_t)))
+(define-c errno (signal-set-fill! "sigfillset") ((pointer sigset_t)))
+(define-c errno (signal-set-add! "sigaddset") ((pointer sigset_t) int))
+(define-c errno (signal-set-delete! "sigdelset") ((pointer sigset_t) int))
+(define-c boolean (signal-set-contains? "sigismember") ((pointer sigset_t) int))
+
+(define-c errno (signal-mask-block! "sigprocmask")
+  ((value SIG_BLOCK int) (pointer sigset_t) (pointer value NULL sigset_t)))
+(define-c errno (signal-mask-unblock! "sigprocmask")
+  ((value SIG_UNBLOCK int) (pointer sigset_t) (pointer value NULL sigset_t)))
+(define-c errno (signal-mask-set! "sigprocmask")
+  ((value SIG_SETMASK int) (pointer sigset_t) (pointer value NULL sigset_t)))
+(define-c errno (current-signal-mask "sigprocmask")
+  ((value SIG_BLOCK int) (pointer value NULL sigset_t) (pointer result sigset_t)))
+
+;;> Send a \var{signal/alarm} signal to the current process
+;;> after \var{unsigned-int} seconds have elapsed.
+
+(define-c unsigned-int alarm (unsigned-int))
+
+;;> Suspend the current process for \var{unsigned-int} seconds.
+;;> See \hyperlink["http://srfi.schemers.org/srfi-18/srfi-18.html"]{SRFI-18}
+;;> \scheme{thread-sleep!} for a light-weight sleep for only the
+;;> current thread.
+
+(define-c unsigned-int sleep (unsigned-int))
+
+;;> Fork the current process.  Returns \rawcode{0} for the newly
+;;> created process, and the process id of the new process for the
+;;> parent.  If multiple threads are active, they are forked as well.
+;;> Use \scheme{fork} to also kill all other threads.
+
+(define-c pid_t (%fork fork) ())
+
+(define-c pid_t (fork sexp_fork_and_kill_threads) ((value ctx sexp)))
+
+(define-c-const int (wait/no-hang "WNOHANG"))
+
+;;(define-c pid_t wait ((result int)))
+
+;;> \procedure{(waitpid pid options)}
+
+;;> Wait on the process \var{pid}, or any child process if \var{pid}
+;;> is \rawcode{-1}.  \var{options} should be 0, or \var{wait/no-hang}
+;;> to return immediately if no processes have reported status.  Returns
+;;> a list whose first element is the actual \var{pid} reporting, and
+;;> the second element is the integer status.
+
+(define-c pid_t waitpid (int (result int) int))
+
+;;> Send a signal to the given process.
+
+(define-c errno kill (int int))
+
+;;(define-c errno raise (int))
+
+;;> Exits the current process immediately.  Finalizers are not run.
+
+(cond-expand
+ (plan9 (define-c void (%exit exits) (string)))
+ (else (define-c void (%exit exit) (int))))
+
+;;> Replace the current process with the given command.  Finalizers
+;;> are not run.
+
+(define-c int (execvp execvp) (string (array string)))
+
+;;> Returns the current process id.
+
+(define-c pid_t (current-process-id getpid) ())
+
+;;> Returns the parent process id.
+
+(define-c pid_t (parent-process-id getppid) ())
+
+(cond-expand
+ (bsd
+  (define-c sexp (%process-command-line sexp_pid_cmdline)
+    ((value ctx sexp) int)))
+ (else #f))
+
+(c-init "sexp_init_signals(ctx, env);")
diff --git a/lib/chibi/quoted-printable.scm b/lib/chibi/quoted-printable.scm
new file mode 100644
index 00000000..d28b28e3
--- /dev/null
+++ b/lib/chibi/quoted-printable.scm
@@ -0,0 +1,178 @@
+;; quoted-printable.scm -- RFC2045 implementation
+;; Copyright (c) 2005-2014 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> RFC 2045 quoted printable encoding and decoding utilities.  This
+;;> API is backwards compatible with the Gauche library
+;;> rfc.quoted-printable.
+
+;;> \schemeblock{
+;;> (define (mime-encode-header header value charset)
+;;>   (let ((prefix (string-append header ": "))
+;;>         (str (ces-convert value "UTF8" charset)))
+;;>     (string-append
+;;>      prefix
+;;>      (quoted-printable-encode-header charset str (string-length prefix)))))
+;;> }
+
+(define *default-max-col* 76)
+
+;; Allow for RFC1522 quoting for headers by always escaping ? and _
+(define (qp-encode bv start-col max-col separator)
+  (define (hex i) (+ i (if (<= i 9) 48 55)))
+  (let ((end (bytevector-length bv))
+        (buf (make-bytevector max-col))
+        (out (open-output-bytevector)))
+    (let lp ((i 0) (col start-col))
+      (cond
+       ((= i end)
+        (write-bytevector (bytevector-copy buf 0 col) out)
+        (get-output-bytevector out))
+       ((>= col (- max-col 3))
+        (write-bytevector (bytevector-copy buf 0 col) out)
+        (lp i 0))
+       (else
+        (let ((c (bytevector-u8-ref bv i)))
+          (cond
+           ((and (<= 33 c 126) (not (memq c '(61 63 95))))
+            (bytevector-u8-set! buf col c)
+            (lp (+ i 1) (+ col 1)))
+           (else
+            (bytevector-u8-set! buf col (char->integer #\=))
+            (bytevector-u8-set! buf (+ col 1) (hex (arithmetic-shift c -4)))
+            (bytevector-u8-set! buf (+ col 2) (hex (bitwise-and c #b1111)))
+            (lp (+ i 1) (+ col 3))))))))))
+
+;;> Return a quoted-printable encoded representation of the input
+;;> according to the official standard as described in RFC2045.
+;;>
+;;> ? and _ are always encoded for compatibility with RFC1522
+;;> encoding, and soft newlines are inserted as necessary to keep each
+;;> lines length less than \var{max-col} (default 76).  The starting
+;;> column may be overridden with \var{start-col} (default 0).
+
+(define (quoted-printable-encode-string src . o)
+  (if (string? src)
+      (utf8->string
+       (apply quoted-printable-encode-bytevector
+              (string->utf8 src)
+              o))
+      (apply quoted-printable-encode-bytevector src o)))
+
+(define (quoted-printable-encode-bytevector . o)
+  (let* ((src (if (pair? o) (car o) (current-input-port)))
+         (o (if (pair? o) (cdr o) '()))
+         (start-col (if (pair? o) (car o) 0))
+         (o (if (pair? o) (cdr o) '()))
+         (max-col (if (pair? o) (car o) *default-max-col*))
+         (o (if (pair? o) (cdr o) '()))
+         (sep (if (pair? o) (car o) (string->utf8 "=\r\n"))))
+    (qp-encode (if (bytevector? src) src (read-bytevector 1000000000 src))
+               start-col max-col sep)))
+
+;;> Variation of the above to read and write to ports.
+
+(define (quoted-printable-encode . o)
+  (write-string (apply quoted-printable-encode-string o)))
+
+;;> Return a quoted-printable encoded representation of string as
+;;> above, wrapped in =?ENC?Q?...?= as per RFC1522, split across
+;;> multiple MIME-header lines as needed to keep each lines length
+;;> less than \var{max-col}.  The string is encoded as is, and the
+;;> encoding \var{enc} is just used for the prefix, i.e. you are
+;;> responsible for ensuring \var{str} is already encoded according to
+;;> \var{enc}.
+
+(define (quoted-printable-encode-header encoding . o)
+  (let* ((src (if (pair? o) (car o) (current-input-port)))
+         (o (if (pair? o) (cdr o) '()))
+         (start-col (if (pair? o) (car o) 0))
+         (o (if (pair? o) (cdr o) '()))
+         (max-col (if (pair? o) (car o) *default-max-col*))
+         (o (if (pair? o) (cdr o) '()))
+         (nl (if (pair? o) (car o) "\r\n")))
+    (let* ((prefix (string-append "=?" encoding "?Q?"))
+           (prefix-length (+ 2 (string-length prefix)))
+           (separator (string->utf8 (string-append "?=" nl "\t" prefix)))
+           (effective-max-col (- max-col prefix-length)))
+      (bytevector-append
+       (string->utf8 prefix)
+       (qp-encode (if (string? src) src (read-string #f src))
+                  start-col effective-max-col separator)
+       (string->utf8 "?=")))))
+
+;;> Return a quoted-printable decoded representation of \var{str}.  If
+;;> \var{mime-header?} is specified and true, _ will be decoded as as
+;;> space in accordance with RFC1522.  No errors will be raised on
+;;> invalid input.
+
+(define (quoted-printable-decode-string src . o)
+  (if (string? src)
+      (utf8->string
+       (apply quoted-printable-decode-bytevector
+              (string->utf8 src)
+              o))
+      (apply quoted-printable-decode-bytevector src o)))
+
+(define (quoted-printable-decode-bytevector  . o)
+  (define (hex? c)
+    (or (char<=? #\0 (integer->char c) #\9)
+        (char<=? #\A (integer->char c) #\F)))
+  (define (unhex1 i)
+    (if (>= i 65) (- i 55) (- i 48)))
+  (define (unhex c1 c2)
+    (+ (arithmetic-shift (unhex1 c1) 4) (unhex1 c2)))
+  (let ((src (if (pair? o) (car o) (current-input-port)))
+        (mime-header? (and (pair? o) (pair? (cdr o)) (car (cdr o)))))
+    (let* ((bv (if (bytevector? src) src (read-bytevector 1000000000 src)))
+           (end (bytevector-length bv))
+           (out (open-output-bytevector)))
+      (let lp ((i 0))
+        (cond
+         ((>= i end)
+          (get-output-bytevector out))
+         (else
+          (let ((c (bytevector-u8-ref bv i)))
+            (case c
+              ((61)                    ; = escapes
+               (cond
+                ((< (+ i 2) end)
+                 (let ((c2 (bytevector-u8-ref bv (+ i 1))))
+                   (cond
+                    ((eq? c2 10) (lp (+ i 2)))
+                    ((eq? c2 13)
+                     (lp (if (eq? 10 (bytevector-u8-ref bv (+ i 2)))
+                             (+ i 3)
+                             (+ i 2))))
+                    ((hex? c2)
+                     (let ((c3 (bytevector-u8-ref bv (+ i 2))))
+                       (if (hex? c3) (write-u8 (unhex c2 c3) out))
+                       (lp (+ i 3))))
+                    (else (lp (+ i 3))))))))
+              ((95)                    ; maybe translate _ to space
+               (write-u8 (if mime-header? 32 c) out)
+               (lp (+ i 1)))
+              ((32 9)          ; strip trailing whitespace
+               (let lp2 ((j (+ i 1)))
+                 (cond
+                  ((not (= j end))
+                   (case (bytevector-u8-ref bv j)
+                     ((32 9) (lp2 (+ j 1)))
+                     ((10)
+                      (lp (+ j 1)))
+                     ((13)
+                      (let ((k (+ j 1)))
+                        (lp (if (and (< k end)
+                                     (eq? 10 (bytevector-u8-ref bv k)))
+                                (+ k 1) k))))
+                     (else
+                      (write-bytevector (bytevector-copy bv i j) out)
+                      (lp j)))))))
+              (else                     ; a literal char
+               (write-u8 c out)
+               (lp (+ i 1)))))))))))
+
+;;> Variation of the above to read and write to ports.
+
+(define (quoted-printable-decode . o)
+  (write-string (apply quoted-printable-decode-string o)))
diff --git a/lib/chibi/quoted-printable.sld b/lib/chibi/quoted-printable.sld
new file mode 100644
index 00000000..23a58168
--- /dev/null
+++ b/lib/chibi/quoted-printable.sld
@@ -0,0 +1,9 @@
+
+(define-library (chibi quoted-printable)
+  (export quoted-printable-encode quoted-printable-encode-string
+          quoted-printable-encode-bytevector
+          quoted-printable-encode-header
+          quoted-printable-decode quoted-printable-decode-string
+          quoted-printable-decode-bytevector)
+  (import (scheme base) (srfi 33) (chibi io))
+  (include "quoted-printable.scm"))
diff --git a/lib/chibi/regexp.scm b/lib/chibi/regexp.scm
new file mode 100644
index 00000000..3ea8b84d
--- /dev/null
+++ b/lib/chibi/regexp.scm
@@ -0,0 +1,1009 @@
+;; regexp.scm -- simple non-bactracking NFA implementation
+;; Copyright (c) 2013 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;; An rx represents a start state and meta-info such as the number
+;;; and names of submatches.
+(define-record-type Rx
+  (make-rx start-state num-matches num-save-indexes match-rules match-names sre)
+  regexp?
+  (start-state rx-start-state rx-start-state-set!)
+  (num-matches rx-num-matches rx-num-matches-set!)
+  (num-save-indexes rx-num-save-indexes rx-num-save-indexes-set!)
+  (match-rules rx-rules rx-rules-set!)
+  (match-names rx-names rx-names-set!)
+  (sre regexp->sre))
+
+;; Syntactic sugar.
+(define-syntax rx
+  (syntax-rules ()
+    ((rx sre ...)
+     (regexp `(: sre ...)))))
+
+;;; A state is a single nfa state with transition rules.
+(define-record-type State
+  (%make-state accept? chars match match-rule next1 next2)
+  state?
+  ;; A boolean indicating if this is an accepting state.
+  (accept? state-accept? state-accept?-set!)
+  ;; A char or char-set indicating when we can transition.
+  ;; Alternately, #f indicates an epsilon transition, while a
+  ;; procedure of the form (lambda (ch i matches) ...) is a predicate
+  ;; which should return #t if the char matches.
+  (chars state-chars state-chars-set!)
+  ;; A single integer indicating the match position to record.
+  (match state-match state-match-set!)
+  ;; The rule for merging ambiguous matches.  Can be any of: left,
+  ;; right, (list i j).  Posix semantics are equivalent to using left
+  ;; for the beginning of a submatch and right for the end.  List is
+  ;; used to capture a list of submatch data in the current match.
+  (match-rule state-match-rule state-match-rule-set!)
+  ;; The destination if the char match succeeds.
+  (next1 state-next1 state-next1-set!)
+  ;; An optional additional transition used for forking to two states.
+  (next2 state-next2 state-next2-set!))
+
+(define (make-state accept? chars match match-rule next1 next2)
+  (if (and next1 (not (state? next1)))
+      (error "expected a state" next1))
+  (if (and next2 (not (state? next2)))
+      (error "expected a state" next2))
+  (%make-state accept? chars match match-rule next1 next2))
+
+(define ~none 0)
+(define ~ci? 1)
+(define ~ascii? 2)
+(define ~nocapture? 4)
+
+(define (flag-set? flags i) (= i (bitwise-and flags i)))
+(define (flag-join a b) (if b (bitwise-ior a b) a))
+(define (flag-clear a b) (bitwise-and a (bitwise-not b)))
+
+(define (char-set-ci cset)
+  (let ((res (char-set)))
+    (char-set-for-each
+     (lambda (ch)
+       (char-set-adjoin! res (char-upcase ch))
+       (char-set-adjoin! res (char-downcase ch)))
+     cset)
+    res))
+
+(define (make-char-state ch flags next)
+  (if (flag-set? flags ~ci?)
+      (let ((cset (cond ((char? ch) (char-set-ci (char-set ch)))
+                        ((char-set? ch) (char-set-ci ch))
+                        (else ch))))
+        (make-state #f cset #f #f next #f))
+      (make-state #f ch #f #f next #f)))
+(define (make-fork-state next1 next2)
+  (make-state #f #f #f #f next1 next2))
+(define (make-epsilon-state next)
+  (make-fork-state next #f))
+(define (make-accept-state)
+  (make-state #t #f #f #f #f #f))
+
+;; A record holding the current match data - essentially a wrapper
+;; around a vector, plus a reference to the RX for meta-info.
+(define-record-type Regexp-Match
+  (%make-regexp-match matches rx string)
+  regexp-match?
+  (matches regexp-match-matches regexp-match-matches-set!)
+  (rx regexp-match-rx)
+  (string regexp-match-string))
+
+(define (regexp-match-rules md)
+  (rx-rules (regexp-match-rx md)))
+(define (regexp-match-names md)
+  (rx-names (regexp-match-rx md)))
+(define (make-regexp-match len rx str)
+  (%make-regexp-match (make-vector len #f) rx str))
+(define (make-regexp-match-for-rx rx str)
+  (make-regexp-match (rx-num-save-indexes rx) rx str))
+(define (regexp-match-count md)
+  (- (quotient (vector-length (regexp-match-matches md)) 2) 1))
+
+(define (regexp-match-name-offset md name)
+  (let lp ((ls (regexp-match-names md)) (first #f))
+    (cond
+     ((null? ls) (or first (error "unknown match name" md name)))
+     ((eq? name (caar ls))
+      (if (regexp-match-submatch-start+end md (cdar ls))
+          (cdar ls)
+          (lp (cdr ls) (or first (cdar ls)))))
+     (else (lp (cdr ls) first)))))
+
+(define (regexp-match-ref md n)
+  (vector-ref (regexp-match-matches md)
+              (if (integer? n)
+                  n
+                  (regexp-match-name-offset md n))))
+
+(define (regexp-match-set! md n val)
+  (vector-set! (regexp-match-matches md) n val))
+
+(define (copy-regexp-match md)
+  (let* ((src (regexp-match-matches md))
+         (len (vector-length src))
+         (dst (make-vector len #f)))
+    (do ((i 0 (+ i 1)))
+        ((= i len)
+         (%make-regexp-match dst (regexp-match-rx md) (regexp-match-string md)))
+      (vector-set! dst i (vector-ref src i)))))
+
+;;> Returns the matching result for the given named or indexed
+;;> submatch \var{n}, possibly as a list for a submatch-list, or
+;;> \scheme{#f} if not matched.
+
+(define (regexp-match-submatch/list md n)
+  (let ((n (if (integer? n) n (regexp-match-name-offset md n))))
+    (cond
+     ((>= n (vector-length (regexp-match-rules md)))
+      #f)
+     (else
+      (let ((rule (vector-ref (regexp-match-rules md) n)))
+        (cond
+         ((pair? rule)
+          (let ((start (regexp-match-ref md (car rule)))
+                (end (regexp-match-ref md (cdr rule)))
+                (str (regexp-match-string md)))
+            (and start end (substring-cursor str start end))))
+         (else
+          (let ((res (regexp-match-ref md rule)))
+            (if (pair? res)
+                (reverse res)
+                res)))))))))
+
+;;> Returns the matching substring for the given named or indexed
+;;> submatch \var{n}, or \scheme{#f} if not matched.
+
+(define (regexp-match-submatch md n)
+  (let ((res (regexp-match-submatch/list md n)))
+    (if (pair? res) (car res) res)))
+
+(define (regexp-match-submatch-start+end md n)
+  (let ((n (if (string-cursor? n) n (regexp-match-name-offset md n))))
+    (and (< n (vector-length (regexp-match-rules md)))
+         (let ((rule (vector-ref (regexp-match-rules md) n)))
+           (if (pair? rule)
+               (let ((start (regexp-match-ref md (car rule)))
+                     (end (regexp-match-ref md (cdr rule)))
+                     (str (regexp-match-string md)))
+                 (and start end
+                      (cons (string-offset->index str start)
+                            (string-offset->index str end))))
+               #f)))))
+
+;;> Returns the start index for the given named or indexed submatch
+;;> \var{n}, or \scheme{#f} if not matched.
+
+(define (regexp-match-submatch-start md n)
+  (cond ((regexp-match-submatch-start+end md n) => car) (else #f)))
+
+;;> Returns the end index for the given named or indexed submatch
+;;> \var{n}, or \scheme{#f} if not matched.
+
+(define (regexp-match-submatch-end md n)
+  (cond ((regexp-match-submatch-start+end md n) => cdr) (else #f)))
+
+(define (regexp-match-convert recurse? md str)
+  (cond
+   ((vector? md)
+    (let lp ((i 0) (res '()))
+      (cond
+       ((>= i (vector-length md))
+        (reverse res))
+       ((string-cursor? (vector-ref md i))
+        (lp (+ i 2)
+            (cons (substring-cursor str
+                                    (vector-ref md i)
+                                    (vector-ref md (+ i 1)))
+                  res)))
+       (else
+        (lp (+ i 1)
+            (cons (regexp-match-convert recurse? (vector-ref md i) str)
+                  res))))))
+   ((list? md)
+    (if recurse?
+        (map (lambda (x) (regexp-match-convert recurse? x str)) (reverse md))
+        (regexp-match-convert recurse? (car md) str)))
+   ((and (pair? md) (string-cursor? (car md)) (string-cursor? (cdr md)))
+    (substring-cursor str (car md) (cdr md)))
+   ((regexp-match? md)
+    (regexp-match-convert
+     recurse? (regexp-match-matches md) (regexp-match-string md)))
+   (else
+    md)))
+
+;;> Convert an regexp-match result to a list of submatches, beginning
+;;> with the full match, using \scheme{#f} for unmatched submatches.
+
+(define (regexp-match->list md)
+  (regexp-match-convert #f md #f))
+
+;;> Convert an regexp-match result to a forest of submatches, beginning
+;;> with the full match, using \scheme{#f} for unmatched submatches.
+
+(define (regexp-match->sexp md)
+  (regexp-match-convert #t md #f))
+
+;; Collect results from a list match.
+(define (match-collect md spec)
+  (define (match-extract md n)
+    (let* ((vec (regexp-match-matches md))
+           (rules (regexp-match-rules md))
+           (n-rule (vector-ref rules n))
+           (rule (vector-ref rules n-rule)))
+      (if (pair? rule)
+          (let ((start (regexp-match-ref md (car rule)))
+                (end (regexp-match-ref md (cdr rule))))
+            (and start end (cons start end)))
+          (regexp-match-ref md rule))))
+  (let ((end (cadr spec))
+        (vec (regexp-match-matches md)))
+    (let lp ((i (+ 1 (car spec)))
+             (ls '()))
+      (if (>= i end)
+          (reverse ls)
+          (lp (+ i 1) (cons (match-extract md i) ls))))))
+
+;; A searcher represents a single rx state and match information.
+(define-record-type Searcher
+  (make-searcher state matches)
+  searcher?
+  (state searcher-state searcher-state-set!)
+  (matches searcher-matches searcher-matches-set!))
+
+;; Merge two regexp-matches, preferring the leftmost-longest of their
+;; matches.
+(define (regexp-match>=? m1 m2)
+  (let ((end (- (vector-length (regexp-match-matches m1)) 1)))
+    (let lp ((i 0))
+      (cond
+       ((>= i end)
+        #t)
+       ((and (eqv? (regexp-match-ref m1 i)
+                   (regexp-match-ref m2 i))
+             (eqv? (regexp-match-ref m1 (+ i 1))
+                   (regexp-match-ref m2 (+ i 1))))
+        (lp (+ i 2)))
+       ((and (string-cursor? (regexp-match-ref m2 i))
+             (or (not (string-cursor? (regexp-match-ref m1 i)))
+                 (string-cursor<? (regexp-match-ref m2 i)
+                                  (regexp-match-ref m1 i))
+                 (and
+                  (string-cursor=? (regexp-match-ref m2 i)
+                                   (regexp-match-ref m1 i))
+                  (or (not (string-cursor? (regexp-match-ref m2 (+ i 1))))
+                      (and (string-cursor? (regexp-match-ref m1 (+ i 1)))
+                           (string-cursor>? (regexp-match-ref m2 (+ i 1))
+                                            (regexp-match-ref m1 (+ i 1))))))))
+        #f)
+       (else
+        #t)))))
+
+(define (regexp-match-max m1 m2)
+  (if (regexp-match>=? m1 m2) m1 m2))
+
+;; Merge match data from sr2 into sr1, preferring the leftmost-longest
+;; match in the event of a conflict.
+(define (searcher-merge! sr1 sr2)
+  (let ((m (regexp-match-max (searcher-matches sr1) (searcher-matches sr2))))
+    (searcher-matches-set! sr1 m)))
+
+(define (searcher-max sr1 sr2)
+  (if (or (not (searcher? sr2))
+          (regexp-match>=? (searcher-matches sr1) (searcher-matches sr2)))
+      sr1
+      sr2))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; A posse is a group of searchers.
+
+(define (make-posse . o)
+  (make-hash-table eq?))
+
+(define posse? hash-table?)
+(define (posse-empty? posse) (zero? (hash-table-size posse)))
+
+(define (posse-ref posse sr)
+  (hash-table-ref/default posse (searcher-state sr) #f))
+(define (posse-add! posse sr)
+  (hash-table-set! posse (searcher-state sr) sr))
+(define (posse-clear! posse)
+  (hash-table-walk posse (lambda (key val) (hash-table-delete! posse key))))
+(define (posse-for-each proc posse)
+  (hash-table-walk posse (lambda (key val) (proc val))))
+
+(define (posse->list posse)
+  (hash-table-values posse))
+(define (list->posse ls)
+  (let ((searchers (make-posse)))
+    (for-each (lambda (sr) (posse-add! searchers sr)) ls)
+    searchers))
+(define (posse . args)
+  (list->posse args))
+
+(define (make-start-searcher rx str)
+  (make-searcher (rx-start-state rx) (make-regexp-match-for-rx rx str)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Execution
+
+;; A transition which doesn't advance the index.
+
+(define (epsilon-state? st)
+  (or (not (state-chars st))
+      (procedure? (state-chars st))))
+
+;; Match the state against a char and index.
+
+(define (state-matches? st str i ch start end matches)
+  (let ((matcher (state-chars st)))
+    (cond
+     ((char? matcher)
+      (eqv? matcher ch))
+     ((char-set? matcher)
+      (char-set-contains? matcher ch))
+     ((pair? matcher)
+      (and (char<=? (car matcher) ch) (char<=? ch (cdr matcher))))
+     ((procedure? matcher)
+      (matcher str i ch start end matches))
+     ((not matcher))
+     (else
+      (error "unknown state matcher" (state-chars st))))))
+
+;; Advance epsilons together - if the State is newly added to the
+;; group and is an epsilon state, recursively add the transition.
+
+(define (posse-advance! new seen accept sr str i start end)
+  (let advance! ((sr sr))
+    (let ((st (searcher-state sr)))
+      ;; Update match data.
+      (cond
+       ((state-match st)
+        (let ((index (state-match st))
+              (matches (searcher-matches sr)))
+          (cond
+           ((pair? index)
+            ;; Submatch list, accumulate and push.
+            (let* ((prev (regexp-match-ref matches (car index)))
+                   (new (cons (match-collect matches (cdr index))
+                              (if (pair? prev) prev '()))))
+              (regexp-match-set! matches (car index) new)))
+           (else
+            (regexp-match-set! matches index i))))))
+      ;; Follow transitions.
+      (cond
+       ((state-accept? st)
+        (set-cdr! accept (searcher-max sr (cdr accept))))
+       ((posse-ref seen sr)
+        => (lambda (sr-prev) (searcher-merge! sr-prev sr)))
+       ((epsilon-state? st)
+        (let ((ch (and (string-cursor<? i end) (string-cursor-ref str i))))
+          ;; Epsilon transition.  If there is a procedure matcher,
+          ;; it's a guarded epsilon and needs to be checked.
+          (cond
+           ((state-matches? st str i ch start end (searcher-matches sr))
+            (posse-add! seen sr)
+            (let ((next1 (state-next1 st))
+                  (next2 (state-next2 st)))
+              (cond
+               (next1
+                (searcher-state-set! sr next1)
+                (advance! sr))) 
+              (cond
+               (next2
+                (let ((sr2 (make-searcher
+                            next2
+                            (copy-regexp-match (searcher-matches sr)))))
+                  (advance! sr2)))))))))
+       ;; Non-special, non-epsilon searcher, add to posse.
+       ((posse-ref new sr)
+        ;; Merge regexp-match for existing searcher.
+        => (lambda (sr-prev) (searcher-merge! sr-prev sr)))
+       (else
+        ;; Add new searcher.
+        (posse-add! new sr))))))
+
+;; Run so long as there is more to match.
+
+(define (regexp-run-offsets search? rx str start end)
+  (let ((rx (regexp rx))
+        (epsilons (posse))
+        (accept (list #f)))
+    (let lp ((i start)
+             (searchers1 (posse))
+             (searchers2 (posse)))
+      ;; Advance initial epsilons once from the first index, or every
+      ;; time when searching.
+      (cond
+       ((or search? (string-cursor=? i start))
+        (posse-advance! searchers1 epsilons accept (make-start-searcher rx str)
+                        str i start end)
+        (posse-clear! epsilons))) 
+      (cond
+       ((or (string-cursor>=? i end)
+            (and (or (not search?) (searcher? (cdr accept)))
+                 (posse-empty? searchers1)))
+        ;; Terminate when the string is done or there are no more
+        ;; searchers.  If we terminate prematurely and are not
+        ;; searching, return false.
+        (and (searcher? (cdr accept))
+             (let ((matches (searcher-matches (cdr accept))))
+               (and (or search? (>= (regexp-match-ref matches 1) end))
+                    (searcher-matches (cdr accept))))))
+       (else
+        ;; Otherwise advance normally.
+        (let ((ch (string-cursor-ref str i))
+              (i2 (string-cursor-next str i)))
+          (posse-for-each  ;; NOTE: non-deterministic from hash order
+           (lambda (sr)
+             (cond
+              ((state-matches? (searcher-state sr) str i ch
+                               start end (searcher-matches sr))
+               (searcher-state-set! sr (state-next1 (searcher-state sr)))
+               ;; Epsilons are considered at the next position.
+               (posse-advance! searchers2 epsilons accept sr str i2 start end)
+               (posse-clear! epsilons))))
+           searchers1)
+          (posse-clear! searchers1)
+          (lp i2 searchers2 searchers1)))))))
+
+;; Wrapper to determine start and end offsets.
+
+(define (regexp-run search? rx str . o)
+  (let ((start (string-start-arg str o))
+        (end (string-end-arg str (if (pair? o) (cdr o) o))))
+    (regexp-run-offsets search? rx str start end)))
+
+;;> Match the given regexp or SRE against the entire string and return
+;;> the match data on success.  Returns \scheme{#f} on failure.
+
+(define (regexp-matches rx str . o)
+  (apply regexp-run #f rx str o))
+
+;;> Match the given regexp or SRE against the entire string and return
+;;> the \scheme{#t} on success.  Returns \scheme{#f} on failure.
+
+(define (regexp-matches? rx str . o)
+  (and (apply regexp-matches rx str o) #t))
+
+;;> Search for the given regexp or SRE within string and return
+;;> the match data on success.  Returns \scheme{#f} on failure.
+
+(define (regexp-search rx str . o)
+  (apply regexp-run #t rx str o))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Compiling
+
+(define (parse-flags ls)
+  (define (symbol->flag s)
+    (case s ((i ci case-insensitive) ~ci?) (else ~none)))
+  (let lp ((ls ls) (res ~none))
+    (if (not (pair? ls))
+        res
+        (lp (cdr ls) (flag-join res (symbol->flag (car ls)))))))
+
+(define char-set:nonl
+  (char-set-difference char-set:full (char-set #\newline)))
+(define char-set:control (ucs-range->char-set 0 32))
+(define char-set:word-constituent
+  (char-set-union char-set:letter char-set:digit (char-set #\_)))
+(define %char-set:word-constituent
+  (char-set-union %char-set:letter %char-set:digit (char-set #\_)))
+(define (char-word-constituent? ch)
+  (char-set-contains? char-set:word-constituent ch))
+(define get-char-set:cased
+  (let ((char-set:cased #f))
+    (lambda ()
+      (if (not char-set:cased)
+          (set! char-set:cased
+                (char-set-union char-set:upper-case
+                                char-set:lower-case
+                                char-set:title-case)))
+      char-set:cased)))
+
+(define (match/bos str i ch start end matches)
+  (string-cursor=? i start))
+(define (match/eos str i ch start end matches)
+  (string-cursor>=? i end))
+(define (match/bol str i ch start end matches)
+  (or (string-cursor=? i start)
+      (eqv? #\newline (string-cursor-ref str (string-cursor-prev str i)))))
+(define (match/eol str i ch start end matches)
+  (or (string-cursor>=? i end)
+      (eqv? #\newline (string-cursor-ref str i))))
+(define (match/bow str i ch start end matches)
+  (and (string-cursor<? i end)
+       (or (string-cursor=? i start)
+           (not (char-word-constituent?
+                 (string-cursor-ref str (string-cursor-prev str i)))))
+       (char-word-constituent? ch)))
+(define (match/eow str i ch start end matches)
+  (and (or (string-cursor>=? i end)
+           (not (char-word-constituent? ch)))
+       (string-cursor>? i start)
+       (char-word-constituent?
+        (string-cursor-ref str (string-cursor-prev str i)))))
+(define (match/nwb str i ch start end matches)
+  (and (not (match/bow str i ch start end matches))
+       (not (match/eow str i ch start end matches))))
+(define (match/bog str i ch start end matches)
+  (and (string-cursor<? i end)
+       (or (string-cursor=? i start)
+           (match/eog str (string-cursor-prev str i) ch start end matches))))
+(define (match/eog str i ch start end matches)
+  (and (string-cursor>? i start)
+       (or (string-cursor>=? i end)
+           (let ((m (regexp-search re:grapheme str
+                                   (string-offset->index str i)
+                                   (string-offset->index str end))))
+             (and m (string-cursor<=? (regexp-match-submatch-end m 0) i))))))
+
+(define (lookup-char-set name flags)
+  (cond
+   ((flag-set? flags ~ascii?)
+    (case name
+      ((any) char-set:full)
+      ((nonl) char-set:nonl)
+      ((lower-case lower)
+       (if (flag-set? flags ~ci?) %char-set:letter %char-set:lower-case))
+      ((upper-case upper)
+       (if (flag-set? flags ~ci?) %char-set:letter %char-set:upper-case))
+      ((title-case title)
+       (if (flag-set? flags ~ci?) %char-set:letter (char-set)))
+      ((alphabetic alpha) %char-set:letter)
+      ((numeric num digit) %char-set:digit)
+      ((alphanumeric alphanum alnum) %char-set:letter+digit)
+      ((punctuation punct) %char-set:punctuation)
+      ((graphic graph) %char-set:graphic)
+      ((word-constituent) %char-set:word-constituent)
+      ((whitespace white space) %char-set:whitespace)
+      ((printing print) %char-set:printing)
+      ((control cntrl) %char-set:iso-control)
+      ((hex-digit xdigit hex) char-set:hex-digit)
+      ((ascii) char-set:ascii)
+      (else #f)))
+   (else
+    (case name
+      ((any) char-set:full)
+      ((nonl) char-set:nonl)
+      ((lower-case lower)
+       (if (flag-set? flags ~ci?) (get-char-set:cased) char-set:lower-case))
+      ((upper-case upper)
+       (if (flag-set? flags ~ci?) (get-char-set:cased) char-set:upper-case))
+      ((title-case title)
+       (if (flag-set? flags ~ci?) (get-char-set:cased) char-set:title-case))
+      ((alphabetic alpha) char-set:letter)
+      ((numeric num digit) char-set:digit)
+      ((alphanumeric alphanum alnum) char-set:letter+digit)
+      ((punctuation punct) char-set:punctuation)
+      ((graphic graph) char-set:graphic)
+      ((word-constituent) char-set:word-constituent)
+      ((whitespace white space) char-set:whitespace)
+      ((printing print) char-set:printing)
+      ((control cntrl) char-set:control)
+      ((hex-digit xdigit hex) char-set:hex-digit)
+      ((ascii) char-set:ascii)
+      (else #f)))))
+
+(define (sre-flatten-ranges orig-ls)
+  (let lp ((ls orig-ls) (res '()))
+    (cond
+     ((null? ls)
+      (reverse res))
+     ((string? (car ls))
+      (lp (append (string->list (car ls)) (cdr ls)) res))
+     ((null? (cdr ls))
+      (error "unbalanced cset / range" orig-ls))
+     ((string? (cadr ls))
+      (lp (cons (car ls) (append (string->list (cadr ls)) (cddr ls))) res))
+     (else
+      (lp (cddr ls) (cons (cons (car ls) (cadr ls)) res))))))
+
+(define (every pred ls)
+  (or (null? ls) (and (pred (car ls)) (every pred (cdr ls)))))
+
+(define (char-set-sre? sre)
+  (or (char? sre)
+      (and (string? sre) (= 1 (string-length sre)))
+      (lookup-char-set sre ~none)
+      (and (pair? sre)
+           (or (string? (car sre))
+               (memq (car sre)
+                     '(char-set / char-range & and ~ complement - difference))
+               (and (memq (car sre) '(|\|| or))
+                    (every char-set-sre? (cdr sre)))))))
+
+(define (valid-sre? x)
+  (guard (exn (else #f)) (regexp x) #t))
+
+(define (sre->char-set sre . o)
+  (let ((flags (if (pair? o) (car o) ~none)))
+    (define (->cs sre) (sre->char-set sre flags))
+    (cond
+     ((lookup-char-set sre flags))
+     ((char-set? sre) (char-set-ci sre))
+     ((char? sre) (char-set-ci (char-set sre)))
+     ((string? sre)
+      (if (= 1 (string-length sre))
+          (string->char-set sre)
+          (error "only single char strings can be char-sets")))
+     ((pair? sre)
+      (if (string? (car sre))
+          (string->char-set (car sre))
+          (case (car sre)
+            ((char-set) (string->char-set (cadr sre)))
+            ((/ char-range)
+             (->cs
+              `(or ,@(map (lambda (x)
+                            (char-set-ci
+                             (ucs-range->char-set
+                              (char->integer (car x))
+                              (+ 1 (char->integer (cdr x))))))
+                          (sre-flatten-ranges (cdr sre))))))
+            ((& and) (apply char-set-intersection (map ->cs (cdr sre))))
+            ((|\|| or) (apply char-set-union (map ->cs (cdr sre))))
+            ((~ complement) (char-set-complement (->cs `(or ,@(cdr sre)))))
+            ((- difference) (char-set-difference (->cs (cadr sre))
+                                                 (->cs `(or ,@(cddr sre)))))
+            (else (error "invalid sre char-set" sre)))))
+     (else (error "invalid sre char-set" sre)))))
+
+(define (char-set->sre cset)
+  (list (char-set->string cset)))
+
+(define (strip-submatches sre)
+  (if (pair? sre)
+      (case (car sre)
+        (($ submatch) (strip-submatches (cons ': (cdr sre))))
+        ((-> => submatch-named) (strip-submatches (cons ': (cddr sre))))
+        (else (cons (strip-submatches (car sre))
+                    (strip-submatches (cdr sre)))))
+      sre))
+
+(define (sre-expand-reps from to sre)
+  (let ((sre0 (strip-submatches sre)))
+    (let lp ((i 0) (res '(:)))
+      (if (= i from)
+          (cond
+           ((not to)
+            (reverse (cons `(* ,sre) res)))
+           ((= from to)
+            (reverse (cons sre (cdr res))))
+           (else
+            (let lp ((i (+ i 1)) (res res))
+              (if (>= i to)
+                  (reverse (cons `(? ,sre) res))
+                  (lp (+ i 1) (cons `(? ,sre0) res))))))
+          (lp (+ i 1) (cons sre0 res))))))
+
+;;> Compile an \var{sre} into a regexp.
+
+(define (regexp sre . o)
+  (define current-index 2)
+  (define current-match 0)
+  (define match-names '())
+  (define match-rules (list (cons 0 1)))
+  (define (make-submatch-state sre flags next index)
+    (let* ((n3 (make-epsilon-state next))
+           (n2 (->rx sre flags n3))
+           (n1 (make-epsilon-state n2)))
+      (state-match-set! n1 index)
+      (state-match-rule-set! n1 'left)
+      (state-match-set! n3 (+ index 1))
+      (state-match-rule-set! n3 'right)
+      n1))
+  (define (->rx sre flags next)
+    (cond
+     ;; The base cases chars and strings match literally.
+     ((char? sre)
+      (make-char-state sre flags next))
+     ((char-set? sre)
+      (make-char-state sre flags next))
+     ((string? sre)
+      (->rx (cons 'seq (string->list sre)) flags next))
+     ((and (symbol? sre) (lookup-char-set sre flags))
+      => (lambda (cset) (make-char-state cset ~none next)))
+     ((symbol? sre)
+      (case sre
+        ((epsilon) next)
+        ((bos) (make-char-state match/bos flags next))
+        ((eos) (make-char-state match/eos flags next))
+        ((bol) (make-char-state match/bol flags next))
+        ((eol) (make-char-state match/eol flags next))
+        ((bow) (make-char-state match/bow flags next))
+        ((eow) (make-char-state match/eow flags next))
+        ((nwb) (make-char-state match/nwb flags next))
+        ((bog) (make-char-state match/bog flags next))
+        ((eog) (make-char-state match/eog flags next))
+        ((grapheme)
+         (->rx
+          `(or (: (* ,char-set:hangul-l) (+ ,char-set:hangul-v)
+                  (* ,char-set:hangul-t))
+               (: (* ,char-set:hangul-l) ,char-set:hangul-v
+                  (* ,char-set:hangul-v) (* ,char-set:hangul-t))
+               (: (* ,char-set:hangul-l) ,char-set:hangul-lvt
+                  (* ,char-set:hangul-t))
+               (+ ,char-set:hangul-l)
+               (+ ,char-set:hangul-t)
+               (+ ,char-set:regional-indicator)
+               (: "\r\n")
+               (: (~ control ("\r\n"))
+                  (+ ,char-set:extend-or-spacing-mark))
+               control)
+          flags
+          next))
+        ((word) (->rx '(word+ any) flags next))
+        (else (error "unknown sre" sre))))
+     ((pair? sre)
+      (case (car sre)
+        ((seq :)
+         ;; Sequencing.  An empty sequence jumps directly to next,
+         ;; otherwise we join the first element to the sequence formed
+         ;; of the remaining elements followed by next.
+         (if (null? (cdr sre))
+             next
+             ;; Make a dummy intermediate to join the states so that
+             ;; we can generate n1 first, preserving the submatch order.
+             (let* ((n2 (make-epsilon-state #f))
+                    (n1 (->rx (cadr sre) flags n2))
+                    (n3 (->rx (cons 'seq (cddr sre)) flags next)))
+               (state-next1-set! n2 n3)
+               n1)))
+        ((or |\||)
+         ;; Alternation.  An empty alternation always fails.
+         ;; Otherwise we fork between any of the alternations, each
+         ;; continuing to next.
+         (cond
+          ((null? (cdr sre))
+           #f)
+          ((char-set-sre? sre)
+           (make-char-state (sre->char-set sre) flags next))
+          ((null? (cddr sre))
+           (->rx (cadr sre) flags next))
+          (else
+           (let* ((n1 (->rx (cadr sre) flags next))
+                  (n2 (->rx (cons 'or (cddr sre)) flags next)))
+             (make-fork-state n1 n2)))))
+        ((? optional)
+         ;; Optionality.  Either match the body or fork to the next
+         ;; state directly.
+         (make-fork-state (->rx (cons 'seq (cdr sre)) flags next) next))
+        ((* zero-or-more)
+         ;; Repetition.  Introduce two fork states which can jump from
+         ;; the end of the loop to the beginning and from the
+         ;; beginning to the end (to skip the first iteration).
+         (let* ((n2 (make-fork-state next #f))
+                (n1 (make-fork-state (->rx (cons 'seq (cdr sre)) flags n2) n2)))
+           (state-next2-set! n2 n1)
+           n1))
+        ((+ one-or-more)
+         ;; One-or-more repetition.  Same as above but the first
+         ;; transition is required so the rx is simpler - we only
+         ;; need one fork from the end of the loop to the beginning.
+         (let* ((n2 (make-fork-state next #f))
+                (n1 (->rx (cons 'seq (cdr sre)) flags n2)))
+           (state-next2-set! n2 n1)
+           n1))
+        ((= exactly)
+         ;; Exact repetition.
+         (->rx (sre-expand-reps (cadr sre) (cadr sre) (cons 'seq (cddr sre)))
+               flags next))
+        ((>= at-least)
+         ;; n-or-more repetition.
+         (->rx (sre-expand-reps (cadr sre) #f (cons 'seq (cddr sre)))
+               flags next))
+        ((** repeated)
+         ;; n-to-m repetition.
+         (->rx (sre-expand-reps (cadr sre) (car (cddr sre))
+                                (cons 'seq (cdr (cddr sre))))
+               flags next))
+        ((-> => submatch-named)
+         ;; Named submatches just record the name for the current
+         ;; match and rewrite as a non-named submatch.
+         (cond
+          ((flag-set? flags ~nocapture?)
+           (->rx (cons 'seq (cddr sre)) flags next))
+          (else
+           (set! match-names
+                 (cons (cons (cadr sre) (+ 1 current-match)) match-names))
+           (->rx (cons 'submatch (cddr sre)) flags next))))
+        ((*-> *=> submatch-named-list)
+         (cond
+          ((flag-set? flags ~nocapture?)
+           (->rx (cons 'seq (cddr sre)) flags next))
+          (else
+           (set! match-names (cons (cons (cadr sre) current-match) match-names))
+           (->rx (cons 'submatch-list (cddr sre)) flags next))))
+        (($ submatch)
+         ;; A submatch wraps next with an epsilon transition before
+         ;; next, setting the start and end index on the result and
+         ;; wrapped next respectively.
+         (cond
+          ((flag-set? flags ~nocapture?)
+           (->rx (cons 'seq (cdr sre)) flags next))
+          (else
+           (let ((num current-match)
+                 (index current-index))
+             (set! current-match (+ current-match 1))
+             (set! current-index (+ current-index 2))
+             (set! match-rules `((,index . ,(+ index 1)) ,@match-rules))
+             (make-submatch-state (cons 'seq (cdr sre)) flags next index)))))
+        ((*$ submatch-list)
+         ;; A submatch-list wraps a range of submatch results into a
+         ;; single match value.
+         (cond
+          ((flag-set? flags ~nocapture?)
+           (->rx (cons 'seq (cdr sre)) flags next))
+          (else
+           (let* ((num current-match)
+                  (index current-index))
+             (set! current-match (+ current-match 1))
+             (set! current-index (+ current-index 1))
+             (set! match-rules `(,index ,@match-rules))
+             (let* ((n2 (make-epsilon-state next))
+                    (n1 (->rx (cons 'submatch (cdr sre)) flags n2)))
+               (state-match-set! n2 (list index num current-match))
+               (state-match-rule-set! n2 'list)
+               n1)))))
+        ((~ - & / complement difference and char-range char-set)
+         (make-char-state (sre->char-set sre flags) ~none next))
+        ((word)
+         (->rx `(: bow ,@(cdr sre) eow) flags next))
+        ((word+)
+         (->rx `(word (+ ,(if (equal? '(any) (cdr sre))
+                              'word-constituent
+                              (char-set-intersection
+                               char-set:word-constituent
+                               (sre->char-set `(or ,@(cdr sre)) flags)))))
+               flags
+               next))
+        ((w/case)
+         (->rx `(: ,@(cdr sre)) (flag-clear flags ~ci?) next))
+        ((w/nocase)
+         (->rx `(: ,@(cdr sre)) (flag-join flags ~ci?) next))
+        ((w/unicode)
+         (->rx `(: ,@(cdr sre)) (flag-clear flags ~ascii?) next))
+        ((w/ascii)
+         (->rx `(: ,@(cdr sre)) (flag-join flags ~ascii?) next))
+        ((w/nocapture)
+         (->rx `(: ,@(cdr sre)) (flag-join flags ~nocapture?) next))
+        (else
+         (if (string? (car sre))
+             (make-char-state (sre->char-set sre flags) ~none next)
+             (error "unknown sre" sre)))))))
+  (let ((flags (parse-flags (and (pair? o) (car o)))))
+    (if (regexp? sre)
+        sre
+        (let ((start (make-submatch-state sre flags (make-accept-state) 0)))
+          (make-rx start current-match current-index
+                   (list->vector (reverse match-rules)) match-names sre)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Utilities
+
+(define (regexp-fold rx kons knil str . o)
+  (let* ((rx (regexp rx))
+         (finish (if (pair? o) (car o) (lambda (from md str acc) acc)))
+         (o (if (pair? o) (cdr o) o))
+         (start (string-start-arg str o))
+         (end (string-end-arg str (if (pair? o) (cdr o) o))))
+    (let lp ((i start)
+             (from start)
+             (acc knil))
+      (cond
+       ((and (string-cursor<? i end) (regexp-run-offsets #t rx str i end))
+        => (lambda (md)
+             (let ((j (regexp-match-ref md 1)))
+               (lp (if (and (string-cursor=? i j) (string-cursor<? j end))
+                       (string-cursor-next str j)
+                       j)
+                   j
+                   (kons (string-offset->index str from) md str acc)))))
+       (else
+        (finish (string-offset->index str from) #f str acc))))))
+
+(define (regexp-extract rx str . o)
+  (apply regexp-fold
+         rx
+         (lambda (from md str a)
+           (let ((s (regexp-match-submatch md 0)))
+             (if (equal? s "") a (cons s a))))
+         '()
+         str
+         (lambda (from md str a) (reverse a))
+         o))
+
+(define (regexp-split rx str . o)
+  ;; start and end in indices passed to regexp-fold
+  (let ((start (if (pair? o) (car o) 0))
+        (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str))))
+    (regexp-fold
+     rx
+     (lambda (from md str a)
+       (let ((i (regexp-match-submatch-start md 0)))
+         (if (< from i) (cons (substring str from i) a) a)))
+     '()
+     str
+     (lambda (from md str a)
+       (reverse (if (< from end) (cons (substring str from end) a) a)))
+     start
+     end)))
+
+(define (regexp-replace rx str subst . o)
+  (let* ((start (if (and (pair? o) (car o)) (car o) 0))
+         (o (if (pair? o) (cdr o) '()))
+         (end (if (and (pair? o) (car o)) (car o) (string-length str)))
+         (o (if (pair? o) (cdr o) '()))
+         (count (if (pair? o) (car o) 0)))
+    (let lp ((i start) (count count))
+      (let ((m (regexp-search rx str i end)))
+        (cond
+         ((not m) str)
+         ((positive? count)
+          (lp (regexp-match-submatch-end m 0) (- count 1)))
+         (else
+          (string-concatenate
+           (cons
+            (substring-cursor str
+                              (string-index->offset str start)
+                              (regexp-match-submatch-start m 0))
+            (append
+             (reverse (regexp-apply-match m str subst))
+             (list (substring-cursor str
+                                     (regexp-match-submatch-end m 0)
+                                     (string-index->offset str end))))))))))))
+
+(define (regexp-replace-all rx str subst . o)
+  (regexp-fold
+   rx
+   (lambda (i m str acc)
+     (let ((m-start (regexp-match-submatch-start m 0)))
+       (append (regexp-apply-match m str subst)
+               (if (>= i m-start)
+                   acc
+                   (cons (substring str i m-start) acc)))))
+   '()
+   str
+   (lambda (i m str acc)
+     (let ((end (string-length str)))
+       (string-concatenate-reverse
+        (if (>= i end)
+            acc
+            (cons (substring str i end) acc)))))))
+
+(define (regexp-apply-match m str ls)
+  (let lp ((ls ls) (res '()))
+    (cond
+     ((null? ls)
+      res)
+     ((not (pair? ls))
+      (lp (list ls) res))
+     ((integer? (car ls))
+      (lp (cdr ls) (cons (or (regexp-match-submatch m (car ls)) "") res)))
+     ((procedure? (car ls))
+      (lp (cdr ls) (cons ((car ls) m) res)))
+     ((symbol? (car ls))
+      (case (car ls)
+        ((pre)
+         (lp (cdr ls)
+             (cons (substring-cursor str 0 (regexp-match-submatch-start m 0))
+                   res)))
+        ((post)
+         (lp (cdr ls)
+             (cons (substring str
+                              (regexp-match-submatch-end m 0)
+                              (string-length str))
+                   res)))
+        (else
+         (cond
+          ((assq (car ls) (regexp-match-names m))
+           => (lambda (x) (lp (cons (cdr x) (cdr ls)) res)))
+          (else
+           (error "unknown match replacement" (car ls)))))))
+     (else
+      (lp (cdr ls) (cons (car ls) res))))))
+
+(define re:grapheme (regexp 'grapheme))
diff --git a/lib/chibi/regexp.sld b/lib/chibi/regexp.sld
new file mode 100644
index 00000000..148d6085
--- /dev/null
+++ b/lib/chibi/regexp.sld
@@ -0,0 +1,87 @@
+
+(define-library (chibi regexp)
+  (export regexp regexp? valid-sre? rx regexp->sre char-set->sre
+          regexp-matches regexp-matches? regexp-search
+          regexp-replace regexp-replace-all
+          regexp-fold regexp-extract regexp-split
+          regexp-match? regexp-match-count
+          regexp-match-submatch regexp-match-submatch/list
+          regexp-match-submatch-start regexp-match-submatch-end
+          regexp-match->list regexp-match->sexp)
+  (import (srfi 33) (srfi 69))
+  ;; Chibi's char-set library is more factored than SRFI-14.
+  (cond-expand
+   (chibi
+    (import (rename (chibi)
+                    (protect guard)
+                    (char-downcase %char-downcase)
+                    (char-upcase %char-upcase))
+            (only (scheme char) char-downcase char-upcase)
+            (srfi 9)
+            (chibi char-set)
+            (chibi char-set full)
+            (prefix (chibi char-set ascii) %))
+    (begin
+      (define char-set:title-case
+        (char-set-union
+         (ucs-range->char-set #x1F88 #x1F90)
+         (ucs-range->char-set #x1F98 #x1FA0)
+         (ucs-range->char-set #x1FA8 #x1FB0)
+         (char-set #\x01C5 #\x01C8 #\x01CB #\x01F2 #\x1FBC #\x1FCC #\x1FFC)))))
+   (else
+    (import (scheme base) (scheme char) (srfi 14))
+    (begin
+      (define %char-set:letter
+        (char-set-intersection char-set:ascii char-set:letter))
+      (define %char-set:lower-case
+        (char-set-intersection char-set:ascii char-set:lower-case))
+      (define %char-set:upper-case
+        (char-set-intersection char-set:ascii char-set:upper-case))
+      (define %char-set:digit
+        (char-set-intersection char-set:ascii char-set:digit))
+      (define %char-set:letter+digit
+        (char-set-intersection char-set:ascii char-set:letter+digit))
+      (define %char-set:punctuation
+        (char-set-intersection char-set:ascii char-set:punctuation))
+      (define %char-set:graphic
+        (char-set-intersection char-set:ascii char-set:graphic))
+      (define %char-set:whitespace
+        (char-set-intersection char-set:ascii char-set:whitespace))
+      (define %char-set:printing
+        (char-set-intersection char-set:ascii char-set:printing))
+      (define %char-set:iso-control
+        (char-set-intersection char-set:ascii char-set:iso-control)))))
+  (import (chibi char-set boundary))
+  ;; Use string-cursors where available.
+  (begin
+    (define string-cursor? integer?))
+  (cond-expand
+   (chibi
+    (begin
+      (define (string-start-arg s o)
+        (if (pair? o) (string-index->offset s (car o)) (string-cursor-start s)))
+      (define (string-end-arg s o)
+        (if (pair? o) (string-index->offset s (car o)) (string-cursor-end s)))
+      (define (string-concatenate-reverse ls)
+        (string-concatenate (reverse ls)))))
+   (else
+    (begin
+      (define (string-start-arg s o)
+        (if (pair? o) (string-index->offset s (car o)) 0))
+      (define (string-end-arg s o)
+        (if (pair? o) (string-index->offset (car o)) (string-length s)))
+      (define string-cursor=? =)
+      (define string-cursor<? <)
+      (define string-cursor<=? <=)
+      (define string-cursor>? >)
+      (define string-cursor>=? >=)
+      (define string-cursor-ref string-ref)
+      (define (string-cursor-next s i) (+ i 1))
+      (define (string-cursor-prev s i) (- i 1))
+      (define substring-cursor substring)
+      (define (string-offset->index str off) off)
+      (define (string-index->offset str i) i)
+      (define (string-concatenate ls) (apply string-append ls))
+      (define (string-concatenate-reverse ls)
+        (string-concatenate (reverse ls))))))
+  (include "regexp.scm"))
diff --git a/lib/chibi/regexp/pcre.scm b/lib/chibi/regexp/pcre.scm
new file mode 100644
index 00000000..3129f8e8
--- /dev/null
+++ b/lib/chibi/regexp/pcre.scm
@@ -0,0 +1,598 @@
+
+;; PCRE parsing, adapted from IrRegex.
+
+(define ~none 0)
+(define ~save? 1)
+(define ~case-insensitive? 2)
+(define ~multi-line? 4)
+(define ~single-line? 8)
+(define ~ignore-space? 16)
+
+(define (flag-set? flags i)
+  (= i (bitwise-and flags i)))
+(define (flag-join a b)
+  (if b (bitwise-ior a b) a))
+(define (flag-clear a b)
+  (bitwise-and a (bitwise-not b)))
+
+(define (symbol-list->flags ls)
+  (let lp ((ls ls) (res ~none))
+    (cond
+     ((null? ls)
+      res)
+     ((not (pair? ls))
+      (lp (list ls) res))
+     (else
+      (lp (cdr ls)
+          (flag-join
+           res
+           (case (car ls)
+             ((i ci case-insensitive) ~case-insensitive?)
+             ((m multi-line) ~multi-line?)
+             ((s single-line) ~single-line?)
+             ((x ignore-space) ~ignore-space?)
+             (else #f))))))))
+
+(define posix-escape-sequences
+  `((#\n . #\newline)
+    (#\r . #\return)
+    (#\t . #\tab)
+    (#\a . #\alarm)
+    (#\e . #\escape)))
+
+(define (char-altcase c)
+  (if (char-upper-case? c) (char-downcase c) (char-upcase c)))
+
+(define (char-mirror c)
+  (case c ((#\<) #\>) ((#\{) #\}) ((#\() #\)) ((#\[) #\]) (else c)))
+
+(define (string-scan-char-escape str c . o)
+  (let ((end (string-length str)))
+    (let scan ((i (if (pair? o) (car o) 0)))
+      (cond ((= i end) #f)
+            ((eqv? c (string-ref str i)) i)
+            ((eqv? c #\\) (scan (+ i 2)))
+            (else (scan (+ i 1)))))))
+
+(define (string-parse-hex-escape str i end)
+  (cond
+   ((>= i end)
+    (error "incomplete hex escape" str i))
+   ((eqv? #\{ (string-ref str i))
+    (let ((j (string-scan-char-escape str #\} (+ i 1))))
+      (if (not j)
+          (error "incomplete hex brace escape" str i)
+          (let* ((s (substring str (+ i 1) j))
+                 (n (string->number s 16)))
+            (if n
+                (list (integer->char n) j)
+                (error "bad hex brace escape" s))))))
+   ((>= (+ i 1) end)
+    (error "incomplete hex escape" str i))
+   (else
+    (let* ((s (substring str i (+ i 2)))
+           (n (string->number s 16)))
+      (if n
+          (list (integer->char n) (+ i 2))
+          (error "bad hex escape" s))))))
+
+(define (string-parse-cset str start flags)
+  (let* ((end (string-length str))
+         (invert? (and (< start end) (eqv? #\^ (string-ref str start)))))
+    (define (cset-union a b)
+      (cond ((not a) b)
+            ((not b) a)
+            ((and (pair? a) (eq? 'or (car a))) `(,@a ,b))
+            (else `(or ,a ,b))))
+    (define (go i prev-char ones pairs classes)
+      (if (>= i end)
+          (error "incomplete char set" str i end))
+      (case (string-ref str i)
+        ((#\])
+         (if (and (null? ones) (null? pairs))
+             (go (+ i 1) #\] (cons #\] ones) pairs classes)
+             (list
+              (let ((res
+                     (cset-union
+                      (cset-union
+                       (and (pair? classes)
+                            `(or ,@classes))
+                       (and (pair? ones)
+                            `(,(list->string (reverse ones)))))
+                      (and (pair? pairs)
+                           `(/ ,(list->string (reverse pairs)))))))
+                (if invert? `(~ ,res) res))
+              i)))
+        ((#\-)
+         (cond
+          ((or (= i start)
+               (and (= i (+ start 1)) invert?)
+               (eqv? #\] (string-ref str (+ i 1))))
+           (go (+ i 1) #\- (cons #\- ones) pairs classes))
+          ;; alternately permissively allow this as a -
+          ((not prev-char)
+           (error "bad pcre char-set, unexpected -" str))
+          (else
+           (let ((ch (string-ref str (+ i 1))))
+             (apply
+              (lambda (c j)
+                (if (char<? c prev-char)
+                    (error "inverted range in pcre char-set" prev-char c)
+                    (go j #f (cdr ones) (cons c (cons prev-char pairs))
+                        classes)))
+              (cond
+               ((and (eqv? #\\ ch)
+                     (assv (string-ref str (+ i 2)) posix-escape-sequences))
+                => (lambda (x) (list (cdr x) (+ i 3))))
+               ((and (eqv? #\\ ch)
+                     (eqv? (string-ref str (+ i 2)) #\x))
+                (string-parse-hex-escape str (+ i 3) end))
+               (else
+                (list ch (+ i 2)))))))))
+        ((#\[)
+         (let* ((inv? (eqv? #\^ (string-ref str (+ i 1))))
+                (i2 (if inv? (+ i 2) (+ i 1))))
+           (case (string-ref str i2)
+             ((#\:)
+              (let ((j (string-find str #\: (+ i2 1) end)))
+                (if (or (>= (+ j 1) end)
+                        (not (eqv? #\] (string-ref str (+ j 1)))))
+                    (error "incomplete character class" str)
+                    (let* ((class (string->symbol (substring str (+ i2 1) j)))
+                           (class (if inv? `(~ ,class) class)))
+                      (go (+ j 2) #f ones pairs (cons class classes))))))
+             ((#\= #\.)
+              (error "collating sequences not supported" str))
+             (else
+              (go (+ i 1) #\[ (cons #\[ ones) pairs classes)))))
+        ((#\\)
+         (let ((c (string-ref str (+ i 1))))
+           (case c
+             ((#\d #\D #\s #\S #\w #\W)
+              (go (+ i 2) #f ones pairs
+                  (cons (pcre->sre (string #\\ c)) classes)))
+             ((#\x)
+              (apply
+               (lambda (c j) (go j c (cons c ones) pairs classes))
+               (string-parse-hex-escape str (+ i 2) end)))
+             (else
+              (let ((c (cond ((assv c posix-escape-sequences) => cdr)
+                             (else c))))
+                (go (+ i 2) c (cons c ones) pairs classes))))))
+        (else
+         => (lambda (c) (go (+ i 1) c (cons c ones) pairs classes)))))
+    (if invert?
+        (let ((ones (if (flag-set? flags ~multi-line?) '(#\newline) '())))
+          (go (+ start 1) #f ones '() '()))
+        (go start #f '() '() '()))))
+
+;; build a (seq ls ...) sre from a list
+(define (sre-sequence ls)
+  (cond
+   ((null? ls) 'epsilon)
+   ((null? (cdr ls)) (car ls))
+   (else (cons 'seq ls))))
+
+;; build a (or ls ...) sre from a list
+(define (sre-alternate ls)
+  (cond
+   ((null? ls) '(or))
+   ((null? (cdr ls)) (car ls))
+   (else (cons 'or ls))))
+
+;; returns #t if the sre can ever be empty
+(define (sre-empty? sre)
+  (if (pair? sre)
+      (case (car sre)
+        ((* ? look-ahead look-behind neg-look-ahead neg-look-behind) #t)
+        ((**) (or (not (number? (cadr sre))) (zero? (cadr sre))))
+        ((or) (any sre-empty? (cdr sre)))
+        ((: seq $ submatch => submatch-named + atomic)
+         (every sre-empty? (cdr sre)))
+        (else #f))
+      (memq sre '(epsilon bos eos bol eol bow eow commit))))
+
+;; returns #t if the sre is a */+ repetition
+(define (sre-repeater? sre)
+  (and (pair? sre)
+       (or (memq (car sre) '(* +))
+           (and (memq (car sre) '($ submatch => submatch-named seq :))
+                (pair? (cdr sre))
+                (null? (cddr sre))
+                (sre-repeater? (cadr sre))))))
+
+(define (pcre->sre str . o)
+  (if (not (string? str))
+      (error "pcre->sre: expected a string" str))
+  (let ((end (string-length str))
+        (orig-flags (if (pair? o) (symbol-list->flags (car o)) ~none)))
+    (let lp ((i 0) (from 0) (flags orig-flags) (res '()) (st '()))
+      ;; accumulate the substring from..i as literal text
+      (define (collect)
+        (if (= i from) res (cons (substring str from i) res)))
+      ;; like collect but breaks off the last single character when
+      ;; collecting literal data, as the argument to ?/*/+ etc.
+      (define (collect/single)
+        (let ((j (- i 1)))
+          (cond
+           ((< j from)
+            res)
+           (else
+            (let ((c (string-ref str j)))
+              (cond
+               ((= j from)
+                (cons c res))
+               (else
+                (cons c (cons (substring str from j) res)))))))))
+      ;; collects for use as a result, reversing and grouping OR
+      ;; terms, and some ugly tweaking of `function-like' groups and
+      ;; conditionals
+      (define (collect/terms)
+        (let* ((ls (collect))
+               (func
+                (and (pair? ls)
+                     (memq (last ls)
+                           '(atomic if look-ahead neg-look-ahead
+                                    look-behind neg-look-behind
+                                    => submatch-named))))
+               (prefix (if (and func (memq (car func) '(=> submatch-named)))
+                           (list 'submatch-named (cadr (reverse ls)))
+                           (and func (list (car func)))))
+               (ls (if func
+                       (if (memq (car func) '(=> submatch-named))
+                           (reverse (cddr (reverse ls)))
+                           (reverse (cdr (reverse ls))))
+                       ls)))
+          (let lp ((ls ls) (term '()) (res '()))
+            (define (shift)
+              (cons (sre-sequence term) res))
+            (cond
+             ((null? ls)
+              (let* ((res (sre-alternate (shift)))
+                     (res (if (flag-set? flags ~save?)
+                              (list 'submatch res)
+                              res)))
+                (if prefix
+                    (if (eq? 'if (car prefix))
+                        (cond
+                         ((not (pair? res))
+                          'epsilon)
+                         ((memq (car res)
+                                '(look-ahead neg-look-ahead
+                                             look-behind neg-look-behind))
+                          res)
+                         ((eq? 'seq (car res))
+                          `(if ,(cadr res)
+                               ,(sre-sequence (cddr res))))
+                         (else
+                          `(if ,(cadadr res)
+                               ,(sre-sequence (cddadr res))
+                               ,(sre-alternate (cddr res)))))
+                        `(,@prefix ,res))
+                    res)))
+             ((eq? 'or (car ls)) (lp (cdr ls) '() (shift)))
+             (else (lp (cdr ls) (cons (car ls) term) res))))))
+      (define (save)
+        (cons (cons flags (collect)) st))
+      ;; main parsing
+      (cond
+       ((>= i end)
+        (if (pair? st)
+            (error "unterminated parenthesis in regexp" str)
+            (collect/terms)))
+       (else
+        (case (string-ref str i)
+          ((#\.)
+           (lp (+ i 1) (+ i 1) flags
+               (cons (if (flag-set? flags ~single-line?) 'any 'nonl)
+                     (collect))
+               st))
+          ((#\?)
+           (let ((res (collect/single)))
+             (if (null? res)
+                 (error "? can't follow empty pattern" str res)
+                 (let ((x (car res)))
+                   (lp (+ i 1)
+                       (+ i 1)
+                       flags
+                       (cons
+                        (if (pair? x)
+                            (case (car x)
+                              ((*)  `(*? ,@(cdr x)))
+                              ((+)  `(**? 1 #f ,@(cdr x)))
+                              ((?)  `(?? ,@(cdr x)))
+                              ((**) `(**? ,@(cdr x)))
+                              ((=)  `(**? ,(cadr x) ,@(cdr x)))
+                              ((>=)  `(**? ,(cadr x) #f ,@(cddr x)))
+                              (else `(? ,x)))
+                            `(? ,x))
+                        (cdr res))
+                       st)))))
+          ((#\+ #\*)
+           (let* ((res (collect/single))
+                  (x (if (pair? res) (car res) 'epsilon))
+                  (op (string->symbol (string (string-ref str i)))))
+             (cond
+              ((sre-repeater? x)
+               (error "duplicate repetition (e.g. **) in pattern" str res))
+              ((sre-empty? x)
+               (error "can't repeat empty pattern (e.g. ()*)" str res))
+              (else
+               (lp (+ i 1) (+ i 1) flags
+                   (cons (list op x) (cdr res))
+                   st)))))
+          ((#\()
+           (cond
+            ((>= (+ i 1) end)
+             (error "unterminated parenthesis in regexp" str))
+            ((not (memv (string-ref str (+ i 1)) '(#\? #\*))) ; normal case
+             (lp (+ i 1) (+ i 1) (flag-join flags ~save?) '() (save)))
+            ((>= (+ i 2) end)
+             (error "unterminated parenthesis in regexp" str))
+            ((eqv? (string-ref str (+ i 1)) #\*)
+             (error "bad regexp syntax: (*FOO) not supported" str))
+            (else ;; (?...) case
+             (case (string-ref str (+ i 2))
+               ((#\#)
+                (let ((j (string-find str #\) (+ i 3))))
+                  (lp (+ j i) (min (+ j 1) end) flags (collect) st)))
+               ((#\:)
+                (lp (+ i 3) (+ i 3) (flag-clear flags ~save?) '() (save)))
+               ((#\=)
+                (lp (+ i 3) (+ i 3) (flag-clear flags ~save?)
+                    '(look-ahead) (save)))
+               ((#\!)
+                (lp (+ i 3) (+ i 3) (flag-clear flags ~save?)
+                    '(neg-look-ahead) (save)))
+               ((#\<)
+                (cond
+                 ((>= (+ i 3) end)
+                  (error "unterminated parenthesis in regexp" str))
+                 (else
+                  (case (string-ref str (+ i 3))
+                    ((#\=)
+                     (lp (+ i 4) (+ i 4) (flag-clear flags ~save?)
+                         '(look-behind) (save)))
+                    ((#\!)
+                     (lp (+ i 4) (+ i 4) (flag-clear flags ~save?)
+                         '(neg-look-behind) (save)))
+                    (else
+                     (let ((j (and (char-alphabetic?
+                                    (string-ref str (+ i 3)))
+                                   (string-find str #\> (+ i 4)))))
+                       (if (< j end)
+                           (lp (+ j 1) (+ j 1) (flag-clear flags ~save?)
+                               `(,(string->symbol (substring str (+ i 3) j))
+                                 submatch-named)
+                               (save))
+                           (error "invalid (?< sequence" str))))))))
+               ((#\>)
+                (lp (+ i 3) (+ i 3) (flag-clear flags ~save?)
+                    '(atomic) (save)))
+               ;;((#\' #\P) ; named subpatterns
+               ;; )
+               ;;((#\R) ; recursion
+               ;; )
+               ((#\()
+                (cond
+                 ((>= (+ i 3) end)
+                  (error "unterminated parenthesis in regexp" str))
+                 ((char-numeric? (string-ref str (+ i 3)))
+                  (let* ((j (string-find str #\) (+ i 3)))
+                         (n (string->number (substring str (+ i 3) j))))
+                    (if (or (= j end) (not n))
+                        (error "invalid conditional reference" str)
+                        (lp (+ j 1) (+ j 1) (flag-clear flags ~save?)
+                            `(,n if) (save)))))
+                 ((char-alphabetic? (string-ref str (+ i 3)))
+                  (let ((j (string-find str #\) (+ i 3))))
+                    (if (= j end)
+                        (error "invalid named conditional reference" str)
+                        (lp (+ j 1) (+ j 1) (flag-clear flags ~save?)
+                            `(,(string->symbol (substring str (+ i 3) j)) if)
+                            (save)))))
+                 (else
+                  (lp (+ i 2) (+ i 2) (flag-clear flags ~save?)
+                      '(if) (save)))))
+               ((#\{)
+                (error "unsupported Perl-style cluster" str))
+               (else
+                (let ((old-flags flags))
+                  (let lp2 ((j (+ i 2)) (flags flags) (invert? #f))
+                    (define (join x)
+                      ((if invert? flag-clear flag-join) flags x))
+                    (cond
+                     ((>= j end)
+                      (error "incomplete cluster" str i))
+                     (else
+                      (case (string-ref str j)
+                        ((#\i)
+                         (lp2 (+ j 1) (join ~case-insensitive?) invert?))
+                        ((#\m)
+                         (lp2 (+ j 1) (join ~multi-line?) invert?))
+                        ((#\x)
+                         (lp2 (+ j 1) (join ~ignore-space?) invert?))
+                        ((#\-)
+                         (lp2 (+ j 1) flags (not invert?)))
+                        ((#\))
+                         (lp (+ j 1) (+ j 1) flags (collect)
+                             st))
+                        ((#\:)
+                         (lp (+ j 1) (+ j 1) flags '()
+                             (cons (cons old-flags (collect)) st)))
+                        (else
+                         (error "unknown regex cluster modifier" str)
+                         )))))))))))
+          ((#\))
+           (if (null? st)
+               (error "too many )'s in regexp" str)
+               (lp (+ i 1)
+                   (+ i 1)
+                   (caar st)
+                   (cons (collect/terms) (cdar st))
+                   (cdr st))))
+          ((#\[)
+           (apply
+            (lambda (sre j)
+              (lp (+ j 1) (+ j 1) flags (cons sre (collect)) st))
+            (string-parse-cset str (+ i 1) flags)))
+          ((#\{)
+           (cond
+            ((or (>= (+ i 1) end)
+                 (not (or (char-numeric? (string-ref str (+ i 1)))
+                          (eqv? #\, (string-ref str (+ i 1))))))
+             (lp (+ i 1) from flags res st))
+            (else
+             (let ((res (collect/single)))
+               (cond
+                ((null? res)
+                 (error "{ can't follow empty pattern"))
+                (else
+                 (let* ((x (car res))
+                        (tail (cdr res))
+                        (j (string-find str #\} (+ i 1)))
+                        (s2 (string-split (substring str (+ i 1) j) #\,))
+                        (n (string->number (car s2)))
+                        (m (and (pair? (cdr s2))
+                                (string->number (cadr s2)))))
+                   (cond
+                    ((or (= j end)
+                         (not n)
+                         (and (pair? (cdr s2))
+                              (not (equal? "" (cadr s2)))
+                              (not m)))
+                     (error "invalid {n} repetition syntax" s2))
+                    ((null? (cdr s2))
+                     (lp (+ j 1) (+ j 1) flags `((= ,n ,x) ,@tail) st))
+                    (m
+                     (lp (+ j 1) (+ j 1) flags `((** ,n ,m ,x) ,@tail) st))
+                    (else
+                     (lp (+ j 1) (+ j 1) flags `((>= ,n ,x) ,@tail) st)
+                     )))))))))
+          ((#\\)
+           (cond
+            ((>= (+ i 1) end)
+             (error "incomplete escape sequence" str))
+            (else
+             (let ((c (string-ref str (+ i 1))))
+               (case c
+                 ((#\d)
+                  (lp (+ i 2) (+ i 2) flags `(numeric ,@(collect)) st))
+                 ((#\D)
+                  (lp (+ i 2) (+ i 2) flags `((~ numeric) ,@(collect)) st))
+                 ((#\s)
+                  (lp (+ i 2) (+ i 2) flags `(space ,@(collect)) st))
+                 ((#\S)
+                  (lp (+ i 2) (+ i 2) flags `((~ space) ,@(collect)) st))
+                 ((#\w)
+                  (lp (+ i 2) (+ i 2) flags
+                      `((or alphanumeric ("_")) ,@(collect)) st))
+                 ((#\W)
+                  (lp (+ i 2) (+ i 2) flags
+                      `((~ (or alphanumeric ("_"))) ,@(collect)) st))
+                 ((#\b)
+                  (lp (+ i 2) (+ i 2) flags
+                      `((or bow eow) ,@(collect)) st))
+                 ((#\B)
+                  (lp (+ i 2) (+ i 2) flags `(nwb ,@(collect)) st))
+                 ((#\A)
+                  (lp (+ i 2) (+ i 2) flags `(bos ,@(collect)) st))
+                 ((#\Z)
+                  (lp (+ i 2) (+ i 2) flags
+                      `((? #\newline) eos ,@(collect)) st))
+                 ((#\z)
+                  (lp (+ i 2) (+ i 2) flags `(eos ,@(collect)) st))
+                 ((#\R)
+                  (lp (+ i 2) (+ i 2) flags `(newline ,@(collect)) st))
+                 ((#\K)
+                  (lp (+ i 2) (+ i 2) flags `(reset ,@(collect)) st))
+                 ;; these two are from Emacs and TRE, but not in PCRE
+                 ((#\<)
+                  (lp (+ i 2) (+ i 2) flags `(bow ,@(collect)) st))
+                 ((#\>)
+                  (lp (+ i 2) (+ i 2) flags `(eow ,@(collect)) st))
+                 ((#\x)
+                  (apply
+                   (lambda (ch j)
+                     (lp (+ j 1) (+ j 1) flags `(,ch ,@(collect)) st))
+                   (string-parse-hex-escape str (+ i 2) end)))
+                 ((#\k)
+                  (let ((c (string-ref str (+ i 2))))
+                    (if (not (memv c '(#\< #\{ #\')))
+                        (error "bad \\k usage, expected \\k<...>" str)
+                        (let* ((terminal (char-mirror c))
+                               (j (string-find str terminal (+ i 2)))
+                               (s (substring str (+ i 3) j))
+                               (backref
+                                (if (flag-set? flags ~case-insensitive?)
+                                    'backref-ci
+                                    'backref)))
+                          (if (= j end)
+                              (error "unterminated named backref" str)
+                              (lp (+ j 1) (+ j 1) flags
+                                  `((,backref ,(string->symbol s))
+                                    ,@(collect))
+                                  st))))))
+                 ((#\Q) ;; \Q..\E escapes
+                  (let ((res (collect)))
+                    (let lp2 ((j (+ i 2)))
+                      (cond
+                       ((>= j end)
+                        (lp j (+ i 2) flags res st))
+                       ((eqv? #\\ (string-ref str j))
+                        (cond
+                         ((>= (+ j 1) end)
+                          (lp (+ j 1) (+ i 2) flags res st))
+                         ((eqv? #\E (string-ref str (+ j 1)))
+                          (lp (+ j 2) (+ j 2) flags
+                              (cons (substring str (+ i 2) j) res) st))
+                         (else
+                          (lp2 (+ j 2)))))
+                       (else
+                        (lp2 (+ j 1)))))))
+                 ;;((#\p)  ; XXXX unicode properties
+                 ;; )
+                 ;;((#\P)
+                 ;; )
+                 (else
+                  (cond
+                   ((char-numeric? c)
+                    (let* ((j (string-skip str char-numeric? (+ i 2)))
+                           (backref
+                            (if (flag-set? flags ~case-insensitive?)
+                                'backref-ci
+                                'backref))
+                           (res `((,backref ,(string->number
+                                              (substring str (+ i 1) j)))
+                                  ,@(collect))))
+                      (lp j j flags res st)))
+                   ((char-alphabetic? c)
+                    (let ((cell (assv c posix-escape-sequences)))
+                      (if cell
+                          (lp (+ i 2) (+ i 2) flags
+                              (cons (cdr cell) (collect)) st)
+                          (error "unknown escape sequence" str c))))
+                   (else
+                    (lp (+ i 2) (+ i 1) flags (collect) st)))))))))
+          ((#\|)
+           (lp (+ i 1) (+ i 1) flags (cons 'or (collect)) st))
+          ((#\^)
+           (let ((sym (if (flag-set? flags ~multi-line?) 'bol 'bos)))
+             (lp (+ i 1) (+ i 1) flags (cons sym (collect)) st)))
+          ((#\$)
+           (let ((sym (if (flag-set? flags ~multi-line?) 'eol 'eos)))
+             (lp (+ i 1) (+ i 1) flags (cons sym (collect)) st)))
+          ((#\space)
+           (if (flag-set? flags ~ignore-space?)
+               (lp (+ i 1) (+ i 1) flags (collect) st)
+               (lp (+ i 1) from flags res st)))
+          ((#\#)
+           (if (flag-set? flags ~ignore-space?)
+               (let ((j (string-find str #\newline (+ i 1))))
+                 (lp (+ j 1) (min (+ j 1) end) flags (collect) st))
+               (lp (+ i 1) from flags res st)))
+          (else
+           (lp (+ i 1) from flags res st))))))))
+
+(define (pcre->regexp pcre . o)
+  (regexp (apply pcre->sre pcre o)))
diff --git a/lib/chibi/regexp/pcre.sld b/lib/chibi/regexp/pcre.sld
new file mode 100644
index 00000000..795220ae
--- /dev/null
+++ b/lib/chibi/regexp/pcre.sld
@@ -0,0 +1,7 @@
+
+(define-library (chibi regexp pcre)
+  (export pcre->sre pcre->regexp)
+  (import (scheme base) (scheme char) (scheme cxr)
+          (srfi 1) (srfi 33)
+          (chibi string) (chibi regexp))
+  (include "pcre.scm"))
diff --git a/lib/chibi/reload.scm b/lib/chibi/reload.scm
new file mode 100644
index 00000000..d65187f1
--- /dev/null
+++ b/lib/chibi/reload.scm
@@ -0,0 +1,68 @@
+;; reload.scm -- automatic module reloading
+;; Copyright (c) 2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define last-modified-time (current-seconds))
+
+(define reload-verbose? (make-parameter #f))
+
+(define (warn msg . args)
+  (let ((err (current-error-port)))
+    (display msg err)
+    (display ":" err)
+    (for-each (lambda (a)
+                (display " " err)
+                (if (string? a) (display a err) (write a err)))
+              args)
+    (newline err)))
+
+(define (reload module-name)
+  (if (reload-verbose?)
+      (warn "Reloading module" module-name))
+  (let ((old-module (find-module module-name)))
+    ;; Remove old entry in modules list.
+    (delete-module! module-name)
+    (protect (exn (else (warn "Error loading module definition" module-name)
+                        (print-exception exn)
+                        (print-stack-trace)
+                        (add-module! module-name old-module)))
+      (load-module-definition module-name)
+      (let ((module (find-module module-name)))
+        (cond
+         ((not module) (warn "Couldn't find module" module-name))
+         (else
+          (protect (exn (else (warn "Error loading module" module-name)
+                              (print-exception exn)
+                              (print-stack-trace)
+                              (delete-module! module-name)
+                              (add-module! module-name old-module)))
+            (let ((env (eval-module module-name module)))
+              (%import (module-env module) env (env-exports env) #f)))))))))
+
+(define (file-modified? path)
+  (and path (> (file-modification-time path) last-modified-time)))
+
+(define (module-definition-modified? module-name module)
+  (file-modified? (find-module-file (module-name->file module-name))))
+
+(define (module-includes-modified? module-name module)
+  (let ((dir (module-name-prefix module-name)))
+    (any
+     (lambda (x)
+       (and (pair? x) (memq (car x) '(include include-ci))
+            (any file-modified?
+                 (map (lambda (f) (find-module-file (string-append dir f)))
+                      (cdr x)))))
+     (module-meta-data module))))
+
+(define (module-modified? module-name module)
+  (or (module-definition-modified? module-name module)
+      (module-includes-modified? module-name module)))
+
+(define (reload-modified-modules)
+  (for-each
+   (lambda (x)
+     (if (module-modified? (car x) (cdr x))
+         (reload (car x))))
+   *modules*)
+  (set! last-modified-time (current-seconds)))
diff --git a/lib/chibi/reload.sld b/lib/chibi/reload.sld
new file mode 100644
index 00000000..2924d863
--- /dev/null
+++ b/lib/chibi/reload.sld
@@ -0,0 +1,9 @@
+
+(define-library (chibi reload)
+  (import (chibi)
+          (meta)
+          (srfi 39)
+          (only (chibi time) current-seconds)
+          (only (chibi filesystem) file-modification-time))
+  (include "reload.scm")
+  (export reload reload-modified-modules reload-verbose?))
diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm
new file mode 100644
index 00000000..fb332dd2
--- /dev/null
+++ b/lib/chibi/repl.scm
@@ -0,0 +1,461 @@
+;; repl.scm - friendlier repl with line editing and signal handling
+;; Copyright (c) 2012-2013 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> A user-friendly REPL with line editing and signal handling.  The
+;;> default REPL provided by chibi-scheme is very minimal, meant
+;;> primarily to be small and work on any platform.  This module
+;;> provides an advanced REPL that handles vt100 line editing and
+;;> signal handling, so that C-c will interrupt a computation and
+;;> bring you back to the REPL prompt.  To use this repl, run
+;;> \command{chibi-scheme -R} from the command line or within Emacs.
+
+(define (with-signal-handler sig handler thunk)
+  (let ((old-handler #f))
+    (dynamic-wind
+      (lambda () (set! old-handler (set-signal-action! sig handler)))
+      thunk
+      (lambda () (set-signal-action! sig old-handler)))))
+
+(define (warn msg . args)
+  (let ((out (current-error-port)))
+    (display msg out)
+    (for-each (lambda (x) (write-char #\space out) (write x out)) args)
+    (newline out)))
+
+(define (write-to-string x)
+  (call-with-output-string (lambda (out) (write x out))))
+
+(define (complete-sexp? str)
+  (call-with-input-string str
+    (lambda (in)
+      (let lp () (if (not (eof-object? (read/ss in))) (lp))))))
+
+(define (read-line/complete-sexp in)
+  (let lp ((res ""))
+    (let ((line (read-line in)))
+      (cond
+       ((eof-object? line)
+        (if (equal? res "") line res))
+       (else
+        (let ((res (string-append res line "\n")))
+          (if (protect (exn (else #f)) (complete-sexp? res))
+              res
+              (lp res))))))))
+
+(define (buffer-complete-sexp? buf)
+  (complete-sexp? (buffer->string buf)))
+
+(define module? vector?)
+(define (module-env mod) (vector-ref mod 1))
+
+(define (all-exports env)
+  (let lp ((env env) (res '()))
+    (if (not env)
+        res
+        (lp (env-parent env) (append (env-exports env) res)))))
+
+(define (string-common-prefix-length strings)
+  (if (null? strings)
+      0
+      (let lp ((len (string-length (car strings)))
+               (prev (car strings))
+               (ls (cdr strings)))
+        (if (or (null? ls) (zero? len))
+            len
+            (lp (min len (string-mismatch prev (car ls)))
+                (car ls)
+                (cdr ls))))))
+
+(define (make-sexp-buffer-completer)
+  (buffer-make-completer
+   (lambda (buf word)
+     (let* ((len (string-length word))
+            (candidates
+             (filter
+              (lambda (w)
+                (and (>= (string-length w) len)
+                     (equal? word (substring w 0 len))))
+              (map symbol->string (all-exports (interaction-environment)))))
+            (prefix-len (string-common-prefix-length candidates)))
+       (if (> prefix-len len)
+           (list (substring (car candidates) 0 prefix-len))
+           (sort candidates))))))
+
+(define (describe x . o)
+  (let ((out (if (pair? o) (car o) (current-output-port))))
+    (cond
+     ((null? x)
+      (display "empty list\n" out))
+     ((list? x)
+      (display "list of length " out) (write (length x) out) (newline out)
+      (let lp ((ls x) (i 0))
+        (cond
+         ((pair? ls)
+          (display " " out) (write i out) (display ": " out)
+          (write/ss (car ls) out) (newline out)
+          (lp (cdr ls) (+ i 1))))))
+     ((pair? x)
+      (display "pair with car " out) (write/ss (car x) out) (newline out)
+      (display "and cdr " out) (write/ss (cdr x) out) (newline out))
+     ((vector? x)
+      (let ((len (vector-length x)))
+        (display "vector of length " out) (write len out) (newline out)
+        (let lp ((i 0))
+          (cond
+           ((< i len)
+            (display " " out) (write i out) (display ": " out)
+            (write/ss (vector-ref x i) out) (newline out)
+            (lp (+ i 1)))))))
+     ((boolean? x)
+      (display (if x "boolean true\n" "boolean false\n") out))
+     ((char? x)
+      (let ((n (char->integer x)))
+        (display "character " out) (write x out)
+        (display ", code: " out) (write n out)
+        (display ", #x" out) (display (number->string n 16) out)
+        (display ", #o" out) (display (number->string n 8) out)
+        (newline out)))
+     ((and (integer? x) (exact? x))
+      (display "exact integer " out) (write x out)
+      (display "\n  #x" out) (display (number->string x 16) out)
+      (display "\n  #o" out) (display (number->string x 8) out)
+      (display "\n  #b" out) (display (number->string x 2) out)
+      (newline out))
+     (else
+      (write/ss x out) (newline out)))))
+
+;;> Runs an interactive REPL.  Repeatedly displays a prompt,
+;;> then Reads an expression, Evaluates the expression, Prints
+;;> the result then Loops.  Terminates when the end of input is
+;;> reached or the \scheme|{\exit}| command is given.
+;;>
+;;> Basic Emacs-style line editing with persistent history
+;;> completion is provided.  C-c can be used to interrupt the
+;;> current computation and drop back to the prompt.  The
+;;> following keyword arguments customize the REPL:
+;;>
+;;> \itemlist[
+;;> \item{\scheme{in:} - the input port (default \scheme{(current-input-port)})}
+;;> \item{\scheme{out:} - the output port (default \scheme{(current-output-port)})}
+;;> \item{\scheme{module:} - the initial module}
+;;> \item{\scheme{environment:} - the initial environment (default \scheme{(interaction-environment)})}
+;;> \item{\scheme{escape:} - the command escape character (default \scheme|{#\\}|)}
+;;> \item{\scheme{make-prompt:} - a procedure taking one argument (the current module name as a list) and returning a string to be used as the prompt}
+;;> \item{\scheme{history:} - the initial command history}
+;;> \item{\scheme{history-file:} - the file to save history to (default ~/.chibi-repl-history)}
+;;> ]
+;;>
+;;> The module: and environment: keyword arguments should not both be given.
+;;>
+;;> REPL commands in the style of \hyperlink["http://s48.org/"]{Scheme48}
+;;> are available to control out-of-band properties.  By default a
+;;> command is written as an identifier beginning with an "@"
+;;> character, but this can be customized with the \scheme{escape:}
+;;> keyword.  The following commands are available:
+;;>
+;;> \itemlist[
+;;> \item{\scheme|{\import <import-spec>}| - import the \var{<import-spec>} in the \scheme{interaction-environment}, useful if the \scheme{import} binding is not available}
+;;> \item{\scheme|{\import-only <import-spec>}| - replace the \scheme{interaction-environment} with the given \var{<import-spec>}}
+;;> \item{\scheme|{\in [<module>]}| - switch to \var{<module>}, or the \scheme{interaction-environment} if \var{<module>} is not specified}
+;;> \item{\scheme|{\meta <expr>}| - evaluate \var{<expr>} in the \scheme{(meta)} module}
+;;> \item{\scheme|{\meta-module-is <module>}| - switch the meta module to \var{<module>}}
+;;> \item{\scheme|{\exit}| - exit the REPL}
+;;> ]
+
+(define-record-type Repl
+  (make-repl
+   in out escape module env meta-env make-prompt history-file history raw?)
+  repl?
+  (in repl-in repl-in-set!)
+  (out repl-out repl-out-set!)
+  (escape repl-escape repl-escape-set!)
+  (module repl-module repl-module-set!)
+  (env repl-env repl-env-set!)
+  (meta-env repl-meta-env  repl-meta-env-set!)
+  (make-prompt repl-make-prompt repl-make-prompt-set!)
+  (history-file repl-history-file repl-history-file-set!)
+  (history repl-history repl-history-set!)
+  (raw? repl-raw? repl-raw?-set!))
+
+(define (repl/import-aux rp args meta continue only?)
+  (let* ((mod-name (cadr args))
+         (mod+imps (eval `(resolve-import ',mod-name) (repl-meta-env rp))))
+    (cond
+     ((pair? mod+imps)
+      (protect
+          (exn
+           (else
+            (print-exception exn (current-error-port))
+            (warn "error loading module:" mod-name)
+            (continue rp)))
+        (let ((env (if only? (make-environment) (repl-env rp)))
+              (imp-env
+               (module-env
+                (eval `(load-module ',(car mod+imps)) (repl-meta-env rp)))))
+          (%import env imp-env (cdr mod+imps) #f)
+          (repl-env-set! rp env)
+          (continue rp))))
+     (else
+      (warn "couldn't find module:" mod-name)
+      (continue rp)))))
+
+(define (repl/import rp args meta continue)
+  (repl/import-aux rp args meta continue #f))
+
+(define (repl/import-only rp args meta continue)
+  (repl/import-aux rp args meta continue #t))
+
+(define (repl/in rp args meta continue)
+  (cond
+   ((null? (cdr args))
+    (repl-module-set! rp #f)
+    (repl-env-set! rp (interaction-environment)))
+   ((eval `(load-module ',(cadr args)) (repl-meta-env rp))
+    => (lambda (m)
+         (repl-module-set! rp (cadr args))
+         (repl-env-set! rp (module-env m))))
+   (else
+    (warn "couldn't find module:" (cadr args))))
+  (continue rp))
+
+(define (repl/meta rp args meta continue)
+  (cond
+   ((null? (cdr args))
+    (warn "usage: @meta <expr>")
+    (continue rp))
+   ((and (symbol? (cadr args))
+         (eqv? (repl-escape rp) (string-ref (symbol->string (cadr args)) 0)))
+    (meta rp (cdr args) (lambda _ (continue rp))))
+   (else
+    (eval (cadr args) (repl-meta-env rp))
+    (continue rp))))
+
+(define (repl/meta-module-is rp args meta continue)
+  (cond
+   ((null? (cdr args))
+    (warn "usage: @meta-module-is <module>"))
+   ((eval `(load-module ',(cadr args)) (repl-meta-env rp))
+    => (lambda (m) (repl-meta-env-set! rp (module-env m))))
+   (else
+    (warn "couldn't find module:" (cadr args))))
+  (continue rp))
+
+(define (repl/help rp args meta continue)
+  (let ((out (repl-out rp)))
+    (cond
+     ((null? (cdr args))
+      (display "Try @help <identifier> [<module>]\n" out))
+     ((null? (cddr args))
+      (let* ((failed (list 'failed))
+             (val (protect (exn (else (print-exception exn) failed))
+                    (eval (second args) (repl-env rp))))
+             (mod (and (procedure? val) (containing-module val))))
+        (cond
+         (mod
+          (write val out) (newline out) (newline out)
+          (print-module-binding-docs (car mod) (second args) out))
+         ((not (eq? val failed))
+          (describe val out)))))
+     (else
+      (protect (exn (else (print-exception exn (current-error-port))))
+        (print-module-binding-docs (third args) (second args) out))))
+    (continue rp)))
+
+(define (repl/exit rp args meta continue)
+  ;; To exit the repl simply don't call continue.
+  #f)
+
+;; Utility to read all objects from a port accumulated into a list.
+(define (read/ss/all port)
+  (let loop ((l '()))
+    (let ((x (read/ss port)))
+      (if (eof-object? x)
+        (reverse l)
+        (loop (cons x l))))))
+
+(define (string->sexp-list str)
+  (call-with-input-string str read/ss/all))
+
+;; Utility to provide additional help for common exceptions.
+(define (repl-advise-exception exn out)
+  (cond
+   ((and (exception? exn)
+         (equal? "undefined variable" (exception-message exn))
+         (pair? (exception-irritants exn)))
+    (let ((name (car (exception-irritants exn))))
+      (cond
+       ((identifier? name)
+        (display "Searching for modules exporting " out)
+        (display name out)
+        (display " ...\n" out)
+        (let ((mods (modules-exporting-identifier name)))
+          (cond
+           ((pair? mods)
+            (display name out)
+            (display " is exported by:\n")
+            (for-each
+             (lambda (m)
+               (display "  " out) (write m out) (newline out))
+             (sort (map car mods)
+                   (lambda (a b)
+                     (string<? (write-to-string a) (write-to-string b))))))
+           (else
+            (display "... none found.\n"))))))))))
+
+(define (repl/eval rp expr-list)
+  (let ((out (repl-out rp)))
+    (protect (exn (else (print-exception exn out)))
+      (let ((thread
+             (make-thread
+              (lambda ()
+                ;; The inner protect in the child thread catches errors
+                ;; from eval.
+                (protect (exn
+                          (else
+                           (print-exception exn out)
+                           (repl-advise-exception exn (current-error-port))))
+                  (for-each
+                   (lambda (expr)
+                     (call-with-values (lambda () (eval expr (repl-env rp)))
+                       (lambda res-list
+                         (cond
+                          ((not (or (null? res-list)
+                                    (equal? res-list (list (if #f #f)))))
+                           (write/ss (car res-list) out)
+                           (for-each
+                            (lambda (res)
+                              (write-char #\space out)
+                              (write/ss res out))
+                            (cdr res-list))
+                           (newline out))))))
+                   expr-list))))))
+        ;; If an interrupt occurs while the child thread is
+        ;; still running, terminate it, otherwise wait for it
+        ;; to complete.
+        (with-signal-handler
+         signal/interrupt
+         (lambda (n)
+           (display "\nInterrupt\n" out)
+           (thread-terminate! thread))
+         (lambda () (thread-join! (thread-start! thread))))))))
+
+(define (repl/eval-string rp str)
+  (repl/eval
+   rp
+   (protect (exn (else (print-exception exn (current-error-port))))
+     ;; Ugly wrapper to account for the implicit state mutation
+     ;; implied by the #!fold-case read syntax.
+     (let ((in (repl-in rp))
+           (in2 (open-input-string str)))
+       (set-port-fold-case! in2 (port-fold-case? in))
+       (set-port-line! in2 (port-line in))
+       (let ((expr-list (read/ss/all in2)))
+         (set-port-fold-case! in (port-fold-case? in2))
+         expr-list)))))
+
+(define (keywords->repl ls)
+  (let-keywords* ls
+      ((in in: (current-input-port))
+       (out out: (current-output-port))
+       (escape escape: #\@)
+       (module module: #f)
+       (env
+        environment:
+        (if module
+            (module-env
+             (if (module? module) module (load-module module)))
+            (interaction-environment)))
+       (make-prompt
+        make-prompt:
+        (lambda (module)
+          (string-append (if module (write-to-string module) "") "> ")))
+       (history-file
+        history-file:
+        (string-append (get-environment-variable "HOME")
+                       "/.chibi-repl-history"))
+       (history
+        history:
+        (or (protect (exn (else #f))
+              (list->history (call-with-input-file history-file read)))
+            (make-history)))
+       (raw? raw?:
+             (member (get-environment-variable "TERM") '("emacs" "dumb")))
+       (meta-env meta-env: (module-env (load-module '(meta)))))
+    (make-repl
+     in out escape module env meta-env make-prompt history-file history raw?)))
+
+(define (repl/edit-line rp)
+  (let ((prompt ((repl-make-prompt rp) (repl-module rp)))
+        (in (repl-in rp))
+        (out (repl-out rp)))
+    (cond
+     ((repl-raw? rp)
+      (display prompt out)
+      (flush-output out)
+      (read-line/complete-sexp in))
+     (else
+      (edit-line in out
+                 'prompt: prompt
+                 'history: (repl-history rp)
+                 'complete?: buffer-complete-sexp?
+                 'completion: (make-sexp-buffer-completer)
+                 'catch-control-c?: #t
+                 'fresh-line: " \x1B;[33m\\\x1B;[0m")))))
+
+(define repl-commands
+  `((import . ,repl/import)
+    (import-only . ,repl/import-only)
+    (in . ,repl/in)
+    (meta . ,repl/meta)
+    (meta-module-is . ,repl/meta-module-is)
+    (? . ,repl/help)
+    (h . ,repl/help)
+    (help . ,repl/help)
+    (exit . ,repl/exit)))
+
+(define (repl . o)
+  (let ((rp (keywords->repl o)))
+    (let lp ((rp rp))
+      (let ((line (repl/edit-line rp)))
+        (cond
+         ((or (not line) (eof-object? line)))
+         ((equal? line "")
+          (history-reset! (repl-history rp))
+          (lp rp))
+         (else
+          (history-commit! (repl-history rp) line)
+          (cond
+           ((and (> (string-length line) 1)
+                 (eqv? (repl-escape rp) (string-ref line 0)))
+            ;; @ escaped command
+            (let meta ((rp rp)
+                       (args (string->sexp-list (substring line 1)))
+                       (continue lp))
+              (cond
+               ((null? args)
+                (warn "empty repl command")
+                (continue rp))
+               ((assq (car args) repl-commands)
+                => (lambda (x) ((cdr x) rp args meta continue)))
+               (else
+                (warn "unknown repl command" (car args))
+                (continue rp)))))
+           (else
+            ;; Normal expression to eval.
+            (repl/eval-string rp line)
+            (lp rp)))))))
+    ;; Update the history file on completion.
+    (if (repl-history-file rp)
+        (protect
+            (exn
+             (else
+              (let ((msg (integer->error-string)))
+                (display "couldn't save repl history: " (current-error-port))
+                (display msg (current-error-port))
+                (newline (current-error-port)))))
+          (call-with-output-file (repl-history-file rp)
+            (lambda (out) (write (history->list (repl-history rp)) out)))))))
+
+(define (main args)
+  (repl))
diff --git a/lib/chibi/repl.sld b/lib/chibi/repl.sld
new file mode 100644
index 00000000..0b280691
--- /dev/null
+++ b/lib/chibi/repl.sld
@@ -0,0 +1,9 @@
+
+(define-library (chibi repl)
+  (export repl)
+  (import (chibi) (only (meta) load-module)
+          (chibi ast) (chibi modules) (chibi doc)
+          (chibi string) (chibi io) (chibi optional)
+          (chibi process) (chibi term edit-line)
+          (srfi 1) (srfi 9) (srfi 18) (srfi 38) (srfi 95) (srfi 98))
+  (include "repl.scm"))
diff --git a/lib/chibi/scribble.scm b/lib/chibi/scribble.scm
new file mode 100644
index 00000000..f005222e
--- /dev/null
+++ b/lib/chibi/scribble.scm
@@ -0,0 +1,257 @@
+;; scribble.scm - scribble parsing
+;; Copyright (c) 2011 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> A library used for parsing "scribble" format, introduced by
+;;> \hyperlink["http://www.racket-lang.org/"]{Racket} and the format
+;;> used to write this manual.  The default escape character is
+;;> backslash as in TeX instead of @ as in Racket, though this can be
+;;> overridden.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; general character utils
+
+(define (char-mirror ch)
+  (case ch ((#\() #\)) ((#\[) #\]) ((#\{) #\}) ((#\<) #\>) (else ch)))
+
+(define (char-delimiter? ch)
+  (or (eof-object? ch) (char-whitespace? ch)
+      (memv ch '(#\( #\) #\[ #\] #\{ #\} #\" #\|))))
+
+(define (char-punctuation? ch)
+  (memv ch '(#\- #\+ #\! #\< #\> #\[ #\] #\|)))
+
+(define (char-digit ch) (- (char->integer ch) (char->integer #\0)))
+
+(define default-ecape-char #\\)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; list utils
+
+(define (drop ls n) (if (<= n 0) ls (drop (cdr ls) (- n 1))))
+
+(define (drop-while pred ls)
+  (if (or (null? ls) (not (pred (car ls)))) ls (drop-while pred (cdr ls))))
+
+(define (list-prefix? prefix ls)
+  (cond ((null? prefix) #t)
+        ((null? ls) #f)
+        ((equal? (car prefix) (car ls)) (list-prefix? (cdr prefix) (cdr ls)))
+        (else #f)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; scribble reader (standalone, don't use the native reader)
+
+(define scribble-dot (list "."))
+(define scribble-close (list ")"))
+
+(define (if-peek-char ch in pass fail)
+  (cond ((eqv? ch (peek-char in)) (read-char in) pass) (else fail)))
+
+(define (skip-line in)
+  (do ((c #f (read-char in))) ((or (eof-object? c) (eqv? c #\newline)))))
+
+(define (read-float-tail in acc)
+  (let lp ((res acc) (k 0.1))
+    (let ((ch (read-char in)))
+      (cond ((or (eof-object? ch) (char-delimiter? ch)) res)
+            ((char-numeric? ch) (lp (+ res (* k (char-digit ch))) (* k 0.1)))
+            (else (error "invalid numeric syntax"))))))
+
+(define (read-number in acc base)
+  (let lp ((acc acc))
+    (let ((ch (peek-char in)))
+      (cond
+       ((or (eof-object? ch) (char-delimiter? ch)) acc)
+       ((char-numeric? ch) (read-char in) (lp (+ (* acc base) (char-digit ch))))
+       ((eqv? #\. ch)
+        (read-char in)
+        (if (= base 10)
+            (begin (read-char in) (read-float-tail in (exact->inexact acc)))
+            (error "non-base-10 floating point")))
+       (else (error "invalid numeric syntax"))))))
+
+(define (read-escaped in terminal)
+  (let lp ((ls '()))
+    (let ((ch (read-char in)))
+      (cond
+       ((or (eof-object? ch) (eqv? ch terminal)) (list->string (reverse ls)))
+       ((eqv? ch #\\) (lp (cons (read-char in) ls)))
+       (else (lp (cons ch ls)))))))
+
+(define (read-symbol in ls)
+  (do ((ls ls (cons c ls)) (c (peek-char in) (peek-char in)))
+      ((char-delimiter? c) (string->symbol (list->string (reverse ls))))
+    (read-char in)))
+
+(define (scrib-read in . o)
+  (define ch (read-char in))
+  (define ec (if (pair? o) (car o) default-ecape-char))
+  (cond
+   ((eof-object? ch) ch)
+   ((char-whitespace? ch) (scrib-read in))
+   ((eqv? ch ec)
+    (scribble-parse-escape in ec))
+   (else
+    (case ch
+      ((#\( #\[ #\{)
+       (let lp ((res '()))
+         (let ((x (scrib-read in)))
+           (cond ((eof-object? x) (error "unterminated list" x))
+                 ((eq? x scribble-close) (reverse res))
+                 ((eq? x scribble-dot)
+                  (let ((y (scrib-read in)))
+                    (if (or (eof-object? y) (eq? y scribble-close))
+                        (error "unterminated dotted list")
+                        (let ((z (scrib-read in)))
+                          (if (not (eq? z scribble-close))
+                              (error "dot in non-terminal position in list" y z)
+                              (append (reverse res) y))))))
+                 (else (lp (cons x res)))))))
+      ((#\} #\] #\)) scribble-close)
+      ((#\.) (if (char-delimiter? (peek-char in)) scribble-dot (read-float-tail in 0.0)))
+      ((#\') (list 'quote (scrib-read in)))
+      ((#\`) (list 'quasiquote (scrib-read in)))
+      ((#\,) (list (if-peek-char #\@ in 'unquote-splicing 'unquote) (scrib-read in)))
+      ((#\;) (skip-line in) (scrib-read in))
+      ((#\|) (string->symbol (read-escaped in #\|)))
+      ((#\") (read-escaped in #\"))
+      ((#\+ #\-)
+       (cond ((char-numeric? (peek-char in))
+              ((if (eqv? ch #\+) + -) 0 (read-number in 0 10)))
+             (else (read-symbol in (list ch)))))
+      ((#\#)
+       (case (peek-char in)
+         ((#\t #\f) (eqv? (read-char in) #\t))
+         ((#\() (list->vector (scrib-read in)))
+         ((#\\)
+          (read-char in)
+          (if (char-alphabetic? (peek-char in))
+              (let ((name (scrib-read in)))
+                (case name
+                  ((space) #\space) ((newline) #\newline)
+                  (else (string-ref (symbol->string name) 0))))
+              (read-char in)))
+         (else (error "unknown # syntax"))))
+      (else
+       (if (char-numeric? ch)
+           (read-number in (char-digit ch) 10)
+           (read-symbol in (list ch))))))))
+
+(define (scribble-read in . o)
+  (let ((res (scrib-read in (if (pair? o) (car o) default-ecape-char))))
+    (cond ((eq? res scribble-dot) (error "invalid . in source"))
+          ((eq? res scribble-close) (error "too many )'s"))
+          (else res))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; scribble parser
+
+(define (read-punctuation in)
+  (if (not (eqv? #\| (peek-char in)))
+      '()
+      (let lp ((ls '()))
+        (let ((c (peek-char in)))
+          (cond ((or (eof-object? c) (not(char-punctuation? c))) ls)
+                (else (lp (cons (char-mirror (read-char in)) ls))))))))
+
+(define (read-prefix-wrapper in)
+  (let lp ((wrap (lambda (x) x)))
+    (case (peek-char in)
+      ((#\') (read-char in) (lp (lambda (x) (wrap (list 'quote x)))))
+      ((#\`) (read-char in) (lp (lambda (x) (wrap (list 'quasiquote x)))))
+      ((#\,)
+       (read-char in)
+       (cond ((eqv? #\@ (peek-char in))
+              (read-char in)
+              (lp (lambda (x) (wrap (list 'unquote-splicing x)))))
+             (else (lp (lambda (x) (wrap (list 'unquote x)))))))
+      (else wrap))))
+
+(define (scribble-parse-escape in ec)
+  (define bracket-char #\[)
+  (define brace-char #\{)
+  (let* ((wrap (read-prefix-wrapper in))
+         (c (peek-char in))
+         (cmd (if (or (eqv? c bracket-char) (eqv? c brace-char)) '() (list (scribble-read in ec))))
+         (data? (eqv? (peek-char in) bracket-char))
+         (data (if data? (scribble-read in ec) '()))
+         (punc (read-punctuation in))
+         (body? (eqv? (peek-char in) brace-char))
+         (body (cond (body? (read-char in) (scribble-parse in punc ec)) (else '()))))
+    (wrap (if (or data? body?) (append cmd data body) (car cmd)))))
+
+(define (scribble-parse in . o)
+  (define init-punc (if (pair? o) (car o) '()))
+  (define escape-char
+    (if (and (pair? o) (pair? (cdr o))) (cadr o) default-ecape-char))
+  (define comment-char #\;)
+  (define bracket-char #\[)
+  (define brace-char #\{)
+  (define close-bracket-char (char-mirror bracket-char))
+  (define close-brace-char (char-mirror brace-char))
+  (define (collect str res)
+    (if (pair? str) (cons (list->string (reverse str)) res) res))
+  (define (skip-space in)
+    (let ((ch (peek-char in)))
+      (cond ((char-whitespace? ch) (read-char in) (skip-space in))
+            ((eqv? ch #\;) (skip-line in) (skip-space in)))))
+  (define (tok str res punc depth)
+    (let ((c (read-char in)))
+      (cond
+        ((eof-object? c)
+         (if (zero? depth)
+             (reverse (collect str res))
+             (error "unterminated expression" punc)))
+        ((and (eqv? c escape-char) (list-prefix? punc str))
+         (let ((c (peek-char in)))
+           (cond
+            ((eof-object? c)
+             (tok str res punc depth))
+            ((char-whitespace? c)
+             (tok (cons c str) res punc depth))
+            ((eqv? c comment-char)
+             (read-char in)
+             (cond ((eqv? brace-char (peek-char in))
+                    (scribble-parse-escape in escape-char))
+                   (else
+                    (skip-line in)
+                    ;; (let lp ()
+                    ;;   (cond ((char-whitespace? (peek-char in)) (read-char in) (lp))))
+                    ))
+             (tok str res punc depth))
+            ((eqv? c #\|)
+             (read-char in)
+             (let lp ((ls (collect str res)))
+               (skip-space in)
+               (cond ((eqv? #\| (peek-char in)) (read-char in) (tok '() ls punc depth))
+                     (else (lp (cons (scribble-read in) ls))))))
+            (else
+             (let ((str (drop str (length punc)))
+                   (x (scribble-parse-escape in escape-char)))
+               (if (string? x)
+                   (tok (append (reverse (string->list x)) str) res punc depth)
+                   (tok '() (cons x (collect str res)) punc depth)))))))
+        ((eqv? c brace-char)
+         (tok (cons c str) res punc (+ depth 1)))
+        ((eqv? c close-brace-char)
+         (cond
+          ((zero? depth)
+           (let lp ((p punc) (ls '()))
+             (cond ((null? p)
+                    (reverse (collect str res)))
+                   ((not (eqv? (car p) (peek-char in)))
+                    (tok (append ls (cons c str)) res punc (- depth 1)))
+                   (else
+                    (lp (cdr p) (cons (read-char in) ls))))))
+          (else (tok (cons c str) res punc (- depth 1)))))
+        ((eqv? c #\newline)
+         (let* ((res (collect str res))
+                (res (if (and (null? res) (null? str))
+                         res
+                         (cons "\n" res))))
+           (tok '() res punc depth)))
+        (else
+         (tok (cons c str) res punc depth)))))
+  ;; begin
+  (tok '() '() init-punc 0))
diff --git a/lib/chibi/scribble.sld b/lib/chibi/scribble.sld
new file mode 100644
index 00000000..a26fb05d
--- /dev/null
+++ b/lib/chibi/scribble.sld
@@ -0,0 +1,5 @@
+
+(define-library (chibi scribble)
+  (export scribble-parse scribble-read)
+  (import (chibi))
+  (include "scribble.scm"))
diff --git a/lib/chibi/show.sld b/lib/chibi/show.sld
new file mode 100644
index 00000000..04b2dcb9
--- /dev/null
+++ b/lib/chibi/show.sld
@@ -0,0 +1,13 @@
+
+(define-library (chibi show)
+  (export
+   show fn fn-fork with update! each each-in-list call-with-output
+   displayed written written-shared written-simply numeric nothing
+   nl fl space-to tab-to
+   padded padded/left padded/right padded/both
+   trimmed trimmed/left trimmed/right trimmed/both trimmed/lazy
+   fitted fitted/left fitted/right fitted/both
+   joined joined/prefix joined/suffix joined/last joined/dot
+   upcased downcased)
+  (import (scheme base) (scheme char) (chibi show base) (scheme write))
+  (include "show/show.scm"))
diff --git a/lib/chibi/show/base.scm b/lib/chibi/show/base.scm
new file mode 100644
index 00000000..ac7f0ea7
--- /dev/null
+++ b/lib/chibi/show/base.scm
@@ -0,0 +1,138 @@
+;; base.scm - base formatting monad
+;; Copyright (c) 2013 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> The minimal base formatting combinators and show interface.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> The environment monad with some pre-defined fields for combinator
+;;> formatting.
+
+(define-environment-monad Show-Env
+  (sequence: sequence)
+  (bind: fn)
+  (bind-fork: fn-fork)
+  (local: %with)
+  (local!: update!)
+  (return: return)
+  (run: run)
+  (fields:
+   (port env-port env-port-set!)
+   (row env-row env-row-set!)
+   (col env-col env-col-set!)
+   (width env-width env-width-set!)
+   (radix env-radix env-radix-set!)
+   (precision env-precision env-precision-set!)
+   (pad-char env-pad-char env-pad-char-set!)
+   (decimal-sep env-decimal-sep env-decimal-sep-set!)
+   (decimal-align env-decimal-align env-decimal-align-set!)
+   (string-width env-string-width env-string-width-set!)
+   (ellipsis env-ellipsis env-ellipsis-set!)
+   (writer env-writer env-writer-set!)
+   (output env-output env-output-set!)))
+
+;; The base formatting handles outputting raw strings and a simple,
+;; configurable handler for formatting objects.
+
+;; Utility - default value of string-width.
+(define (substring-length str . o)
+  (let ((start (if (pair? o) (car o) 0))
+        (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str))))
+    (- end start)))
+
+;; Raw output.  All primitive output should go through this operation.
+;; Overridable, defaulting to output-default.
+(define (output str)
+  (fn (output) ((or output output-default) str)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> \procedure{(show out [args ...])}
+;;>
+;;> Run the combinators \var{args}, accumulating the output to
+;;> \var{out}, which is either an output port or a boolean, with
+;;> \scheme{#t} indicating \scheme{current-output-port} and
+;;> \scheme{#f} to collect the output as a string.
+(define (show out . args)
+  (let ((proc (each-in-list args)))
+    (cond
+     ((output-port? out)
+      (show-run out proc))
+     ((eq? #t out)
+      (show-run (current-output-port) proc))
+     ((eq? #f out)
+      (let ((out (open-output-string)))
+        (show-run out proc) 
+        (get-output-string out)))
+     (else
+      (error "unknown output to show" out)))))
+
+;; Run with an output port with initial default values.
+(define (show-run out proc)
+  (run (sequence (update! (port out)
+                          (col 0)
+                          (row 0)
+                          (width 78)
+                          (radix 10)
+                          (pad-char #\space)
+                          (output output-default)
+                          (string-width substring-length))
+                 proc)))
+
+;;> Shortcut syntax for \scheme{(bind (...) (each ...))}.
+
+(define-syntax with
+  (syntax-rules ()
+    ((with params x) (%with params (displayed x)))
+    ((with params . x) (%with params (each . x)))))
+
+;;> The noop formatter.  Generates no output and leaves the state
+;;> unmodified.
+(define nothing (fn () (update!)))
+
+;;> Formats a displayed version of x - if a string or char, outputs the
+;;> raw characters (as with `display'), if x is already a formatter
+;;> defers to that, otherwise outputs a written version of x.
+(define (displayed x)
+  (cond
+   ((procedure? x) x)
+   ((string? x) (output x))
+   ((char? x) (output (string x)))
+   (else (written x))))
+
+;;> Formats a written version of x, as with `write'.  The formatting
+;;> can be updated with the \scheme{'writer} field.
+(define (written x)
+  (fn (writer) ((or writer written-default) x)))
+
+;;> Takes a single list of formatters, combined in sequence with
+;;> \scheme{each}.
+(define (each-in-list args)
+  (if (pair? args)
+      (sequence (displayed (car args)) (each-in-list (cdr args)))
+      nothing))
+
+;;> Combines each of the formatters in a sequence using
+;;> \scheme{displayed}, so that strings and chars will be output
+;;> directly and other objects will be \scheme{written}.
+(define (each . args)
+  (each-in-list args))
+
+;;> Raw output - displays str to the formatter output port and updates
+;;> row and col.
+(define (output-default str)
+  (fn (port row col string-width)
+    (display str port)
+    (let ((nl-index (string-find-right str #\newline)))
+      (if (> nl-index 0)
+          (update! (row (+ row (string-count str #\newline)))
+                   (col (string-width str nl-index)))
+          (update! (col (+ col (string-width str))))))))
+
+;;> Captures the output of \var{producer} and formats the result with
+;;> \var{consumer}.
+(define (call-with-output producer consumer)
+  (let ((out (open-output-string)))
+    (fn-fork (with ((port out)) producer)
+             (fn () (consumer (get-output-string out))))))
diff --git a/lib/chibi/show/base.sld b/lib/chibi/show/base.sld
new file mode 100644
index 00000000..c56d236e
--- /dev/null
+++ b/lib/chibi/show/base.sld
@@ -0,0 +1,12 @@
+
+(define-library (chibi show base)
+  (export
+   show fn fn-fork with update! each each-in-list call-with-output
+   displayed written written-shared written-simply numeric nothing
+   ;; internal
+   output-default extract-shared-objects write-to-string write-with-shares
+   call-with-shared-ref call-with-shared-ref/cdr)
+  (import (scheme base) (scheme write) (scheme complex) (scheme inexact)
+          (srfi 1) (srfi 69) (chibi string) (chibi monad environment))
+  (include "base.scm")
+  (include "write.scm"))
diff --git a/lib/chibi/show/pretty.scm b/lib/chibi/show/pretty.scm
new file mode 100644
index 00000000..7312d94a
--- /dev/null
+++ b/lib/chibi/show/pretty.scm
@@ -0,0 +1,357 @@
+;; pretty.scm -- pretty printing format combinator
+;; Copyright (c) 2006-2013 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utilities
+
+(define (take* ls n)   ; handles dotted lists and n > length
+  (cond ((zero? n) '())
+        ((pair? ls) (cons (car ls) (take* (cdr ls) (- n 1))))
+        (else '())))
+
+(define (drop* ls n)   ; may return the dot
+  (cond ((zero? n) ls)
+        ((pair? ls) (drop* (cdr ls) (- n 1)))
+        (else ls)))
+
+(define (make-space n) (make-string n #\space))
+(define (make-nl-space n) (string-append "\n" (make-string n #\space)))
+
+(define (joined/shares fmt ls shares . o)
+  (let ((sep (displayed (if (pair? o) (car o) " "))))
+    (fn ()
+      (if (null? ls)
+          nothing
+          (let lp ((ls ls))
+            (each
+             (fmt (car ls))
+             (let ((rest (cdr ls)))
+               (cond
+                ((null? rest) nothing)
+                ((pair? rest)
+                 (call-with-shared-ref/cdr rest
+                                           shares
+                                           (fn () (lp rest))
+                                           sep))
+                (else (each sep ". " (fmt rest)))))))))))
+
+(define (try-fitted2 proc fail)
+  (fn (width string-width output)
+    (let ((out (open-output-string)))
+      (call-with-current-continuation
+       (lambda (abort)
+         ;; Modify output to accumulate to an output string port,
+         ;; and escape immediately with failure if we exceed the
+         ;; column width.
+         (define (output* str)
+           (fn (col)
+             (let lp ((i 0) (col col))
+               (let ((nli (string-find str #\newline i))
+                     (len (string-width str)))
+                 (if (< nli len)
+                     (if (> (+ (- nli i) col) width)
+                         (abort fail)
+                         (lp (+ nli 1) 0))
+                     (let ((col (+ (- len i) col)))
+                       (cond
+                        ((> col width)
+                         (abort fail))
+                        (else
+                         (output str)))))))))
+         (fn-fork
+          (with ((output output*)
+                 (port out))
+            proc)
+          ;; fitted successfully
+          (output (get-output-string out))))))))
+
+(define (try-fitted proc . fail)
+  (if (null? fail)
+      proc
+      (try-fitted2 proc (apply try-fitted fail))))
+
+(define (fits-in-width width proc)
+  (call-with-current-continuation
+   (lambda (abort)
+     (show
+      #f
+      (fn (output)
+        (define (output* str)
+          (each (output str)
+                (fn (col)
+                  (if (>= col width)
+                      (abort #f)
+                      nothing))))
+        (with ((output output*))
+          proc))))))
+
+(define (fits-in-columns width ls writer)
+  (let ((max-w (quotient width 2)))
+    (let lp ((ls ls) (res '()) (widest 0))
+      (cond
+       ((pair? ls)
+        (let ((str (fits-in-width max-w (writer (car ls)))))
+          (and str
+               (lp (cdr ls)
+                   (cons str res)
+                   (max (string-length str) widest)))))
+       ((null? ls) (cons widest (reverse res)))
+       (else #f)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; style
+
+(define syntax-abbrevs
+  '((quote . "'") (quasiquote . "`")
+    (unquote . ",") (unquote-splicing . ",@")
+    ))
+
+(define (pp-let ls pp shares)
+  (if (and (pair? (cdr ls)) (symbol? (cadr ls)))
+      (pp-with-indent 2 ls pp shares)
+      (pp-with-indent 1 ls pp shares)))
+
+(define indent-rules
+  `((lambda . 1) (define . 1)
+    (let . ,pp-let) (loop . ,pp-let)
+    (let* . 1) (letrec . 1) (letrec* . 1) (and-let* . 1) (let1 . 2)
+    (let-values . 1) (let*-values . 1) (receive . 2) (parameterize . 1)
+    (let-syntax . 1) (letrec-syntax . 1) (syntax-rules . 1) (syntax-case . 2)
+    (match . 1) (match-let . 1) (match-let* . 1)
+    (if . 3) (when . 1) (unless . 1) (case . 1) (while . 1) (until . 1)
+    (do . 2) (dotimes . 1) (dolist . 1) (test . 1)
+    (condition-case . 1) (guard . 1) (rec . 1)
+    (call-with-current-continuation . 0)
+    ))
+
+(define indent-prefix-rules
+  `(("with-" . -1) ("call-with-" . -1) ("define-" . 1))
+  )
+
+(define indent-suffix-rules
+  `(("-case" . 1))
+  )
+
+(define (pp-indentation form)
+  (let ((indent
+         (cond
+          ((assq (car form) indent-rules) => cdr)
+          ((and (symbol? (car form))
+                (let ((str (symbol->string (car form))))
+                  (or (find (lambda (rx) (string-prefix? (car rx) str))
+                            indent-prefix-rules)
+                      (find (lambda (rx) (string-suffix? (car rx) str))
+                            indent-suffix-rules))))
+           => cdr)
+          (else #f))))
+    (if (and (number? indent) (negative? indent))
+        (max 0 (- (+ (length+ form) indent) 1))
+        indent)))
+
+(define (with-reset-shares shares proc)
+  (let ((orig-count (cdr shares)))
+    (fn ()
+      (let ((new-count (cdr shares)))
+        (cond
+         ((> new-count orig-count)
+          (hash-table-walk
+           (car shares)
+           (lambda (k v)
+             (if (and (cdr v) (>= (car v) orig-count))
+                 (set-cdr! v #f))))
+          (set-cdr! shares orig-count)))
+        proc))))
+
+(define (pp-with-indent indent-rule ls pp shares)
+  (fn ((col1 col))
+    (each
+     "("
+     (pp (car ls))
+     (fn ((col2 col) width string-width)
+       (let ((fixed (take* (cdr ls) (or indent-rule 1)))
+             (tail (drop* (cdr ls) (or indent-rule 1)))
+             (default
+               (let ((sep (make-nl-space (+ col1 1))))
+                 (each sep (joined/shares pp (cdr ls) shares sep))))
+             ;; reset in case we don't fit on the first line
+             (reset-shares (with-reset-shares shares nothing)))
+         (call-with-output
+          (each " "
+                (joined/shares
+                 (lambda (x) (pp-flat x pp shares)) fixed shares " "))
+          (lambda (first-line)
+            (cond
+             ((< (+ col2 (string-width first-line)) width)
+              ;; fixed values on first line
+              (let ((sep (make-nl-space
+                          (if indent-rule (+ col1 2) (+ col2 1)))))
+                (each first-line
+                      (cond
+                       ((not (or (null? tail) (pair? tail)))
+                        (each ". " (pp tail pp shares)))
+                       ((> (length+ (cdr ls)) (or indent-rule 1))
+                        (each sep (joined/shares pp tail shares sep)))
+                       (else
+                        nothing)))))
+             (indent-rule
+              ;; fixed values lined up, body indented two spaces
+              (try-fitted
+               (each
+                reset-shares
+                " "
+                (joined/shares pp fixed shares (make-nl-space (+ col2 1)))
+                (if (pair? tail)
+                    (let ((sep (make-nl-space (+ col1 2))))
+                      (each sep (joined/shares pp tail shares sep)))
+                    nothing))
+               (each reset-shares default)))
+             (else
+              ;; all on separate lines
+              (each reset-shares default)))))))
+     ")")))
+
+(define (pp-app ls pp shares)
+  (let ((indent-rule (pp-indentation ls)))
+    (if (procedure? indent-rule)
+        (indent-rule ls pp shares)
+        (pp-with-indent indent-rule ls pp shares))))
+
+;; the elements may be shared, just checking the top level list
+;; structure
+(define (proper-non-shared-list? ls shares)
+  (let ((tab (car shares)))
+    (let lp ((ls ls))
+      (or (null? ls)
+          (and (pair? ls)
+               (not (hash-table-ref/default tab ls #f))
+               (lp (cdr ls)))))))
+
+(define (non-app? x)
+  (if (pair? x)
+      (or (not (or (null? (cdr x)) (pair? (cdr x))))
+          (non-app? (car x)))
+      (not (symbol? x))))
+
+(define (pp-data-list ls pp shares)
+  (each
+   "("
+   (fn (col width string-width)
+     (let ((avail (- width col)))
+       (cond
+        ;; ((and (pair? (cdr ls)) (pair? (cddr ls)) (pair? (cdr (cddr ls)))
+        ;;       (fits-in-columns width ls (lambda (x) (pp-flat x pp shares))))
+        ;;  => (lambda (ls)
+        ;;       ;; at least four elements which can be broken into columns
+        ;;       (let* ((prefix (make-nl-space col))
+        ;;              (widest (+ 1 (car ls)))
+        ;;              (columns (quotient width widest))) ; always >= 2
+        ;;         (let lp ((ls (cdr ls)) (i 1))
+        ;;           (cond
+        ;;            ((null? ls)
+        ;;             nothing)
+        ;;            ((null? (cdr ls))
+        ;;             (displayed (car ls)))
+        ;;            ((>= i columns)
+        ;;             (each (car ls)
+        ;;                   prefix
+        ;;                   (fn () (lp (cdr ls) 1))))
+        ;;            (else
+        ;;             (let ((pad (- widest (string-width (car ls)))))
+        ;;               (each (car ls)
+        ;;                     (make-space pad)
+        ;;                     (lp (cdr ls) (+ i 1))))))))))
+        (else
+         ;; no room, print one per line
+         (joined/shares pp ls shares (make-nl-space col))))))
+   ")"))
+
+(define (pp-flat x pp shares)
+  (cond
+   ((pair? x)
+    (cond
+     ((and (pair? (cdr x)) (null? (cddr x))
+           (assq (car x) syntax-abbrevs))
+      => (lambda (abbrev)
+           (each (cdr abbrev)
+                 (call-with-shared-ref
+                  (cadr x)
+                  shares
+                  (pp-flat (cadr x) pp shares)))))
+     (else
+      (each "("
+            (joined/shares (lambda (x) (pp-flat x pp shares)) x shares " ")
+            ")"))))
+   ((vector? x)
+    (each "#("
+          (joined/shares
+           (lambda (x) (pp-flat x pp shares)) (vector->list x) shares " ")
+          ")"))
+   (else
+    (pp x))))
+
+(define (pp-pair ls pp shares)
+  (cond
+   ;; one element list, no lines to break
+   ((null? (cdr ls))
+    (each "(" (pretty (car ls)) ")"))
+   ;; quote or other abbrev
+   ((and (pair? (cdr ls)) (null? (cddr ls))
+         (assq (car ls) syntax-abbrevs))
+    => (lambda (abbrev)
+         (each (cdr abbrev) (pp (cadr ls)))))
+   (else
+    (try-fitted
+     (fn () (pp-flat ls pp shares))
+     (with-reset-shares
+      shares
+      (fn ()
+        (if (and (non-app? ls)
+                 (proper-non-shared-list? ls shares))
+            (pp-data-list ls pp shares)
+            (pp-app ls pp shares))))))))
+
+(define (pp-vector vec pp shares)
+  (each "#" (pp-data-list (vector->list vec) pp shares)))
+
+;; adapted from `write-with-shares'
+(define (pp obj shares)
+  (fn (radix precision)
+    (let ((write-number
+           (cond
+            ((and (not precision)
+                  (assv radix '((16 . "#x") (10 . "") (8 . "#o") (2 . "#b"))))
+             => (lambda (cell)
+                  (lambda (n)
+                    (if (or (exact? n) (eqv? radix 10))
+                        (each (cdr cell) (number->string n (car cell)))
+                        (with ((radix 10)) (numeric n))))))
+            (else (lambda (n) (with ((radix 10)) (numeric n)))))))
+      (let pp ((obj obj))
+        (call-with-shared-ref
+         obj shares
+         (fn ()
+           (cond
+            ((pair? obj)
+             (pp-pair obj pp shares))
+            ((vector? obj)
+             (pp-vector obj pp shares))
+            ((number? obj)
+             (write-number obj))
+            (else
+             (write-with-shares obj shares)))))))))
+
+(define (pretty obj)
+  (fn ()
+    (each (pp obj (extract-shared-objects obj #t))
+          fl)))
+
+(define (pretty-shared obj)
+  (fn ()
+    (each (pp obj (extract-shared-objects obj #f))
+          fl)))
+
+(define (pretty-simply obj)
+  (fn ()
+    (each (pp obj (extract-shared-objects #f #f))
+          fl)))
diff --git a/lib/chibi/show/pretty.sld b/lib/chibi/show/pretty.sld
new file mode 100644
index 00000000..b8b422df
--- /dev/null
+++ b/lib/chibi/show/pretty.sld
@@ -0,0 +1,8 @@
+
+(define-library (chibi show pretty)
+  (export pretty pretty-shared pretty-simply
+          joined/shares
+          )
+  (import (scheme base) (scheme write) (chibi show) (chibi show base)
+          (srfi 1) (srfi 69) (chibi string))
+  (include "pretty.scm"))
diff --git a/lib/chibi/show/show.scm b/lib/chibi/show/show.scm
new file mode 100644
index 00000000..5cf9bb50
--- /dev/null
+++ b/lib/chibi/show/show.scm
@@ -0,0 +1,299 @@
+;; show.scm -- additional combinator formatters
+;; Copyright (c) 2013 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> A library of procedures for formatting Scheme objects to text in
+;;> various ways, and for easily concatenating, composing and
+;;> extending these formatters.
+
+;;> \section{Background}
+;;>
+;;> There are several approaches to text formatting.  Building strings
+;;> to \scheme{display} is not acceptable, since it doesn't scale to
+;;> very large output.  The simplest realistic idea, and what people
+;;> resort to in typical portable Scheme, is to interleave
+;;> \scheme{display} and \scheme{write} and manual loops, but this is
+;;> both extremely verbose and doesn't compose well.  A simple concept
+;;> such as padding space can't be achieved directly without somehow
+;;> capturing intermediate output.
+;;>
+;;> The traditional approach is to use templates - typically strings,
+;;> though in theory any object could be used and indeed Emacs'
+;;> mode-line format templates allow arbitrary sexps.  Templates can
+;;> use either escape sequences (as in C's \cfun{printf} and
+;;> \hyperlink["http://en.wikipedia.org/wiki/Format_(Common_Lisp)"]{CL's}
+;;> \scheme{format}) or pattern matching (as in Visual Basic's
+;;> \cfun{Format},
+;;> \hyperlink["http://search.cpan.org/~dconway/Perl6-Form-0.04/Form.pm"}{Perl6's}
+;;> \cfun{form}, and SQL date formats).  The primary disadvantage of
+;;> templates is the relative difficulty (usually impossibility) of
+;;> extending them, their opaqueness, and the unreadability that
+;;> arises with complex formats.  Templates are not without their
+;;> advantages, but they are already addressed by other libraries such
+;;> as
+;;> \hyperlink["http://srfi.schemers.org/srfi-28/srfi-28.html"]{SRFI-28}
+;;> and
+;;> \hyperlink["http://srfi.schemers.org/srfi-48/srfi-48.html"]{SRFI-48}.
+;;>
+;;> This library takes a combinator approach.  Formats are nested chains
+;;> of closures, which are called to produce their output as needed.
+;;> The primary goal of this library is to have, first and foremost, a
+;;> maximally expressive and extensible formatting library.  The next
+;;> most important goal is scalability - to be able to handle
+;;> arbitrarily large output and not build intermediate results except
+;;> where necessary.  The third goal is brevity and ease of use.
+
+;;> \section{Interface}
+
+;;> \procedure{(show out [args ...])}
+;;>
+;;> The primary interface.  Analogous to CL's \scheme{format}, the first
+;;> argument is either an output port or a boolean, with \scheme{#t}
+;;> indicating \scheme{current-output-port} and \scheme{#f} indicating a
+;;> string port.  The remaining arguments are formatters, combined as with
+;;> \scheme{each}, run with output to the given destination.  If \var{out}
+;;> is \scheme{#f} then the accumulated output is returned, otherwise
+;;> the result is unspecified.
+
+;;> \section{Formatters}
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Spacing
+
+;;> Output a single newline.
+(define nl (displayed "\n"))
+
+;;> "Fresh line" - output a newline iff we're not at the start of a
+;;> fresh line.
+(define fl
+  (fn (col) (if (zero? col) nothing nl)))
+
+;;> Move to a given tab-stop (using spaces, not tabs).
+(define (tab-to . o)
+  (fn (col pad-char)
+    (let* ((tab-width (if (pair? o) (car o) 8))
+           (rem (modulo col tab-width)))
+      (if (positive? rem)
+          (displayed (make-string (- tab-width rem) pad-char))
+          nothing))))
+
+;;> Move to an explicit column.
+(define (space-to where)
+  (fn (col pad-char)
+    (displayed (make-string (max 0 (- where col)) pad-char))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; String transformations
+
+(define (with-string-transformer proc . ls)
+  (fn (output)
+    (let ((output* (lambda (str) (fn () (output (proc str))))))
+      (with ((output output*)) (each-in-list ls)))))
+
+;;> Show each of \var{ls}, uppercasing all generated text.
+(define (upcased . ls) (apply with-string-transformer string-upcase ls))
+
+;;> Show each of \var{ls}, lowercasing all generated text.
+(define (downcased . ls) (apply with-string-transformer string-downcase ls))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Padding and trimming
+
+;;> Pad the result of \scheme{(each-in-list ls)} to at least
+;;> \var{width} characters, equally applied to the left and right,
+;;> with any extra odd padding applied to the right.  Uses the value
+;;> of \scheme{pad-char} for padding, defaulting to \scheme{#\\space}.
+(define (padded/both width . ls)
+  (call-with-output
+   (each-in-list ls)
+   (lambda (str)
+     (fn (string-width pad-char)
+       (let ((diff (- width (string-width str))))
+         (if (positive? diff)
+             (let* ((diff/2 (quotient diff 2))
+                    (left (make-string diff/2 pad-char))
+                    (right (if (even? diff)
+                               left
+                               (make-string (+ 1 diff/2) pad-char))))
+               (each right str left))
+             (displayed str)))))))
+
+;;> As \scheme{padded/both} but only applies padding on the right.
+(define (padded width . ls)
+  (fn ((col1 col))
+    (each (each-in-list ls)
+          (fn ((col2 col) pad-char)
+            (displayed (make-string (max 0 (- width (- col2 col1)))
+                                    pad-char))))))
+
+;;> An alias for \scheme{padded}.
+(define padded/right padded)
+
+;;> As \scheme{padded/both} but only applies padding on the left.
+(define (padded/left width . ls)
+  (call-with-output
+   (each-in-list ls)
+   (lambda (str)
+     (fn (string-width pad-char)
+       (let ((diff (- width (string-width str))))
+         (each (make-string diff pad-char) str))))))
+
+;; General buffered trim - capture the output apply a trimmer.
+(define (trimmed/buffered width producer proc)
+  (call-with-output
+   producer
+   (lambda (str)
+     (fn (string-width)
+       (let* ((str-width (string-width str))
+              (diff (- str-width width)))
+         (displayed (if (positive? diff)
+                        (proc str str-width diff)
+                        str)))))))
+
+;;> Trims the result of \scheme{(each-in-list ls)} to at most
+;;> \var{width} characters, removed from the right.  If any characters
+;;> are removed, then the value of \scheme{ellipsis} (default empty)
+;;> is used in its place (trimming additional characters as needed to
+;;> be sure the final output doesn't exceed \var{width}).
+(define (trimmed width . ls)
+  (trimmed/buffered
+   width
+   (each-in-list ls)
+   (lambda (str str-width diff)
+     (fn (ellipsis string-width col)
+       (let* ((ell (if (char? ellipsis) (string ellipsis) (or ellipsis "")))
+              (ell-len (string-width ell))
+              (diff (- (+ str-width ell-len) width)))
+         (each (if (negative? diff)
+                   nothing
+                   (substring str 0 (- width ell-len)))
+               ell))))))
+
+;;> An alias for \scheme{trimmed}.
+(define trimmed/right trimmed)
+
+;;> As \scheme{trimmed} but removes from the left.
+(define (trimmed/left width . ls)
+  (trimmed/buffered
+   width
+   (each-in-list ls)
+   (lambda (str str-width diff)
+     (fn (ellipsis string-width)
+       (let* ((ell (if (char? ellipsis) (string ellipsis) (or ellipsis "")))
+              (ell-len (string-width ell))
+              (diff (- (+ str-width ell-len) width)))
+         (each ell
+               (if (negative? diff)
+                   nothing
+                   (substring str diff))))))))
+
+;;> As \scheme{trimmed} but removes equally from both the left and the
+;;> right, removing extra odd characters from the right, and inserting
+;;> \scheme{ellipsis} on both sides.
+(define (trimmed/both width . ls)
+  (trimmed/buffered
+   width
+   (each-in-list ls)
+   (lambda (str str-width diff)
+     (fn (ellipsis string-width)
+       (let* ((ell (if (char? ellipsis) (string ellipsis) (or ellipsis "")))
+              (ell-len (string-width ell))
+              (diff (- (+ str-width ell-len ell-len) width))
+              (left (quotient diff 2))
+              (right (- (string-width str) (quotient (+ diff 1) 2))))
+         (if (negative? diff)
+             ell
+             (each ell (substring str left right) ell)))))))
+
+;;> A \scheme{trimmed}, but truncates and terminates immediately if
+;;> more than \var{width} characters are generated by \var{ls}.  Thus
+;;> \var{ls} may lazily generate an infinite amount of output safely
+;;> (e.g. \scheme{write-simple} on an infinite list).  The nature of
+;;> this procedure means only truncating on the right is meaningful.
+(define (trimmed/lazy width . ls)
+  (fn (orig-output string-width)
+    (call-with-current-continuation
+     (lambda (return)
+       (let ((chars-written 0)
+             (output (or orig-output output-default)))
+         (define (output* str)
+           (let ((len (string-width str)))
+             (set! chars-written (+ chars-written len))
+             (if (> chars-written width)
+                 (let* ((end (max 0 (- len (- chars-written width))))
+                        (s (substring str 0 end)))
+                   (each (output s)
+                         (update! (output orig-output))
+                         (fn () (return nothing))))
+                 (output str))))
+         (with ((output output*))
+           (each-in-list ls)))))))
+
+;;> Fits the result of \scheme{(each-in-list ls)} to exactly
+;;> \var{width} characters, padding or trimming on the right as
+;;> needed.
+(define (fitted width . ls)
+  (padded width (trimmed width (each-in-list ls))))
+
+;;> An alias for \scheme{fitted}.
+(define fitted/right fitted)
+
+;;> As \scheme{fitted} but pads/trims from the left.
+(define (fitted/left width . ls)
+  (padded/left width (trimmed/left width (each-in-list ls))))
+
+;;> As \scheme{fitted} but pads/trims equally from both the left and
+;;> the right.
+(define (fitted/both width . ls)
+  (padded/both width (trimmed/both width (each-in-list ls))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Joining and interspersing
+
+(define (joined/general elt-f last-f dot-f init-ls sep)
+  (fn ()
+    (let lp ((ls init-ls))
+      (cond
+       ((pair? ls)
+        (each (if (eq? ls init-ls) nothing sep)
+              ((if (and last-f (null? (cdr ls))) last-f elt-f) (car ls))
+              (lp (cdr ls))))
+       ((and dot-f (not (null? ls)))
+        (each (if (eq? ls init-ls) nothing sep) (dot-f ls)))
+       (else
+        nothing)))))
+
+;;> \procedure{(joined elt-f ls [sep])}
+;;>
+;;> Joins the result of applying \var{elt-f} to each element of the
+;;> list \var{ls} together with \var{sep}, which defaults to the empty
+;;> string.
+(define (joined elt-f ls . o)
+  (joined/general elt-f #f #f ls (if (pair? o) (car o) "")))
+
+;;> As \scheme{joined} but treats the separator as a prefix, inserting
+;;> before every element instead of between.
+(define (joined/prefix elt-f ls . o)
+  (if (null? ls)
+      nothing
+      (let ((sep (if (pair? o) (car o) "")))
+        (each sep (joined elt-f ls sep)))))
+
+;;> As \scheme{joined} but treats the separator as a suffix, inserting
+;;> after every element instead of between.
+(define (joined/suffix elt-f ls . o)
+  (if (null? ls)
+      nothing
+      (let ((sep (if (pair? o) (car o) "")))
+        (each (joined elt-f ls sep) sep))))
+
+;;> As \scheme{joined} but applies \var{last-f}, instead of
+;;> \var{elt-f}, to the last element of \var{ls}, useful for
+;;> e.g. commas separating a list with "and" before the final element.
+(define (joined/last elt-f last-f ls . o)
+  (joined/general elt-f last-f #f ls (if (pair? o) (car o) "")))
+
+;;> As \scheme{joined} but if \var{ls} is a dotted list applies
+;;> \var{dot-f} to the dotted tail as a final element.
+(define (joined/dot elt-f dot-f ls . o)
+  (joined/general elt-f #f dot-f ls (if (pair? o) (car o) "")))
diff --git a/lib/chibi/show/write.scm b/lib/chibi/show/write.scm
new file mode 100644
index 00000000..d5218a85
--- /dev/null
+++ b/lib/chibi/show/write.scm
@@ -0,0 +1,376 @@
+;; write.scm - written formatting, the default displayed for non-string/chars
+;; Copyright (c) 2006-2013 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> \section{String utilities}
+
+(define (write-to-string x)
+  (let ((out (open-output-string)))
+    (write x out)
+    (get-output-string out)))
+
+(define (string-replace-all str ch1 ch2)
+  (let ((out (open-output-string)))
+    (string-for-each
+     (lambda (ch) (write-char (if (eqv? ch ch1) ch2 ch) out))
+     str)
+    (get-output-string out)))
+
+(define (string-intersperse-right str sep rule)
+  (let lp ((i (string-length str))
+           (rule rule)
+           (res '()))
+    (let* ((offset (if (pair? rule) (car rule) rule))
+           (i2 (if offset (- i offset) 0)))
+      (if (<= i2 0)
+          (apply string-append (cons (substring str 0 i) res))
+          (lp i2
+              (if (pair? rule) (cdr rule) rule)
+              (cons sep (cons (substring str i2 i) res)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; numeric formatting
+
+(define (char-mirror c)
+  (case c ((#\() #\)) ((#\[) #\]) ((#\{) #\}) ((#\<) #\>) (else c)))
+
+(define (integer-log a base)
+  (if (zero? a)
+      0
+      (exact (ceiling (/ (log (+ a 1)) (log base))))))
+
+;; The original fmt algorithm was based on "Printing Floating-Point
+;; Numbers Quickly and Accurately" by Burger and Dybvig
+;; (FP-Printing-PLDI96.pdf).  It had grown unwieldy with formatting
+;; special cases, so the below is a simplification which tries to rely
+;; on number->string for common cases.
+
+(define (numeric n)
+  (fn (radix precision decimal-sep decimal-align comma-rule comma-sep sign-rule)
+    (let ((dec-sep (or decimal-sep (if (eqv? comma-sep #\.) #\, #\.))))
+      ;; General formatting utilities.
+      (define (get-scale q)
+        (expt radix (- (integer-log q radix) 1)))
+      (define (char-digit d)
+        (cond ((char? d) d)
+              ((< d 10) (integer->char (+ d (char->integer #\0))))
+              (else (integer->char (+ (- d 10) (char->integer #\a))))))
+      (define (digit-value ch)
+        (let ((res (- (char->integer ch) (char->integer #\0))))
+          (if (<= 0 res 9)
+              res
+              ch)))
+      (define (round-up ls)
+        (let lp ((ls ls) (res '()))
+          (cond
+           ((null? ls)
+            (cons 1 res))
+           ((not (number? (car ls)))
+            (lp (cdr ls) (cons (car ls) res)))
+           ((= (car ls) (- radix 1))
+            (lp (cdr ls) (cons 0 res)))
+           (else
+            (append (reverse res) (cons (+ 1 (car ls)) (cdr ls)))))))
+      (define (maybe-round n d ls)
+        (let* ((q (quotient n d))
+               (digit (* 2 (if (>= q radix) (quotient q (get-scale q)) q))))
+          (if (or (> digit radix)
+                  (and (= digit radix)
+                       (let ((prev (find integer? ls)))
+                         (and prev (odd? prev)))))
+              (round-up ls)
+              ls)))
+      (define (maybe-trim-zeros i res)
+        (if (and (not precision) (positive? i))
+            (let lp ((res res))
+              (cond
+               ((and (pair? res) (eqv? 0 (car res))) (lp (cdr res)))
+               ((and (pair? res) (eqv? dec-sep (car res))) (cdr res))
+               (else res)))
+            res))
+      ;; General slow loop to generate digits one at a time, for
+      ;; non-standard radixes or writing rationals with a fixed
+      ;; precision.
+      (define (gen-general n)
+        (let* ((p (exact n))
+               (n (numerator p))
+               (d (denominator p)))
+          (let lp ((n n)
+                   (i (- (integer-log p radix)))
+                   (res '()))
+            (cond
+             ;; Use a fixed precision if specified, otherwise generate
+             ;; 15 decimals.
+             ((if precision (< i precision) (< i 16))
+              (let ((res (if (zero? i)
+                             (cons dec-sep (if (null? res) (cons 0 res) res))
+                             res))
+                    (q (quotient n d)))
+                (cond
+                 ((>= q radix)
+                  (let* ((scale (get-scale q))
+                         (digit (quotient q scale))
+                         (n2 (- n (* d digit scale))))
+                    (lp n2 (+ i 1) (cons digit res))))
+                 (else
+                  (lp (* (remainder n d) radix)
+                      (+ i 1)
+                      (cons q res))))))
+             (else
+              (list->string
+               (map char-digit
+                    (reverse (maybe-round n d (maybe-trim-zeros i res))))))))))
+      ;; Generate a fixed precision decimal result by post-editing the
+      ;; result of string->number.
+      (define (gen-fixed n)
+        (cond
+         ((and (eqv? radix 10) (or (integer? n) (inexact? n)))
+          (let* ((s (number->string n))
+                 (len (string-length s))
+                 (dec (string-find s #\.))
+                 (digits (- len dec)))
+            (cond
+             ((< (string-find s #\e) len)
+              (gen-general n))
+             ((= dec len)
+              (string-append s "." (make-string precision #\0)))
+             ((<= digits precision)
+              (string-append s (make-string (- precision digits -1) #\0)))
+             (else
+              (let* ((last (- len (- digits precision 1)))
+                     (res (substring s 0 last)))
+                (if (and
+                     (< last len)
+                     (let ((next (digit-value (string-ref s last))))
+                       (or (> next 5)
+                           (and (= next 5) (> last 0)
+                                (odd? (digit-value
+                                       (string-ref s (- last 1))))))))
+                    (list->string
+                     (reverse
+                      (map char-digit
+                           (round-up
+                            (reverse (map digit-value (string->list res)))))))
+                    res))))))
+         (else
+          (gen-general n))))
+      ;; Generate any unsigned real number.
+      (define (gen-positive-real n)
+        (cond
+         (precision
+          (gen-fixed n))
+         ((and (exact? n) (not (integer? n)))
+          (string-append (number->string (numerator n) radix)
+                         "/"
+                         (number->string (denominator n) radix)))
+         ((memv radix (if (exact? n) '(2 8 10 16) '(10)))
+          (number->string n))
+         (else
+          (gen-general n))))
+      ;; Insert commas according to the current comma-rule.
+      (define (insert-commas str)
+        (let* ((dec-pos (string-find str dec-sep))
+               (left (substring str 0 dec-pos))
+               (right (substring str dec-pos))
+               (sep (cond ((char? comma-sep) (string comma-sep))
+                          ((string? comma-sep) comma-sep)
+                          ((eqv? #\, dec-sep) ".")
+                          (else ","))))
+          (string-append
+           (string-intersperse-right left sep comma-rule)
+           right)))
+      ;; Post-process a positive real number with decimal char fixup
+      ;; and commas as needed.
+      (define (wrap-comma n)
+        (let* ((s0 (gen-positive-real n))
+               (s1 (if (and (char? dec-sep)
+                            (not (eqv? #\. dec-sep)))
+                       (string-replace-all s0 #\. dec-sep)
+                       s0)))
+          (if comma-rule (insert-commas s1) s1)))
+      ;; Wrap the sign of a real number, forcing a + prefix or using
+      ;; parentheses (n) for negatives according to sign-rule.
+      (define (wrap-sign n sign-rule)
+        (cond
+         ((negative? n)
+          (if (char? sign-rule)
+              (string-append (string sign-rule)
+                             (wrap-comma (abs n))
+                             (string (char-mirror sign-rule)))
+              (string-append "-" (wrap-comma (abs n)))))
+         ((eq? #t sign-rule)
+          (string-append "+" (wrap-comma n)))
+         (else
+          (wrap-comma n))))
+      ;; Format a single real number with padding as necessary.
+      (define (format n sign-rule)
+        (let ((s (wrap-sign n sign-rule)))
+          (let* ((dec-pos (if decimal-align (string-find s dec-sep) 0))
+                 (diff (- (or decimal-align 0) dec-pos 1)))
+            (if (positive? diff)
+                (string-append (make-string diff #\space) s)
+                s))))
+      ;; Write any number.
+      (define (write-complex n)
+        (cond
+         ((and radix (not (and (integer? radix) (<= 2 radix 36))))
+          (error "invalid radix for numeric formatting" radix))
+         ((zero? (imag-part n))
+          (displayed (format (real-part n) sign-rule)))
+         (else
+          (each (format (real-part n) sign-rule)
+                (format (imag-part n) #t)
+                "i"))))
+      (write-complex n))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; shared structure utilities
+
+(define (extract-shared-objects x cyclic-only?)
+  (let ((seen (make-hash-table eq?)))
+    ;; find shared references
+    (let find ((x x))
+      (cond ;; only interested in pairs and vectors (and records later)
+       ((or (pair? x) (vector? x))
+        ;; increment the count
+        (hash-table-update!/default seen x (lambda (n) (+ n 1)) 0)
+        ;; walk if this is the first time
+        (cond
+         ((> (hash-table-ref seen x) 1))
+         ((pair? x)
+          (find (car x))
+          (find (cdr x)))
+         ((vector? x)
+          (do ((i 0 (+ i 1)))
+              ((= i (vector-length x)))
+            (find (vector-ref x i)))))
+        ;; delete if this shouldn't count as a shared reference
+        (if (and cyclic-only? (<= (hash-table-ref/default seen x 0) 1))
+            (hash-table-delete! seen x)))))
+    ;; extract shared references
+    (let ((res (make-hash-table eq?))
+          (count 0))
+      (hash-table-walk
+       seen
+       (lambda (k v)
+         (cond
+          ((> v 1)
+           (hash-table-set! res k (cons count #f))
+           (set! count (+ count 1))))))
+      (cons res 0))))
+
+(define (maybe-gen-shared-ref cell shares)
+  (cond
+    ((pair? cell)
+     (set-car! cell (cdr shares))
+     (set-cdr! cell #t)
+     (set-cdr! shares (+ (cdr shares) 1))
+     (each "#" (number->string (car cell)) "="))
+    (else nothing)))
+
+(define (call-with-shared-ref obj shares proc)
+  (let ((cell (hash-table-ref/default (car shares) obj #f)))
+    (if (and (pair? cell) (cdr cell))
+        (each "#" (number->string (car cell)) "#")
+        (each (maybe-gen-shared-ref cell shares) proc))))
+
+(define (call-with-shared-ref/cdr obj shares proc . o)
+  (let ((sep (displayed (if (pair? o) (car o) "")))
+        (cell (hash-table-ref/default (car shares) obj #f)))
+    (cond
+      ((and (pair? cell) (cdr cell))
+       (each sep ". #" (number->string (car cell)) "#"))
+      ((pair? cell)
+       (each sep ". " (maybe-gen-shared-ref cell shares) "(" proc ")"))
+      (else
+       (each sep proc)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; written
+
+(define (write-with-shares obj shares)
+  (fn (radix precision)
+    (let ((write-number
+           ;; Shortcut for numeric values.  Try to rely on
+           ;; number->string for standard radixes and no precision,
+           ;; otherwise fall back on numeric but resetting to a usable
+           ;; radix.
+           (cond
+            ((and (not precision)
+                  (assv radix '((16 . "#x") (10 . "") (8 . "#o") (2 . "#b"))))
+             => (lambda (cell)
+                  (lambda (n)
+                    (if (or (exact? n) (eqv? radix 10))
+                        (each (cdr cell) (number->string n (car cell)))
+                        (with ((radix 10)) (numeric n))))))
+            (else (lambda (n) (with ((radix 10)) (numeric n)))))))
+      ;; `wr' is the recursive writer closing over the shares.
+      (let wr ((obj obj))
+        (call-with-shared-ref
+         obj shares
+         (fn ()
+           (cond
+            ((pair? obj)
+             (each "("
+                   (fn ()
+                     (let lp ((ls obj))
+                       (let ((rest (cdr ls)))
+                         (each (wr (car ls))
+                               (cond
+                                ((null? rest)
+                                 nothing)
+                                ((pair? rest)
+                                 (each
+                                  " "
+                                  (call-with-shared-ref/cdr
+                                   rest shares
+                                   (fn () (lp rest)))))
+                                (else
+                                 (each " . " (wr rest))))))))
+                   ")"))
+            ((vector? obj)
+             (let ((len (vector-length obj)))
+               (if (zero? len)
+                   (displayed "#()")
+                   (each "#("
+                         (wr (vector-ref obj 0))
+                         (fn ()
+                           (let lp ((i 1))
+                             (if (>= i len)
+                                 nothing
+                                 (each " " (wr (vector-ref obj i))
+                                       (fn () (lp (+ i 1)))))))
+                         ")"))))
+            ((number? obj)
+             (write-number obj))
+            (else
+             (displayed (write-to-string obj))))))))))
+
+;; The default formatter for `written', overriden with the `writer'
+;; variable.  Intended to be equivalent to `write', using datum labels
+;; for shared notation iff there are cycles in the object.
+
+(define (written-default obj)
+  (fn ()
+    (write-with-shares obj (extract-shared-objects obj #t))))
+
+;; Writes the object showing the full shared structure.
+
+(define (written-shared obj)
+  (fn ()
+    (write-with-shares obj (extract-shared-objects obj #f))))
+
+;; The only expensive part, in both time and memory, of handling
+;; shared structures when writing is building the initial table, so
+;; for the efficient version we just skip that and re-use the writing
+;; code.
+
+(define (written-simply obj)
+  (fn ()
+    (write-with-shares obj (extract-shared-objects #f #f))))
+
+;; Local variables:
+;; eval: (put 'fn 'scheme-indent-function 1)
+;; End:
diff --git a/lib/chibi/signal.c b/lib/chibi/signal.c
new file mode 100644
index 00000000..10591a4f
--- /dev/null
+++ b/lib/chibi/signal.c
@@ -0,0 +1,143 @@
+/*  signal.c -- process signals interface                     */
+/*  Copyright (c) 2009-2011 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#define SEXP_MAX_SIGNUM 32
+
+static sexp sexp_signal_contexts[SEXP_MAX_SIGNUM];
+
+static struct sigaction call_sigaction, call_sigdefault, call_sigignore;
+
+static void sexp_call_sigaction (int signum, siginfo_t *info, void *uctx) {
+  sexp ctx;
+#if ! SEXP_USE_GREEN_THREADS
+  sexp sigctx, handler;
+  sexp_gc_var1(args);
+#endif
+  ctx = sexp_signal_contexts[signum];
+  if (ctx) {
+#if SEXP_USE_GREEN_THREADS
+    sexp_global(ctx, SEXP_G_THREADS_SIGNALS) =
+      sexp_make_fixnum((1UL<<signum) | sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_THREADS_SIGNALS)));
+#else
+    handler = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS),
+                              sexp_make_fixnum(signum));
+    if (sexp_applicablep(handler)) {
+      sigctx = sexp_make_child_context(ctx, NULL);
+      sexp_gc_preserve1(sigctx, args);
+      args = sexp_cons(sigctx, sexp_make_fixnum(signum), SEXP_NULL);
+      sexp_apply(sigctx, handler, args);
+      sexp_gc_release1(sigctx);
+    }
+#endif
+  }
+}
+
+static sexp sexp_set_signal_action (sexp ctx, sexp self, sexp signum, sexp newaction) {
+  int res;
+  sexp oldaction;
+  if (! (sexp_fixnump(signum) && sexp_unbox_fixnum(signum) > 0
+         && sexp_unbox_fixnum(signum) < SEXP_MAX_SIGNUM))
+    return sexp_xtype_exception(ctx, self, "not a valid signal number", signum);
+  if (! (sexp_procedurep(newaction) || sexp_opcodep(newaction)
+         || sexp_booleanp(newaction)))
+    return sexp_type_exception(ctx, self, SEXP_PROCEDURE, newaction);
+  if (! sexp_vectorp(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS)))
+    sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS)
+      = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_MAX_SIGNUM), SEXP_FALSE);
+  oldaction = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum);
+  res = sigaction(sexp_unbox_fixnum(signum),
+                  (sexp_booleanp(newaction) ?
+                   (sexp_truep(newaction) ? &call_sigdefault : &call_sigignore)
+                   : &call_sigaction),
+                  NULL);
+  if (res)
+    return sexp_user_exception(ctx, self, "couldn't set signal", signum);
+  sexp_vector_set(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum, newaction);
+  sexp_signal_contexts[sexp_unbox_fixnum(signum)] = ctx;
+  return oldaction;
+}
+
+#if SEXP_BSD
+
+#include <sys/time.h>
+#ifndef __DragonFly__
+#include <sys/param.h>
+#include <sys/sysctl.h>
+#include <sys/proc.h>
+#endif
+#include <sys/sysctl.h>
+#include <sys/user.h>
+
+static sexp sexp_pid_cmdline (sexp ctx, int pid) {
+  size_t reslen = sizeof(struct kinfo_proc);
+  struct kinfo_proc res;
+  int name[4] = {CTL_KERN, KERN_PROC, KERN_PROC_PID, pid};
+  if (sysctl(name, 4, &res, &reslen, NULL, 0) >= 0) {
+#if defined(__APPLE__) || defined(__NetBSD__)
+    return sexp_c_string(ctx, res.kp_proc.p_comm, -1);
+#elif __OpenBSD__
+    return sexp_c_string(ctx, res.p_comm, -1);
+#elif __DragonFly__
+    return sexp_c_string(ctx, res.kp_comm, -1);
+#else
+    return sexp_c_string(ctx, res.ki_comm, -1);
+#endif
+  } else {
+    return SEXP_FALSE;
+  }
+}
+
+#else
+
+/* #include <sys/syscall.h> */
+/* #include <linux/sysctl.h> */
+
+/* #define CMDLINE_LENGTH 512 */
+
+/* static sexp sexp_pid_cmdline (sexp ctx, int pid) { */
+/*   struct __sysctl_args args; */
+/*   char cmdline[CMDLINE_LENGTH]; */
+/*   size_t cmdline_length; */
+/*   int name[] = { CTL_KERN, KERN_OSTYPE }; */
+
+/*   memset(&args, 0, sizeof(struct __sysctl_args)); */
+/*   args.name = name; */
+/*   args.nlen = sizeof(name)/sizeof(name[0]); */
+/*   args.oldval = cmdline; */
+/*   args.oldlenp = &cmdline_length; */
+/*   cmdline_length = sizeof(cmdline); */
+
+/*   if (syscall(SYS__sysctl, &args) == -1) { */
+/*     return SEXP_FALSE; */
+/*   } else { */
+/*     return sexp_c_string(ctx, cmdline, -1); */
+/*   } */
+/* } */
+
+#endif
+
+static pid_t sexp_fork_and_kill_threads (sexp ctx) {
+  pid_t res = fork();
+#if SEXP_USE_GREEN_THREADS
+  if (res == 0) {               /* child */
+    sexp_global(ctx, SEXP_G_THREADS_FRONT) = SEXP_NULL;
+    sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL;
+    sexp_global(ctx, SEXP_G_THREADS_PAUSED) = SEXP_NULL;
+  }
+#endif
+  return res;
+}
+
+static void sexp_init_signals (sexp ctx, sexp env) {
+  call_sigaction.sa_sigaction  = sexp_call_sigaction;
+#if SEXP_USE_GREEN_THREADS
+  call_sigaction.sa_flags      = SA_SIGINFO | SA_RESTART /* | SA_NODEFER */;
+  sigfillset(&call_sigaction.sa_mask);
+#else
+  call_sigaction.sa_flags      = SA_SIGINFO | SA_RESTART | SA_NODEFER;
+#endif
+  call_sigdefault.sa_handler   = SIG_DFL;
+  call_sigignore.sa_handler    = SIG_IGN;
+  memset(sexp_signal_contexts, 0, sizeof(sexp_signal_contexts));
+}
diff --git a/lib/chibi/snow/commands.scm b/lib/chibi/snow/commands.scm
new file mode 100644
index 00000000..96876be8
--- /dev/null
+++ b/lib/chibi/snow/commands.scm
@@ -0,0 +1,1277 @@
+;; commands.scm -- snow commands
+;;
+;; This code was written by Alex Shinn in 2014 and placed in the
+;; Public Domain.  All warranties are disclaimed.
+
+(define (find-in-path file . o)
+  (any (lambda (dir)
+         (let ((path (make-path dir file)))
+           (and (file-exists? path) path)))
+       (if (pair? o)
+           (car o)
+           (string-split (get-environment-variable "PATH") #\:))))
+
+(define (find-sexp-in-path file dirs . o)
+  (let ((pred (if (pair? o) (car o) (lambda (x) #t))))
+    (any (lambda (dir)
+           (let ((path (make-path dir file)))
+             (and (file-exists? path)
+                  (guard (exn (else #f))
+                    (let ((x (call-with-input-file path read)))
+                      (and (pred x) x))))))
+         dirs)))
+
+(define (available-implementations cfg)
+  (define (find prog name) (if (find-in-path prog) (list name) '()))
+  (append (cond-expand
+           (chibi (list 'chibi))
+           (else (find "chibi-scheme" 'chibi)))
+          (find "foment" 'foment)
+          (find "gosh" 'gauche)
+          (find "guile" 'guile)
+          (find "sagittarius" 'sagittarius)))
+
+(define (conf-selected-implementations cfg)
+  (let ((requested (conf-get-list cfg 'implementations '(chibi)))
+        (available (available-implementations cfg)))
+    (if (memq 'all requested)
+        available
+        (lset-intersection eq? requested available))))
+
+(define (conf-for-implementation cfg impl)
+  (conf-specialize cfg 'implementation impl))
+
+(define (call-with-output-string proc)
+  (let ((out (open-output-string)))
+    (proc out)
+    (get-output-string out)))
+
+(define (write-to-string x)
+  (call-with-output-string (lambda (out) (write x out))))
+
+(define (file->sexp-list file)
+  (call-with-input-file file
+    (lambda (in)
+      (let lp ((res '()))
+        (let ((x (read in)))
+          (if (eof-object? x)
+              (reverse res)
+              (lp (cons x res))))))))
+
+(define (version-split str)
+  (if str
+      (map (lambda (x) (or (string->number x) x))
+        (string-split str #\.))
+      '()))
+
+(define (version-compare a b)
+  (define (less? x y)
+    (cond ((number? x) (if (number? y) (< x y) 1))
+          ((number? y) -1)
+          (else (string<? x y))))
+  (let lp ((as (version-split a))
+           (bs (version-split b)))
+    (cond
+     ((null? as) (if (null? bs) -1 0))
+     ((null? bs) 1)
+     ((less? (car as) (car bs)) -1)
+     ((less? (car bs) (car as)) 1)
+     (else (lp (cdr as) (cdr bs))))))
+
+(define (version>? a b) (> (version-compare a b) 0))
+(define (version>=? a b) (>= (version-compare a b) 0))
+
+;; Hack to evaluate an expression in a separate process with a larger
+;; default heap.  The expression and result must be serializable with
+;; write, and imports should be an argument list for environment.
+;; Currently only used when generating keys and signing.
+(define (fast-eval expr imports . o)
+  (let* ((heap-size (if (pair? o) (car o) 500))
+         (cmd
+          `("chibi-scheme"
+            ,(string-append "-h" (number->string heap-size) "M")
+            ,@(map
+               (lambda (i)
+                 (string-append "-m" (string-join (map write-to-string i) ".")))
+               imports)
+            "-p" ,(write-to-string expr))))
+    (let ((res (process->sexp cmd)))
+      (if (eof-object? res)  ; process error
+          (eval expr (apply environment imports))
+          res))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Package - generate a package from one or more libraries.
+
+(define (tar-file? file)
+  (or (equal? (path-extension file) "tgz")
+      (and (member (path-extension file) '("gz" "bz2"))
+           (equal? (path-extension (path-strip-extension file)) "tar"))))
+
+(define (package-file-meta file)
+  (and
+   (tar-file? file)
+   (let* ((unzipped-file
+           (if (member (path-extension file) '("tgz" "gz"))
+               (gunzip (let* ((in (open-binary-input-file file))
+                              (res (port->bytevector in)))
+                         (close-input-port in)
+                         res))
+               file))
+          (package-file
+           (find
+            (lambda (x)
+              (and (equal? "package.scm" (path-strip-directory x))
+                   (equal? "." (path-directory (path-directory x)))))
+            (tar-files unzipped-file))))
+     (and package-file
+          (guard (exn (else #f))
+            (let* ((str (utf8->string
+                         (tar-extract-file unzipped-file package-file)))
+                   (package (read (open-input-string str))))
+              (and (pair? package)
+                   (eq? 'package (car package))
+                   package)))))))
+
+(define (package-file? file)
+  (and (package-file-meta file) #t))
+
+(define (x->string x)
+  (cond ((string? x) x)
+        ((symbol? x) (symbol->string x))
+        ((number? x) (number->string x))
+        (else (error "not a valid path component" x))))
+
+(define (library-path-base file name)
+  (let lp ((ls (cdr (reverse name))) (dir (path-directory file)))
+    (cond
+     ((null? ls) dir)
+     ((equal? (x->string (car ls)) (path-strip-directory dir))
+      (lp (cdr ls) (path-directory dir)))
+     (else dir))))
+
+(define (path-relative file dir)
+  (let ((file (path-normalize file))
+        (dir (string-trim-right (path-normalize dir) #\/)))
+    (string-trim-left
+     (if (string-prefix? dir file)
+         (substring file (string-length dir))
+         file)
+     #\/)))
+
+;; remove import qualifiers
+(define (import-name import)
+  (cond
+   ((and (pair? import)
+         (memq (car import) '(only except prefix drop-prefix rename))
+         (pair? (cadr import)))
+    (import-name (cadr import)))
+   (else import)))
+
+(define (extract-library cfg file)
+  (let ((lib (read-from-file file)))
+    (match lib
+      (('define-library (name ...)
+         declarations ...)
+       (let* ((dir (library-path-base file name))
+              (lib-file (path-relative file dir))
+              (lib-dir (path-directory lib-file)))
+         (define (resolve file)
+           (let ((dest-path (make-path lib-dir file)))
+             (list 'rename (make-path dir dest-path) dest-path)))
+         (let lp ((ls declarations)
+                  (info `(,@(cond
+                             ((conf-get cfg '(command package author))
+                              => (lambda (x) (list (list 'author x))))
+                             (else '()))
+                          (path ,lib-file)
+                          (name ,name)))
+                  (files `((rename ,file ,lib-file))))
+           (cond
+            ((null? ls)
+             (cons `(library ,@(reverse info))
+                   files))
+            (else
+             (match (car ls)
+               (((or 'include 'include-ci) includes ...)
+                (lp (cdr ls)
+                    info
+                    (append (map resolve includes) files)))
+               (('include-library-declarations includes ...)
+                (lp (append (append-map file->sexp-list includes) (cdr ls))
+                    info
+                    (append (map resolve includes) files)))
+               (('import libs ...)
+                (lp (cdr ls)
+                    (cons (cons 'depends (map import-name libs)) info)
+                    files))
+               (('cond-expand clauses ...)
+                (lp (append (append-map cdr clauses) (cdr ls)) info files))
+               (else
+                (lp (cdr ls) info files))))))))
+      (else
+       (die 2 "not a valid library declaration " lib " in file " file)))))
+
+(define (extract-program-imports file)
+  (let lp ((ls (guard (exn (else '())) (file->sexp-list file)))
+           (deps '()))
+    (cond
+     ((and (pair? ls) (pair? (car ls)) (eq? 'import (caar ls)))
+      (lp (cdr ls) (append (reverse (map import-name (cdar ls))) deps)))
+     (else
+      (reverse deps)))))
+
+(define (make-package-name cfg libs . o)
+  (let ((name (any (lambda (x) (or (library-name x) (program-name x))) libs))
+        (version (and (pair? o) (car o))))
+    (cond
+     ((not (and (pair? name) (list? name)))
+      (die 2 "Invalid library name: " name))
+     ((not name)
+      (die 2 "Couldn't determine package name from libs: " libs))
+     (else
+      (let lp ((ls (if version
+                       (append name (list version))
+                       name))
+               (res '()))
+        (if (null? ls)
+            (string-join (reverse (cons ".tgz" res)))
+            (lp (cdr ls)
+                (cons (x->string (car ls))
+                      (if (null? res) res (cons "-" res))))))))))
+
+(define (check-overwrite cfg file type-pred type-name)
+  (let ((mode (conf-get cfg '(command package overwrite) 'same-type)))
+    (cond
+     ((eq? mode 'always))
+     ((file-exists? file)
+      (case mode
+        ((never)
+         (die 2 "Destination " file " already exists, not overwriting"))
+        ((same-type)
+         (if (not (type-pred file))
+             (die 2 "Destination " file " doesn't look like a " type-name
+                  ", not overwriting")))
+        ((confirm)
+         (if (not (yes-or-no? cfg "Overwrite existing " file "?"))
+             (die 2 "Not overwriting " file))))))))
+
+;; Simplistic pretty printing for package/repository/config declarations.
+(define (write-simple-pretty pkg out)
+  (let wr ((ls pkg) (indent 0) (tails 0))
+    (cond
+     ((and (pair? ls)
+           (pair? (cdr ls))
+           (pair? (cadr ls)))
+      (display (make-string indent #\space) out)
+      (write-char #\( out)
+      (write (car ls) out)
+      (newline out)
+      (for-each (lambda (x) (wr x (+ indent 2) 0)) (drop-right (cdr ls) 1))
+      (wr (last ls) (+ indent 2) (+ tails 1)))
+     (else
+      (display (make-string indent #\space) out)
+      (write ls out)
+      (display (make-string tails #\)) out)
+      (newline out)))))
+
+;; We want to automatically bundle (foo bar *) when packaging (foo bar)
+;; if it's already in the same directory.
+(define (submodule->path base file lib dep)
+  (and base
+       (> (length dep) (length base))
+       (equal? base (take dep (length base)))
+       ;; TODO: find-library(-relative)
+       (let* ((dir (library-path-base file lib))
+              (dep-file (make-path dir (string-append
+                                        (library-name->path dep)
+                                        ".sld"))))
+         (and (file-exists? dep-file) dep-file))))
+
+(define (package-docs cfg spec libs)
+  (cond
+   ((conf-get cfg '(command package doc)) => list)
+   ((conf-get cfg '(command package doc-from-scribble))
+    (map
+     (lambda (lib)
+       (let* ((lib+files (extract-library cfg lib))
+              (lib-name (library-name (car lib+files))))
+         `(inline
+           ,(string-append (library-name->path lib-name) ".html")
+           ,(call-with-output-string
+              (lambda (out)
+                (print-module-docs lib-name out sxml-display-as-html))))))
+     libs))
+   (else '())))
+
+(define (package-description cfg spec libs docs)
+  (cond
+   ((conf-get cfg '(command package description)))
+   ((conf-get cfg '(command upload description)))
+   ;; Crazy hack, make this more robust, probably opt-in.
+   ((and (pair? docs) (pair? (car docs)) (eq? 'inline (caar docs))
+         (regexp-search
+          '(: "<p>" (* "\n") (* space) ($ (* (~ ("."))) "."))
+          (third (car docs))))
+    => (lambda (m)
+         (let ((s (regexp-match-submatch m 1)))
+           (and s
+                (regexp-replace-all
+                 '(>= 2 space)
+                 (regexp-replace-all
+                  "\n"
+                  (regexp-replace-all '(: "<" (? "/") (* (~ ("<>"))) ">")
+                                      s "")
+                  " ")
+                 " ")))))
+   (else #f)))
+
+(define (package-test cfg)
+  (conf-get cfg '(command package test)))
+
+(define (package-license cfg)
+  (conf-get cfg '(command package license)))
+
+(define (package-output-version cfg)
+  (cond ((conf-get cfg '(command package version)))
+        ((conf-get cfg '(command upload version)))
+        ((conf-get cfg '(command package version-file))
+         => (lambda (file) (call-with-input-file file read-line)))
+        ((conf-get cfg '(command upload version-file))
+         => (lambda (file) (call-with-input-file file read-line)))
+        (else #f)))
+
+(define (package-output-path cfg package-spec)
+  (or (conf-get cfg 'output)
+      (make-package-name
+       cfg
+       (filter (lambda (x) (and (pair? x) (memq (car x) '(library program))))
+               package-spec)
+       (package-output-version cfg))))
+
+(define (package-spec+files cfg spec libs)
+  (let* ((recursive? (conf-get cfg '(command package recursive?)))
+         (programs (conf-get-list cfg '(command package programs)))
+         (docs (package-docs cfg spec libs))
+         (desc (package-description cfg spec libs docs))
+         (test (package-test cfg))
+         (authors (conf-get-list cfg '(command package authors)))
+         (maintainers (conf-get-list cfg '(command package maintainers)))
+         (version (package-output-version cfg))
+         (license (package-license cfg)))
+    (let lp ((ls (map (lambda (x) (cons x #f)) libs))
+             (progs programs)
+             (res
+              `(,@(if license `((license ,license)) '())
+                ,@(if (pair? docs)
+                      `((manual ,@(map
+                                   (lambda (x)
+                                     (path-strip-leading-parents
+                                      (if (pair? x) (cadr x) x)))
+                                   docs)))
+                      '())
+                ,@(if desc `((description ,desc)) '())
+                ,@(if test `((test ,(path-strip-leading-parents test))) '())
+                ,@(if version `((version ,version)) '())
+                ,@(if (pair? authors) `((authors ,@authors)) '())
+                ,@(if (pair? maintainers) `((maintainers ,@maintainers)) '())))
+             (files
+              `(,@(if test (list test) '())
+                ,@docs)))
+      (cond
+       ((pair? ls)
+        (let* ((lib+files (extract-library cfg (caar ls)))
+               (lib (car lib+files))
+               (name (library-name lib))
+               (base (or (cdar ls) name))
+               (subdeps (if recursive?
+                            (filter-map
+                             (lambda (x)
+                               (submodule->path base (caar ls) name x))
+                             (cond ((assq 'depends (cdr lib)) => cdr)
+                                   (else '())))
+                            '())))
+          (lp (append (map (lambda (x) (cons x base)) subdeps) (cdr ls))
+              progs
+              (cons lib res)
+              (append (reverse (cdr lib+files)) files))))
+       ((pair? progs)
+        (lp ls
+            (cdr progs)
+            (cons `(program
+                    (path ,(path-strip-leading-parents (car progs)))
+                    (depends ,@(extract-program-imports (car progs))))
+                  res)
+            (cons (car progs) files)))
+       ((null? res)
+        (die 2 "No packages generated"))
+       (else
+        (cons (cons 'package (reverse res)) (reverse files)))))))
+
+(define (create-package spec files path)
+  (gzip
+   (tar-create #f `(,@files
+                    (inline "package.scm"
+                            ,(call-with-output-string
+                               (lambda (out) (write-simple-pretty spec out)))))
+               (let ((dir (path-strip-extension (path-strip-directory path))))
+                 (lambda (f) (make-path dir f)))
+               #t)))
+
+(define (command/package cfg spec . libs)
+  (let* ((spec+files (package-spec+files cfg spec libs))
+         (output (package-output-path cfg (car spec+files)))
+         (tarball (create-package (car spec+files) (cdr spec+files) output)))
+    (check-overwrite cfg output package-file? "package")
+    (let ((out (open-binary-output-file output)))
+      (write-bytevector tarball out)
+      (close-output-port out))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Gen-key - generate a new RSA key pair.
+
+(define (conf-get-snow-dir cfg)
+  (or (conf-get cfg 'snow-dir)
+      (string-append (get-environment-variable "HOME") "/.snow")))
+
+(define (rsa-key->sexp key name email)
+  `((name ,name)
+    (email ,email)
+    (bits ,(rsa-key-bits key))
+    ,@(cond
+       ((rsa-key-e key)
+        => (lambda (e)
+             `((public-key
+                (modulus ,(integer->hex-string (rsa-key-n key)))
+                (exponent ,e)))))
+       (else '()))
+    ,@(cond
+       ((rsa-key-d key)
+        => (lambda (d)
+             `((private-key
+                (modulus ,(integer->hex-string (rsa-key-n key)))
+                (exponent ,d)))))
+       (else '()))))
+
+(define (conf-gen-key cfg bits)
+  (show #t "Generating a new key, this may take quite a while...\n")
+  (if (conf-get cfg 'gen-key-in-process?)
+      (rsa-key-gen bits)
+      (let* ((lo (max 3 (expt 2 (- bits 1))))
+             (hi (expt 2 bits))
+             (p (fast-eval `(random-prime ,lo ,hi)
+                           '((chibi math prime))))
+             (q (fast-eval `(random-prime-distinct-from ,lo ,hi ,p)
+                           '((chibi math prime)))))
+        (rsa-key-gen-from-primes bits p q))))
+
+(define (command/gen-key cfg spec)
+  (show #t
+        "Generate a new RSA key for signing packages.\n"
+        "We need a descriptive name, and an email address to "
+        "uniquely identify the key.\n")
+  (let* ((name (input cfg '(gen-key name) "Name: "))
+         (email (input cfg '(gen-key email) "Email: "))
+         (bits (input-number cfg '(gen-key bits)
+                             "RSA key size in bits: " 512 64 20148))
+         (key (conf-gen-key cfg bits))
+         (snow-dir (conf-get-snow-dir cfg))
+         (key-file (or (conf-get cfg 'key-file)
+                       (string-append snow-dir "/priv-key.scm")))
+         (old-keys (guard (exn (else '()))
+                     (call-with-input-file key-file read)))
+         (new-keys
+          (cons (rsa-key->sexp key name email) 
+                ;; TODO: confirm overwrite, preserve old keys
+                (remove (rsa-identity=? email) old-keys))))
+    (if (not (file-directory? snow-dir))
+        (create-directory snow-dir))
+    (let* ((fd (open key-file (bitwise-ior open/write open/create) #o600))
+           (out (open-output-file-descriptor fd)))
+      (show out "("
+            (joined (lambda (x)
+                      (if (pair? x)
+                          (each "(" (joined written x "\n  ") ")")
+                          (written x)))
+                    new-keys
+                    "\n ")
+            ")" nl)
+      (close-output-port out)
+      (show #t "Saved key to " key-file ".\n"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Reg-key - register an RSA key pair with a repository.
+
+(define (remote-uri cfg name path)
+  (or (conf-get cfg name)
+      (make-path (or (conf-get cfg 'host) "http://snow-fort.org")
+                 path)))
+
+(define (remote-command cfg name path params)
+  (let ((uri (remote-uri cfg name path)))
+    (sxml-display-as-text (read (http-post uri (cons '(fmt . "sexp") params))))
+    (newline)))
+
+(define (command/reg-key cfg spec)
+  (let* ((keys (call-with-input-file
+                   (or (conf-get cfg 'key-file)
+                       (string-append (conf-get-snow-dir cfg) "/priv-key.scm"))
+                 read))
+         (email (or (conf-get cfg 'email)
+                    (assoc-get (car keys) 'email)))
+         (rsa-key-sexp (or (find (rsa-identity=? email) keys)
+                           (and (not email) (car keys))))
+         (name (assoc-get rsa-key-sexp 'name))
+         (rsa-pub-key (extract-rsa-public-key rsa-key-sexp))
+         (rsa-pub-key-str
+          (write-to-string (rsa-key->sexp rsa-pub-key name email))))
+    (remote-command cfg
+                    '(command reg-key uri)
+                    "/pkg/reg"
+                    `((u (file . "pub-key.scm")
+                         (value . ,rsa-pub-key-str))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Sign - sign a package.
+
+(define (generate-signature cfg package)
+  (let* ((digest-name (conf-get cfg 'digest 'sha-256))
+         (digest-func (lookup-digest digest-name))
+         (raw-data (if (string? package)
+                       (call-with-input-file package port->bytevector)
+                       package))
+         (snowball (maybe-gunzip raw-data))
+         (digest (digest-func snowball))
+         (keys (call-with-input-file
+                   (or (conf-get cfg 'key-file)
+                       (string-append (conf-get-snow-dir cfg) "/priv-key.scm"))
+                 read))
+         (email (or (conf-get cfg 'email)
+                    (assoc-get (car keys) 'email)))
+         (rsa-key-sexp (find (rsa-identity=? email) keys))
+         (rsa-key (extract-rsa-private-key rsa-key-sexp))
+         (sig (fast-eval `(rsa-sign (make-rsa-key ,(rsa-key-bits rsa-key)
+                                                  ,(rsa-key-n rsa-key)
+                                                  #f
+                                                  ,(rsa-key-d rsa-key))
+                                    ;;,(hex-string->integer digest)
+                                    ,(hex-string->bytevector digest))
+                         '((chibi crypto rsa))))
+         (hex-sig (if (bytevector? sig)
+                      (bytevector->hex-string sig)
+                      (integer->hex-string sig))))
+    `(signature
+      (email ,email)
+      (digest ,digest-name)
+      (,digest-name ,digest)
+      (rsa ,hex-sig))))
+
+(define (command/sign cfg spec package)
+  (let* ((dst (or (conf-get cfg 'output)
+                  (path-replace-extension package "sig")))
+         (sig (generate-signature cfg package)))
+    (call-with-output-file dst
+      (lambda (out) (write sig out)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Verify - verify a signature.
+
+(define (command/verify cfg spec sig)
+  (let* ((sig-spec (cdr (call-with-input-file sig read)))
+         (keys (call-with-input-file
+                   (or (conf-get cfg 'key-file)
+                       (string-append (conf-get-snow-dir cfg) "/priv-key.scm"))
+                 read))
+         (email (assoc-get sig-spec 'email))
+         (digest-name (assoc-get sig-spec 'digest #f 'sha-256))
+         (digest (assoc-get sig-spec digest-name))
+         (sig (assoc-get sig-spec 'rsa))
+         (rsa-key-sexp (or (and (string? email)
+                                (find (rsa-identity=? email) keys))
+                           (car keys)))
+         (rsa-key (extract-rsa-public-key rsa-key-sexp))
+         (cipher (rsa-verify rsa-key (hex-string->bytevector sig)))
+         (digest-bv (hex-string->bytevector digest)))
+    (if (equal? cipher digest-bv)
+        (show #t "signature valid " nl)
+        (show #t "signature invalid " cipher " != " digest-bv nl))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Upload - upload a package.
+
+(define (upload-package cfg spec package . o)
+  (let ((pkg (if (string? package)
+                 `(u (file . ,package))
+                 `(u (file . ,(if (pair? o) (car o) "package.tgz"))
+                     (value . ,package))))
+        (sig
+         (cond
+          ((conf-get cfg 'sig-file)
+           => (lambda (sig-file) `(sig (file . ,sig-file))))
+          (else
+           `(sig (file . "package.sig")
+                 (value . ,(write-to-string
+                            (generate-signature cfg package))))))))
+    (remote-command cfg '(command package uri) "/pkg/put" (list pkg sig))))
+
+(define (command/upload cfg spec . o)
+  (define (non-homogeneous)
+    (die 1 "upload arguments must all be packages or all be libraries, "
+         "but got " o))
+  (cond
+   ((null? o)
+    (die 1 "upload requires at least one input argument"))
+   ((package-file? (car o))
+    (if (not (every package-file? (cdr o)))
+        (non-homogeneous))
+    (for-each
+     (lambda (package) (upload-package cfg spec package))
+     o))
+   (else
+    (if (any package-file? (cdr o))
+        (non-homogeneous))
+    (let* ((spec+files (package-spec+files cfg spec o))
+           (package-file (package-output-path cfg (car spec+files)))
+           (package (create-package (car spec+files)
+                                    (cdr spec+files)
+                                    package-file)))
+      (upload-package cfg spec package package-file)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Remove - removes the listed libraries.
+;;
+;; Provides a summary of the libraries to remove along with any
+;; dependencies they have which were not explicitly installed.
+
+(define (warn-delete-file file)
+  (guard (exn (else (warn "couldn't delete file: " file)))
+    (delete-file file)))
+
+(define (delete-library-files impl cfg pkg lib-name)
+  (for-each warn-delete-file (package-installed-files pkg))
+  (warn-delete-file (make-path (get-install-source-dir impl cfg)
+                               (get-package-meta-file cfg pkg)))
+  (let ((dir (make-path (get-install-source-dir impl cfg)
+                        (package->path pkg))))
+    (if (and (file-directory? dir)
+             (= 2 (length (directory-files dir))))
+        (delete-directory dir))))
+
+(define (command/remove cfg spec . args)
+  (let* ((impls (conf-selected-implementations cfg))
+         (impl-cfgs (map (lambda (impl)
+                           (conf-for-implementation cfg impl))
+                         impls))
+         (lib-names (map parse-library-name args)))
+    (for-each
+     (lambda (impl impl-cfg)
+       (for-each (lambda (pkg lib-name)
+                   (delete-library-files impl impl-cfg (cdr pkg) lib-name))
+                 (lookup-installed-libraries impl impl-cfg lib-names)
+                 lib-names))
+     impls
+     impl-cfgs)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Search - search for libraries matching keywords.
+;;
+;; Prints a list of libraries whose meta-info contain any of the given
+;; keywords.  Returns in sorted order for how well the package matches.
+
+(define (summarize-libraries cfg lib-names+pkgs)
+  (for-each describe-library
+            (map car lib-names+pkgs)
+            (map cdr lib-names+pkgs)))
+
+;; faster than (length (regexp-extract re str))
+(define (regexp-count re str)
+  (regexp-fold re (lambda (from md str acc) (+ acc 1)) 0 str))
+
+(define (count-in-sexp x keywords)
+  (regexp-count `(word (w/nocase (or ,@keywords)))
+                (write-to-string x)))
+
+(define (extract-matching-libraries cfg repo keywords)
+  (define (library-score lib)
+    (+ (* 10 (count-in-sexp (library-name lib) keywords))
+       (count-in-sexp lib keywords)
+       (let ((use-for (assoc-get lib 'use-for)))
+         (case (if (pair? use-for) (car use-for) use-for)
+           ((test) 0)
+           ((build) 10)
+           (else 100)))))
+  (append-map
+   (lambda (x)
+     (cond
+      ((not (package? x)) '())
+      (else
+       (let ((pkg-score (count-in-sexp x keywords))
+             (libs (package-libraries x)))
+         (if (or (zero? pkg-score) (null? libs))
+             '()
+             (let lp ((libs (cdr libs))
+                      (best-score (library-score (car libs)))
+                      (best-lib (car libs)))
+               (cond
+                ((null? libs)
+                 (list (cons (+ best-score pkg-score)
+                             (cons (library-name best-lib) x))))
+                (else
+                 (let ((score (library-score (car libs))))
+                   (if (> score best-score)
+                       (lp (cdr libs) score (car libs))
+                       (lp (cdr libs) best-score best-lib)))))))))))
+   repo))
+
+(define (extract-sorted-packages cfg repo keywords)
+  (let ((ls (extract-matching-libraries cfg repo keywords)))
+    (map cdr (sort ls > car))))
+
+(define (command/search cfg spec . keywords)
+  (let* ((repo (maybe-update-repository cfg))
+         (lib-names+pkgs (extract-sorted-packages cfg repo keywords)))
+    (if (pair? lib-names+pkgs)
+        (summarize-libraries cfg lib-names+pkgs)
+        (display "No libraries matched your query.\n"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Show - show detailed information for the given libraries
+;;
+;; The typical pattern is to use search to find the names of libraries
+;; of interest, and show to see detailed information to decide whether
+;; or not to install them.
+
+(define (describe-library library-name pkg)
+  (display library-name)
+  (display "\t")
+  (display (package-version pkg))
+  (newline))
+
+(define (command/show cfg spec . args)
+  (maybe-update-repository cfg)
+  (let* ((impls (conf-selected-implementations cfg))
+         (impl-cfgs (map (lambda (impl)
+                           (conf-for-implementation cfg impl))
+                         impls))
+         (lib-names (map parse-library-name args)))
+    (for-each
+     (lambda (impl impl-cfg)
+       (for-each describe-library
+                 (lookup-installed-libraries impl impl-cfg lib-names)
+                 lib-names))
+     impls
+     impl-cfgs)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Update - update the repository.
+
+(define (valid-repository? repo)
+  (and (pair? repo) (list? repo) (eq? 'repository (car repo))))
+
+(define (repository-dir cfg)
+  (cond
+   ((zero? (current-user-id))
+    (or (conf-get cfg 'local-root-repository)
+        "/usr/local/share/snow/repo"))
+   (else
+    (or (conf-get cfg 'local-user-repository)
+        (make-path (conf-get-snow-dir cfg) "repo")))))
+
+(define (update-repository cfg)
+  (let* ((local-dir (repository-dir cfg))
+         (local-path (make-path local-dir "repo.scm"))
+         (local-tmp (string-append local-path ".tmp."
+                                   (number->string (current-second))))
+         (repo-uri (remote-uri cfg 'repository-uri "/s/repo.scm"))
+         (repo-str (call-with-input-url repo-uri port->string))
+         (repo (guard (exn (else #f))
+                 (let ((repo (read (open-input-string repo-str))))
+                   `(,(car repo) (url ,repo-uri) ,@(cdr repo))))))
+    (cond
+     ((not (valid-repository? repo))
+      (die 2 "not a valid repository: " repo-uri))
+     ((not (create-directory* local-dir))
+      (die 2 "can't create directory: " local-dir ))
+     (else
+      (guard (exn (else (die 2 "couldn't write repository")))
+        (call-with-output-file local-tmp
+          (lambda (out) (write repo out)))
+        (if (file-exists? local-path)
+            (rename-file local-path (string-append local-path ".bak")))
+        (rename-file local-tmp local-path)
+        repo)))))
+
+(define (repository-stale? cfg)
+  (let ((path (make-path (repository-dir cfg) "repo.scm")))
+    (guard (exn (else #t))
+      (> (current-second)
+         (+ (file-modification-time path)
+            ;; by default update once every 3 hours
+            (conf-get cfg 'update-refresh (* 3 60 60)))))))
+
+(define (should-update-repository? cfg)
+  (case (conf-get cfg 'update-strategy 'cache)
+    ((always) #t)
+    ((never) #f)
+    ((cache)
+     (repository-stale? cfg))
+    ((confirm)
+     (and (repository-stale? cfg)
+          (yes-or-no? cfg "Update repository info?")))
+    (else
+     (warn "unknown update-stategy: " (conf-get cfg 'update-strategy))
+     #f)))
+
+(define (maybe-update-repository cfg)
+  (or (guard (exn (else #f))
+        (and (should-update-repository? cfg)
+             (update-repository cfg)))
+      (guard (exn (else '(repository)))
+        (call-with-input-file (make-path (repository-dir cfg) "repo.scm")
+          read))))
+
+(define (command/update cfg spec)
+  (update-repository cfg))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Install - install one or more libraries.
+;;
+;; Installs the listed libraries along with their transitive closure
+;; of dependencies.  For each library to install we confirm the
+;; current status (skipping if already installed), the signature and
+;; trust (optionally updating the trust level), and the default tests.
+;; If multiple implementations are targeted, we install separately but
+;; use the same confirmations for each.
+
+(define (get-install-dirs impl cfg)
+  (define (guile-eval expr)
+    (guard (exn (else #f))
+      (process->sexp `(guile -c ,(write-to-string `(write ,expr))))))
+  (case impl
+    ((chibi)
+     (let* ((dirs (reverse (fast-eval '(current-module-path) '((chibi)))))
+            (share-dir (find (lambda (d) (string-contains d "/share/")) dirs)))
+       (if share-dir
+           (cons share-dir (delete share-dir dirs))
+           dirs)))
+    ((gauche)
+     (let ((dir (process->string '(gauche-config "--sitelibdir"))))
+       (and (string? dir) (> 0 (string-length dir))
+            (eqv? #\/ (string-ref dir 0))
+            dir)))
+    ((guile)
+     (let ((path
+            (guile-eval
+             '(string-append (cdr (assq 'pkgdatadir %guile-build-info))
+                             (string (integer->char 47))
+                             (effective-version)))))
+       (if (string? path)
+           path
+           "/usr/local/share/guile/")))
+    (else (list (make-path "/usr/local/share/snow" impl)))))
+
+(define (get-install-search-dirs impl cfg)
+  (let ((install-dir (get-install-source-dir impl cfg))
+        (other-dirs (get-install-dirs impl cfg)))
+    (cons install-dir (delete install-dir other-dirs))))
+
+(define (find-library-meta impl cfg name)
+  (let ((dirs (get-install-search-dirs impl cfg)))
+    (let lp ((subname name))
+      (or (find-sexp-in-path
+           (package-name->meta-file cfg subname)
+           dirs
+           (lambda (x)
+             (and (package? x)
+                  (any (lambda (y) (equal? name (library-name y)))
+                       (package-libraries x)))))
+          (and (pair? (cdr subname))
+               (lp (drop-right subname 1)))))))
+
+(define (test-library impl cfg library dir)
+  #t)
+
+(define (lookup-installed-libraries impl cfg names)
+  (map (lambda (name)
+         (cons name
+               (or (find-library-meta impl cfg name)
+                   `(not-installed ,name))))
+       names))
+
+(define (installed-libraries impl cfg)
+  (delete-duplicates
+   (directory-fold-tree
+    (get-install-source-dir impl cfg)
+    #f #f
+    (lambda (file acc)
+      (cond
+       ((and (equal? "meta" (path-extension file))
+             (guard (exn (else #f))
+               (let ((pkg (call-with-input-file file read)))
+                 (and (package? pkg) pkg))))
+        => (lambda (pkg)
+             (append
+              (map
+               (lambda (lib) (cons (library-name lib) pkg))
+               (package-libraries pkg))
+              acc)))
+       (else acc)))
+    '())
+   (lambda (a b) (equal? (car a) (car b)))))
+
+(define (get-install-source-dir impl cfg)
+  (cond
+   ((conf-get cfg 'install-source-dir))
+   ((conf-get cfg 'install-prefix)
+    => (lambda (prefix) (make-path prefix "share/snow" impl)))
+   (else (car (get-install-dirs impl cfg)))))
+
+(define (get-install-binary-dir impl cfg)
+  (cond
+   ((conf-get cfg 'install-binary-dir))
+   ((conf-get cfg 'install-prefix)
+    => (lambda (prefix) (make-path prefix "bin")))
+   (else "/usr/local/bin")))
+
+(define (install-with-sudo? cfg path)
+  (case (conf-get cfg '(command install use-sudo?))
+    ((always) #t)
+    ((never) #f)
+    (else
+     (let lp ((path path))
+       (let ((dir (path-directory path)))
+         (and (not (file-is-writable? path))
+              (or (file-exists? path)
+                  (lp dir))))))))
+
+(define (install-file cfg source dest)
+  (if (install-with-sudo? cfg dest)
+      (system "sudo" "cp" source dest)
+      (copy-file source dest)))
+
+(define (install-sexp-file cfg obj dest)
+  (if (install-with-sudo? cfg dest)
+      (call-with-temp-file "sexp"
+        (lambda (tmp-path out)
+          (write-simple-pretty obj out)
+          (close-output-port out)
+          (system "sudo" "cp" tmp-path dest)))
+      (call-with-output-file dest
+        (lambda (out) (write-simple-pretty obj out)))))
+
+(define (install-symbolic-link cfg source dest)
+  (if (install-with-sudo? cfg dest)
+      (system "sudo" "ln" "-s" source dest)
+      (symbolic-link-file source dest)))
+
+(define (install-directory cfg dir)
+  (cond
+   ((file-directory? dir))
+   ((install-with-sudo? cfg dir)
+    (system "sudo" "mkdir" "-p" dir))
+   (else
+    (create-directory* dir))))
+
+(define (install-package-meta-info impl cfg pkg)
+  (let* ((meta-file (get-package-meta-file cfg pkg))
+         (install-dir (get-install-source-dir impl cfg))
+         (path (make-path install-dir meta-file)))
+    ;; write the package name
+    (install-sexp-file cfg pkg path)
+    ;; symlink utility libraries for which the package can't be inferred
+    (let ((pkg-name (package-name pkg)))
+      (for-each
+       (lambda (lib)
+         (let ((lib-name (library-name lib)))
+           (if (not (equal? pkg-name (take lib-name (length pkg-name))))
+               (let ((lib-meta (get-library-meta-file cfg lib)))
+                 (install-symbolic-link
+                  cfg path (make-path install-dir lib-meta))))))
+       (package-libraries pkg)))))
+
+;; The default installer just copies the library file and any included
+;; source files to an installation directory, optionally mapping
+;; extensions to the implementations preferred value.
+(define (default-installer impl cfg library dir)
+  (let* ((library-file (get-library-file cfg library))
+         (ext (conf-get cfg 'library-extension "sld"))
+         (dest-library-file (path-replace-extension library-file ext))
+         (include-files
+          (library-include-files cfg (make-path dir library-file)))
+         (rewrite-include-files
+          ;; Rewrite if any include has the same path as the library
+          ;; declaration file after extension renaming.
+          ;; TODO: Also rewrite if multiple libs use same file names?
+          (map
+           (lambda (x)
+             (if (equal? x dest-library-file)
+                 (cons x (string-append x "." ext))
+                 x))
+           include-files))
+         (install-dir (get-install-source-dir impl cfg)))
+    ;; install the library file
+    (let ((path (make-path install-dir dest-library-file)))
+      (install-directory cfg (path-directory path))
+      (if (any pair? rewrite-include-files)
+          (install-sexp-file
+           cfg
+           (library-rewrite-includes library rewrite-include-files)
+           path)
+          (install-file cfg (make-path dir library-file) path))
+      ;; install any includes
+      (cons
+       path
+       (map
+        (lambda (x)
+          (let ((dest-file
+                 (make-path install-dir
+                            (path-relative (if (pair? x) (cdr x) x) dir))))
+            (install-directory cfg (path-directory dest-file))
+            (install-file cfg (if (pair? x) (car x) x) dest-file)
+            dest-file))
+        rewrite-include-files)))))
+
+(define (default-program-installer impl cfg prog dir)
+  (let* ((program-file (get-program-file cfg prog))
+         (dest-program-file (program-install-name prog))
+         (install-dir (get-install-binary-dir impl cfg)))
+    (let ((path (make-path install-dir dest-program-file)))
+      (install-directory cfg (path-directory path))
+      (install-file cfg (make-path dir program-file) path))))
+
+;; installers should return the list of installed files
+(define (lookup-installer installer)
+  (case installer
+    (else default-installer)))
+
+(define (install-library impl cfg library dir)
+  (let ((installer (lookup-installer (conf-get cfg 'installer))))
+    (installer impl cfg library dir)))
+
+(define (build-library impl cfg library dir)
+  ;; the currently supported implementations don't require building
+  #t)
+
+(define (build-program impl cfg prog dir)
+  #t)
+
+(define (lookup-program-installer installer)
+  (case installer
+    (else default-program-installer)))
+
+(define (install-program impl cfg prog dir)
+  (let ((installer (lookup-program-installer
+                    (conf-get cfg 'program-installer))))
+    (installer impl cfg prog dir)))
+
+(define (fetch-package cfg url)
+  (call-with-input-url url port->bytevector))
+
+(define (path-strip-top file)
+  (let ((pos (string-find file #\/)))
+    (if (string-cursor<? pos (string-cursor-end file))
+        (substring-cursor file (string-cursor-next file pos))
+        file)))
+
+(define (maybe-invalid-package-reason impl cfg pkg)
+  (let ((res (invalid-package-reason pkg)))
+    (and res
+         (not (yes-or-no? cfg "Package invalid: " res "\nProceed anyway?"))
+         res)))
+
+(define (package-maybe-digest-mismatches impl cfg pkg raw)
+  (and (not (conf-get cfg 'ignore-digests?))
+       (let ((res (package-digest-mismatches cfg pkg raw)))
+         (and res
+              (not (yes-or-no? cfg "Package checksum mismatches: " res
+                               "\nProceed anyway?"))
+              res))))
+
+(define (package-maybe-signature-mismatches repo impl cfg pkg raw)
+  (cond
+   ((conf-get cfg 'ignore-signature?) #f)
+   ((not (assq 'signature (cdr pkg)))
+    (if (yes-or-no? cfg "Package signature missing.\nProceed anyway?")
+        #f
+        '(package-signature-missing)))
+   (else
+    (let ((res (package-signature-mismatches repo cfg pkg raw)))
+      (and res
+           (not (yes-or-no? cfg "Package signature mismatches: " res
+                            "\nProceed anyway?"))
+           res)))))
+
+(define (install-package repo impl cfg pkg)
+  (cond
+   ((maybe-invalid-package-reason impl cfg pkg)
+    => (lambda (x) (die 2 "package invalid: " x)))
+   (else
+    (let* ((url (package-url repo pkg))
+           (raw (fetch-package cfg url))
+           (snowball (maybe-gunzip raw)))
+      (cond
+       ((not (tar-safe? snowball))
+        (die 2 "package tarball should contain a single relative directory: "
+             (tar-files snowball)))
+       ((package-maybe-digest-mismatches impl cfg pkg snowball)
+        => (lambda (x) (die 2 "package checksum didn't match: " x)))
+       ((package-maybe-signature-mismatches repo impl cfg pkg snowball)
+        => (lambda (x) (die 2 "package signature didn't match: " x)))
+       (else
+        (call-with-temp-dir
+         "pkg"
+         (lambda (dir)
+           (tar-extract snowball (lambda (f) (make-path dir (path-strip-top f))))
+           (let ((installed-files
+                  (append
+                   (append-map
+                    (lambda (lib)
+                      (build-library impl cfg lib dir)
+                      (test-library impl cfg lib dir)
+                      (install-library impl cfg lib dir))
+                    (package-libraries pkg))
+                   (append-map
+                    (lambda (prog)
+                      (build-program impl cfg prog dir)
+                      (install-program impl cfg prog dir))
+                    (package-programs pkg)))))
+             (install-package-meta-info
+              impl cfg
+              `(,@(remove (lambda (x)
+                            (and (pair? x) (eq? 'installed-files (car x))))
+                          pkg)
+                (installed-files ,@installed-files))))))))))))
+
+(define (install-for-implementation repo impl cfg pkgs)
+  (for-each
+   (lambda (pkg) (install-package repo impl cfg pkg))
+   pkgs))
+
+(define (select-best-candidate impl cfg repo candidates)
+  (cond
+   ((null? (cdr candidates))
+    (car candidates))
+   (else
+    (display "Select a package:\n")
+    (let lp ((ls candidates) (i 1))
+      (if (pair? ls)
+          (let ((pkg (car ls)))
+            (display "  ") (display i)
+            (display "  ") (display (package-name pkg))
+            (display " ") (display (package-version pkg))
+            (display " (") (display (package-author repo pkg #t))
+            (display ")\n")
+            (lp (cdr ls) (+ i 1)))))
+    (let ((n (input-number cfg 'candidate-number "Candidate number: "
+                           1 1 (length candidates))))
+      (list-ref candidates (- n 1))))))
+
+;; Choose packages for the corresponding libraries, and recursively
+;; select uninstalled packages.  Verifies and records preferences for
+;; trusting publishers for different library prefixes.
+(define (expand-package-dependencies repo impl cfg lib-names)
+  (let ((current (installed-libraries impl cfg)))
+    (let lp ((ls lib-names) (res '()) (ignored '()))
+      (cond
+       ((null? ls) res)
+       ((find (lambda (pkg) (package-provides? pkg (car ls))) res)
+        (lp (cdr ls) res ignored))
+       (else
+        (let* ((current-version
+                (cond ((assoc (car ls) current)
+                       => (lambda (x) (package-version (cdr x))))
+                      (else #f)))
+               (candidates
+                (filter
+                 (lambda (pkg)
+                   (and (package-provides? pkg (car ls))
+                        (or (not current-version)
+                            (version>? (package-version pkg)
+                                       current-version))))
+                 (cdr repo))))
+          (cond
+           ((member (car ls) ignored)
+            (lp (cdr ls) res ignored))
+           ((and (null? candidates) (assoc (car ls) current))
+            (if (member (car ls) lib-names)
+                (warn "skipping already installed library" (car ls)))
+            (lp (cdr ls) res (cons (car ls) ignored)))
+           ((and (null? candidates) (member (car ls) lib-names))
+            (die 2 "Can't find package: " (car ls)))
+           ((null? candidates)
+            (if (yes-or-no? cfg "Can't find package: " (car ls)
+                            ".  Proceed anyway?")
+                (lp (cdr ls) res (cons (car ls) ignored))
+                (exit 2)))
+           (else
+            (let ((pkg (select-best-candidate impl cfg repo candidates)))
+              (lp (append (package-dependencies pkg) (cdr ls))
+                  (cons pkg res)
+                  ignored))))))))))
+
+;; First lookup dependencies for all implementations so we can
+;; download in a single batch.  Then perform the installations a
+;; single implementation at a time.
+(define (command/install cfg spec . args)
+  (let* ((repo (maybe-update-repository cfg))
+         (impls (conf-selected-implementations cfg))
+         (impl-cfgs (map (lambda (impl)
+                           (conf-for-implementation cfg impl))
+                         impls))
+         (lib-names (map parse-library-name args))
+         (impl-pkgs
+          (map (lambda (impl cfg)
+                 (expand-package-dependencies repo impl cfg lib-names))
+               impls
+               impl-cfgs)))
+    (for-each
+     (lambda (impl cfg pkgs)
+       (install-for-implementation repo impl cfg pkgs))
+     impls
+     impl-cfgs
+     impl-pkgs)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Upgrade - upgrade installed packages.
+
+;; With explicit packages same as install, but by default upgrade all
+;; available packages.
+(define (command/upgrade cfg spec . args)
+  (if (pair? args)
+      (apply command/install cfg spec args)
+      (let* ((repo (maybe-update-repository cfg))
+             (impls (conf-selected-implementations cfg))
+             (impl-cfgs (map (lambda (impl)
+                               (conf-for-implementation cfg impl))
+                             impls)))
+        (for-each
+         (lambda (impl cfg)
+           (let ((pkgs (map cdr (installed-libraries impl cfg))))
+             (install-for-implementation repo impl cfg pkgs)))
+         impls
+         impl-cfgs))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Status - show the status of installed libraries.
+
+(define (command/status cfg spec . args)
+  (let* ((impls (conf-selected-implementations cfg))
+         (impl-cfgs (map (lambda (impl)
+                           (conf-for-implementation cfg impl))
+                         impls)))
+    (for-each
+     (lambda (impl impl-cfg)
+       (cond
+        ((pair? (cdr impls))
+         (if (not (eq? impl (car impls)))
+             (display "\n"))
+         (display impl)
+         (display ":\n")))
+       (summarize-libraries
+        impl-cfg
+        (if (pair? args)
+            (lookup-installed-libraries
+             impl impl-cfg (map parse-library-name args))
+            (installed-libraries impl impl-cfg))))
+     impls
+     impl-cfgs)))
diff --git a/lib/chibi/snow/commands.sld b/lib/chibi/snow/commands.sld
new file mode 100644
index 00000000..7037b3d1
--- /dev/null
+++ b/lib/chibi/snow/commands.sld
@@ -0,0 +1,50 @@
+
+(define-library (chibi snow commands)
+  (export command/package
+          command/gen-key
+          command/reg-key
+          command/sign
+          command/verify
+          command/upload
+          command/install
+          command/remove
+          command/search
+          command/show
+          command/status
+          command/update
+          command/upgrade)
+  (import (scheme base)
+          (scheme eval)
+          (scheme file)
+          (scheme process-context)
+          (scheme time)
+          (scheme read)
+          (scheme write)
+          (srfi 1)
+          (srfi 27)
+          (srfi 33)
+          (srfi 95)
+          (chibi snow interface)
+          (chibi snow package)
+          (chibi snow utils)
+          (chibi bytevector)
+          (chibi config)
+          (chibi crypto md5)
+          (chibi crypto rsa)
+          (chibi crypto sha2)
+          (chibi doc)
+          (chibi filesystem)
+          (chibi io)
+          (chibi match)
+          (chibi net http)
+          (chibi process)
+          (chibi pathname)
+          (chibi regexp)
+          (chibi show)
+          (chibi show pretty)
+          (chibi string)
+          (chibi sxml)
+          (chibi system)
+          (chibi tar)
+          (chibi zlib))
+  (include "commands.scm"))
diff --git a/lib/chibi/snow/interface.scm b/lib/chibi/snow/interface.scm
new file mode 100644
index 00000000..fd44f255
--- /dev/null
+++ b/lib/chibi/snow/interface.scm
@@ -0,0 +1,97 @@
+
+;; Abstract user interface for the snow command.  This could be
+;; substituted with a different implementation to provide a GUI.
+
+(define (message . args)
+  (for-each display args)
+  (newline))
+
+(define (info . args)
+  (apply message args))
+
+(define (warn msg . args)
+  (let ((err (current-error-port)))
+    (display "WARNING: " err)
+    (display msg err)
+    (display ": " err)
+    (if (and (pair? args) (null? (cdr args)))
+        (write (car args) err)
+        (for-each (lambda (x) (display "\n  " err) (write x err)) args))
+    (newline err)))
+
+(define (die x . args)
+  (let ((n (if (number? x) x 2))
+        (args (if (number? x) args (cons x args)))
+        (err (current-error-port)))
+    (for-each (lambda (x) (display x err)) args)
+    (newline err)
+    (exit n)))
+
+(define input-history #f)
+
+(define (conf-input-history-file cfg)
+  (or (conf-get cfg 'input-history)
+      (string-append (or (conf-get cfg 'snow-dir)
+                         (string-append (get-environment-variable "HOME")
+                                        "/.snow"))
+                     "/input-history.scm")))
+
+(define (restore-history cfg)
+  (let ((history-file (conf-input-history-file cfg)))
+    (set! input-history
+          (or (guard (exn (else #f))
+                (list->history (call-with-input-file history-file read)))
+              (make-history)))))
+
+(define (save-history cfg)
+  (let ((history-file (conf-input-history-file cfg)))
+    (guard (exn (else (warn "couldn't save history to " history-file)))
+      (call-with-output-file history-file
+        (lambda (out)
+          (write (remove (lambda (x) (equal? x ""))
+                         (history->list input-history))
+                 out))))))
+
+(define (input cfg name prompt . o)
+  (let ((proc (or (and (pair? o) (car o)) (lambda (x) x)))
+        (check (or (and (pair? o) (pair? (cdr o)) (cadr o))
+                   (lambda (str res lp) res))))
+    (let lp ((reason #f))
+      (cond
+       ((and (not reason) (conf-get cfg name))
+        => (lambda (res) (check "" res lp)))
+       (else
+        (if reason
+            (show #t reason fl))
+        (let ((str (edit-line 'prompt: (lambda () (show #f prompt))
+                              'history: input-history)))
+          (history-insert! input-history str)
+          (check str (proc str) lp)))))))
+
+(define (input-number cfg name prompt . o)
+  (let* ((default (and (pair? o) (car o)))
+         (lo (and (pair? o) (pair? (cdr o)) (cadr o)))
+         (hi (and (pair? o) (pair? (cdr o)) (pair? (cddr o)) (car (cddr o))))
+         (prompt
+          (if default (each prompt " [default=" default "]: ") prompt))
+         (proc (lambda (str)
+                 (if (and default (equal? str ""))
+                     default
+                     (string->number str))))
+         (check
+          (lambda (str res fail)
+            (cond
+             ((not (number? res))
+              (fail "not a valid number"))
+             ((and lo (< res lo))
+              (fail (each "too low, must be greater than " lo)))
+             ((and hi (> res hi))
+              (fail (each "too high, must be less than " hi)))
+             (else
+              res)))))
+    (input cfg name prompt proc check)))
+
+(define (yes-or-no? cfg . prompt)
+  (define (is-true? str)
+    (and (member (string-downcase str) '("#t" "y" "yes")) #t))
+  (input cfg 'always-yes? (each (each-in-list prompt) " [y/n]: ") is-true?))
diff --git a/lib/chibi/snow/interface.sld b/lib/chibi/snow/interface.sld
new file mode 100644
index 00000000..23d6819d
--- /dev/null
+++ b/lib/chibi/snow/interface.sld
@@ -0,0 +1,8 @@
+
+(define-library (chibi snow interface)
+  (export warn info message die input input-number yes-or-no?
+          restore-history save-history)
+  (import (scheme base) (scheme char) (scheme read) (scheme write)
+          (scheme file) (scheme process-context) (srfi 1)
+          (chibi config) (chibi show) (chibi stty) (chibi term edit-line))
+  (include "interface.scm"))
diff --git a/lib/chibi/snow/package.scm b/lib/chibi/snow/package.scm
new file mode 100644
index 00000000..8ed65b0c
--- /dev/null
+++ b/lib/chibi/snow/package.scm
@@ -0,0 +1,322 @@
+
+;; general utils
+
+(define (read-from-string str)
+  (call-with-input-string str read))
+
+(define (display-to-string x)
+  (cond ((string? x) x)
+        ((symbol? x) (symbol->string x))
+        ((number? x) (number->string x))
+        (else (call-with-output-string (lambda (out) (display x out))))))
+
+(define (maybe-parse-hex x)
+  (if (string? x) (hex-string->bytevector x) x))
+
+;; rsa key utils
+
+(define (lookup-digest name)
+  (case name
+    ((md5) md5)
+    ((sha-224) sha-224)
+    ((sha-256) sha-256)
+    (else (error "unknown digest: " name))))
+
+(define (rsa-identity=? email)
+  (lambda (x)
+    (cond ((not email) #f)
+          ((assoc-get x 'email eq?)
+           => (lambda (e) (string-ci=? email e)))
+          (else #f))))
+
+(define (extract-rsa-key ls name)
+  (define (hex x)
+    (if (integer? x) x (string->number x 16)))
+  (cond
+   ((assq name ls)
+    => (lambda (x)
+         (let ((bits (assoc-get ls 'bits))
+               (modulus (assoc-get (cdr x) 'modulus))
+               (exponent (assoc-get (cdr x) 'exponent)))
+           (and bits modulus exponent
+                (if (eq? name 'private-key)
+                    (make-rsa-key (hex bits) (hex modulus) #f (hex exponent))
+                    (make-rsa-key (hex bits) (hex modulus)
+                                  (hex exponent) #f))))))
+   (else #f)))
+
+(define (extract-rsa-private-key ls)
+  (extract-rsa-key ls 'private-key))
+
+(define (extract-rsa-public-key ls)
+  (extract-rsa-key ls 'public-key))
+
+;; repositories
+
+(define (repo-url repo)
+  (and (pair? repo) (assoc-get (cdr repo) 'url eq?)))
+
+(define (repo-find-publisher repo email)
+  (find (rsa-identity=? email)
+        (filter (lambda (x) (and (pair? x) (eq? 'publisher (car x))))
+                (cdr repo))))
+
+;; packages
+
+(define (package? x)
+  (and (pair? x) (eq? 'package (car x)) (every pair? (cdr x))))
+
+(define (package-name package)
+  (and (pair? package)
+       (eq? 'package (car package))
+       (or (cond ((assoc-get (cdr package) 'name)
+                  => (lambda (x) (and (pair? x) x)))
+                 (else #f))
+           ;; TODO: longest common prefix
+           (let ((lib (assq 'library (cdr package))))
+             (and lib (library-name lib))))))
+
+(define (package-email pkg)
+  (and (package? pkg)
+       (let ((sig (assq 'signature (cdr pkg))))
+         (and (pair? sig)
+              (assoc-get (cdr sig) 'email eq?)))))
+
+(define (package-author repo pkg . o)
+  (and (package? pkg)
+       (let ((email (package-email pkg))
+             (show-email? (and (pair? o) (car o))))
+         (or (cond
+              ((repo-find-publisher repo email)
+               => (lambda (pub)
+                    (let ((name (assoc-get pub 'name)))
+                      (if (and name show-email?)
+                          (string-append name " <" (or email "") ">")
+                          (or name email "")))))
+              (else #f))
+             email))))
+
+(define (package-url repo pkg)
+  (let ((url (and (pair? pkg) (assoc-get (cdr pkg) 'url eq?))))
+    (and url
+         (uri-resolve url (string->path-uri 'http (repo-url repo))))))
+
+(define (package-version pkg)
+  (and (pair? pkg) (assoc-get (cdr pkg) 'version eq?)))
+
+(define (package-digest-mismatches cfg pkg raw)
+  (let ((size (assoc-get (cdr pkg) 'size))
+        (actual-size (bytevector-length raw)))
+    (if (and (integer? size) (not (= size actual-size)))
+        `(size: expected: ,size actual: ,actual-size)
+        (let* ((digest-name (assoc-get (cdr pkg) 'digest #f 'sha-256))
+               (digest (assoc-get (cdr pkg) digest-name))
+               (actual-digest ((lookup-digest digest-name) raw)))
+          (and digest
+               (not (equal? digest actual-digest))
+               `(digest: ,digest-name expected: ,digest
+                         actual: ,actual-digest))))))
+
+(define (package-digest-ok? cfg pkg raw)
+  (not (package-digest-mismatches cfg pkg raw)))
+
+(define (package-signature-mismatches repo cfg pkg raw)
+  (let* ((sig-spec (assoc-get-list (cdr pkg) 'signature))
+         (digest-name (assoc-get sig-spec 'digest #f 'sha-256))
+         (digest (assoc-get sig-spec digest-name))
+         (sig (assoc-get sig-spec 'rsa))
+         (email (assoc-get sig-spec 'email))
+         (rsa-key-sexp (repo-find-publisher repo email))
+         (rsa-key (and (pair? rsa-key-sexp)
+                       (extract-rsa-public-key (cdr rsa-key-sexp)))))
+    (cond
+     ((not email)
+      `(sign: missing-email ,sig-spec))
+     ((not rsa-key)
+      `(sign: unknown-publisher: ,email))
+     ((not (rsa-verify? rsa-key
+                        (maybe-parse-hex digest)
+                        (maybe-parse-hex sig)))
+      `(sign: rsa-signature-invalid: digest: ,digest sig: ,sig
+              actual: ,(rsa-verify rsa-key (maybe-parse-hex digest))))
+     (else #f))))
+
+(define (package-signature-ok? cfg pkg raw)
+  (not (package-signature-mismatches cfg pkg raw)))
+
+(define (failure str . args)
+  (let ((out (open-output-string)))
+    (display str out)
+    (cond
+     ((pair? args)
+      (display ":" out)
+      (for-each (lambda (x) (display " " out) (write x out)) args)))
+    (get-output-string out)))
+
+(define (invalid-library-reason lib)
+  (cond
+   ((not (list? lib)) "library must be a list")
+   ((not (list? (library-name lib)))
+    (failure "library name must be a list" (library-name lib)))
+   ((not (every (lambda (x) (or (symbol? x) (integer? x))) (library-name lib)))
+    (failure "library name must contain only symbols or integers"
+             (library-name lib)))
+   (else #f)))
+
+(define (valid-library? lib)
+  (not (invalid-library-reason lib)))
+
+(define (invalid-package-reason pkg)
+  (cond
+   ((not (list? pkg))
+    "package must be a list")
+   ((not (string? (package-version pkg)))
+    (failure "package-version is not a string" (package-version pkg)))
+   (else
+    (let ((libs (package-libraries pkg)))
+      (cond
+       ((not (pair? libs)) "package must contain at least one library")
+       ((any invalid-library-reason libs))
+       (else #f))))))
+
+(define (valid-package? pkg)
+  (not (invalid-package-reason pkg)))
+
+(define (package-libraries package)
+  (and (package? package) (filter library? (cdr package))))
+
+(define (package-provides? package name)
+  (and (pair? package)
+       (eq? 'package (car package))
+       (or (equal? name (assoc-get (cdr package) 'name))
+           (find (lambda (x) (equal? name (library-name x)))
+                 (package-libraries package)))))
+
+(define (package-dependencies package)
+  (append-map library-dependencies
+              (package-libraries package)))
+
+(define (package-installed-files pkg)
+  (or (and (pair? pkg) (assoc-get-list (cdr pkg) 'installed-files)) '()))
+
+(define (library-name->path name)
+  (if (null? name)
+      ""
+      (call-with-output-string
+        (lambda (out)
+          (let lp ((name name))
+            (display (car name) out)
+            (cond ((pair? (cdr name))
+                   (write-char #\/ out)
+                   (lp (cdr name)))))))))
+
+;; map a library to the path name it would be found in (sans extension)
+(define (library->path library)
+  (library-name->path (library-name library)))
+
+;; find the library declaration file for the given library
+(define (get-library-file cfg library)
+  (or (assoc-get library 'path)
+      (string-append (library->path library) "."
+                     (conf-get cfg 'library-extension "sld"))))
+
+(define (package->path pkg)
+  (library-name->path (package-name pkg)))
+
+(define (package-name->meta-file cfg name)
+  (let ((path (library-name->path name)))
+    (string-append (path-directory path) "/."
+                   (path-strip-directory path) ".meta")))
+
+(define (get-package-meta-file cfg pkg)
+  (package-name->meta-file cfg (package-name pkg)))
+
+(define (get-library-meta-file cfg lib)
+  (package-name->meta-file cfg (library-name lib)))
+
+;; libraries
+
+(define (library? x)
+  (and (pair? x) (eq? 'library (car x)) (every pair? (cdr x))))
+
+(define (library-name lib)
+  (and (pair? lib) (assoc-get (cdr lib) 'name eq?)))
+
+(define (library-url lib)
+  (and (pair? lib) (assoc-get (cdr lib) 'url eq?)))
+
+(define (library-dependencies lib)
+  (cond ((assq 'depends (cdr lib)) => cdr)
+        (else '())))
+
+(define (parse-library-name str)
+  (cond
+   ((pair? str) str)
+   ((equal? "" str) (error "empty library name"))
+   ((eqv? #\( (string-ref str 0)) (read-from-string str))
+   (else (map (lambda (x) (or (string->number x) (string->symbol x)))
+              (string-split str #\.)))))
+
+(define (check-cond-expand config test)
+  (define (library-installed? config name)
+    ;; assume it could be installed for now
+    #t)
+  (cond
+   ((symbol? test)
+    (or (eq? 'else test) (memq test (conf-get-list config 'features))))
+   ((pair? test)
+    (case (car test)
+      ((not) (not (check-cond-expand config (cadr test))))
+      ((and) (every (lambda (x) (check-cond-expand config x)) (cdr test)))
+      ((or) (any (lambda (x) (check-cond-expand config x)) (cdr test)))
+      ((library) (every (lambda (x) (library-installed? config x)) (cdr test)))
+      (else
+       (warn "unknown cond-expand form" test)
+       #f)))
+   (else #f)))
+
+;; We can't use the native library system introspection since we may
+;; be analyzing a library which can't be loaded in the native system.
+(define (library-analyze config file)
+  (let ((sexp (call-with-input-file file read)))
+    (and (list? sexp)
+         (memq (car sexp) '(define-library library define-module module))
+         (let analyze ((ls (cddr sexp)))
+           (cond
+            ((null? ls) '())
+            (else
+             (append
+              (case (caar ls)
+                ((cond-expand)
+                 (cond
+                  ((find (lambda (x) (check-cond-expand config (car x))) (cdar ls))
+                   => (lambda (x) (analyze (cdr x))))
+                  (else (analyze (cdr ls)))))
+                (else (list (car ls))))
+              (analyze (cdr ls)))))))))
+
+(define (library-include-files config file)
+  (let ((lib (library-analyze config file))
+        (dir (path-directory file)))
+    (append-map
+     (lambda (x) (map (lambda (y) (make-path dir y)) (cdr x)))
+     (filter (lambda (x) (and (pair? x) (memq (car x) '(include include-ci))))
+             lib))))
+
+(define (library-rewrite-includes x rules)
+  (define (recurse x) (library-rewrite-includes x rules))
+  (define (rewrite x)
+    (cond ((any (lambda (r) (and (pair? r) (equal? x (car r)))) rules) => cdr)
+          (else x)))
+  (cond
+   ((pair? x)
+    (case (car x)
+      ((include include-ci)
+       (cons (car x) (map rewrite (cdr x))))
+      ((cond-expand)
+       (cons (car x)
+             (map (lambda (y) (cons (car y) (map recurse (cdr y)))) (cdr x))))
+      ((define-library library)
+       (cons (car x) (map recurse (cdr x))))
+      (else x)))
+   (else x)))
diff --git a/lib/chibi/snow/package.sld b/lib/chibi/snow/package.sld
new file mode 100644
index 00000000..f0eb3c86
--- /dev/null
+++ b/lib/chibi/snow/package.sld
@@ -0,0 +1,30 @@
+
+(define-library (chibi snow package)
+  (export package? library?
+          package-name package-email package-url package-version
+          package-libraries package-provides? package-dependencies
+          package-installed-files package-author
+          package-digest-mismatches package-signature-mismatches
+          package-digest-ok? package-signature-ok?
+          package->path package-name->meta-file
+          get-package-meta-file get-library-meta-file
+          library-name->path library->path get-library-file
+          library-url library-name parse-library-name library-name->path
+          library-analyze library-include-files library-dependencies
+          library-rewrite-includes
+          invalid-package-reason valid-package?
+          invalid-library-reason valid-library?
+          repo-find-publisher lookup-digest rsa-identity=?
+          extract-rsa-private-key extract-rsa-public-key)
+  (import (chibi)
+          (srfi 1)
+          (chibi snow interface)
+          (chibi bytevector)
+          (chibi config)
+          (chibi crypto md5)
+          (chibi crypto rsa)
+          (chibi crypto sha2)
+          (chibi pathname)
+          (chibi string)
+          (chibi uri))
+  (include "package.scm"))
diff --git a/lib/chibi/snow/utils.scm b/lib/chibi/snow/utils.scm
new file mode 100644
index 00000000..941e8dd0
--- /dev/null
+++ b/lib/chibi/snow/utils.scm
@@ -0,0 +1,53 @@
+
+;;> Copies the file \var{from} to \var{to}.
+
+(define (copy-file from to)
+  (let ((in (open-binary-input-file from))
+        (out (open-binary-output-file to)))
+    (let lp ()
+      (let ((n (read-u8 in)))
+        (cond ((eof-object? n) (close-input-port in) (close-output-port out))
+              (else (write-u8 n out) (lp)))))))
+
+(define (call-with-temp-file template proc)
+  (let ((base (string-append
+               "/tmp/" (path-strip-extension template)
+               "-" (number->string (current-process-id)) "-"
+               (number->string (exact (round (current-second)))) "-"))
+        (ext (or (path-extension template) "tmp")))
+    (let lp ((i 0))
+      (let ((path (string-append base (number->string i) "." ext)))
+        (cond
+         ((> i 100)  ;; give up after too many tries regardless
+          (die 2 "Repeatedly failed to generate temp file in /tmp"))
+         ((file-exists? path)
+          (lp (+ i 1)))
+         (else
+          (let ((fd (open path
+                          (bitwise-ior open/write open/create open/exclusive))))
+            (if (not fd)
+                (if (file-exists? path) ;; created between test and open
+                    (lp (+ i 1))
+                    (die 2 "Couldn't generate temp file in /tmp " path))
+                (let* ((out (open-output-file-descriptor fd #o700))
+                       (res (proc path out)))
+                  (close-output-port out)
+                  (delete-file path)
+                  res)))))))))
+
+(define (call-with-temp-dir template proc)
+  (let ((base (string-append
+               "/tmp/" template
+               "-" (number->string (current-process-id)) "-"
+               (number->string (exact (round (current-second)))) "-")))
+    (let lp ((i 0))
+      (let ((path (string-append base (number->string i))))
+        (cond
+         ((> i 100)  ;; give up after too many tries
+          (die 2 "Repeatedly failed to generate temp dir in /tmp " path))
+         ((file-exists? path)
+          (lp (+ i 1)))
+         ((create-directory path #o700)
+          (let ((res (proc path)))
+            (delete-file-hierarchy path)
+            res)))))))
diff --git a/lib/chibi/snow/utils.sld b/lib/chibi/snow/utils.sld
new file mode 100644
index 00000000..d0d1a262
--- /dev/null
+++ b/lib/chibi/snow/utils.sld
@@ -0,0 +1,12 @@
+
+(define-library (chibi snow utils)
+  (export copy-file call-with-temp-file call-with-temp-dir)
+  (import (scheme base)
+          (scheme file)
+          (scheme time)
+          (srfi 33)
+          (chibi filesystem)
+          (chibi pathname)
+          (chibi process)
+          (chibi snow interface))
+  (include "utils.scm"))
diff --git a/lib/chibi/string.scm b/lib/chibi/string.scm
new file mode 100644
index 00000000..9a19fcc4
--- /dev/null
+++ b/lib/chibi/string.scm
@@ -0,0 +1,198 @@
+;; strings.scm -- cursor-oriented string library
+;; Copyright (c) 2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (string-null? str)
+  (equal? str ""))
+
+(define (make-char-predicate x)
+  (cond ((procedure? x) x)
+        ((char? x) (lambda (ch) (eq? ch x)))
+        ((char-set? x) (lambda (ch) (char-set-contains? x ch)))
+        (else (error "invalid character predicate" x))))
+
+(define (complement pred) (lambda (x) (not (pred x))))
+
+(define (string-any x str)
+  (let ((pred (make-char-predicate x))
+        (end (string-cursor-end str)))
+    (and (string-cursor>? end (string-cursor-start str))
+         (let lp ((i (string-cursor-start str)))
+           (let ((i2 (string-cursor-next str i))
+                 (ch (string-cursor-ref str i)))
+             (if (string-cursor>=? i2 end)
+                 (pred ch)  ;; tail call
+                 (or (pred ch) (lp i2))))))))
+
+(define (string-every x str)
+  (not (string-any (complement (make-char-predicate x)) str)))
+
+(define (string-find str x . o)
+  (let ((pred (make-char-predicate x))
+        (end (if (and (pair? o) (pair? (cdr o)))
+                 (cadr o)
+                 (string-cursor-end str))))
+    (let lp ((i (if (pair? o) (car o) (string-cursor-start str))))
+      (cond ((string-cursor>=? i end) end)
+            ((pred (string-cursor-ref str i)) i)
+            (else (lp (string-cursor-next str i)))))))
+
+(define (string-find? str x . o)
+  (let ((start (if (pair? o) (car o) (string-cursor-start str)))
+        (end (if (and (pair? o) (pair? (cdr o)))
+                 (cadr o)
+                 (string-cursor-end str))))
+    (< (string-find str x start end) end)))
+
+(define (string-find-right str x . o)
+  (let ((pred (make-char-predicate x))
+        (start (if (pair? o) (car o) (string-cursor-start str))))
+    (let lp ((i (if (and (pair? o) (pair? (cdr o)))
+                    (cadr o)
+                    (string-cursor-end str))))
+      (let ((i2 (string-cursor-prev str i)))
+        (cond ((string-cursor<? i2 start) start)
+              ((pred (string-cursor-ref str i2)) i)
+              (else (lp i2)))))))
+
+(define (string-skip str x . o)
+  (apply string-find str (complement (make-char-predicate x)) o))
+
+(define (string-skip-right str x . o)
+  (apply string-find-right str (complement (make-char-predicate x)) o))
+
+(define string-join string-concatenate)
+
+(define (string-split str . o)
+  (let ((pred (make-char-predicate (if (pair? o) (car o) #\space)))
+        (limit (if (and (pair? o) (pair? (cdr o)))
+                   (cadr o)
+                   (+ 1 (string-size str))))
+        (start (string-cursor-start str))
+        (end (string-cursor-end str)))
+    (if (string-cursor>=? start end)
+        '()
+        (let lp ((i start) (n 1) (res '()))
+          (cond
+           ((>= n limit)
+            (reverse (cons (substring-cursor str i) res)))
+           (else
+            (let* ((j (string-find str pred i))
+                   (res (cons (substring-cursor str i j) res)))
+              (if (string-cursor>=? j end)
+                  (reverse res)
+                  (lp (string-cursor-next str j) (+ n 1) res)))))))))
+
+(define (string-trim-left str . o)
+  (let ((pred (make-char-predicate (if (pair? o) (car o) #\space))))
+    (substring-cursor str (string-skip str pred))))
+
+(define (string-trim-right str . o)
+  (let ((pred (make-char-predicate (if (pair? o) (car o) #\space))))
+    (substring-cursor str
+                      (string-cursor-start str)
+                      (string-skip-right str pred))))
+
+(define (string-trim str . o)
+  (let* ((pred (if (pair? o) (car o) #\space))
+         (left (string-skip str pred))
+         (right (string-skip-right str pred)))
+    (if (string-cursor>=? left right)
+        ""
+        (substring-cursor str left right))))
+
+(define (string-mismatch prefix str)
+  (let ((end1 (string-cursor-end prefix))
+        (end2 (string-cursor-end str)))
+    (let lp ((i (string-cursor-start prefix))
+             (j (string-cursor-start str)))
+      (if (or (string-cursor>=? i end1)
+              (string-cursor>=? j end2)
+              (not (eq? (string-cursor-ref prefix i) (string-cursor-ref str j))))
+          j
+          (lp (string-cursor-next prefix i) (string-cursor-next str j))))))
+
+(define (string-mismatch-right suffix str)
+  (let ((end1 (string-cursor-start suffix))
+        (end2 (string-cursor-start str)))
+    (let lp ((i (string-cursor-prev suffix (string-cursor-end suffix)))
+             (j (string-cursor-prev str (string-cursor-end str))))
+      (if (or (string-cursor<? i end1)
+              (string-cursor<? j end2)
+              (not (eq? (string-cursor-ref suffix i) (string-cursor-ref str j))))
+          j
+          (lp (string-cursor-prev suffix i) (string-cursor-prev str j))))))
+
+;; TODO: These definitions are specific to the Chibi implementation of
+;; cursors.  Possibly the mismatch API should be modified to allow an
+;; efficient portable definition.
+(define (string-prefix? prefix str)
+  (= (string-cursor-end prefix) (string-mismatch prefix str)))
+
+(define (string-suffix? suffix str)
+  (= (string-cursor-prev suffix (string-cursor-start suffix))
+     (- (string-mismatch-right suffix str)
+        (- (string-cursor-end str) (string-cursor-end suffix)))))
+
+(define (string-fold kons knil str . los)
+  (if (null? los)
+      (let ((end (string-cursor-end str)))
+        (let lp ((i (string-cursor-start str)) (acc knil))
+          (if (string-cursor>=? i end)
+              acc
+              (lp (string-cursor-next str i)
+                  (kons (string-cursor-ref str i) acc)))))
+      (let ((los (cons str los)))
+        (let lp ((is (map string-cursor-start los))
+                 (acc knil))
+          (if (any (lambda (str i)
+                     (string-cursor>=? i (string-cursor-end str)))
+                   los is)
+              acc
+              (lp (map string-cursor-next los is)
+                  (apply kons (append (map string-cursor-ref los is)
+                                      (list acc)))))))))
+
+(define (string-fold-right kons knil str)
+  (let ((end (string-cursor-end str)))
+    (let lp ((i (string-cursor-start str)))
+      (if (string-cursor>=? i end)
+          knil
+          (kons (string-cursor-ref str i) (lp (string-cursor-next str i)))))))
+
+(define (string-count str x)
+  (let ((pred (make-char-predicate x)))
+    (string-fold (lambda (ch count) (if (pred ch) (+ count 1) count)) 0 str)))
+
+(define (string-for-each proc str . los)
+  (if (null? los)
+      (string-fold (lambda (ch a) (proc ch)) #f str)
+      (let ((los (cons str los)))
+	(let lp ((is (map string-cursor-start los)))
+	  (cond
+	   ((any (lambda (str i)
+		   (string-cursor>=? i (string-cursor-end str)))
+		 los is))
+	   (else
+	    (apply proc (map string-cursor-ref los is))
+	    (lp (map string-cursor-next los is))))))))
+
+(define (string-map proc str . los)
+  (call-with-output-string
+    (lambda (out)
+      (apply string-for-each
+	     (lambda args (write-char (apply proc args) out))
+	     str los))))
+
+(define (make-string-searcher needle)
+  (lambda (haystack) (string-contains haystack needle)))
+
+(define (string-downcase-ascii s)
+  (call-with-output-string
+    (lambda (out)
+      (string-for-each (lambda (ch) (write-char (char-downcase ch) out)) s))))
+
+(define (string-upcase-ascii s)
+  (call-with-output-string
+    (lambda (out)
+      (string-for-each (lambda (ch) (write-char (char-upcase ch) out)) s))))
diff --git a/lib/chibi/string.sld b/lib/chibi/string.sld
new file mode 100644
index 00000000..3bbb7eef
--- /dev/null
+++ b/lib/chibi/string.sld
@@ -0,0 +1,17 @@
+
+(define-library (chibi string)
+  (export
+   string-cursor-start string-cursor-end string-cursor-ref
+   string-cursor<? string-cursor<=? string-cursor>? string-cursor>=?
+   string-cursor=? string-cursor-next string-cursor-prev substring-cursor
+   string-null? string-every string-any
+   string-join string-split string-count
+   string-trim string-trim-left string-trim-right
+   string-mismatch string-mismatch-right
+   string-prefix? string-suffix?
+   string-find string-find-right string-find? string-skip string-skip-right
+   string-fold string-fold-right string-map string-for-each
+   string-contains make-string-searcher
+   string-downcase-ascii string-upcase-ascii)
+  (import (chibi) (chibi ast) (chibi char-set base))
+  (include "string.scm"))
diff --git a/lib/chibi/stty.scm b/lib/chibi/stty.scm
new file mode 100644
index 00000000..7e404144
--- /dev/null
+++ b/lib/chibi/stty.scm
@@ -0,0 +1,263 @@
+;; Copyright (c) 2011 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> A high-level interface to stty and ioctl.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; symbolic representation of attributes
+
+(define stty-lookup (make-hash-table eq?))
+
+(for-each
+ (lambda (c)
+   (let ((type (cadr c))
+         (value (car (cddr c))))
+     (hash-table-set! stty-lookup (car c) (cdr c))))
+
+ ;; ripped from the stty man page, then trimmed down to what seemed
+ ;; available on most systems
+
+ `(;; characters
+   ;;(dsusp    char     ,VDSUSP)   ; CHAR will send a terminal stop signal
+   (eof      char     ,VEOF)     ; CHAR will send an EOF (terminate input)
+   (eol      char     ,VEOL)     ; CHAR will end the line
+   (eol2     char     ,VEOL2)    ; alternate CHAR for ending the line
+   (erase    char     ,VERASE)   ; CHAR will erase the last character typed
+   (intr     char     ,VINTR)    ; CHAR will send an interrupt signal
+   (kill     char     ,VKILL)    ; CHAR will erase the current line
+   (lnext    char     ,VLNEXT)   ; CHAR will enter the next character quoted
+   (quit     char     ,VQUIT)    ; CHAR will send a quit signal
+   (rprnt    char     ,VREPRINT) ; CHAR will redraw the current line
+   (start    char     ,VSTART)   ; CHAR will restart output after stopping it
+   (stop     char     ,VSTOP)    ; CHAR will stop the output
+   (susp     char     ,VSUSP)    ; CHAR will send a terminal stop signal
+   (werase   char     ,VWERASE)  ; CHAR will erase the last word typed
+
+   ;; special settings
+   (cols     special  #f) ; tell the kernel that the terminal has N columns
+   (columns  special  #f) ; same as cols N
+   (ispeed   special  #f) ; set the input speed to N
+   (line     special  #f) ; use line discipline N
+   (min      special  #f) ; with -icanon, set N characters minimum for a completed read
+   (ospeed   special  #f) ; set the output speed to N
+   (rows     special  #f) ; tell the kernel that the terminal has N rows
+   (size     special  #f) ; print the number of rows and columns according to the kernel
+   (speed    special  #f) ; print the terminal speed
+   (time     special  #f) ; with -icanon, set read timeout of N tenths of a second
+
+   ;; control settings
+   (clocal   control  ,CLOCAL)  ; disable modem control signals
+   (cread    control  ,CREAD)   ; allow input to be received
+   (crtscts  control  ,CRTSCTS) ; enable RTS/CTS handshaking
+   (cs5      control  ,CS5)     ; set character size to 5 bits
+   (cs6      control  ,CS6)     ; set character size to 6 bits
+   (cs7      control  ,CS7)     ; set character size to 7 bits
+   (cs8      control  ,CS8)     ; set character size to 8 bits
+   (cstopb   control  ,CSTOPB)  ; use two stop bits per character (one with `-')
+   (hup      control  ,HUPCL)   ; send a hangup signal when the last process closes the tty
+   (hupcl    control  ,HUPCL)   ; same as [-]hup
+   (parenb   control  ,PARENB)  ; generate parity bit in output and expect parity bit in input
+   (parodd   control  ,PARODD)  ; set odd parity (even with `-')
+
+   ;; input settings
+   (brkint   input    ,BRKINT)  ; breaks cause an interrupt signal
+   (icrnl    input    ,ICRNL)   ; translate carriage return to newline
+   (ignbrk   input    ,IGNBRK)  ; ignore break characters
+   (igncr    input    ,IGNCR)   ; ignore carriage return
+   (ignpar   input    ,IGNPAR)  ; ignore characters with parity errors
+   (imaxbel  input    ,IMAXBEL) ; * beep and do not flush a full input buffer on a character
+   (inlcr    input    ,INLCR)   ; translate newline to carriage return
+   (inpck    input    ,INPCK)   ; enable input parity checking
+   (istrip   input    ,ISTRIP)  ; clear high (8th) bit of input characters
+   ;;(iuclc    input    ,IUCLC)   ; * translate uppercase characters to lowercase
+   (ixany    input    ,IXANY)   ; * let any character restart output, not only start character
+   (ixoff    input    ,IXOFF)   ; enable sending of start/stop characters
+   (ixon     input    ,IXON)    ; enable XON/XOFF flow control
+   (parmrk   input    ,PARMRK)  ; mark parity errors (with a 255-0-character sequence)
+   (tandem   input    ,IXOFF)   ; same as [-]ixoff
+
+   ;; output settings
+   ;;(bs0      output   ,BS0) ; backspace delay style, N in [0..1]
+   ;;(bs1      output   ,BS1) ; backspace delay style, N in [0..1]
+   ;;(cr0      output   ,CR0) ; carriage return delay style, N in [0..3]
+   ;;(cr1      output   ,CR1) ; carriage return delay style, N in [0..3]
+   ;;(cr2      output   ,CR2) ; carriage return delay style, N in [0..3]
+   ;;(cr3      output   ,CR3) ; carriage return delay style, N in [0..3]
+   ;;(ff0      output   ,FF0) ; form feed delay style, N in [0..1]
+   ;;(ff1      output   ,FF1) ; form feed delay style, N in [0..1]
+   ;;(nl0      output   ,NL0) ; newline delay style, N in [0..1]
+   ;;(nl1      output   ,NL1) ; newline delay style, N in [0..1]
+   (ocrnl    output   ,OCRNL) ; translate carriage return to newline
+   ;;(ofdel    output   ,OFDEL) ; use delete characters for fill instead of null characters
+   ;;(ofill    output   ,OFILL) ; use fill (padding) characters instead of timing for delays
+   ;;(olcuc    output   ,OLCUC) ; translate lowercase characters to uppercase
+   (onlcr    output   ,ONLCR) ; translate newline to carriage return-newline
+   (onlret   output   ,ONLRET) ; newline performs a carriage return
+   (onocr    output   ,ONOCR) ; do not print carriage returns in the first column
+   (opost    output   ,OPOST) ; postprocess output
+   (tab0     output   #f) ; horizontal tab delay style, N in [0..3]
+   (tab1     output   #f) ; horizontal tab delay style, N in [0..3]
+   (tab2     output   #f) ; horizontal tab delay style, N in [0..3]
+   (tab3     output   #f) ; horizontal tab delay style, N in [0..3]
+   (tabs     output   #f) ; same as tab0
+   ;;(-tabs    output   #f) ; same as tab3
+   ;;(vt0      output   ,VT0) ; vertical tab delay style, N in [0..1]
+   ;;(vt1      output   ,VT1) ; vertical tab delay style, N in [0..1]
+
+   ;; local settings
+   (crterase local    ,ECHOE)   ; echo erase characters as backspace-space-backspace
+   (crtkill  local    ,ECHOKE)  ; kill all line by obeying the echoprt and echoe settings
+   ;;(-crtkill local    #f) ; kill all line by obeying the echoctl and echok settings
+   (ctlecho  local    ,ECHOCTL) ; echo control characters in hat notation (`^c')
+   (echo     local    ,ECHO)    ; echo input characters
+   (echoctl  local    ,ECHOCTL) ; same as [-]ctlecho
+   (echoe    local    ,ECHOE)   ; same as [-]crterase
+   ;;(echok    local    ,ECHOK)   ; echo a newline after a kill character
+   (echoke   local    ,ECHOKE)  ; same as [-]crtkill
+   (echonl   local    ,ECHONL)  ; echo newline even if not echoing other characters
+   ;;(echoprt  local    ,ECHOPRT) ; echo erased characters backward, between `\' and '/'
+   (icanon   local    ,ICANON)  ; enable erase, kill, werase, and rprnt special characters
+   ;;(iexten   local    ,IEXTEN)  ; enable non-POSIX special characters
+   (isig     local    ,ISIG)    ; enable interrupt, quit, and suspend special characters
+   (noflsh   local    ,NOFLSH)  ; disable flushing after interrupt and quit special characters
+   ;;(prterase local    ,ECHOPRT) ; same as [-]echoprt
+   (tostop   local    ,TOSTOP)  ; stop background jobs that try to write to the terminal
+   ;;(xcase    local    ,XCASE)   ; with icanon, escape with `\' for uppercase characters
+
+   ;; combination settings
+   (LCASE    combine  (lcase))
+   (cbreak   combine  (not icanon))
+   (cooked   combine  (brkint ignpar istrip icrnl ixon opost isig icanon))
+                                        ; also eof and eol characters
+                                        ; to their default values
+   (crt      combine  (echoe echoctl echoke))
+   (dec      combine  (echoe echoctl echoke (not ixany)))
+                                        ; also intr ^c erase 0177 kill ^u
+   (decctlq  combine  (ixany))
+   (ek       combine  ()) ; erase and kill characters to their default values
+   (evenp    combine  (parenb (not parodd) cs7))
+   ;;(-evenp combine  #f) ; same as -parenb cs8
+   (lcase    combine  (xcase iuclc olcuc))
+   (litout   combine  (cs8 (not parenb istrip opost)))
+   ;;(-litout  combine  #f) ; same as parenb istrip opost cs7
+   (nl       combine  (not icrnl onlcr))
+   ;;(-nl      combine  #f) ; same as icrnl -inlcr -igncr onlcr -ocrnl -onlret
+   (oddp     combine  (parenb parodd cs7))
+   (parity   combine  (evenp)) ; same as [-]evenp
+   (pass8    combine  (cs8 (not parenb istrip)))
+   ;;(-pass8   combine  #f) ; same as parenb istrip cs7
+   (raw      combine  (not ignbrk brkint ignpar parmrk
+                           inpck istrip inlcr igncr icrnl))
+   (ixon     combine  (ixoff ixany imaxbel opost isig icanon)) ;; xcase iuclc
+   ;;(time     combine  #f) ; 0
+   ;;(-raw     combine  #f) ; same as cooked
+   (sane     combine  (cread brkint icrnl imaxbel opost onlcr
+                       isig icanon ;; nl0 cr0 bs0 vt0 ff0 ; tab0
+                       echo echoe echoctl echoke ;; iexten echok
+                       (not ignbrk igncr ixoff ixany inlcr ;; iuclc
+                            ocrnl onocr onlret ;; olcuc ofill ofdel
+                            echonl noflsh tostop echoprt))) ;; xcase
+                                        ; plus all special characters to
+                                        ; their default values
+   ))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; high-level interface
+
+;;> \subsubsubsection{\scheme{(stty [port] args ...)}}
+
+;;> Set the terminal attributes for \var{port} (default
+;;> \scheme{(current-output-port)}) to \var{attrs}.
+;;> Attributes are specified symbolically using the
+;;> names from the \rawcode{stty(1)} command.  In addition,
+;;> (not args ...) may be used to negate the listed symbols.
+
+(define (stty . args)
+  (let* ((port (if (and (pair? args) (port? (car args)))
+                   (car args)
+                   (current-output-port)))
+         (attr (get-terminal-attributes port)))
+    ;; parse change requests
+    (let lp ((lst (if (and (pair? args) (port? (car args))) (cdr args) args))
+             (iflag (term-attrs-iflag attr))
+             (oflag (term-attrs-oflag attr))
+             (cflag (term-attrs-cflag attr))
+             (lflag (term-attrs-lflag attr))
+             (invert? #f)
+             (return (lambda (iflag oflag cflag lflag)
+                       (term-attrs-iflag-set! attr iflag)
+                       (term-attrs-oflag-set! attr oflag)
+                       (term-attrs-cflag-set! attr cflag)
+                       (term-attrs-lflag-set! attr lflag)
+                       (set-terminal-attributes! port TCSANOW attr))))
+      (define (join old new)
+        (if invert? (bitwise-and old (bitwise-not new)) (bitwise-ior old new)))
+      (cond
+       ((pair? lst)
+        (let ((command (car lst)))
+          (cond
+           ((pair? command) ;; recurse on sub-expr
+            (lp command iflag oflag cflag lflag invert?
+                (lambda (i o c l) (lp (cdr lst) i o c l invert? return))))
+           ((eq? command 'not) ;; toggle current setting
+            (lp (cdr lst) iflag oflag cflag lflag (not invert?) return))
+           (else
+            (let ((x (hash-table-ref/default stty-lookup command #f)))
+              (case (and x (car x))
+                ((input)
+                 (lp (cdr lst) (join iflag (cadr x)) oflag cflag lflag invert? return))
+                ((output)
+                 (lp (cdr lst) iflag (join oflag (cadr x)) cflag lflag invert? return))
+                ((control)
+                 (lp (cdr lst) iflag oflag (join cflag (cadr x)) lflag invert? return))
+                ((local)
+                 (lp (cdr lst) iflag oflag cflag (join lflag (cadr x)) invert? return))
+                ((char)
+                 ;;(term-attrs-cc-set! attr (cadr x) (or (cadr lst) 0))
+                 (lp (cddr lst) iflag oflag cflag lflag invert? return))
+                ((combine)
+                 (lp (cadr x) iflag oflag cflag lflag invert?
+                     (lambda (i o c l) (lp (cdr lst) i o c l invert? return))))
+                ((special)
+                 (error "special settings not yet supported" command))
+                (else
+                 (error "unknown stty command" command))))))))
+       (else
+        (return iflag oflag cflag lflag))))))
+
+;;> Run \var{thunk} with the \scheme{stty} \var{setting}s in effect
+;;> during its dynamic extent, resetting the original settings
+;;> when it returns.
+
+(define (with-stty setting thunk . o)
+  (let* ((port (if (pair? o) (car o) (current-input-port)))
+         (orig-attrs (get-terminal-attributes port)))
+    (cond
+     (orig-attrs
+      (dynamic-wind
+        (lambda () (stty port setting))
+        thunk
+        (lambda () (set-terminal-attributes! port TCSANOW orig-attrs))))
+     (else
+      ;; No terminal attributes means this isn't a tty.
+      (thunk)))))
+
+;;> Run \var{thunk} with the "raw" (no canonical or echo) options
+;;> needed for a terminal application.
+
+(define (with-raw-io port thunk)
+  (with-stty '(not icanon isig echo) thunk port))
+
+;;> Returns the current terminal width in characters of \var{x},
+;;> which must be a port or a file descriptor.
+
+(define (get-terminal-width x)
+  (let ((ws (ioctl x TIOCGWINSZ)))
+    (and ws (winsize-col ws))))
+
+;;> Returns the current terminal dimensions, as a list of character width
+;;> and height, of \var{x}, which must be a port or a file descriptor.
+
+(define (get-terminal-dimensions x)
+  (let ((ws (ioctl x TIOCGWINSZ)))
+    (and ws (list (winsize-col ws) (winsize-row ws)))))
diff --git a/lib/chibi/stty.sld b/lib/chibi/stty.sld
new file mode 100644
index 00000000..d054486e
--- /dev/null
+++ b/lib/chibi/stty.sld
@@ -0,0 +1,8 @@
+
+(define-library (chibi stty)
+  (export stty with-stty with-raw-io
+          get-terminal-width get-terminal-dimensions
+          TCSANOW TCSADRAIN TCSAFLUSH)
+  (import (chibi) (srfi 33) (srfi 69))
+  (include-shared "stty")
+  (include "stty.scm"))
diff --git a/lib/chibi/stty.stub b/lib/chibi/stty.stub
new file mode 100644
index 00000000..1e66f787
--- /dev/null
+++ b/lib/chibi/stty.stub
@@ -0,0 +1,112 @@
+
+(c-system-include "termios.h")
+(c-system-include "sys/ioctl.h")
+
+(define-c-struct termios
+  predicate: term-attrs?
+  constructor: (make-term-attrs)
+  (unsigned-long c_iflag term-attrs-iflag term-attrs-iflag-set!)
+  (unsigned-long c_oflag term-attrs-oflag term-attrs-oflag-set!)
+  (unsigned-long c_cflag term-attrs-cflag term-attrs-cflag-set!)
+  (unsigned-long c_lflag term-attrs-lflag term-attrs-lflag-set!)
+  ;;(unsigned-char (c_cc 22) term-attrs-cc term-attrs-cc-set!)
+  ;;(unsigned-long c_ispeed term-attrs-ispeed term-attrs-ispeed-set!)
+  ;;(unsigned-long c_ospeed term-attrs-ospeed term-attrs-ospeed-set!)
+  )
+
+(define-c unsigned-long (term-attrs-ispeed cfgetispeed) (termios))
+(define-c unsigned-long (term-attrs-ospeed cfgetospeed) (termios))
+(define-c errno (term-attrs-ispeed-set! cfsetispeed) (termios unsigned-long))
+(define-c errno (term-attrs-ospeed-set! cfsetospeed) (termios unsigned-long))
+
+(define-c-struct winsize
+  predicate: winsize?
+  (unsigned-short ws_row winsize-row)
+  (unsigned-short ws_col winsize-col))
+
+(define-c errno ioctl (port-or-fileno unsigned-long (result winsize)))
+
+(define-c-const int TIOCGWINSZ)
+
+(define-c-const int TCSANOW)
+(define-c-const int TCSADRAIN)
+(define-c-const int TCSAFLUSH)
+
+(define-c-const unsigned-long IGNBRK)
+(define-c-const unsigned-long BRKINT)
+(define-c-const unsigned-long IGNPAR)
+(define-c-const unsigned-long PARMRK)
+(define-c-const unsigned-long INPCK)
+(define-c-const unsigned-long ISTRIP)
+(define-c-const unsigned-long INLCR)
+(define-c-const unsigned-long IGNCR)
+(define-c-const unsigned-long ICRNL)
+(define-c-const unsigned-long IXON)
+(define-c-const unsigned-long IXOFF)
+(define-c-const unsigned-long IXANY)
+(define-c-const unsigned-long IMAXBEL)
+;; (define-c-const unsigned-long IUCLC)
+
+(define-c-const unsigned-long OPOST)
+(define-c-const unsigned-long ONLCR)
+;; (define-c-const unsigned-long OXTABS)
+;; (define-c-const unsigned-long ONOEOT)
+(define-c-const unsigned-long OCRNL)
+;; (define-c-const unsigned-long OLCUC)
+(define-c-const unsigned-long ONOCR)
+(define-c-const unsigned-long ONLRET)
+
+(define-c-const unsigned-long CSIZE)
+(define-c-const unsigned-long CS5)
+(define-c-const unsigned-long CS6)
+(define-c-const unsigned-long CS7)
+(define-c-const unsigned-long CS8)
+(define-c-const unsigned-long CSTOPB)
+(define-c-const unsigned-long CREAD)
+(define-c-const unsigned-long PARENB)
+(define-c-const unsigned-long PARODD)
+(define-c-const unsigned-long HUPCL)
+(define-c-const unsigned-long CLOCAL)
+;; (define-c-const unsigned-long CCTS_OFLOW)
+(define-c-const unsigned-long CRTSCTS)
+;; (define-c-const unsigned-long CRTS_IFLOW)
+;; (define-c-const unsigned-long MDMBUF)
+
+(define-c-const unsigned-long ECHOKE)
+(define-c-const unsigned-long ECHOE)
+(define-c-const unsigned-long ECHO)
+(define-c-const unsigned-long ECHONL)
+;; (define-c-const unsigned-long ECHOPRT)
+(define-c-const unsigned-long ECHOCTL)
+(define-c-const unsigned-long ISIG)
+(define-c-const unsigned-long ICANON)
+;; (define-c-const unsigned-long ALTWERASE)
+(define-c-const unsigned-long IEXTEN)
+;; (define-c-const unsigned-long EXTPROC)
+(define-c-const unsigned-long TOSTOP)
+(define-c-const unsigned-long FLUSHO)
+;; (define-c-const unsigned-long NOKERNINFO)
+;; (define-c-const unsigned-long PENDIN)
+(define-c-const unsigned-long NOFLSH)
+
+(define-c-const unsigned-long VEOF)
+(define-c-const unsigned-long VEOL)
+(define-c-const unsigned-long VEOL2)
+(define-c-const unsigned-long VERASE)
+;; (define-c-const unsigned-long VERASE2)
+(define-c-const unsigned-long VWERASE)
+(define-c-const unsigned-long VINTR)
+(define-c-const unsigned-long VKILL)
+(define-c-const unsigned-long VQUIT)
+(define-c-const unsigned-long VSUSP)
+(define-c-const unsigned-long VSTART)
+(define-c-const unsigned-long VSTOP)
+;; (define-c-const unsigned-long VDSUSP)
+(define-c-const unsigned-long VLNEXT)
+(define-c-const unsigned-long VREPRINT)
+;; (define-c-const unsigned-long VSTATUS)
+
+(define-c errno (get-terminal-attributes "tcgetattr")
+  (port-or-fileno (result termios)))
+(define-c errno (set-terminal-attributes! "tcsetattr")
+  (port-or-fileno int termios))
diff --git a/lib/chibi/sxml.scm b/lib/chibi/sxml.scm
new file mode 100644
index 00000000..a74e9a28
--- /dev/null
+++ b/lib/chibi/sxml.scm
@@ -0,0 +1,148 @@
+
+(define (call-with-output-string proc)
+  (let ((out (open-output-string)))
+    (proc out)
+    (get-output-string out)))
+
+(define (display-to-string x)
+  (cond ((string? x) x)
+        ((char? x) (string x))
+        ((symbol? x) (symbol->string x))
+        ((number? x) (number->string x))
+        (else (error "don't know how to display as sxml" x))))
+
+(define (html-display-escaped-attr str . o)
+  (let ((start 0)
+        (end (string-length str))
+        (out (if (pair? o) (car o) (current-output-port))))
+    (let lp ((from start) (to start))
+      (if (>= to end)
+          (display (substring str from to) out)
+          (let ((c (string-ref str to)))
+            (cond
+             ((eq? c #\<)
+              (display (substring str from to) out)
+              (display "&lt;" out)
+              (lp (+ to 1) (+ to 1)))
+             ((eq? c #\&)
+              (display (substring str from to) out)
+              (display "&amp;" out)
+              (lp (+ to 1) (+ to 1)))
+             ((eq? c #\")
+              (display (substring str from to) out)
+              (display "&quot;" out)
+              (lp (+ to 1) (+ to 1)))
+             (else
+              (lp from (+ to 1)))))))))
+
+(define (html-escape-attr str)
+  (call-with-output-string
+    (lambda (out) (html-display-escaped-attr (display-to-string str) out))))
+
+(define (html-attr->string attr)
+  (if (cdr attr)
+      (let ((val (if (pair? (cdr attr)) (cadr attr) (cdr attr))))
+        (string-append (symbol->string (car attr))
+                       "=\"" (html-escape-attr val) "\""))
+      (symbol->string (car attr))))
+
+(define (html-tag->string tag attrs)
+  (let lp ((ls attrs) (res (list (symbol->string tag) "<")))
+    (if (null? ls)
+        (apply string-append (reverse (cons ">" res)))
+        (lp (cdr ls) (cons (html-attr->string (car ls)) (cons " " res))))))
+
+(define (html-display-escaped-string x . o)
+  (let* ((str (display-to-string x))
+         (start 0)
+         (end (string-length str))
+         (out (if (pair? o) (car o) (current-output-port))))
+    (let lp ((from start) (to start))
+      (if (>= to end)
+          (display (substring str from to) out)
+          (let ((c (string-ref str to)))
+            (cond
+             ((eq? c #\<)
+              (display (substring str from to) out)
+              (display "&lt;" out)
+              (lp (+ to 1) (+ to 1)))
+             ((eq? c #\&)
+              (display (substring str from to) out)
+              (display "&amp;" out)
+              (lp (+ to 1) (+ to 1)))
+             (else
+              (lp from (+ to 1)))))))))
+
+(define (html-escape str)
+  (call-with-output-string
+    (lambda (out) (html-display-escaped-string str out))))
+
+;; utility to render (valid, expanded) sxml as html
+(define (sxml-display-as-html sxml . o)
+  (let ((out (if (pair? o) (car o) (current-output-port))))
+    (let lp ((sxml sxml))
+      (cond
+       ((pair? sxml)
+        (let ((tag (car sxml)))
+          (if (symbol? tag)
+              (let ((rest (cdr sxml)))
+                (cond
+                 ((and (pair? rest)
+                       (pair? (car rest))
+                       (eq? '@ (caar rest)))
+                  (display (html-tag->string tag (cdar rest)) out)
+                  (for-each lp (cdr rest))
+                  (display "</" out) (display tag out) (display ">" out))
+                 (else
+                  (display (html-tag->string tag '()) out)
+                  (for-each lp rest)
+                  (display "</" out) (display tag out) (display ">" out))))
+              (for-each lp sxml))))
+       ((null? sxml))
+       (else (html-display-escaped-string sxml out))))))
+
+(define (sxml->xml sxml)
+  (call-with-output-string
+    (lambda (out) (sxml-display-as-html sxml out))))
+
+;; utility to render sxml as simple text, stripping all tags
+(define (sxml-strip sxml)
+  (call-with-output-string
+    (lambda (out)
+      (let strip ((x sxml))
+        (cond
+         ((pair? x)
+          (for-each
+           strip
+           (if (and (pair? (cdr x)) (eq? '@ (cadr x))) (cddr x) (cdr x))))
+         ((string? x)
+          (display x out)))))))
+
+;; utility to render sxml as text for viewing in a terminal
+(define (sxml-display-as-text sxml . o)
+  (let ((out (if (pair? o) (car o) (current-output-port))))
+    (let lp ((sxml sxml))
+      (cond
+       ((pair? sxml)
+        (let ((tag (car sxml)))
+          (cond
+           ;; skip headers and the menu
+           ((or (memq tag '(head style script))
+                (and (eq? 'div tag)
+                     (pair? (cdr sxml))
+                     (pair? (cadr sxml))
+                     (eq? '@ (car (cadr sxml)))
+                     (equal? '(id . "menu") (assq 'id (cdr (cadr sxml)))))))
+           ;; recurse other tags, appending newlines for new sections
+           ((symbol? tag)
+            (for-each
+             lp
+             (if (and (pair? (cdr sxml)) (eq? '@ (cadr sxml)))
+                 (cddr sxml)
+                 (cdr sxml)))
+            (if (memq tag '(p br h1 h2 h3 h4 h5 h6))
+                (newline out)))
+           (else
+            (for-each lp sxml)))))
+       ((null? sxml))
+       (else (html-display-escaped-string sxml out))))))
diff --git a/lib/chibi/sxml.sld b/lib/chibi/sxml.sld
new file mode 100644
index 00000000..e0a9f298
--- /dev/null
+++ b/lib/chibi/sxml.sld
@@ -0,0 +1,5 @@
+
+(define-library (chibi sxml)
+  (export sxml->xml sxml-display-as-html sxml-display-as-text sxml-strip)
+  (import (scheme base) (scheme write))
+  (include "sxml.scm"))
diff --git a/lib/chibi/system.sld b/lib/chibi/system.sld
new file mode 100644
index 00000000..fa8223ab
--- /dev/null
+++ b/lib/chibi/system.sld
@@ -0,0 +1,23 @@
+
+(define-library (chibi system)
+  (export get-host-name
+          user-information user? user-name user-password
+          user-id user-group-id user-gecos user-home user-shell
+          group-information group-name group-password group-id
+          current-user-id current-group-id
+          current-effective-user-id current-effective-group-id
+          set-current-user-id! set-current-effective-user-id!
+          set-current-group-id! set-current-effective-group-id!
+          current-session-id create-session
+          set-root-directory!)
+  (import (chibi))
+  (include-shared "system")
+  (body
+   (define (user-information user)
+     (car (if (string? user)
+              (getpwnam_r user (make-string 1024))
+              (getpwuid_r user (make-string 1024)))))
+   (define (group-information group)
+     (car (if (string? group)
+              (getgrnam_r group (make-string 1024))
+              (getgrgid_r group (make-string 1024)))))))
diff --git a/lib/chibi/system.stub b/lib/chibi/system.stub
new file mode 100644
index 00000000..23da1d33
--- /dev/null
+++ b/lib/chibi/system.stub
@@ -0,0 +1,90 @@
+
+(c-system-include "unistd.h")
+(c-system-include "pwd.h")
+(c-system-include "grp.h")
+(c-system-include "sys/types.h")
+
+;;> Returns the standard hostname of the current processor.
+
+(define-c errno (get-host-name "gethostname")
+  ((result (array char (auto-expand arg1))) (value 256 int)))
+
+;;> \section{\scheme{(user-information name-or-id)}}
+
+;;> Returns the password entry for the given user.  \var{name-or-id}
+;;> should be a string indicating the user name, or an integer
+;;> for the user id.
+
+(define-c-struct passwd
+  predicate: user?
+  (string  pw_name     user-name)
+  (string  pw_passwd   user-password)
+  (uid_t   pw_uid      user-id)
+  (gid_t   pw_gid      user-group-id)
+  (string  pw_gecos    user-gecos)
+  (string  pw_dir      user-home)
+  (string  pw_shell    user-shell))
+
+;;> Accessors for the password entry structure returned by
+;;> \scheme{user-information}.
+;;/
+
+(define-c uid_t (current-user-id "getuid") ())
+(define-c gid_t (current-group-id "getgid") ())
+(define-c uid_t (current-effective-user-id "geteuid") ())
+(define-c gid_t (current-effective-group-id "getegid") ())
+
+(define-c errno (set-current-user-id! "setuid") (uid_t))
+(define-c errno (set-current-effective-user-id! "seteuid") (uid_t))
+(define-c errno (set-current-group-id! "setgid") (gid_t))
+(define-c errno (set-current-effective-group-id! "setegid") (gid_t))
+
+;;> Accessors for the current user credentials.
+;;/
+
+;;> Returns the session id of the specified process,
+;;> defaulting to the current process.
+
+(define-c pid_t (current-session-id "getsid") ((default 0 pid_t)))
+
+;;> Creates a new session.
+
+(define-c pid_t (create-session "setsid") ())
+
+;;> Set \var{string} to be the new root directory, so that
+;;> paths beginning with "/" are resolved relative to the
+;;> new root.
+
+(define-c errno (set-root-directory! "chroot") (string))
+
+(define-c errno getpwuid_r
+  (uid_t (result passwd)
+         (link string)
+         (value (string-size arg2) int)
+         (result pointer passwd)))
+
+(define-c errno getpwnam_r
+  (string (result passwd)
+          (link string)
+          (value (string-size arg2) int)
+          (result pointer passwd)))
+
+(define-c-struct group
+  predicate: group?
+  (string  gr_name     group-name)
+  (string  gr_passwd   group-password)
+  (gid_t   gr_gid      group-id)
+  ;;((array string)  gr_mem      group-members)
+  )
+
+(define-c errno getgrgid_r
+  (gid_t (result group)
+         (link string)
+         (value (string-size arg2) int)
+         (result pointer group)))
+
+(define-c errno getgrnam_r
+  (string (result group)
+          (link string)
+          (value (string-size arg2) int)
+          (result pointer group)))
diff --git a/lib/chibi/tar.scm b/lib/chibi/tar.scm
new file mode 100644
index 00000000..8571d55e
--- /dev/null
+++ b/lib/chibi/tar.scm
@@ -0,0 +1,298 @@
+(define-binary-record-type tar
+  (make (make-tar))
+  (write write-tar-raw)
+  (block
+   (path (padded-string 100) (getter tar-path-raw) (setter tar-path-raw-set!))
+   (mode (octal 8))
+   (uid (octal 8))
+   (gid (octal 8))
+   (size (octal 12))
+   (time (octal 12))
+   (checksum (octal 8))
+   (type (fixed-string 1))
+   (link-name (padded-string 100))
+   (ustar (padded-string 6))
+   (ustar-version (padded-string 2))
+   (owner (padded-string 32))
+   (group (padded-string 32))
+   (device-major (octal 8))
+   (device-minor (octal 8))
+   (path-prefix (padded-string 155))
+   #u8(0 0 0 0 0 0 0 0 0 0 0 0)))
+
+(define (tar-compute-checksum tar)
+  (let ((tmp (open-output-bytevector)))
+    (write-tar-raw tar tmp)
+    (let ((bv (get-output-bytevector tmp)))
+      (do ((i 0 (+ i 1))) ((= i 8))
+        (bytevector-u8-set! bv (+ i 148) 32))
+      (do ((i 0 (+ i 1))
+           (sum 0 (+ sum (bytevector-u8-ref bv i))))
+          ((= i 512) sum)))))
+
+;; wrap the writer to automatically compute the checksum
+(define (write-tar tar out)
+  (tar-checksum-set! tar (tar-compute-checksum tar))
+  (write-tar-raw tar out))
+
+;; wrap the path to use the prefix
+(define (tar-path tar)
+  (string-append (tar-path-prefix tar) (tar-path-raw tar)))
+
+(define (tar-normalize-path tar path)
+  (cond ((string-suffix? "/." path) (string-trim-right path #\.))
+        ((and (not (string-suffix? "/" path)) (equal? "5" (tar-type tar)))
+         (string-append path "/"))
+        (else path)))
+
+(define (tar-path-set! tar path)
+  (let* ((path (tar-normalize-path tar path))
+         (len (string-length path)))
+    (cond ((< len 100)
+           (tar-path-raw-set! tar path))
+          ((< len 255)
+           (tar-path-raw-set! tar (substring path (- len 100)))
+           (tar-path-prefix-set! tar (substring path 0 (- len 100))))
+          (else (error "path name too long")))))
+
+;; utilities
+
+(define (read-modulo-bytevector in len mod)
+  (let ((res (read-bytevector len in))
+        (rem (modulo len mod)))
+    (if (positive? rem)
+        (read-bytevector (- mod rem) in))
+    res))
+
+(define (write-modulo-file out file mod)
+  (let ((in (open-binary-input-file file)))
+    (let lp ()
+      (let ((bv (read-bytevector mod in)))
+        (cond
+         ((eof-object? bv))
+         (else
+          (write-bytevector bv out)
+          (let ((len (bytevector-length bv)))
+            (if (< len mod)
+                (write-bytevector (make-bytevector (- mod len) 0) out)
+                (lp)))))))))
+
+;; fundamental iterator
+(define (tar-fold src kons knil)
+  (let ((in (cond ((string? src) (open-binary-input-file src))
+                  ((bytevector? src) (open-input-bytevector src))
+                  (else src))))
+    (let lp ((acc knil) (empty 0))
+      (cond
+       ((or (eof-object? (peek-u8 in)) (>= empty 2))
+        (close-input-port in)
+        acc)
+       (else
+        (let ((tar (read-tar in)))
+          (if (and (equal? "" (tar-path tar)) (zero? (tar-size tar)))
+              (lp acc (+ empty 1))
+              (let ((bv (read-modulo-bytevector in (tar-size tar) 512)))
+                (lp (kons tar bv acc) 0)))))))))
+
+;; not a tar-bomb and no absolute paths
+(define (tar-safe? tarball)
+  (define (path-top path)
+    (substring path 0 (string-find path #\/)))
+  (let ((files (map path-normalize (tar-files tarball))))
+    (and (every path-relative? files)
+         (or (< (length files) 2)
+             (let ((dir (path-top (car files))))
+               (every (lambda (f) (equal? dir (path-top f))) (cdr files)))))))
+
+(define (tar-for-each tarball proc)
+  (tar-fold tarball (lambda (tar bv acc) (proc tar bv)) #f))
+
+;; list the files in the archive
+(define (tar-files tarball)
+  (reverse (tar-fold tarball (lambda (tar bv acc) (cons (tar-path tar) acc)) '())))
+
+;; extract to the current filesystem
+(define (tar-extract tarball . o)
+  (define (safe-path path)
+    (string-trim-left
+     (path-strip-leading-parents (path-normalize path))
+     #\/))
+  (let ((rename (if (pair? o) (car o) safe-path)))
+    (tar-for-each
+     tarball
+     (lambda (tar bv)
+       (let ((path (rename (tar-path tar))))
+         (case (string-ref (tar-type tar) 0)
+           ((#\0 #\null)
+            (let ((out (open-output-file-descriptor
+                        (open path
+                              (bitwise-ior open/write
+                                           open/create
+                                           open/non-block)
+                              (tar-mode tar)))))
+              (write-bytevector bv out)
+              (close-output-port out)))
+           ((#\1) (link-file (rename (tar-link-name tar)) path))
+           ((#\2) (symbolic-link-file (rename (tar-link-name tar)) path))
+           ((#\5) (create-directory* path (tar-mode tar)))
+           ((#\g #\x))                   ;; meta data
+           ((#\3 #\4 #\6) (error "devices not supported" (tar-type tar)))
+           (else (error "invalid tar type" (tar-type tar)))))))))
+
+(define (tar-extract-file tarball file)
+  (call-with-current-continuation
+   (lambda (return)
+     (tar-for-each
+      tarball
+      (lambda (tar bv) (if (equal? (tar-path tar) file) (return bv))))
+     #f)))
+
+(define (file-owner-or-nobody st)
+  (or (user-name (user-information (file-owner st))) "nobody"))
+(define (file-group-or-nobody st)
+  (or (group-name (group-information (file-group st))) "nobody"))
+
+(define (file->tar file)
+  (let ((tar (make-tar))
+        (st (file-link-status file)))
+    (tar-path-set! tar file)
+    (tar-ustar-set! tar "ustar")
+    (tar-ustar-version-set! tar "00")
+    (cond
+     (st
+      (tar-mode-set! tar (file-mode st))
+      (tar-uid-set! tar (file-owner st))
+      (tar-gid-set! tar (file-group st))
+      (tar-owner-set! tar (file-owner-or-nobody st))
+      (tar-group-set! tar (file-group-or-nobody st))
+      (tar-time-set! tar (+ 1262271600 (file-modification-time st)))
+      (tar-type-set! tar (cond ((file-link? st) "2")
+                               ((file-character? st) "3")
+                               ((file-block? st) "4")
+                               ((file-directory? st) "5")
+                               (else "0")))
+      (if (equal? "0" (tar-type tar))
+          (tar-size-set! tar (file-size st)))
+      (if (file-link? st)
+          (tar-link-name-set! tar (read-link file)))))
+    tar))
+
+(define (inline->tar file content . o)
+  (let ((tar (make-tar)))
+    (tar-path-set! tar file)
+    (tar-ustar-set! tar "ustar")
+    (tar-ustar-version-set! tar "00")
+    (tar-mode-set! tar (if (pair? o) (car o) #o644))
+    (tar-uid-set! tar (current-user-id))
+    (tar-gid-set! tar (current-group-id))
+    (tar-owner-set! tar (user-name (user-information (current-user-id))))
+    (tar-group-set! tar (group-name (group-information (current-group-id))))
+    (tar-time-set! tar (exact (round (current-second))))
+    (tar-type-set! tar "0")
+    (tar-size-set! tar (bytevector-length content))
+    tar))
+
+(define (tar-add-directories tar out acc)
+  (let lp ((dir (path-directory (tar-path tar))) (acc acc))
+    (let ((dir/ (if (string-suffix? "/" dir) dir (string-append dir "/"))))
+      (cond
+       ((member dir '("" "." "/")) acc)
+       ((assoc dir/ acc) (lp (path-directory dir) acc))
+       (else
+        (let ((acc (lp (path-directory dir) (cons (cons dir/ #f) acc))))
+          (let ((tar2 (make-tar)))
+            (tar-path-set! tar2 dir/)
+            (tar-ustar-set! tar2 "ustar")
+            (tar-ustar-version-set! tar2 "00")
+            (tar-mode-set! tar2 (bitwise-ior #o111 (tar-mode tar) ))
+            (tar-uid-set! tar2 (tar-uid tar))
+            (tar-gid-set! tar2 (tar-gid tar))
+            (tar-owner-set! tar2 (tar-owner tar))
+            (tar-group-set! tar2 (tar-group tar))
+            (tar-time-set! tar2 (tar-time tar))
+            (tar-type-set! tar2 "5")
+            (tar-size-set! tar2 0)
+            (write-tar tar2 out)
+            acc)))))))
+
+;; create an archive for a given file list
+(define (tar-create tarball files . o)
+  (let* ((rename (if (pair? o) (car o) (lambda (f) f)))
+         (no-recurse? (and (pair? o) (pair? (cdr o)) (cadr o)))
+         (get-src
+          (lambda (x) (if (pair? x) (and (eq? 'rename (car x)) (cadr x)) x)))
+         (get-dest
+          (lambda (x)
+            (rename (if (pair? x)
+                        (if (eq? 'rename (car x))
+                            (car (cddr x))
+                            (cadr x))
+                        x))))
+         (get-content
+          (lambda (x) (and (pair? x) (eq? 'inline (car x))
+                       (let ((c (car (cddr x))))
+                         (if (string? c) (string->utf8 c) c))))))
+    (let ((out (cond ((eq? #t tarball) (current-output-port))
+                     ((eq? #f tarball) (open-output-bytevector))
+                     (else (open-binary-output-file tarball)))))
+      (fold
+       (lambda (file acc)
+         (let ((src0 (get-src file))
+               (dest0 (get-dest file))
+               (content0 (get-content file)))
+           (define (kons x acc)
+             (let* ((src (get-src x))
+                    (dest (if (equal? x src0) dest0 (get-dest x)))
+                    (content (if (equal? x src0) content0 (get-content x)))
+                    (tar (if content
+                             (inline->tar dest content)
+                             (file->tar src))))
+               (tar-path-set! tar dest)
+               (cond
+                ((assoc (tar-path tar) acc)
+                 => (lambda (prev)
+                      (if (not (and (file-directory? src)
+                                    (file-directory? (cdr prev))))
+                          (write-string
+                           (string-append "tar-create: duplicate file: "
+                                          dest "\n")
+                           (current-error-port)))
+                      acc))
+                (else
+                 (let ((acc (tar-add-directories tar out acc)))
+                   (write-tar tar out)
+                   (cond
+                    ((and (string? src) (equal? "0" (tar-type tar)))
+                     (write-modulo-file out src 512))
+                    (content
+                     (write-bytevector content out)
+                     (let ((rem (modulo (bytevector-length content) 512)))
+                       (if (positive? rem)
+                           (write-bytevector
+                            (make-bytevector (- 512 rem) 0) out)))))
+                   (cons (cons (tar-path tar) src) acc))))))
+           (if (and src0 (not no-recurse?))
+               (directory-fold-tree src0 kons acc kons)
+               (kons src0 acc))))
+       '() files)
+      (write-bytevector (make-bytevector 1024 0) out)
+      (let ((res (if (eq? #f tarball) (get-output-bytevector out))))
+        (close-output-port out)
+        res))))
+
+(define (main args)
+  (let ((args (cdr args)))
+    (cond
+     ((equal? "t" (car args))
+      (for-each (lambda (f) (write-string f) (newline)) (tar-files (cadr args))))
+     ((equal? "x" (car args))
+      (if (tar-safe? (cadr args))
+          (tar-extract (cadr args))
+          (error "tar file not a single relative directory" (cadr args))))
+     ((equal? "c" (car args))
+      (tar-create (cadr args) (cddr args)))
+     ((equal? "f" (car args))
+      (write-string
+       (utf8->string (tar-extract-file (cadr args) (car (cddr args))))))
+     (else
+      (error "unknown tar command" (car args))))))
diff --git a/lib/chibi/tar.sld b/lib/chibi/tar.sld
new file mode 100644
index 00000000..d5693664
--- /dev/null
+++ b/lib/chibi/tar.sld
@@ -0,0 +1,21 @@
+
+(define-library (chibi tar)
+  (import (scheme base) (scheme file) (scheme time) (srfi 1) (srfi 33)
+          (chibi string) (chibi binary-record)
+          (chibi pathname) (chibi filesystem) (chibi system))
+  (export
+   ;; basic
+   tar make-tar tar? read-tar write-tar
+   ;; utilities
+   tar-safe? tar-files tar-fold tar-extract tar-extract-file tar-create
+   ;; accessors
+   tar-path tar-mode tar-uid tar-gid
+   tar-owner tar-group tar-size
+   tar-time tar-type tar-link-name
+   tar-path-set! tar-mode-set! tar-uid-set! tar-gid-set!
+   tar-owner-set! tar-group-set! tar-size-set!
+   tar-time-set! tar-type-set! tar-link-name-set!
+   tar-device-major tar-device-major-set!
+   tar-device-minor tar-device-minor-set!
+   tar-ustar tar-ustar-set!)
+  (include "tar.scm"))
diff --git a/lib/chibi/term/ansi.scm b/lib/chibi/term/ansi.scm
new file mode 100644
index 00000000..0d80a49d
--- /dev/null
+++ b/lib/chibi/term/ansi.scm
@@ -0,0 +1,433 @@
+;; Copyright (c) 2010-2014 Alex Shinn. All rights reserved. BSD-style
+;; license: http://synthcode.com/license.txt
+
+;;> A library to use ANSI escape codes to format text and background
+;;> color, font weigh, and underlining.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (make-simple-escape-procedure parameter)
+  (let ((code (string-append "\x1B;[" (number->string parameter) "m")))
+    (lambda () code)))
+
+(define (make-wrap-procedure start-escape end-escape)
+  (lambda (str)
+    (if (not (string? str))
+        (error "argument must be a string" str))
+    (if (ansi-escapes-enabled?)
+        (string-append start-escape str end-escape)
+        str)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Some definitions are wrapped in begin in order to avoid Scribble
+;; generating duplicate signatures.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> \section{Library}
+
+(define black-escape
+   (make-simple-escape-procedure 30))
+(define red-escape
+  (make-simple-escape-procedure 31))
+(define green-escape
+  (make-simple-escape-procedure 32))
+(define yellow-escape
+  (make-simple-escape-procedure 33))
+(define blue-escape
+  (make-simple-escape-procedure 34))
+(define magenta-escape
+  (make-simple-escape-procedure 35))
+(define cyan-escape
+  (make-simple-escape-procedure 36))
+(define white-escape
+  (make-simple-escape-procedure 37))
+
+;;> Return a string consisting of an ANSI escape code to select the
+;;> specified text color.
+;;/
+
+;;> Return a string consisting of an ANSI escape code to select the
+;;> text color specified by the \var{red-level}, \var{green-level},
+;;> and \var{blue-level} arguments, each of which must be an exact
+;;> integer in the range [0, 5].
+;;>
+;;> The caller is resonsible for verifying that the terminal supports
+;;> 256 colors.
+
+(define (rgb-escape red-level green-level blue-level)
+  (when (not (and (exact-integer? red-level) (<= 0 red-level 5)))
+    (error "invalid red-level value" red-level))
+  (when (not (and (exact-integer? green-level) (<= 0 green-level 5)))
+    (error "invalid green-level value" green-level))
+  (when (not (and (exact-integer? blue-level) (<= 0 blue-level 5)))
+    (error "invalid blue-level value" blue-level))
+  (string-append
+   "\x1B[38;5;"
+   (number->string (+ (* 36 red-level) (* 6 green-level) blue-level 16))
+   "m"))
+
+;;> Return a string consisting of an ANSI escape code to select the
+;;> text color specified by the \var{gray-level} argument, which must
+;;> be an exact integer in the range [0, 23].
+;;>
+;;> The caller is resonsible for verifying that the terminal supports
+;;> 256 colors.
+
+(define (gray-escape gray-level)
+  (when (not (and (exact-integer? gray-level) (<= 0 gray-level 23)))
+    (error "invalid gray-level value" gray-level))
+  (string-append "\x1B[38;5;"
+                 (number->string (+ gray-level 232))
+                 "m"))
+
+;;> Return a string consisting of an ANSI escape code to select the
+;;> default text color.
+
+(define reset-color-escape
+  (make-simple-escape-procedure 39))
+
+(define black
+  (make-wrap-procedure (black-escape)
+                       (reset-color-escape)))
+(define red
+  (make-wrap-procedure (red-escape)
+                       (reset-color-escape)))
+(define green
+  (make-wrap-procedure (green-escape)
+                       (reset-color-escape)))
+(define yellow
+  (make-wrap-procedure (yellow-escape)
+                       (reset-color-escape)))
+(define blue
+  (make-wrap-procedure (blue-escape)
+                       (reset-color-escape)))
+(define magenta
+  (make-wrap-procedure (magenta-escape)
+                       (reset-color-escape)))
+(define cyan
+  (make-wrap-procedure (cyan-escape)
+                       (reset-color-escape)))
+(define white
+  (make-wrap-procedure (white-escape)
+                       (reset-color-escape)))
+
+;;> If ANSI escapes are enabled, return a string consisting of the
+;;> string \var{str} with a prefix that selects specified text color
+;;> and a suffix that selects the default text color.
+;;>
+;;> If ANSI escapes are not enabled, return \var{str}.
+;;/
+
+;;> Returns a procedure which takes a single argument, a string, and
+;;> which when called behaves as follows.
+;;>
+;;> If ANSI escapes are enabled, the procedure returns a string
+;;> consisting of its argument with a prefix that selects specified
+;;> text color (obtained by calling the \scheme{rgb-escape} procedure
+;;> with the values of the \var{red-level}, \var{green-level}, and
+;;> \var{blue-level} arguments) and a suffix that selects the default
+;;> text color.
+;;>
+;;> If ANSI escapes are not enabled, the procedure returns its argument.
+;;>
+;;> The caller is resonsible for verifying that the terminal supports
+;;> 256 colors.
+
+(define (rgb red-level green-level blue-level)
+  (make-wrap-procedure (rgb-escape red-level green-level blue-level)
+                       (reset-color-escape)))
+
+;;> Returns a procedure which takes a single argument, a string, and
+;;> which when called behaves as follows.
+;;>
+;;> If ANSI escapes are enabled, the procedure returns a string
+;;> consisting of its argument with a prefix that selects specified
+;;> text color (obtained by calling the \scheme{gray-escape} procedure
+;;> with the values of the \var{gray-level} argument) and a suffix
+;;> that selects the default text color.
+;;>
+;;> If ANSI escapes are not enabled, the procedure returns its argument.
+;;>
+;;> The caller is resonsible for verifying that the terminal supports
+;;> 256 colors.
+
+(define (gray gray-level)
+  (make-wrap-procedure (gray-escape gray-level)
+                       (reset-color-escape)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define black-background-escape
+  (make-simple-escape-procedure 40))
+(define red-background-escape
+  (make-simple-escape-procedure 41))
+(define green-background-escape
+  (make-simple-escape-procedure 42))
+(define yellow-background-escape
+  (make-simple-escape-procedure 43))
+(define blue-background-escape
+  (make-simple-escape-procedure 44))
+(define magenta-background-escape
+  (make-simple-escape-procedure 45))
+(define cyan-background-escape
+  (make-simple-escape-procedure 46))
+(define white-background-escape
+  (make-simple-escape-procedure 47))
+
+;;> Return a string consisting of an ANSI escape code to select the
+;;> specified background color.
+;;/
+
+;;> Return a string consisting of an ANSI escape code to select the
+;;> background color specified by the \var{red-level}, \var{green-level},
+;;> and \var{blue-level} arguments, each of which must be an exact
+;;> integer in the range [0, 5].
+;;>
+;;> The caller is resonsible for verifying that the terminal supports
+;;> 256 colors.
+
+(define (rgb-background-escape red-level green-level blue-level)
+  (when (not (and (exact-integer? red-level) (<= 0 red-level 5)))
+    (error "invalid red-level value" red-level))
+  (when (not (and (exact-integer? green-level) (<= 0 green-level 5)))
+    (error "invalid green-level value" green-level))
+  (when (not (and (exact-integer? blue-level) (<= 0 blue-level 5)))
+    (error "invalid blue-level value" blue-level))
+  (string-append
+   "\x1B[48;5;"
+   (number->string (+ (* 36 red-level) (* 6 green-level) blue-level 16))
+   "m"))
+
+;;> Return a string consisting of an ANSI escape code to select the
+;;> background color specified by the \var{gray-level} argument, which
+;;> must be an exact integer in the range [0, 23].
+;;>
+;;> The caller is resonsible for verifying that the terminal supports
+;;> 256 colors.
+
+(define (gray-background-escape gray-level)
+  (when (not (and (exact-integer? gray-level) (<= 0 gray-level 23)))
+    (error "invalid gray-level value" gray-level))
+  (string-append "\x1B[48;5;"
+                 (number->string (+ gray-level 232))
+                 "m"))
+
+;;> \procedure{(reset-background-color-escape)}
+;;>
+;;> Return a string consisting of an ANSI escape code to select the
+;;> default background color.
+
+(define reset-background-color-escape
+  (make-simple-escape-procedure 49))
+
+(define black-background
+  (make-wrap-procedure (black-background-escape)
+                       (reset-background-color-escape)))
+(define red-background
+  (make-wrap-procedure (red-background-escape)
+                       (reset-background-color-escape)))
+(define green-background
+  (make-wrap-procedure (green-background-escape)
+                       (reset-background-color-escape)))
+(define yellow-background
+  (make-wrap-procedure (yellow-background-escape)
+                       (reset-background-color-escape)))
+(define blue-background
+  (make-wrap-procedure (blue-background-escape)
+                       (reset-background-color-escape)))
+(define magenta-background
+  (make-wrap-procedure (magenta-background-escape)
+                       (reset-background-color-escape)))
+(define cyan-background
+  (make-wrap-procedure (cyan-background-escape)
+                       (reset-background-color-escape)))
+(define white-background
+  (make-wrap-procedure (white-background-escape)
+                       (reset-background-color-escape)))
+
+;;> If ANSI escapes are enabled, return a string consisting of the
+;;> string \var{str} with a prefix that selects specified background
+;;> color and a suffix that selects the default background color.
+;;>
+;;> If ANSI escapes are not enabled, return \var{str}.
+;;/
+
+;;> Returns a procedure which takes a single argument, a string, and
+;;> which when called behaves as follows.
+;;>
+;;> If ANSI escapes are enabled, the procedure returns a string
+;;> consisting of its argument with a prefix that selects specified
+;;> background color (obtained by calling the \scheme{rgb-background-escape}
+;;> procedure with the values of the \var{red-level}, \var{green-level},
+;;> and \var{blue-level} arguments) and a suffix that selects the
+;;> default background color.
+;;>
+;;> If ANSI escapes are not enabled, the procedure returns its argument.
+;;>
+;;> The caller is resonsible for verifying that the terminal supports
+;;> 256 colors.
+
+(define (rgb-background red-level green-level blue-level)
+  (make-wrap-procedure (rgb-background-escape red-level green-level blue-level)
+                       (reset-background-color-escape)))
+
+;;> Returns a procedure which takes a single argument, a string, and
+;;> which when called behaves as follows.
+;;>
+;;> If ANSI escapes are enabled, the procedure returns a string
+;;> consisting of its argument with a prefix that selects specified
+;;> background color (obtained by calling the \scheme{gray-background-escape}
+;;> procedure with the values of the \var{gray-level} argument) and a
+;;> suffix that selects the default background color.
+;;>
+;;> If ANSI escapes are not enabled, the procedure returns its argument.
+;;>
+;;> The caller is resonsible for verifying that the terminal supports
+;;> 256 colors.
+
+(define (gray-background gray-level)
+  (make-wrap-procedure (gray-background-escape gray-level)
+                       (reset-background-color-escape)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> Return a string consisting of an ANSI escape code to select bold
+;;> style.
+
+(define bold-escape
+  (make-simple-escape-procedure 1))
+
+;;> Return a string consisting of an ANSI escape code to select non-bold
+;;> style.
+
+(define reset-bold-escape
+  (make-simple-escape-procedure 22))
+
+;;> If ANSI escapes are enabled, return a string consisting of the
+;;> string \var{str} with a prefix that selects bold style and a suffix
+;;> that selects non-bold style.
+;;>
+;;> If ANSI escapes are not enabled, return \var{str}.
+
+(define bold (make-wrap-procedure (bold-escape)
+                                  (reset-bold-escape)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> Return a string consisting of an ANSI escape code to select
+;;> underlined style.
+
+(define underline-escape
+  (make-simple-escape-procedure 4))
+
+;;> Return a string consisting of an ANSI escape code to select
+;;> non-underlined style.
+
+(define reset-underline-escape
+  (make-simple-escape-procedure 24))
+
+;;> If ANSI escapes are enabled, return a string consisting of the
+;;> string \var{str} with a prefix that selects underlined style and
+;;> a suffix that selects non-underlined style.
+;;>
+;;> If ANSI escapes are not enabled, return \var{str}.
+
+(define underline (make-wrap-procedure (underline-escape)
+                                       (reset-underline-escape)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> Return a string consisting of an ANSI escape code to select negative
+;;> style (text in the background color and background in the text
+;;> color).
+
+(define negative-escape
+  (make-simple-escape-procedure 7))
+
+;;> Return a string consisting of an ANSI escape code to select positive
+;;> style (text in the text color and background in the background
+;;> color).
+
+(define reset-negative-escape
+  (make-simple-escape-procedure 27))
+
+;;> If ANSI escapes are enabled, return a string consisting of the
+;;> string \var{str} with a prefix that selects negative style (text
+;;> in the background color and background in the text color) and a
+;;> suffix that selects positive style (text in the text color and
+;;> background in the background color).
+;;>
+;;> If ANSI escapes are not enabled, return \var{str}.
+
+(define negative (make-wrap-procedure (negative-escape)
+                                      (reset-negative-escape)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> A parameter object that determines whether ANSI escapes are enabled
+;;> in some of the preceding procedures. They are disabled if
+;;> \scheme{(ansi-escapes-enabled?)} returns \scheme{#f}, and otherwise
+;;> they are enabled.
+;;>
+;;> The initial value returned by \scheme{(ansi-escapes-enabled?)} is
+;;> determined by the environment.
+;;>
+;;> If the environment variable \scheme{ANSI_ESCAPES_ENABLED} is set,
+;;> its value determines the initial value returned by
+;;> \scheme{(ansi-escapes-enabled?)}. If the value of
+;;> \scheme{ANSI_ESCAPES_ENABLED} is \scheme{"0"}, the initial value
+;;> is \scheme{#f}, otherwise the initial value is \scheme{#t}.
+;;>
+;;> If the environment variable \scheme{ANSI_ESCAPES_ENABLED} is not
+;;> set, but the environment variable \scheme{TERM} is set, the value
+;;> of the latter determines the initial value returned by
+;;> \scheme{(ansi-escapes-enabled?)}. If the value of \scheme{TERM}
+;;> is \scheme{"xterm"}, \scheme{"xterm-color"}, \scheme{"xterm-256color"},
+;;> \scheme{"rxvt"}, \scheme{"kterm"}, \scheme{"linux"}, \scheme{"screen"},
+;;> \scheme{"screen-256color"}, or \scheme{"vt100"}, the initial value
+;;> is \scheme{#t}, otherwise the initial value is \scheme{#f}.
+;;>
+;;> If neither of the environment variables \scheme{ANSI_ESCAPES_ENABLED}
+;;> and \scheme{TERM} are set, the initial value returned by
+;;> \scheme{(ansi-escapes-enabled?)} is \scheme{#f}.
+
+(define ansi-escapes-enabled?
+  (make-parameter
+   (cond
+    ((get-environment-variable "ANSI_ESCAPES_ENABLED")
+     => (lambda (s) (not (equal? s "0"))))
+    (else
+     (member (get-environment-variable "TERM")
+             '("xterm" "xterm-color" "xterm-256color" "rxvt" "kterm"
+               "linux" "screen" "screen-256color" "vt100"))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> \section{Notes}
+;;>
+;;> It is important to remember that the formatting procedures apply
+;;> a prefix to set a particular graphics parameter and a suffix to
+;;> reset the parameter to its default value. This can lead to surprises.
+;;> For example, on an ANSI terminal, one might mistakenly expect the
+;;> following to display GREEN in green text and then RED in red text:
+;;>
+;;> \codeblock{(display (red (string-append (green "GREEN") "RED")))}
+;;>
+;;> However, it will actually display GREEN in green text and then RED
+;;> in the default text color. This is a limitation of ANSI control
+;;> codes; graphics attributes are not saved to and restored from a
+;;> stack, but instead are simply set. One way to display GREEN in
+;;> green text and then RED in red text is:
+;;>
+;;> \codeblock{(display (string-append (green "GREEN") (red "RED")))}
+;;>
+;;> On the other hand, text color, background color, font weight (bold
+;;> or default), underline (on or off), image (positive or negative)
+;;> are orthogonal. So, for example, on an ANSI terminal the following
+;;> should display GREEN in green text and then RED in red text, with
+;;> both in bold and GREEN underlined.
+;;>
+;;> \codeblock{(display (bold (string-append (underline (green "GREEN")) (red "RED"))))}
+;;>
diff --git a/lib/chibi/term/ansi.sld b/lib/chibi/term/ansi.sld
new file mode 100644
index 00000000..42d752ea
--- /dev/null
+++ b/lib/chibi/term/ansi.sld
@@ -0,0 +1,35 @@
+(define-library (chibi term ansi)
+  (export
+
+   black-escape red-escape yellow-escape green-escape
+   blue-escape cyan-escape magenta-escape white-escape
+   rgb-escape 
+   gray-escape
+   reset-color-escape
+
+   black-background-escape red-background-escape
+   yellow-background-escape green-background-escape
+   blue-background-escape cyan-background-escape
+   magenta-background-escape white-background-escape
+   rgb-background-escape
+   gray-background-escape
+   reset-background-color-escape
+
+   black red yellow green
+   blue cyan magenta white
+   black-background red-background yellow-background green-background
+   blue-background cyan-background magenta-background white-background
+   bold
+   underline
+   negative
+   rgb rgb-background
+   gray gray-background
+   bold-escape reset-bold-escape
+   underline-escape reset-underline-escape
+   negative-escape reset-negative-escape
+
+   ansi-escapes-enabled?)
+  (import (scheme base)
+          (scheme write)
+          (scheme process-context))
+  (include "ansi.scm"))
diff --git a/lib/chibi/term/edit-line.scm b/lib/chibi/term/edit-line.scm
new file mode 100644
index 00000000..35020d34
--- /dev/null
+++ b/lib/chibi/term/edit-line.scm
@@ -0,0 +1,870 @@
+;;;; edit-line.scm - pure scheme line editor
+;;
+;; Copyright (c) 2011-2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; vt100 terminal utilities
+
+(define (terminal-escape out ch arg)
+  (write-char (integer->char 27) out)
+  (write-char #\[ out)
+  (if arg (display arg out))
+  (write-char ch out)
+  (flush-output out))
+
+;; we use zero-based columns
+(define (terminal-goto-col out n)  (terminal-escape out #\G (+ n 1)))
+(define (terminal-up out n)        (terminal-escape out #\A n))
+(define (terminal-down out n)      (terminal-escape out #\B n))
+(define (terminal-clear-below out) (terminal-escape out #\J #f))
+(define (terminal-clear-right out) (terminal-escape out #\K #f))
+
+(define (read-numeric-sequence in)
+  (let lp ((c (peek-char in)) (acc '()))
+    (case c
+      ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+       (read-char in)  ;; skip peeked char
+       (lp (peek-char in) (cons c acc)))
+      (else
+       (string->number (apply string (reverse acc)))))))
+
+(define (terminal-current-position in out)
+  (with-stty '(not icanon isig echo)
+    (lambda ()
+      (terminal-escape out #\n 6)
+      (read-char in)
+      (and (eqv? #\[ (read-char in))
+           (let ((y (read-numeric-sequence in)))
+             (and y
+                  (eqv? #\; (read-char in))
+                  (let ((x (read-numeric-sequence in)))
+                    (and x
+                         (eqv? #\R (read-char in))
+                         (list (- y 1) (- x 1))))))))))
+
+(define (at-first-column? in out)
+  (let ((pos (terminal-current-position in out)))
+    (and pos (zero? (cadr pos)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; history
+
+(define maximum-history-size 512)
+
+(define-record-type History
+  (%make-history remaining past future filter)
+  history?
+  (remaining history-remaining history-remaining-set!)
+  (past history-past history-past-set!)
+  (future history-future history-future-set!)
+  (filter history-filter history-filter-set!))
+
+(define (make-history . o)
+  (%make-history (if (pair? o) (car o) maximum-history-size)
+                 '()
+                 '()
+                 (and (pair? o) (pair? (cdr o)) (cadr o))))
+
+(define (history-current h)
+  (let ((p (history-past h)))
+    (and (pair? p) (car p))))
+
+(define (history->list h)
+  (let ((past (history-past h)) (future (history-future h)))
+    (if (pair? past) (cons (car past) (append future (cdr past))) future)))
+
+(define (list->history ls . o)
+  (%make-history (max maximum-history-size (length ls)) ls '()
+                 (and (pair? o) (car o))))
+
+(define (history-flatten! h)
+  (history-past-set! h (history->list h))
+  (history-future-set! h '()))
+
+(define (drop-last ls) (reverse (cdr (reverse ls))))
+
+(define (history-past-push! h x)
+  (if (positive? (history-remaining h))
+      (history-remaining-set! h (- (history-remaining h) 1))
+      (if (pair? (history-past h))
+          (history-past-set! h (drop-last (history-past h)))
+          (history-future-set! h (drop-last (history-future h)))))
+  (history-past-set! h (cons x (history-past h))))
+
+(define (history-insert! h x)
+  (history-flatten! h)
+  (if (not (and (history-filter h) ((history-filter h) x)))
+      (history-past-push! h x)))
+
+(define (history-reset! h)
+  (cond
+   ((pair? (history-future h))
+    (history-past-set! h (append (drop-last (history-future h))
+                                 (history-past h)))
+    (history-future-set! h '()))))
+
+(define (history-commit! h x)
+  (history-reset! h)
+  (history-insert! h x))
+
+(define (history-prev! h)
+  (let ((past (history-past h)))
+    (and (pair? past)
+         (pair? (cdr past))
+         (begin
+           (history-future-set! h (cons (car past) (history-future h)))
+           (history-past-set! h (cdr past))
+           (cadr past)))))
+
+(define (history-next! h)
+  (let ((future (history-future h)))
+    (and (pair? future)
+         (begin
+           (history-past-set! h (cons (car future) (history-past h)))
+           (history-future-set! h (cdr future))
+           (car future)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; char and string utils
+
+(define (char-word-constituent? ch)
+  (or (char-alphabetic? ch) (char-numeric? ch)
+      (memv ch '(#\_ #\- #\+ #\:))))
+
+(define (char-non-word-constituent? ch) (not (char-word-constituent? ch)))
+
+(define (string-copy! dst dstart src start end)
+  (if (>= start dstart)
+      (do ((i start (+ i 1)) (j dstart (+ j 1)))
+          ((= i end))
+        (string-set! dst j (string-ref src i)))
+      (do ((i (- end 1) (- i 1)) (j (+ dstart (- end start 1)) (- j 1)))
+          ((< i start))
+        (string-set! dst j (string-ref src i)))))
+
+(define (string-index ch x)
+  (let ((len (string-length x)))
+    (let lp ((i 0))
+      (cond ((>= i len) #f)
+            ((eqv? ch (string-ref x i)))
+            (else (lp (+ i 1)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; buffers
+
+(define-record-type Buffer
+  (%make-buffer refresh? cleared? min pos row max-row col gap start width
+                string history complete? single-line?)
+  buffer?
+  (refresh? buffer-refresh? buffer-refresh?-set!)
+  (cleared? buffer-cleared? buffer-cleared?-set!)
+  (min buffer-min buffer-min-set!)
+  (pos buffer-pos buffer-pos-set!)
+  (row buffer-row buffer-row-set!)
+  (max-row buffer-max-row buffer-max-row-set!)
+  (col buffer-col buffer-col-set!)
+  (gap buffer-gap buffer-gap-set!)
+  (start buffer-start buffer-start-set!)
+  (width buffer-width buffer-width-set!)
+  (string buffer-string buffer-string-set!)
+  (kill-ring buffer-kill-ring buffer-kill-ring-set!)
+  (history buffer-history buffer-history-set!)
+  (complete? buffer-complete? buffer-complete?-set!)
+  (single-line? buffer-single-line? buffer-single-line?-set!))
+
+(define default-buffer-size 256)
+(define default-buffer-width 80)
+
+(define (make-buffer)
+  (%make-buffer #f #f 0 0 0 0 0 default-buffer-size 0 default-buffer-width
+                (make-string default-buffer-size) '() #f #f))
+
+(define (buffer->string buf)
+  (let ((str (buffer-string buf)))
+    (string-append (substring str (buffer-min buf) (buffer-pos buf))
+                   (substring str (buffer-gap buf) (string-length str)))))
+
+(define (buffer-right-length buf)
+  (- (string-length (buffer-string buf)) (buffer-gap buf)))
+(define (buffer-length buf)
+  (+ (buffer-pos buf) (buffer-right-length buf)))
+(define (buffer-free-space buf)
+  (- (buffer-gap buf) (buffer-pos buf)))
+
+(define (buffer-clamp buf n)
+  (max (buffer-min buf) (min n (buffer-length buf))))
+
+(define (buffer-resize buf n)
+  (cond ((<= (buffer-free-space buf) n)
+         (let* ((right-len (buffer-right-length buf))
+                (new-len (* 2 (max n (buffer-length buf))))
+                (new-gap (- new-len right-len))
+                (new (make-string new-len))
+                (old (buffer-string buf)))
+           (string-copy! new 0 old 0 (buffer-pos buf))
+           (string-copy! new new-gap old (buffer-gap buf) (string-length old))
+           (buffer-string-set! buf new)
+           (buffer-gap-set! buf new-gap)))))
+
+;; Adapted from fmt-unicode. TODO: convert to char-sets.
+(define low-non-spacing-chars '#u8(
+#xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+#x78    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0 #xfe #xff #xff #xff #xff #xff #x1f    0    0    0    0    0    0    0
+   0    0 #x3f    0    0    0    0    0    0 #xf8 #xff #x01    0    0 #x01    0
+   0    0    0    0    0    0    0    0    0    0 #xc0 #xff #xff #x3f    0    0
+   0    0 #x02    0    0    0 #xff #xff #xff #x07    0    0    0    0    0    0
+   0    0    0    0 #xc0 #xff #x01    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+#x06    0    0    0    0    0    0 #x10 #xfe #x21 #x1e    0 #x0c    0    0    0
+#x02    0    0    0    0    0    0 #x10 #x1e #x20    0    0 #x0c    0    0    0
+#x06    0    0    0    0    0    0 #x10 #xfe #x3f    0    0    0    0 #x03    0
+#x06    0    0    0    0    0    0 #x30 #xfe #x21    0    0 #x0c    0    0    0
+#x02    0    0    0    0    0    0 #x90 #x0e #x20 #x40    0    0    0    0    0
+#x04    0    0    0    0    0    0    0    0 #x20    0    0    0    0    0    0
+   0    0    0    0    0    0    0 #xc0 #xc1 #xff #x7f    0    0    0    0    0
+   0    0    0    0    0    0    0 #x10 #x40 #x30    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0 #x0e #x20    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0 #x04 #x7c    0    0    0    0    0
+   0    0    0    0    0    0 #xf2 #x07 #x80 #x7f    0    0    0    0    0    0
+   0    0    0    0    0    0 #xf2 #x1f    0 #x3f    0    0    0    0    0    0
+   0    0    0 #x03    0    0 #xa0 #x02    0    0    0    0    0    0 #xfe #x7f
+#xdf    0 #xff #xff #xff #xff #xff #x1f #x40    0    0    0    0    0    0    0
+   0    0    0    0    0 #xe0 #xfd #x02    0    0    0 #x03    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0 #x1c    0    0    0 #x1c    0    0    0 #x0c    0    0    0 #x0c    0
+   0    0    0    0    0    0 #x80 #x3f #x40 #xfe #x0f #x20    0    0    0    0
+   0 #x38    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0 #x02    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0 #x87 #x01 #x04 #x0e    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
+   0    0    0    0    0    0    0    0    0    0 #xff #x1f #xe2 #x07))
+
+(define (unicode-char-width c)
+  (let ((ci (char->integer c)))
+    (cond
+      ;; hand-checked ranges from EastAsianWidth.txt
+      ((<= #x1100 ci #x115F) 2) ; Hangul
+      ((<= #x2E80 ci #x4DB5) 2) ; CJK
+      ((<= #x4E00 ci #xA4C6) 2)
+      ((<= #xAC00 ci #xD7A3) 2) ; Hangul
+      ((<= #xF900 ci #xFAD9) 2) ; CJK compat
+      ((<= #xFE10 ci #xFE6B) 2)
+      ((<= #xFF01 ci #xFF60) 2)
+      ((<= #xFFE0 ci #xFFE6) 2)
+      ((<= #x20000 ci #x30000) 2)
+      ;; non-spacing mark (Mn) ranges from UnicodeData.txt
+      ((<= #x0300 ci #x3029)
+       ;; inlined bit-vector-ref for portability
+       (let* ((i (- ci #x0300))
+              (byte (quotient i 8))
+              (off (remainder i 8)))
+         (if (zero? (bitwise-and (bytevector-u8-ref low-non-spacing-chars byte)
+                                 (arithmetic-shift 1 off)))
+             1
+             0)))
+      ((<= #x302A ci #x302F) 0)
+      ((<= #x3099 ci #x309A) 0)
+      ((= #xFB1E ci) 0)
+      ((<= #xFE00 ci #xFE23) 0)
+      ((<= #x1D167 ci #x1D169) 0)
+      ((<= #x1D17B ci #x1D182) 0)
+      ((<= #x1D185 ci #x1D18B) 0)
+      ((<= #x1D1AA ci #x1D1AD) 0)
+      ((<= #xE0100 ci #xE01EF) 0)
+      (else 1))))
+
+(define (unicode-string-width str . o)
+  (let ((start (if (pair? o) (car o) 0))
+        (end (if (and (pair? o) (pair? (cdr o)))
+                 (cadr o)
+                 (string-length str))))
+    (let lp1 ((i start) (width 0))
+      (if (>= i end)
+          width
+          (let ((c (string-ref str i)))
+            (cond
+              ;; ANSI escapes
+              ((and (= 27 (char->integer c)) ; esc
+                    (< (+ i 1) end)
+                    (eqv? #\[ (string-ref str (+ i 1))))
+               (let lp2 ((i (+ i 2)))
+                 (cond ((>= i end) width)
+                       ((memv (string-ref str i) '(#\m #\newline))
+                        (lp1 (+ i 1) width))
+                       (else (lp2 (+ i 1))))))
+              ;; unicode characters
+              ((>= (char->integer c) #x80)
+               (lp1 (+ i 1) (+ width (unicode-char-width c))))
+              ;; normal ASCII
+              (else (lp1 (+ i 1) (+ width 1)))))))))
+
+(define (buffer-update-position! buf)
+  (let ((pos (buffer-pos buf))
+        (gap (buffer-gap buf))
+        (str (buffer-string buf))
+        (end (string-length (buffer-string buf)))
+        (width (buffer-width buf)))
+    (cond
+     ((buffer-single-line? buf)
+      ;; The "start" is the last left-most column of the buffer when
+      ;; we overflow and need to scroll horizontally.  This defaults
+      ;; to 0 and increments as we move past the last column.  We
+      ;; update it when we find that (via movement or insertion) the
+      ;; point would no longer be visible from "start" to the end of
+      ;; the line, by shifting the start to the rightmost column that
+      ;; would show the point.  Thus, after scrolling off the
+      ;; beginning of the buffer, successive movements left will first
+      ;; go to the 0th column, then scroll to the start one character
+      ;; at a time.  A beginning-of-line command will restore the
+      ;; "start" to 0 immediately.
+      ;; We assume no embedded newlines in this case.
+      (let ((start (buffer-start buf))
+            (min-width (unicode-string-width str 0 (buffer-min buf))))
+        (cond
+         ((> start pos)
+          ;; We've moved back before the current start - reset to pos.
+          (buffer-start-set! buf pos))
+         ((> (+ 1 min-width (unicode-string-width str start pos))
+             (buffer-width buf))
+          ;; The edited text is wider than the screen - scroll the
+          ;; start so that pos fits on the end.
+          ;; TODO: This isn't correct for wide characters, need to
+          ;; loop checking individual widths.
+          (buffer-start-set!
+           buf
+           (max 0 (- (+ 1 min-width (unicode-string-width str 0 pos))
+                     (buffer-width buf))))))
+        ;; Compute the current column as the width of the prompt plus
+        ;; the width of the visible buffer from start to pos.
+        (let* ((vis-width (unicode-string-width str (buffer-start buf) pos))
+               (col (+ min-width vis-width)))
+          (buffer-col-set! buf col))))
+     (else
+      ;; Otherwise, in a multi-line editor we need to scan for
+      ;; newlines to determine the current (relative) row and column.
+      ;; TODO: Handle ANSI escapes.
+      (let lp ((i 0) (row 0) (col 0)) ;; update row/col
+        (cond ((= i pos)
+               (buffer-row-set! buf row)
+               (buffer-col-set! buf col)
+               (lp gap row col))      ;; skip from pos->gap
+              ((>= i end)
+               (buffer-max-row-set!
+                buf (if (and (zero? col) (> row 0)) (- row 1) row)))
+              ((eqv? #\newline (string-ref str i))
+               (lp (+ i 1) (+ row 1) 0))
+              (else
+               (let ((off (unicode-char-width (string-ref str i))))
+                 (if (>= (+ col off) width)
+                     (lp (+ i 1) (+ row 1) 0)
+                     (lp (+ i 1) row (+ col off)))))))))))
+
+(define (buffer-clear buf out)
+  (cond
+   ((not (buffer-cleared? buf))
+    ;; goto start of input
+    (terminal-goto-col out 0)
+    (if (positive? (buffer-row buf))
+        (terminal-up out (buffer-row buf)))
+    ;; clear below
+    (terminal-clear-below out)
+    (buffer-cleared?-set! buf #t))))
+
+(define (buffer-draw buf out)
+  (let* ((gap (buffer-gap buf))
+         (str (buffer-string buf))
+         (end (string-length str))
+         (old-row (buffer-row buf))
+         (old-col (buffer-col buf)))
+    ;; update position and clear the current input
+    (buffer-clear buf out)
+    (buffer-update-position! buf)
+    (let ((left (if (buffer-single-line? buf)
+                    (buffer-start buf)
+                    (buffer-min buf)))
+          (right
+           (if (buffer-single-line? buf)
+               (min end (+ (buffer-gap buf)
+                           (- (buffer-width buf) (buffer-col buf))))
+               end)))
+      (display (substring str 0 (buffer-min buf)) out)
+      (display (substring str left (buffer-pos buf)) out)
+      (display (substring str (buffer-gap buf) right) out))
+    (cond
+     ((not (buffer-single-line? buf))
+      ;; move to next line if point at eol
+      (if (and (zero? (buffer-col buf)) (positive? (buffer-row buf)))
+          (write-char #\space out))
+      ;; move to correct row then col
+      (if (< (buffer-row buf) (buffer-max-row buf))
+          (terminal-up out (- (buffer-max-row buf) (buffer-row buf))))))
+    (terminal-goto-col out (buffer-col buf))
+    (flush-output out)
+    (buffer-cleared?-set! buf #f)))
+
+(define (buffer-refresh buf out)
+  (cond ((buffer-refresh? buf)
+         (buffer-draw buf out)
+         (buffer-refresh?-set! buf #f))))
+
+(define (buffer-goto! buf out n)
+  (let ((pos (buffer-pos buf))
+        (gap (buffer-gap buf))
+        (str (buffer-string buf))
+        (n (buffer-clamp buf n)))
+    (cond ((not (= n pos))
+           (buffer-update-position! buf) ;; necesary?
+           (if (< n pos)
+               (string-copy! str (- gap (- pos n)) str n pos)
+               (string-copy! str pos str gap (+ gap (- n pos))))
+           (buffer-pos-set! buf n)
+           (buffer-gap-set! buf (+ gap (- n pos)))
+           (cond
+            ((not (buffer-refresh? buf))
+             (let ((old-row (buffer-row buf))
+                   (old-start (buffer-start buf)))
+               (buffer-update-position! buf)
+               (cond
+                ((not (= old-start (buffer-start buf)))
+                 (buffer-refresh?-set! buf #t))
+                (else
+                 (let ((row-diff (- old-row (buffer-row buf))))
+                   (cond ((> row-diff 0) (terminal-up out row-diff))
+                         ((< row-diff 0) (terminal-down out (- row-diff)))))
+                 (terminal-goto-col out (buffer-col buf)))))))))))
+
+(define (buffer-insert! buf out x)
+  (let ((len (if (char? x) 1 (string-length x)))
+        (pos (buffer-pos buf)))
+    (buffer-resize buf len)
+    (if (char? x)
+        (string-set! (buffer-string buf) pos x)
+        (string-copy! (buffer-string buf) pos x 0 len))
+    (buffer-pos-set! buf (+ (buffer-pos buf) len))
+    (cond
+     ((buffer-refresh? buf))
+     ((and (= (buffer-gap buf) (string-length (buffer-string buf)))
+           (< (+ (buffer-col buf) len) (buffer-width buf))
+           (if (char? x)
+               (not (eqv? x #\newline))
+               (not (string-index #\newline x))))
+      ;; fast path - append to end of buffer w/o wrapping to next line
+      (display x out)
+      (flush-output out)
+      (buffer-col-set! buf (+ (buffer-col buf) len))
+      (buffer-cleared?-set! buf #f))
+     (else
+      (buffer-refresh?-set! buf #t)))))
+
+(define (buffer-delete! buf out start end)
+  (let ((pos (buffer-pos buf))
+        (gap (buffer-gap buf))
+        (str (buffer-string buf))
+        (start (buffer-clamp buf start))
+        (end (buffer-clamp buf end)))
+    (if (not (buffer-refresh? buf))
+        (if (and (= start pos) (>= end (buffer-length buf)))
+            (terminal-clear-below out)
+            (buffer-refresh?-set! buf #t)))
+    (cond ((< end pos)
+           (string-copy! str start str end pos)
+           (buffer-pos-set! buf (+ start (- pos end))))
+          ((> start gap)
+           (string-copy! str start str gap (+ gap (- end start)))
+           (buffer-gap-set! buf (+ gap (- end start))))
+          (else
+           (buffer-pos-set! buf (min pos start))
+           (buffer-gap-set! buf (max gap (+ pos (- gap pos) (- end pos))))))))
+
+(define (buffer-skip buf pred)
+  (let* ((str (buffer-string buf)) (end (string-length str)))
+    (let lp ((i (buffer-gap buf)))
+      (if (or (>= i end) (not (pred (string-ref str i))))
+          (+ (- i (buffer-gap buf)) (buffer-pos buf))
+          (lp (+ i 1))))))
+
+(define (buffer-skip-reverse buf pred)
+  (let ((str (buffer-string buf)))
+    (let lp ((i (- (buffer-pos buf) 1)))
+      (if (or (< i 0) (not (pred (string-ref str i)))) i (lp (- i 1))))))
+
+(define (buffer-previous-word buf)
+  (let ((i (buffer-skip-reverse buf char-word-constituent?)))
+    (substring (buffer-string buf) (+ i 1) (buffer-pos buf))))
+
+(define (buffer-format-list buf out words)
+  (let ((width (buffer-width buf)))
+    (define (write-rows num-cols widths)
+      (let lp ((ls words) (i 0))
+        (cond
+         ((pair? ls)
+          (let ((diff (- (vector-ref widths i) (string-length (car ls)))))
+            (display (car ls) out)
+            (if (= (+ i 1) num-cols)
+                (newline out)
+                (display (make-string (+ 1 diff) #\space) out))
+            (lp (cdr ls) (modulo (+ i 1) num-cols))))
+         ((< i num-cols)
+          (newline out)))))
+    (let try-cols ((num-cols (length words)))
+      (cond
+       ((<= num-cols 1)
+        (newline out)
+        (for-each (lambda (x) (display x out) (newline out)) words))
+       (else
+        (let ((widths (make-vector num-cols 0)))
+          (let lp ((ls words) (i 0) (avail (- num-cols 1)))
+            (cond
+             ((null? ls)
+              (write-rows num-cols widths))
+             (else
+              (let ((diff (- (string-length (car ls)) (vector-ref widths i))))
+                (if (positive? diff)
+                    (let ((avail (+ avail diff)))
+                      (cond
+                       ((> avail width)
+                        (try-cols (- num-cols 1)))
+                       (else
+                        (vector-set! widths i (string-length (car ls)))
+                        (lp (cdr ls) (modulo (+ i 1) num-cols) avail))))
+                    (lp (cdr ls) (modulo (+ i 1) num-cols) avail))))))))))))
+
+(define (buffer-make-completer generate)
+  (lambda (ch buf out return)
+    (let* ((word (buffer-previous-word buf))
+           (ls (generate buf word)))
+      (cond
+       ((null? ls)
+        (command/beep ch buf out return))
+       ((= 1 (length ls))
+        (buffer-insert! buf out (substring (car ls) (string-length word))))
+       (else
+        (newline out)
+        (buffer-format-list buf out ls)
+        (buffer-draw buf out))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; keymaps
+
+(define keymap? pair?)
+
+(define (make-keymap . o)
+  (cons (make-vector 256 #f) (and (pair? o) (car o))))
+
+(define (make-sparse-keymap . o)
+  (cons '() (and (pair? o) (car o))))
+
+(define (make-printable-keymap)
+  (let* ((keymap (make-keymap command/self-insert))
+         (v (car keymap)))
+    (do ((i #x20 (+ i 1))) ((= i #x7F) keymap)
+      (vector-set! v i command/self-insert))))
+
+(define (make-standard-escape-bracket-keymap)
+  (let* ((keymap (make-keymap))
+         (v (car keymap)))
+    (vector-set! v 65 command/backward-history)
+    (vector-set! v 66 command/forward-history)
+    (vector-set! v 67 command/forward-char)
+    (vector-set! v 68 command/backward-char)
+    keymap))
+
+(define (make-standard-escape-keymap)
+  (let* ((keymap (make-keymap))
+         (v (car keymap)))
+    (vector-set! v   8 command/backward-delete-word)
+    (vector-set! v  91 (make-standard-escape-bracket-keymap))
+    (vector-set! v  98 command/backward-word)
+    (vector-set! v 100 command/forward-delete-word)
+    (vector-set! v 102 command/forward-word)
+    (vector-set! v 127 command/backward-delete-word)
+    keymap))
+
+(define (make-standard-keymap . o)
+  (let* ((keymap (make-printable-keymap))
+         (v (car keymap))
+         (catch-control-c? (and (pair? o) (car o))))
+    (vector-set! v   0 command/enter)   ;; for telnet
+    (vector-set! v   1 command/beginning-of-line)
+    (vector-set! v   2 command/backward-char)
+    (vector-set! v   3 (if catch-control-c? command/cancel command/quit))
+    (vector-set! v   4 command/forward-delete-char)
+    (vector-set! v   5 command/end-of-line)
+    (vector-set! v   6 command/forward-char)
+    (vector-set! v   8 command/backward-delete-char)
+    (vector-set! v  10 command/enter)
+    (vector-set! v  11 command/forward-delete-line)
+    (vector-set! v  12 command/refresh)
+    (vector-set! v  13 command/skip)
+    (vector-set! v  14 command/forward-history)
+    (vector-set! v  16 command/backward-history)
+    (vector-set! v  21 command/backward-delete-line)
+    (vector-set! v  27 (make-standard-escape-keymap))
+    (vector-set! v 127 command/backward-delete-char)
+    keymap))
+
+(define (keymap-lookup keymap n)
+  (let ((table (car keymap)))
+    (or (if (vector? table)
+            (and (< -1 n (vector-length table)) (vector-ref table n))
+            (cond ((assv n table) => cdr) (else #f)))
+        (if (keymap? (cdr keymap))
+            (keymap-lookup (cdr keymap) n)
+            (cdr keymap)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; commands
+
+(define (command/self-insert ch buf out return)
+  (buffer-insert! buf out ch))
+
+(define (command/enter ch buf out return)
+  (protect (exn
+            ((and (exception? exn)
+                  (eq? 'read-incomplete (exception-kind exn)))
+             (command/self-insert ch buf out return))
+            (else
+             (buffer-clear buf out)
+             (print-exception exn out)
+             (buffer-draw buf out)))
+    (cond
+     (((buffer-complete? buf) buf)
+      (command/end-of-line ch buf out return)
+      (display "\r\n" out)
+      (flush-output out)
+      (return))
+     (else
+      (command/self-insert ch buf out return)))))
+
+(define (command/cancel ch buf out return)
+  (command/end-of-line ch buf out return)
+  (display "^C" out)
+  (newline out)
+  (buffer-delete! buf out 0 (buffer-length buf))
+  (buffer-draw buf out))
+
+(define (command/quit ch buf out return)
+  (command/end-of-line ch buf out return)
+  (display "^C" out)
+  (newline out)
+  (stty out '(icanon isig echo))
+  (exit))
+
+(define (command/beep ch buf out return)
+  (write-char (integer->char 7) out))
+
+(define (command/skip ch buf out return)
+  #f)
+
+(define (command/refresh ch buf out return)
+  (buffer-draw buf out))
+
+(define (command/beginning-of-line ch buf out return)
+  (buffer-goto! buf out 0))
+
+(define (command/end-of-line ch buf out return)
+  (buffer-goto! buf out (buffer-length buf)))
+
+(define (command/forward-char ch buf out return)
+  (buffer-goto! buf out (+ (buffer-pos buf) 1)))
+
+(define (command/backward-char ch buf out return)
+  (buffer-goto! buf out (- (buffer-pos buf) 1)))
+
+(define (command/forward-delete-char ch buf out return)
+  (cond
+   ((zero? (- (buffer-length buf) (buffer-min buf)))
+    (newline out)
+    (return 'eof))
+   (else
+    (buffer-delete! buf out (buffer-pos buf) (+ (buffer-pos buf) 1)))))
+
+(define (command/backward-delete-char ch buf out return)
+  (buffer-delete! buf out (- (buffer-pos buf) 1) (buffer-pos buf)))
+
+(define (command/forward-delete-line ch buf out return)
+  (buffer-delete! buf out (buffer-pos buf) (buffer-length buf)))
+
+(define (command/backward-delete-line ch buf out return)
+  (buffer-delete! buf out 0 (buffer-pos buf)))
+
+(define (command/backward-history ch buf out return)
+  (let ((history (buffer-history buf)))
+    (cond
+     ((and (history? history) (pair? (history-past history)))
+      (if (null? (history-future history))
+          (history-insert! history (buffer->string buf)))
+      (cond
+       ((pair? (cdr (history-past history)))
+        (buffer-delete! buf out 0 (buffer-length buf))
+        (buffer-insert! buf out (history-prev! history))))))))
+
+(define (command/forward-history ch buf out return)
+  (let ((history (buffer-history buf)))
+    (cond
+     ((and (history? history) (pair? (history-future history)))
+      (buffer-delete! buf out 0 (buffer-length buf))
+      (let ((res (buffer-insert! buf out (history-next! history))))
+        (if (null? (history-future history))
+            (history-past-set! history (cdr (history-past history))))
+        res)))))
+
+(define (command/forward-word ch buf out return)
+  (buffer-goto! buf out (buffer-skip buf char-non-word-constituent?))
+  (buffer-goto! buf out (buffer-skip buf char-word-constituent?)))
+
+(define (command/backward-word ch buf out return)
+  (buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?))
+  (buffer-goto! buf out (+ (buffer-skip-reverse buf char-word-constituent?) 1)))
+
+(define (command/forward-delete-word ch buf out return)
+  (let ((start (buffer-pos buf)))
+    (buffer-goto! buf out (buffer-skip buf char-non-word-constituent?))
+    (buffer-delete! buf out start (buffer-skip buf char-word-constituent?))))
+
+(define (command/backward-delete-word ch buf out return)
+  (let ((end (buffer-pos buf)))
+    (buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?))
+    (let ((start (buffer-skip-reverse buf char-word-constituent?)))
+      (buffer-delete! buf out (+ start 1) end))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; line-editing
+
+(define standard-keymap (make-standard-keymap))
+(define standard-cancel-keymap (make-standard-keymap #t))
+
+(define (get-key ls key . o)
+  (let ((x (memq key ls)))
+    (if (and x (pair? (cdr x))) (cadr x) (and (pair? o) (car o)))))
+
+(define (with-leading-ports ls proc)
+  (if (and (pair? ls) (input-port? (car ls)))
+      (if (and (pair? (cdr ls)) (output-port? (cadr ls)))
+          (proc (car ls) (cadr ls) (cddr ls))
+          (proc (car ls) (current-output-port) (cdr ls)))
+      (proc (current-input-port) (current-output-port) ls)))
+
+(define (make-line-editor . args)
+  (let* ((prompter (get-key args 'prompt: "> "))
+         (history (get-key args 'history:))
+         (complete? (get-key args 'complete?: (lambda (buf) #t)))
+         (completion (get-key args 'completion: #f))
+         (terminal-width (get-key args 'terminal-width:))
+         (single-line? (get-key args 'single-line?: #f))
+         (fresh-line (get-key args 'fresh-line: #f))
+         (no-stty? (get-key args 'no-stty?: #f))
+         (keymap0 (get-key args 'keymap:
+                           (if (get-key args 'catch-control-c?: #f)
+                               standard-cancel-keymap
+                               standard-keymap)))
+         (keymap (if completion
+                     (cons (list (cons 9 completion)) keymap0)
+                     keymap0))
+         (buf (or (get-key args 'buffer: #f) (make-buffer))))
+    (lambda (in out)
+      (let* ((width (or terminal-width (get-terminal-width out) 80))
+             (prompt (if (procedure? prompter) (prompter) prompter))
+             (done? #f)
+             (return (lambda o (set! done? (if (pair? o) (car o) #t)))))
+        ;; Maybe start at a fresh line.
+        (cond
+         ((and fresh-line (not (at-first-column? in out)))
+          (if (string? fresh-line) (display fresh-line out))
+          (newline out)))
+        ;; Clear buffer and reset prompt.
+        (buffer-refresh?-set! buf #t)
+        (buffer-min-set! buf 0)
+        (buffer-delete! buf out 0 (buffer-length buf))
+        (buffer-width-set! buf width)
+        (buffer-insert! buf out prompt)
+        (buffer-min-set! buf (string-length prompt))
+        (buffer-history-set! buf history)
+        (buffer-complete?-set! buf complete?)
+        (buffer-single-line?-set! buf single-line?)
+        (if single-line? (buffer-start-set! buf (buffer-min buf)))
+        (buffer-refresh buf out)
+        (flush-output out)
+        ((if no-stty? (lambda (out f) (f)) with-raw-io)
+         out
+         (lambda ()
+           (let lp ((kmap keymap))
+             (let ((ch (read-char in)))
+               (if (eof-object? ch)
+                   (let ((res (buffer->string buf)))
+                     (if (equal? res "") ch res))
+                   (let ((x (keymap-lookup kmap (char->integer ch))))
+                     (cond
+                      ((keymap? x)
+                       (lp x))
+                      ((procedure? x)
+                       (protect (exn (else
+                                      (buffer-clear buf out)
+                                      (print-exception exn out)
+                                      (buffer-draw buf out)))
+                         (x ch buf out return))
+                       (flush-output out)
+                       (buffer-refresh buf out)
+                       (if done?
+                           (and (not (eq? done? 'eof)) (buffer->string buf))
+                           (lp keymap)))
+                      (else
+                       ;;(command/beep ch buf out return)
+                       (lp keymap)))))))))))))
+
+(define (edit-line . args)
+  (with-leading-ports
+   args
+   (lambda (in out rest) ((apply make-line-editor rest) in out))))
+
+(define (edit-line-repl . args)
+  (with-leading-ports
+   args
+   (lambda (in out rest)
+     (let ((eval (get-key rest 'eval: (lambda (x) x)))
+           (print (get-key rest 'write: write))
+           (history (or (get-key rest 'history:) (make-history))))
+       (let ((edit-line
+              (apply make-line-editor 'no-stty?: #t 'history: history rest)))
+         ((if (get-key args 'no-stty?:) (lambda (out f) (f)) with-raw-io)
+          out
+          (lambda ()
+            (let lp ()
+              (let ((line (edit-line in out)))
+                (if (pair? (history-future history))
+                    (history-past-set! history (cdr (history-past history))))
+                (history-commit! history line)
+                (print (eval line) out)
+                (newline out)
+                (lp))))))))))
diff --git a/lib/chibi/term/edit-line.sld b/lib/chibi/term/edit-line.sld
new file mode 100644
index 00000000..1bb0e996
--- /dev/null
+++ b/lib/chibi/term/edit-line.sld
@@ -0,0 +1,11 @@
+
+(define-library (chibi term edit-line)
+  (export make-line-editor edit-line edit-line-repl
+          make-history history-insert! history-reset!
+          history-commit! history->list list->history buffer->string
+          make-buffer buffer-make-completer
+          buffer-clear buffer-refresh buffer-draw
+          buffer-row buffer-col
+          make-keymap make-standard-keymap)
+  (import (chibi) (chibi ast) (chibi stty) (chibi process) (srfi 9) (srfi 33))
+  (include "edit-line.scm"))
diff --git a/lib/chibi/test.scm b/lib/chibi/test.scm
new file mode 100644
index 00000000..8a956bef
--- /dev/null
+++ b/lib/chibi/test.scm
@@ -0,0 +1,796 @@
+;; Copyright (c) 2010-2014 Alex Shinn. All rights reserved. 
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> Simple testing framework adapted from the Chicken \scheme{test}
+;;> module.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; list utilities
+
+;; Simplified version of SRFI-1 every.
+(define (every pred ls)
+  (or (null? ls)
+      (if (null? (cdr ls))
+          (pred (car ls))
+          (if (pred (car ls)) (every pred (cdr ls)) #f))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; exception utilities
+
+(define (warning msg . args)
+  (display msg (current-error-port))
+  (for-each (lambda (x)
+              (write-char #\space (current-error-port))
+              (write x (current-error-port)))
+            args)
+  (newline (current-error-port)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; string utilities
+
+(define (string-search pat str)
+  (let* ((pat-len (string-length pat))
+         (limit (- (string-length str) pat-len)))
+    (let lp1 ((i 0))
+      (cond
+       ((>= i limit) #f)
+       (else
+        (let lp2 ((j i) (k 0))
+          (cond ((>= k pat-len) #t)
+                ((not (eqv? (string-ref str j) (string-ref pat k)))
+                 (lp1 (+ i 1)))
+                (else (lp2 (+ j 1) (+ k 1))))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; test interface
+
+;;> \macro{(test [name] expect expr)}
+
+;;> Evaluate \var{expr} and check that it is \scheme{equal?}
+;;> to \var{expect}.  \var{name} is used in reporting, and
+;;> defaults to a printed summary of \var{expr}.
+
+(define-syntax test
+  (syntax-rules (quote)
+    ((test expect expr)
+     (test #f expect expr))
+    ((test name expect (expr ...))
+     (test-propagate-info name expect (expr ...) ()))
+    ((test name 'expect expr)
+     (test-propagate-info name 'expect expr ()))
+    ((test name (expect ...) expr)
+     (test-syntax-error
+      'test
+      "the test expression should come last: (test <expected> (<expr> ...)) "
+      (test name (expect ...) expr)))
+    ((test name expect expr)
+     (test-propagate-info name expect expr ()))
+    ((test a ...)
+     (test-syntax-error 'test "test requires 2 or 3 arguments" (test a ...)))))
+
+;;> \macro{(test-equal equal [name] expect expr)}
+
+;;> Equivalent to test, using \var{equal} for comparison instead of
+;;> \scheme{equal?}.
+
+(define-syntax test-equal
+  (syntax-rules ()
+    ((test-equal equal . args)
+     (parameterize ((current-test-comparator equal))
+       (test . args)))))
+
+;;> \macro{(test-assert [name] expr)}
+
+;;> Like \scheme{test} but evaluates \var{expr} and checks that it's true.
+
+(define-syntax test-assert
+  (syntax-rules ()
+    ((_ expr)
+     (test-assert #f expr))
+    ((_ name expr)
+     (test-propagate-info name #f expr ((assertion . #t))))
+    ((test a ...)
+     (test-syntax-error 'test-assert "1 or 2 arguments required"
+                        (test a ...)))))
+
+;;> \macro{(test-not [name] expr)}
+
+;;> Like \scheme{test} but evaluates \var{expr} and checks that it's false.
+
+(define-syntax test-not
+  (syntax-rules ()
+    ((_ expr) (test-assert (not expr)))
+    ((_ name expr) (test-assert name (not expr)))))
+
+;;> \macro{(test-values [name] expect expr)}
+
+;;> Like \scheme{test} but \var{expect} and \var{expr} can both
+;;> return multiple values.
+
+(define-syntax test-values
+  (syntax-rules ()
+    ((_ expect expr)
+     (test-values #f expect expr))
+    ((_ name expect expr)
+     (test name (call-with-values (lambda () expect) (lambda results results))
+       (call-with-values (lambda () expr) (lambda results results))))))
+
+;;> \macro{(test-error [name] expr)}
+
+;;> Like \scheme{test} but evaluates \var{expr} and checks that it
+;;> raises an error.
+
+(define-syntax test-error
+  (syntax-rules ()
+    ((_ expr)
+     (test-error #f expr))
+    ((_ name expr)
+     (test-propagate-info name #f expr ((expect-error . #t))))
+    ((test a ...)
+     (test-syntax-error 'test-error "1 or 2 arguments required"
+                        (test a ...)))))
+
+;; TODO: Extract interesting variables so we can show their values on
+;; failure.
+(define-syntax test-propagate-info
+  (syntax-rules ()
+    ((test-propagate-info name expect expr info)
+     (test-vars () name expect expr info))))
+
+(define-syntax test-vars
+  (syntax-rules ()
+    ((_ (vars ...) n expect expr ((key . val) ...))
+     (test-run (lambda () expect)
+               (lambda () expr)
+               `((name . ,n)
+                 (source . expr)
+                 (var-names . (vars ...))
+                 (var-values . ,(list vars ...))
+                 (key . val) ...)))))
+
+;;> \macro{(test-exit)}
+
+;;> Exits with a failure status if any tests have failed,
+;;> and a successful status otherwise.
+
+(define (test-exit)
+  (exit (zero? (test-failure-count))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; group interface
+
+;;> Wraps \var{body} as a single test group, which can be filtered
+;;> and summarized separately.
+
+(define-syntax test-group
+  (syntax-rules ()
+    ((_ name-expr body ...)
+     (let ((name name-expr)
+           (old-group (current-test-group)))
+       (if (not (string? name))
+           (error "a name is required, got " 'name-expr name))
+       (test-begin name)
+       (guard
+           (exn
+            (else
+             (warning "error in group outside of tests")
+             (print-exception exn (current-error-port))
+             (test-group-inc! (current-test-group) 'count)
+             (test-group-inc! (current-test-group) 'ERROR)))
+         body ...)
+       (test-end name)
+       (current-test-group old-group)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utilities
+
+(define-syntax test-syntax-error
+  (syntax-rules ()
+    ((_) (syntax-error "invalid use of test-syntax-error"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; test-group representation
+
+;; (name (prop value) ...)
+(define (make-test-group name . o)
+  (let ((parent (and (pair? o) (car o)))
+        (group (list name (cons 'start-time (current-second)))))
+    (test-group-set! group 'parent parent)
+    (test-group-set! group 'verbose
+                     (if parent
+                         (test-group-ref parent 'verbose)
+                         (current-test-verbosity)))
+    (test-group-set! group 'level
+                     (if parent
+                         (+ 1 (test-group-ref parent 'level 0))
+                         0))
+    (test-group-set!
+     group
+     'skip-group?
+     (or (and parent (test-group-ref parent 'skip-group?))
+         (not (every (lambda (f) (f group)) (current-test-group-filters)))))
+    group))
+
+(define test-group-name car)
+
+(define (test-group-ref group field . o)
+  (if group
+      (apply assq-ref (cdr group) field o)
+      (and (pair? o) (car o))))
+
+(define (test-group-set! group field value)
+  (cond
+   ((assq field (cdr group))
+    => (lambda (x) (set-cdr! x value)))
+   (else (set-cdr! group (cons (cons field value) (cdr group))))))
+
+(define (test-group-inc! group field . o)
+  (let ((amount (if (pair? o) (car o) 1)))
+    (cond
+     ((assq field (cdr group))
+      => (lambda (x) (set-cdr! x (+ amount (cdr x)))))
+     (else (set-cdr! group (cons (cons field amount) (cdr group)))))))
+
+(define (test-group-push! group field value)
+  (cond
+   ((assq field (cdr group))
+    => (lambda (x) (set-cdr! x (cons value (cdr x)))))
+   (else (set-cdr! group (cons (cons field (list value)) (cdr group))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utilities
+
+(define (assq-ref ls key . o)
+  (cond ((assq key ls) => cdr)
+        ((pair? o) (car o))
+        (else #f)))
+
+(define (approx-equal? a b epsilon)
+  (cond
+   ((> (abs a) (abs b))
+    (approx-equal? b a epsilon))
+   ((zero? a)
+    (< (abs b) epsilon))
+   (else
+    (< (abs (/ (- a b) b)) epsilon))))
+
+(define (call-with-output-string proc)
+  (let ((out (open-output-string)))
+    (proc out)
+    (get-output-string out)))
+
+;; partial pretty printing to abbreviate `quote' forms and the like
+(define (write-to-string x)
+  (call-with-output-string
+    (lambda (out)
+      (let wr ((x x))
+        (if (pair? x)
+            (cond
+             ((and (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))
+                   (assq (car x)
+                         '((quote . "'") (quasiquote . "`")
+                           (unquote . ",") (unquote-splicing . ",@"))))
+              => (lambda (s) (display (cdr s) out) (wr (cadr x))))
+             (else
+              (display "(" out)
+              (wr (car x))
+              (let lp ((ls (cdr x)))
+                (cond ((pair? ls)
+                       (display " " out)
+                       (wr (car ls))
+                       (lp (cdr ls)))
+                      ((not (null? ls))
+                       (display " . " out)
+                       (write ls out))))
+              (display ")" out)))
+            (write x out))))))
+
+(define (display-to-string x)
+  (if (string? x) x (call-with-output-string (lambda (out) (display x out)))))
+
+;; if we need to truncate, try first dropping let's to get at the
+;; heart of the expression
+(define (truncate-source x width . o)
+  (let* ((str (write-to-string x))
+         (len (string-length str)))
+    (cond
+     ((<= len width)
+      str)
+     ((and (pair? x) (eq? 'let (car x)))
+      (if (and (pair? o) (car o))
+          (truncate-source (car (reverse x)) width #t)
+          (string-append "..."
+                         (truncate-source (car (reverse x)) (- width 3) #t))))
+     ((and (pair? x) (eq? 'call-with-current-continuation (car x)))
+      (truncate-source (cons 'call/cc (cdr x)) width (and (pair? o) (car o))))
+     ((and (pair? x) (eq? 'call-with-values (car x)))
+      (string-append
+       "..."
+       (truncate-source (if (and (pair? (cadr x)) (eq? 'lambda (car (cadr x))))
+                            (car (reverse (cadr x)))
+                            (cadr x))
+                        (- width 3)
+                        #t)))
+     (else
+      (string-append
+       (substring str 0 (min (max 0 (- width 3)) (string-length str)))
+       "...")))))
+
+(define (test-get-name! info)
+  (or
+   (assq-ref info 'name)
+   (assq-ref info 'gen-name)
+   (let ((name
+          (cond
+           ((assq 'source info)
+            => (lambda (src)
+                 (truncate-source (cdr src) (- (current-column-width) 12))))
+           ((current-test-group)
+            => (lambda (g)
+                 (display "no source in: " (current-error-port))
+                 (write info (current-error-port))
+                 (display "\n" (current-error-port))
+                 (string-append
+                  "test-"
+                  (number->string (test-group-ref g 'count 0)))))
+           (else ""))))
+     (if (pair? info)
+         (set-cdr! info (cons (cons 'gen-name name) (cdr info))))
+     name)))
+
+(define (test-print-name info . indent)
+  (let ((width (- (current-column-width)
+                  (or (and (pair? indent) (car indent)) 0)))
+        (name (test-get-name! info)))
+    (display name)
+    (display " ")
+    (let ((diff (- width 9 (string-length name))))
+      (cond
+       ((positive? diff)
+        (display (make-string diff #\.)))))
+    (display " ")
+    (flush-output-port)))
+
+(define (test-group-indent-width group)
+  (let ((level (max 0 (+ 1 (- (test-group-ref group 'level 0)
+                              (test-first-indentation))))))
+    (* 4 (min level (test-max-indentation)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (test-expand-info info)
+  (let ((expr (assq-ref info 'source)))
+    (if (and (pair? expr)
+             (pair-source expr)
+             (not (assq-ref info 'line-number)))
+        `((file-name . ,(car (pair-source expr)))
+          (line-number . ,(cdr (pair-source expr)))
+          ,@info)
+        info)))
+
+(define (test-run expect expr info)
+  (let ((info (test-expand-info info)))
+    (if (and (cond ((current-test-group)
+                    => (lambda (g) (not (test-group-ref g 'skip-group?))))
+                   (else #t))
+             (every (lambda (f) (f info)) (current-test-filters)))
+        ((current-test-applier) expect expr info)
+        ((current-test-skipper) info))))
+
+(define (test-default-applier expect expr info)
+  (let* ((group (current-test-group))
+         (indent (and group (test-group-indent-width group))))
+    (cond
+     ((test-group-ref group 'verbose)
+      (if (and indent (positive? indent))
+          (display (make-string indent #\space)))
+      (test-print-name info indent)))
+    (let ((expect-val
+           (guard
+               (exn
+                (else
+                 (warning "bad expect value")
+                 (print-exception exn (current-error-port))
+                 #f))
+             (expect))))
+      (guard
+          (exn
+           (else
+            ((current-test-handler)
+             (if (assq-ref info 'expect-error) 'PASS 'ERROR)
+             (append `((exception . ,exn)) info))))
+        (let ((res (expr)))
+          (let ((status
+                 (if (and (not (assq-ref info 'expect-error))
+                          (if (assq-ref info 'assertion)
+                              res
+                              ((current-test-comparator) expect-val res)))
+                     'PASS
+                     'FAIL))
+                (info `((result . ,res) (expected . ,expect-val) ,@info)))
+            ((current-test-handler) status info)))))))
+
+(define (test-default-skipper info)
+  ((current-test-handler) 'SKIP info))
+
+(define (test-status-color status)
+  (case status
+    ((ERROR) (lambda (x) (underline (red x))))
+    ((FAIL) red)
+    ((SKIP) yellow)
+    (else (lambda (x) x))))
+
+(define (test-status-message status)
+  ((test-status-color status) status))
+
+(define (test-status-code status)
+  ((test-status-color status)
+   (case status
+     ((ERROR) "!")
+     ((FAIL) "x")
+     ((SKIP) "-")
+     (else "."))))
+
+(define (test-print-explanation indent status info)
+  (cond
+   ((eq? status 'ERROR)
+    (display indent)
+    (cond ((assq 'exception info)
+           => (lambda (e)
+                (print-exception (cdr e) (current-output-port))))))
+   ((and (eq? status 'FAIL) (assq-ref info 'assertion))
+    (display indent)
+    (display "assertion failed\n"))
+   ((and (eq? status 'FAIL) (assq-ref info 'expect-error))
+    (display indent)
+    (display "expected an error but got ")
+    (write (assq-ref info 'result)) (newline))
+   ((eq? status 'FAIL)
+    (display indent)
+    (display "expected ") (write (assq-ref info 'expected))
+    (display " but got ") (write (assq-ref info 'result)) (newline)))
+  ;; print variables
+  (cond
+   ((and (memq status '(FAIL ERROR)) (assq-ref info 'var-names))
+    => (lambda (names)
+         (let ((values (assq-ref info 'var-values)))
+           (if (and (pair? names)
+                    (pair? values)
+                    (= (length names) (length values)))
+               (let ((indent2
+                      (string-append indent (make-string 2 #\space))))
+                 (for-each
+                  (lambda (name value)
+                    (display indent2) (write name) (display ": ")
+                    (write value) (newline))
+                  names values))))))))
+
+(define (test-print-source indent status info)
+  (case status
+    ((FAIL ERROR)
+     (cond
+      ((assq-ref info 'line-number)
+       => (lambda (line)
+            (display "    on line ")
+            (write line)
+            (cond ((assq-ref info 'file-name)
+                   => (lambda (file) (display " of file ") (write file))))
+            (newline))))
+     (cond
+      ((assq-ref info 'source)
+       => (lambda (s)
+            (cond
+             ((or (assq-ref info 'name)
+                  (> (string-length (write-to-string s))
+                     (current-column-width)))
+              (display (write-to-string s))
+              (newline))))))
+     (cond
+      ((assq-ref info 'values)
+       => (lambda (v)
+            (for-each
+             (lambda (v)
+               (display "    ") (display (car v))
+               (display ": ") (write (cdr v)) (newline))
+             v)))))))
+
+(define (test-print-failure indent status info)
+  ;; display status explanation
+  (test-print-explanation indent status info)
+  ;; display line, source and values info
+  (test-print-source indent status info))
+
+(define (test-print-header-line str . indent)
+  (let* ((header (string-append
+                  (make-string (if (pair? indent) (car indent) 0) #\space)
+                  "-- " str " "))
+         (len (string-length header)))
+    (display (bold header))
+    (display (make-string (max 0 (- (current-column-width) len)) #\-))
+    (newline)))
+
+(define (test-default-handler status info)
+  (define indent
+    (make-string
+     (+ 4 (cond ((current-test-group)
+                 => (lambda (group) (or (test-group-indent-width group) 0)))
+                (else 0)))
+     #\space))
+  ;; update group info
+  (cond
+   ((current-test-group)
+    => (lambda (group)
+         (if (not (eq? 'SKIP status))
+             (test-group-inc! group 'count))
+         (test-group-inc! group status)
+         ;; maybe wrap long status lines
+         (let ((width (max (- (current-column-width)
+                              (or (test-group-indent-width group) 0))
+                           4))
+               (column
+                (+ (string-length (or (test-group-name group) ""))
+                   (or (test-group-ref group 'count) 0)
+                   1)))
+           (if (and (zero? (modulo column width))
+                    (not (test-group-ref group 'verbose)))
+               (display (string-append "\n" (string-copy indent 4))))))))
+  ;; update global failure count for exit status
+  (cond
+   ((or (eq? status 'FAIL) (eq? status 'ERROR))
+    (test-failure-count (+ 1 (test-failure-count)))))
+  (cond
+   ((eq? status 'SKIP))
+   ((test-group-ref (current-test-group) 'verbose)
+    ;; display status
+    (display "[")
+    (if (not (eq? status 'ERROR)) (display " ")) ; pad
+    (display (test-status-message status))
+    (display "]")
+    (newline)
+    (test-print-failure indent status info))
+   (else
+    (display (test-status-code status))
+    (cond
+     ((and (memq status '(FAIL ERROR)) (current-test-group))
+      => (lambda (group)
+           (test-group-push! group 'failures (list indent status info)))))
+    (cond ((current-test-group)
+           => (lambda (group) (test-group-set! group 'trailing #t))))))
+  (flush-output-port)
+  status)
+
+(define (test-default-group-reporter group)
+  (define (plural word n)
+    (if (= n 1) word (string-append word "s")))
+  (define (percent n d)
+    (string-append " (" (number->string (/ (round (* 1000.0 (/ n d))) 10))
+                   "%)"))
+  (let* ((end-time (current-second))
+         (start-time (test-group-ref group 'start-time))
+         (duration (- end-time start-time))
+         (base-count (or (test-group-ref group 'count) 0))
+         (base-pass (or (test-group-ref group 'PASS) 0))
+         (base-fail (or (test-group-ref group 'FAIL) 0))
+         (base-err (or (test-group-ref group 'ERROR) 0))
+         (skip (or (test-group-ref group 'SKIP) 0))
+         (pass (+ base-pass (or (test-group-ref group 'total-pass) 0)))
+         (fail (+ base-fail (or (test-group-ref group 'total-fail) 0)))
+         (err (+ base-err (or (test-group-ref group 'total-error) 0)))
+         (count (+ pass fail err))
+         (subgroups-count (or (test-group-ref group 'subgroups-count) 0))
+         (subgroups-pass (or (test-group-ref group 'subgroups-pass) 0))
+         (indent (make-string (or (test-group-indent-width group) 0) #\space)))
+    (if (and (not (test-group-ref group 'verbose))
+             (test-group-ref group 'trailing))
+        (newline))
+    (cond
+     ((or (positive? count) (positive? subgroups-count))
+      (if (not (= base-count (+ base-pass base-fail base-err)))
+          (warning "inconsistent count:"
+                   base-count base-pass base-fail base-err))
+      (cond
+       ((positive? count)
+        (display indent)
+        (display
+         ((if (= pass count) green (lambda (x) x))
+          (string-append
+           (number->string pass) " out of " (number->string count)
+           (percent pass count))))
+        (display
+         (string-append
+          (plural " test" pass) " passed in "
+          (number->string duration) " seconds"
+          (cond
+           ((zero? skip) "")
+           (else (string-append " (" (number->string skip)
+                                (plural " test" skip) " skipped)")))
+          ".\n"))))
+      (cond ((positive? fail)
+             (display indent)
+             (display
+              (red
+               (string-append
+                (number->string fail) (plural " failure" fail)
+                (percent fail count) ".\n")))))
+      (cond ((positive? err)
+             (display indent)
+             (display
+              ((lambda (x) (underline (red x)))
+               (string-append
+                (number->string err) (plural " error" err)
+                (percent err count) ".\n")))))
+      (cond
+       ((not (test-group-ref group 'verbose))
+        (for-each
+         (lambda (failure)
+           (display indent)
+           (display (red
+                     (string-append (display-to-string (cadr failure)) ": ")))
+           (display (test-get-name! (car (cddr failure))))
+           (newline)
+           (apply test-print-failure failure))
+         (reverse (or (test-group-ref group 'failures) '())))))
+      (cond
+       ((positive? subgroups-count)
+        (display indent)
+        (display
+         ((if (= subgroups-pass subgroups-count)
+              green (lambda (x) x))
+          (string-append
+           (number->string subgroups-pass) " out of "
+           (number->string subgroups-count)
+           (percent subgroups-pass subgroups-count))))
+        (display (plural " subgroup" subgroups-pass))
+        (display " passed.\n")))))
+    (cond
+     ((test-group-ref group 'verbose)
+      (test-print-header-line
+       (string-append "done testing " (or (test-group-name group) ""))
+       (or (test-group-indent-width group) 0))
+      (newline)))
+    (cond
+     ((test-group-ref group 'parent)
+      => (lambda (parent)
+           (test-group-set! parent 'trailing #f)
+           (test-group-inc! parent 'total-pass pass)
+           (test-group-inc! parent 'total-fail fail)
+           (test-group-inc! parent 'total-error err))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (test-equal? expect res)
+  (or (equal? expect res)
+      (if (real? expect)
+          (and (inexact? expect)
+               (real? res)
+               (inexact? res)
+               (approx-equal? expect res (current-test-epsilon)))
+          (and (complex? res)
+               (complex? expect)
+               (test-equal? (real-part expect) (real-part res))
+               (test-equal? (imag-part expect) (imag-part res))))))
+
+;;> Begin testing a new group until the closing \scheme{(test-end)}.
+
+(define (test-begin . o)
+  (let* ((name (if (pair? o) (car o) ""))
+         (parent (current-test-group))
+         (group (make-test-group name parent)))
+    (cond
+     ((and parent
+           ;; (zero? (test-group-ref parent 'count 0))
+           (zero? (test-group-ref parent 'subgroups-count 0)))
+      (newline)))
+    (cond
+     ((test-group-ref group 'verbose)
+      (test-print-header-line
+       (string-append "testing " name)
+       (or (test-group-indent-width group) 0)))
+     (else
+      (display
+       (make-string (or (test-group-indent-width group) 0)
+                    #\space))
+      (display (bold (string-append name ": ")))))
+    (current-test-group group)))
+
+;;> Ends testing group introduced with \scheme{(test-begin)}, and
+;;> summarizes the results.
+
+(define (test-end . o)
+  (cond
+   ((current-test-group)
+    => (lambda (group)
+         (if (and (pair? o) (not (equal? (car o) (test-group-name group))))
+             (warning "mismatched test-end:" (car o) (test-group-name group)))
+         (let ((parent (test-group-ref group 'parent)))
+           (cond
+            ((not (test-group-ref group 'skip-group?))
+             ;; only report if there's something to say
+             ((current-test-group-reporter) group)
+             (cond
+              (parent
+               (test-group-inc! parent 'subgroups-count)
+               (cond
+                ((and (zero? (test-group-ref group 'FAIL 0))
+                      (zero? (test-group-ref group 'ERROR 0))
+                      (= (test-group-ref group 'subgroups-pass 0)
+                         (test-group-ref group 'subgroups-count 0)))
+                 (test-group-inc! parent 'subgroups-pass)))))))
+           (current-test-group parent)
+           group)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; parameters
+
+(define current-test-group (make-parameter #f))
+(define current-test-verbosity
+  (make-parameter
+   (cond ((get-environment-variable "TEST_VERBOSE")
+          => (lambda (s) (not (member s "" "0"))))
+         (else #f))))
+(define current-test-epsilon (make-parameter 1e-5))
+(define current-test-comparator (make-parameter test-equal?))
+(define current-test-applier (make-parameter test-default-applier))
+(define current-test-handler (make-parameter test-default-handler))
+(define current-test-skipper (make-parameter test-default-skipper))
+(define current-test-group-reporter
+  (make-parameter test-default-group-reporter))
+(define test-failure-count (make-parameter 0))
+
+(define test-first-indentation
+  (make-parameter
+   (or (cond ((get-environment-variable "TEST_FIRST_INDENTATION")
+              => string->number)
+             (else #f))
+       1)))
+
+(define test-max-indentation
+  (make-parameter
+   (or (cond ((get-environment-variable "TEST_MAX_INDENTATION")
+              => string->number)
+             (else #f))
+       5)))
+
+(define (string->info-matcher str)
+  (lambda (info)
+    (cond ((test-get-name! info)
+           => (lambda (n) (string-search str n)))
+          (else #f))))
+
+(define (string->group-matcher str)
+  (lambda (group) (string-search str (car group))))
+
+(define (getenv-filter-list proc name . o)
+  (cond
+   ((get-environment-variable name)
+    => (lambda (s)
+         (guard
+             (exn
+              (else
+               (warning
+                (string-append "invalid filter '" s
+                               "' from environment variable: " name))
+               (print-exception exn (current-error-port))
+               '()))
+           (let ((f (proc s)))
+             (list (if (and (pair? o) (car o))
+                       (lambda (x) (not (f x)))
+                       f))))))
+   (else '())))
+
+(define current-test-filters
+  (make-parameter
+   (append (getenv-filter-list string->info-matcher "TEST_FILTER")
+           (getenv-filter-list string->info-matcher "TEST_REMOVE" #t))))
+
+(define current-test-group-filters
+  (make-parameter
+   (append (getenv-filter-list string->group-matcher "TEST_GROUP_FILTER")
+           (getenv-filter-list string->group-matcher "TEST_GROUP_REMOVE" #t))))
+
+(define current-column-width
+  (make-parameter
+   (or (cond ((get-environment-variable "TEST_COLUMN_WIDTH")
+              => string->number)
+             (else #f))
+       78)))
diff --git a/lib/chibi/test.sld b/lib/chibi/test.sld
new file mode 100644
index 00000000..61f586cc
--- /dev/null
+++ b/lib/chibi/test.sld
@@ -0,0 +1,27 @@
+
+(define-library (chibi test)
+  (export
+   test test-equal test-error test-assert test-not test-values
+   test-group current-test-group
+   test-begin test-end test-syntax-error test-propagate-info
+   test-vars test-run test-exit
+   current-test-verbosity current-test-epsilon current-test-comparator
+   current-test-applier current-test-handler current-test-skipper
+   current-test-group-reporter test-failure-count
+   current-test-epsilon current-test-comparator)
+  (import (scheme write)
+          (scheme complex)
+          (scheme process-context)
+          (scheme time)
+          (chibi term ansi))
+  (cond-expand
+   (chibi
+    (import (except (scheme base) guard)
+            (rename (only (chibi) pair-source print-exception protect)
+                    (protect guard))))
+   (else
+    (import (scheme base))
+    (begin
+      (define (pair-source x) #f)
+      (define print-exception write))))
+  (include "test.scm"))
diff --git a/lib/chibi/time.sld b/lib/chibi/time.sld
new file mode 100644
index 00000000..df1e0a3e
--- /dev/null
+++ b/lib/chibi/time.sld
@@ -0,0 +1,18 @@
+
+(define-library (chibi time)
+  (export current-seconds get-time-of-day set-time-of-day!
+          seconds->time seconds->string time->seconds time->string
+          make-timeval make-tm timeval-seconds timeval-microseconds
+          timezone-offset timezone-dst-time
+          time-second time-minute time-hour time-day time-month time-year
+          time-day-of-week time-day-of-year time-dst? time-timezone-name
+          time-offset
+          tm? timeval? timezone?)
+  (cond-expand
+   ((or bsd linux)
+    (export rusage? resource-usage-time resource-usage-system-time
+            resource-usage-max-rss resource-usage/self
+            resource-usage/children get-resource-usage))
+   (else))
+  (import (chibi))
+  (include-shared "time"))
diff --git a/lib/chibi/time.stub b/lib/chibi/time.stub
new file mode 100644
index 00000000..abba475d
--- /dev/null
+++ b/lib/chibi/time.stub
@@ -0,0 +1,102 @@
+
+(cond-expand
+ (plan9)
+ (else
+  (c-system-include "time.h")
+  (c-system-include "sys/time.h")))
+
+(define-c-struct tm
+  predicate: tm?
+  constructor: (make-tm tm_sec tm_min tm_hour
+                tm_mday tm_mon tm_year tm_isdst)
+  (int     tm_sec    time-second)
+  (int     tm_min    time-minute)
+  (int     tm_hour   time-hour)
+  (int     tm_mday   time-day)
+  (int     tm_mon    time-month)
+  (int     tm_year   time-year)
+  (int     tm_wday   time-day-of-week)
+  (int     tm_yday   time-day-of-year)
+  (int     tm_isdst  time-dst?)
+  (string  tm_zone   time-timezone-name)
+  (int     tm_gmtoff time-offset))
+
+;;> Accessors for the \scheme{tm} struct.
+;;/
+
+(define-c-struct timeval
+  predicate: timeval?
+  constructor: (make-timeval tv_sec tv_usec)
+  (time_t  tv_sec          timeval-seconds)
+  (int     tv_usec         timeval-microseconds))
+
+;;> Accessors for the \scheme{timeval} struct.
+;;/
+
+(define-c-struct timezone
+  predicate: timezone?
+  (int     tz_minuteswest  timezone-offset)
+  (int     tz_dsttime      timezone-dst-time))
+
+;;> Accessors for the \scheme{timezone} struct.
+;;/
+
+;;> Returns the current time as an integer number
+;;> of seconds since an arbitrary epoch.
+
+(define-c time_t (current-seconds "time") ((value NULL)))
+
+;;> Returns the current time as a list of a timeval struct
+;;> and a timezone.
+
+(define-c errno (get-time-of-day "gettimeofday")
+  ((result timeval) (result timezone)))
+
+;;> Set the current time from a timeval struct and
+;;> and optional timezone.
+
+(define-c errno (set-time-of-day! "settimeofday")
+  (timeval (maybe-null default NULL timezone)))
+
+;;> Convert an integer number of epoch seconds to a broken-down tm struct.
+
+(define-c non-null-pointer (seconds->time "localtime_r")
+  ((pointer time_t) (result tm)))
+
+;;> Convert a tm struct to an integer number of seconds.
+
+(define-c time_t (time->seconds "mktime")
+  (tm))
+
+;;> Format a datetime string from an integer number of epoch seconds.
+
+(define-c non-null-string (seconds->string "ctime_r")
+  ((pointer time_t) (result (array char 64))))
+
+;;> Format a datetime string from a tm struct.
+
+(define-c non-null-string (time->string "asctime_r")
+  (tm (result (array char 64))))
+
+(cond-expand
+ ((or bsd linux)
+  (c-system-include "sys/resource.h")
+  (define-c-struct rusage
+    predicate: rusage?
+    ((struct timeval) ru_utime  resource-usage-time)
+    ((struct timeval) ru_stime  resource-usage-system-time)
+    (long             ru_maxrss resource-usage-max-rss))
+
+;;> Accessors for the \scheme{rusage} struct.
+;;/
+
+  (define-c-const int (resource-usage/self RUSAGE_SELF))
+  (define-c-const int (resource-usage/children RUSAGE_CHILDREN))
+
+;;> Returns a struct describing the resources used by the current
+;;> process.
+
+  (define-c errno (get-resource-usage "getrusage")
+    ((default RUSAGE_SELF int) (result rusage))))
+ (else
+  ))
diff --git a/lib/chibi/trace.scm b/lib/chibi/trace.scm
new file mode 100644
index 00000000..6b0c30ff
--- /dev/null
+++ b/lib/chibi/trace.scm
@@ -0,0 +1,78 @@
+
+;; Table mapping traced procedures to their original untraced values.
+(define all-traces
+  (make-parameter (make-hash-table eq?)))
+
+;; The current number of traced procedure frames on the stack.
+(define active-trace-depth
+  (make-parameter 0))
+
+(define (show-trace cell args)
+  (let ((out (current-error-port)))
+    (do ((i 0 (+ i 1)))
+        ((>= i (active-trace-depth)))
+      (display "| " out))
+    (display "> " out)
+    (write/ss (cons (car cell) args) out)
+    (newline out)))
+
+(define (show-trace-result cell args res)
+  (let ((out (current-error-port)))
+    (do ((i 0 (+ i 1)))
+        ((>= i (active-trace-depth)))
+      (display "| " out))
+    (write/ss res out)
+    (newline out)))
+
+(define (make-tracer cell)
+  (let ((proc (cdr cell)))
+    (lambda args
+      (show-trace cell args)
+      (active-trace-depth (+ (active-trace-depth) 1))
+      (let ((res (apply proc args)))
+        (active-trace-depth (- (active-trace-depth) 1))
+        (show-trace-result cell args res)
+        res))))
+
+(define-syntax trace
+  (syntax-rules ()
+    ((trace id)
+     (trace-cell (env-cell (interaction-environment) 'id)))))
+
+(define-syntax untrace
+  (syntax-rules ()
+    ((untrace id)
+     (untrace-cell (env-cell (interaction-environment) 'id)))))
+
+(define (warn . args)
+  (let ((out (current-error-port)))
+    (display "WARNING: " out)
+    (for-each (lambda (x) (display x out)) args)
+    (newline out)))
+
+(define (trace-cell cell)
+  (let ((tab (all-traces)))
+    (cond
+     ((not (pair? cell))
+      (warn "No such binding."))
+     ((hash-table-exists? tab cell)
+      (warn "Procedure already being traced: " (car cell)))
+     (else
+      (hash-table-set! tab cell (cdr cell))
+      (set-cdr! cell (make-tracer cell))))))
+
+(define (untrace-cell cell)
+  (let ((tab (all-traces)))
+    (cond
+     ((not (pair? cell))
+      (warn "No such binding."))
+     ((not (hash-table-exists? tab cell))
+      (warn "Procedure not being traced: " (car cell)))
+     (else
+      (let ((proc (hash-table-ref tab cell)))
+        (hash-table-delete! tab cell)
+        (set-cdr! cell proc))))))
+
+(define (untrace-all)
+  (hash-table-walk (all-traces) (lambda (cell proc) (set-cdr! cell proc)))
+  (all-traces (make-hash-table eq?)))
diff --git a/lib/chibi/trace.sld b/lib/chibi/trace.sld
new file mode 100644
index 00000000..ecb32a7d
--- /dev/null
+++ b/lib/chibi/trace.sld
@@ -0,0 +1,18 @@
+
+;;> \subsubsubsection{(trace proc)}
+
+;;> Write a trace of all calls to the procedure \var{proc} to
+;;> \scheme{(current-error-port)}.
+
+;;> \subsubsubsection{(untrace proc)}
+
+;;> Remove any active traces on the procedure \var{proc}.
+
+;;> \subsubsubsection{(untrace-all)}
+
+;;> Remove all active procedure traces.
+
+(define-library (chibi trace)
+  (export trace untrace untrace-all trace-cell untrace-cell)
+  (import (chibi) (chibi ast) (srfi 38) (srfi 39) (srfi 69))
+  (include "trace.scm"))
diff --git a/lib/chibi/type-inference.scm b/lib/chibi/type-inference.scm
new file mode 100644
index 00000000..407f456e
--- /dev/null
+++ b/lib/chibi/type-inference.scm
@@ -0,0 +1,340 @@
+;; Copyright (c) 2010-2011 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> General type-inference library.
+
+(define (typed? x)
+  (and (lambda? x)
+       (lambda-return-type x)))
+
+(define (union-type? a)
+  (and (pair? a) (equal? (car a) 'or)))
+
+(define (intersection-type? a)
+  (and (pair? a) (equal? (car a) 'and)))
+
+(define (unfinalized-type? a)
+  (and (pair? a)
+       (or (memq (car a) '(return-type param-type))
+           (and (memq (car a) '(and or))
+                (any unfinalized-type? (cdr a))))))
+
+(define (finalized-type? a)
+  (not (unfinalized-type? a)))
+
+(define (numeric-type? a)
+  (or (eq? a Number) (eq? a Flonum) (eq? a Integer)))
+
+(define (procedure-type? a)
+  (or (eq? a Opcode)
+      (eq? a Procedure)
+      (and (pair? a) (eq? (car a) 'lambda))))
+
+(define (type=? a b)
+  (cond
+   ((and (pair? a) (eq? (car a) 'param-type))
+    (and (pair? b) (eq? (car b) 'param-type)
+         (eq? (cadr a) (cadr b))
+         (eq? (car (cddr a)) (car (cddr b)))))
+   ((and (pair? a) (eq? (car a) 'return-type))
+    (and (pair? b) (eq? (car b) 'return-type)
+         (eq? (cadr a) (cadr b))))
+   (else
+    (equal? a b))))
+
+(define (type-subset? a b)
+  (or (type=? a b)
+      (eq? a Object)
+      (eq? b Object)
+      (and (numeric-type? a) (numeric-type? b))
+      (and (procedure-type? a) (procedure-type? b))
+      (if (union-type? a)
+          (if (union-type? b)
+              (lset<= type=? (cdr a) (cdr b))
+              (member b (cdr a) type=?))
+          (and (union-type? b) (member a (cdr b) type=?)))))
+
+(define (type-not a)
+  (match a
+    (('not b) b)
+    (else (list 'not a))))
+
+;; XXXX check for type hierarchies
+(define (type-union a b)
+  (cond
+   ((type=? a b) a)
+   ((or (eq? a Object) (eq? b Object)) Object)
+   ((union-type? a)
+    (if (union-type? b)
+        (cons (car a) (lset-union type=? (cdr a) (cdr b)))
+        (cons (car a) (lset-adjoin type=? (cdr a) b))))
+   (else (list 'or a b))))
+
+;; XXXX check for conflicts
+(define (type-intersection a b)
+  (cond
+   ((type=? a b) a)
+   ((or (eq? a Object) (unfinalized-type? a)) b)
+   ((or (eq? b Object) (unfinalized-type? b)) a)
+   ((intersection-type? a)
+    (if (intersection-type? b)
+        (lset-intersection type=? (cdr a) (cdr b))
+        (cons (car a) (lset-adjoin type=? (cdr a) b))))
+   (else (list 'and a b))))
+
+(define (lambda-param-types-initialize! f)
+  (lambda-param-types-set! f (map (lambda (p) (list 'param-type f p))
+                                  (lambda-params f))))
+
+(define (lambda-param-type-memq f x)
+  (let lp ((p (lambda-params f))
+           (t (lambda-param-types f)))
+    (and (pair? p)
+         (pair? t)
+         (if (eq? x (car p))
+             t
+             (lp (cdr p) (cdr t))))))
+
+(define (lambda-param-type-ref f x)
+  (cond ((lambda-param-type-memq f x) => car)
+        (else #f)))
+
+(define (lambda-param-type-set! f x y)
+  (if (not (pair? (lambda-param-types f)))
+      (lambda-param-types-initialize! f))
+  (cond ((lambda-param-type-memq f x)
+         => (lambda (cell) (set-car! cell y)))))
+
+(define (type-assert x true?)
+  (match x
+    (((? opcode? f) ($ Ref name (_ . (? lambda? g))))
+     (cond
+      ((eq? (opcode-class f) (opcode-class pair?))
+       (let ((t (type-intersection
+                 (lambda-param-type-ref g name)
+                 (if true? (opcode-data f) (type-not (opcode-data f))))))
+         (lambda-param-type-set! g name t)))))
+    ((($ Ref _ ('not . (? procedure? f))) expr)
+     (if (eq? f not)
+         (type-assert expr (not true?))))
+    (else #f)))
+
+(define (type-analyze-expr x)
+  (match x
+    (($ Lam name params body defs)
+     (cond
+      ((not (lambda-return-type x))
+       (lambda-return-type-set! x (list 'return-type x))
+       (lambda-param-types-initialize! x)
+       (let ((ret-type (type-analyze-expr body)))
+         (lambda-return-type-set! x ret-type)
+         (cons 'lambda (cons ret-type (lambda-param-types x)))))))
+    (($ Set ref value)
+     (type-analyze-expr value)
+     (if #f #f))
+    (($ Ref name (value . loc))
+     (cond
+      ((lambda? loc) (lambda-param-type-ref loc name))
+      ((procedure? loc)
+       (let ((sig (procedure-signature loc)))
+         (if (and (pair? sig) (car sig))
+             (cons 'lambda sig)
+             (list 'return-type (procedure-analysis loc)))))
+      (else Object)))
+    (($ Cnd test pass fail)
+     (let ((test-type (type-analyze-expr test))
+           (pass-type (type-analyze-expr pass))
+           (fail-type (type-analyze-expr fail)))
+       (cond
+        ((equal? '(error) pass-type)
+         (type-assert test #f)
+         fail-type)
+        ((equal? '(error) fail-type)
+         (type-assert test #t)
+         pass-type)
+        (else
+         (type-union pass-type fail-type)))))
+    (($ Seq ls)
+     (let lp ((ls ls))
+       (cond ((null? (cdr ls))
+              (type-analyze-expr (car ls)))
+             (else
+              (type-analyze-expr (car ls))
+              (lp (cdr ls))))))
+    (((? opcode? f) args ...)
+     (let lp ((p (opcode-param-types f))
+              (a args))
+       (cond
+        ((pair? a)
+         (cond
+          ((or (pair? p) (opcode-variadic? f))
+           (let ((p-type
+                  (if (pair? p)
+                      (car p)
+                      (opcode-param-type f (opcode-num-params f)))))
+             (match (car a)
+               (($ Ref name (_ . (and g ($ Lam))))
+                (let ((t (type-intersection (lambda-param-type-ref g name)
+                                            p-type)))
+                  (lambda-param-type-set! g name t)))
+               (else
+                (let ((t (type-analyze-expr (car a))))
+                  (cond
+                   ((and t p-type
+                         (finalized-type? t)
+                         (finalized-type? p-type)
+                         (not (type-subset? t p-type)))
+                    (display "WARNING: incompatible type: "
+                             (current-error-port))
+                    (write/ss (list x t p-type) (current-error-port))
+                    (newline (current-error-port))))
+                  t))))
+           (lp (and (pair? p) (cdr p)) (cdr a)))
+          (else
+           (for-each type-analyze-expr a))))))
+     (opcode-return-type f))
+    ((f args ...)
+     (let ((f-type (type-analyze-expr f)))
+       ;; XXXX apply f-type to params
+       (for-each type-analyze-expr args)
+       (cond
+        ((and (pair? f-type) (eq? (car f-type) 'lambda))
+         (cadr f-type))
+        ((and (pair? f-type) (memq (car f-type) '(return-type param-type)))
+         f-type)
+        (else
+         Object))))
+    (($ Lit value)
+     (type-of value))
+    (else
+     (type-of x))))
+
+(define (resolve-delayed-type x)
+  (let lp ((x x) (seen '()) (default Object))
+    (match x
+      (('return-type (? lambda? f))
+       (if (memq f seen)
+           default
+           (lp (lambda-return-type f) (cons f seen) default)))
+      (('param-type f p)
+       (if (member x seen)
+           default
+           (lp (lambda-param-type-ref f p) (cons x seen) default)))
+      (('or y ...)
+       (let ((z (find finalized-type? y)))
+         (if z
+             (let ((default (if (eq? default Object)
+                                (lp z seen default)
+                                (type-union (lp z seen default) default))))
+               (fold type-union
+                     default
+                     (map (lambda (y1) (lp y1 seen default)) (delete z y))))
+             (fold type-union default (map (lambda (y1) (lp y1 seen default)) y)))))
+      (('and y ...)
+       (fold type-intersection default (map (lambda (y1) (lp y1 seen default)) y)))
+      (('not y)
+       (list 'not (lp y seen default)))
+      (else
+       x))))
+
+(define (type-resolve-circularities x)
+  (match x
+    (($ Lam name params body defs)
+     (if (unfinalized-type? (lambda-return-type x))
+         (lambda-return-type-set! x (resolve-delayed-type
+                                     (lambda-return-type x))))
+     (for-each
+      (lambda (p t)
+        (if (unfinalized-type? t)
+            (lambda-param-type-set! x p (resolve-delayed-type t))))
+      params
+      (lambda-param-types x))
+     (type-resolve-circularities (lambda-body x)))
+    (($ Set ref value)
+     (type-resolve-circularities value))
+    (($ Cnd test pass fail)
+     (type-resolve-circularities test)
+     (type-resolve-circularities pass)
+     (type-resolve-circularities fail))
+    (($ Seq ls)
+     (for-each type-resolve-circularities ls))
+    ((app ...)
+     (for-each type-resolve-circularities app))
+    (else #f)))
+
+(define (type-analyze-module-body name ls)
+  (for-each type-analyze-expr ls)
+  (for-each type-resolve-circularities ls))
+
+;;> Analyze the types of all bindings in the module \var{name}.
+
+(define (type-analyze-module name)
+  (let* ((mod (analyze-module name))
+         (ls (and (vector? mod) (module-ast mod))))
+    (and ls
+         (let ((x (let lp ((ls ls)) ;; first lambda
+                    (and (pair? ls)
+                         (if (and (set? (car ls))
+                                  (lambda? (set-value (car ls))))
+                             (set-value (car ls))
+                             (lp (cdr ls)))))))
+           (if (and x (not (typed? x)))
+               (type-analyze-module-body name ls))
+           ls))))
+
+;;> Return the type signature for a given source
+;;> code expression.
+
+(define (type-analyze sexp . o)
+  (type-analyze-expr (apply analyze sexp o)))
+
+(define (opcode-param-types x)
+  (let lp ((n (- (opcode-num-params x) 1)) (res '()))
+    (if (< n 0)
+        res
+        (lp (- n 1) (cons (opcode-param-type x n) res)))))
+
+(define (opcode-type x)
+  (cons 'lambda (cons (opcode-return-type x) (opcode-param-types x))))
+
+(define (lambda-type x)
+  (cons 'lambda (cons (lambda-return-type x) (lambda-param-types x))))
+
+;;> Return the type signature for the procedure \var{x} as
+;;> a list whose first element is the return type and whose
+;;> remaining arguments are the parameter types.
+
+(define (procedure-signature x . o)
+  (define (ast-sig x)
+    (cond
+     ((lambda? x)
+      (cons (lambda-return-type x)
+            (if (pair? (lambda-param-types x))
+                (lambda-param-types x)
+                (lambda-params x))))
+     ((seq? x) (ast-sig (last (seq-ls x))))
+     ((and (pair? x) (lambda? (car x))) (ast-sig (lambda-body (car x))))
+     ;; TODO: improve the type inference so this isn't needed
+     ((and (pair? x) (ref? (car x))
+           (pair? o) (apply procedure-analysis (ref-name (car x)) o))
+      => (lambda (lam)
+           (and (lambda? lam)
+                (or (lambda-return-type lam)
+                    (ast-sig (lambda-body lam))))))
+     (else #f)))
+  (cond
+   ((opcode? x)
+    (cdr (opcode-type x)))
+   ((macro? x)
+    (procedure-signature (macro-procedure x)))
+   (else
+    (let lp ((count 0))
+      (let ((lam (apply procedure-analysis x o)))
+        (cond
+         ((and lam (not (typed? lam)) (zero? count)
+               (containing-module x))
+          => (lambda (mod)
+               (and (type-analyze-module (car mod))
+                    (lp (+ count 1)))))
+         (else
+          (ast-sig lam))))))))
diff --git a/lib/chibi/type-inference.sld b/lib/chibi/type-inference.sld
new file mode 100644
index 00000000..a2fdb8d6
--- /dev/null
+++ b/lib/chibi/type-inference.sld
@@ -0,0 +1,8 @@
+
+(define-library (chibi type-inference)
+  (export type-analyze-module type-analyze procedure-signature
+          type=? type-subset?)
+  (import (chibi) (srfi 1) (srfi 38) (srfi 69)
+          (chibi modules) (chibi ast) (chibi match))
+  (include "type-inference.scm"))
+
diff --git a/lib/chibi/uri.scm b/lib/chibi/uri.scm
new file mode 100644
index 00000000..29d450cb
--- /dev/null
+++ b/lib/chibi/uri.scm
@@ -0,0 +1,341 @@
+;; Copyright (c) 2009-2013 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> Library for parsing and constructing URI objects.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; URI representation
+
+(define-record-type Uri
+  (%make-uri scheme user host port path query fragment)
+  uri?
+  (scheme uri-scheme)
+  (user uri-user)
+  (host uri-host)
+  (port uri-port)
+  (path uri-path)
+  (query uri-query)
+  (fragment uri-fragment))
+
+;;> Accessors for the URI type.
+;;/
+
+;;> \procedure{(make-uri scheme [user host port path query fragment])}
+
+(define (make-uri scheme . o)
+  (let* ((user (if (pair? o) (car o) #f))
+         (o (if (pair? o) (cdr o) '()))
+         (host (if (pair? o) (car o) #f))
+         (o (if (pair? o) (cdr o) '()))
+         (port (if (pair? o) (car o) #f))
+         (o (if (pair? o) (cdr o) '()))
+         (path (if (pair? o) (car o) #f))
+         (o (if (pair? o) (cdr o) '()))
+         (query (if (pair? o) (car o) #f))
+         (o (if (pair? o) (cdr o) '()))
+         (fragment (and (pair? o) (car o))))
+    (%make-uri scheme user host port path query fragment)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (uri-with-scheme u scheme)
+  (%make-uri scheme (uri-user u) (uri-host u) (uri-port u)
+             (uri-path u) (uri-query u) (uri-fragment u)))
+
+(define (uri-with-user u user)
+  (%make-uri (uri-scheme u) user (uri-host u) (uri-port u)
+             (uri-path u) (uri-query u) (uri-fragment u)))
+
+(define (uri-with-host u host)
+  (%make-uri (uri-scheme u) (uri-user u) host (uri-port u)
+             (uri-path u) (uri-query u) (uri-fragment u)))
+
+(define (uri-with-port u port)
+  (%make-uri (uri-scheme u) (uri-user u) (uri-host u) port
+             (uri-path u) (uri-query u) (uri-fragment u)))
+
+(define (uri-with-path u path)
+  (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u)
+             path (uri-query u) (uri-fragment u)))
+
+(define (uri-with-query u query)
+  (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u)
+             (uri-path u) query (uri-fragment u)))
+
+(define (uri-with-fragment u fragment)
+  (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u)
+             (uri-path u) (uri-query u) fragment))
+
+;;> Functional updaters - returns a new uri identical to \var{u}
+;;> with only the specified field changed.
+;;/
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; parsing - without :// we just split into scheme & path
+
+(define (char-uri-scheme-unsafe? ch)
+  (not (or (char-alphabetic? ch) (char-numeric? ch) (memv ch '(#\+ #\- #\.)))))
+
+;;> Parses a string with a default scheme and returns a new URI
+;;> object.  If the string does not begin with a scheme it is take to
+;;> be a simple path URI with the default scheme.  This is a
+;;> lightweight permissive parser.
+
+(define (string->path-uri scheme str . o)
+  (define decode? (and (pair? o) (car o)))
+  (define decode (if decode? uri-decode (lambda (x) x)))
+  (define decode-query
+    (if (and (pair? o) (pair? (cdr o)) (cadr o))
+        (if decode? (lambda (q) (uri-query->alist q #t)) uri-query->alist)
+        decode))
+  (if (uri? str)
+      str
+      (let* ((start (string-cursor-start str))
+             (end (string-cursor-end str))
+             (colon0 (string-find str #\:))
+             (colon
+              (if (string-cursor>=?
+                   (string-find str char-uri-scheme-unsafe? start colon0)
+                   colon0)
+                  colon0
+                  end)))
+        (if (string-cursor>=? colon end)
+            (and scheme
+                 (let* ((quest (string-find str #\?))
+                        (pound
+                         (string-find
+                          str
+                          #\#
+                          (if (string-cursor<? quest end) quest start))))
+                   (make-uri scheme #f #f #f
+                             (decode
+                              (substring-cursor
+                               str start (if (< quest end) quest pound)))
+                             (and (< quest end)
+                                  (decode-query
+                                   (substring-cursor str (+ quest 1) pound)))
+                             (and (< pound end)
+                                  (decode
+                                   (substring-cursor str (+ pound 1) end))))))
+            (let ((sc1 (+ colon 1))
+                  (scheme (string->symbol
+                           (string-downcase-ascii
+                            (substring-cursor str start colon)))))
+              (if (string-cursor>=? sc1 end)
+                  (make-uri scheme)
+                  (if (or (string-cursor>=? (+ sc1 1) end)
+                          (not
+                           (and (eqv? #\/ (string-cursor-ref str sc1))
+                                (eqv? #\/ (string-cursor-ref str (+ sc1 1))))))
+                      (make-uri scheme #f #f #f (substring-cursor str sc1 end))
+                      (if (string-cursor>=? (+ sc1 2) end)
+                          (make-uri scheme #f "")
+                          (let* ((sc2 (+ sc1 2))
+                                 (slash (string-find str #\/ sc2))
+                                 (at (string-find-right str #\@ sc2 slash))
+                                 (colon3
+                                  (string-find
+                                   str #\: (if (> at sc2) at sc2) slash))
+                                 (quest (string-find str #\? slash))
+                                 (pound
+                                  (string-find
+                                   str #\# (if (< quest end) quest slash))))
+                            (%make-uri
+                             scheme
+                             (and (> at sc2)
+                                  (decode (substring-cursor str sc2 at)))
+                             (decode
+                              (substring-cursor
+                               str
+                               (if (> at sc2) (+ at 1) sc2)
+                               (if (< colon3 slash) colon3 slash)))
+                             (and (< colon3 slash)
+                                  (string->number
+                                   (substring-cursor str (+ colon3 1) slash)))
+                             (and (< slash end)
+                                  (decode
+                                   (substring-cursor
+                                    str slash (if (< quest end) quest pound))))
+                             (and (< quest end)
+                                  (decode-query
+                                   (substring-cursor str (+ quest 1) pound)))
+                             (and (< pound end)
+                                  (decode
+                                   (substring-cursor str (+ pound 1) end)))
+                             ))))))))))
+
+;;> Parses a string and returns a new URI object.  If the string does
+;;> not have a scheme, returns false.
+
+(define (string->uri str . o)
+  (apply string->path-uri #f str o))
+
+;;> Convert a URI object to a string.  Returns #f if the uri has no scheme.
+
+(define (uri->string uri . o)
+  (define encode? (and (pair? o) (car o)))
+  (define encode (if encode? uri-encode (lambda (x) x)))
+  (if (string? uri)
+      uri
+      (let ((fragment (uri-fragment uri))
+            (query (uri-query uri))
+            (path (uri-path uri))
+            (port (uri-port uri))
+            (host (uri-host uri))
+            (user (uri-user uri)))
+        (string-append
+         (symbol->string (uri-scheme uri)) ":"
+         (if (or user host port) "//" "")
+         (if user (encode user) "") (if user "@" "")
+         (or host "")                   ; host shouldn't need encoding
+         (if port ":" "") (if port (number->string port) "")
+         (if path (encode path) "")
+         (if query "?" "")
+         (if (pair? query) (uri-alist->query query) (or query ""))
+         (if fragment "#" "") (if fragment (encode fragment) "")))))
+
+;;> Returns true iff the given URI string has a scheme.
+
+(define uri-has-scheme?
+  (let ((no-scheme (list 'no-scheme)))
+    (lambda (url)
+      (not (eq? no-scheme (uri-scheme (string->path-uri no-scheme url)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; query encoding and decoding
+
+(define (uri-safe-char? ch)
+  (or (char-alphabetic? ch)
+      (char-numeric? ch)
+      (case ch
+        ((#\- #\_ #\. #\! #\~ #\* #\' #\( #\)) #t)
+        (else #f))))
+
+(define (collect str from to res)
+  (if (>= from to)
+      res
+      (cons (substring-cursor str from to) res)))
+
+;;> \procedure{(uri-encode str [plus?])}
+
+;;> Return the URI encoded version of the string \var{str},
+;;> using hex escapes as needed and replacing spaces with "+"
+;;> iff the optional argument \var{plus?} is true.
+
+(define (uri-encode str . o)
+  (define (encode-1-space ch)
+    (if (eqv? ch #\space)
+        "+"
+        (encode-1-normal ch)))
+  (define (encode-1-normal ch)
+    (let* ((i (char->integer ch))
+           (hex (number->string i 16)))
+      (if (< i 16)
+          (string-append "%0" hex)
+          (string-append "%" hex))))
+  (let ((start 0)
+        (end (string-cursor-end str))
+        (encode-1 (if (and (pair? o) (car o))
+                      encode-1-space
+                      encode-1-normal)))
+    (let lp ((from start) (to start) (res '()))
+      (if (string-cursor>=? to end)
+          (if (zero? from)
+              str
+              (string-concatenate (reverse (collect str from to res))))
+          (let* ((ch (string-cursor-ref str to))
+                 (next (string-cursor-next str to)))
+            (if (uri-safe-char? ch)
+                (lp from next res)
+                (lp next next (cons (encode-1 ch)
+                                    (collect str from to res)))))))))
+
+;;> \procedure{(uri-decode str [plus?])}
+
+;;> Decodes any URI hex escapes in the given string, and
+;;> translates any pluses ("+") to space iff the optional
+;;> argument \var{plus?} is true.
+
+(define (uri-decode str . o)
+  (let ((space-as-plus? (and (pair? o) (car o)))
+        (start (string-cursor-start str))
+        (end (string-cursor-end str)))
+    (let lp ((from start) (to start) (res '()))
+      (if (string-cursor>=? to end)
+          (if (zero? from)
+              str
+              (string-concatenate (reverse (collect str from to res))))
+          (let* ((ch (string-cursor-ref str to))
+                 (next (string-cursor-next str to)))
+            (cond
+             ((eqv? ch #\%)
+              (if (string-cursor>=? next end)
+                  (lp next next (collect str from to res))
+                  (let ((next2 (string-cursor-next str next)))
+                    (if (string-cursor>=? next2 end)
+                        (lp next2 next2 (collect str from to res))
+                        (let* ((next3 (+ next2 1))
+                               (hex (substring-cursor str next next3))
+                               (i (string->number hex 16)))
+                          (lp next3 next3 (cons (string (integer->char i))
+                                                (collect str from to res))))))))
+             ((and space-as-plus? (eqv? ch #\+))
+              (lp next next (cons " " (collect str from to res))))
+             (else
+              (lp from next res))))))))
+
+;;> \procedure{(uri-query->alist str [plus?])}
+
+;;> Parses the query part of a URI as a delimited list of
+;;> URI encoded \rawcode{VAR=VALUE} pairs, decodes them and
+;;> returns the result as an alist.
+
+(define (uri-query->alist str . o)
+  (define (split-char? c) (if (eqv? c #\&) #t (eqv? c #\;)))
+  (let ((end (string-cursor-end str))
+        (plus? (and (pair? o) (car o))))
+    (let lp ((i 0) (res '()))
+      (if (string-cursor>=? i end)
+          (reverse res)
+          (let* ((j (string-find str split-char? i))
+                 (k (string-find str #\= i j))
+                 (cell
+                  (if (< k end)
+                      (cons (uri-decode (substring-cursor str i k) plus?)
+                            (uri-decode (substring-cursor str (+ k 1) j) plus?))
+                      (cons (uri-decode (substring-cursor str i j) plus?) #f))))
+            (lp (+ j 1) (cons cell res)))))))
+
+;;> \procedure{(uri-alist->query ls [plus?])}
+
+;;> The reverse of the above, formats the alist as a URI
+;;> query string.
+
+(define (uri-alist->query ls . o)
+  (define plus? (and (pair? o) (car o)))
+  (define (encode key val res)
+    (let ((res (cons (uri-encode key plus?) res)))
+      (if val (cons (uri-encode val plus?) (cons "=" res)) res)))
+  (if (null? ls)
+      ""
+      (let lp ((x (car ls)) (ls (cdr ls)) (res '()))
+        (let ((res (encode (car x) (cdr x) res)))
+          (if (null? ls)
+              (string-concatenate (reverse res))
+              (lp (car ls) (cdr ls) (cons "&" res)))))))
+
+;;> Returns a new URI from \var{path}, a string or URI object, as
+;;> would be interpreted from as a reference from \var{uri}.  Thus if
+;;> any components of \var{path} are missing, or if \var{path} is a
+;;> raw path, it is taken relative to \var{uri}.
+
+(define (uri-resolve path uri)
+  (or (string->uri path)
+      (let ((uri (string->uri uri)))
+        (and uri
+             (uri-with-path
+              (uri-with-fragment (uri-with-query uri #f) #f)
+              (path-resolve path
+                            (if (string-suffix? (uri-path uri) "/")
+                                (uri-path uri)
+                                (path-directory (uri-path uri)))))))))
diff --git a/lib/chibi/uri.sld b/lib/chibi/uri.sld
new file mode 100644
index 00000000..2e50fe26
--- /dev/null
+++ b/lib/chibi/uri.sld
@@ -0,0 +1,9 @@
+
+(define-library (chibi uri)
+  (export uri? uri->string make-uri string->uri string->path-uri uri-has-scheme?
+          uri-scheme uri-user uri-host uri-port uri-path uri-query uri-fragment
+          uri-with-scheme uri-with-user uri-with-host uri-with-path
+          uri-with-query uri-with-fragment uri-resolve
+          uri-encode uri-decode uri-query->alist uri-alist->query)
+  (import (chibi) (chibi string) (chibi pathname) (srfi 9))
+  (include "uri.scm"))
diff --git a/lib/chibi/weak.c b/lib/chibi/weak.c
new file mode 100644
index 00000000..d95ab54b
--- /dev/null
+++ b/lib/chibi/weak.c
@@ -0,0 +1,118 @@
+/*  weak.c -- weak pointers and ephemerons                    */
+/*  Copyright (c) 2010-2013 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+
+sexp sexp_ephemeron_brokenp_op (sexp ctx, sexp self, sexp_sint_t n, sexp eph) {
+  if (! (sexp_pointerp(eph) && (sexp_pointer_tag(eph) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
+    return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), eph);
+  return sexp_make_boolean(sexp_brokenp(eph));
+}
+
+#if 0
+#define sexp_weak_vector_p(x) sexp_check_tag(x, sexp_weak_vector_id)
+
+sexp sexp_make_weak_vector (sexp ctx, sexp self, sexp_sint_t n, sexp len) {
+  sexp vec, *x;
+  int i, clen = sexp_unbox_fixnum(len);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, len);
+  vec = sexp_alloc_tagged(ctx, sexp_sizeof(vector) + clen*sizeof(sexp),
+                          sexp_unbox_fixnum(sexp_opcode_return_type(self)));
+  if (sexp_exceptionp(vec)) return vec;
+  x = sexp_vector_data(vec);
+  for (i=0; i<clen; i++)
+    x[i] = SEXP_VOID;
+  sexp_vector_length(vec) = clen;
+  return vec;
+}
+
+sexp sexp_weak_vector_length (sexp ctx, sexp self, sexp_sint_t n, sexp v) {
+  if (! (sexp_pointerp(v) && (sexp_pointer_tag(v) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
+    return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), v);
+  return sexp_make_fixnum(sexp_vector_length(v));
+}
+
+sexp sexp_weak_vector_ref (sexp ctx, sexp self, sexp_sint_t n, sexp v, sexp k) {
+  if (! (sexp_pointerp(v) && (sexp_pointer_tag(v) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
+    return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), v);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, k);
+  return sexp_vector_ref(v, k);
+}
+
+sexp sexp_weak_vector_set (sexp ctx, sexp self, sexp_sint_t n, sexp v, sexp k, sexp x) {
+  if (! (sexp_pointerp(v) && (sexp_pointer_tag(v) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
+    return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), v);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, k);
+  sexp_vector_set(v, k, x);
+  return SEXP_VOID;
+}
+#endif
+
+sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
+#if 0
+  sexp v;
+  int sexp_weak_vector_id;
+#endif
+  sexp_gc_var3(name, t, op);
+  if (!(sexp_version_compatible(ctx, version, sexp_version)
+        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
+    return SEXP_ABI_ERROR;
+  sexp_gc_preserve3(ctx, name, t, op);
+
+  t = sexp_make_fixnum(SEXP_EPHEMERON);
+  op = sexp_make_type_predicate(ctx, name=sexp_c_string(ctx,"ephemeron?",-1), t);
+  sexp_env_define(ctx, env, name=sexp_intern(ctx, "ephemeron?", -1), op);
+  op = sexp_make_getter(ctx, name=sexp_c_string(ctx, "ephemeron-key", -1), t, SEXP_ZERO);
+  sexp_env_define(ctx, env, name=sexp_intern(ctx, "ephemeron-key", -1), op);
+  op = sexp_make_getter(ctx, name=sexp_c_string(ctx, "ephemeron-value", -1), t, SEXP_ONE);
+  sexp_env_define(ctx, env, name=sexp_intern(ctx, "ephemeron-value", -1), op);
+  op = sexp_define_foreign(ctx, env, "make-ephemeron", 2, sexp_make_ephemeron_op);
+  if (sexp_opcodep(op)) {
+    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_EPHEMERON);
+  }
+  op = sexp_define_foreign(ctx, env, "ephemeron-broken?", 1, sexp_ephemeron_brokenp_op);
+  if (sexp_opcodep(op)) {
+    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
+    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_EPHEMERON);
+  }
+
+#if 0
+  name = sexp_c_string(ctx, "Weak-Vector", -1);
+  t = sexp_register_simple_type(ctx, name, SEXP_FALSE, SEXP_ZERO);
+  v = sexp_type_by_index(ctx, SEXP_VECTOR);
+  sexp_weak_vector_id = sexp_type_tag(t);
+  sexp_type_weak_base(t) = sexp_type_field_base(v);
+  sexp_type_weak_len_off(t) = sexp_type_field_len_off(v);
+  sexp_type_weak_len_scale(t) = sexp_type_field_len_scale(v);
+
+  op = sexp_make_type_predicate(ctx, name=sexp_c_string(ctx,"weak-vector?",-1), t);
+  sexp_env_define(ctx, env, name=sexp_intern(ctx, "weak-vector?", -1), op);
+  op = sexp_define_foreign(ctx, env, "make-weak-vector", 1, sexp_make_weak_vector);
+  if (sexp_opcodep(op)) {
+    sexp_opcode_return_type(op) = sexp_make_fixnum(sexp_weak_vector_id);
+    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
+  }
+  op = sexp_define_foreign(ctx, env, "weak-vector-length", 2, sexp_weak_vector_length);
+  if (sexp_opcodep(op)) {
+    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
+    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_weak_vector_id);
+  }
+  op = sexp_define_foreign(ctx, env, "weak-vector-ref", 2, sexp_weak_vector_ref);
+  if (sexp_opcodep(op)) {
+    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
+    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_weak_vector_id);
+    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
+  }
+  op = sexp_define_foreign(ctx, env, "weak-vector-set!", 3, sexp_weak_vector_set);
+  if (sexp_opcodep(op)) {
+    sexp_opcode_return_type(op) = SEXP_VOID;
+    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_weak_vector_id);
+    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
+  }
+#endif
+
+  sexp_gc_release3(ctx);
+  return SEXP_VOID;
+}
+
diff --git a/lib/chibi/weak.sld b/lib/chibi/weak.sld
new file mode 100644
index 00000000..ecac71bb
--- /dev/null
+++ b/lib/chibi/weak.sld
@@ -0,0 +1,10 @@
+
+;;> Library for weak data structures.
+
+(define-library (chibi weak)
+  (export make-ephemeron ephemeron? ephemeron-broken?
+          ephemeron-key ephemeron-value
+          ;; make-weak-vector weak-vector? weak-vector-length
+          ;; weak-vector-ref weak-vector-set!
+          )
+  (include-shared "weak"))
diff --git a/lib/chibi/zlib.scm b/lib/chibi/zlib.scm
new file mode 100644
index 00000000..c2cf44e2
--- /dev/null
+++ b/lib/chibi/zlib.scm
@@ -0,0 +1,47 @@
+
+;; Temporary hack, need to rewrite in pure Scheme.
+
+;;> Gzip compress a file in place, renaming with a .gz suffix.
+
+(define (gzip-file path)
+  (system "gzip" path))
+
+;;> Gunzip decompress a file in place, removing any .gz suffix.
+
+(define (gunzip-file path)
+  (system "gzip" "-d" path))
+
+;; Utility to filter a bytevector to a process and return the
+;; accumulated output as a new bytevector.
+(define (process-pipe-bytevector cmd bvec)
+  (call-with-process-io
+   cmd
+   (lambda (pid proc-in proc-out proc-err)
+     ;; This could overflow the pipe.
+     (write-bytevector bvec proc-in)
+     (close-output-port proc-in)
+     (let ((res (port->bytevector proc-out)))
+       (waitpid pid 0)
+       res))))
+
+;;> Gzip compress a string or bytevector in memory.
+
+(define (gzip x)
+  (if (string? x)
+      (gzip (string->utf8 x))
+      (process-pipe-bytevector '("gzip" "-c") x)))
+
+;;> Gunzip decompress a bytevector in memory.
+
+(define (gunzip bvec)
+  (process-pipe-bytevector '("gzip" "-c" "-d") bvec))
+
+;;> Gunzip decompress a bytevector in memory if it has been
+;;> compressed, or return as-is otherwise.
+
+(define (maybe-gunzip bvec)
+  (if (and (>= (bytevector-length bvec) 10)
+           (eqv? #x1f (bytevector-u8-ref bvec 0))
+           (eqv? #x8b (bytevector-u8-ref bvec 1)))
+      (gunzip bvec)
+      bvec))
diff --git a/lib/chibi/zlib.sld b/lib/chibi/zlib.sld
new file mode 100644
index 00000000..252b46a0
--- /dev/null
+++ b/lib/chibi/zlib.sld
@@ -0,0 +1,5 @@
+
+(define-library (chibi zlib)
+  (export gzip-file gunzip-file gzip gunzip maybe-gunzip)
+  (import (scheme base) (chibi io) (chibi process))
+  (include "zlib.scm"))
diff --git a/lib/init-7.scm b/lib/init-7.scm
new file mode 100644
index 00000000..3a63da9a
--- /dev/null
+++ b/lib/init-7.scm
@@ -0,0 +1,1251 @@
+;; init-7.scm -- core library procedures for R7RS
+;; Copyright (c) 2009-2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(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 (cons-source kar kdr source)
+  ((lambda (pair)
+     (if (pair? source)
+         (pair-source-set! pair (pair-source source)))
+     pair)
+   (cons kar kdr)))
+
+;; basic utils
+
+(define (procedure? x) (if (closure? x) #t (opcode? x)))
+
+(define (length ls)
+  (if (list? ls) (length* ls) (error "length: not a list" ls)))
+
+(define (list . args) args)
+
+(define (list-tail ls k)
+  (if (eq? k 0)
+      ls
+      (list-tail (cdr ls) (- k 1))))
+
+(define (list-ref ls k) (car (list-tail ls k)))
+
+(define (append-helper ls res)
+  (if (null? ls)
+      res
+      (append-helper (cdr ls) (append2 (car ls) res))))
+
+(define (append . o)
+  (if (null? o)
+      '()
+      ((lambda (lol)
+         (append-helper (cdr lol) (car lol)))
+       (reverse o))))
+
+(define (apply proc . args)
+  (if (null? args)
+      (proc)
+      ((lambda (lol)
+         (apply1 proc (append2 (reverse (cdr lol)) (car lol))))
+       (reverse args))))
+
+;; map with a fast-path for single lists
+
+(define (map proc ls . lol)
+  (define (map1 proc ls res)
+    (if (pair? ls)
+        (map1 proc (cdr ls) (cons (proc (car ls)) res))
+        (reverse res)))
+  (define (mapn proc lol res)
+    (if (every pair? lol)
+        (mapn proc
+              (map1 cdr lol '())
+              (cons (apply proc (map1 car lol '())) res))
+        (reverse res)))
+  (if (null? lol)
+      (map1 proc ls '())
+      (mapn proc (cons ls lol) '())))
+
+(define (for-each f ls . lol)
+  (define (for1 f ls) (if (pair? ls) (begin (f (car ls)) (for1 f (cdr ls)))))
+  (if (null? lol) (for1 f ls) (begin (apply map f ls lol) (if #f #f))))
+
+(define (any pred ls . lol)
+  (define (any1 pred ls)
+    (if (pair? (cdr ls))
+        ((lambda (x) (if x x (any1 pred (cdr ls)))) (pred (car ls)))
+        (pred (car ls))))
+  (define (anyn pred lol)
+    (if (every pair? lol)
+        ((lambda (x) (if x x (anyn pred (map cdr lol))))
+         (apply pred (map car lol)))
+        #f))
+  (if (null? lol) (if (pair? ls) (any1 pred ls) #f) (anyn pred (cons ls lol))))
+
+(define (every pred ls . lol)
+  (define (every1 pred ls)
+    (if (null? (cdr ls))
+        (pred (car ls))
+        (if (pred (car ls)) (every1 pred (cdr ls)) #f)))
+  (if (null? lol)
+      (if (pair? ls) (every1 pred ls) #t)
+      (not (apply any (lambda xs (not (apply pred xs))) ls lol))))
+
+(define (error msg . args)
+  (raise (make-exception 'user msg args #f #f)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; syntax
+
+(define sc-macro-transformer
+  (lambda (f)
+    (lambda (expr use-env mac-env)
+      (make-syntactic-closure mac-env '() (f expr use-env)))))
+
+(define rsc-macro-transformer
+  (lambda (f)
+    (lambda (expr use-env mac-env)
+      (f expr mac-env))))
+
+(define er-macro-transformer
+  (lambda (f)
+    (lambda (expr use-env mac-env)
+      ((lambda (rename compare) (f expr rename compare))
+       ((lambda (renames)
+          (lambda (identifier)
+            ((lambda (cell)
+               (if cell
+                   (cdr cell)
+                   ((lambda (name)
+                      (set! renames (cons (cons identifier name) renames))
+                      name)
+                    (make-syntactic-closure mac-env '() identifier))))
+             (assq identifier renames))))
+        '())
+       (lambda (x y) (identifier=? use-env x use-env y))))))
+
+(define-syntax cond
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (if (null? (cdr expr))
+         (if #f #f)
+         ((lambda (cl)
+            (if (compare (rename 'else) (car cl))
+                (if (pair? (cddr expr))
+                    (error "non-final else in cond" expr)
+                    (cons (rename 'begin) (cdr cl)))
+                (if (if (null? (cdr cl)) #t (compare (rename '=>) (cadr cl)))
+                    (list (list (rename 'lambda) (list (rename 'tmp))
+                                (list (rename 'if) (rename 'tmp)
+                                      (if (null? (cdr cl))
+                                          (rename 'tmp)
+                                          (list (car (cddr cl)) (rename 'tmp)))
+                                      (cons (rename 'cond) (cddr expr))))
+                          (car cl))
+                    (list (rename 'if)
+                          (car cl)
+                          (cons (rename 'begin) (cdr cl))
+                          (cons (rename 'cond) (cddr expr))))))
+          (cadr expr))))))
+
+(define-syntax or
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (cond ((null? (cdr expr)) #f)
+           ((null? (cddr expr)) (cadr expr))
+           (else
+            (list (rename 'let) (list (list (rename 'tmp) (cadr expr)))
+                  (list (rename 'if) (rename 'tmp)
+                        (rename 'tmp)
+                        (cons (rename 'or) (cddr expr)))))))))
+
+(define-syntax and
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (cond ((null? (cdr expr)))
+           ((null? (cddr expr)) (cadr expr))
+           (else (list (rename 'if) (cadr expr)
+                       (cons (rename 'and) (cddr expr))
+                       #f))))))
+
+(define-syntax quasiquote
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (define (qq x d)
+       (cond
+        ((pair? x)
+         (cond
+          ((compare (rename 'unquote) (car x))
+           (if (<= d 0)
+               (cadr x)
+               (list (rename 'list) (list (rename 'quote) 'unquote)
+                     (qq (cadr x) (- d 1)))))
+          ((compare (rename 'unquote-splicing) (car x))
+           (if (<= d 0)
+               (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))
+               (list (rename 'list) (list (rename 'quote) 'unquote-splicing)
+                     (qq (cadr x) (- d 1)))))
+          ((compare (rename 'quasiquote) (car x))
+           (list (rename 'list) (list (rename 'quote) 'quasiquote)
+                 (qq (cadr x) (+ d 1))))
+          ((and (<= d 0) (pair? (car x))
+                (compare (rename 'unquote-splicing) (caar x)))
+           (if (null? (cdr x))
+               (cadr (car x))
+               (list (rename 'append) (cadr (car x)) (qq (cdr x) d))))
+          (else
+           (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)))))
+        ((vector? x) (list (rename 'list->vector) (qq (vector->list x) d)))
+        ((if (identifier? x) #t (null? x)) (list (rename 'quote) x))
+        (else x)))
+     (qq (cadr expr) 0))))
+
+(define-syntax letrec
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     ((lambda (defs)
+        `((,(rename 'lambda) () ,@defs ,@(cddr expr))))
+      (map (lambda (x) (cons (rename 'define) x)) (cadr expr))))))
+
+(define-syntax let
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (if (null? (cdr expr)) (error "empty let" expr))
+     (if (null? (cddr expr)) (error "no let body" expr))
+     ((lambda (bindings)
+        (if (list? bindings) #f (error "bad let bindings"))
+        (if (every (lambda (x)
+                     (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f))
+                   bindings)
+            ((lambda (vars vals)
+               (if (identifier? (cadr expr))
+                   `((,(rename 'lambda) ,vars
+                      (,(rename 'letrec) ((,(cadr expr)
+                                           (,(rename 'lambda) ,vars
+                                            ,@(cdr (cddr expr)))))
+                       (,(cadr expr) ,@vars)))
+                     ,@vals)
+                   `((,(rename 'lambda) ,vars ,@(cddr expr)) ,@vals)))
+             (map car bindings)
+             (map cadr bindings))
+            (error "bad let syntax" expr)))
+      (if (identifier? (cadr expr)) (car (cddr expr)) (cadr expr))))))
+
+(define-syntax let*
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (if (null? (cdr expr)) (error "empty let*" expr))
+     (if (null? (cddr expr)) (error "no let* body" expr))
+     (if (null? (cadr expr))
+         `(,(rename 'let) () ,@(cddr expr))
+         (if (if (list? (cadr expr))
+                 (every
+                  (lambda (x)
+                    (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f))
+                  (cadr expr))
+                 #f)
+             `(,(rename 'let) (,(caar (cdr expr)))
+               (,(rename 'let*) ,(cdar (cdr expr)) ,@(cddr expr)))
+             (error "bad let* syntax"))))))
+
+(define-syntax case
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (define (body exprs)
+       (cond
+        ((null? exprs)
+         (rename 'tmp))
+        ((compare (rename '=>) (car exprs))
+         `(,(cadr exprs) ,(rename 'tmp)))
+        (else
+         `(,(rename 'begin) ,@exprs))))
+     (define (clause ls)
+       (cond
+        ((null? ls) #f)
+        ((compare (rename 'else) (caar ls))
+         (body (cdar ls)))
+        ((and (pair? (car (car ls))) (null? (cdr (car (car ls)))))
+         `(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp)
+                          (,(rename 'quote) ,(car (caar ls))))
+           ,(body (cdar ls))
+           ,(clause (cdr ls))))
+        (else
+         `(,(rename 'if) (,(rename 'memv) ,(rename 'tmp)
+                          (,(rename 'quote) ,(caar ls)))
+           ,(body (cdar ls))
+           ,(clause (cdr ls))))))
+     `(let ((,(rename 'tmp) ,(cadr expr)))
+        ,(clause (cddr expr))))))
+
+(define-syntax do
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let* ((body
+             `(,(rename 'begin)
+               ,@(cdr (cddr expr))
+               (,(rename 'lp)
+                ,@(map (lambda (x)
+                         (if (pair? (cddr x))
+                             (if (pair? (cdr (cddr x)))
+                                 (error "too many forms in do iterator" x)
+                                 (car (cddr x)))
+                             (car x)))
+                       (cadr expr)))))
+            (check (car (cddr expr)))
+            (wrap
+             (if (null? (cdr check))
+                 `(,(rename 'let) ((,(rename 'tmp) ,(car check)))
+                   (,(rename 'if) ,(rename 'tmp)
+                    ,(rename 'tmp)
+                    ,body))
+                 `(,(rename 'if) ,(car check)
+                   (,(rename 'begin) ,@(cdr check))
+                   ,body))))
+       `(,(rename 'let) ,(rename 'lp)
+         ,(map (lambda (x) (list (car x) (cadr x))) (cadr expr))
+         ,wrap)))))
+
+(define-syntax delay-force
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     `(,(rename 'promise) #f (,(rename 'lambda) () ,(cadr expr))))))
+
+(define-syntax delay
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     `(,(rename 'delay-force) (,(rename 'promise) #t ,(cadr expr))))))
+
+(define-syntax define-auxiliary-syntax
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     `(,(rename 'define-syntax) ,(cadr expr)
+       (,(rename 'er-macro-transformer)
+        (,(rename 'lambda) (expr rename compare)
+         (,(rename 'error) "invalid use of auxiliary syntax" ',(cadr expr))))))))
+
+(define-auxiliary-syntax _)
+(define-auxiliary-syntax =>)
+(define-auxiliary-syntax ...)
+(define-auxiliary-syntax else)
+(define-auxiliary-syntax unquote)
+(define-auxiliary-syntax unquote-splicing)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; library functions
+
+;; booleans
+
+(define (not x) (if x #f #t))
+(define (boolean? x) (if (eq? x #t) #t (eq? x #f)))
+
+;; char utils
+
+(define (char-alphabetic? ch) (<= 65 (char->integer (char-upcase ch)) 90))
+(define (char-numeric? ch) (<= 48 (char->integer ch) 57))
+(define (char-whitespace? ch)
+  (if (eq? ch #\space)
+      #t
+      (if (eq? ch #\tab) #t (if (eq? ch #\newline)
+                                #t
+                                (if (eq? ch #\xC0) #f (eq? ch #\return))))))
+(define (char-upper-case? ch) (<= 65 (char->integer ch) 90))
+(define (char-lower-case? ch) (<= 97 (char->integer ch) 122))
+
+(define (char-cmp op a ls)
+  (let lp ((op op) (a (char->integer a)) (ls ls))
+    (if (null? ls)
+        #t
+        (let ((b (char->integer (car ls))))
+          (and (op a b) (lp op b (cdr ls)))))))
+
+(define (char=? a . ls) (char-cmp = a ls))
+(define (char<? a . ls) (char-cmp < a ls))
+(define (char>? a . ls) (char-cmp > a ls))
+(define (char<=? a . ls) (char-cmp <= a ls))
+(define (char>=? a . ls) (char-cmp >= a ls))
+
+(define (char-cmp-ci op a ls)
+  (let lp ((op op) (a (char->integer (char-downcase a))) (ls ls))
+    (if (null? ls)
+        #t
+        (let ((b (char->integer (char-downcase (car ls)))))
+          (and (op a b) (lp op b (cdr ls)))))))
+
+(define (char-ci=? a . ls) (char-cmp-ci = a ls))
+(define (char-ci<? a . ls) (char-cmp-ci < a ls))
+(define (char-ci>? a . ls) (char-cmp-ci > a ls))
+(define (char-ci<=? a . ls) (char-cmp-ci <= a ls))
+(define (char-ci>=? a . ls) (char-cmp-ci >= a ls))
+
+;; string utils
+
+(define (digit-char n)
+  (if (<= n 9)
+      (integer->char (+ n (char->integer #\0)))
+      (integer->char (+ (- n 10) (char->integer #\a)))))
+
+(define (%number->string num)
+  (call-with-output-string (lambda (out) (write num out))))
+
+(define (number->string num . o)
+  (cond
+   ((not (number? num))
+    (error "not a number" num))
+   ((if (null? o) #t (eq? 10 (car o)))
+    (%number->string num))
+   (else
+    (let lp ((n (abs num)) (d (car o)) (res '()))
+      (if (> n 0)
+          (lp (quotient n d) d (cons (digit-char (remainder n d)) res))
+          (if (null? res)
+              "0"
+              (list->string (if (negative? num) (cons #\- res) res))))))))
+
+(define (list->string ls)
+  (call-with-output-string
+    (lambda (out) (for-each (lambda (ch) (write-char ch out)) ls))))
+
+(define (string->list str . o)
+  (cond
+   ((null? o)
+    (let lp ((i (string-cursor-prev str (string-cursor-end str))) (res '()))
+      (if (< i 0)
+          res
+          (lp (string-cursor-prev str i) (cons (string-cursor-ref str i) res)))))
+   (else
+    (string->list (apply substring str o)))))
+
+(define (string-fill! str ch . o)
+  (let ((start (if (pair? o) (car o) 0))
+        (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str))))
+    (let lp ((i (- end 1)))
+      (if (>= i start) (begin (string-set! str i ch) (lp (- i 1)))))))
+
+(define (string . args) (list->string args))
+(define (string-append . args) (string-concatenate args))
+
+(define (string-cmp-ls op ci? s ls)
+  (if (null? ls)
+      #t
+      (and (op (string-cmp s (car ls) ci?) 0)
+           (string-cmp-ls op ci? (car ls) (cdr ls)))))
+
+(define (string=? s . ls) (string-cmp-ls eq? #f s ls))
+(define (string<? s . ls) (string-cmp-ls < #f s ls))
+(define (string>? s . ls) (string-cmp-ls > #f s ls))
+(define (string<=? s . ls) (string-cmp-ls <= #f s ls))
+(define (string>=? s . ls) (string-cmp-ls >= #f s ls))
+
+(define (string-ci=? s . ls) (string-cmp-ls eq? #t s ls))
+(define (string-ci<? s . ls) (string-cmp-ls < #t s ls))
+(define (string-ci>? s . ls) (string-cmp-ls > #t s ls))
+(define (string-ci<=? s . ls) (string-cmp-ls <= #t s ls))
+(define (string-ci>=? s . ls) (string-cmp-ls >= #t s ls))
+
+;; list utils
+
+(define (make-list n . o)
+  (let ((default (if (pair? o) (car o))))
+    (let lp ((n n) (res '()))
+      (if (<= n 0) res (lp (- n 1) (cons default res))))))
+
+(define (list-copy ls)
+  (let lp ((ls ls) (res '()))
+    (if (pair? ls)
+        (lp (cdr ls) (cons (car ls) res))
+        (append (reverse res) ls))))
+
+(define (member obj ls . o)
+  (let ((eq (if (pair? o) (car o) equal?)))
+    (let lp ((ls ls))
+      (and (pair? ls) (if (eq obj (car ls)) ls (lp (cdr ls)))))))
+
+(define memv member)
+
+(define (assoc obj ls . o)
+  (let ((eq (if (pair? o) (car o) equal?)))
+    (let assoc ((ls ls))
+      (cond ((null? ls) #f)
+            ((eq obj (caar ls)) (car ls))
+            (else (assoc (cdr ls)))))))
+
+(define (assv obj ls) (assoc obj ls eqv?))
+
+(define (find-tail pred ls)
+  (and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls)))))
+
+(define (find pred ls)
+  (cond ((find-tail pred ls) => car) (else #f)))
+
+;; vector utils
+
+(define (vector-copy vec . o)
+  (let* ((start (if (pair? o) (car o) 0))
+         (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (vector-length vec)))
+         (res (make-vector (- end start))))
+    (do ((i 0 (+ i 1)) (j start (+ j 1))) ((>= j end) res)
+      (vector-set! res i (vector-ref vec j)))))
+
+(define (list->vector ls)
+  (let ((vec (make-vector (length ls) #f)))
+    (let lp ((ls ls) (i 0))
+      (if (pair? ls)
+          (begin
+            (vector-set! vec i (car ls))
+            (lp (cdr ls) (+ i 1)))))
+    vec))
+
+(define (vector->list vec . o)
+  (let ((start (if (pair? o) (car o) 0))
+        (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (vector-length vec))))
+    (let lp ((i (- end 1)) (res '()))
+      (if (< i start) res (lp (- i 1) (cons (vector-ref vec i) res))))))
+
+(define (vector-fill! vec ch . o)
+  (let ((start (if (pair? o) (car o) 0))
+        (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (vector-length vec))))
+    (let lp ((i (- end 1)))
+      (if (>= i start) (begin (vector-set! vec i ch) (lp (- i 1)))))))
+
+(define (vector . args) (list->vector args))
+
+;; I/O utils
+
+(define (display x . o)
+  (let ((out (if (pair? o) (car o) (current-output-port))))
+    (cond ((char? x) (write-char x out))
+          ((string? x) (%write-string x #t out))
+          (else (write x out)))))
+
+(define (newline . o)
+  (write-char #\newline (if (pair? o) (car o) (current-output-port))))
+
+(define (port? x) (or (input-port? x) (output-port? x)))
+
+(define textual-port? port?)
+
+(define (call-with-input-string str proc)
+  (let* ((in (open-input-string str))
+         (res (proc in)))
+    (close-input-port in)
+    res))
+
+(define (call-with-output-string proc)
+  (let ((out (open-output-string)))
+    (proc out)
+    (let ((res (get-output-string out)))
+      (close-output-port out)
+      res)))
+
+(define (call-with-input-file file proc)
+  (let* ((in (open-input-file file))
+         (res (proc in)))
+    (close-input-port in)
+    res))
+
+(define (call-with-output-file file proc)
+  (let* ((out (open-output-file file))
+         (res (proc out)))
+    (close-output-port out)
+    res))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; values
+
+(define *values-tag* (list 'values))
+
+(define (%values ls)
+  (if (and (pair? ls) (null? (cdr ls)))
+      (car ls)
+      (cons *values-tag* ls)))
+
+(define (values . ls) (%values ls))
+
+(define (call-with-values producer consumer)
+  (let ((res (producer)))
+    (if (and (pair? res) (eq? *values-tag* (car res)))
+        (apply consumer (cdr res))
+        (consumer res))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; SRFI-0
+
+(define-syntax cond-expand
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (define (check x)
+       (if (pair? x)
+           (case (car x)
+             ((and) (every check (cdr x)))
+             ((or) (any check (cdr x)))
+             ((not) (not (check (cadr x))))
+             ((library) (eval `(find-module ',(cadr x)) (%meta-env)))
+             (else (error "cond-expand: bad feature" x)))
+           (memq (identifier->symbol x) *features*)))
+     (let expand ((ls (cdr expr)))
+       (cond ((null? ls))  ; (error "cond-expand: no expansions" expr)
+             ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls)))
+             ((eq? 'else (identifier->symbol (caar ls)))
+              (if (pair? (cdr ls))
+                  (error "cond-expand: else in non-final position")
+                  `(,(rename 'begin) ,@(cdar ls))))
+             ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls)))
+             (else (expand (cdr ls))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; dynamic-wind
+
+(define %make-point vector)
+(define (%point-depth point) (vector-ref point 0))
+(define (%point-in point) (vector-ref point 1))
+(define (%point-out point) (vector-ref point 2))
+(define (%point-parent point) (vector-ref point 3))
+
+(define root-point			; Shared among all state spaces
+  (%make-point 0
+	      (lambda () (error "winding in to root!"))
+	      (lambda () (error "winding out of root!"))
+	      #f))
+
+(cond-expand
+ (threads)
+ (else
+  (define %dk
+    (let ((dk root-point))
+      (lambda o (if (pair? o) (set! dk (car o)) dk))))))
+
+(%dk root-point)
+
+(define (dynamic-wind in body out)
+  (in)
+  (let ((here (%dk)))
+    (%dk (%make-point (+ (%point-depth here) 1)
+                     in
+                     out
+                     here))
+    (let ((res (body)))
+      (%dk here)
+      (out)
+      res)))
+
+(define (travel-to-point! here target)
+  (cond
+   ((eq? here target)
+    'done)
+   ((< (%point-depth here) (%point-depth target))
+    (travel-to-point! here (%point-parent target))
+    ((%point-in target)))
+   (else
+    ((%point-out here))
+    (travel-to-point! (%point-parent here) target))))
+
+(define (continuation->procedure cont point)
+  (lambda res
+    (travel-to-point! (%dk) point)
+    (%dk point)
+    (cont (%values res))))
+
+(define (call-with-current-continuation proc)
+  (%call/cc
+   (lambda (cont)
+     (proc (continuation->procedure cont (%dk))))))
+
+(define (with-input-from-file file thunk)
+  (let ((old-in (current-input-port))
+        (tmp-in (open-input-file file)))
+    (dynamic-wind
+      (lambda () (current-input-port tmp-in))
+      (lambda () (let ((res (thunk))) (close-input-port tmp-in) res))
+      (lambda () (current-input-port old-in)))))
+
+(define (with-output-to-file file thunk)
+  (let ((old-out (current-output-port))
+        (tmp-out (open-output-file file)))
+    (dynamic-wind
+      (lambda () (current-output-port tmp-out))
+      (lambda () (let ((res (thunk))) (close-output-port tmp-out) res))
+      (lambda () (current-output-port old-out)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; syntax-rules
+
+(define-syntax syntax-rules
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let ((ellipsis-specified? (identifier? (cadr expr)))
+           (count 0)
+           (_er-macro-transformer (rename 'er-macro-transformer))
+           (_lambda (rename 'lambda))      (_let (rename 'let))
+           (_begin (rename 'begin))        (_if (rename 'if))
+           (_and (rename 'and))            (_or (rename 'or))
+           (_eq? (rename 'eq?))            (_equal? (rename 'equal?))
+           (_car (rename 'car))            (_cdr (rename 'cdr))
+           (_cons (rename 'cons))          (_pair? (rename 'pair?))
+           (_null? (rename 'null?))        (_expr (rename 'expr))
+           (_rename (rename 'rename))      (_compare (rename 'compare))
+           (_quote (rename 'syntax-quote)) (_apply (rename 'apply))
+           (_append (rename 'append))      (_map (rename 'map))
+           (_vector? (rename 'vector?))    (_list? (rename 'list?))
+           (_len (rename'len))             (_length (rename 'length*))
+           (_- (rename '-))   (_>= (rename '>=))   (_error (rename 'error))
+           (_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i))
+           (_reverse (rename 'reverse))
+           (_vector->list (rename 'vector->list))
+           (_list->vector (rename 'list->vector))
+           (_cons3 (rename 'cons-source)))
+       (define ellipsis (rename (if ellipsis-specified? (cadr expr) '...)))
+       (define lits (if ellipsis-specified? (car (cddr expr)) (cadr expr)))
+       (define forms (if ellipsis-specified? (cdr (cddr expr)) (cddr expr)))
+       (define (next-symbol s)
+         (set! count (+ count 1))
+         (rename (string->symbol (string-append s (%number->string count)))))
+       (define (expand-pattern pat tmpl)
+         (let lp ((p (cdr pat))
+                  (x (list _cdr _expr))
+                  (dim 0)
+                  (vars '())
+                  (k (lambda (vars)
+                       (list _cons (expand-template tmpl vars) #f))))
+           (let ((v (next-symbol "v.")))
+             (list
+              _let (list (list v x))
+              (cond
+               ((identifier? p)
+                (if (any (lambda (l) (compare p l)) lits)
+                    (list _and
+                          (list _compare v (list _rename (list _quote p)))
+                          (k vars))
+                    (list _let (list (list p v)) (k (cons (cons p dim) vars)))))
+               ((ellipsis? p)
+                (cond
+                 ((not (null? (cdr (cdr p))))
+                  (cond
+                   ((any (lambda (x) (and (identifier? x) (compare x ellipsis)))
+                         (cddr p))
+                    (error "multiple ellipses" p))
+                   (else
+                    (let ((len (length* (cdr (cdr p))))
+                          (_lp (next-symbol "lp.")))
+                      `(,_let ((,_len (,_length ,v)))
+                         (,_and (,_>= ,_len ,len)
+                                (,_let ,_lp ((,_ls ,v)
+                                             (,_i (,_- ,_len ,len))
+                                             (,_res (,_quote ())))
+                                  (,_if (,_>= 0 ,_i)
+                                      ,(lp `(,(cddr p) 
+                                             (,(car p) ,(car (cdr p))))
+                                           `(,_cons ,_ls
+                                                    (,_cons (,_reverse ,_res)
+                                                            (,_quote ())))
+                                           dim
+                                           vars
+                                           k)
+                                      (,_lp (,_cdr ,_ls)
+                                            (,_- ,_i 1)
+                                            (,_cons3 (,_car ,_ls)
+                                                     ,_res
+                                                     ,_ls))))))))))
+                 ((identifier? (car p))
+                  (list _and (list _list? v)
+                        (list _let (list (list (car p) v))
+                              (k (cons (cons (car p) (+ 1 dim)) vars)))))
+                 (else
+                  (let* ((w (next-symbol "w."))
+                         (_lp (next-symbol "lp."))
+                         (new-vars (all-vars (car p) (+ dim 1)))
+                         (ls-vars (map (lambda (x)
+                                         (next-symbol
+                                          (string-append
+                                           (symbol->string
+                                            (identifier->symbol (car x)))
+                                           "-ls")))
+                                       new-vars))
+                         (once
+                          (lp (car p) (list _car w) (+ dim 1) '()
+                              (lambda (_)
+                                (cons
+                                 _lp
+                                 (cons
+                                  (list _cdr w)
+                                  (map (lambda (x l)
+                                         (list _cons (car x) l))
+                                       new-vars
+                                       ls-vars)))))))
+                    (list
+                     _let
+                     _lp (cons (list w v)
+                               (map (lambda (x) (list x (list _quote '()))) ls-vars))
+                     (list _if (list _null? w)
+                           (list _let (map (lambda (x l)
+                                             (list (car x) (list _reverse l)))
+                                           new-vars
+                                           ls-vars)
+                                 (k (append new-vars vars)))
+                           (list _and (list _pair? w) once)))))))
+               ((pair? p)
+                (list _and (list _pair? v)
+                      (lp (car p)
+                          (list _car v)
+                          dim
+                          vars
+                          (lambda (vars)
+                            (lp (cdr p) (list _cdr v) dim vars k)))))
+               ((vector? p)
+                (list _and
+                      (list _vector? v)
+                      (lp (vector->list p) (list _vector->list v) dim vars k)))
+               ((null? p) (list _and (list _null? v) (k vars)))
+               (else (list _and (list _equal? v p) (k vars))))))))
+       (define (ellipsis-escape? x) (and (pair? x) (compare ellipsis (car x))))
+       (define (ellipsis? x)
+         (and (pair? x) (pair? (cdr x)) (compare ellipsis (cadr x))))
+       (define (ellipsis-depth x)
+         (if (ellipsis? x)
+             (+ 1 (ellipsis-depth (cdr x)))
+             0))
+       (define (ellipsis-tail x)
+         (if (ellipsis? x)
+             (ellipsis-tail (cdr x))
+             (cdr x)))
+       (define (all-vars x dim)
+         (let lp ((x x) (dim dim) (vars '()))
+           (cond ((identifier? x)
+                  (if (any (lambda (lit) (compare x lit)) lits)
+                      vars
+                      (cons (cons x dim) vars)))
+                 ((ellipsis? x) (lp (car x) (+ dim 1) (lp (cddr x) dim vars)))
+                 ((pair? x) (lp (car x) dim (lp (cdr x) dim vars)))
+                 ((vector? x) (lp (vector->list x) dim vars))
+                 (else vars))))
+       (define (free-vars x vars dim)
+         (let lp ((x x) (free '()))
+           (cond
+            ((identifier? x)
+             (if (and (not (memq x free))
+                      (cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim)))
+                            (else #f)))
+                 (cons x free)
+                 free))
+            ((pair? x) (lp (car x) (lp (cdr x) free)))
+            ((vector? x) (lp (vector->list x) free))
+            (else free))))
+       (define (expand-template tmpl vars)
+         (let lp ((t tmpl) (dim 0))
+           (cond
+            ((identifier? t)
+             (cond
+              ((find (lambda (v) (compare t (car v))) vars)
+               => (lambda (cell)
+                    (if (<= (cdr cell) dim)
+                        t
+                        (error "too few ...'s"))))
+              (else
+               (list _rename (list _quote t)))))
+            ((pair? t)
+             (cond
+              ((ellipsis-escape? t)
+               (list _quote
+                     (if (pair? (cdr t))
+                         (if (pair? (cddr t)) (cddr t) (cadr t))
+                         (cdr t))))
+              ((ellipsis? t)
+               (let* ((depth (ellipsis-depth t))
+                      (ell-dim (+ dim depth))
+                      (ell-vars (free-vars (car t) vars ell-dim)))
+                 (cond
+                  ((null? ell-vars)
+                   (error "too many ...'s"))
+                  ((and (null? (cdr (cdr t))) (identifier? (car t)))
+                   ;; shortcut for (var ...)
+                   (lp (car t) ell-dim))
+                  (else
+                   (let* ((once (lp (car t) ell-dim))
+                          (nest (if (and (null? (cdr ell-vars))
+                                         (identifier? once)
+                                         (eq? once (car vars)))
+                                    once ;; shortcut
+                                    (cons _map
+                                          (cons (list _lambda ell-vars once)
+                                                ell-vars))))
+                          (many (do ((d depth (- d 1))
+                                     (many nest
+                                           (list _apply _append many)))
+                                    ((= d 1) many))))
+                     (if (null? (ellipsis-tail t))
+                         many ;; shortcut
+                         (list _append many (lp (ellipsis-tail t) dim))))))))
+              (else (list _cons3 (lp (car t) dim) (lp (cdr t) dim) (list _quote t)))))
+            ((vector? t) (list _list->vector (lp (vector->list t) dim)))
+            ((null? t) (list _quote '()))
+            (else t))))
+       (list
+        _er-macro-transformer
+        (list _lambda (list _expr _rename _compare)
+              (list
+               _car
+               (cons
+                _or
+                (append
+                 (map
+                  (lambda (clause) (expand-pattern (car clause) (cadr clause)))
+                  forms)
+                 (list
+                  (list _cons
+                        (list _error "no expansion for"
+                              (list (rename 'strip-syntactic-closures) _expr))
+                        #f)))))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; additional syntax
+
+(define-syntax syntax-error
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (apply error (cdr expr)))))
+
+(define-syntax letrec*
+  (syntax-rules ()
+    ((letrec* ((var val) ...) . body)
+     (let () (define var val) ... . body))))
+
+(define-syntax let-optionals*
+  (syntax-rules ()
+    ((let-optionals* opt-ls () . body)
+     (begin . body))
+    ((let-optionals* (op . args) vars . body)
+     (let ((tmp (op . args)))
+       (let-optionals* tmp vars . body)))
+    ((let-optionals* tmp ((var default) . rest) . body)
+     (let ((var (if (pair? tmp) (car tmp) default))
+           (tmp2 (if (pair? tmp) (cdr tmp) '())))
+       (let-optionals* tmp2 rest . body)))
+    ((let-optionals* tmp tail . body)
+     (let ((tail tmp)) . body))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; exceptions
+
+;; We wrap continuable objects in specially marked exceptions.
+(define (raise-continuable exn)
+  (raise (make-exception 'continuable "" exn #f #f)))
+
+(cond-expand
+ (threads
+  (define (%with-exception-handler handler thunk)
+    (let* ((old (thread-parameters))
+           (new (cons (cons current-exception-handler handler) old)))
+      (dynamic-wind
+        (lambda () (thread-parameters-set! new))
+        thunk
+        (lambda () (thread-parameters-set! old))))))
+ (else
+  (define (%with-exception-handler handler thunk)
+    (let ((old (current-exception-handler)))
+      (dynamic-wind
+        (lambda () (current-exception-handler handler))
+        thunk
+        (lambda () (current-exception-handler old)))))))
+
+(define (with-exception-handler handler thunk)
+  (letrec ((orig-handler (current-exception-handler))
+           (self (lambda (exn)
+                   (%with-exception-handler orig-handler
+                     (lambda ()
+                       (cond
+                        ((and (exception? exn)
+                              (eq? 'continuable (exception-kind exn)))
+                         (handler (exception-irritants exn)))
+                        (else
+                         (handler exn)
+                         (error "exception handler returned"))))))))
+    (%with-exception-handler self thunk)))
+
+(define-syntax protect
+  (syntax-rules ()
+    ((protect (var clause ...) e1 e2 ...)
+     (let ((orig-handler (current-exception-handler)))
+       (call-with-current-continuation
+        (lambda (protect-k)
+          (with-exception-handler
+           (lambda (condition)
+             (let ((var condition))  ; clauses may set! var
+               (protect-k
+                (protect-aux (raise-continuable condition) clause ...))))
+           (lambda () e1 e2 ...))))))))
+
+(define-syntax protect-aux
+  (syntax-rules (else =>)
+    ((protect-aux reraise (else result1 result2 ...))
+     (begin result1 result2 ...))
+    ((protect-aux reraise (test => result))
+     (let ((temp test))
+       (if temp (result temp) reraise)))
+    ((protect-aux reraise (test => result) clause1 clause2 ...)
+     (let ((temp test))
+       (if temp (result temp) (protect-aux reraise clause1 clause2 ...))))
+    ((protect-aux reraise (test))
+     (or test reraise))
+    ((protect-aux reraise (test) clause1 clause2 ...)
+     (or test (protect-aux reraise clause1 clause2 ...)))
+    ((protect-aux reraise (test result1 result2 ...))
+     (if test (begin result1 result2 ...) reraise))
+    ((protect-aux reraise (test result1 result2 ...) clause1 clause2 ...)
+     (if test
+         (begin result1 result2 ...)
+         (protect-aux reraise clause1 clause2 ...)))))
+
+;; Similar to unwind-protect, but allows escape via continuations
+;; assuming they'll return, whereas exceptions are assumed to not return.
+(define (with-exception-protect thunk final)
+  (let* ((finalized? #f)
+         (run-finalize
+          (lambda ()
+            (cond ((not finalized?)
+                   (set! finalized? #t)
+                   (final))))))
+    (protect (exn (else (run-finalize) (raise exn)))
+      (let ((res (thunk)))
+        (run-finalize)
+        res))))
+
+(define-syntax exception-protect
+  (syntax-rules ()
+    ((exception-protect expr final)
+     (with-exception-protect (lambda () expr)  (lambda () final)))))
+
+(define (eval x . o)
+  (let ((thunk (compile x (if (pair? o) (car o) (interaction-environment)))))
+    (if (procedure? thunk) (thunk) (raise thunk))))
+
+(define (load file . o)
+  (let* ((env (if (pair? o) (car o) (interaction-environment)))
+         (len (string-length file))
+         (ext *shared-object-extension*)
+         (ext-len (string-length ext)))
+    (cond
+     ((and (> len ext-len 0) (equal? ext (substring file (- len ext-len))))
+      (%load file env))
+     (else
+      (let ((old-env (current-environment)))
+        (dynamic-wind
+          (lambda () (set-current-environment! env))
+          (lambda ()
+            (call-with-input-file file
+              (lambda (in)
+                (set-port-line! in 1)
+                (let lp ()
+                  (let ((x (read in)))
+                    (cond
+                     ((not (eof-object? x))
+                      (eval x env)
+                      (lp))))))))
+          (lambda () (set-current-environment! old-env))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; promises
+
+(cond-expand
+ (auto-force
+  )
+ (else
+  (define (promise done? proc)
+    (list (cons done? proc)))
+  (define (promise-done? x) (car (car x)))
+  (define (promise-value x) (cdr (car x)))
+  (define (promise-update! new old)
+    (set-car! (car old) (promise-done? new))
+    (set-cdr! (car old) (promise-value new))
+    (set-car! new (car old)))
+  (define (force promise)
+    (if (promise-done? promise)
+        (promise-value promise)
+        (let ((promise* ((promise-value promise))))
+          (if (not (promise-done? promise))
+            (promise-update! promise* promise))
+          (force promise))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; math utils
+
+(cond-expand
+ (complex
+  (define (exact-complex? x)
+    (and (%complex? x) (exact? (complex-real x)) (exact? (complex-imag x)))))
+ (else
+  (define (exact-complex? x) #f)))
+
+(cond-expand
+ (ratios
+  (cond-expand
+   (complex
+    (define (exact? x)
+      (if (fixnum? x)
+          #t
+          (if (bignum? x) #t (if (ratio? x) #t (exact-complex? x))))))
+   (else
+    (define (exact? x) (if (fixnum? x) #t (if (bignum? x) #t (ratio? x))))))
+  (define (numerator x)
+    (if (ratio? x)
+        (ratio-numerator x)
+        (if (inexact? x)
+            (exact->inexact (numerator (inexact->exact x)))
+            x)))
+  (define (denominator x)
+    (if (exact? x)
+        (if (ratio? x) (ratio-denominator x) 1)
+        (if (integer? x)
+            1.0
+            (exact->inexact (denominator (inexact->exact x)))))))
+ (else
+  (cond-expand
+   (complex
+    (define (exact? x)
+      (if (fixnum? x) #t (if (bignum? x) #t (exact-complex? x)))))
+   (else
+    (define (exact? x) (if (fixnum? x) #t (bignum? x)))))
+  (define (numerator x)
+    (if (integer? x) x (numerator (* x 10))))
+  (define (denominator x)
+    (if (exact? x)
+        1
+        (let lp ((x x) (r 1.0)) (if (integer? x) r (lp (* x 10) (* r 10))))))))
+
+(cond-expand
+ (complex
+  (define (inexact? x)
+    (if (flonum? x) #t (and (%complex? x) (not (exact-complex? x))))))
+ (else (define inexact? flonum?)))
+(define (exact-integer? x) (if (fixnum? x) #t (bignum? x)))
+(define (integer? x)
+  (if (exact-integer? x) #t (and (flonum? x) (= x (truncate x)))))
+(define (number? x) (if (inexact? x) #t (exact? x)))
+(define complex? number?)
+(cond-expand
+ (complex (define (real? x) (and (number? x) (not (%complex? x)))))
+ (else (define real? number?)))
+(define (rational? x)
+  (and (real? x) (= x x) (not (= x (+ x (if (positive? x) 1 -1))))))
+
+(define (eqv? a b) (if (eq? a b) #t (and (number? a) (equal? a b))))
+
+(define (zero? x) (= x 0))
+(define (positive? x) (> x 0))
+(define (negative? x) (< x 0))
+(define (even? n) (= (remainder n 2) 0))
+(define (odd? n) (not (= (remainder n 2) 0)))
+
+(define (abs x) (if (< x 0) (- x) x))
+
+(define (modulo a b)
+  (let ((res (remainder a b)))
+    (if (< b 0)
+        (if (<= res 0) res (+ res b))
+        (if (>= res 0) res (+ res b)))))
+
+(define (gcd2 a b)
+  (if (= b 0)
+      (abs a)
+      (gcd b (remainder a b))))
+
+(define (gcd . args)
+  (if (null? args)
+      0
+      (let lp ((x (car args)) (ls (cdr args)))
+        (if (null? ls) x (lp (gcd2 x (car ls)) (cdr ls))))))
+
+(define (lcm2 a b)
+  (abs (quotient (* a b) (gcd a b))))
+
+(define (lcm . args)
+  (if (null? args)
+      1
+      (let lp ((x (car args)) (ls (cdr args)))
+        (if (null? ls) x (lp (lcm2 x (car ls)) (cdr ls))))))
+
+(define (max x . rest)
+  (define (~max hi ls)
+    (if (null? ls)
+        (exact->inexact hi)
+        (~max (if (> (car ls) hi) (car ls) hi) (cdr ls))))
+  (if (inexact? x)
+      (~max x rest)
+      (let lp ((hi x) (ls rest))
+        (cond ((null? ls) hi)
+              ((inexact? (car ls)) (~max hi ls))
+              (else (lp (if (> (car ls) hi) (car ls) hi) (cdr ls)))))))
+
+(define (min x . rest)
+  (define (~min lo ls)
+    (if (null? ls)
+        (exact->inexact lo)
+        (~min (if (< (car ls) lo) (car ls) lo) (cdr ls))))
+  (if (inexact? x)
+      (~min x rest)
+      (let lp ((lo x) (ls rest))
+        (cond ((null? ls) lo)
+              ((inexact? (car ls)) (~min lo ls))
+              (else (lp (if (< (car ls) lo) (car ls) lo) (cdr ls)))))))
+
+(cond-expand
+ (complex
+  (define (real-part z) (if (%complex? z) (complex-real z) z))
+  (define (imag-part z) (if (%complex? z) (complex-imag z) 0))
+  (define (magnitude z)
+    (sqrt (+ (* (real-part z) (real-part z))
+             (* (imag-part z) (imag-part z)))))
+  (define (angle z) (atan (imag-part z) (real-part z)))
+  (define (make-rectangular x y)
+    (+ x (* y (sqrt -1))))
+  (define (make-polar r phi)
+    (make-rectangular (* r (cos phi)) (* r (sin phi)))))
+ (else
+  (define (real-part z) z)
+  (define (imag-part z) 0.0)
+  (define magnitude abs)
+  (define (angle z) (if (< z 0) 3.141592653589793 0))))
+
+(define (log x . o)
+  (if (pair? o) (/ (ln x) (ln (car o))) (ln x)))
+
+(define (atan y . o)
+  (define (inf? z) (if (= +inf.0 z) #t (= -inf.0 z)))
+  (if (null? o)
+      (atan1 y)
+      (let ((x (exact->inexact (car o))))
+        (if (and (inf? x) (inf? y))
+            (* (if (< y 0) -1 1) (if (= x -inf.0) 3 1) 0.7853981633974483)
+            (if (negative? x)
+                (if (or (negative? y) (eqv? y -0.0))
+                    (- (atan1 (/ y x)) 3.141592653589793)
+                    (- 3.141592653589793 (atan1 (/ y (- x)))))
+                (if (and (zero? x) (zero? y))
+                    (* (if (eqv? y -0.0) -1 1)
+                       (if (eqv? x -0.0) 3.141592653589793 x))
+                    (atan1 (/ y x))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; string cursors
+
+(define string-cursor<? <)
+(define string-cursor<=? <=)
+(define string-cursor>? >)
+(define string-cursor>=? >=)
+(define string-cursor=? =)
+
+(define (string-cursor-start s) 0)
+
+(define (string-copy str . o)
+  (apply substring str (if (pair? o) o '(0))))
+
+(cond-expand
+ (full-unicode
+  (define string-cursor-end string-size))
+ (else
+  (define (string-index->offset str i) i)
+  (define (string-offset->index str off) off)
+  (define string-size string-length)
+  (define substring-cursor substring)
+  (define string-cursor-end string-length)
+  (define string-cursor-ref string-ref)
+  (define (string-cursor-next s i) (+ i 1))
+  (define (string-cursor-prev s i) (- i 1))))
diff --git a/lib/meta-7.scm b/lib/meta-7.scm
new file mode 100644
index 00000000..8b58a4c7
--- /dev/null
+++ b/lib/meta-7.scm
@@ -0,0 +1,412 @@
+;; meta.scm -- meta langauge for describing modules
+;; Copyright (c) 2009-2014 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; modules
+
+(define *this-module* '())
+(define *this-path* '())
+
+(define (make-module exports env meta) (vector exports env meta #f))
+(define (%module-exports mod) (vector-ref mod 0))
+(define (module-env mod) (vector-ref mod 1))
+(define (module-env-set! mod env) (vector-set! mod 1 env))
+(define (module-meta-data mod) (vector-ref mod 2))
+(define (module-meta-data-set! mod x) (vector-set! mod 2 x))
+
+(define (module-exports mod)
+  (or (%module-exports mod)
+      (if (module-env mod)
+          (env-exports (module-env mod))
+          '())))
+
+(define (module-name->strings ls res)
+  (if (null? ls)
+      res
+      (let ((str (cond ((symbol? (car ls)) (symbol->string (car ls)))
+                       ((number? (car ls)) (number->string (car ls)))
+                       ((string? (car ls)) (car ls))
+                       (else (error "invalid module name" (car ls))))))
+        (module-name->strings (cdr ls) (cons "/" (cons str res))))))
+
+(define (module-name->file name)
+  (string-concatenate
+   (reverse (cons ".sld" (cdr (module-name->strings name '()))))))
+
+(define (module-name-prefix name)
+  (string-concatenate (reverse (cdr (cdr (module-name->strings name '()))))))
+
+(define load-module-definition
+  (let ((meta-env (current-environment)))
+    (lambda (name)
+      (let* ((file (module-name->file name))
+             (path (find-module-file file)))
+        (if path (load path meta-env))))))
+
+(define (find-module name)
+  (cond
+   ((assoc name *modules*) => cdr)
+   (else
+    (load-module-definition name)
+    (cond ((assoc name *modules*) => cdr)
+          (else #f)))))
+
+(define (add-module! name module)
+  (set! *modules* (cons (cons name module) *modules*)))
+
+(define (delete-module! name)
+  (let lp ((ls *modules*) (prev #f))
+    (cond ((null? ls))
+          ((equal? name (car (car ls)))
+           (if prev
+               (set-cdr! prev (cdr ls))
+               (set! *modules* (cdr ls))))
+          (else (lp (cdr ls) ls)))))
+
+(define (symbol-append a b)
+  (string->symbol (string-append (symbol->string a) (symbol->string b))))
+
+(define (symbol-drop a b)
+  (let ((as (symbol->string a))
+        (bs (symbol->string b)))
+    (if (and (> (string-length bs) (string-length as))
+             (string=? as (substring bs 0 (string-length as))))
+        (string->symbol (substring bs (string-length as)))
+        b)))
+
+(define (warn msg . args)
+  (display msg (current-error-port))
+  (display ":" (current-error-port))
+  (for-each (lambda (a)
+              (display " " (current-error-port))
+              (write a (current-error-port)))
+            args)
+  (newline (current-error-port)))
+
+(define (to-id id) (if (pair? id) (car id) id))
+(define (from-id id) (if (pair? id) (cdr id) id))
+(define (id-filter pred ls)
+  (cond ((null? ls) '())
+        ((pred (to-id (car ls))) (cons (car ls) (id-filter pred (cdr ls))))
+        (else (id-filter pred (cdr ls)))))
+
+(define (resolve-import x)
+  (cond
+   ((not (and (pair? x) (list? x)))
+    (error "invalid module syntax" x))
+   ((and (memq (car x) '(prefix drop-prefix))
+         (symbol? (car (cddr x))) (list? (cadr x)))
+    (let ((mod-name+imports (resolve-import (cadr x))))
+      (cons (car mod-name+imports)
+            (map (lambda (i)
+                   (cons ((if (eq? (car x) 'drop-prefix)
+                              symbol-drop
+                              symbol-append)
+                          (car (cddr x))
+                          (to-id i))
+                         (from-id i)))
+                 (or (cdr mod-name+imports)
+                     (module-exports (find-module (car mod-name+imports))))))))
+   ((and (pair? (cdr x)) (pair? (cadr x)))
+    (if (memq (car x) '(only except rename))
+        (let* ((mod-name+imports (resolve-import (cadr x)))
+               (imp-ids (or (cdr mod-name+imports)
+                            (and (not (eq? 'only (car x)))
+                                 (module-exports
+                                  (find-module (car mod-name+imports)))))))
+          ;; (if (not (eq? 'only (car x)))
+          ;;     (let ((unbound
+          ;;            (id-filter (lambda (i) (not (memq i imp-ids))) (cddr x))))
+          ;;       (if (pair? unbound)
+          ;;           (warn "import excepting unbound identifiers" unbound))))
+          (cons (car mod-name+imports)
+                (case (car x)
+                  ((only)
+                   (cddr x))
+                  ((except)
+                   (id-filter (lambda (i) (not (memq i (cddr x)))) imp-ids))
+                  ((rename)
+                   (map (lambda (i)
+                          (let ((rename (assq (to-id i) (cddr x))))
+                            (if rename (cons (cadr rename) (from-id i)) i)))
+                        imp-ids)))))
+        (error "invalid import modifier" x)))
+   ((find-module x)
+    => (lambda (mod) (cons x (%module-exports mod))))
+   (else
+    (error "couldn't find import" x))))
+
+(define (eval-module name mod . o)
+  (let ((env (if (pair? o) (car o) (make-environment)))
+        (meta (module-meta-data mod))
+        (dir (module-name-prefix name)))
+    (define (load-modules files extension fold?)
+      (for-each
+       (lambda (f)
+         (let ((f (string-append dir f extension)))
+           (cond
+            ((find-module-file f)
+             => (lambda (path)
+                  (cond (fold?
+                         (let ((in (open-input-file path)))
+                           (set-port-fold-case! in #t)
+                           (load in env)))
+                        (else
+                         (load path env)))))
+            (else (error "couldn't find include" f)))))
+       files))
+    ;; catch cyclic references
+    (cond
+     ((procedure? meta)
+      (meta env))
+     (else
+      (module-meta-data-set!
+       mod
+       `((error "module attempted to reference itself while loading" ,name)))
+      (for-each
+       (lambda (x)
+         (case (and (pair? x) (car x))
+           ((import import-immutable)
+            (for-each
+             (lambda (m)
+               (let* ((mod2-name+imports (resolve-import m))
+                      (mod2 (load-module (car mod2-name+imports))))
+                 (%import env (module-env mod2) (cdr mod2-name+imports) #t)))
+             (cdr x)))))
+       meta)
+      (protect
+          (exn (else
+                (module-meta-data-set! mod meta)
+                (if (not (any (lambda (x)
+                                (and (pair? x)
+                                     (memq (car x) '(import import-immutable))))
+                              meta))
+                    (warn "WARNING: exception inside module with no imports - did you forget to (import (scheme base)) in" name))
+                (raise-continuable exn)))
+        (for-each
+         (lambda (x)
+           (case (and (pair? x) (car x))
+             ((include)
+              (load-modules (cdr x) "" #f))
+             ((include-ci)
+              (load-modules (cdr x) "" #t))
+             ((include-shared)
+              (load-modules (cdr x) *shared-object-extension* #f))
+             ((body begin)
+              (for-each (lambda (expr) (eval expr env)) (cdr x)))
+             ((error)
+              (apply error (cdr x)))))
+         meta))
+      (module-meta-data-set! mod meta)
+      (warn-undefs env #f)
+      env))))
+
+(define (environment . ls)
+  (let ((env (make-environment)))
+    (for-each
+     (lambda (m)
+       (let* ((mod2-name+imports (resolve-import m))
+              (mod2 (load-module (car mod2-name+imports))))
+         (%import env (module-env mod2) (cdr mod2-name+imports) #t)))
+     ls)
+    env))
+
+(define (load-module name)
+  (let ((mod (find-module name)))
+    (if (and mod (not (module-env mod)))
+        (module-env-set! mod (eval-module name mod)))
+    mod))
+
+(define-syntax meta-begin begin)
+(define-syntax meta-define define)
+
+(define define-library-transformer
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let ((name (cadr expr))
+           (body (cddr expr))
+           (tmp (rename 'tmp))
+           (this-module (rename '*this-module*))
+           (add-module! (rename 'add-module!))
+           (_make-module (rename 'make-module))
+           (_define (rename 'meta-define))
+           (_lambda (rename 'lambda))
+           (_let (rename 'let))
+           (_map (rename 'map))
+           (_if (rename 'if))
+           (_cond (rename 'cond))
+           (_set! (rename 'set!))
+           (_quote (rename 'quote))
+           (_and (rename 'and))
+           (_= (rename '=))
+           (_eq? (rename 'eq?))
+           (_pair? (rename 'pair?))
+           (_null? (rename 'null?))
+           (_reverse (rename 'reverse))
+           (_append (rename 'append))
+           (_assq (rename 'assq))
+           (_=> (rename '=>))
+           (_else (rename 'else))
+           (_length (rename 'length))
+           (_identifier->symbol (rename 'identifier->symbol))
+           (_error (rename 'error))
+           (_cons (rename 'cons))
+           (_car (rename 'car))
+           (_cdr (rename 'cdr))
+           (_caar (rename 'caar))
+           (_cadr (rename 'cadr))
+           (_cdar (rename 'cdar))
+           (_cddr (rename 'cddr)))
+       ;; Check for suspicious defines.
+       (for-each
+        (lambda (x)
+          (if (and (pair? x) (memq (strip-syntactic-closures (car x))
+                                   '(define define-syntax)))
+              (warn "suspicious use of define in library declarations - did you forget to wrap it in begin?" x)))
+        (cdr expr))
+       ;; Generate the library wrapper.
+       (set! *this-path*
+             (cons (string-concatenate
+                    (module-name->strings (cdr (reverse name)) '()))
+                   *this-path*))
+       `(,_let ((,tmp ,this-module))
+          (,_define (rewrite-export x)
+            (,_if (,_pair? x)
+                (,_if (,_and (,_= 3 (,_length x))
+                             (,_eq? (,_quote rename)
+                                    (,_identifier->symbol (,_car x))))
+                    (,_cons (,_car (,_cddr x)) (,_cadr x))
+                    (,_error "invalid module export" x))
+                x))
+          (,_define (extract-exports)
+            (,_cond
+             ((,_assq (,_quote export-all) ,this-module)
+              ,_=> (,_lambda (x)
+                     (,_if (,_pair? (,_cdr x))
+                         (,_error "export-all takes no parameters" x))
+                     #f))
+             (,_else
+              (,_let lp ((ls ,this-module) (res (,_quote ())))
+                (,_cond
+                 ((,_null? ls) res)
+                 ((,_and (,_pair? (,_car ls))
+                         (,_eq? (,_quote export) (,_caar ls)))
+                  (lp (,_cdr ls)
+                      (,_append (,_map rewrite-export (,_cdar ls)) res)))
+                 (,_else (lp (,_cdr ls) res)))))))
+          (,_set! ,this-module (,_quote ()))
+          ,@body
+          (,add-module! (,_quote ,name)
+                        (,_make-module (extract-exports)
+                                       #f
+                                       (,_reverse ,this-module)))
+          (,_set! ,this-module ,tmp)
+          (,(rename 'pop-this-path)))))))
+
+(define-syntax define-library define-library-transformer)
+(define-syntax module define-library-transformer)
+
+(define-syntax pop-this-path
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (if (pair? *this-path*)
+         (set! *this-path* (cdr *this-path*)))
+     #f)))
+
+(define-syntax include-library-declarations
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let lp1 ((ls (cdr expr)) (res '()))
+       (cond
+        ((pair? ls)
+         (let* ((file (car ls))
+                (rel-path (if (pair? *this-path*)
+                              (string-append (car *this-path*) "/" file)
+                              file)))
+           (cond
+            ((find-module-file rel-path)
+             => (lambda (path)
+                  (call-with-input-file path
+                    (lambda (in)
+                      (let lp2 ((res res))
+                        (let ((x (read in)))
+                          (if (eof-object? x)
+                              (lp1 (cdr ls) res)
+                              (lp2 (cons x res)))))))))
+            (else
+             (error "couldn't find include-library-declarations file" file)))))
+        (else
+         `(,(rename 'meta-begin)
+           ,@(reverse res)
+           (,(rename 'set!) ,(rename '*this-module*)
+            (,(rename 'cons) (,(rename 'quote)
+                              ,(cons 'include-library-declarations (cdr expr)))
+             ,(rename '*this-module*))))))))))
+
+(define-syntax define-meta-primitive
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let ((name (cadr expr)))
+       `(define-syntax ,name
+          (er-macro-transformer
+           (lambda (expr rename compare)
+             (let ((this-module (rename '*this-module*))
+                   (_set! (rename 'set!))
+                   (_cons (rename 'cons))
+                   (_quote (rename 'syntax-quote)))
+               `(,_set! ,this-module
+                        (,_cons (,_quote ,(cons ',name (cdr expr)))
+                                ,this-module))))))))))
+
+(define-meta-primitive import)
+(define-meta-primitive import-immutable)
+(define-meta-primitive export)
+(define-meta-primitive export-all)
+(define-meta-primitive include)
+(define-meta-primitive include-ci)
+(define-meta-primitive include-shared)
+(define-meta-primitive body)
+(define-meta-primitive begin)
+
+;; The `import' binding used by (chibi) and (scheme base), etc.
+(define-syntax repl-import
+  (er-macro-transformer
+   (let ((meta-env (current-environment)))
+     (lambda (expr rename compare)
+       (let lp ((ls (cdr expr)) (res '()))
+         (cond
+          ((null? ls)
+           (cons (rename 'meta-begin) (reverse res)))
+          (else
+           (let ((mod+imps (resolve-import (car ls))))
+             (cond
+              ((pair? mod+imps)
+               (lp (cdr ls)
+                   (cons `(,(rename '%import)
+                           #f
+                           (,(rename 'module-env)
+                            (,(rename 'load-module)
+                             (,(rename 'quote) ,(car mod+imps))))
+                           (,(rename 'quote) ,(cdr mod+imps))
+                           #f)
+                         res)))
+              (else
+               (error "couldn't find module" (car ls))))))))))))
+
+(define *modules*
+  (list
+   (cons '(chibi)
+         ;; capture a static copy of the current environment to serve
+         ;; as the (chibi) module
+         (let ((env (make-environment)))
+           (%import env (interaction-environment) #f #t)
+           (make-module #f (env-parent env) '((include "init-7.scm")))))
+   (cons '(chibi primitive)
+         (make-module #f #f (lambda (env) (primitive-environment 7))))
+   (cons '(meta)
+         (make-module #f (current-environment) '()))
+   (cons '(srfi 0)
+         (make-module (list 'cond-expand)
+                      (current-environment)
+                      (list (list 'export 'cond-expand))))))
diff --git a/lib/scheme/base.sld b/lib/scheme/base.sld
new file mode 100644
index 00000000..9046c826
--- /dev/null
+++ b/lib/scheme/base.sld
@@ -0,0 +1,59 @@
+
+(define-library (scheme base)
+  (import (except (chibi) equal?)
+          (rename (chibi equiv) (equiv? equal?))
+          (only (chibi string) string-map string-for-each)
+          (chibi io)
+          (rename (only (chibi ast)
+                        exception? exception-message exception-irritants)
+                  (exception? error-object?)
+                  (exception-message error-object-message)
+                  (exception-irritants error-object-irritants))
+          (srfi 9) (srfi 11) (srfi 39))
+  (export
+   * + - ... / < <= = => > >= _ abs and append apply assoc assq assv begin
+   binary-port?  boolean?  boolean=?  bytevector bytevector-append
+   bytevector-copy bytevector-copy! bytevector-length
+   bytevector-u8-ref bytevector-u8-set!  bytevector?  caar cadr
+   call-with-current-continuation call-with-port call-with-values
+   call/cc car case cdr cdar cddr ceiling char->integer
+   char-ready? char<=?  char<?  char=?  char>=?  char>?  char?
+   close-input-port close-output-port close-port complex?  cond cond-expand
+   cons current-error-port current-input-port current-output-port define
+   define-record-type define-syntax define-values denominator do
+   dynamic-wind else eof-object? eof-object  eq?  equal?  eqv?  error
+   error-object-irritants error-object-message error-object?  even?
+   exact exact-integer-sqrt exact-integer?  exact?  expt features
+   file-error? floor
+   flush-output-port for-each gcd get-output-bytevector get-output-string
+   guard if include include-ci inexact inexact?  input-port?
+   integer->char
+   integer?  lambda lcm length let let* let*-values let-syntax let-values
+   letrec letrec* letrec-syntax list list->string list->vector list-copy
+   list-ref list-set!  list-tail list?  make-bytevector make-list
+   make-parameter make-string make-vector map max member memq memv min
+   modulo negative?  newline not null?  number->string number?  numerator
+   odd?  open-input-bytevector open-input-string open-output-bytevector
+   open-output-string or output-port?  pair?  parameterize peek-char
+   peek-u8 input-port-open? output-port-open?  port?  positive?
+   procedure?  quasiquote quote
+   quotient raise raise-continuable rational?  rationalize read-bytevector
+   read-bytevector!  read-char read-error? read-line read-string read-u8
+   real?  remainder
+   reverse round set!  set-car!  set-cdr!  square string string->list
+   string->number string->symbol string->utf8 string->vector string-append
+   string-copy string-copy! string-fill!  string-for-each string-length
+   string-map
+   string-ref string-set!  string<=?  string<?  string=?  string>=?
+   string>?  string?  substring symbol->string symbol?  symbol=?  syntax-error
+   syntax-rules textual-port?  truncate u8-ready?  unless unquote
+   unquote-splicing utf8->string values vector vector-append
+   vector->list vector->string
+   vector-copy vector-copy! vector-fill!  vector-for-each vector-length
+   vector-map vector-ref vector-set!  vector?  when with-exception-handler
+   write-bytevector write-char write-string write-u8 zero?
+   truncate-quotient truncate-remainder truncate/
+   floor-quotient floor-remainder floor/)
+  (include "define-values.scm"
+           "extras.scm"
+           "misc-macros.scm"))
diff --git a/lib/scheme/case-lambda.sld b/lib/scheme/case-lambda.sld
new file mode 100644
index 00000000..d102db87
--- /dev/null
+++ b/lib/scheme/case-lambda.sld
@@ -0,0 +1,4 @@
+
+(define-library (scheme case-lambda)
+  (import (srfi 16))
+  (export case-lambda))
diff --git a/lib/scheme/char.sld b/lib/scheme/char.sld
new file mode 100644
index 00000000..2da5c423
--- /dev/null
+++ b/lib/scheme/char.sld
@@ -0,0 +1,28 @@
+
+(define-library (scheme char)
+  (import (scheme base))
+  (cond-expand
+   (full-unicode
+    (import (scheme write)
+            (chibi char-set full)
+            (chibi char-set base)
+            (chibi iset base))
+    (include "char/full.scm")
+    (include "char/special-casing.scm")
+    (include "char/case-offsets.scm"))
+   (else
+    (include "char/ascii.scm")
+    (import
+     (only (chibi)
+           string-ci<=? string-ci<? string-ci=? string-ci>=? string-ci>?
+           char-ci<=? char-ci<? char-ci=? char-ci>=? char-ci>?
+           char-alphabetic?  char-lower-case? char-numeric?
+           char-upper-case? char-whitespace? digit-value
+           char-upcase char-downcase))))
+  (include "digit-value.scm")
+  (export
+   char-alphabetic? char-ci<=? char-ci<? char-ci=? char-ci>=? char-ci>?
+   char-downcase char-foldcase char-lower-case? char-numeric?
+   char-upcase char-upper-case? char-whitespace? digit-value
+   string-ci<=? string-ci<? string-ci=? string-ci>=? string-ci>?
+   string-downcase string-foldcase string-upcase))
diff --git a/lib/scheme/char/ascii.scm b/lib/scheme/char/ascii.scm
new file mode 100644
index 00000000..aa687288
--- /dev/null
+++ b/lib/scheme/char/ascii.scm
@@ -0,0 +1,11 @@
+
+(define char-foldcase char-downcase)
+
+(define (string-downcase str)
+  (string-map char-downcase str))
+
+(define (string-upcase str)
+  (string-map char-upcase str))
+
+(define (string-foldcase str)
+  (string-map char-foldcase str))
diff --git a/lib/scheme/char/case-offsets.scm b/lib/scheme/char/case-offsets.scm
new file mode 100644
index 00000000..1e202878
--- /dev/null
+++ b/lib/scheme/char/case-offsets.scm
@@ -0,0 +1,5 @@
+(define char-downcase-offsets (list (cons (%make-iset 8579 8579 #f (%make-iset 880 1318 727785128884533462021393239927996327852405488163715491688443665188997571489595753887351274307852390522542297450010406753856251110621253 (%make-iset 256 590 46622255956467149554182616418411281498693699703261745055828801286035997868185593113689917615708132693 #f #f) (%make-iset 7680 7934 154389452316421593898094646677763852341147247234746543203694500835710989587797 #f #f)) (%make-iset 42560 42646 340282366921041625127166164553021347157 (%make-iset 11360 11506 6277101735386773453122860106355103562402757378851211577985 #f #f) (%make-iset 42786 42920 6277101735386680792844867735842886829046547597890503906645 #f #f))) 1) (cons (%make-iset 913 1071 6277101736117431582331099698849039600728809650576250765311 (%make-iset 65 222 6277101735750628925305668009417060106580289400525817905151 #f #f) (%make-iset 65313 65338 #f #f #f)) 32) (cons (%make-iset 11264 11310 #f (%make-iset 1329 1366 #f #f #f) #f) 48) (cons (%make-iset 7944 8169 80881074129870197631446573842447034610982086425645202976396910985471 #f #f) -8) (cons (%make-iset 9398 9423 #f #f #f) 26) (cons (%make-iset 4256 4301 36009005809663 #f #f) 7264) (cons (%make-iset 66560 66599 #f #f #f) 40)))
+
+(define char-downcase-map (quote #(181 956 376 255 383 115 385 595 390 596 393 598 394 599 398 477 399 601 400 603 403 608 404 611 406 617 407 616 412 623 413 626 415 629 422 640 425 643 430 648 433 650 434 651 439 658 452 454 455 457 458 460 497 499 502 405 503 447 544 414 570 11365 573 410 574 11366 579 384 580 649 581 652 837 953 902 940 904 941 905 942 906 943 908 972 910 973 911 974 975 983 976 946 977 952 981 966 982 960 1008 954 1009 961 1012 952 1013 949 1017 1010 1021 891 1022 892 1023 893 1024 1104 1025 1105 1026 1106 1027 1107 1028 1108 1029 1109 1030 1110 1031 1111 1032 1112 1033 1113 1034 1114 1035 1115 1036 1116 1037 1117 1038 1118 1039 1119 1216 1231 7835 7777 8122 8048 8123 8049 8126 953 8136 8050 8137 8051 8138 8052 8139 8053 8154 8054 8155 8055 8170 8058 8171 8059 8172 8165 8184 8056 8185 8057 8186 8060 8187 8061 8486 969 8490 107 8491 229 8498 8526 8544 8560 8545 8561 8546 8562 8547 8563 8548 8564 8549 8565 8550 8566 8551 8567 8552 8568 8553 8569 8554 8570 8555 8571 8556 8572 8557 8573 8558 8574 8559 8575 11362 619 11363 7549 11364 637 11373 593 11374 625 11375 592 11376 594 11390 575 11391 576 42877 7545 42893 613 42922 614)))
+
+(define char-upcase-map (quote #(107 8490 115 383 229 8491 255 376 384 579 405 502 410 573 414 544 447 503 454 452 457 455 460 458 477 398 499 497 575 11390 576 11391 592 11375 593 11373 594 11376 595 385 596 390 598 393 599 394 601 399 603 400 608 403 611 404 613 42893 614 42922 616 407 617 406 619 11362 623 412 625 11374 626 413 629 415 637 11364 640 422 643 425 648 430 649 580 650 433 651 434 652 581 658 439 891 1021 892 1022 893 1023 940 902 941 904 942 905 943 906 946 976 949 1013 1010 1017 952 1012 952 977 953 837 953 8126 954 1008 956 181 960 982 961 1009 966 981 969 8486 972 908 973 910 974 911 983 975 1104 1024 1105 1025 1106 1026 1107 1027 1108 1028 1109 1029 1110 1030 1111 1031 1112 1032 1113 1033 1114 1034 1115 1035 1116 1036 1117 1037 1118 1038 1119 1039 1231 1216 7545 42877 7549 11363 7777 7835 8048 8122 8049 8123 8050 8136 8051 8137 8052 8138 8053 8139 8054 8154 8055 8155 8056 8184 8057 8185 8058 8170 8059 8171 8060 8186 8061 8187 8165 8172 8526 8498 8560 8544 8561 8545 8562 8546 8563 8547 8564 8548 8565 8549 8566 8550 8567 8551 8568 8552 8569 8553 8570 8554 8571 8555 8572 8556 8573 8557 8574 8558 8575 8559 11365 570 11366 574)))
diff --git a/lib/scheme/char/full.scm b/lib/scheme/char/full.scm
new file mode 100644
index 00000000..4f994ea6
--- /dev/null
+++ b/lib/scheme/char/full.scm
@@ -0,0 +1,125 @@
+
+(define (char-alphabetic? ch) (char-set-contains? char-set:letter ch))
+(define (char-lower-case? ch) (char-set-contains? char-set:lower-case ch))
+(define (char-upper-case? ch) (char-set-contains? char-set:upper-case ch))
+(define (char-numeric? ch) (char-set-contains? char-set:digit ch))
+(define (char-whitespace? ch) (char-set-contains? char-set:whitespace ch))
+
+(define (char-downcase ch)
+  (let ((n (char->integer ch)))
+    (let lp ((ls char-downcase-offsets))
+      (cond
+       ((null? ls)
+        (let lp ((lo 0) (hi (vector-length char-downcase-map)))
+          (if (> lo hi)
+              ch
+              (let* ((mid (+ lo (* (quotient (- hi lo) 4) 2)))
+                     (m (vector-ref char-downcase-map mid)))
+                (cond
+                 ((= n m)
+                  (integer->char (vector-ref char-downcase-map (+ mid 1))))
+                 ((< n m)
+                  (lp lo (- mid 2)))
+                 (else
+                  (lp (+ mid 2) hi)))))))
+       ((iset-contains? (caar ls) n)
+        (integer->char (+ n (cdar ls))))
+       (else (lp (cdr ls)))))))
+
+(define char-foldcase char-downcase)
+
+(define (char-upcase ch)
+  (let ((n (char->integer ch)))
+    (let lp ((ls char-downcase-offsets))
+      (cond
+       ((null? ls)
+        (let lp ((lo 0) (hi (vector-length char-upcase-map)))
+          (if (> lo hi)
+              ch
+              (let* ((mid (+ lo (* (quotient (- hi lo) 4) 2)))
+                     (m (vector-ref char-upcase-map mid)))
+                (cond
+                 ((= n m)
+                  (integer->char (vector-ref char-upcase-map (+ mid 1))))
+                 ((< n m)
+                  (lp lo (- mid 2)))
+                 (else
+                  (lp (+ mid 2) hi)))))))
+       ((iset-contains? (caar ls) (- n (cdar ls)))
+        (integer->char (- n (cdar ls))))
+       (else (lp (cdr ls)))))))
+
+(define (char-cmp-ci op a ls)
+  (let lp ((op op) (a (char->integer (char-foldcase a))) (ls ls))
+    (if (null? ls)
+        #t
+        (let ((b (char->integer (char-downcase (car ls)))))
+          (and (op a b) (lp op b (cdr ls)))))))
+
+(define (char-ci=? a . ls) (char-cmp-ci = a ls))
+(define (char-ci<? a . ls) (char-cmp-ci < a ls))
+(define (char-ci>? a . ls) (char-cmp-ci > a ls))
+(define (char-ci<=? a . ls) (char-cmp-ci <= a ls))
+(define (char-ci>=? a . ls) (char-cmp-ci >= a ls))
+
+(define (char-get-special-case ch off)
+  (let ((i (char->integer ch)))
+    (let lp ((a 0) (b (vector-length special-cases)))
+      (let* ((mid (+ a (quotient (- b a) 2)))
+             (vec (vector-ref special-cases mid))
+             (val (vector-ref vec 0)))
+        (cond ((< i val) (and (< mid b) (lp a mid)))
+              ((> i val) (and (> mid a) (lp mid b)))
+              (else (vector-ref vec off)))))))
+
+(define (call-with-output-string proc)
+  (let ((out (open-output-string)))
+    (proc out)
+    (get-output-string out)))
+
+(define (string-down-or-fold-case str fold?)
+  (call-with-output-string
+    (lambda (out)
+      (let ((in (open-input-string str)))
+        (let lp ()
+          (let ((ch (read-char in)))
+            (cond
+             ((not (eof-object? ch))
+              (display
+               (if (and (not fold?) (eqv? ch #\x03A3))
+                   (let ((ch2 (peek-char in)))
+                     (if (or (eof-object? ch2)
+                             (not (char-set-contains? char-set:letter ch2)))
+                         #\x03C2
+                         #\x03C3))
+                   (or (char-get-special-case ch 1) (char-downcase ch)))
+               out)
+              (lp)))))))))
+
+(define (string-downcase str) (string-down-or-fold-case str #f))
+(define (string-foldcase str) (string-down-or-fold-case str #t))
+
+(define (string-upcase str)
+  (call-with-output-string
+    (lambda (out)
+      (string-for-each
+       (lambda (ch)
+         (display (if (memv ch '(#\x03C2 #\x03C3))
+                      #\x03A3
+                      (or (char-get-special-case ch 3)
+                          (char-upcase ch)))
+                  out))
+       str))))
+
+(define (string-cmp-ci op a ls)
+  (let lp ((op op) (a (string-foldcase a)) (ls ls))
+    (if (null? ls)
+        #t
+        (let ((b (string-foldcase (car ls))))
+          (and (op a b) (lp op b (cdr ls)))))))
+
+(define (string-ci=? a . ls) (string-cmp-ci string=? a ls))
+(define (string-ci<? a . ls) (string-cmp-ci string<? a ls))
+(define (string-ci>? a . ls) (string-cmp-ci string>? a ls))
+(define (string-ci<=? a . ls) (string-cmp-ci string<=? a ls))
+(define (string-ci>=? a . ls) (string-cmp-ci string>=? a ls))
diff --git a/lib/scheme/char/normalization.sld b/lib/scheme/char/normalization.sld
new file mode 100644
index 00000000..1c0ef73c
--- /dev/null
+++ b/lib/scheme/char/normalization.sld
@@ -0,0 +1,11 @@
+;; This library is deprecated, occurring in early R7RS drafts before
+;; being removed.
+
+(define-library (scheme char normalization)
+  (import (rename (chibi)
+                  (string=? string-ni=?)
+                  (string<? string-ni<?)
+                  (string>? string-ni>?)
+                  (string<=? string-ni<=?)
+                  (string>=? string-ni>=?)))
+  (export string-ni=? string-ni<? string-ni>? string-ni<=? string-ni>=?))
diff --git a/lib/scheme/char/special-casing.scm b/lib/scheme/char/special-casing.scm
new file mode 100644
index 00000000..83b32623
--- /dev/null
+++ b/lib/scheme/char/special-casing.scm
@@ -0,0 +1,109 @@
+
+;; Unconditoinal non-1-to-1 case mappings derived from Unicode data
+;; file SpecialCasing.txt.
+
+(define special-cases
+  ;; <code> <lower> <title> <upper>
+  #(#(223 "ß" "Ss" "SS")
+    #(304 "i̇" "İ" "İ")
+    #(329 "ʼn" "ʼN" "ʼN")
+    #(496 "ǰ" "J̌" "J̌")
+    #(912 "ΐ" "Ϊ́" "Ϊ́")
+    #(944 "ΰ" "Ϋ́" "Ϋ́")
+    #(1415 "և" "Եւ" "ԵՒ")
+    #(7830 "ẖ" "H̱" "H̱")
+    #(7831 "ẗ" "T̈" "T̈")
+    #(7832 "ẘ" "W̊" "W̊")
+    #(7833 "ẙ" "Y̊" "Y̊")
+    #(7834 "ẚ" "Aʾ" "Aʾ")
+    #(8016 "ὐ" "Υ̓" "Υ̓")
+    #(8018 "ὒ" "Υ̓̀" "Υ̓̀")
+    #(8020 "ὔ" "Υ̓́" "Υ̓́")
+    #(8022 "ὖ" "Υ̓͂" "Υ̓͂")
+    #(8064 "ᾀ" "ᾈ" "ἈΙ")
+    #(8065 "ᾁ" "ᾉ" "ἉΙ")
+    #(8066 "ᾂ" "ᾊ" "ἊΙ")
+    #(8067 "ᾃ" "ᾋ" "ἋΙ")
+    #(8068 "ᾄ" "ᾌ" "ἌΙ")
+    #(8069 "ᾅ" "ᾍ" "ἍΙ")
+    #(8070 "ᾆ" "ᾎ" "ἎΙ")
+    #(8071 "ᾇ" "ᾏ" "ἏΙ")
+    #(8072 "ᾀ" "ᾈ" "ἈΙ")
+    #(8073 "ᾁ" "ᾉ" "ἉΙ")
+    #(8074 "ᾂ" "ᾊ" "ἊΙ")
+    #(8075 "ᾃ" "ᾋ" "ἋΙ")
+    #(8076 "ᾄ" "ᾌ" "ἌΙ")
+    #(8077 "ᾅ" "ᾍ" "ἍΙ")
+    #(8078 "ᾆ" "ᾎ" "ἎΙ")
+    #(8079 "ᾇ" "ᾏ" "ἏΙ")
+    #(8080 "ᾐ" "ᾘ" "ἨΙ")
+    #(8081 "ᾑ" "ᾙ" "ἩΙ")
+    #(8082 "ᾒ" "ᾚ" "ἪΙ")
+    #(8083 "ᾓ" "ᾛ" "ἫΙ")
+    #(8084 "ᾔ" "ᾜ" "ἬΙ")
+    #(8085 "ᾕ" "ᾝ" "ἭΙ")
+    #(8086 "ᾖ" "ᾞ" "ἮΙ")
+    #(8087 "ᾗ" "ᾟ" "ἯΙ")
+    #(8088 "ᾐ" "ᾘ" "ἨΙ")
+    #(8089 "ᾑ" "ᾙ" "ἩΙ")
+    #(8090 "ᾒ" "ᾚ" "ἪΙ")
+    #(8091 "ᾓ" "ᾛ" "ἫΙ")
+    #(8092 "ᾔ" "ᾜ" "ἬΙ")
+    #(8093 "ᾕ" "ᾝ" "ἭΙ")
+    #(8094 "ᾖ" "ᾞ" "ἮΙ")
+    #(8095 "ᾗ" "ᾟ" "ἯΙ")
+    #(8096 "ᾠ" "ᾨ" "ὨΙ")
+    #(8097 "ᾡ" "ᾩ" "ὩΙ")
+    #(8098 "ᾢ" "ᾪ" "ὪΙ")
+    #(8099 "ᾣ" "ᾫ" "ὫΙ")
+    #(8100 "ᾤ" "ᾬ" "ὬΙ")
+    #(8101 "ᾥ" "ᾭ" "ὭΙ")
+    #(8102 "ᾦ" "ᾮ" "ὮΙ")
+    #(8103 "ᾧ" "ᾯ" "ὯΙ")
+    #(8104 "ᾠ" "ᾨ" "ὨΙ")
+    #(8105 "ᾡ" "ᾩ" "ὩΙ")
+    #(8106 "ᾢ" "ᾪ" "ὪΙ")
+    #(8107 "ᾣ" "ᾫ" "ὫΙ")
+    #(8108 "ᾤ" "ᾬ" "ὬΙ")
+    #(8109 "ᾥ" "ᾭ" "ὭΙ")
+    #(8110 "ᾦ" "ᾮ" "ὮΙ")
+    #(8111 "ᾧ" "ᾯ" "ὯΙ")
+    #(8114 "ᾲ" "Ὰͅ" "ᾺΙ")
+    #(8115 "ᾳ" "ᾼ" "ΑΙ")
+    #(8116 "ᾴ" "Άͅ" "ΆΙ")
+    #(8118 "ᾶ" "Α͂" "Α͂")
+    #(8119 "ᾷ" "ᾼ͂" "Α͂Ι")
+    #(8124 "ᾳ" "ᾼ" "ΑΙ")
+    #(8130 "ῂ" "Ὴͅ" "ῊΙ")
+    #(8131 "ῃ" "ῌ" "ΗΙ")
+    #(8132 "ῄ" "Ήͅ" "ΉΙ")
+    #(8134 "ῆ" "Η͂" "Η͂")
+    #(8135 "ῇ" "ῌ͂" "Η͂Ι")
+    #(8140 "ῃ" "ῌ" "ΗΙ")
+    #(8146 "ῒ" "Ϊ̀" "Ϊ̀")
+    #(8147 "ΐ" "Ϊ́" "Ϊ́")
+    #(8150 "ῖ" "Ι͂" "Ι͂")
+    #(8151 "ῗ" "Ϊ͂" "Ϊ͂")
+    #(8162 "ῢ" "Ϋ̀" "Ϋ̀")
+    #(8163 "ΰ" "Ϋ́" "Ϋ́")
+    #(8164 "ῤ" "Ρ̓" "Ρ̓")
+    #(8166 "ῦ" "Υ͂" "Υ͂")
+    #(8167 "ῧ" "Ϋ͂" "Ϋ͂")
+    #(8178 "ῲ" "Ὼͅ" "ῺΙ")
+    #(8179 "ῳ" "ῼ" "ΩΙ")
+    #(8180 "ῴ" "Ώͅ" "ΏΙ")
+    #(8182 "ῶ" "Ω͂" "Ω͂")
+    #(8183 "ῷ" "ῼ͂" "Ω͂Ι")
+    #(8188 "ῳ" "ῼ" "ΩΙ")
+    #(64256 "ff" "Ff" "FF")
+    #(64257 "fi" "Fi" "FI")
+    #(64258 "fl" "Fl" "FL")
+    #(64259 "ffi" "Ffi" "FFI")
+    #(64260 "ffl" "Ffl" "FFL")
+    #(64261 "ſt" "St" "ST")
+    #(64262 "st" "St" "ST")
+    #(64275 "ﬓ" "Մն" "ՄՆ")
+    #(64276 "ﬔ" "Մե" "ՄԵ")
+    #(64277 "ﬕ" "Մի" "ՄԻ")
+    #(64278 "ﬖ" "Վն" "ՎՆ")
+    #(64279 "ﬗ" "Մխ" "ՄԽ")))
diff --git a/lib/scheme/complex.sld b/lib/scheme/complex.sld
new file mode 100644
index 00000000..7e79f76b
--- /dev/null
+++ b/lib/scheme/complex.sld
@@ -0,0 +1,4 @@
+
+(define-library (scheme complex)
+  (import (chibi))
+  (export angle imag-part magnitude make-polar make-rectangular real-part))
diff --git a/lib/scheme/cxr.scm b/lib/scheme/cxr.scm
new file mode 100644
index 00000000..df62b1dd
--- /dev/null
+++ b/lib/scheme/cxr.scm
@@ -0,0 +1,27 @@
+
+;; provide c[ad]{3,4}r
+
+(define (caaar x) (car (car (car x))))
+(define (caadr x) (car (car (cdr x))))
+(define (cadar x) (car (cdr (car x))))
+(define (caddr x) (car (cdr (cdr x))))
+(define (cdaar x) (cdr (car (car x))))
+(define (cdadr x) (cdr (car (cdr x))))
+(define (cddar x) (cdr (cdr (car x))))
+(define (cdddr x) (cdr (cdr (cdr x))))
+(define (caaaar x) (car (car (car (car x)))))
+(define (caaadr x) (car (car (car (cdr x)))))
+(define (caadar x) (car (car (cdr (car x)))))
+(define (caaddr x) (car (car (cdr (cdr x)))))
+(define (cadaar x) (car (cdr (car (car x)))))
+(define (cadadr x) (car (cdr (car (cdr x)))))
+(define (caddar x) (car (cdr (cdr (car x)))))
+(define (cadddr x) (car (cdr (cdr (cdr x)))))
+(define (cdaaar x) (cdr (car (car (car x)))))
+(define (cdaadr x) (cdr (car (car (cdr x)))))
+(define (cdadar x) (cdr (car (cdr (car x)))))
+(define (cdaddr x) (cdr (car (cdr (cdr x)))))
+(define (cddaar x) (cdr (cdr (car (car x)))))
+(define (cddadr x) (cdr (cdr (car (cdr x)))))
+(define (cdddar x) (cdr (cdr (cdr (car x)))))
+(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
diff --git a/lib/scheme/cxr.sld b/lib/scheme/cxr.sld
new file mode 100644
index 00000000..de48a8b2
--- /dev/null
+++ b/lib/scheme/cxr.sld
@@ -0,0 +1,8 @@
+
+(define-library (scheme cxr)
+  (import (chibi))
+  (export
+   caaar caadr cadar caddr cdaar cdadr cddar cdddr
+   caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+   cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)
+  (include "cxr.scm"))
diff --git a/lib/scheme/define-values.scm b/lib/scheme/define-values.scm
new file mode 100644
index 00000000..49c96732
--- /dev/null
+++ b/lib/scheme/define-values.scm
@@ -0,0 +1,38 @@
+
+(define-syntax define-values
+  (syntax-rules ()
+    ((define-values () expr)
+     (define dummy
+       (call-with-values (lambda () expr)
+         (lambda args #f))))
+    ((define-values (var) expr)
+     (define var expr))
+    ((define-values (var0 var1 ... varn) expr)
+     (begin
+       (define var0
+         (call-with-values (lambda () expr) list))
+       (define var1
+         (let ((v (cadr var0)))
+           (set-cdr! var0 (cddr var0))
+           v))
+       ...
+       (define varn
+         (let ((v (cadr var0)))
+           (set! var0 (car var0))
+           v))))
+    ((define-values (var0 var1 ... . var-dot) expr)
+     (begin
+       (define var0
+         (call-with-values (lambda () expr) list))
+       (define var1
+         (let ((v (cadr var0)))
+           (set-cdr! var0 (cddr var0))
+           v))
+       ...
+       (define var-dot
+         (let ((v (cdr var0)))
+           (set! var0 (car var0))
+           v))))
+    ((define-values var expr)
+     (define var
+       (call-with-values (lambda () expr) list)))))
diff --git a/lib/scheme/digit-value.scm b/lib/scheme/digit-value.scm
new file mode 100644
index 00000000..c09cf010
--- /dev/null
+++ b/lib/scheme/digit-value.scm
@@ -0,0 +1,64 @@
+
+(cond-expand
+ (full-unicode
+  (define zeros
+    '#(#\x0030                ;DIGIT ZERO
+       #\x0660                ;ARABIC-INDIC DIGIT ZERO
+       #\x06F0                ;EXTENDED ARABIC-INDIC DIGIT ZERO
+       #\x07C0                ;NKO DIGIT ZERO
+       #\x0966                ;DEVANAGARI DIGIT ZERO
+       #\x09E6                ;BENGALI DIGIT ZERO
+       #\x0A66                ;GURMUKHI DIGIT ZERO
+       #\x0AE6                ;GUJARATI DIGIT ZERO
+       #\x0B66                ;ORIYA DIGIT ZERO
+       #\x0BE6                ;TAMIL DIGIT ZERO
+       #\x0C66                ;TELUGU DIGIT ZERO
+       #\x0CE6                ;KANNADA DIGIT ZERO
+       #\x0D66                ;MALAYALAM DIGIT ZERO
+       #\x0E50                ;THAI DIGIT ZERO
+       #\x0ED0                ;LAO DIGIT ZERO
+       #\x0F20                ;TIBETAN DIGIT ZERO
+       #\x1040                ;MYANMAR DIGIT ZERO
+       #\x1090                ;MYANMAR SHAN DIGIT ZERO
+       #\x17E0                ;KHMER DIGIT ZERO
+       #\x1810                ;MONGOLIAN DIGIT ZERO
+       #\x1946                ;LIMBU DIGIT ZERO
+       #\x19D0                ;NEW TAI LUE DIGIT ZERO
+       #\x1A80                ;TAI THAM HORA DIGIT ZERO
+       #\x1A90                ;TAI THAM THAM DIGIT ZERO
+       #\x1B50                ;BALINESE DIGIT ZERO
+       #\x1BB0                ;SUNDANESE DIGIT ZERO
+       #\x1C40                ;LEPCHA DIGIT ZERO
+       #\x1C50                ;OL CHIKI DIGIT ZERO
+       #\xA620                ;VAI DIGIT ZERO
+       #\xA8D0                ;SAURASHTRA DIGIT ZERO
+       #\xA900                ;KAYAH LI DIGIT ZERO
+       #\xA9D0                ;JAVANESE DIGIT ZERO
+       #\xAA50                ;CHAM DIGIT ZERO
+       #\xABF0                ;MEETEI MAYEK DIGIT ZERO
+       #\xFF10                ;FULLWIDTH DIGIT ZERO
+       #\x104A0               ;OSMANYA DIGIT ZERO
+       #\x11066               ;BRAHMI DIGIT ZERO
+       #\x1D7CE               ;MATHEMATICAL BOLD DIGIT ZERO
+       #\x1D7D8               ;MATHEMATICAL DOUBLE-STRUCK DIGIT ZERO
+       #\x1D7E2               ;MATHEMATICAL SANS-SERIF DIGIT ZERO
+       #\x1D7EC               ;MATHEMATICAL SANS-SERIF BOLD DIGIT ZERO
+       #\x1D7F6               ;MATHEMATICAL MONOSPACE DIGIT ZERO
+       )))
+ (else
+  (define zeros #(#\0))))
+
+(define (digit-value ch)
+  (let ((n (char->integer ch)))
+    (let lp ((lo 0) (hi (- (vector-length zeros) 1)))
+      (if (> lo hi)
+          #f
+          (let* ((mid (+ lo (quotient (- hi lo) 2)))
+                 (mid-zero (char->integer (vector-ref zeros mid))))
+            (cond
+             ((<= mid-zero n (+ mid-zero 9))
+              (- n mid-zero))
+             ((< n mid-zero)
+              (lp lo (- mid 1)))
+             (else
+              (lp (+ mid 1) hi))))))))
diff --git a/lib/scheme/division.scm b/lib/scheme/division.scm
new file mode 100644
index 00000000..6e2ec3ae
--- /dev/null
+++ b/lib/scheme/division.scm
@@ -0,0 +1,75 @@
+;;;; division.scm -- portable R7RS (scheme division) implementation
+;;
+;; This code is written by Alex Shinn and placed in the
+;; Public Domain.  All warranties are disclaimed.
+;;
+;; This is basically the simplest possible implementation.  Note the
+;; code below assumes that either 1) exact ratios are supported and
+;; are handled correctly by floor, ceiling and round, or 2) that
+;; you're using a simple implementation with only fixnums and flonums.
+;; In the intermediate case where you have bignums but no ratios there
+;; will be a loss of precision for large values.
+;;
+;; We handle both cases by the use of the cond-expand form in
+;; division.sld to conditionally define copy-exactness2.  In case 1,
+;; no adjustment is needed, whereas in case 2 we want to convert the
+;; intermediate result back to exact if both inputs were exact.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; The builtin quotient and remainder implement truncation - the
+;; fractional part is always discarded.
+
+(define truncate-quotient quotient)
+(define truncate-remainder remainder)
+(define (truncate/ n m)
+  (values (truncate-quotient n m) (truncate-remainder n m)))
+
+;; Floor, ceiling and round just compose their corresponding function
+;; with division to determine the quotient, and compute the remainder
+;; from that.
+
+(define (floor-quotient n m)
+  (copy-exactness2 n m (floor (/ n m))))
+(define (floor-remainder n m)
+  (- n (* m (floor-quotient n m))))
+(define (floor/ n m)
+  (values (floor-quotient n m) (floor-remainder n m)))
+
+(define (ceiling-quotient n m)
+  (copy-exactness2 n m (ceiling (/ n m))))
+(define (ceiling-remainder n m)
+  (- n (* m (ceiling-quotient n m))))
+(define (ceiling/ n m)
+  (values (ceiling-quotient n m) (ceiling-remainder n m)))
+
+(define (round-quotient n m)
+  (copy-exactness2 n m (round (/ n m))))
+(define (round-remainder n m)
+  (- n (* m (round-quotient n m))))
+(define (round/ n m)
+  (values (round-quotient n m) (round-remainder n m)))
+
+;; Euclidean is defined as floor if the divisor is negative, and
+;; ceiling otherwise.
+
+(define (euclidean-quotient n m)
+  (if (> m 0) (floor-quotient n m) (ceiling-quotient n m)))
+(define (euclidean-remainder n m)
+  (- n (* m (euclidean-quotient n m))))
+(define (euclidean/ n m)
+  (values (euclidean-quotient n m) (euclidean-remainder n m)))
+
+;; Centered places the remainder in the half-open interval
+;; [-m/2, m/2).
+
+(define (centered-remainder n m)
+  (let ((r (euclidean-remainder n m))
+        (m/2 (abs (/ m 2))))
+    (cond ((< r (- m/2)) (+ r (abs m)))
+          ((>= r m/2) (- r (abs m)))
+          (else r))))
+(define (centered-quotient n m)
+  (quotient (- n (centered-remainder n m)) m))
+(define (centered/ n m)
+  (values (centered-quotient n m) (centered-remainder n m)))
diff --git a/lib/scheme/division.sld b/lib/scheme/division.sld
new file mode 100644
index 00000000..bba05139
--- /dev/null
+++ b/lib/scheme/division.sld
@@ -0,0 +1,31 @@
+;; This library is deprecated, occurring in early R7RS drafts before
+;; being removed.
+
+(define-library (scheme division)
+  (import (chibi))
+  (export ceiling-quotient ceiling-remainder ceiling/
+          centered-quotient centered-remainder centered/
+          euclidean-quotient euclidean-remainder euclidean/
+          floor-quotient floor-remainder floor/
+          round-quotient round-remainder round/
+          truncate-quotient truncate-remainder truncate/)
+  ;; The second definition is always valid, but the first is simpler
+  ;; and faster if exact ratios are supported and handled correctly
+  ;; but floor/ceil/round.
+  (cond-expand
+   (ratios
+    (begin
+      (define-syntax copy-exactness2
+        (syntax-rules ()
+          ((copy-exactness2 src1 src2 expr)
+           expr)))))
+   (else
+    (begin
+      (define-syntax copy-exactness2
+        (syntax-rules ()
+          ((copy-exactness2 src1 src2 expr)
+           (let ((tmp expr))
+             (if (and (exact? src1) (exact? src2))
+                 (inexact->exact tmp)
+                 tmp))))))))
+  (include "division.scm"))
diff --git a/lib/scheme/eval.sld b/lib/scheme/eval.sld
new file mode 100644
index 00000000..2311e1db
--- /dev/null
+++ b/lib/scheme/eval.sld
@@ -0,0 +1,4 @@
+
+(define-library (scheme eval)
+  (import (chibi) (meta)) ; (chibi compiler analyze)
+  (export eval environment))
diff --git a/lib/scheme/extras.scm b/lib/scheme/extras.scm
new file mode 100644
index 00000000..b717ade2
--- /dev/null
+++ b/lib/scheme/extras.scm
@@ -0,0 +1,260 @@
+
+(define (read-sexps file . o)
+  (let ((in (open-input-file file)))
+    (if (and (pair? o) (car o))
+        (set-port-fold-case! in #t))
+    (let lp ((res '()))
+      (let ((x (read in)))
+        (if (eof-object? x) res (lp (cons x res)))))))
+
+(define-syntax include
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let lp ((files (cdr expr)) (res '()))
+       (cond
+        ((null? files) (cons (rename 'begin) (reverse res)))
+        (else (lp (cdr files) (append (read-sexps (car files)) res))))))))
+
+(define-syntax include-ci
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let lp ((files (cdr expr)) (res '()))
+       (cond
+        ((null? files) (cons (rename 'begin) (reverse res)))
+        (else (lp (cdr files) (append (read-sexps (car files) #t) res))))))))
+
+(define (read-error? x)
+  (and (error-object? x) (eq? 'read (exception-kind x))))
+
+(define (file-error? x)
+  (and (error-object? x) (eq? 'file (exception-kind x))))
+
+(define (features) *features*)
+
+(define exact inexact->exact)
+(define inexact exact->inexact)
+
+(define (boolean=? x y . o)
+  (and (eq? x y) (if (pair? o) (apply boolean=? y o) #t)))
+(define (symbol=? x y . o)
+  (and (eq? x y) (if (pair? o) (apply symbol=? y o) #t)))
+
+(define call/cc call-with-current-continuation)
+
+(define truncate-quotient quotient)
+(define truncate-remainder remainder)
+(define (truncate/ n m)
+  (values (truncate-quotient n m) (truncate-remainder n m)))
+
+(define (floor-quotient n m)
+  (let ((res (floor (/ n m))))
+    (if (and (exact? n) (exact? m))
+        (inexact->exact res)
+        res)))
+(define (floor-remainder n m)
+  (- n (* m (floor-quotient n m))))
+(define (floor/ n m)
+  (values (floor-quotient n m) (floor-remainder n m)))
+
+(define (exact-integer-sqrt x)
+  (let ((res (exact-sqrt x)))
+    (values (car res) (cdr res))))
+
+;; Adapted from Bawden's algorithm.
+(define (rationalize x e)
+  (define (sr x y return)
+    (let ((fx (floor x)) (fy (floor y)))
+      (cond
+       ((>= fx x)
+        (return fx 1))
+       ((= fx fy)
+        (sr (/ (- y fy)) (/ (- x fx)) (lambda (n d) (return (+ d (* fx n)) n))))
+       (else
+        (return (+ fx 1) 1)))))
+  (let ((return (if (negative? x) (lambda (num den) (/ (- num) den)) /))
+        (x (abs x))
+        (e (abs e)))
+    (sr (- x e) (+ x e) return)))
+
+(define (square x) (* x x))
+
+(define flush-output-port flush-output)
+
+(define input-port-open? port-open?)
+(define output-port-open? port-open?)
+
+(define (close-port port)
+  ((if (input-port? port) close-input-port close-output-port) port))
+
+(define (u8-ready? port) (char-ready? port))
+
+(define (call-with-port port proc)
+  (let ((res (proc port)))
+    (close-port port)
+    res))
+
+(define (eof-object) (read-char (open-input-string "")))
+
+(define (read-bytevector n . o)
+  (if (zero? n)
+      #u8()
+      (let ((in (if (pair? o) (car o) (current-input-port)))
+            (res (make-bytevector n)))
+        (let lp ((i 0))
+          (if (>= i n)
+              res
+              (let ((x (read-u8 in)))
+                (cond ((eof-object? x)
+                       (if (zero? i) x (subbytes res 0 i)))
+                      (else
+                       (bytevector-u8-set! res i x)
+                       (lp (+ i 1))))))))))
+
+(define (read-bytevector! vec . o)
+  (let* ((in (if (pair? o) (car o) (current-input-port)))
+         (o (if (pair? o) (cdr o) o))
+         (start (if (pair? o) (car o) 0))
+         (end (if (and (pair? o) (pair? (cdr o)))
+                  (cadr o)
+                  (bytevector-length vec))))
+    (if (>= start end)
+        0
+        (let ((res (read-bytevector (- end start) in)))
+          (cond
+           ((eof-object? res)
+            res)
+           (else
+            (let ((len (bytevector-length res)))
+              (do ((i 0 (+ i 1)))
+                  ((>= i len) len)
+                (bytevector-u8-set! vec (+ i start) (bytevector-u8-ref res i))
+                ))))))))
+
+(define (write-bytevector vec . o)
+  (let* ((out (if (pair? o) (car o) (current-output-port)))
+         (o (if (pair? o) (cdr o) '()))
+         (start (if (pair? o) (car o) 0))
+         (o (if (pair? o) (cdr o) '()))
+         (end (if (pair? o) (car o) (bytevector-length vec))))
+    (do ((i start (+ i 1)))
+        ((>= i end))
+      (write-u8 (bytevector-u8-ref vec i) out))))
+
+(define (list-set! ls k x)
+  (cond ((null? ls) (error "invalid list index"))
+        ((zero? k) (set-car! ls x))
+        (else (list-set! (cdr ls) (- k 1) x))))
+
+(define (vector-append . vecs)
+  (let* ((len (apply + (map vector-length vecs)))
+         (res (make-vector len)))
+    (let lp ((ls vecs) (i 0))
+      (if (null? ls)
+          res
+          (let ((v-len (vector-length (car ls))))
+            (vector-copy! res i (car ls))
+            (lp (cdr ls) (+ i v-len)))))))
+
+(define (vector-map proc vec . lov)
+  (if (null? lov)
+      (let lp ((i (vector-length vec)) (res '()))
+        (if (zero? i)
+            (list->vector res)
+            (lp (- i 1) (cons (proc (vector-ref vec (- i 1))) res))))
+      (list->vector (apply map proc (map vector->list (cons vec lov))))))
+
+(define (vector-for-each proc vec . lov)
+  (if (null? lov)
+      (let ((len (vector-length vec)))
+        (let lp ((i 0))
+          (cond ((< i len)
+                 (proc (vector-ref vec i))
+                 (lp (+ i 1))))))
+      (apply for-each proc (map vector->list (cons vec lov)))))
+
+(define (vector-copy! to at from . o)
+  (let* ((start (if (pair? o) (car o) 0))
+         (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (vector-length from)))
+         (limit (min end (+ start (- (vector-length to) at)))))
+    (if (<= at start)
+        (do ((i at (+ i 1)) (j start (+ j 1)))
+            ((>= j limit))
+          (vector-set! to i (vector-ref from j)))
+        (do ((i (+ at (- end start 1)) (- i 1)) (j (- limit 1) (- j 1)))
+            ((< j start))
+          (vector-set! to i (vector-ref from j))))))
+
+(define (vector->string vec . o)
+  (list->string (apply vector->list vec o)))
+
+(define (string->vector vec . o)
+  (list->vector (apply string->list vec o)))
+
+(define (bytevector . args)
+  (let* ((len (length args))
+         (res (make-bytevector len)))
+    (do ((i 0 (+ i 1)) (ls args (cdr ls)))
+        ((null? ls) res)
+      (bytevector-u8-set! res i (car ls)))))
+
+(define (bytevector-copy! to at from . o)
+  (let* ((start (if (pair? o) (car o) 0))
+         (end (if (and (pair? o) (pair? (cdr o)))
+                  (cadr o)
+                  (bytevector-length from)))
+         (limit (min end (+ start (- (bytevector-length to) at)))))
+    (if (<= at start)
+        (do ((i at (+ i 1)) (j start (+ j 1)))
+            ((>= j limit))
+          (bytevector-u8-set! to i (bytevector-u8-ref from j)))
+        (do ((i (+ at (- end start 1)) (- i 1)) (j (- limit 1) (- j 1)))
+            ((< j start))
+          (bytevector-u8-set! to i (bytevector-u8-ref from j))))))
+
+(define (bytevector-copy vec . o)
+  (if (null? o)
+      (subbytes vec 0)
+      (apply subbytes vec o)))
+
+(define (bytevector-append . vecs)
+  (let* ((len (apply + (map bytevector-length vecs)))
+         (res (make-bytevector len)))
+    (let lp ((ls vecs) (i 0))
+      (if (null? ls)
+          res
+          (let ((v-len (bytevector-length (car ls))))
+            (bytevector-copy! res i (car ls))
+            (lp (cdr ls) (+ i v-len)))))))
+
+;; Never use this!
+(define (string-copy! to at from . o)
+  (let* ((start (if (pair? o) (car o) 0))
+         (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length from)))
+         (limit (min end (+ start (- (string-length to) at)))))
+    (if (<= at start)
+        (do ((i at (+ i 1)) (j start (+ j 1)))
+            ((>= j limit))
+          (string-set! to i (string-ref from j)))
+        (do ((i (+ at (- end start 1)) (- i 1)) (j (- limit 1) (- j 1)))
+            ((< j start))
+          (string-set! to i (string-ref from j))))))
+
+(define truncate-quotient quotient)
+(define truncate-remainder remainder)
+(define (truncate/ n m)
+  (values (truncate-quotient n m) (truncate-remainder n m)))
+
+(cond-expand
+ (ratios
+  (define (floor-quotient n m)
+    (floor (/ n m))))
+ (else
+  (define (floor-quotient n m)
+    (let ((res (floor (/ n m))))
+      (if (and (exact? n) (exact? m))
+          (exact res)
+          res)))))
+(define (floor-remainder n m)
+  (- n (* m (floor-quotient n m))))
+(define (floor/ n m)
+  (values (floor-quotient n m) (floor-remainder n m)))
diff --git a/lib/scheme/file.sld b/lib/scheme/file.sld
new file mode 100644
index 00000000..a43c52ac
--- /dev/null
+++ b/lib/scheme/file.sld
@@ -0,0 +1,9 @@
+
+(define-library (scheme file)
+  (import (chibi) (only (chibi filesystem) delete-file file-exists?))
+  (export
+   call-with-input-file call-with-output-file
+   delete-file file-exists?
+   open-binary-input-file open-binary-output-file
+   open-input-file open-output-file
+   with-input-from-file with-output-to-file))
diff --git a/lib/scheme/inexact.scm b/lib/scheme/inexact.scm
new file mode 100644
index 00000000..6e267514
--- /dev/null
+++ b/lib/scheme/inexact.scm
@@ -0,0 +1,11 @@
+
+(define (nan? x)
+  (and (real? x) (not (= x x))))
+
+(define (finite? x)
+  (if (real? x)
+      (and (not (nan? x)) (not (= x +inf.0)) (not (= x -inf.0)))
+      (and (complex? x) (finite? (real-part x)) (finite? (imag-part x)))))
+
+(define (infinite? x)
+  (and (number? x) (not (finite? x)) (not (nan? x))))
diff --git a/lib/scheme/inexact.sld b/lib/scheme/inexact.sld
new file mode 100644
index 00000000..16329f97
--- /dev/null
+++ b/lib/scheme/inexact.sld
@@ -0,0 +1,5 @@
+
+(define-library (scheme inexact)
+  (import (chibi))
+  (export acos asin atan cos exp finite? infinite? log nan? sin sqrt tan)
+  (include "inexact.scm"))
diff --git a/lib/scheme/lazy.sld b/lib/scheme/lazy.sld
new file mode 100644
index 00000000..b9a06e8b
--- /dev/null
+++ b/lib/scheme/lazy.sld
@@ -0,0 +1,19 @@
+
+(define-library (scheme lazy)
+  (import (chibi))
+  (export delay force delay-force make-promise promise?)
+  (begin
+    (define (make-promise x)
+      (delay x)))
+  (cond-expand
+   (auto-force
+    )
+   (else
+    (begin
+      (define (promise? x)
+        (and (pair? x)
+             (null? (cdr x))
+             (pair? (car x))
+             (or (eq? #t (caar x))
+                 (and (eq? #f (caar x))
+                      (procedure? (cdar x))))))))))
diff --git a/lib/scheme/load.sld b/lib/scheme/load.sld
new file mode 100644
index 00000000..20a2e95b
--- /dev/null
+++ b/lib/scheme/load.sld
@@ -0,0 +1,4 @@
+
+(define-library (scheme load)
+  (import (chibi))
+  (export load))
diff --git a/lib/scheme/misc-macros.scm b/lib/scheme/misc-macros.scm
new file mode 100644
index 00000000..7b367671
--- /dev/null
+++ b/lib/scheme/misc-macros.scm
@@ -0,0 +1,50 @@
+
+(define-syntax when
+  (syntax-rules ()
+    ((when test . body)
+     (if test (begin . body)))))
+
+(define-syntax unless
+  (syntax-rules ()
+    ((unless test . body)
+     (when (not test) . body))))
+
+(define-syntax guard
+  (syntax-rules ()
+    ((guard (var clause ...) e1 e2 ...)
+     ((call-with-current-continuation
+       (lambda (guard-k)
+         (with-exception-handler
+          (lambda (condition)
+            ((call-with-current-continuation
+              (lambda (handler-k)
+                (guard-k
+                 (lambda ()
+                   (let ((var condition))      ; clauses may SET! var
+                     (guard-aux (handler-k (lambda ()
+                                             (raise-continuable condition)))
+                                clause ...))))))))
+          (lambda ()
+            (let ((res (begin e1 e2 ...)))
+              (guard-k (lambda () res)))))))))))
+
+(define-syntax guard-aux
+  (syntax-rules (else =>)
+    ((guard-aux reraise (else result1 result2 ...))
+     (begin result1 result2 ...))
+    ((guard-aux reraise (test => result))
+     (let ((temp test))
+       (if temp (result temp) reraise)))
+    ((guard-aux reraise (test => result) clause1 clause2 ...)
+     (let ((temp test))
+       (if temp (result temp) (guard-aux reraise clause1 clause2 ...))))
+    ((guard-aux reraise (test))
+     (or test reraise))
+    ((guard-aux reraise (test) clause1 clause2 ...)
+     (or test (guard-aux reraise clause1 clause2 ...)))
+    ((guard-aux reraise (test result1 result2 ...))
+     (if test (begin result1 result2 ...) reraise))
+    ((guard-aux reraise (test result1 result2 ...) clause1 clause2 ...)
+     (if test
+         (begin result1 result2 ...)
+         (guard-aux reraise clause1 clause2 ...)))))
diff --git a/lib/scheme/process-context.sld b/lib/scheme/process-context.sld
new file mode 100644
index 00000000..29aab00a
--- /dev/null
+++ b/lib/scheme/process-context.sld
@@ -0,0 +1,7 @@
+
+(define-library (scheme process-context)
+  (import (chibi) (srfi 98) (only (chibi process) exit))
+  (export get-environment-variable get-environment-variables
+          command-line exit emergency-exit)
+  ;; TODO: Make exit unwind and finalize properly.
+  (begin (define emergency-exit exit)))
diff --git a/lib/scheme/r5rs.sld b/lib/scheme/r5rs.sld
new file mode 100644
index 00000000..c6d8e25b
--- /dev/null
+++ b/lib/scheme/r5rs.sld
@@ -0,0 +1,55 @@
+
+(define-library (scheme r5rs)
+  (import
+   (rename (scheme base)
+           (exact inexact->exact)
+           (inexact exact->inexact))
+   (scheme cxr)
+   (scheme char)
+   (scheme inexact)
+   (scheme complex)
+   (scheme read)
+   (scheme write)
+   (scheme file)
+   (scheme lazy)
+   (scheme eval)
+   (scheme repl)
+   (scheme load)
+   (only (chibi) null-environment scheme-report-environment))
+  (export
+   - * / + < <= = > >= abs acos and angle append apply asin assoc assq
+   assv atan begin boolean?
+   caaaar caaadr caadar caaddr
+   cadaar cadadr caddar cadddr
+   cdaaar cdaadr cdadar cdaddr
+   cddaar cddadr cdddar cddddr
+   caaar caadr cadar caddr
+   cdaar cdadr cddar cdddr
+   caar cadr cdar cddr
+   call-with-current-continuation call-with-input-file call-with-output-file
+   call-with-values car case cdr ceiling char->integer char-alphabetic?
+   char-ci<? char-ci<=? char-ci=? char-ci>? char-ci>=? char-downcase
+   char-lower-case? char-numeric? char-ready? char-upcase
+   char-upper-case? char-whitespace? char? char<? char<=? char=? char>?
+   char>=? close-input-port close-output-port complex? cond cons cos
+   current-input-port current-output-port define define-syntax delay
+   denominator display do dynamic-wind eof-object? eq? equal? eqv? eval
+   even? exact->inexact exact? exp expt floor for-each force gcd if
+   imag-part inexact->exact inexact? input-port? integer->char integer?
+   interaction-environment lambda lcm length let let-syntax let* letrec
+   letrec-syntax list list->string list->vector list-ref list-tail list?
+   load log magnitude make-polar make-rectangular make-string make-vector
+   map max member memq memv min modulo negative? newline not
+   null-environment null? number->string number? numerator odd?
+   open-input-file open-output-file or output-port? pair? peek-char
+   positive? procedure? quasiquote quote quotient rational? rationalize
+   read read-char real-part real? remainder reverse round
+   scheme-report-environment set-car! set-cdr! set! sin sqrt string
+   string->list string->number string->symbol string-append string-ci<?
+   string-ci<=? string-ci=? string-ci>? string-ci>=? string-copy
+   string-fill! string-length string-ref string-set! string? string<?
+   string<=? string=? string>? string>=? substring symbol->string symbol?
+   tan truncate values vector vector->list vector-fill! vector-length
+   vector-ref vector-set! vector? with-input-from-file
+   with-output-to-file write write-char zero?
+   ))
diff --git a/lib/scheme/read.sld b/lib/scheme/read.sld
new file mode 100644
index 00000000..8645070a
--- /dev/null
+++ b/lib/scheme/read.sld
@@ -0,0 +1,4 @@
+
+(define-library (scheme read)
+  (import (rename (srfi 38) (read/ss read)))
+  (export read))
diff --git a/lib/scheme/repl.sld b/lib/scheme/repl.sld
new file mode 100644
index 00000000..c5c46f49
--- /dev/null
+++ b/lib/scheme/repl.sld
@@ -0,0 +1,4 @@
+
+(define-library (scheme repl)
+  (import (chibi))
+  (export interaction-environment))
diff --git a/lib/scheme/small.sld b/lib/scheme/small.sld
new file mode 100644
index 00000000..0457e4af
--- /dev/null
+++ b/lib/scheme/small.sld
@@ -0,0 +1,85 @@
+(define-library (scheme small)
+  (import (scheme base) (scheme char) (scheme complex) (scheme cxr)
+          (scheme eval) (scheme file) (scheme inexact) (scheme lazy)
+          (scheme load) (scheme read) (scheme repl) (scheme time)
+          (scheme write))
+  (export
+   ;; base
+   * + - ... / < <= = => > >= _ abs and append apply assoc assq assv begin
+   binary-port?  boolean?  boolean=?  bytevector bytevector-append
+   bytevector-copy bytevector-copy! bytevector-length
+   bytevector-u8-ref bytevector-u8-set!  bytevector?  caar cadr
+   call-with-current-continuation call-with-port call-with-values
+   call/cc car case cdr cdar cddr ceiling char->integer
+   char-ready? char<=?  char<?  char=?  char>=?  char>?  char?
+   close-input-port close-output-port close-port complex?  cond cond-expand
+   cons current-error-port current-input-port current-output-port define
+   define-record-type define-syntax define-values denominator do
+   dynamic-wind else eof-object? eof-object  eq?  equal?  eqv?  error
+   error-object-irritants error-object-message error-object?  even?
+   exact exact-integer-sqrt exact-integer?  exact?  expt features
+   file-error? floor
+   flush-output-port for-each gcd get-output-bytevector get-output-string
+   guard if include include-ci inexact inexact?  input-port?
+   integer->char
+   integer?  lambda lcm length let let* let*-values let-syntax let-values
+   letrec letrec* letrec-syntax list list->string list->vector list-copy
+   list-ref list-set!  list-tail list?  make-bytevector make-list
+   make-parameter make-string make-vector map max member memq memv min
+   modulo negative?  newline not null?  number->string number?  numerator
+   odd?  open-input-bytevector open-input-string open-output-bytevector
+   open-output-string or output-port?  pair?  parameterize peek-char
+   peek-u8 input-port-open? output-port-open?  port?  positive?
+   procedure?  quasiquote quote
+   quotient raise raise-continuable rational?  rationalize read-bytevector
+   read-bytevector!  read-char read-error? read-line read-string read-u8
+   real?  remainder
+   reverse round set!  set-car!  set-cdr!  square string string->list
+   string->number string->symbol string->utf8 string->vector string-append
+   string-copy string-copy! string-fill!  string-for-each string-length
+   string-map
+   string-ref string-set!  string<=?  string<?  string=?  string>=?
+   string>?  string?  substring symbol->string symbol?  symbol=?  syntax-error
+   syntax-rules textual-port?  truncate u8-ready?  unless unquote
+   unquote-splicing utf8->string values vector vector-append
+   vector->list vector->string
+   vector-copy vector-copy! vector-fill!  vector-for-each vector-length
+   vector-map vector-ref vector-set!  vector?  when with-exception-handler
+   write-bytevector write-char write-string write-u8 zero?
+   truncate-quotient truncate-remainder truncate/
+   floor-quotient floor-remainder floor/
+   ;; char
+   char-alphabetic? char-ci<=? char-ci<? char-ci=? char-ci>=? char-ci>?
+   char-downcase char-foldcase char-lower-case? char-numeric?
+   char-upcase char-upper-case? char-whitespace? digit-value
+   string-ci<=? string-ci<? string-ci=? string-ci>=? string-ci>?
+   string-downcase string-foldcase string-upcase
+   ;; complex
+   angle imag-part magnitude make-polar make-rectangular real-part
+   ;; cxr
+   caaar caadr cadar caddr cdaar cdadr cddar cdddr
+   caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+   cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+   ;; eval
+   eval environment
+   ;; file
+   call-with-input-file call-with-output-file
+   delete-file file-exists?
+   open-binary-input-file open-binary-output-file
+   open-input-file open-output-file
+   with-input-from-file with-output-to-file
+   ;; inexact
+   acos asin atan cos exp finite? infinite? log nan? sin sqrt tan
+   ;; lazy
+   delay force delay-force make-promise promise?
+   ;; load
+   load
+   ;; read
+   read
+   ;; repl
+   interaction-environment
+   ;; time
+   current-second current-jiffy jiffies-per-second
+   ;; write
+   display write write-shared write-simple
+   ))
diff --git a/lib/scheme/time.c b/lib/scheme/time.c
new file mode 100644
index 00000000..6d676a8e
--- /dev/null
+++ b/lib/scheme/time.c
@@ -0,0 +1,106 @@
+/* time.c -- R7RS time routines                              */
+/* Copyright (c) 2011-2012 Alex Shinn.  All rights reserved. */
+/* Copyright (c) 2012 Alan Watson. All rights reserved.      */
+/* BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+
+#ifndef PLAN9
+#include <sys/time.h>
+#else
+typedef long time_t;
+#endif
+
+#if SEXP_USE_NTP_GETTIME
+#include <sys/timex.h>
+
+/* We can determine the clock resolution by calling ntp_adjtime() and */
+/* seeing if the STA_NANO bit of the status word is set. If it is, we */
+/* have nanosecond resolution, otherwise we have microsecond resolution. */
+
+/* The time member of the ntptimeval struct may be either a struct */
+/* timeval (with the fraction in microseconds) or a struct timespec */
+/* (with the fraction in nanoseconds). */
+
+/* However, there are systems (e.g., Ubuntu 10.4 on X86_64) that use */
+/* nanosecond resolution but still declare the time member of struct */
+/* ntptimeval to be a struct timeval. Therefore, we explicitly use casts */
+/* to access this member either as a struct timeval or struct timespec */
+/* depending on the resolution. */
+
+static double ntp_resolution = 0.0;
+
+static void determine_ntp_resolution (void) {
+  struct timex tx;
+  tx.modes = 0;
+  if (ntp_adjtime(&tx) < 0) {
+    ntp_resolution = 0;
+  } else if (tx.status & STA_NANO) {
+    ntp_resolution = 1e-9;
+  } else {
+    ntp_resolution = 1e-6;
+  }
+}
+
+static void current_ntp_clock_values (double *second, int *leap_second_indicator) {
+  struct ntptimeval ntv;
+  int status = ntp_gettime(&ntv);
+  if (ntp_resolution != 0 && (
+        status == TIME_OK  || 
+        status == TIME_INS || 
+        status == TIME_DEL || 
+        status == TIME_OOP || 
+        status == TIME_WAIT)) {
+    if (ntp_resolution == 1e-6) {
+      struct timeval *tv = (struct timeval *) &ntv.time;
+      *second = tv->tv_sec + ntp_resolution * tv->tv_usec;
+    } else {
+      struct timespec *ts = (struct timespec *) &ntv.time;
+      *second = ts->tv_sec + ntp_resolution * ts->tv_nsec;
+    }
+    *leap_second_indicator = (status == TIME_OOP);
+  } else {
+    *second = current_clock_second();
+    *leap_second_indicator = 0;
+  }
+}
+
+static sexp sexp_current_ntp_clock_values (sexp ctx, sexp self, sexp_sint_t n) {
+  double second;
+  int leap_second_indicator;
+  sexp_gc_var3(res, car, cdr);
+  current_ntp_clock_values (&second, &leap_second_indicator);
+  sexp_gc_preserve3(ctx, res, car, cdr);
+  cdr = sexp_make_boolean(leap_second_indicator);
+  car = sexp_make_flonum(ctx, second);
+  res = sexp_cons(ctx, car, cdr);
+  sexp_gc_release3(ctx);
+  return res;
+}
+
+#endif  /* def SEXP_USE_NTP_GETTIME */
+
+static sexp sexp_current_clock_second (sexp ctx, sexp self, sexp_sint_t n) {
+#ifndef PLAN9
+  struct timeval tv;
+  struct timezone tz;
+  if (gettimeofday(&tv, &tz))
+    return sexp_user_exception(ctx, self, "couldn't gettimeofday", SEXP_FALSE);
+  return sexp_make_flonum(ctx, tv.tv_sec + tv.tv_usec / 1000000.0);
+#else
+  time_t res = time(NULL);
+  return sexp_make_flonum(ctx, res);
+#endif
+}
+
+sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
+  if (!(sexp_version_compatible(ctx, version, sexp_version)
+        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
+    return sexp_global(ctx, SEXP_G_ABI_ERROR);
+  sexp_define_foreign(ctx, env, "current-clock-second", 0, sexp_current_clock_second);
+#if SEXP_USE_NTP_GETTIME
+  determine_ntp_resolution();
+  sexp_define_foreign(ctx, env, "current-ntp-clock-values", 0, sexp_current_ntp_clock_values);
+#endif
+  return SEXP_VOID;
+}
diff --git a/lib/scheme/time.sld b/lib/scheme/time.sld
new file mode 100644
index 00000000..c34040a5
--- /dev/null
+++ b/lib/scheme/time.sld
@@ -0,0 +1,78 @@
+;; time.sld - (scheme time) library definition
+;;
+;; Copyright (c) 2012 Alex Shinn. All rights reserved.
+;; Copyright (c) 2012 Alan Watson. All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define-library (scheme time)
+  (export current-second current-jiffy jiffies-per-second)
+  (import (chibi))
+  (import (scheme process-context))
+  (import (scheme time tai))
+  (include-shared "time")
+  ;; If the environment variable SEXP_CLOCK_TYPE is set, its value
+  ;; is used for the system clock type. If the environment variable
+  ;; SEXP_CLOCK_TYPE is not set, then the system clock is ntp-like
+  ;; if current-ntp-clock-values is a procedure and is posix-like
+  ;; otherwise.
+  (cond-expand
+   (ntp
+    (begin
+      (define clock-type
+        (cond
+         ((get-environment-variable "SEXP_CLOCK_TYPE")
+          => (lambda (x)
+               (let ((type (string->symbol x)))
+                 (case type
+                   ((posix-like tai-like ntp-like) type)
+                   (else
+                    (display "invalid value for SEXP_CLOCK_TYPE: " (current-error-port))
+                    (write x (current-error-port))
+                    (display " - expected \"ntp-like\", \"posix-like\" or \"tai-like\"\n" (current-error-port))
+                    'ntp-like)))))
+         (else 'ntp-like)))))
+   (else
+    (begin (define clock-type 'posix-like))))
+  (begin
+    ;; The value of the environment variable SEXP_CLOCK_EPOCH_OFFSET
+    ;; specifies the offset of the system clock relative to the
+    ;; standard epoch (1970-01-01 00:00:00 UTC for posix-like and
+    ;; ntp-like clocks and 1970-01-01 00:00:00 TAI for tai-like system
+    ;; clocks). If it not set, the offset is assumed to be zero. In
+    ;; call-with-current-clock-values, the offset is added to the
+    ;; current seconds before calling the procedure argument.
+    (define epoch-offset
+      (exact->inexact
+       (string->number
+        (or (get-environment-variable "SEXP_CLOCK_EPOCH_OFFSET")
+            "0"))))
+
+    ;; Normally, one does not need to specify either the clock type or
+    ;; clock epoch explicitly. One case where it might be necessary is
+    ;; if the system clock runs on the TAI-10 timescale. In this case,
+    ;; one should set SEXP_CLOCK_TYPE to "tai-like" and
+    ;; SEXP_CLOCK_EPOCH_OFFSET to -10.
+    ;;
+    ;; The call-with-current-clock-values obtains the clock values
+    ;; from the current-ntp-clock-values procedure, if the system
+    ;; clock is ntp-like, and from the current-clock-second procedure
+    ;; otherwise.
+    (define call-with-current-clock-values
+      (cond-expand
+       (ntp
+        (case clock-type
+          ((ntp-like)
+           (lambda (p)
+             (let ((values-pair (current-ntp-clock-values)))
+               (p (+ (car values-pair) epoch-offset) (cdr values-pair)))))
+          (else
+           (lambda (p) (p (+ (current-clock-second) epoch-offset) #f)))))
+       (else
+        (lambda (p) (p (+ (current-clock-second) epoch-offset) #f)))))
+
+    ;; Exported interface.
+    (define current-second
+      (make-tai-clock clock-type call-with-current-clock-values))
+    (define (current-jiffy)
+      (inexact->exact (round (* (current-second) (jiffies-per-second)))))
+    (define (jiffies-per-second) 1000)))
diff --git a/lib/scheme/time/tai-to-utc-offset.sld b/lib/scheme/time/tai-to-utc-offset.sld
new file mode 100644
index 00000000..7edb7142
--- /dev/null
+++ b/lib/scheme/time/tai-to-utc-offset.sld
@@ -0,0 +1,380 @@
+;; Copyright (c) 2012 Alan Watson. All rights reserved. BSD-style
+;; license: http://synthcode.com/license.txt
+
+;; This library implements procedures that give the TAI to UTC offset a
+;; specified instant in the UTC or TAI timescales.
+
+(define-library (scheme time tai-to-utc-offset)
+  
+  (export tai-to-utc-offset-at-utc-day
+          tai-to-utc-offset-at-tai-second
+          set-open-leap-seconds-list-port!
+          set-update-exception-handler!)
+  
+  (import (scheme base))
+  (import (scheme file))
+  (import (scheme read))
+  (import (scheme process-context))
+  
+  (cond-expand
+   (threads
+    (import (srfi 18)))
+   (else
+    (begin
+      (define (make-thread thunk name) #f)
+      (define (thread-start! th) #f)
+      (define (thread-sleep! secs) #f))))
+  
+  (cond-expand
+   (chibi
+    (begin
+      (define *file-name-environment-variable* "SEXP_LEAP_SECONDS_LIST_FILE")))
+   (else
+    (begin
+      (error "Need to define *file-name-environment-variable*."))))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  
+  (cond-expand
+   
+   ;; We ensure thread-safe atomic access to mutated bindings using
+   ;; atomic boxes.
+   
+   (chibi
+    (begin
+      
+      ;; This implementation relies on record accessors and mutators
+      ;; being atomic in Chibi Scheme.
+      
+      (define-record-type atomic-box-record-type
+        (make-atomic-box value)
+        atomic-box?
+        (value atomic-box-value atomic-box-value-set!))))
+   
+   (else
+    (begin
+      
+      ;; This implementation uses SRFI-18 mutexes.
+      
+      (define (make-atomic-box value)
+        (let ((mutex (make-mutex)))
+          (mutex-specific-set! mutex value)
+          mutex))
+      
+      (define atomic-box? mutex?)
+      
+      (define (atomic-box-value mutex)
+        (mutex-lock! mutex)
+        (let ((value (mutex-specific mutex)))
+          (mutex-unlock! mutex)
+          value))
+      
+      (define (atomic-box-value-set! mutex value)
+        (mutex-lock! mutex)
+        (mutex-specific-set! mutex value)
+        (mutex-unlock! mutex)))))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  
+  (begin
+    
+    (define seconds-per-day 86400)
+    
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    
+    ;; First, a remark on timescales.
+    ;;
+    ;; The TAI timescale used in this library has an epoch of 1970-01-01
+    ;; 00:00:00 TAI. The epoch used by the current-second procedure in
+    ;; the draft R7RS (scheme time) library is the "TAI-10" timescale
+    ;; with an epoch of 1970-01-01 00:00:10 TAI.
+    
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    
+    ;; The library maintains a cache of values derived from the leap
+    ;; seconds list.
+    ;;
+    ;; The first cached value is the utc-day-alist. This is an alist
+    ;; whose cars are the UTC days since 1970-01-01 00:00:00 UTC and
+    ;; whose cdrs are the corresponding TAI to UTC offsets.
+    ;;
+    ;; The second cached value is the tai-second-alist. This is an alist
+    ;; whose cars are the TAI seconds since 1970-01-01 00:00:00 TAI and
+    ;; whose cdrs are the corresponding TAI to UTC offsets.
+    
+    (define-record-type cache-record-type
+      (make-cache utc-day-alist tai-second-alist)
+      cache?
+      (utc-day-alist cache-utc-day-alist)
+      (tai-second-alist cache-tai-second-alist))
+    
+    (define (make-cache-from-port port)
+      (let ((utc-day-alist (read-leap-seconds-list port)))
+        (make-cache utc-day-alist
+                    (utc-day-alist->tai-second-alist utc-day-alist))))
+    
+    ;; The utc-day-alist->tai-second-alist procedure converts an alist
+    ;; indexed by the number of UTC day since 1970-01-01 00:00:00 UTC
+    ;; into an equivalent alist indexed by the number of TAI seconds
+    ;; since 1970-01-01 00:00:00 TAI.
+    ;;
+    ;; This procedure does not have to worry about the complications of
+    ;; transforming UTC dates prior to 1972-01-01 00:00:00 UTC to TAI,
+    ;; since there were no leap seconds prior to this date.
+    
+    (define (utc-day-alist->tai-second-alist utc-day-alist)
+      (map
+       (lambda (p)
+         (let* ((utc-day      (car p))
+                (leap-seconds (cdr p))
+                (tai-second   (+ (* utc-day seconds-per-day) leap-seconds)))
+           (cons tai-second leap-seconds)))
+       utc-day-alist))
+    
+    ;; The library updates the cache: when the library is loaded; when
+    ;; the set-open-leap-seconds-list-port! is called; and once per day.
+    ;; These automatic periodic updates are useful in long-running
+    ;; programs.
+    ;;
+    ;; The choice of daily updates is motivated by the following
+    ;; considerations. ITU-R TF.460-6, which contains the current
+    ;; definition of UTC, requires that the IERS should announce leap
+    ;; seconds with at least eight weeks in advance. However, NIST,
+    ;; which maintains the leap-seconds.list file, only guarantees one
+    ;; month. Recently the IERS and NIST have managed six months of
+    ;; notice, but we should not rely on this.
+    ;;
+    ;; During updates, we install the update-exception-handler.
+    
+    (define *cache-lifetime* (* 1 seconds-per-day))
+    
+    (define (update-cache! open-port)
+      (with-exception-handler
+          (update-exception-handler)
+        (lambda ()
+          (let ((port (open-port)))
+            (when port
+              (set-cache! (make-cache-from-port port)))))))
+    
+    (thread-start!
+     (make-thread
+      (lambda ()
+        (let loop ()
+          (thread-sleep! *cache-lifetime*)
+          (update-cache! (open-leap-seconds-list-port))
+          (loop)))
+      "leap-second-update-poll"))
+    
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    
+    ;; The read-leap-seconds-list procedure reads text from the port
+    ;; argument. The text must follow the format of a NIST leap seconds
+    ;; file, for example,
+    ;;
+    ;;   ftp://time.nist.gov/pub/leap-seconds.list
+    ;;
+    ;; The procedure returns an alist. The cars of the pairs are the
+    ;; number of whole UTC days since 1970-01-01 00:00:00 UTC and the
+    ;; cdrs of the pairs are the corresponding TAI to UTC offset. The
+    ;; alist is ordered by decreasing car. The cars and cdrs are exact
+    ;; integers.
+    ;;
+    ;; TODO: Do not rely on the input file being correctly ordered. Do
+    ;; not rely on the input data being exact integers.
+    ;;
+    ;; TODO: Check known leap seconds.
+    
+    (define (read-leap-seconds-list port)
+      
+      (define (ntp-second->utc-day ntp-second)
+        ;; The NTP initial epoch is 1900-01-01 00:00:00 UTC. The UTC
+        ;; initial epoch is 1970-01-01 00:00:00 UTC. There are 70 years,
+        ;; containing 17 leap days, between these epochs.
+        (- (quotient ntp-second seconds-per-day) (* 70 365) 17))
+      
+      (define (leap-seconds-line->pair line)
+        (let* ((line-port         (open-input-string line))
+               (ntp-second        (read line-port))
+               (tai-to-utc-offset (read line-port))
+               (utc-day           (ntp-second->utc-day ntp-second))
+               (leap-seconds      tai-to-utc-offset))
+          (cons utc-day leap-seconds)))
+      
+      (define (leap-seconds-comment-line? line)
+        (char=? #\# (string-ref line 0)))
+      
+      (define (read-leap-seconds-line port)
+        (let ((line (read-line port)))
+          (cond
+           ((eof-object? line) line)
+           ((leap-seconds-comment-line? line) (read-leap-seconds-line port))
+           (else line))))
+      
+      (let loop ((alist '()))
+        (let ((line (read-leap-seconds-line port)))
+          (if (eof-object? line)
+            alist
+            (loop (cons (leap-seconds-line->pair line) alist))))))
+    
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    
+    ;; (set-open-leap-seconds-list-port! p)
+    ;;
+    ;; The set-open-leap-seconds-list-port! procedure sets the value of
+    ;; procedure called to obtain the leap second list is read to its
+    ;; argument p and then performs a cache update. The procedure should
+    ;; return either #f, signifying that no leap second list is
+    ;; available, or an input port, from which a leap-second list,
+    ;; following the format of the NIST leap-second list, will be read.
+    ;; The NIST leap-second file can be found here:
+    ;;
+    ;;   ftp://time.nist.gov/pub/leap-seconds.list
+    ;;
+    ;; The default procedure attempts to open the file named by the
+    ;; environment variable SEXP_LEAP_SECOND_LIST_FILE and returns the
+    ;; port. If the environment variable is not set or if the file does
+    ;; not exist, it return #f.
+    
+    (define *open-leap-seconds-list-port*
+      (make-atomic-box
+       (lambda ()
+         (when *file-name-environment-variable*
+           (let ((file-name
+                  (get-environment-variable *file-name-environment-variable*)))
+             (if file-name
+               (open-input-file file-name)
+               #f))))))
+    
+    (define (open-leap-seconds-list-port)
+      (atomic-box-value *open-leap-seconds-list-port*))
+    
+    (define (set-open-leap-seconds-list-port! p)
+      (atomic-box-value-set! *open-leap-seconds-list-port* p)
+      (update-cache! (open-leap-seconds-list-port)))
+    
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    
+    ;; (set-update-exception-handler! p)
+    ;;
+    ;; The set-update-exception-handler! procedure sets the value of the
+    ;; error handler installed during cache updates. The default error
+    ;; handler simply raises the exception again.
+    
+    (define *update-exception-handler*
+      (make-atomic-box raise))
+    
+    (define (update-exception-handler)
+      (atomic-box-value *update-exception-handler*))
+    
+    (define (set-update-exception-handler! p)
+      (atomic-box-value-set! *update-exception-handler* p))
+    
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    
+    (define *cache*
+      (make-atomic-box #f))
+    
+    (define (cache)
+      (atomic-box-value *cache*))
+    
+    (define (set-cache! value)
+      (atomic-box-value-set! *cache* value))
+    
+    (update-cache!
+     (lambda ()
+       (open-input-string
+        (string-append
+         
+         ;; These strings are lines extracted from:
+         ;;
+         ;;   ftp://time.nist.gov/pub/leap-seconds.3535228800
+         ;;
+         ;; The original file contains extensive comments on the format
+         ;; and provenance of the data, which have been removed from
+         ;; this version.
+         
+         "2272060800 10  # 1 Jan 1972\n"
+         "2287785600 11  # 1 Jul 1972\n"
+         "2303683200 12  # 1 Jan 1973\n"
+         "2335219200 13  # 1 Jan 1974\n"
+         "2366755200 14  # 1 Jan 1975\n"
+         "2398291200 15  # 1 Jan 1976\n"
+         "2429913600 16  # 1 Jan 1977\n"
+         "2461449600 17  # 1 Jan 1978\n"
+         "2492985600 18  # 1 Jan 1979\n"
+         "2524521600 19  # 1 Jan 1980\n"
+         "2571782400 20  # 1 Jul 1981\n"
+         "2603318400 21  # 1 Jul 1982\n"
+         "2634854400 22  # 1 Jul 1983\n"
+         "2698012800 23  # 1 Jul 1985\n"
+         "2776982400 24  # 1 Jan 1988\n"
+         "2840140800 25  # 1 Jan 1990\n"
+         "2871676800 26  # 1 Jan 1991\n"
+         "2918937600 27  # 1 Jul 1992\n"
+         "2950473600 28  # 1 Jul 1993\n"
+         "2982009600 29  # 1 Jul 1994\n"
+         "3029443200 30  # 1 Jan 1996\n"
+         "3076704000 31  # 1 Jul 1997\n"
+         "3124137600 32  # 1 Jan 1999\n"
+         "3345062400 33  # 1 Jan 2006\n"
+         "3439756800 34  # 1 Jan 2009\n"
+         "3550089600 35  # 1 Jul 2012\n"))))
+    
+    (update-cache! (open-leap-seconds-list-port))
+    
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    
+    ;; (tai-to-utc-offset-at-utc-day utc-day)
+    ;;
+    ;; The tai-to-utc-offset-at-utc-day procedure returns the TAI to UTC
+    ;; offset at the instant specified by its argument utc-day. The
+    ;; instant is specified by the number of UTC days since 1970-01-01
+    ;; 00:00:00 UTC.
+    ;;
+    ;; To convert a UTC time since 1972-01-01 00:00:00 UTC to number of
+    ;; TAI seconds since 1972-01-01 00:00:00 TAI, first find the number
+    ;; of whole UTC days D since 1970-01-01 00:00:00 UTC and the number
+    ;; of UTC seconds S since the start of the current day. The number
+    ;; of TAI seconds since 1972-01-01 00:00:00 TAI is then
+    ;;
+    ;;   (+ (* D 86400) S (tai-to-utc-offset-at-utc-day D))
+    ;;
+    ;; This implementation does not return the correct result for
+    ;; instants prior to 1972-01-01 00:00:00 UTC.
+    ;;
+    ;; Converting a UTC time prior to 1972-01-01 00:00:00 UTC to TAI is
+    ;; more involved, since prior to this date UTC and TAI seconds were
+    ;; not equal. See,
+    ;;
+    ;;   http://hpiers.obspm.fr/eop-pc/index.php?index=TAI-UTC_tab
+    
+    (define (tai-to-utc-offset-at-utc-day-loop utc-day alist)
+      (cond ((null? alist) 10)
+            ((>= utc-day (caar alist)) (cdar alist))
+            (else (tai-to-utc-offset-at-utc-day-loop utc-day (cdr alist)))))
+    
+    (define (tai-to-utc-offset-at-utc-day utc-day)
+      (tai-to-utc-offset-at-utc-day-loop
+       utc-day
+       (cache-utc-day-alist (cache))))
+    
+    ;; (tai-to-utc-offset-at-tai-second tai-second)
+    ;;
+    ;; The tai-to-utc-offset-at-tai-second procedure returns TAI to UTC
+    ;; offset at the instant specified by its argument tai-second. The
+    ;; instant is specified by the number of TAI seconds since
+    ;; 1970-01-01 00:00:00 TAI.
+    ;;
+    ;; This implementation does not return the correct result for
+    ;; instants prior to 1972-01-01 00:00:00 UTC.
+    
+    (define (tai-to-utc-offset-at-tai-second-loop tai-second alist)
+      (cond
+       ((null? alist) 10)
+       ((>= tai-second (caar alist)) (cdar alist))
+       (else (tai-to-utc-offset-at-tai-second-loop tai-second (cdr alist)))))
+    
+    (define (tai-to-utc-offset-at-tai-second tai-second)
+      (tai-to-utc-offset-at-tai-second-loop
+       tai-second
+       (cache-tai-second-alist (cache))))))
diff --git a/lib/scheme/time/tai.sld b/lib/scheme/time/tai.sld
new file mode 100644
index 00000000..7e9034f5
--- /dev/null
+++ b/lib/scheme/time/tai.sld
@@ -0,0 +1,57 @@
+;; Copyright (c) 2012 Alan Watson. All rights reserved. BSD-style
+;; license: http://synthcode.com/license.txt
+
+;; This library implements TAI clocks with an epoch of 1970-01-01
+;; 00:00:00 TAI.
+
+(define-library (scheme time tai)
+  
+  (export make-tai-clock)
+  
+  (import (scheme base))
+  (import (scheme time tai-to-utc-offset))
+  
+  (begin
+    
+    (define seconds-per-day (* 24.0 60.0 60.0))
+    
+    (define (make-tai-clock-from-tai-like-clock call-with-current-clock-values)
+      (define (consumer second leap-second-indicator)
+        second)
+      (lambda ()
+        (call-with-current-clock-values consumer)))
+    
+    (define (make-tai-clock-from-posix-like-clock call-with-current-clock-values)
+      (define (consumer second leap-second-indicator)
+        (+ second (tai-to-utc-offset-at-utc-day (/ second seconds-per-day))))
+      (lambda ()
+        (call-with-current-clock-values consumer)))
+    
+    (define (make-tai-clock-from-ntp-like-clock call-with-current-clock-values)
+      (define (consumer second leap-second-indicator)
+        (+ second
+           (tai-to-utc-offset-at-utc-day (/ second seconds-per-day))
+           (if leap-second-indicator 1.0 0.0)))
+      (lambda ()
+        (call-with-current-clock-values consumer)))
+    
+    ;; (make-tai-clock type call-with-current-clock-values)
+    ;;
+    ;; The make-tai-clock procedure returns a procedure that, when
+    ;; called with no arguments, returns an estimate of the number of
+    ;; TAI seconds since 1970-01-01 00:00:00 TAI.
+    ;;
+    ;; The type and call-with-current-clock-values argument should
+    ;; conform to the descriptions in the documentation of the (clock
+    ;; system-clock) library.
+    
+    (define (make-tai-clock type call-with-current-clock-values)
+      (case type
+        ((tai-like)
+         (make-tai-clock-from-tai-like-clock call-with-current-clock-values))
+        ((posix-like)
+         (make-tai-clock-from-posix-like-clock call-with-current-clock-values))
+        ((ntp-like)
+         (make-tai-clock-from-ntp-like-clock call-with-current-clock-values))
+        (else
+         (error "invalid clock type" type))))))
diff --git a/lib/scheme/write.sld b/lib/scheme/write.sld
new file mode 100644
index 00000000..4a2d7390
--- /dev/null
+++ b/lib/scheme/write.sld
@@ -0,0 +1,10 @@
+
+(define-library (scheme write)
+  (import (rename (chibi) (write write-simple) (display display-simple))
+          (rename (srfi 38) (write/ss write-shared)))
+  (export display write write-shared write-simple)
+  (begin
+    (define (display x . o)
+      (apply (if (or (string? x) (char? x)) display-simple write) x o))
+    (define (write x . o)
+      (write-shared x (if (pair? o) (car o) (current-output-port)) #t))))
diff --git a/lib/srfi/1.sld b/lib/srfi/1.sld
new file mode 100644
index 00000000..8e9498a8
--- /dev/null
+++ b/lib/srfi/1.sld
@@ -0,0 +1,31 @@
+
+(define-library (srfi 1)
+  (export
+   xcons cons* make-list list-tabulate list-copy circular-list iota
+   proper-list? circular-list? dotted-list? not-pair? null-list? list=
+   first second third fourth fifth sixth seventh eighth ninth tenth
+   car+cdr take drop take-right drop-right take! drop-right! split-at split-at!
+   last last-pair length+ concatenate append! concatenate! reverse!
+   append-reverse append-reverse!
+   zip unzip1 unzip2 unzip3 unzip4 unzip5 count
+   fold unfold pair-fold reduce fold-right unfold-right
+   pair-fold-right reduce-right
+   append-map append-map! map! pair-for-each filter-map map-in-order
+   filter partition remove filter! partition! remove! find find-tail any every
+   list-index take-while drop-while take-while! span break span! break!
+   delete delete-duplicates delete! delete-duplicates!
+   alist-cons alist-copy alist-delete alist-delete!
+   lset<= lset= lset-adjoin lset-union lset-union! lset-intersection
+   lset-intersection! lset-difference lset-difference! lset-xor lset-xor!
+   lset-diff+intersection lset-diff+intersection!)
+  (import (chibi))
+  (include "1/predicates.scm"
+           "1/selectors.scm"
+           "1/search.scm"
+           "1/misc.scm"
+           "1/constructors.scm"
+           "1/fold.scm"
+           "1/deletion.scm"
+           "1/alists.scm"
+           "1/lset.scm"))
+
diff --git a/lib/srfi/1/alists.scm b/lib/srfi/1/alists.scm
new file mode 100644
index 00000000..a35db42c
--- /dev/null
+++ b/lib/srfi/1/alists.scm
@@ -0,0 +1,14 @@
+;; alist.scm -- association list utilities
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (alist-cons key value ls) (cons (cons key value) ls))
+
+(define (alist-copy ls) (map (lambda (x) (cons (car x) (cdr x))) ls))
+
+(define (alist-delete key ls . o)
+  (let ((eq (if (pair? o) (car o) equal?)))
+    (remove (lambda (x) (eq (car x) key)) ls)))
+
+(define alist-delete! alist-delete)
+
diff --git a/lib/srfi/1/constructors.scm b/lib/srfi/1/constructors.scm
new file mode 100644
index 00000000..09eae17b
--- /dev/null
+++ b/lib/srfi/1/constructors.scm
@@ -0,0 +1,28 @@
+;; constructors.scm -- list construction utilities
+;; Copyright (c) 2009-2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (xcons a b) (cons b a))
+
+(define (cons* x . args)
+  (let lp ((rev '()) (x x) (ls args))
+    (if (null? ls)
+        (append-reverse rev x)
+        (lp (cons x rev) (car ls) (cdr ls)))))
+
+(define (list-tabulate n proc)
+  (let lp ((n (- n 1)) (res '()))
+    (if (< n 0) res (lp (- n 1) (cons (proc n) res)))))
+
+(define (circular-list x . args)
+  (let ((res (cons x args)))
+    (set-cdr! (last-pair res) res)
+    res))
+
+(define (iota count . o)
+  (let ((start (if (pair? o) (car o) 0))
+        (step (if (and (pair? o) (pair? (cdr o))) (cadr o) 1)))
+    (let lp ((i count) (res '()))
+      (if (<= i 0)
+          res
+          (lp (- i 1) (cons (+ start (* (- i 1) step)) res))))))
diff --git a/lib/srfi/1/deletion.scm b/lib/srfi/1/deletion.scm
new file mode 100644
index 00000000..5466d7be
--- /dev/null
+++ b/lib/srfi/1/deletion.scm
@@ -0,0 +1,24 @@
+;; deletion.scm -- list deletion utilities
+;; Copyright (c) 2009-2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (delete x ls . o)
+  (let ((eq (if (pair? o) (car o) equal?)))
+    (if (eq? eq eq?)
+        (let lp ((ls ls) (rev '())) ;; fast path for delq
+          (let ((tail (memq x ls)))
+            (if tail
+                (lp (cdr tail) (take-up-to-reverse ls tail rev))
+                (if (pair? rev) (append-reverse! rev ls) ls))))
+        (remove (lambda (y) (eq x y)) ls))))
+
+(define delete! delete)
+
+(define (delete-duplicates ls . o)
+  (let ((eq (if (pair? o) (car o) equal?)))
+    (let lp ((ls ls) (res '()))
+      (if (pair? ls)
+          (lp (cdr ls) (if (member (car ls) res eq) res (cons (car ls) res)))
+          (reverse! res)))))
+
+(define delete-duplicates! delete-duplicates)
diff --git a/lib/srfi/1/fold.scm b/lib/srfi/1/fold.scm
new file mode 100644
index 00000000..babce309
--- /dev/null
+++ b/lib/srfi/1/fold.scm
@@ -0,0 +1,113 @@
+;; fold.scm -- list fold/reduce utilities
+;; Copyright (c) 2009-2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (fold kons knil ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls) (acc knil))
+        (if (pair? ls) (lp (cdr ls) (kons (car ls) acc)) acc))
+      (let lp ((lists (cons ls lists)) (acc knil))
+        (if (every pair? lists)
+            (lp (map cdr lists) (apply kons (map-onto car lists (list acc))))
+            acc))))
+
+(define (fold-right kons knil ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls))
+        (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil))
+      (let lp ((lists (cons ls lists)))
+        (if (every pair? lists)
+            (apply kons (map-onto car lists (list (lp (map cdr lists)))))
+            knil))))
+
+(define (pair-fold kons knil ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls) (acc knil))
+        (if (pair? ls) (lp (cdr ls) (kons ls acc)) acc))
+      (let lp ((lists (cons ls lists)) (acc knil))
+        (if (every pair? lists)
+            (lp (map cdr lists) (apply kons (append lists (list acc))))
+            acc))))
+
+(define (pair-fold-right kons knil ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls))
+        (if (pair? ls) (kons ls (lp (cdr ls))) knil))
+      (let lp ((lists (cons ls lists)))
+        (if (every pair? lists)
+            (apply kons (append lists (list (lp (map cdr lists)))))
+            knil))))
+
+(define (reduce f identity ls)
+  (if (null? ls) identity (fold f (car ls) (cdr ls))))
+
+(define (reduce-right f identity ls)
+  (if (null? ls) identity (fold-right f (car ls) (cdr ls))))
+
+(define (unfold p f g seed . o)
+  (let lp ((seed seed))
+    (if (p seed)
+        (if (pair? o) ((car o) seed) '())
+        (cons (f seed) (lp (g seed))))))
+
+(define (unfold-right p f g seed . o)
+  (let lp ((seed seed) (res (if (pair? o) (car o) '())))
+    (if (p seed) res (lp (g seed) (cons (f seed) res)))))
+
+(define (append-map-helper append f ls lists)
+  (if (null? lists)
+      (if (null? ls)
+          '()
+          (let lp ((ls (reverse ls)) (res '()))
+            (if (null? ls) res (lp (cdr ls) (append (f (car ls)) res)))))
+      (if (and (pair? ls) (every pair? lists))
+          (let lp ((lists (cons ls lists)))
+            (let ((vals (apply f (map car lists)))
+                  (cdrs (map cdr lists)))
+              (if (every pair? cdrs) (append vals (lp cdrs)) vals)))
+          '())))
+
+(define (append-map f ls . lists)
+  (append-map-helper append f ls lists))
+
+(define (append-map! f ls . lists)
+  (append-map-helper append! f ls lists))
+
+(define map! map)
+(define map-in-order map)
+
+(define (pair-for-each f ls . lists)
+  (apply pair-fold (lambda (x _) (f x)) #f ls lists))
+
+(define (filter-map f ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls) (res '()))
+        (if (pair? ls)
+            (let ((x (f (car ls)))) (lp (cdr ls) (if x (cons x res) res)))
+            (reverse! res)))
+      (filter (lambda (x) x) (apply map f ls lists))))
+
+(define (take-up-to-reverse from to init)
+  (if (eq? from to)
+      init
+      (take-up-to-reverse (cdr from) to (cons (car from) init))))
+
+(define (remove pred ls)
+  (let lp ((ls ls) (rev '()))
+    (let ((tail (find-tail pred ls)))
+      (if tail
+          (lp (cdr tail) (take-up-to-reverse ls tail rev))
+          (if (pair? rev) (append-reverse! rev ls) ls)))))
+
+(define (filter pred ls) (remove (lambda (x) (not (pred x))) ls))
+
+(define (partition pred ls)
+  (let lp ((ls ls) (good '()) (bad '()))
+    (cond ((null? ls) (values (reverse! good) (reverse! bad)))
+          ((pred (car ls)) (lp (cdr ls) (cons (car ls) good) bad))
+          (else (lp (cdr ls) good (cons (car ls) bad))))))
+
+(define filter! filter)
+(define remove! remove)
+(define partition! partition)
+
diff --git a/lib/srfi/1/lset.scm b/lib/srfi/1/lset.scm
new file mode 100644
index 00000000..8245fed3
--- /dev/null
+++ b/lib/srfi/1/lset.scm
@@ -0,0 +1,52 @@
+;; lset.scm -- list set library
+;; Copyright (c) 2009-2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (lset<= eq . sets)
+  (if (null? sets)
+      #t
+      (let lp1 ((set1 (car sets)) (sets (cdr sets)))
+        (if (null? sets)
+            #t
+            (let ((set2 (car sets)))
+              (let lp2 ((ls set1))
+                (if (pair? ls)
+                    (and (member (car ls) set2 eq) (lp2 (cdr ls)))
+                    (lp1 set2 (cdr sets)))))))))
+
+(define (lset= eq . sets)
+  (and (apply lset<= eq sets) (apply lset<= eq (reverse sets))))
+
+(define (lset-adjoin eq set . elts)
+  (lset-union2 eq set elts))
+
+(define (lset-union2 eq a b)
+  (if (null? b)
+      a
+      (lset-union2 eq (if (member (car b) a eq) a (cons (car b) a)) (cdr b))))
+
+(define (lset-union eq . sets)
+  (reduce (lambda (a b) (lset-union2 eq b a)) '() sets))
+
+(define (lset-intersection eq . sets)
+  (reduce (lambda (a b) (filter (lambda (x) (member x a eq)) b)) '() sets))
+
+(define (lset-diff2 eq a b)
+  (remove (lambda (x) (member x a eq)) b))
+
+(define (lset-difference eq . sets)
+  (reduce (lambda (a b) (lset-diff2 eq a b)) '() sets))
+
+(define (lset-xor eq . sets)
+  (reduce (lambda (a b) (append (lset-diff2 eq a b) (lset-diff2 eq b a)))
+          '()
+          sets))
+
+(define (lset-diff+intersection eq . sets)
+  (values (apply lset-difference eq sets) (apply lset-intersection eq sets)))
+
+(define lset-diff+intersection! lset-diff+intersection)
+(define lset-xor! lset-xor)
+(define lset-difference! lset-difference)
+(define lset-intersection! lset-intersection)
+(define lset-union! lset-union)
diff --git a/lib/srfi/1/misc.scm b/lib/srfi/1/misc.scm
new file mode 100644
index 00000000..ce360dc8
--- /dev/null
+++ b/lib/srfi/1/misc.scm
@@ -0,0 +1,53 @@
+;; misc.scm -- miscellaneous list utilities
+;; Copyright (c) 2009-2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (map-onto proc ls init)
+  (let lp ((ls (reverse ls)) (res init))
+    (if (null? ls) res (lp (cdr ls) (cons (proc (car ls)) res)))))
+
+(define (append! . lists) (concatenate! lists))
+
+(define (concatenate lists)
+  (let lp ((ls (reverse lists)) (res '()))
+    (if (null? ls) res (lp (cdr ls) (append (car ls) res)))))
+
+(define (concatenate! lists)
+  (if (null? lists)
+      '()
+      (let lp ((ls lists))
+        (cond ((not (pair? (cdr ls)))
+               (car lists))
+              (else
+               (set-cdr! (last-pair (car ls)) (cadr ls))
+               (lp (cdr ls)))))))
+
+(define (append-reverse rev tail)
+  (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail))))
+
+(define (append-reverse! rev tail)
+  (if (null? rev)
+      tail
+      (let ((head (reverse! rev)))
+        (set-cdr! rev tail)
+        head)))
+
+(define (zip . lists) (apply map list lists))
+
+(define (unzip1 ls) (map first ls))
+(define (unzip2 ls) (values (map first ls) (map second ls)))
+(define (unzip3 ls) (values (map first ls) (map second ls) (map third ls)))
+(define (unzip4 ls)
+  (values (map first ls) (map second ls) (map third ls) (map fourth ls)))
+(define (unzip5 ls)
+  (values (map first ls) (map second ls) (map third ls) (map fourth ls)
+          (map fifth ls)))
+
+(define (count pred ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls) (res 0))
+        (if (pair? ls) (lp (cdr ls) (if (pred (car ls)) (+ res 1) res)) res))
+      (let lp ((lists (cons ls lists)) (res 0))
+        (if (every pair? lists)
+            (lp (map cdr lists) (if (apply pred (map car lists)) (+ res 1) res))
+            res))))
diff --git a/lib/srfi/1/predicates.scm b/lib/srfi/1/predicates.scm
new file mode 100644
index 00000000..942bfdab
--- /dev/null
+++ b/lib/srfi/1/predicates.scm
@@ -0,0 +1,44 @@
+;; predicates.scm -- list prediates
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (proper-list? x)
+  (cond ((null? x) #t)
+        ((pair? x) (proper-list? (cdr x)))
+        (else #f)))
+
+(define (circular-list? x)
+  (and (pair? x) (pair? (cdr x))
+       (let race ((hare (cdr x)) (tortoise x))
+         (or (eq? hare tortoise)
+             (and (pair? hare) (pair? (cdr hare))
+                  (race (cddr hare) (cdr tortoise)))))))
+
+(define (dotted-list? x)
+  (not (proper-list? x)))
+
+(define (not-pair? x) (not (pair? x)))
+
+(define (null-list? x) (null? x)) ; no error
+
+(define (list= eq . lists)
+  (let lp1 ((lists lists))
+    (or (null? lists)
+        (null? (cdr lists))
+        (let lp2 ((ls1 (car lists)) (ls2 (cadr lists)))
+          (if (null? ls1)
+              (and (null? ls2)
+                   (lp1 (cdr lists)))
+              (and (eq (car ls1) (car ls2))
+                   (lp2 (cdr ls1) (cdr ls2))))))))
+
+(define (length+ x)
+  (if (not (pair? x))
+      0
+      (let lp ((hare (cdr x)) (tortoise x) (res 1))
+        (and (not (eq? hare tortoise))
+             (if (pair? hare)
+                 (if (not (pair? (cdr hare)))
+                     (+ res 1)
+                     (lp (cddr hare) (cdr tortoise) (+ res 2)))
+                 res)))))
diff --git a/lib/srfi/1/search.scm b/lib/srfi/1/search.scm
new file mode 100644
index 00000000..9b65b1ca
--- /dev/null
+++ b/lib/srfi/1/search.scm
@@ -0,0 +1,35 @@
+;; search.scm -- list searching and splitting
+;; Copyright (c) 2009-2011 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (take-while pred ls)
+  (let lp ((ls ls) (res '()))
+    (if (and (pair? ls) (pred (car ls)))
+        (lp (cdr ls) (cons (car ls) res))
+        (reverse! res))))
+
+(define take-while! take-while)
+
+(define (drop-while pred ls)
+  (or (find-tail (lambda (x) (not (pred x))) ls) '()))
+
+(define (span pred ls)
+  (let lp ((ls ls) (res '()))
+    (if (and (pair? ls) (pred (car ls)))
+        (lp (cdr ls) (cons (car ls) res))
+        (values (reverse! res) ls))))
+
+(define span! span)
+
+(define (break pred ls) (span (lambda (x) (not (pred x))) ls))
+
+(define break! break)
+
+(define (list-index pred ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls) (n 0))
+        (and (pair? ls) (if (pred (car ls)) n (lp (cdr ls) (+ n 1)))))
+      (let lp ((lists (cons ls lists)) (n 0))
+        (and (every pair? lists)
+             (if (apply pred (map car lists)) n (lp (map cdr lists) (+ n 1)))
+             ))))
diff --git a/lib/srfi/1/selectors.scm b/lib/srfi/1/selectors.scm
new file mode 100644
index 00000000..66dca43c
--- /dev/null
+++ b/lib/srfi/1/selectors.scm
@@ -0,0 +1,59 @@
+;; selectors.scm -- extended list selectors
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define first car)
+(define second cadr)
+(define (third ls)   (car (cdr (cdr ls))))
+(define (fourth ls)  (car (cdr (cdr (cdr ls)))))
+(define (fifth ls)   (car (cdr (cdr (cdr (cdr ls))))))
+(define (sixth ls)   (car (cdr (cdr (cdr (cdr (cdr ls)))))))
+(define (seventh ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))
+(define (eighth ls)  (car (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))
+(define (ninth ls)   (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))))
+(define (tenth ls)   (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))))
+
+(define (car+cdr x) (values (car x) (cdr x)))
+
+(define (take ls i)
+  (let lp ((i i) (ls ls) (res '()))
+    (if (<= i 0)
+        (reverse! res)
+        (lp (- i 1) (cdr ls) (cons (car ls) res)))))
+
+(define (take! ls i)
+  (if (<= i 0)
+      '()
+      (let ((tail (list-tail ls (- i 1))))
+        (set-cdr! tail '())
+        ls)))
+
+(define (drop ls i)
+  (if (<= i 0) ls (drop (cdr ls) (- i 1))))
+
+(define (take-right ls i)
+  (drop ls (- (length+ ls) i)))
+
+(define (drop-right ls i)
+  (take ls (- (length+ ls) i)))
+
+(define (drop-right! ls i)
+  (take! ls (- (length+ ls) i)))
+
+(define (split-at ls i)
+  (let lp ((i i) (ls ls) (res '()))
+    (if (<= i 0)
+        (values (reverse! res) ls)
+        (lp (- i 1) (cdr ls) (cons (car ls) res)))))
+
+(define (split-at! ls i)
+  (if (<= i 0)
+      (values '() ls)
+      (let* ((tail (list-tail ls (- i 1)))
+             (right (cdr tail)))
+        (set-cdr! tail '())
+        (values ls right))))
+
+(define (last ls) (if (null? (cdr ls)) (car ls) (last (cdr ls))))
+(define (last-pair ls) (if (null? (cdr ls)) ls (last-pair (cdr ls))))
+
diff --git a/lib/srfi/11.sld b/lib/srfi/11.sld
new file mode 100644
index 00000000..0a3512ac
--- /dev/null
+++ b/lib/srfi/11.sld
@@ -0,0 +1,27 @@
+
+(define-library (srfi 11)
+  (export let-values let*-values)
+  (import (chibi))
+  (begin
+   (define-syntax let*-values
+     (syntax-rules ()
+       ((let*-values () . body)
+        (begin . body))
+       ((let*-values (((a) expr) . rest) . body)
+        (let ((a expr)) (let*-values rest . body)))
+       ((let*-values ((params expr) . rest) . body)
+        (call-with-values (lambda () expr)
+          (lambda params (let*-values rest . body))))))
+   (define-syntax let-values
+     (syntax-rules ()
+       ((let-values ("step") (binds ...) bind expr maps () () . body)
+        (let*-values (binds ... (bind expr)) (let maps . body)))
+       ((let-values ("step") (binds ...) bind old-expr maps () ((params expr) . rest) . body)
+        (let-values ("step") (binds ... (bind old-expr)) () expr maps params rest . body))
+       ((let-values ("step") binds (bind ...) expr (maps ...) (x . y) rest . body)
+        (let-values ("step") binds (bind ... tmp) expr (maps ... (x tmp)) y rest . body))
+       ((let-values ("step") binds (bind ...) expr (maps ...) x rest . body)
+        (let-values ("step") binds (bind ... . tmp) expr (maps ... (x tmp)) () rest . body))
+       ((let-values ((params expr) . rest) . body)
+        (let-values ("step") () () expr () params rest . body))
+       ))))
diff --git a/lib/srfi/16.sld b/lib/srfi/16.sld
new file mode 100644
index 00000000..0434e40b
--- /dev/null
+++ b/lib/srfi/16.sld
@@ -0,0 +1,23 @@
+
+(define-library (srfi 16)
+  (export case-lambda)
+  (import (chibi))
+  (begin
+   (define-syntax %case
+     (syntax-rules ()
+       ((%case args len n p ((params ...) . body) . rest)
+        (if (= len (length '(params ...)))
+            (apply (lambda (params ...) . body) args)
+            (%case args len 0 () . rest)))
+       ((%case args len n (p ...) ((x . y) . body) . rest)
+        (%case args len (+ n 1) (p ... x) (y . body) . rest))
+       ((%case args len n (p ...) (y . body) . rest)
+        (if (>= len n)
+            (apply (lambda (p ... . y) . body) args)
+            (%case args len 0 () . rest)))
+       ((%case args len n p)
+        (error "case-lambda: no cases matched"))))
+   (define-syntax case-lambda
+     (syntax-rules ()
+       ((case-lambda . clauses)
+        (lambda args (let ((len (length* args))) (%case args len 0 () . clauses))))))))
diff --git a/lib/srfi/18.sld b/lib/srfi/18.sld
new file mode 100644
index 00000000..38d32add
--- /dev/null
+++ b/lib/srfi/18.sld
@@ -0,0 +1,26 @@
+
+(define-library (srfi 18)
+  (export
+   current-thread thread? make-thread thread-name
+   thread-specific thread-specific-set! thread-start!
+   thread-yield! thread-sleep! thread-terminate!
+   thread-join! mutex? make-mutex mutex-name
+   mutex-specific mutex-specific-set! mutex-state
+   mutex-lock! mutex-unlock! condition-variable?
+   make-condition-variable condition-variable-name
+   condition-variable-specific condition-variable-specific-set!
+   condition-variable-signal! condition-variable-broadcast!
+   current-time time? time->seconds seconds->time
+   current-exception-handler with-exception-handler raise
+   join-timeout-exception? abandoned-mutex-exception?
+   terminated-thread-exception? uncaught-exception?
+   uncaught-exception-reason)
+  (cond-expand
+   (threads
+    (import (chibi) (srfi 9) (chibi ast)
+            (except (chibi time) time->seconds seconds->time))
+    (include "18/types.scm")
+    (include-shared "18/threads")
+    (include "18/interface.scm"))
+   (else
+    (error "chibi was not compiled with threading support"))))
diff --git a/lib/srfi/18/interface.scm b/lib/srfi/18/interface.scm
new file mode 100644
index 00000000..d95522ee
--- /dev/null
+++ b/lib/srfi/18/interface.scm
@@ -0,0 +1,91 @@
+
+(define current-time get-time-of-day)
+(define (time? x) (timeval? (if (pair? x) (car x) x)))
+
+(define (time->seconds x)
+  (timeval-seconds (if (pair? x) (car x) x)))
+
+(define (seconds->time x)
+  (make-timeval (if (inexact? x) (inexact->exact (round x)) x) 0))
+
+(define (timeout->seconds x)
+  (if (time? x) (- (time->seconds x) (time->seconds (current-time))) x))
+
+(define thread-yield! yield!)
+
+(define (thread-result thread)
+  (cond
+   ((%thread-exception? thread)
+    (raise (%thread-end-result thread)))
+   (else
+    (%thread-end-result thread))))
+
+(define (thread-join! thread . o)
+  (let ((timeout (and (pair? o) (car o))))
+    (let lp ()
+      (cond
+       ((%thread-join! thread (timeout->seconds timeout))
+        (thread-result thread))
+       (else
+        (thread-yield!)
+        (cond
+         ((and timeout (thread-timeout?))
+          (if (and (pair? o) (pair? (cdr o)))
+              (cadr o)
+              (error "timed out waiting for thread" thread)))
+         (else
+          (lp))))))))
+
+(define (thread-terminate! thread)
+  (if (%thread-terminate! thread) ;; need to yield if terminating ourself
+      (thread-yield!)))
+
+(define (thread-sleep! timeout)
+  (%thread-sleep! (timeout->seconds timeout))
+  (thread-yield!))
+
+(define (mutex-lock! mutex . o)
+  (let ((timeout (and (pair? o) (car o)))
+        (thread (if (and (pair? o) (pair? (cdr o))) (cadr o) #t)))
+    (cond
+     ((%mutex-lock! mutex (timeout->seconds timeout) thread))
+     (else
+      (thread-yield!)
+      ;; If we timed out, fail.
+      (if (thread-timeout?)
+          #f
+          ;; Otherwise the lock was released, try again.
+          (mutex-lock! mutex timeout thread))))))
+
+(define (mutex-unlock! mutex . o)
+  (let ((condvar (and (pair? o) (car o)))
+        (timeout (if (and (pair? o) (pair? (cdr o))) (cadr o) #f)))
+    (cond
+     ((%mutex-unlock! mutex condvar (timeout->seconds timeout)))
+     (else
+      (thread-yield!)
+      (not (thread-timeout?))))))
+
+(define (join-timeout-exception? x)
+  (and (exception? x)
+       (equal? (exception-message x) "timed out waiting for thread")))
+
+;; XXXX flush out exception types
+(define (abandoned-mutex-exception? x) #f)
+(define (terminated-thread-exception? x) #f)
+(define (uncaught-exception? x) #f)
+(define (uncaught-exception-reason x) #f)
+
+;; signal runner
+
+(define (signal-runner)
+  (let lp ()
+    (let ((n (pop-signal!)))
+      (cond
+       ((integer? n)
+        (let ((handler (get-signal-handler n)))
+          (if (procedure? handler)
+              (handler n))))
+       (else
+        (thread-sleep! #t))))
+    (lp)))
diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c
new file mode 100644
index 00000000..2858273e
--- /dev/null
+++ b/lib/srfi/18/threads.c
@@ -0,0 +1,696 @@
+/*  threads.c -- SRFI-18 thread primitives                    */
+/*  Copyright (c) 2010-2012 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+#include <time.h>
+#include <sys/time.h>
+#include <unistd.h>
+#include <poll.h>
+
+#define sexp_mutexp(ctx, x)      (sexp_check_tag(x, sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_THREADS_MUTEX_ID))))
+#define sexp_mutex_name(x)       sexp_slot_ref(x, 0)
+#define sexp_mutex_specific(x)   sexp_slot_ref(x, 1)
+#define sexp_mutex_thread(x)     sexp_slot_ref(x, 2)
+#define sexp_mutex_lockp(x)      sexp_slot_ref(x, 3)
+
+#define sexp_condvar_name(x)     sexp_slot_ref(x, 0)
+#define sexp_condvar_specific(x) sexp_slot_ref(x, 1)
+#define sexp_condvar_threads(x)  sexp_slot_ref(x, 2)
+
+struct sexp_pollfds_t {
+  struct pollfd *fds;
+  nfds_t nfds, mfds;
+};
+
+#define SEXP_INIT_POLLFDS_MAX_FDS 16
+
+#define sexp_pollfdsp(ctx, x)    (sexp_check_tag(x, sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_THREADS_POLLFDS_ID))))
+#define sexp_pollfds_fds(x)      (((struct sexp_pollfds_t*)(&(x)->value))->fds)
+#define sexp_pollfds_num_fds(x)  (((struct sexp_pollfds_t*)(&(x)->value))->nfds)
+#define sexp_pollfds_max_fds(x)  (((struct sexp_pollfds_t*)(&(x)->value))->mfds)
+
+#define sexp_sizeof_pollfds (sexp_sizeof_header + sizeof(struct sexp_pollfds_t))
+
+#define timeval_le(a, b) (((a).tv_sec < (b).tv_sec) || (((a).tv_sec == (b).tv_sec) && ((a).tv_usec < (b).tv_usec)))
+#define sexp_context_before(c, t) (((sexp_context_timeval(c).tv_sec != 0) || (sexp_context_timeval(c).tv_usec != 0)) && timeval_le(sexp_context_timeval(c), t))
+
+/**************************** threads *************************************/
+
+#if SEXP_USE_GREEN_THREADS
+
+static void sexp_define_type_predicate_by_tag (sexp ctx, sexp env, const char *cname, sexp_uint_t type) {
+  sexp_gc_var2(name, op);
+  sexp_gc_preserve2(ctx, name, op);
+  name = sexp_c_string(ctx, cname, -1);
+  op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type));
+  sexp_env_define(ctx, env, name=sexp_intern(ctx, cname, -1), op);
+  sexp_gc_release2(ctx);
+}
+
+sexp sexp_thread_timeoutp (sexp ctx, sexp self, sexp_sint_t n) {
+  return sexp_make_boolean(sexp_context_timeoutp(ctx));
+}
+
+sexp sexp_thread_name (sexp ctx, sexp self, sexp_sint_t n, sexp thread) {
+  sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
+  return sexp_context_name(thread);
+}
+
+sexp sexp_thread_specific (sexp ctx, sexp self, sexp_sint_t n, sexp thread) {
+  sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
+  return sexp_context_specific(thread);
+}
+
+sexp sexp_thread_specific_set (sexp ctx, sexp self, sexp_sint_t n, sexp thread, sexp val) {
+  sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
+  sexp_context_specific(thread) = val;
+  return SEXP_VOID;
+}
+
+sexp sexp_thread_end_result (sexp ctx, sexp self, sexp_sint_t n, sexp thread) {
+  sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
+  return sexp_context_result(thread) ? sexp_context_result(thread) : SEXP_VOID;
+}
+
+sexp sexp_thread_exceptionp (sexp ctx, sexp self, sexp_sint_t n, sexp thread) {
+  sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
+  return sexp_make_boolean(sexp_context_errorp(thread));
+}
+
+sexp sexp_current_thread (sexp ctx, sexp self, sexp_sint_t n) {
+  return ctx;
+}
+
+sexp sexp_make_thread (sexp ctx, sexp self, sexp_sint_t n, sexp thunk, sexp name) {
+  sexp *stack;
+  sexp_gc_var1(res);
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, thunk);
+  sexp_gc_preserve1(ctx, res);
+  res = sexp_make_eval_context(ctx, SEXP_FALSE, sexp_context_env(ctx), 0, 0);
+  sexp_context_name(res) = name;
+  sexp_context_proc(res) = thunk;
+  sexp_context_ip(res) = sexp_bytecode_data(sexp_procedure_code(thunk));
+  stack = sexp_stack_data(sexp_context_stack(res));
+  stack[0] = stack[1] = stack[3] = SEXP_ZERO;
+  stack[2] = sexp_global(ctx, SEXP_G_FINAL_RESUMER);
+  sexp_context_top(res) = 4;
+  sexp_context_last_fp(res) = 0;
+  sexp_context_dk(res) = sexp_make_vector(res, SEXP_FOUR, SEXP_FALSE);
+  sexp_vector_set(sexp_context_dk(res), SEXP_ZERO, SEXP_ZERO);
+  /* reset parameters */
+  sexp_context_params(res) = SEXP_NULL;
+  /* alternately reset only the current exception handler */
+  /* for (ls1=sexp_context_params(ctx), ls2=SEXP_NULL; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) */
+  /*   if (sexp_caar(ls1) != sexp_global(ctx, SEXP_G_ERR_HANDLER)) */
+  /*     ls2 = sexp_cons(ctx, sexp_car(ls1), ls2); */
+  /* sexp_context_params(res) = ls2; */
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_thread_start (sexp ctx, sexp self, sexp_sint_t n, sexp thread) {
+  sexp cell;
+  sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
+  sexp_context_errorp(thread) = 0;
+  cell = sexp_cons(ctx, thread, SEXP_NULL);
+  if (sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) {
+    sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = cell;
+    sexp_global(ctx, SEXP_G_THREADS_BACK) = cell;
+  } else {            /* init queue */
+    sexp_global(ctx, SEXP_G_THREADS_BACK) = sexp_global(ctx, SEXP_G_THREADS_FRONT) = cell;
+  }
+  return thread;
+}
+
+static int sexp_delete_list (sexp ctx, int global, sexp x) {
+  sexp ls1=NULL, ls2=sexp_global(ctx, global);
+  for ( ; sexp_pairp(ls2) && sexp_car(ls2) != x; ls1=ls2, ls2=sexp_cdr(ls2))
+    ;
+  if (sexp_pairp(ls2)) {
+    if (ls1) sexp_cdr(ls1) = sexp_cdr(ls2);
+    else     sexp_global(ctx, global) = sexp_cdr(ls2);
+    return 1;
+  } else {
+    return 0;
+  }
+}
+
+sexp sexp_thread_terminate (sexp ctx, sexp self, sexp_sint_t n, sexp thread) {
+  sexp res = sexp_make_boolean(ctx == thread);
+  sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
+  /* terminate the thread and all children */
+  for ( ; thread && sexp_contextp(thread); thread=sexp_context_child(thread)) {
+    /* if not already terminated set an exception status */
+    if (sexp_context_refuel(ctx) > 0) {
+      sexp_context_errorp(thread) = 1;
+      sexp_context_result(thread) =
+        sexp_global(ctx, SEXP_G_THREAD_TERMINATE_ERROR);
+      /* zero the refuel - this tells the scheduler the thread is terminated */
+      sexp_context_refuel(thread) = 0;
+    }
+    /* unblock the thread if needed so it can be scheduled and terminated */
+    if (sexp_delete_list(ctx, SEXP_G_THREADS_PAUSED, thread))
+      sexp_thread_start(ctx, self, 1, thread);
+  }
+  /* return true if terminating self, then we can yield */
+  return res;
+}
+
+static void sexp_insert_timed (sexp ctx, sexp thread, sexp timeout) {
+#if SEXP_USE_FLONUMS
+  double d;
+#endif
+  sexp ls1=SEXP_NULL, ls2;
+  sexp_delete_list(ctx, SEXP_G_THREADS_PAUSED, thread);
+  ls2 = sexp_global(ctx, SEXP_G_THREADS_PAUSED);
+  if (sexp_realp(timeout))
+    gettimeofday(&sexp_context_timeval(thread), NULL);
+  if (sexp_fixnump(timeout)) {
+    sexp_context_timeval(thread).tv_sec += sexp_unbox_fixnum(timeout);
+#if SEXP_USE_FLONUMS
+  } else if (sexp_flonump(timeout)) {
+    d = sexp_flonum_value(timeout);
+    sexp_context_timeval(thread).tv_sec += trunc(d);
+    sexp_context_timeval(thread).tv_usec += (d-trunc(d))*1000000;
+    if (sexp_context_timeval(thread).tv_usec > 1000000) {
+      sexp_context_timeval(thread).tv_sec += 1;
+      sexp_context_timeval(thread).tv_usec -= 1000000;
+    }
+#endif
+#if SEXP_USE_RATIOS
+  } else if (sexp_ratiop(timeout)) {
+    d = sexp_ratio_to_double(timeout);
+    sexp_context_timeval(thread).tv_sec += trunc(d);
+    sexp_context_timeval(thread).tv_usec += (d-trunc(d))*1000000;
+    if (sexp_context_timeval(thread).tv_usec > 1000000) {
+      sexp_context_timeval(thread).tv_sec += 1;
+      sexp_context_timeval(thread).tv_usec -= 1000000;
+    }
+#endif
+  } else if (sexp_contextp(timeout)) {
+    sexp_context_timeval(thread).tv_sec = sexp_context_timeval(timeout).tv_sec;
+    sexp_context_timeval(thread).tv_usec = sexp_context_timeval(timeout).tv_usec;
+  } else {
+    sexp_context_timeval(thread).tv_sec = 0;
+    sexp_context_timeval(thread).tv_usec = 0;
+  }
+  if (sexp_realp(timeout) || sexp_contextp(timeout))
+    while (sexp_pairp(ls2)
+           && sexp_context_before(sexp_car(ls2), sexp_context_timeval(thread)))
+      ls1=ls2, ls2=sexp_cdr(ls2);
+  else
+    while (sexp_pairp(ls2) && sexp_context_timeval(sexp_car(ls2)).tv_sec)
+      ls1=ls2, ls2=sexp_cdr(ls2);
+  if (ls1 == SEXP_NULL)
+    sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cons(ctx, thread, ls2);
+  else
+    sexp_cdr(ls1) = sexp_cons(ctx, thread, ls2);
+}
+
+sexp sexp_thread_join (sexp ctx, sexp self, sexp_sint_t n, sexp thread, sexp timeout) {
+  sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
+  if (sexp_context_refuel(thread) <= 0) /* return true if already terminated */ {
+    return SEXP_TRUE;
+  }
+  sexp_context_timeoutp(ctx) = 0;
+  sexp_context_waitp(ctx) = 1;
+  sexp_context_event(ctx) = thread;
+  sexp_insert_timed(ctx, ctx, timeout);
+  return SEXP_FALSE;
+}
+
+sexp sexp_thread_sleep (sexp ctx, sexp self, sexp_sint_t n, sexp timeout) {
+  sexp_context_waitp(ctx) = 1;
+  if (timeout != SEXP_TRUE) {
+    sexp_assert_type(ctx, sexp_realp, SEXP_NUMBER, timeout);
+    sexp_context_event(ctx) = SEXP_FALSE;
+    sexp_insert_timed(ctx, ctx, timeout);
+  }
+  return SEXP_FALSE;
+}
+
+/**************************** mutexes *************************************/
+
+sexp sexp_mutex_state (sexp ctx, sexp self, sexp_sint_t n, sexp mutex) {
+  if (!sexp_mutexp(ctx, mutex))
+    return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_THREADS_POLLFDS_ID)), mutex);
+  if (sexp_truep(sexp_mutex_lockp(mutex))) {
+    if (sexp_contextp(sexp_mutex_thread(mutex)))
+      return sexp_mutex_thread(mutex);
+    else
+      return sexp_intern(ctx, "not-owned", -1);
+  } else {
+    return sexp_intern(ctx, (sexp_mutex_thread(mutex) ? "not-abandoned" : "abandoned"), -1);
+  }
+}
+
+sexp sexp_mutex_lock (sexp ctx, sexp self, sexp_sint_t n, sexp mutex, sexp timeout, sexp thread) {
+  if (thread == SEXP_TRUE)
+    thread = ctx;
+  if (sexp_not(sexp_mutex_lockp(mutex))) {
+    sexp_mutex_lockp(mutex) = SEXP_TRUE;
+    sexp_mutex_thread(mutex) = thread;
+    return SEXP_TRUE;
+  } else {
+    sexp_context_waitp(ctx) = 1;
+    sexp_context_event(ctx) = mutex;
+    sexp_insert_timed(ctx, ctx, timeout);
+    return SEXP_FALSE;
+  }
+}
+
+sexp sexp_mutex_unlock (sexp ctx, sexp self, sexp_sint_t n, sexp mutex, sexp condvar, sexp timeout) {
+  sexp ls1, ls2;
+  /* first unlock and unblock threads */
+  if (sexp_truep(sexp_mutex_lockp(mutex))) {
+    sexp_mutex_lockp(mutex) = SEXP_FALSE;
+    sexp_mutex_thread(mutex) = ctx;
+    /* search for threads blocked on this mutex */
+    for (ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED);
+         sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2))
+      if (sexp_context_event(sexp_car(ls2)) == mutex) {
+        if (ls1==SEXP_NULL)
+          sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2);
+        else
+          sexp_cdr(ls1) = sexp_cdr(ls2);
+        sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT);
+        sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2;
+        if (! sexp_pairp(sexp_cdr(ls2)))
+          sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2;
+        sexp_context_waitp(sexp_car(ls2))
+          = sexp_context_timeoutp(sexp_car(ls2)) = 0;
+        break;
+      }
+  }
+  if (sexp_truep(condvar)) {
+    /* wait on condition var if specified */
+    sexp_context_waitp(ctx) = 1;
+    sexp_context_event(ctx) = condvar;
+    sexp_insert_timed(ctx, ctx, timeout);
+    return SEXP_FALSE;
+  }
+  return SEXP_TRUE;
+}
+
+/**************************** condition variables *************************/
+
+sexp sexp_condition_variable_signal (sexp ctx, sexp self, sexp_sint_t n, sexp condvar) {
+  sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED);
+  for ( ; sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2))
+    if (sexp_context_event(sexp_car(ls2)) == condvar) {
+      if (ls1==SEXP_NULL)
+        sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2);
+      else
+        sexp_cdr(ls1) = sexp_cdr(ls2);
+      sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT);
+      sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2;
+      if (! sexp_pairp(sexp_cdr(ls2)))
+        sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2;
+      sexp_context_waitp(sexp_car(ls2)) = sexp_context_timeoutp(sexp_car(ls2)) = 0;
+      return SEXP_TRUE;
+    }
+  return SEXP_FALSE;
+}
+
+sexp sexp_condition_variable_broadcast (sexp ctx, sexp self, sexp_sint_t n, sexp condvar) {
+  sexp res = SEXP_FALSE;
+  while (sexp_truep(sexp_condition_variable_signal(ctx, self, n, condvar)))
+    res = SEXP_TRUE;
+  return res;
+}
+
+/**************************** the scheduler *******************************/
+
+static const sexp_uint_t sexp_log2_lookup[32] = {
+  0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, 
+  31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9
+};
+
+/* only works on powers of two */
+static sexp_uint_t sexp_log2_of_pow2 (sexp_uint_t n) {
+  return sexp_log2_lookup[((unsigned)n * 0x077CB531U) >> 27];
+}
+
+static sexp sexp_pop_signal (sexp ctx, sexp self, sexp_sint_t n) {
+  int allsigs, restsigs, signum;
+  if (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) == SEXP_ZERO) {
+    return SEXP_FALSE;
+  } else {
+    allsigs = sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_THREADS_SIGNALS));
+    restsigs = allsigs & (allsigs-1);
+    sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = sexp_make_fixnum(restsigs);
+    signum = sexp_log2_of_pow2(allsigs-restsigs);
+    return sexp_make_fixnum(signum);
+  }
+}
+
+static sexp sexp_get_signal_handler (sexp ctx, sexp self, sexp_sint_t n, sexp signum) {
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, signum);
+  return sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum);
+}
+
+static sexp sexp_make_pollfds (sexp ctx) {
+  sexp res = sexp_alloc_tagged(ctx, sexp_sizeof_pollfds, sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_THREADS_POLLFDS_ID)));
+  sexp_pollfds_fds(res) = malloc(SEXP_INIT_POLLFDS_MAX_FDS * sizeof(struct pollfd));
+  sexp_pollfds_num_fds(res) = 0;
+  sexp_pollfds_max_fds(res) = SEXP_INIT_POLLFDS_MAX_FDS;
+  return res;
+}
+
+static sexp sexp_free_pollfds (sexp ctx, sexp self, sexp_sint_t n, sexp pollfds) {
+  if (sexp_pollfds_fds(pollfds)) {
+    free(sexp_pollfds_fds(pollfds));
+    sexp_pollfds_fds(pollfds) = NULL;
+    sexp_pollfds_num_fds(pollfds) = 0;
+    sexp_pollfds_max_fds(pollfds) = 0;
+  }
+  return SEXP_VOID;
+}
+
+/* return true if this fd was already being polled */
+static sexp sexp_insert_pollfd (sexp ctx, int fd, int events) {
+  int i;
+  struct pollfd *pfd;
+  sexp pollfds = sexp_global(ctx, SEXP_G_THREADS_POLL_FDS);
+  if (! (pollfds && sexp_pollfdsp(ctx, pollfds))) {
+    sexp_global(ctx, SEXP_G_THREADS_POLL_FDS) = pollfds = sexp_make_pollfds(ctx);
+  }
+  for (i=0; i<sexp_pollfds_num_fds(pollfds); ++i) {
+    if (sexp_pollfds_fds(pollfds)[i].fd == fd) {
+      sexp_pollfds_fds(pollfds)[i].events |= events;
+      return SEXP_TRUE;
+    }
+  }
+  if (sexp_pollfds_num_fds(pollfds) == sexp_pollfds_max_fds(pollfds)) {
+    sexp_pollfds_max_fds(pollfds) = i*2;
+    pfd = sexp_pollfds_fds(pollfds);
+    sexp_pollfds_fds(pollfds) = malloc(i*2*sizeof(struct pollfd));
+    if (sexp_pollfds_fds(pollfds))
+      memcpy(sexp_pollfds_fds(pollfds), pfd, i*2*sizeof(struct pollfd));
+    free(pfd);
+  }
+  pfd = &(sexp_pollfds_fds(pollfds)[sexp_pollfds_num_fds(pollfds)++]);
+  pfd->fd = fd;
+  pfd->events = events;
+  return SEXP_FALSE;
+}
+
+/* block the current thread on the specified port */
+static sexp sexp_blocker (sexp ctx, sexp self, sexp_sint_t n, sexp portorfd, sexp timeout) {
+  int fd;
+  /* register the fd */
+  if (sexp_portp(portorfd))
+    fd = sexp_port_fileno(portorfd);
+  else if (sexp_filenop(portorfd))
+    fd = sexp_fileno_fd(portorfd);
+  else if (sexp_fixnump(portorfd))
+    fd = sexp_unbox_fixnum(portorfd);
+  else
+    return sexp_type_exception(ctx, self, SEXP_IPORT, portorfd);
+  if (fd >= 0)
+    sexp_insert_pollfd(ctx, fd, sexp_oportp(portorfd) ? POLLOUT : POLLIN);
+  /* pause the current thread */
+  sexp_context_waitp(ctx) = 1;
+  sexp_context_event(ctx) = portorfd;
+  sexp_insert_timed(ctx, ctx, timeout);
+  return SEXP_VOID;
+}
+
+sexp sexp_scheduler (sexp ctx, sexp self, sexp_sint_t n, sexp root_thread) {
+  int i, k;
+  struct timeval tval;
+  struct pollfd *pfds;
+  useconds_t usecs = 0;
+  sexp res, ls1, ls2, evt, runner, paused, front, pollfds;
+  sexp_gc_var1(tmp);
+  sexp_gc_preserve1(ctx, tmp);
+
+  front  = sexp_global(ctx, SEXP_G_THREADS_FRONT);
+  paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED);
+
+  /* check signals */
+  if (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) != SEXP_ZERO) {
+    runner = sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER);
+    if (! sexp_contextp(runner)) { /* ensure the runner exists */
+      if (sexp_envp(runner)) {
+        tmp = sexp_env_cell(ctx, runner, (tmp=sexp_intern(ctx, "signal-runner", -1)), 0);
+        if (sexp_pairp(tmp) && sexp_procedurep(sexp_cdr(tmp))) {
+          runner = sexp_make_thread(ctx, self, 2, sexp_cdr(tmp), SEXP_FALSE);
+          sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = runner;
+          sexp_thread_start(ctx, self, 1, runner);
+          if (!sexp_pairp(front))
+            front = sexp_global(ctx, SEXP_G_THREADS_FRONT);
+        }
+      }
+    } else if (sexp_context_waitp(runner)) { /* wake it if it's sleeping */
+      sexp_context_waitp(runner) = 0;
+      sexp_thread_start(ctx, self, 1, runner);
+    }
+  }
+
+  /* check blocked fds */
+  pollfds = sexp_global(ctx, SEXP_G_THREADS_POLL_FDS);
+  if (sexp_pollfdsp(ctx, pollfds) && sexp_pollfds_num_fds(pollfds) > 0) {
+    pfds = sexp_pollfds_fds(pollfds);
+    k = poll(sexp_pollfds_fds(pollfds), sexp_pollfds_num_fds(pollfds), 0);
+    for (i=sexp_pollfds_num_fds(pollfds)-1; i>=0 && k>0; --i) {
+      if (pfds[i].revents > 0) { /* free all threads blocked on this fd */
+        k--;
+        /* maybe unblock the current thread */
+        evt = sexp_context_event(ctx);
+        if ((sexp_portp(evt) && (sexp_port_fileno(evt) == pfds[i].fd))
+            || (sexp_fixnump(evt) && (sexp_unbox_fixnum(evt) == pfds[i].fd))) {
+          sexp_context_waitp(ctx) = 0;
+          sexp_context_timeoutp(ctx) = 0;
+          sexp_context_event(ctx) = SEXP_FALSE;
+        }
+        /* maybe unblock paused threads */
+        for (ls1=SEXP_NULL, ls2=paused; sexp_pairp(ls2); ) {
+          /* TODO: distinguish input and output on the same fd? */
+          evt = sexp_context_event(sexp_car(ls2));
+          if ((sexp_portp(evt) && sexp_port_fileno(evt) == pfds[i].fd)
+              || (sexp_fixnump(evt) && sexp_unbox_fixnum(evt) == pfds[i].fd)) {
+            sexp_context_waitp(sexp_car(ls2)) = 0;
+            sexp_context_timeoutp(sexp_car(ls2)) = 0;
+            sexp_context_event(sexp_car(ls2)) = SEXP_FALSE;
+            if (ls1==SEXP_NULL)
+              sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = sexp_cdr(ls2);
+            else
+              sexp_cdr(ls1) = sexp_cdr(ls2);
+            tmp = sexp_cdr(ls2);
+            sexp_cdr(ls2) = SEXP_NULL;
+            if (sexp_car(ls2) != ctx) {
+              if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) {
+                sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = ls2;
+              } else {
+                sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = ls2;
+              }
+              sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2;
+            }
+            ls2 = tmp;
+          } else {
+            ls1 = ls2;
+            ls2 = sexp_cdr(ls2);
+          }
+        }
+        if (i < (sexp_pollfds_num_fds(pollfds) - 1)) {
+          pfds[i] = pfds[sexp_pollfds_num_fds(pollfds) - 1];
+        }
+        sexp_pollfds_num_fds(pollfds) -= 1;
+      }
+    }
+  }
+
+  /* if we've terminated, check threads joining us */
+  if (sexp_context_refuel(ctx) <= 0) {
+    for (ls1=SEXP_NULL, ls2=paused; sexp_pairp(ls2); ) {
+      if (sexp_context_event(sexp_car(ls2)) == ctx) {
+        sexp_context_waitp(sexp_car(ls2)) = 0;
+        sexp_context_timeoutp(sexp_car(ls2)) = 0;
+        if (ls1==SEXP_NULL)
+          sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = sexp_cdr(ls2);
+        else
+          sexp_cdr(ls1) = sexp_cdr(ls2);
+        tmp = sexp_cdr(ls2);
+        sexp_cdr(ls2) = SEXP_NULL;
+        if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) {
+          sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = ls2;
+        } else {
+          sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = ls2;
+        }
+        sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2;
+        ls2 = tmp;
+      } else {
+        ls1 = ls2;
+        ls2 = sexp_cdr(ls2);
+      }
+    }
+  }
+
+  /* check timeouts */
+  if (sexp_pairp(paused)) {
+    if (gettimeofday(&tval, NULL) == 0) {
+      ls1 = SEXP_NULL;
+      ls2 = paused;
+      while (sexp_pairp(ls2) && sexp_context_before(sexp_car(ls2), tval)) {
+        sexp_context_timeoutp(sexp_car(ls2)) = 1;
+        sexp_context_waitp(sexp_car(ls2)) = 0;
+        ls1 = ls2;
+        ls2 = sexp_cdr(ls2);
+      }
+      if (sexp_pairp(ls1)) {
+        sexp_cdr(ls1) = SEXP_NULL;
+        if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) {
+          sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = paused;
+        } else {
+          sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = paused;
+        }
+        sexp_global(ctx, SEXP_G_THREADS_BACK) = ls1;
+        sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = ls2;
+      }
+    }
+  }
+
+  /* dequeue next thread */
+  if (sexp_pairp(front)) {
+    res = sexp_car(front);
+    if ((sexp_context_refuel(ctx) <= 0) || sexp_context_waitp(ctx)) {
+      /* orig ctx is either terminated or paused */
+      sexp_global(ctx, SEXP_G_THREADS_FRONT) = sexp_cdr(front);
+      if (! sexp_pairp(sexp_cdr(front)))
+        sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL;
+      if (sexp_context_refuel(ctx) > 0 && sexp_not(sexp_memq(ctx, ctx, paused)))
+        sexp_insert_timed(ctx, ctx, SEXP_FALSE);
+      paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED);
+    } else {
+      /* swap with front of queue */
+      sexp_car(sexp_global(ctx, SEXP_G_THREADS_FRONT)) = ctx;
+      /* rotate front of queue to back */
+      sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK))
+        = sexp_global(ctx, SEXP_G_THREADS_FRONT);
+      sexp_global(ctx, SEXP_G_THREADS_FRONT)
+        = sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_FRONT));
+      sexp_global(ctx, SEXP_G_THREADS_BACK)
+        = sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK));
+      sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = SEXP_NULL;
+    }
+  } else {
+    /* no threads to dequeue */
+    res = ctx;
+    /* prefer a thread we can wait on instead of spinning */
+    if (sexp_context_refuel(ctx) <= 0) {
+      for (ls1=paused; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) {
+        evt = sexp_context_event(sexp_car(ls1));
+        if (sexp_fixnump(evt) || sexp_portp(evt)) {
+          res = sexp_car(ls1);
+          break;
+        }
+      }
+    }
+  }
+
+  if (sexp_context_waitp(res)) {
+    /* the only thread available was waiting */
+    if (sexp_pairp(paused)
+        && sexp_context_before(sexp_car(paused), sexp_context_timeval(res))) {
+      tmp = res;
+      res = sexp_car(paused);
+      paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(paused);
+      if (sexp_not(sexp_memq(ctx, tmp, paused)))
+        sexp_insert_timed(ctx, tmp, tmp);
+    } else {
+      sexp_delete_list(ctx, SEXP_G_THREADS_PAUSED, res);
+    }
+    paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED);
+    usecs = 0;
+    if ((sexp_context_timeval(res).tv_sec == 0)
+        && (sexp_context_timeval(res).tv_usec == 0)) {
+      /* no timeout, wait for default 10ms */
+      usecs = 10*1000;
+    } else {
+      /* wait until the next timeout */
+      gettimeofday(&tval, NULL);
+      if (tval.tv_sec <= sexp_context_timeval(res).tv_sec) {
+        usecs = (sexp_context_timeval(res).tv_sec - tval.tv_sec) * 1000000;
+        if (tval.tv_usec < sexp_context_timeval(res).tv_usec || usecs > 0)
+          usecs += sexp_context_timeval(res).tv_usec - tval.tv_usec;
+      }
+    }
+    /* take a nap to avoid busy looping */
+    usleep(usecs);
+    sexp_context_waitp(res) = 0;
+    sexp_context_timeoutp(res) = 1;
+  }
+
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+/**************************************************************************/
+
+sexp sexp_lookup_named_type (sexp ctx, sexp env, const char *name) {
+  sexp t = sexp_env_ref(ctx, env, sexp_intern(ctx, name, -1), SEXP_FALSE);
+  return sexp_make_fixnum((sexp_typep(t)) ? sexp_type_tag(t) : -1);
+}
+
+#endif  /* SEXP_USE_GREEN_THREADS */
+
+sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
+  sexp t;
+  sexp_gc_var1(name);
+  if (!(sexp_version_compatible(ctx, version, sexp_version)
+        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
+    return SEXP_ABI_ERROR;
+
+#if SEXP_USE_GREEN_THREADS
+
+  sexp_gc_preserve1(ctx, name);
+
+  sexp_global(ctx, SEXP_G_THREADS_MUTEX_ID) = sexp_lookup_named_type(ctx, env, "Mutex");
+  name = sexp_c_string(ctx, "pollfds", -1);
+  t = sexp_register_type(ctx, name, SEXP_FALSE, SEXP_FALSE,
+                         SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO,
+                         SEXP_ZERO, sexp_make_fixnum(sexp_sizeof_pollfds),
+                         SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO,
+                         SEXP_ZERO, SEXP_ZERO, NULL,
+                         (sexp_proc2)sexp_free_pollfds);
+  if (sexp_typep(t)) {
+    sexp_global(ctx, SEXP_G_THREADS_POLLFDS_ID) = sexp_make_fixnum(sexp_type_tag(t));
+  }
+
+  sexp_define_type_predicate_by_tag(ctx, env, "thread?", SEXP_CONTEXT);
+  sexp_define_foreign(ctx, env, "thread-timeout?", 0, sexp_thread_timeoutp);
+  sexp_define_foreign(ctx, env, "current-thread", 0, sexp_current_thread);
+  sexp_define_foreign_opt(ctx, env, "make-thread", 2, sexp_make_thread, SEXP_FALSE);
+  sexp_define_foreign(ctx, env, "thread-start!", 1, sexp_thread_start);
+  sexp_define_foreign(ctx, env, "%thread-terminate!", 1, sexp_thread_terminate);
+  sexp_define_foreign(ctx, env, "%thread-join!", 2, sexp_thread_join);
+  sexp_define_foreign(ctx, env, "%thread-sleep!", 1, sexp_thread_sleep);
+  sexp_define_foreign(ctx, env, "thread-name", 1, sexp_thread_name);
+  sexp_define_foreign(ctx, env, "thread-specific", 1, sexp_thread_specific);
+  sexp_define_foreign(ctx, env, "thread-specific-set!", 2, sexp_thread_specific_set);
+  sexp_define_foreign(ctx, env, "%thread-end-result", 1, sexp_thread_end_result);
+  sexp_define_foreign(ctx, env, "%thread-exception?", 1, sexp_thread_exceptionp);
+  sexp_define_foreign(ctx, env, "mutex-state", 1, sexp_mutex_state);
+  sexp_define_foreign(ctx, env, "%mutex-lock!", 3, sexp_mutex_lock);
+  sexp_define_foreign(ctx, env, "%mutex-unlock!", 3, sexp_mutex_unlock);
+  sexp_define_foreign(ctx, env, "condition-variable-signal!", 1, sexp_condition_variable_signal);
+  sexp_define_foreign(ctx, env, "condition-variable-broadcast!", 1, sexp_condition_variable_broadcast);
+  sexp_define_foreign(ctx, env, "pop-signal!", 0, sexp_pop_signal);
+  sexp_define_foreign(ctx, env, "get-signal-handler", 1, sexp_get_signal_handler);
+
+  sexp_global(ctx, SEXP_G_THREADS_SCHEDULER)
+    = sexp_make_foreign(ctx, "scheduler", 1, 0, (sexp_proc1)sexp_scheduler, SEXP_FALSE);
+  sexp_global(ctx, SEXP_G_THREADS_BLOCKER)
+    = sexp_make_foreign(ctx, "blocker", 2, 0, (sexp_proc1)sexp_blocker, SEXP_FALSE);
+
+  /* remember the env to lookup the runner later */
+  sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = env;
+
+  sexp_gc_release1(ctx);
+
+#endif  /* SEXP_USE_GREEN_THREADS */
+
+  return SEXP_VOID;
+}
diff --git a/lib/srfi/18/types.scm b/lib/srfi/18/types.scm
new file mode 100644
index 00000000..e4f42fe2
--- /dev/null
+++ b/lib/srfi/18/types.scm
@@ -0,0 +1,24 @@
+;; types.scm -- thread types
+;; Copyright (c) 2010-2011 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define-record-type Mutex
+  (%make-mutex name specific thread lock)
+  mutex?
+  (name mutex-name)
+  (specific mutex-specific mutex-specific-set!)
+  (thread %mutex-thread %mutex-thread-set!)
+  (lock %mutex-lock %mutex-lock-set!))
+
+(define (make-mutex . o)
+  (%make-mutex (and (pair? o) (car o)) #f #f #f))
+
+(define-record-type Condition-Variable
+  (%make-condition-variable name specific threads)
+  condition-variable?
+  (name condition-variable-name)
+  (specific condition-variable-specific condition-variable-specific-set!)
+  (threads %condition-variable-threads %condition-variable-threads-set!))
+
+(define (make-condition-variable . o)
+  (%make-condition-variable (and (pair? o) (car o)) #f #f))
diff --git a/lib/srfi/2.sld b/lib/srfi/2.sld
new file mode 100644
index 00000000..d046f99b
--- /dev/null
+++ b/lib/srfi/2.sld
@@ -0,0 +1,23 @@
+
+(define-library (srfi 2)
+  (export and-let*)
+  (import (chibi))
+  (begin
+   (define-syntax and-let*
+     (syntax-rules ()
+       ((and-let* () . body)
+        (begin #t . body))
+       ((and-let* ((var expr)))
+        expr)
+       ((and-let* ((expr)))
+        expr)
+       ((and-let* (expr))  ; Extension: in SRFI-2 this can only be a var ref
+        expr)
+       ((and-let* ((var expr) . rest) . body)
+        (let ((var expr))
+          (and var (and-let* rest . body))))
+       ((and-let* ((expr) . rest) . body)
+        (and expr (and-let* rest . body)))
+       ((and-let* (expr . rest) . body)   ; Same extension as above
+        (let ((tmp expr))
+          (and tmp (and-let* rest . body))))))))
diff --git a/lib/srfi/26.sld b/lib/srfi/26.sld
new file mode 100644
index 00000000..ad7b46e1
--- /dev/null
+++ b/lib/srfi/26.sld
@@ -0,0 +1,23 @@
+
+(define-library (srfi 26)
+  (export cut cute)
+  (import (chibi))
+  (begin
+   (define-syntax %cut
+     (syntax-rules (<> <...>)
+       ((%cut e? params args)
+        (lambda params args))
+       ((%cut e? (params ...) (args ...) <> . rest)
+        (%cut e? (params ... tmp) (args ... tmp) . rest))
+       ((%cut e? (params ...) (args ...) <...>)
+        (%cut e? (params ... . tmp) (apply args ... tmp)))
+       ((%cut e? (params ...) (args ...) <...> . rest)
+        (error "cut: non-terminal <...>"))
+       ((%cut #t (params ...) (args ...) x . rest)
+        (let ((tmp x)) (%cut #t (params ...) (args ... tmp) . rest)))
+       ((%cut #f (params ...) (args ...) x . rest)
+        (%cut #f (params ...) (args ... x) . rest))))
+   (define-syntax cut
+     (syntax-rules () ((cut args ...) (%cut #f () () args ...))))
+   (define-syntax cute
+     (syntax-rules () ((cute args ...) (%cut #t () () args ...))))))
diff --git a/lib/srfi/27.sld b/lib/srfi/27.sld
new file mode 100644
index 00000000..82bf7c3f
--- /dev/null
+++ b/lib/srfi/27.sld
@@ -0,0 +1,10 @@
+
+(define-library (srfi 27)
+  (export random-integer random-real default-random-source
+          make-random-source random-source?
+          random-source-state-ref random-source-state-set!
+          random-source-randomize! random-source-pseudo-randomize!
+          random-source-make-integers random-source-make-reals)
+  (import (chibi))
+  (include-shared "27/rand")
+  (include "27/constructors.scm"))
diff --git a/lib/srfi/27/constructors.scm b/lib/srfi/27/constructors.scm
new file mode 100644
index 00000000..dbd0a8c6
--- /dev/null
+++ b/lib/srfi/27/constructors.scm
@@ -0,0 +1,10 @@
+;; constructors.scm -- random function constructors
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (random-source-make-integers rs)
+  (lambda (n) (%random-integer rs n)))
+
+(define (random-source-make-reals rs . o)
+  (lambda () (%random-real rs)))
+
diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c
new file mode 100644
index 00000000..12bc6efa
--- /dev/null
+++ b/lib/srfi/27/rand.c
@@ -0,0 +1,219 @@
+/*  rand.c -- rand_r/random_r interface                       */
+/*  Copyright (c) 2009-2014 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include <time.h>
+#include <chibi/eval.h>
+
+#define SEXP_RANDOM_STATE_SIZE 128
+
+#define ZERO sexp_make_fixnum(0)
+#define ONE  sexp_make_fixnum(1)
+#define STATE_SIZE sexp_make_fixnum(SEXP_RANDOM_STATE_SIZE)
+
+#define sexp_random_source_p(x) sexp_check_tag(x, rs_type_id)
+
+#define sexp_random_state(x) (sexp_slot_ref((x), 0))
+#define sexp_random_data(x)  ((sexp_random_t*)(&sexp_slot_ref((x), 1)))
+
+#define sexp_sizeof_random (sexp_sizeof_header + sizeof(sexp_random_t) + sizeof(sexp))
+
+static sexp_uint_t rs_type_id = 0;
+static sexp default_random_source;
+
+#ifdef __GNU_LIBRARY__
+
+typedef struct random_data sexp_random_t;
+
+#define sexp_random_init(rs, seed)                                      \
+  initstate_r(seed,                                                     \
+              sexp_bytes_data(sexp_random_state(rs)),                   \
+              SEXP_RANDOM_STATE_SIZE,                                   \
+              sexp_random_data(rs))
+
+#define sexp_call_random(rs, dst) random_r(sexp_random_data(rs), &dst)
+#define sexp_seed_random(n, rs) srandom_r(n, sexp_random_data(rs))
+
+#else
+
+typedef unsigned int sexp_random_t;
+
+#define sexp_random_init(rs, seed) *sexp_random_data(rs) = (seed)
+
+#define sexp_call_random(rs, dst) ((dst) = rand_r(sexp_random_data(rs)))
+#define sexp_seed_random(n, rs) *sexp_random_data(rs) = (n)
+
+#endif
+
+static sexp sexp_rs_random_integer (sexp ctx, sexp self, sexp_sint_t n, sexp rs, sexp bound) {
+  sexp res;
+  int32_t m;
+#if SEXP_USE_BIGNUMS
+  int32_t hi, mod, len, i, *data;
+#endif
+  if (! sexp_random_source_p(rs))
+    res = sexp_type_exception(ctx, self, rs_type_id, rs);
+  if (sexp_fixnump(bound)) {
+    sexp_call_random(rs, m);
+    res = sexp_make_fixnum(m % sexp_unbox_fixnum(bound));
+#if SEXP_USE_BIGNUMS
+  } else if (sexp_bignump(bound)) {
+    hi = sexp_bignum_hi(bound);
+    len = hi * (sizeof(sexp_uint_t) / sizeof(int32_t));
+    res = sexp_make_bignum(ctx, hi + 1);
+    data = (int32_t*) sexp_bignum_data(res);
+    for (i=0; i<len-1; i++) {
+      sexp_call_random(rs, m);
+      data[i] = m;
+    }
+    mod = sexp_bignum_data(bound)[hi-1];
+    if (mod && sexp_bignum_data(res)[hi-1] > 0)
+      sexp_bignum_data(res)[hi-1] %= mod;
+#endif
+  } else {
+    res = sexp_type_exception(ctx, self, SEXP_FIXNUM, bound);
+  }
+  return res;
+}
+
+static sexp sexp_random_integer (sexp ctx, sexp self, sexp_sint_t n, sexp bound) {
+  return sexp_rs_random_integer(ctx, self, n, default_random_source, bound);
+}
+
+static sexp sexp_rs_random_real (sexp ctx, sexp self, sexp_sint_t n, sexp rs) {
+  int32_t res;
+  if (! sexp_random_source_p(rs))
+    return sexp_type_exception(ctx, self, rs_type_id, rs);
+  sexp_call_random(rs, res);
+  return sexp_make_flonum(ctx, (double)res / (double)RAND_MAX);
+}
+
+static sexp sexp_random_real (sexp ctx, sexp self, sexp_sint_t n) {
+  return sexp_rs_random_real(ctx, self, n, default_random_source);
+}
+
+#if SEXP_BSD || defined(__CYGWIN__)
+
+static sexp sexp_make_random_source (sexp ctx, sexp self, sexp_sint_t n) {
+  sexp res;
+  res = sexp_alloc_tagged(ctx, sexp_sizeof_random, rs_type_id);
+  *sexp_random_data(res) = 1;
+  return res;
+}
+
+static sexp sexp_random_source_state_ref (sexp ctx, sexp self, sexp_sint_t n, sexp rs) {
+  if (! sexp_random_source_p(rs))
+    return sexp_type_exception(ctx, self, rs_type_id, rs);
+  else
+    return sexp_make_integer(ctx, *sexp_random_data(rs));
+}
+
+static sexp sexp_random_source_state_set (sexp ctx, sexp self, sexp_sint_t n, sexp rs, sexp state) {
+  if (! sexp_random_source_p(rs))
+    return sexp_type_exception(ctx, self, rs_type_id, rs);
+  else if (sexp_fixnump(state))
+    *sexp_random_data(rs) = sexp_unbox_fixnum(state);
+#if SEXP_USE_BIGNUMS
+  else if (sexp_bignump(state))
+    *sexp_random_data(rs)
+      = sexp_bignum_data(state)[0]*sexp_bignum_sign(state);
+#endif
+  else
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, state);
+  return SEXP_VOID;
+}
+
+#else
+
+static sexp sexp_make_random_source (sexp ctx, sexp self, sexp_sint_t n) {
+  sexp res;
+  sexp_gc_var1(state);
+  sexp_gc_preserve1(ctx, state);
+  state = sexp_make_bytes(ctx, STATE_SIZE, SEXP_UNDEF);
+  res = sexp_alloc_tagged(ctx, sexp_sizeof_random, rs_type_id);
+  if (sexp_exceptionp(res)) return res;
+  sexp_random_state(res) = state;
+  sexp_random_init(res, 1);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+static sexp sexp_random_source_state_ref (sexp ctx, sexp self, sexp_sint_t n, sexp rs) {
+  if (! sexp_random_source_p(rs))
+    return sexp_type_exception(ctx, self, rs_type_id, rs);
+  else
+    return sexp_subbytes(ctx, sexp_random_state(rs), ZERO, STATE_SIZE);
+}
+
+static sexp sexp_random_source_state_set (sexp ctx, sexp self, sexp_sint_t n, sexp rs, sexp state) {
+  if (! sexp_random_source_p(rs))
+    return sexp_type_exception(ctx, self, rs_type_id, rs);
+  else if (! (sexp_bytesp(state)
+              && (sexp_bytes_length(state) == SEXP_RANDOM_STATE_SIZE)))
+    return sexp_type_exception(ctx, self, SEXP_BYTES, state);
+  sexp_random_state(rs) = sexp_subbytes(ctx, state, ZERO, STATE_SIZE);
+  sexp_random_init(rs, 1);
+  return SEXP_VOID;
+}
+
+#endif
+
+static sexp sexp_random_source_randomize (sexp ctx, sexp self, sexp_sint_t n, sexp rs) {
+  if (! sexp_random_source_p(rs))
+    return sexp_type_exception(ctx, self, rs_type_id, rs);
+  sexp_seed_random(time(NULL), rs);
+  return SEXP_VOID;
+}
+
+static sexp sexp_random_source_pseudo_randomize (sexp ctx, sexp self, sexp_sint_t n, sexp rs, sexp seed1, sexp seed2) {
+  if (! sexp_random_source_p(rs))
+    return sexp_type_exception(ctx, self, rs_type_id, rs);
+  if (! sexp_fixnump(seed1))
+    return sexp_type_exception(ctx, self, rs_type_id, seed1);
+  if (! sexp_fixnump(seed2))
+    return sexp_type_exception(ctx, self, rs_type_id, seed2);
+  sexp_seed_random(sexp_unbox_fixnum(seed1) ^ sexp_unbox_fixnum(seed2), rs);
+  return SEXP_VOID;
+}
+
+sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
+  sexp_gc_var2(name, op);
+  if (!(sexp_version_compatible(ctx, version, sexp_version)
+        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
+    return SEXP_ABI_ERROR;
+  sexp_gc_preserve2(ctx, name, op);
+
+  name = sexp_c_string(ctx, "random-source", -1);
+  op = sexp_register_type(ctx, name, SEXP_FALSE, SEXP_FALSE,
+                          sexp_make_fixnum(sexp_offsetof_slot0),
+                          ONE, ONE, ZERO, ZERO,
+                          sexp_make_fixnum(sexp_sizeof_random), ZERO,
+                          ZERO, ZERO, ZERO, ZERO, ZERO, ZERO, NULL, NULL);
+  if (sexp_exceptionp(op))
+    return op;
+  rs_type_id = sexp_type_tag(op);
+
+  name = sexp_c_string(ctx, "random-source?", -1);
+  op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(rs_type_id));
+  name = sexp_intern(ctx, "random-source?", -1);
+  sexp_env_define(ctx, env, name, op);
+
+  sexp_define_foreign(ctx, env, "make-random-source", 0, sexp_make_random_source);
+  sexp_define_foreign(ctx, env, "%random-integer", 2, sexp_rs_random_integer);
+  sexp_define_foreign(ctx, env, "random-integer", 1, sexp_random_integer);
+  sexp_define_foreign(ctx, env, "%random-real", 1, sexp_rs_random_real);
+  sexp_define_foreign(ctx, env, "random-real", 0, sexp_random_real);
+  sexp_define_foreign(ctx, env, "random-source-state-ref", 1, sexp_random_source_state_ref);
+  sexp_define_foreign(ctx, env, "random-source-state-set!", 2, sexp_random_source_state_set);
+  sexp_define_foreign(ctx, env, "random-source-randomize!", 1, sexp_random_source_randomize);
+  sexp_define_foreign(ctx, env, "random-source-pseudo-randomize!", 3, sexp_random_source_pseudo_randomize);
+
+  default_random_source = op = sexp_make_random_source(ctx, NULL, 0);
+  name = sexp_intern(ctx, "default-random-source", -1);
+  sexp_env_define(ctx, env, name, default_random_source);
+  sexp_random_source_randomize(ctx, NULL, 0, default_random_source);
+
+  sexp_gc_release2(ctx);
+  return SEXP_VOID;
+}
+
diff --git a/lib/srfi/33.sld b/lib/srfi/33.sld
new file mode 100644
index 00000000..6a6a7cbc
--- /dev/null
+++ b/lib/srfi/33.sld
@@ -0,0 +1,17 @@
+
+(define-library (srfi 33)
+  (export bitwise-not
+          bitwise-and   bitwise-ior 
+          bitwise-xor   bitwise-eqv
+          bitwise-nand  bitwise-nor 
+          bitwise-andc1 bitwise-andc2
+          bitwise-orc1  bitwise-orc2 
+          arithmetic-shift bit-count integer-length
+          bitwise-merge 
+          bit-set? any-bits-set? all-bits-set?
+          first-set-bit
+          extract-bit-field test-bit-field? clear-bit-field 
+          replace-bit-field  copy-bit-field)
+  (import (chibi))
+  (include-shared "33/bit")
+  (include "33/bitwise.scm"))
diff --git a/lib/srfi/33/bit.c b/lib/srfi/33/bit.c
new file mode 100644
index 00000000..b81f5d77
--- /dev/null
+++ b/lib/srfi/33/bit.c
@@ -0,0 +1,361 @@
+/*  bit.c -- bitwise operators                                */
+/*  Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+
+#ifndef PLAN9
+#include <limits.h>
+#else
+#define CHAR_BIT 8
+#endif
+
+#if SEXP_USE_BIGNUMS
+#include <chibi/bignum.h>
+#else
+#define sexp_bignum_normalize(x) x
+#endif
+
+static sexp sexp_twos_complement (sexp ctx, sexp x) {
+  int i;
+  sexp_gc_var1(res);
+  if (sexp_bignump(x) && sexp_bignum_sign(x) < 0) {
+    sexp_gc_preserve1(ctx, res);
+    res = sexp_copy_bignum(ctx, NULL, x, 0);
+    sexp_bignum_sign(res) = 1;
+    for (i = sexp_bignum_length(res)-1; i >= 0; i--)
+      sexp_bignum_data(res)[i] = ~sexp_bignum_data(res)[i];
+    res = sexp_bignum_fxadd(ctx, res, 1);
+    sexp_gc_release1(ctx);
+    return res;
+  }
+  return x;
+}
+
+static sexp sexp_fixnum_to_twos_complement (sexp ctx, sexp x, int len) {
+  int i;
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  res = sexp_make_bignum(ctx, len);
+  for (i = len-1; i > 0; i--)
+    sexp_bignum_data(res)[i] = (sexp_uint_t)((sexp_sint_t)-1);
+  sexp_bignum_data(res)[0] = ~(-(sexp_unbox_fixnum(x)));
+  res = sexp_bignum_fxadd(ctx, res, 1);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+static sexp sexp_bit_and (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
+#if SEXP_USE_BIGNUMS
+  sexp_sint_t len, i;
+#endif
+  sexp_gc_var3(res, x2, y2);
+  if (sexp_fixnump(x) && sexp_fixnump(y)) {
+    return (sexp) ((sexp_uint_t)x & (sexp_uint_t)y);  /* safe to AND tags */
+#if SEXP_USE_BIGNUMS
+  } else if (sexp_fixnump(x) && sexp_bignump(y)) {
+    return sexp_bit_and(ctx, self, n, y, x);
+  } else if (sexp_bignump(x)) {
+    sexp_gc_preserve3(ctx, res, x2, y2);
+    x2 = sexp_twos_complement(ctx, x);
+    y2 = sexp_twos_complement(ctx, y);
+    if (sexp_fixnump(y2) && sexp_negativep(y2))
+      y2 = sexp_fixnum_to_twos_complement(ctx, y2, sexp_bignum_length(x2));
+    if (sexp_fixnump(y2)) {
+      res = sexp_make_fixnum(sexp_unbox_fixnum(y2) & sexp_bignum_data(x2)[0]);
+    } else if (sexp_bignump(y2)) {
+      if (sexp_bignum_length(x2) < sexp_bignum_length(y2))
+        res = sexp_copy_bignum(ctx, NULL, x2, 0);
+      else
+        res = sexp_copy_bignum(ctx, NULL, y2, 0);
+      for (i=0, len=sexp_bignum_length(res); i<len; i++)
+        sexp_bignum_data(res)[i]
+          = sexp_bignum_data(x2)[i] & sexp_bignum_data(y2)[i];
+    } else {
+      res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y2);
+    }
+    sexp_gc_release3(ctx);
+    return sexp_bignum_normalize(res);
+#endif
+  } else {
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
+  }
+}
+
+static sexp sexp_bit_ior (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
+  sexp res;
+#if SEXP_USE_BIGNUMS
+  sexp_sint_t len, i;
+#endif
+  if (sexp_fixnump(x)) {
+    if (sexp_fixnump(y))
+      res = (sexp) ((sexp_uint_t)x | (sexp_uint_t)y);
+#if SEXP_USE_BIGNUMS
+    else if (sexp_bignump(y))
+      res = sexp_bit_ior(ctx, self, n, y, x);
+#endif
+    else
+      res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y);
+#if SEXP_USE_BIGNUMS
+  } else if (sexp_bignump(x)) {
+    if (sexp_fixnump(y)) {
+      res = sexp_copy_bignum(ctx, NULL, x, 0);
+      sexp_bignum_data(res)[0] |= (sexp_uint_t)sexp_unbox_fixnum(y);
+    } else if (sexp_bignump(y)) {
+      if (sexp_bignum_length(x) >= sexp_bignum_length(y)) {
+        res = sexp_copy_bignum(ctx, NULL, x, 0);
+        len = sexp_bignum_length(y);
+      } else {
+        res = sexp_copy_bignum(ctx, NULL, y, 0);
+        len = sexp_bignum_length(x);
+      }
+      for (i=0; i<len; i++)
+        sexp_bignum_data(res)[i]
+          = sexp_bignum_data(x)[i] | sexp_bignum_data(y)[i];
+    } else {
+      res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y);
+    }
+#endif
+  } else {
+    res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
+  }
+  return sexp_bignum_normalize(res);
+}
+
+static sexp sexp_bit_xor (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
+  sexp res;
+#if SEXP_USE_BIGNUMS
+  sexp_sint_t len, i;
+#endif
+  if (sexp_fixnump(x)) {
+    if (sexp_fixnump(y))
+      res = sexp_make_fixnum(sexp_unbox_fixnum(x) ^ sexp_unbox_fixnum(y));
+#if SEXP_USE_BIGNUMS
+    else if (sexp_bignump(y))
+      res = sexp_bit_xor(ctx, self, n, y, x);
+#endif
+    else
+      res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y);
+#if SEXP_USE_BIGNUMS
+  } else if (sexp_bignump(x)) {
+    if (sexp_fixnump(y)) {
+      res = sexp_copy_bignum(ctx, NULL, x, 0);
+      sexp_bignum_data(res)[0] ^= sexp_unbox_fixnum(y);
+    } else if (sexp_bignump(y)) {
+      if (sexp_bignum_length(x) >= sexp_bignum_length(y)) {
+        res = sexp_copy_bignum(ctx, NULL, x, 0);
+        len = sexp_bignum_length(y);
+      } else {
+        res = sexp_copy_bignum(ctx, NULL, y, 0);
+        len = sexp_bignum_length(x);
+      }
+      for (i=0; i<len; i++)
+        sexp_bignum_data(res)[i]
+          = sexp_bignum_data(x)[i] ^ sexp_bignum_data(y)[i];
+    } else {
+      res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y);
+    }
+#endif
+  } else {
+    res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
+  }
+  return sexp_bignum_normalize(res);
+}
+
+static int log2i(sexp_uint_t v) {
+  int i;
+  for (i = 0; i < sizeof(v)*8; i++)
+    if (((sexp_uint_t)1<<(i+1)) > v)
+      break;
+  return i;
+}
+
+/* should probably split into left and right shifts, that's a better */
+/* interface anyway */
+static sexp sexp_arithmetic_shift (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp count) {
+  sexp_uint_t tmp;
+  sexp_sint_t c;
+#if SEXP_USE_BIGNUMS
+  sexp_sint_t len, offset, bit_shift, tail_shift, j;
+  sexp_gc_var1(res);
+#else
+  sexp res;
+#endif
+  if (! sexp_fixnump(count))
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, count);
+  c = sexp_unbox_fixnum(count);
+  if (c == 0) return i;
+  if (sexp_fixnump(i)) {
+    if (c < 0) {
+      res = sexp_make_fixnum(c > -sizeof(sexp_sint_t)*CHAR_BIT ? sexp_unbox_fixnum(i) >> -c : 0);
+    } else {
+#if SEXP_USE_BIGNUMS
+      if ((log2i(sexp_unbox_fixnum(i)) + c + 1)
+          < (sizeof(sexp_uint_t)*CHAR_BIT - SEXP_FIXNUM_BITS)) {
+#endif
+        tmp = (sexp_uint_t)sexp_unbox_fixnum(i) << c;
+        res = sexp_make_fixnum(tmp * sexp_fx_sign(i));
+#if SEXP_USE_BIGNUMS
+      } else {
+        sexp_gc_preserve1(ctx, res);
+        res = sexp_fixnum_to_bignum(ctx, i);
+        res = sexp_arithmetic_shift(ctx, self, n, res, count);
+        sexp_gc_release1(ctx);
+      }
+#endif
+    }
+#if SEXP_USE_BIGNUMS
+  } else if (sexp_bignump(i)) {
+    len = sexp_bignum_hi(i);
+    if (c < 0) {
+      c = -c;
+      offset = c / (sizeof(sexp_uint_t)*CHAR_BIT);
+      bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT);
+      if (len < offset) {
+        res = sexp_make_fixnum(sexp_bignum_sign(i) > 0 ? 0 : -1);
+      } else {
+        res = sexp_make_bignum(ctx, len - offset + 1);
+        if (!sexp_exceptionp(res)) {
+          sexp_bignum_sign(res) = sexp_bignum_sign(i);
+          for (j=len-offset-1, tmp=0; j>=0; j--) {
+            sexp_bignum_data(res)[j]
+              = (sexp_bignum_data(i)[j+offset] >> bit_shift)+ tmp;
+            tmp = sexp_bignum_data(i)[j+offset]
+              << (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift);
+          }
+        }
+      }
+    } else {
+      offset = c / (sizeof(sexp_uint_t)*CHAR_BIT);
+      bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT);
+      tail_shift = (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift);
+      res = sexp_make_bignum(ctx, len + offset + 1);
+      if (!sexp_exceptionp(res)) {
+        sexp_bignum_sign(res) = sexp_bignum_sign(i);
+        for (j=tmp=0; j<len; j++) {
+          sexp_bignum_data(res)[j+offset]
+            = (sexp_bignum_data(i)[j] << bit_shift) + tmp;
+          if (bit_shift != 0)
+            tmp = sexp_bignum_data(i)[j] >> tail_shift;
+        }
+        if (bit_shift != 0) sexp_bignum_data(res)[len+offset] = tmp;
+      }
+    }
+#endif
+  } else {
+    res = sexp_type_exception(ctx, self, SEXP_FIXNUM, i);
+  }
+  return sexp_bignum_normalize(res);
+}
+
+/* bit-count and integer-length were adapted from: */
+/* http://graphics.stanford.edu/~seander/bithacks.html */
+static sexp_uint_t bit_count (sexp_uint_t i) {
+  i -= ((i >> 1) & (sexp_uint_t)~(sexp_uint_t)0/3);
+  i = ((i & (sexp_uint_t)~(sexp_uint_t)0/15*3)
+       + ((i >> 2) & (sexp_uint_t)~(sexp_uint_t)0/15*3));
+  i = (i + (i >> 4)) & (sexp_uint_t)~(sexp_uint_t)0/255*15;
+  return ((sexp_uint_t)(i * ((sexp_uint_t)~(sexp_uint_t)0/255))
+          >> (sizeof(i) - 1) * CHAR_BIT);
+}
+
+static sexp sexp_bit_count (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  sexp res;
+  sexp_sint_t i;
+#if SEXP_USE_BIGNUMS
+  sexp_uint_t count;
+#endif
+  if (sexp_fixnump(x)) {
+    i = sexp_unbox_fixnum(x);
+    res = sexp_make_fixnum(bit_count(i<0 ? ~i : i));
+#if SEXP_USE_BIGNUMS
+  } else if (sexp_bignump(x)) {
+    for (i=count=0; i<sexp_bignum_length(x); i++)
+      count += bit_count(sexp_bignum_data(x)[i]);
+    res = sexp_make_fixnum(count);
+#endif
+  } else {
+    res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
+  }
+  return res;
+}
+
+static const char log_table_256[256] = 
+{
+#define LT(n) n, n, n, n, n, n, n, n, n, n, n, n, n, n, n, n
+  0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4,
+  LT(5), LT(6), LT(7), LT(7), LT(7), LT(7), LT(7),
+  LT(8), LT(8), LT(8), LT(8), LT(8), LT(8), LT(8), LT(8)
+};
+
+static sexp_uint_t integer_log2 (sexp_uint_t x) {
+  sexp_uint_t t, tt;
+#if SEXP_64_BIT
+  if ((tt = x >> 32))
+    return integer_log2(tt) + 32;
+  else
+#endif
+  if ((tt = x >> 16))
+    return (t = tt >> 8) ? 24 + log_table_256[t] : 16 + log_table_256[tt];
+  else 
+    return (t = x >> 8) ? 8 + log_table_256[t] : log_table_256[x];
+}
+
+static sexp sexp_integer_length (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  sexp_sint_t tmp;
+#if SEXP_USE_BIGNUMS
+  sexp_sint_t hi;
+#endif
+  if (sexp_fixnump(x)) {
+    tmp = sexp_unbox_fixnum(x);
+    return sexp_make_fixnum(integer_log2(tmp < 0 ? -tmp-1 : tmp));
+#if SEXP_USE_BIGNUMS
+  } else if (sexp_bignump(x)) {
+    hi = sexp_bignum_hi(x);
+    return sexp_make_fixnum(integer_log2(sexp_bignum_data(x)[hi-1])
+                            + (hi-1)*sizeof(sexp_uint_t)*CHAR_BIT);
+#endif
+  } else {
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
+  }
+}
+
+static sexp sexp_bit_set_p (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp x) {
+  sexp_sint_t pos;
+#if SEXP_USE_BIGNUMS
+  sexp_sint_t rem;
+#endif
+  if (! sexp_fixnump(i))
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, i);
+  pos = sexp_unbox_fixnum(i);
+  if (pos < 0)
+    return sexp_xtype_exception(ctx, self, "index must be non-negative", i);
+  if (sexp_fixnump(x)) {
+    return sexp_make_boolean((pos < sizeof(sexp_uint_t)*CHAR_BIT)
+                             && (sexp_unbox_fixnum(x) & (1UL<<pos)));
+#if SEXP_USE_BIGNUMS
+  } else if (sexp_bignump(x)) {
+    pos /= (sizeof(sexp_uint_t)*CHAR_BIT);
+    rem = (sexp_unbox_fixnum(i) - pos*sizeof(sexp_uint_t)*CHAR_BIT);
+    return sexp_make_boolean((pos < sexp_bignum_length(x))
+                             && (sexp_bignum_data(x)[pos] & (1UL<<rem)));
+#endif
+  } else {
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
+  }
+}
+
+sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
+  if (!(sexp_version_compatible(ctx, version, sexp_version)
+        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
+    return SEXP_ABI_ERROR;
+  sexp_define_foreign(ctx, env, "bit-and",    2, sexp_bit_and);
+  sexp_define_foreign(ctx, env, "bit-ior",    2, sexp_bit_ior);
+  sexp_define_foreign(ctx, env, "bit-xor",    2, sexp_bit_xor);
+  sexp_define_foreign(ctx, env, "arithmetic-shift",  2, sexp_arithmetic_shift);
+  sexp_define_foreign(ctx, env, "bit-count",  1, sexp_bit_count);
+  sexp_define_foreign(ctx, env, "integer-length",  1, sexp_integer_length);
+  sexp_define_foreign(ctx, env, "bit-set?", 2, sexp_bit_set_p);
+  return SEXP_VOID;
+}
+
diff --git a/lib/srfi/33/bitwise.scm b/lib/srfi/33/bitwise.scm
new file mode 100644
index 00000000..690b81c3
--- /dev/null
+++ b/lib/srfi/33/bitwise.scm
@@ -0,0 +1,61 @@
+;; bitwise.scm -- high-level bitwise functions
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (bitwise-not i) (- -1 i))
+
+(define (bitwise-complement f) (lambda args (bitwise-not (apply f args))))
+
+(define (make-nary proc2 default)
+  (lambda args
+    (if (null? args)
+        default
+        (let lp ((i (car args)) (ls (cdr args)))
+          (if (null? ls)
+              i
+              (lp (proc2 i (car ls)) (cdr ls)))))))
+
+(define bitwise-and  (make-nary bit-and  -1))
+(define bitwise-ior  (make-nary bit-ior   0))
+(define bitwise-xor  (make-nary bit-xor   0))
+
+(define bitwise-eqv  (bitwise-complement (make-nary bit-xor -1)))
+(define bitwise-nand (bitwise-complement (make-nary bit-and  0)))
+(define bitwise-nor  (bitwise-complement (make-nary bit-ior -1)))
+
+(define (bitwise-andc1 i j) (bit-and (bitwise-not i) j))
+(define (bitwise-andc2 i j) (bit-and i (bitwise-not j)))
+(define (bitwise-orc1 i j)  (bit-ior (bitwise-not i) j))
+(define (bitwise-orc2 i j)  (bit-ior i (bitwise-not j)))
+
+(define (any-bits-set? test-bits i)
+  (not (zero? (bitwise-and test-bits i))))
+(define (all-bits-set? test-bits i)
+  (= test-bits (bitwise-and test-bits i)))
+
+(define (first-set-bit i)
+  (if (zero? i)
+      -1
+      (integer-length (- i (bit-and i (- i 1))))))
+
+(define (mask len) (- (arithmetic-shift 1 len) 1))
+
+(define (bitwise-merge mask n m)
+  (bit-ior (bit-and mask n) (bit-and (bitwise-not mask) m)))
+
+(define (extract-bit-field size position n)
+  (bit-and (arithmetic-shift n (- position)) (mask size)))
+
+(define (test-bit-field? size position n)
+  (not (zero? (bit-and (arithmetic-shift n (- position)) (mask size)))))
+
+(define (replace-bit-field size position newfield n)
+  (bit-ior (bit-and n (bitwise-not (arithmetic-shift (mask size) position)))
+           (arithmetic-shift newfield position)))
+
+(define (clear-bit-field size position n)
+  (replace-bit-field size position 0 n))
+
+(define (copy-bit-field size position from to)
+  (bitwise-merge (arithmetic-shift (mask size) position) to from))
+
diff --git a/lib/srfi/38.scm b/lib/srfi/38.scm
new file mode 100644
index 00000000..d75a3006
--- /dev/null
+++ b/lib/srfi/38.scm
@@ -0,0 +1,436 @@
+;;;; srfi-38.scm - reading and writing shared structures
+;;
+;; This code was written by Alex Shinn in 2009 and placed in the
+;; Public Domain.  All warranties are disclaimed.
+
+(define (raise-typed-error type)
+  (lambda (msg . args) (raise (make-exception type msg args #f #f))))
+(define read-error (raise-typed-error 'read))
+(define read-incomplete-error (raise-typed-error 'read-incomplete))
+
+(define (extract-shared-objects x cyclic-only?)
+  (let ((seen (make-hash-table eq?)))
+    ;; find shared references
+    (let find ((x x))
+      (let ((type (type-of x)))
+        (cond ;; only interested in pairs, vectors and records
+         ((or (pair? x) (vector? x) (and type (type-printer type)))
+          ;; increment the count
+          (hash-table-update!/default seen x (lambda (n) (+ n 1)) 0)
+          ;; walk if this is the first time
+          (cond
+           ((> (hash-table-ref seen x) 1))
+           ((pair? x)
+            (find (car x))
+            (find (cdr x)))
+           ((vector? x)
+            (do ((i 0 (+ i 1)))
+                ((= i (vector-length x)))
+              (find (vector-ref x i))))
+           (else
+            (let ((num-slots (type-num-slots type)))
+              (let lp ((i 0))
+                (cond ((< i num-slots)
+                       (find (slot-ref type x i))
+                       (lp (+ i 1))))))))
+          ;; delete if this shouldn't count as a shared reference
+          (if (and cyclic-only?
+                   (<= (hash-table-ref/default seen x 0) 1))
+              (hash-table-delete! seen x))))))
+    ;; extract shared references
+    (let ((res (make-hash-table eq?)))
+      (hash-table-walk
+       seen
+       (lambda (k v) (if (> v 1) (hash-table-set! res k #t))))
+      res)))
+
+(define (write-with-shared-structure x . o)
+  (let ((out (if (pair? o) (car o) (current-output-port)))
+        (shared
+         (extract-shared-objects x (and (pair? o) (pair? (cdr o)) (cadr o))))
+        (count 0))
+    (define (check-shared x prefix cont)
+      (let ((index (hash-table-ref/default shared x #f)))
+        (cond ((integer? index)
+               (display prefix out)
+               (display "#" out)
+               (write index out)
+               (display "#" out))
+              (else
+               (cond (index
+                      (display prefix out)
+                      (display "#" out)
+                      (write count out)
+                      (display "=" out)
+                      (hash-table-set! shared x count)
+                      (set! count (+ count 1))))
+               (cont x index)))))
+    (let wr ((x x))
+      (check-shared
+       x
+       ""
+       (lambda (x shared?)
+         (cond
+          ((pair? x)
+           (display "(" out)
+           (wr (car x))
+           (let lp ((ls (cdr x)))
+             (check-shared
+              ls
+              " . "
+              (lambda (ls shared?)
+                (cond ((null? ls))
+                      ((pair? ls)
+                       (cond
+                        (shared?
+                         (display "(" out)
+                         (wr (car ls))
+                         (check-shared
+                          (cdr ls)
+                          " . "
+                          (lambda (ls shared?) (lp ls)))
+                         (display ")" out))
+                        (else
+                         (display " " out)
+                         (wr (car ls))
+                         (lp (cdr ls)))))
+                      (else
+                       (display " . " out)
+                       (wr ls))))))
+           (display ")" out))
+          ((vector? x)
+           (display "#(" out)
+           (let ((len (vector-length x)))
+             (cond ((> len 0)
+                    (wr (vector-ref x 0))
+                    (do ((i 1 (+ i 1)))
+                        ((= i len))
+                      (display " " out)
+                      (wr (vector-ref x i))))))
+           (display ")" out))
+          ((let ((type (type-of x)))
+             (and (type? type) (type-printer type)))
+           => (lambda (printer) (printer x wr out)))
+          ((null? x) (display "()" out))
+          ((char? x) (display "#\\" out) (write-char x out))
+          ((symbol? x) (display (symbol->string x) out))
+          ((number? x) (display (number->string x) out))
+          ((eq? x #t) (display "#t" out))
+          ((eq? x #f) (display "#f" out))
+          (else
+           ;; (display "#<unknown>" out)
+           (write x out))))))))
+
+(define write/ss write-with-shared-structure)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (skip-line in)
+  (let ((c (read-char in)))
+    (if (not (or (eof-object? c) (eqv? c #\newline)))
+        (skip-line in))))
+
+(define (skip-whitespace in)
+  (case (peek-char in)
+    ((#\space #\tab #\newline #\return)
+     (read-char in)
+     (skip-whitespace in))
+    ((#\;)
+     (skip-line in)
+     (skip-whitespace in))))
+
+(define (skip-comment in depth)
+  (case (read-char in)
+    ((#\#) (skip-comment in (if (eqv? #\| (peek-char in)) (+ depth 1) depth)))
+    ((#\|) (if (eqv? #\# (peek-char in))
+               (if (zero? depth) (read-char in) (skip-comment in (- depth 1)))
+               (skip-comment in depth)))
+    (else (if (eof-object? (peek-char in))
+              (read-incomplete-error "unterminated #| comment")
+              (skip-comment in depth)))))
+
+;; returns #f if a trailing # was consumed
+(define (skip-whitespace-and-sexp-comments in read)
+  (skip-whitespace in)
+  (cond
+   ((eqv? #\# (peek-char in))
+    (read-char in)
+    (cond ((eqv? #\; (peek-char in))
+           (read-char in)
+           (read in)
+           (skip-whitespace-and-sexp-comments in read))
+          (else #f)))
+   (else
+    #t)))
+
+(define delimiters
+  '(#\; #\" #\| #\( #\) #\{ #\} #\space #\tab #\newline #\return))
+
+(define named-chars
+  `(("newline" . #\newline)
+    ("return" . #\return)
+    ("space" . #\space)
+    ("tab" . #\tab)
+    ("null" . ,(integer->char 0))
+    ("alarm" . ,(integer->char 7))
+    ("backspace" . ,(integer->char 8))
+    ("escape" . ,(integer->char 27))
+    ("delete" . ,(integer->char 127))))
+
+(define read-with-shared-structure
+  (let ((read read))
+    (lambda o
+      (let ((in (if (pair? o) (car o) (current-input-port)))
+            (shared '()))
+        (define (read-label res)
+          (let ((c (peek-char in)))
+            (cond
+             ((and (not (eof-object? c))
+                   (or (char-numeric? c)
+                       (memv (char-downcase c)
+                             '(#\- #\+ #\a #\b #\c #\d #\e #\f #\i))))
+              (read-label (cons (read-char in) res)))
+             ((and (eqv? c #\/) (not (memv #\/ res)))
+              (read-label (cons (read-char in) res)))
+             (else
+              (list->string (reverse res))))))
+        (define (read-number base)
+          (let* ((str (read-label '()))
+                 (n (string->number str base))
+                 (c (peek-char in)))
+            (if (or (not n) (not (or (eof-object? c) (memv c delimiters))))
+                (read-error "read error: invalid number syntax" str c)
+                n)))
+        (define (read-float-tail in) ;; called only after a leading period
+          (let lp ((res 0.0) (k 0.1))
+            (let ((c (peek-char in)))
+              (cond
+               ((char-numeric? c)
+                (lp (+ res (* (- (char->integer (read-char in))
+                                 (char->integer #\0))
+                              k))
+                    (* k 0.1)))
+               ((or (eof-object? c) (memv c delimiters)) res)
+               (else (read-error "invalid char in float syntax" c))))))
+        (define (read-name c in)
+          (let lp ((ls (if (char? c) (list c) '())))
+            (let ((c (peek-char in)))
+              (cond ((or (eof-object? c) (memv c delimiters))
+                     (list->string (reverse ls)))
+                    (else (lp (cons (read-char in) ls)))))))
+        (define (read-named-char c in)
+          (let ((name (read-name c in)))
+            (cond ((assoc name named-chars string-ci=?) => cdr)
+                  ((and (or (eqv? c #\x) (eqv? c #\X))
+                        (string->number (substring name 1 (string-length name))
+                                        16))
+                   => integer->char)
+                  (else (read-error "unknown char name" name)))))
+        (define (read-type-id in)
+          (let ((ch (peek-char in)))
+            (cond
+             ((eqv? ch #\#)
+              (read-char in)
+              (let ((id (read in)))
+                (cond ((eq? id 't) #t)
+                      ((integer? id) id)
+                      (else (read-error "invalid type identifier" id)))))
+             ((eqv? ch #\")
+              (read in))
+             (else
+              (read-error "invalid type identifier syntax" ch)))))
+        (define (read-object)
+          (let ((name (read-name #f in)))
+            (skip-whitespace in)
+            (let* ((id (read-type-id in))
+                   (type (lookup-type name id)))
+              (let lp ((ls '()))
+                (skip-whitespace in)
+                (cond
+                 ((eof-object? (peek-char in))
+                  (read-error "missing closing }"))
+                 ((eqv? #\} (peek-char in))
+                  (read-char in)
+                  (let ((res ((make-constructor #f type))))
+                    (let lp ((ls (reverse ls)) ( i 0))
+                      (cond
+                       ((null? ls)
+                        res)
+                       (else
+                        (slot-set! type res i (car ls))
+                        (lp (cdr ls) (+ i 1)))))))
+                 (else (lp (cons (read-one) ls))))))))
+        (define (read-one)
+          (skip-whitespace in)
+          (case (peek-char in)
+            ((#\#)
+             (read-char in)
+             (if (eof-object? (peek-char in))
+                 (read-error "read error: incomplete # found at end of input"))
+             (case (char-downcase (peek-char in))
+               ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+                (let* ((str (read-label '()))
+                       (n (string->number str)))
+                  (if (not n) (read-error "read error: invalid reference" str))
+                  (cond
+                   ((eqv? #\= (peek-char in))
+                    (read-char in)
+                    (let* ((cell (list #f))
+                           (thunk (lambda () (car cell))))
+                      (set! shared (cons (cons n thunk) shared))
+                      (let ((x (read-one)))
+                        (set-car! cell x)
+                        x)))
+                   ((eqv? #\# (peek-char in))
+                    (read-char in)
+                    (cond
+                     ((assv n shared) => cdr)
+                     (else (read-error "read error: unknown reference" n))))
+                   (else
+                    (read-error "read error: expected # after #n"
+                                (read-char in))))))
+               ((#\;)
+                (read-char in)
+                (read-one) ;; discard
+                (read-one))
+               ((#\|)
+                (skip-comment in 0)
+                (read-one))
+               ((#\!)
+                (read-char in)
+                (let ((c (peek-char in)))
+                  (cond
+                   ((or (char-whitespace? c) (eqv? c #\/))
+                    (skip-line in)
+                    (read-one))
+                   (else
+                    (let ((name (read-name #f in)))
+                      (cond
+                       ((string-ci=? name "fold-case")
+                        (set-port-fold-case! in #t))
+                       ((string-ci=? name "no-fold-case")
+                        (set-port-fold-case! in #f))
+                       (else            ;; assume a #!/bin/bash line
+                        (read-error "unknown #! symbol" name)))
+                      (read-one))))))
+               ((#\() (list->vector (read-one)))
+               ((#\') (read-char in) (list 'syntax (read-one)))
+               ((#\`) (read-char in) (list 'quasisyntax (read-one)))
+               ((#\t) (let ((s (read-name #f in)))
+                        (or (string-ci=? s "t") (string-ci=? s "true")
+                            (read-error "bad # syntax" s))))
+               ((#\f) (let ((s (read-name #f in)))
+                        (if (or (string-ci=? s "f") (string-ci=? s "false"))
+                            #f
+                            (read-error "bad # syntax" s))))
+               ((#\d) (read-char in) (read in))
+               ((#\x) (read-char in) (read-number 16))
+               ((#\o) (read-char in) (read-number 8))
+               ((#\b) (read-char in) (read-number 2))
+               ((#\i) (read-char in) (exact->inexact (read-one)))
+               ((#\e) (string->number (read-name #\# in)))
+               ((#\u #\v)
+                (if (eqv? #\v (peek-char in))
+                    (read-char in))
+                (read-char in)
+                (if (not (eqv? #\8 (peek-char in)))
+                    (read-error "invalid syntax #u" (peek-char in)))
+                (read-char in)
+                (let ((ls (read-one)))
+                  (if (not (list? ls))
+                      (read-error "invalid bytevector syntax" ls))
+                  (let* ((len (length ls))
+                         (bv (make-bytevector len)))
+                    (do ((i 0 (+ i 1)) (ls ls (cdr ls)))
+                        ((null? ls) bv)
+                      (bytevector-u8-set! bv i (car ls))))))
+               ((#\\)
+                (read-char in)
+                (let* ((c1 (read-char in))
+                       (c2 (peek-char in)))
+                  (if (or (eof-object? c2) (memv c2 delimiters))
+                      c1
+                      (read-named-char c1 in))))
+               (else
+                (read-error "unknown # syntax: " (peek-char in)))))
+            ((#\()
+             (read-char in)
+             (let lp ((res '()))
+               (skip-whitespace in)
+               (let ((c (peek-char in)))
+                 (case c
+                   ((#\))
+                    (read-char in)
+                    (reverse res))
+                   ((#\.)
+                    (read-char in)
+                    (cond
+                     ((memv (peek-char in) delimiters)
+                      (let ((tail (read-one)))
+                        (cond
+                         ((and (skip-whitespace-and-sexp-comments
+                                in (lambda (in) (read-one)))
+                               (eqv? #\) (peek-char in)))
+                          (read-char in)
+                          (append (reverse res) tail))
+                         ((eof-object? (peek-char in))
+                          (read-incomplete-error "unterminated dotted list"))
+                         (else
+                          (read-error "expected end of list after dot")))))
+                     ((char-numeric? (peek-char in))
+                      (lp (cons (read-float-tail in) res)))
+                     (else
+                      (lp (cons (string->symbol (read-name #\. in)) res)))))
+                   (else
+                    (if (eof-object? c)
+                        (read-incomplete-error "unterminated list")
+                        (lp (cons (read-one) res))))))))
+            ((#\{)
+             (read-char in)
+             (read-object))
+            ((#\') (read-char in) (list 'quote (read-one)))
+            ((#\`) (read-char in) (list 'quasiquote (read-one)))
+            ((#\,)
+             (read-char in)
+             (let ((sym (if (eqv? #\@ (peek-char in))
+                            (begin (read-char in) 'unquote-splicing)
+                            'unquote)))
+               (list sym (read-one))))
+            (else
+             (read in))))
+        ;; body
+        (let ((res (read-one)))
+          (if (pair? shared)
+              (patch res))
+          res)))))
+
+(define (hole? x) (procedure? x))
+(define (fill-hole x) (if (hole? x) (fill-hole (x)) x))
+
+(define (patch x)
+  (cond
+   ((pair? x)
+    (if (hole? (car x)) (set-car! x (fill-hole (car x))) (patch (car x)))
+    (if (hole? (cdr x)) (set-cdr! x (fill-hole (cdr x))) (patch (cdr x))))
+   ((vector? x)
+    (do ((i (- (vector-length x) 1) (- i 1)))
+        ((< i 0))
+      (let ((elt (vector-ref x i)))
+        (if (hole? elt)
+            (vector-set! x i (fill-hole elt))
+            (patch elt)))))
+   (else
+    (let* ((type (type-of x))
+           (slots (and type (type-slots type))))
+      (cond
+       (slots
+        (let lp ((i 0) (ls slots))
+          (cond
+           ((pair? ls)
+            (let ((elt (slot-ref type x i)))
+              (if (hole? elt)
+                  (slot-set! type x i (fill-hole elt))
+                  (patch elt))
+              (lp (+ i 1) (cdr ls))))))))))))
+
+(define read/ss read-with-shared-structure)
diff --git a/lib/srfi/38.sld b/lib/srfi/38.sld
new file mode 100644
index 00000000..60a6c31c
--- /dev/null
+++ b/lib/srfi/38.sld
@@ -0,0 +1,6 @@
+
+(define-library (srfi 38)
+  (import (chibi) (srfi 69) (chibi ast))
+  (export write-with-shared-structure write/ss
+          read-with-shared-structure read/ss)
+  (include "38.scm"))
diff --git a/lib/srfi/39.sld b/lib/srfi/39.sld
new file mode 100644
index 00000000..fe2341f5
--- /dev/null
+++ b/lib/srfi/39.sld
@@ -0,0 +1,10 @@
+
+(define-library (srfi 39)
+  (export make-parameter parameterize)
+  (import (chibi))
+  (include-shared "39/param")
+  (cond-expand
+   (threads
+    (include "39/syntax.scm"))
+   (else
+    (include "39/syntax-no-threads.scm"))))
diff --git a/lib/srfi/39/param.c b/lib/srfi/39/param.c
new file mode 100644
index 00000000..01c477db
--- /dev/null
+++ b/lib/srfi/39/param.c
@@ -0,0 +1,40 @@
+/*  param.c -- low-level parameter utilities                  */
+/*  Copyright (c) 2010-2011 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+
+#define _I(x) sexp_make_fixnum(x)
+
+static sexp sexp_make_parameter (sexp ctx, sexp self, sexp_sint_t n, sexp init, sexp conv) {
+  sexp res;
+  sexp_gc_var1(cell);
+  sexp_gc_preserve1(ctx, cell);
+  cell = sexp_cons(ctx, SEXP_FALSE, init);
+  res = sexp_make_opcode(ctx, self, SEXP_FALSE, _I(SEXP_OPC_PARAMETER),
+                         _I(SEXP_OP_PARAMETER_REF), SEXP_ZERO, SEXP_ONE,
+                         _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_ZERO,
+                         cell, conv, NULL);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+static sexp sexp_parameter_converter (sexp ctx, sexp self, sexp_sint_t n, sexp param) {
+  sexp res;
+  sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, param);
+  res = sexp_opcode_data2(param);
+  return res ? res : SEXP_FALSE;
+}
+
+sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
+  if (!(sexp_version_compatible(ctx, version, sexp_version)
+        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
+    return SEXP_ABI_ERROR;
+
+  sexp_define_foreign(ctx, env, "%make-parameter", 2, sexp_make_parameter);
+  sexp_define_foreign(ctx, env, "parameter-converter", 1, sexp_parameter_converter);
+
+  return SEXP_VOID;
+}
+
+#undef _I
diff --git a/lib/srfi/39/syntax-no-threads.scm b/lib/srfi/39/syntax-no-threads.scm
new file mode 100644
index 00000000..a26167f0
--- /dev/null
+++ b/lib/srfi/39/syntax-no-threads.scm
@@ -0,0 +1,40 @@
+;; param.scm -- SRFI-39 parameters
+;; Copyright (c) 2010-2011 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (parameter-convert param value)
+  (let ((proc (parameter-converter param)))
+    (if (procedure? proc)
+        (proc value)
+        value)))
+
+(define (make-parameter init . o)
+  (let ((conv (and (pair? o) (car o))))
+    (%make-parameter (if conv (conv init) init) conv)))
+
+(define-syntax parameterize
+  (syntax-rules ()
+    ((parameterize ("step")
+                   ((param value p old new) ...)
+                   ()
+                   body)
+     (let ((p param) ...)
+       (let ((old (p)) ...
+             (new (parameter-convert p value)) ...)
+         (dynamic-wind
+          (lambda () (p new) ...)
+          (lambda () . body)
+          (lambda () (p old) ...)))))
+    ((parameterize ("step")
+                   args
+                   ((param value) . rest)
+                   body)
+     (parameterize ("step")
+                   ((param value p old new) . args)
+                   rest
+                   body))
+    ((parameterize ((param value) ...) . body)
+     (parameterize ("step")
+                   ()
+                   ((param value) ...)
+                   body))))
diff --git a/lib/srfi/39/syntax.scm b/lib/srfi/39/syntax.scm
new file mode 100644
index 00000000..72e04674
--- /dev/null
+++ b/lib/srfi/39/syntax.scm
@@ -0,0 +1,29 @@
+;; param.scm -- SRFI-39 parameters
+;; Copyright (c) 2010 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (parameter-convert param value)
+  (let ((proc (parameter-converter param)))
+    (if (procedure? proc)
+        (proc value)
+        value)))
+
+(define (make-parameter init . o)
+  (let ((conv (and (pair? o) (car o))))
+    (%make-parameter (if conv (conv init) init) conv)))
+
+(define-syntax parameterize
+  (syntax-rules ()
+    ((parameterize ("step") old cons-new ((param value ptmp vtmp) ...) () body)
+     (let ((ptmp param) ...)
+       (let ((vtmp (parameter-convert ptmp value)) ...)
+         (let ((old (thread-parameters)))
+           (let ((new cons-new))
+             (dynamic-wind
+                 (lambda () (thread-parameters-set! new))
+                 (lambda () . body)
+                 (lambda () (thread-parameters-set! old))))))))
+    ((parameterize ("step") old cons-new args ((param value) . rest) body)
+     (parameterize ("step") old (cons (cons ptmp vtmp) cons-new) ((param value ptmp vtmp) . args) rest body))
+    ((parameterize ((param value) ...) . body)
+     (parameterize ("step") old (thread-parameters) () ((param value) ...) body))))
diff --git a/lib/srfi/46.sld b/lib/srfi/46.sld
new file mode 100644
index 00000000..19a522dc
--- /dev/null
+++ b/lib/srfi/46.sld
@@ -0,0 +1,4 @@
+
+(define-library (srfi 46)
+  (import (chibi))
+  (export syntax-rules))
diff --git a/lib/srfi/55.sld b/lib/srfi/55.sld
new file mode 100644
index 00000000..348065bf
--- /dev/null
+++ b/lib/srfi/55.sld
@@ -0,0 +1,9 @@
+
+(define-library (srfi 55)
+  (export require-extension)
+  (import (chibi))
+  (begin
+   (define-syntax require-extension
+     (syntax-rules ()
+       ((require-extension (prefix mod ...))
+        (begin (import (prefix mod) ...)))))))
diff --git a/lib/srfi/6.sld b/lib/srfi/6.sld
new file mode 100644
index 00000000..27b36b29
--- /dev/null
+++ b/lib/srfi/6.sld
@@ -0,0 +1,4 @@
+
+(define-library (srfi 6)
+  (export open-input-string open-output-string get-output-string)
+  (import (chibi)))
diff --git a/lib/srfi/69.sld b/lib/srfi/69.sld
new file mode 100644
index 00000000..785b58cf
--- /dev/null
+++ b/lib/srfi/69.sld
@@ -0,0 +1,15 @@
+
+(define-library (srfi 69)
+  (export hash-table-cell
+   make-hash-table hash-table? alist->hash-table
+   hash-table-equivalence-function hash-table-hash-function
+   hash-table-ref hash-table-ref/default hash-table-set!
+   hash-table-delete! hash-table-exists?
+   hash-table-update! hash-table-update!/default
+   hash-table-size hash-table-keys hash-table-values
+   hash-table-walk hash-table-fold hash-table->alist
+   hash-table-copy hash-table-merge!
+   hash string-hash string-ci-hash hash-by-identity)
+  (import (chibi) (srfi 9))
+  (include-shared "69/hash")
+  (include "69/type.scm" "69/interface.scm"))
diff --git a/lib/srfi/69/hash.c b/lib/srfi/69/hash.c
new file mode 100644
index 00000000..13987c36
--- /dev/null
+++ b/lib/srfi/69/hash.c
@@ -0,0 +1,252 @@
+/*  hash.c -- type-general hashing                            */
+/*  Copyright (c) 2009-2011 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+
+#define HASH_DEPTH 5
+#define HASH_BOUND sexp_make_fixnum(SEXP_MAX_FIXNUM)
+
+#define FNV_PRIME 16777619
+#define FNV_OFFSET_BASIS 2166136261uL
+
+#define sexp_hash_table_buckets(x)  sexp_slot_ref(x, 0)
+#define sexp_hash_table_size(x)     sexp_slot_ref(x, 1)
+#define sexp_hash_table_hash_fn(x)  sexp_slot_ref(x, 2)
+#define sexp_hash_table_eq_fn(x)    sexp_slot_ref(x, 3)
+
+#define sexp_hash_resize_check(n, len) (((n)*3) > ((len)>>2))
+
+static sexp_uint_t string_hash (char *str, sexp_uint_t bound) {
+  sexp_uint_t acc = FNV_OFFSET_BASIS;
+  while (*str) {acc *= FNV_PRIME; acc ^= *str++;}
+  return acc % bound;
+}
+
+static sexp sexp_string_hash (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp bound) {
+  if (! sexp_stringp(str))
+    return sexp_type_exception(ctx, self, SEXP_STRING, str);
+  else if (! sexp_fixnump(bound))
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound);
+  return sexp_make_fixnum(string_hash(sexp_string_data(str),
+                                      sexp_unbox_fixnum(bound)));
+}
+
+static sexp_uint_t string_ci_hash (char *str, sexp_uint_t bound) {
+  sexp_uint_t acc = FNV_OFFSET_BASIS;
+  while (*str) {acc *= FNV_PRIME; acc ^= sexp_tolower(*str++);}
+  return acc % bound;
+}
+
+static sexp sexp_string_ci_hash (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp bound) {
+  if (! sexp_stringp(str))
+    return sexp_type_exception(ctx, self, SEXP_STRING, str);
+  else if (! sexp_fixnump(bound))
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound);
+  return sexp_make_fixnum(string_ci_hash(sexp_string_data(str),
+                                         sexp_unbox_fixnum(bound)));
+}
+
+static sexp_uint_t hash_one (sexp ctx, sexp obj, sexp_uint_t bound, sexp_sint_t depth) {
+  sexp_uint_t acc = FNV_OFFSET_BASIS, size;
+  sexp_sint_t i, len;
+  sexp t, *p;
+  char *p0;
+ loop:
+  if (obj) {
+#if SEXP_USE_FLONUMS
+    if (sexp_flonump(obj))
+      acc ^= (sexp_sint_t) sexp_flonum_value(obj);
+    else
+#endif
+    if (sexp_pointerp(obj)) {
+      if (depth > 0) {
+        t = sexp_object_type(ctx, obj);
+        p = (sexp*) (((char*)obj) + sexp_type_field_base(t));
+        p0 = ((char*)obj) + offsetof(struct sexp_struct, value);
+        if ((sexp)p == obj) p=(sexp*)p0;
+        /* hash trailing non-object data */
+        size = sexp_type_size_of_object(t, obj)-offsetof(struct sexp_struct, value);
+        p0 = ((char*)p + sexp_type_num_slots_of_object(t,obj)*sizeof(sexp));
+        if (((char*)obj + size) > p0)
+          for (i=0; i<size; i++) {acc *= FNV_PRIME; acc ^= p0[i];}
+        /* hash eq-object slots */
+        len = sexp_type_num_eq_slots_of_object(t, obj);
+        if (len > 0) {
+          depth--;
+          for (i=0; i<len-1; i++) {
+            acc *= FNV_PRIME;
+            acc ^= hash_one(ctx, p[i], 0, depth);
+          }
+          /* tail-recurse on the last value */
+          obj = p[len-1]; goto loop;
+        }
+      } else {
+        acc ^= sexp_pointer_tag(obj);
+      }
+    } else {
+      acc ^= (sexp_uint_t)obj;
+    }
+  }
+  return (bound ? acc % bound : acc);
+}
+
+static sexp sexp_hash (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp bound) {
+  if (! sexp_exact_integerp(bound))
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound);
+  return sexp_make_fixnum(hash_one(ctx, obj, sexp_unbox_fixnum(bound), HASH_DEPTH));
+}
+
+static sexp sexp_hash_by_identity (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp bound) {
+  if (! sexp_exact_integerp(bound))
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound);
+  return sexp_make_fixnum((sexp_uint_t)obj % sexp_unbox_fixnum(bound));
+}
+
+static sexp sexp_get_bucket (sexp ctx, sexp buckets, sexp hash_fn, sexp obj) {
+  sexp_gc_var1(args);
+  sexp res;
+  sexp_uint_t len = sexp_vector_length(buckets);
+  if (hash_fn == SEXP_ONE)
+    res = sexp_hash_by_identity(ctx, NULL, 2, obj, sexp_make_fixnum(len));
+  else if (hash_fn == SEXP_TWO)
+    res = sexp_hash(ctx, NULL, 2, obj, sexp_make_fixnum(len));
+  else {
+    sexp_gc_preserve1(ctx, args);
+    args = sexp_list2(ctx, obj, sexp_make_fixnum(len));
+    res = sexp_apply(ctx, hash_fn, args);
+    if (sexp_exceptionp(res)) {
+      args = sexp_eval_string(ctx, "(current-error-port)", -1, sexp_context_env(ctx));
+      sexp_print_exception(ctx, res, args);
+      res = SEXP_ZERO;
+    } else if (sexp_unbox_fixnum(res) >= len) {
+      res = SEXP_ZERO;
+    }
+    sexp_gc_release1(ctx);
+  }
+  return res;
+}
+
+static sexp sexp_scan_bucket (sexp ctx, sexp ls, sexp obj, sexp eq_fn) {
+  sexp_gc_var1(res);
+  sexp p;
+  res = SEXP_FALSE;
+  if ((eq_fn == SEXP_ONE)
+      || ((eq_fn == SEXP_TWO)
+          && (sexp_pointerp(obj) ?
+              (sexp_pointer_tag(obj) == SEXP_SYMBOL) : ! sexp_fixnump(obj)))) {
+    for (p=ls; sexp_pairp(p); p=sexp_cdr(p)) {
+      if (sexp_caar(p) == obj) {
+        res = p;
+        break;
+      }
+    }
+  } else if (eq_fn == SEXP_TWO) {
+    for (p=ls; sexp_pairp(p); p=sexp_cdr(p)) {
+      if (sexp_truep(sexp_equalp(ctx, sexp_caar(p), obj))) {
+        res = p;
+        break;
+      }
+    }
+  } else {
+    sexp_gc_preserve1(ctx, res);
+    for (p=ls; sexp_pairp(p); p=sexp_cdr(p)) {
+      res = sexp_list2(ctx, sexp_caar(p), obj);
+      if (sexp_truep(sexp_apply(ctx, eq_fn, res))) {
+        res = p;
+        break;
+      } else {
+        res = SEXP_FALSE;
+      }
+    }
+    sexp_gc_release1(ctx);
+  }
+  return res;
+}
+
+static void sexp_regrow_hash_table (sexp ctx, sexp ht, sexp oldbuckets, sexp hash_fn) {
+  sexp ls, *oldvec, *newvec;
+  int i, j, oldsize=sexp_vector_length(oldbuckets), newsize=oldsize*2;
+  sexp_gc_var1(newbuckets);
+  sexp_gc_preserve1(ctx, newbuckets);
+  newbuckets = sexp_make_vector(ctx, sexp_make_fixnum(newsize), SEXP_NULL);
+  if (newbuckets) {
+    oldvec = sexp_vector_data(oldbuckets);
+    newvec = sexp_vector_data(newbuckets);
+    for (i=0; i<oldsize; i++) {
+      for (ls=oldvec[i]; sexp_pairp(ls); ls=sexp_cdr(ls)) {
+        j = sexp_unbox_fixnum(sexp_get_bucket(ctx, newbuckets, hash_fn, sexp_caar(ls)));
+        sexp_push(ctx, newvec[j], sexp_car(ls));
+      }
+    }
+    sexp_hash_table_buckets(ht) = newbuckets;
+  }
+  sexp_gc_release1(ctx);
+}
+
+static sexp sexp_hash_table_cell (sexp ctx, sexp self, sexp_sint_t n, sexp ht, sexp obj, sexp createp) {
+  sexp buckets, eq_fn, hash_fn, i;
+  sexp_uint_t size;
+  sexp_gc_var1(res);
+  /* extra check - exact type should be checked by the calling procedure */
+  if (! sexp_pointerp(ht))
+    return sexp_xtype_exception(ctx, self, "not a Hash-Table", ht);
+  buckets = sexp_hash_table_buckets(ht);
+  eq_fn = sexp_hash_table_eq_fn(ht);
+  hash_fn = sexp_hash_table_hash_fn(ht);
+  i = sexp_get_bucket(ctx, buckets, hash_fn, obj);
+  res = sexp_scan_bucket(ctx, sexp_vector_ref(buckets, i), obj, eq_fn);
+  if (sexp_truep(res)) {
+    res = sexp_car(res);
+  } else if (sexp_truep(createp)) {
+    sexp_gc_preserve1(ctx, res);
+    size = sexp_unbox_fixnum(sexp_hash_table_size(ht));
+    if (sexp_hash_resize_check(size, sexp_vector_length(buckets))) {
+      sexp_regrow_hash_table(ctx, ht, buckets, hash_fn);
+      buckets = sexp_hash_table_buckets(ht);
+      i = sexp_get_bucket(ctx, buckets, hash_fn, obj);
+    }
+    res = sexp_cons(ctx, obj, createp);
+    sexp_vector_set(buckets, i, sexp_cons(ctx, res, sexp_vector_ref(buckets, i)));
+    sexp_hash_table_size(ht) = sexp_make_fixnum(size+1);
+    sexp_gc_release1(ctx);
+  }
+  return res;
+}
+
+static sexp sexp_hash_table_delete (sexp ctx, sexp self, sexp_sint_t n, sexp ht, sexp obj) {
+  sexp buckets, eq_fn, hash_fn, i, p, res;
+  if (!(sexp_pointerp(ht) && strcmp(sexp_string_data(sexp_object_type_name(ctx, ht)), "Hash-Table") == 0))
+    return sexp_xtype_exception(ctx, self, "not a Hash-Table", ht);
+  buckets = sexp_hash_table_buckets(ht);
+  eq_fn = sexp_hash_table_eq_fn(ht);
+  hash_fn = sexp_hash_table_hash_fn(ht);
+  i = sexp_get_bucket(ctx, buckets, hash_fn, obj);
+  res = sexp_scan_bucket(ctx, sexp_vector_ref(buckets, i), obj, eq_fn);
+  if (sexp_pairp(res)) {
+    sexp_hash_table_size(ht) = sexp_fx_sub(sexp_hash_table_size(ht), SEXP_ONE);
+    if (res == sexp_vector_ref(buckets, i)) {
+      sexp_vector_set(buckets, i, sexp_cdr(res));
+    } else {
+      for (p=sexp_vector_ref(buckets, i); sexp_cdr(p)!=res; p=sexp_cdr(p))
+        ;
+      sexp_cdr(p) = sexp_cdr(res);
+    }
+  }
+  return SEXP_VOID;
+}
+
+sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
+  if (!(sexp_version_compatible(ctx, version, sexp_version)
+        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
+    return SEXP_ABI_ERROR;
+
+  sexp_define_foreign_opt(ctx, env, "string-hash", 2, sexp_string_hash, HASH_BOUND);
+  sexp_define_foreign_opt(ctx, env, "string-ci-hash", 2, sexp_string_ci_hash, HASH_BOUND);
+  sexp_define_foreign_opt(ctx, env, "hash", 2, sexp_hash, HASH_BOUND);
+  sexp_define_foreign_opt(ctx, env, "hash-by-identity", 2, sexp_hash_by_identity, HASH_BOUND);
+  sexp_define_foreign(ctx, env, "hash-table-cell", 3, sexp_hash_table_cell);
+  sexp_define_foreign(ctx, env, "hash-table-delete!", 2, sexp_hash_table_delete);
+
+  return SEXP_VOID;
+}
diff --git a/lib/srfi/69/interface.scm b/lib/srfi/69/interface.scm
new file mode 100644
index 00000000..1f95fe90
--- /dev/null
+++ b/lib/srfi/69/interface.scm
@@ -0,0 +1,116 @@
+;; interface.scm -- hash-table interface
+;; Copyright (c) 2009-2011 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;; the non-exported hash-table-cell is the heart of the implemenation
+
+(define (make-hash-table . o)
+  (let* ((eq-fn (if (pair? o) (car o) equal?))
+         (hash-fn (if (and (pair? o) (pair? (cdr o)))
+                      (car (cdr o))
+                      (if (eq? eq? eq-fn) hash-by-identity hash))))
+    (cond
+     ((not (procedure? eq-fn))
+      (error "make-hash-table: bad equivalence function" eq-fn))
+     ((not (procedure? hash-fn))
+      (error "make-hash-table: bad hash function" hash-fn))
+     (else
+      (%make-hash-table
+       (make-vector 23 '())
+       0
+       (if (eq? hash-fn hash-by-identity) 1 (if (eq? hash-fn hash) 2 hash-fn))
+       (if (eq? eq-fn eq?) 1 (if (eq? eq-fn equal?) 2 eq-fn)))))))
+
+(define (hash-table-hash-function table)
+  (let ((f (%hash-table-hash-function table)))
+    (case f ((1) hash-by-identity) ((2) hash) (else f))))
+
+(define (hash-table-equivalence-function table)
+  (let ((f (%hash-table-equivalence-function table)))
+    (case f ((1) eq?) ((2) equal?) (else f))))
+
+(define-syntax assert-hash-table
+  (syntax-rules ()
+    ((assert-hash-table from obj)
+     (if (not (hash-table? obj))
+         (error (string-append from ": not a Hash-Table") obj)))))
+
+(define (hash-table-ref table key . o)
+  (assert-hash-table "hash-table-ref" table)
+  (let ((cell (hash-table-cell table key #f)))
+    (cond (cell (cdr cell))
+          ((pair? o) ((car o)))
+          (else (error "hash-table-ref: key not found" key)))))
+
+(define (hash-table-ref/default table key default)
+  (assert-hash-table "hash-table-ref/default" table)
+  (let ((cell (hash-table-cell table key #f)))
+    (if cell (cdr cell) default)))
+
+(define (hash-table-set! table key value)
+  (assert-hash-table "hash-table-set!" table)
+  (let ((cell (hash-table-cell table key #t)))
+    (set-cdr! cell value)))
+
+(define (hash-table-exists? table key)
+  (assert-hash-table "hash-table-exists?" table)
+  (and (hash-table-cell table key #f) #t))
+
+(define hash-table-update!
+  (let ((not-found (cons 'not-found '())))
+    (lambda (table key func . o)
+      (assert-hash-table "hash-table-update!" table)
+      (let ((cell (hash-table-cell table key not-found)))
+        (set-cdr! cell (if (eq? not-found (cdr cell))
+                           (if (pair? o)
+                               (func ((car o)))
+                               (error "hash-table-update!: key not found" key))
+                           (func (cdr cell))))))))
+
+(define hash-table-update!/default
+  (let ((not-found (cons 'not-found '())))
+    (lambda (table key func default)
+      (assert-hash-table "hash-table-update!/default" table)
+      (let ((cell (hash-table-cell table key not-found)))
+        (set-cdr! cell (func (if (eq? not-found (cdr cell)) default (cdr cell))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (hash-table-fold table kons knil)
+  (assert-hash-table "hash-table-fold" table)
+  (let ((vec (hash-table-buckets table)))
+    (let lp1 ((i (- (vector-length vec) 1)) (acc knil))
+      (if (< i 0)
+          acc
+          (let lp2 ((ls (vector-ref vec i)) (acc acc))
+            (if (null? ls)
+                (lp1 (- i 1) acc)
+                (lp2 (cdr ls) (kons (car (car ls)) (cdr (car ls)) acc))))))))
+
+(define (hash-table-walk table proc)
+  (hash-table-fold table (lambda (k v a) (proc k v)) #f)
+  (if #f #f))
+
+(define (hash-table->alist table)
+  (hash-table-fold table (lambda (k v a) (cons (cons k v) a)) '()))
+
+(define (hash-table-keys table)
+  (hash-table-fold table (lambda (k v a) (cons k a)) '()))
+
+(define (hash-table-values table)
+  (hash-table-fold table (lambda (k v a) (cons v a)) '()))
+
+(define (alist->hash-table ls . o)
+  (let ((res (apply make-hash-table o)))
+    (for-each (lambda (x) (hash-table-set! res (car x) (cdr x))) ls)
+    res))
+
+(define (hash-table-merge! a b)
+  (hash-table-walk b (lambda (k v) (hash-table-set! a k v)))
+  a)
+
+(define (hash-table-copy table)
+  (assert-hash-table "hash-table-copy" table)
+  (let ((res (make-hash-table (hash-table-equivalence-function table))))
+    (hash-table-merge! res table)
+    res))
diff --git a/lib/srfi/69/type.scm b/lib/srfi/69/type.scm
new file mode 100644
index 00000000..8233857c
--- /dev/null
+++ b/lib/srfi/69/type.scm
@@ -0,0 +1,12 @@
+;; types.scm -- the hash-table record type
+;; Copyright (c) 2009-2011 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define-record-type Hash-Table
+  (%make-hash-table buckets size hash-fn eq-fn)
+  hash-table?
+  (buckets hash-table-buckets hash-table-buckets-set!)
+  (size hash-table-size hash-table-size-set!)
+  (hash-fn %hash-table-hash-function)
+  (eq-fn %hash-table-equivalence-function))
+
diff --git a/lib/srfi/8.sld b/lib/srfi/8.sld
new file mode 100644
index 00000000..1223cef5
--- /dev/null
+++ b/lib/srfi/8.sld
@@ -0,0 +1,9 @@
+
+(define-library (srfi 8)
+  (export receive)
+  (import (chibi))
+  (body
+   (define-syntax receive
+     (syntax-rules ()
+       ((receive params expr . body)
+        (call-with-values (lambda () expr) (lambda params . body)))))))
diff --git a/lib/srfi/9.scm b/lib/srfi/9.scm
new file mode 100644
index 00000000..d8f38377
--- /dev/null
+++ b/lib/srfi/9.scm
@@ -0,0 +1,72 @@
+
+(define-syntax define-record-type
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let* ((name+parent (cadr expr))
+            (name (if (pair? name+parent) (car name+parent) name+parent))
+            (parent (and (pair? name+parent) (cadr name+parent)))
+            (name-str (symbol->string (identifier->symbol name)))
+            (procs (cddr expr))
+            (make (caar procs))
+            (make-fields (cdar procs))
+            (pred (cadr procs))
+            (fields (cddr procs))
+            (_define (rename 'define))
+            (_lambda (rename 'lambda))
+            (_let (rename 'let))
+            (_register (rename 'register-simple-type))
+            (_slot-set! (rename 'slot-set!))
+            (_type_slot_offset (rename 'type-slot-offset)))
+       ;; catch a common mistake
+       (if (eq? name make)
+           (error "same binding for record rtd and constructor" name))
+       `(,(rename 'begin)
+         ;; type
+         (,_define ,name (,_register ,name-str ,parent ',(map car fields)))
+         ;; predicate
+         (,_define ,pred (,(rename 'make-type-predicate)
+                          ,(symbol->string (identifier->symbol pred))
+                          ,name))
+         ;; fields
+         ,@(map (lambda (f)
+                  (and (pair? f) (pair? (cdr f))
+                       `(,_define ,(cadr f)
+                          (,(rename 'make-getter)
+                           ,(symbol->string
+                             (identifier->symbol (cadr f)))
+                           ,name
+                           (,_type_slot_offset ,name ',(car f))))))
+                fields)
+         ,@(map (lambda (f)
+                  (and (pair? f) (pair? (cdr f)) (pair? (cddr f))
+                       `(,_define ,(car (cddr f))
+                          (,(rename 'make-setter)
+                           ,(symbol->string
+                             (identifier->symbol (car (cddr f))))
+                           ,name
+                           (,_type_slot_offset ,name ',(car f))))))
+                fields)
+         ;; constructor
+         (,_define ,make
+           ,(let lp ((ls make-fields) (sets '()))
+              (cond
+               ((null? ls)
+                `(,_let ((%make (,(rename 'make-constructor)
+                                 ,(symbol->string (identifier->symbol make))
+                                 ,name)))
+                   (,_lambda ,make-fields
+                     (,_let ((res (%make)))
+                       ,@sets
+                       res))))
+               (else
+                (let ((field (assq (car ls) fields)))
+                  (cond
+                   ((not field)
+                    (error "unknown record field in constructor" (car ls)))
+                   ((pair? (cddr field))
+                    (lp (cdr ls)
+                        (cons `(,(car (cddr field)) res ,(car ls)) sets)))
+                   (else
+                    (lp (cdr ls)
+                        (cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls))
+                              sets))))))))))))))
diff --git a/lib/srfi/9.sld b/lib/srfi/9.sld
new file mode 100644
index 00000000..1d58203b
--- /dev/null
+++ b/lib/srfi/9.sld
@@ -0,0 +1,5 @@
+
+(define-library (srfi 9)
+  (export define-record-type)
+  (import (chibi))
+  (include "9.scm"))
diff --git a/lib/srfi/95.sld b/lib/srfi/95.sld
new file mode 100644
index 00000000..f4575ad5
--- /dev/null
+++ b/lib/srfi/95.sld
@@ -0,0 +1,6 @@
+
+(define-library (srfi 95)
+  (export sorted? merge merge! sort sort! object-cmp)
+  (import (chibi))
+  (include-shared "95/qsort")
+  (include "95/sort.scm"))
diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c
new file mode 100644
index 00000000..10ce14cf
--- /dev/null
+++ b/lib/srfi/95/qsort.c
@@ -0,0 +1,272 @@
+/*  qsort.c -- quicksort implementation                       */
+/*  Copyright (c) 2009-2011 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include "chibi/eval.h"
+
+#if SEXP_USE_HUFF_SYMS
+#if SEXP_USE_STATIC_LIBS
+#include "chibi/sexp-hufftabdefs.h"
+#else
+#include "chibi/sexp-hufftabs.h"
+#endif
+#endif
+
+#define swap(tmp_var, a, b) (tmp_var=a, a=b, b=tmp_var)
+
+static sexp sexp_vector_copy_to_list (sexp ctx, sexp vec, sexp seq) {
+  sexp_sint_t i;
+  sexp ls, *data=sexp_vector_data(vec);
+  for (i=0, ls=seq; sexp_pairp(ls); i++, ls=sexp_cdr(ls))
+    sexp_car(ls) = data[i];
+  return seq;
+}
+
+static sexp sexp_vector_nreverse (sexp ctx, sexp vec) {
+  int i, j;
+  sexp tmp, *data=sexp_vector_data(vec);
+  for (i=0, j=sexp_vector_length(vec)-1; i<j; i++, j--)
+    swap(tmp, data[i], data[j]);
+  return vec;
+}
+
+static int sexp_basic_comparator (sexp op) {
+  if (sexp_not(op))
+    return 1;
+  if (! sexp_opcodep(op))
+    return 0;
+  if (sexp_opcode_class(op) == SEXP_OPC_ARITHMETIC_CMP)
+    return 1;
+  return 0;
+}
+
+#if SEXP_USE_HUFF_SYMS
+static int sexp_isymbol_compare (sexp ctx, sexp a, sexp b) {
+  int res, res2, tmp;
+  sexp_uint_t c = ((sexp_uint_t)a)>>3, d = ((sexp_uint_t)b)>>3;
+  while (c && d) {
+#include "chibi/sexp-unhuff.h"
+#define c d
+#define res res2
+#include "chibi/sexp-unhuff.h"
+#undef c
+#undef res
+    if ((tmp=res-res2) != 0)
+      return tmp;
+  }
+  return c ? 1 : d ? -1 : 0;
+}
+#endif
+
+static int sexp_object_compare (sexp ctx, sexp a, sexp b) {
+  int res;
+  if (a == b)
+    return 0;
+  if (sexp_pointerp(a)) {
+    if (sexp_pointerp(b)) {
+      if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) {
+        res = sexp_pointer_tag(a) - sexp_pointer_tag(b);
+      } else {
+        switch (sexp_pointer_tag(a)) {
+#if SEXP_USE_FLONUMS
+        case SEXP_FLONUM:
+          res = sexp_flonum_value(a) > sexp_flonum_value(b) ? 1 :
+                sexp_flonum_value(a) < sexp_flonum_value(b) ? -1 : 0;
+          break;
+#endif
+#if SEXP_USE_BIGNUMS
+        case SEXP_BIGNUM:
+          res = sexp_bignum_compare(a, b);
+          break;
+#endif
+#if SEXP_USE_RATIOS
+        case SEXP_RATIO:
+          res = sexp_unbox_fixnum(sexp_ratio_compare(ctx, a, b));
+          break;
+#endif
+#if SEXP_USE_COMPLEX
+        case SEXP_COMPLEX:
+          res = sexp_object_compare(ctx, sexp_complex_real(a), sexp_complex_real(b));
+          if (res==0) res = sexp_object_compare(ctx, sexp_complex_imag(a), sexp_complex_imag(b));
+          break;
+#endif
+        case SEXP_STRING:
+          res = strcmp(sexp_string_data(a), sexp_string_data(b));
+          break;
+        case SEXP_SYMBOL:
+          res = strcmp(sexp_lsymbol_data(a), sexp_lsymbol_data(b));
+          break;
+        /* TODO: consider recursively traversing containers.  requires */
+        /* cycle detection. */
+        /* case SEXP_PAIR: */
+        /*   res = sexp_object_compare(ctx, sexp_car(a), sexp_car(b)); */
+        /*   if (res==0) res = sexp_object_compare(ctx, sexp_cdr(a), sexp_cdr(b)); */
+        /*   break; */
+        default:
+          res = 0;
+          break;
+        }
+      }
+#if SEXP_USE_HUFF_SYMS
+    } else if (sexp_lsymbolp(a) && sexp_isymbolp(b)) {
+      res = strcmp(sexp_lsymbol_data(a),
+		   sexp_string_data(sexp_write_to_string(ctx, b)));
+#endif
+    } else {
+      res = 1;
+    }
+  } else if (sexp_pointerp(b)) {
+#if SEXP_USE_HUFF_SYMS
+    if (sexp_isymbolp(a) && sexp_lsymbolp(b))
+      res = strcmp(sexp_string_data(sexp_write_to_string(ctx, a)),
+		   sexp_lsymbol_data(b));
+    else
+#endif
+      res = -1;
+  } else {
+#if SEXP_USE_HUFF_SYMS
+    if (sexp_isymbolp(a) && sexp_isymbolp(b))
+      return sexp_isymbol_compare(ctx, a, b);
+    else
+#endif
+      res = (sexp_sint_t)a - (sexp_sint_t)b;
+  }
+  return res;
+}
+
+static sexp sexp_object_compare_op (sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b) {
+  return sexp_make_fixnum(sexp_object_compare(ctx, a, b));
+}
+
+/* fast path when using general object-cmp comparator with no key */
+/* TODO: include another fast path when the key is a fixed offset */
+static void sexp_qsort (sexp ctx, sexp *vec, sexp_sint_t lo, sexp_sint_t hi) {
+  sexp_sint_t mid, i, j, diff;
+  sexp tmp, tmp2;
+ loop:
+  if (lo < hi) {
+    mid = lo + (hi-lo)/2;
+    swap(tmp, vec[mid], vec[hi]);
+    /* partition */
+    for (i=j=lo; i < hi; i++) {
+      diff = sexp_object_compare(ctx, vec[i], tmp);
+      if (diff <= 0) {
+        swap(tmp2, vec[i], vec[j]);
+        j++;
+      }
+    }
+    swap(tmp, vec[j], vec[hi]);
+    /* recurse */
+    sexp_qsort(ctx, vec, lo, j-1);
+    if (j < hi-1) {
+      lo = j;
+      goto loop; /* tail recurse on right side */
+    }
+  }
+}
+
+static sexp sexp_qsort_less (sexp ctx, sexp *vec,
+                             sexp_sint_t lo, sexp_sint_t hi,
+                             sexp less, sexp key) {
+  sexp_sint_t mid, i, j;
+  sexp args1;
+  sexp_gc_var5(a, b, tmp, args2, res);
+  sexp_gc_preserve5(ctx, a, b, tmp, args2, res);
+  args2 = sexp_list2(ctx, SEXP_VOID, SEXP_VOID);
+  args1 = sexp_cdr(args2);
+ loop:
+  if (lo >= hi) {
+    res = SEXP_VOID;
+  } else {
+    mid = lo + (hi-lo)/2;
+    swap(tmp, vec[mid], vec[hi]);
+    if (sexp_truep(key)) {
+      sexp_car(args1) = tmp;
+      b = sexp_apply(ctx, key, args1);
+    } else {
+      b = tmp;
+    }
+    /* partition */
+    for (i=j=lo; i < hi; i++) {
+      if (sexp_truep(key)) {
+        sexp_car(args1) = vec[i];
+        a = sexp_apply(ctx, key, args1);
+      } else {
+        a = vec[i];
+      }
+      sexp_car(args2) = b;
+      sexp_car(args1) = a;
+      res = sexp_apply(ctx, less, args2);
+      if (sexp_exceptionp(res)) {
+        goto done;
+      } else if (sexp_not(res)) {
+        swap(res, vec[i], vec[j]), j++;
+      } else {
+        sexp_car(args2) = b;
+        sexp_car(args1) = a;
+        res = sexp_apply(ctx, less, args2);
+        if (sexp_not(res)) j++;  /* equal */
+      }
+    }
+    swap(tmp, vec[j], vec[hi]);
+    /* recurse */
+    res = sexp_qsort_less(ctx, vec, lo, j-1, less, key);
+    if (sexp_exceptionp(res))
+      goto done;
+    if (j < hi-1) {
+      lo = j;
+      goto loop; /* tail recurse on right side */
+    }
+  }
+ done:
+  sexp_gc_release5(ctx);
+  return res;
+}
+
+static sexp sexp_sort_x (sexp ctx, sexp self, sexp_sint_t n, sexp seq,
+                         sexp less, sexp key) {
+  sexp_sint_t len;
+  sexp res, *data;
+  sexp_gc_var1(vec);
+
+  if (sexp_nullp(seq)) return seq;
+
+  sexp_gc_preserve1(ctx, vec);
+
+  vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq);
+
+  if (! sexp_vectorp(vec)) {
+    res = sexp_type_exception(ctx, self, SEXP_VECTOR, vec);
+  } else {
+    data = sexp_vector_data(vec);
+    len = sexp_vector_length(vec);
+    if (sexp_not(key) && sexp_basic_comparator(less)) {
+      sexp_qsort(ctx, data, 0, len-1);
+      if (sexp_opcodep(less) && sexp_opcode_inverse(less))
+        sexp_vector_nreverse(ctx, vec);
+      res = vec;
+    } else if (! (sexp_procedurep(less) || sexp_opcodep(less))) {
+      res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, less);
+    } else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) {
+      res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, key);
+    } else {
+      res = sexp_qsort_less(ctx, data, 0, len-1, less, key);
+      if (!sexp_exceptionp(res)) res = vec;
+    }
+  }
+
+  if (sexp_pairp(seq) && ! sexp_exceptionp(res))
+    res = sexp_vector_copy_to_list(ctx, vec, seq);
+
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
+  if (!(sexp_version_compatible(ctx, version, sexp_version)
+        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
+    return SEXP_ABI_ERROR;
+  sexp_define_foreign(ctx, env, "object-cmp", 2, sexp_object_compare_op);
+  sexp_define_foreign_opt(ctx, env, "sort!", 3, sexp_sort_x, SEXP_FALSE);
+  return SEXP_VOID;
+}
diff --git a/lib/srfi/95/sort.scm b/lib/srfi/95/sort.scm
new file mode 100644
index 00000000..3b15a791
--- /dev/null
+++ b/lib/srfi/95/sort.scm
@@ -0,0 +1,74 @@
+;; sort.scm -- SRFI-95 sorting utilities
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (copy seq)
+  (if (vector? seq)
+      (let* ((len (vector-length seq))
+             (res (make-vector len)))
+        (do ((i (- len 1) (- i 1)))
+            ((< i 0) res)
+          (vector-set! res i (vector-ref seq i))))
+      (map (lambda (x) x) seq)))
+
+(define (sort seq . o)
+  (let ((less (and (pair? o) (car o)))
+        (key (and (pair? o) (pair? (cdr o)) (car (cdr o)))))
+    (sort! (copy seq) less key)))
+
+(define (sorted? seq less . o)
+  (let ((key (if (pair? o) (car o) (lambda (x) x))))
+    (cond
+     ((vector? seq)
+      (let ((len (- (vector-length seq) 1)))
+        (let lp ((i 0))
+          (cond
+           ((>= i len) #t)
+           ((less (key (vector-ref seq (+ i 1)))
+                  (key (vector-ref seq i)))
+            #f)
+           (else (lp (+ i 1)))))))
+     ((null? seq)
+      #t)
+     ((pair? seq)
+      (let lp ((ls1 seq) (ls2 (cdr seq)))
+        (cond ((null? ls2) #t)
+              ((less (key (car ls2)) (key (car ls1))) #f)
+              (else (lp ls2 (cdr ls2))))))
+     (else
+      (error "sorted?: not a list or vector" seq)))))
+
+(define (merge! ls1 ls2 less . o)
+  (let ((key (if (pair? o) (car o) (lambda (x) x))))
+    (define (lp prev ls1 ls2 a b less key)
+      (cond
+       ((less a b)
+        (if (null? (cdr ls1))
+            (set-cdr! ls1 ls2)
+            (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key)))
+       (else
+        (set-cdr! prev ls2)
+        (if (null? (cdr ls2))
+            (set-cdr! ls2 ls1)
+            (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key)))))
+    (cond
+     ((null? ls1) ls2)
+     ((null? ls2) ls1)
+     (else
+      (let ((a (key (car ls1)))
+            (b (key (car ls2))))
+        (cond
+         ((less a b)
+          (if (null? (cdr ls1))
+              (set-cdr! ls1 ls2)
+              (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key))
+          ls1)
+         (else
+          (if (null? (cdr ls2))
+              (set-cdr! ls2 ls1)
+              (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key))
+          ls2)))))))
+
+(define (merge ls1 ls2 less . o)
+  (let ((key (if (pair? o) (car o) (lambda (x) x))))
+    (merge! (copy ls1) (copy ls2) less key)))
diff --git a/lib/srfi/98.sld b/lib/srfi/98.sld
new file mode 100644
index 00000000..a28e64f3
--- /dev/null
+++ b/lib/srfi/98.sld
@@ -0,0 +1,4 @@
+
+(define-library (srfi 98)
+  (export get-environment-variable get-environment-variables)
+  (include-shared "98/env"))
diff --git a/lib/srfi/98/env.c b/lib/srfi/98/env.c
new file mode 100644
index 00000000..e583ab70
--- /dev/null
+++ b/lib/srfi/98/env.c
@@ -0,0 +1,55 @@
+/* env.c -- SRFI-98 environment interface                    */
+/* Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
+/* BSD-style license: http://synthcode.com/license.txt       */
+
+#ifdef __APPLE__
+#include <crt_externs.h>
+#define environ (*_NSGetEnviron())
+#else
+#ifndef PLAN9
+extern char **environ;
+#endif
+#endif
+
+#include <chibi/eval.h>
+
+sexp sexp_get_environment_variable (sexp ctx, sexp self, sexp_sint_t n, sexp str) {
+  char *cstr;
+  if (! sexp_stringp(str))
+    return sexp_type_exception(ctx, self, SEXP_STRING, str);
+  cstr = getenv(sexp_string_data(str));
+  return cstr ? sexp_c_string(ctx, cstr, -1) : SEXP_FALSE;
+}
+
+sexp sexp_get_environment_variables (sexp ctx, sexp self, sexp_sint_t n) {
+  int i;
+  char **env, *cname, *cval;
+  sexp_gc_var3(res, name, val);
+  sexp_gc_preserve3(ctx, res, name, val);
+  res = SEXP_NULL;
+#ifndef PLAN9
+  env = environ;
+  for (i=0; env[i]; i++) {
+    cname = env[i];
+    cval = strchr(cname, '=');
+    if (cval) {
+      name = sexp_c_string(ctx, cname, cval-cname);
+      val = sexp_c_string(ctx, cval+1, -1);
+      val = sexp_cons(ctx, name, val);
+      res = sexp_cons(ctx, val, res);
+    }
+  }
+#endif
+  sexp_gc_release3(ctx);
+  return res;
+}
+
+sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
+  if (!(sexp_version_compatible(ctx, version, sexp_version)
+        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
+    return SEXP_ABI_ERROR;
+  sexp_define_foreign(ctx, env, "get-environment-variable", 1, sexp_get_environment_variable);
+  sexp_define_foreign(ctx, env, "get-environment-variables", 0, sexp_get_environment_variables);
+  return SEXP_VOID;
+}
+
diff --git a/lib/srfi/99.sld b/lib/srfi/99.sld
new file mode 100644
index 00000000..11a238de
--- /dev/null
+++ b/lib/srfi/99.sld
@@ -0,0 +1,7 @@
+
+(define-library (srfi 99)
+  (import (srfi 99 records))
+  (export make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator
+          record? record-rtd rtd-name rtd-parent
+          rtd-field-names rtd-all-field-names rtd-field-mutable?
+          define-record-type))
diff --git a/lib/srfi/99/records.sld b/lib/srfi/99/records.sld
new file mode 100644
index 00000000..a85b9acd
--- /dev/null
+++ b/lib/srfi/99/records.sld
@@ -0,0 +1,9 @@
+
+(define-library (srfi 99 records)
+  (import (srfi 99 records procedural)
+          (srfi 99 records inspection)
+          (srfi 99 records syntactic))
+  (export make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator
+          record? record-rtd rtd-name rtd-parent
+          rtd-field-names rtd-all-field-names rtd-field-mutable?
+          define-record-type))
diff --git a/lib/srfi/99/records/inspection.scm b/lib/srfi/99/records/inspection.scm
new file mode 100644
index 00000000..dfcb55dc
--- /dev/null
+++ b/lib/srfi/99/records/inspection.scm
@@ -0,0 +1,34 @@
+
+(define (record? x)
+  (is-a? x Object))
+
+(define (record-rtd x)
+  (type-of x))
+
+(define (rtd-name x) (string->symbol (type-name x)))
+
+(define (rtd-parent x) (type-parent x))
+
+(define (rtd-field-names x)
+  (list->vector
+   (map (lambda (x) (if (pair? x) (cadr x) x)) (type-slots x))))
+
+(define (rtd-all-field-names x)
+  (let lp ((x x) (res '()))
+    (let ((res (append (vector->list (rtd-field-names x)) res)))
+      (let ((p (type-parent x)))
+        (if (type? p)
+            (lp p res)
+            (list->vector res))))))
+
+(define (rtd-field-mutable? rtd x)
+  (let lp ((ls (type-slots rtd)))
+    (cond ((null? ls)
+           (let ((p (type-parent rtd)))
+             (if (type? p)
+                 (rtd-field-mutable? p x)
+                 (error "unknown field" rtd x))))
+          ((eq? x (car ls)))
+          ((and (pair? (car ls)) (eq? x (cadr (car ls))))
+           (not (eq? 'immutable (caar ls))))
+          (else (lp (cdr ls))))))
diff --git a/lib/srfi/99/records/inspection.sld b/lib/srfi/99/records/inspection.sld
new file mode 100644
index 00000000..25d6324d
--- /dev/null
+++ b/lib/srfi/99/records/inspection.sld
@@ -0,0 +1,6 @@
+
+(define-library (srfi 99 records inspection)
+  (export record? record-rtd rtd-name rtd-parent
+          rtd-field-names rtd-all-field-names rtd-field-mutable?)
+  (import (chibi) (chibi ast))
+  (include "inspection.scm"))
diff --git a/lib/srfi/99/records/procedural.scm b/lib/srfi/99/records/procedural.scm
new file mode 100644
index 00000000..301e5e6d
--- /dev/null
+++ b/lib/srfi/99/records/procedural.scm
@@ -0,0 +1,51 @@
+
+(define (make-rtd name fields . o)
+  (let ((parent (and (pair? o) (car o))))
+    (register-simple-type name parent (vector->list fields))))
+
+(define (rtd? x)
+  (type? x))
+
+(define (rtd-constructor rtd . o)
+  (let ((fields (vector->list (if (pair? o) (car o) (rtd-all-field-names rtd))))
+        (make (make-constructor (type-name rtd) rtd)))
+    (lambda args
+      (let ((res (make)))
+        (let lp ((a args) (p fields))
+          (cond
+           ((null? a) (if (null? p) res (error "not enough args" p)))
+           ((null? p) (error "too many args" a))
+           (else
+            (slot-set! rtd res (rtd-field-offset rtd (car p)) (car a))
+            (lp (cdr a) (cdr p)))))))))
+
+(define (rtd-predicate rtd)
+  (make-type-predicate (type-name rtd) rtd))
+
+(define (field-index-of ls field)
+  (let lp ((i 0) (ls ls))
+    (cond ((null? ls ) #f)
+          ((if (pair? (car ls))
+               (eq? field (car (cdar ls)))
+               (eq? field (car ls)))
+           i)
+          (else (lp (+ i 1) (cdr ls))))))
+
+(define (rtd-field-offset rtd field)
+  (let ((p (type-parent rtd)))
+    (or (and (type? p)
+             (rtd-field-offset p field))
+        (let ((i (field-index-of (type-slots rtd) field)))
+          (and i
+               (if (type? p)
+                   (+ i (vector-length (rtd-all-field-names p)))
+                   i))))))
+
+(define (rtd-accessor rtd field)
+  (make-getter (type-name rtd) rtd (rtd-field-offset rtd field)))
+
+(define (rtd-mutator rtd field)
+  (if (rtd-field-mutable? rtd field)
+      (make-setter (type-name rtd) rtd (rtd-field-offset rtd field))
+      (error "can't make mutator for immutable field" rtd field)))
+
diff --git a/lib/srfi/99/records/procedural.sld b/lib/srfi/99/records/procedural.sld
new file mode 100644
index 00000000..b5791992
--- /dev/null
+++ b/lib/srfi/99/records/procedural.sld
@@ -0,0 +1,5 @@
+
+(define-library (srfi 99 records procedural)
+  (export make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator)
+  (import (chibi) (chibi ast) (srfi 99 records inspection))
+  (include "procedural.scm"))
diff --git a/lib/srfi/99/records/syntactic.scm b/lib/srfi/99/records/syntactic.scm
new file mode 100644
index 00000000..1f8ae70c
--- /dev/null
+++ b/lib/srfi/99/records/syntactic.scm
@@ -0,0 +1,116 @@
+
+(define-syntax define-record-type
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let* ((id->string (lambda (x) (symbol->string (identifier->symbol x))))
+            (name+parent (cadr expr))
+            (name (if (pair? name+parent) (car name+parent) name+parent))
+            (parent (and (pair? name+parent) (cadr name+parent)))
+            (name-str (id->string name))
+            (procs (cddr expr))
+            (make (car procs))
+            (make-name (if (eq? make #t)
+                           (string->symbol (string-append "make-" name-str))
+                           (if (pair? make) (car make) make)))
+            (pred (cadr procs))
+            (pred-name (if (eq? pred #t)
+                           (string->symbol (string-append name-str "?"))
+                           pred))
+            (fields (cddr procs))
+            (field-names (map (lambda (x) (if (pair? x) (car x) x)) fields))
+            (make-fields (if (pair? make) (cdr make) (and (not parent) field-names)))
+            (_make (rename '%make))
+            (_define (rename 'define))
+            (_lambda (rename 'lambda))
+            (_let (rename 'let))
+            (_register (rename 'register-simple-type))
+            (_slot-set! (rename 'slot-set!))
+            (_vector->list (rename 'vector->list))
+            (_type_slot_offset (rename 'type-slot-offset))
+            (_rtd-all-field-names (rename 'rtd-all-field-names)))
+       `(,(rename 'begin)
+         ;; type
+         (,_define ,name (,_register ,name-str ,parent ',field-names))
+         ;; predicate
+         ,@(if pred-name
+               `((,_define ,pred-name
+                   (,(rename 'make-type-predicate)
+                    ,(id->string pred-name)
+                    ,name)))
+               '())
+         ;; accessors
+         ,@(map (lambda (f)
+                  (let ((g (if (and (pair? f) (pair? (cdr f)))
+                               (cadr f)
+                               (string->symbol
+                                 (string-append name-str
+                                                "-"
+                                                (id->string (if (pair? f) (car f) f)))))))
+                    (and g
+                         `(,_define ,g
+                            (,(rename 'make-getter)
+                             ,(id->string g)
+                             ,name
+                             (,_type_slot_offset ,name ',(if (pair? f) (car f) f)))))))
+                fields)
+         ,@(map (lambda (f)
+                  (let ((s (and (pair? f)
+                                (if (and (pair? (cdr f)) (pair? (cddr f)))
+                                    (car (cddr f))
+                                    (string->symbol
+                                      (string-append name-str
+                                                     "-"
+                                                     (id->string (car f))
+                                                     "-set!"))))))
+                    (and s
+                         `(,_define ,s
+                            (,(rename 'make-setter)
+                             ,(id->string s)
+                             ,name
+                             (,_type_slot_offset ,name ',(if (pair? f) (car f) f)))))))
+                fields)
+         ;; constructor
+         ,@(if make-name
+              (if make-fields
+                (let ((fields (map (lambda (f) (cons (rename f) f)) make-fields)))
+                  `((,_define ,make-name
+                     ,(let lp ((ls fields) (sets '()))
+                        (cond
+                         ((null? ls)
+                          `(,_let ((,_make (,(rename 'make-constructor)
+                                            ,(id->string make-name)
+                                            ,name)))
+                             (,_lambda ,(map car fields)
+                               (,_let ((res (,_make)))
+                                 ,@sets
+                                 res))))
+                         (else
+                          (let ((field (assq (cdar ls) fields)))
+                            (cond
+                             ((and (pair? field) (pair? (cdr field)) (pair? (cddr field)))
+                              (lp (cdr ls)
+                                  (cons (list (car (cddr field)) 'res (cdar ls)) sets)))
+                             (else
+                              (lp (cdr ls)
+                                  (cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(cdar ls)) ,(caar ls)) sets)))))))))))
+                `((,_define ,make-name
+                   (,_let ((,_make (,(rename 'make-constructor)
+                                    ,(id->string make-name)
+                                    ,name)))
+                     (,_lambda args
+                       (,_let ((res (,_make)))
+                         (let lp ((a args)
+                                  (p (,_vector->list (,_rtd-all-field-names ,name))))
+                           (cond
+                            ((null? a)
+                             (if (null? p)
+                                 res
+                                 (error ,(string-append "not enough arguments to " (id->string make-name) ": missing")
+                                        p)))
+                            ((null? p)
+                             (error ,(string-append "too many arguments to " (id->string make-name))
+                                    a))
+                            (else
+                             (,_slot-set! ,name res (,_type_slot_offset ,name (car p)) (car a))
+                             (lp (cdr a) (cdr p)))))))))))
+              '()))))))
diff --git a/lib/srfi/99/records/syntactic.sld b/lib/srfi/99/records/syntactic.sld
new file mode 100644
index 00000000..6a62db99
--- /dev/null
+++ b/lib/srfi/99/records/syntactic.sld
@@ -0,0 +1,5 @@
+
+(define-library (srfi 99 records syntactic)
+  (export define-record-type)
+  (import (chibi) (srfi 99 records inspection))
+  (include "syntactic.scm"))
diff --git a/main.c b/main.c
new file mode 100644
index 00000000..22ff6b86
--- /dev/null
+++ b/main.c
@@ -0,0 +1,672 @@
+/* main.c -- chibi-scheme command-line app                   */
+/* Copyright (c) 2009-2013 Alex Shinn.  All rights reserved. */
+/* BSD-style license: http://synthcode.com/license.txt       */
+
+#include "chibi/eval.h"
+
+#define sexp_argv_symbol "command-line"
+
+#define sexp_import_prefix "(import ("
+#define sexp_import_suffix "))"
+#define sexp_environment_prefix "(environment '("
+#define sexp_environment_suffix "))"
+#define sexp_default_environment "(environment '(scheme small))"
+#define sexp_advice_environment "(load-module '(chibi repl))"
+
+#define sexp_version_string "chibi-scheme "sexp_version" \""sexp_release_name"\" "
+
+#ifdef PLAN9
+#define exit_failure() exits("ERROR")
+#define exit           exits
+#else
+#define exit_failure() exit(70)
+#endif
+#define exit_success() exit(0)
+
+#if SEXP_USE_MAIN_HELP
+void sexp_usage(int err) {
+  printf("usage: chibi-scheme [<options> ...] [<file> <args> ...]\n"
+#if SEXP_USE_FOLD_CASE_SYMS
+         "  -f           - case-fold symbols\n"
+#endif
+         "  -q           - \"quick\" load, use the core -xchibi language\n"
+         "  -Q           - extra \"quick\" load, -xchibi.primitive\n"
+         "  -V           - print version information\n"
+#if ! SEXP_USE_BOEHM
+         "  -h <size>    - specify the initial heap size\n"
+#endif
+#if SEXP_USE_MODULES
+         "  -A <dir>     - append a module search directory\n"
+         "  -I <dir>     - prepend a module search directory\n"
+         "  -m <module>  - import a module\n"
+         "  -x <module>  - import only a module\n"
+#endif
+         "  -e <expr>    - evaluate an expression\n"
+         "  -p <expr>    - evaluate and print an expression\n"
+         "  -r[<main>]   - run a SRFI-22 main\n"
+         "  -R[<module>] - run main from a module\n"
+#if SEXP_USE_IMAGE_LOADING
+         "  -d <file>    - dump an image file and exit\n"
+         "  -i <file>    - load an image file\n"
+#endif
+         );
+  if (err == 0) exit_success();
+  else exit_failure();
+}
+#else
+#define sexp_usage(err) (err ? exit_failure() : exit_success())
+#endif
+
+#if SEXP_USE_PRINT_BACKTRACE_ON_SEGFAULT
+#include <execinfo.h>
+#include <signal.h>
+void sexp_segfault_handler(int sig) {
+  void *array[10];
+  size_t size;
+  // get void*'s for all entries on the stack
+  size = backtrace(array, 10);
+  // print out all the frames to stderr
+  fprintf(stderr, "Error: signal %d:\n", sig);
+  backtrace_symbols_fd(array, size, STDERR_FILENO);
+  exit(1);
+}
+#endif
+
+#if SEXP_USE_IMAGE_LOADING
+
+#include <sys/types.h>
+#include <sys/uio.h>
+#include <unistd.h>
+#include <fcntl.h>
+
+#define SEXP_IMAGE_MAGIC "\a\achibi\n\0"
+#define SEXP_IMAGE_MAJOR_VERSION 1
+#define SEXP_IMAGE_MINOR_VERSION 1
+
+typedef struct sexp_image_header_t* sexp_image_header;
+struct sexp_image_header_t {
+  char magic[8];
+  short major, minor;
+  sexp_abi_identifier_t abi;
+  sexp_uint_t size;
+  sexp_heap base;
+  sexp context;
+};
+
+sexp sexp_gc (sexp ctx, size_t *sum_freed);
+void sexp_offset_heap_pointers (sexp_heap heap, sexp_heap from_heap, sexp* types, sexp flags);
+
+static sexp sexp_load_image (const char* file, sexp_uint_t heap_size, sexp_uint_t heap_max_size) {
+  sexp ctx, flags, *globals, *types;
+  int fd;
+  sexp_sint_t offset;
+  sexp_heap heap;
+  sexp_free_list q;
+  struct sexp_image_header_t header;
+  fd = open(file, O_RDONLY);
+  if (fd < 0) {
+    fprintf(stderr, "can't open image file: %s\n", file);
+    return NULL;
+  }
+  if (read(fd, &header, sizeof(header)) != sizeof(header))
+    return NULL;
+  if (memcmp(header.magic, SEXP_IMAGE_MAGIC, sizeof(header.magic)) != 0) {
+    fprintf(stderr, "invalid image file magic for %s: %s\n", file, header.magic);
+    return NULL;
+  } else if (header.major != SEXP_IMAGE_MAJOR_VERSION
+             || header.major < SEXP_IMAGE_MINOR_VERSION) {
+    fprintf(stderr, "unsupported image version: %d.%d\n",
+            header.major, header.minor);
+    return NULL;
+  } else if (!sexp_abi_compatible(NULL, header.abi, SEXP_ABI_IDENTIFIER)) {
+    fprintf(stderr, "unsupported ABI: %s (expected %s)\n",
+            header.abi, SEXP_ABI_IDENTIFIER);
+    return NULL;
+  }
+  if (heap_size < header.size) heap_size = header.size;
+  heap = (sexp_heap)malloc(sexp_heap_pad_size(heap_size));
+  if (!heap) {
+    fprintf(stderr, "couldn't malloc heap\n");
+    return NULL;
+  }
+  if (read(fd, heap, header.size) != header.size) {
+    fprintf(stderr, "error reading image\n");
+    return NULL;
+  }
+  offset = (sexp_sint_t)((char*)heap - (sexp_sint_t)header.base);
+  /* expand the last free chunk if necessary */
+  if (heap->size < heap_size) {
+    for (q=(sexp_free_list)(((char*)heap->free_list) + offset); q->next;
+         q=(sexp_free_list)(((char*)q->next) + offset))
+      ;
+    if ((char*)q + q->size >= (char*)heap->data + heap->size) {
+      /* last free chunk at end of heap */
+      q->size += heap_size - heap->size;
+    } else {
+      /* last free chunk in the middle of the heap */
+      q->next = (sexp_free_list)((char*)heap->data + heap->size);
+      q = (sexp_free_list)(((char*)q->next) + offset);
+      q->size = heap_size - heap->size;
+      q->next = NULL;
+    }
+    heap->size += (heap_size - heap->size);
+  }
+  ctx = (sexp)(((char*)header.context) + offset);
+  globals = sexp_vector_data((sexp)((char*)sexp_context_globals(ctx) + offset));
+  types = sexp_vector_data((sexp)((char*)(globals[SEXP_G_TYPES]) + offset));
+  flags = sexp_fx_add(SEXP_COPY_LOADP, SEXP_COPY_FREEP);
+  sexp_offset_heap_pointers(heap, header.base, types, flags);
+  close(fd);
+  return ctx;
+}
+
+static int sexp_save_image (sexp ctx, const char* path) {
+  sexp_heap heap;
+  FILE* file;
+  struct sexp_image_header_t header;
+  file = fopen(path, "w");
+  if (!file) {
+    fprintf(stderr, "couldn't open image file for writing: %s\n", path);
+    return 0;
+  }
+  heap = sexp_context_heap(ctx);
+  memcpy(&header.magic, SEXP_IMAGE_MAGIC, sizeof(header.magic));
+  memcpy(&header.abi, SEXP_ABI_IDENTIFIER, sizeof(header.abi));
+  header.major = SEXP_IMAGE_MAJOR_VERSION;
+  header.minor = SEXP_IMAGE_MINOR_VERSION;
+  header.size = heap->size;
+  header.base = heap;
+  header.context = ctx;
+  sexp_gc(ctx, NULL);
+  if (! (fwrite(&header, sizeof(header), 1, file) == 1
+         && fwrite(heap, heap->size, 1, file) == 1)) {
+    fprintf(stderr, "error writing image file\n");
+    return 0;
+  }
+  fclose(file);
+  return 1;
+}
+
+#endif
+
+#if SEXP_USE_GREEN_THREADS
+static void sexp_make_unblocking (sexp ctx, sexp port) {
+  if (!(sexp_portp(port) && sexp_port_fileno(port) >= 0))
+    return;
+  if (sexp_port_flags(port) == SEXP_PORT_UNKNOWN_FLAGS)
+    sexp_port_flags(port) = fcntl(sexp_port_fileno(port), F_GETFL);
+  if (!(sexp_port_flags(port) & O_NONBLOCK))
+    if (fcntl(sexp_port_fileno(port), F_SETFL, sexp_port_flags(port) | O_NONBLOCK) == 0)
+      sexp_port_flags(port) |= O_NONBLOCK;
+}
+#endif
+
+static sexp sexp_meta_env (sexp ctx) {
+  if (sexp_envp(sexp_global(ctx, SEXP_G_META_ENV)))
+    return sexp_global(ctx, SEXP_G_META_ENV);
+  return sexp_context_env(ctx);
+}
+
+static sexp sexp_param_ref (sexp ctx, sexp env, sexp name) {
+  sexp res = sexp_env_ref(ctx, env, name, SEXP_FALSE);
+  return sexp_opcodep(res) ? sexp_parameter_ref(ctx, res) : NULL;
+}
+
+static sexp sexp_load_standard_params (sexp ctx, sexp e) {
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  sexp_load_standard_ports(ctx, e, stdin, stdout, stderr, 0);
+#if SEXP_USE_GREEN_THREADS
+  sexp_make_unblocking(ctx, sexp_param_ref(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL)));
+  sexp_make_unblocking(ctx, sexp_param_ref(ctx, e, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL)));
+  sexp_make_unblocking(ctx, sexp_param_ref(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL)));
+#endif
+  res = sexp_make_env(ctx);
+  sexp_env_parent(res) = e;
+  sexp_context_env(ctx) = res;
+  sexp_set_parameter(ctx, sexp_meta_env(ctx), sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), res);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+static void repl (sexp ctx, sexp env) {
+  sexp_gc_var6(obj, tmp, res, in, out, err);
+  sexp_gc_preserve6(ctx, obj, tmp, res, in, out, err);
+  sexp_context_tracep(ctx) = 1;
+  in  = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL));
+  out = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL));
+  err = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL));
+  if (in == NULL || out == NULL) {
+    fprintf(stderr, "Standard I/O ports not found, aborting.  Maybe a bad -x language?\n");
+    exit_failure();
+  }
+  if (err == NULL) err = out;
+  sexp_port_sourcep(in) = 1;
+  while (1) {
+    sexp_write_string(ctx, "> ", out);
+    sexp_flush(ctx, out);
+    sexp_maybe_block_port(ctx, in, 1);
+    obj = sexp_read(ctx, in);
+    sexp_maybe_unblock_port(ctx, in);
+    if (obj == SEXP_EOF)
+      break;
+    if (sexp_exceptionp(obj)) {
+      sexp_print_exception(ctx, obj, err);
+    } else {
+      sexp_context_top(ctx) = 0;
+      if (!(sexp_idp(obj)||sexp_pairp(obj)||sexp_nullp(obj)))
+        obj = sexp_make_lit(ctx, obj);
+      tmp = sexp_env_bindings(env);
+      res = sexp_eval(ctx, obj, env);
+#if SEXP_USE_WARN_UNDEFS
+      sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, res);
+#endif
+      if (res && sexp_exceptionp(res)) {
+        sexp_print_exception(ctx, res, err);
+        sexp_stack_trace(ctx, err);
+      } else if (res != SEXP_VOID) {
+        sexp_write(ctx, res, out);
+        sexp_write_char(ctx, '\n', out);
+      }
+    }
+  }
+  sexp_gc_release6(ctx);
+}
+
+#if ! SEXP_USE_BOEHM
+static sexp_uint_t multiplier (char c) {
+  switch (sexp_tolower((unsigned char)c)) {
+  case 'k': return 1024;
+  case 'm': return (1024*1024);
+  case 'g': return (1024*1024*1024);
+  default:  return 1;
+  }
+}
+#endif
+
+static char* make_import(const char* prefix, const char* mod, const char* suffix) {
+  int len = strlen(mod) + strlen(prefix) + strlen(suffix);
+  char *p, *impmod = (char*) malloc(len+1);
+  strcpy(impmod, prefix);
+  strcpy(impmod+strlen(prefix), mod);
+  strcpy(impmod+len-+strlen(suffix), suffix);
+  impmod[len] = '\0';
+  for (p=impmod; *p; p++)
+    if (*p == '.') *p=' ';
+  return impmod;
+}
+
+static void check_nonull_arg (int c, char *arg) {
+  if (! arg) {
+    fprintf(stderr, "chibi-scheme: option '%c' requires an argument\n", c);
+    sexp_usage(1);
+  }
+}
+
+static sexp check_exception (sexp ctx, sexp res) {
+  sexp_gc_var4(err, advise, sym, tmp);
+  if (res && sexp_exceptionp(res)) {
+    sexp_gc_preserve4(ctx, err, advise, sym, tmp);
+    tmp = res;
+    err = sexp_current_error_port(ctx);
+    if (! sexp_oportp(err))
+      err = sexp_make_output_port(ctx, stderr, SEXP_FALSE);
+    sexp_print_exception(ctx, res, err);
+    sexp_stack_trace(ctx, err);
+#if SEXP_USE_MAIN_ERROR_ADVISE
+    if (sexp_envp(sexp_global(ctx, SEXP_G_META_ENV))) {
+      advise = sexp_eval_string(ctx, sexp_advice_environment, -1, sexp_global(ctx, SEXP_G_META_ENV));
+      if (sexp_vectorp(advise)) {
+        advise = sexp_vector_ref(advise, SEXP_ONE);
+        if (sexp_envp(advise)) {
+          sym = sexp_intern(ctx, "repl-advise-exception", -1);
+          advise = sexp_env_ref(ctx, advise, sym, SEXP_FALSE);
+          if (sexp_procedurep(advise))
+            sexp_apply(ctx, advise, tmp=sexp_list2(ctx, res, err));
+        }
+      }
+    }
+#endif
+    sexp_gc_release4(ctx);
+    exit_failure();
+  }
+  return res;
+}
+
+static sexp sexp_load_standard_repl_env (sexp ctx, sexp env, sexp k, int bootp) {
+  sexp_gc_var3(e, sym, tmp);
+  sexp_gc_preserve3(ctx, e, sym, tmp);
+  e = sexp_load_standard_env(ctx, env, k);
+  if (!sexp_exceptionp(e)) {
+#if SEXP_USE_MODULES
+    if (!bootp) {
+      e = sexp_eval_string(ctx, sexp_default_environment, -1, sexp_global(ctx, SEXP_G_META_ENV));
+      sym = sexp_intern(ctx, "repl-import", -1);
+      tmp = sexp_env_ref(ctx, sexp_meta_env(ctx), sym, SEXP_VOID);
+      sym = sexp_intern(ctx, "import", -1);
+      sexp_env_define(ctx, e, sym, tmp);
+    }
+#endif
+    if (!sexp_exceptionp(e)) {
+      e = sexp_load_standard_params(ctx, e);
+    }
+  }
+  sexp_gc_release3(ctx);
+  return e;
+}
+
+static void do_init_context (sexp* ctx, sexp* env, sexp_uint_t heap_size,
+                             sexp_uint_t heap_max_size, sexp_sint_t fold_case) {
+  *ctx = sexp_make_eval_context(NULL, NULL, NULL, heap_size, heap_max_size);
+  if (! *ctx) {
+    fprintf(stderr, "chibi-scheme: out of memory\n");
+    exit_failure();
+  }
+#if SEXP_USE_FOLD_CASE_SYMS
+  sexp_global(*ctx, SEXP_G_FOLD_CASE_P) = sexp_make_boolean(fold_case);
+#endif
+  *env = sexp_context_env(*ctx);
+}
+
+#define handle_noarg() if (argv[i][2] != '\0') { \
+    fprintf(stderr, "option %c doesn't take any argument but got: %s\n", argv[i][1], argv[i]); \
+    exit_failure();                                                     \
+  }
+
+#define init_context() if (! ctx) do {                                  \
+      do_init_context(&ctx, &env, heap_size, heap_max_size, fold_case); \
+      sexp_gc_preserve4(ctx, tmp, sym, args, env);                      \
+    } while (0)
+
+#define load_init(bootp) if (! init_loaded++) do {                      \
+      init_context();                                                   \
+      check_exception(ctx, env=sexp_load_standard_repl_env(ctx, env, SEXP_SEVEN, bootp)); \
+    } while (0)
+
+void run_main (int argc, char **argv) {
+#if SEXP_USE_MODULES
+  char *impmod;
+#endif
+  char *arg;
+  const char *prefix=NULL, *suffix=NULL, *main_symbol=NULL, *main_module=NULL;
+  sexp_sint_t i, j, c, quit=0, print=0, init_loaded=0, mods_loaded=0,
+    fold_case=SEXP_DEFAULT_FOLD_CASE_SYMS;
+  sexp_uint_t heap_size=0, heap_max_size=SEXP_MAXIMUM_HEAP_SIZE;
+  sexp out=SEXP_FALSE, ctx=NULL;
+  sexp_gc_var4(tmp, sym, args, env);
+  args = SEXP_NULL;
+  env = NULL;
+
+  /* parse options */
+  for (i=1; i < argc && argv[i][0] == '-'; i++) {
+    switch ((c=argv[i][1])) {
+    case 'e':
+    case 'p':
+      mods_loaded = 1;
+      load_init(0);
+      print = (argv[i][1] == 'p');
+      arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
+      check_nonull_arg('e', arg);
+      tmp = check_exception(ctx, sexp_eval_string(ctx, arg, -1, env));
+      if (print) {
+        if (! sexp_oportp(out))
+          out = sexp_eval_string(ctx, "(current-output-port)", -1, env);
+        sexp_write(ctx, tmp, out);
+        sexp_write_char(ctx, '\n', out);
+      }
+      quit = 1;
+      break;
+    case 'l':
+      mods_loaded = 1;
+      load_init(0);
+      arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
+      check_nonull_arg('l', arg);
+      check_exception(ctx, sexp_load_module_file(ctx, arg, env));
+      break;
+    case 'x':
+      prefix = sexp_environment_prefix;
+      suffix = sexp_environment_suffix;
+    case 'm':
+      arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
+      if (c == 'x') {
+        if (strcmp(arg, "chibi.primitive") == 0) {
+          goto load_primitive;
+        } else if (strcmp(arg, "scheme.small") == 0) {
+          load_init(0);
+          break;
+        }
+      } else {
+        prefix = sexp_import_prefix;
+        suffix = sexp_import_suffix;
+      }
+      mods_loaded = 1;
+      load_init(c == 'x');      /* only load the meta-env if we're */
+                                /* explicitly setting a language   */
+#if SEXP_USE_MODULES
+      check_nonull_arg(c, arg);
+      impmod = make_import(prefix, arg, suffix);
+      tmp = check_exception(ctx, sexp_eval_string(ctx, impmod, -1, (c=='x' ? sexp_global(ctx, SEXP_G_META_ENV) : env)));
+      free(impmod);
+      if (c == 'x') {
+        sexp_set_parameter(ctx, sexp_global(ctx, SEXP_G_META_ENV), sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env);
+        sexp_context_env(ctx) = env = tmp;
+        tmp = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL));
+        if (tmp != NULL && !sexp_oportp(tmp))
+          sexp_load_standard_ports(ctx, env, stdin, stdout, stderr, 0);
+      }
+#endif
+      break;
+    load_primitive:
+    case 'Q':
+      init_context();
+      mods_loaded = 1;
+      if (! init_loaded++)
+        sexp_load_standard_ports(ctx, env, stdin, stdout, stderr, 0);
+      handle_noarg();
+      break;
+    case 'q':
+      argv[i--] = (char*)"-xchibi";
+      break;
+    case 'A':
+      init_context();
+      arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
+      check_nonull_arg('A', arg);
+      sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_TRUE);
+      break;
+    case 'I':
+      init_context();
+      arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
+      check_nonull_arg('I', arg);
+      sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_FALSE);
+      break;
+    case '-':
+      if (argv[i][2] == '\0') {
+        i++;
+        goto done_options;
+      }
+      sexp_usage(1);
+    case 'h':
+      arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
+      check_nonull_arg('h', arg);
+#if ! SEXP_USE_BOEHM
+      heap_size = strtoul(arg, &arg, 0);
+      if (sexp_isalpha((unsigned char)*arg)) heap_size *= multiplier(*arg++);
+      if (*arg == '/') {
+        heap_max_size = strtoul(arg+1, &arg, 0);
+        if (sexp_isalpha((unsigned char)*arg)) heap_max_size *= multiplier(*arg++);
+      }
+#endif
+      break;
+#if SEXP_USE_IMAGE_LOADING
+    case 'i':
+      arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
+      if (ctx) {
+        fprintf(stderr, "-:i <file>: image files must be loaded first\n");
+        exit_failure();
+      }
+      ctx = sexp_load_image(arg, heap_size, heap_max_size);
+      if (!ctx) {
+        fprintf(stderr, "-:i <file>: couldn't open file for reading: %s\n", arg);
+        exit_failure();
+      }
+      env = sexp_load_standard_params(ctx, sexp_context_env(ctx));
+      init_loaded++;
+      break;
+    case 'd':
+      if (! init_loaded++) {
+        init_context();
+        env = sexp_load_standard_env(ctx, env, SEXP_SEVEN);
+      }
+      arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
+      if (!sexp_save_image(ctx, arg))
+        exit_failure();
+      quit = 1;
+      break;
+#endif
+    case 'V':
+      load_init(1);
+      if (! sexp_oportp(out))
+        out = sexp_eval_string(ctx, "(current-output-port)", -1, env);
+      sexp_write_string(ctx, sexp_version_string, out);
+      tmp = sexp_env_ref(ctx, env, sym=sexp_intern(ctx, "*features*", -1), SEXP_NULL);
+      sexp_write(ctx, tmp, out);
+      sexp_newline(ctx, out);
+      return;
+#if SEXP_USE_FOLD_CASE_SYMS
+    case 'f':
+      fold_case = 1;
+      init_context();
+      sexp_global(ctx, SEXP_G_FOLD_CASE_P) = SEXP_TRUE;
+      handle_noarg();
+      break;
+#endif
+    case 'R':
+      main_module = argv[i][2] != '\0' ? argv[i]+2 :
+        (i+1 < argc && argv[i+1][0] != '-') ? argv[++i] : "chibi.repl";
+      if (main_symbol == NULL) main_symbol = "main";
+      break;
+    case 'r':
+      main_symbol = argv[i][2] == '\0' ? "main" : argv[i]+2;
+      break;
+    case 's':
+      init_context(); sexp_global(ctx, SEXP_G_STRICT_P) = SEXP_TRUE;
+      handle_noarg();
+      break;
+    case 't':
+      mods_loaded = 1;
+      load_init(0);
+      arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
+#if SEXP_USE_MODULES
+      suffix = strrchr(arg, '.');
+      sym = sexp_intern(ctx, suffix + 1, -1);
+      *(char*)suffix = '\0';
+      impmod = make_import(sexp_environment_prefix, arg, sexp_environment_suffix);
+      tmp = check_exception(ctx, sexp_eval_string(ctx, impmod, -1, sexp_meta_env(ctx)));
+      free(impmod);
+      sym = sexp_list1(ctx, sexp_env_cell(ctx, tmp, sym, 0));
+      tmp = check_exception(ctx, sexp_eval_string(ctx, "(environment '(chibi trace))", -1, sexp_meta_env(ctx)));
+      tmp = sexp_env_ref(ctx, tmp, sexp_intern(ctx, "trace-cell", -1), 0);
+      check_exception(ctx, sexp_apply(ctx, tmp, sym));
+#endif
+      break;
+    default:
+      fprintf(stderr, "unknown option: %s\n", argv[i]);
+      /* ... FALLTHROUGH ... */
+    case '?':
+      sexp_usage(1);
+    }
+  }
+
+ done_options:
+  if (!quit || main_symbol != NULL) {
+    load_init(0);
+    /* build argument list */
+    if (i < argc)
+      for (j=argc-1; j>=i; j--)
+        args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args);
+    if (i >= argc)
+      args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args);
+    sexp_set_parameter(ctx, sexp_meta_env(ctx), sym=sexp_intern(ctx, sexp_argv_symbol, -1), args);
+    if (i >= argc && main_symbol == NULL) {
+      /* no script or main, run interactively */
+      repl(ctx, env);
+    } else {
+#if SEXP_USE_MODULES
+      /* load the module or script */
+      if (main_module != NULL) {
+        impmod = make_import("(load-module '(", main_module, "))");
+        env = check_exception(ctx, sexp_eval_string(ctx, impmod, -1, sexp_meta_env(ctx)));
+        if (sexp_vectorp(env)) env = sexp_vector_ref(env, SEXP_ONE);
+        free(impmod);
+        check_exception(ctx, env);
+        if (!sexp_envp(env)) {
+          fprintf(stderr, "couldn't find module: %s\n", main_module);
+          exit_failure();
+        }
+      } else
+#endif
+      if (i < argc) {   /* script usage */
+#if SEXP_USE_MODULES
+        /* reset the environment to have only the `import' and */
+        /* `cond-expand' bindings */
+        if (!mods_loaded) {
+          env = sexp_make_env(ctx);
+          sexp_set_parameter(ctx, sexp_meta_env(ctx),
+                             sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env);
+          sexp_context_env(ctx) = env;
+          sym = sexp_intern(ctx, "repl-import", -1);
+          tmp = sexp_env_ref(ctx, sexp_meta_env(ctx), sym, SEXP_VOID);
+          sym = sexp_intern(ctx, "import", -1);
+          check_exception(ctx, sexp_env_define(ctx, env, sym, tmp));
+          sym = sexp_intern(ctx, "cond-expand", -1);
+          tmp = sexp_env_cell(ctx, sexp_meta_env(ctx), sym, 0);
+#if SEXP_USE_RENAME_BINDINGS
+          sexp_env_rename(ctx, env, sym, tmp);
+#endif
+          sexp_env_define(ctx, env, sym, sexp_cdr(tmp));
+        }
+#endif
+        sexp_context_tracep(ctx) = 1;
+        tmp = sexp_env_bindings(env);
+#if SEXP_USE_MODULES
+        /* use scheme load if possible for better stack traces */
+        sym = sexp_intern(ctx, "load", -1);
+        tmp = sexp_env_ref(ctx, sexp_meta_env(ctx), sym, SEXP_FALSE);
+        if (sexp_procedurep(tmp)) {
+          sym = sexp_c_string(ctx, argv[i], -1);
+          sym = sexp_list2(ctx, sym, env);
+          check_exception(ctx, sexp_apply(ctx, tmp, sym));
+        } else
+#endif
+          check_exception(ctx, sexp_load(ctx, sym=sexp_c_string(ctx, argv[i], -1), env));
+#if SEXP_USE_WARN_UNDEFS
+        sexp_warn_undefs(ctx, env, tmp, SEXP_VOID);
+#endif
+      }
+      /* SRFI-22: run main if specified */
+      if (main_symbol) {
+        sym = sexp_intern(ctx, main_symbol, -1);
+        tmp = sexp_env_ref(ctx, env, sym, SEXP_FALSE);
+        if (sexp_procedurep(tmp)) {
+          args = sexp_list1(ctx, args);
+          check_exception(ctx, sexp_apply(ctx, tmp, args));
+        } else {
+          fprintf(stderr, "couldn't find main binding: %s in %s\n", main_symbol, main_module ? main_module : argv[i]);
+        }
+      }
+    }
+  }
+
+  sexp_gc_release4(ctx);
+  sexp_destroy_context(ctx);
+}
+
+int main (int argc, char **argv) {
+#if SEXP_USE_PRINT_BACKTRACE_ON_SEGFAULT
+  signal(SIGSEGV, sexp_segfault_handler); 
+#endif
+  sexp_scheme_init();
+  run_main(argc, argv);
+  exit_success();
+  return 0;
+}
diff --git a/mkfile b/mkfile
new file mode 100644
index 00000000..791f949b
--- /dev/null
+++ b/mkfile
@@ -0,0 +1,109 @@
+</$objtype/mkfile
+
+BIN=/$objtype/bin
+TARG=chibi-scheme
+MODDIR=/sys/lib/chibi-scheme
+
+CHIBI=./$O.out
+GENSTATIC=./tools/chibi-genstatic
+
+CPPFLAGS= -Iinclude -DPLAN9 -DSEXP_USE_GREEN_THREADS=0
+CFLAGS= -p $CPPFLAGS
+CFLAGS_STATIC=$CFLAGS -DSEXP_USE_STATIC_LIBS
+
+OFILES=gc.$O sexp.$O bignum.$O opcodes.$O plan9.$O vm.$O simplify.$O eval.$O main.$O $STATIC
+HFILES=include/chibi/sexp.h include/chibi/eval.h include/chibi/features.h include/chibi/install.h
+CLEANFILES=tests/basic/*.out tests/basic/*.err
+
+EXCLUDE=srfi.18 srfi.27 chibi.filesystem chibi.io \
+	chibi.net chibi.process chibi.stty chibi.system \
+	chibi.time
+
+CHIBI_LIBS = lib/chibi/filesystem.c lib/chibi/process.c \
+	lib/chibi/time.c lib/chibi/system.c lib/chibi/stty.c \
+	lib/chibi/weak.c lib/chibi/heap-stats.c lib/chibi/disasm.c \
+	lib/chibi/net.c
+CHIBI_IO_COMPILED_LIBS = lib/chibi/io/io.c
+CHIBI_OPT_COMPILED_LIBS = lib/chibi/optimize/rest.c \
+	lib/chibi/optimize/profile.c
+COMPILED_LIBS = $CHIBI_COMPILED_LIBS $CHIBI_IO_COMPILED_LIBS \
+	$CHIBI_OPT_COMPILED_LIBS \
+	lib/srfi/33/bit.c lib/srfi/39/param.c \
+	lib/srfi/69/hash.c lib/srfi/95/qsort.c lib/srfi/98/env.c \
+	lib/scheme/time.c
+
+</sys/src/cmd/mkone
+
+clean:
+	rm -f $CLEANFILES
+
+clibs.$O: clibs.c
+
+$TARG: $O.out
+	rm $OFILES
+	mk 'CFLAGS=$CFLAGS_STATIC' clibs.$O $OFILES
+	mk 'CFLAGS=$CFLAGS_STATIC' 'STATIC=clibs.$O' default
+
+target: $O.out
+	mv $O.out $TARG
+
+%.c:   %.stub
+	$CHIBI ./tools/chibi-ffi $stem.stub
+
+include/chibi/install.h: mkfile
+	echo '#define sexp_default_module_path "'$MODDIR'"' > include/chibi/install.h
+	echo '#define sexp_so_extension ".no-such-file"' >> include/chibi/install.h
+	echo '#define sexp_platform "plan9"' >> include/chibi/install.h
+	echo '#define sexp_version "'`{cat VERSION}'"' >> include/chibi/install.h
+	echo '#define sexp_release_name "'`{cat RELEASE}'"' >> include/chibi/install.h
+
+dist-clean: clean
+	rm -f include/chibi/install.h clibs.c
+
+install:V: $BIN/$TARG
+	test -d $MODDIR || mkdir -p $MODDIR
+	{cd lib; tar c .} | {cd $MODDIR ; tar x }
+
+clibs.c:V: $GENSTATIC $CHIBI $COMPILED_LIBS
+	du -a lib | sed 's/^[0-9]*[ 	]*//' | grep '\.sld$' | \
+	$CHIBI $GENSTATIC \
+	-x srfi.27 -x srfi.18 -x chibi.filesystem -x chibi.io \
+	-x chibi.net -x chibi.process -x chibi.stty -x chibi.system \
+	-x chibi.time \
+	> ,clibs.c && mv ,clibs.c clibs.c
+
+test:V:
+	./$O.out -xscheme tests/r5rs-tests.scm
+
+test-threads:
+	./$O.out -xscheme tests/thread-tests.scm
+
+test-numbers:
+	./$O.out -xscheme tests/numeric-tests.scm
+
+test-flonums:
+	./$O.out -xscheme tests/flonum-tests.scm
+
+test-hash:
+	./$O.out -xscheme tests/hash-tests.scm
+
+test-match:
+	./$O.out -xscheme tests/match-tests.scm
+
+test-loop:
+	./$O.out -xscheme tests/loop-tests.scm
+
+test-sort:
+	./$O.out -xscheme tests/sort-tests.scm
+
+test-records:
+	./$O.out -xscheme tests/record-tests.scm
+
+test-weak:
+	./$O.out -xscheme tests/weak-tests.scm
+
+test-unicode:
+	./$O.out -xscheme tests/unicode-tests.scm
+
+test-libs:
+	./$O.out -xscheme tests/lib-tests.scm
diff --git a/opcodes.c b/opcodes.c
new file mode 100644
index 00000000..57e770b2
--- /dev/null
+++ b/opcodes.c
@@ -0,0 +1,277 @@
+
+#include "chibi/eval.h"
+
+#define _I(n) sexp_make_fixnum(n)
+
+#define _OP(c,o,n,m,rt,a1,a2,a3,i,s,d,f) \
+ {c, o, n, m, i, (sexp)s, d, NULL, NULL, rt, a1, a2, a3, NULL, NULL, SEXP_FALSE, f}
+
+#define _GETTER(name, type, index) \
+  {SEXP_OPC_GETTER, SEXP_OP_SLOT_REF, 1, 0, 0, (sexp)name, _I(type), _I(index), NULL, _I(SEXP_OBJECT), _I(type), NULL, NULL, NULL, NULL, SEXP_FALSE, NULL}
+#define _SETTER(name, type, index) \
+  {SEXP_OPC_SETTER, SEXP_OP_SLOT_SET, 2, 0, 0, (sexp)name, _I(type), _I(index), NULL, SEXP_VOID, _I(type), _I(SEXP_OBJECT), NULL, NULL, NULL, SEXP_FALSE, NULL}
+
+#define _PARAM(n, t) \
+  _OP(SEXP_OPC_PARAMETER, SEXP_OP_PARAMETER_REF, 0, 1, t, t, SEXP_FALSE, SEXP_FALSE, 0, n, SEXP_FALSE, 0)
+
+#if SEXP_USE_IMAGE_LOADING
+#define _FN(o,n,m,rt,a1,a2,a3,s,d,f) {SEXP_OPC_FOREIGN, o, n, m, 0, (sexp)s, d, (sexp)#f, NULL, rt, a1, a2, a3, NULL, NULL, SEXP_FALSE, (sexp_proc1)f}
+#else
+#define _FN(o,n,m,rt,a1,a2,a3,s,d,f) _OP(SEXP_OPC_FOREIGN, o, n, m, rt, a1, a2, a3, 0, s, d, (sexp_proc1)f)
+#endif
+
+#define _FN0(rt, s, d, f) _FN(SEXP_OP_FCALL0, 0, 0, rt, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, s, d, f)
+#define _FN1(rt, a1, s, d, f) _FN(SEXP_OP_FCALL1, 1, 0, rt, a1, SEXP_FALSE, SEXP_FALSE, s, d, f)
+#define _FN1OPT(rt, a1, s, d, f) _FN(SEXP_OP_FCALL1, 0, 1, rt, a1, SEXP_FALSE, SEXP_FALSE, s, d, f)
+#define _FN1OPTP(rt, a1, s, d, f) _FN(SEXP_OP_FCALL1, 0, 3, rt, a1, SEXP_FALSE, SEXP_FALSE, s, d, f)
+#define _FN2(rt, a1, a2, s, d, f) _FN(SEXP_OP_FCALL2, 2, 0, rt, a1, a2, SEXP_FALSE, s, d, f)
+#define _FN2OPT(rt, a1, a2, s, d, f) _FN(SEXP_OP_FCALL2, 1, 1, rt, a1, a2, SEXP_FALSE, s, d, f)
+#define _FN2OPTP(rt, a1, a2, s, d, f) _FN(SEXP_OP_FCALL2, 1, 3, rt, a1, a2, SEXP_FALSE, s, d, f)
+#define _FN3(rt, a1, a2, a3, s, d, f) _FN(SEXP_OP_FCALL3, 3, 0, rt, a1, a2, a3, s, d, f)
+#define _FN3OPT(rt, a1, a2, a3, s, d, f) _FN(SEXP_OP_FCALL3, 2, 1, rt, a1, a2, a3, s, d, f)
+#define _FN4(rt, a1, a2, a3, s, d, f) _FN(SEXP_OP_FCALL4, 4, 0, rt, a1, a2, a3, s, d, f)
+#define _FN5(rt, a1, a2, a3, s, d, f) _FN(SEXP_OP_FCALLN, 5, 0, rt, a1, a2, a3, s, d, f)
+
+static struct sexp_opcode_struct opcodes[] = {
+_PARAM("current-input-port", _I(SEXP_IPORT)),
+_PARAM("current-output-port", _I(SEXP_OPORT)),
+_PARAM("current-error-port", _I(SEXP_OPORT)),
+_PARAM("current-exception-handler", _I(SEXP_PROCEDURE)),
+_PARAM("interaction-environment", _I(SEXP_ENV)),
+_PARAM("command-line", SEXP_NULL),
+_OP(SEXP_OPC_GETTER, SEXP_OP_CAR, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PAIR), SEXP_FALSE, SEXP_FALSE, 0, "car", 0, NULL),
+_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CAR, 2, 0, SEXP_VOID, _I(SEXP_PAIR), _I(SEXP_OBJECT), SEXP_FALSE, 0, "set-car!", 0, NULL),
+_OP(SEXP_OPC_GETTER, SEXP_OP_CDR, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PAIR), SEXP_FALSE, SEXP_FALSE, 0, "cdr", 0, NULL),
+_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CDR, 2, 0, SEXP_VOID, _I(SEXP_PAIR), _I(SEXP_OBJECT), SEXP_FALSE, 0, "set-cdr!", 0, NULL),
+_GETTER("pair-source", SEXP_PAIR, 2),
+_SETTER("pair-source-set!", SEXP_PAIR, 2),
+_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_REF, 2, 0, _I(SEXP_OBJECT), _I(SEXP_VECTOR), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"vector-ref", 0, NULL),
+_OP(SEXP_OPC_SETTER, SEXP_OP_VECTOR_SET, 3, 0, SEXP_VOID, _I(SEXP_VECTOR), _I(SEXP_FIXNUM), _I(SEXP_OBJECT), 0,"vector-set!", 0, NULL),
+_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_VECTOR), SEXP_FALSE, SEXP_FALSE, 0,"vector-length", 0, NULL),
+_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_REF, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_BYTES), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"bytevector-u8-ref", 0, NULL),
+_OP(SEXP_OPC_SETTER, SEXP_OP_BYTES_SET, 3, 0, SEXP_VOID, _I(SEXP_BYTES), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), 0,"bytevector-u8-set!", 0, NULL),
+_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_BYTES), SEXP_FALSE, SEXP_FALSE, 0,"bytevector-length", 0, NULL),
+#if SEXP_USE_UTF8_STRINGS
+_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF, 2, 0, _I(SEXP_CHAR), _I(SEXP_STRING), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"string-cursor-ref", 0, NULL),
+_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_CURSOR_NEXT, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_STRING), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"string-cursor-next", 0, NULL),
+_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_CURSOR_PREV, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_STRING), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"string-cursor-prev", 0, NULL),
+_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_SIZE, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_STRING), SEXP_FALSE, SEXP_FALSE, 0,"string-size", 0, NULL),
+#else
+_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF, 2, 0, _I(SEXP_CHAR), _I(SEXP_STRING), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"string-ref", 0, NULL),
+#endif
+#if SEXP_USE_MUTABLE_STRINGS
+#if SEXP_USE_UTF8_STRINGS
+_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET, 3, 0, SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), 0,"string-cursor-set!", 0, NULL),
+#else
+_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET, 3, 0, SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), 0,"string-set!", 0, NULL),
+#endif
+#endif
+_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_STRING), SEXP_FALSE, SEXP_FALSE, 0,"string-length", 0, NULL),
+_FN1(_I(SEXP_FLONUM), _I(SEXP_FIXNUM), "exact->inexact", 0, sexp_exact_to_inexact),
+_FN1(_I(SEXP_FIXNUM), _I(SEXP_FLONUM), "inexact->exact", 0, sexp_inexact_to_exact),
+#if SEXP_USE_NATIVE_X86
+_FN1(_I(SEXP_CHAR), _I(SEXP_CHAR), "char-upcase", 0, sexp_char_upcase),
+_FN1(_I(SEXP_CHAR), _I(SEXP_CHAR), "char-downcase", 0, sexp_char_downcase),
+#else
+_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_UPCASE, 1, 0, _I(SEXP_CHAR), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char-upcase", 0, NULL),
+_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_DOWNCASE, 1, 0, _I(SEXP_CHAR), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char-downcase", 0, NULL),
+#endif
+_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char->integer", 0, NULL),
+_OP(SEXP_OPC_GENERIC, SEXP_OP_INT2CHAR, 1, 0, _I(SEXP_CHAR), _I(SEXP_FIXNUM), SEXP_FALSE, SEXP_FALSE, 0, "integer->char", 0, NULL),
+_OP(SEXP_OPC_ARITHMETIC,     SEXP_OP_ADD, 0, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "+", SEXP_ZERO, NULL),
+_OP(SEXP_OPC_ARITHMETIC,     SEXP_OP_MUL, 0, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "*", SEXP_ONE, NULL),
+_OP(SEXP_OPC_ARITHMETIC,     SEXP_OP_SUB, 1, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, "-", SEXP_ZERO, NULL),
+_OP(SEXP_OPC_ARITHMETIC,     SEXP_OP_DIV, 1, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, "/", SEXP_ONE, NULL),
+_OP(SEXP_OPC_ARITHMETIC,     SEXP_OP_QUOTIENT, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), SEXP_FALSE, 0, "quotient", 0, NULL),
+_OP(SEXP_OPC_ARITHMETIC,     SEXP_OP_REMAINDER, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), SEXP_FALSE, 0, "remainder", 0, NULL),
+_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT,  2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "<", 0, NULL),
+_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE,  2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "<=", 0, NULL),
+_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT,  2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, ">", 0, NULL),
+_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE,  2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, ">=", 0, NULL),
+_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_EQN, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "=", 0, NULL),
+_OP(SEXP_OPC_PREDICATE,      SEXP_OP_EQ,  2, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, 0, "eq?", 0, NULL),
+_OP(SEXP_OPC_CONSTRUCTOR,    SEXP_OP_CONS, 2, 0, _I(SEXP_PAIR), _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, 0, "cons", 0, NULL),
+_OP(SEXP_OPC_CONSTRUCTOR,    SEXP_OP_MAKE_VECTOR, 1, 1, _I(SEXP_VECTOR), _I(SEXP_FIXNUM), _I(SEXP_OBJECT), SEXP_FALSE, 0, "make-vector", SEXP_VOID, NULL),
+_OP(SEXP_OPC_CONSTRUCTOR,    SEXP_OP_MAKE_EXCEPTION, 5, 0, _I(SEXP_EXCEPTION), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), 0, "make-exception", 0, NULL),
+_GETTER("exception-kind", SEXP_EXCEPTION, 0),
+_GETTER("exception-irritants", SEXP_EXCEPTION, 2),
+_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_ISA,  2, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, 0, "is-a?", NULL, 0),
+_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "null?", NULL, 0),
+_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "eof-object?", NULL, 0),
+_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "symbol?", NULL, 0),
+_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_CHARP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "char?", NULL, 0),
+_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_FIXNUMP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "fixnum?", NULL, 0),
+_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "pair?", _I(SEXP_PAIR), 0),
+_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "string?", _I(SEXP_STRING), 0),
+_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "vector?", _I(SEXP_VECTOR), 0),
+_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "bytevector?", _I(SEXP_BYTES), 0),
+_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "fileno?", _I(SEXP_FILENO), 0),
+_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "exception?", _I(SEXP_EXCEPTION), 0),
+#if SEXP_USE_IMMEDIATE_FLONUMS
+_FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "flonum?", 0, sexp_flonump_op),
+#else
+_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "flonum?", _I(SEXP_FLONUM), 0),
+#endif
+_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "bignum?", _I(SEXP_BIGNUM), 0),
+#if SEXP_USE_RATIOS
+_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "ratio?", _I(SEXP_RATIO), 0),
+_FN1(_I(SEXP_FIXNUM), _I(SEXP_RATIO), "ratio-numerator", 0, sexp_ratio_numerator_op),
+_FN1(_I(SEXP_FIXNUM), _I(SEXP_RATIO), "ratio-denominator", 0, sexp_ratio_denominator_op),
+#endif
+#if SEXP_USE_COMPLEX
+_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "%complex?", _I(SEXP_COMPLEX), 0),
+_FN1(_I(SEXP_NUMBER), _I(SEXP_COMPLEX), "complex-real", 0, sexp_complex_real_op),
+_FN1(_I(SEXP_NUMBER), _I(SEXP_COMPLEX), "complex-imag", 0, sexp_complex_imag_op),
+#endif
+_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "closure?", _I(SEXP_PROCEDURE), 0),
+_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "opcode?", _I(SEXP_OPCODE), 0),
+_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "input-port?", _I(SEXP_IPORT), 0),
+_FN1(_I(SEXP_BOOLEAN), _I(SEXP_IPORT), "output-port?", 0, sexp_port_outputp_op),
+_FN1(_I(SEXP_BOOLEAN), _I(SEXP_IPORT), "binary-port?", 0, sexp_port_binaryp_op),
+_FN1(_I(SEXP_BOOLEAN), _I(SEXP_IPORT), "port-open?", 0, sexp_port_openp_op),
+_OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 16, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_NULL, SEXP_FALSE, 0, "apply1", 0, NULL),
+_OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_FALSE, SEXP_FALSE, 0, "%call/cc", 0, NULL),
+_OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "raise", 0, NULL),
+#if SEXP_USE_NATIVE_X86
+_FN2OPTP(SEXP_VOID, _I(SEXP_CHAR), _I(SEXP_OPORT), "write-char", (sexp)"current-output-port", sexp_write_char_op),
+_FN1OPTP(SEXP_VOID, _I(SEXP_IPORT), "read-char", (sexp)"current-input-port", sexp_read_char_op),
+_FN1OPTP(SEXP_VOID, _I(SEXP_IPORT), "peek-char", (sexp)"current-input-port", sexp_peek_char_op),
+_FN5(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), "five", 0, sexp_five),
+#else
+_OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, SEXP_VOID, _I(SEXP_CHAR), _I(SEXP_OPORT), SEXP_FALSE, 0, "write-char", (sexp)"current-output-port", NULL),
+_OP(SEXP_OPC_IO, SEXP_OP_WRITE_STRING, 2, 3, SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_OPORT), 0, "%write-string", (sexp)"current-output-port", NULL),
+_OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "read-char", (sexp)"current-input-port", NULL),
+_OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "peek-char", (sexp)"current-input-port", NULL),
+#endif
+_FN1OPTP(_I(SEXP_BOOLEAN), _I(SEXP_IPORT), "char-ready?", (sexp)"current-input-port", sexp_char_ready_p),
+_FN1OPTP(_I(SEXP_OBJECT), _I(SEXP_IPORT), "read", (sexp)"current-input-port", sexp_read_op),
+_FN2OPTP(SEXP_VOID,_I(SEXP_OBJECT), _I(SEXP_OPORT), "write", (sexp)"current-output-port", sexp_write_op),
+_FN1OPTP(SEXP_VOID, _I(SEXP_OPORT), "flush-output", (sexp)"current-output-port", sexp_flush_output_op),
+_FN2(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), "equal?", 0, sexp_equalp_op),
+_FN4(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), "equal?/bounded", 0, sexp_equalp_bound),
+_FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "list?", 0, sexp_listp_op),
+_FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "identifier?", 0, sexp_identifierp_op),
+_FN1(_I(SEXP_SYMBOL), _I(SEXP_OBJECT), "identifier->symbol", 0, sexp_syntactic_closure_expr_op),
+_FN4(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_ENV), _I(SEXP_OBJECT), "identifier=?", 0, sexp_identifier_eq_op),
+_FN1(_I(SEXP_FIXNUM), SEXP_NULL, "length*", 0, sexp_length_op),
+_FN1(SEXP_NULL, SEXP_NULL, "reverse", 0, sexp_reverse_op),
+_FN1(SEXP_NULL, SEXP_NULL, "reverse!", 0, sexp_nreverse_op),
+_FN2(SEXP_NULL, SEXP_NULL, SEXP_NULL, "append2", 0, sexp_append2_op),
+_FN1(_I(SEXP_VECTOR), SEXP_NULL, "list->vector", 0, sexp_list_to_vector_op),
+_FN1(_I(SEXP_IPORT), _I(SEXP_STRING), "open-input-file", 0, sexp_open_input_file_op),
+_FN1(_I(SEXP_OPORT), _I(SEXP_STRING), "open-output-file", 0, sexp_open_output_file_op),
+_FN1(_I(SEXP_IPORT), _I(SEXP_STRING), "open-binary-input-file", 0, sexp_open_binary_input_file),
+_FN1(_I(SEXP_OPORT), _I(SEXP_STRING), "open-binary-output-file", 0, sexp_open_binary_output_file),
+_FN1(SEXP_VOID, _I(SEXP_IPORT), "close-input-port", 0, sexp_close_port_op),
+_FN1(SEXP_VOID, _I(SEXP_OPORT), "close-output-port", 0, sexp_close_port_op),
+_FN0(_I(SEXP_ENV), "make-environment", 0, sexp_make_env_op),
+_FN1(_I(SEXP_ENV), _I(SEXP_ENV), "env-parent", 0, sexp_env_parent_op),
+_FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "null-environment", 0, sexp_make_null_env_op),
+_FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "primitive-environment", 0, sexp_make_primitive_env_op),
+_FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "scheme-report-environment", 0, sexp_make_standard_env_op),
+_FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_ENV), "compile", (sexp)"interaction-environment", sexp_compile_op),
+_FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_ENV), "generate", (sexp)"interaction-environment", sexp_generate_op),
+_FN2OPTP(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_ENV), "%load", (sexp)"interaction-environment", sexp_load_op),
+_FN4(SEXP_VOID, _I(SEXP_ENV), _I(SEXP_ENV), _I(SEXP_OBJECT), "%import", 0, sexp_env_import_op),
+_FN2OPTP(SEXP_VOID, _I(SEXP_EXCEPTION), _I(SEXP_OPORT), "print-exception", (sexp)"current-error-port", sexp_print_exception_op),
+_FN1OPTP(SEXP_VOID, _I(SEXP_OPORT), "print-stack-trace", (sexp)"current-error-port", sexp_stack_trace_op),
+_FN3OPT(SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), "warn-undefs", SEXP_FALSE, sexp_warn_undefs_op),
+_FN2OPT(_I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), "make-string", sexp_make_character(' '), sexp_make_string_op),
+_FN2OPT(_I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-bytevector", SEXP_ZERO, sexp_make_bytes_op),
+_FN2OPT(_I(SEXP_NUMBER), _I(SEXP_STRING), _I(SEXP_FIXNUM), "string->number", SEXP_TEN, sexp_string_to_number_op),
+_FN3(_I(SEXP_FIXNUM), _I(SEXP_STRING), _I(SEXP_STRING), _I(SEXP_BOOLEAN), "string-cmp", 0, sexp_string_cmp_op),
+_FN1(_I(SEXP_SYMBOL), _I(SEXP_STRING), "string->symbol", 0, sexp_string_to_symbol_op),
+_FN1(_I(SEXP_STRING), _I(SEXP_SYMBOL), "symbol->string", 0, sexp_symbol_to_string_op),
+_FN2OPT(_I(SEXP_STRING), SEXP_NULL, _I(SEXP_STRING), "string-concatenate", SEXP_FALSE, sexp_string_concatenate_op),
+_FN2(_I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_NULL, "memq", 0, sexp_memq_op),
+_FN2(_I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_NULL, "assq", 0, sexp_assq_op),
+_FN3(_I(SEXP_SYNCLO), _I(SEXP_ENV), SEXP_NULL, _I(SEXP_OBJECT), "make-syntactic-closure", 0, sexp_make_synclo_op),
+_FN1(_I(SEXP_OBJECT), _I(SEXP_OBJECT), "strip-syntactic-closures", 0, sexp_strip_synclos),
+_FN0(_I(SEXP_OPORT), "open-output-string", 0, sexp_open_output_string_op),
+_FN1(_I(SEXP_IPORT), _I(SEXP_STRING), "open-input-string", 0, sexp_open_input_string_op),
+_FN1(_I(SEXP_STRING), _I(SEXP_OPORT), "get-output-string", 0, sexp_get_output_string_op),
+_FN2OPT(_I(SEXP_IPORT), _I(SEXP_FIXNUM), _I(SEXP_BOOLEAN), "open-input-file-descriptor", SEXP_FALSE, sexp_open_input_file_descriptor),
+_FN2OPT(_I(SEXP_OPORT), _I(SEXP_FIXNUM), _I(SEXP_BOOLEAN), "open-output-file-descriptor", SEXP_FALSE, sexp_open_output_file_descriptor),
+_FN2(_I(SEXP_VOID), _I(SEXP_IPORT), _I(SEXP_FIXNUM), "set-port-line!", 0, sexp_set_port_line_op),
+_FN2OPT(_I(SEXP_OBJECT), _I(SEXP_PROCEDURE), _I(SEXP_FIXNUM), "register-optimization!", _I(600), sexp_register_optimization),
+#if SEXP_USE_MATH
+_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "exp", 0, sexp_exp),
+_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "ln", 0, sexp_log),
+_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "sin", 0, sexp_sin),
+_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "cos", 0, sexp_cos),
+_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "tan", 0, sexp_tan),
+_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "asin", 0, sexp_asin),
+_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "acos", 0, sexp_acos),
+_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "atan1", 0, sexp_atan),
+_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "sqrt", 0, sexp_sqrt),
+_FN1(_I(SEXP_PAIR), _I(SEXP_NUMBER), "exact-sqrt", 0, sexp_exact_sqrt),
+_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "round", 0, sexp_round),
+_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "truncate", 0, sexp_trunc),
+_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "floor", 0, sexp_floor),
+_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "ceiling", 0, sexp_ceiling),
+#endif
+_FN2(_I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), "expt", 0, sexp_expt_op),
+#if SEXP_USE_UTF8_STRINGS
+_FN2(_I(SEXP_FIXNUM), _I(SEXP_STRING), _I(SEXP_FIXNUM), "string-index->offset", 0, sexp_string_index_to_offset),
+_FN2(_I(SEXP_FIXNUM), _I(SEXP_STRING), _I(SEXP_FIXNUM), "string-offset->index", 0, sexp_string_offset_to_index),
+_FN2(_I(SEXP_CHAR), _I(SEXP_STRING), _I(SEXP_FIXNUM), "string-ref", 0, sexp_string_utf8_index_ref),
+#if SEXP_USE_MUTABLE_STRINGS
+_FN3(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), "string-set!", 0, sexp_string_utf8_index_set),
+#endif
+_FN3OPT(_I(SEXP_STRING), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "substring-cursor", SEXP_FALSE, sexp_substring_op),
+_FN3OPT(_I(SEXP_STRING), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "substring", SEXP_FALSE, sexp_utf8_substring_op),
+#else
+_FN3OPT(_I(SEXP_STRING), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "substring", SEXP_FALSE, sexp_substring_op),
+#endif
+_FN3OPT(_I(SEXP_BYTES), _I(SEXP_BYTES), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "subbytes", SEXP_FALSE, sexp_subbytes_op),
+#if SEXP_USE_FOLD_CASE_SYMS
+_FN1(SEXP_VOID, _I(SEXP_IPORT), "port-fold-case?", 0, sexp_get_port_fold_case),
+_FN2(SEXP_VOID, _I(SEXP_IPORT), _I(SEXP_BOOLEAN), "set-port-fold-case!", 0, sexp_set_port_fold_case),
+#endif
+#if SEXP_USE_OBJECT_BRACE_LITERALS
+_FN2(_I(SEXP_TYPE), _I(SEXP_STRING), _I(SEXP_OBJECT), "lookup-type", 0, sexp_lookup_type_op),
+#endif
+#if SEXP_USE_TYPE_DEFS
+_FN3(_I(SEXP_TYPE), _I(SEXP_STRING), _I(SEXP_TYPE), SEXP_NULL, "register-simple-type", 0, sexp_register_simple_type_op),
+_FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-type-predicate", 0, sexp_make_type_predicate_op),
+_FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-constructor", 0, sexp_make_constructor_op),
+_FN3(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-getter", 0, sexp_make_getter_op),
+_FN3(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-setter", 0, sexp_make_setter_op),
+_FN2(_I(SEXP_OPCODE), _I(SEXP_TYPE), _I(SEXP_SYMBOL), "type-slot-offset", 0, sexp_type_slot_offset_op),
+_OP(SEXP_OPC_GETTER, SEXP_OP_SLOTN_REF, 3, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0, "slot-ref", 0, NULL),
+_OP(SEXP_OPC_SETTER, SEXP_OP_SLOTN_SET, 4, 0, SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0,"slot-set!", 0, NULL),
+#endif
+#ifdef PLAN9
+#include "opt/plan9-opcodes.c"
+#else
+_FN1(_I(SEXP_OBJECT), _I(SEXP_IPORT), "port-fileno", 0, sexp_get_port_fileno),
+#endif
+#if SEXP_USE_MODULES
+_FN0(_I(SEXP_ENV), "current-environment", 0, sexp_current_environment),
+_FN1(_I(SEXP_ENV), _I(SEXP_ENV), "set-current-environment!", 0, sexp_set_current_environment),
+_FN0(_I(SEXP_ENV), "%meta-env", 0, sexp_meta_environment),
+_FN1(SEXP_NULL, _I(SEXP_ENV), "env-exports", 0, sexp_env_exports_op),
+_FN1OPT(_I(SEXP_PAIR), _I(SEXP_PAIR), "current-module-path", SEXP_FALSE, sexp_current_module_path_op),
+_FN1(_I(SEXP_STRING), _I(SEXP_STRING), "find-module-file", 0, sexp_find_module_file_op),
+_FN2(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_ENV), "load-module-file", 0, sexp_load_module_file_op),
+_FN2(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_BOOLEAN), "add-module-directory", 0, sexp_add_module_directory_op),
+#endif
+#if SEXP_USE_GREEN_THREADS
+_FN1OPT(_I(SEXP_OBJECT), _I(SEXP_OBJECT), "%dk", SEXP_FALSE, sexp_dk),
+_OP(SEXP_OPC_GENERIC, SEXP_OP_YIELD, 0, 0, SEXP_VOID, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, 0, "yield!", 0, NULL),
+#endif
+_FN0(_I(SEXP_OBJECT), "thread-parameters", 0, sexp_thread_parameters),
+_FN1(_I(SEXP_OBJECT), _I(SEXP_OBJECT), "thread-parameters-set!", 0, sexp_thread_parameters_set),
+#if SEXP_USE_PROFILE_VM
+_FN0(SEXP_VOID, "reset-vm-profile", 0, sexp_reset_vm_profile),
+_FN0(SEXP_VOID, "print-vm-profile", 0, sexp_print_vm_profile),
+#endif
+#if SEXP_USE_AUTO_FORCE
+_OP(SEXP_OPC_GENERIC, SEXP_OP_FORCE, 1, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "force", 0, NULL),
+_FN2(_I(SEXP_PROMISE), _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "promise", 0, sexp_make_promise),
+_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "promise?", _I(SEXP_PROMISE), 0),
+#endif
+_OP(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
+};
+
+struct sexp_opcode_struct* sexp_primitive_opcodes = opcodes;
diff --git a/opt/fcall.c b/opt/fcall.c
new file mode 100644
index 00000000..051c4c76
--- /dev/null
+++ b/opt/fcall.c
@@ -0,0 +1,37 @@
+
+typedef sexp (*sexp_proc8) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp);
+typedef sexp (*sexp_proc9) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp);
+typedef sexp (*sexp_proc10) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp);
+typedef sexp (*sexp_proc11) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp);
+typedef sexp (*sexp_proc12) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp);
+typedef sexp (*sexp_proc13) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp);
+typedef sexp (*sexp_proc14) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp);
+typedef sexp (*sexp_proc15) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp);
+typedef sexp (*sexp_proc16) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp);
+typedef sexp (*sexp_proc17) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp);
+typedef sexp (*sexp_proc18) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp);
+typedef sexp (*sexp_proc19) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp);
+
+#define _A(i) stack[top-i]
+
+sexp sexp_fcall (sexp ctx, sexp self, sexp_sint_t n, sexp f) {
+  sexp *stack = sexp_stack_data(sexp_context_stack(ctx));
+  sexp_sint_t top = sexp_context_top(ctx);
+  switch (n) {
+  case 5: return ((sexp_proc6)sexp_opcode_func(f))(ctx, f, 5, _A(1), _A(2), _A(3), _A(4), _A(5));
+  case 6: return ((sexp_proc7)sexp_opcode_func(f))(ctx, f, 6, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6));
+  case 7: return ((sexp_proc8)sexp_opcode_func(f))(ctx, f, 7, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7));
+  case 8: return ((sexp_proc9)sexp_opcode_func(f))(ctx, f, 8, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8));
+  case 9: return ((sexp_proc10)sexp_opcode_func(f))(ctx, f, 9, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9));
+  case 10: return ((sexp_proc11)sexp_opcode_func(f))(ctx, f, 10, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10));
+  case 11: return ((sexp_proc12)sexp_opcode_func(f))(ctx, f, 11, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11));
+  case 12: return ((sexp_proc13)sexp_opcode_func(f))(ctx, f, 12, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12));
+  case 13: return ((sexp_proc14)sexp_opcode_func(f))(ctx, f, 13, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13));
+  case 14: return ((sexp_proc15)sexp_opcode_func(f))(ctx, f, 14, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14));
+  case 15: return ((sexp_proc16)sexp_opcode_func(f))(ctx, f, 15, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15));
+  case 16: return ((sexp_proc17)sexp_opcode_func(f))(ctx, f, 16, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15), _A(16));
+  case 17: return ((sexp_proc18)sexp_opcode_func(f))(ctx, f, 17, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15), _A(16), _A(17));
+  case 18: return ((sexp_proc19)sexp_opcode_func(f))(ctx, f, 18, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15), _A(16), _A(17), _A(18));
+  default: return sexp_user_exception(ctx, self, "too many FFI arguments", f);
+  }
+}
diff --git a/opt/opcode_names.h b/opt/opcode_names.h
new file mode 100644
index 00000000..a8d13a48
--- /dev/null
+++ b/opt/opcode_names.h
@@ -0,0 +1,24 @@
+
+static const char* sexp_opcode_names_[] =
+  {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL",
+   "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALLN",
+   "JUMP-UNLESS", "JUMP", "PUSH", "RESERVE", "DROP",
+   "GLOBAL-REF", "GLOBAL-KNOWN-REF", "PARAMETER-REF", "STACK-REF",
+   "LOCAL-REF", "LOCAL-SET", "CLOSURE-REF", "CLOSURE-VARS",
+   "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", 
+   "BYTES-REF", "BYTES-SET", "BYTES-LENGTH",
+   "STRING-REF", "STRING-SET", "STRING-LENGTH",
+   "STRING-CURSOR-NEXT", "STRING-CURSOR-PREV", "STRING-SIZE",
+   "MAKE-PROCEDURE", "MAKE-VECTOR",
+   "MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?",
+   "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET",
+   "ISA?", "SLOTN-REF", "SLOTN-SET",
+   "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS",
+   "ADD", "SUB", "MUL", "DIV", "QUOTIENT", "REMAINDER",
+   "LT", "LE", "EQN", "EQ",
+   "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE",
+   "WRITE-CHAR", "WRITE-STRING", "READ-CHAR", "PEEK-CHAR",
+   "YIELD", "FORCE", "RET", "DONE",
+  };
+
+const char** sexp_opcode_names = sexp_opcode_names_;
diff --git a/opt/plan9-opcodes.c b/opt/plan9-opcodes.c
new file mode 100644
index 00000000..d4ef0220
--- /dev/null
+++ b/opt/plan9-opcodes.c
@@ -0,0 +1,19 @@
+_FN0(_I(SEXP_FIXNUM), "random-integer", 0, sexp_rand),
+_FN1(_I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "random-seed", 0, sexp_srand),
+_FN0(_I(SEXP_STRING), "current-directory", 0, sexp_getwd),
+_FN0(_I(SEXP_STRING), "current-user", 0, sexp_getuser),
+_FN0(_I(SEXP_STRING), "system-name", 0, sexp_sysname),
+_FN1(_I(SEXP_FIXNUM), _I(SEXP_IPORT), "port-fileno", 0, sexp_fileno),
+_FN2(_I(SEXP_IPORT), _I(SEXP_FIXNUM), _I(SEXP_STRING), "fileno->port", 0, sexp_fdopen),
+_FN0(_I(SEXP_FIXNUM), "fork", 0, sexp_fork),
+_FN2(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_PAIR), "exec", 0, sexp_exec),
+_FN1(SEXP_VOID, _I(SEXP_STRING), "exits", 0, sexp_exits),
+_FN2(_I(SEXP_FIXNUM), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "dup", 0, sexp_dup),
+_FN0(_I(SEXP_PAIR), "pipe", 0, sexp_pipe),
+_FN1(_I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "sleep", 0, sexp_sleep),
+_FN1(_I(SEXP_STRING), _I(SEXP_STRING), "getenv", 0, sexp_getenv),
+_FN1(_I(SEXP_FIXNUM), _I(SEXP_STRING), "change-directory", 0, sexp_chdir),
+_FN0(_I(SEXP_FIXNUM), "wait", 0, sexp_wait),
+_FN2(_I(SEXP_FIXNUM), _I(SEXP_FIXNUM), _I(SEXP_STRING), "post-note", 0, sexp_postnote),
+_FN4(_I(SEXP_FIXNUM), _I(SEXP_PAIR), _I(SEXP_STRING), _I(SEXP_STRING), "%postmountsrv", 0, sexp_postmountsrv),
+_FN1(_I(SEXP_FIXNUM), _I(SEXP_STRING), "file-exists?", 0, sexp_file_exists_p),
diff --git a/opt/sexp-huff.c b/opt/sexp-huff.c
new file mode 100644
index 00000000..abf6bc9f
--- /dev/null
+++ b/opt/sexp-huff.c
@@ -0,0 +1,128 @@
+ {12, 0x0C00},   /* '\x00' */
+ {15, 0x0000},   /* '\x01' */
+ {15, 0x4000},   /* '\x02' */
+ {15, 0x2000},   /* '\x03' */
+ {15, 0x6000},   /* '\x04' */
+ {15, 0x0800},   /* '\x05' */
+ {15, 0x4800},   /* '\x06' */
+ {15, 0x2800},   /* '\x07' */
+ {15, 0x6800},   /* '\x08' */
+ {15, 0x1800},   /* '\x09' */
+ {15, 0x5800},   /* '\x0a' */
+ {15, 0x3800},   /* '\x0b' */
+ {15, 0x7800},   /* '\x0c' */
+ {15, 0x0100},   /* '\x0d' */
+ {15, 0x4100},   /* '\x0e' */
+ {15, 0x2100},   /* '\x0f' */
+ {15, 0x6100},   /* '\x10' */
+ {15, 0x1100},   /* '\x11' */
+ {15, 0x5100},   /* '\x12' */
+ {15, 0x3100},   /* '\x13' */
+ {15, 0x7100},   /* '\x14' */
+ {15, 0x0900},   /* '\x15' */
+ {15, 0x4900},   /* '\x16' */
+ {15, 0x2900},   /* '\x17' */
+ {15, 0x6900},   /* '\x18' */
+ {15, 0x1900},   /* '\x19' */
+ {15, 0x5900},   /* '\x1a' */
+ {15, 0x3900},   /* '\x1b' */
+ {15, 0x7900},   /* '\x1c' */
+ {15, 0x0500},   /* '\x1d' */
+ {15, 0x4500},   /* '\x1e' */
+ {15, 0x2500},   /* '\x1f' */
+ {15, 0x6500},   /* '\x20' */
+ { 8, 0x0040},   /* '!'   */
+ {15, 0x1500},   /* '"'   */
+ {15, 0x5500},   /* '#'   */
+ {15, 0x3500},   /* '$'   */
+ {15, 0x7500},   /* '%'   */
+ {15, 0x0D00},   /* '&'   */
+ {15, 0x4D00},   /* '\''  */
+ {15, 0x2D00},   /* '('   */
+ {15, 0x6D00},   /* ')'   */
+ {11, 0x0300},   /* '*'   */
+ {10, 0x0180},   /* '+'   */
+ {15, 0x1D00},   /* ','   */
+ { 4, 0x000D},   /* '-'   */
+ {15, 0x5D00},   /* '.'   */
+ {10, 0x0380},   /* '/'   */
+ {15, 0x3D00},   /* '0'   */
+ {15, 0x7D00},   /* '1'   */
+ {14, 0x0080},   /* '2'   */
+ {14, 0x2080},   /* '3'   */
+ {14, 0x1080},   /* '4'   */
+ {14, 0x3080},   /* '5'   */
+ {14, 0x0880},   /* '6'   */
+ {14, 0x2880},   /* '7'   */
+ {14, 0x1880},   /* '8'   */
+ {14, 0x3880},   /* '9'   */
+ {14, 0x0480},   /* ':'   */
+ {14, 0x2480},   /* ';'   */
+ { 7, 0x0050},   /* '<'   */
+ { 7, 0x0042},   /* '='   */
+ { 7, 0x0022},   /* '>'   */
+ { 5, 0x0009},   /* '?'   */
+ {14, 0x1480},   /* '@'   */
+ {14, 0x3480},   /* 'A'   */
+ {14, 0x0C80},   /* 'B'   */
+ {14, 0x2C80},   /* 'C'   */
+ {14, 0x1C80},   /* 'D'   */
+ {14, 0x3C80},   /* 'E'   */
+ {14, 0x0280},   /* 'F'   */
+ {14, 0x2280},   /* 'G'   */
+ {14, 0x1280},   /* 'H'   */
+ {14, 0x3280},   /* 'I'   */
+ {14, 0x0A80},   /* 'J'   */
+ {14, 0x2A80},   /* 'K'   */
+ {14, 0x1A80},   /* 'L'   */
+ {14, 0x3A80},   /* 'M'   */
+ {14, 0x0680},   /* 'N'   */
+ {14, 0x2680},   /* 'O'   */
+ {14, 0x1680},   /* 'P'   */
+ {14, 0x3680},   /* 'Q'   */
+ {14, 0x0E80},   /* 'R'   */
+ {14, 0x2E80},   /* 'S'   */
+ {14, 0x1E80},   /* 'T'   */
+ {14, 0x3E80},   /* 'U'   */
+ {14, 0x0200},   /* 'V'   */
+ {14, 0x2200},   /* 'W'   */
+ {14, 0x1200},   /* 'X'   */
+ {14, 0x3200},   /* 'Y'   */
+ {14, 0x0A00},   /* 'Z'   */
+ {14, 0x2A00},   /* '['   */
+ {14, 0x1A00},   /* '\\'  */
+ {14, 0x3A00},   /* ']'   */
+ {14, 0x0600},   /* '^'   */
+ {14, 0x2600},   /* '_'   */
+ {14, 0x1600},   /* '`'   */
+ { 3, 0x0007},   /* 'a'   */
+ { 7, 0x0020},   /* 'b'   */
+ { 4, 0x0004},   /* 'c'   */
+ { 5, 0x001A},   /* 'd'   */
+ { 4, 0x0006},   /* 'e'   */
+ { 7, 0x0002},   /* 'f'   */
+ { 5, 0x0011},   /* 'g'   */
+ { 6, 0x0012},   /* 'h'   */
+ { 4, 0x000C},   /* 'i'   */
+ {12, 0x0400},   /* 'j'   */
+ { 8, 0x00C0},   /* 'k'   */
+ { 5, 0x0018},   /* 'l'   */
+ { 6, 0x0032},   /* 'm'   */
+ { 4, 0x0005},   /* 'n'   */
+ { 5, 0x000A},   /* 'o'   */
+ { 5, 0x0001},   /* 'p'   */
+ { 7, 0x0070},   /* 'q'   */
+ { 3, 0x0003},   /* 'r'   */
+ { 5, 0x0008},   /* 's'   */
+ { 4, 0x000E},   /* 't'   */
+ { 5, 0x0019},   /* 'u'   */
+ { 7, 0x0062},   /* 'v'   */
+ { 7, 0x0030},   /* 'w'   */
+ { 7, 0x0060},   /* 'x'   */
+ { 7, 0x0010},   /* 'y'   */
+ {11, 0x0700},   /* 'z'   */
+ {14, 0x3600},   /* '{'   */
+ {14, 0x0E00},   /* '|'   */
+ {14, 0x2E00},   /* '}'   */
+ {14, 0x1E00},   /* '~'   */
+ {14, 0x3E00},   /* '\x7f' */
diff --git a/opt/sexp-hufftabdefs.h b/opt/sexp-hufftabdefs.h
new file mode 100644
index 00000000..3bf05f3f
--- /dev/null
+++ b/opt/sexp-hufftabdefs.h
@@ -0,0 +1,7 @@
+
+char _huff_tab1[8], _huff_tab2[8], _huff_tab3[2], _huff_tab4[2],
+  _huff_tab5[4], _huff_tab6[2], _huff_tab7[4], _huff_tab8[4],
+  _huff_tab9[4], _huff_tab10[4], _huff_tab11[4], _huff_tab12[2],
+  _huff_tab13[8], _huff_tab14[2], _huff_tab15[8], _huff_tab16[8],
+  _huff_tab17[8], _huff_tab18[8], _huff_tab19[4], _huff_tab20[8],
+  _huff_tab21[8];
diff --git a/opt/sexp-hufftabs.c b/opt/sexp-hufftabs.c
new file mode 100644
index 00000000..7704184f
--- /dev/null
+++ b/opt/sexp-hufftabs.c
@@ -0,0 +1,92 @@
+/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */
+
+char _huff_tab21[] = {
+  '\x01',  '\x00',  '\x03',  '\x00',  '\x02',  '\x00',  '\x04',  '\x00',
+};
+
+char _huff_tab19[] = {
+  '\x01',     'j',  '\x01',  '\x00',
+};
+
+char _huff_tab20[] = {
+  '\x05',  '\x09',  '\x07',  '\x0b',  '\x06',  '\x0a',  '\x08',  '\x0c',
+};
+
+char _huff_tab18[] = {
+     '2',     ':',     '6',     'B',     '4',     '@',     '8',     'D',
+     '3',     ';',     '7',     'C',     '5',     'A',     '9',     'E',
+};
+
+char _huff_tab17[] = {
+  '\x0d',  '\x1d',  '\x15',     '&',  '\x11',     '"',  '\x19',     ',',
+  '\x0f',  '\x1f',  '\x17',     '(',  '\x13',     '$',  '\x1b',     '0',
+  '\x0e',  '\x1e',  '\x16',    '\'',  '\x12',     '#',  '\x1a',     '.',
+  '\x10',  '\x20',  '\x18',     ')',  '\x14',     '%',  '\x1c',     '1',
+};
+
+char _huff_tab16[] = {
+     'V',     '^',     'Z',     '|',     'X',     '`',    '\\',     '~',
+     'W',     '_',     '[',     '}',     'Y',     '{',     ']',  '\x7f',
+};
+
+char _huff_tab15[] = {
+     'F',     'N',     'J',     'R',     'H',     'P',     'L',     'T',
+     'G',     'O',     'K',     'S',     'I',     'Q',     'M',     'U',
+};
+
+char _huff_tab13[] = {
+  '\x00',  '\x00',  '\x00',     '+',  '\x00',  '\x00',  '\x00',     '/',
+};
+
+char _huff_tab14[] = {
+     '*',     'z',
+};
+
+char _huff_tab11[] = {
+  '\x00',     'b',  '\x00',     'x',
+};
+
+char _huff_tab12[] = {
+     '!',     'k',
+};
+
+char _huff_tab9[] = {
+  '\x00',     's',  '\x00',     'l',
+};
+
+char _huff_tab10[] = {
+     'y',     'w',     '<',     'q',
+};
+
+char _huff_tab8[] = {
+     'p',     '?',     'g',     'u',
+};
+
+char _huff_tab7[] = {
+     'f',     '>',     '=',     'v',
+};
+
+char _huff_tab5[] = {
+  '\x00',     'o',  '\x00',     'd',
+};
+
+char _huff_tab6[] = {
+     'h',     'm',
+};
+
+char _huff_tab4[] = {
+     'c',     'i',
+};
+
+char _huff_tab3[] = {
+     'n',     '-',
+};
+
+char _huff_tab1[] = {
+  '\x00',  '\x00',  '\x00',     'r',  '\x00',  '\x00',  '\x00',     'a',
+};
+
+char _huff_tab2[] = {
+     'e',     't',
+};
+
diff --git a/opt/sexp-unhuff.c b/opt/sexp-unhuff.c
new file mode 100644
index 00000000..fa142e16
--- /dev/null
+++ b/opt/sexp-unhuff.c
@@ -0,0 +1,71 @@
+/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */
+
+res = c & 7;
+c = c >> 3;
+if (res == 0) {
+  res = c & 3;
+  c = c >> 2;
+  if (res == 0) {
+    res = c & 3;
+    c = c >> 2;
+    if (res == 0) {
+      res = c & 7;
+      c = c >> 3;
+      if (res == 0) {
+        res = c & 3;
+        c = c >> 2;
+        if (res == 0) {
+          res = _huff_tab21[c & 7];
+          c = c >> 3;
+        } else if ((res = _huff_tab19[res]) == '\x01') {
+          res = _huff_tab20[c & 7];
+          c = c >> 3;
+        }
+      } else if (res == 1) {
+        res = _huff_tab18[c & 15];
+        c = c >> 4;
+      } else if (res == 2) {
+        res = _huff_tab17[c & 31];
+        c = c >> 5;
+      } else if (res == 4) {
+        res = _huff_tab16[c & 15];
+        c = c >> 4;
+      } else if (res == 5) {
+        res = _huff_tab15[c & 15];
+        c = c >> 4;
+      } else if ((res = _huff_tab13[res]) == '\x00') {
+        res = _huff_tab14[c & 1];
+        c = c >> 1;
+      }
+    } else if ((res = _huff_tab11[res]) == '\x00') {
+      res = _huff_tab12[c & 1];
+      c = c >> 1;
+    }
+  } else if ((res = _huff_tab9[res]) == '\x00') {
+    res = _huff_tab10[c & 3];
+    c = c >> 2;
+  }
+ } else if (res == 1) {
+  res = _huff_tab8[c & 3];
+  c = c >> 2;
+ } else if (res == 2) {
+  res = c & 3;
+  c = c >> 2;
+  if (res == 0) {
+    res = _huff_tab7[c & 3];
+    c = c >> 2;
+  } else if ((res = _huff_tab5[res]) == '\x00') {
+    res = _huff_tab6[c & 1];
+    c = c >> 1;
+  }
+ } else if (res == 4) {
+  res = _huff_tab4[c & 1];
+  c = c >> 1;
+ } else if (res == 5) {
+  res = _huff_tab3[c & 1];
+  c = c >> 1;
+ } else if ((res = _huff_tab1[res]) == '\x00') {
+  res = _huff_tab2[c & 1];
+  c = c >> 1;
+ }
+
diff --git a/plan9.c b/plan9.c
new file mode 100644
index 00000000..3123d9a3
--- /dev/null
+++ b/plan9.c
@@ -0,0 +1,353 @@
+/*  plan9.c -- extended Plan 9 system utils                   */
+/*  Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include "chibi/eval.h"
+
+sexp sexp_rand (sexp ctx, sexp self, sexp_sint_t n) {
+  return sexp_make_fixnum(rand());
+}
+
+sexp sexp_srand (sexp ctx, sexp self, sexp_sint_t n, sexp seed) {
+  srand(sexp_unbox_fixnum(seed));
+  return SEXP_VOID;
+}
+
+sexp sexp_file_exists_p (sexp ctx, sexp self, sexp_sint_t n, sexp path) {
+  int res;
+  uchar statbuf[STATMAX];
+  if (! sexp_stringp(path))
+    return sexp_type_exception(ctx, self, SEXP_STRING, path);
+  res = stat(sexp_string_data(path), statbuf, sizeof(statbuf));
+  return (res < 0) ? SEXP_FALSE : SEXP_TRUE;
+}
+
+sexp sexp_fdopen (sexp ctx, sexp self, sexp_sint_t n, sexp fd, sexp mode) {
+  FILE *f;
+  if (! sexp_integerp(fd))
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, fd);
+  if (! sexp_stringp(mode))
+    return sexp_type_exception(ctx, self, SEXP_STRING, mode);
+  f = fdopen(sexp_unbox_fixnum(fd), sexp_string_data(mode));
+  if (! f)
+    return sexp_user_exception(ctx, SEXP_FALSE, "fdopen failed", fd);
+  /* maybe use fd2path to get the name of the fd */
+  if (sexp_string_data(mode)[0] == 'w')
+    return sexp_make_output_port(ctx, f, SEXP_FALSE);
+  else
+    return sexp_make_input_port(ctx, f, SEXP_FALSE);
+}
+
+sexp sexp_fileno (sexp ctx, sexp self, sexp_sint_t n, sexp port) {
+  if (! sexp_portp(port))
+    return sexp_type_exception(ctx, self, SEXP_IPORT, port);
+  return sexp_make_fixnum(fileno(sexp_port_stream(port)));
+}
+
+sexp sexp_fork (sexp ctx, sexp self, sexp_sint_t n) {
+  return sexp_make_fixnum(fork());
+}
+
+sexp sexp_exec (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp args) {
+  int i, len = sexp_unbox_fixnum(sexp_length(ctx, args));
+  char **argv = malloc((len+1)*sizeof(char*));
+  for (i=0; i<len; i++, args=sexp_cdr(args))
+    argv[i] = sexp_string_data(sexp_car(args));
+  argv[len] = NULL;
+  exec(sexp_string_data(name), argv);
+  return SEXP_VOID;             /* won't really return */
+}
+
+void sexp_exits (sexp ctx, sexp self, sexp_sint_t n, sexp msg) {
+  exits(sexp_string_data(sexp_stringp(msg)
+                         ? msg : sexp_write_to_string(ctx, msg)));
+}
+
+sexp sexp_dup (sexp ctx, sexp self, sexp_sint_t n, sexp oldfd, sexp newfd) {
+  return sexp_make_fixnum(dup(sexp_unbox_fixnum(oldfd),
+                               sexp_unbox_fixnum(newfd)));
+}
+
+sexp sexp_pipe (sexp ctx, sexp self, sexp_sint_t n) {
+  int fds[2];
+  pipe(fds);
+  return sexp_list2(ctx, sexp_make_fixnum(fds[0]), sexp_make_fixnum(fds[1]));
+}
+
+sexp sexp_sleep (sexp ctx, sexp self, sexp_sint_t n, sexp msecs) {
+  if (! sexp_integerp(msecs))
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, msecs);
+  sleep(sexp_unbox_fixnum(msecs));
+  return SEXP_VOID;
+}
+
+sexp sexp_getenv (sexp ctx, sexp self, sexp_sint_t n, sexp name) {
+  char *value;
+  if (! sexp_stringp(name))
+    return sexp_type_exception(ctx, self, SEXP_STRING, name);
+  value = getenv(sexp_string_data(name));
+  return ((! value) ? SEXP_FALSE : sexp_c_string(ctx, value, -1));
+}
+
+sexp sexp_getwd (sexp ctx, sexp self, sexp_sint_t n) {
+  char buf[512];
+  getwd(buf, 512);
+  return sexp_c_string(ctx, buf, -1);
+}
+
+sexp sexp_chdir (sexp ctx, sexp self, sexp_sint_t n, sexp path) {
+  if (! sexp_stringp(path))
+    return sexp_type_exception(ctx, self, SEXP_STRING, path);
+  chdir(sexp_string_data(path));
+  return SEXP_VOID;
+}
+
+sexp sexp_getuser (sexp ctx, sexp self, sexp_sint_t n) {
+  return sexp_c_string(ctx, getuser(), -1);
+}
+
+sexp sexp_sysname (sexp ctx, sexp self, sexp_sint_t n) {
+  return sexp_c_string(ctx, sysname(), -1);
+}
+
+sexp sexp_wait (sexp ctx, sexp self, sexp_sint_t n) { /* just return (pid msg) */
+  Waitmsg *wmsg;
+  sexp res;
+  sexp_gc_var(msg, s_msg);
+  sexp_gc_preserve(ctx, msg, s_msg);
+  wmsg = wait();
+  msg = sexp_c_string(ctx, wmsg->msg, -1);
+  res = sexp_list2(ctx, sexp_make_fixnum(wmsg->pid), msg);
+  sexp_gc_release(ctx, msg, s_msg);
+  return res;
+}
+
+sexp sexp_postnote (sexp ctx, sexp self, sexp_sint_t n, sexp pid, sexp note) {
+  if (! sexp_integerp(pid))
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, pid);
+  if (! sexp_stringp(note))
+    return sexp_type_exception(ctx, self, SEXP_STRING, note);
+  postnote(PNPROC, sexp_unbox_fixnum(pid), sexp_string_data(note));
+  return SEXP_VOID;
+}
+
+/**********************************************************************/
+/* 9p interface */
+
+typedef struct sexp_plan9_srv {
+  sexp context, auth, attach, walk, walk1, clone, open, create, remove,
+    read, write, stat, wstat, flush, destroyfid, destroyreq, end;
+} *sexp_plan9_srv;
+
+void sexp_build_srv (sexp ctx, sexp_plan9_srv s, sexp ls) {
+  s->context = ctx;
+  s->auth = s->attach = s->walk = s->walk1 = s->clone = s->open
+    = s->create = s->remove = s->read = s->write = s->stat = s->wstat
+    = s->flush = s->destroyfid = s->destroyreq = s->end = SEXP_FALSE;
+  for ( ; sexp_pairp(ls) && sexp_pairp(sexp_cdr(ls)); ls=sexp_cddr(ls)) {
+    if (sexp_car(ls) == sexp_intern(ctx, "auth:", -1)) {
+      s->auth = sexp_cadr(ls);
+    } else if (sexp_car(ls) == sexp_intern(ctx, "attach:", -1)) {
+      s->attach = sexp_cadr(ls);
+    } else if (sexp_car(ls) == sexp_intern(ctx, "walk:", -1)) {
+      s->walk = sexp_cadr(ls);
+    } else if (sexp_car(ls) == sexp_intern(ctx, "walk1:", -1)) {
+      s->walk1 = sexp_cadr(ls);
+    } else if (sexp_car(ls) == sexp_intern(ctx, "clone:", -1)) {
+      s->clone = sexp_cadr(ls);
+    } else if (sexp_car(ls) == sexp_intern(ctx, "open:", -1)) {
+      s->open = sexp_cadr(ls);
+    } else if (sexp_car(ls) == sexp_intern(ctx, "create:", -1)) {
+      s->create = sexp_cadr(ls);
+    } else if (sexp_car(ls) == sexp_intern(ctx, "remove:", -1)) {
+      s->remove = sexp_cadr(ls);
+    } else if (sexp_car(ls) == sexp_intern(ctx, "read:", -1)) {
+      s->read = sexp_cadr(ls);
+    } else if (sexp_car(ls) == sexp_intern(ctx, "write:", -1)) {
+      s->write = sexp_cadr(ls);
+    } else if (sexp_car(ls) == sexp_intern(ctx, "stat:", -1)) {
+      s->stat = sexp_cadr(ls);
+    } else if (sexp_car(ls) == sexp_intern(ctx, "wstat:", -1)) {
+      s->wstat = sexp_cadr(ls);
+    } else if (sexp_car(ls) == sexp_intern(ctx, "flush:", -1)) {
+      s->flush = sexp_cadr(ls);
+    } else if (sexp_car(ls) == sexp_intern(ctx, "destroyfid:", -1)) {
+      s->destroyfid = sexp_cadr(ls);
+    } else if (sexp_car(ls) == sexp_intern(ctx, "destroyreq:", -1)) {
+      s->destroyreq = sexp_cadr(ls);
+    } else if (sexp_car(ls) == sexp_intern(ctx, "end:", -1)) {
+      s->end = sexp_cadr(ls);
+    }
+  }
+}
+
+void sexp_run_9p_handler (Req *r, sexp handler) {
+  sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux;
+  sexp ctx = s->context;
+  sexp_gc_var(ptr, s_ptr);
+  sexp_gc_var(args, s_args);
+  sexp_gc_preserve(ctx, ptr, s_ptr);
+  sexp_gc_preserve(ctx, args, s_args);
+  ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0);
+  args = sexp_cons(ctx, ptr, SEXP_NULL);
+  sexp_apply(ctx, handler, args);
+  sexp_gc_release(ctx, ptr, s_ptr);
+}
+
+#define sexp_def_9p_handler(name, field)                                \
+  void name (Req *r) {                                                  \
+    sexp_run_9p_handler(r, ((sexp_plan9_srv)r->srv->aux)->field);       \
+  }
+
+sexp_def_9p_handler(sexp_9p_auth, auth)
+sexp_def_9p_handler(sexp_9p_attach, attach)
+sexp_def_9p_handler(sexp_9p_walk, walk)
+sexp_def_9p_handler(sexp_9p_open, open)
+sexp_def_9p_handler(sexp_9p_create, create)
+sexp_def_9p_handler(sexp_9p_remove, remove)
+sexp_def_9p_handler(sexp_9p_read, read)
+sexp_def_9p_handler(sexp_9p_write, write)
+sexp_def_9p_handler(sexp_9p_stat, stat)
+sexp_def_9p_handler(sexp_9p_wstat, wstat)
+sexp_def_9p_handler(sexp_9p_flush, flush)
+
+char* sexp_9p_walk1 (Fid *fid, char *name, Qid *qid) {
+  sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux;
+  sexp res, ctx = s->context;
+  sexp_gc_var(ptr, s_ptr);
+  sexp_gc_var(args, s_args);
+  sexp_gc_preserve(ctx, ptr, s_ptr);
+  sexp_gc_preserve(ctx, args, s_args);
+  ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, qid, SEXP_FALSE, 0);
+  args = sexp_cons(ctx, ptr, SEXP_NULL);
+  ptr = sexp_c_string(ctx, name, -1);
+  args = sexp_cons(ctx, ptr, args);
+  ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0);
+  args = sexp_cons(ctx, ptr, args);
+  res = sexp_apply(ctx, s->walk1, args);
+  sexp_gc_release(ctx, ptr, s_ptr);
+  return sexp_stringp(res) ? sexp_string_data(res) : nil;
+}
+
+char* sexp_9p_clone (Fid *oldfid, Fid *newfid) {
+  sexp_plan9_srv s = (sexp_plan9_srv)oldfid->pool->srv->aux;
+  sexp res, ctx = s->context;
+  sexp_gc_var(ptr, s_ptr);
+  sexp_gc_var(args, s_args);
+  sexp_gc_preserve(ctx, ptr, s_ptr);
+  sexp_gc_preserve(ctx, args, s_args);
+  ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, oldfid, SEXP_FALSE, 0);
+  args = sexp_cons(ctx, ptr, SEXP_NULL);
+  ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, newfid, SEXP_FALSE, 0);
+  args = sexp_cons(ctx, ptr, args);
+  res = sexp_apply(ctx, s->clone, args);
+  sexp_gc_release(ctx, ptr, s_ptr);
+  return sexp_stringp(res) ? sexp_string_data(res) : nil;
+}
+
+void sexp_9p_destroyfid (Fid *fid) {
+  sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux;
+  sexp ctx = s->context;
+  sexp_gc_var(ptr, s_ptr);
+  sexp_gc_var(args, s_args);
+  sexp_gc_preserve(ctx, ptr, s_ptr);
+  sexp_gc_preserve(ctx, args, s_args);
+  ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0);
+  args = sexp_cons(ctx, ptr, SEXP_NULL);
+  sexp_apply(ctx, s->destroyfid, args);
+  sexp_gc_release(ctx, ptr, s_ptr);
+}
+
+void sexp_9p_destroyreq (Req *r) {
+  sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux;
+  sexp ctx = s->context;
+  sexp_gc_var(ptr, s_ptr);
+  sexp_gc_var(args, s_args);
+  sexp_gc_preserve(ctx, ptr, s_ptr);
+  sexp_gc_preserve(ctx, args, s_args);
+  ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0);
+  args = sexp_cons(ctx, ptr, SEXP_NULL);
+  sexp_apply(ctx, s->destroyreq, args);
+  sexp_gc_release(ctx, ptr, s_ptr);
+}
+
+void sexp_9p_end (Srv *srv) {
+  sexp_plan9_srv s = (sexp_plan9_srv)srv->aux;
+  sexp ctx = s->context;
+  sexp_gc_var(ptr, s_ptr);
+  sexp_gc_var(args, s_args);
+  sexp_gc_preserve(ctx, ptr, s_ptr);
+  sexp_gc_preserve(ctx, args, s_args);
+  ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, srv, SEXP_FALSE, 0);
+  args = sexp_cons(ctx, ptr, SEXP_NULL);
+  sexp_apply(ctx, s->end, args);
+  sexp_gc_release(ctx, ptr, s_ptr);
+}
+
+sexp sexp_postmountsrv (sexp ctx, sexp self, sexp_sint_t n, sexp ls, sexp name, sexp mtpt, sexp flags) {
+  Srv s;
+  struct sexp_plan9_srv p9s;
+  if (! sexp_listp(ctx, ls))
+    return sexp_type_exception(ctx, self, SEXP_PAIR, ls);
+  if (! sexp_stringp(name))
+    return sexp_type_exception(ctx, self, SEXP_STRING, name);
+  if (! sexp_stringp(mtpt))
+    return sexp_type_exception(ctx, self, SEXP_STRING, mtpt);
+  if (! sexp_integerp(flags))
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, flags);
+  sexp_build_srv(ctx, &p9s, ls);
+  s.aux = &p9s;
+  s.auth = &sexp_9p_auth;
+  s.attach = &sexp_9p_attach;
+  s.walk = &sexp_9p_walk;
+  s.walk1 = &sexp_9p_walk1;
+  s.clone = &sexp_9p_clone;
+  s.open = &sexp_9p_open;
+  s.create = &sexp_9p_create;
+  s.remove = &sexp_9p_remove;
+  s.read = &sexp_9p_read;
+  s.write = &sexp_9p_write;
+  s.stat = &sexp_9p_stat;
+  s.wstat = &sexp_9p_wstat;
+  s.flush = &sexp_9p_flush;
+  s.destroyfid = &sexp_9p_destroyfid;
+  s.destroyreq = &sexp_9p_destroyreq;
+  s.end = &sexp_9p_end;
+  postmountsrv(&s, sexp_string_data(name), sexp_string_data(mtpt),
+               sexp_unbox_fixnum(flags));
+  return SEXP_UNDEF;
+}
+
+sexp sexp_9p_req_offset (sexp ctx, sexp self, sexp_sint_t n, sexp req) {
+  return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.offset);
+}
+
+sexp sexp_9p_req_count (sexp ctx, sexp self, sexp_sint_t n, sexp req) {
+  return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.count);
+}
+
+#if 0
+sexp sexp_9p_req_path (sexp ctx, sexp self, sexp_sint_t n, sexp req) {
+  return sexp_c_string(ctx, ((Req*)sexp_cpointer_value(req))->fid->qid.path, -1);
+}
+#endif
+
+sexp sexp_9p_req_fid (sexp ctx, sexp self, sexp_sint_t n, sexp req) {
+  return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->fid, SEXP_FALSE, 0);
+}
+
+sexp sexp_9p_req_newfid (sexp ctx, sexp self, sexp_sint_t n, sexp req) {
+  return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->newfid, SEXP_FALSE, 0);
+}
+
+sexp sexp_9p_respond (sexp ctx, sexp self, sexp_sint_t n, sexp req, sexp err) {
+  char *cerr = sexp_stringp(err) ? sexp_string_data(err) : nil;
+  respond(sexp_cpointer_value(req), cerr);
+  return SEXP_VOID;
+}
+
+sexp sexp_9p_responderror (sexp ctx, sexp self, sexp_sint_t n, sexp req) {
+  responderror(sexp_cpointer_value(req));
+  return SEXP_VOID;
+}
+
diff --git a/sexp.c b/sexp.c
new file mode 100644
index 00000000..f3cbb505
--- /dev/null
+++ b/sexp.c
@@ -0,0 +1,3346 @@
+/*  sexp.c -- standalone sexp library implementation          */
+/*  Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include "chibi/sexp.h"
+
+/* optional huffman-compressed immediate symbols */
+struct sexp_huff_entry {
+  unsigned char len;
+  unsigned short bits;
+};
+
+#if SEXP_USE_HUFF_SYMS
+#include "chibi/sexp-hufftabs.h"
+static struct sexp_huff_entry huff_table[] = {
+#include "chibi/sexp-huff.h"
+};
+#endif
+
+static int sexp_initialized_p = 0;
+
+static const char sexp_separators[] = {
+  /* 1  2  3  4  5  6  7  8  9  a  b  c  d  e  f         */
+  0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 0, 0, /* x0_ */
+  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x1_ */
+  1, 0, 1, 0, 0, 0, 0, 1, 1, 1, 0, 0, 1, 0, 0, 0, /* x2_ */
+  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, /* x3_ */
+  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x4_ */
+  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, /* x5_ */
+  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x6_ */
+  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, /* x7_ */
+};
+
+static int digit_value (int c) {
+  return (((c)<='9') ? ((c) - '0') : ((sexp_tolower(c) - 'a') + 10));
+}
+
+static int hex_digit (int n) {
+  return ((n<=9) ? ('0' + n) : ('a' + n - 10));
+}
+
+static int is_precision_indicator(int c) {
+  return c=='d' || c=='D' || c=='e' || c=='E' || c=='f' || c=='F'
+    || c=='l' || c=='L' || c=='s' || c=='S';
+}
+
+int sexp_is_separator(int c) {
+  return 0<c && c<0x80 && sexp_separators[c];
+}
+
+#if SEXP_USE_GLOBAL_SYMBOLS
+sexp sexp_symbol_table[SEXP_SYMBOL_TABLE_SIZE];
+#endif
+
+#if ! SEXP_USE_UNSAFE_PUSH
+sexp sexp_push_op(sexp ctx, sexp* loc, sexp x) {
+  sexp tmp = sexp_cons(ctx, x, *loc);
+  if (sexp_exceptionp(tmp)) return *loc;
+  *loc = tmp;
+  return tmp;
+}
+#endif
+
+sexp sexp_alloc_tagged_aux(sexp ctx, size_t size, sexp_uint_t tag sexp_current_source_param) {
+#if SEXP_USE_TRACK_ALLOC_BACKTRACE
+  int i;
+  void* trace[SEXP_BACKTRACE_SIZE + 1];
+#endif
+  sexp res = (sexp) sexp_alloc(ctx, size);
+  if (res && ! sexp_exceptionp(res)) {
+    sexp_pointer_tag(res) = tag;
+#if SEXP_USE_TRACK_ALLOC_SOURCE
+    sexp_pointer_source(res) = source;
+#if SEXP_USE_TRACK_ALLOC_BACKTRACE
+    backtrace(trace, SEXP_BACKTRACE_SIZE + 1);
+    for (i=0; i<SEXP_BACKTRACE_SIZE; i++) res->backtrace[i] = trace[i+1];
+#endif
+#endif
+#if SEXP_USE_HEADER_MAGIC
+    sexp_pointer_magic(res) = SEXP_POINTER_MAGIC;
+#endif
+  }
+  return res;
+}
+
+#if SEXP_USE_OBJECT_BRACE_LITERALS
+sexp sexp_write_simple_object (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp writer, sexp out) {
+  sexp t, x;
+  sexp_gc_var1(args);
+  sexp_sint_t i, len, nulls=0;
+  i = sexp_pointer_tag(obj);
+  sexp_write_char(ctx, '{', out);
+  if (i >= sexp_context_num_types(ctx)) {
+    sexp_write_string(ctx, "invalid", out);
+  } else {
+    sexp_gc_preserve1(ctx, args);
+    t = sexp_object_type(ctx, obj);
+    sexp_write_string(ctx, sexp_string_data(sexp_type_name(t)), out);
+    sexp_write_char(ctx, ' ', out);
+    if (sexp_type_id(t) && sexp_truep(sexp_type_id(t))) {
+      sexp_write(ctx, sexp_type_id(t), out);
+    } else {
+      sexp_write_char(ctx, '#', out);
+      sexp_write(ctx, sexp_make_fixnum(sexp_type_tag(t)), out);
+    }
+    len = sexp_type_num_slots_of_object(t, obj);
+    args = sexp_list1(ctx, SEXP_FALSE);
+    for (i=0; i<len; i++) {
+      x = sexp_slot_ref(obj, i);
+      if (x) {
+        if (nulls)
+          while (--nulls) sexp_write_string(ctx, " #<null>", out);
+        sexp_write_char(ctx, ' ', out);
+        if (writer && sexp_applicablep(writer)) {
+          sexp_car(args) = x;
+          x = sexp_apply(ctx, writer, args);
+          if (sexp_exceptionp(x)) sexp_print_exception(ctx, x, out);
+        } else {
+          sexp_write(ctx, sexp_slot_ref(obj, i), out);
+        }
+      } else {
+        nulls++;
+      }
+    }
+    sexp_gc_release1(ctx);
+  }
+  sexp_write_char(ctx, '}', out);
+  return SEXP_VOID;
+}
+#else
+#define sexp_write_simple_object NULL
+#endif
+
+sexp sexp_finalize_fileno (sexp ctx, sexp self, sexp_sint_t n, sexp fileno) {
+  if (sexp_fileno_openp(fileno) && !sexp_fileno_no_closep(fileno)) {
+    sexp_fileno_openp(fileno) = 0;
+    close(sexp_fileno_fd(fileno));
+  }
+  return SEXP_VOID;
+}
+
+sexp sexp_finalize_port (sexp ctx, sexp self, sexp_sint_t n, sexp port) {
+  sexp res = SEXP_VOID;
+  if (sexp_port_openp(port)) {
+    sexp_port_openp(port) = 0;
+    if (sexp_oportp(port)) sexp_flush_forced(ctx, port);
+#ifndef PLAN9
+    if (sexp_filenop(sexp_port_fd(port))
+        && sexp_fileno_openp(sexp_port_fd(port))) {
+      if (sexp_port_shutdownp(port)) {
+        /* shutdown the socket if requested */
+        if (sexp_iportp(port))
+          shutdown(sexp_port_fileno(port), sexp_oportp(port) ? SHUT_RDWR : SHUT_RD);
+        if (sexp_oportp(port))
+          shutdown(sexp_port_fileno(port), SHUT_WR);
+      }
+      if (!sexp_port_no_closep(port)) {
+        if (--sexp_fileno_count(sexp_port_fd(port)) == 0)
+          sexp_finalize_fileno(ctx, self, n, sexp_port_fd(port));
+      }
+    }
+#endif
+    if (sexp_port_stream(port) && ! sexp_port_no_closep(port))
+      /* close the stream */
+      fclose(sexp_port_stream(port));
+      /* free the buffer if allocated */
+    if (sexp_port_buf(port) && sexp_oportp(port)
+        /* output string ports have list cookies */
+        && (sexp_nullp(sexp_port_cookie(port)) || sexp_pairp(sexp_port_cookie(port)))
+#if !SEXP_USE_STRING_STREAMS
+        && !sexp_port_customp(port)
+#endif
+        )
+      free(sexp_port_buf(port));
+    sexp_port_offset(port) = 0;
+    sexp_port_size(port) = 0;
+  }
+  return res;
+}
+
+#if SEXP_USE_DL
+sexp sexp_finalize_dl (sexp ctx, sexp self, sexp_sint_t n, sexp dl) {
+  dlclose(sexp_dl_handle(dl));
+  return SEXP_VOID;
+}
+#endif
+
+static struct sexp_type_struct _sexp_type_specs[] = {
+  {SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Object", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+  {SEXP_TYPE, sexp_offsetof(type, name), 7+SEXP_USE_DL, 7+SEXP_USE_DL, 0, 0, sexp_sizeof(type), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Type", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+  {SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Integer", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+  {SEXP_NUMBER, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Number", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+  {SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Char", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+  {SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Boolean", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+  {SEXP_PAIR, sexp_offsetof(pair, car), 2, 3, 0, 0, sexp_sizeof(pair), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Pair", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+  {SEXP_SYMBOL, 0, 0, 0, 0, 0, sexp_sizeof(symbol)+1, sexp_offsetof(symbol, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Symbol", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+  {SEXP_BYTES, 0, 0, 0, 0, 0, sexp_sizeof(bytes)+1, sexp_offsetof(bytes, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Byte-Vector", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+#if SEXP_USE_PACKED_STRINGS
+  {SEXP_STRING, 0, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"String", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+#else
+  {SEXP_STRING, sexp_offsetof(string, bytes), 1, 1, 0, 0, sexp_sizeof(string), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"String", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+#endif
+  {SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), 0, 0, 0, 0, 0, 0, (sexp)"Vector", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+  {SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Flonum", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+  {SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp_uint_t), 0, 0, 0, 0, 0, 0, (sexp)"Bignum", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+#if SEXP_USE_RATIOS
+  {SEXP_RATIO, sexp_offsetof(ratio, numerator), 2, 2, 0, 0, sexp_sizeof(ratio), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Ratio", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+#endif
+#if SEXP_USE_COMPLEX
+  {SEXP_COMPLEX, sexp_offsetof(complex, real), 2, 2, 0, 0, sexp_sizeof(complex), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Complex", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+#endif
+  {SEXP_IPORT, sexp_offsetof(port, name), 3, 3, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Input-Port", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, SEXP_FINALIZE_PORT},
+  {SEXP_OPORT, sexp_offsetof(port, name), 3, 3, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Output-Port", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, SEXP_FINALIZE_PORT},
+  {SEXP_FILENO, 0, 0, 0, 0, 0, sexp_sizeof(fileno), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"File-Descriptor", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, SEXP_FINALIZE_FILENO},
+  {SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Exception", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL},
+  {SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Procedure", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+  {SEXP_MACRO, sexp_offsetof(macro, proc), 3, 3, 0, 0, sexp_sizeof(macro), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Macro", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+  {SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 3, 0, 0, sexp_sizeof(synclo), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Syntactic-Closure", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL},
+  {SEXP_ENV, sexp_offsetof(env, parent), 3+SEXP_USE_RENAME_BINDINGS, 3+SEXP_USE_RENAME_BINDINGS, 0, 0, sexp_sizeof(env), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Environment", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+  {SEXP_BYTECODE, sexp_offsetof(bytecode, name), 3, 3, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Bytecode", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+  {SEXP_CORE, sexp_offsetof(core, name), 1, 1, 0, 0, sexp_sizeof(core), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Core-Form", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+#if SEXP_USE_DL
+  {SEXP_DL, sexp_offsetof(dl, file), 1, 1, 0, 0, sexp_sizeof(dl), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Dynamic-Library", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, SEXP_FINALIZE_DL},
+#endif
+  {SEXP_OPCODE, sexp_offsetof(opcode, name), 11, 11, 0, 0, sexp_sizeof(opcode), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Opcode", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+  {SEXP_LAMBDA, sexp_offsetof(lambda, name), 11, 11, 0, 0, sexp_sizeof(lambda), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Lambda", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL},
+  {SEXP_CND, sexp_offsetof(cnd, test), 4, 4, 0, 0, sexp_sizeof(cnd), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Conditional", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL},
+  {SEXP_REF, sexp_offsetof(ref, name), 3, 3, 0, 0, sexp_sizeof(ref), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Reference", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL},
+  {SEXP_SET, sexp_offsetof(set, var), 3, 3, 0, 0, sexp_sizeof(set), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Set!", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL},
+  {SEXP_SEQ, sexp_offsetof(seq, ls), 2, 2, 0, 0, sexp_sizeof(seq), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Sequence", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL},
+  {SEXP_LIT, sexp_offsetof(lit, value), 2, 2, 0, 0, sexp_sizeof(lit), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Literal", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL},
+  {SEXP_STACK, sexp_offsetof(stack, data), 1, 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), 0, 0, 0, 0, 0, 0, (sexp)"Stack", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+  {SEXP_CONTEXT, sexp_offsetof(context, stack), 12+SEXP_USE_DL, 12+SEXP_USE_DL, 0, 0, sexp_sizeof(context), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Context", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+  {SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Cpointer", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+#if SEXP_USE_AUTO_FORCE
+  {SEXP_PROMISE, sexp_offsetof(promise, value), 1, 1, 0, 0, sexp_sizeof(promise), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Promise", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+#endif
+#if SEXP_USE_WEAK_REFERENCES
+  {SEXP_EPHEMERON, sexp_offsetof(lit, value), 0, 0, 0, 0, sizeof(sexp), 0, 0, sexp_offsetof(lit, value), 1, 0, 0, 1, 0, (sexp)"Ephemeron", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+#endif
+};
+
+#define SEXP_INIT_NUM_TYPES (SEXP_NUM_CORE_TYPES*2)
+
+#if SEXP_USE_TYPE_DEFS
+
+sexp sexp_register_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name,
+                            sexp parent, sexp slots,
+                            sexp fb, sexp felb, sexp flb, sexp flo, sexp fls,
+                            sexp sb, sexp so, sexp sc, sexp w, sexp wb, sexp wo,
+                            sexp ws, sexp we, sexp p, sexp_proc2 f) {
+  sexp *v1, *v2;
+  sexp_gc_var2(res, type);
+  sexp_uint_t i, len, num_types=sexp_context_num_types(ctx),
+    type_array_size=sexp_context_type_array_size(ctx);
+  sexp_gc_preserve2(ctx, res, type);
+  if (num_types >= SEXP_MAXIMUM_TYPES) {
+    res = sexp_user_exception(ctx, self, "register-type: exceeded maximum type limit", name);
+  } else if (! sexp_stringp(name)) {
+    res = sexp_type_exception(ctx, self, SEXP_STRING, name);
+  } else {
+    if (num_types >= type_array_size) {
+      len = type_array_size*2;
+      if (len > SEXP_MAXIMUM_TYPES) len = SEXP_MAXIMUM_TYPES;
+      res = sexp_make_vector(ctx, sexp_make_fixnum(len), SEXP_VOID);
+      if (sexp_exceptionp(res)) {
+        sexp_gc_release2(ctx);
+        return res;
+      }
+      v1 = sexp_vector_data(res);
+      v2 = sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES));
+      for (i=0; i<num_types; i++)
+        v1[i] = v2[i];
+      sexp_global(ctx, SEXP_G_TYPES) = res;
+    }
+    sexp_type_by_index(ctx, num_types) = sexp_alloc_type(ctx, type, SEXP_TYPE);
+    type = sexp_type_by_index(ctx, num_types);
+    if (!sexp_exceptionp(type)) {
+      sexp_pointer_tag(type) = SEXP_TYPE;
+      sexp_type_tag(type) = num_types;
+      sexp_type_slots(type) = slots;
+      sexp_type_field_base(type) = sexp_unbox_fixnum(fb);
+      sexp_type_field_eq_len_base(type) = sexp_unbox_fixnum(felb);
+      sexp_type_field_len_base(type) = sexp_unbox_fixnum(flb);
+      sexp_type_field_len_off(type) = sexp_unbox_fixnum(flo);
+      sexp_type_field_len_scale(type) = sexp_unbox_fixnum(fls);
+      sexp_type_size_base(type) = sexp_unbox_fixnum(sb);
+      sexp_type_size_off(type) = sexp_unbox_fixnum(so);
+      sexp_type_size_scale(type) = sexp_unbox_fixnum(sc);
+      sexp_type_weak_base(type) = sexp_unbox_fixnum(w);
+      sexp_type_weak_len_base(type) = sexp_unbox_fixnum(wb);
+      sexp_type_weak_len_off(type) = sexp_unbox_fixnum(wo);
+      sexp_type_weak_len_scale(type) = sexp_unbox_fixnum(ws);
+      sexp_type_weak_len_extra(type) = sexp_unbox_fixnum(we);
+      sexp_type_name(type) = name;
+      sexp_type_getters(type) = SEXP_FALSE;
+      sexp_type_setters(type) = SEXP_FALSE;
+      sexp_type_finalize(type) = f;
+      sexp_type_id(type) = SEXP_FALSE;
+#if SEXP_USE_DL
+      if (f) sexp_type_dl(type) = sexp_context_dl(ctx);
+#endif
+      sexp_type_print(type) = p;
+      if (sexp_typep(parent)) {
+        len = sexp_vectorp(sexp_type_cpl(parent)) ? sexp_vector_length(sexp_type_cpl(parent)) : 1;
+        sexp_type_cpl(type) = sexp_make_vector(ctx, sexp_make_fixnum(len+1), SEXP_VOID);
+        if (sexp_vectorp(sexp_type_cpl(parent)))
+          memcpy(sexp_vector_data(sexp_type_cpl(type)),
+                 sexp_vector_data(sexp_type_cpl(parent)),
+                 len * sizeof(sexp));
+        else
+          sexp_vector_data(sexp_type_cpl(type))[len-1] = parent;
+      } else {
+        len = 0;
+        sexp_type_cpl(type) = sexp_make_vector(ctx, SEXP_ONE, SEXP_VOID);
+      }
+      sexp_vector_data(sexp_type_cpl(type))[len] = type;
+      sexp_type_depth(type) = len;
+      sexp_global(ctx, SEXP_G_NUM_TYPES) = sexp_make_fixnum(num_types + 1);
+    }
+    res = type;
+  }
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+sexp sexp_register_simple_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp parent, sexp slots) {
+  short i, num_slots = sexp_unbox_fixnum(sexp_length(ctx, slots));
+  sexp type_size, num_slots_obj, cpl, tmp;
+  if (parent && sexp_typep(parent)) {
+    num_slots += sexp_unbox_fixnum(sexp_length(ctx, sexp_type_slots(parent)));
+    if (sexp_vectorp((cpl = sexp_type_cpl(parent))))
+      for (i=sexp_vector_length(cpl)-1; i>=0; i--) {
+        tmp = sexp_vector_ref(cpl, sexp_make_fixnum(i));
+        num_slots += sexp_unbox_fixnum(sexp_length(ctx, sexp_type_slots(tmp)));
+      }
+  }
+  num_slots_obj = sexp_make_fixnum(num_slots);
+  type_size = sexp_make_fixnum(sexp_sizeof_header + sizeof(sexp)*num_slots);
+  return
+    sexp_register_type(ctx, name, parent, slots,
+                       sexp_make_fixnum(sexp_offsetof_slot0),
+                       num_slots_obj, num_slots_obj, SEXP_ZERO, SEXP_ZERO,
+                       type_size, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO,
+                       SEXP_ZERO, SEXP_ZERO, SEXP_ZERO,
+                       sexp_type_print(sexp_type_by_index(ctx, SEXP_EXCEPTION)),
+                       NULL);
+}
+
+#if SEXP_USE_OBJECT_BRACE_LITERALS
+sexp sexp_lookup_type_op(sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp id) {
+  int i;
+  sexp res;
+  const char* str;
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name);
+  str = sexp_string_data(name);
+  if (sexp_fixnump(id)) {
+    i = sexp_unbox_fixnum(id);
+    if (i < sexp_context_num_types(ctx)
+        && strcmp(str, sexp_string_data(sexp_type_name_by_index(ctx, i))) == 0)
+      return sexp_type_by_index(ctx, i);
+    else
+      return SEXP_FALSE;
+  }
+  for (i=sexp_context_num_types(ctx)-1; i>=0; i--)
+    if (strcmp(str, sexp_string_data(sexp_type_name_by_index(ctx, i))) == 0) {
+      res = sexp_type_by_index(ctx, i);
+      if (sexp_stringp(id)
+          && !(sexp_stringp(sexp_type_id(res))
+               && strcmp(sexp_string_data(id), sexp_string_data(sexp_type_id(res))) == 0))
+        return SEXP_FALSE;
+      return res;
+    }
+  return SEXP_FALSE;
+}
+#endif
+
+sexp sexp_finalize_c_type (sexp ctx, sexp self, sexp_sint_t n, sexp obj) {
+  if (sexp_cpointer_freep(obj))
+    free(sexp_cpointer_value(obj));
+  return SEXP_VOID;
+}
+
+#else
+#define sexp_num_types SEXP_NUM_CORE_TYPES
+#endif
+
+/****************************** contexts ******************************/
+
+void sexp_init_context_globals (sexp ctx) {
+  sexp type, *vec, print=NULL;
+  int i;
+  sexp_context_globals(ctx)
+    = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_G_NUM_GLOBALS), SEXP_VOID);
+#if ! SEXP_USE_GLOBAL_SYMBOLS
+  sexp_global(ctx, SEXP_G_SYMBOLS) = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_SYMBOL_TABLE_SIZE), SEXP_NULL);
+#endif
+  sexp_global(ctx, SEXP_G_STRICT_P) = SEXP_FALSE;
+#if SEXP_USE_FOLD_CASE_SYMS
+  sexp_global(ctx, SEXP_G_FOLD_CASE_P) = sexp_make_boolean(SEXP_DEFAULT_FOLD_CASE_SYMS);
+#endif
+#if ! SEXP_USE_BOEHM
+  sexp_global(ctx, SEXP_G_PRESERVATIVES) = SEXP_NULL;
+#endif
+#if SEXP_USE_WEAK_REFERENCES
+  sexp_global(ctx, SEXP_G_FILE_DESCRIPTORS) = SEXP_FALSE;
+  sexp_global(ctx, SEXP_G_NUM_FILE_DESCRIPTORS) = SEXP_ZERO;
+#endif
+  sexp_global(ctx, SEXP_G_OOM_ERROR) = sexp_user_exception(ctx, SEXP_FALSE, "out of memory", SEXP_NULL);
+  sexp_global(ctx, SEXP_G_OOS_ERROR) = sexp_user_exception(ctx, SEXP_FALSE, "out of stack space", SEXP_NULL);
+  sexp_global(ctx, SEXP_G_ABI_ERROR) = sexp_user_exception(ctx, SEXP_FALSE, "incompatible ABI", SEXP_NULL);
+  sexp_global(ctx, SEXP_G_QUOTE_SYMBOL) = sexp_intern(ctx, "quote", -1);
+  sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL) = sexp_intern(ctx, "quasiquote", -1);
+  sexp_global(ctx, SEXP_G_UNQUOTE_SYMBOL) = sexp_intern(ctx, "unquote", -1);
+  sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL) = sexp_intern(ctx, "unquote-splicing", -1);
+  sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL) = sexp_intern(ctx, "current-input-port", -1);
+  sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL) = sexp_intern(ctx, "current-output-port", -1);
+  sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL) = sexp_intern(ctx, "current-error-port", -1);
+  sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL) = sexp_intern(ctx, "interaction-environment", -1);
+  sexp_global(ctx, SEXP_G_CONTINUABLE_SYMBOL) = sexp_intern(ctx, "continuable", -1);
+  sexp_global(ctx, SEXP_G_EMPTY_VECTOR) = sexp_alloc_type(ctx, vector, SEXP_VECTOR);
+  sexp_vector_length(sexp_global(ctx, SEXP_G_EMPTY_VECTOR)) = 0;
+  sexp_global(ctx, SEXP_G_NUM_TYPES) = sexp_make_fixnum(SEXP_NUM_CORE_TYPES);
+  sexp_global(ctx, SEXP_G_TYPES)
+    = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_INIT_NUM_TYPES), SEXP_VOID);
+  vec = sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES));
+  for (i=0; i<SEXP_NUM_CORE_TYPES; i++) {
+    type = sexp_alloc_type(ctx, type, SEXP_TYPE);
+    memcpy(&(type->value), &(_sexp_type_specs[i]), sizeof(_sexp_type_specs[0]));
+    vec[i] = type;
+    sexp_type_name(type) = sexp_c_string(ctx, (char*)sexp_type_name(type), -1);
+    if (sexp_type_print(type)) {
+      if (print && ((sexp_proc1)sexp_type_print(type) == sexp_opcode_func(print)))
+        sexp_type_print(type) = print;
+      else
+        sexp_type_print(type) = print = sexp_make_foreign(ctx, "sexp_write_simple_object", 3, 0, (sexp_proc1)sexp_type_print(type), NULL);
+    }
+  }
+}
+
+#if ! SEXP_USE_GLOBAL_HEAP
+sexp sexp_bootstrap_context (sexp_uint_t size, sexp_uint_t max_size) {
+  sexp ctx;
+  sexp_heap heap;
+  struct sexp_struct dummy_ctx;
+  if (size < SEXP_MINIMUM_HEAP_SIZE) size = SEXP_INITIAL_HEAP_SIZE;
+  heap = sexp_make_heap(sexp_heap_align(size), sexp_heap_align(max_size));
+  if (!heap) return 0;
+  sexp_pointer_tag(&dummy_ctx) = SEXP_CONTEXT;
+  sexp_context_saves(&dummy_ctx) = NULL;
+  sexp_context_heap(&dummy_ctx) = heap;
+  ctx = sexp_alloc_type(&dummy_ctx, context, SEXP_CONTEXT);
+  if (!ctx || sexp_exceptionp(ctx)) {
+    sexp_free_heap(heap);
+  } else {
+    sexp_context_heap(ctx) = heap;
+  }
+  return ctx;
+}
+#endif
+
+sexp sexp_make_context (sexp ctx, size_t size, size_t max_size) {
+  sexp_gc_var1(res);
+  if (ctx) sexp_gc_preserve1(ctx, res);
+#if ! SEXP_USE_GLOBAL_HEAP
+  if (! ctx) {
+    res = sexp_bootstrap_context(size, max_size);
+    if (!res || sexp_exceptionp(res)) return res;
+  } else
+#endif
+    {
+      res = sexp_alloc_type(ctx, context, SEXP_CONTEXT);
+#if ! SEXP_USE_BOEHM && ! SEXP_USE_MALLOC
+      sexp_context_heap(res) = sexp_context_heap(ctx);
+#endif
+    }
+  if (!res || sexp_exceptionp(res)) return res;
+  sexp_context_parent(res) = ctx;
+  sexp_context_name(res) = sexp_context_specific(res) = SEXP_FALSE;
+  sexp_context_saves(res) = NULL;
+  sexp_context_params(res) = SEXP_NULL;
+  sexp_context_last_fp(res) = 0;
+  sexp_context_tracep(res) = 0;
+  sexp_context_timeoutp(res) = 0;
+  sexp_context_tailp(res) = 1;
+#if SEXP_USE_GREEN_THREADS
+  sexp_context_errorp(res) = 0;
+  sexp_context_event(res) = SEXP_FALSE;
+  sexp_context_refuel(res) = SEXP_DEFAULT_QUANTUM;
+#endif
+#if SEXP_USE_DL
+  sexp_context_dl(res) = ctx ? sexp_context_dl(ctx) : SEXP_FALSE;
+#endif
+  if (ctx) {
+    sexp_context_globals(res) = sexp_context_globals(ctx);
+    sexp_context_dk(res) = sexp_context_dk(ctx);
+    sexp_gc_release1(ctx);
+  } else {
+    sexp_init_context_globals(res);
+  }
+  return res;
+}
+
+#if ! SEXP_USE_GLOBAL_HEAP
+void sexp_destroy_context (sexp ctx) {
+  sexp_heap heap, tmp;
+  size_t sum_freed;
+  if (sexp_context_heap(ctx)) {
+    heap = sexp_context_heap(ctx);
+    sexp_markedp(ctx) = 1;
+    sexp_markedp(sexp_context_globals(ctx)) = 1;
+    sexp_mark(ctx, sexp_global(ctx, SEXP_G_TYPES));
+    sexp_finalize(ctx);
+    sexp_sweep(ctx, &sum_freed);
+    sexp_finalize(ctx);
+    sexp_context_heap(ctx) = NULL;
+    for ( ; heap; heap=tmp) {
+      tmp = heap->next;
+      sexp_free_heap(heap);
+    }
+  }
+}
+#endif
+
+/***************************** exceptions *****************************/
+
+sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants,
+                          sexp procedure, sexp source) {
+  sexp exn = sexp_alloc_type(ctx, exception, SEXP_EXCEPTION);
+  sexp_exception_kind(exn) = kind;
+  sexp_exception_message(exn) = message;
+  sexp_exception_irritants(exn) = irritants;
+  sexp_exception_procedure(exn) = procedure;
+  sexp_exception_source(exn) = source;
+  return exn;
+}
+
+sexp sexp_string_cat3 (sexp ctx, const char *pre, const char *mid, const char* suf) {
+  int plen=strlen(pre), mlen=strlen(mid), slen=strlen(suf);
+  char *s;
+  sexp str;
+  str = sexp_make_string(ctx, sexp_make_fixnum(plen+mlen+slen), SEXP_VOID);
+  memcpy(s=sexp_string_data(str), pre, plen);
+  memcpy(s+plen, mid, mlen);
+  memcpy(s+plen+mlen, suf, slen);
+  return str;
+}
+
+sexp sexp_user_exception (sexp ctx, sexp self, const char *ms, sexp ir) {
+  sexp res;
+  sexp_gc_var3(sym, str, irr);
+  sexp_gc_preserve3(ctx, sym, str, irr);
+  res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "user", -1),
+                            str = sexp_c_string(ctx, ms, -1),
+                            ((sexp_pairp(ir) || sexp_nullp(ir))
+                             ? ir : (irr = sexp_list1(ctx, ir))),
+                            self, SEXP_FALSE);
+  sexp_gc_release3(ctx);
+  return res;
+}
+
+sexp sexp_file_exception (sexp ctx, sexp self, const char *ms, sexp ir) {
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  res = sexp_user_exception(ctx, self, ms, ir);
+  sexp_exception_kind(res) = sexp_intern(ctx, "file", -1);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+static sexp type_exception (sexp ctx, sexp self, sexp str, sexp obj, sexp src) {
+  sexp_gc_var2(res, sym);
+  sexp_gc_preserve2(ctx, res, sym);
+  sym = sexp_intern(ctx, "type", -1);
+  res = sexp_make_exception(ctx, sym, str, obj, self, src);
+  sexp_exception_irritants(res)=sexp_list1(ctx, sexp_exception_irritants(res));
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp obj) {
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  res = sexp_c_string(ctx, msg, -1);
+  res = type_exception(ctx, self, res, obj, SEXP_FALSE);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp obj) {
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  res = sexp_string_cat3(ctx, "invalid type, expected ",
+                         sexp_string_data(sexp_type_name_by_index(ctx, type_id)), "");
+  res = type_exception(ctx, self, res, obj, SEXP_FALSE);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) {
+  sexp_gc_var2(res, msg);
+  sexp_gc_preserve2(ctx, res, msg);
+  msg = sexp_c_string(ctx, "bad index range", -1);
+  res = sexp_list2(ctx, start, end);
+  res = sexp_cons(ctx, obj, res);
+  res = sexp_make_exception(ctx, sexp_intern(ctx, "range", -1), msg, res,
+                            SEXP_FALSE, SEXP_FALSE);
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+sexp sexp_print_exception_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp out) {
+  sexp_gc_var2(ls, tmp);
+  /* unwrap continuable exceptions */
+  if (sexp_exceptionp(exn)
+      && sexp_exception_kind(exn) == sexp_global(ctx, SEXP_G_CONTINUABLE_SYMBOL)
+      && sexp_exceptionp(sexp_exception_irritants(exn))) {
+    return sexp_print_exception_op(ctx, self, n, sexp_exception_irritants(exn), out);
+  }
+  sexp_gc_preserve2(ctx, ls, tmp);
+  if (! sexp_oportp(out))
+    out = tmp = sexp_make_output_port(ctx, stderr, SEXP_FALSE);
+  sexp_write_string(ctx, "ERROR", out);
+  if (sexp_exceptionp(exn)) {
+    if (sexp_exception_procedure(exn)) {
+      if (sexp_procedurep(sexp_exception_procedure(exn))) {
+        ls = sexp_bytecode_name(
+              sexp_procedure_code(sexp_exception_procedure(exn)));
+        if (ls && sexp_symbolp(ls)) {
+          sexp_write_string(ctx, " in ", out);
+          sexp_write(ctx, ls, out);
+        }
+      } else if (sexp_opcodep(sexp_exception_procedure(exn))) {
+        sexp_write_string(ctx, " in ", out);
+        sexp_write(ctx, sexp_opcode_name(sexp_exception_procedure(exn)), out);
+      }
+    }
+    ls = sexp_exception_source(exn);
+    if ((! (ls && sexp_pairp(ls)))
+        && sexp_exception_procedure(exn)
+        && sexp_procedurep(sexp_exception_procedure(exn)))
+      ls = sexp_bytecode_source(sexp_procedure_code(sexp_exception_procedure(exn)));
+    if (ls && sexp_pairp(ls)) {
+      if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) {
+        sexp_write_string(ctx, " on line ", out);
+        sexp_write(ctx, sexp_cdr(ls), out);
+      }
+      if (sexp_stringp(sexp_car(ls))) {
+        sexp_write_string(ctx, " of file ", out);
+        sexp_write_string(ctx, sexp_string_data(sexp_car(ls)), out);
+      }
+    }
+    sexp_write_string(ctx, ": ", out);
+    if (sexp_stringp(sexp_exception_message(exn)))
+      sexp_write_string(ctx, sexp_string_data(sexp_exception_message(exn)), out);
+    else
+      sexp_write(ctx, sexp_exception_message(exn), out);
+    if (sexp_exception_irritants(exn)
+        && sexp_pairp(sexp_exception_irritants(exn))) {
+      if (sexp_nullp(sexp_cdr(sexp_exception_irritants(exn)))) {
+        sexp_write_string(ctx, ": ", out);
+        sexp_write(ctx, sexp_car(sexp_exception_irritants(exn)), out);
+        sexp_write_string(ctx, "\n", out);
+      } else {
+        sexp_write_string(ctx, "\n", out);
+        for (ls=sexp_exception_irritants(exn);
+             sexp_pairp(ls); ls=sexp_cdr(ls)) {
+          sexp_write_string(ctx, "    ", out);
+          sexp_write(ctx, sexp_car(ls), out);
+          sexp_write_char(ctx, '\n', out);
+        }
+      }
+    } else {
+      sexp_write_char(ctx, '\n', out);
+    }
+  } else {
+    sexp_write_string(ctx, ": ", out);
+    if (sexp_stringp(exn))
+      sexp_write_string(ctx, sexp_string_data(exn), out);
+    else
+      sexp_write(ctx, exn, out);
+    sexp_write_char(ctx, '\n', out);
+  }
+  sexp_gc_release2(ctx);
+  return SEXP_VOID;
+}
+
+sexp sexp_read_error (sexp ctx, const char *msg, sexp ir, sexp port) {
+  sexp res;
+  sexp_gc_var4(sym, name, str, irr);
+  sexp_gc_preserve4(ctx, sym, name, str, irr);
+  name = (sexp_port_name(port) ? sexp_port_name(port) : SEXP_FALSE);
+  name = sexp_cons(ctx, name, sexp_make_fixnum(sexp_port_line(port)));
+  str = sexp_c_string(ctx, msg, -1);
+  irr = ((sexp_pairp(ir) || sexp_nullp(ir)) ? ir : sexp_list1(ctx, ir));
+  res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "read", -1),
+                            str, irr, SEXP_FALSE, name);
+  sexp_gc_release4(ctx);
+  return res;
+}
+
+sexp sexp_read_incomplete_error (sexp ctx, const char *msg, sexp ir, sexp port) {
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  res = sexp_read_error(ctx, msg, ir, port);
+  if (sexp_exceptionp(res))
+    sexp_exception_kind(res) = sexp_intern(ctx, "read-incomplete", -1);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+/*************************** list utilities ***************************/
+
+sexp sexp_cons_op (sexp ctx, sexp self, sexp_sint_t n, sexp head, sexp tail) {
+  sexp pair = sexp_alloc_type(ctx, pair, SEXP_PAIR);
+  if (sexp_exceptionp(pair)) return pair;
+  sexp_car(pair) = head;
+  sexp_cdr(pair) = tail;
+  sexp_pair_source(pair) = SEXP_FALSE;
+  return pair;
+}
+
+sexp sexp_list2 (sexp ctx, sexp a, sexp b) {
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  res = sexp_cons(ctx, b, SEXP_NULL);
+  res = sexp_cons(ctx, a, res);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_listp_op (sexp ctx, sexp self, sexp_sint_t n, sexp hare) {
+  sexp turtle;
+  if (! sexp_pairp(hare))
+    return sexp_make_boolean(sexp_nullp(hare));
+  turtle = hare;
+  hare = sexp_cdr(hare);
+  for ( ; sexp_pairp(hare); turtle=sexp_cdr(turtle)) {
+    if (hare == turtle) return SEXP_FALSE;
+    hare = sexp_cdr(hare);
+    if (sexp_pairp(hare)) hare = sexp_cdr(hare);
+  }
+  return sexp_make_boolean(sexp_nullp(hare));
+}
+
+sexp sexp_memq_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp ls) {
+  while (sexp_pairp(ls))
+    if (x == sexp_car(ls))
+      return ls;
+    else
+      ls = sexp_cdr(ls);
+  return SEXP_FALSE;
+}
+
+sexp sexp_assq_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp ls) {
+  while (sexp_pairp(ls))
+    if (sexp_pairp(sexp_car(ls)) && (x == sexp_caar(ls)))
+      return sexp_car(ls);
+    else
+      ls = sexp_cdr(ls);
+  return SEXP_FALSE;
+}
+
+sexp sexp_reverse_op (sexp ctx, sexp self, sexp_sint_t n, sexp ls) {
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls))
+    res = sexp_cons(ctx, sexp_car(ls), res);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_nreverse_op (sexp ctx, sexp self, sexp_sint_t n, sexp ls) {
+  sexp a, b, tmp;
+  if (ls == SEXP_NULL) return ls;
+  sexp_assert_type(ctx, sexp_pairp, SEXP_PAIR, ls);
+  b = ls;
+  a = sexp_cdr(ls);
+  sexp_cdr(b) = SEXP_NULL;
+  for ( ; sexp_pairp(a); b=a, a=tmp) {
+    tmp = sexp_cdr(a);
+    sexp_cdr(a) = b;
+  }
+  return b;
+}
+
+sexp sexp_copy_list_op (sexp ctx, sexp self, sexp_sint_t n, sexp ls) {
+  sexp tmp;
+  sexp_gc_var1(res);
+  if (! sexp_pairp(ls)) return ls;
+  sexp_gc_preserve1(ctx, res);
+  tmp = res = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls));
+  for (ls=sexp_cdr(ls); sexp_pairp(ls); ls=sexp_cdr(ls), tmp=sexp_cdr(tmp))
+    sexp_cdr(tmp) = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls));
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_append2_op (sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b) {
+  sexp_gc_var2(a1, b1);
+  sexp_gc_preserve2(ctx, a1, b1);
+  b1 = b;
+  for (a1=sexp_reverse(ctx, a); sexp_pairp(a1); a1=sexp_cdr(a1))
+    b1 = sexp_cons(ctx, sexp_car(a1), b1);
+  sexp_gc_release2(ctx);
+  return b1;
+}
+
+sexp sexp_length_op (sexp ctx, sexp self, sexp_sint_t n, sexp ls1) {
+  sexp ls2;
+  sexp_uint_t res = 1;
+  if (!sexp_pairp(ls1))
+    return SEXP_ZERO;
+  for (ls2=sexp_cdr(ls1); sexp_pairp(ls2) && sexp_pairp(sexp_cdr(ls2));
+       res+=2, ls1=sexp_cdr(ls1), ls2=sexp_cddr(ls2))
+    if (ls1 == ls2)
+      return SEXP_FALSE;
+  return sexp_make_fixnum(res + (sexp_pairp(ls2) ? 1 : 0));
+}
+
+sexp sexp_equalp_bound (sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b, sexp depth, sexp bound) {
+  sexp_uint_t left_size, right_size;
+  sexp_sint_t i, len;
+  sexp t, *p, *q, depth2;
+  char *p_left, *p_right, *q_left, *q_right;
+
+ loop:
+  if (a == b)
+    return bound;
+  else if ((!a || !sexp_pointerp(a)) || (!b || !sexp_pointerp(b))
+           || (sexp_pointer_tag(a) != sexp_pointer_tag(b)))
+    return SEXP_FALSE;
+
+  /* a and b are both pointers of the same type */
+#if SEXP_USE_BIGNUMS
+  if (sexp_pointer_tag(a) == SEXP_BIGNUM)
+    return !sexp_bignum_compare(a, b) ? bound : SEXP_FALSE;
+#endif
+#if SEXP_USE_FLONUMS && ! SEXP_USE_IMMEDIATE_FLONUMS
+  if (sexp_pointer_tag(a) == SEXP_FLONUM)
+    return sexp_flonum_eqv(a, b) ? bound : SEXP_FALSE;
+#endif
+  /* check limits */
+  if (sexp_unbox_fixnum(bound) < 0 || sexp_unbox_fixnum(depth) < 0)
+    return bound;
+  depth2 = sexp_fx_sub(depth, SEXP_ONE);
+  bound = sexp_fx_sub(bound, SEXP_ONE);
+  t = sexp_object_type(ctx, a);
+  p_left = ((char*)a) + offsetof(struct sexp_struct, value);
+  p = (sexp*) (((char*)a) + sexp_type_field_base(t));
+  q_left = ((char*)b) + offsetof(struct sexp_struct, value);
+  q = (sexp*) (((char*)b) + sexp_type_field_base(t));
+  /* if no fields, the base is value (just past the header) */
+  if ((sexp)p == a) {p=(sexp*)p_left; q=(sexp*)q_left;}
+  /* check preliminary non-object data */
+  left_size = (char*)p - p_left;
+  if ((left_size > 0) && memcmp(p_left, q_left, left_size))
+    return SEXP_FALSE;
+  /* check trailing non-object data */
+  p_right = ((char*)p + sexp_type_num_slots_of_object(t,a)*sizeof(sexp));
+  right_size = ((char*)a + sexp_type_size_of_object(t, a)) - p_right;
+  if (right_size > 0) {
+    q_right = ((char*)q + sexp_type_num_slots_of_object(t,b)*sizeof(sexp));
+    if (right_size != ((char*)b + sexp_type_size_of_object(t, b)) - q_right)
+      return SEXP_FALSE;
+    if (memcmp(p_right, q_right, right_size))
+      return SEXP_FALSE;
+  }
+  /* left and right non-object data is the same, now check eq-object slots */
+  len = sexp_type_num_eq_slots_of_object(t, a);
+  if (len > 0) {
+    for (; len > 1; len--) {
+      a = p[len-1]; b = q[len-1];
+      if (a != b) {
+        if ((!a || !sexp_pointerp(a)) || (!b || !sexp_pointerp(b))
+            || (sexp_pointer_tag(a) != sexp_pointer_tag(b)))
+          return SEXP_FALSE;
+        else break;
+      }
+    }
+    for (i=0; i<len-1; i++) {
+      bound = sexp_equalp_bound(ctx, self, n, p[i], q[i], depth2, bound);
+      if (sexp_not(bound)) return SEXP_FALSE;
+    }
+    /* tail-recurse on the last value (same depth) */
+    a = p[len-1]; b = q[len-1]; goto loop;
+  }
+  return bound;
+}
+
+sexp sexp_equalp_op (sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b) {
+  return sexp_make_boolean(
+    sexp_truep(sexp_equalp_bound(ctx, self, n, a, b,
+                                 sexp_make_fixnum(SEXP_DEFAULT_EQUAL_DEPTH),
+                                 sexp_make_fixnum(SEXP_DEFAULT_EQUAL_BOUND))));
+}
+
+/********************* strings, symbols, vectors **********************/
+
+sexp sexp_flonump_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  return sexp_make_boolean(sexp_flonump(x));
+}
+
+#if ! SEXP_USE_IMMEDIATE_FLONUMS
+sexp sexp_make_flonum (sexp ctx, double f) {
+  sexp x = sexp_alloc_type(ctx, flonum, SEXP_FLONUM);
+  if (sexp_exceptionp(x)) return x;
+  sexp_flonum_value(x) = f;
+  return x;
+}
+#else
+#if SEXP_64_BIT
+float sexp_flonum_value (sexp x) {
+  union sexp_flonum_conv r;
+  r.bits = (sexp_uint_t)x >> 32;
+  return r.flonum;
+}
+sexp sexp_make_flonum (sexp ctx, float f) {
+  union sexp_flonum_conv x;
+  x.flonum = f;
+  return (sexp)(((sexp_uint_t)(x.bits) << 32) + SEXP_IFLONUM_TAG);
+}
+#endif
+#endif
+
+sexp sexp_make_bytes_op (sexp ctx, sexp self, sexp_sint_t n, sexp len, sexp i) {
+  sexp_sint_t clen = sexp_unbox_fixnum(len);
+  sexp s;
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, len);
+  if (clen < 0) return sexp_xtype_exception(ctx, self, "negative length", len);
+  s = sexp_alloc_atomic(ctx, sexp_sizeof(bytes)+clen+1);
+  if (sexp_exceptionp(s)) return s;
+  sexp_pointer_tag(s) = SEXP_BYTES;
+#if SEXP_USE_HEADER_MAGIC
+  sexp_pointer_magic(s) = SEXP_POINTER_MAGIC;
+#endif
+  sexp_bytes_length(s) = clen;
+  if (sexp_fixnump(i))
+    memset(sexp_bytes_data(s), sexp_unbox_fixnum(i), clen);
+  sexp_bytes_data(s)[clen] = '\0';
+  return s;
+}
+
+#if SEXP_USE_UTF8_STRINGS
+
+int sexp_utf8_initial_byte_count (int c) {
+  if (c < 0xC0) return 1;
+  if (c < 0xE0) return 2;
+  return ((c>>4)&1)+3;
+}
+
+int sexp_utf8_char_byte_count (int c) {
+  if (c < 0x80) return 1;
+  if (c < 0x800) return 2;
+  if (c < 0x10000) return 3;
+  return 4;
+}
+
+sexp_uint_t sexp_string_utf8_length (unsigned char *p, long len) {
+  unsigned char *q = p+len;
+  sexp_uint_t i;
+  for (i=0; p<q; i++)
+    p += sexp_utf8_initial_byte_count(*p);
+  return i;
+}
+
+char* sexp_string_utf8_prev (unsigned char *p) {
+  while ((*--p)>>6 == 2)
+    ;
+  return (char*)p;
+}
+
+sexp sexp_string_utf8_ref (sexp ctx, sexp str, sexp i) {
+  unsigned char *p=(unsigned char*)sexp_string_data(str) + sexp_unbox_fixnum(i);
+  if (*p < 0x80)
+    return sexp_make_character(*p);
+  else if ((*p < 0xC0) || (*p > 0xF7))
+    return sexp_user_exception(ctx, NULL, "string-ref: invalid utf8 byte", i);
+  else if (*p < 0xE0)
+    return sexp_make_character(((p[0]&0x3F)<<6) + (p[1]&0x3F));
+  else if (*p < 0xF0)
+    return sexp_make_character(((p[0]&0x1F)<<12) + ((p[1]&0x3F)<<6) + (p[2]&0x3F));
+  else
+    return sexp_make_character(((p[0]&0x0F)<<18) + ((p[1]&0x3F)<<12) + ((p[2]&0x3F)<<6) + (p[3]&0x3F));
+}
+
+void sexp_utf8_encode_char (unsigned char* p, int len, int c) {
+  switch (len) {
+  case 4:  *p++ = (0xF0 + ((c)>>18)); *p++ = (0x80 + ((c>>12)&0x3F));
+    *p++ = (0x80 + ((c>>6)&0x3F));    *p = (0x80 + (c&0x3F)); break;
+  case 3:  *p++ = (0xE0 + ((c)>>12)); *p++ = (0x80 + ((c>>6)&0x3F));
+    *p = (0x80 + (c&0x3F)); break;
+  case 2:  *p++ = (0xC0 + ((c)>>6));  *p = (0x80 + (c&0x3F)); break;
+  default: *p = c; break;
+  }
+}
+
+sexp sexp_string_index_to_offset (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp index) {
+  sexp_sint_t i, j, limit;
+  unsigned char *p;
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, index);
+  p = (unsigned char*)sexp_string_data(str);
+  limit = sexp_string_size(str);
+  for (j=0, i=sexp_unbox_fixnum(index); i>0 && j<limit; i--)
+    j += sexp_utf8_initial_byte_count(p[j]);
+  if (i != 0)
+    return sexp_user_exception(ctx, self, "string-index->offset: index out of range", index);
+  return sexp_make_fixnum(j);
+}
+
+sexp sexp_string_offset_to_index (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp offset) {
+  sexp_sint_t off = sexp_unbox_fixnum(offset);
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, offset);
+  if (off < 0 || off > sexp_string_size(str))
+    return sexp_user_exception(ctx, self, "string-offset->index: offset out of range", offset);
+  return sexp_make_fixnum(sexp_string_utf8_length((unsigned char*)sexp_string_data(str), off));
+}
+
+#endif
+
+sexp sexp_make_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp len, sexp ch)
+{
+  sexp i = (sexp_charp(ch) ? sexp_make_fixnum(sexp_unbox_character(ch)) : ch);
+#if SEXP_USE_PACKED_STRINGS
+  sexp b;
+#else
+  sexp_gc_var2(b, s);
+#endif
+#if SEXP_USE_UTF8_STRINGS
+  int j, clen;
+  if (sexp_charp(ch) && (sexp_unbox_character(ch) >= 0x80)) {
+    sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, len);
+    clen = sexp_utf8_char_byte_count(sexp_unbox_character(ch));
+    b = sexp_make_bytes_op(ctx, self, n,
+                           sexp_fx_mul(len, sexp_make_fixnum(clen)), SEXP_VOID);
+    if (sexp_exceptionp(b)) return b;
+    for (j=0; j<sexp_unbox_fixnum(len); j++)
+      sexp_utf8_encode_char((unsigned char*)sexp_bytes_data(b)+(j*clen), clen,
+                            sexp_unbox_character(ch));
+  } else
+#endif
+  b = sexp_make_bytes_op(ctx, self, n, len, i);
+  if (sexp_exceptionp(b)) return b;
+#if SEXP_USE_PACKED_STRINGS
+  sexp_pointer_tag(b) = SEXP_STRING;
+  return b;
+#else
+  sexp_gc_preserve2(ctx, b, s);
+  s = sexp_alloc_type(ctx, string, SEXP_STRING);
+  sexp_string_bytes(s) = b;
+  sexp_string_offset(s) = 0;
+  sexp_string_size(s) = sexp_bytes_length(b);
+  sexp_gc_release2(ctx);
+  return s;
+#endif
+}
+
+sexp sexp_c_string (sexp ctx, const char *str, sexp_sint_t slen) {
+  sexp_sint_t len;
+  sexp s;
+  if (str == NULL) return SEXP_FALSE;
+  len = ((slen >= 0) ? slen : strlen(str));
+  s = sexp_make_string(ctx, sexp_make_fixnum(len), SEXP_VOID);
+  if (sexp_exceptionp(s)) return s;
+  memcpy(sexp_string_data(s), str, len);
+  sexp_string_data(s)[len] = '\0';
+  return s;
+}
+
+sexp sexp_substring_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp start, sexp end) {
+  sexp res;
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, start);
+  if (sexp_not(end))
+    end = sexp_make_fixnum(sexp_string_size(str));
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, end);
+  if ((sexp_unbox_fixnum(start) < 0)
+      || (sexp_unbox_fixnum(start) > sexp_string_size(str))
+      || (sexp_unbox_fixnum(end) < 0)
+      || (sexp_unbox_fixnum(end) > sexp_string_size(str))
+      || (end < start))
+    return sexp_range_exception(ctx, str, start, end);
+  res = sexp_make_string(ctx, sexp_fx_sub(end, start), SEXP_VOID);
+  memcpy(sexp_string_data(res),
+         sexp_string_data(str)+sexp_unbox_fixnum(start),
+         sexp_string_size(res));
+  sexp_string_data(res)[sexp_string_size(res)] = '\0';
+  return res;
+}
+
+sexp sexp_subbytes_op (sexp ctx, sexp self, sexp_sint_t n, sexp vec, sexp start, sexp end) {
+  sexp res;
+  sexp_gc_var1(str);
+  sexp_assert_type(ctx, sexp_bytesp, SEXP_BYTES, vec);
+  sexp_gc_preserve1(ctx, str);
+#if SEXP_USE_PACKED_STRINGS
+  str = sexp_c_string(ctx, sexp_bytes_data(vec), sexp_bytes_length(vec));
+#else
+  str = sexp_alloc_type(ctx, string, SEXP_STRING);
+  sexp_string_bytes(str) = vec;
+  sexp_string_offset(str) = 0;
+  sexp_string_size(str) = sexp_bytes_length(vec);
+#endif
+  res = sexp_substring_op(ctx, self, n, str, start, end);
+  if (!sexp_exceptionp(res))
+    res = sexp_string_to_bytes(ctx, res);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+#if SEXP_USE_UTF8_STRINGS
+sexp sexp_utf8_substring_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp start, sexp end) {
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, start);
+  start = sexp_string_index_to_offset(ctx, self, n, str, start);
+  if (sexp_exceptionp(start)) return start;
+  if (sexp_fixnump(end)) {
+    end = sexp_string_index_to_offset(ctx, self, n, str, end);
+    if (sexp_exceptionp(end)) return end;
+  }
+  return sexp_substring_op(ctx, self, n, str, start, end);
+}
+#endif
+
+sexp sexp_string_concatenate_op (sexp ctx, sexp self, sexp_sint_t n, sexp str_ls, sexp sep) {
+  sexp res, ls;
+  sexp_uint_t len=0, i=0, sep_len=0;
+  char *p, *csep=NULL;
+  for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls), i++)
+    if (! sexp_stringp(sexp_car(ls)))
+      return sexp_type_exception(ctx, self, SEXP_STRING, sexp_car(ls));
+    else
+      len += sexp_string_size(sexp_car(ls));
+  if ((i > 0) && sexp_stringp(sep) && ((sep_len=sexp_string_size(sep)) > 0)) {
+    csep = sexp_string_data(sep);
+    len += sep_len*(i-1);
+  }
+  res = sexp_make_string(ctx, sexp_make_fixnum(len), SEXP_VOID);
+  p = sexp_string_data(res);
+  for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) {
+    len = sexp_string_size(sexp_car(ls));
+    memcpy(p, sexp_string_data(sexp_car(ls)), len);
+    p += len;
+    if (sep_len && sexp_pairp(sexp_cdr(ls))) {
+      memcpy(p, csep, sep_len);
+      p += sep_len;
+    }
+  }
+  *p = '\0';
+  return res;
+}
+
+#define FNV_PRIME 16777619
+#define FNV_OFFSET_BASIS 2166136261uL
+
+#if SEXP_USE_HASH_SYMS
+
+static sexp_uint_t sexp_string_hash(const char *str, sexp_sint_t len,
+                                    sexp_uint_t acc) {
+  for ( ; len; len--) {acc *= FNV_PRIME; acc ^= *str++;}
+  return acc;
+}
+
+#endif
+
+sexp sexp_intern(sexp ctx, const char *str, sexp_sint_t len) {
+#if SEXP_USE_HUFF_SYMS
+  struct sexp_huff_entry he;
+  sexp_sint_t space, newbits;
+  char c;
+#endif
+  sexp ls, tmp;
+  sexp_gc_var1(sym);
+  sexp_sint_t bucket=0;
+#if (SEXP_USE_HASH_SYMS || SEXP_USE_HUFF_SYMS)
+  sexp_sint_t i=0, res=FNV_OFFSET_BASIS;
+  const char *p=str;
+#endif
+
+  if (len < 0) len = strlen(str);
+
+#if SEXP_USE_HUFF_SYMS
+  res = 0;
+  space = 3;
+  if (len == 0) goto normal_intern;
+  for ( ; i<len; i++, p++) {
+    c = *p;
+    if ((unsigned char)c <= 32 || (unsigned char)c > 127 || c == '\\')
+      goto normal_intern;
+    he = huff_table[(unsigned char)c];
+    newbits = he.len;
+    if ((space+newbits) > (sizeof(sexp)*8))
+      goto normal_intern;
+    res |= (((sexp_uint_t) he.bits) << space);
+    space += newbits;
+  }
+  return (sexp) (res + SEXP_ISYMBOL_TAG);
+
+ normal_intern:
+#endif
+#if SEXP_USE_HASH_SYMS
+  bucket = (sexp_string_hash(p, len-i, res) % SEXP_SYMBOL_TABLE_SIZE);
+#endif
+  for (ls=sexp_context_symbols(ctx)[bucket]; sexp_pairp(ls); ls=sexp_cdr(ls))
+    if ((sexp_lsymbol_length(tmp=sexp_car(ls)) == len)
+        && ! strncmp(str, sexp_lsymbol_data(tmp), len))
+      return sexp_car(ls);
+
+  /* not found, make a new symbol */
+  sexp_gc_preserve1(ctx, sym);
+  sym = sexp_c_string(ctx, str, len);
+  if (sexp_exceptionp(sym)) return sym;
+#if ! SEXP_USE_PACKED_STRINGS
+  sym = sexp_string_bytes(sym);
+#endif
+  sexp_pointer_tag(sym) = SEXP_SYMBOL;
+  sexp_push(ctx, sexp_context_symbols(ctx)[bucket], sym);
+  sexp_gc_release1(ctx);
+  return sym;
+}
+
+sexp sexp_string_to_symbol_op (sexp ctx, sexp self, sexp_sint_t n, sexp str) {
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
+  return sexp_intern(ctx, sexp_string_data(str), sexp_string_size(str));
+}
+
+sexp sexp_make_vector_op (sexp ctx, sexp self, sexp_sint_t n, sexp len, sexp dflt) {
+  sexp vec, *x;
+  int i, clen = sexp_unbox_fixnum(len);
+  if (! clen) return sexp_global(ctx, SEXP_G_EMPTY_VECTOR);
+  vec = sexp_alloc_tagged(ctx, sexp_sizeof(vector) + clen*sizeof(sexp),
+                          SEXP_VECTOR);
+  if (sexp_exceptionp(vec)) return vec;
+  x = sexp_vector_data(vec);
+  for (i=0; i<clen; i++)
+    x[i] = dflt;
+  sexp_vector_length(vec) = clen;
+  return vec;
+}
+
+sexp sexp_list_to_vector_op (sexp ctx, sexp self, sexp_sint_t n, sexp ls) {
+  int i;
+  sexp x, *elts, vec = sexp_make_vector(ctx, sexp_length(ctx, ls), SEXP_VOID);
+  if (sexp_exceptionp(vec)) return vec;
+  elts = sexp_vector_data(vec);
+  for (i=0, x=ls; sexp_pairp(x); i++, x=sexp_cdr(x))
+    elts[i] = sexp_car(x);
+  return vec;
+}
+
+sexp sexp_make_cpointer (sexp ctx, sexp_uint_t type_id, void *value,
+                         sexp parent, int freep) {
+  sexp ptr;
+  if (! value) return SEXP_FALSE;
+  ptr = sexp_alloc_type(ctx, cpointer, type_id);
+  if (sexp_exceptionp(ptr)) return ptr;
+  sexp_freep(ptr) = freep;
+  sexp_cpointer_value(ptr) = value;
+  sexp_cpointer_parent(ptr) = parent;
+  sexp_cpointer_length(ptr) = 0;
+  return ptr;
+}
+
+/************************ reading and writing *************************/
+
+#if SEXP_USE_STRING_STREAMS
+
+#define SEXP_INIT_STRING_PORT_SIZE 128
+
+#if SEXP_BSD
+
+#define sexp_streamp(vec) sexp_vectorp(vec)
+
+#define sexp_stream_ctx(vec) sexp_vector_ref((sexp)vec, SEXP_ZERO)
+#define sexp_stream_buf(vec) sexp_vector_ref((sexp)vec, SEXP_ONE)
+#define sexp_stream_size(vec) sexp_vector_ref((sexp)vec, SEXP_TWO)
+#define sexp_stream_pos(vec) sexp_vector_ref((sexp)vec, SEXP_THREE)
+
+#define sexp_stream_ctx_set(vec, x) sexp_vector_set((sexp)vec, SEXP_ZERO, x)
+#define sexp_stream_buf_set(vec, x) sexp_vector_set((sexp)vec, SEXP_ONE, x)
+#define sexp_stream_size_set(vec, x) sexp_vector_set((sexp)vec, SEXP_TWO, x)
+#define sexp_stream_pos_set(vec, x) sexp_vector_set((sexp)vec, SEXP_THREE, x)
+
+static int sstream_read (void *vec, char *dst, int n) {
+  sexp_uint_t len = sexp_unbox_fixnum(sexp_stream_size(vec));
+  sexp_uint_t pos = sexp_unbox_fixnum(sexp_stream_pos(vec));
+  if (pos >= len) return 0;
+  if (n > (len - pos)) n = (len - pos);
+  memcpy(dst, sexp_string_data(sexp_stream_buf(vec))+pos, n);
+  sexp_stream_pos_set(vec, sexp_make_fixnum(pos + n));
+  return n;
+}
+
+static int sstream_write (void *vec, const char *src, int n) {
+  sexp_uint_t len, pos, newpos;
+  sexp newbuf;
+  len = sexp_unbox_fixnum(sexp_stream_size(vec));
+  pos = sexp_unbox_fixnum(sexp_stream_pos(vec));
+  newpos = pos+n;
+  if (newpos >= len) {
+    newbuf = sexp_make_string(sexp_stream_ctx(vec),
+                              sexp_make_fixnum(newpos*2),
+                              SEXP_VOID);
+    memcpy(sexp_string_data(newbuf),
+           sexp_string_data(sexp_stream_buf(vec)),
+           pos);
+    sexp_stream_buf_set(vec, newbuf);
+    sexp_stream_size_set(vec, sexp_make_fixnum(newpos*2));
+  }
+  memcpy(sexp_string_data(sexp_stream_buf(vec))+pos, src, n);
+  sexp_stream_pos_set(vec, sexp_make_fixnum(newpos));
+  return n;
+}
+
+static off_t sstream_seek (void *vec, off_t offset, int whence) {
+  sexp_sint_t pos;
+  if (whence == SEEK_SET) {
+    pos = offset;
+  } else if (whence == SEEK_CUR) {
+    pos = sexp_unbox_fixnum(sexp_stream_pos(vec)) + offset;
+  } else {                      /* SEEK_END */
+    pos = sexp_unbox_fixnum(sexp_stream_size(vec)) + offset;
+  }
+  sexp_stream_pos_set(vec, sexp_make_fixnum(pos));
+  return pos;
+}
+
+sexp sexp_open_input_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp str) {
+  FILE *in;
+  sexp res;
+  sexp_gc_var1(cookie);
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
+  sexp_gc_preserve1(ctx, cookie);
+  cookie = sexp_make_vector(ctx, sexp_make_fixnum(4), SEXP_VOID);
+  sexp_stream_ctx_set(cookie, ctx);
+  sexp_stream_buf_set(cookie, str);
+  sexp_stream_size_set(cookie, sexp_make_fixnum(sexp_string_size(str)));
+  sexp_stream_pos_set(cookie, SEXP_ZERO);
+  in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL);
+  res = sexp_make_input_port(ctx, in, SEXP_FALSE);
+  sexp_port_cookie(res) = cookie;
+  sexp_port_binaryp(res) = 0;
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_open_output_string_op (sexp ctx, sexp self, sexp_sint_t n) {
+  FILE *out;
+  sexp res, size;
+  sexp_gc_var1(cookie);
+  sexp_gc_preserve1(ctx, cookie);
+  size = sexp_make_fixnum(SEXP_INIT_STRING_PORT_SIZE);
+  cookie = sexp_make_vector(ctx, sexp_make_fixnum(4), SEXP_VOID);
+  sexp_stream_ctx_set(cookie, ctx);
+  sexp_stream_buf_set(cookie, sexp_make_string(ctx, size, SEXP_VOID));
+  sexp_stream_size_set(cookie, size);
+  sexp_stream_pos_set(cookie, SEXP_ZERO);
+  out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL);
+  res = sexp_make_output_port(ctx, out, SEXP_FALSE);
+  sexp_port_cookie(res) = cookie;
+  sexp_port_binaryp(res) = 0;
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_get_output_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp port) {
+  sexp cookie;
+  sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, port);
+  if (!sexp_port_openp(port))
+    return sexp_xtype_exception(ctx, self, "output port is closed", port);
+  cookie = sexp_port_cookie(port);
+  if (!sexp_streamp(cookie))
+    return sexp_xtype_exception(ctx, self, "not a string port", port);
+  fflush(sexp_port_stream(port));
+  return sexp_substring_cursor(ctx,
+                               sexp_stream_buf(cookie),
+                               SEXP_ZERO,
+                               sexp_stream_pos(cookie));
+}
+
+#else  /* SEXP_USE_STRING_STREAMS && ! SEXP_BSD */
+
+sexp sexp_open_input_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp str) {
+  FILE *in;
+  sexp res;
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
+  if (sexp_string_size(str) == 0)
+    in = fopen("/dev/null", "r");
+  else
+    in = fmemopen(sexp_string_data(str), sexp_string_size(str), "r");
+  if (in) {
+    res = sexp_make_input_port(ctx, in, SEXP_FALSE);
+    if (sexp_string_size(str) == 0)
+      sexp_port_name(res) = sexp_c_string(ctx, "/dev/null", -1);
+    sexp_port_cookie(res) = str;  /* for gc preservation */
+    sexp_port_binaryp(res) = 0;
+  } else {
+    res = sexp_user_exception(ctx, SEXP_FALSE, "couldn't open string", str);
+  }
+  return res;
+}
+
+sexp sexp_open_output_string_op (sexp ctx, sexp self, sexp_sint_t n) {
+  sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE);
+  sexp_port_stream(res)
+    = open_memstream(&sexp_port_buf(res), &sexp_port_size(res));
+  sexp_port_binaryp(res) = 0;
+  sexp_port_cookie(res) = SEXP_STRING_OPORT;
+  return res;
+}
+
+sexp sexp_get_output_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp port) {
+  sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, port);
+  if (sexp_port_cookie(port) != SEXP_STRING_OPORT)
+    return sexp_xtype_exception(ctx, self, "not an output string port", port);
+  if (!sexp_openp(port))
+    return sexp_xtype_exception(ctx, self, "output port is closed", port);
+  fflush(sexp_port_stream(port));
+  return sexp_c_string(ctx, sexp_port_buf(port), sexp_port_size(port));
+}
+
+#endif
+
+sexp sexp_open_input_file_descriptor (sexp ctx, sexp self, sexp_sint_t n, sexp fileno, sexp shutdownp) {
+  sexp res;
+  FILE* in;
+  sexp_assert_type(ctx, sexp_filenop, SEXP_FILENO, fileno);
+  in = fdopen(sexp_fileno_fd(fileno), "r");
+  if (!in) return sexp_file_exception(ctx, SEXP_FALSE, "couldn't open fileno", fileno);
+  res = sexp_make_input_port(ctx, in, SEXP_FALSE);
+  if (!sexp_exceptionp(res)) {
+    sexp_port_binaryp(res) = 1;
+    sexp_port_shutdownp(res) = sexp_truep(shutdownp);
+    sexp_fileno_count(fileno)++;
+  }
+  return res;
+}
+
+sexp sexp_open_output_file_descriptor (sexp ctx, sexp self, sexp_sint_t n, sexp fileno, sexp shutdownp) {
+  sexp res;
+  FILE* out;
+  sexp_assert_type(ctx, sexp_filenop, SEXP_FILENO, fileno);
+  out = fdopen(sexp_fileno_fd(fileno), "w");
+  if (!out) return sexp_user_exception(ctx, SEXP_FALSE, "couldn't open fileno", fileno);
+  res = sexp_make_output_port(ctx, out, SEXP_FALSE);
+  if (!sexp_exceptionp(res)) {
+    sexp_port_shutdownp(res) = sexp_truep(shutdownp);
+    sexp_fileno_count(fileno)++;
+  }
+  return res;
+}
+
+#else  /* ! SEXP_USE_STRING_STREAMS */
+
+int sexp_buffered_read_char (sexp ctx, sexp p) {
+  sexp_gc_var2(tmp, origbytes);
+  int res = 0;
+  if (sexp_port_offset(p) < sexp_port_size(p)) {
+    return ((unsigned char*)sexp_port_buf(p))[sexp_port_offset(p)++];
+  } else if (!sexp_port_openp(p)) {
+    return EOF;
+  } else if (sexp_port_stream(p)) {
+    res = fread(sexp_port_buf(p), 1, SEXP_PORT_BUFFER_SIZE, sexp_port_stream(p));
+    if (res >= 0) {
+      sexp_port_offset(p) = 0;
+      sexp_port_size(p) = res;
+      res = ((sexp_port_offset(p) < sexp_port_size(p))
+             ? ((unsigned char*)sexp_port_buf(p))[sexp_port_offset(p)++] : EOF);
+    }
+  } else if (sexp_filenop(sexp_port_fd(p))) {
+    res = read(sexp_port_fileno(p), sexp_port_buf(p), SEXP_PORT_BUFFER_SIZE);
+    if (res >= 0) {
+      sexp_port_offset(p) = 0;
+      sexp_port_size(p) = res;
+      res = ((sexp_port_offset(p) < sexp_port_size(p))
+             ? ((unsigned char*)sexp_port_buf(p))[sexp_port_offset(p)++] : EOF);
+    }
+  } else if (sexp_port_customp(p)) {
+    sexp_gc_preserve2(ctx, tmp, origbytes);
+    tmp = sexp_list2(ctx, SEXP_ZERO, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE));
+    origbytes = sexp_port_binaryp(p) && !SEXP_USE_PACKED_STRINGS ? sexp_string_bytes(sexp_port_buffer(p)) : sexp_port_buffer(p);
+    tmp = sexp_cons(ctx, origbytes, tmp);
+    tmp = sexp_apply(ctx, sexp_port_reader(p), tmp);
+    if (sexp_fixnump(tmp) && sexp_unbox_fixnum(tmp) > 0) {
+      sexp_port_offset(p) = 0;
+      sexp_port_size(p) = sexp_unbox_fixnum(tmp);
+      if (!sexp_port_binaryp(p) && !SEXP_USE_PACKED_STRINGS
+          && origbytes != sexp_string_bytes(sexp_port_buffer(p))) {
+        /* handle resize */
+        memcpy(sexp_port_buf(p), sexp_string_data(sexp_port_buffer(p)), sexp_port_size(p));
+      }
+      res = ((sexp_port_offset(p) < sexp_port_size(p))
+             ? ((unsigned char*)sexp_port_buf(p))[sexp_port_offset(p)++] : EOF);
+    } else {
+      res = EOF;
+      sexp_port_size(p) = 0;
+    }
+    sexp_gc_release2(ctx);
+  } else {
+    res = EOF;
+  }
+  return res;
+}
+
+int sexp_buffered_write_char (sexp ctx, int c, sexp p) {
+  int res;
+  if (sexp_port_offset(p)+1 >= sexp_port_size(p))
+    if ((res = sexp_buffered_flush(ctx, p, 0)))
+      return res;
+  sexp_port_buf(p)[sexp_port_offset(p)++] = c;
+  return 0;
+}
+
+int sexp_buffered_write_string_n (sexp ctx, const char *str,
+                                  sexp_uint_t len, sexp p) {
+  int diff, res, written=0;
+  while (sexp_port_offset(p)+len >= sexp_port_size(p)) {
+    diff = sexp_port_size(p) - sexp_port_offset(p);
+    memcpy(sexp_port_buf(p)+sexp_port_offset(p), str, diff);
+    sexp_port_offset(p) = sexp_port_size(p);
+    if ((res = sexp_buffered_flush(ctx, p, 0)))
+      return written + diff;
+    written += sexp_port_size(p);
+    str += diff;
+    len -= diff;
+  }
+  memcpy(sexp_port_buf(p)+sexp_port_offset(p), str, len);
+  sexp_port_offset(p) += len;
+  return written + len;
+}
+
+int sexp_buffered_write_string (sexp ctx, const char *str, sexp p) {
+  return sexp_buffered_write_string_n(ctx, str, strlen(str), p);
+}
+
+int sexp_buffered_flush (sexp ctx, sexp p, int forcep) {
+  long res = 0, off;
+  sexp_gc_var1(tmp);
+  if (!sexp_oportp(p) || (!forcep && !sexp_port_openp(p)))
+    return -1;
+  off = sexp_port_offset(p);
+  if (sexp_port_stream(p)) {
+    if (off > 0) fwrite(sexp_port_buf(p), 1, off, sexp_port_stream(p));
+    res = fflush(sexp_port_stream(p));
+  } else if (sexp_filenop(sexp_port_fd(p))) {
+    if (off > 0)
+      res = write(sexp_fileno_fd(sexp_port_fd(p)), sexp_port_buf(p), off);
+    if (res < off) {
+      if (res > 0) {
+        memmove(sexp_port_buf(p), sexp_port_buf(p) + res, off - res);
+        sexp_port_offset(p) = off - res;
+      }
+      res = -1;
+    } else {
+      sexp_port_offset(p) = 0;
+      res = 0;
+    }
+  } else if (!sexp_port_openp(p)) {
+    return -1;
+  } else if (sexp_port_offset(p) > 0) {
+    sexp_gc_preserve1(ctx, tmp);
+    if (sexp_port_customp(p)) {   /* custom port */
+      tmp = sexp_list2(ctx, SEXP_ZERO, sexp_make_fixnum(sexp_port_offset(p)));
+      tmp = sexp_cons(ctx, sexp_port_binaryp(p) ? sexp_string_bytes(sexp_port_buffer(p)) : sexp_port_buffer(p), tmp);
+      tmp = sexp_apply(ctx, sexp_port_writer(p), tmp);
+      res = (sexp_fixnump(tmp) && sexp_unbox_fixnum(tmp) > 0) ? 0 : -1;
+    } else {                      /* string port */
+      tmp = sexp_c_string(ctx, sexp_port_buf(p), off);
+      if (tmp && sexp_stringp(tmp)) {
+        sexp_push(ctx, sexp_port_cookie(p), tmp);
+        sexp_port_offset(p) = 0;
+        res = 0;
+      } else {
+        res = -1;
+      }
+    }
+    sexp_gc_release1(ctx);
+  }
+  return res;
+}
+
+sexp sexp_open_input_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp str) {
+  sexp res;
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
+  res = sexp_make_input_port(ctx, NULL, SEXP_FALSE);
+  if (sexp_exceptionp(res)) return res;
+  sexp_port_cookie(res) = str;
+  sexp_port_buf(res) = sexp_string_data(str);
+  sexp_port_offset(res) = 0;
+  sexp_port_size(res) = sexp_string_size(str);
+  sexp_port_binaryp(res) = 0;
+  return res;
+}
+
+sexp sexp_open_output_string_op (sexp ctx, sexp self, sexp_sint_t n) {
+  sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE);
+  if (sexp_exceptionp(res)) return res;
+  sexp_port_buf(res) = (char*) sexp_malloc(SEXP_PORT_BUFFER_SIZE);
+  if (!sexp_port_buf(res)) {
+    res = sexp_global(ctx, SEXP_G_OOM_ERROR);
+  } else {
+    sexp_port_size(res) = SEXP_PORT_BUFFER_SIZE;
+    sexp_port_offset(res) = 0;
+    sexp_port_cookie(res) = SEXP_NULL;
+    sexp_port_binaryp(res) = 0;
+  }
+  return res;
+}
+
+sexp sexp_get_output_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp out) {
+  sexp res;
+  sexp_gc_var3(ls, rev, tmp);
+  sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out);
+  if (!sexp_port_openp(out))
+    return sexp_xtype_exception(ctx, self, "output port is closed", out);
+  sexp_gc_preserve3(ctx, ls, rev, tmp);
+  if (sexp_port_offset(out) > 0) {
+    tmp = sexp_c_string(ctx, sexp_port_buf(out), sexp_port_offset(out));
+    rev = sexp_cons(ctx, tmp, sexp_port_cookie(out));
+  } else {
+    rev = sexp_port_cookie(out);
+  }
+  ls = sexp_reverse(ctx, rev);
+  res = SEXP_FALSE;
+  for (tmp = ls; sexp_pairp(tmp); tmp = sexp_cdr(tmp))
+    if (!sexp_stringp(sexp_car(tmp)))
+      res = sexp_xtype_exception(ctx, self, "not an output string port", out);
+  if (!sexp_nullp(tmp))
+    res = sexp_xtype_exception(ctx, self, "not an output string port", out);
+  if (!sexp_exceptionp(res))
+    res = sexp_string_concatenate(ctx, ls, SEXP_FALSE);
+  sexp_gc_release3(ctx);
+  return res;
+}
+
+sexp sexp_open_input_file_descriptor (sexp ctx, sexp self, sexp_sint_t n, sexp fileno, sexp shutdownp) {
+  sexp_gc_var2(res, str);
+  sexp_assert_type(ctx, sexp_filenop, SEXP_FILENO, fileno);
+  if (sexp_fileno_fd(fileno) < 0)
+    return sexp_file_exception(ctx, self, "invalid file descriptor", fileno);
+  sexp_gc_preserve2(ctx, res, str);
+  str = sexp_make_string(ctx, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE), SEXP_VOID);
+  res = sexp_open_input_string(ctx, str);
+  if (!sexp_exceptionp(res)) {
+    sexp_port_fd(res) = fileno;
+    sexp_port_offset(res) = SEXP_PORT_BUFFER_SIZE;
+    sexp_port_binaryp(res) = 1;
+    sexp_port_shutdownp(res) = sexp_truep(shutdownp);
+    sexp_fileno_count(fileno)++;
+  }
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+sexp sexp_open_output_file_descriptor (sexp ctx, sexp self, sexp_sint_t n, sexp fileno, sexp shutdownp) {
+  sexp res = sexp_open_input_file_descriptor(ctx, self, n, fileno, shutdownp);
+  if (!sexp_exceptionp(res)) {
+    sexp_pointer_tag(res) = SEXP_OPORT;
+    sexp_port_offset(res) = 0;
+  }
+  return res;
+}
+
+#endif  /* ! SEXP_USE_STRING_STREAMS */
+
+#if SEXP_USE_WEAK_REFERENCES
+sexp sexp_make_ephemeron_op(sexp ctx, sexp self, sexp_sint_t n, sexp key, sexp value) {
+  sexp res = sexp_alloc_type(ctx, pair, SEXP_EPHEMERON);
+  if (!sexp_exceptionp(res)) {
+    sexp_ephemeron_key(res) = key;
+    sexp_ephemeron_value(res) = value;
+  }
+  return res;
+}
+
+static sexp* sexp_fileno_cell(sexp ctx, sexp vec, int fd) {
+  sexp *data;
+  sexp_sint_t i, cell, len;
+  if (!sexp_vectorp(vec))
+    return NULL;
+  len = sexp_vector_length(vec);
+  data = sexp_vector_data(vec);
+  for (i = 0, cell = (fd * FNV_PRIME) % len; i < len; i++, cell=(cell+1)%len)
+    if (!sexp_ephemeronp(data[cell])
+        || (sexp_filenop(sexp_ephemeron_key(data[cell]))
+            && sexp_fileno_fd(sexp_ephemeron_key(data[cell])) == fd))
+        return &(data[cell]);
+  return NULL;
+}
+
+static sexp sexp_lookup_fileno(sexp ctx, int fd) {
+  sexp* cell = sexp_fileno_cell(ctx, sexp_global(ctx, SEXP_G_FILE_DESCRIPTORS), fd);
+  if (cell && sexp_ephemeronp(*cell)
+      && sexp_fileno_fd(sexp_ephemeron_key(*cell)) == fd)
+    return sexp_ephemeron_key(*cell);
+  return SEXP_FALSE;
+}
+
+static sexp* sexp_insert_fileno_ephemeron(sexp ctx, sexp vec, sexp eph) {
+  sexp *data = sexp_fileno_cell(ctx, vec, sexp_fileno_fd(sexp_ephemeron_key(eph)));
+  if (data) *data = eph;
+  return data;
+}
+
+static void sexp_insert_fileno(sexp ctx, sexp fileno) {
+  sexp *data, *data2, tmp, vec = sexp_global(ctx, SEXP_G_FILE_DESCRIPTORS);
+  sexp_sint_t i, n2, n = sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_NUM_FILE_DESCRIPTORS));
+  if (!sexp_vectorp(vec)) {
+    vec = sexp_global(ctx, SEXP_G_FILE_DESCRIPTORS)
+        = sexp_make_vector(ctx, sexp_make_fixnum(128), SEXP_FALSE);
+  } else if (n >= sexp_vector_length(vec)) {
+    data = sexp_vector_data(vec);
+    for (i = n2 = 0; i < sexp_vector_length(vec); i++)
+      if (sexp_ephemeronp(data[i]) && !sexp_brokenp(data[i]))
+        n2++;
+    if (n2 * 2 >= n)
+      n2 = n * 2;
+    tmp = sexp_global(ctx, SEXP_G_FILE_DESCRIPTORS)
+        = sexp_make_vector(ctx, sexp_make_fixnum(n2), SEXP_FALSE);
+    data2 = sexp_vector_data(tmp);
+    for (i = n = 0; i < sexp_vector_length(vec); i++)
+      if (sexp_ephemeronp(data[i]) && !sexp_brokenp(data[i])
+          && sexp_insert_fileno_ephemeron(ctx, tmp, data[i]))
+        n++;
+    vec = tmp;
+  }
+  if (sexp_insert_fileno_ephemeron(ctx, sexp_global(ctx, SEXP_G_FILE_DESCRIPTORS), sexp_make_ephemeron(ctx, fileno, SEXP_FALSE)))
+    n++;
+  sexp_global(ctx, SEXP_G_NUM_FILE_DESCRIPTORS) = sexp_make_fixnum(n);
+}
+#endif
+
+sexp sexp_make_fileno_op (sexp ctx, sexp self, sexp_sint_t n, sexp fd, sexp no_closep) {
+  sexp_gc_var1(res);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, fd);
+  if (sexp_unbox_fixnum(fd) < 0) return SEXP_FALSE;
+#if SEXP_USE_WEAK_REFERENCES
+  res = sexp_lookup_fileno(ctx, sexp_unbox_fixnum(fd));
+  if (sexp_filenop(res)) {
+    sexp_fileno_no_closep(res) = sexp_truep(no_closep);
+    sexp_fileno_openp(res) = 1;  /* not necessarily */
+    return res;
+  }
+#endif
+  sexp_gc_preserve1(ctx, res);
+  res = sexp_alloc_type(ctx, fileno, SEXP_FILENO);
+  if (!sexp_exceptionp(res)) {
+    sexp_fileno_fd(res) = sexp_unbox_fixnum(fd);
+    sexp_fileno_openp(res) = 1;
+    sexp_fileno_no_closep(res) = sexp_truep(no_closep);
+#if SEXP_USE_WEAK_REFERENCES
+    sexp_insert_fileno(ctx, res);
+#endif
+  }
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) {
+  sexp p = sexp_alloc_type(ctx, port, SEXP_IPORT);
+  if (sexp_exceptionp(p)) return p;
+  sexp_port_stream(p) = in;
+  sexp_port_name(p) = name;
+  sexp_port_line(p) = 1;
+  sexp_port_flags(p) = SEXP_PORT_UNKNOWN_FLAGS;
+  sexp_port_buf(p) = NULL;
+  sexp_port_fd(p) = SEXP_FALSE;
+  sexp_port_openp(p) = 1;
+  sexp_port_bidirp(p) = 0;
+  sexp_port_binaryp(p) = 1;
+  sexp_port_shutdownp(p) = 0;
+  sexp_port_no_closep(p) = 0;
+  sexp_port_sourcep(p) = 0;
+  sexp_port_blockedp(p) = 0;
+#if SEXP_USE_FOLD_CASE_SYMS
+  sexp_port_fold_casep(p) = sexp_truep(sexp_global(ctx, SEXP_G_FOLD_CASE_P));
+#endif
+#if SEXP_USE_WEAK_REFERENCES
+  /* if the fd was previously opened by a non-stream port, preserve it */
+  /* here to avoid gc timing issues */
+  if (in && fileno(in) >= 0) {
+    sexp_port_fd(p) = sexp_lookup_fileno(ctx, fileno(in));
+    if (sexp_filenop(sexp_port_fd(p)))
+      sexp_fileno_openp(sexp_port_fd(p)) = 1;
+  }
+#endif
+  sexp_port_cookie(p) = SEXP_VOID;
+  return p;
+}
+
+sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) {
+  sexp p = sexp_make_input_port(ctx, out, name);
+  if (sexp_exceptionp(p)) return p;
+  sexp_pointer_tag(p) = SEXP_OPORT;
+  return p;
+}
+
+sexp sexp_make_non_null_input_port (sexp ctx, FILE* in, sexp name) {
+  if (!in) return sexp_user_exception(ctx, SEXP_FALSE, "null input-port", name);
+  return sexp_make_input_port(ctx, in, name);
+}
+
+sexp sexp_make_non_null_output_port (sexp ctx, FILE* out, sexp name) {
+  if (!out) return sexp_user_exception(ctx, SEXP_FALSE, "null output-port", name);
+  return sexp_make_output_port(ctx, out, name);
+}
+
+#if SEXP_USE_BIDIRECTIONAL_PORTS
+sexp sexp_make_non_null_input_output_port (sexp ctx, FILE* io, sexp name) {
+  sexp res;
+  if (!io) return sexp_user_exception(ctx, SEXP_FALSE, "null input-output-port", name);
+  res = sexp_make_input_port(ctx, io, name);
+  if (sexp_portp(res)) sexp_port_bidirp(res) = 1;
+  return res;
+}
+#else
+#define sexp_make_non_null_input_output_port sexp_make_non_null_input_port
+#endif
+
+sexp sexp_port_outputp_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj) {
+  return sexp_make_boolean(sexp_oportp(obj));
+}
+
+sexp sexp_port_binaryp_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj) {
+  return sexp_make_boolean(sexp_portp(obj) && sexp_port_binaryp(obj));
+}
+
+sexp sexp_port_openp_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj) {
+  return sexp_make_boolean(sexp_portp(obj) && sexp_port_openp(obj));
+}
+
+#if SEXP_USE_FOLD_CASE_SYMS
+sexp sexp_get_port_fold_case (sexp ctx, sexp self, sexp_sint_t n, sexp in) {
+  sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in);
+  return sexp_make_boolean(sexp_port_fold_casep(in));
+}
+sexp sexp_set_port_fold_case (sexp ctx, sexp self, sexp_sint_t n, sexp in, sexp x) {
+  sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in);
+  sexp_assert_type(ctx, sexp_booleanp, SEXP_BOOLEAN, x);
+  sexp_port_fold_casep(in) = sexp_truep(x);
+  return SEXP_VOID;
+}
+#endif
+
+#if SEXP_USE_GREEN_THREADS
+int sexp_maybe_block_port (sexp ctx, sexp in, int forcep) {
+  sexp f;
+  int c;
+  if ((sexp_port_stream(in) || sexp_filenop(sexp_port_fd(in)))
+      && sexp_port_fileno(in) >= 0) {
+    if (sexp_port_flags(in) == SEXP_PORT_UNKNOWN_FLAGS)
+      sexp_port_flags(in) = fcntl(sexp_port_fileno(in), F_GETFL);
+    if (sexp_port_flags(in) & O_NONBLOCK) {
+      if (!forcep
+          && (((c = sexp_read_char(ctx, in)) == EOF)
+              && sexp_port_stream(in)
+              && (sexp_port_stream(in) ? ferror(sexp_port_stream(in)) : 1)
+              && (errno == EAGAIN))) {
+        if (sexp_port_stream(in))
+          clearerr(sexp_port_stream(in));
+        f = sexp_global(ctx, SEXP_G_THREADS_BLOCKER);
+        if (sexp_applicablep(f)) {
+          sexp_apply2(ctx, f, in, SEXP_FALSE);
+          return 1;
+        }
+      }
+      if (!forcep) sexp_push_char(ctx, c, in);
+      sexp_port_blockedp(in) = 1;
+      fcntl(sexp_port_fileno(in), F_SETFL, sexp_port_flags(in) & ~O_NONBLOCK);
+    }
+  }
+  return 0;
+}
+
+int sexp_maybe_block_output_port (sexp ctx, sexp out) {
+  if (sexp_port_stream(out) && sexp_port_fileno(out) >= 0) {
+    if (sexp_port_flags(out) == SEXP_PORT_UNKNOWN_FLAGS)
+      sexp_port_flags(out) = fcntl(sexp_port_fileno(out), F_GETFL);
+    if (sexp_port_flags(out) & O_NONBLOCK) {
+      sexp_port_blockedp(out) = 1;
+      fcntl(sexp_port_fileno(out), F_SETFL, sexp_port_flags(out) & ~O_NONBLOCK);
+      return 1;
+    }
+  }
+  return 0;
+}
+
+void sexp_maybe_unblock_port (sexp ctx, sexp port) {
+  if (sexp_port_blockedp(port)) {
+    sexp_port_blockedp(port) = 0;
+    fcntl(sexp_port_fileno(port), F_SETFL, sexp_port_flags(port));
+  }
+}
+#endif
+
+#if SEXP_USE_GREEN_THREADS
+static int sexp_fileno_ready_p (int fd) {
+  struct pollfd pfd;
+  if (fd < 0) return 0;
+  pfd.fd = fd;
+  pfd.events = POLLIN;
+  return poll(&pfd, 1, 0) == 1;
+}
+
+static int sexp_stream_ready_p (FILE* in) {
+  int flags = fcntl(fileno(in), F_GETFL), res;
+  if (! (flags & O_NONBLOCK)) fcntl(fileno(in), F_SETFL, flags & O_NONBLOCK);
+  res = getc(in);
+  if (! (flags & O_NONBLOCK)) fcntl(fileno(in), F_SETFL, flags);
+  if (res == EOF || ferror(in)) {
+    clearerr(in);
+    return 0;
+  }
+  ungetc(res, in);
+  return 1;
+}
+#endif
+
+sexp sexp_char_ready_p (sexp ctx, sexp self, sexp_sint_t n, sexp in) {
+  sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in);
+  if (!sexp_port_openp(in))
+    return SEXP_FALSE;
+#if !SEXP_USE_STRING_STREAMS
+  if (sexp_port_buf(in))
+    if (sexp_port_offset(in) < sexp_port_size(in)
+        || (!sexp_filenop(sexp_port_fd(in)) && !sexp_port_stream(in)))
+      return SEXP_TRUE;
+#endif
+#if SEXP_USE_GREEN_THREADS     /* maybe not just when threads are enabled */
+  if (sexp_filenop(sexp_port_fd(in)))
+    return sexp_make_boolean(sexp_fileno_ready_p(sexp_port_fileno(in)));
+  else if (sexp_port_stream(in))
+    return sexp_make_boolean(sexp_stream_ready_p(sexp_port_stream(in)));
+#endif
+  /* for custom ports and unthreaded compiles we just return true for now */
+  return SEXP_TRUE;
+}
+
+#define NUMBUF_LEN 32
+
+static struct {const char* name; char ch;} sexp_char_names[] = {
+  {"newline", '\n'},
+  {"return", '\r'},
+  {"space", ' '},
+  {"tab", '\t'},
+#if SEXP_USE_EXTENDED_CHAR_NAMES
+  {"alarm", '\a'},
+  {"backspace", '\b'},
+  {"delete", 127},
+  {"escape", '\e'},
+  {"null", 0},
+#endif
+};
+
+#define sexp_num_char_names (sizeof(sexp_char_names)/sizeof(sexp_char_names[0]))
+
+sexp sexp_apply_writer(sexp ctx, sexp writer, sexp obj, sexp out) {
+  sexp res;
+  sexp_gc_var1(args);
+  sexp_gc_preserve1(ctx, args);
+  args = sexp_list2(ctx, NULL, out);
+  args = sexp_cons(ctx, obj, args);
+  res = sexp_apply(ctx, writer, args);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_write_one (sexp ctx, sexp obj, sexp out) {
+#if SEXP_USE_HUFF_SYMS
+  unsigned long res;
+#endif
+  unsigned long len, c;
+  long i=0;
+#if SEXP_USE_FLONUMS
+  double f;
+#endif
+  sexp x, *elts;
+  char *str=NULL, numbuf[NUMBUF_LEN];
+
+  if (! obj) {
+    sexp_write_string(ctx, "#<null>", out); /* shouldn't happen */
+  } else if (sexp_pointerp(obj)) {
+    switch (sexp_pointer_tag(obj)) {
+    case SEXP_PAIR:
+      sexp_write_char(ctx, '(', out);
+      sexp_write_one(ctx, sexp_car(obj), out);
+      for (x=sexp_cdr(obj); sexp_pairp(x); x=sexp_cdr(x)) {
+        sexp_write_char(ctx, ' ', out);
+        sexp_write_one(ctx, sexp_car(x), out);
+      }
+      if (! sexp_nullp(x)) {
+        sexp_write_string(ctx, " . ", out);
+        sexp_write_one(ctx, x, out);
+      }
+      sexp_write_char(ctx, ')', out);
+      break;
+    case SEXP_VECTOR:
+      len = sexp_vector_length(obj);
+      elts = sexp_vector_data(obj);
+      if (len == 0) {
+        sexp_write_string(ctx, "#()", out);
+      } else {
+        sexp_write_string(ctx, "#(", out);
+        sexp_write_one(ctx, elts[0], out);
+        for (i=1; i<len; i++) {
+          sexp_write_char(ctx, ' ', out);
+          sexp_write_one(ctx, elts[i], out);
+        }
+        sexp_write_char(ctx, ')', out);
+      }
+      break;
+#if SEXP_USE_FLONUMS
+#if ! SEXP_USE_IMMEDIATE_FLONUMS
+    case SEXP_FLONUM:
+      f = sexp_flonum_value(obj);
+#if SEXP_USE_INFINITIES
+      if (isinf(f) || isnan(f)) {
+        numbuf[0] = (isinf(f) && f < 0 ? '-' : '+');
+        strcpy(numbuf+1, isinf(f) ? "inf.0" : "nan.0");
+      } else
+#endif
+      {
+        i = snprintf(numbuf, NUMBUF_LEN, "%.15g", f);
+        if (!strchr(numbuf, '.') && !strchr(numbuf, 'e')) {
+          numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0';
+        }
+      }
+      sexp_write_string(ctx, numbuf, out);
+      break;
+#endif
+#endif
+    case SEXP_PROCEDURE:
+      sexp_write_string(ctx, "#<procedure ", out);
+      x = sexp_bytecode_name(sexp_procedure_code(obj));
+      sexp_write_one(ctx, sexp_synclop(x) ? sexp_synclo_expr(x): x, out);
+#if SEXP_USE_DEBUG_VM
+      if (sexp_procedure_source(obj)) {
+        sexp_write_string(ctx, " ", out);
+        sexp_write(ctx, sexp_procedure_source(obj), out);
+      }
+#endif
+      sexp_write_string(ctx, ">", out);
+      break;
+    case SEXP_TYPE:
+      sexp_write_string(ctx, "#<type ", out);
+      sexp_write(ctx, sexp_type_name(obj), out);
+      sexp_write_string(ctx, ">", out);
+      break;
+#if 0
+    case SEXP_ENV:
+      sexp_write_string(ctx, "#<Env ", out);
+      sexp_write(ctx, sexp_make_fixnum(obj), out);
+      sexp_write_string(ctx, " ", out);
+      sexp_write(ctx, sexp_make_fixnum(sexp_env_bindings(obj)), out);
+      sexp_write_string(ctx, " (", out);
+      sexp_write(ctx, sexp_length(ctx, sexp_env_bindings(obj)), out);
+      sexp_write_string(ctx, ")", out);
+      if (sexp_env_parent(obj)) {
+        sexp_write_string(ctx, " ", out);
+        sexp_write(ctx, sexp_env_parent(obj), out);
+      }
+      sexp_write_string(ctx, ">", out);
+      break;
+#endif
+    case SEXP_STRING:
+      sexp_write_char(ctx, '"', out);
+      i = sexp_string_size(obj);
+      str = sexp_string_data(obj);
+      for ( ; i>0; str++, i--) {
+        switch (str[0]) {
+        case '\\': sexp_write_string(ctx, "\\\\", out); break;
+        case '"': sexp_write_string(ctx, "\\\"", out); break;
+        case '\a': sexp_write_string(ctx, "\\a", out); break;
+        case '\b': sexp_write_string(ctx, "\\b", out); break;
+        case '\n': sexp_write_string(ctx, "\\n", out); break;
+        case '\r': sexp_write_string(ctx, "\\r", out); break;
+        case '\t': sexp_write_string(ctx, "\\t", out); break;
+        default:
+          if (str[0] < ' ' && str[0] >= 0) {
+            sexp_write_string(ctx, "\\x", out);
+            sexp_write_char(ctx, hex_digit(str[0]>>4), out);
+            sexp_write_char(ctx, hex_digit(str[0]&0x0F), out);
+            sexp_write_char(ctx, ';', out);
+          } else {
+            sexp_write_char(ctx, str[0], out);
+          }
+        }
+      }
+      sexp_write_char(ctx, '"', out);
+      break;
+    case SEXP_SYMBOL:
+      str = sexp_lsymbol_data(obj);
+      c = sexp_lsymbol_length(obj) > 0 ? EOF : '|';
+      for (i=sexp_lsymbol_length(obj)-1; i>=0; i--)
+        if (str[i] <= ' ' || str[i] == '\\' || sexp_is_separator(str[i])) c = '|';
+      if (c!=EOF) sexp_write_char(ctx, c, out);
+      for (i=sexp_lsymbol_length(obj); i>0; str++, i--) {
+        if (str[0] == '\\') sexp_write_char(ctx, '\\', out);
+        sexp_write_char(ctx, str[0], out);
+      }
+      if (c!=EOF) sexp_write_char(ctx, c, out);
+      break;
+#if SEXP_USE_BIGNUMS
+    case SEXP_BIGNUM:
+      sexp_write_bignum(ctx, obj, out, 10);
+      break;
+#endif
+#if SEXP_USE_RATIOS
+    case SEXP_RATIO:
+      sexp_write(ctx, sexp_ratio_numerator(obj), out);
+      sexp_write_char(ctx, '/', out);
+      sexp_write(ctx, sexp_ratio_denominator(obj), out);
+      break;
+#endif
+#if SEXP_USE_COMPLEX
+    case SEXP_COMPLEX:
+      sexp_write(ctx, sexp_complex_real(obj), out);
+      if (!sexp_negativep(sexp_complex_imag(obj))
+          && !sexp_infp(sexp_complex_imag(obj)))
+        sexp_write_char(ctx, '+', out);
+      if (sexp_complex_imag(obj) == SEXP_NEG_ONE)
+        sexp_write_char(ctx, '-', out);
+      else if (sexp_complex_imag(obj) != SEXP_ONE)
+        sexp_write(ctx, sexp_complex_imag(obj), out);
+      sexp_write_char(ctx, 'i', out);
+      break;
+#endif
+    case SEXP_OPCODE:
+      sexp_write_string(ctx, "#<opcode ", out);
+      sexp_write(ctx, sexp_opcode_name(obj), out);
+      sexp_write_char(ctx, '>', out);
+      break;
+#if SEXP_USE_BYTEVECTOR_LITERALS
+    case SEXP_BYTES:
+      sexp_write_string(ctx, "#u8(", out);
+      str = sexp_bytes_data(obj);
+      len = sexp_bytes_length(obj);
+      for (i=0; i<len; i++) {
+        if (i!=0) sexp_write_char(ctx, ' ', out);
+        sexp_write(ctx, sexp_make_fixnum(((unsigned char*)str)[i]), out);
+      }
+      sexp_write_char(ctx, ')', out);
+      break;
+#endif
+    case SEXP_FILENO:
+      sexp_write_string(ctx, "#<fileno ", out);
+      sexp_write(ctx, sexp_make_fixnum(sexp_fileno_fd(obj)), out);
+      sexp_write_char(ctx, '>', out);
+      break;
+    case SEXP_SYNCLO:
+      sexp_write_string(ctx, "#<SC ", out);
+      sexp_write(ctx, sexp_make_fixnum(obj), out);
+      sexp_write_char(ctx, ' ', out);
+      sexp_write(ctx, sexp_synclo_expr(obj), out);
+      sexp_write_char(ctx, '>', out);
+      break;
+    default:
+      i = sexp_pointer_tag(obj);
+      if (i < 0 || i >= sexp_context_num_types(ctx)) {
+        sexp_write_string(ctx, "#<invalid type tag: ", out);
+        sexp_write(ctx, sexp_make_fixnum(i), out);
+        sexp_write_char(ctx, '>', out);
+      } else {
+        x = sexp_type_by_index(ctx, i);
+#if SEXP_USE_TYPE_PRINTERS
+        if (sexp_type_print(x)) {
+          x = sexp_apply_writer(ctx, sexp_type_print(x), obj, out);
+          if (sexp_exceptionp(x)) return x;
+        } else {
+#endif
+          sexp_write_string(ctx, "#<", out);
+          if (sexp_stringp(sexp_type_name(x)))
+            sexp_write_string(ctx, sexp_string_data(sexp_type_name(x)), out);
+          else
+            sexp_write(ctx, sexp_type_name(x), out);
+          sexp_write_char(ctx, ' ', out);
+          sexp_write(ctx, sexp_make_fixnum(obj), out);
+          sexp_write_char(ctx, '>', out);
+#if SEXP_USE_TYPE_PRINTERS
+        }
+#endif
+      }
+      break;
+    }
+  } else if (sexp_fixnump(obj)) {
+    snprintf(numbuf, NUMBUF_LEN, "%ld", (long)sexp_unbox_fixnum(obj));
+    sexp_write_string(ctx, numbuf, out);
+#if SEXP_USE_IMMEDIATE_FLONUMS
+  } else if (sexp_flonump(obj)) {
+    f = sexp_flonum_value(obj);
+#if SEXP_USE_INFINITIES
+    if (isinf(f) || isnan(f)) {
+      numbuf[0] = (isinf(f) && f < 0 ? '-' : '+');
+      strcpy(numbuf+1, isinf(f) ? "inf.0" : "nan.0");
+    } else
+#endif
+    {
+      i = snprintf(numbuf, NUMBUF_LEN, "%.8g", f);
+      if (f == trunc(f) && ! strchr(numbuf, '.')) {
+        numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0';
+      }
+    }
+    sexp_write_string(ctx, numbuf, out);
+#endif
+  } else if (sexp_charp(obj)) {
+    sexp_write_string(ctx, "#\\", out);
+    for (i=0; i < sexp_num_char_names; i++) {
+      if (sexp_unbox_character(obj) == sexp_char_names[i].ch) {
+        sexp_write_string(ctx, sexp_char_names[i].name, out);
+        break;
+      }
+    }
+    if (i >= sexp_num_char_names) {
+      if ((33 <= sexp_unbox_character(obj))
+          && (sexp_unbox_character(obj) < 127)) {
+        sexp_write_char(ctx, sexp_unbox_character(obj), out);
+      } else {
+        sexp_write_string(ctx, "x", out);
+        c = sexp_unbox_character(obj);
+        if (c >= 0x100) {
+          if (c >= 0x10000) {
+            sexp_write_char(ctx, hex_digit((c>>20)&0x0F), out);
+            sexp_write_char(ctx, hex_digit((c>>16)&0x0F), out);
+          }
+          sexp_write_char(ctx, hex_digit((c>>12)&0x0F), out);
+          sexp_write_char(ctx, hex_digit((c>>8)&0x0F), out);
+        }
+        sexp_write_char(ctx, hex_digit((c>>4)&0x0F), out);
+        sexp_write_char(ctx, hex_digit(c&0x0F), out);
+      }
+    }
+  } else if (sexp_symbolp(obj)) {
+
+#if SEXP_USE_HUFF_SYMS
+    if (sexp_isymbolp(obj)) {
+      c = ((sexp_uint_t)obj)>>3;
+      while (c) {
+#include "chibi/sexp-unhuff.h"
+        sexp_write_char(ctx, res, out);
+      }
+    }
+#endif
+
+  } else {
+    switch ((sexp_uint_t) obj) {
+    case (sexp_uint_t) SEXP_NULL:
+      sexp_write_string(ctx, "()", out); break;
+    case (sexp_uint_t) SEXP_TRUE:
+      sexp_write_string(ctx, "#t", out); break;
+    case (sexp_uint_t) SEXP_FALSE:
+      sexp_write_string(ctx, "#f", out); break;
+    case (sexp_uint_t) SEXP_EOF:
+      sexp_write_string(ctx, "#<eof>", out); break;
+    case (sexp_uint_t) SEXP_UNDEF:
+    case (sexp_uint_t) SEXP_VOID:
+      sexp_write_string(ctx, "#<undef>", out); break;
+    default:
+      sexp_write_string(ctx, "#<invalid immediate: ", out);
+      sexp_write(ctx, sexp_make_fixnum(obj), out);
+      sexp_write_char(ctx, '>', out);
+    }
+  }
+  return SEXP_VOID;
+}
+
+sexp sexp_write_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp out) {
+  sexp res;
+  sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out);
+#if SEXP_USE_GREEN_THREADS
+  sexp_maybe_block_output_port(ctx, out);
+#endif
+  res = sexp_write_one(ctx, obj, out);
+#if SEXP_USE_GREEN_THREADS
+  sexp_maybe_unblock_port(ctx, out);
+#endif
+  return res;
+}
+
+#if SEXP_USE_UTF8_STRINGS
+int sexp_write_utf8_char (sexp ctx, int c, sexp out) {
+  unsigned char buf[8];
+  int len = sexp_utf8_char_byte_count(c), i;
+  sexp_utf8_encode_char(buf, len, c);
+  buf[len] = 0;
+  i = sexp_write_char(ctx, buf[0], out);
+  if (i == EOF) return EOF;
+  sexp_write_string(ctx, (char*)buf+1, out);
+  return len;
+}
+#endif
+
+sexp sexp_flush_output_op (sexp ctx, sexp self, sexp_sint_t n, sexp out) {
+  int res;
+  sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out);
+  res = sexp_flush_forced(ctx, out);
+  if (res == EOF) {
+#if SEXP_USE_GREEN_THREADS
+    if (sexp_port_stream(out) && ferror(sexp_port_stream(out)) && (errno == EAGAIN))
+      return sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR);
+#endif
+    return SEXP_FALSE;
+  }
+  return SEXP_TRUE;
+}
+
+#define INIT_STRING_BUFFER_SIZE 128
+
+sexp sexp_read_string (sexp ctx, sexp in, int sentinel) {
+#if SEXP_USE_UTF8_STRINGS
+  int len;
+#endif
+  int c, i=0;
+  sexp_sint_t size=INIT_STRING_BUFFER_SIZE;
+  char initbuf[INIT_STRING_BUFFER_SIZE];
+  char *buf=initbuf, *tmp;
+  sexp res = SEXP_FALSE;
+
+  for (c = sexp_read_char(ctx, in); c != sentinel; c = sexp_read_char(ctx, in)) {
+    if (c == '\\') {
+      c = sexp_read_char(ctx, in);
+      switch (c) {
+      case 'a': c = '\a'; break;
+      case 'b': c = '\b'; break;
+      case 'n': c = '\n'; break;
+      case 'r': c = '\r'; break; 
+      case 't': c = '\t'; break;
+      case 'x':
+        res = sexp_read_number(ctx, in, 16, 0);
+        if (sexp_fixnump(res)) {
+          c = sexp_read_char(ctx, in);
+          if (c != ';') {
+#if SEXP_USE_ESCAPE_REQUIRES_TRAILING_SEMI_COLON
+            res = sexp_read_error(ctx, "missing ; in \\x escape", SEXP_NULL, in);
+#else
+            sexp_push_char(ctx, c, in);
+#endif
+          }
+          c = sexp_unbox_fixnum(res);
+#if SEXP_USE_UTF8_STRINGS
+          if ((unsigned)c > 0x80) {
+            len = sexp_utf8_char_byte_count(c);
+            sexp_utf8_encode_char((unsigned char*)buf + i, len, c);
+            i += len;
+            goto maybe_expand;
+          }
+#endif
+        }
+        break;
+#if SEXP_USE_ESCAPE_NEWLINE
+      default:
+        if (isspace(c)) {
+          while (c==' ' || c=='\t') c=sexp_read_char(ctx, in);
+          if (c=='\r') c=sexp_read_char(ctx, in);
+          if (c=='\n') {
+            sexp_port_line(in)++;
+            do {c=sexp_read_char(ctx, in);} while (c==' ' || c=='\t');
+          }
+        }
+#endif
+      }
+      if (sexp_exceptionp(res)) break;
+    } else if (c == '\n') {
+      sexp_port_line(in)++;
+    } else if (c == EOF) {
+      res = sexp_read_error(ctx, "premature end of string", SEXP_NULL, in);
+      break;
+    }
+    buf[i++] = c;
+  maybe_expand:
+    if (i+4 >= size) {       /* expand buffer w/ malloc(), later free() it */
+      tmp = (char*) sexp_malloc(size*2);
+      if (!tmp) {res = sexp_global(ctx, SEXP_G_OOM_ERROR); break;}
+      memcpy(tmp, buf, i);
+      if (size != INIT_STRING_BUFFER_SIZE) free(buf);
+      buf = tmp;
+      size *= 2;
+    }
+  }
+
+  if (!sexp_exceptionp(res)) {
+    buf[i] = '\0';
+    res = sexp_c_string(ctx, buf, i);
+  }
+  if (size != INIT_STRING_BUFFER_SIZE) free(buf);
+  return res;
+}
+
+sexp sexp_read_symbol (sexp ctx, sexp in, int init, int internp) {
+  int c, i=0, size=INIT_STRING_BUFFER_SIZE;
+  char initbuf[INIT_STRING_BUFFER_SIZE];
+  char *buf=initbuf, *tmp;
+  sexp res=SEXP_VOID;
+#if SEXP_USE_FOLD_CASE_SYMS
+  int foldp = sexp_port_fold_casep(in);
+  init = (foldp ? sexp_tolower(init) : init);
+#endif
+
+  if (init != EOF)
+    buf[i++] = init;
+
+  for (c = sexp_read_char(ctx, in); ; c = sexp_read_char(ctx, in)) {
+#if SEXP_USE_FOLD_CASE_SYMS
+    if (foldp) c = sexp_tolower(c);
+#endif
+    if (c == '\\') c = sexp_read_char(ctx, in);
+    if (c == EOF || sexp_is_separator(c)) {
+      sexp_push_char(ctx, c, in);
+      break;
+    }
+    buf[i++] = c;
+    if (i >= size) {       /* expand buffer w/ malloc(), later free() it */
+      tmp = (char*) sexp_malloc(size*2);
+      if (!tmp) {res = sexp_global(ctx, SEXP_G_OOM_ERROR); break;}
+      memcpy(tmp, buf, i);
+      if (size != INIT_STRING_BUFFER_SIZE) free(buf);
+      buf = tmp;
+      size *= 2;
+    }
+  }
+
+  if (!sexp_exceptionp(res)) {
+    buf[i] = '\0';
+    res = (internp ? sexp_intern(ctx, buf, i) : sexp_c_string(ctx, buf, i));
+  }
+  if (size != INIT_STRING_BUFFER_SIZE) free(buf);
+  return res;
+}
+
+#if SEXP_USE_COMPLEX
+sexp sexp_make_complex (sexp ctx, sexp real, sexp image) {
+  sexp res = sexp_alloc_type(ctx, complex, SEXP_COMPLEX);
+  sexp_complex_real(res) = real;
+  sexp_complex_imag(res) = image;
+  return res;
+}
+
+sexp sexp_complex_normalize (sexp cpx) {
+  return sexp_complexp(cpx)
+    && (sexp_complex_imag(cpx) == SEXP_ZERO
+        /* Only normalize for an exact zero imaginary part.  */
+        /* || (sexp_flonump(sexp_complex_imag(cpx)) */
+        /*     && sexp_flonum_value(sexp_complex_imag(cpx)) == 0.0) */
+        )
+    ? sexp_complex_real(cpx) : cpx;
+}
+
+sexp sexp_read_complex_tail (sexp ctx, sexp in, sexp real) {
+  int c = sexp_read_char(ctx, in), c2;
+  sexp default_real = SEXP_ZERO;
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  res = SEXP_VOID;
+  if (c=='i' || c=='I') {       /* trailing i, no sign */
+  trailing_i:
+    c = sexp_read_char(ctx, in);
+    if (c=='n' || c=='N') {
+      res = sexp_read_symbol(ctx, in, c, 1);
+      if (res == sexp_intern(ctx, "nf.0i", -1))
+        real = res = sexp_make_flonum(ctx, real == SEXP_ONE ? sexp_pos_infinity : sexp_neg_infinity);
+      else
+        goto invalid;
+    } else if ((c!=EOF) && ! sexp_is_separator(c)) {
+    invalid:
+      res = sexp_read_error(ctx, "invalid complex numeric syntax", sexp_make_character(c), in);
+    } else
+      sexp_push_char(ctx, c, in);
+    if (!sexp_exceptionp(res))
+      res = sexp_make_complex(ctx, default_real, real);  /* NNNNi has 0 real */
+  } else {                      /* trailing + or - */
+    c2 = sexp_read_char(ctx, in);
+    if (c2=='i' || c2=='I') {
+      default_real = real;
+      real = (c=='-') ? SEXP_NEG_ONE : SEXP_ONE;
+      goto trailing_i;
+    } else {
+      sexp_push_char(ctx, c2, in);
+      /* read imaginary part */
+      if (c=='-') sexp_push_char(ctx, c, in);
+      res = sexp_read_number(ctx, in, 10, 0);
+      if (sexp_complexp(res)) {
+        if (sexp_complex_real(res) == SEXP_ZERO)
+          sexp_complex_real(res) = real;
+        else
+          res = sexp_read_error(ctx, "multiple real parts of complex", res, in);
+      } else if ((res == SEXP_ZERO)
+                 || (sexp_flonump(res) && sexp_flonum_value(res) == 0.0)) {
+        res = sexp_make_complex(ctx, real, res);
+      } else {                    /* found trailing +/-NNNN with no i */
+        res = sexp_exceptionp(res) ? res
+          : sexp_read_error(ctx, "missing imaginary part of complex", res, in);
+      }
+    }
+  }
+  sexp_gc_release1(ctx);
+  return sexp_complex_normalize(res);
+}
+
+#if SEXP_USE_MATH
+sexp sexp_read_polar_tail (sexp ctx, sexp in, sexp magnitude) {
+  sexp_gc_var2(res, theta);
+  sexp_gc_preserve2(ctx, res, theta);
+  theta = sexp_read_number(ctx, in, 10, 0);
+  if (sexp_exceptionp(theta)) {
+    res = theta;
+  } else if (sexp_complexp(theta) || !sexp_numberp(theta)) {
+    res = sexp_read_error(ctx, "invalid polar numeric syntax", theta, in);
+  } else {
+    res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
+    sexp_complex_real(res) = sexp_cos(ctx, NULL, 1, theta);
+    sexp_complex_real(res) = sexp_mul(ctx, magnitude, sexp_complex_real(res));
+    sexp_complex_imag(res) = sexp_sin(ctx, NULL, 1, theta);
+    sexp_complex_imag(res) = sexp_mul(ctx, magnitude, sexp_complex_imag(res));
+  }
+  sexp_gc_release2(ctx);
+  return sexp_complex_normalize(res);
+}
+#endif
+#endif
+
+sexp sexp_read_float_tail (sexp ctx, sexp in, double whole, int negp) {
+  int c, c2;
+  sexp exponent=SEXP_VOID;
+  double val=0.0, scale=0.1, e=0.0;
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  for (c=sexp_read_char(ctx, in); sexp_isdigit(c);
+       c=sexp_read_char(ctx, in), scale*=0.1)
+    val += digit_value(c)*scale;
+#if SEXP_USE_PLACEHOLDER_DIGITS
+  for (; c==SEXP_PLACEHOLDER_DIGIT; c=sexp_read_char(ctx, in), scale*=0.1)
+    val += sexp_placeholder_digit_value(10)*scale;
+#endif
+  val += whole;
+  if (negp) val *= -1;
+  if (is_precision_indicator(c)) {
+    c2 = sexp_read_char(ctx, in);
+    if (c2 != '+') sexp_push_char(ctx, c2, in);
+    exponent = sexp_read_number(ctx, in, 10, 0);
+    if (sexp_exceptionp(exponent)) {
+      sexp_gc_release1(ctx);
+      return exponent;
+    }
+#if SEXP_USE_COMPLEX
+    if (sexp_complexp(exponent)) {
+      res = exponent;
+      exponent = (sexp_complex_real(res) == SEXP_ZERO ? sexp_complex_imag(res) : sexp_complex_real(res));
+    }
+#endif
+    e = (sexp_fixnump(exponent) ? sexp_unbox_fixnum(exponent)
+         : sexp_flonump(exponent) ? sexp_flonum_value(exponent) : 0.0);
+#if SEXP_USE_COMPLEX
+    if (sexp_complexp(res)) {
+      if (sexp_complex_real(res) == SEXP_ZERO) {
+        sexp_complex_imag(res) = sexp_make_flonum(ctx, val * pow(10, e));
+      } else {
+        sexp_complex_real(res) = sexp_make_flonum(ctx, val * pow(10, e));
+      }
+      sexp_gc_release1(ctx);
+      return res;
+    }
+#endif
+  }
+  if (e != 0.0) val *= pow(10, e);
+#if SEXP_USE_FLONUMS
+  res = sexp_make_flonum(ctx, val);
+#else
+  res = sexp_make_fixnum((sexp_uint_t)val);
+#endif
+  if (!is_precision_indicator(c)) {
+#if SEXP_USE_COMPLEX
+    if (c=='i' || c=='i' || c=='+' || c=='-') {
+      sexp_push_char(ctx, c, in);
+      res = sexp_read_complex_tail(ctx, in, res);
+    } else
+#endif
+    if ((c!=EOF) && ! sexp_is_separator(c))
+      res = sexp_read_error(ctx, "invalid numeric syntax",
+                            sexp_make_character(c), in);
+    else
+      sexp_push_char(ctx, c, in);
+  }
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+#if SEXP_USE_RATIOS
+sexp sexp_make_ratio (sexp ctx, sexp num, sexp den) {
+  sexp res = sexp_alloc_type(ctx, ratio, SEXP_RATIO);
+  sexp_ratio_numerator(res) = num;
+  sexp_ratio_denominator(res) = den;
+  return res;
+}
+
+sexp sexp_ratio_normalize (sexp ctx, sexp rat, sexp in) {
+  sexp tmp;
+  sexp_gc_var2(num, den);
+  num = sexp_ratio_numerator(rat), den = sexp_ratio_denominator(rat);
+  if (den == SEXP_ZERO)
+    return sexp_read_error(ctx, "zero denominator in ratio", rat, in);
+  else if (num == SEXP_ZERO)
+    return SEXP_ZERO;
+  sexp_gc_preserve2(ctx, num, den);
+  while (den != SEXP_ZERO) {
+    tmp = sexp_remainder(ctx, num, den);
+    if (sexp_exceptionp(tmp)) {
+      sexp_gc_release2(ctx);
+      return tmp;
+    }
+    num = den, den = tmp;
+  }
+  sexp_ratio_denominator(rat)
+    = den = sexp_quotient(ctx, sexp_ratio_denominator(rat), num);
+  sexp_ratio_numerator(rat)
+    = sexp_quotient(ctx, sexp_ratio_numerator(rat), num);
+  if (sexp_exact_negativep(sexp_ratio_denominator(rat))) {
+    sexp_negate(sexp_ratio_numerator(rat));
+    sexp_negate(sexp_ratio_denominator(rat));
+  }
+  sexp_ratio_numerator(rat) = sexp_bignum_normalize(sexp_ratio_numerator(rat));
+  sexp_ratio_denominator(rat) = sexp_bignum_normalize(sexp_ratio_denominator(rat));
+  sexp_gc_release2(ctx);
+  return (sexp_ratio_denominator(rat) == SEXP_ONE) ? sexp_ratio_numerator(rat)
+    : rat;
+}
+#endif
+
+sexp sexp_read_number (sexp ctx, sexp in, int base, int exactp) {
+  sexp_sint_t val = 0, tmp = -1;
+  int c, digit, negativep = 0;
+#if SEXP_USE_PLACEHOLDER_DIGITS
+  double whole = 0.0, scale = 0.1;
+#endif
+  sexp_gc_var2(res, den);
+
+  c = sexp_read_char(ctx, in);
+  if (c == '#') {
+    switch ((c = sexp_tolower(sexp_read_char(ctx, in)))) {
+      case 'b': base = 2; break;   case 'o': base = 8; break;
+      case 'd': base = 10; break;  case 'x': base = 16; break;
+      case 'i': exactp = 0; break; case 'e': exactp = 1; break;
+      default: return sexp_read_error(ctx, "unexpected numeric # code", sexp_make_character(c), in);
+    }
+    c = sexp_read_char(ctx, in);
+  }
+  if (c == '-') {
+    negativep = 1;
+    c = sexp_read_char(ctx, in);
+  }
+
+#if SEXP_USE_COMPLEX
+  if (c == 'i' || c == 'I') val = 1;
+#endif
+
+  for ( ; sexp_isxdigit(c); c=sexp_read_char(ctx, in)) {
+    digit = digit_value(c);
+    if ((digit < 0) || (digit >= base))
+      break;
+    tmp = val * base + digit;
+#if SEXP_USE_BIGNUMS
+    if ((SEXP_MAX_FIXNUM / base < val) ||
+        (tmp < val) || (tmp > SEXP_MAX_FIXNUM)) {
+      sexp_push_char(ctx, c, in);
+      return sexp_read_bignum(ctx, in, val, (negativep ? -1 : 1), base);
+    }
+#endif
+    val = tmp;
+  }
+
+#if SEXP_USE_PLACEHOLDER_DIGITS
+  if (sexp_placeholder_digit_p(c) && tmp >= 0) {
+    whole = val;
+    for ( ; sexp_placeholder_digit_p(c); c=sexp_read_char(ctx, in))
+      whole = whole*10 + sexp_placeholder_digit_value(base);
+    if ((c=='.' || is_precision_indicator(c)) && (base != 10))
+      return sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in);
+    if (c=='.')
+      for (c=sexp_read_char(ctx, in); sexp_placeholder_digit_p(c);
+           c=sexp_read_char(ctx, in), scale*=0.1)
+        whole += sexp_placeholder_digit_value(10)*scale;
+    if (is_precision_indicator(c)) {
+      sexp_push_char(ctx, c, in);
+      return sexp_read_float_tail(ctx, in, whole, negativep);
+    } else if ((c!=EOF) && !sexp_is_separator(c)) {
+      return sexp_read_error(ctx, "invalid numeric syntax after placeholders",
+                             sexp_make_character(c), in);
+    }
+    sexp_push_char(ctx, c, in);
+    return sexp_make_flonum(ctx, (negativep ? -whole : whole));
+  }
+#endif
+
+  if (exactp && is_precision_indicator(c)) {
+    sexp_gc_preserve2(ctx, res, den);
+    res = sexp_make_fixnum(negativep ? -val : val);
+    den = sexp_read_number(ctx, in, base, 0);
+    if (sexp_flonump(den)) den = sexp_make_fixnum(sexp_flonum_value(den));
+    den = sexp_expt(ctx, SEXP_TEN, den);
+    res = sexp_mul(ctx, res, den);
+    sexp_gc_release2(ctx);
+    return res;
+  } else if (c=='.' || is_precision_indicator(c)) {
+    if (base != 10)
+      return sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in);
+    if (c!='.') sexp_push_char(ctx, c, in);
+    return sexp_read_float_tail(ctx, in, val, negativep);
+  } else if (c=='/') {
+    sexp_gc_preserve2(ctx, res, den);
+    den = sexp_read_number(ctx, in, base, exactp);
+    if (! (sexp_fixnump(den) || sexp_bignump(den) || sexp_complexp(den)))
+      res = (sexp_exceptionp(den)
+             ? den : sexp_read_error(ctx, "invalid rational syntax", den, in));
+    else {
+#if SEXP_USE_RATIOS
+#if SEXP_USE_COMPLEX
+    if (sexp_complexp(den)) {
+      res = sexp_make_fixnum(negativep ? -val : val);
+      if (sexp_complex_real(den) == SEXP_ZERO) {
+        res = sexp_make_ratio(ctx, res, sexp_complex_imag(den));
+        res = sexp_ratio_normalize(ctx, res, in);
+        sexp_complex_imag(den) = res;
+      } else {
+        res = sexp_make_ratio(ctx, res, sexp_complex_real(den));
+        res = sexp_ratio_normalize(ctx, res, in);
+        sexp_complex_real(den) = res;
+      }
+      if (!sexp_exceptionp(res))
+        res = den;
+    } else
+#endif
+      do {
+    res = sexp_make_ratio(ctx, sexp_make_fixnum(negativep ? -val : val), den);
+    res = sexp_ratio_normalize(ctx, res, in);
+      } while (0);
+#else
+    if (!sexp_exceptionp(res))
+      res = sexp_make_flonum(ctx, (double)(negativep ? -val : val)
+                             / (double)sexp_unbox_fixnum(den));
+#endif
+    }
+    sexp_gc_release2(ctx);
+    return res;
+#if SEXP_USE_COMPLEX
+  } else if (c=='i' || c=='I' || c=='+' || c=='-' || c=='@') {
+    if (base != 10)
+      return sexp_read_error(ctx, "found non-base 10 complex", SEXP_NULL, in);
+#if SEXP_USE_MATH
+    if (c=='@')
+      return sexp_read_polar_tail(ctx, in, sexp_make_fixnum(negativep ? -val : val));
+#endif
+    sexp_push_char(ctx, c, in);
+    return sexp_read_complex_tail(ctx, in, sexp_make_fixnum(negativep ? -val : val));
+#endif
+  } else {
+    if ((c!=EOF) && ! sexp_is_separator(c))
+      return sexp_read_error(ctx, "invalid numeric syntax",
+                             sexp_make_character(c), in);
+    else if (tmp < 0)
+      return sexp_read_error(ctx, "digitless numeric literal", SEXP_NULL, in);
+    sexp_push_char(ctx, c, in);
+  }
+
+  return sexp_make_fixnum(negativep ? -val : val);
+}
+
+#if SEXP_USE_UTF8_STRINGS
+static int sexp_decode_utf8_char(const unsigned char* s) {
+  int i = s[0], len = strlen((const char*)s);
+  if ((i >= 0xC0) && (i <= 0xF7) && (s[1]>>6 == 2)) {
+    if ((i < 0xE0) && (len == 2)) {
+      return ((i&0x3F)<<6) + (s[1]&0x3F);
+    } else if ((i < 0xF0) && (len == 3) && (s[2]>>6 == 2)) {
+      return ((i&0x1F)<<12) + ((s[1]&0x3F)<<6) + (s[2]&0x3F);
+    } else if ((len == 4) && (s[2]>>6 == 2) && (s[3]>>6 == 2)) {
+      return ((i&0x0F)<<16) + ((s[1]&0x3F)<<6) + ((s[2]&0x3F)<<6) + (s[3]&0x3F);
+    }
+  }
+  return -1;
+}
+#endif
+
+sexp sexp_read_raw (sexp ctx, sexp in) {
+  char *str;
+  int c1, c2, line;
+  sexp tmp2;
+  sexp_gc_var2(res, tmp);
+  sexp_check_block_port(ctx, in, 0);
+  sexp_gc_preserve2(ctx, res, tmp);
+
+ scan_loop:
+  switch (c1 = sexp_read_char(ctx, in)) {
+  case EOF:
+    res = SEXP_EOF;
+    break;
+  case ';':
+    while ((c1 = sexp_read_char(ctx, in)) != EOF)
+      if (c1 == '\n')
+        break;
+    /* ... FALLTHROUGH ... */
+  case '\n':
+    sexp_port_line(in)++;
+    goto scan_loop;
+  case ' ':
+  case '\t':
+  case '\f':
+  case '\r':
+    goto scan_loop;
+  case '\'':
+    res = sexp_read(ctx, in);
+    if (! sexp_exceptionp(res))
+      res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUOTE_SYMBOL), res);
+    break;
+  case '`':
+    res = sexp_read(ctx, in);
+    if (! sexp_exceptionp(res))
+      res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL), res);
+    break;
+  case ',':
+    if ((c1 = sexp_read_char(ctx, in)) == '@') {
+      res = sexp_read(ctx, in);
+      if (! sexp_exceptionp(res))
+        res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL), res);
+    } else {
+      sexp_push_char(ctx, c1, in);
+      res = sexp_read(ctx, in);
+      if (! sexp_exceptionp(res))
+        res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_UNQUOTE_SYMBOL), res);
+    }
+    break;
+  case '"':
+    res = sexp_read_string(ctx, in, '"');
+    break;
+  case '(':
+    line = (sexp_port_sourcep(in) ? sexp_port_line(in) : -1);
+    res = SEXP_NULL;
+    tmp = sexp_read_raw(ctx, in);
+    while ((tmp != SEXP_EOF) && (tmp != SEXP_CLOSE) && (tmp != SEXP_RAWDOT)) {
+      if (sexp_exceptionp(tmp)) {
+        res = tmp;
+        break;
+      }
+      res = sexp_cons(ctx, tmp, res);
+      if (sexp_port_sourcep(in) && (line >= 0))
+        sexp_pair_source(res)
+          = sexp_cons(ctx, sexp_port_name(in), sexp_make_fixnum(line));
+      tmp = sexp_read_raw(ctx, in);
+    }
+    if (! sexp_exceptionp(res)) {
+      if (tmp == SEXP_RAWDOT) { /* dotted list */
+        if (res == SEXP_NULL) {
+          res = sexp_read_error(ctx, "dot before any elements in list",
+                                SEXP_NULL, in);
+        } else {
+          tmp = sexp_read_raw(ctx, in);
+          if (sexp_exceptionp(tmp)) {
+            res = tmp;
+          } else if (tmp == SEXP_CLOSE) {
+            res = sexp_read_error(ctx, "no final element in list after dot",
+                                  SEXP_NULL, in);
+          } else if (sexp_read_raw(ctx, in) != SEXP_CLOSE) {
+            res = sexp_read_error(ctx, "multiple tokens in dotted tail",
+                                  SEXP_NULL, in);
+          } else if (tmp == SEXP_RAWDOT) {
+            res = sexp_read_error(ctx, "multiple dots in list",
+                                  SEXP_NULL, in);
+          } else {
+            tmp2 = res;
+            res = sexp_nreverse(ctx, res);
+            sexp_cdr(tmp2) = tmp;
+          }
+        }
+      } else if (tmp == SEXP_CLOSE) {
+        res = (sexp_pairp(res) ? sexp_nreverse(ctx, res) : res);
+      } else {
+        res = sexp_read_error(ctx, "missing trailing ')' started on line",
+                              sexp_make_fixnum(line), in);
+      }
+    }
+    if ((line >= 0) && sexp_pairp(res)) {
+      sexp_pair_source(res)
+        = sexp_cons(ctx, sexp_port_name(in), sexp_make_fixnum(line));
+      for (tmp=sexp_cdr(res); sexp_pairp(tmp); tmp=sexp_cdr(tmp))
+        sexp_pair_source(tmp) = sexp_pair_source(res);
+    }
+    if (sexp_port_sourcep(in))
+      for (tmp=res; sexp_pairp(tmp); tmp=sexp_cdr(tmp))
+        sexp_immutablep(tmp) = 1;
+    break;
+#if SEXP_USE_OBJECT_BRACE_LITERALS
+  case '{':
+    res = sexp_read_symbol(ctx, in, EOF, 0);
+    if (!sexp_exceptionp(res)) {
+      for (c1=' '; isspace(c1); c1=sexp_read_char(ctx, in))
+        ;
+      if (c1=='#') {
+        tmp = sexp_read(ctx, in);
+        if (sexp_symbolp(tmp) && tmp == sexp_intern(ctx, "t", 1))
+          tmp = SEXP_TRUE;
+        else if (!sexp_fixnump(tmp))
+          tmp = sexp_read_error(ctx, "invalid type identifier", tmp, in);
+      } else if (c1=='"') {
+        tmp = sexp_read_string(ctx, in, '"');
+      } else {
+        tmp = sexp_read_error(ctx, "brace literal missing type identifier", sexp_make_character(c1), in);
+      }
+      if (!sexp_exceptionp(tmp)) tmp = sexp_lookup_type(ctx, res, tmp);
+      if (tmp && sexp_typep(tmp) && sexp_opcodep(sexp_type_print(tmp))
+          && sexp_opcode_func(sexp_type_print(tmp)) == (sexp_proc1)sexp_write_simple_object) {
+        res = sexp_alloc_tagged(ctx, sexp_type_size_base(tmp), sexp_type_tag(tmp));
+        for (c1=0; ; c1++) {
+          tmp2 = sexp_read_raw(ctx, in);
+          if (sexp_exceptionp(tmp2)) {
+            res = tmp2;
+            break;
+          } else if (tmp2 == SEXP_CLOSE_BRACE) {
+            break;
+          } else if (c1 >= sexp_type_field_len_base(tmp)) {
+            res = sexp_read_error(ctx, "too many slots in object literal", res, in);
+            break;
+          } else {
+            sexp_slot_set(res, c1, tmp2);
+          }
+        }
+      } else {
+        res = sexp_exceptionp(tmp) ? tmp : sexp_read_error(ctx, "invalid type for brace literals", tmp, in);
+      }
+    }
+    break;
+#endif
+  case '#':
+    switch (c1=sexp_read_char(ctx, in)) {
+    case 'b': case 'B':
+      res = sexp_read_number(ctx, in, 2, 0); break;
+    case 'o': case 'O':
+      res = sexp_read_number(ctx, in, 8, 0); break;
+    case 'd': case 'D':
+      res = sexp_read_number(ctx, in, 10, 0); break;
+    case 'x': case 'X':
+      res = sexp_read_number(ctx, in, 16, 0); break;
+    case 'e': case 'E':
+      res = sexp_read_number(ctx, in, 10, 1);
+#if SEXP_USE_INFINITIES
+      if (sexp_flonump(res)
+          && (isnan(sexp_flonum_value(res)) || isinf(sexp_flonum_value(res))))
+        res = sexp_read_error(ctx, "can't convert non-finite flonum to exact", res, in);
+      else
+#endif
+      if (sexp_flonump(res))
+#if SEXP_USE_RATIOS
+        res = sexp_double_to_ratio(ctx, sexp_flonum_value(res));
+#elif SEXP_USE_BIGNUMS
+        res = sexp_bignum_normalize(sexp_double_to_bignum(ctx, sexp_flonum_value(res)));
+#else
+        res = sexp_make_fixnum(sexp_flonum_value(res));
+#endif
+      break;
+    case 'i': case 'I':
+      res = sexp_read(ctx, in);
+      if (sexp_exact_integerp(res))
+        res = sexp_make_flonum(ctx, sexp_unbox_fixnum(res));
+#if SEXP_USE_RATIOS
+      else if (sexp_ratiop(res))
+        res = sexp_make_flonum(ctx, sexp_ratio_to_double(res));
+#endif
+      break;
+    case 'f': case 'F':
+    case 't': case 'T':
+      c2 = sexp_read_char(ctx, in);
+      if (c2 == EOF || sexp_is_separator(c2)) {
+        res = (sexp_tolower(c1) == 't' ? SEXP_TRUE : SEXP_FALSE);
+        sexp_push_char(ctx, c2, in);
+      } else {
+        sexp_push_char(ctx, c2, in);
+        res = sexp_read_symbol(ctx, in, c1, 0);
+        if (!sexp_exceptionp(res)) {
+          if (strcasecmp("true", sexp_string_data(res)) == 0)
+            res = SEXP_TRUE;
+          else if (strcasecmp("false", sexp_string_data(res)) == 0)
+            res = SEXP_FALSE;
+          else
+            res = sexp_read_error(ctx, "invalid # syntax", res, in);
+        }
+      }
+      break;
+#if SEXP_USE_BYTEVECTOR_LITERALS
+    case 'v': case 'V':
+      c1 = sexp_read_char(ctx, in);
+      if (!(c1=='u'||c1=='U')) {
+        res = sexp_read_error(ctx, "invalid syntax #v%c", sexp_make_character(c1), in);
+        break;
+      }
+      /* ... FALLTHROUGH ... */
+    case 'u': case 'U':
+      if ((c1 = sexp_read_char(ctx, in)) == '8') {
+        tmp = sexp_read(ctx, in);
+        if (!sexp_listp(ctx, tmp)) {
+          res = sexp_exceptionp(tmp) ? tmp
+            : sexp_read_error(ctx, "invalid syntax object after #u8", tmp, in);
+        } else {
+          res = sexp_make_bytes(ctx, sexp_length(ctx, tmp), SEXP_VOID);
+          for (c1=0; sexp_pairp(tmp); tmp=sexp_cdr(tmp), c1++) {
+            tmp2 = sexp_car(tmp);
+            if (!(sexp_fixnump(tmp2) && sexp_unbox_fixnum(tmp2) >= 0
+                  && sexp_unbox_fixnum(tmp2) < 0x100)) {
+              res = sexp_read_error(ctx, "invalid bytevector value", tmp2, in);
+              break;
+            } else {
+              sexp_bytes_set(res, sexp_make_fixnum(c1), tmp2);
+            }
+          }
+        }
+      } else {
+        tmp = sexp_list2(ctx, sexp_make_character('u'), sexp_make_character(c1));
+        res = sexp_read_error(ctx, "invalid syntax #%c%c", tmp, in);
+      }
+      break;
+#endif
+/*     case '0': case '1': case '2': case '3': case '4': */
+/*     case '5': case '6': case '7': case '8': case '9': */
+    case ';':
+      tmp = sexp_read(ctx, in);   /* discard */
+      if (sexp_exceptionp(tmp))
+        res = tmp;
+      else
+        goto scan_loop;
+      break;
+    case '|':
+      for (c2 = 1; c2 > 0 && c1 != EOF; ) {
+        c1 = sexp_read_char(ctx, in);
+        if (c1 == '#') {
+          while ((c1 = sexp_read_char(ctx, in)) == '#')
+            ;
+          if (c1 == '|') c2++;
+        } else if (c1 == '|') {
+          while ((c1 = sexp_read_char(ctx, in)) == '|')
+            ;
+          if (c1 == '#') c2--;
+        } else if (c1 == '\n') {
+          sexp_port_line(in)++;
+        }
+      }
+      if (c1 == EOF)
+        res = sexp_read_error(ctx, "unterminated #| comment", SEXP_NULL, in);
+      else
+        goto scan_loop;
+      break;
+    case '!':
+      c1 = sexp_read_char(ctx, in);
+      if (isspace(c1) || c1 == '/') {
+        while ((c1 = sexp_read_char(ctx, in)) != EOF)
+          if (c1 == '\n')
+            break;
+        sexp_port_line(in)++;
+        res = SEXP_VOID;
+      } else {
+        sexp_push_char(ctx, c1, in);
+        res = sexp_read_symbol(ctx, in, '!', 0);
+        if (SEXP_USE_FOLD_CASE_SYMS && sexp_stringp(res)
+            && strcmp("!fold-case", sexp_string_data(res)) == 0) {
+          sexp_port_fold_casep(in) = 1;
+        } else if (SEXP_USE_FOLD_CASE_SYMS && sexp_stringp(res)
+                   && strcmp("!no-fold-case", sexp_string_data(res)) == 0) {
+          sexp_port_fold_casep(in) = 0;
+        } else {
+          res = sexp_read_error(ctx, "unknown #! symbol", res, in);
+        }
+      }
+      if (!sexp_exceptionp(res))
+        goto scan_loop;
+      break;
+    case '\\':
+      c1 = sexp_read_char(ctx, in);
+      c2 = sexp_read_char(ctx, in);
+      sexp_push_char(ctx, c2, in);
+      if ((c1 == 'x' || c1 == 'X') && (sexp_isxdigit(c2))) {
+        res = sexp_read_number(ctx, in, 16, 0);
+        if (sexp_fixnump(res) && sexp_unbox_fixnum(res) >= 0 && sexp_unbox_fixnum(res) <= 0x10FFFF)
+          res = sexp_make_character(sexp_unbox_fixnum(res));
+        else if (!sexp_exceptionp(res))
+          res = sexp_read_error(ctx, "bad character #\\x literal", res, in);
+      } else {
+        res = sexp_read_symbol(ctx, in, c1, 0);
+        if (sexp_stringp(res)) {
+          str = sexp_string_data(res);
+          if (sexp_string_size(res) == 0)
+            res =
+              sexp_read_error(ctx, "unexpected end of character literal",
+                              SEXP_NULL, in);
+          if (sexp_string_size(res) == 1) {
+            res = sexp_make_character(c1);
+          } else {
+            res = 0;
+            for (c2=0; c2 < sexp_num_char_names; c2++) {
+              if (strcasecmp(str, sexp_char_names[c2].name) == 0) {
+                res = sexp_make_character(sexp_char_names[c2].ch);
+                break;
+              }
+            }
+            if (!res) {
+#if SEXP_USE_UTF8_STRINGS
+              if ((c1=sexp_decode_utf8_char((unsigned char*)str)) > 0) {
+                res = sexp_make_character(c1);
+                break;
+              }
+#endif
+              tmp = sexp_c_string(ctx, str, -1);
+              res = sexp_read_error(ctx, "unknown character name", tmp, in);
+            }
+          }
+        }
+      }
+      break;
+    case '(':
+      sexp_push_char(ctx, c1, in);
+      res = sexp_read(ctx, in);
+      if (sexp_not(sexp_listp(ctx, res))) {
+        if (! sexp_exceptionp(res)) {
+          res = sexp_read_error(ctx, "dotted list not allowed in vector syntax",
+                                SEXP_NULL,
+                                in);
+        }
+      } else {
+        res = sexp_list_to_vector(ctx, res);
+      }
+      break;
+    default:
+      res = sexp_read_error(ctx, "invalid char following '#'",
+                            c1 == EOF ? SEXP_EOF : sexp_make_character(c1), in);
+    }
+    break;
+  case '.':
+    c1 = sexp_read_char(ctx, in);
+    sexp_push_char(ctx, c1, in);
+    if (c1 == EOF || sexp_is_separator(c1)) {
+      res = SEXP_RAWDOT;
+    } else if (sexp_isdigit(c1)) {
+      res = sexp_read_float_tail(ctx, in, 0, 0);
+    } else {
+      res = sexp_read_symbol(ctx, in, '.', 1);
+    }
+    break;
+  case ')':
+    res = SEXP_CLOSE;
+    break;
+#if SEXP_USE_OBJECT_BRACE_LITERALS
+  case '}':
+    res = SEXP_CLOSE_BRACE;
+    break;
+#endif
+  case '|':
+    res = sexp_read_string(ctx, in, '|');
+    if (sexp_stringp(res))
+      res = sexp_intern(ctx, sexp_string_data(res), sexp_string_size(res));
+    break;
+  case '+':
+  case '-':
+    c2 = sexp_read_char(ctx, in);
+    if (c2 == '.' || sexp_isdigit(c2)) {
+      sexp_push_char(ctx, c2, in);
+      res = sexp_read_number(ctx, in, 10, 0);
+      if ((c1 == '-') && ! sexp_exceptionp(res)) {
+#if SEXP_USE_FLONUMS
+        if (sexp_flonump(res))
+#if SEXP_USE_IMMEDIATE_FLONUMS
+          res = sexp_make_flonum(ctx, -1 * sexp_flonum_value(res));
+#else
+          sexp_flonum_value(res) = -1 * sexp_flonum_value(res);
+#endif
+        else
+#endif
+#if SEXP_USE_BIGNUMS
+          if (sexp_bignump(res)) {
+            if ((sexp_bignum_hi(res) == 1)
+                && (sexp_bignum_data(res)[0] == (SEXP_MAX_FIXNUM+1)))
+              res = sexp_make_fixnum(-sexp_bignum_data(res)[0]);
+            else
+              sexp_bignum_sign(res) = -sexp_bignum_sign(res);
+          } else
+#endif
+#if SEXP_USE_RATIOS
+          if (sexp_ratiop(res)) {
+            sexp_negate(sexp_ratio_numerator(res));
+          } else
+#endif
+#if SEXP_USE_COMPLEX
+          if (sexp_complexp(res)) {
+            if (sexp_complex_real(res) == SEXP_ZERO) {
+              sexp_negate(sexp_complex_imag(res));
+            } else {
+              sexp_negate(sexp_complex_real(res));
+            }
+          } else
+#endif
+            res = sexp_fx_mul(res, SEXP_NEG_ONE);
+      }
+    } else {
+      sexp_push_char(ctx, c2, in);
+      res = sexp_read_symbol(ctx, in, c1, !SEXP_USE_INFINITIES);
+#if SEXP_USE_INFINITIES
+      if (sexp_stringp(res)) {
+        str = sexp_string_data(res);
+        if (strcasecmp(str, "+inf.0") == 0)
+          res = sexp_make_flonum(ctx, sexp_pos_infinity);
+        else if (strcasecmp(str, "-inf.0") == 0)
+          res = sexp_make_flonum(ctx, sexp_neg_infinity);
+        else if (strcasecmp(str+1, "nan.0") == 0)
+          res = sexp_make_flonum(ctx, sexp_nan);
+#if SEXP_USE_COMPLEX
+        else if (strcasestr(str+1, "inf.0") == str+1) {
+          tmp = sexp_make_flonum(ctx, c1 == '+' ? sexp_pos_infinity : sexp_neg_infinity);
+          if (str[6] == 0) {
+            res = tmp;
+          } else if ((str[6] == 'i' || str[6] == 'I') && str[7] == 0) {
+            res = sexp_make_complex(ctx, SEXP_ZERO, tmp);
+          } else if (str[6] == '+' || str[6] == '-') {
+            res = sexp_substring_cursor(ctx, res, SEXP_SIX, SEXP_FALSE);
+            res = sexp_string_to_number(ctx, res, SEXP_TEN);
+            if (sexp_complexp(res) && (sexp_complex_real(res) == SEXP_ZERO))
+              sexp_complex_real(res) = tmp;
+            else
+              res = sexp_read_error(ctx, "invalid complex infinity", res, in);
+          } else {
+            res = sexp_read_error(ctx, "invalid infinity", res, in);
+          }
+        }
+#endif
+        else
+          res = sexp_intern(ctx, str, sexp_string_size(res));
+      }
+#endif
+#if SEXP_USE_COMPLEX
+      if (res == sexp_intern(ctx, "+i", -1))
+        res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ONE);
+      else if (res == sexp_intern(ctx, "-i", -1))
+        res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_NEG_ONE);
+#endif
+    }
+    break;
+  case '0': case '1': case '2': case '3': case '4':
+  case '5': case '6': case '7': case '8': case '9':
+    sexp_push_char(ctx, c1, in);
+    res = sexp_read_number(ctx, in, 10, 0);
+    break;
+  default:
+    res = sexp_read_symbol(ctx, in, c1, 1);
+    break;
+  }
+
+  if (sexp_port_sourcep(in) && sexp_pointerp(res))
+    sexp_immutablep(res) = 1;
+  sexp_maybe_unblock_port(ctx, in);
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+sexp sexp_read_op (sexp ctx, sexp self, sexp_sint_t n, sexp in) {
+  sexp res;
+  sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in);
+  res = sexp_read_raw(ctx, in);
+  if (res == SEXP_CLOSE)
+    res = sexp_read_error(ctx, "too many ')'s", SEXP_NULL, in);
+#if SEXP_USE_OBJECT_BRACE_LITERALS
+  else if (res == SEXP_CLOSE_BRACE)
+    res = sexp_read_error(ctx, "too many '}'s", SEXP_NULL, in);
+#endif
+  else if (res == SEXP_RAWDOT)
+    res = sexp_read_error(ctx, "unexpected '.'", SEXP_NULL, in);
+  return res;
+}
+
+sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len) {
+  sexp res;
+  sexp_gc_var2(s, in);
+  sexp_gc_preserve2(ctx, s, in);
+  s = sexp_c_string(ctx, str, len);
+  in = sexp_open_input_string(ctx, s);
+  res = sexp_read(ctx, in);
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+sexp sexp_string_to_number_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp b) {
+  int base;
+  sexp_gc_var1(in);
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, b);
+  if (((base=sexp_unbox_fixnum(b)) < 2) || (base > 36))
+    return sexp_user_exception(ctx, self, "invalid numeric base", b);
+  if (sexp_string_data(str)[0]=='\0'
+      || (sexp_string_data(str)[1]=='\0' && !sexp_isxdigit((unsigned char)(sexp_string_data(str)[0]))))
+    return SEXP_FALSE;
+  sexp_gc_preserve1(ctx, in);
+  in = sexp_open_input_string(ctx, str);
+  if (sexp_string_data(str)[0] == '+') {
+    if (sexp_isdigit((unsigned char)(sexp_string_data(str)[1]))
+        || sexp_string_data(str)[1] == '.' || sexp_string_data(str)[1] == '#')
+      sexp_read_char(ctx, in);
+  }
+  in = ((sexp_string_data(str)[0] == '#') || base == 10 ?
+        sexp_read(ctx, in) : sexp_read_number(ctx, in, base, 0));
+  sexp_gc_release1(ctx);
+  return sexp_numberp(in) ? in : SEXP_FALSE;
+}
+
+sexp sexp_write_to_string (sexp ctx, sexp obj) {
+  sexp str;
+  sexp_gc_var1(out);
+  sexp_gc_preserve1(ctx, out);
+  out = sexp_open_output_string(ctx);
+  str = sexp_write(ctx, obj, out);
+  if (! sexp_exceptionp(str))
+    str = sexp_get_output_string(ctx, out);
+  sexp_gc_release1(ctx);
+  return str;
+}
+
+sexp sexp_symbol_to_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp sym) {
+#if SEXP_USE_HUFF_SYMS
+  if (sexp_isymbolp(sym)) return sexp_write_to_string(ctx, sym);
+#endif
+  sexp_assert_type(ctx, sexp_lsymbolp, SEXP_SYMBOL, sym);
+  return sexp_c_string(ctx, sexp_lsymbol_data(sym), sexp_lsymbol_length(sym));
+}
+
+void sexp_init (void) {
+#if SEXP_USE_GLOBAL_SYMBOLS
+  int i;
+#endif
+  if (! sexp_initialized_p) {
+    sexp_initialized_p = 1;
+#if SEXP_USE_BOEHM
+    GC_init();
+#if SEXP_USE_GLOBAL_SYMBOLS
+    GC_add_roots((char*)&sexp_symbol_table,
+                 ((char*)&sexp_symbol_table)+sizeof(sexp_symbol_table)+1);
+#endif
+#elif ! SEXP_USE_MALLOC
+    sexp_gc_init();
+#endif
+#if SEXP_USE_GLOBAL_SYMBOLS
+    for (i=0; i<SEXP_SYMBOL_TABLE_SIZE; i++)
+      sexp_symbol_table[i] = SEXP_NULL;
+#endif
+  }
+}
diff --git a/simplify.c b/simplify.c
new file mode 100644
index 00000000..c30d3a4b
--- /dev/null
+++ b/simplify.c
@@ -0,0 +1,196 @@
+/*  simplify.c -- basic simplification pass                   */
+/*  Copyright (c) 2010-2013 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include "chibi/eval.h"
+
+#if SEXP_USE_SIMPLIFY
+
+#define simplify_it(it) ((it) = simplify(ctx, it, substs, lambda))
+
+static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) {
+  int check;
+  sexp ls1, ls2, p1, p2, sv;
+  sexp_gc_var5(res, substs, tmp, app, ctx2);
+  if (!sexp_pointerp(ast))
+    return ast;
+  sexp_gc_preserve5(ctx, res, substs, tmp, app, ctx2);
+  res = ast;                    /* return the ast as-is by default */
+  substs = init_substs;
+
+  switch (sexp_pointer_tag(res)) {
+
+  case SEXP_PAIR:
+    /* don't simplify the operator if it's a lambda because we
+       simplify that as a special case below, with the appropriate
+       substs list */
+    app = sexp_list1(ctx, sexp_lambdap(sexp_car(res)) ? sexp_car(res)
+                     : (tmp=simplify(ctx, sexp_car(res), substs, lambda)));
+    sexp_pair_source(app) = sexp_pair_source(res);
+    for (ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) {
+      sexp_push(ctx, app, tmp=simplify(ctx, sexp_car(ls1), substs, lambda));
+      if (sexp_pairp(app)) sexp_pair_source(app) = sexp_pair_source(ls1);
+    }
+    app = sexp_nreverse(ctx, app);
+    /* app now holds a copy of the list, and is the default result
+       (res = app below) if we don't replace it with a simplification */
+    if (sexp_opcodep(sexp_car(app))) {
+      /* opcode app - right now we just constant fold arithmetic */
+      if (sexp_opcode_class(sexp_car(app)) == SEXP_OPC_ARITHMETIC) {
+        for (check=1, ls1=sexp_cdr(app); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) {
+          if (sexp_pointerp(sexp_car(ls1)) && ! sexp_litp(sexp_car(ls1))) {
+            check = 0;
+            break;
+          }
+        }
+        if (check) {
+          ctx2 = sexp_make_eval_context(ctx, NULL, sexp_context_env(ctx), 0, 0);
+          sexp_generate(ctx2, 0, 0, 0, app);
+          res = sexp_complete_bytecode(ctx2);
+          if (! sexp_exceptionp(res)) {
+            tmp = sexp_make_vector(ctx2, 0, SEXP_VOID);
+            tmp = sexp_make_procedure(ctx2, SEXP_ZERO, SEXP_ZERO, res, tmp);
+            if (! sexp_exceptionp(tmp)) {
+              tmp = sexp_apply_no_err_handler(ctx2, tmp, SEXP_NULL);
+              if (! sexp_exceptionp(tmp))
+                app = sexp_make_lit(ctx2, tmp);
+            }
+          }
+        }
+      }
+    } else if (lambda && sexp_lambdap(sexp_car(app))) { /* let */
+      p1 = NULL;
+      p2 = sexp_lambda_params(sexp_car(app));
+      ls1 = app;
+      ls2 = sexp_cdr(app);
+      sv = sexp_lambda_sv(sexp_car(app));
+      /* inline constants and immutable references */
+      if (sexp_length(ctx, p2) == sexp_length(ctx, ls2)) {
+        for ( ; sexp_pairp(ls2); ls2=sexp_cdr(ls2), p2=sexp_cdr(p2)) {
+          if (sexp_not(sexp_memq(ctx, sexp_car(p2), sv))
+              && (! sexp_pointerp(sexp_car(ls2)) || sexp_litp(sexp_car(ls2))
+                  /* disable inline references for now */
+                  || (0 && sexp_refp(sexp_car(ls2))
+                      && sexp_lambdap(sexp_ref_loc(sexp_car(ls2)))
+                      && sexp_not(sexp_memq(ctx, sexp_ref_name(sexp_car(ls2)),
+                                            sexp_lambda_sv(sexp_ref_loc(sexp_car(ls2)))))))) {
+            tmp = sexp_cons(ctx, sexp_car(app), sexp_car(ls2));
+            tmp = sexp_cons(ctx, sexp_car(p2), tmp);
+            sexp_push(ctx, substs, tmp);
+            sexp_cdr(ls1) = sexp_cdr(ls2);
+            if (p1)
+              sexp_cdr(p1) = sexp_cdr(p2);
+            else
+              sexp_lambda_params(sexp_car(app)) = sexp_cdr(p2);
+          } else {
+            p1 = p2;
+            ls1 = ls2;
+          }
+        }
+        sexp_lambda_body(sexp_car(app))
+          = simplify(ctx, sexp_lambda_body(sexp_car(app)), substs, sexp_car(app));
+        /* TODO: Revisit this - it causes GC problems in rare cases. */
+        /* if (sexp_nullp(sexp_cdr(app)) */
+        /*     && sexp_nullp(sexp_lambda_params(sexp_car(app))) */
+        /*     && sexp_nullp(sexp_lambda_defs(sexp_car(app)))) */
+        /*   app = sexp_lambda_body(sexp_car(app)); */
+      } else if (sexp_lambdap(sexp_car(app))) {
+        sexp_lambda_body(sexp_car(app))
+          = simplify(ctx, sexp_lambda_body(sexp_car(app)), substs, sexp_car(app));
+      }
+    }
+    res = app;
+    break;
+
+  case SEXP_LAMBDA:
+    sexp_lambda_body(res) = simplify(ctx, sexp_lambda_body(res), substs, res);
+    break;
+
+  case SEXP_CND:
+    tmp = simplify(ctx, sexp_cnd_test(res), substs, lambda);
+    if (sexp_litp(tmp) || ! sexp_pointerp(tmp)) {
+      res = sexp_not((sexp_litp(tmp) ? sexp_lit_value(tmp) : tmp))
+        ? sexp_cnd_fail(res) : sexp_cnd_pass(res);
+      res = simplify(ctx, res, substs, lambda);
+    } else {
+      sexp_cnd_test(res) = tmp;
+      simplify_it(sexp_cnd_pass(res));
+      simplify_it(sexp_cnd_fail(res));
+    }
+    break;
+
+  case SEXP_REF:
+    tmp = sexp_ref_name(res);
+    for (ls1=substs; sexp_pairp(ls1); ls1=sexp_cdr(ls1))
+      if ((sexp_caar(ls1) == tmp) && (sexp_cadar(ls1) == sexp_ref_loc(res))) {
+        res = sexp_cddar(ls1);
+        break;
+      }
+    break;
+
+  case SEXP_SET:
+    simplify_it(sexp_set_value(res));
+    break;
+
+  case SEXP_SEQ:
+    app = SEXP_NULL;
+    for (ls2=sexp_seq_ls(res); sexp_pairp(ls2); ls2=sexp_cdr(ls2)) {
+      tmp = simplify(ctx, sexp_car(ls2), substs, lambda);
+      if (! (sexp_pairp(sexp_cdr(ls2))
+             && (sexp_litp(tmp) || ! sexp_pointerp(tmp) || sexp_refp(tmp)
+                 || sexp_lambdap(tmp))))
+        sexp_push(ctx, app, tmp);
+    }
+    if (sexp_pairp(app) && sexp_nullp(sexp_cdr(app)))
+      res = sexp_car(app);
+    else
+      sexp_seq_ls(res) = sexp_nreverse(ctx, app);
+    break;
+
+  }
+
+  sexp_gc_release5(ctx);
+  return res;
+}
+
+sexp sexp_simplify (sexp ctx, sexp self, sexp_sint_t n, sexp ast) {
+  return simplify(ctx, ast, SEXP_NULL, NULL);
+}
+
+static int usedp (sexp lambda, sexp var, sexp x) {
+  sexp ls;
+ loop:
+  switch (sexp_pointerp(x) ? sexp_pointer_tag(x) : 0) {
+  case SEXP_REF:
+    return sexp_ref_name(x) == var && sexp_ref_loc(x) == lambda;
+  case SEXP_SET:
+    x = sexp_set_value(x);
+    goto loop;
+  case SEXP_LAMBDA:
+    x = sexp_lambda_body(x);
+    goto loop;
+  case SEXP_CND:
+    if (usedp(lambda, var, sexp_cnd_test(x))
+        || usedp(lambda, var, sexp_cnd_pass(x)))
+      return 1;
+    x = sexp_cnd_fail(x);
+    goto loop;
+  case SEXP_SEQ:
+    x = sexp_seq_ls(x);
+  case SEXP_PAIR:
+    for (ls=x; sexp_pairp(ls); ls=sexp_cdr(ls))
+      if (usedp(lambda, var, sexp_car(ls)))
+        return 1;
+  }
+  return 0;
+}
+
+int sexp_rest_unused_p (sexp lambda) {
+  sexp var;
+  for (var=sexp_lambda_params(lambda); sexp_pairp(var); var=sexp_cdr(var))
+    ;
+  if (sexp_nullp(var)) return 0;
+  return !usedp(lambda, var, sexp_lambda_body(lambda));
+}
+
+#endif
diff --git a/tests/base64-tests.scm b/tests/base64-tests.scm
new file mode 100644
index 00000000..2ecb461f
--- /dev/null
+++ b/tests/base64-tests.scm
@@ -0,0 +1,40 @@
+
+(import (chibi) (chibi base64) (chibi test))
+
+(test-begin "base64")
+
+(test "YW55IGNhcm5hbCBwbGVhc3VyZS4="
+    (base64-encode-string "any carnal pleasure."))
+(test "YW55IGNhcm5hbCBwbGVhc3VyZQ=="
+    (base64-encode-string "any carnal pleasure"))
+(test "YW55IGNhcm5hbCBwbGVhc3Vy"
+    (base64-encode-string "any carnal pleasur"))
+(test "YW55IGNhcm5hbCBwbGVhc3U="
+    (base64-encode-string "any carnal pleasu"))
+(test "YW55IGNhcm5hbCBwbGVhcw=="
+    (base64-encode-string "any carnal pleas"))
+
+(test "any carnal pleas"
+    (base64-decode-string "YW55IGNhcm5hbCBwbGVhcw=="))
+(test "any carnal pleasu"
+    (base64-decode-string "YW55IGNhcm5hbCBwbGVhc3U="))
+(test "any carnal pleasur"
+    (base64-decode-string "YW55IGNhcm5hbCBwbGVhc3Vy"))
+(test "any carnal pleas"
+    (base64-decode-string "YW55IGNhcm5hbCBwbGVhcw"))
+(test "any carnal pleasu"
+    (base64-decode-string "YW55IGNhcm5hbCBwbGVhc3U"))
+
+(test "YW55IGNhcm5hbCBwbGVhc3VyZS4="
+    (call-with-output-string
+      (lambda (out)
+        (call-with-input-string "any carnal pleasure."
+          (lambda (in) (base64-encode in out))))))
+
+(test "any carnal pleasure."
+    (call-with-output-string
+      (lambda (out)
+        (call-with-input-string "YW55IGNhcm5hbCBwbGVhc3VyZS4="
+          (lambda (in) (base64-decode in out))))))
+
+(test-end)
diff --git a/tests/basic/test00-fact-3.res b/tests/basic/test00-fact-3.res
new file mode 100644
index 00000000..f76d3d1e
--- /dev/null
+++ b/tests/basic/test00-fact-3.res
@@ -0,0 +1 @@
+(fact 3) => 6
diff --git a/tests/basic/test00-fact-3.scm b/tests/basic/test00-fact-3.scm
new file mode 100644
index 00000000..41d9c20e
--- /dev/null
+++ b/tests/basic/test00-fact-3.scm
@@ -0,0 +1,14 @@
+
+(define (fact-helper x res)
+  (if (= x 0)
+      res
+      (fact-helper (- x 1) (* res x))))
+
+(define (fact x)
+  (fact-helper x 1))
+
+(display "(fact 3) => ")
+(write (fact 3))
+(newline)
+
+
diff --git a/tests/basic/test01-apply.res b/tests/basic/test01-apply.res
new file mode 100644
index 00000000..c5b83af4
--- /dev/null
+++ b/tests/basic/test01-apply.res
@@ -0,0 +1,8 @@
+11
+(11 10 9 8 7 6 5 4 3 2 1)
+(1 2 3 4)
+100
+100
+100
+100
+100
diff --git a/tests/basic/test01-apply.scm b/tests/basic/test01-apply.scm
new file mode 100644
index 00000000..183a591c
--- /dev/null
+++ b/tests/basic/test01-apply.scm
@@ -0,0 +1,18 @@
+
+(define foo
+  (lambda (a b c d e f g h)
+    (+ (+ (* a b) (* c d)) (+ (* e f) (* g h)))))
+
+(define (writeln x)
+  (write x)
+  (newline))
+
+(writeln (length (reverse (list 1 2 3 4 5 6 7 8 9 10 11))))
+(writeln (reverse (list 1 2 3 4 5 6 7 8 9 10 11)))
+(writeln (append (list 1 2) (list 3 4)))
+(writeln (foo 1 2 3 4 5 6 7 8))
+(writeln (apply foo (list 1 2 3 4 5 6 7 8)))
+(writeln (apply foo 1 (list 2 3 4 5 6 7 8)))
+(writeln (apply foo 1 2 3 4 (list 5 6 7 8)))
+(writeln (apply foo 1 2 3 4 5 (list 6 7 8)))
+
diff --git a/tests/basic/test02-closure.res b/tests/basic/test02-closure.res
new file mode 100644
index 00000000..4d764d20
--- /dev/null
+++ b/tests/basic/test02-closure.res
@@ -0,0 +1,6 @@
+1
+2
+101
+102
+3
+103
diff --git a/tests/basic/test02-closure.scm b/tests/basic/test02-closure.scm
new file mode 100644
index 00000000..6ed987fe
--- /dev/null
+++ b/tests/basic/test02-closure.scm
@@ -0,0 +1,16 @@
+
+(define (make-counter n)
+  (lambda ()
+    (set! n (+ n 1))
+    n))
+
+(define f (make-counter 0))
+(define g (make-counter 100))
+
+(write (f)) (newline)
+(write (f)) (newline)
+(write (g)) (newline)
+(write (g)) (newline)
+(write (f)) (newline)
+(write (g)) (newline)
+
diff --git a/tests/basic/test03-nested-closure.res b/tests/basic/test03-nested-closure.res
new file mode 100644
index 00000000..c97c8394
--- /dev/null
+++ b/tests/basic/test03-nested-closure.res
@@ -0,0 +1 @@
+11357
diff --git a/tests/basic/test03-nested-closure.scm b/tests/basic/test03-nested-closure.scm
new file mode 100644
index 00000000..6656bd4e
--- /dev/null
+++ b/tests/basic/test03-nested-closure.scm
@@ -0,0 +1,8 @@
+
+((lambda (a b)
+   ((lambda (c d e)
+      (write (+ e (* c 1000) (* a 100) (* b 10) d))
+      (newline))
+    (- a 2) (+ b 2) 10000))
+ 3 5)
+
diff --git a/tests/basic/test04-nested-let.res b/tests/basic/test04-nested-let.res
new file mode 100644
index 00000000..c97c8394
--- /dev/null
+++ b/tests/basic/test04-nested-let.res
@@ -0,0 +1 @@
+11357
diff --git a/tests/basic/test04-nested-let.scm b/tests/basic/test04-nested-let.scm
new file mode 100644
index 00000000..584bc6e5
--- /dev/null
+++ b/tests/basic/test04-nested-let.scm
@@ -0,0 +1,9 @@
+
+(let ((a 3)
+      (b 5))
+  (let ((c (- a 2))
+        (d (+ b 2))
+        (e 10000))
+    (write (+ e (* c 1000) (* a 100) (* b 10) d))
+    (newline)))
+
diff --git a/tests/basic/test05-internal-define.res b/tests/basic/test05-internal-define.res
new file mode 100644
index 00000000..4edae4cc
--- /dev/null
+++ b/tests/basic/test05-internal-define.res
@@ -0,0 +1 @@
+1000 1003
diff --git a/tests/basic/test05-internal-define.scm b/tests/basic/test05-internal-define.scm
new file mode 100644
index 00000000..a5576a63
--- /dev/null
+++ b/tests/basic/test05-internal-define.scm
@@ -0,0 +1,8 @@
+
+(let ((a 1000))
+  (define b (+ a 3))
+  (write a)
+  (display " ")
+  (write b)
+  (newline))
+
diff --git a/tests/basic/test06-letrec.res b/tests/basic/test06-letrec.res
new file mode 100644
index 00000000..83d9c566
--- /dev/null
+++ b/tests/basic/test06-letrec.res
@@ -0,0 +1,4 @@
+7
+#t
+#f
+#f
diff --git a/tests/basic/test06-letrec.scm b/tests/basic/test06-letrec.scm
new file mode 100644
index 00000000..a9c01b4e
--- /dev/null
+++ b/tests/basic/test06-letrec.scm
@@ -0,0 +1,15 @@
+
+(letrec ((add (lambda (a b) (+ a b))))
+  (write (add 3 4))
+  (newline))
+
+(letrec ((even? (lambda (n) (if (zero? n) #t (odd? (- n 1)))))
+         (odd? (lambda (n) (if (zero? n) #f (even? (- n 1))))))
+  (write (even? 1000))
+  (newline)
+  (write (even? 1001))
+  (newline)
+  (write (odd? 1000))
+  (newline)
+  )
+
diff --git a/tests/basic/test07-mutation.res b/tests/basic/test07-mutation.res
new file mode 100644
index 00000000..c97c8394
--- /dev/null
+++ b/tests/basic/test07-mutation.res
@@ -0,0 +1 @@
+11357
diff --git a/tests/basic/test07-mutation.scm b/tests/basic/test07-mutation.scm
new file mode 100644
index 00000000..8dacb7fb
--- /dev/null
+++ b/tests/basic/test07-mutation.scm
@@ -0,0 +1,9 @@
+
+(let ((a 3)
+      (b 5))
+  (let ((c (- a 2))
+        (d (+ b 2))
+        (e #f))
+    (set! e 10000)
+    (write (+ e (* c 1000) (* a 100) (* b 10) d))
+    (newline)))
diff --git a/tests/basic/test08-callcc.res b/tests/basic/test08-callcc.res
new file mode 100644
index 00000000..849baeed
--- /dev/null
+++ b/tests/basic/test08-callcc.res
@@ -0,0 +1 @@
+543
diff --git a/tests/basic/test08-callcc.scm b/tests/basic/test08-callcc.scm
new file mode 100644
index 00000000..3a5c355e
--- /dev/null
+++ b/tests/basic/test08-callcc.scm
@@ -0,0 +1,34 @@
+
+(define fail
+  (lambda () 999999))
+
+(define in-range
+  (lambda (a b)
+    (call-with-current-continuation
+      (lambda (cont)
+        (enumerate a b cont)))))
+
+(define enumerate
+  (lambda (a b cont)
+    (if (< b a)
+        (fail)
+        (let ((save fail))
+          (begin
+            (set! fail
+              (lambda ()
+                (begin
+                  (set! fail save)
+                  (enumerate (+ a 1) b cont))))
+            (cont a))))))
+
+(write
+ (let ((x (in-range 2 9))
+       (y (in-range 2 9))
+       (z (in-range 2 9)))
+   (if (= (* x x)
+          (+ (* y y) (* z z)))
+       (+ (* x 100) (+ (* y 10) z))
+       (fail))))
+
+(newline)
+
diff --git a/tests/basic/test09-hygiene.res b/tests/basic/test09-hygiene.res
new file mode 100644
index 00000000..31cd4d7e
--- /dev/null
+++ b/tests/basic/test09-hygiene.res
@@ -0,0 +1,7 @@
+1
+2
+3
+4
+5
+6
+outer
diff --git a/tests/basic/test09-hygiene.scm b/tests/basic/test09-hygiene.scm
new file mode 100644
index 00000000..820020c1
--- /dev/null
+++ b/tests/basic/test09-hygiene.scm
@@ -0,0 +1,48 @@
+
+(write (or 1))
+(newline)
+(write (or #f 2))
+(newline)
+(write (or 3 #t))
+(newline)
+
+(let ((tmp 4))
+  (write (or #f tmp))
+  (newline))
+
+(write
+ (letrec-syntax
+     ((myor
+       (er-macro-transformer
+        (lambda (expr rename compare)
+          (if (null? (cdr expr))
+              #f
+              (list (rename 'let) (list (list (rename 'tmp) (cadr expr)))
+                    (list (rename 'if) (rename 'tmp)
+                          (rename 'tmp)
+                          (cons (rename 'myor) (cddr expr)))))))))
+   (let ((tmp 5)) (myor #f tmp))))
+(newline)
+
+(define-syntax myor
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (if (null? (cdr expr))
+         #f
+         (list (rename 'let) (list (list (rename 'tmp) (cadr expr)))
+               (list (rename 'if) (rename 'tmp)
+                     (rename 'tmp)
+                     (cons (rename 'myor) (cddr expr))))))))
+
+(write (let ((tmp 6)) (myor #f tmp)))
+(newline)
+
+(let ((x 'outer))
+  (let-syntax ((with-x
+                (syntax-rules ()
+                  ((_ y expr)
+                   (let-syntax ((y (syntax-rules () ((_) x))))
+                     expr)))))
+    (let ((x 'inner))
+      (write (with-x z (z)))
+      (newline)))) 
diff --git a/tests/basic/test10-unhygiene.res b/tests/basic/test10-unhygiene.res
new file mode 100644
index 00000000..0d174dc4
--- /dev/null
+++ b/tests/basic/test10-unhygiene.res
@@ -0,0 +1,6 @@
+1
+1
+1
+6
+7
+8
diff --git a/tests/basic/test10-unhygiene.scm b/tests/basic/test10-unhygiene.scm
new file mode 100644
index 00000000..c69f2b37
--- /dev/null
+++ b/tests/basic/test10-unhygiene.scm
@@ -0,0 +1,49 @@
+
+(define-syntax aif
+  (sc-macro-transformer
+   (lambda (form environment)
+     (let ((condition
+            (make-syntactic-closure environment '() (cadr form)))
+           (consequent
+            (make-syntactic-closure environment '(it) (car (cddr form))))
+           (alternative
+            (make-syntactic-closure environment '() (cadr (cddr form)))))
+       `(let ((it ,condition))
+             (if it
+                 ,consequent
+                 ,alternative))))))
+
+(write (aif 1 it 3))
+(newline)
+
+(write (let ((it 4)) (aif 1 it 3)))
+(newline)
+
+(write (let ((it 4)) (aif (let ((it 5)) 1) it 3)))
+(newline)
+
+(write (let ((it 4)) (aif (let ((it 5)) 1) (let ((it 6)) it) 3)))
+(newline)
+
+(write
+ (letrec-syntax
+     ((myor
+       (er-macro-transformer
+        (lambda (expr rename compare)
+          (if (null? (cdr expr))
+              #f
+              (list (rename 'let) (list (list (rename 'it) (cadr expr)))
+                    (list (rename 'if) (rename 'it)
+                          (rename 'it)
+                          (cons (rename 'myor) (cddr expr)))))))))
+   (let ((it 7)) (myor #f it))))
+(newline)
+
+(define-syntax define-foo
+  (sc-macro-transformer
+   (lambda (form environment)
+     (make-syntactic-closure environment '(foo) `(define foo 8)))))
+
+(define-foo)
+(write foo)
+(newline)
diff --git a/tests/build/build-opts.txt b/tests/build/build-opts.txt
new file mode 100644
index 00000000..a22b3c57
--- /dev/null
+++ b/tests/build/build-opts.txt
@@ -0,0 +1,34 @@
+CPPFLAGS=-DSEXP_USE_MODULES=0
+CPPFLAGS=-DSEXP_USE_GREEN_THREADS=0
+CPPFLAGS=-DSEXP_USE_DL=0
+CPPFLAGS=-DSEXP_USE_SIMPLIFY=0
+CPPFLAGS=-DSEXP_USE_TYPE_DEFS=0
+SEXP_USE_BOEHM=1;CPPFLAGS=-I/opt/local/include;LDFLAGS=-L/opt/local/lib
+CPPFLAGS=-DSEXP_USE_DEBUG_GC=1
+CPPFLAGS=-DSEXP_USE_CONSERVATIVE_GC=1
+CPPFLAGS=-DSEXP_USE_GLOBAL_HEAP=1
+CPPFLAGS=-DSEXP_USE_GLOBAL_SYMBOLS=1
+CPPFLAGS=-DSEXP_USE_FLONUMS=0
+CPPFLAGS=-DSEXP_USE_IMMEDIATE_FLONUMS=1
+CPPFLAGS=-DSEXP_USE_BIGNUMS=0
+CPPFLAGS=-DSEXP_USE_COMPLEX=0
+CPPFLAGS=-DSEXP_USE_RATIOS=0
+CPPFLAGS=-DSEXP_USE_MATH=0
+CPPFLAGS=-DSEXP_WARN_UNDEFS=0
+CPPFLAGS=-DSEXP_USE_HUFF_SYMS=0
+CPPFLAGS=-DSEXP_USE_HASH_SYMS=0
+CPPFLAGS=-DSEXP_USE_STRING_STREAMS=1
+CPPFLAGS=-DSEXP_USE_AUTOCLOSE_PORTS=0
+CPPFLAGS=-DSEXP_USE_2010_EPOCH=0
+CPPFLAGS=-DSEXP_USE_CHECK_STACK=0
+CPPFLAGS=-DSEXP_USE_EXTENDED_FCALL=0
+CPPFLAGS=-DSEXP_USE_WEAK_REFERENCES=0
+CPPFLAGS=-DSEXP_USE_OBJECT_BRACE_LITERALS=0
+CPPFLAGS=-DSEXP_USE_TAIL_JUMPS=0
+CPPFLAGS=-DSEXP_USE_RESERVE_OPCODE=0
+CPPFLAGS=-DSEXP_USE_PROFILE_VM=1
+CPPFLAGS=-DSEXP_USE_UTF8_STRINGS=0
+CPPFLAGS=-DSEXP_USE_STATIC_LIBS=1
+CPPFLAGS=-DSEXP_USE_MUTABLE_STRINGS=0
+CPPFLAGS=-DSEXP_USE_STRICT_TOPLEVEL_BINDINGS=1
+CPPFLAGS=-DSEXP_USE_NO_FEATURES=1
diff --git a/tests/build/build-tests.sh b/tests/build/build-tests.sh
new file mode 100755
index 00000000..6f01102f
--- /dev/null
+++ b/tests/build/build-tests.sh
@@ -0,0 +1,55 @@
+#!/bin/sh
+
+# Test basic build options.
+
+# For bootstrapping reasons this is a shell script, instead of a
+# scheme script using (chibi process).
+
+# We just check each build against r5rs-tests.scm - some of the
+# libraries will fail to build (notably if modules or user-defined
+# types are disabled).
+
+BUILDDIR=tests/build
+FAILURES=0
+MAKE=${MAKE:-make}
+vars=CFLAGS="-O0 -g0 -w"
+i=0
+
+for opts in $(cat ${BUILDDIR}/build-opts.txt); do
+    # If compiling with static libs, we need to bootstrap to build
+    # clibs.c.
+    if echo ${opts} | grep -q 'SEXP_USE_STATIC_LIBS=1'; then
+        staticopts=$(echo ${opts} | sed 's/-DSEXP_USE_STATIC_LIBS=1;*//')
+        staticopts=$(echo ${staticopts} | tr ';' ' ')
+        $MAKE cleaner 2>&1 >/dev/null
+        rm -f clibs.c
+        $MAKE -j 8 "$vars" $staticopts 2>&1 >${BUILDDIR}/build${i}-bootstrap.out
+        $MAKE -j 8 "$vars" $staticopts clibs.c 2>&1 >${BUILDDIR}/build${i}-clibs.out
+    fi
+    # Try to build then run tests.
+    opts=$(echo ${opts} | tr ';' ' ')
+    $MAKE cleaner 2>&1 >/dev/null
+    sync
+    if $MAKE -j 8 "$vars" $opts chibi-scheme 2>&1 >${BUILDDIR}/build${i}-make.out; then
+        sync
+        if $MAKE test-r5rs 2>&1 | tee ${BUILDDIR}/build${i}-test.out \
+            | grep -q -E 'FAIL|ERROR'; then
+            echo "[FAIL] ${i}: tests failed with $opts"
+            FAILURES=$((FAILURES + 1))
+        else
+            echo "[PASS] ${i}: tests passed with $opts"
+        fi
+    else
+        echo "[FAIL] ${i}: couldn't build with $opts"
+        FAILURES=$((FAILURES + 1))
+    fi
+    i=$((i+1))
+done
+$MAKE cleaner 2>&1 >/dev/null
+
+if [ $FAILURES = 0 ]; then
+    echo "build-tests: all tests passed"
+else
+    echo "build-tests: ${FAILURES} tests failed"
+fi
+
diff --git a/tests/division-tests.scm b/tests/division-tests.scm
new file mode 100644
index 00000000..41cf6d43
--- /dev/null
+++ b/tests/division-tests.scm
@@ -0,0 +1,467 @@
+
+(import (chibi test) (scheme division))
+
+(test-begin "division")
+
+;; These verify the basic rounding operators floor, ceiling, truncate
+;; and round, on which the other tests depend.
+
+(test-begin "rounding")
+
+(test 4.0 (floor 4.3))
+(test 5.0 (ceiling 4.3))
+(test 4.0 (truncate 4.3))
+(test 4.0 (round 4.3))
+(test -5.0 (floor -4.3))
+(test -4.0 (ceiling -4.3))
+(test -4.0 (truncate -4.3))
+(test -4.0 (round -4.3))
+(test 3.0 (floor 3.5)) 
+(test 4.0 (ceiling 3.5)) 
+(test 3.0 (truncate 3.5)) 
+(test 4.0 (round 3.5))
+(test -4.0 (floor -3.5)) 
+(test -3.0 (ceiling -3.5)) 
+(test -3.0 (truncate -3.5)) 
+(test -4.0 (round -3.5))
+(test 3 (floor (/ 1300000000000000000000 400000000000000000000)))
+(test 4 (ceiling (/ 1300000000000000000000 400000000000000000000)))
+(test 3 (truncate (/ 1300000000000000000000 400000000000000000000)))
+(test 3 (round (/ 1300000000000000000000 400000000000000000000)))
+(test -4 (floor (/ -1300000000000000000000 400000000000000000000)))
+(test -3 (ceiling (/ -1300000000000000000000 400000000000000000000)))
+(test -3 (truncate (/ -1300000000000000000000 400000000000000000000)))
+(test -3 (round (/ -1300000000000000000000 400000000000000000000)))
+(test 650000000000000000000 (floor (/ 1300000000000000000001 2)))
+(test 650000000000000000001 (ceiling (/ 1300000000000000000001 2)))
+(test 650000000000000000000 (truncate (/ 1300000000000000000001 2)))
+(test 650000000000000000000 (round (/ 1300000000000000000001 2)))
+(test 650000000000000000001 (floor (/ 1300000000000000000003 2)))
+(test 650000000000000000002 (ceiling (/ 1300000000000000000003 2)))
+(test 650000000000000000001 (truncate (/ 1300000000000000000003 2)))
+(test 650000000000000000002 (round (/ 1300000000000000000003 2)))
+(test -650000000000000000001 (floor (/ -1300000000000000000001 2)))
+(test -650000000000000000000 (ceiling (/ -1300000000000000000001 2)))
+(test -650000000000000000000 (truncate (/ -1300000000000000000001 2)))
+(test -650000000000000000000 (round (/ -1300000000000000000001 2)))
+(test -650000000000000000002 (floor (/ -1300000000000000000003 2)))
+(test -650000000000000000001 (ceiling (/ -1300000000000000000003 2)))
+(test -650000000000000000001 (truncate (/ -1300000000000000000003 2)))
+(test -650000000000000000002 (round (/ -1300000000000000000003 2)))
+(test 4 (round 7/2))
+(test 7 (round 7))
+
+(test-end)
+
+(test-begin "trivial zero divisor")
+
+;; All operators are the same when the quotient is zero.
+
+(test 0 (ceiling-quotient 0 4))
+(test 0 (ceiling-quotient 0 -4))
+
+(test 0 (ceiling-remainder 0 4))
+(test 0 (ceiling-remainder 0 -4))
+
+(test 0 (floor-quotient 0 4))
+(test 0 (floor-quotient 0 -4))
+
+(test 0 (floor-remainder 0 4))
+(test 0 (floor-remainder 0 -4))
+
+(test 0 (truncate-quotient 0 4))
+(test 0 (truncate-quotient 0 -4))
+
+(test 0 (truncate-remainder 0 4))
+(test 0 (truncate-remainder 0 -4))
+
+(test 0 (round-quotient 0 4))
+(test 0 (round-quotient 0 -4))
+
+(test 0 (round-remainder 0 4))
+(test 0 (round-remainder 0 -4))
+
+(test 0 (euclidean-quotient 0 4))
+(test 0 (euclidean-quotient 0 -4))
+
+(test 0 (euclidean-remainder 0 4))
+(test 0 (euclidean-remainder 0 -4))
+
+(test 0 (centered-quotient 0 4))
+(test 0 (centered-quotient 0 -4))
+
+(test 0 (centered-remainder 0 4))
+(test 0 (centered-remainder 0 -4))
+
+(test-end)
+
+(test-begin "trivial one dividend")
+
+;; The remainder is always zero when dividing by one.
+
+(test 13 (ceiling-quotient 13 1))
+(test -13 (ceiling-quotient -13 1))
+
+(test 0 (ceiling-remainder 13 1))
+(test 0 (ceiling-remainder -13 1))
+
+(test 13 (floor-quotient 13 1))
+(test -13 (floor-quotient -13 1))
+
+(test 0 (floor-remainder 13 1))
+(test 0 (floor-remainder -13 1))
+
+(test 13 (truncate-quotient 13 1))
+(test -13 (truncate-quotient -13 1))
+
+(test 0 (truncate-remainder 13 1))
+(test 0 (truncate-remainder -13 1))
+
+(test 13 (round-quotient 13 1))
+(test -13 (round-quotient -13 1))
+
+(test 0 (round-remainder 13 1))
+(test 0 (round-remainder -13 1))
+
+(test 13 (euclidean-quotient 13 1))
+(test -13 (euclidean-quotient -13 1))
+
+(test 0 (euclidean-remainder 13 1))
+(test 0 (euclidean-remainder -13 1))
+
+(test 13 (centered-quotient 13 1))
+(test -13 (centered-quotient -13 1))
+
+(test 0 (centered-remainder 13 1))
+(test 0 (centered-remainder -13 1))
+
+(test-end)
+
+(test-begin "fixnum division")
+
+;; Ceiling rounds towards positive infinity.
+
+(test 4 (ceiling-quotient 13 4))
+(test -3 (ceiling-quotient -13 4))
+(test -3 (ceiling-quotient 13 -4))
+(test 4 (ceiling-quotient -13 -4))
+
+(test -3 (ceiling-remainder 13 4))
+(test -1 (ceiling-remainder -13 4))
+(test 1 (ceiling-remainder 13 -4))
+(test 3 (ceiling-remainder -13 -4))
+
+;; Floor rounds towards negative infinity.
+
+(test 3 (floor-quotient 13 4))
+(test -4 (floor-quotient -13 4))
+(test -4 (floor-quotient 13 -4))
+(test 3 (floor-quotient -13 -4))
+
+(test 1 (floor-remainder 13 4))
+(test 3 (floor-remainder -13 4))
+(test -3 (floor-remainder 13 -4))
+(test -1 (floor-remainder -13 -4))
+
+;; Truncate rounds towards zero - the magnitudes never change
+;; regardless of the signs.
+
+(test 3 (truncate-quotient 13 4))
+(test -3 (truncate-quotient -13 4))
+(test -3 (truncate-quotient 13 -4))
+(test 3 (truncate-quotient -13 -4))
+
+(test 1 (truncate-remainder 13 4))
+(test -1 (truncate-remainder -13 4))
+(test 1 (truncate-remainder 13 -4))
+(test -1 (truncate-remainder -13 -4))
+
+;; Round rounds towards the nearest integer - it's equivalent to floor
+;; when signs are the same, and equivalent to ceiling when the signs
+;; differ.
+
+(test 3 (round-quotient 13 4))
+(test -3 (round-quotient -13 4))
+(test -3 (round-quotient 13 -4))
+(test 3 (round-quotient -13 -4))
+
+(test 1 (round-remainder 13 4))
+(test -1 (round-remainder -13 4))
+(test 1 (round-remainder 13 -4))
+(test -1 (round-remainder -13 -4))
+
+;; Euclidean rounds such that the remainder is always in the interval
+;; [0, divisor) - i.e. the remainder is always non-negative.  It's
+;; equivalent to floor if the divisor is negative, and ceiling
+;; otherwise.
+
+(test 3 (euclidean-quotient 13 4))
+(test -4 (euclidean-quotient -13 4))
+(test -3 (euclidean-quotient 13 -4))
+(test 4 (euclidean-quotient -13 -4))
+
+(test 1 (euclidean-remainder 13 4))
+(test 3 (euclidean-remainder -13 4))
+(test 1 (euclidean-remainder 13 -4))
+(test 3 (euclidean-remainder -13 -4))
+
+;; Centered differs from truncate only in the 0.5 remainder border
+;; case in the next test group.
+
+(test 3 (centered-quotient 13 4))
+(test -3 (centered-quotient -13 4))
+(test -3 (centered-quotient 13 -4))
+(test 3 (centered-quotient -13 -4))
+
+(test 1 (centered-remainder 13 4))
+(test -1 (centered-remainder -13 4))
+(test 1 (centered-remainder 13 -4))
+(test -1 (centered-remainder -13 -4))
+
+(test-end)
+
+(test-begin "one half remainder")
+
+;; Testing the 0.5 remainder border cases.  Ceiling, floor and
+;; truncate and euclidean don't change.
+
+(test 7 (ceiling-quotient 13 2))
+(test -6 (ceiling-quotient -13 2))
+(test -6 (ceiling-quotient 13 -2))
+(test 7 (ceiling-quotient -13 -2))
+
+(test -1 (ceiling-remainder 13 2))
+(test -1 (ceiling-remainder -13 2))
+(test 1 (ceiling-remainder 13 -2))
+(test 1 (ceiling-remainder -13 -2))
+
+(test 6 (floor-quotient 13 2))
+(test -7 (floor-quotient -13 2))
+(test -7 (floor-quotient 13 -2))
+(test 6 (floor-quotient -13 -2))
+
+(test 1 (floor-remainder 13 2))
+(test 1 (floor-remainder -13 2))
+(test -1 (floor-remainder 13 -2))
+(test -1 (floor-remainder -13 -2))
+
+(test 6 (truncate-quotient 13 2))
+(test -6 (truncate-quotient -13 2))
+(test -6 (truncate-quotient 13 -2))
+(test 6 (truncate-quotient -13 -2))
+
+(test 1 (truncate-remainder 13 2))
+(test -1 (truncate-remainder -13 2))
+(test 1 (truncate-remainder 13 -2))
+(test -1 (truncate-remainder -13 -2))
+
+(test 6 (euclidean-quotient 13 2))
+(test -7 (euclidean-quotient -13 2))
+(test -6 (euclidean-quotient 13 -2))
+(test 7 (euclidean-quotient -13 -2))
+
+(test 1 (euclidean-remainder 13 2))
+(test 1 (euclidean-remainder -13 2))
+(test 1 (euclidean-remainder 13 -2))
+(test 1 (euclidean-remainder -13 -2))
+
+;; For consistency with the default rounding mode specified by the
+;; IEEE floating point standard, round rounds to even when exactly
+;; half-way between two integers.
+
+(test 6 (round-quotient 13 2))
+(test -6 (round-quotient -13 2))
+(test -6 (round-quotient 13 -2))
+(test 6 (round-quotient -13 -2))
+
+(test 1 (round-remainder 13 2))
+(test -1 (round-remainder -13 2))
+(test 1 (round-remainder 13 -2))
+(test -1 (round-remainder -13 -2))
+
+;; Centered rounds up when exactly half-way between two integers.
+
+(test 7 (centered-quotient 13 2))
+(test -6 (centered-quotient -13 2))
+(test -7 (centered-quotient 13 -2))
+(test 6 (centered-quotient -13 -2))
+
+(test -1 (centered-remainder 13 2))
+(test -1 (centered-remainder -13 2))
+(test -1 (centered-remainder 13 -2))
+(test -1 (centered-remainder -13 -2))
+
+(test-end)
+
+(test-begin "exactness")
+
+(define-syntax values->list
+  (syntax-rules ()
+    ((values->list expr) (call-with-values (lambda () expr) list))))
+
+(test '(4.0 -3.0) (values->list (ceiling/ 13.0 4)))
+(test '(4.0 -3.0) (values->list (ceiling/ 13 4.0)))
+(test '(4.0 -3.0) (values->list (ceiling/ 13.0 4.0)))
+
+(test 4.0 (ceiling-quotient 13.0 4))
+(test 4.0 (ceiling-quotient 13 4.0))
+(test 4.0 (ceiling-quotient 13.0 4.0))
+
+(test -3.0 (ceiling-remainder 13.0 4))
+(test -3.0 (ceiling-remainder 13 4.0))
+(test -3.0 (ceiling-remainder 13.0 4.0))
+
+(test '(3.0 1.0) (values->list (floor/ 13.0 4)))
+(test '(3.0 1.0) (values->list (floor/ 13 4.0)))
+(test '(3.0 1.0) (values->list (floor/ 13.0 4.0)))
+
+(test 3.0 (floor-quotient 13.0 4))
+(test 3.0 (floor-quotient 13 4.0))
+(test 3.0 (floor-quotient 13.0 4.0))
+
+(test 1.0 (floor-remainder 13.0 4))
+(test 1.0 (floor-remainder 13 4.0))
+(test 1.0 (floor-remainder 13.0 4.0))
+
+(test '(3.0 1.0) (values->list (truncate/ 13.0 4)))
+(test '(3.0 1.0) (values->list (truncate/ 13 4.0)))
+(test '(3.0 1.0) (values->list (truncate/ 13.0 4.0)))
+
+(test 3.0 (truncate-quotient 13.0 4))
+(test 3.0 (truncate-quotient 13 4.0))
+(test 3.0 (truncate-quotient 13.0 4.0))
+
+(test 1.0 (truncate-remainder 13.0 4))
+(test 1.0 (truncate-remainder 13 4.0))
+(test 1.0 (truncate-remainder 13.0 4.0))
+
+(test '(3.0 1.0) (values->list (round/ 13.0 4)))
+(test '(3.0 1.0) (values->list (round/ 13 4.0)))
+(test '(3.0 1.0) (values->list (round/ 13.0 4.0)))
+
+(test 3.0 (round-quotient 13.0 4))
+(test 3.0 (round-quotient 13 4.0))
+(test 3.0 (round-quotient 13.0 4.0))
+
+(test 1.0 (round-remainder 13.0 4))
+(test 1.0 (round-remainder 13 4.0))
+(test 1.0 (round-remainder 13.0 4.0))
+
+(test '(3.0 1.0) (values->list (euclidean/ 13.0 4)))
+(test '(3.0 1.0) (values->list (euclidean/ 13 4.0)))
+(test '(3.0 1.0) (values->list (euclidean/ 13.0 4.0)))
+
+(test 3.0 (euclidean-quotient 13.0 4))
+(test 3.0 (euclidean-quotient 13 4.0))
+(test 3.0 (euclidean-quotient 13.0 4.0))
+
+(test 1.0 (euclidean-remainder 13.0 4))
+(test 1.0 (euclidean-remainder 13 4.0))
+(test 1.0 (euclidean-remainder 13.0 4.0))
+
+(test '(3.0 1.0) (values->list (centered/ 13.0 4)))
+(test '(3.0 1.0) (values->list (centered/ 13 4.0)))
+(test '(3.0 1.0) (values->list (centered/ 13.0 4.0)))
+
+(test 3.0 (centered-quotient 13.0 4))
+(test 3.0 (centered-quotient 13 4.0))
+(test 3.0 (centered-quotient 13.0 4.0))
+
+(test 1.0 (centered-remainder 13.0 4))
+(test 1.0 (centered-remainder 13 4.0))
+(test 1.0 (centered-remainder 13.0 4.0))
+
+(test-end)
+
+(test-begin "bignum division")
+
+;; A repeat of the fixnum division tests above, using bignums to test
+;; bignum division.
+
+(test 4 (ceiling-quotient 1300000000000000000000 400000000000000000000))
+(test -3 (ceiling-quotient -1300000000000000000000 400000000000000000000))
+(test -3 (ceiling-quotient 1300000000000000000000 -400000000000000000000))
+(test 4 (ceiling-quotient -1300000000000000000000 -400000000000000000000))
+
+(test -300000000000000000000
+      (ceiling-remainder 1300000000000000000000 400000000000000000000))
+(test -100000000000000000000
+      (ceiling-remainder -1300000000000000000000 400000000000000000000))
+(test 100000000000000000000
+      (ceiling-remainder 1300000000000000000000 -400000000000000000000))
+(test 300000000000000000000
+      (ceiling-remainder -1300000000000000000000 -400000000000000000000))
+
+(test 3 (floor-quotient 1300000000000000000000 400000000000000000000))
+(test -4 (floor-quotient -1300000000000000000000 400000000000000000000))
+(test -4 (floor-quotient 1300000000000000000000 -400000000000000000000))
+(test 3 (floor-quotient -1300000000000000000000 -400000000000000000000))
+
+(test 100000000000000000000
+      (floor-remainder 1300000000000000000000 400000000000000000000))
+(test 300000000000000000000
+      (floor-remainder -1300000000000000000000 400000000000000000000))
+(test -300000000000000000000
+      (floor-remainder 1300000000000000000000 -400000000000000000000))
+(test -100000000000000000000
+      (floor-remainder -1300000000000000000000 -400000000000000000000))
+
+(test 3 (truncate-quotient 1300000000000000000000 400000000000000000000))
+(test -3 (truncate-quotient -1300000000000000000000 400000000000000000000))
+(test -3 (truncate-quotient 1300000000000000000000 -400000000000000000000))
+(test 3 (truncate-quotient -1300000000000000000000 -400000000000000000000))
+
+(test 100000000000000000000
+      (truncate-remainder 1300000000000000000000 400000000000000000000))
+(test -100000000000000000000
+      (truncate-remainder -1300000000000000000000 400000000000000000000))
+(test 100000000000000000000
+      (truncate-remainder 1300000000000000000000 -400000000000000000000))
+(test -100000000000000000000
+      (truncate-remainder -1300000000000000000000 -400000000000000000000))
+
+(test 3 (round-quotient 1300000000000000000000 400000000000000000000))
+(test -3 (round-quotient -1300000000000000000000 400000000000000000000))
+(test -3 (round-quotient 1300000000000000000000 -400000000000000000000))
+(test 3 (round-quotient -1300000000000000000000 -400000000000000000000))
+
+(test 100000000000000000000
+      (round-remainder 1300000000000000000000 400000000000000000000))
+(test -100000000000000000000
+      (round-remainder -1300000000000000000000 400000000000000000000))
+(test 100000000000000000000
+      (round-remainder 1300000000000000000000 -400000000000000000000))
+(test -100000000000000000000
+      (round-remainder -1300000000000000000000 -400000000000000000000))
+
+(test 3 (euclidean-quotient 1300000000000000000000 400000000000000000000))
+(test -4 (euclidean-quotient -1300000000000000000000 400000000000000000000))
+(test -3 (euclidean-quotient 1300000000000000000000 -400000000000000000000))
+(test 4 (euclidean-quotient -1300000000000000000000 -400000000000000000000))
+
+(test 100000000000000000000
+      (euclidean-remainder 1300000000000000000000 400000000000000000000))
+(test 300000000000000000000
+      (euclidean-remainder -1300000000000000000000 400000000000000000000))
+(test 100000000000000000000
+      (euclidean-remainder 1300000000000000000000 -400000000000000000000))
+(test 300000000000000000000
+      (euclidean-remainder -1300000000000000000000 -400000000000000000000))
+
+(test 3 (centered-quotient 1300000000000000000000 400000000000000000000))
+(test -3 (centered-quotient -1300000000000000000000 400000000000000000000))
+(test -3 (centered-quotient 1300000000000000000000 -400000000000000000000))
+(test 3 (centered-quotient -1300000000000000000000 -400000000000000000000))
+
+(test 100000000000000000000
+      (centered-remainder 1300000000000000000000 400000000000000000000))
+(test -100000000000000000000
+      (centered-remainder -1300000000000000000000 400000000000000000000))
+(test 100000000000000000000
+      (centered-remainder 1300000000000000000000 -400000000000000000000))
+(test -100000000000000000000
+      (centered-remainder -1300000000000000000000 -400000000000000000000))
+
+(test-end)
+
+(test-end)
diff --git a/tests/ffi/ffi-tests.scm b/tests/ffi/ffi-tests.scm
new file mode 100644
index 00000000..6376ed72
--- /dev/null
+++ b/tests/ffi/ffi-tests.scm
@@ -0,0 +1,471 @@
+
+(import (chibi) (chibi ast) (chibi match)
+        (chibi process) (chibi filesystem) (chibi test))
+
+(test-begin "ffi")
+
+(define-syntax test-ffi
+  (syntax-rules ()
+    ((test-ffi name-expr decls tests ...)
+     (let* ((name name-expr)
+            (stub-file (string-append "tests/ffi/" name ".stub"))
+            (c-file (string-append "tests/ffi/" name ".c"))
+            (lib-file
+             (string-append "tests/ffi/" name *shared-object-extension*)))
+       (call-with-output-file stub-file
+         (lambda (out) (write 'decls out) (newline out)))
+       (let ((res (system
+                   "./chibi-scheme" "tools/chibi-ffi" "-c"
+                   "-f" (string-append
+                         "-O0 -L. -Iinclude"
+                         (cond-expand
+                          (boehm-gc
+                           " -DSEXP_USE_BOEHM=1 -I/opt/local/include")
+                          (else
+                           "")))
+                   stub-file)))
+         (cond
+          ((zero? (cadr res))
+           (let ((orig-failures (test-failure-count)))
+             (load lib-file)
+             tests ...
+             ;; on any failure leave the stub and c file for reference
+             (cond
+              ((= orig-failures (test-failure-count))
+               (delete-file stub-file)
+               (delete-file c-file)))
+             (delete-file lib-file)))
+          (else
+           (test-assert (string-append "couldn't compile " name)
+             #f))))))))
+
+;; A couple of dummy definitions to ensure the basic FFI and test
+;; framework are working.
+(test-ffi
+ "basic"
+ (begin
+   (c-declare "
+int zero() {
+  return 0;
+}
+int cube(int x) {
+  return x * x * x;
+}
+int sub(int x, int y) {
+  return x - y;
+}
+")
+   (define-c int zero ())
+   (define-c int cube (int))
+   (define-c int sub (int int)))
+ (test 0 (zero))
+ (test 4 (sub 7 3))
+ (test -27 (cube -3))
+ (test -3 (sub (zero) 3)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; More detailed tests on integer conversions and overflow.
+
+(cond
+ ((fixnum? (expt 2 60))
+  (test-ffi
+   "integers"
+   (begin
+     (c-declare "
+unsigned hoge(unsigned x) {
+  return x;
+}
+long poge(long x) {
+  return x;
+}
+unsigned long piyo(unsigned long x) {
+  return x;
+}
+int ponyo(int x) {
+  return !x;
+}
+enum suuji {
+  ichi, ni, san, yon, go, roku, shichi, hachi, kyuu, juu
+};
+enum suuji tasu(enum suuji a, enum suuji b) {
+  return a + b;
+}
+")
+     (define-c unsigned hoge (unsigned))
+     (define-c long poge (long))
+     (define-c unsigned-long piyo (unsigned-long))
+     (define-c boolean ponyo (boolean))
+     (define-c-int-type suuji)
+     (define-c suuji tasu (suuji suuji)))
+   ;; static cast
+   (test 4294967295 (hoge -1))
+   ;; pass and return a signed bignum
+   (test -9223372036854775808 (poge (- (expt 2 63))))
+   ;; pass and return an unsigned bignum
+   (test 4611686018427387904 (piyo (expt 2 62)))
+   ;; booleans
+   (test #f (ponyo 'blah))
+   (test #t (ponyo #f))
+   ;; int types
+   (test 5 (tasu 2 3))
+   )))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; String passing, returning and mutation.
+
+(test-ffi
+ "strings"
+ (begin
+   (c-declare "
+int char_count(char* str, char ch) {
+  int count = 0;
+  if (!str) return -1;
+  while (*str) if (*str++ == ch) count++;
+  return count;
+}
+
+char message[] = \"Hello, World!\";
+char* get_message() {
+  return message;
+}
+char* get_message2(int k) {
+  return k == 1 ? message : NULL;
+}
+
+void reverse_string(char* str) {
+  int lo=0, hi=strlen(str)-1, ch;
+  for (; lo < hi; lo++, hi--) {
+    ch = str[lo];
+    str[lo] = str[hi];
+    str[hi] = ch;
+  }
+}
+
+char test_cwd[] = \"/home/home/on/the/range\";
+char* my_getcwd(char* buf, int len) {
+  char* res = test_cwd;
+  int needed = strlen(res);
+  if (needed >= len) return NULL;
+  strncpy(buf, res, needed+1);
+  return res;
+}
+")
+
+   (define-c int char_count (string char))
+   (define-c int (char_count2 char_count) (char* char))
+   (define-c int (char_count3 char_count) (char* int))
+   (define-c int (char_count4 char_count) ((maybe-null char*) int))
+   ;; failures
+   ;;(define-c int (char_count5 char_count) ((pointer char) int))
+   ;;(define-c int (char_count6 char_count) ((array char) int))
+   (define-c string get_message ())
+   ;; fix maybe-null results
+   ;;(define-c (maybe-null string) get_message2 (int))
+   ;; fix error results
+   ;;(define-c non-null-string (get_message3 get_message2) (int))
+   (define-c (free string) strdup (string))
+   (define-c void reverse_string (string))
+   (define-c non-null-string my_getcwd
+     ((result (array char (auto-expand arg1))) (value 4 int)))
+   (define-c non-null-string strncpy
+     (string string (value (string-length arg1) int)))
+   )
+ (test 1 (char_count "1-2" #\-))
+ (test 2 (char_count2 "1-2-3" #\-))
+ (test 3 (char_count3 "-1-2-3" #x2D))
+ (test -1 (char_count4 #f #x2D))
+ (test 4 (char_count4 "-1-2-3-" #x2D))
+ ;;(test 5 (char_count5 "-1--2-3-" #x2D))
+ ;;(test 5 (char_count5 "-1-2--3-" #x2D))
+ (test "Hello, World!" (get_message))
+ ;; (test "Hello, World!" (get_message2 1))
+ ;; (test #f (get_message2 0))
+ ;; (test "Hello, World!" (get_message3 1))
+ ;; (test #f (get_message3 0))
+ ;; memory leak
+ (test "Hello, World!" (strdup "Hello, World!"))
+ (let ((str "abcdef"))
+   (reverse_string str)
+   (test "fedcba" str))
+ (test "/home/home/on/the/range" (my_getcwd))
+ (let ((str1 "abcdef")
+       (str2 "xxx"))
+   (test #t (strncpy str1 str2))  ;; update after fixing error results
+   (test "xxxdef" str1))
+ )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Structs and opaque types.
+
+(test-ffi
+ "structs"
+ (begin
+   (c-declare "
+struct Point {
+  double x, y;
+};
+struct Rectangle {
+  struct Point *top_left, *bottom_right;
+};
+struct Circle {
+  struct Point center;
+  double radius;
+};
+typedef struct {
+  short r, g, b;
+} Color;
+typedef struct {
+  struct Circle circle;
+  Color color;
+} ColoredCircle;
+
+void set_color(short r, short g, short b, Color* res) {
+  res->r = r;
+  res->g = g;
+  res->b = b;
+}
+
+Color* make_color(short r, short g, short b) {
+  Color* res = malloc(sizeof(Color));
+  if (res) {
+    res->r = r;
+    res->g = g;
+    res->b = b;
+  }
+  return res;
+}
+
+short color_red(Color* color) {
+  return color->r;
+}
+
+int draw_rect(struct Rectangle* rect, Color color) {
+  return 0;
+}
+
+double circle_area1(struct Circle* circ) {
+  return (circ->radius * circ->radius * 3.14);
+}
+double circle_area2(struct Circle circ) {
+  return circle_area1(&circ);
+}
+")
+   (define-c-struct Point
+     predicate: point?
+     constructor: (make-point x y)
+     (double x point-x point-x-set!)
+     (double y point-y point-y-set!))
+   (define-c-struct Rectangle
+     predicate: rect?
+     constructor: (make-rect top_left bottom_right)
+     (Point top_left rect-top-left)
+     (Point bottom_right rect-bottom-right))
+   ;; constructor with point fails
+   (define-c-struct Circle
+     predicate: circle?
+     constructor: (make-circle radius)
+     ((struct Point) center circle-center)
+     (double radius circle-radius))
+   (define-c double circle_area1 (Circle))
+   ;; TODO: struct means no pointer
+   ;;(define-c double circle_area2 ((struct Circle)))
+   (define-c-type Color predicate: color?)
+   (define-c void set_color (short short short (result pointer Color)))
+   (define-c Color make_color (short short short))
+   (define-c short color_red ((pointer Color)))
+   ;;(define-c errno draw_rect (Rectangle Color))
+   )
+ (test-assert (point? (make-point 1. 2.)))
+ (test 1. (point-x (make-point 1. 2.)))
+ (test 2. (point-y (make-point 1. 2.)))
+ (test 3. (point-x (let ((pt (make-point 1. 2.))) (point-x-set! pt 3.) pt)))
+ ;; need constructor argument checking
+ ;;(test-error (rect? (make-rect 1 2)))
+ ;; gc miss - we don't preserve the pointers
+ (test-assert (rect? (make-rect (make-point 1. 2.) (make-point 3. 4.))))
+ (test-assert
+     (point? (rect-top-left
+              (make-rect (make-point 1. 2.) (make-point 3. 4.)))))
+ (test-assert
+     (point? (rect-bottom-right
+              (make-rect (make-point 1. 2.) (make-point 3. 4.)))))
+ (test 2.
+     (point-y (rect-top-left
+               (make-rect (make-point 1. 2.) (make-point 3. 4.)))))
+ (test 3.
+     (point-x (rect-bottom-right
+               (make-rect (make-point 1. 2.) (make-point 3. 4.)))))
+ (test-assert (circle? (make-circle 3.)))
+ (test 3.0 (circle-radius (make-circle 3.)))
+ (test 28.26 (circle_area1 (make-circle 3.)))
+ ;;(test 28.26 (circle_area2 (make-circle 3.)))
+ (let ((circle (make-circle 3.)))
+   (point-x-set! (circle-center circle) 7.)
+   (point-y-set! (circle-center circle) 11.)
+   (test 7. (point-x (circle-center circle)))
+   (test 11. (point-y (circle-center circle))))
+ (test-assert (color? (set_color 1 2 3)))
+ (test 1 (color_red (set_color 1 2 3)))
+ (test-assert (color? (make_color 1 2 3)))
+ (test 1 (color_red (make_color 1 2 3)))
+ )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Exception wrapping.
+
+(test-ffi
+ "exceptions"
+ (begin
+   (c-declare "
+sexp usererror(sexp ctx, sexp self, const char* str) {
+  return sexp_maybe_wrap_error(ctx, sexp_user_exception(ctx, self, str, SEXP_NULL));
+}
+")
+   (define-c sexp usererror
+     ((value ctx sexp) (value self sexp) string)))
+ (test-assert (exception? (usererror "BOOM!")))
+ (test-error (usererror 'not-a-string)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; More complex return parameters.
+
+(test-ffi
+ "results"
+ (begin
+   (c-declare "
+struct password {
+  char* pw_name;
+  char* pw_passwd;
+};
+char* etc_passwd[] = {
+  \"root:12345\",
+  \"joe:joe\",
+};
+int getpwnam_x(char* name, struct password* pwd, char* buf,
+               size_t bufsize, struct password** res) {
+  int i;
+  char* entry;
+  for (i=0; i < sizeof(etc_passwd) / sizeof(etc_passwd[0]); i++) {
+    entry = etc_passwd[i];
+    if (strstr(entry, name) == entry && entry[strlen(name)] == ':') {
+      strncpy(buf, entry, bufsize);
+      buf[strlen(entry)] = 0;
+      buf[strlen(name)] = 0;
+      pwd->pw_name = buf;
+      pwd->pw_passwd = buf + strlen(name) + 1;
+      *res = pwd;
+      return 0;
+    }
+  }
+  *res = NULL;
+  return -1;
+}
+")
+   (define-c-struct password
+     predicate: user?
+     (string  pw_name     user-name)
+     (string  pw_passwd   user-password))
+   (define-c errno getpwnam_x
+     (string
+      (result password)
+      (link string)
+      (value (string-length arg2) int)
+      (result pointer password))))
+ (test-assert (user? (car (getpwnam_x "root" (make-string 1024)))))
+ (test "root" (user-name (car (getpwnam_x "root" (make-string 1024)))))
+ (test "12345" (user-password (car (getpwnam_x "root" (make-string 1024)))))
+ (test-assert (user? (car (getpwnam_x "joe" (make-string 1024)))))
+ (test "joe" (user-name (car (getpwnam_x "joe" (make-string 1024)))))
+ (test "joe" (user-password (car (getpwnam_x "joe" (make-string 1024)))))
+ (test-not (getpwnam_x "hacker" (make-string 1024)))
+ )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Field introspection and matching.
+
+(test-ffi
+ "introspection"
+ (begin
+   (c-declare "
+struct point3d {
+  int x, y, z;
+};
+")
+   (define-c-struct point3d
+     predicate: point3d?
+     constructor: (make-point3d x y z)
+     (int x point3d-x point3d-x-set!)
+     (int y point3d-y point3d-y-set!)
+     (int z point3d-z point3d-z-set!)))
+ (test-assert (point3d? (make-point3d 1 2 3)))
+ (test '(4 5 6)
+     (let ((pt (make-point3d 4 5 6)))
+       (list (point3d-x pt) (point3d-y pt) (point3d-z pt))))
+ (test '(7 8 9)
+     (match (make-point3d 7 8 9)
+       (($ point3d a b c) (list a b c))))
+ (test '(12 11 10)
+     (match (make-point3d 10 11 12)
+       ((@ point3d (z a) (y b) (x c)) (list a b c))))
+ (test '(13 14 15 42)
+     (let ((pt (make-point3d 13 14 15)))
+       (match pt
+         ((@ point3d (y b) (z (and (set! set-z!) orig-z)) (x c))
+          (set-z! 42)
+          (list c b orig-z (point3d-z pt))))))
+ )
+
+(test-ffi
+ "virtual accessors"
+ (begin
+   (c-declare "
+struct VirtComplex {
+  double r, phi;
+};
+double complex_real(struct VirtComplex* c) {
+  return c->r * cos(c->phi);
+}
+double complex_imag(struct VirtComplex* c) {
+  return c->r * sin(c->phi);
+}
+void complex_set(struct VirtComplex* c, double x, double y) {
+  c->r = sqrt(x*x + y*y);
+  c->phi = atan2(y, x);
+}
+void complex_real_set(struct VirtComplex* c, double x) {
+  complex_set(c, x, complex_imag(c));
+}
+void complex_imag_set(struct VirtComplex* c, double y) {
+  complex_set(c, complex_real(c), y);
+}
+")
+   (define-c-struct VirtComplex
+     predicate: virt-complex?
+     constructor: (make-virt-complex real imag)
+     (double real
+             (virt-complex-real function: "complex_real")
+             (virt-complex-real-set! function: "complex_real_set"))
+     (double imag
+             (virt-complex-imag function: "complex_imag")
+             (virt-complex-imag-set! function: "complex_imag_set"))
+     ))
+ (test-assert (virt-complex? (make-virt-complex 1.0 2.0)))
+ (test 1.0 (virt-complex-real (make-virt-complex 1.0 2.0)))
+ (test 2.0 (virt-complex-imag (make-virt-complex 1.0 2.0)))
+ (let ((c (make-virt-complex 1.0 2.0)))
+   (test 1.0 (virt-complex-real c))
+   (virt-complex-real-set! c 3.0)
+   (test 3.0 (virt-complex-real c))
+   (test 2.0 (virt-complex-imag c)))
+ (test '(5 6 7)
+     (let ((c (make-virt-complex 5.0 6.0)))
+       (match c
+         ((@ VirtComplex (real r) (imag (and (set! set-imag!) orig-i)))
+          (set-imag! 7.0)
+          (map inexact->exact
+               (map round (list r orig-i (virt-complex-imag c))))))))
+ )
+
+;; TODO: virtual method accessors
+
+(test-end)
diff --git a/tests/filesystem-tests.scm b/tests/filesystem-tests.scm
new file mode 100644
index 00000000..459f30cb
--- /dev/null
+++ b/tests/filesystem-tests.scm
@@ -0,0 +1,74 @@
+
+(import (chibi) (chibi io) (chibi filesystem) (chibi test) (srfi 33))
+
+(test-begin "filesystem")
+
+(define tmp-file "/tmp/chibi-fs-test-0123456789")
+(define tmp-file2 "/tmp/chibi-fs-test-0123456789-2")
+(define tmp-link "/tmp/chibi-fs-test-0123456789-link")
+(define tmp-dir "/tmp/chibi-fs-test-0123456789-dir")
+
+(call-with-output-file tmp-file
+  (lambda (out) (display "0123456789" out)))
+
+(test-assert (file-exists? tmp-file))
+(test "0123456789" (call-with-input-file tmp-file port->string))
+
+;; call-with-output-file truncates
+(call-with-output-file tmp-file
+  (lambda (out) (display "xxxxx" out)))
+(test "xxxxx" (call-with-input-file tmp-file port->string))
+
+(call-with-output-file tmp-file
+  (lambda (out) (display "0123456789" out)))
+(test "0123456789" (call-with-input-file tmp-file port->string))
+
+;; open without open/truncate writes in place
+(let* ((fd (open tmp-file open/write))
+       (out (open-output-file-descriptor fd)))
+  (display "xxxxx" out)
+  (close-output-port out))
+(test "xxxxx56789" (call-with-input-file tmp-file port->string))
+
+;; file-truncate can explicitly truncate
+(let* ((fd (open tmp-file open/write))
+       (out (open-output-file-descriptor fd)))
+  (display "01234" out)
+  (file-truncate out 7)
+  (close-output-port out))
+(test "0123456" (call-with-input-file tmp-file port->string))
+
+;; symbolic links
+(test-assert (symbolic-link-file tmp-file tmp-link))
+(test-assert (file-exists? tmp-link))
+(test-assert (file-link? tmp-link))
+(test tmp-file (read-link tmp-link))
+
+;; rename
+(test-assert (rename-file tmp-file tmp-file2))
+(test-not (file-exists? tmp-file))
+(test-not (file-exists? tmp-link))
+(test-assert (file-link? tmp-link))
+(test-assert (delete-file tmp-link))
+(test-not (file-exists? tmp-link))
+
+;; cleanup
+(test-assert (delete-file tmp-file2))
+(test-not (file-exists? tmp-file2))
+
+;; directories
+(test-assert (file-directory? "."))
+(test-assert (file-directory? ".."))
+(test-assert (file-directory? "/"))
+(test-not (file-regular? "."))
+(test-assert (create-directory tmp-dir))
+(test-assert (file-directory? tmp-dir))
+(test-not (file-regular? tmp-dir))
+(test-assert
+  (let ((files (directory-files tmp-dir)))
+    (or (equal? files '("." ".."))
+        (equal? files '(".." ".")))))
+(test-assert (delete-directory tmp-dir))
+(test-not (file-directory? tmp-dir))
+
+(test-end)
diff --git a/tests/flonum-tests.scm b/tests/flonum-tests.scm
new file mode 100644
index 00000000..424c381f
--- /dev/null
+++ b/tests/flonum-tests.scm
@@ -0,0 +1,23 @@
+;;;; these will fail when compiled either without flonums or trig funcs
+
+(cond-expand
+ (modules (import (only (chibi test) test-begin test-assert test test-end)))
+ (else #f))
+
+(test-begin "floating point")
+
+(test-assert (= -5 (floor -4.3)))
+(test-assert (= -4 (ceiling -4.3)))
+(test-assert (= -4 (truncate -4.3)))
+(test-assert (= -4 (round -4.3)))
+(test-assert (= 3 (floor 3.5)))
+(test-assert (= 4 (ceiling 3.5)))
+(test-assert (= 3 (truncate 3.5)))
+(test-assert (= 4 (round 3.5)))
+
+(test 1124378190243790143.0 (exact->inexact 1124378190243790143))
+
+;; (test "1124378190243790143.0"
+;;     (number->string (exact->inexact 1124378190243790143)))
+
+(test-end)
diff --git a/tests/foreign/apply-loop.c b/tests/foreign/apply-loop.c
new file mode 100644
index 00000000..3feb6d98
--- /dev/null
+++ b/tests/foreign/apply-loop.c
@@ -0,0 +1,40 @@
+
+#include "chibi/eval.h"
+
+sexp sexp_apply_times_to_pi(sexp ctx, sexp self, sexp_sint_t n,
+                            sexp fn, sexp times) {
+  int i;
+  sexp_gc_var1(tmp);
+  sexp_assert_type(ctx, sexp_applicablep, SEXP_PROCEDURE, fn);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, times);
+  sexp_gc_preserve1(ctx, tmp);
+  for (i=0; i<sexp_unbox_fixnum(times); i++) {
+    tmp = sexp_make_flonum(ctx, 3.14);
+    tmp = sexp_apply(ctx, fn, tmp = sexp_list1(ctx, tmp));
+  }
+  sexp_gc_release1(ctx);
+  return SEXP_VOID;
+}
+
+int main (int argc, char **argv) {
+  sexp ctx, res;
+
+  /* Create a context and load two modules with C types. */
+  ctx = sexp_make_eval_context(NULL, NULL, NULL, 0, 0);
+  sexp_load_standard_env(ctx, NULL, SEXP_SEVEN);
+  sexp_load_standard_ports(ctx, NULL, stdin, stdout, stderr, 1);
+  sexp_define_foreign(ctx, sexp_context_env(ctx),
+                      "apply-times-to-pi", 2, sexp_apply_times_to_pi);
+  sexp_eval_string(ctx, "(define counter 0)", -1, NULL);
+  sexp_eval_string(ctx,
+                   "(apply-times-to-pi"
+                   " (lambda (pi) (set! counter (+ counter pi)))"
+                   " 1000000)",
+                   -1,
+                   NULL);
+  sexp_eval_string(ctx, "(begin (write (round counter)) (newline))", -1, NULL);
+
+  sexp_destroy_context(ctx);
+
+  return 0;
+}
diff --git a/tests/foreign/typeid.c b/tests/foreign/typeid.c
new file mode 100644
index 00000000..5ebae1d8
--- /dev/null
+++ b/tests/foreign/typeid.c
@@ -0,0 +1,44 @@
+
+#include "chibi/eval.h"
+
+#define sexp_safe_pointer_tag(x) (sexp_pointerp(x) ? sexp_pointer_tag(x) : -1)
+
+#define CHECK(expr) res = expr; check_exception(res, #expr)
+
+void check_exception (sexp x, const char* expr) {
+  if (sexp_exceptionp(x))
+    fprintf(stderr, "Exception: %s => %s\n", expr,
+            sexp_string_data(sexp_exception_message(x)));
+}
+
+int main (int argc, char **argv) {
+  sexp ctx1, ctx2, res;
+
+  /* Create a context and load two modules with C types. */
+  ctx1 = sexp_make_eval_context(NULL, NULL, NULL, 0, 0);
+  sexp_load_standard_env(ctx1, NULL, SEXP_SEVEN);
+  CHECK(sexp_eval_string(ctx1, "(import (chibi net))", -1, NULL));
+  CHECK(sexp_eval_string(ctx1, "(import (chibi time))", -1, NULL));
+
+  /* Create another context and load the same modules in a different order. */
+  ctx2 = sexp_make_eval_context(NULL, NULL, NULL, 0, 0);
+  sexp_load_standard_env(ctx2, NULL, SEXP_SEVEN);
+  CHECK(sexp_eval_string(ctx2, "(import (chibi time))", -1, NULL));
+  CHECK(sexp_eval_string(ctx2, "(import (chibi net))", -1, NULL));
+
+  /* Both instances of seconds->time should return the same type, */
+  /* but with different tags. */
+  CHECK(sexp_eval_string(ctx1, "(seconds->time 0)", -1, NULL));
+  fprintf(stderr, "ctx1: %p (%d): %s\n", res, sexp_safe_pointer_tag(res),
+          sexp_string_data(sexp_object_type_name(ctx1, res)));
+
+  CHECK(sexp_eval_string(ctx2, "(seconds->time 0)", -1, NULL));
+  fprintf(stderr, "ctx2: %p (%d): %s\n", res, sexp_safe_pointer_tag(res),
+          sexp_string_data(sexp_object_type_name(ctx2, res)));
+
+  /* Cleanup. */
+  sexp_destroy_context(ctx1);
+  sexp_destroy_context(ctx2);
+
+  return 0;
+}
diff --git a/tests/generic-tests.scm b/tests/generic-tests.scm
new file mode 100644
index 00000000..8c6fc72d
--- /dev/null
+++ b/tests/generic-tests.scm
@@ -0,0 +1,35 @@
+
+(import (chibi) (chibi generic) (chibi test))
+
+(test-begin "generics")
+
+(let ()
+  (define-generic add)
+  (define-method (add (x number?) (y number?))
+    (+ x y))
+  (define-method (add (x string?) (y string?))
+    (string-append x y))
+  (define-method (add x (y list?))
+    (append x y))
+  (test 4 (add 2 2))
+  (test "22" (add "2" "2"))
+  (test '(2 2) (add '() '(2 2)))
+  (test '(2 2) (add '(2) '(2)))
+  (test '(2 2) (add '(2 2) '()))
+  (test '(2) (add #f '(2)))
+  (test-error (add #(2) #(2))))
+
+(let ()
+  (define-generic mul)
+  (define-method (mul (x number?) (y number?))
+    (* x y))
+  (define-method (mul (x inexact?) (y inexact?))
+    (+ (* x y) 0.1))
+  (define-method (mul (x exact?) (y exact?))
+    (inexact->exact (call-next-method)))
+  (test 21 (mul 3 7))
+  (test 21.0 (mul 3.0 7))
+  (test 21.0 (mul 3 7.0))
+  (test 21.1 (mul 3.0 7.0)))
+
+(test-end)
diff --git a/tests/hash-tests.scm b/tests/hash-tests.scm
new file mode 100644
index 00000000..bcdb4899
--- /dev/null
+++ b/tests/hash-tests.scm
@@ -0,0 +1,182 @@
+
+(cond-expand
+ (modules (import (srfi 1) (srfi 69) (chibi test)))
+ (else #f))
+
+(test-begin "hash")
+
+(define-syntax test-lset-eq?
+  (syntax-rules ()
+    ((test-lset= . args)
+     (test-equal (lambda (a b) (lset= eq? a b)) . args))))
+
+(define-syntax test-lset-equal?
+  (syntax-rules ()
+    ((test-lset-equal? . args)
+     (test-equal (lambda (a b) (lset= equal? a b)) . args))))
+
+(let ((ht (make-hash-table eq?)))
+  ;; 3 initial elements
+  (test 0 (hash-table-size ht))
+  (hash-table-set! ht 'cat 'black)
+  (hash-table-set! ht 'dog 'white)
+  (hash-table-set! ht 'elephant 'pink)
+  (test 3 (hash-table-size ht))
+  (test-assert (hash-table-exists? ht 'dog))
+  (test-assert (hash-table-exists? ht 'cat))
+  (test-assert (hash-table-exists? ht 'elephant))
+  (test-not (hash-table-exists? ht 'goose))
+  (test 'white (hash-table-ref ht 'dog))
+  (test 'black (hash-table-ref ht 'cat))
+  (test 'pink (hash-table-ref ht 'elephant))
+  (test-error (hash-table-ref ht 'goose))
+  (test 'grey (hash-table-ref ht 'goose (lambda () 'grey)))
+  (test 'grey (hash-table-ref/default ht 'goose 'grey))
+  (test-lset-eq? '(cat dog elephant) (hash-table-keys ht))
+  (test-lset-eq? '(black white pink) (hash-table-values ht))
+  (test-lset-equal? '((cat . black) (dog . white) (elephant . pink))
+                    (hash-table->alist ht))
+
+  ;; remove an element
+  (hash-table-delete! ht 'dog)
+  (test 2 (hash-table-size ht))
+  (test-not (hash-table-exists? ht 'dog))
+  (test-assert (hash-table-exists? ht 'cat))
+  (test-assert (hash-table-exists? ht 'elephant))
+  (test-error (hash-table-ref ht 'dog))
+  (test 'black (hash-table-ref ht 'cat))
+  (test 'pink (hash-table-ref ht 'elephant))
+  (test-lset-eq? '(cat elephant) (hash-table-keys ht))
+  (test-lset-eq? '(black pink) (hash-table-values ht))
+  (test-lset-equal? '((cat . black) (elephant . pink)) (hash-table->alist ht))
+
+  ;; remove a non-existing element
+  (hash-table-delete! ht 'dog)
+  (test 2 (hash-table-size ht))
+  (test-not (hash-table-exists? ht 'dog))
+
+  ;; overwrite an existing element
+  (hash-table-set! ht 'cat 'calico)
+  (test 2 (hash-table-size ht))
+  (test-not (hash-table-exists? ht 'dog))
+  (test-assert (hash-table-exists? ht 'cat))
+  (test-assert (hash-table-exists? ht 'elephant))
+  (test-error (hash-table-ref ht 'dog))
+  (test 'calico (hash-table-ref ht 'cat))
+  (test 'pink (hash-table-ref ht 'elephant))
+  (test-lset-eq? '(cat elephant) (hash-table-keys ht))
+  (test-lset-eq? '(calico pink) (hash-table-values ht))
+  (test-lset-equal? '((cat . calico) (elephant . pink)) (hash-table->alist ht))
+
+  ;; walk and fold
+  (test-lset-equal?
+   '((cat . calico) (elephant . pink))
+   (let ((a '()))
+     (hash-table-walk ht (lambda (k v) (set! a (cons (cons k v) a))))
+     a))
+  (test-lset-equal? '((cat . calico) (elephant . pink))
+                    (hash-table-fold ht (lambda (k v a) (cons (cons k v) a)) '()))
+
+  ;; copy
+  (let ((ht2 (hash-table-copy ht)))
+    (test 2 (hash-table-size ht2))
+    (test-not (hash-table-exists? ht2 'dog))
+    (test-assert (hash-table-exists? ht2 'cat))
+    (test-assert (hash-table-exists? ht2 'elephant))
+    (test-error (hash-table-ref ht2 'dog))
+    (test 'calico (hash-table-ref ht2 'cat))
+    (test 'pink (hash-table-ref ht2 'elephant))
+    (test-lset-eq? '(cat elephant) (hash-table-keys ht2))
+    (test-lset-eq? '(calico pink) (hash-table-values ht2))
+    (test-lset-equal? '((cat . calico) (elephant . pink))
+                      (hash-table->alist ht2)))
+
+  ;; merge
+  (let ((ht2 (make-hash-table eq?)))
+    (hash-table-set! ht2 'bear 'brown)
+    (test 1 (hash-table-size ht2))
+    (test-not (hash-table-exists? ht2 'dog))
+    (test-assert (hash-table-exists? ht2 'bear))
+    (hash-table-merge! ht2 ht)
+    (test 3 (hash-table-size ht2))
+    (test-assert (hash-table-exists? ht2 'bear))
+    (test-assert (hash-table-exists? ht2 'cat))
+    (test-assert (hash-table-exists? ht2 'elephant))
+    (test-not (hash-table-exists? ht2 'goose))
+    (test 'brown (hash-table-ref ht2 'bear))
+    (test 'calico (hash-table-ref ht2 'cat))
+    (test 'pink (hash-table-ref ht2 'elephant))
+    (test-error (hash-table-ref ht2 'goose))
+    (test 'grey (hash-table-ref/default ht2 'goose 'grey))
+    (test-lset-eq? '(bear cat elephant) (hash-table-keys ht2))
+    (test-lset-eq? '(brown calico pink) (hash-table-values ht2))
+    (test-lset-equal? '((cat . calico) (bear . brown) (elephant . pink))
+                      (hash-table->alist ht2)))
+
+  ;; alist->hash-table
+  (test-lset-equal? (hash-table->alist ht)
+                    (hash-table->alist
+                     (alist->hash-table
+                      '((cat . calico) (elephant . pink))))))
+
+;; update
+(let ((ht (make-hash-table eq?))
+      (add1 (lambda (x) (+ x 1))))
+  (hash-table-set! ht 'sheep 0)
+  (hash-table-update! ht 'sheep add1)
+  (hash-table-update! ht 'sheep add1)
+  (test 2 (hash-table-ref ht 'sheep))
+  (hash-table-update!/default ht 'crows add1 0)
+  (hash-table-update!/default ht 'crows add1 0)
+  (hash-table-update!/default ht 'crows add1 0)
+  (test 3 (hash-table-ref ht 'crows)))
+
+;; string keys
+(let ((ht (make-hash-table equal?)))
+  (hash-table-set! ht "cat" 'black)
+  (hash-table-set! ht "dog" 'white)
+  (hash-table-set! ht "elephant" 'pink)
+  (hash-table-ref/default ht "dog" #f)
+  (test 'white (hash-table-ref ht "dog"))
+  (test 'black (hash-table-ref ht "cat"))
+  (test 'pink (hash-table-ref ht "elephant"))
+  (test-error (hash-table-ref ht "goose"))
+  (test 'grey (hash-table-ref/default ht "goose" 'grey))
+  (test-lset-equal? '("cat" "dog" "elephant") (hash-table-keys ht))
+  (test-lset-equal? '(black white pink) (hash-table-values ht))
+  (test-lset-equal?
+   '(("cat" . black) ("dog" . white) ("elephant" . pink))
+   (hash-table->alist ht)))
+
+;; string-ci keys
+(let ((ht (make-hash-table string-ci=? string-ci-hash)))
+  (hash-table-set! ht "cat" 'black)
+  (hash-table-set! ht "dog" 'white)
+  (hash-table-set! ht "elephant" 'pink)
+  (hash-table-ref/default ht "DOG" #f)
+  (test 'white (hash-table-ref ht "DOG"))
+  (test 'black (hash-table-ref ht "Cat"))
+  (test 'pink (hash-table-ref ht "eLePhAnT"))
+  (test-error (hash-table-ref ht "goose"))
+  (test-lset-equal? '("cat" "dog" "elephant") (hash-table-keys ht))
+  (test-lset-equal? '(black white pink) (hash-table-values ht))
+  (test-lset-equal?
+   '(("cat" . black) ("dog" . white) ("elephant" . pink))
+   (hash-table->alist ht)))
+
+;; Exception values - this works because the return value from the
+;; primitives is a cell, and we use the cdr opcode to retrieve the
+;; cell value.  Thus there is no FFI issue with storing exceptions.
+(let ((ht (make-hash-table)))
+  (hash-table-set! ht 'boom (make-exception 'my-exn-type "boom!" '() #f #f))
+  (test 'my-exn-type (exception-kind (hash-table-ref ht 'boom))))
+
+;; stress test
+(test 625
+ (let ((ht (make-hash-table)))
+   (do ((i 0 (+ i 1))) ((= i 1000))
+     (hash-table-set! ht i (* i i)))
+   (hash-table-ref/default ht 25 #f)))
+
+(test-end)
+
diff --git a/tests/install/install-tests.pl b/tests/install/install-tests.pl
new file mode 100755
index 00000000..63681324
--- /dev/null
+++ b/tests/install/install-tests.pl
@@ -0,0 +1,57 @@
+#! /usr/bin/env perl
+
+use strict;
+use warnings;
+
+my $ROOT="tests/install/root";
+my $USER=$ENV{USER};
+
+my $ignore = qr!/lib\d*/modules|/X11|alsa-lib|aspell|dosemu|emacs|erlang|/perl|python|ruby|lisp|sbcl|/ghc-|ocaml|evolution|office|gimp|gtk|mysql|postgres|wordnet|xulrunner!;
+
+sub linkdir ($$$) {
+  my ($FROM, $TO, $DEPTH) = @_;
+  mkdir $TO;
+  for my $f (`ls $FROM`) {
+    chomp $f;
+    if (-d "$FROM/$f") {
+      if (($DEPTH > 0) && ($FROM !~ $ignore)) {
+        linkdir("$FROM/$f", "$TO/$f", $DEPTH-1);
+      }
+    } else {
+      link "$FROM/$f", "$TO/$f";
+    }
+  }
+}
+
+mkdir "$ROOT";
+mkdir "$ROOT/bin";
+mkdir "$ROOT/sbin";
+mkdir "$ROOT/dev";
+mkdir "$ROOT/etc";
+mkdir "$ROOT/etc/alternatives";
+mkdir "$ROOT/lib";
+mkdir "$ROOT/lib64";
+mkdir "$ROOT/usr";
+mkdir "$ROOT/usr/bin";
+mkdir "$ROOT/usr/include";
+mkdir "$ROOT/usr/lib";
+mkdir "$ROOT/usr/lib/gcc";
+
+linkdir "/bin", "$ROOT/bin", 1;
+linkdir "/sbin", "$ROOT/sbin", 1;
+link "/etc/passwd", "$ROOT/etc/passwd";
+linkdir "/etc/alternatives", "$ROOT/etc/alternatives", 1;
+linkdir "/lib", "$ROOT/lib", 3;
+linkdir "/lib64", "$ROOT/lib64", 3;
+linkdir "/usr/bin", "$ROOT/usr/bin", 3;
+linkdir "/usr/include", "$ROOT/usr/include", 2;
+linkdir "/usr/lib", "$ROOT/usr/lib", 3;
+linkdir "/usr/lib/gcc", "$ROOT/usr/lib/gcc", 3;
+
+`make dist`;
+my $VERSION=`cat VERSION`;
+chomp $VERSION;
+`cp chibi-scheme-$VERSION.tgz $ROOT/`;
+`sed -e 's/\@VERSION\@/$VERSION/g' <tests/install/run-install-test.sh >$ROOT/bin/run-install-test.sh`;
+`chmod 755 $ROOT/bin/run-install-test.sh`;
+exec "sudo chroot $ROOT run-install-test.sh";
diff --git a/tests/install/run-install-test.sh b/tests/install/run-install-test.sh
new file mode 100755
index 00000000..13f35184
--- /dev/null
+++ b/tests/install/run-install-test.sh
@@ -0,0 +1,12 @@
+#!/bin/sh
+
+export PATH=/usr/local/bin:$PATH
+export LD_LIBRARY_PATH=/usr/local/lib:$LD_LIBRARY_PATH
+
+tar xzvf chibi-scheme-@VERSION@.tgz
+cd chibi-scheme-@VERSION@
+make
+make install
+cp tests/r5rs-tests.scm ..
+cd ..
+chibi-scheme r5rs-tests.scm | tee r5rs-tests.out
diff --git a/tests/io-tests.scm b/tests/io-tests.scm
new file mode 100644
index 00000000..563590e0
--- /dev/null
+++ b/tests/io-tests.scm
@@ -0,0 +1,163 @@
+
+(cond-expand
+ (modules
+  (import (chibi io)
+          (only (scheme base) read-bytevector write-bytevector)
+          (only (chibi test) test-begin test test-end)))
+ (else #f))
+
+(test-begin "io")
+
+(define long-string (make-string 2000 #\a))
+
+(test "input-string-port" 1025
+  (call-with-input-string (substring long-string 0 1025)
+    (lambda (in)
+      (let loop ((c (read-char in)) (i 0))
+        (cond ((eof-object? c) i)
+              ((> i 1025) (error "read past eof"))
+              (else (loop (read-char in) (+ i 1))))))))
+
+(test "read-line" '("abc" "def")
+  (call-with-input-string "abc\ndef\n"
+    (lambda (in) (let ((line (read-line in))) (list line (read-line in))))))
+
+(test "read-line" '("abc" "def" "ghi")
+  (call-with-input-string "abcdef\nghi\n"
+    (lambda (in)
+      (let* ((line1 (read-line in 3))
+             (line2 (read-line in 3)))
+        (list line1 line2 (read-line in 3))))))
+
+(test "read-line-to-eof" '("abc" "def")
+  (call-with-input-string "abc\ndef"
+    (lambda (in) (let ((line (read-line in))) (list line (read-line in))))))
+
+(test "read-string" '("abc" "def")
+  (call-with-input-string "abcdef"
+    (lambda (in) (let ((str (read-string 3 in))) (list str (read-string 3 in))))))
+
+(test "read-string-to-eof" '("abc" "de")
+  (call-with-input-string "abcde"
+    (lambda (in) (let ((str (read-string 3 in))) (list str (read-string 3 in))))))
+
+(test "read-string" '("ab日" "本語f")
+  (call-with-input-string "ab日本語f"
+    (lambda (in) (let ((str (read-string 3 in))) (list str (read-string 3 in))))))
+
+(test "read-string!" '("abc" "def")
+  (call-with-input-string "abcdef"
+    (lambda (in)
+      (let* ((str1 (make-string 3))
+             (str2 (make-string 3)))
+        (read-string! str1 3 in)
+        (read-string! str2 3 in)
+        (list str1 str2)))))
+
+(test "read-string!-to-eof" '("abc" "de ")
+  (call-with-input-string "abcde"
+    (lambda (in)
+      (let* ((str1 (make-string 3))
+             (str2 (make-string 3 #\space)))
+        (read-string! str1 3 in)
+        (read-string! str2 3 in)
+        (list str1 str2)))))
+
+(test "null-output-port" #t
+  (let ((out (make-null-output-port)))
+    (write 1 out)
+    (close-output-port out)
+    #t))
+
+(test "null-input-port" #t
+  (let ((in (make-null-input-port)))
+    (let ((res (eof-object? (read-char in))))
+      (close-input-port in)
+      res)))
+
+(define (string-upcase str)
+  (list->string (map char-upcase (string->list str))))
+
+(test "upcase-input-port" "ABC"
+  (call-with-input-string "abc"
+    (lambda (in)
+      (let ((in (make-filtered-input-port string-upcase in)))
+        (let ((res (read-line in)))
+          (close-input-port in)
+          res)))))
+
+(test "upcase-output-port" "ABC"
+  (call-with-output-string
+    (lambda (out)
+      (let ((out (make-filtered-output-port string-upcase out)))
+        (display "abc" out)
+        (close-output-port out)))))
+
+(define (strings->input-port str-ls)
+  (make-generated-input-port
+   (lambda ()
+     (and (pair? str-ls)
+          (let ((res (car str-ls)))
+            (set! str-ls (cdr str-ls))
+            res)))))
+
+(test "abcdef" (read-line (strings->input-port '("abcdef"))))
+(test "abcdef" (read-line (strings->input-port '("abc" "def"))))
+(test "abcdef" (read-line (strings->input-port '("a" "b" "c" "d" "e" "f"))))
+(test "日本語" (read-line (strings->input-port '("日本語"))))
+(test "日本語" (read-line (strings->input-port '("日" "本" "語"))))
+(test "abc"
+    (let ((in (strings->input-port
+               (list "日本語" (make-string 4087 #\-) "abc"))))
+      (read-string 4090 in)
+      (read-line in)))
+(test "abc"
+    (let ((in (strings->input-port
+               (list "日本語" (make-string 4087 #\本) "abc"))))
+      (read-string 4090 in)
+      (read-line in)))
+(test "abc"
+    (let ((in (strings->input-port
+               (list "日本語" (make-string 4093 #\-) "abc"))))
+      (read-string 4096 in)
+      (read-line in)))
+
+(let ((in (make-custom-binary-input-port
+           (let ((i 0))
+             (lambda (bv start end)
+               (do ((j start (+ j 1)))
+                   ((= j end))
+                 (bytevector-u8-set! bv j (modulo (+ j i) 256)))
+               (if (> end 0)
+                   (set! i (bytevector-u8-ref bv (- end 1))))
+               (- end start))))))
+  (test #u8(0 1 2 3) (read-bytevector 4 in))
+  (test #u8(4 5 6 7) (read-bytevector 4 in))
+  (test 7 (bytevector-u8-ref (read-bytevector 256 in) 255))
+  (test 6 (bytevector-u8-ref (read-bytevector 1024 in) 1022)))
+
+(let* ((sum 0)
+       (out (make-custom-binary-output-port
+             (lambda (bv start end)
+               (do ((i start (+ i 1))
+                    (x 0 (+ x (bytevector-u8-ref bv i))))
+                   ((= i end) (set! sum x)))))))
+  (write-bytevector #u8(0 1 2 3) out)
+  (flush-output out)
+  (test 6 sum)
+  (write-bytevector #u8(100) out)
+  (flush-output out)
+  (test 106 sum))
+
+(test "file-position"
+    '(0 1 2)
+  (let* ((p (open-input-file "tests/io-tests.scm"))
+         (t0 (file-position p)))
+    (read-char p)
+    (let ((t1 (file-position p)))
+      (read-char p)
+      (let ((t2 (file-position p)))
+        (close-input-port p)
+        (list t0 t1 t2)))))
+
+(test-end)
diff --git a/tests/iset-tests.scm b/tests/iset-tests.scm
new file mode 100644
index 00000000..5e8f18bd
--- /dev/null
+++ b/tests/iset-tests.scm
@@ -0,0 +1,197 @@
+
+(cond-expand
+ (modules
+  (import (chibi) (chibi iset) (chibi iset optimize) (srfi 1) (chibi test)))
+ (else #f))
+
+(define (test-name iset op)
+  (call-with-output-string
+    (lambda (out)
+      (let* ((ls (iset->list iset))
+             (ls (if (> (length ls) 10)
+                     `(,@(take ls 5) ... ,@(take-right ls 5))
+                     ls)))
+        (write `(,(car op) (iset ,@ls) ,@(cdr op)) out)))))
+
+(test-begin "iset")
+
+;; Tests to perform repeated operations on an iset.  The first element
+;; in each list is a list of integers to initialize the set `is', which
+;; we generate and verify the size and round-trip list conversion.
+;; Subsequent elements are abbreviated operations on is:
+;;
+;;   (+ a ...)     (iset-adjoin! a) ...
+;;   (- a ...)     (iset-delete! a) ...
+;;   (= a ...)     (test (list a ...) (iset->list is))
+;;   (<= a ...)    (test-assert (iset<= is (iset a ...)))
+;;   (? a ...)     (test-assert (iset-contains? is a)) ...
+;;   (!? a ...)    (test-not (iset-contains? is a)) ...
+;;   (u a ...)     (iset-union is (iset a ...))
+;;   (u: a b)      (iset-union is (make-iset a b))
+;;   (i a ...)     (iset-intersection is (iset a ...))
+;;   (d a ...)     (iset-difference is (iset a ...))
+;;   (m f)         (iset-map f is)
+;;   (s size)      (test size (iset-size iset))
+;;   (z [empty?])  (test empty? (iset-empty? iset))
+(let ((tests
+       `(;; construction
+         ((1 128 127))
+         ((129 2 127))
+         ((1 -128 -126))
+         ((1 2 3 1000 1005))
+         ((97308 97827 97845 97827))
+         ((1 2 3 4 5 6 7 8))
+         ((2 3 4 5 6 7 8))
+         ((1 3 4 5 6 7 8))
+         ((1 2 4 5 6 7 8))
+         ((1 2 3 5 6 7 8))
+         ((1 2 3 4 6 7 8))
+         ((1 2 3 4 5 7 8))
+         ((1 2 3 4 5 6 8))
+         ((1 2 3 4 5 6 7))
+         ;; ordering
+         ((97) (<= 97 117))
+         ((117) (<= 97 117))
+         ;; individual elements
+         (() (+ 99) (u 3 50) (? 99))
+         (() (+ 1) (+ 1000) (+ -1000) (+ 3) (+ -1))
+         ((0) (z #f) (- 0) (z))
+         ((0 1 2) (- 1) (- 2) (? 0))
+         ;; union
+         ((17 29) (u 7 29))
+         ((2 3 4) (u 1 2 3 4 5))
+         ((1 2 3 4 5) (u 2 3 4))
+         ((1 2 3 1000 2000) (u 1 4))
+         ((1 3) (u 1 4) (= 1 3 4))
+         ((1 3) (u 3 4) (= 1 3 4))
+         ((1) (u 1 3) (= 1 3))
+         ((3) (u 1 3) (= 1 3))
+         ((1 4) (u 3 4 5) (= 1 3 4 5))
+         ((1 2 3 4) (u 5 6 7 8) (= 1 2 3 4 5 6 7 8))
+         ((1 3 4) (u 5 6 7 8) (= 1 3 4 5 6 7 8))
+         ((1 2 4) (u 5 6 7 8) (= 1 2 4 5 6 7 8))
+         ((1 2 3) (u 5 6 7 8) (= 1 2 3 5 6 7 8))
+         ((1 2 3 4) (u 6 7 8) (= 1 2 3 4 6 7 8))
+         ((1 2 3 4) (u 5 7 8) (= 1 2 3 4 5 7 8))
+         ((1 2 3 4) (u 5 6 8) (= 1 2 3 4 5 6 8))
+         ((1 2 3) (u 6 7 8) (= 1 2 3 6 7 8))
+         ((1 3) (u 6 8) (= 1 3 6 8))
+         ((1 2 3 4 1001 1002)
+          (u 1003 1004 2001 2002 2003 2004)
+          (= 1 2 3 4 1001 1002 1003 1004 2001 2002 2003 2004))
+         ((1 2 4 1001 1002)
+          (u 1003 1004 2001 2002 2003 2004)
+          (= 1 2 4 1001 1002 1003 1004 2001 2002 2003 2004))
+         ((1 2 3 4 1001 1002)
+          (u 1004 2001 2002 2003 2004)
+          (= 1 2 3 4 1001 1002 1004 2001 2002 2003 2004))
+         ((1 2 3 4 1001 1002)
+          (u 1003 1004 2001 2003 2004)
+          (= 1 2 3 4 1001 1002 1003 1004 2001 2003 2004))
+         (() (u: 349 680) (u: 682 685))
+         (() (u: 64434 64449) (u: 65020 65021) (u #xFE62))
+         (() (u: 716 747) (u: 750 1084))
+         (() (u: 48 57) (u: 65 90) (u: 97 122) (u 45 46 95 126) (? 119))
+         ;; intersection
+         ((1 2 3 4 5) (i 1) (= 1))
+         ((1 2 3 4 5) (i 1 2) (= 1 2))
+         ((1 2 3 4 5) (i 1 2 3) (= 1 2 3))
+         ((1 2 3 4 5) (i 2 3) (= 2 3))
+         ((1 2 3 4 5) (i 2 3 4) (= 2 3 4))
+         ((1 2 3 4 5) (i 5) (= 5))
+         ((1 2 3 4 5) (i 4 5) (= 4 5))
+         ((1 2 3 4 5) (i 1 2 3 4 5) (= 1 2 3 4 5))
+         ((1 2 3 4 5) (i 0 1 5 6) (= 1 5))
+         ;; difference
+         ((1 2 3 4 5) (d 1) (!? 0) (? 2 3 4 5) (!? 6))
+         ((1 2 3 4 5) (d 1 2) (!? 0) (? 3 4 5) (!? 6))
+         ((1 2 3 4 5) (d 1 2 3) (!? 0) (? 4 4) (!? 6))
+         ((1 2 3 4 5) (d 2 3) (!? 0) (? 1 4 5) (!? 6))
+         ((1 2 3 4 5) (d 2 3 4) (!? 0) (? 1 5) (!? 6))
+         ((1 2 3 4 5) (d 5) (!? 0) (? 1 2 3 4) (!? 6))
+         ((1 2 3 4 5) (d 4 5) (!? 0) (? 1 2 3) (!? 6))
+         ((1 2 3 4 5) (d 1 2 3 4 5) (z))
+         ((1 2 3 4 5) (d 0 1 5 6) (? 2 3 4))
+         ;; map
+         ((1 2 3) (m ,(lambda (x) (+ x 1))) (= 2 3 4))
+         )))
+  (for-each
+   (lambda (tst)
+     (let* ((ls (car tst))
+            (is (list->iset ls))
+            (ls2 (delete-duplicates ls =)))
+       ;; initial creation and sanity checks
+       (test-assert (lset= equal? ls2 (iset->list is)))
+       (test (length ls2) (iset-size is))
+       (test-assert (call-with-output-string
+                      (lambda (out)
+                        (display "init: " out)
+                        (write ls out)))
+           (every
+            (lambda (x) (iset-contains? is x))
+            ls))
+       (test (iset-contains? is 42) (member 42 ls))
+       ;; additional operations
+       (for-each
+        (lambda (op)
+          (let ((name (test-name is op)))
+            (case (car op)
+              ((+)
+               (for-each
+                (lambda (x) (iset-adjoin! is x))
+                (cdr op))
+               (test-assert name (iset-contains? is (cadr op))))
+              ((-)
+               (for-each
+                (lambda (x) (iset-delete! is x))
+                (cdr op))
+               (test-assert name (not (iset-contains? is (cadr op)))))
+              ((=)
+               (test name (cdr op) (iset->list is))
+               (test-assert name (iset= (list->iset (cdr op)) is)))
+              ((<=)
+               (test-assert name (iset<= is (list->iset (cdr op)))))
+              ((?)
+               (test-assert name
+                 (every (lambda (x) (iset-contains? is x)) (cdr op))))
+              ((!?)
+               (test-assert name
+                 (every (lambda (x) (not (iset-contains? is x))) (cdr op))))
+              ((d)
+               (set! is (iset-difference is (list->iset (cdr op))))
+               (test-assert name
+                 (every
+                  (lambda (x) (not (iset-contains? is x)))
+                  (cdr op))))
+              ((i) (set! is (iset-intersection is (list->iset (cdr op)))))
+              ((u u:)
+               (let ((arg (cond ((eq? 'u: (car op))
+                                 (make-iset (cadr op) (car (cddr op))))
+                                ((iset? (cadr op)) (cadr op))
+                                (else (list->iset (cdr op))))))
+                 (set! is (iset-union is arg)))
+               (test-assert name
+                 (every (lambda (x)
+                          (or (not (integer? x))
+                              (iset-contains? is x)))
+                        (cdr op))))
+              ((m) (set! is (iset-map (cadr op) is)))
+              ((s) (test (iset-size is) (cadr op)))
+              ((z) (test (iset-empty? is) (if (pair? (cdr op)) (cadr op) #t)))
+              (else (error "unknown operation" (car op))))))
+        (cdr tst))
+       ;; optimization
+       (let* ((is2 (iset-optimize is))
+              (is3 (iset-balance is))
+              (is4 (iset-balance is2)))
+         (test-assert (iset= is is2))
+         (test-assert (iset= is is3))
+         (test-assert (iset= is is4)))))
+   tests))
+
+(let ((a (%make-iset 65 90 #f #f (%make-iset 97 122 #f #f #f)))
+      (b (list->iset '(45 46 95 126))))
+  (test-assert (iset-contains? (iset-union a b) 119))
+  (test-assert (iset-contains? (iset-union b a) 119))) 
+
+(test-end)
diff --git a/tests/lib-tests.scm b/tests/lib-tests.scm
new file mode 100644
index 00000000..29ce96fb
--- /dev/null
+++ b/tests/lib-tests.scm
@@ -0,0 +1,51 @@
+
+(cond-expand
+ (modules (import (only (chibi) load)
+                  (only (chibi test) test-begin test-end)))
+ (else (load "tests/r5rs-tests.scm")))
+
+(test-begin "libraries")
+
+(load "tests/srfi-1-tests.scm")
+(load "tests/srfi-2-tests.scm")
+(load "tests/srfi-16-tests.scm")
+(load "tests/srfi-26-tests.scm")
+(load "tests/srfi-27-tests.scm")
+(load "tests/srfi-38-tests.scm")
+(load "tests/flonum-tests.scm")
+(load "tests/numeric-tests.scm")
+(load "tests/loop-tests.scm")
+(load "tests/match-tests.scm")
+(load "tests/scribble-tests.scm")
+(load "tests/string-tests.scm")
+(load "tests/iset-tests.scm")
+(load "tests/uri-tests.scm")
+(load "tests/mime-tests.scm")
+(load "tests/regexp-tests.scm")
+(load "tests/prime-tests.scm")
+(load "tests/md5-tests.scm")
+(load "tests/sha-tests.scm")
+;; (load "tests/rsa-tests.scm")
+(load "tests/tar-tests.scm")
+(load "tests/term-ansi-tests.scm")
+(cond-expand (full-unicode (load "tests/unicode-tests.scm")) (else #f))
+
+(cond-expand
+ (modules
+  (load "tests/record-tests.scm")
+  (load "tests/hash-tests.scm")
+  (load "tests/sort-tests.scm")
+  (load "tests/parse-tests.scm")
+  ;; (load "tests/weak-tests.scm")
+  (load "tests/io-tests.scm")
+  (load "tests/process-tests.scm")
+  (load "tests/system-tests.scm")
+  )
+ (else #f))
+
+(cond-expand
+ ((and modules threads)
+  (load "tests/thread-tests.scm"))
+ (else #f))
+
+(test-end)
diff --git a/tests/loop-tests.scm b/tests/loop-tests.scm
new file mode 100644
index 00000000..b3f914f1
--- /dev/null
+++ b/tests/loop-tests.scm
@@ -0,0 +1,170 @@
+
+(cond-expand
+ (modules (import (chibi loop) (only (chibi test) test-begin test test-end)))
+ (else (load "lib/chibi/loop/loop.scm")))
+
+(test-begin "loops")
+
+(test
+ "stepping"
+ '(0 1 2)
+ (loop lp ((with i 0 (+ i 1))
+           (with res '() (cons i res)))
+   (if (= i 3)
+     (reverse res)
+     (lp))))
+
+(test
+ "basic in-list"
+ '(c b a)
+ (let ((res '()))
+   (loop ((for x (in-list '(a b c))))
+     (set! res (cons x res)))
+   res))
+
+(test
+ "in-list with result"
+ '(c b a)
+ (loop ((for x (in-list '(a b c)))
+        (with res '() (cons x res)))
+   => res))
+
+(test
+ "in-list with listing"
+ '(a b c)
+ (loop ((for x (in-list '(a b c))) (for res (listing x))) => res))
+
+(test
+ "in-list with listing-reverse"
+ '(c b a)
+ (loop ((for x (in-list '(a b c))) (for res (listing-reverse x))) => res))
+
+(test
+ "uneven length in-list's"
+ '((a . 1) (b . 2) (c . 3))
+ (loop ((for x (in-list '(a b c)))
+        (for y (in-list '(1 2 3 4)))
+        (for res (listing (cons x y))))
+    => res))
+
+(test
+ "in-lists"
+ '((a 1) (b 2) (c 3))
+ (loop ((for ls (in-lists '((a b c) (1 2 3))))
+        (for res (listing ls)))
+   => res))
+
+(define (flatten ls)
+  (reverse
+   (loop lp ((for x ls (in-list ls)) (with res '()))
+     => res
+     (if (pair? x)
+         (lp (=> res (lp (=> ls x))))
+         (lp (=> res (cons x res)))))))
+
+(test
+ "flatten (recursion test)"
+ '(1 2 3 4 5 6 7)
+ (flatten '(1 (2) (3 (4 (5)) 6) 7)))
+
+(test
+ "in-string"
+ '(#\h #\e #\l #\l #\o)
+ (loop ((for c (in-string "hello")) (for res (listing c))) => res))
+
+(test
+ "in-string with start"
+ '(#\l #\o)
+ (loop ((for c (in-string "hello" 3)) (for res (listing c))) => res))
+
+(test
+ "in-string with start and end"
+ '(#\h #\e #\l #\l)
+ (loop ((for c (in-string "hello" 0 4)) (for res (listing c))) => res))
+
+(test
+ "in-string-reverse"
+ '(#\o #\l #\l #\e #\h)
+ (loop ((for c (in-string-reverse "hello")) (for res (listing c))) => res))
+
+(test
+ "in-vector"
+ '(1 2 3)
+ (loop ((for x (in-vector '#(1 2 3))) (for res (listing x))) => res))
+
+(test
+ "in-vector-reverse"
+ '(3 2 1)
+ (loop ((for x (in-vector-reverse '#(1 2 3))) (for res (listing x))) => res))
+
+(test "up-from" '(5 6 7)
+  (loop ((for i (up-from 5 (to 8)))
+         (for res (listing i)))
+    => res))
+
+(test "up-from by" '(5 10 15)
+  (loop ((for i (up-from 5 (to 20) (by 5)))
+         (for res (listing i)))
+    => res))
+
+(test "up-from listing if" '(10 12 14 16 18)
+  (loop ((for i (up-from 10 (to 20)))
+         (for res (listing i (if (even? i)))))
+    => res))
+
+(test "down-from" '(7 6 5)
+  (loop ((for i (down-from 8 (to 5)))
+         (for res (listing i)))
+    => res))
+
+(test "down-from by" '(15 10 5)
+  (loop ((for i (down-from 20 (to 5) (by 5)))
+         (for res (listing i)))
+    => res))
+
+(test "down-from listing if" '(18 16 14 12 10)
+  (loop ((for i (down-from 20 (to 10)))
+         (for res (listing i (if (even? i)))))
+    => res))
+
+(test "appending" '(1 2 3 4 5 6 7 8 9)
+  (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9))))
+         (for res (appending ls)))
+    => res))
+
+(test "appending-reverse" '(9 8 7 6 5 4 3 2 1)
+  (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9))))
+         (for res (appending-reverse ls)))
+    => res))
+
+(test "while + up-from" '(5 6 7)
+      (loop ((for i (up-from 5 (to 10)))
+             (while (< i 8))
+             (for res (listing i)))
+        => res))
+
+(test "up-from by, open-ended" '(5 7 9)
+  (loop ((for i (up-from 5 (by 2)))
+         (while (< i 10))
+         (for res (listing i)))
+    => res))
+
+(test "up-from open-ended" '(5 6 7)
+  (loop ((for i (up-from 5))
+         (while (< i 8))
+         (for res (listing i)))
+    => res))
+
+(test "down-from by, open-ended" '(5 3 1)
+  (loop ((for i (down-from 7 (by 2)))
+         (until (< i 1))
+         (for res (listing i)))
+    => res))
+
+(test "down-from open-ended" '(4 3 2)
+  (loop ((for i (down-from 5))
+         (until (< i 2))
+         (for res (listing i)))
+    => res))
+
+(test-end)
diff --git a/tests/match-tests.scm b/tests/match-tests.scm
new file mode 100644
index 00000000..e6a48513
--- /dev/null
+++ b/tests/match-tests.scm
@@ -0,0 +1,185 @@
+
+(cond-expand
+ (modules (import (chibi match) (srfi 99) (only (chibi test) test-begin test test-end)))
+ (else (load "lib/chibi/match/match.scm")))
+
+(test-begin "match")
+
+(test "any" 'ok (match 'any (_ 'ok)))
+(test "symbol" 'ok (match 'ok (x x)))
+(test "number" 'ok (match 28 (28 'ok)))
+(test "string" 'ok (match "good" ("bad" 'fail) ("good" 'ok)))
+(test "literal symbol" 'ok (match 'good ('bad 'fail) ('good 'ok)))
+(test "null" 'ok (match '() (() 'ok)))
+(test "pair" 'ok (match '(ok) ((x) x)))
+(test "vector" 'ok (match '#(ok) (#(x) x)))
+(test "any doubled" 'ok (match '(1 2) ((_ _) 'ok)))
+(test "and empty" 'ok (match '(o k) ((and) 'ok)))
+(test "and single" 'ok (match 'ok ((and x) x)))
+(test "and double" 'ok (match 'ok ((and (? symbol?) y) 'ok)))
+(test "or empty" 'ok (match '(o k) ((or) 'fail) (else 'ok)))
+(test "or single" 'ok (match 'ok ((or x) 'ok)))
+(test "or double" 'ok (match 'ok ((or (? symbol? y) y) y)))
+(test "not" 'ok (match 28 ((not (a . b)) 'ok)))
+(test "pred" 'ok (match 28 ((? number?) 'ok)))
+(test "named pred" 29 (match 28 ((? number? x) (+ x 1))))
+
+(test "duplicate symbols pass" 'ok (match '(ok . ok) ((x . x) x)))
+(test "duplicate symbols fail" 'ok (match '(ok . bad) ((x . x) 'bad) (else 'ok)))
+(test "duplicate symbols samth" 'ok (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)))
+(test "duplicate symbols bound" 3 (let ((a '(1 2))) (match a ((and (a 2) (1 b)) (+ a b)) (_ #f))))
+
+(test "ellipses" '((a b c) (1 2 3))
+  (match '((a . 1) (b . 2) (c . 3))
+    (((x . y) ___) (list x y))))
+
+(test "real ellipses" '((a b c) (1 2 3))
+  (match '((a . 1) (b . 2) (c . 3))
+    (((x . y) ...) (list x y))))
+
+(test "vector ellipses" '(1 2 3 (a b c) (1 2 3))
+  (match '#(1 2 3 (a . 1) (b . 2) (c . 3))
+    (#(a b c (hd . tl) ...) (list a b c hd tl))))
+
+(test "pred ellipses" '(1 2 3)
+  (match '(1 2 3)
+    (((? odd? n) ___) n)
+    (((? number? n) ___) n)))
+
+(test "failure continuation" 'ok
+  (match '(1 2)
+    ((a . b) (=> next) (if (even? a) 'fail (next)))
+    ((a . b) 'ok)))
+
+(test "let" '(o k)
+  (match-let ((x 'ok) (y '(o k))) y))
+
+(test "let*" '(f o o f)
+  (match-let* ((x 'f) (y 'o) ((z w) (list y x))) (list x y z w)))
+
+(test "getter car" '(1 2)
+  (match '(1 . 2) (((get! a) . b) (list (a) b))))
+
+(test "getter cdr" '(1 2)
+  (match '(1 . 2) ((a . (get! b)) (list a (b)))))
+
+(test "getter vector" '(1 2 3)
+  (match '#(1 2 3) (#((get! a) b c) (list (a) b c))))
+
+(test "setter car" '(3 . 2)
+  (let ((x (cons 1 2)))
+    (match x (((set! a) . b) (a 3)))
+    x))
+
+(test "setter cdr" '(1 . 3)
+  (let ((x (cons 1 2)))
+    (match x ((a . (set! b)) (b 3)))
+    x))
+
+(test "setter vector" '#(1 0 3)
+  (let ((x (vector 1 2 3)))
+    (match x (#(a (set! b) c) (b 0)))
+    x))
+
+(test "single tail" '((a b) (1 2) (c . 3))
+  (match '((a . 1) (b . 2) (c . 3))
+    (((x . y) ... last) (list x y last))))
+
+(test "single tail 2" '((a b) (1 2) 3)
+  (match '((a . 1) (b . 2) 3)
+    (((x . y) ... last) (list x y last))))
+
+(test "multiple tail" '((a b) (1 2) (c . 3) (d . 4) (e . 5))
+  (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5))
+    (((x . y) ... u v w) (list x y u v w))))
+
+(test "tail against improper list" #f
+  (match '(a b c d e f . g)
+    ((x ... y u v w) (list x y u v w))
+    (else #f)))
+
+(test "Riastradh quasiquote" '(2 3)
+  (match '(1 2 3) (`(1 ,b ,c) (list b c))))
+
+(test "trivial tree search" '(1 2 3)
+  (match '(1 2 3) ((_ *** (a b c)) (list a b c))))
+
+(test "simple tree search" '(1 2 3)
+  (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c))))
+
+(test "deep tree search" '(1 2 3)
+  (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c))))
+
+(test "non-tail tree search" '(1 2 3)
+  (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c))))
+
+(test "restricted tree search" '(1 2 3)
+  (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c))))
+
+(test "fail restricted tree search" #f
+  (match '(x (y (x a b c (1 2 3) d e f)))
+    (('x *** (a b c)) (list a b c))
+    (else #f)))
+
+(test "sxml tree search" '(((href . "http://synthcode.com/")) ("synthcode"))
+  (match '(p (ul (li a (b c) (a (@ (href . "http://synthcode.com/")) "synthcode") d e f)))
+    (((or 'p 'ul 'li 'b) *** ('a ('@ attrs ...) text ...))
+     (list attrs text))
+    (else #f)))
+
+(test "failed sxml tree search" #f
+  (match '(p (ol (li a (b c) (a (@ (href . "http://synthcode.com/")) "synthcode") d e f)))
+    (((or 'p 'ul 'li 'b) *** ('a ('@ attrs ...) text ...))
+     (list attrs text))
+    (else #f)))
+
+(test "collect tree search"
+    '((p ul li) ((href . "http://synthcode.com/")) ("synthcode"))
+  (match '(p (ul (li a (b c) (a (@ (href . "http://synthcode.com/")) "synthcode") d e f)))
+    (((and tag (or 'p 'ul 'li 'b)) *** ('a ('@ attrs ...) text ...))
+     (list tag attrs text))
+    (else #f)))
+
+(test "anded tail pattern" '(1 2)
+      (match '(1 2 3) ((and (a ... b) x) a)))
+
+(test "anded search pattern" '(a b c)
+      (match '(a (b (c d))) ((and (p *** 'd) x) p)))
+
+(test "joined tail" '(1 2)
+      (match '(1 2 3) ((and (a ... b) x) a)))
+
+(test "list ..1" '(a b c)
+    (match '(a b c) ((x ..1) x)))
+
+(test "list ..1 failed" #f
+    (match '()
+      ((x ..1) x)
+      (else #f)))
+
+(test "list ..1 with predicate" '(a b c)
+    (match '(a b c)
+      (((and x (? symbol?)) ..1) x)))
+
+(test "list ..1 with failed predicate" #f
+    (match '(a b 3)
+      (((and x (? symbol?)) ..1) x)
+      (else #f)))
+
+(define-record-type Point
+  (make-point x y)
+  point?
+  (x point-x point-x-set!)
+  (y point-y point-y-set!))
+
+(test "record positional"
+    '(1 0)
+  (match (make-point 0 1)
+    (($ Point x y) (list y x))))
+
+(test "record named"
+    '(1 0)
+  (match (make-point 0 1)
+    ((@ Point (x x) (y y)) (list y x))))
+
+(test-end)
diff --git a/tests/md5-tests.scm b/tests/md5-tests.scm
new file mode 100644
index 00000000..14ef9ab3
--- /dev/null
+++ b/tests/md5-tests.scm
@@ -0,0 +1,13 @@
+
+(import (chibi crypto md5) (chibi test))
+
+(test-begin "md5")
+
+(test "d41d8cd98f00b204e9800998ecf8427e"
+    (md5 ""))
+(test "900150983cd24fb0d6963f7d28e17f72"
+    (md5 "abc"))
+(test "9e107d9d372bb6826bd81d3542a419d6"
+    (md5 "The quick brown fox jumps over the lazy dog"))
+
+(test-end)
diff --git a/tests/memoize-tests.scm b/tests/memoize-tests.scm
new file mode 100644
index 00000000..21504139
--- /dev/null
+++ b/tests/memoize-tests.scm
@@ -0,0 +1,49 @@
+
+(import (chibi) (chibi memoize) (chibi filesystem) (chibi test))
+
+(test-begin "memoize")
+
+(define-memoized (fib n)
+  (if (<= n 1)
+      1
+      (+ (fib (- n 1)) (fib (- n 2)))))
+
+(test 1 (fib 1))
+(test 573147844013817084101 (fib 100))
+
+(define-memoized (ack m n)
+  (cond
+   ((= m 0) (+ n 1))
+   ((= n 0) (ack (- m 1) 1))
+   (else (ack (- m 1) (ack m (- n 1))))))
+
+(test 29 (ack 3 2))
+(test 61 (ack 3 3))
+
+(let ((n 0))
+  (let ((f (memoize (lambda (x) (set! n (+ n 1)) (* x x)))))
+    (test 0 n)
+    (test 9 (f 3))
+    (test 1 n)
+    (test 9 (f 3))
+    (test 1 n)))
+
+(let ((n 0))
+  (let ((f (memoize (lambda (x) (set! n (+ n 1)) (* x x))
+                    'size-limit: #f)))
+    (test 0 n)
+    (test 9 (f 3))
+    (test 1 n)
+    (test 9 (f 3))
+    (test 1 n)))
+
+(letrec ((fib (lambda (n)
+                (if (<= n 1)
+                    1
+                    (+ (fib (- n 1)) (fib (- n 2)))))))
+  (let ((f (memoize-to-file fib 'memo-dir: "/tmp/memo.d/")))
+    (test 89 (f 10))
+    (test-assert (file-exists? "/tmp/memo.d/10.memo"))
+    (test 89 (f 10))))
+
+(test-end)
diff --git a/tests/memory/memory-tests.sh b/tests/memory/memory-tests.sh
new file mode 100755
index 00000000..3ad428c4
--- /dev/null
+++ b/tests/memory/memory-tests.sh
@@ -0,0 +1,12 @@
+#!/bin/sh
+
+for f in tests/memory/*.scm; do
+    ./chibi-scheme-ulimit -xscheme $f >${f%.scm}.out 2>${f%.scm}.err
+    if diff -q ${f%.scm}.out ${f%.scm}.res \
+        && diff -q ${f%.scm}.err ${f%.scm}.err-res; then
+        echo "[PASS] ${f%.scm}"
+        rm -f ${f%.scm}.out ${f%.scm}.err
+    else
+        echo "[FAIL] ${f%.scm}"
+    fi
+done
diff --git a/tests/memory/test00-read-string.err-res b/tests/memory/test00-read-string.err-res
new file mode 100644
index 00000000..c52e0fd4
--- /dev/null
+++ b/tests/memory/test00-read-string.err-res
@@ -0,0 +1,5 @@
+ERROR: out of memory
+  called from <anonymous> on line 513 of file ./lib/init-7.scm
+  called from <anonymous> on line 15 of file tests/memory/test00-read-string.scm
+  called from <anonymous> on line 1000 of file ./lib/init-7.scm
+  called from <anonymous> on line 526 of file ./lib/init-7.scm
diff --git a/tests/memory/test00-read-string.res b/tests/memory/test00-read-string.res
new file mode 100644
index 00000000..d0b82be5
--- /dev/null
+++ b/tests/memory/test00-read-string.res
@@ -0,0 +1 @@
+string: "aaa...
diff --git a/tests/memory/test00-read-string.scm b/tests/memory/test00-read-string.scm
new file mode 100644
index 00000000..8a1ca665
--- /dev/null
+++ b/tests/memory/test00-read-string.scm
@@ -0,0 +1,16 @@
+
+(define (show-string str)
+  (display "string: ")
+  (display (substring str 0 (min (string-length str) 4)))
+  (display "...\n"))
+
+(define str-length (inexact->exact (round (* 2 1024 1024)))) ;; 2MB
+(define str1
+  (let ((tmp (make-string str-length #\a)))
+    (string-set! tmp 0 #\")
+    (string-set! tmp (- str-length 1) #\")
+    tmp))
+(show-string str1)
+
+(define str2 (call-with-input-string str1 read))
+(show-string str2)
diff --git a/tests/memory/test01-read-symbol.err-res b/tests/memory/test01-read-symbol.err-res
new file mode 100644
index 00000000..02e0b655
--- /dev/null
+++ b/tests/memory/test01-read-symbol.err-res
@@ -0,0 +1,5 @@
+ERROR: out of memory
+  called from <anonymous> on line 513 of file ./lib/init-7.scm
+  called from <anonymous> on line 11 of file tests/memory/test01-read-symbol.scm
+  called from <anonymous> on line 1000 of file ./lib/init-7.scm
+  called from <anonymous> on line 526 of file ./lib/init-7.scm
diff --git a/tests/memory/test01-read-symbol.res b/tests/memory/test01-read-symbol.res
new file mode 100644
index 00000000..60902799
--- /dev/null
+++ b/tests/memory/test01-read-symbol.res
@@ -0,0 +1 @@
+string: aaaa...
diff --git a/tests/memory/test01-read-symbol.scm b/tests/memory/test01-read-symbol.scm
new file mode 100644
index 00000000..c4a72e36
--- /dev/null
+++ b/tests/memory/test01-read-symbol.scm
@@ -0,0 +1,12 @@
+
+(define (show-string str)
+  (display "string: ")
+  (display (substring str 0 (min (string-length str) 4)))
+  (display "...\n"))
+
+(define str-length (inexact->exact (round (* 2 1024 1024)))) ;; 2MB
+(define str1 (make-string str-length #\a))
+(show-string str1)
+
+(define str2 (call-with-input-string str1 read))
+(show-string str2)
diff --git a/tests/mime-tests.scm b/tests/mime-tests.scm
new file mode 100644
index 00000000..c23c0064
--- /dev/null
+++ b/tests/mime-tests.scm
@@ -0,0 +1,146 @@
+
+(import (chibi) (chibi mime) (chibi test)
+        (only (scheme base) string->utf8 open-input-bytevector))
+
+(test-begin "mime")
+
+(test '(text/html (charset . "UTF-8") (filename . "index.html"))
+    (mime-parse-content-type "text/html; CHARSET=UTF-8; filename=index.html"))
+
+(test '(multipart/form-data (boundary . "AaB03x"))
+    (mime-parse-content-type "multipart/form-data, boundary=AaB03x"))
+
+(test '(mime (@ (from . "\"Dr. Watson <guest@grimpen.moor>\"")
+                (to . "\"Sherlock Homes <not-really@221B-baker.street>\"")
+                (subject . "\"First Report\"")
+                (content-type . "text/plain; charset=\"ISO-8859-1\""))
+             "Moor is gloomy. Heard strange noise, attached.\n")
+    (call-with-input-string
+     "From:    \"Dr. Watson <guest@grimpen.moor>\"
+To:      \"Sherlock Homes <not-really@221B-baker.street>\"
+Subject: \"First Report\"
+Content-Type: text/plain; charset=\"ISO-8859-1\"
+
+Moor is gloomy. Heard strange noise, attached.
+
+"
+     mime-message->sxml))
+
+;; from rfc 1867
+
+(test '(mime
+        (@ (content-type . "multipart/form-data, boundary=AaB03x"))
+        (mime (@ (content-disposition . "form-data; name=\"field1\""))
+              "Joe Blow")
+        (mime (@ (content-disposition
+                  . "form-data; name=\"pics\"; filename=\"file1.txt\"")
+                 (content-type . "text/plain"))
+              " ... contents of file1.txt ..."))
+    (call-with-input-string
+        "Content-type: multipart/form-data, boundary=AaB03x
+
+--AaB03x
+content-disposition: form-data; name=\"field1\"
+
+Joe Blow
+--AaB03x
+content-disposition: form-data; name=\"pics\"; filename=\"file1.txt\"
+Content-Type: text/plain
+
+ ... contents of file1.txt ...
+--AaB03x--
+"
+      mime-message->sxml))
+
+(test '(mime
+        (@ (content-type . "multipart/form-data, boundary=AaB03x"))
+        (mime (@ (content-disposition . "form-data; name=\"field1\""))
+              "Joe Blow")
+        (mime (@ (content-disposition . "form-data; name=\"pics\"")
+                 (content-type . "multipart/mixed, boundary=BbC04y"))
+              (mime (@ (content-disposition
+                        . "attachment; filename=\"file1.txt\"")
+                       (content-type . "text/plain"))
+                    "... contents of file1.txt ...")
+              (mime (@ (content-disposition
+                        . "attachment; filename=\"file2.gif\"")
+                       (content-type . "image/gif")
+                       (content-transfer-encoding . "binary"))
+                    #u8(32 32 46 46 46 99 111 110 116 101 110
+                        116 115 32 111 102 32 102 105 108 101
+                        50 46 103 105 102 46 46 46))))
+    (call-with-input-string
+        "Content-type: multipart/form-data, boundary=AaB03x
+
+--AaB03x
+content-disposition: form-data; name=\"field1\"
+
+Joe Blow
+--AaB03x
+content-disposition: form-data; name=\"pics\"
+Content-type: multipart/mixed, boundary=BbC04y
+
+--BbC04y
+Content-disposition: attachment; filename=\"file1.txt\"
+Content-Type: text/plain
+
+... contents of file1.txt ...
+--BbC04y
+Content-disposition: attachment; filename=\"file2.gif\"
+Content-type: image/gif
+Content-Transfer-Encoding: binary
+
+  ...contents of file2.gif...
+--BbC04y--
+--AaB03x--
+"
+      mime-message->sxml))
+
+(test '(mime
+        (@ (content-type . "multipart/form-data, boundary=AaB03x"))
+        (mime (@ (content-disposition . "form-data; name=\"field1\"")
+                 (content-type . "text/plain"))
+              "Joe Blow")
+        (mime (@ (content-disposition . "form-data; name=\"pics\"")
+                 (content-type . "multipart/mixed, boundary=BbC04y"))
+              (mime (@ (content-disposition
+                        . "attachment; filename=\"file1.txt\"")
+                       (content-type . "text/plain"))
+                    "... contents of file1.txt ...")
+              (mime (@ (content-disposition
+                        . "attachment; filename=\"file2.gif\"")
+                       (content-type . "image/gif")
+                       (content-transfer-encoding . "binary"))
+                    #u8(32 32 46 46 46 99 111 110 116 101 110
+                        116 115 32 111 102 32 102 105 108 101
+                        50 46 103 105 102 46 46 46))))
+    (mime-message->sxml
+     (open-input-bytevector
+      (string->utf8
+       "Content-type: multipart/form-data, boundary=AaB03x
+
+--AaB03x
+content-disposition: form-data; name=\"field1\"
+Content-Type: text/plain
+
+Joe Blow
+--AaB03x
+content-disposition: form-data; name=\"pics\"
+Content-type: multipart/mixed, boundary=BbC04y
+
+--BbC04y
+Content-disposition: attachment; filename=\"file1.txt\"
+Content-Type: text/plain
+
+... contents of file1.txt ...
+--BbC04y
+Content-disposition: attachment; filename=\"file2.gif\"
+Content-type: image/gif
+Content-Transfer-Encoding: binary
+
+  ...contents of file2.gif...
+--BbC04y--
+--AaB03x--
+"))))
+
+(test-end)
diff --git a/tests/numeric-tests.scm b/tests/numeric-tests.scm
new file mode 100644
index 00000000..6fc7c06e
--- /dev/null
+++ b/tests/numeric-tests.scm
@@ -0,0 +1,201 @@
+
+;; these tests are only valid if chibi-scheme is compiled with full
+;; numeric support (USE_BIGNUMS, USE_FLONUMS and USE_MATH)
+
+(cond-expand
+ (modules (import (only (chibi test) test-begin test test-end)))
+ (else #f))
+
+(test-begin "numbers")
+
+(define (integer-neighborhoods x)
+  (list x (+ 1 x) (+ -1 x) (- x) (- 1 x) (- -1 x)))
+
+(test '(536870912 536870913 536870911 -536870912 -536870911 -536870913)
+    (integer-neighborhoods (expt 2 29)))
+
+(test '(1073741824 1073741825 1073741823 -1073741824 -1073741823 -1073741825)
+    (integer-neighborhoods (expt 2 30)))
+
+(test '(2147483648 2147483649 2147483647 -2147483648 -2147483647 -2147483649)
+    (integer-neighborhoods (expt 2 31)))
+
+(test '(4294967296 4294967297 4294967295 -4294967296 -4294967295 -4294967297)
+    (integer-neighborhoods (expt 2 32)))
+
+(test '(4611686018427387904 4611686018427387905 4611686018427387903
+        -4611686018427387904 -4611686018427387903 -4611686018427387905)
+    (integer-neighborhoods (expt 2 62)))
+
+(test '(9223372036854775808 9223372036854775809 9223372036854775807
+        -9223372036854775808 -9223372036854775807 -9223372036854775809)
+    (integer-neighborhoods (expt 2 63)))
+
+(test '(18446744073709551616 18446744073709551617 18446744073709551615
+        -18446744073709551616 -18446744073709551615 -18446744073709551617)
+    (integer-neighborhoods (expt 2 64)))
+
+(test '(85070591730234615865843651857942052864
+        85070591730234615865843651857942052865
+        85070591730234615865843651857942052863
+        -85070591730234615865843651857942052864
+        -85070591730234615865843651857942052863
+        -85070591730234615865843651857942052865)
+    (integer-neighborhoods (expt 2 126)))
+
+(test '(170141183460469231731687303715884105728
+        170141183460469231731687303715884105729
+        170141183460469231731687303715884105727
+        -170141183460469231731687303715884105728
+        -170141183460469231731687303715884105727
+        -170141183460469231731687303715884105729)
+    (integer-neighborhoods (expt 2 127)))
+
+(test '(340282366920938463463374607431768211456
+        340282366920938463463374607431768211457
+        340282366920938463463374607431768211455
+        -340282366920938463463374607431768211456
+        -340282366920938463463374607431768211455
+        -340282366920938463463374607431768211457)
+    (integer-neighborhoods (expt 2 128)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (integer-arithmetic-combinations a b)
+  (list (+ a b) (- a b) (* a b) (quotient a b) (remainder a b)))
+
+(define (sign-combinations a b)
+  (list (integer-arithmetic-combinations a b)
+        (integer-arithmetic-combinations (- a) b)
+        (integer-arithmetic-combinations a (- b))
+        (integer-arithmetic-combinations (- a) (- b))))
+
+;; fix x fix
+(test '((1 -1 0 0 0) (1 -1 0 0 0) (-1 1 0 0 0) (-1 1 0 0 0))
+    (sign-combinations 0 1))
+(test '((2 0 1 1 0) (0 -2 -1 -1 0) (0 2 -1 -1 0) (-2 0 1 1 0))
+    (sign-combinations 1 1))
+(test '((59 25 714 2 8) (-25 -59 -714 -2 -8)
+        (25 59 -714 -2 8) (-59 -25 714 2 -8))
+    (sign-combinations 42 17))
+
+;; fix x big
+(test '((4294967338 -4294967254 180388626432 0 42)
+        (4294967254 -4294967338 -180388626432 0 -42)
+        (-4294967254 4294967338 -180388626432 0 42)
+        (-4294967338 4294967254 180388626432 0 -42))
+    (sign-combinations 42 (expt 2 32)))
+
+;; big x fix
+(test '((4294967338 4294967254 180388626432 102261126 4)
+        (-4294967254 -4294967338 -180388626432 -102261126 -4)
+        (4294967254 4294967338 -180388626432 -102261126 4)
+        (-4294967338 -4294967254 180388626432 102261126 -4))
+    (sign-combinations (expt 2 32) 42))
+
+;; big x bigger
+(test '((12884901889 -4294967297 36893488151714070528 0 4294967296)
+        (4294967297 -12884901889 -36893488151714070528 0 -4294967296)
+        (-4294967297 12884901889 -36893488151714070528 0 4294967296)
+        (-12884901889 4294967297 36893488151714070528 0 -4294967296))
+    (sign-combinations (expt 2 32) (+ 1 (expt 2 33))))
+
+(test '((18446744078004518913 -18446744069414584321 79228162514264337597838917632 0 4294967296)
+        (18446744069414584321 -18446744078004518913 -79228162514264337597838917632 0 -4294967296)
+        (-18446744069414584321 18446744078004518913 -79228162514264337597838917632 0 4294967296)
+        (-18446744078004518913 18446744069414584321 79228162514264337597838917632 0 -4294967296))
+    (sign-combinations (expt 2 32) (+ 1 (expt 2 64))))
+
+;; bigger x big
+(test '((12884901889 4294967297 36893488151714070528 2 1)
+        (-4294967297 -12884901889 -36893488151714070528 -2 -1)
+        (4294967297 12884901889 -36893488151714070528 -2 1)
+        (-12884901889 -4294967297 36893488151714070528 2 -1))
+    (sign-combinations (+ 1 (expt 2 33)) (expt 2 32)))
+
+(test '((18446744078004518913 18446744069414584321 79228162514264337597838917632 4294967296 1)
+        (-18446744069414584321 -18446744078004518913 -79228162514264337597838917632 -4294967296 -1)
+        (18446744069414584321 18446744078004518913 -79228162514264337597838917632 -4294967296 1)
+        (-18446744078004518913 -18446744069414584321 79228162514264337597838917632 4294967296 -1))
+    (sign-combinations (+ 1 (expt 2 64)) (expt 2 32)))
+
+(define M7 (- (expt 2 127) 1))
+
+(test '((170141183460469231750134047789593657344
+         170141183460469231713240559642174554110
+         3138550867693340382088035895064302439764418281874191810559
+         9223372036854775807
+         9223372036854775808)
+        (-170141183460469231713240559642174554110
+         -170141183460469231750134047789593657344
+         -3138550867693340382088035895064302439764418281874191810559
+         -9223372036854775807
+         -9223372036854775808)
+        (170141183460469231713240559642174554110
+         170141183460469231750134047789593657344
+         -3138550867693340382088035895064302439764418281874191810559
+         -9223372036854775807
+         9223372036854775808)
+        (-170141183460469231750134047789593657344
+         -170141183460469231713240559642174554110
+         3138550867693340382088035895064302439764418281874191810559
+         9223372036854775807
+         -9223372036854775808))
+    (sign-combinations M7 (+ 1 (expt 2 64))))
+
+(test #f (< +nan.0 +nan.0))
+(test #f (<= +nan.0 +nan.0))
+(test #f (= +nan.0 +nan.0))
+(test #f (>= +nan.0 +nan.0))
+(test #f (> +nan.0 +nan.0))
+
+(test #f (< +inf.0 +inf.0))
+(test #t (<= +inf.0 +inf.0))
+(test #t (= +inf.0 +inf.0))
+(test #t (>= +inf.0 +inf.0))
+(test #f (> +inf.0 +inf.0))
+
+(test #f (< -inf.0 -inf.0))
+(test #t (<= -inf.0 -inf.0))
+(test #t (= -inf.0 -inf.0))
+(test #t (>= -inf.0 -inf.0))
+(test #f (> -inf.0 -inf.0))
+
+(test #t (< -inf.0 +inf.0))
+(test #t (<= -inf.0 +inf.0))
+(test #f (= -inf.0 +inf.0))
+(test #f (>= -inf.0 +inf.0))
+(test #f (> -inf.0 +inf.0))
+
+(test 88962710306127702866241727433142015
+    (string->number "#x00112233445566778899aabbccddeeff"))
+
+(test (expt 10 154) (sqrt (expt 10 308)))
+
+(test 36893488147419103231
+    (- 340282366920938463463374607431768211456
+       340282366920938463426481119284349108225))
+
+(cond-expand
+ (ratios
+  (test #t (< 1/2 1.0))
+  (test #t (< 1.0 3/2))
+  (test #t (< 1/2 1.5))
+  (test #t (< 1/2 2.0))
+  (test 1.0 (max 1/2 1.0))
+  (test 18446744073709551617 (numerator (/ 18446744073709551617 2)))
+  (test "18446744073709551617/2" (number->string (/ 18446744073709551617 2)))
+  (let ((a 1000000000000000000000000000000000000000)
+        (b 31622776601683794000))
+    (test 31622776601683792639 (quotient a b))
+    (test 30922992657207634000 (remainder a b)))
+  (let ((g 18446744073709551616/6148914691236517205))
+    (test 36893488147419103231/113427455640312821148309287786019553280
+        (- g (/ 9 g))))
+  (let ((r  (/ (expt 2 61) 3)))
+    (test 0 (- r r))
+    (test 2305843009213693952/3 r)))
+ (else
+  #f))
+
+(test-end)
diff --git a/tests/parse-tests.scm b/tests/parse-tests.scm
new file mode 100644
index 00000000..245eac6e
--- /dev/null
+++ b/tests/parse-tests.scm
@@ -0,0 +1,134 @@
+
+(import (chibi) (chibi test)
+        (chibi char-set) (chibi char-set ascii)
+        (chibi parse) (chibi parse common))
+
+(test-begin "parse")
+
+;; basic
+
+(test-assert (parse parse-epsilon ""))
+(test-assert (parse-fully parse-epsilon ""))
+(test-error (parse-fully parse-epsilon "a"))
+
+(test-not (parse parse-anything ""))
+(test-assert (parse-fully parse-anything "a"))
+(test-error (parse-fully parse-anything "ab"))
+
+(test-not (parse parse-nothing ""))
+(test-not (parse parse-nothing "a"))
+
+(test-not (parse (parse-char #\a) ""))
+(test-assert (parse-fully (parse-char #\a) "a"))
+(test-not (parse (parse-char #\a) "b"))
+(test-error (parse-fully (parse-char #\a) "ab"))
+
+(let ((f (parse-seq (parse-char #\a) (parse-char #\b))))
+  (test-not (parse f "a"))
+  (test-not (parse f "b"))
+  (test-assert (parse f "ab"))
+  (test-error (parse-fully f "abc")))
+
+(let ((f (parse-or (parse-char #\a) (parse-char #\b))))
+  (test-not (parse f ""))
+  (test-assert (parse f "a"))
+  (test-assert (parse f "b"))
+  (test-error (parse-fully f "ab")))
+
+(let ((f (parse-not (parse-char #\a))))
+  (test-assert (parse f ""))
+  (test-error (parse-fully f "a"))
+  (test-assert (parse f "b")))
+
+(let ((f (parse-repeat (parse-char #\a))))
+  (test-assert (parse-fully f ""))
+  (test-assert (parse-fully f "a"))
+  (test-assert (parse-fully f "aa"))
+  (test-assert (parse-fully f "aaa"))
+  (test-assert (parse f "b"))
+  (test-assert (parse f "aab"))
+  (test-error (parse-fully f "aab")))
+
+;; grammars
+
+(let ()
+  (define-grammar calc
+    (space ((* ,char-set:whitespace)))
+    (number ((=> n (+ ,char-set:digit))
+             (string->number (list->string n))))
+    (simple ((=> n ,number) n)
+            ((: "(" (=> e1 ,term) ")") e1))
+    (term-op ("*" *)
+             ("/" /)
+             ("%" modulo))
+    (term ((: (=> e1 ,simple) ,space (=> op ,term-op) ,space (=> e2 ,term))
+           (op e1 e2))
+          ((=> e1 ,simple)
+           e1)))
+  (test 88 (parse term "4*22"))
+  (test 42 (parse term "42"))
+  ;; partial match (grammar isn't checking end)
+  (test 42 (parse term "42*")))
+
+(define calculator
+  (grammar expr
+    (space ((: ,char-set:whitespace ,space))
+           (() #f))
+    (digit ((=> d ,char-set:digit) d))
+    (number ((=> n (+ ,digit))
+             (string->number (list->string n))))
+    (simple ((=> n ,number) n)
+            ((: "(" (=> e1 ,expr) ")") e1))
+    (term-op ("*" *)
+             ("/" /)
+             ("%" modulo))
+    (term ((: (=> e1 ,simple) ,space (=> op ,term-op) ,space (=> e2 ,term))
+           (op e1 e2))
+          ((=> e1 ,simple)
+           e1))
+    (expr-op ("+" +) ("-" -))
+    (expr ((: ,space (=> e1 ,term) ,space (=> op ,expr-op) ,space (=> e2 ,expr))
+           (op e1 e2))
+          ((: ,space (=> e1 ,term))
+           e1))))
+
+(test 42 (parse calculator "42"))
+(test 4 (parse calculator "2 + 2"))
+(test 23 (parse calculator "2 + 2*10 + 1"))
+(test 25 (parse calculator "2+2 * 10+1 * 3"))
+(test 41 (parse calculator "(2 + 2) * 10 + 1"))
+
+(define prec-calc
+  (grammar expr
+    (simple (,(parse-integer))
+            ((: "(" (=> e1 ,expr) ")") e1))
+    (op
+     ("+" '+) ("-" '-) ("*" '*) ("/" '/) ("^" '^))
+    (expr
+     (,(parse-binary-op op `((+ 5) (- 5) (* 3) (/ 3) (^ 1 right)) simple)))))
+
+(test 42 (parse prec-calc "42"))
+(test '(+ 2 2) (parse prec-calc "2 + 2"))
+(test '(+ (+ 2 2) 2) (parse prec-calc "2 + 2 + 2"))
+(test '(+ (+ 2 (* 2 10)) 1) (parse prec-calc "2 + 2*10 + 1"))
+(test '(+ (+ 2 (* 2 10)) (* 1 3)) (parse prec-calc "2+2 * 10+1 * 3"))
+(test '(+ (* (+ 2 2) 10) 1) (parse prec-calc "(2 + 2) * 10 + 1"))
+(test '(^ 2 (^ 2 2)) (parse prec-calc "2 ^ 2 ^ 2"))
+(test '(+ (+ (+ 1 (* (* 2 (^ 3 (^ 4 5))) 6)) (^ 7 8)) 9)
+    (parse prec-calc "1 + 2 * 3 ^ 4 ^ 5 * 6 + 7 ^ 8 + 9"))
+
+;; this takes exponential time without memoization
+(define explode
+  (grammar start
+    (start ((: ,S eos) #t))
+    (S ((+ ,A) #t))
+    (A ((: "a" ,S "b") #t)
+       ((: "a" ,S "c") #t)
+       ((: "a") #t))))
+
+(test-assert (parse explode "aaabb"))
+(test-not (parse explode "bbaa"))
+(test-assert
+ (parse explode (string-append (make-string 10 #\a) (make-string 8 #\c))))
+
+(test-end)
diff --git a/tests/path-tests.scm b/tests/path-tests.scm
new file mode 100644
index 00000000..8d6aa422
--- /dev/null
+++ b/tests/path-tests.scm
@@ -0,0 +1,204 @@
+
+(import (chibi) (chibi pathname) (chibi test))
+
+(test-begin "pathname")
+
+;; tests from the dirname(3) manpage
+
+(test "dirname(3)" "/usr" (path-directory "/usr/lib"))
+(test "lib"  (path-strip-directory "/usr/lib"))
+
+(test "/"    (path-directory "/usr/"))
+(test ""     (path-strip-directory "/usr/"))
+
+(test "."    (path-directory "usr"))
+(test "usr"  (path-strip-directory "usr"))
+
+(test "/"    (path-directory "/"))
+(test ""     (path-strip-directory "/"))
+
+(test "."    (path-directory "."))
+(test "."    (path-strip-directory "."))
+
+(test "."    (path-directory ".."))
+(test ".."   (path-strip-directory ".."))
+
+;; additional tests (should match GNU dirname/basename behavior)
+
+(test "path-directory:border"
+            "/"    (path-directory "//"))
+(test ""     (path-strip-directory "//"))
+
+(test "."    (path-directory ""))
+(test ""     (path-strip-directory ""))
+
+(test "."    (path-directory "../"))
+(test ""     (path-strip-directory "../"))
+
+(test ".."   (path-directory "../.."))
+(test ".."   (path-strip-directory "../.."))
+
+(test "path-directory:extra"
+            "/usr/local" (path-directory "/usr/local/lib"))
+(test "lib" (path-strip-directory "/usr/local/lib"))
+
+(test "/usr" (path-directory "/usr/local/"))
+(test "" (path-strip-directory "/usr/local/"))
+
+(test "usr"    (path-directory "usr/local"))
+(test "local"  (path-strip-directory "usr/local"))
+
+(test "/" (path-directory "//usr"))
+(test "usr" (path-strip-directory "//usr"))
+
+(test "/" (path-directory "//usr/"))
+(test "" (path-strip-directory "//usr/"))
+
+(test "path-directory:small"
+            "/a" (path-directory "/a/b"))
+(test "b" (path-strip-directory "/a/b"))
+
+(test "a" (path-directory "a/b"))
+(test "b" (path-strip-directory "a/b"))
+
+(test "a" (path-directory "a/b/"))
+(test "" (path-strip-directory "a/b/"))
+
+(test "/a/b/c" (path-directory "/a/b/c/d"))
+(test "d" (path-strip-directory "/a/b/c/d"))
+
+(test "/a/b/c" (path-directory "/a/b/c/d/"))
+(test "" (path-strip-directory "/a/b/c/d/"))
+
+(test "a/b/c"    (path-directory "a/b/c/d"))
+(test "d"  (path-strip-directory "a/b/c/d"))
+
+(test "/a/b" (path-directory "/a/b/c.d"))
+(test "c.d" (path-strip-directory "/a/b/c.d"))
+
+(test "/a/b" (path-directory "/a/b/c.d/"))
+(test "" (path-strip-directory "/a/b/c.d/"))
+
+(test "/a/b/c" (path-directory "/a/b/c/."))
+(test "." (path-strip-directory "/a/b/c/."))
+
+(test "/a/b/c" (path-directory "/a/b/c/.."))
+(test ".." (path-strip-directory "/a/b/c/.."))
+
+(test "/a/b/." (path-directory "/a/b/./c"))
+(test "c" (path-strip-directory "/a/b/./c"))
+
+(test "/a/b/.." (path-directory "/a/b/../c"))
+(test "c" (path-strip-directory "/a/b/../c"))
+
+(test "/a/b" (path-directory "/a/b/c//"))
+(test "" (path-strip-directory "/a/b/c//"))
+
+(test "/a/b" (path-directory "/a/b//c///"))
+(test "" (path-strip-directory "/a/b//c///"))
+
+;; extensions
+
+(test "path-extension" "scm" (path-extension "foo.scm"))
+(test "foo" (path-strip-extension "foo.scm"))
+
+(test "c" (path-extension "foo.scm.c"))
+(test "foo.scm" (path-strip-extension "foo.scm.c"))
+
+(test "scm" (path-extension "/home/me/foo.scm"))
+(test "/home/me/foo" (path-strip-extension "/home/me/foo.scm"))
+
+(test "scm" (path-extension "foo..scm"))
+(test "foo." (path-strip-extension "foo..scm"))
+
+(test "s" (path-extension "foo.s"))
+(test "foo" (path-strip-extension "foo.s"))
+
+(test #f (path-extension "foo."))
+(test "foo." (path-strip-extension "foo."))
+
+(test #f (path-extension "foo.scm."))
+(test "foo.scm." (path-strip-extension "foo.scm."))
+
+(test #f (path-extension "."))
+(test "." (path-strip-extension "."))
+
+(test #f (path-extension "a."))
+(test "a." (path-strip-extension "a."))
+
+(test #f (path-extension "/."))
+(test "/." (path-strip-extension "/."))
+
+(test #f (path-extension "foo.scm/"))
+(test "foo.scm/" (path-strip-extension "foo.scm/"))
+
+(test "path-replace-extension"
+            "foo.c" (path-replace-extension "foo.scm" "c"))
+(test "foo.c" (path-replace-extension "foo" "c"))
+
+;; absolute paths
+
+(test-assert (path-absolute? "/"))
+(test-assert (path-absolute? "//"))
+(test-assert (path-absolute? "/usr"))
+(test-assert (path-absolute? "/usr/"))
+(test-assert (path-absolute? "/usr/."))
+(test-assert (path-absolute? "/usr/.."))
+(test-assert (path-absolute? "/usr/./"))
+(test-assert (path-absolute? "/usr/../"))
+
+(test-assert (not (path-absolute? "")))
+(test-assert (not (path-absolute? ".")))
+(test-assert (not (path-absolute? "usr")))
+(test-assert (not (path-absolute? "usr/")))
+
+;; normalization & building
+
+(test "path-normalize" "/a/b/c/d/e" (path-normalize "/a/b/c/d/./e"))
+(test "/a/b/c/d/e" (path-normalize "/a/b//.///c//d/./e"))
+(test "/a/b/c/d/e/" (path-normalize "/a/b//.///c//d/./e/"))
+(test "/a/c/d/e" (path-normalize "/a/b/../c/d/e"))
+(test "/a/b/c/e" (path-normalize "/a/b//.///c//d/../e"))
+(test "/a/c/e" (path-normalize "/a/b//..///c//d/../e"))
+(test "/a/b/c/d/e/"
+            (path-normalize "/a/b//./../c/d/../../b//c/d/e/f/.."))
+(test "/a/b/c/" (path-normalize "/a/b/c/."))
+
+(test "path-normalize:border" "" (path-normalize ""))
+(test "." (path-normalize "."))
+(test "/" (path-normalize "/"))
+(test "/" (path-normalize "/."))
+
+(test "path-normalize:overflow"
+            "/" (path-normalize "/a/b/c/../../../../.."))
+(test "../.." (path-normalize "a/b/c/../../../../.."))
+(test "../../.." (path-normalize "../a/b/c/../../../../.."))
+
+(test "" (path-strip-leading-parents ".."))
+(test "" (path-strip-leading-parents "../"))
+(test "a" (path-strip-leading-parents "../a"))
+(test "a/b" (path-strip-leading-parents "../../a/b"))
+(test "a/b" (path-strip-leading-parents "../../../a/b"))
+(test "a/../b" (path-strip-leading-parents "../../../a/../b"))
+
+(test "path-relative-to" "c" (path-relative-to "/a/b/c" "/a/b"))
+(test "c" (path-relative-to "/a/b/c" "/a/b/"))
+(test "." (path-relative-to "/a/b/" "/a/b/"))
+(test "." (path-relative-to "/a/b/" "/a/b"))
+(test "." (path-relative-to "/a/b" "/a/b/"))
+(test "." (path-relative-to "/a/b" "/a/b"))
+(test-not (path-relative-to "/d/a/b/c" "/a/b"))
+
+(test "make-path" "a/b" (make-path "a" "b"))
+(test "a/b" (make-path "a/" "b"))
+(test "a/b/./c" (make-path "a" "b" "." "c"))
+(test "a/b/../c" (make-path "a" "b" ".." "c"))
+(test "a/b/c" (make-path "a" '("b" "c")))
+(test "/" (make-path "/" ""))
+(test "/" (make-path "/" "/"))
+(test "/." (make-path "/" "."))
+(test "/a" (make-path "/a" ""))
+(test "/a" (make-path "/a" "/"))
+(test "/a/." (make-path "/a" "."))
+
+(test-end)
diff --git a/tests/prime-tests.scm b/tests/prime-tests.scm
new file mode 100644
index 00000000..a060f82c
--- /dev/null
+++ b/tests/prime-tests.scm
@@ -0,0 +1,95 @@
+
+(import (chibi) (chibi math prime) (chibi test))
+
+(test-begin "prime")
+
+(test 7 (modular-inverse 3 10))
+(test 4 (modular-inverse 3 11))
+(test 27 (modular-inverse 3 40))
+(test 43 (modular-inverse 3 64))
+
+(test #f (prime? 1))
+(test #t (prime? 2))
+(test #t (prime? 3))
+(test #f (prime? 4))
+(test #t (prime? 5))
+(test #f (prime? 6))
+(test #t (prime? 7))
+(test #f (prime? 8))
+(test #f (prime? 9))
+(test #f (prime? 10))
+(test #t (prime? 11))
+
+(test 2 (nth-prime 0))
+(test 3 (nth-prime 1))
+(test 5 (nth-prime 2))
+(test 7 (nth-prime 3))
+(test 11 (nth-prime 4))
+(test 997 (nth-prime 167))
+(test 1009 (nth-prime 168))
+(test 1013 (nth-prime 169))
+
+(test 907 (prime-above 888))
+(test 797 (prime-below 808))
+
+(test 1 (totient 2))
+(test 2 (totient 3))
+(test 2 (totient 4))
+(test 4 (totient 5))
+(test 2 (totient 6))
+(test 6 (totient 7))
+(test 4 (totient 8))
+(test 6 (totient 9))
+(test 4 (totient 10))
+
+(test #f (perfect? 1))
+(test #f (perfect? 2))
+(test #f (perfect? 3))
+(test #f (perfect? 4))
+(test #f (perfect? 5))
+(test #t (perfect? 6))
+(test #f (perfect? 7))
+(test #f (perfect? 8))
+(test #f (perfect? 9))
+(test #f (perfect? 10))
+(test #t (perfect? 28))
+(test #t (perfect? 496))
+(test #t (perfect? 8128))
+
+(test '(1) (factor 1))
+(test '(2) (factor 2))
+(test '(3) (factor 3))
+(test '(2 2) (factor 4))
+(test '(5) (factor 5))
+(test '(2 3) (factor 6))
+(test '(7) (factor 7))
+(test '(2 2 2) (factor 8))
+(test '(3 3) (factor 9))
+(test '(2 5) (factor 10))
+(test '(11) (factor 11))
+(test '(2 2 3) (factor 12))
+(test '(2 3 3) (factor 18))
+(test '(2 2 2 3 3) (factor 72))
+(test '(3 3 3 5 7) (factor 945))
+
+(test 975 (aliquot 945))
+
+(do ((i 3 (+ i 2)))
+    ((>= i 101))
+  (test (number->string i) (prime? i)
+    (probable-prime? i)))
+
+(test #t (probable-prime? 4611686020149081683))
+(test #t (probable-prime? 4611686020243253179))
+(test #t (probable-prime? 4611686020243253219))
+(test #t (probable-prime? 4611686020243253257))
+(test #f (probable-prime? 4611686020243253181))
+(test #f (probable-prime? 4611686020243253183))
+(test #f (probable-prime? 4611686020243253247))
+
+(test 5
+    (modular-expt 7670626353261554806
+                  5772301760555853353
+                  (* 2936546443 3213384203)))
+
+(test-end)
diff --git a/tests/process-tests.scm b/tests/process-tests.scm
new file mode 100644
index 00000000..3f79a568
--- /dev/null
+++ b/tests/process-tests.scm
@@ -0,0 +1,28 @@
+
+(cond-expand
+ (modules (import (chibi process) (only (chibi test) test-begin test test-end)))
+ (else #f))
+
+(test-begin "processes")
+
+(test #t (process-running? (current-process-id)))
+(test #t (process-running? (parent-process-id)))
+(test #f (signal-set-contains? (current-signal-mask) signal/alarm))
+
+(test #t (signal-set? (make-signal-set)))
+(test #t (signal-set? (current-signal-mask)))
+(test #f (signal-set? #f))
+(test #f (signal-set? '(#f)))
+(test #f (signal-set-contains? (make-signal-set) signal/interrupt))
+(test #t (let ((sset (make-signal-set)))
+           (signal-set-fill! sset)
+           (signal-set-contains? sset signal/interrupt)))
+(test #t (let ((sset (make-signal-set)))
+           (signal-set-add! sset signal/interrupt)
+           (signal-set-contains? sset signal/interrupt)))
+(test #f (let ((sset (make-signal-set)))
+           (signal-set-fill! sset)
+           (signal-set-delete! sset signal/interrupt)
+           (signal-set-contains? sset signal/interrupt)))
+
+(test-end)
diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm
new file mode 100644
index 00000000..b056be49
--- /dev/null
+++ b/tests/r5rs-tests.scm
@@ -0,0 +1,524 @@
+
+(define *tests-run* 0)
+(define *tests-passed* 0)
+
+(define-syntax test
+  (syntax-rules ()
+    ((test name expect expr)
+     (test expect expr))
+    ((test expect expr)
+     (begin
+       (set! *tests-run* (+ *tests-run* 1))
+       (let ((str (call-with-output-string
+                    (lambda (out)
+                      (write *tests-run*)
+                      (display ". ")
+                      (display 'expr out))))
+             (res expr))
+         (display str)
+         (write-char #\space)
+         (display (make-string (max 0 (- 72 (string-length str))) #\.))
+         (flush-output)
+         (cond
+          ((equal? res expect)
+           (set! *tests-passed* (+ *tests-passed* 1))
+           (display " [PASS]\n"))
+          (else
+           (display " [FAIL]\n")
+           (display "    expected ") (write expect)
+           (display " but got ") (write res) (newline))))))))
+
+(define-syntax test-assert
+  (syntax-rules ()
+    ((test-assert expr) (test #t expr))))
+
+(define (test-begin . name)
+  #f)
+
+(define (test-end)
+  (write *tests-passed*)
+  (display " out of ")
+  (write *tests-run*)
+  (display " passed (")
+  (write (* (/ *tests-passed* *tests-run*) 100))
+  (display "%)")
+  (newline))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(test-begin "r5rs")
+
+(test 8 ((lambda (x) (+ x x)) 4))
+
+(test '(3 4 5 6) ((lambda x x) 3 4 5 6))
+
+(test '(5 6) ((lambda (x y . z) z) 3 4 5 6))
+
+(test 'yes (if (> 3 2) 'yes 'no))
+
+(test 'no (if (> 2 3) 'yes 'no))
+
+(test 1 (if (> 3 2) (- 3 2) (+ 3 2)))
+
+(test 'greater (cond ((> 3 2) 'greater) ((< 3 2) 'less)))
+
+(test 'equal (cond ((> 3 3) 'greater) ((< 3 3) 'less) (else 'equal)))
+
+(test 'composite (case (* 2 3) ((2 3 5 7) 'prime) ((1 4 6 8 9) 'composite)))
+
+(test 'consonant
+    (case (car '(c d))
+      ((a e i o u) 'vowel)
+      ((w y) 'semivowel)
+      (else 'consonant)))
+
+(test #t (and (= 2 2) (> 2 1)))
+
+(test #f (and (= 2 2) (< 2 1)))
+
+(test '(f g) (and 1 2 'c '(f g)))
+
+(test #t (and))
+
+(test #t (or (= 2 2) (> 2 1)))
+
+(test #t (or (= 2 2) (< 2 1)))
+
+(test '(b c) (or (memq 'b '(a b c)) (/ 3 0)))
+
+(test 6 (let ((x 2) (y 3)) (* x y)))
+
+(test 35 (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
+
+(test 70 (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
+
+(test -2 (let ()
+           (define x 2)
+           (define f (lambda () (- x)))
+           (f)))
+
+(define let*-def 1)
+(let* () (define let*-def 2) #f)
+(test 1 let*-def)
+
+(test '#(0 1 2 3 4)
+ (do ((vec (make-vector 5))
+      (i 0 (+ i 1)))
+     ((= i 5) vec)
+   (vector-set! vec i i)))
+
+(test 25
+    (let ((x '(1 3 5 7 9)))
+      (do ((x x (cdr x))
+           (sum 0 (+ sum (car x))))
+          ((null? x)
+           sum))))
+
+(test '((6 1 3) (-5 -2))
+    (let loop ((numbers '(3 -2 1 6 -5)) (nonneg '()) (neg '()))
+      (cond
+       ((null? numbers)
+        (list nonneg neg))
+       ((>= (car numbers) 0)
+        (loop (cdr numbers) (cons (car numbers) nonneg) neg))
+       ((< (car numbers) 0)
+        (loop (cdr numbers) nonneg (cons (car numbers) neg))))))
+
+(test '(list 3 4) `(list ,(+ 1 2) 4))
+
+(test '(list a 'a) (let ((name 'a)) `(list ,name ',name)))
+
+(test '(a 3 4 5 6 b)
+    `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
+
+(test '(10 5 4 16 9 8)
+    `(10 5 ,(expt 2 2) ,@(map (lambda (n) (expt n 2)) '(4 3)) 8))
+
+(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
+    `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
+
+(test '(a `(b ,x ,'y d) e)
+    (let ((name1 'x)
+          (name2 'y))
+      `(a `(b ,,name1 ,',name2 d) e)))
+
+(test '(list 3 4)
+ (quasiquote (list (unquote (+ 1 2)) 4)))
+
+(test #t (eqv? 'a 'a))
+
+(test #f (eqv? 'a 'b))
+
+(test #t (eqv? '() '()))
+
+(test #f (eqv? (cons 1 2) (cons 1 2)))
+
+(test #f (eqv? (lambda () 1) (lambda () 2)))
+
+(test #t (let ((p (lambda (x) x))) (eqv? p p)))
+
+(test #t (eq? 'a 'a))
+
+(test #f (eq? (list 'a) (list 'a)))
+
+(test #t (eq? '() '()))
+
+(test #t (eq? car car))
+
+(test #t (let ((x '(a))) (eq? x x)))
+
+(test #t (let ((p (lambda (x) x))) (eq? p p)))
+
+(test #t (equal? 'a 'a))
+
+(test #t (equal? '(a) '(a)))
+
+(test #t (equal? '(a (b) c) '(a (b) c)))
+
+(test #t (equal? "abc" "abc"))
+
+(test #f (equal? "abc" "abcd"))
+
+(test #f (equal? "a" "b"))
+
+(test #t (equal? 2 2))
+
+;;(test #f (eqv? 2 2.0))
+
+;;(test #f (equal? 2.0 2))
+
+(test #t (equal? (make-vector 5 'a) (make-vector 5 'a)))
+
+(test 4 (max 3 4))
+
+;;(test 4 (max 3.9 4))
+
+(test 7 (+ 3 4))
+
+(test 3 (+ 3))
+
+(test 0 (+))
+
+(test 4 (* 4))
+
+(test 1 (*))
+
+(test -1 (- 3 4))
+
+(test -6 (- 3 4 5))
+
+(test -3 (- 3))
+
+(test -1.0 (- 3.0 4))
+
+(test 7 (abs -7))
+
+(test 1 (modulo 13 4))
+
+(test 1 (remainder 13 4))
+
+(test 3 (modulo -13 4))
+
+(test -1 (remainder -13 4))
+
+(test -3 (modulo 13 -4))
+
+(test 1 (remainder 13 -4))
+
+(test -1 (modulo -13 -4))
+
+(test -1 (remainder -13 -4))
+
+(test 4 (gcd 32 -36))
+
+(test 288 (lcm 32 -36))
+
+(test 100 (string->number "100"))
+
+(test 256 (string->number "100" 16))
+
+(test 127 (string->number "177" 8))
+
+(test 5 (string->number "101" 2))
+
+(test 100.0 (string->number "1e2"))
+
+(test "100" (number->string 100))
+
+(test "100" (number->string 256 16))
+
+(test "ff" (number->string 255 16))
+
+(test "177" (number->string 127 8))
+
+(test "101" (number->string 5 2))
+
+(test #f (not 3))
+
+(test #f (not (list 3)))
+
+(test #f (not '()))
+
+(test #f (not (list)))
+
+(test #f (not '()))
+
+(test #f (boolean? 0))
+
+(test #f (boolean? '()))
+
+(test #t (pair? '(a . b)))
+
+(test #t (pair? '(a b c)))
+
+(test '(a) (cons 'a '()))
+
+(test '((a) b c d) (cons '(a) '(b c d)))
+
+(test '("a" b c) (cons "a" '(b c)))
+
+(test '(a . 3) (cons 'a 3))
+
+(test '((a b) . c) (cons '(a b) 'c))
+
+(test 'a (car '(a b c)))
+
+(test '(a) (car '((a) b c d)))
+
+(test 1 (car '(1 . 2)))
+
+(test '(b c d) (cdr '((a) b c d)))
+
+(test 2 (cdr '(1 . 2)))
+
+(test #t (list? '(a b c)))
+
+(test #t (list? '()))
+
+(test #f (list? '(a . b)))
+
+(test #f
+    (let ((x (list 'a)))
+      (set-cdr! x x)
+      (list? x)))
+
+(test '(a 7 c) (list 'a (+ 3 4) 'c))
+
+(test '() (list))
+
+(test 3 (length '(a b c)))
+
+(test 3 (length '(a (b) (c d e))))
+
+(test 0 (length '()))
+
+(test '(x y) (append '(x) '(y)))
+
+(test '(a b c d) (append '(a) '(b c d)))
+
+(test '(a (b) (c)) (append '(a (b)) '((c))))
+
+(test '(a b c . d) (append '(a b) '(c . d)))
+
+(test 'a (append '() 'a))
+
+(test '(c b a) (reverse '(a b c)))
+
+(test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f)))))
+
+(test 'c (list-ref '(a b c d) 2))
+
+(test '(a b c) (memq 'a '(a b c)))
+
+(test '(b c) (memq 'b '(a b c)))
+
+(test #f (memq 'a '(b c d)))
+
+(test #f (memq (list 'a) '(b (a) c)))
+
+(test '((a) c) (member (list 'a) '(b (a) c)))
+
+(test '(101 102) (memv 101 '(100 101 102)))
+
+(test #f (assq (list 'a) '(((a)) ((b)) ((c)))))
+
+(test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c)))))
+
+(test '(5 7) (assv 5 '((2 3) (5 7) (11 13))))
+
+(test #t (symbol? 'foo))
+
+(test #t (symbol? (car '(a b))))
+
+(test #f (symbol? "bar"))
+
+(test #t (symbol? 'nil))
+
+(test #f (symbol? '()))
+
+(test "flying-fish" (symbol->string 'flying-fish))
+
+(test "Martin" (symbol->string 'Martin))
+
+(test "Malvina" (symbol->string (string->symbol "Malvina")))
+
+(test #t (string? "a"))
+
+(test #f (string? 'a))
+
+(test 0 (string-length ""))
+
+(test 3 (string-length "abc"))
+
+(test #\a (string-ref "abc" 0))
+
+(test #\c (string-ref "abc" 2))
+
+(test #t (string=? "a" (string #\a)))
+
+(test #f (string=? "a" (string #\b)))
+
+(test #t (string<? "a" "aa"))
+
+(test #f (string<? "aa" "a"))
+
+(test #f (string<? "a" "a"))
+
+(test #t (string<=? "a" "aa"))
+
+(test #t (string<=? "a" "a"))
+
+(test #t (string=? "a" (make-string 1 #\a)))
+
+(test #f (string=? "a" (make-string 1 #\b)))
+
+(test "" (substring "abc" 0 0))
+
+(test "a" (substring "abc" 0 1))
+
+(test "bc" (substring "abc" 1 3))
+
+(test "abc" (string-append "abc" ""))
+
+(test "abc" (string-append "" "abc"))
+
+(test "abc" (string-append "a" "bc"))
+
+(test '#(0 ("Sue" "Sue") "Anna")
+ (let ((vec (vector 0 '(2 2 2 2) "Anna")))
+   (vector-set! vec 1 '("Sue" "Sue"))
+   vec))
+
+(test '(dah dah didah) (vector->list '#(dah dah didah)))
+
+(test '#(dididit dah) (list->vector '(dididit dah)))
+
+(test #t (procedure? car))
+
+(test #f (procedure? 'car))
+
+(test #t (procedure? (lambda (x) (* x x))))
+
+(test #f (procedure? '(lambda (x) (* x x))))
+
+(test #t (call-with-current-continuation procedure?))
+
+(test 7 (call-with-current-continuation (lambda (k) (+ 2 5))))
+
+(test 3 (call-with-current-continuation (lambda (k) (+ 2 5 (k 3)))))
+
+(test 7 (apply + (list 3 4)))
+
+(test '(b e h) (map cadr '((a b) (d e) (g h))))
+
+(test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5)))
+
+(test '(5 7 9) (map + '(1 2 3) '(4 5 6)))
+
+(test '#(0 1 4 9 16)
+    (let ((v (make-vector 5)))
+      (for-each
+       (lambda (i) (vector-set! v i (* i i)))
+       '(0 1 2 3 4))
+      v))
+
+(test 3 (force (delay (+ 1 2))))
+
+(test '(3 3) (let ((p (delay (+ 1 2)))) (list (force p) (force p))))
+
+(test 'ok (let ((else 1)) (cond (else 'ok) (#t 'bad))))
+
+(test 'ok (let ((=> 1)) (cond (#t => 'ok))))
+
+(test '(,foo) (let ((unquote 1)) `(,foo)))
+
+(test '(,@foo) (let ((unquote-splicing 1)) `(,@foo)))
+
+(test 'ok
+    (let ((... 2))
+      (let-syntax ((s (syntax-rules ()
+                        ((_ x ...) 'bad)
+                        ((_ . r) 'ok))))
+        (s a b c))))
+
+(test 'ok (let ()
+            (let-syntax ()
+              (define internal-def 'ok))
+            internal-def))
+
+(test 'ok (let ()
+            (letrec-syntax ()
+              (define internal-def 'ok))
+            internal-def))
+
+(test '(2 1)
+    ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (list x y))))))
+
+(test '(2 2)
+    ((lambda () (let ((x 1)) (set! x 2) (let ((y x)) (list x y))))))
+
+(test '(1 2)
+    ((lambda () (let ((x 1)) (let ((y x)) (set! y 2) (list x y))))))
+
+(test '(2 3)
+    ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (set! y 3) (list x y))))))
+
+(test '(a b c)
+    (let* ((path '())
+           (add (lambda (s) (set! path (cons s path)))))
+      (dynamic-wind (lambda () (add 'a)) (lambda () (add 'b)) (lambda () (add 'c)))
+      (reverse path)))
+
+(test '(connect talk1 disconnect connect talk2 disconnect)
+    (let ((path '())
+          (c #f))
+      (let ((add (lambda (s)
+                   (set! path (cons s path)))))
+        (dynamic-wind
+            (lambda () (add 'connect))
+            (lambda ()
+              (add (call-with-current-continuation
+                    (lambda (c0)
+                      (set! c c0)
+                      'talk1))))
+            (lambda () (add 'disconnect)))
+        (if (< (length path) 4)
+            (c 'talk2)
+            (reverse path)))))
+
+(test 2 (let-syntax
+            ((foo (syntax-rules ::: ()
+                    ((foo ... args :::)
+                     (args ::: ...)))))
+          (foo 3 - 5)))
+
+(test '(5 4 1 2 3)
+    (let-syntax
+        ((foo (syntax-rules ()
+                ((foo args ... penultimate ultimate)
+                 (list ultimate penultimate args ...)))))
+      (foo 1 2 3 4 5)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(test-end)
diff --git a/tests/r7rs-tests.scm b/tests/r7rs-tests.scm
new file mode 100644
index 00000000..10b5fa48
--- /dev/null
+++ b/tests/r7rs-tests.scm
@@ -0,0 +1,2286 @@
+;; -*- coding: utf-8 -*-
+
+(import (scheme base) (scheme char) (scheme lazy)
+        (scheme inexact) (scheme complex) (scheme time)
+        (scheme file) (scheme read) (scheme write)
+        (scheme eval) (scheme process-context) (scheme case-lambda)
+        (scheme r5rs)
+        (chibi test)  ; or (srfi 64)
+        )
+
+;; R7RS test suite.  Covers all procedures and syntax in the small
+;; language except `delete-file'.  Currently assumes full-unicode
+;; support, the full numeric tower and all standard libraries
+;; provided.
+;;
+;; Uses the (chibi test) library which is written in portable R7RS.
+;; This is mostly a subset of SRFI-64, providing test-begin, test-end
+;; and test, which could be defined as something like:
+;;
+;;   (define (test-begin . o) #f)
+;;
+;;   (define (test-end . o) #f)
+;;
+;;   (define-syntax test
+;;     (syntax-rules ()
+;;       ((test expected expr)
+;;        (let ((res expr))
+;;          (cond
+;;           ((not (equal? expr expected))
+;;            (display "FAIL: ")
+;;            (write 'expr)
+;;            (display ": expected ")
+;;            (write expected)
+;;            (display " but got ")
+;;            (write res)
+;;            (newline)))))))
+;;
+;; however (chibi test) provides nicer output, timings, and
+;; approximate equivalence for floating point numbers.
+
+(test-begin "R7RS")
+
+(test-begin "4.1 Primitive expression types")
+
+(let ()
+  (define x 28)
+  (test 28 x))
+
+(test 'a (quote a))
+(test #(a b c) (quote #(a b c)))
+(test '(+ 1 2) (quote (+ 1 2)))
+
+(test 'a 'a)
+(test #(a b c) '#(a b c))
+(test '() '())
+(test '(+ 1 2) '(+ 1 2))
+(test '(quote a) '(quote a))
+(test '(quote a) ''a)
+
+(test "abc" '"abc")
+(test "abc" "abc")
+(test 145932 '145932)
+(test 145932 145932)
+(test #t '#t)
+(test #t #t)
+
+(test 7 (+ 3 4))
+(test 12 ((if #f + *) 3 4))
+
+(test 8 ((lambda (x) (+ x x)) 4))
+(define reverse-subtract
+  (lambda (x y) (- y x)))
+(test 3 (reverse-subtract 7 10))
+(define add4
+  (let ((x 4))
+    (lambda (y) (+ x y))))
+(test 10 (add4 6))
+
+(test '(3 4 5 6) ((lambda x x) 3 4 5 6))
+(test '(5 6) ((lambda (x y . z) z)
+ 3 4 5 6))
+
+(test 'yes (if (> 3 2) 'yes 'no))
+(test 'no (if (> 2 3) 'yes 'no))
+(test 1 (if (> 3 2)
+    (- 3 2)
+    (+ 3 2)))
+(let ()
+  (define x 2)
+  (test 3 (+ x 1)))
+
+(test-end)
+
+(test-begin "4.2 Derived expression types")
+
+(test 'greater
+    (cond ((> 3 2) 'greater)
+          ((< 3 2) 'less)))
+
+(test 'equal
+    (cond ((> 3 3) 'greater)
+          ((< 3 3) 'less)
+          (else 'equal)))
+
+(test 2
+    (cond ((assv 'b '((a 1) (b 2))) => cadr)
+          (else #f)))
+
+(test 'composite
+    (case (* 2 3)
+      ((2 3 5 7) 'prime)
+      ((1 4 6 8 9) 'composite)))
+
+(test 'c
+    (case (car '(c d))
+      ((a e i o u) 'vowel)
+      ((w y) 'semivowel)
+      (else => (lambda (x) x))))
+
+(test '((other . z) (semivowel . y) (other . x)
+        (semivowel . w) (vowel . u))
+    (map (lambda (x)
+           (case x
+             ((a e i o u) => (lambda (w) (cons 'vowel w)))
+             ((w y) (cons 'semivowel x))
+             (else => (lambda (w) (cons 'other w)))))
+         '(z y x w u)))
+
+(test #t (and (= 2 2) (> 2 1)))
+(test #f (and (= 2 2) (< 2 1)))
+(test '(f g) (and 1 2 'c '(f g)))
+(test #t (and))
+
+(test #t (or (= 2 2) (> 2 1)))
+(test #t (or (= 2 2) (< 2 1)))
+(test #f (or #f #f #f))
+(test '(b c) (or (memq 'b '(a b c))
+    (/ 3 0)))
+
+(test 6 (let ((x 2) (y 3))
+  (* x y)))
+
+(test 35 (let ((x 2) (y 3))
+  (let ((x 7)
+        (z (+ x y)))
+    (* z x))))
+
+(test 70 (let ((x 2) (y 3))
+  (let* ((x 7)
+         (z (+ x y)))
+    (* z x))))
+
+(test #t
+    (letrec ((even?
+              (lambda (n)
+                (if (zero? n)
+                    #t
+                    (odd? (- n 1)))))
+             (odd?
+              (lambda (n)
+                (if (zero? n)
+                    #f
+                    (even? (- n 1))))))
+      (even? 88)))
+
+(test 5
+    (letrec* ((p
+               (lambda (x)
+                 (+ 1 (q (- x 1)))))
+              (q
+               (lambda (y)
+                 (if (zero? y)
+                     0
+                     (+ 1 (p (- y 1))))))
+              (x (p 5))
+              (y x))
+             y))
+
+;; By Jussi Piitulainen <jpiitula@ling.helsinki.fi>
+;; and John Cowan <cowan@mercury.ccil.org>:
+;; http://lists.scheme-reports.org/pipermail/scheme-reports/2013-December/003876.html
+(define (means ton)
+  (letrec*
+     ((mean
+        (lambda (f g)
+          (f (/ (sum g ton) n))))
+      (sum
+        (lambda (g ton)
+          (if (null? ton)
+            (+)
+            (if (number? ton)
+                (g ton)
+                (+ (sum g (car ton))
+                   (sum g (cdr ton)))))))
+      (n (sum (lambda (x) 1) ton)))
+    (values (mean values values)
+            (mean exp log)
+            (mean / /))))
+(let*-values (((a b c) (means '(8 5 99 1 22))))
+  (test 27 a)
+  (test 9.728 b)
+  (test 1800/497 c))
+
+(let*-values (((root rem) (exact-integer-sqrt 32)))
+  (test 35 (* root rem)))
+
+(test '(1073741824 0)
+    (let*-values (((root rem) (exact-integer-sqrt (expt 2 60))))
+      (list root rem)))
+
+(test '(1518500249 3000631951)
+    (let*-values (((root rem) (exact-integer-sqrt (expt 2 61))))
+      (list root rem)))
+
+(test '(815238614083298888 443242361398135744)
+    (let*-values (((root rem) (exact-integer-sqrt (expt 2 119))))
+      (list root rem)))
+
+(test '(1152921504606846976 0)
+    (let*-values (((root rem) (exact-integer-sqrt (expt 2 120))))
+      (list root rem)))
+
+(test '(1630477228166597776 1772969445592542976)
+    (let*-values (((root rem) (exact-integer-sqrt (expt 2 121))))
+      (list root rem)))
+
+(test '(31622776601683793319 62545769258890964239)
+    (let*-values (((root rem) (exact-integer-sqrt (expt 10 39))))
+      (list root rem)))
+
+(let*-values (((root rem) (exact-integer-sqrt (expt 2 140))))
+  (test 0 rem)
+  (test (expt 2 140) (square root)))
+
+(test '(x y x y) (let ((a 'a) (b 'b) (x 'x) (y 'y))
+  (let*-values (((a b) (values x y))
+                ((x y) (values a b)))
+    (list a b x y))))
+
+(let ()
+  (define x 0)
+  (set! x 5)
+  (test 6 (+ x 1)))
+
+(test #(0 1 2 3 4) (do ((vec (make-vector 5))
+     (i 0 (+ i 1)))
+    ((= i 5) vec)
+  (vector-set! vec i i)))
+
+(test 25 (let ((x '(1 3 5 7 9)))
+  (do ((x x (cdr x))
+       (sum 0 (+ sum (car x))))
+      ((null? x) sum))))
+
+(test '((6 1 3) (-5 -2))
+    (let loop ((numbers '(3 -2 1 6 -5))
+               (nonneg '())
+               (neg '()))
+      (cond ((null? numbers) (list nonneg neg))
+            ((>= (car numbers) 0)
+             (loop (cdr numbers)
+                   (cons (car numbers) nonneg)
+                   neg))
+            ((< (car numbers) 0)
+             (loop (cdr numbers)
+                   nonneg
+                   (cons (car numbers) neg))))))
+
+(test 3 (force (delay (+ 1 2))))
+
+(test '(3 3)  
+    (let ((p (delay (+ 1 2))))
+      (list (force p) (force p))))
+
+(define integers
+  (letrec ((next
+            (lambda (n)
+              (delay (cons n (next (+ n 1)))))))
+    (next 0)))
+(define head
+  (lambda (stream) (car (force stream))))
+(define tail
+  (lambda (stream) (cdr (force stream))))
+
+(test 2 (head (tail (tail integers))))
+
+(define (stream-filter p? s)
+  (delay-force
+   (if (null? (force s)) 
+       (delay '())
+       (let ((h (car (force s)))
+             (t (cdr (force s))))
+         (if (p? h)
+             (delay (cons h (stream-filter p? t)))
+             (stream-filter p? t))))))
+
+(test 5 (head (tail (tail (stream-filter odd? integers)))))
+
+(let ()
+  (define x 5)
+  (define count 0)
+  (define p
+    (delay (begin (set! count (+ count 1))
+                  (if (> count x)
+                      count
+                      (force p)))))
+  (test 6 (force p))
+  (test 6 (begin (set! x 10) (force p))))
+
+(test #t (promise? (delay (+ 2 2))))
+(test #t (promise? (make-promise (+ 2 2))))
+(test #t
+    (let ((x (delay (+ 2 2))))
+      (force x)
+      (promise? x)))
+(test #t
+    (let ((x (make-promise (+ 2 2))))
+      (force x)
+      (promise? x)))
+
+(define radix
+  (make-parameter
+   10
+   (lambda (x)
+     (if (and (integer? x) (<= 2 x 16))
+         x
+         (error "invalid radix")))))
+(define (f n) (number->string n (radix)))
+(test "12" (f 12))
+(test "1100" (parameterize ((radix 2))
+  (f 12)))
+(test "12" (f 12))
+
+(test '(list 3 4) `(list ,(+ 1 2) 4))
+(let ((name 'a)) (test '(list a (quote a)) `(list ,name ',name)))
+(test '(a 3 4 5 6 b) `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
+(test #(10 5 4 16 9 8)
+    `#(10 5 ,(square 2) ,@(map square '(4 3)) 8))
+(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
+    `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f) )
+(let ((name1 'x)
+      (name2 'y))
+   (test '(a `(b ,x ,'y d) e) `(a `(b ,,name1 ,',name2 d) e)))
+(test '(list 3 4) (quasiquote (list (unquote (+ 1 2)) 4)) )
+(test `(list ,(+ 1 2) 4) (quasiquote (list (unquote (+ 1 2)) 4)))
+
+(define plus
+  (case-lambda 
+   (() 0)
+   ((x) x)
+   ((x y) (+ x y))
+   ((x y z) (+ (+ x y) z))
+   (args (apply + args))))
+
+(test 0 (plus))
+(test 1 (plus 1))
+(test 3 (plus 1 2))
+(test 6 (plus 1 2 3))
+(test 10 (plus 1 2 3 4))
+
+(define mult
+  (case-lambda 
+   (() 1)
+   ((x) x)
+   ((x y) (* x y))
+   ((x y . z) (apply mult (* x y) z))))
+
+(test 1 (mult))
+(test 1 (mult 1))
+(test 2 (mult 1 2))
+(test 6 (mult 1 2 3))
+(test 24 (mult 1 2 3 4))
+
+(test-end)
+
+(test-begin "4.3 Macros")
+
+(test 'now (let-syntax
+               ((when (syntax-rules ()
+                        ((when test stmt1 stmt2 ...)
+                         (if test
+                             (begin stmt1
+                                    stmt2 ...))))))
+             (let ((if #t))
+               (when if (set! if 'now))
+               if)))
+
+(test 'outer (let ((x 'outer))
+  (let-syntax ((m (syntax-rules () ((m) x))))
+    (let ((x 'inner))
+      (m)))))
+
+(test 7 (letrec-syntax
+  ((my-or (syntax-rules ()
+            ((my-or) #f)
+            ((my-or e) e)
+            ((my-or e1 e2 ...)
+             (let ((temp e1))
+               (if temp
+                   temp
+                   (my-or e2 ...)))))))
+  (let ((x #f)
+        (y 7)
+        (temp 8)
+        (let odd?)
+        (if even?))
+    (my-or x
+           (let temp)
+           (if y)
+           y))))
+
+(define-syntax be-like-begin1
+  (syntax-rules ()
+    ((be-like-begin1 name)
+     (define-syntax name
+       (syntax-rules ()
+         ((name expr (... ...))
+          (begin expr (... ...))))))))
+(be-like-begin1 sequence1)
+(test 3 (sequence1 0 1 2 3))
+
+(define-syntax be-like-begin2
+  (syntax-rules ()
+    ((be-like-begin2 name)
+     (define-syntax name
+       (... (syntax-rules ()
+              ((name expr ...)
+               (begin expr ...))))))))
+(be-like-begin1 sequence2)
+(test 4 (sequence2 1 2 3 4))
+
+(define-syntax be-like-begin3
+  (syntax-rules ()
+    ((be-like-begin3 name)
+     (define-syntax name
+       (syntax-rules dots ()
+         ((name expr dots)
+          (begin expr dots)))))))
+(be-like-begin3 sequence3)
+(test 5 (sequence3 2 3 4 5))
+
+;; Syntax pattern with ellipsis in middle of proper list.
+(define-syntax part-2
+  (syntax-rules ()
+    ((_ a b (m n) ... x y)
+     (vector (list a b) (list m ...) (list n ...) (list x y)))
+    ((_ . rest) 'error)))
+(test '#((10 43) (31 41 51) (32 42 52) (63 77))
+    (part-2 10 (+ 21 22) (31 32) (41 42) (51 52) (+ 61 2) 77))
+;; Syntax pattern with ellipsis in middle of improper list.
+(define-syntax part-2x
+  (syntax-rules ()
+    ((_ a b (m n) ... x y . rest)
+     (vector (list a b) (list m ...) (list n ...) (list x y)
+             (cons "rest:" 'rest)))
+    ((_ . rest) 'error)))
+(test '#((10 43) (31 41 51) (32 42 52) (63 77) ("rest:"))
+    (part-2x 10 (+ 21 22) (31 32) (41 42) (51 52) (+ 61 2) 77))
+(test '#((10 43) (31 41 51) (32 42 52) (63 77) ("rest:" . "tail"))
+    (part-2x 10 (+ 21 22) (31 32) (41 42) (51 52) (+ 61 2) 77 . "tail"))
+
+;; underscore
+(define-syntax count-to-2
+  (syntax-rules ()
+    ((_) 0)
+    ((_ _) 1)
+    ((_ _ _) 2)
+    ((_ . _) 'many)))
+(test '(2 0 many)
+    (list (count-to-2 a b) (count-to-2) (count-to-2 a b c d)))
+
+(define-syntax count-to-2_
+  (syntax-rules (_)
+    ((_) 0)
+    ((_ _) 1)
+    ((_ _ _) 2)
+    ((x . y) 'fail)))
+(test '(2 0 fail fail)
+    (list (count-to-2_ _ _) (count-to-2_)
+          (count-to-2_ a b) (count-to-2_ a b c d)))
+
+(define-syntax jabberwocky
+  (syntax-rules ()
+    ((_ hatter)
+     (begin
+       (define march-hare 42)
+       (define-syntax hatter
+         (syntax-rules ()
+           ((_) march-hare)))))))
+(jabberwocky mad-hatter)
+(test 42 (mad-hatter))
+
+(test 'ok (let ((=> #f)) (cond (#t => 'ok))))
+
+(test-end)
+
+(test-begin "5 Program structure")
+
+(define add3
+  (lambda (x) (+ x 3)))
+(test 6 (add3 3))
+(define first car)
+(test 1 (first '(1 2)))
+
+(test 45 (let ((x 5))
+  (define foo (lambda (y) (bar x y)))
+  (define bar (lambda (a b) (+ (* a b) a)))
+  (foo (+ x 3))))
+
+(test 'ok
+    (let ()
+      (define-values () (values))
+      'ok))
+(test 1
+    (let ()
+      (define-values (x) (values 1))
+      x))
+(test 3
+    (let ()
+      (define-values x (values 1 2))
+      (apply + x)))
+(test 3
+    (let ()
+      (define-values (x y) (values 1 2))
+      (+ x y)))
+(test 6
+    (let ()
+      (define-values (x y z) (values 1 2 3))
+      (+ x y z)))
+(test 10
+    (let ()
+      (define-values (x y . z) (values 1 2 3 4))
+      (+ x y (car z) (cadr z))))
+
+(test '(2 1) (let ((x 1) (y 2))
+  (define-syntax swap!
+    (syntax-rules ()
+      ((swap! a b)
+       (let ((tmp a))
+         (set! a b)
+         (set! b tmp)))))
+  (swap! x y)
+  (list x y)))
+
+;; Records
+
+(define-record-type <pare>
+  (kons x y)
+  pare?
+  (x kar set-kar!)
+  (y kdr))
+
+(test #t (pare? (kons 1 2)))
+(test #f (pare? (cons 1 2)))
+(test 1 (kar (kons 1 2)))
+(test 2 (kdr (kons 1 2)))
+(test 3 (let ((k (kons 1 2)))
+          (set-kar! k 3)
+          (kar k)))
+
+(test-end)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 6 Standard Procedures
+
+(test-begin "6.1 Equivalence Predicates")
+
+(test #t (eqv? 'a 'a))
+(test #f (eqv? 'a 'b))
+(test #t (eqv? 2 2))
+(test #t (eqv? '() '()))
+(test #t (eqv? 100000000 100000000))
+(test #f (eqv? (cons 1 2) (cons 1 2)))
+(test #f (eqv? (lambda () 1)
+               (lambda () 2)))
+(test #f (eqv? #f 'nil))
+
+(define gen-counter
+  (lambda ()
+    (let ((n 0))
+      (lambda () (set! n (+ n 1)) n))))
+(test #t
+    (let ((g (gen-counter)))
+      (eqv? g g)))
+(test #f (eqv? (gen-counter) (gen-counter)))
+(define gen-loser
+  (lambda ()
+    (let ((n 0))
+      (lambda () (set! n (+ n 1)) 27))))
+(test #t (let ((g (gen-loser)))
+  (eqv? g g)))
+
+(test #f
+(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
+         (g (lambda () (if (eqv? f g) 'g 'both))))
+   (eqv? f g)))
+
+(test #t
+    (let ((x '(a)))
+      (eqv? x x)))
+
+(test #t (eq? 'a 'a))
+(test #f (eq? (list 'a) (list 'a)))
+(test #t (eq? '() '()))
+(test #t
+    (let ((x '(a)))
+      (eq? x x)))
+(test #t
+    (let ((x '#()))
+      (eq? x x)))
+(test #t
+    (let ((p (lambda (x) x)))
+      (eq? p p)))
+
+(test #t (equal? 'a 'a))
+(test #t (equal? '(a) '(a)))
+(test #t (equal? '(a (b) c)
+                 '(a (b) c)))
+(test #t (equal? "abc" "abc"))
+(test #t (equal? 2 2))
+(test #t (equal? (make-vector 5 'a)
+                 (make-vector 5 'a)))
+
+(test-end)
+
+(test-begin "6.2 Numbers")
+
+(test #t (complex? 3+4i))
+(test #t (complex? 3))
+(test #t (real? 3))
+(test #t (real? -2.5+0i))
+(test #f (real? -2.5+0.0i))
+(test #t (real? #e1e10))
+(test #t (real? +inf.0))
+(test #f (rational? -inf.0))
+(test #t (rational? 6/10))
+(test #t (rational? 6/3))
+(test #t (integer? 3+0i))
+(test #t (integer? 3.0))
+(test #t (integer? 8/4))
+
+(test #f (exact? 3.0))
+(test #t (exact? #e3.0))
+(test #t (inexact? 3.))
+
+(test #t (exact-integer? 32))
+(test #f (exact-integer? 32.0))
+(test #f (exact-integer? 32/5))
+
+(test #t (finite? 3))
+(test #f (finite? +inf.0))
+(test #f (finite? 3.0+inf.0i))
+
+(test #f (infinite? 3))
+(test #t (infinite? +inf.0))
+(test #f (infinite? +nan.0))
+(test #t (infinite? 3.0+inf.0i))
+
+(test #t (nan? +nan.0))
+(test #f (nan? 32))
+;; (test #t (nan? +nan.0+5.0i))
+(test #f (nan? 1+2i))
+
+(test #t (= 1 1.0 1.0+0.0i))
+(test #f (= 1.0 1.0+1.0i))
+(test #t (< 1 2 3))
+(test #f (< 1 1 2))
+(test #t (> 3.0 2.0 1.0))
+(test #f (> -3.0 2.0 1.0))
+(test #t (<= 1 1 2))
+(test #f (<= 1 2 1))
+(test #t (>= 2 1 1))
+(test #f (>= 1 2 1))
+(test '(#t #f) (list (<= 1 1 2) (<= 2 1 3)))
+
+;; From R7RS 6.2.6 Numerical operations:
+;;
+;; These predicates are required to be transitive.
+;;
+;; _Note:_ The traditional implementations of these predicates in
+;; Lisp-like languages, which involve converting all arguments to inexact
+;; numbers if any argument is inexact, are not transitive.
+
+;; Example from Alan Bawden
+(let ((a (- (expt 2 1000) 1))
+      (b (inexact (expt 2 1000))) ; assuming > single-float-epsilon
+      (c (+ (expt 2 1000) 1)))
+  (test #t (if (and (= a b) (= b c))
+               (= a c)
+               #t)))
+
+;; From CLtL 12.3. Comparisons on Numbers:
+;;
+;;  Let _a_ be the result of (/ 10.0 single-float-epsilon), and let
+;;  _j_ be the result of (floor a). ..., all of (<= a j), (< j (+ j
+;;  1)), and (<= (+ j 1) a) would be true; transitivity would then
+;;  imply that (< a a) ought to be true ...
+
+;; Transliteration from Jussi Piitulainen
+(define single-float-epsilon
+  (do ((eps 1.0 (* eps 2.0)))
+      ((= eps (+ eps 1.0)) eps)))
+
+(let* ((a (/ 10.0 single-float-epsilon))
+       (j (exact a)))
+  (test #t (if (and (<= a j) (< j (+ j 1)))
+               (not (<= (+ j 1) a))
+               #t)))
+
+(test #t (zero? 0))
+(test #t (zero? 0.0))
+(test #t (zero? 0.0+0.0i))
+(test #f (zero? 1))
+(test #f (zero? -1))
+
+(test #f (positive? 0))
+(test #f (positive? 0.0))
+(test #t (positive? 1))
+(test #t (positive? 1.0))
+(test #f (positive? -1))
+(test #f (positive? -1.0))
+(test #t (positive? +inf.0))
+(test #f (positive? -inf.0))
+
+(test #f (negative? 0))
+(test #f (negative? 0.0))
+(test #f (negative? 1))
+(test #f (negative? 1.0))
+(test #t (negative? -1))
+(test #t (negative? -1.0))
+(test #f (negative? +inf.0))
+(test #t (negative? -inf.0))
+
+(test #f (odd? 0))
+(test #t (odd? 1))
+(test #t (odd? -1))
+(test #f (odd? 102))
+
+(test #t (even? 0))
+(test #f (even? 1))
+(test #t (even? -2))
+(test #t (even? 102))
+
+(test 3 (max 3))
+(test 4 (max 3 4))
+(test 4.0 (max 3.9 4))
+(test 5.0 (max 5 3.9 4))
+(test +inf.0 (max 100 +inf.0))
+(test 3 (min 3))
+(test 3 (min 3 4))
+(test 3.0 (min 3 3.1))
+(test -inf.0 (min -inf.0 -100))
+
+(test 7 (+ 3 4))
+(test 3 (+ 3))
+(test 0 (+))
+(test 4 (* 4))
+(test 1 (*))
+
+(test -1 (- 3 4))
+(test -6 (- 3 4 5))
+(test -3 (- 3))
+(test 3/20 (/ 3 4 5))
+(test 1/3 (/ 3))
+
+(test 7 (abs -7))
+(test 7 (abs 7))
+
+(test-values (values 2 1) (floor/ 5 2))
+(test-values (values -3 1) (floor/ -5 2))
+(test-values (values -3 -1) (floor/ 5 -2))
+(test-values (values 2 -1) (floor/ -5 -2))
+(test-values (values 2 1) (truncate/ 5 2))
+(test-values (values -2 -1) (truncate/ -5 2))
+(test-values (values -2 1) (truncate/ 5 -2))
+(test-values (values 2 -1) (truncate/ -5 -2))
+(test-values (values 2.0 -1.0) (truncate/ -5.0 -2))
+
+(test 1 (modulo 13 4))
+(test 1 (remainder 13 4))
+
+(test 3 (modulo -13 4))
+(test -1 (remainder -13 4))
+
+(test -3 (modulo 13 -4))
+(test 1 (remainder 13 -4))
+
+(test -1 (modulo -13 -4))
+(test -1 (remainder -13 -4))
+
+(test -1.0 (remainder -13 -4.0))
+
+(test 4 (gcd 32 -36))
+(test 0 (gcd))
+(test 288 (lcm 32 -36))
+(test 288.0 (lcm 32.0 -36))
+(test 1 (lcm))
+
+(test 3 (numerator (/ 6 4)))
+(test 2 (denominator (/ 6 4)))
+(test 2.0 (denominator (inexact (/ 6 4))))
+(test 11.0 (numerator 5.5))
+(test 2.0 (denominator 5.5))
+(test 5.0 (numerator 5.0))
+(test 1.0 (denominator 5.0))
+
+(test -5.0 (floor -4.3))
+(test -4.0 (ceiling -4.3))
+(test -4.0 (truncate -4.3))
+(test -4.0 (round -4.3))
+
+(test 3.0 (floor 3.5))
+(test 4.0 (ceiling 3.5))
+(test 3.0 (truncate 3.5))
+(test 4.0 (round 3.5))
+
+(test 4 (round 7/2))
+(test 7 (round 7))
+
+(test 1/3 (rationalize (exact .3) 1/10))
+(test #i1/3 (rationalize .3 1/10))
+
+(test 1.0 (inexact (exp 0))) ;; may return exact number
+(test 20.0855369231877 (exp 3))
+
+(test 0.0 (inexact (log 1))) ;; may return exact number
+(test 1.0 (log (exp 1)))
+(test 42.0 (log (exp 42)))
+(test 2.0 (log 100 10))
+(test 12.0 (log 4096 2))
+
+(test 0.0 (inexact (sin 0))) ;; may return exact number
+(test 1.0 (sin 1.5707963267949))
+(test 1.0 (inexact (cos 0))) ;; may return exact number
+(test -1.0 (cos 3.14159265358979))
+(test 0.0 (inexact (tan 0))) ;; may return exact number
+(test 1.5574077246549 (tan 1))
+
+(test 0.0 (asin 0))
+(test 1.5707963267949 (asin 1))
+(test 0.0 (acos 1))
+(test 3.14159265358979 (acos -1))
+
+(test 0.0 (atan 0.0 1.0))
+(test -0.0 (atan -0.0 1.0))
+(test 0.785398163397448 (atan 1.0 1.0))
+(test 1.5707963267949 (atan 1.0 0.0))
+(test 2.35619449019234 (atan 1.0 -1.0))
+(test 3.14159265358979 (atan 0.0 -1.0))
+(test -3.14159265358979 (atan -0.0 -1.0)) ;
+(test -2.35619449019234 (atan -1.0 -1.0))
+(test -1.5707963267949 (atan -1.0 0.0))
+(test -0.785398163397448 (atan -1.0 1.0))
+;; (test undefined (atan 0.0 0.0))
+
+(test 1764 (square 42))
+(test 4 (square 2))
+
+(test 3.0 (inexact (sqrt 9)))
+(test 1.4142135623731 (sqrt 2))
+(test 0.0+1.0i (inexact (sqrt -1)))
+
+(test '(2 0) (call-with-values (lambda () (exact-integer-sqrt 4)) list))
+(test '(2 1) (call-with-values (lambda () (exact-integer-sqrt 5)) list))
+
+(test 27 (expt 3 3))
+(test 1 (expt 0 0))
+(test 0 (expt 0 1))
+(test 1.0 (expt 0.0 0))
+(test 0.0 (expt 0 1.0))
+
+(test 1+2i (make-rectangular 1 2))
+
+(test 0.54030230586814+0.841470984807897i (make-polar 1 1))
+
+(test 1 (real-part 1+2i))
+
+(test 2 (imag-part 1+2i))
+
+(test 2.23606797749979 (magnitude 1+2i))
+
+(test 1.10714871779409 (angle 1+2i))
+
+(test 1.0 (inexact 1))
+(test #t (inexact? (inexact 1)))
+(test 1 (exact 1.0))
+(test #t (exact? (exact 1.0)))
+
+(test 100 (string->number "100"))
+(test 256 (string->number "100" 16))
+(test 100.0 (string->number "1e2"))
+
+(test-end)
+
+(test-begin "6.3 Booleans")
+
+(test #t #t)
+(test #f #f)
+(test #f '#f)
+
+(test #f (not #t))
+(test #f (not 3))
+(test #f (not (list 3)))
+(test #t (not #f))
+(test #f (not '()))
+(test #f (not (list)))
+(test #f (not 'nil))
+
+(test #t (boolean? #f))
+(test #f (boolean? 0))
+(test #f (boolean? '()))
+
+(test #t (boolean=? #t #t))
+(test #t (boolean=? #f #f))
+(test #f (boolean=? #t #f))
+(test #t (boolean=? #f #f #f))
+(test #f (boolean=? #t #t #f))
+
+(test-end)
+
+(test-begin "6.4 Lists")
+
+(let* ((x (list 'a 'b 'c))
+       (y x))
+  (test '(a b c) (values y))
+  (test #t (list? y))
+  (set-cdr! x 4)
+  (test '(a . 4) (values x))
+  (test #t (eqv? x y))
+  (test #f (list? y))
+  (set-cdr! x x)
+  (test #f (list? x)))
+
+(test #t (pair? '(a . b)))
+(test #t (pair? '(a b c)))
+(test #f (pair? '()))
+(test #f (pair? '#(a b)))
+
+(test '(a) (cons 'a '()))
+(test '((a) b c d) (cons '(a) '(b c d)))
+(test '("a" b c) (cons "a" '(b c)))
+(test '(a . 3) (cons 'a 3))
+(test '((a b) . c) (cons '(a b) 'c))
+
+(test 'a (car '(a b c)))
+(test '(a) (car '((a) b c d)))
+(test 1 (car '(1 . 2)))
+
+(test '(b c d) (cdr '((a) b c d)))
+(test 2 (cdr '(1 . 2)))
+(define (g) '(constant-list))
+
+(test #t (list? '(a b c)))
+(test #t (list? '()))
+(test #f (list? '(a . b)))
+(test #f (let ((x (list 'a))) (set-cdr! x x) (list? x)))
+
+(test '(3 3) (make-list 2 3))
+
+(test '(a 7 c) (list 'a (+ 3 4) 'c))
+(test '() (list))
+
+(test 3 (length '(a b c)))
+(test 3 (length '(a (b) (c d e))))
+(test 0 (length '()))
+
+(test '(x y) (append '(x) '(y)))
+(test '(a b c d) (append '(a) '(b c d)))
+(test '(a (b) (c)) (append '(a (b)) '((c))))
+
+(test '(a b c . d) (append '(a b) '(c . d)))
+(test 'a (append '() 'a))
+
+(test '(c b a) (reverse '(a b c)))
+(test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f)))))
+
+(test '(d e) (list-tail '(a b c d e) 3))
+
+(test 'c (list-ref '(a b c d) 2))
+(test 'c (list-ref '(a b c d)
+          (exact (round 1.8))))
+
+(test '(0 ("Sue" "Sue") "Anna")
+    (let ((lst (list 0 '(2 2 2 2) "Anna")))
+      (list-set! lst 1 '("Sue" "Sue"))
+      lst))
+
+(test '(a b c) (memq 'a '(a b c)))
+(test '(b c) (memq 'b '(a b c)))
+(test #f (memq 'a '(b c d)))
+(test #f (memq (list 'a) '(b (a) c)))
+(test '((a) c) (member (list 'a) '(b (a) c)))
+(test '("b" "c") (member "B" '("a" "b" "c") string-ci=?))
+(test '(101 102) (memv 101 '(100 101 102)))
+
+(let ()
+  (define e '((a 1) (b 2) (c 3)))
+  (test '(a 1) (assq 'a e))
+  (test '(b 2) (assq 'b e))
+  (test #f (assq 'd e)))
+
+(test #f (assq (list 'a) '(((a)) ((b)) ((c)))))
+(test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c)))))
+(test '(2 4) (assoc 2.0 '((1 1) (2 4) (3 9)) =))
+(test '(5 7) (assv 5 '((2 3) (5 7) (11 13))))
+
+(test '(1 2 3) (list-copy '(1 2 3)))
+(test "foo" (list-copy "foo"))
+(test '() (list-copy '()))
+(test '(3 . 4) (list-copy '(3 . 4)))
+(test '(6 7 8 . 9) (list-copy '(6 7 8 . 9)))
+(let* ((l1 '((a b) (c d) e))
+       (l2 (list-copy l1)))
+  (test l2 '((a b) (c d) e))
+  (test #t (eq? (car l1) (car l2)))
+  (test #t (eq? (cadr l1) (cadr l2)))
+  (test #f (eq? (cdr l1) (cdr l2)))
+  (test #f (eq? (cddr l1) (cddr l2))))
+
+(test-end)
+
+(test-begin "6.5 Symbols")
+
+(test #t (symbol? 'foo))
+(test #t (symbol? (car '(a b))))
+(test #f (symbol? "bar"))
+(test #t (symbol? 'nil))
+(test #f (symbol? '()))
+(test #f (symbol? #f))
+
+(test #t (symbol=? 'a 'a))
+(test #f (symbol=? 'a 'A))
+(test #t (symbol=? 'a 'a 'a))
+(test #f (symbol=? 'a 'a 'A))
+
+(test "flying-fish"     
+(symbol->string 'flying-fish))
+(test "Martin" (symbol->string 'Martin))
+(test "Malvina" (symbol->string (string->symbol "Malvina")))
+
+(test 'mISSISSIppi (string->symbol "mISSISSIppi"))
+(test #t (eq? 'bitBlt (string->symbol "bitBlt")))
+(test #t (eq? 'LollyPop (string->symbol (symbol->string 'LollyPop))))
+(test #t (string=? "K. Harper, M.D."
+                   (symbol->string (string->symbol "K. Harper, M.D."))))
+
+(test-end)
+
+(test-begin "6.6 Characters")
+
+(test #t (char? #\a))
+(test #f (char? "a"))
+(test #f (char? 'a))
+(test #f (char? 0))
+
+(test #t (char=? #\a #\a #\a))
+(test #f (char=? #\a #\A))
+(test #t (char<? #\a #\b #\c))
+(test #f (char<? #\a #\a))
+(test #f (char<? #\b #\a))
+(test #f (char>? #\a #\b))
+(test #f (char>? #\a #\a))
+(test #t (char>? #\c #\b #\a))
+(test #t (char<=? #\a #\b #\b))
+(test #t (char<=? #\a #\a))
+(test #f (char<=? #\b #\a))
+(test #f (char>=? #\a #\b))
+(test #t (char>=? #\a #\a))
+(test #t (char>=? #\b #\b #\a))
+
+(test #t (char-ci=? #\a #\a))
+(test #t (char-ci=? #\a #\A #\a))
+(test #f (char-ci=? #\a #\b))
+(test #t (char-ci<? #\a #\B #\c))
+(test #f (char-ci<? #\A #\a))
+(test #f (char-ci<? #\b #\A))
+(test #f (char-ci>? #\A #\b))
+(test #f (char-ci>? #\a #\A))
+(test #t (char-ci>? #\c #\B #\a))
+(test #t (char-ci<=? #\a #\B #\b))
+(test #t (char-ci<=? #\A #\a))
+(test #f (char-ci<=? #\b #\A))
+(test #f (char-ci>=? #\A #\b))
+(test #t (char-ci>=? #\a #\A))
+(test #t (char-ci>=? #\b #\B #\a))
+
+(test #t (char-alphabetic? #\a))
+(test #f (char-alphabetic? #\space))
+(test #t (char-numeric? #\0))
+(test #f (char-numeric? #\.))
+(test #f (char-numeric? #\a))
+(test #t (char-whitespace? #\space))
+(test #t (char-whitespace? #\tab))
+(test #t (char-whitespace? #\newline))
+(test #f (char-whitespace? #\_))
+(test #f (char-whitespace? #\a))
+(test #t (char-upper-case? #\A))
+(test #f (char-upper-case? #\a))
+(test #f (char-upper-case? #\3))
+(test #t (char-lower-case? #\a))
+(test #f (char-lower-case? #\A))
+(test #f (char-lower-case? #\3))
+
+(test #t (char-alphabetic? #\Λ))
+(test #f (char-alphabetic? #\x0E50))
+(test #t (char-upper-case? #\Λ))
+(test #f (char-upper-case? #\λ))
+(test #f (char-lower-case? #\Λ))
+(test #t (char-lower-case? #\λ))
+(test #f (char-numeric? #\Λ))
+(test #t (char-numeric? #\x0E50))
+(test #t (char-whitespace? #\x1680))
+
+(test 0 (digit-value #\0))
+(test 3 (digit-value #\3))
+(test 9 (digit-value #\9))
+(test 4 (digit-value #\x0664))
+(test 0 (digit-value #\x0AE6))
+(test #f (digit-value #\.))
+(test #f (digit-value #\-))
+
+(test 97 (char->integer #\a))
+(test #\a (integer->char 97))
+
+(test #\A (char-upcase #\a))
+(test #\A (char-upcase #\A))
+(test #\a (char-downcase #\a))
+(test #\a (char-downcase #\A))
+(test #\a (char-foldcase #\a))
+(test #\a (char-foldcase #\A))
+
+(test #\Λ (char-upcase #\λ))
+(test #\Λ (char-upcase #\Λ))
+(test #\λ (char-downcase #\λ))
+(test #\λ (char-downcase #\Λ))
+(test #\λ (char-foldcase #\λ))
+(test #\λ (char-foldcase #\Λ))
+
+(test-end)
+
+(test-begin "6.7 Strings")
+
+(test #t (string? ""))
+(test #t (string? " "))
+(test #f (string? 'a))
+(test #f (string? #\a))
+
+(test 3 (string-length (make-string 3)))
+(test "---" (make-string 3 #\-))
+
+(test "" (string))
+(test "---" (string #\- #\- #\-))
+(test "kitten" (string #\k #\i #\t #\t #\e #\n))
+
+(test 0 (string-length ""))
+(test 1 (string-length "a"))
+(test 3 (string-length "abc"))
+
+(test #\a (string-ref "abc" 0))
+(test #\b (string-ref "abc" 1))
+(test #\c (string-ref "abc" 2))
+
+(test "a-c" (let ((str (string #\a #\b #\c))) (string-set! str 1 #\-) str))
+
+(test (string #\a #\x1F700 #\c)
+    (let ((s (string #\a #\b #\c)))
+      (string-set! s 1 #\x1F700)
+      s))
+
+(test #t (string=? "" ""))
+(test #t (string=? "abc" "abc" "abc"))
+(test #f (string=? "" "abc"))
+(test #f (string=? "abc" "aBc"))
+
+(test #f (string<? "" ""))
+(test #f (string<? "abc" "abc"))
+(test #t (string<? "abc" "abcd" "acd"))
+(test #f (string<? "abcd" "abc"))
+(test #t (string<? "abc" "bbc"))
+
+(test #f (string>? "" ""))
+(test #f (string>? "abc" "abc"))
+(test #f (string>? "abc" "abcd"))
+(test #t (string>? "acd" "abcd" "abc"))
+(test #f (string>? "abc" "bbc"))
+
+(test #t (string<=? "" ""))
+(test #t (string<=? "abc" "abc"))
+(test #t (string<=? "abc" "abcd" "abcd"))
+(test #f (string<=? "abcd" "abc"))
+(test #t (string<=? "abc" "bbc"))
+
+(test #t (string>=? "" ""))
+(test #t (string>=? "abc" "abc"))
+(test #f (string>=? "abc" "abcd"))
+(test #t (string>=? "abcd" "abcd" "abc"))
+(test #f (string>=? "abc" "bbc"))
+
+(test #t (string-ci=? "" ""))
+(test #t (string-ci=? "abc" "abc"))
+(test #f (string-ci=? "" "abc"))
+(test #t (string-ci=? "abc" "aBc"))
+(test #f (string-ci=? "abc" "aBcD"))
+
+(test #f (string-ci<? "abc" "aBc"))
+(test #t (string-ci<? "abc" "aBcD"))
+(test #f (string-ci<? "ABCd" "aBc"))
+
+(test #f (string-ci>? "abc" "aBc"))
+(test #f (string-ci>? "abc" "aBcD"))
+(test #t (string-ci>? "ABCd" "aBc"))
+
+(test #t (string-ci<=? "abc" "aBc"))
+(test #t (string-ci<=? "abc" "aBcD"))
+(test #f (string-ci<=? "ABCd" "aBc"))
+
+(test #t (string-ci>=? "abc" "aBc"))
+(test #f (string-ci>=? "abc" "aBcD"))
+(test #t (string-ci>=? "ABCd" "aBc"))
+
+(test #t (string-ci=? "ΑΒΓ" "αβγ" "αβγ"))
+(test #f (string-ci<? "ΑΒΓ" "αβγ"))
+(test #f (string-ci>? "ΑΒΓ" "αβγ"))
+(test #t (string-ci<=? "ΑΒΓ" "αβγ"))
+(test #t (string-ci>=? "ΑΒΓ" "αβγ"))
+
+;; latin
+(test "ABC" (string-upcase "abc"))
+(test "ABC" (string-upcase "ABC"))
+(test "abc" (string-downcase "abc"))
+(test "abc" (string-downcase "ABC"))
+(test "abc" (string-foldcase "abc"))
+(test "abc" (string-foldcase "ABC"))
+
+;; cyrillic
+(test "ΑΒΓ" (string-upcase "αβγ"))
+(test "ΑΒΓ" (string-upcase "ΑΒΓ"))
+(test "αβγ" (string-downcase "αβγ"))
+(test "αβγ" (string-downcase "ΑΒΓ"))
+(test "αβγ" (string-foldcase "αβγ"))
+(test "αβγ" (string-foldcase "ΑΒΓ"))
+
+;; special cases
+(test "SSA" (string-upcase "ßa"))
+(test "ßa" (string-downcase "ßa"))
+(test "ssa" (string-downcase "SSA"))
+(test "İ" (string-upcase "İ"))
+(test "i\x0307;" (string-downcase "İ"))
+(test "i\x0307;" (string-foldcase "İ"))
+(test "J̌" (string-upcase "ǰ"))
+
+;; context-sensitive (final sigma)
+(test "ΓΛΏΣΣΑ" (string-upcase "γλώσσα"))
+(test "γλώσσα" (string-downcase "ΓΛΏΣΣΑ"))
+(test "γλώσσα" (string-foldcase "ΓΛΏΣΣΑ"))
+(test "ΜΈΛΟΣ" (string-upcase "μέλος"))
+(test #t (and (member (string-downcase "ΜΈΛΟΣ") '("μέλος" "μέλοσ")) #t))
+(test "μέλοσ" (string-foldcase "ΜΈΛΟΣ"))
+(test #t (and (member (string-downcase "ΜΈΛΟΣ ΕΝΌΣ")
+                      '("μέλος ενός" "μέλοσ ενόσ"))
+              #t))
+
+(test "" (substring "" 0 0))
+(test "" (substring "a" 0 0))
+(test "" (substring "abc" 1 1))
+(test "ab" (substring "abc" 0 2))
+(test "bc" (substring "abc" 1 3))
+
+(test "" (string-append ""))
+(test "" (string-append "" ""))
+(test "abc" (string-append "" "abc"))
+(test "abc" (string-append "abc" ""))
+(test "abcde" (string-append "abc" "de"))
+(test "abcdef" (string-append "abc" "de" "f"))
+
+(test '() (string->list ""))
+(test '(#\a) (string->list "a"))
+(test '(#\a #\b #\c) (string->list "abc"))
+(test '(#\a #\b #\c) (string->list "abc" 0))
+(test '(#\b #\c) (string->list "abc" 1))
+(test '(#\b #\c) (string->list "abc" 1 3))
+
+(test "" (list->string '()))
+(test "abc" (list->string '(#\a #\b #\c)))
+
+(test "" (string-copy ""))
+(test "" (string-copy "" 0))
+(test "" (string-copy "" 0 0))
+(test "abc" (string-copy "abc"))
+(test "abc" (string-copy "abc" 0))
+(test "bc" (string-copy "abc" 1))
+(test "b" (string-copy "abc" 1 2))
+(test "bc" (string-copy "abc" 1 3))
+
+(test "-----"
+    (let ((str (make-string 5 #\x))) (string-fill! str #\-) str))
+(test "xx---"
+    (let ((str (make-string 5 #\x))) (string-fill! str #\- 2) str))
+(test "xx-xx"
+    (let ((str (make-string 5 #\x))) (string-fill! str #\- 2 3) str))
+
+(test "a12de"
+    (let ((str (string-copy "abcde"))) (string-copy! str 1 "12345" 0 2) str))
+(test "-----"
+    (let ((str (make-string 5 #\x))) (string-copy! str 0 "-----") str))
+(test "---xx"
+    (let ((str (make-string 5 #\x))) (string-copy! str 0 "-----" 2) str))
+(test "xx---"
+    (let ((str (make-string 5 #\x))) (string-copy! str 2 "-----" 0 3) str))
+(test "xx-xx"
+    (let ((str (make-string 5 #\x))) (string-copy! str 2 "-----" 2 3) str))
+
+;; same source and dest
+(test "aabde"
+    (let ((str (string-copy "abcde"))) (string-copy! str 1 str 0 2) str))
+(test "abcab"
+    (let ((str (string-copy "abcde"))) (string-copy! str 3 str 0 2) str))
+
+(test-end)
+
+(test-begin "6.8 Vectors")
+
+(test #t (vector? #()))
+(test #t (vector? #(1 2 3)))
+(test #t (vector? '#(1 2 3)))
+
+(test 0 (vector-length (make-vector 0)))
+(test 1000 (vector-length (make-vector 1000)))
+
+(test #(0 (2 2 2 2) "Anna") '#(0 (2 2 2 2) "Anna"))
+
+(test #(a b c) (vector 'a 'b 'c))
+
+(test 8 (vector-ref '#(1 1 2 3 5 8 13 21) 5))
+(test 13 (vector-ref '#(1 1 2 3 5 8 13 21)
+            (let ((i (round (* 2 (acos -1)))))
+              (if (inexact? i)
+                  (exact i)
+                  i))))
+
+(test #(0 ("Sue" "Sue") "Anna") (let ((vec (vector 0 '(2 2 2 2) "Anna")))
+  (vector-set! vec 1 '("Sue" "Sue"))
+  vec))
+
+(test '(dah dah didah) (vector->list '#(dah dah didah)))
+(test '(dah didah) (vector->list '#(dah dah didah) 1))
+(test '(dah) (vector->list '#(dah dah didah) 1 2))
+(test #(dididit dah) (list->vector '(dididit dah)))
+
+(test #() (string->vector ""))
+(test #(#\A #\B #\C) (string->vector "ABC"))
+(test #(#\B #\C) (string->vector "ABC" 1))
+(test #(#\B) (string->vector "ABC" 1 2))
+
+(test "" (vector->string #()))
+(test "123" (vector->string #(#\1 #\2 #\3)))
+(test "23" (vector->string #(#\1 #\2 #\3) 1))
+(test "2" (vector->string #(#\1 #\2 #\3) 1 2))
+
+(test #() (vector-copy #()))
+(test #(a b c) (vector-copy #(a b c)))
+(test #(b c) (vector-copy #(a b c) 1))
+(test #(b) (vector-copy #(a b c) 1 2))
+
+(test #() (vector-append #()))
+(test #() (vector-append #() #()))
+(test #(a b c) (vector-append #() #(a b c)))
+(test #(a b c) (vector-append #(a b c) #()))
+(test #(a b c d e) (vector-append #(a b c) #(d e)))
+(test #(a b c d e f) (vector-append #(a b c) #(d e) #(f)))
+
+(test #(1 2 smash smash 5)
+    (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'smash 2 4) vec))
+(test #(x x x x x)
+    (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x) vec))
+(test #(1 2 x x x)
+    (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x 2) vec))
+(test #(1 2 x 4 5)
+    (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x 2 3) vec))
+
+(test #(1 a b 4 5)
+    (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 1 #(a b c d e) 0 2) vec))
+(test #(a b c d e)
+    (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 0 #(a b c d e)) vec))
+(test #(c d e 4 5)
+    (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 0 #(a b c d e) 2) vec))
+(test #(1 2 a b c)
+    (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 2 #(a b c d e) 0 3) vec))
+(test #(1 2 c 4 5)
+    (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 2 #(a b c d e) 2 3) vec))
+
+;; same source and dest
+(test #(1 1 2 4 5)
+    (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 1 vec 0 2) vec))
+(test #(1 2 3 1 2)
+    (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 3 vec 0 2) vec))
+
+(test-end)
+
+(test-begin "6.9 Bytevectors")
+
+(test #t (bytevector? #u8()))
+(test #t (bytevector? #u8(0 1 2)))
+(test #f (bytevector? #()))
+(test #f (bytevector? #(0 1 2)))
+(test #f (bytevector? '()))
+(test #t (bytevector? (make-bytevector 0)))
+
+(test 0 (bytevector-length (make-bytevector 0)))
+(test 1024 (bytevector-length (make-bytevector 1024)))
+(test 1024 (bytevector-length (make-bytevector 1024 255)))
+
+(test 3 (bytevector-length (bytevector 0 1 2)))
+
+(test 0 (bytevector-u8-ref (bytevector 0 1 2) 0))
+(test 1 (bytevector-u8-ref (bytevector 0 1 2) 1))
+(test 2 (bytevector-u8-ref (bytevector 0 1 2) 2))
+
+(test #u8(0 255 2)
+    (let ((bv (bytevector 0 1 2))) (bytevector-u8-set! bv 1 255) bv))
+
+(test #u8() (bytevector-copy #u8()))
+(test #u8(0 1 2) (bytevector-copy #u8(0 1 2)))
+(test #u8(1 2) (bytevector-copy #u8(0 1 2) 1))
+(test #u8(1) (bytevector-copy #u8(0 1 2) 1 2))
+
+(test #u8(1 6 7 4 5)
+    (let ((bv (bytevector 1 2 3 4 5)))
+      (bytevector-copy! bv 1 #u8(6 7 8 9 10) 0 2)
+      bv))
+(test #u8(6 7 8 9 10)
+    (let ((bv (bytevector 1 2 3 4 5)))
+      (bytevector-copy! bv 0 #u8(6 7 8 9 10))
+      bv))
+(test #u8(8 9 10 4 5)
+    (let ((bv (bytevector 1 2 3 4 5)))
+      (bytevector-copy! bv 0 #u8(6 7 8 9 10) 2)
+      bv))
+(test #u8(1 2 6 7 8)
+    (let ((bv (bytevector 1 2 3 4 5)))
+      (bytevector-copy! bv 2 #u8(6 7 8 9 10) 0 3)
+      bv))
+(test #u8(1 2 8 4 5)
+    (let ((bv (bytevector 1 2 3 4 5)))
+      (bytevector-copy! bv 2 #u8(6 7 8 9 10) 2 3)
+      bv))
+
+;; same source and dest
+(test #u8(1 1 2 4 5)
+    (let ((bv (bytevector 1 2 3 4 5)))
+      (bytevector-copy! bv 1 bv 0 2)
+      bv))
+(test #u8(1 2 3 1 2)
+    (let ((bv (bytevector 1 2 3 4 5)))
+      (bytevector-copy! bv 3 bv 0 2)
+      bv))
+
+(test #u8() (bytevector-append #u8()))
+(test #u8() (bytevector-append #u8() #u8()))
+(test #u8(0 1 2) (bytevector-append #u8() #u8(0 1 2)))
+(test #u8(0 1 2) (bytevector-append #u8(0 1 2) #u8()))
+(test #u8(0 1 2 3 4) (bytevector-append #u8(0 1 2) #u8(3 4)))
+(test #u8(0 1 2 3 4 5) (bytevector-append #u8(0 1 2) #u8(3 4) #u8(5)))
+
+(test "ABC" (utf8->string #u8(#x41 #x42 #x43)))
+(test "ABC" (utf8->string #u8(0 #x41 #x42 #x43) 1))
+(test "ABC" (utf8->string #u8(0 #x41  #x42 #x43 0) 1 4))
+(test "λ" (utf8->string #u8(0 #xCE #xBB 0) 1 3))
+(test #u8(#x41 #x42 #x43) (string->utf8 "ABC"))
+(test #u8(#x42 #x43) (string->utf8 "ABC" 1))
+(test #u8(#x42) (string->utf8 "ABC" 1 2))
+(test #u8(#xCE #xBB) (string->utf8 "λ"))
+
+(test-end)
+
+(test-begin "6.10 Control Features")
+
+(test #t (procedure? car))
+(test #f (procedure? 'car))
+(test #t (procedure? (lambda (x) (* x x))))
+(test #f (procedure? '(lambda (x) (* x x))))
+(test #t (call-with-current-continuation procedure?))
+
+(test 7 (apply + (list 3 4)))
+
+(define compose
+  (lambda (f g)
+    (lambda args
+      (f (apply g args)))))
+(test '(30 0)
+    (call-with-values (lambda () ((compose exact-integer-sqrt *) 12 75))
+      list))
+
+(test '(b e h) (map cadr '((a b) (d e) (g h))))
+
+(test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5)))
+
+(test '(5 7 9) (map + '(1 2 3) '(4 5 6 7)))
+
+(test #t
+    (let ((res (let ((count 0))
+                 (map (lambda (ignored)
+                        (set! count (+ count 1))
+                        count)
+                      '(a b)))))
+      (or (equal? res '(1 2))
+          (equal? res '(2 1)))))
+
+(test '(10 200 3000 40 500 6000)
+    (let ((ls1 (list 10 100 1000))
+          (ls2 (list 1 2 3 4 5 6)))
+      (set-cdr! (cddr ls1) ls1)
+      (map * ls1 ls2)))
+
+(test "abdegh" (string-map char-foldcase "AbdEgH"))
+
+(test "IBM" (string-map
+ (lambda (c)
+   (integer->char (+ 1 (char->integer c))))
+ "HAL"))
+
+(test "StUdLyCaPs"
+    (string-map
+     (lambda (c k) (if (eqv? k #\u) (char-upcase c) (char-downcase c)))
+     "studlycaps xxx"
+     "ululululul"))
+
+(test #(b e h) (vector-map cadr '#((a b) (d e) (g h))))
+
+(test #(1 4 27 256 3125)
+    (vector-map (lambda (n) (expt n n))
+                '#(1 2 3 4 5)))
+
+(test #(5 7 9) (vector-map + '#(1 2 3) '#(4 5 6 7)))
+
+(test #t
+    (let ((res (let ((count 0))
+                 (vector-map
+                  (lambda (ignored)
+                    (set! count (+ count 1))
+                    count)
+                  '#(a b)))))
+      (or (equal? res #(1 2))
+          (equal? res #(2 1)))))
+
+(test #(0 1 4 9 16)
+    (let ((v (make-vector 5)))
+      (for-each (lambda (i)
+                  (vector-set! v i (* i i)))
+                '(0 1 2 3 4))
+      v))
+
+(test 9750
+    (let ((ls1 (list 10 100 1000))
+          (ls2 (list 1 2 3 4 5 6))
+          (count 0))
+      (set-cdr! (cddr ls1) ls1)
+      (for-each (lambda (x y) (set! count (+ count (* x y)))) ls2 ls1)
+      count))
+
+(test '(101 100 99 98 97)
+    (let ((v '()))
+      (string-for-each
+       (lambda (c) (set! v (cons (char->integer c) v)))
+       "abcde")
+      v))
+
+(test '(0 1 4 9 16) (let ((v (make-list 5)))
+  (vector-for-each
+   (lambda (i) (list-set! v i (* i i)))
+   '#(0 1 2 3 4))
+  v))
+
+(test -3 (call-with-current-continuation
+  (lambda (exit)
+    (for-each (lambda (x)
+                (if (negative? x)
+                    (exit x)))
+              '(54 0 37 -3 245 19))
+    #t)))
+(define list-length
+  (lambda (obj)
+    (call-with-current-continuation
+      (lambda (return)
+        (letrec ((r
+                  (lambda (obj)
+                    (cond ((null? obj) 0)
+                          ((pair? obj)
+                           (+ (r (cdr obj)) 1))
+                          (else (return #f))))))
+          (r obj))))))
+
+(test 4 (list-length '(1 2 3 4)))
+
+(test #f (list-length '(a b . c)))
+
+(test 5
+    (call-with-values (lambda () (values 4 5))
+      (lambda (a b) b)))
+
+(test -1 (call-with-values * -))
+
+(test '(connect talk1 disconnect
+        connect talk2 disconnect)
+    (let ((path '())
+          (c #f))
+      (let ((add (lambda (s)
+                   (set! path (cons s path)))))
+        (dynamic-wind
+          (lambda () (add 'connect))
+          (lambda ()
+            (add (call-with-current-continuation
+                  (lambda (c0)
+                    (set! c c0)
+                    'talk1))))
+          (lambda () (add 'disconnect)))
+        (if (< (length path) 4)
+            (c 'talk2)
+            (reverse path)))))
+
+(test-end)
+
+(test-begin "6.11 Exceptions")
+
+(test 65
+    (with-exception-handler
+     (lambda (con) 42)
+     (lambda ()
+       (+ (raise-continuable "should be a number")
+          23))))
+
+(test #t
+    (error-object? (guard (exn (else exn)) (error "BOOM!" 1 2 3))))
+(test "BOOM!"
+    (error-object-message (guard (exn (else exn)) (error "BOOM!" 1 2 3))))
+(test '(1 2 3)
+    (error-object-irritants (guard (exn (else exn)) (error "BOOM!" 1 2 3))))
+
+(test #f
+    (file-error? (guard (exn (else exn)) (error "BOOM!"))))
+(test #t
+    (file-error? (guard (exn (else exn)) (open-input-file " no such file "))))
+
+(test #f
+    (read-error? (guard (exn (else exn)) (error "BOOM!"))))
+(test #t
+    (read-error? (guard (exn (else exn)) (read (open-input-string ")")))))
+
+(define something-went-wrong #f)
+(define (test-exception-handler-1 v)
+  (call-with-current-continuation
+   (lambda (k)
+     (with-exception-handler
+      (lambda (x)
+        (set! something-went-wrong (list "condition: " x))
+        (k 'exception))
+      (lambda ()
+        (+ 1 (if (> v 0) (+ v 100) (raise 'an-error))))))))
+(test 106 (test-exception-handler-1 5))
+(test #f something-went-wrong)
+(test 'exception (test-exception-handler-1 -1))
+(test '("condition: " an-error) something-went-wrong)
+
+(set! something-went-wrong #f)
+(define (test-exception-handler-2 v)
+  (guard (ex (else 'caught-another-exception))
+    (with-exception-handler
+     (lambda (x)
+       (set! something-went-wrong #t)
+       (list "exception:" x))
+     (lambda ()
+       (+ 1 (if (> v 0) (+ v 100) (raise 'an-error)))))))
+(test 106 (test-exception-handler-2 5))
+(test #f something-went-wrong)
+(test 'caught-another-exception (test-exception-handler-2 -1))
+(test #t something-went-wrong)
+
+;; Based on an example from R6RS-lib section 7.1 Exceptions.
+;; R7RS section 6.11 Exceptions has a simplified version.
+(let* ((out (open-output-string))
+       (value (with-exception-handler
+               (lambda (con)
+                 (cond
+                  ((not (list? con))
+                   (raise con))
+                  ((list? con)
+                   (display (car con) out))
+                  (else
+                   (display "a warning has been issued" out)))
+                 42)
+               (lambda ()
+                 (+ (raise-continuable
+                     (list "should be a number"))
+                    23)))))
+  (test "should be a number" (get-output-string out))
+  (test 65 value))
+
+;; From SRFI-34 "Examples" section - #3
+(define (test-exception-handler-3 v out)
+  (guard (condition
+          (else
+           (display "condition: " out)
+           (write condition out)
+           (display #\! out)
+           'exception))
+         (+ 1 (if (= v 0) (raise 'an-error) (/ 10 v)))))
+(let* ((out (open-output-string))
+       (value (test-exception-handler-3 0 out)))
+  (test 'exception value)
+  (test "condition: an-error!" (get-output-string out)))
+
+(define (test-exception-handler-4 v out)
+  (call-with-current-continuation
+   (lambda (k)
+     (with-exception-handler
+      (lambda (x)
+        (display "reraised " out)
+        (write x out) (display #\! out)
+        (k 'zero))
+      (lambda ()
+        (guard (condition
+                ((positive? condition)
+                 'positive)
+                ((negative? condition)
+                 'negative))
+          (raise v)))))))
+
+;; From SRFI-34 "Examples" section - #5
+(let* ((out (open-output-string))
+       (value (test-exception-handler-4 1 out)))
+  (test "" (get-output-string out))
+  (test 'positive value))
+;; From SRFI-34 "Examples" section - #6
+(let* ((out (open-output-string))
+       (value (test-exception-handler-4 -1 out)))
+  (test "" (get-output-string out))
+  (test 'negative value))
+;; From SRFI-34 "Examples" section - #7
+(let* ((out (open-output-string))
+       (value (test-exception-handler-4 0 out)))
+  (test "reraised 0!" (get-output-string out))
+  (test 'zero value))
+
+;; From SRFI-34 "Examples" section - #8
+(test 42
+    (guard (condition
+            ((assq 'a condition) => cdr)
+            ((assq 'b condition)))
+      (raise (list (cons 'a 42)))))
+
+;; From SRFI-34 "Examples" section - #9
+(test '(b . 23)
+    (guard (condition
+            ((assq 'a condition) => cdr)
+            ((assq 'b condition)))
+      (raise (list (cons 'b 23)))))
+
+(test 'caught-d
+    (guard (condition
+            ((assq 'c condition) 'caught-c)
+            ((assq 'd condition) 'caught-d))
+      (list
+       (sqrt 8)
+       (guard (condition
+               ((assq 'a condition) => cdr)
+               ((assq 'b condition)))
+         (raise (list (cons 'd 24)))))))
+
+(test-end)
+
+(test-begin "6.12 Environments and evaluation")
+
+;; (test 21 (eval '(* 7 3) (scheme-report-environment 5)))
+
+(test 20
+    (let ((f (eval '(lambda (f x) (f x x)) (null-environment 5))))
+      (f + 10)))
+
+(test 1024 (eval '(expt 2 10) (environment '(scheme base))))
+;; (sin 0) may return exact number
+(test 0.0 (inexact (eval '(sin 0) (environment '(scheme inexact)))))
+;; ditto
+(test 1024.0 (eval '(+ (expt 2 10) (inexact (sin 0)))
+                   (environment '(scheme base) '(scheme inexact))))
+
+(test-end)
+
+(test-begin "6.13 Input and output")
+
+(test #t (port? (current-input-port)))
+(test #t (input-port? (current-input-port)))
+(test #t (output-port? (current-output-port)))
+(test #t (output-port? (current-error-port)))
+(test #t (input-port? (open-input-string "abc")))
+(test #t (output-port? (open-output-string)))
+
+(test #t (textual-port? (open-input-string "abc")))
+(test #t (textual-port? (open-output-string)))
+(test #t (binary-port? (open-input-bytevector #u8(0 1 2))))
+(test #t (binary-port? (open-output-bytevector)))
+
+(test #t (input-port-open? (open-input-string "abc")))
+(test #t (output-port-open? (open-output-string)))
+
+(test #f
+    (let ((in (open-input-string "abc")))
+      (close-input-port in)
+      (input-port-open? in)))
+
+(test #f
+    (let ((out (open-output-string)))
+      (close-output-port out)
+      (output-port-open? out)))
+
+(test #f
+    (let ((out (open-output-string)))
+      (close-port out)
+      (output-port-open? out)))
+
+(test 'error
+    (let ((in (open-input-string "abc")))
+      (close-input-port in)
+      (guard (exn (else 'error)) (read-char in))))
+
+(test 'error
+    (let ((out (open-output-string)))
+      (close-output-port out)
+      (guard (exn (else 'error)) (write-char #\c out))))
+
+(test #t (eof-object? (eof-object)))
+(test #t (eof-object? (read (open-input-string ""))))
+(test #t (char-ready? (open-input-string "42")))
+(test 42 (read (open-input-string " 42 ")))
+
+(test #t (eof-object? (read-char (open-input-string ""))))
+(test #\a (read-char (open-input-string "abc")))
+
+(test #t (eof-object? (read-line (open-input-string ""))))
+(test "abc" (read-line (open-input-string "abc")))
+(test "abc" (read-line (open-input-string "abc\ndef\n")))
+
+(test #t (eof-object? (read-string 3 (open-input-string ""))))
+(test "abc" (read-string 3 (open-input-string "abcd")))
+(test "abc" (read-string 3 (open-input-string "abc\ndef\n")))
+
+(let ((in (open-input-string (string #\x10F700 #\x10F701 #\x10F702))))
+  (let* ((c1 (read-char in))
+         (c2 (read-char in))
+         (c3 (read-char in)))
+    (test #\x10F700 c1)
+    (test #\x10F701 c2)
+    (test #\x10F702 c3)))
+
+(test (string #\x10F700)
+    (let ((out (open-output-string)))
+      (write-char #\x10F700 out)
+      (get-output-string out)))
+
+(test "abc"
+    (let ((out (open-output-string)))
+      (write 'abc out)
+      (get-output-string out)))
+
+(test "abc def"
+    (let ((out (open-output-string)))
+      (display "abc def" out)
+      (get-output-string out)))
+
+(test "abc"
+    (let ((out (open-output-string)))
+      (display #\a out)
+      (display "b" out)
+      (display #\c out)
+      (get-output-string out)))
+
+(test #t
+      (let* ((out (open-output-string))
+             (r (begin (newline out) (get-output-string out))))
+        (or (equal? r "\n") (equal? r "\r\n"))))
+
+(test "abc def"
+    (let ((out (open-output-string)))
+      (write-string "abc def" out)
+      (get-output-string out)))
+
+(test "def"
+    (let ((out (open-output-string)))
+      (write-string "abc def" out 4)
+      (get-output-string out)))
+
+(test "c d"
+    (let ((out (open-output-string)))
+      (write-string "abc def" out 2 5)
+      (get-output-string out)))
+
+(test ""
+  (let ((out (open-output-string)))
+    (flush-output-port out)
+    (get-output-string out)))
+
+(test #t (eof-object? (read-u8 (open-input-bytevector #u8()))))
+(test 1 (read-u8 (open-input-bytevector #u8(1 2 3))))
+
+(test #t (eof-object? (read-bytevector 3 (open-input-bytevector #u8()))))
+(test #t (u8-ready? (open-input-bytevector #u8(1))))
+(test #u8(1) (read-bytevector 3 (open-input-bytevector #u8(1))))
+(test #u8(1 2) (read-bytevector 3 (open-input-bytevector #u8(1 2))))
+(test #u8(1 2 3) (read-bytevector 3 (open-input-bytevector #u8(1 2 3))))
+(test #u8(1 2 3) (read-bytevector 3 (open-input-bytevector #u8(1 2 3 4))))
+
+(test #t
+    (let ((bv (bytevector 1 2 3 4 5)))
+      (eof-object? (read-bytevector! bv (open-input-bytevector #u8())))))
+
+(test #u8(6 7 8 9 10)
+  (let ((bv (bytevector 1 2 3 4 5)))
+    (read-bytevector! bv (open-input-bytevector #u8(6 7 8 9 10)) 0 5)
+    bv))
+
+(test #u8(6 7 8 4 5)
+  (let ((bv (bytevector 1 2 3 4 5)))
+    (read-bytevector! bv (open-input-bytevector #u8(6 7 8 9 10)) 0 3)
+    bv))
+
+(test #u8(1 2 3 6 5)
+  (let ((bv (bytevector 1 2 3 4 5)))
+    (read-bytevector! bv (open-input-bytevector #u8(6 7 8 9 10)) 3 4)
+    bv))
+
+(test #u8(1 2 3)
+  (let ((out (open-output-bytevector)))
+    (write-u8 1 out)
+    (write-u8 2 out)
+    (write-u8 3 out)
+    (get-output-bytevector out)))
+
+(test #u8(1 2 3 4 5)
+  (let ((out (open-output-bytevector)))
+    (write-bytevector #u8(1 2 3 4 5) out)
+    (get-output-bytevector out)))
+
+(test #u8(3 4 5)
+  (let ((out (open-output-bytevector)))
+    (write-bytevector #u8(1 2 3 4 5) out 2)
+    (get-output-bytevector out)))
+
+(test #u8(3 4)
+  (let ((out (open-output-bytevector)))
+    (write-bytevector #u8(1 2 3 4 5) out 2 4)
+    (get-output-bytevector out)))
+
+(test #u8()
+  (let ((out (open-output-bytevector)))
+    (flush-output-port out)
+    (get-output-bytevector out)))
+
+(test #t
+    (and (member
+          (let ((out (open-output-string))
+                (x (list 1)))
+            (set-cdr! x x)
+            (write x out)
+            (get-output-string out))
+          ;; labels not guaranteed to be 0 indexed, spacing may differ
+          '("#0=(1 . #0#)" "#1=(1 . #1#)"))
+         #t))
+
+(test "((1 2 3) (1 2 3))"
+    (let ((out (open-output-string))
+          (x (list 1 2 3)))
+      (write (list x x) out)
+      (get-output-string out)))
+
+(test "((1 2 3) (1 2 3))"
+    (let ((out (open-output-string))
+          (x (list 1 2 3)))
+      (write-simple (list x x) out)
+      (get-output-string out)))
+
+(test #t
+    (and (member (let ((out (open-output-string))
+                       (x (list 1 2 3)))
+                   (write-shared (list x x) out)
+                   (get-output-string out))
+                 '("(#0=(1 2 3) #0#)" "(#1=(1 2 3) #1#)"))
+         #t))
+
+(test-begin "Read syntax")
+
+;; check reading boolean followed by eof
+(test #t (read (open-input-string "#t")))
+(test #t (read (open-input-string "#true")))
+(test #f (read (open-input-string "#f")))
+(test #f (read (open-input-string "#false")))
+(define (read2 port)
+  (let* ((o1 (read port)) (o2 (read port)))
+    (cons o1 o2)))
+;; check reading boolean followed by delimiter
+(test '(#t . (5)) (read2 (open-input-string "#t(5)")))
+(test '(#t . 6) (read2 (open-input-string "#true 6 ")))
+(test '(#f . 7) (read2 (open-input-string "#f 7")))
+(test '(#f . "8") (read2 (open-input-string "#false\"8\"")))
+
+(test '() (read (open-input-string "()")))
+(test '(1 2) (read (open-input-string "(1 2)")))
+(test '(1 . 2) (read (open-input-string "(1 . 2)")))
+(test '(1 2) (read (open-input-string "(1 . (2))")))
+(test '(1 2 3 4 5) (read (open-input-string "(1 . (2 3 4 . (5)))")))
+(test '1 (cadr (read (open-input-string "#0=(1 . #0#)"))))
+(test '(1 2 3) (cadr (read (open-input-string "(#0=(1 2 3) #0#)"))))
+
+(test '(quote (1 2)) (read (open-input-string "'(1 2)")))
+(test '(quote (1 (unquote 2))) (read (open-input-string "'(1 ,2)")))
+(test '(quote (1 (unquote-splicing 2))) (read (open-input-string "'(1 ,@2)")))
+(test '(quasiquote (1 (unquote 2))) (read (open-input-string "`(1 ,2)")))
+
+(test #() (read (open-input-string "#()")))
+(test #(a b) (read (open-input-string "#(a b)")))
+
+(test #u8() (read (open-input-string "#u8()")))
+(test #u8(0 1) (read (open-input-string "#u8(0 1)")))
+
+(test 'abc (read (open-input-string "abc")))
+(test 'abc (read (open-input-string "abc def")))
+(test 'ABC (read (open-input-string "ABC")))
+(test 'Hello (read (open-input-string "|H\\x65;llo|")))
+
+(test 'abc (read (open-input-string "#!fold-case ABC")))
+(test 'ABC (read (open-input-string "#!fold-case #!no-fold-case ABC")))
+
+(test 'def (read (open-input-string "#; abc def")))
+(test 'def (read (open-input-string "; abc \ndef")))
+(test 'def (read (open-input-string "#| abc |# def")))
+(test 'ghi (read (open-input-string "#| abc #| def |# |# ghi")))
+(test 'ghi (read (open-input-string "#; ; abc\n def ghi")))
+(test '(abs -16) (read (open-input-string "(#;sqrt abs -16)")))
+(test '(a d) (read (open-input-string "(a #; #;b c d)")))
+(test '(a e) (read (open-input-string "(a #;(b #;c d) e)")))
+(test '(a . c) (read (open-input-string "(a . #;b c)")))
+(test '(a . b) (read (open-input-string "(a . b #;c)")))
+
+(define (test-read-error str)
+  (test-assert
+      (guard (exn (else #t))
+        (read (open-input-string str))
+        #f)))
+
+(test-read-error "(#;a . b)")
+(test-read-error "(a . #;b)")
+(test-read-error "(a #;. b)")
+(test-read-error "(#;x #;y . z)")
+(test-read-error "(#; #;x #;y . z)")
+(test-read-error "(#; #;x . z)")
+
+(test #\a (read (open-input-string "#\\a")))
+(test #\space (read (open-input-string "#\\space")))
+(test 0 (char->integer (read (open-input-string "#\\null"))))
+(test 7 (char->integer (read (open-input-string "#\\alarm"))))
+(test 8 (char->integer (read (open-input-string "#\\backspace"))))
+(test 9 (char->integer (read (open-input-string "#\\tab"))))
+(test 10 (char->integer (read (open-input-string "#\\newline"))))
+(test 13 (char->integer (read (open-input-string "#\\return"))))
+(test #x7F (char->integer (read (open-input-string "#\\delete"))))
+(test #x1B (char->integer (read (open-input-string "#\\escape"))))
+(test #x03BB (char->integer (read (open-input-string "#\\λ"))))
+(test #x03BB (char->integer (read (open-input-string "#\\x03BB"))))
+
+(test "abc" (read (open-input-string "\"abc\"")))
+(test "abc" (read (open-input-string "\"abc\" \"def\"")))
+(test "ABC" (read (open-input-string "\"ABC\"")))
+(test "Hello" (read (open-input-string "\"H\\x65;llo\"")))
+(test 7 (char->integer (string-ref (read (open-input-string "\"\\a\"")) 0)))
+(test 8 (char->integer (string-ref (read (open-input-string "\"\\b\"")) 0)))
+(test 9 (char->integer (string-ref (read (open-input-string "\"\\t\"")) 0)))
+(test 10 (char->integer (string-ref (read (open-input-string "\"\\n\"")) 0)))
+(test 13 (char->integer (string-ref (read (open-input-string "\"\\r\"")) 0)))
+(test #x22 (char->integer (string-ref (read (open-input-string "\"\\\"\"")) 0)))
+(test #x7C (char->integer (string-ref (read (open-input-string "\"\\|\"")) 0)))
+(test "line 1\nline 2\n" (read (open-input-string "\"line 1\nline 2\n\"")))
+(test "line 1continued\n" (read (open-input-string "\"line 1\\\ncontinued\n\"")))
+(test "line 1continued\n" (read (open-input-string "\"line 1\\ \ncontinued\n\"")))
+(test "line 1continued\n" (read (open-input-string "\"line 1\\\n continued\n\"")))
+(test "line 1continued\n" (read (open-input-string "\"line 1\\ \t \n \t continued\n\"")))
+(test "line 1\n\nline 3\n" (read (open-input-string "\"line 1\\ \t \n \t \n\nline 3\n\"")))
+(test #x03BB (char->integer (string-ref (read (open-input-string "\"\\x03BB;\"")) 0)))
+
+(test-end)
+
+(test-begin "Numeric syntax")
+
+;; Numeric syntax adapted from Peter Bex's tests.
+;;
+;; These are updated to R7RS, using string ports instead of
+;; string->number, and "error" tests removed because implementations
+;; are free to provide their own numeric extensions.  Currently all
+;; tests are run by default - need to cond-expand and test for
+;; infinities and -0.0.
+
+(define-syntax test-numeric-syntax
+  (syntax-rules ()
+    ((test-numeric-syntax str expect strs ...)
+     (let* ((z (read (open-input-string str)))
+            (out (open-output-string))
+            (z-str (begin (write z out) (get-output-string out))))
+       (test expect (values z))
+       (test #t (and (member z-str '(str strs ...)) #t))))))
+
+;; Each test is of the form:
+;;
+;;   (test-numeric-syntax input-str expected-value expected-write-values ...)
+;;
+;; where the input should be eqv? to the expected-value, and the
+;; written output the same as any of the expected-write-values.  The
+;; form
+;;
+;;   (test-numeric-syntax input-str expected-value)
+;;
+;; is a shorthand for
+;;
+;;   (test-numeric-syntax input-str expected-value (input-str))
+
+;; Simple
+(test-numeric-syntax "1" 1)
+(test-numeric-syntax "+1" 1 "1")
+(test-numeric-syntax "-1" -1)
+(test-numeric-syntax "#i1" 1.0 "1.0" "1.")
+(test-numeric-syntax "#I1" 1.0 "1.0" "1.")
+(test-numeric-syntax "#i-1" -1.0 "-1.0" "-1.")
+;; Decimal
+(test-numeric-syntax "1.0" 1.0 "1.0" "1.")
+(test-numeric-syntax "1." 1.0 "1.0" "1.")
+(test-numeric-syntax ".1" 0.1 "0.1" "100.0e-3")
+(test-numeric-syntax "-.1" -0.1 "-0.1" "-100.0e-3")
+;; Some Schemes don't allow negative zero. This is okay with the standard
+(test-numeric-syntax "-.0" -0.0 "-0." "-0.0" "0.0" "0." ".0")
+(test-numeric-syntax "-0." -0.0 "-.0" "-0.0" "0.0" "0." ".0")
+(test-numeric-syntax "#i1.0" 1.0 "1.0" "1.")
+(test-numeric-syntax "#e1.0" 1 "1")
+(test-numeric-syntax "#e-.0" 0 "0")
+(test-numeric-syntax "#e-0." 0 "0")
+;; Decimal notation with suffix
+(test-numeric-syntax "1e2" 100.0 "100.0" "100.")
+(test-numeric-syntax "1E2" 100.0 "100.0" "100.")
+(test-numeric-syntax "1s2" 100.0 "100.0" "100.")
+(test-numeric-syntax "1S2" 100.0 "100.0" "100.")
+(test-numeric-syntax "1f2" 100.0 "100.0" "100.")
+(test-numeric-syntax "1F2" 100.0 "100.0" "100.")
+(test-numeric-syntax "1d2" 100.0 "100.0" "100.")
+(test-numeric-syntax "1D2" 100.0 "100.0" "100.")
+(test-numeric-syntax "1l2" 100.0 "100.0" "100.")
+(test-numeric-syntax "1L2" 100.0 "100.0" "100.")
+;; NaN, Inf
+(test-numeric-syntax "+nan.0" +nan.0 "+nan.0" "+NaN.0")
+(test-numeric-syntax "+NAN.0" +nan.0 "+nan.0" "+NaN.0")
+(test-numeric-syntax "+inf.0" +inf.0 "+inf.0" "+Inf.0")
+(test-numeric-syntax "+InF.0" +inf.0 "+inf.0" "+Inf.0")
+(test-numeric-syntax "-inf.0" -inf.0 "-inf.0" "-Inf.0")
+(test-numeric-syntax "-iNF.0" -inf.0 "-inf.0" "-Inf.0")
+(test-numeric-syntax "#i+nan.0" +nan.0 "+nan.0" "+NaN.0")
+(test-numeric-syntax "#i+inf.0" +inf.0 "+inf.0" "+Inf.0")
+(test-numeric-syntax "#i-inf.0" -inf.0 "-inf.0" "-Inf.0")
+;; Exact ratios
+(test-numeric-syntax "1/2" (/ 1 2))
+(test-numeric-syntax "#e1/2" (/ 1 2) "1/2")
+(test-numeric-syntax "10/2" 5 "5")
+(test-numeric-syntax "-1/2" (- (/ 1 2)))
+(test-numeric-syntax "0/10" 0 "0")
+(test-numeric-syntax "#e0/10" 0 "0")
+(test-numeric-syntax "#i3/2" (/ 3.0 2.0) "1.5")
+;; Exact complex
+(test-numeric-syntax "1+2i" (make-rectangular 1 2))
+(test-numeric-syntax "1+2I" (make-rectangular 1 2) "1+2i")
+(test-numeric-syntax "1-2i" (make-rectangular 1 -2))
+(test-numeric-syntax "-1+2i" (make-rectangular -1 2))
+(test-numeric-syntax "-1-2i" (make-rectangular -1 -2))
+(test-numeric-syntax "+i" (make-rectangular 0 1) "+i" "+1i" "0+i" "0+1i")
+(test-numeric-syntax "0+i" (make-rectangular 0 1) "+i" "+1i" "0+i" "0+1i")
+(test-numeric-syntax "0+1i" (make-rectangular 0 1) "+i" "+1i" "0+i" "0+1i")
+(test-numeric-syntax "-i" (make-rectangular 0 -1) "-i" "-1i" "0-i" "0-1i")
+(test-numeric-syntax "0-i" (make-rectangular 0 -1) "-i" "-1i" "0-i" "0-1i")
+(test-numeric-syntax "0-1i" (make-rectangular 0 -1) "-i" "-1i" "0-i" "0-1i")
+(test-numeric-syntax "+2i" (make-rectangular 0 2) "2i" "+2i" "0+2i")
+(test-numeric-syntax "-2i" (make-rectangular 0 -2) "-2i" "0-2i")
+;; Decimal-notation complex numbers (rectangular notation)
+(test-numeric-syntax "1.0+2i" (make-rectangular 1.0 2) "1.0+2.0i" "1.0+2i" "1.+2i" "1.+2.i")
+(test-numeric-syntax "1+2.0i" (make-rectangular 1 2.0) "1.0+2.0i" "1+2.0i" "1.+2.i" "1+2.i")
+(test-numeric-syntax "1e2+1.0i" (make-rectangular 100.0 1.0) "100.0+1.0i" "100.+1.i")
+(test-numeric-syntax "1s2+1.0i" (make-rectangular 100.0 1.0) "100.0+1.0i" "100.+1.i")
+(test-numeric-syntax "1.0+1e2i" (make-rectangular 1.0 100.0) "1.0+100.0i" "1.+100.i")
+(test-numeric-syntax "1.0+1s2i" (make-rectangular 1.0 100.0) "1.0+100.0i" "1.+100.i")
+;; Fractional complex numbers (rectangular notation)
+(test-numeric-syntax "1/2+3/4i" (make-rectangular (/ 1 2) (/ 3 4)))
+;; Mixed fractional/decimal notation complex numbers (rectangular notation)
+(test-numeric-syntax "0.5+3/4i" (make-rectangular 0.5 (/ 3 4))
+  "0.5+0.75i" ".5+.75i" "0.5+3/4i" ".5+3/4i" "500.0e-3+750.0e-3i")
+;; Complex NaN, Inf (rectangular notation)
+;;(test-numeric-syntax "+nan.0+nan.0i" (make-rectangular the-nan the-nan) "+NaN.0+NaN.0i") 
+(test-numeric-syntax "+inf.0+inf.0i" (make-rectangular +inf.0 +inf.0) "+Inf.0+Inf.0i")
+(test-numeric-syntax "-inf.0+inf.0i" (make-rectangular -inf.0 +inf.0) "-Inf.0+Inf.0i")
+(test-numeric-syntax "-inf.0-inf.0i" (make-rectangular -inf.0 -inf.0) "-Inf.0-Inf.0i")
+(test-numeric-syntax "+inf.0-inf.0i" (make-rectangular +inf.0 -inf.0) "+Inf.0-Inf.0i")
+;; Complex numbers (polar notation)
+;; Need to account for imprecision in write output.
+;;(test-numeric-syntax "1@2" -0.416146836547142+0.909297426825682i "-0.416146836547142+0.909297426825682i")
+;; Base prefixes
+(test-numeric-syntax "#x11" 17 "17")
+(test-numeric-syntax "#X11" 17 "17")
+(test-numeric-syntax "#d11" 11 "11")
+(test-numeric-syntax "#D11" 11 "11")
+(test-numeric-syntax "#o11" 9 "9")
+(test-numeric-syntax "#O11" 9 "9")
+(test-numeric-syntax "#b11" 3 "3")
+(test-numeric-syntax "#B11" 3 "3")
+(test-numeric-syntax "#o7" 7 "7")
+(test-numeric-syntax "#xa" 10 "10")
+(test-numeric-syntax "#xA" 10 "10")
+(test-numeric-syntax "#xf" 15 "15")
+(test-numeric-syntax "#x-10" -16 "-16")
+(test-numeric-syntax "#d-10" -10 "-10")
+(test-numeric-syntax "#o-10" -8 "-8")
+(test-numeric-syntax "#b-10" -2 "-2")
+;; Combination of prefixes
+(test-numeric-syntax "#e#x10" 16 "16")
+(test-numeric-syntax "#i#x10" 16.0 "16.0" "16.")
+;; (Attempted) decimal notation with base prefixes
+(test-numeric-syntax "#d1." 1.0 "1.0" "1.")
+(test-numeric-syntax "#d.1" 0.1 "0.1" ".1" "100.0e-3")
+(test-numeric-syntax "#x1e2" 482 "482")
+(test-numeric-syntax "#d1e2" 100.0 "100.0" "100.")
+;; Fractions with prefixes
+(test-numeric-syntax "#x10/2" 8 "8")
+(test-numeric-syntax "#x11/2" (/ 17 2) "17/2")
+(test-numeric-syntax "#d11/2" (/ 11 2) "11/2")
+(test-numeric-syntax "#o11/2" (/ 9 2) "9/2")
+(test-numeric-syntax "#b11/10" (/ 3 2) "3/2")
+;; Complex numbers with prefixes
+;;(test-numeric-syntax "#x10+11i" (make-rectangular 16 17) "16+17i")
+(test-numeric-syntax "#d1.0+1.0i" (make-rectangular 1.0 1.0) "1.0+1.0i" "1.+1.i")
+(test-numeric-syntax "#d10+11i" (make-rectangular 10 11) "10+11i")
+;;(test-numeric-syntax "#o10+11i" (make-rectangular 8 9) "8+9i")
+;;(test-numeric-syntax "#b10+11i" (make-rectangular 2 3) "2+3i")
+;;(test-numeric-syntax "#e1.0+1.0i" (make-rectangular 1 1) "1+1i" "1+i")
+;;(test-numeric-syntax "#i1.0+1.0i" (make-rectangular 1.0 1.0) "1.0+1.0i" "1.+1.i")
+
+(test-end)
+
+(test-end)
+
+(test-begin "6.14 System interface")
+
+;; 6.14 System interface
+
+;; (test "/usr/local/bin:/usr/bin:/bin" (get-environment-variable "PATH"))
+
+(test #t (string? (get-environment-variable "PATH")))
+
+;; (test '(("USER" . "root") ("HOME" . "/")) (get-environment-variables))
+
+(let ((env (get-environment-variables)))
+  (define (env-pair? x)
+    (and (pair? x) (string? (car x)) (string? (cdr x))))
+  (define (all? pred ls)
+    (or (null? ls) (and (pred (car ls)) (all? pred (cdr ls)))))
+  (test #t (list? env))
+  (test #t (all? env-pair? env)))
+
+(test #t (list? (command-line)))
+
+(test #t (real? (current-second)))
+(test #t (inexact? (current-second)))
+(test #t (exact? (current-jiffy)))
+(test #t (exact? (jiffies-per-second)))
+
+(test #t (list? (features)))
+(test #t (and (memq 'r7rs (features)) #t))
+
+(test #t (file-exists? "."))
+(test #f (file-exists? " no such file "))
+
+(test #t (file-error?
+          (guard (exn (else exn))
+            (delete-file " no such file "))))
+
+(test-end)
+
+(test-end)
diff --git a/tests/re-tests.txt b/tests/re-tests.txt
new file mode 100644
index 00000000..aea08801
--- /dev/null
+++ b/tests/re-tests.txt
@@ -0,0 +1,135 @@
+abc	abc	y	&	abc
+abc	xbc	n	-	-
+abc	axc	n	-	-
+abc	abx	n	-	-
+abc	xabcy	y	&	abc
+abc	ababc	y	&	abc
+ab*c	abc	y	&	abc
+ab*bc	abc	y	&	abc
+ab*bc	abbc	y	&	abbc
+ab*bc	abbbbc	y	&	abbbbc
+ab+bc	abbc	y	&	abbc
+ab+bc	abc	n	-	-
+ab+bc	abq	n	-	-
+ab+bc	abbbbc	y	&	abbbbc
+ab?bc	abbc	y	&	abbc
+ab?bc	abc	y	&	abc
+ab?bc	abbbbc	n	-	-
+ab?c	abc	y	&	abc
+^abc$	abc	y	&	abc
+^abc$	abcc	n	-	-
+^abc	abcc	y	&	abc
+^abc$	aabc	n	-	-
+abc$	aabc	y	&	abc
+^	abc	y	&	
+$	abc	y	&	
+a.c	abc	y	&	abc
+a.c	axc	y	&	axc
+a.*c	axyzc	y	&	axyzc
+a.*c	axyzd	n	-	-
+a[bc]d	abc	n	-	-
+a[bc]d	abd	y	&	abd
+a[b-d]e	abd	n	-	-
+a[b-d]e	ace	y	&	ace
+a[b-d]	aac	y	&	ac
+a[-b]	a-	y	&	a-
+a[b-]	a-	y	&	a-
+[k]	ab	n	-	-
+a[b-a]	-	c	-	-
+a[]b	-	c	-	-
+a[	-	c	-	-
+a]	a]	y	&	a]
+a[]]b	a]b	y	&	a]b
+a[^bc]d	aed	y	&	aed
+a[^bc]d	abd	n	-	-
+a[^-b]c	adc	y	&	adc
+a[^-b]c	a-c	n	-	-
+a[^]b]c	a]c	n	-	-
+a[^]b]c	adc	y	&	adc
+ab|cd	abc	y	&	ab
+ab|cd	abcd	y	&	ab
+()ef	def	y	&-\1	ef-
+()*	-	c	-	-
+*a	-	c	-	-
+^*	-	c	-	-
+$*	-	c	-	-
+(*)b	-	c	-	-
+$b	b	n	-	-
+a\	-	c	-	-
+a\(b	a(b	y	&-\1	a(b-
+a\(*b	ab	y	&	ab
+a\(*b	a((b	y	&	a((b
+a\\b	a\b	y	&	a\b
+abc)	-	c	-	-
+(abc	-	c	-	-
+((a))	abc	y	&-\1-\2	a-a-a
+(a)b(c)	abc	y	&-\1-\2	abc-a-c
+a+b+c	aabbabc	y	&	abc
+a**	-	c	-	-
+(a*)*	-	c	-	-
+(a*)+	-	c	-	-
+(a|)*	-	c	-	-
+(a*|b)*	-	c	-	-
+(a+|b)*	ab	y	&-\1	ab-b
+(a+|b)+	ab	y	&-\1	ab-b
+(a+|b)?	ab	y	&-\1	a-a
+[^ab]*	cde	y	&	cde
+(^)*	-	c	-	-
+(ab|)*	-	c	-	-
+)(	-	c	-	-
+	abc	y	&	
+abc		n	-	-
+a*		y	&	
+abcd	abcd	y	&-\&-\\&	abcd-&-\abcd
+a(bc)d	abcd	y	\1-\\1-\\\1	bc-\1-\bc
+([abc])*d	abbbcd	y	&-\1	abbbcd-c
+([abc])*bcd	abcd	y	&-\1	abcd-a
+a|b|c|d|e	e	y	&	e
+(a|b|c|d|e)f	ef	y	&-\1	ef-e
+((a*|b))*	-	c	-	-
+abcd*efg	abcdefg	y	&	abcdefg
+ab*	xabyabbbz	y	&	ab
+ab*	xayabbbz	y	&	a
+(ab|cd)e	abcde	y	&-\1	cde-cd
+[abhgefdc]ij	hij	y	&	hij
+^(ab|cd)e	abcde	n	x\1y	xy
+(abc|)ef	abcdef	y	&-\1	ef-
+(a|b)c*d	abcd	y	&-\1	bcd-b
+(ab|ab*)bc	abc	y	&-\1	abc-a
+(?:(a)b|ac)	ac	y	&-\1	ac-
+a([bc]*)c*	abc	y	&-\1	abc-bc
+a([bc]*)(c*d)	abcd	y	&-\1-\2	abcd-bc-d
+a([bc]+)(c*d)	abcd	y	&-\1-\2	abcd-bc-d
+a([bc]*)(c+d)	abcd	y	&-\1-\2	abcd-b-cd
+a[bcd]*dcdcde	adcdcde	y	&	adcdcde
+a[bcd]+dcdcde	adcdcde	n	-	-
+(ab|a)b*c	abc	y	&-\1	abc-ab
+(.*)b	abc	y	&-\1	ab-a
+((a)(b)c)(d)	abcd	y	\1-\2-\3-\4	abc-a-b-d
+((a)(b)?c)(d)	abcd	y	\1-\2-\3-\4	abc-a-b-d
+((a)(b)?c)(d)	acd	y	\1-\2-\3-\4	ac-a--d
+((aa)(bb)?cc)(dd)	aaccdd	y	\1-\2-\3-\4	aacc-aa--dd
+[ -~]*	abc	y	&	abc
+[ -~ -~]*	abc	y	&	abc
+[ -~ -~ -~]*	abc	y	&	abc
+[ -~ -~ -~ -~]*	abc	y	&	abc
+[ -~ -~ -~ -~ -~]*	abc	y	&	abc
+[ -~ -~ -~ -~ -~ -~]*	abc	y	&	abc
+[ -~ -~ -~ -~ -~ -~ -~]*	abc	y	&	abc
+[a-zA-Z_][a-zA-Z0-9_]*	alpha	y	&	alpha
+^a(bc+|b[eh])g|.h$	abh	y	&-\1	bh-
+(bc+d$|ef*g.|h?i(j|k))	effgz	y	&-\1-\2	effgz-effgz-
+(bc+d$|ef*g.|h?i(j|k))	ij	y	&-\1-\2	ij-ij-j
+(bc+d$|ef*g.|h?i(j|k))	effg	n	-	-
+(bc+d$|ef*g.|h?i(j|k))	bcdd	n	-	-
+(bc+d$|ef*g.|h?i(j|k))	reffgz	y	&-\1-\2	effgz-effgz-
+((((((((((a)))))))))	-	c	-	-
+((((((((((a))))))))))	a	y	&-\10	a-a
+(((((((((a)))))))))	a	y	&	a
+multiple words of text	uh-uh	n	-	-
+multiple words	multiple words, yeah	y	&	multiple words
+(.*)c(.*)	abcde	y	&-\1-\2	abcde-ab-de
+\((.*), (.*)\)	(a, b)	y	(\2, \1)	(b, a)
+(we|wee|week)(knights|night)	weeknights	y	&-\1-\2	weeknights-wee-knights
+(a([^a])*)*	abcaBC	y	&-\1-\2	abcaBC-aBC-C
+a([\/\\]*)b	a//\\b	y	&-\1	a//\\b-//\\
diff --git a/tests/record-tests.scm b/tests/record-tests.scm
new file mode 100644
index 00000000..c1159fe1
--- /dev/null
+++ b/tests/record-tests.scm
@@ -0,0 +1,222 @@
+
+(cond-expand
+ (modules
+  (import (srfi 99)
+          (only (chibi) env-exports)
+          (only (chibi test) test-begin test-assert test test-end)))
+ (else #f))
+
+(test-begin "records")
+
+(define-record-type organism
+  (make-organism name)
+  organism?
+  (name name-of set-name-of!))
+
+;; kingdom
+(define-record-type (animal organism)
+  (make-animal name food)
+  animal?
+  ;; all animals eat
+  (food food-of set-food-of!))
+
+;; phylum
+(define-record-type (chordate animal)
+  (make-chordate name food)
+  chordate?)
+
+;; class
+(define-record-type (mammal chordate)
+  (make-mammal name food num-nipples)
+  mammal?
+  ;; all mammals have nipples
+  (num-nipples num-nipples-of set-num-nipples-of!))
+
+;; order
+(define-record-type (carnivore mammal)
+  (make-carnivore name food num-nipples)
+  carnivore?)
+
+(define-record-type (rodent mammal)
+  (make-rodent name food num-nipples)
+  rodent?)
+
+;; family
+(define-record-type (felidae carnivore)
+  (make-felidae name food num-nipples)
+  felidae?)
+
+(define-record-type (muridae rodent)
+  (make-muridae name food num-nipples)
+  muridae?)
+
+;; genus
+(define-record-type (felis felidae)
+  (make-felis name food num-nipples)
+  felis?)
+
+(define-record-type (mus muridae)
+  (make-mus name food num-nipples)
+  mus?)
+
+;; species
+(define-record-type (cat felis)
+  (make-cat name food num-nipples breed color)
+  cat?
+  (breed breed-of set-breed-of!)
+  (color color-of set-color-of!))
+
+(define-record-type (mouse mus)
+  (make-mouse name food num-nipples)
+  mouse?)
+
+(define mickey (make-mouse "Mickey" "cheese" 10))
+(define felix (make-cat "Felix" mickey 8 'mixed '(and black white)))
+
+(test-assert (organism? mickey))
+(test-assert (animal? mickey))
+(test-assert (chordate? mickey))
+(test-assert (mammal? mickey))
+(test-assert (rodent? mickey))
+(test-assert (muridae? mickey))
+(test-assert (mus? mickey))
+(test-assert (mouse? mickey))
+
+(test-assert (not (carnivore? mickey)))
+(test-assert (not (felidae? mickey)))
+(test-assert (not (felis? mickey)))
+(test-assert (not (cat? mickey)))
+
+(test-assert (organism? felix))
+(test-assert (animal? felix))
+(test-assert (chordate? felix))
+(test-assert (mammal? felix))
+(test-assert (carnivore? felix))
+(test-assert (felidae? felix))
+(test-assert (felis? felix))
+(test-assert (cat? felix))
+
+(test-assert (not (rodent? felix)))
+(test-assert (not (muridae? felix)))
+(test-assert (not (mus? felix)))
+(test-assert (not (mouse? felix)))
+
+(test "Mickey" (name-of mickey))
+(test "cheese" (food-of mickey))
+(test 10 (num-nipples-of mickey))
+
+(test "Felix" (name-of felix))
+(test mickey (food-of felix))
+(test 8 (num-nipples-of felix))
+(test 'mixed (breed-of felix))
+(test '(and black white) (color-of felix))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-record-type person #t #t (name) (sex) (age))
+(define-record-type (employee person) #t #t (department) (salary))
+
+(define bob (make-employee "Bob" 'male 28 'hr 50000.0))
+(define alice (make-employee "Alice" 'female 32 'research 100000.0))
+
+(test-assert (person? bob))
+(test-assert (employee? bob))
+(test "Bob" (person-name bob))
+(test 'male (person-sex bob))
+(test 28 (person-age bob))
+(test 'hr (employee-department bob))
+(test 50000.0 (employee-salary bob))
+
+(test-assert (person? alice))
+(test-assert (employee? alice))
+(test "Alice" (person-name alice))
+(test 'female (person-sex alice))
+(test 32 (person-age alice))
+(test 'research (employee-department alice))
+(test 100000.0 (employee-salary alice))
+
+;; After a trip to Thailand...
+(person-sex-set! bob 'female)
+(person-name-set! bob "Roberta")
+
+;; Then Roberta quits!
+(employee-department-set! bob #f)
+(employee-salary-set! bob 0.0)
+
+(test "Roberta" (person-name bob))
+(test 'female (person-sex bob))
+(test 28 (person-age bob))
+(test #f (employee-department bob))
+(test 0.0 (employee-salary bob))
+
+;; SRFI-99 forbids this, but we currently do it anyway.
+(test-assert (equal? (make-employee "Chuck" 'male 20 'janitorial 50000.0)
+                     (make-employee "Chuck" 'male 20 'janitorial 50000.0)))
+
+(test-assert (record? alice))
+(test 'person (rtd-name person))
+(let* ((constructor (rtd-constructor person))
+       (trent (constructor "Trent" 'male 44)))
+  (test "Trent" (person-name trent))
+  (test 'male (person-sex trent))
+  (test 44 ((rtd-accessor person 'age) trent))
+  ((rtd-mutator person 'age) trent 45)
+  (test 45 (person-age trent)))
+
+(test-assert (rtd-field-mutable? employee 'department))
+
+;;; We do not retain mutability information ATM.
+;; (define-record-type foo
+;;   (make-foo x)
+;;   foo?
+;;   (x foo-x))
+;;
+;; (test-assert (not (rtd-field-mutable? foo 'x)))
+
+(define point (make-rtd "point" #(x y)))
+(define make-point (rtd-constructor point #(x y)))
+(define point-x (rtd-accessor point 'x))
+(test 3 (point-x (make-point 3 2)))
+
+;; Name conflicts - make sure we rename 
+
+(define-record-type example make-example #t example)
+(test-assert (example? (make-example 3)))
+(test 3 (example-example (make-example 3)))
+
+;; record types definitions with #f passed as either the constructor or
+;; predicate argument should not create the corresponding function
+
+(define-record-type abstract
+  #f #t)
+
+(test #f (memq 'make-abstract (env-exports (current-environment))))
+
+(define-record-type (derived abstract)
+  #t #f)
+
+(define instance (make-derived))
+(test-assert (abstract? instance))
+(test #f (memq 'derived? (env-exports (current-environment))))
+
+(define-record-type container
+  #t #t
+  default-immutable
+  (default-mutable)
+  (named-immutable get-container-immutable)
+  (named-mutable get-container-mutable set-container-mutable!))
+
+(define container-instance (make-container 1 2 3 4))
+
+(test 1 (container-default-immutable container-instance))
+(test 2 (container-default-mutable container-instance))
+(test 3 (get-container-immutable container-instance))
+(test 4 (get-container-mutable container-instance))
+
+(container-default-mutable-set! container-instance #t)
+(test #t (container-default-mutable container-instance))
+
+(set-container-mutable! container-instance #t)
+(test #t (get-container-mutable container-instance))
+
+(test-end)
diff --git a/tests/regexp-tests.scm b/tests/regexp-tests.scm
new file mode 100644
index 00000000..0d065518
--- /dev/null
+++ b/tests/regexp-tests.scm
@@ -0,0 +1,282 @@
+
+(import (chibi) (chibi regexp) (chibi regexp pcre)
+        (chibi string) (chibi io) (chibi match) (chibi test))
+
+(define (maybe-match->sexp rx str . o)
+  (let ((res (apply regexp-matches rx str o)))
+    (and res (regexp-match->sexp res))))
+
+(define-syntax test-re
+  (syntax-rules ()
+    ((test-re res rx str start end)
+     (test res (maybe-match->sexp rx str start end)))
+    ((test-re res rx str start)
+     (test-re res rx str start (string-length str)))
+    ((test-re res rx str)
+     (test-re res rx str 0))))
+
+(define (maybe-search->sexp rx str . o)
+  (let ((res (apply regexp-search rx str o)))
+    (and res (regexp-match->sexp res))))
+
+(define-syntax test-re-search
+  (syntax-rules ()
+    ((test-re-search res rx str start end)
+     (test res (maybe-search->sexp rx str start end)))
+    ((test-re-search res rx str start)
+     (test-re-search res rx str start (string-length str)))
+    ((test-re-search res rx str)
+     (test-re-search res rx str 0))))
+
+(test-begin "regexp")
+
+(test-re '("ababc" "abab")
+         '(: ($ (* "ab")) "c")
+         "ababc")
+
+(test-re '("ababc" "abab")
+         '(: ($ (* "ab")) "c")
+         "xababc"
+         1)
+
+(test-re-search '("y") '(: "y") "xy")
+
+(test-re-search '("ababc" "abab")
+                '(: ($ (* "ab")) "c")
+                "xababc")
+
+(test-re #f
+         '(: (* any) ($ "foo" (* any)) ($ "bar" (* any)))
+         "fooxbafba")
+
+(test-re '("fooxbarfbar" "fooxbarf" "bar")
+         '(: (* any) ($ "foo" (* any)) ($ "bar" (* any)))
+         "fooxbarfbar")
+
+(test-re '("abcd" "abcd")
+         '($ (* (or "ab" "cd")))
+         "abcd")
+
+;; first match is a list of ab's, second match is the last (temporary) cd
+(test-re '("abcdc" (("ab") ("cd")) "cd")
+         '(: (* (*$ (or "ab" "cd"))) "c")
+         "abcdc")
+
+(test "ab"
+    (regexp-match-submatch
+     (regexp-matches '(or (-> foo "ab") (-> foo "cd")) "ab")
+     'foo))
+
+(test "cd"
+    (regexp-match-submatch
+     (regexp-matches '(or (-> foo "ab") (-> foo "cd")) "cd")
+     'foo))
+
+;; non-deterministic case from issue #229
+(let* ((elapsed '(: (** 1 2 num) ":" num num (? ":" num num)))
+       (span (rx ,elapsed "-" ,elapsed)))
+  (test-re-search '("1:45:02-2:06:13") span " 1:45:02-2:06:13 "))
+
+(test-re '("ababc" "abab")
+         '(: bos ($ (* "ab")) "c")
+         "ababc")
+(test-re '("ababc" "abab")
+         '(: ($ (* "ab")) "c" eos)
+         "ababc")
+(test-re '("ababc" "abab")
+         '(: bos ($ (* "ab")) "c" eos)
+         "ababc")
+(test-re #f
+         '(: bos ($ (* "ab")) eos "c")
+         "ababc")
+(test-re #f
+         '(: ($ (* "ab")) bos "c" eos)
+         "ababc")
+
+(test-re '("ababc" "abab")
+         '(: bol ($ (* "ab")) "c")
+         "ababc")
+(test-re '("ababc" "abab")
+         '(: ($ (* "ab")) "c" eol)
+         "ababc")
+(test-re '("ababc" "abab")
+         '(: bol ($ (* "ab")) "c" eol)
+         "ababc")
+(test-re #f
+         '(: bol ($ (* "ab")) eol "c")
+         "ababc")
+(test-re #f
+         '(: ($ (* "ab")) bol "c" eol)
+         "ababc")
+(test-re '("\nabc\n" "abc")
+         '(: (* #\newline) bol ($ (* alpha)) eol (* #\newline))
+         "\nabc\n")
+(test-re #f
+         '(: (* #\newline) bol ($ (* alpha)) eol (* #\newline))
+         "\n'abc\n")
+(test-re #f
+         '(: (* #\newline) bol ($ (* alpha)) eol (* #\newline))
+         "\nabc.\n")
+
+(test-re '("ababc" "abab")
+         '(: bow ($ (* "ab")) "c")
+         "ababc")
+(test-re '("ababc" "abab")
+         '(: ($ (* "ab")) "c" eow)
+         "ababc")
+(test-re '("ababc" "abab")
+         '(: bow ($ (* "ab")) "c" eow)
+         "ababc")
+(test-re #f
+         '(: bow ($ (* "ab")) eow "c")
+         "ababc")
+(test-re #f
+         '(: ($ (* "ab")) bow "c" eow)
+         "ababc")
+(test-re '("  abc  " "abc")
+         '(: (* space) bow ($ (* alpha)) eow (* space))
+         "  abc  ")
+(test-re #f
+         '(: (* space) bow ($ (* alpha)) eow (* space))
+         " 'abc  ")
+(test-re #f
+         '(: (* space) bow ($ (* alpha)) eow (* space))
+         " abc.  ")
+(test-re-search '("foo") '(: "foo") " foo ")
+(test-re-search #f '(: nwb "foo" nwb) " foo ")
+(test-re-search '("foo") '(: nwb "foo" nwb) "xfoox")
+
+(test-re '("beef")
+         '(* (/"af"))
+         "beef")
+
+(test-re '("12345beef" "beef")
+         '(: (* digit) ($ (* (/"af"))))
+         "12345beef")
+
+(let ((number '($ (+ digit))))
+  (test '("555" "867" "5309")
+      (cdr
+       (regexp-match->list
+        (regexp-search `(: ,number "-" ,number "-" ,number)
+                       "555-867-5309"))))
+  (test '("555" "5309")
+      (cdr
+       (regexp-match->list
+        (regexp-search `(: ,number "-" (w/nocapture ,number) "-" ,number)
+                       "555-867-5309")))))
+
+(test-re '("12345BeeF" "BeeF")
+         '(: (* digit) (w/nocase ($ (* (/"af")))))
+         "12345BeeF")
+
+(test-re #f '(* lower) "abcD")
+(test-re '("abcD") '(w/nocase (* lower)) "abcD")
+(test-re '("σζ") '(* lower) "σζ")
+(test-re '("Σ") '(* upper) "Σ")
+(test-re '("\x01C5;") '(* title) "\x01C5;")
+(test-re '("σζ\x01C5;") '(w/nocase (* lower)) "σζ\x01C5;")
+
+(test-re '("кириллица") '(* alpha) "кириллица")
+(test-re #f '(w/ascii (* alpha)) "кириллица")
+(test-re '("кириллица") '(w/nocase "КИРИЛЛИЦА") "кириллица")
+
+(test-re '("１２３４５") '(* digit) "１２３４５")
+(test-re #f '(w/ascii (* digit)) "１２３４５")
+
+(test-re '("한") 'grapheme "한")
+(test-re '("글") 'grapheme "글")
+
+(test-re '("한") '(: bog grapheme eog) "한")
+(test-re #f '(: "ᄒ" bog grapheme eog "ᆫ") "한")
+
+(test '("123" "456" "789") (regexp-extract '(+ digit) "abc123def456ghi789"))
+(test '("123" "456" "789") (regexp-extract '(* digit) "abc123def456ghi789"))
+(test '("abc" "def" "ghi") (regexp-split '(+ digit) "abc123def456ghi789"))
+(test '("a" "b" "c" "d" "e" "f" "g" "h" "i")
+    (regexp-split '(* digit) "abc123def456ghi789"))
+(test '("a" "b") (regexp-split '(+ whitespace) "a b"))
+(test '("한" "글")
+    (regexp-extract
+     'grapheme
+     (utf8->string '#u8(#xe1 #x84 #x92 #xe1 #x85 #xa1 #xe1 #x86 #xab
+                        #xe1 #x84 #x80 #xe1 #x85 #xb3 #xe1 #x86 #xaf))))
+
+(test "abc def" (regexp-replace '(+ space) "abc \t\n def" " "))
+(test "  abc-abc"
+    (regexp-replace '(: ($ (+ alpha)) ":" (* space)) "  abc: " '(1 "-" 1)))
+(test "  abc-  abc"
+    (regexp-replace '(: ($ (+ alpha)) ":" (* space)) "  abc: " '(1 "-" pre 1)))
+
+(test "-abc \t\n d ef  "
+    (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0))
+(test "-abc \t\n d ef  "
+    (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0 #f 0))
+(test "  abc-d ef  "
+    (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0 #f 1))
+(test "  abc \t\n d-ef  "
+    (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0 #f 2))
+(test "  abc \t\n d ef-"
+    (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0 #f 3))
+(test "  abc \t\n d ef  "
+    (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0 #f 4))
+(test " abc d ef " (regexp-replace-all '(+ space) "  abc \t\n d ef  " " "))
+
+(define (subst-matches matches input subst)
+  (define (submatch n)
+    (regexp-match-submatch matches n))
+  (and
+   matches
+   (call-with-output-string
+     (lambda (out)
+       (call-with-input-string subst
+         (lambda (in)
+           (let lp ()
+             (let ((c (read-char in)))
+               (cond
+                ((not (eof-object? c))
+                 (case c
+                   ((#\&)
+                    (display (or (submatch 0) "") out))
+                   ((#\\)
+                    (let ((c (read-char in)))
+                      (if (char-numeric? c)
+                          (let lp ((res (list c)))
+                            (if (and (char? (peek-char in))
+                                     (char-numeric? (peek-char in)))
+                                (lp (cons (read-char in) res))
+                                (display
+                                 (or (submatch (string->number
+                                                (list->string (reverse res))))
+                                     "")
+                                 out)))
+                          (write-char c out))))
+                   (else
+                    (write-char c out)))
+                 (lp)))))))))))
+
+(define (test-pcre line)
+  (match (string-split line #\tab)
+    ((pattern input result subst output)
+     (let ((name (string-append pattern " " input " " result " " subst)))
+       (cond
+        ((equal? "c" result)
+         (test-error name (regexp-search (pcre->sre pattern) input)))
+        ((equal? "n" result)
+         (test-assert name (not (regexp-search (pcre->sre pattern) input))))
+        (else
+         (test name output
+           (subst-matches (regexp-search (pcre->sre pattern) input)
+                          input
+                          subst))))))
+    (else
+     (error "invalid regex test line" line))))
+
+(test-group "pcre"
+  (call-with-input-file "tests/re-tests.txt"
+    (lambda (in)
+      (for-each
+       (lambda (line) (test-pcre line))
+       (port->list read-line in)))))
+
+(test-end)
diff --git a/tests/rsa-tests.scm b/tests/rsa-tests.scm
new file mode 100644
index 00000000..7d98cf81
--- /dev/null
+++ b/tests/rsa-tests.scm
@@ -0,0 +1,81 @@
+
+(import (scheme base)
+        (chibi crypto rsa)
+        (chibi crypto sha2)
+        (chibi test))
+
+(test-begin "rsa")
+
+;; Verify an explicit key.
+
+;; p = 61, q = 53
+(define priv-key (rsa-key-gen-from-primes 8 61 53))
+(define pub-key (rsa-pub-key priv-key))
+
+(test 439 (rsa-sign priv-key 42))
+(test #t (rsa-verify? pub-key 42 (rsa-sign priv-key 42)))
+
+(let ((msg 42))
+  (test msg (rsa-decrypt priv-key (rsa-encrypt pub-key msg))))
+
+(define priv-key2 (rsa-key-gen-from-primes 32 2936546443 3213384203))
+(define pub-key2 (rsa-pub-key priv-key2))
+
+(let ((msg 42))
+  (test msg (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg))))
+
+(let ((msg #u8(42)))
+  (test msg (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg))))
+
+(let ((msg "*"))
+  (test msg (utf8->string (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg)))))
+
+(let ((msg "*"))
+  (test #t (rsa-verify? pub-key2 msg (rsa-sign priv-key2 msg))))
+
+(let ((msg #u8(42)))
+  (test #t (rsa-verify? pub-key2 msg (rsa-sign priv-key2 msg))))
+
+;; Key generation.
+
+(define (test-key key)
+  (test #t (rsa-key? key))
+  (test #t (positive? (rsa-key-n key)))
+  (test #t (positive? (rsa-key-e key)))
+  (test #t (positive? (rsa-key-d key)))
+  (test 5 (rsa-decrypt key (rsa-encrypt (rsa-pub-key key) 5))))
+
+(test-key (rsa-key-gen 8))
+(test-key (rsa-key-gen 16))
+(test-key (rsa-key-gen 32))
+(test-key (rsa-key-gen-from-primes 32 2936546443 3213384203))
+
+;; These are expensive to test.  Times with -h1G:
+;; (test-key (rsa-key-gen 128))   ; 0.04s
+;; (test-key (rsa-key-gen 256))   ; 0.4s
+;; (test-key (rsa-key-gen 512))   ; 4s
+;; (test-key (rsa-key-gen 1024))  ; 92s
+
+;; padding
+
+(test #u8(8 8 8 8 8 8 8 8) (pkcs1-pad #u8()))
+(test #u8(1 7 7 7 7 7 7 7) (pkcs1-pad #u8(1)))
+(test #u8(1 2 6 6 6 6 6 6) (pkcs1-pad #u8(1 2)))
+(test #u8(1 2 3 5 5 5 5 5) (pkcs1-pad #u8(1 2 3)))
+(test #u8(1 2 3 4 4 4 4 4) (pkcs1-pad #u8(1 2 3 4)))
+(test #u8(1 2 3 4 5 3 3 3) (pkcs1-pad #u8(1 2 3 4 5)))
+(test #u8(1 2 3 4 5 6 2 2) (pkcs1-pad #u8(1 2 3 4 5 6)))
+(test #u8(1 2 3 4 5 6 7 1) (pkcs1-pad #u8(1 2 3 4 5 6 7)))
+(test #u8(1 2 3 4 5 6 7 8 8 8 8 8 8 8 8 8) (pkcs1-pad #u8(1 2 3 4 5 6 7 8)))
+
+(test #u8() (pkcs1-unpad #u8(8 8 8 8 8 8 8 8)))
+(test #u8(1) (pkcs1-unpad #u8(1 7 7 7 7 7 7 7)))
+(test #u8(1 2) (pkcs1-unpad #u8(1 2 6 6 6 6 6 6)))
+(test #u8(1 2 3) (pkcs1-unpad #u8(1 2 3 5 5 5 5 5)))
+(test #u8(1 2 3 4) (pkcs1-unpad #u8(1 2 3 4 4 4 4 4)))
+(test #u8(1 2 3 4 5) (pkcs1-unpad #u8(1 2 3 4 5 3 3 3)))
+(test #u8(1 2 3 4 5 6) (pkcs1-unpad #u8(1 2 3 4 5 6 2 2)))
+(test #u8(1 2 3 4 5 6 7) (pkcs1-unpad #u8(1 2 3 4 5 6 7 1)))
+(test #u8(1 2 3 4 5 6 7 8) (pkcs1-unpad #u8(1 2 3 4 5 6 7 8 8 8 8 8 8 8 8 8)))
+
+(test-end)
diff --git a/tests/scribble-tests.scm b/tests/scribble-tests.scm
new file mode 100644
index 00000000..ad6f97cc
--- /dev/null
+++ b/tests/scribble-tests.scm
@@ -0,0 +1,212 @@
+
+(cond-expand
+ (modules (import (chibi scribble) (only (chibi test) test-begin test test-end)))
+ (else (load "lib/chibi/scribble.scm")))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(test-begin "scribble")
+
+(define (test-scribble expect str)
+  (test (call-with-output-string (lambda (out) (write str out)))
+      expect
+    (call-with-input-string str scribble-parse)))
+
+(test-scribble '((foo "blah blah blah")) "\\foo{blah blah blah}")
+(test-scribble '((foo "blah \"blah\" (`blah'?)")) "\\foo{blah \"blah\" (`blah'?)}")
+(test-scribble '((foo 1 2 "3 4")) "\\foo[1 2]{3 4}")
+(test-scribble '((foo 1 2 3 4)) "\\foo[1 2 3 4]")
+(test-scribble '((foo width: 2 "blah blah")) "\\foo[width: 2]{blah blah}")
+(test-scribble '((foo "blah blah" "\n" "     yada yada")) "\\foo{blah blah
+     yada yada}")
+(test-scribble '((foo "  blah blah" "\n" "  yada yada" "\n")) "\\foo{
+  blah blah
+  yada yada
+}")
+
+(test-scribble '((foo "bar " (baz "3") "\n" "     blah")) "\\foo{bar \\baz{3}
+     blah}")
+(test-scribble '((foo (b (u 3) " " (u "4")) "\n" "     blah")) "\\foo{\\b{\\u[3] \\u{4}}
+     blah}")
+(test-scribble '((C "while (*(p++))" "\n" "     *p = '\\n';")) "\\C{while (*(p++))
+     *p = '\\\"\\\\\"n';}")
+(test-scribble '(("blah blah")) "\\{blah blah}")
+(test-scribble '(("blah " (3))) "\\{blah \\[3]}")
+(test-scribble '(("foo" "\n" "   bar" "\n" "   baz")) "\\{foo
+   bar
+   baz}")
+(test-scribble '(foo) "\\foo")
+(test-scribble '(("blah " foo " blah")) "\\{blah \\foo blah}")
+(test-scribble '(("blah " foo: " blah")) "\\{blah \\foo: blah}")
+(test-scribble '(("blah " foo ": blah")) "\\{blah \\|foo|: blah}")
+(test-scribble '((foo "(+ 1 2) -> " (+ 1 2) "!")) "\\foo{(+ 1 2) -> \\(+ 1 2)!}")
+(test-scribble '((foo "A string escape")) "\\foo{A \\\"string\" escape}")
+(test-scribble '((foo "eli@barzilay.org")) "\\foo{eli@barzilay.org}")
+(test-scribble '((foo "eli\\barzilay.org")) "\\foo{eli\\\"\\\\\"barzilay.org}")
+(test-scribble '((foo "A { begins a block")) "\\foo{A \\\"{\" begins a block}")
+(test-scribble '((C "while (*(p++)) {" "\n" "     *p = '\\n';" "\n" "   }"))
+ "\\C{while (*(p++)) {
+     *p = '\\\"\\\\\"n';
+   }}")
+(test-scribble '((foo "bar}\\{baz")) "\\foo|{bar}\\{baz}|")
+(test-scribble '((foo "bar " (x "X") " baz")) "\\foo|{bar |\\x{X} baz}|")
+(test-scribble '((foo "bar " (x "\\") " baz")) "\\foo|{bar |\\x|{\\}| baz}|")
+
+(test-scribble '((foo "bar}\\|{baz")) "\\foo|--{bar}\\|{baz}--|")
+(test-scribble '((foo "bar}\\|{baz")) "\\foo|<<{bar}\\|{baz}>>|")
+
+(test-scribble '((foo "bar " (baz 2 3) " {4 5}")) "\\foo{bar \\baz[2 3] {4 5}}")
+
+(test-scribble '(`',@(foo "blah")) "\\`',@foo{blah}")
+;;(test-scribble '(#`#'#,@(foo "blah")) "\\#`#'#,@foo{blah}")
+(test-scribble '(((lambda (x) x) "blah")) "\\(lambda (x) x){blah}")
+(test-scribble '(`(,foo  "blah")) "\\`(unquote foo){blah}")
+
+(test-scribble '(("foo bar" "\n" "  baz")) "\\{foo bar
+  baz}")
+(test-scribble '('("foo bar" "\n" "       baz")) "\\'{foo bar
+       baz}")
+(test-scribble '((foo "bar      baz     blah")) "\\foo{bar \\; comment
+     baz\\;
+     blah}")
+
+(test-scribble '((foo "x " y " z")) "\\foo{x \\y z}")
+(test-scribble '((foo "x " (* y 2) " z")) "\\foo{x \\(* y 2) z}")
+(test-scribble '((foo " bar")) "\\{\\foo bar}")
+(test-scribble '(((foo "bar") "baz")) "\\\\foo{bar}{baz}")
+
+(test-scribble '((foo 1 (* 2 3) "bar")) "\\foo[1 (* 2 3)]{bar}")
+(test-scribble '((foo (bar "...") "blah")) "\\foo[\\bar{...}]{blah}")
+(test-scribble '((foo bar)) "\\foo[bar]")
+(test-scribble '((foo "bar " (f x) " baz")) "\\foo{bar \\f[x] baz}")
+(test-scribble '((foo "bar")) "\\foo[]{bar}")
+(test-scribble '((foo)) "\\foo[]")
+(test-scribble '(foo) "\\foo")
+(test-scribble '((foo)) "\\foo{}")
+
+(test-scribble '((foo 'style: 'big  "bar")) "\\foo['style: 'big]{bar}")
+
+(test-scribble '((foo "f{o}o")) "\\foo{f{o}o}")
+(test-scribble '((foo "{{}}{}")) "\\foo{{{}}{}}")
+(test-scribble '((foo "bar")) "\\foo{bar}")
+(test-scribble '((foo " bar ")) "\\foo{ bar }")
+(test-scribble '((foo 1 " bar ")) "\\foo[1]{ bar }")
+
+(test-scribble '((foo "a " (bar "b") " c")) "\\foo{a \\bar{b} c}")
+(test-scribble '((foo "a " bar " c")) "\\foo{a \\bar c}")
+(test-scribble '((foo "a " (bar 2) " c")) "\\foo{a \\(bar 2) c}")
+(test-scribble '((foo "A } marks the end")) "\\foo{A \\\"}\" marks the end}")
+(test-scribble '((foo "The prefix: @.")) "\\foo{The prefix: \\\"@\".}")
+(test-scribble '((foo "The prefix: \\.")) "\\foo{The prefix: \\\"\\\\\".}")
+(test-scribble '((foo "\\x{y} --> (x \"y\")")) "\\foo{\\\"\\\\x{y}\" --> (x \"y\")}")
+
+(test-scribble '((foo "...")) "\\foo|{...}|")
+(test-scribble '((foo "\"}\" follows \"{\"")) "\\foo|{\"}\" follows \"{\"}|")
+(test-scribble '((foo "Nesting |{is}| ok")) "\\foo|{Nesting |{is}| ok}|")
+
+(test-scribble '((foo "Maze" "\n" "      " (bar "is") "\n" "      Life!"))
+ "\\foo|{Maze
+      |\\bar{is}
+      Life!}|")
+(test-scribble '((t "In " (i "sub\\s") " too")) "\\t|{In |\\i|{sub|\\\"\\\\\"s}| too}|")
+(test-scribble '((foo "\\x{foo} |\\{bar}|.")) "\\foo|<<<{\\x{foo} |\\{bar}|.}>>>|")
+(test-scribble '((foo "X " (b "Y") "...")) "\\foo|!!{X |!!\\b{Y}...}!!|")
+
+(test-scribble '((foo "foo" bar.)) "\\foo{foo\\bar.}")
+(test-scribble '((foo "foo" bar ".")) "\\foo{foo\\|bar|.}")
+(test-scribble '((foo "foo" 3.0)) "\\foo{foo\\3.}")
+(test-scribble '((foo "foo" 3 ".")) "\\foo{foo\\|3|.}")
+(test-scribble '((foo "foo" (f 1) "{bar}")) "\\foo{foo\\|(f 1)|{bar}}")
+(test-scribble '((foo "foo" bar "[1]{baz}")) "\\foo{foo\\|bar|[1]{baz}}")
+(test-scribble '((foo "xyz")) "\\foo{x\\\"y\"z}")
+(test-scribble '((foo "x" "y" "z")) "\\foo{x\\|\"y\"|z}")
+(test-scribble '((foo "x" 1 (+ 2 3) 4 "y")) "\\foo{x\\|1 (+ 2 3) 4|y}")
+(test-scribble '((foo "x" * * "y")) "\\foo{x\\|*
+        *|y}")
+(test-scribble '((foo "Alice" "Bob" "Carol")) "\\foo{Alice\\||Bob\\|
+     |Carol}")
+(test-scribble '((blah)) "\\|{blah}|")
+(test-scribble '((blah blah)) "\\|{blah blah}|")
+
+(test-scribble '((foo "First line" "\n" "     Second line")) "\\foo{First line\\;{there is still a
+                  newline here;}
+     Second line}")
+(test-scribble '((foo "A long      single-     string arg.")) "\\foo{A long \\;
+     single-\\;
+     string arg.}")
+
+(test-scribble '((foo "bar")) "\\foo{bar}")
+(test-scribble '((foo " bar ")) "\\foo{ bar }")
+(test-scribble '((foo " bar" "\n" "     baz ")) "\\foo{ bar
+     baz }")
+
+(test-scribble '((foo "bar" "\n")) "\\foo{bar
+}")
+(test-scribble '((foo "  bar" "\n") "\n") "\\foo{
+  bar
+}
+")
+(test-scribble '((foo "  bar" "\n" "\n")) "\\foo{
+
+  bar
+
+}")
+(test-scribble '((foo "  bar" "\n" "\n" "  baz" "\n")) "\\foo{
+  bar
+
+  baz
+}")
+(test-scribble '((foo)) "\\foo{
+}")
+(test-scribble '((foo)) "\\foo{
+
+}")
+(test-scribble '((foo " bar" "\n" "     baz ")) "\\foo{ bar
+     baz }")
+
+(test-scribble '((foo "  bar" "\n" "  baz" "\n" "  blah" "\n")) "\\foo{
+  bar
+  baz
+  blah
+}")
+(test-scribble '((foo "  begin" "\n" "    x++;" "\n" "  end")) "\\foo{
+  begin
+    x++;
+  end}")
+(test-scribble '((foo "    a" "\n" "   b" "\n" "  c")) "\\foo{
+    a
+   b
+  c}")
+
+(test-scribble '((foo "bar" "\n" "       baz" "\n" "     bbb")) "\\foo{bar
+       baz
+     bbb}")
+(test-scribble '((foo " bar" "\n" "        baz" "\n" "      bbb")) "\\foo{ bar
+        baz
+      bbb}")
+(test-scribble '((foo "bar" "\n" "   baz" "\n" "   bbb")) "\\foo{bar
+   baz
+   bbb}")
+(test-scribble '((foo " bar" "\n" "   baz" "\n" "   bbb")) "\\foo{ bar
+   baz
+   bbb}")
+(test-scribble
+ '((foo " bar" "\n" "   baz" "\n" "     bbb"))
+ "\\foo{ bar
+   baz
+     bbb}")
+(test-scribble
+ '((text "Some " (b "bold" "\n" "\n" "  text")", and" "\n" "\n" "  more text."))
+ "\\text{Some \\b{bold
+
+  text}, and
+
+  more text.}")
+
+(test-scribble '((foo "  " " bar " "\n" "  " " baz")) "\\foo{
+  \\|| bar \\||
+  \\|| baz}")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(test-end)
diff --git a/tests/sha-tests.scm b/tests/sha-tests.scm
new file mode 100644
index 00000000..573b31b3
--- /dev/null
+++ b/tests/sha-tests.scm
@@ -0,0 +1,24 @@
+
+(import (chibi crypto sha2) (chibi test))
+
+(test-begin "sha2")
+
+(test "d14a028c2a3a2bc9476102bb288234c415a2b01f828ea62ac5b3e42f"
+    (sha-224 ""))
+(test "23097d223405d8228642a477bda255b32aadbce4bda0b3f7e36c9da7"
+    (sha-224 "abc"))
+(test "730e109bd7a8a32b1cb9d9a09aa2325d2430587ddbc0c38bad911525"
+    (sha-224 "The quick brown fox jumps over the lazy dog"))
+
+(test "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"
+    (sha-256 ""))
+(test "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad"
+    (sha-256 "abc"))
+(test "d7a8fbb307d7809469ca9abcb0082e4f8d5651e46d3cdb762d02d0bf37c9e592"
+    (sha-256 "The quick brown fox jumps over the lazy dog"))
+(test "61f8fe4c4cdc8b3e10673933fcd0c5b1f6b46d3392550e42b265daefc7bc0d31"
+    (sha-256 "abcdbcdecdefdefgefghfghighijhijkijkljklmklm"))
+(test "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1"
+    (sha-256 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"))
+
+(test-end)
diff --git a/tests/show-tests.scm b/tests/show-tests.scm
new file mode 100644
index 00000000..2c56f021
--- /dev/null
+++ b/tests/show-tests.scm
@@ -0,0 +1,376 @@
+
+(import (scheme base) (scheme read) (chibi test)
+        (chibi show) (chibi show base) (chibi show pretty))
+
+(test-begin "show")
+
+;; basic data types
+
+(test "hi" (show #f "hi"))
+(test "\"hi\"" (show #f (written "hi")))
+(test "\"hi \\\"bob\\\"\"" (show #f (written "hi \"bob\"")))
+(test "\"hello\\nworld\"" (show #f (written "hello\nworld")))
+(test "#(1 2 3)" (show #f (written '#(1 2 3))))
+(test "(1 2 3)" (show #f (written '(1 2 3))))
+(test "(1 2 . 3)" (show #f (written '(1 2 . 3))))
+(test "ABC" (show #f (upcased "abc")))
+(test "abc" (show #f (downcased "ABC")))
+
+(test "abc     def" (show #f "abc" (tab-to) "def"))
+(test "abc  def" (show #f "abc" (tab-to 5) "def"))
+(test "abcdef" (show #f "abc" (tab-to 3) "def"))
+
+;; numbers
+
+(test "-1" (show #f -1))
+(test "0" (show #f 0))
+(test "1" (show #f 1))
+(test "10" (show #f 10))
+(test "100" (show #f 100))
+(test "-1" (show #f (numeric -1)))
+(test "0" (show #f (numeric 0)))
+(test "1" (show #f (numeric 1)))
+(test "10" (show #f (numeric 10)))
+(test "100" (show #f (numeric 100)))
+(test "57005" (show #f #xDEAD))
+(test "#xdead" (show #f (with ((radix 16)) #xDEAD)))
+(test "#xdead1234" (show #f (with ((radix 16)) #xDEAD) 1234))
+(test "de.ad"
+    (show #f (with ((radix 16) (precision 2)) (numeric (/ #xDEAD #x100)))))
+(test "d.ead"
+    (show #f (with ((radix 16) (precision 3)) (numeric (/ #xDEAD #x1000)))))
+(test "0.dead"
+    (show #f (with ((radix 16) (precision 4)) (numeric (/ #xDEAD #x10000)))))
+(test "1g"
+    (show #f (with ((radix 17)) (numeric 33))))
+
+(test "3.14159" (show #f 3.14159))
+(test "3.14" (show #f (with ((precision 2)) 3.14159)))
+(test "3.14" (show #f (with ((precision 2)) 3.14)))
+(test "3.00" (show #f (with ((precision 2)) 3.)))
+(test "1.10" (show #f (with ((precision 2)) 1.099)))
+(test "0.00" (show #f (with ((precision 2)) 1e-17)))
+(test "0.0000000010" (show #f (with ((precision 10)) 1e-9)))
+(test "0.0000000000" (show #f (with ((precision 10)) 1e-17)))
+(test "0.000004" (show #f (with ((precision 6)) 0.000004)))
+(test "0.0000040" (show #f (with ((precision 7)) 0.000004)))
+(test "0.00000400" (show #f (with ((precision 8)) 0.000004)))
+
+(test "   3.14159" (show #f (with ((decimal-align 5)) (numeric 3.14159))))
+(test "  31.4159" (show #f (with ((decimal-align 5)) (numeric 31.4159))))
+(test " 314.159" (show #f (with ((decimal-align 5)) (numeric 314.159))))
+(test "3141.59" (show #f (with ((decimal-align 5)) (numeric 3141.59))))
+(test "31415.9" (show #f (with ((decimal-align 5)) (numeric 31415.9))))
+(test "  -3.14159" (show #f (with ((decimal-align 5)) (numeric -3.14159))))
+(test " -31.4159" (show #f (with ((decimal-align 5)) (numeric -31.4159))))
+(test "-314.159" (show #f (with ((decimal-align 5)) (numeric -314.159))))
+(test "-3141.59" (show #f (with ((decimal-align 5)) (numeric -3141.59))))
+(test "-31415.9" (show #f (with ((decimal-align 5)) (numeric -31415.9))))
+
+(cond
+ ((exact? (/ 1 3)) ;; exact rationals
+  (test "333.333333333333333333333333333333"
+      (show #f (with ((precision 30)) (numeric 1000/3))))
+  (test  "33.333333333333333333333333333333"
+      (show #f (with ((precision 30)) (numeric 100/3))))
+  (test   "3.333333333333333333333333333333"
+      (show #f (with ((precision 30)) (numeric 10/3))))
+  (test   "0.333333333333333333333333333333"
+      (show #f (with ((precision 30)) (numeric 1/3))))
+  (test   "0.033333333333333333333333333333"
+      (show #f (with ((precision 30)) (numeric 1/30))))
+  (test   "0.003333333333333333333333333333"
+      (show #f (with ((precision 30)) (numeric 1/300))))
+  (test   "0.000333333333333333333333333333"
+      (show #f (with ((precision 30)) (numeric 1/3000))))
+  (test   "0.666666666666666666666666666667"
+      (show #f (with ((precision 30)) (numeric 2/3))))
+  (test   "0.090909090909090909090909090909"
+      (show #f (with ((precision 30)) (numeric 1/11))))
+  (test   "1.428571428571428571428571428571"
+      (show #f (with ((precision 30)) (numeric 10/7))))
+  (test "0.123456789012345678901234567890"
+      (show #f (with ((precision 30))
+                 (numeric (/  123456789012345678901234567890
+                              1000000000000000000000000000000)))))
+  (test  " 333.333333333333333333333333333333"
+      (show #f (with ((precision 30) (decimal-align 5)) (numeric 1000/3))))
+  (test  "  33.333333333333333333333333333333"
+      (show #f (with ((precision 30) (decimal-align 5)) (numeric 100/3))))
+  (test  "   3.333333333333333333333333333333"
+      (show #f (with ((precision 30) (decimal-align 5)) (numeric 10/3))))
+  (test  "   0.333333333333333333333333333333"
+      (show #f (with ((precision 30) (decimal-align 5)) (numeric 1/3))))
+  ))
+
+(test "11.75" (show #f (with ((precision 2)) (/ 47 4))))
+(test "-11.75" (show #f (with ((precision 2)) (/ -47 4))))
+
+(test "(#x11 #x22 #x33)" (show #f (with ((radix 16)) '(#x11 #x22 #x33))))
+
+(test "299792458" (show #f (with ((comma-rule 3)) 299792458)))
+(test "299,792,458" (show #f (with ((comma-rule 3)) (numeric 299792458))))
+(test "-29,97,92,458"
+    (show #f (with ((comma-rule '(3 . 2))) (numeric -299792458))))
+(test "299.792.458"
+    (show #f (with ((comma-rule 3) (comma-sep #\.)) (numeric 299792458))))
+(test "299.792.458,0"
+    (show #f (with ((comma-rule 3) (decimal-sep #\,)) (numeric 299792458.0))))
+
+(test "100,000" (show #f (with ((comma-rule 3)) (numeric 100000))))
+(test "100,000.0"
+    (show #f (with ((comma-rule 3) (precision 1)) (numeric 100000))))
+(test "100,000.00"
+    (show #f (with ((comma-rule 3) (precision 2)) (numeric 100000))))
+
+(cond-expand
+ (complex
+  (test "1+2i" (show #f (string->number "1+2i")))
+  (test "1.00+2.00i"
+      (show #f (with ((precision 2)) (string->number "1+2i"))))
+  (test "3.14+2.00i"
+      (show #f (with ((precision 2)) (string->number "3.14159+2i"))))))
+
+;; padding/trimming
+
+(test "abc  " (show #f (padded 5 "abc")))
+(test "  abc" (show #f (padded/left 5 "abc")))
+(test " abc " (show #f (padded/both 5 "abc")))
+(test "abcde" (show #f (padded 5 "abcde")))
+(test "abcdef" (show #f (padded 5 "abcdef")))
+
+(test "abc" (show #f (trimmed 3 "abcde")))
+(test "abc" (show #f (trimmed 3 "abcd")))
+(test "abc" (show #f (trimmed 3 "abc")))
+(test "ab" (show #f (trimmed 3 "ab")))
+(test "a" (show #f (trimmed 3 "a")))
+(test "cde" (show #f (trimmed/left 3 "abcde")))
+(test "bcd" (show #f (trimmed/both 3 "abcde")))
+(test "bcdef" (show #f (trimmed/both 5 "abcdefgh")))
+(test "abc" (show #f (trimmed/lazy 3 "abcde")))
+(test "abc" (show #f (trimmed/lazy 3 "abc\nde")))
+
+(test "prefix: abc" (show #f "prefix: " (trimmed 3 "abcde")))
+(test "prefix: cde" (show #f "prefix: " (trimmed/left 3 "abcde")))
+(test "prefix: bcd" (show #f "prefix: " (trimmed/both 3 "abcde")))
+(test "prefix: abc" (show #f "prefix: " (trimmed/lazy 3 "abcde")))
+(test "prefix: abc" (show #f "prefix: " (trimmed/lazy 3 "abc\nde")))
+
+(test "abc :suffix" (show #f (trimmed 3 "abcde") " :suffix"))
+(test "cde :suffix" (show #f (trimmed/left 3 "abcde") " :suffix"))
+(test "bcd :suffix" (show #f (trimmed/both 3 "abcde") " :suffix"))
+(test "abc :suffix" (show #f (trimmed/lazy 3 "abcde") " :suffix"))
+(test "abc :suffix" (show #f (trimmed/lazy 3 "abc\nde") " :suffix"))
+
+(test "abcde"
+    (show #f (with ((ellipsis "...")) (trimmed 5 "abcde"))))
+(test "ab..."
+    (show #f (with ((ellipsis "...")) (trimmed 5 "abcdef"))))
+(test "abc..."
+    (show #f (with ((ellipsis "...")) (trimmed 6 "abcdefg"))))
+(test "abcde"
+    (show #f (with ((ellipsis "...")) (trimmed/left 5 "abcde"))))
+(test "...ef"
+    (show #f (with ((ellipsis "...")) (trimmed/left 5 "abcdef"))))
+(test "...efg"
+    (show #f (with ((ellipsis "...")) (trimmed/left 6 "abcdefg"))))
+(test "abcdefg"
+    (show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefg"))))
+(test "...d..."
+    (show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefgh"))))
+(test "...e..."
+    (show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefghi"))))
+
+(test "abc  " (show #f (fitted 5 "abc")))
+(test "  abc" (show #f (fitted/left 5 "abc")))
+(test " abc " (show #f (fitted/both 5 "abc")))
+(test "abcde" (show #f (fitted 5 "abcde")))
+(test "abcde" (show #f (fitted/left 5 "abcde")))
+(test "abcde" (show #f (fitted/both 5 "abcde")))
+(test "abcde" (show #f (fitted 5 "abcdefgh")))
+(test "defgh" (show #f (fitted/left 5 "abcdefgh")))
+(test "bcdef" (show #f (fitted/both 5 "abcdefgh")))
+
+(test "prefix: abc   :suffix"
+    (show #f "prefix: " (fitted 5 "abc") " :suffix"))
+(test "prefix:   abc :suffix"
+    (show #f "prefix: " (fitted/left 5 "abc") " :suffix"))
+(test "prefix:  abc  :suffix"
+    (show #f "prefix: " (fitted/both 5 "abc") " :suffix"))
+(test "prefix: abcde :suffix"
+    (show #f "prefix: " (fitted 5 "abcde") " :suffix"))
+(test "prefix: abcde :suffix"
+    (show #f "prefix: " (fitted/left 5 "abcde") " :suffix"))
+(test "prefix: abcde :suffix"
+    (show #f "prefix: " (fitted/both 5 "abcde") " :suffix"))
+(test "prefix: abcde :suffix"
+    (show #f "prefix: " (fitted 5 "abcdefgh") " :suffix"))
+(test "prefix: defgh :suffix"
+    (show #f "prefix: " (fitted/left 5 "abcdefgh") " :suffix"))
+(test "prefix: bcdef :suffix"
+    (show #f "prefix: " (fitted/both 5 "abcdefgh") " :suffix"))
+
+;; joining
+
+(test "1 2 3" (show #f (joined each '(1 2 3) " ")))
+
+(test ":abc:123"
+    (show #f (joined/prefix
+              (lambda (x) (trimmed 3 x))
+              '("abcdef" "123456")
+              ":")))
+
+(test "abc\n123\n"
+    (show #f (joined/suffix
+              (lambda (x) (trimmed 3 x))
+              '("abcdef" "123456")
+              nl)))
+
+(test "lions, tigers, and bears"
+    (show #f (joined/last
+              each
+              (lambda (x) (each "and " x))
+              '(lions tigers bears)
+              ", ")))
+
+(test "lions, tigers, or bears"
+    (show #f (joined/dot
+              each
+              (lambda (x) (each "or " x))
+              '(lions tigers . bears)
+              ", ")))
+
+;; shared structures
+
+(test "#0=(1 . #0#)"
+    (show #f (written (let ((ones (list 1))) (set-cdr! ones ones) ones))))
+(test "(0 . #0=(1 . #0#))"
+    (show #f (written (let ((ones (list 1)))
+                        (set-cdr! ones ones)
+                        (cons 0 ones)))))
+(test "(sym . #0=(sym . #0#))"
+    (show #f (written (let ((syms (list 'sym)))
+                        (set-cdr! syms syms)
+                        (cons 'sym syms)))))
+(test "(#0=(1 . #0#) #1=(2 . #1#))"
+    (show #f (written (let ((ones (list 1))
+                            (twos (list 2)))
+                        (set-cdr! ones ones)
+                        (set-cdr! twos twos)
+                        (list ones twos)))))
+(test "(#0=(1 . #0#) #0#)"
+    (show #f (written (let ((ones (list 1)))
+                        (set-cdr! ones ones)
+                        (list ones ones)))))
+(test "((1) (1))"
+    (show #f (written (let ((ones (list 1)))
+                        (list ones ones)))))
+
+(test "(#0=(1) #0#)"
+    (show #f (written-shared (let ((ones (list 1)))
+                               (list ones ones)))))
+
+;; cycles without shared detection
+
+(test "(1 1 1 1 1"
+    (show #f (trimmed/lazy
+             10
+             (written-simply
+              (let ((ones (list 1))) (set-cdr! ones ones) ones)))))
+
+(test "(1 1 1 1 1 "
+    (show #f (trimmed/lazy
+             11
+             (written-simply
+              (let ((ones (list 1))) (set-cdr! ones ones) ones)))))
+
+;; pretty printing
+
+(define-syntax test-pretty
+  (syntax-rules ()
+    ((test-pretty str)
+     (let ((sexp (read (open-input-string str))))
+       (test str (show #f (pretty sexp)))))))
+
+(test-pretty "(foo bar)\n")
+
+(test-pretty
+"((self . aquanet-paper-1991)
+ (type . paper)
+ (title . \"Aquanet: a hypertext tool to hold your\"))
+")
+
+(test-pretty
+"(abracadabra xylophone
+             bananarama
+             yellowstonepark
+             cryptoanalysis
+             zebramania
+             delightful
+             wubbleflubbery)\n")
+
+(test-pretty
+ "#(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)\n")
+
+(test-pretty
+ "(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)\n")
+
+(test-pretty
+ "(define (fold kons knil ls)
+  (define (loop ls acc)
+    (if (null? ls) acc (loop (cdr ls) (kons (car ls) acc))))
+  (loop ls knil))\n")
+
+(test-pretty
+"(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) (vector-set! vec i i))\n")
+
+(test-pretty
+"(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec)
+  (vector-set! vec i 'supercalifrajalisticexpialidocious))\n")
+
+(test-pretty
+"(do ((my-vector (make-vector 5)) (index 0 (+ index 1)))
+    ((= index 5) my-vector)
+  (vector-set! my-vector index index))\n")
+
+(test-pretty
+ "(define (fold kons knil ls)
+  (let loop ((ls ls) (acc knil))
+    (if (null? ls) acc (loop (cdr ls) (kons (car ls) acc)))))\n")
+
+(test-pretty
+ "(define (file->sexp-list pathname)
+  (call-with-input-file pathname
+    (lambda (port)
+      (let loop ((res '()))
+        (let ((line (read port)))
+          (if (eof-object? line) (reverse res) (loop (cons line res))))))))\n")
+
+(test-pretty
+ "(design
+ (module (name \"\\\\testshiftregister\")
+         (attributes
+          (attribute (name \"\\\\src\") (value \"testshiftregister.v:10\"))))
+ (wire (name \"\\\\shreg\")
+       (attributes
+        (attribute (name \"\\\\src\") (value \"testshiftregister.v:15\")))))\n")
+
+(test "(let ((ones '#0=(1 . #0#))) ones)\n"
+    (show #f (pretty (let ((ones (list 1)))
+                       (set-cdr! ones ones)
+                       `(let ((ones ',ones)) ones)))))
+
+'(test
+"(let ((zeros '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
+      (ones '#0=(1 . #0#)))
+  (append zeros ones))\n"
+    (show #f (pretty
+              (let ((ones (list 1)))
+                (set-cdr! ones ones)
+                `(let ((zeros '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
+                       (ones ',ones))
+                   (append zeros ones))))))
+
+(test-end)
diff --git a/tests/sort-tests.scm b/tests/sort-tests.scm
new file mode 100644
index 00000000..6305539b
--- /dev/null
+++ b/tests/sort-tests.scm
@@ -0,0 +1,115 @@
+
+(cond-expand
+ (modules (import (srfi 95) (only (chibi test) test-begin test test-end)))
+ (else #f))
+
+(test-begin "sorting")
+
+(test "sort null" '() (sort '()))
+(test "sort null <" '() (sort '() <))
+(test "sort null < car" '() (sort '() < car))
+(test "sort equal list" '(0 0 0 0 0 0 0 0 0) (sort '(0 0 0 0 0 0 0 0 0)))
+(test "sort equal list cmp" '(0 0 0 0 0 0 0 0 0)
+  (sort '(0 0 0 0 0 0 0 0 0) (lambda (a b) (< a b))))
+(test "sort ordered list" '(1 2 3 4 5 6 7 8 9) (sort '(1 2 3 4 5 6 7 8 9)))
+(test "sort reversed list" '(1 2 3 4 5 6 7 8 9) (sort '(9 8 7 6 5 4 3 2 1)))
+(test "sort random list 1" '(1 2 3 4 5 6 7 8 9) (sort '(7 5 2 8 1 6 4 9 3)))
+(test "sort random list 2" '(1 2 3 4 5 6 7 8) (sort '(5 3 4 1 7 6 8 2)))
+(test "sort random list 3" '(1 2 3 4 5 6 7 8 9) (sort '(5 3 4 1 7 9 6 8 2)))
+(test "sort short equal list" '(0 0 0) (sort '(0 0 0)))
+(test "sort short random list" '(1 2 3) (sort '(2 1 3)))
+(test "sort short random list cmp" '(1 2 3) (sort '(2 1 3) (lambda (a b) (< a b))))
+(test "sort numeric list <" '(1 2 3 4 5 6 7 8 9)
+  (sort '(7 5 2 8 1 6 4 9 3) <))
+(test "sort numeric list < car" '((1) (2) (3) (4) (5) (6) (7) (8) (9))
+  (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) < car))
+(test "sort list (lambda (a b) (< (car a) (car b)))"
+    '((1) (2) (3) (4) (5) (6) (7) (8) (9))
+  (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3))
+        (lambda (a b) (< (car a) (car b)))))
+(test "sort 1-char symbols" '(a b c d e f g h i j k)
+  (sort '(h b k d a c j i e g f)))
+(test "sort short symbols" '(a aa b c d e ee f g h i j k)
+  (sort '(h b aa k d a ee c j i e g f)))
+(test "sort long symbol"
+    '(a aa b bzzzzzzzzzzzzzzzzzzzzzzz c d e ee f g h i j k)
+  (sort '(h b aa k d a ee c j i bzzzzzzzzzzzzzzzzzzzzzzz e g f)))
+(test "sort long symbols"
+    '(a aa b bzzzzzzzzzzzzzzzzzzzzzzz czzzzzzzzzzzzz dzzzzzzzz e ee f g h i j k)
+  (sort '(h b aa k dzzzzzzzz a ee czzzzzzzzzzzzz j i bzzzzzzzzzzzzzzzzzzzzzzz e g f)))
+(test "sort strings"
+    '("ape" "bear" "cat" "dog" "elephant" "fox" "goat" "hawk")
+  (sort '("elephant" "cat" "dog" "ape" "goat" "fox" "hawk" "bear")))
+(test "sort strings string-ci<?"
+    '("ape" "Bear" "CaT" "DOG" "elephant" "Fox" "GoAt" "HAWK")
+  (sort '("elephant" "CaT" "DOG" "ape" "GoAt" "Fox" "HAWK" "Bear")
+          string-ci<?))
+
+(test "sort lists"
+    '((chibi) (scheme r5rs) (scheme write))
+  (sort '((chibi) (scheme r5rs) (scheme write))
+        (lambda (a b)
+          (string<? (call-with-output-string (lambda (out) (write a out)))
+                    (call-with-output-string (lambda (out) (write b out)))))))
+
+(test "sort numeric inexact vector <" '#(1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8 9.9)
+  (sort '#(7.7 5.5 2.2 8.8 1.1 6.6 4.4 9.9 3.3) <))
+(test "sort numeric signed inexact vector <"
+    '#(-9.9 -7.7 -5.5 -3.3 -1.1 2.2 4.4 6.6 8.8)
+  (sort '#(-7.7 -5.5 2.2 8.8 -1.1 6.6 4.4 -9.9 -3.3) <))
+(test "sort numeric same whole number inexact vector"
+    '#(-5.2155
+       -4.3817
+       -4.3055
+       -4.0415
+       -3.5883
+       -3.5714
+       -3.4059
+       -2.7829
+       -2.6406
+       -2.4985
+       -2.4607
+       -1.2487
+       -0.537800000000001
+       -0.481999999999999
+       -0.469100000000001
+       -0.0932999999999993
+       0.0066999999999986)
+  (sort '#(-5.2155
+           -3.5714
+           -4.3817
+           -3.5883
+           -4.3055
+           -2.4985
+           -4.0415
+           -3.4059
+           -0.0932999999999993
+           -0.537800000000001
+           -2.6406
+           -0.481999999999999
+           -2.7829
+           -2.4607
+           -1.2487
+           -0.469100000000001
+           0.0066999999999986)
+        <))
+
+(test "sort watson no dups"
+    '#(-0.3096 -0.307000000000002 -0.303800000000003 -0.301600000000001
+       -0.300599999999999 -0.3003 -0.3002 -0.2942)
+  (sort '#(-0.3096 -0.307000000000002 -0.303800000000003 -0.301600000000001
+           -0.300599999999999 -0.2942 -0.3003 -0.3002)))
+
+(test "sort watson"
+    '#(-0.3096 -0.307000000000002 -0.303800000000003 -0.301600000000001
+       -0.300599999999999 -0.3003 -0.3003 -0.3002 -0.2942)
+  (sort '#(-0.3096 -0.307000000000002 -0.303800000000003 -0.301600000000001
+           -0.300599999999999 -0.2942 -0.3003 -0.3003 -0.3002)))
+
+(test "sort ratios" '(1/5 1/4 1/3 2/5 1/2 3/5 2/3 3/4 4/5)
+  (sort '(1/2 1/3 1/4 1/5 2/3 3/4 2/5 3/5 4/5)))
+
+(test "sort complex" '(1+1i 1+2i 1+3i 2+2i 3+3i 4+4i 5+5i 6+6i 7+7i 8+8i 9+9i)
+  (sort '(7+7i 1+2i 5+5i 2+2i 8+8i 1+1i 6+6i 4+4i 9+9i 1+3i 3+3i)))
+
+(test-end)
diff --git a/tests/srfi-1-tests.scm b/tests/srfi-1-tests.scm
new file mode 100644
index 00000000..8719ef80
--- /dev/null
+++ b/tests/srfi-1-tests.scm
@@ -0,0 +1,170 @@
+(import (chibi) (chibi test) (srfi 1))
+
+(test-begin "srfi-1")
+
+;; srfi-1 examples
+;; http://srfi.schemers.org/srfi-1/srfi-1.html
+(test '(a) (cons 'a '()))
+(test '((a) b c d) (cons '(a) '(b c d)))
+(test '("a" b c) (cons "a" '(b c)))
+(test '(a . 3) (cons 'a 3))
+(test '((a b) . c) (cons '(a b) 'c))
+(test '(a 7 c) (list 'a (+ 3 4) 'c))
+(test '() (list))
+(test '(a b c) (xcons '(b c) 'a))
+(test '(1 2 3 . 4) (cons* 1 2 3 4))
+(test 1 (cons* 1))
+(test '(c c c c) (make-list 4 'c))
+(test '(0 1 2 3) (list-tabulate 4 values))
+(test '(z q z q z q) (take (circular-list 'z 'q) 6))
+(test '(0 1 2 3 4) (iota 5))
+(test '(0 -0.1 -0.2 -0.3 -0.4)
+    (let ((res (iota 5 0 -0.1)))
+      (cons (inexact->exact (car res)) (cdr res))))
+(test #t (pair? '(a . b)))
+(test #t (pair? '(a b c)))
+(test #f (pair? '()))
+(test #f (pair? '#(a b)))
+(test #f (pair? 7))
+(test #f (pair? 'a))
+(test #t (list= eq?))
+(test #t (list= eq? '(a)))
+(test 'a (car '(a b c)))
+(test '(b c)   (cdr '(a b c)))
+(test '(a) (car '((a) b c d)))
+(test '(b c d) (cdr '((a) b c d)))
+(test '1 (car '(1 . 2)))
+(test '2 (cdr '(1 . 2)))
+(test-error (car '()))
+(test-error (cdr '()))
+(test 'c (list-ref '(a b c d) 2))
+(test 'c (third '(a b c d e)))
+(test '(a b) (take '(a b c d e)  2))
+(test '(c d e) (drop '(a b c d e)  2))
+(test '(1 2) (take '(1 2 3 . d) 2))
+(test '(3 . d) (drop '(1 2 3 . d) 2))
+(test '(1 2 3) (take '(1 2 3 . d) 3))
+(test 'd (drop '(1 2 3 . d) 3))
+(test '(d e) (take-right '(a b c d e) 2))
+(test '(a b c) (drop-right '(a b c d e) 2))
+(test '(2 3 . d) (take-right '(1 2 3 . d) 2))
+(test '(1) (drop-right '(1 2 3 . d) 2))
+(test 'd (take-right '(1 2 3 . d) 0))
+(test '(1 2 3) (drop-right '(1 2 3 . d) 0))
+(test-assert (member (take! (circular-list 1 3 5) 8) '((1 3) (1 3 5 1 3 5 1 3)) equal?))
+(test-values (values '(a b c) '(d e f g h)) (split-at '(a b c d e f g h) 3))
+(test 'c (last '(a b c)))
+(test '(c) (last-pair '(a b c)))
+(test '(x y) (append '(x) '(y)))
+(test '(a b c d) (append '(a) '(b c d)))
+(test '(a (b) (c)) (append '(a (b)) '((c))))
+(test '(a b c . d) (append '(a b) '(c . d)))
+(test 'a (append '() 'a))
+(test '(x y) (append '(x y)))
+(test '() (append))
+(test '(c b a) (reverse '(a b c)))
+(test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f)))))
+(test '((one 1 odd) (two 2 even) (three 3 odd)) (zip '(one two three) '(1 2 3) '(odd even odd even odd even odd even)))
+(test '((1) (2) (3)) (zip '(1 2 3)))
+(test '((3 #f) (1 #t) (4 #f) (1 #t)) (zip '(3 1 4 1) (circular-list #f #t)))
+(test-values (values '(1 2 3) '(one two three)) (unzip2 '((1 one) (2 two) (3 three))))
+(test 3 (count even? '(3 1 4 1 5 9 2 5 6)))
+(test 3 (count < '(1 2 4 8) '(2 4 6 8 10 12 14 16)))
+(test 2 (count < '(3 1 4 1) (circular-list 1 10)))
+(test '(c 3 b 2 a 1) (fold cons* '() '(a b c) '(1 2 3 4 5)))
+(test '(a 1 b 2 c 3) (fold-right cons* '() '(a b c) '(1 2 3 4 5)))
+(test '((a b c) (b c) (c)) (pair-fold-right cons '() '(a b c)))
+(test '((a b c) (1 2 3) (b c) (2 3) (c) (3)) (pair-fold-right cons* '() '(a b c) '(1 2 3)))
+(test '(b e h) (map cadr '((a b) (d e) (g h))))
+(test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5)))
+(test '(5 7 9) (map + '(1 2 3) '(4 5 6)))
+(test-assert (member (let ((count 0)) (map (lambda (ignored) (set! count (+ count 1)) count) '(a b))) '((1 2) (2 1)) equal?))
+(test '(4 1 5 1) (map + '(3 1 4 1) (circular-list 1 0)))
+(test '#(0 1 4 9 16) (let ((v (make-vector 5))) (for-each (lambda (i) (vector-set! v i (* i i))) '(0 1 2 3 4)) v))
+(test '(1 -1 3 -3 8 -8) (append-map (lambda (x) (list x (- x))) '(1 3 8)))
+(test '(1 -1 3 -3 8 -8) (apply append (map (lambda (x) (list x (- x))) '(1 3 8))))
+(test '(1 -1 3 -3 8 -8) (append-map! (lambda (x) (list x (- x))) '(1 3 8)))
+(test '(1 -1 3 -3 8 -8) (apply append! (map (lambda (x) (list x (- x))) '(1 3 8))))
+(test "pair-for-each-1" '((a b c) (b c) (c))
+      (let ((a '()))
+        (pair-for-each (lambda (x) (set! a (cons x a))) '(a b c))
+        (reverse a)))
+(test '(1 9 49) (filter-map (lambda (x) (and (number? x) (* x x))) '(a 1 b 3 c 7)))
+(test '(0 8 8 -4) (filter even? '(0 7 8 8 43 -4)))
+(test-values (values '(one four five) '(2 3 6)) (partition symbol? '(one 2 3 four five 6)))
+(test '(7 43) (remove even? '(0 7 8 8 43 -4)))
+(test 2 (find even? '(1 2 3)))
+(test #t (any  even? '(1 2 3)))
+(test #f (find even? '(1 7 3)))
+(test #f (any  even? '(1 7 3)))
+;(test-error (find even? '(1 3 . x)))
+;(test-error (any  even? '(1 3 . x)))
+;(test 'error/undefined (find even? '(1 2 . x)))
+;(test 'error/undefined (any  even? '(1 2 . x))) ; success, error or other
+(test 6 (find even? (circular-list 1 6 3)))
+(test #t (any  even? (circular-list 1 6 3)))
+;(test-error (find even? (circular-list 1 3))) ; divergent
+;(test-error (any even? (circular-list 1 3))) ; divergent
+(test 4 (find even? '(3 1 4 1 5 9)))
+(test #f (every odd? '(1 2 3)))
+(test #t (every < '(1 2 3) '(4 5 6)))
+(test-error (every odd? '(1 3 . x)))
+(test '(-8 -5 0 0) (find-tail even? '(3 1 37 -8 -5 0 0)))
+(test '#f (find-tail even? '(3 1 37 -5)))
+(test '(2 18) (take-while even? '(2 18 3 10 22 9)))
+(test '(3 10 22 9) (drop-while even? '(2 18 3 10 22 9)))
+(test-values (values '(2 18) '(3 10 22 9)) (span even? '(2 18 3 10 22 9)))
+(test-values (values '(3 1) '(4 1 5 9)) (break even? '(3 1 4 1 5 9)))
+(test #t (any integer? '(a 3 b 2.7)))
+(test #f (any integer? '(a 3.1 b 2.7)))
+(test #t (any < '(3 1 4 1 5) '(2 7 1 8 2)))
+(test 2 (list-index even? '(3 1 4 1 5 9)))
+(test 1 (list-index < '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
+(test #f (list-index = '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
+(test '(a b c) (memq 'a '(a b c)))
+(test '(b c) (memq 'b '(a b c)))
+(test #f (memq 'a '(b c d)))
+(test #f (memq (list 'a) '(b (a) c)))
+(test '((a) c) (member (list 'a) '(b (a) c)))
+;(test '*unspecified* (memq 101 '(100 101 102)))
+(test '(101 102) (memv 101 '(100 101 102)))
+(test '(a b c z) (delete-duplicates '(a b a c a b c z)))
+(test '((a . 3) (b . 7) (c . 1)) (delete-duplicates '((a . 3) (b . 7) (a . 9) (c . 1)) (lambda (x y) (eq? (car x) (car y)))))
+(let ((e '((a 1) (b 2) (c 3))))
+  (test '(a 1) (assq 'a e))
+  (test '(b 2) (assq 'b e))
+  (test #f (assq 'd e))
+  (test #f (assq (list 'a) '(((a)) ((b)) ((c)))))
+  (test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c)))))
+  ;(test '*unspecified* (assq 5 '((2 3) (5 7) (11 13))))
+  (test '(5 7) (assv 5 '((2 3) (5 7) (11 13)))))
+(test #t (lset<= eq? '(a) '(a b a) '(a b c c)))
+(test #t (lset<= eq?))
+(test #t (lset<= eq? '(a)))
+(test #f (lset= eq? '(a) '()))
+(test #f (lset= eq? '() '(a)))
+(test #t (lset= eq? '(b e a) '(a e b) '(e e b a)))
+(test #t (lset= eq?))
+(test #t (lset= eq? '(a)))
+(test #f (lset= = '(2 1) '(2 1 0)))
+(test #t (lset<= = '(2 1) '(2 1 0)))
+(test #f (lset<= = '(2 1 0) '(2 1)))
+(test '(u o i a b c d c e) (lset-adjoin eq? '(a b c d c e) 'a 'e 'i 'o 'u))
+(test '(u o i a b c d e) (lset-union eq? '(a b c d e) '(a e i o u)))
+(test '(x a a c) (lset-union eq? '(a a c) '(x a x)))
+(test '() (lset-union eq?))
+(test '(a b c) (lset-union eq? '(a b c)))
+(test '(a e) (lset-intersection eq? '(a b c d e) '(a e i o u)))
+(test '(a x a) (lset-intersection eq? '(a x y a) '(x a x z)))
+(test '(a b c) (lset-intersection eq? '(a b c)))
+(test '(b c d) (lset-difference eq? '(a b c d e) '(a e i o u)))
+(test '(a b c) (lset-difference eq? '(a b c)))
+(test #t (lset= eq? '(d c b i o u) (lset-xor eq? '(a b c d e) '(a e i o u))))
+(test '() (lset-xor eq?))
+(test '(a b c d e) (lset-xor eq? '(a b c d e)))
+(let ((f (lambda () (list 'not-a-constant-list)))
+      (g (lambda () '(constant-list))))
+  ;(test '*unspecified* (set-car! (f) 3))
+  (test-error (set-car! (g) 3)))
+
+(test-end)
diff --git a/tests/srfi-16-tests.scm b/tests/srfi-16-tests.scm
new file mode 100644
index 00000000..edb00495
--- /dev/null
+++ b/tests/srfi-16-tests.scm
@@ -0,0 +1,45 @@
+
+(cond-expand
+ (modules (import (chibi) (chibi test) (srfi 16)))
+ (else #f))
+
+(define plus
+  (case-lambda 
+   (() 0)
+   ((x) x)
+   ((x y) (+ x y))
+   ((x y z) (+ (+ x y) z))
+   (args (apply + args))))
+
+(test-begin "case-lambda")
+
+(test 0 (plus))
+(test 1 (plus 1))
+(test 6 (plus 1 2 3))
+(test-error ((case-lambda ((a) a) ((a b) (* a b))) 1 2 3))
+
+(define print
+  (case-lambda
+   (()
+    (display ""))
+   ((arg)
+    (display arg))
+   ((arg . args)
+    (display arg)
+    (display " ")
+    (apply print args))))
+
+(define (print-to-string . args)
+  (let ((out (open-output-string))
+        (old-out (current-output-port)))
+    (dynamic-wind
+      (lambda () (current-output-port out))
+      (lambda () (apply print args))
+      (lambda () (current-output-port old-out)))
+    (get-output-string out)))
+
+(test "" (print-to-string))
+(test "hi" (print-to-string 'hi))
+(test "hi there world" (print-to-string 'hi 'there 'world))
+
+(test-end)
diff --git a/tests/srfi-2-tests.scm b/tests/srfi-2-tests.scm
new file mode 100644
index 00000000..c083c238
--- /dev/null
+++ b/tests/srfi-2-tests.scm
@@ -0,0 +1,43 @@
+
+(import (chibi) (srfi 2) (chibi test))
+
+(test-begin "srfi-2")
+
+(test 1 (and-let* () 1))
+(test 2 (and-let* () 1 2))
+(test #t (and-let* () ))
+
+(test #f (let ((x #f)) (and-let* (x))))
+(test 1 (let ((x 1)) (and-let* (x))))
+(test #f (and-let* ((x #f)) ))
+(test 1 (and-let* ((x 1)) ))
+;; (test-syntax-error (and-let* ( #f (x 1))))
+(test #f (and-let* ( (#f) (x 1)) ))
+;; (test-syntax-error (and-let* (2 (x 1))))
+(test 1 (and-let* ( (2) (x 1)) ))
+(test 2 (and-let* ( (x 1) (2)) ))
+(test #f (let ((x #f)) (and-let* (x) x)))
+(test "" (let ((x "")) (and-let* (x) x)))
+(test "" (let ((x "")) (and-let* (x)  )))
+(test 2 (let ((x 1)) (and-let* (x) (+ x 1))))
+(test #f (let ((x #f)) (and-let* (x) (+ x 1))))
+(test 2 (let ((x 1)) (and-let* (((positive? x))) (+ x 1))))
+(test #t (let ((x 1)) (and-let* (((positive? x))) )))
+(test #f (let ((x 0)) (and-let* (((positive? x))) (+ x 1))))
+(test 3  (let ((x 1)) (and-let* (((positive? x)) (x (+ x 1))) (+ x 1))))
+(test 4
+    (let ((x 1))
+      (and-let* (((positive? x)) (x (+ x 1)) (x (+ x 1))) (+ x 1))))
+
+(test 2 (let ((x 1)) (and-let* (x ((positive? x))) (+ x 1))))
+(test 2 (let ((x 1)) (and-let* ( ((begin x)) ((positive? x))) (+ x 1))))
+(test #f (let ((x 0)) (and-let* (x ((positive? x))) (+ x 1))))
+(test #f (let ((x #f)) (and-let* (x ((positive? x))) (+ x 1))))
+(test #f (let ((x #f)) (and-let* ( ((begin x)) ((positive? x))) (+ x 1))))
+
+(test  #f (let ((x 1)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))))
+(test  #f (let ((x 0)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))))
+(test  #f (let ((x #f)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))))
+(test  3/2 (let ((x 3)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))))
+
+(test-end)
diff --git a/tests/srfi-26-tests.scm b/tests/srfi-26-tests.scm
new file mode 100644
index 00000000..0051aa2f
--- /dev/null
+++ b/tests/srfi-26-tests.scm
@@ -0,0 +1,16 @@
+
+(import (chibi) (srfi 26) (chibi test))
+
+(test-begin "srfi-26")
+
+(let ((x 'orig))
+  (let ((f (cute list x)))
+    (set! x 'wrong)
+    (test '(orig) (f))))
+
+(let ((x 'wrong))
+  (let ((f (cut list x)))
+    (set! x 'right)
+    (test '(right) (f))))
+
+(test-end)
diff --git a/tests/srfi-27-tests.scm b/tests/srfi-27-tests.scm
new file mode 100644
index 00000000..ebdb4d65
--- /dev/null
+++ b/tests/srfi-27-tests.scm
@@ -0,0 +1,28 @@
+
+(import (chibi)
+        (srfi 27)
+        (chibi test))
+
+(test-begin "srfi-27")
+
+(define (test-random rand n)
+  (test-assert (<= 0 (rand n) (- n 1))))
+
+(let ((rs (make-random-source)))
+  ;; chosen by fair dice roll.  guaranteed to be random
+  (random-source-pseudo-randomize! rs 4 4)
+  (let ((rand (random-source-make-integers rs)))
+    (do ((k 0 (+ k 5))
+         (n 1 (* n 2)))
+        ((> k 1024))
+      (test-random rand n))
+    (let* ((state (random-source-state-ref rs))
+           (x (rand 1000000)))
+      ;; the next int won't be the same, but it will be after
+      ;; resetting the state
+      (test-not (= x (rand 1000000)))
+      (random-source-state-set! rs state)
+      ;; (test x (rand 1000000))
+      )))
+
+(test-end)
diff --git a/tests/srfi-33-tests.scm b/tests/srfi-33-tests.scm
new file mode 100644
index 00000000..5ae7b494
--- /dev/null
+++ b/tests/srfi-33-tests.scm
@@ -0,0 +1,61 @@
+
+(import (chibi) (srfi 33) (chibi test))
+
+(test-begin "srfi-33")
+
+(test 0 (bitwise-and #b0 #b1))
+(test 1 (bitwise-and #b1 #b1))
+(test 0 (bitwise-and #b1 #b10))
+(test #b10 (bitwise-and #b11 #b10))
+(test #b101 (bitwise-and #b101 #b111))
+(test #b111 (bitwise-and -1 #b111))
+(test #b110 (bitwise-and -2 #b111))
+(test 3769478 (bitwise-and -4290775858 1694076839))
+(test 1680869008 (bitwise-and -193073517 1689392892))
+;; (test -2600468497 (bitwise-ior 1694076839 -4290775858))
+;; (test -184549633 (bitwise-ior -193073517 1689392892))
+;; (test -2604237975 (bitwise-xor 1694076839 -4290775858))
+;; (test -1865418641 (bitwise-xor -193073517 1689392892))
+
+(test 1 (arithmetic-shift 1 0))
+(test 2 (arithmetic-shift 1 1))
+(test 4 (arithmetic-shift 1 2))
+(test 8 (arithmetic-shift 1 3))
+(test 16 (arithmetic-shift 1 4))
+(test (expt 2 31) (arithmetic-shift 1 31))
+(test (expt 2 32) (arithmetic-shift 1 32))
+(test (expt 2 33) (arithmetic-shift 1 33))
+(test (expt 2 63) (arithmetic-shift 1 63))
+(test (expt 2 64) (arithmetic-shift 1 64))
+(test (expt 2 65) (arithmetic-shift 1 65))
+(test (expt 2 127) (arithmetic-shift 1 127))
+(test (expt 2 128) (arithmetic-shift 1 128))
+(test (expt 2 129) (arithmetic-shift 1 129))
+(test 3028397001194014464 (arithmetic-shift 11829675785914119 8))
+
+(test -1 (arithmetic-shift -1 0))
+(test -2 (arithmetic-shift -1 1))
+(test -4 (arithmetic-shift -1 2))
+(test -8 (arithmetic-shift -1 3))
+(test -16 (arithmetic-shift -1 4))
+(test (- (expt 2 31)) (arithmetic-shift -1 31))
+(test (- (expt 2 32)) (arithmetic-shift -1 32))
+(test (- (expt 2 33)) (arithmetic-shift -1 33))
+(test (- (expt 2 63)) (arithmetic-shift -1 63))
+(test (- (expt 2 64)) (arithmetic-shift -1 64))
+(test (- (expt 2 65)) (arithmetic-shift -1 65))
+(test (- (expt 2 127)) (arithmetic-shift -1 127))
+(test (- (expt 2 128)) (arithmetic-shift -1 128))
+(test (- (expt 2 129)) (arithmetic-shift -1 129))
+
+(test 0 (arithmetic-shift 1 -63))
+(test 0 (arithmetic-shift 1 -64))
+(test 0 (arithmetic-shift 1 -65))
+
+(test #x1000000000000000100000000000000000000000000000000
+    (arithmetic-shift #x100000000000000010000000000000000 64))
+
+(test-not (bit-set? 64 1))
+(test-assert (bit-set? 64 #x10000000000000000))
+
+(test-end)
diff --git a/tests/srfi-38-tests.scm b/tests/srfi-38-tests.scm
new file mode 100644
index 00000000..da0fe7b5
--- /dev/null
+++ b/tests/srfi-38-tests.scm
@@ -0,0 +1,98 @@
+
+(cond-expand
+ (chibi (import (chibi) (chibi test) (srfi 1) (srfi 38)))
+ (chicken (use chicken test srfi-38)))
+
+(test-begin "read/write")
+
+(define (read-from-string str)
+  (call-with-input-string str
+    (lambda (in) (read/ss in))))
+
+(define (write-to-string x . o)
+  (call-with-output-string
+    (lambda (out) (apply write/ss x out o))))
+
+(define-syntax test-io
+  (syntax-rules ()
+    ((test-io str-expr expr)
+     (let ((str str-expr)
+           (value expr))
+       (test str (write-to-string value))
+       (test str (write-to-string (read-from-string str)))))))
+
+(define-syntax test-cyclic-io
+  (syntax-rules ()
+    ((test-io str-expr expr)
+     (let ((str str-expr)
+           (value expr))
+       (test str (write-to-string value #t))
+       (test str (write-to-string (read-from-string str) #t))))))
+
+(test-io "(1)" (list 1))
+(test-io "(1 2)" (list 1 2))
+(test-io "(1 . 2)" (cons 1 2))
+
+(test-io "#0=(1 . #0#)" (circular-list 1))
+(test-io "#0=(1 2 . #0#)" (circular-list 1 2))
+(test-io "(1 . #0=(2 . #0#))" (cons 1 (circular-list 2)))
+(test-io "#0=(1 #0# 3)"
+         (let ((x (list 1 2 3))) (set-car! (cdr x) x) x))
+(test-io "(#0=(1 #0# 3))"
+         (let ((x (list 1 2 3))) (set-car! (cdr x) x) (list x)))
+(test-io "(#0=(1 #0# 3) #0#)"
+         (let ((x (list 1 2 3))) (set-car! (cdr x) x) (list x x)))
+(test-io "(#0=(1 . #0#) #1=(1 . #1#))"
+         (list (circular-list 1) (circular-list 1)))
+
+(test-io "(#0=(1 . 2) #1=(1 . 2) #2=(3 . 4) #0# #1# #2#)"
+         (let ((a (cons 1 2)) (b (cons 1 2)) (c (cons 3 4)))
+           (list a b c a b c)))
+(test-cyclic-io "((1 . 2) (1 . 2) (3 . 4) (1 . 2) (1 . 2) (3 . 4))"
+                (let ((a (cons 1 2)) (b (cons 1 2)) (c (cons 3 4)))
+                  (list a b c a b c)))
+(test-cyclic-io "#0=((1 . 2) (1 . 2) (3 . 4) . #0#)"
+                (let* ((a (cons 1 2))
+                       (b (cons 1 2))
+                       (c (cons 3 4))
+                       (ls (list a b c)))
+                  (set-cdr! (cddr ls) ls)
+                  ls))
+
+(test-io "#0=#(#0#)"
+         (let ((x (vector 1))) (vector-set! x 0 x) x))
+(test-io "#0=#(1 #0#)"
+         (let ((x (vector 1 2))) (vector-set! x 1 x) x))
+(test-io "#0=#(1 #0# 3)"
+         (let ((x (vector 1 2 3))) (vector-set! x 1 x) x))
+(test-io "(#0=#(1 #0# 3))"
+         (let ((x (vector 1 2 3))) (vector-set! x 1 x) (list x)))
+(test-io "#0=#(#0# 2 #0#)"
+         (let ((x (vector 1 2 3)))
+           (vector-set! x 0 x)
+           (vector-set! x 2 x)
+           x))
+
+(test 255 (read-from-string "#xff"))
+(test 99 (read-from-string "#d99"))
+(test 63 (read-from-string "#o77"))
+(test 3 (read-from-string "#b11"))
+(test 5 (read-from-string "#e5.0"))
+(test 5.0 (read-from-string "#i5"))
+(test 15 (read-from-string "#e#xf"))
+(test 15.0 (read-from-string "#i#xf"))
+(test (expt 10 100) (read-from-string "#e1e100"))
+
+(cond-expand
+ (chicken
+  (test-io "(#0=\"abc\" #0# #0#)"
+           (let ((str (string #\a #\b #\c))) (list str str str)))
+  (test "(\"abc\" \"abc\" \"abc\")"
+      (let ((str (string #\a #\b #\c)))
+        (call-with-output-string
+          (lambda (out)
+            (write/ss (list str str str) out ignore-strings: #t))))))
+ (else
+  ))
+
+(test-end)
diff --git a/tests/string-tests.scm b/tests/string-tests.scm
new file mode 100644
index 00000000..2cf481b3
--- /dev/null
+++ b/tests/string-tests.scm
@@ -0,0 +1,82 @@
+
+(cond-expand
+ (modules (import (only (chibi test) test-begin test test-end)
+                  (chibi string)))
+ (else #f))
+
+(test-begin "strings")
+
+(test #t (string-null? ""))
+(test #f (string-null? " "))
+
+(test #t (string-every char-alphabetic? "abc"))
+(test #f (string-every char-alphabetic? "abc0"))
+(test #f (string-every char-alphabetic? " abc"))
+(test #f (string-every char-alphabetic? "a.c"))
+
+(define (digit-value ch)
+  (case ch
+    ((#\0) 0) ((#\1) 1) ((#\2) 2) ((#\3) 3) ((#\4) 4)
+    ((#\5) 5) ((#\6) 6) ((#\7) 7) ((#\8) 8) ((#\9) 9) (else #f)))
+
+(test 3 (string-any digit-value "a3c"))
+(test #f (string-any digit-value "abc"))
+
+(test 0 (string-find "abc" char-alphabetic?))
+(test 3 (string-find "abc0" char-numeric?))
+(test 3 (string-find "abc" char-numeric?))
+
+(test 3 (string-find-right "abc" char-alphabetic?))
+(test 4 (string-find-right "abc0" char-numeric?))
+(test 0 (string-find-right "abc" char-numeric?))
+
+(test 0 (string-skip "abc" char-numeric?))
+(test 3 (string-skip "abc0" char-alphabetic?))
+(test 3 (string-skip "abc" char-alphabetic?))
+
+(test 3 (string-skip-right "abc" char-numeric?))
+(test 4 (string-skip-right "abc0" char-alphabetic?))
+(test 0 (string-skip-right "abc" char-alphabetic?))
+
+(test "foobarbaz" (string-join '("foo" "bar" "baz")))
+(test "foo bar baz" (string-join '("foo" "bar" "baz") " "))
+
+(test '() (string-split ""))
+(test '("" "") (string-split " "))
+(test '("foo" "bar" "baz") (string-split "foo bar baz"))
+(test '("foo" "bar" "baz" "") (string-split "foo bar baz "))
+(test '("foo" "bar" "baz") (string-split "foo:bar:baz" #\:))
+(test '("" "foo" "bar" "baz") (string-split ":foo:bar:baz" #\:))
+(test '("foo" "bar" "baz" "") (string-split "foo:bar:baz:" #\:))
+(test '("foo" "bar:baz") (string-split "foo:bar:baz" #\: 2))
+
+(test "abc" (string-trim-left "  abc"))
+(test "abc  " (string-trim-left "abc  "))
+(test "abc  " (string-trim-left "  abc  "))
+
+(test "  abc" (string-trim-right "  abc"))
+(test "abc" (string-trim-right "abc  "))
+(test "  abc" (string-trim-right "  abc  "))
+
+(test "abc" (string-trim "  abc"))
+(test "abc" (string-trim "abc  "))
+(test "abc" (string-trim "  abc  "))
+(test "" (string-trim ""))
+(test "" (string-trim " "))
+(test "" (string-trim "  "))
+
+(test #t (string-prefix? "abc" "abc"))
+(test #t (string-prefix? "abc" "abcde"))
+(test #f (string-prefix? "abcde" "abc"))
+
+(test #t (string-suffix? "abc" "abc"))
+(test #f (string-suffix? "abc" "abcde"))
+(test #f (string-suffix? "abcde" "abc"))
+(test #f (string-suffix? "abcde" "cde"))
+(test #t (string-suffix? "cde" "abcde"))
+
+(test 3 (string-count "!a0 bc /.," char-alphabetic?))
+
+(test "ABC" (string-map char-upcase "abc"))
+
+(test-end)
diff --git a/tests/system-tests.scm b/tests/system-tests.scm
new file mode 100644
index 00000000..a7585896
--- /dev/null
+++ b/tests/system-tests.scm
@@ -0,0 +1,35 @@
+
+(cond-expand
+ (modules (import (chibi system) (only (chibi test) test-begin test test-end)))
+ (else #f))
+
+(test-begin "system")
+
+(test #t (user? (user-information (current-user-id))))
+(test #f (user? #f))
+(test #f (user? (list #f)))
+(test #t (string? (user-name (user-information (current-user-id)))))
+(test #t (string? (user-password (user-information (current-user-id)))))
+(test #t (integer? (user-id (user-information (current-user-id)))))
+(test #t (integer? (user-group-id (user-information (current-user-id)))))
+(test #t (string? (user-gecos (user-information (current-user-id)))))
+(test #t (string? (user-home (user-information (current-user-id)))))
+(test #t (string? (user-shell (user-information (current-user-id)))))
+
+(test (current-user-id) (user-id (user-information (current-user-id))))
+(test (current-group-id) (user-group-id (user-information (current-user-id))))
+
+(test (user-id (user-information (current-user-id)))
+    (user-id (user-information (user-name (user-information (current-user-id))))))
+
+(test #t (integer? (current-session-id)))
+
+;; stress test user-name
+(test (user-name (user-information (current-user-id)))
+    (user-name (user-information (current-user-id))))
+(define u (user-information (current-user-id)))
+(test (user-name u) (user-name (user-information (current-user-id))))
+(define un (user-name (user-information (current-user-id))))
+(test un (user-name (user-information (current-user-id))))
+
+(test-end)
diff --git a/tests/tar-tests.scm b/tests/tar-tests.scm
new file mode 100644
index 00000000..d57c048f
--- /dev/null
+++ b/tests/tar-tests.scm
@@ -0,0 +1,73 @@
+
+(import (chibi)
+        (only (scheme base)
+              bytevector-append
+              make-bytevector
+              string->utf8
+              bytevector
+              open-input-bytevector
+              open-output-bytevector
+              get-output-bytevector
+              )
+        (chibi tar)
+        (chibi test))
+
+(test-begin "tar")
+
+;; Utility to flatten bytevectors, strings and individual bytes
+;; (integers) into a single bytevector for generating readable test
+;; data.  (<byte> . <repetition>) can be used to repeat a byte.
+(define (bv . args)
+  (apply bytevector-append
+         (map (lambda (x)
+                (cond ((string? x) (string->utf8 x))
+                      ((pair? x) (make-bytevector (cdr x) (car x)))
+                      ((integer? x) (bytevector x))
+                      (else x)))
+              args)))
+
+(let ((b (bv "foo" '(0 . 97)
+             "000644 " 0
+             "000765 " 0
+             "000765 " 0
+             "00000000016 "
+             "12302104616 "
+             "011512" 0 " "
+             "0"
+             '(0 . 100)
+             "ustar" 0 "00"
+             "bob" '(0 . 29)
+             "bob" '(0 . 29)
+             "000000 " 0
+             "000000 " 0
+             '(0 . 155)
+             '(0 . 12)
+             )))
+  (let ((x (read-tar (open-input-bytevector b))))
+    (test "foo" (tar-path x))
+    (test 501 (tar-uid x))
+    (test "bob" (tar-owner x)))
+  (let ((x (make-tar)))
+    (tar-path-set! x "bar")
+    (tar-mode-set! x #o644)
+    (tar-uid-set! x 501)
+    (tar-gid-set! x 502)
+    (tar-size-set! x 123)
+    (tar-time-set! x 456)
+    (tar-ustar-set! x "ustar")
+    (tar-owner-set! x "john")
+    (tar-group-set! x "john")
+    (test "bar" (tar-path x))
+    (test-error (tar-mode-set! x "r"))
+    (let ((out (open-output-bytevector)))
+      (write-tar x out)
+      (let ((bv2 (get-output-bytevector out)))
+        (test-assert (bytevector? bv2))
+        (let ((x2 (read-tar (open-input-bytevector bv2))))
+          (test-assert "bar" (tar-path x2))
+          (test-assert #o644 (tar-mode x2))
+          (test-assert 501 (tar-uid x2))
+          (test-assert 502 (tar-gid x2))
+          (test-assert "john" (tar-owner x2)))))))
+
+(test-end)
diff --git a/tests/term-ansi-tests.scm b/tests/term-ansi-tests.scm
new file mode 100644
index 00000000..aba89e2c
--- /dev/null
+++ b/tests/term-ansi-tests.scm
@@ -0,0 +1,170 @@
+(import (chibi)
+        (only (scheme base) parameterize)
+        (chibi test)
+        (chibi term ansi))
+
+(test-begin "term.ansi")
+
+(test-assert (procedure? ansi-escapes-enabled?))
+(test-assert
+ (let ((tag (cons #t #t)))
+   (eqv? tag
+         (parameterize ((ansi-escapes-enabled? tag))
+           (ansi-escapes-enabled?)))))
+
+(define-syntax test-escape-procedure
+  (syntax-rules ()
+    ((test-escape-procedure p s)
+     (begin
+       (test-assert (procedure? p))
+       (test-error (p #f))
+       (test s (p))))))
+
+(define-syntax test-wrap-procedure
+  (syntax-rules ()
+    ((test-wrap-procedure p s)
+     (begin
+       (test-assert (procedure? p))
+       (test-error (p))
+       (test-error (p #f))
+       (test-error (p "" #f))
+       (test (p "FOO")
+             "FOO"
+             (parameterize ((ansi-escapes-enabled? #f)) (p "FOO")))
+       (test (p "FOO")
+             s
+             (parameterize ((ansi-escapes-enabled? #t)) (p "FOO")))))))
+
+(test-escape-procedure black-escape       "\x1b;[30m")
+(test-escape-procedure red-escape         "\x1b;[31m")
+(test-escape-procedure green-escape       "\x1b;[32m")
+(test-escape-procedure yellow-escape      "\x1b;[33m")
+(test-escape-procedure blue-escape        "\x1b;[34m")
+(test-escape-procedure cyan-escape        "\x1b;[36m")
+(test-escape-procedure magenta-escape     "\x1b;[35m")
+(test-escape-procedure white-escape       "\x1b;[37m")
+(test-escape-procedure reset-color-escape "\x1b;[39m")
+
+(test-assert (procedure? rgb-escape))
+(test-error (rgb-escape))
+(test-error (rgb-escape 0))
+(test-error (rgb-escape 0 0))
+(test-error (rgb-escape 0 0 0 0))
+(test-error (rgb-escape 0.0 0 0))
+(test-error (rgb-escape 0 0.0 0))
+(test-error (rgb-escape 0 0 0.0))
+(test-error (rgb-escape -1 0 0))
+(test-error (rgb-escape 0 -1 0))
+(test-error (rgb-escape 0 0 -1))
+(test-error (rgb-escape 6 0 0))
+(test-error (rgb-escape 0 6 0))
+(test-error (rgb-escape 0 0 6))
+(test-escape-procedure (lambda () (rgb-escape 0 0 0)) "\x1B[38;5;16m")
+(test-escape-procedure (lambda () (rgb-escape 5 0 0)) "\x1B[38;5;196m")
+(test-escape-procedure (lambda () (rgb-escape 0 5 0)) "\x1B[38;5;46m")
+(test-escape-procedure (lambda () (rgb-escape 0 0 5)) "\x1B[38;5;21m")
+(test-escape-procedure (lambda () (rgb-escape 1 1 1)) "\x1B[38;5;59m")
+(test-escape-procedure (lambda () (rgb-escape 2 2 2)) "\x1B[38;5;102m")
+(test-escape-procedure (lambda () (rgb-escape 3 3 3)) "\x1B[38;5;145m")
+(test-escape-procedure (lambda () (rgb-escape 4 4 4)) "\x1B[38;5;188m")
+(test-escape-procedure (lambda () (rgb-escape 5 5 5)) "\x1B[38;5;231m")
+(test-escape-procedure (lambda () (rgb-escape 1 3 5)) "\x1B[38;5;75m")
+(test-escape-procedure (lambda () (rgb-escape 5 1 3)) "\x1B[38;5;205m")
+(test-escape-procedure (lambda () (rgb-escape 3 5 1)) "\x1B[38;5;155m")
+
+(test-assert (procedure? gray-escape))
+(test-error (gray-escape))
+(test-error (gray-escape 0 0))
+(test-error (gray-escape 0.0))
+(test-error (gray-escape -1))
+(test-error (gray-escape 24))
+(test-escape-procedure (lambda () (gray-escape  0)) "\x1B[38;5;232m")
+(test-escape-procedure (lambda () (gray-escape 23)) "\x1B[38;5;255m")
+(test-escape-procedure (lambda () (gray-escape 12)) "\x1B[38;5;244m")
+
+(test-wrap-procedure   black       "\x1b;[30mFOO\x1b;[39m")
+(test-wrap-procedure   red         "\x1b;[31mFOO\x1b;[39m")
+(test-wrap-procedure   green       "\x1b;[32mFOO\x1b;[39m")
+(test-wrap-procedure   yellow      "\x1b;[33mFOO\x1b;[39m")
+(test-wrap-procedure   blue        "\x1b;[34mFOO\x1b;[39m")
+(test-wrap-procedure   cyan        "\x1b;[36mFOO\x1b;[39m")
+(test-wrap-procedure   magenta     "\x1b;[35mFOO\x1b;[39m")
+(test-wrap-procedure   white       "\x1b;[37mFOO\x1b;[39m")
+(test-wrap-procedure   (rgb 0 0 0) "\x1B[38;5;16mFOO\x1b;[39m")
+(test-wrap-procedure   (rgb 5 5 5) "\x1B[38;5;231mFOO\x1b;[39m")
+(test-wrap-procedure   (gray 0)    "\x1B[38;5;232mFOO\x1b;[39m")
+(test-wrap-procedure   (gray 23)   "\x1B[38;5;255mFOO\x1b;[39m")
+
+(test-escape-procedure black-background-escape       "\x1b;[40m")
+(test-escape-procedure red-background-escape         "\x1b;[41m")
+(test-escape-procedure green-background-escape       "\x1b;[42m")
+(test-escape-procedure yellow-background-escape      "\x1b;[43m")
+(test-escape-procedure blue-background-escape        "\x1b;[44m")
+(test-escape-procedure cyan-background-escape        "\x1b;[46m")
+(test-escape-procedure magenta-background-escape     "\x1b;[45m")
+(test-escape-procedure white-background-escape       "\x1b;[47m")
+(test-escape-procedure reset-background-color-escape "\x1b;[49m")
+
+(test-assert (procedure? rgb-background-escape))
+(test-error (rgb-background-escape))
+(test-error (rgb-background-escape 0))
+(test-error (rgb-background-escape 0 0))
+(test-error (rgb-background-escape 0 0 0 0))
+(test-error (rgb-background-escape 0.0 0 0))
+(test-error (rgb-background-escape 0 0.0 0))
+(test-error (rgb-background-escape 0 0 0.0))
+(test-error (rgb-background-escape -1 0 0))
+(test-error (rgb-background-escape 0 -1 0))
+(test-error (rgb-background-escape 0 0 -1))
+(test-error (rgb-background-escape 6 0 0))
+(test-error (rgb-background-escape 0 6 0))
+(test-error (rgb-background-escape 0 0 6))
+(test-escape-procedure (lambda () (rgb-background-escape 0 0 0)) "\x1B[48;5;16m")
+(test-escape-procedure (lambda () (rgb-background-escape 5 0 0)) "\x1B[48;5;196m")
+(test-escape-procedure (lambda () (rgb-background-escape 0 5 0)) "\x1B[48;5;46m")
+(test-escape-procedure (lambda () (rgb-background-escape 0 0 5)) "\x1B[48;5;21m")
+(test-escape-procedure (lambda () (rgb-background-escape 1 1 1)) "\x1B[48;5;59m")
+(test-escape-procedure (lambda () (rgb-background-escape 2 2 2)) "\x1B[48;5;102m")
+(test-escape-procedure (lambda () (rgb-background-escape 3 3 3)) "\x1B[48;5;145m")
+(test-escape-procedure (lambda () (rgb-background-escape 4 4 4)) "\x1B[48;5;188m")
+(test-escape-procedure (lambda () (rgb-background-escape 5 5 5)) "\x1B[48;5;231m")
+(test-escape-procedure (lambda () (rgb-background-escape 1 3 5)) "\x1B[48;5;75m")
+(test-escape-procedure (lambda () (rgb-background-escape 5 1 3)) "\x1B[48;5;205m")
+(test-escape-procedure (lambda () (rgb-background-escape 3 5 1)) "\x1B[48;5;155m")
+
+(test-assert (procedure? gray-background-escape))
+(test-error (gray-background-escape))
+(test-error (gray-background-escape 0 0))
+(test-error (gray-background-escape 0.0))
+(test-error (gray-background-escape -1))
+(test-error (gray-background-escape 24))
+(test-escape-procedure (lambda () (gray-background-escape  0)) "\x1B[48;5;232m")
+(test-escape-procedure (lambda () (gray-background-escape 23)) "\x1B[48;5;255m")
+(test-escape-procedure (lambda () (gray-background-escape 12)) "\x1B[48;5;244m")
+
+(test-wrap-procedure   black-background       "\x1b;[40mFOO\x1b;[49m")
+(test-wrap-procedure   red-background         "\x1b;[41mFOO\x1b;[49m")
+(test-wrap-procedure   green-background       "\x1b;[42mFOO\x1b;[49m")
+(test-wrap-procedure   yellow-background      "\x1b;[43mFOO\x1b;[49m")
+(test-wrap-procedure   blue-background        "\x1b;[44mFOO\x1b;[49m")
+(test-wrap-procedure   cyan-background        "\x1b;[46mFOO\x1b;[49m")
+(test-wrap-procedure   magenta-background     "\x1b;[45mFOO\x1b;[49m")
+(test-wrap-procedure   white-background       "\x1b;[47mFOO\x1b;[49m")
+(test-wrap-procedure   (rgb-background 0 0 0) "\x1B[48;5;16mFOO\x1b;[49m")
+(test-wrap-procedure   (rgb-background 5 5 5) "\x1B[48;5;231mFOO\x1b;[49m")
+(test-wrap-procedure   (gray-background 0)    "\x1B[48;5;232mFOO\x1b;[49m")
+(test-wrap-procedure   (gray-background 23)   "\x1B[48;5;255mFOO\x1b;[49m")
+
+(test-escape-procedure bold-escape            "\x1b;[1m")
+(test-escape-procedure reset-bold-escape      "\x1b;[22m")
+(test-wrap-procedure   bold                   "\x1b;[1mFOO\x1b;[22m")
+
+(test-escape-procedure underline-escape       "\x1b;[4m")
+(test-escape-procedure reset-underline-escape "\x1b;[24m")
+(test-wrap-procedure   underline              "\x1b;[4mFOO\x1b;[24m")
+
+(test-escape-procedure negative-escape        "\x1b;[7m")
+(test-escape-procedure reset-negative-escape  "\x1b;[27m")
+(test-wrap-procedure   negative               "\x1b;[7mFOO\x1b;[27m")
+
+(test-end)
diff --git a/tests/thread-tests.scm b/tests/thread-tests.scm
new file mode 100644
index 00000000..e99a7147
--- /dev/null
+++ b/tests/thread-tests.scm
@@ -0,0 +1,114 @@
+
+(cond-expand
+ (modules (import (srfi 18) (srfi 39) (chibi test)))
+ (else #f))
+
+(test-begin "threads")
+
+(test "no threads" 'ok (begin 'ok))
+
+(test "unstarted thread" 'ok
+  (let ((t (make-thread (lambda () (error "oops"))))) 'ok))
+
+(test "ignored thread terminates" 'ok
+  (let ((t (make-thread (lambda () 'oops)))) (thread-start! t) 'ok))
+
+(test "ignored thread hangs" 'ok
+  (let ((t (make-thread (lambda () (let lp () (lp))))))
+    (thread-start! t)
+    'ok))
+
+(test "joined thread terminates" 'ok
+  (let ((t (make-thread (lambda () 'oops))))
+    (thread-start! t)
+    (thread-join! t)
+    'ok))
+
+(test "joined thread hangs, timeout" 'timeout
+  (let ((t (make-thread (lambda () (let lp () (lp))))))
+    (thread-start! t)
+    (thread-join! t 0.1 'timeout)))
+
+(test "basic mutex" 'ok
+  (let ((m (make-mutex)))
+    (and (mutex? m) 'ok)))
+
+(test "mutex unlock" 'ok
+  (let ((m (make-mutex)))
+    (and (mutex-unlock! m) 'ok)))
+
+(test "mutex lock/unlock" 'ok
+  (let ((m (make-mutex)))
+    (and (mutex-lock! m)
+         (mutex-unlock! m)
+         'ok)))
+
+(test "mutex lock/lock" 'timeout
+  (let ((m (make-mutex)))
+    (and (mutex-lock! m)
+         (if (mutex-lock! m 0.1) 'fail 'timeout))))
+
+(test "mutex lock timeout" 'timeout
+  (let* ((m (make-mutex))
+         (t (make-thread (lambda () (mutex-lock! m)))))
+    (thread-start! t)
+    (thread-yield!)
+    (if (mutex-lock! m 0.1) 'fail 'timeout)))
+
+(test "mutex lock/unlock/lock/lock" 'timeout
+  (let* ((m (make-mutex))
+         (t (make-thread (lambda () (mutex-unlock! m)))))
+    (mutex-lock! m)
+    (thread-start! t)
+    (if (mutex-lock! m 0.1)
+        (if (mutex-lock! m 0.1) 'fail-second 'timeout)
+        'bad-timeout)))
+
+(test "thread-join! end result" 5
+  (let* ((th (make-thread (lambda () (+ 3 2)))))
+    (thread-start! th)
+    (thread-join! th)))
+
+(test-error "thread-join! exception"
+  (let* ((th (make-thread
+              (lambda ()
+                (parameterize ((current-error-port (open-output-string)))
+                  (+ 3 "2"))))))
+    (thread-start! th)
+    (thread-join! th)))
+
+(test-assert "make-condition-variable"
+  (condition-variable? (make-condition-variable)))
+
+(test "condition-variable signal" 'ok
+  (let* ((mutex (make-mutex))
+         (cndvar (make-condition-variable))
+         (th (make-thread
+              (lambda ()
+                (if (mutex-unlock! mutex cndvar 0.1) 'ok 'timeout1)))))
+    (thread-start! th)
+    (thread-yield!)
+    (condition-variable-signal! cndvar)
+    (thread-join! th 0.1 'timeout2)))
+
+(test "condition-variable broadcast" '(ok1 ok2)
+  (let* ((mutex (make-mutex))
+         (cndvar (make-condition-variable))
+         (th1 (make-thread
+               (lambda ()
+                 (mutex-lock! mutex)
+                 (if (mutex-unlock! mutex cndvar 1.0) 'ok1 'timeout1))))
+         (th2 (make-thread
+               (lambda ()
+                 (mutex-lock! mutex)
+                 (if (mutex-unlock! mutex cndvar 1.0) 'ok2 'timeout2)))))
+    (thread-start! th1)
+    (thread-start! th2)
+    (thread-yield!)
+    (mutex-lock! mutex)
+    (condition-variable-broadcast! cndvar)
+    (mutex-unlock! mutex)
+    (list (thread-join! th1 0.1 'timeout3)
+          (thread-join! th2 0.1 'timeout4))))
+
+(test-end)
diff --git a/tests/unicode-tests.scm b/tests/unicode-tests.scm
new file mode 100644
index 00000000..6e88ea93
--- /dev/null
+++ b/tests/unicode-tests.scm
@@ -0,0 +1,55 @@
+;; These tests are only valid if chibi-scheme is compiled with Unicode
+;; support (SEXP_USE_UTF8_STRINGS).
+
+(cond-expand
+ (modules (import (only (chibi test) test-begin test test-end)))
+ (else #f))
+
+(test-begin "unicode")
+
+(test #\Р (string-ref "Русский" 0))
+(test #\и (string-ref "Русский" 5))
+(test #\й (string-ref "Русский" 6))
+
+(test 7 (string-length "Русский"))
+
+(test #\日 (string-ref "日本語" 0))
+(test #\本 (string-ref "日本語" 1))
+(test #\語 (string-ref "日本語" 2))
+
+(test 3 (string-length "日本語"))
+
+(test '(#\日 #\本 #\語) (string->list "日本語"))
+(test "日本語" (list->string '(#\日 #\本 #\語)))
+
+(test "日本" (substring "日本語" 0 2))
+(test "本語" (substring "日本語" 1 3))
+
+(test "日-語"
+      (let ((s (substring "日本語" 0 3)))
+        (string-set! s 1 #\-)
+        s))
+
+(test "日本人"
+      (let ((s (substring "日本語" 0 3)))
+        (string-set! s 2 #\人)
+        s))
+
+(test "字字字" (make-string 3 #\字))
+
+(test "字字字"
+      (let ((s (make-string 3)))
+        (string-fill! s #\字)
+        s))
+
+(cond-expand (modules (import (chibi loop))) (else #f))
+
+(test "in-string"
+ '(#\日 #\本 #\語)
+ (loop ((for c (in-string "日本語")) (for res (listing c))) => res))
+
+(test "in-string-reverse"
+ '(#\語 #\本 #\日)
+ (loop ((for c (in-string-reverse "日本語")) (for res (listing c))) => res))
+
+(test-end)
diff --git a/tests/uri-tests.scm b/tests/uri-tests.scm
new file mode 100644
index 00000000..c8e3d13a
--- /dev/null
+++ b/tests/uri-tests.scm
@@ -0,0 +1,65 @@
+
+(import (chibi) (chibi test) (chibi uri))
+
+(test-begin "uri")
+
+(test-assert (uri? (make-uri 'http)))
+(test 'http (uri-scheme (make-uri 'http)))
+(test "r" (uri-user (make-uri 'http "r")))
+(test "google.com" (uri-host (make-uri 'http "r" "google.com")))
+(test 80 (uri-port (make-uri 'http "r" "google.com" 80)))
+(test "/search" (uri-path (make-uri 'http "r" "google.com" 80 "/search")))
+(test "q=cats"
+    (uri-query (make-uri 'http "r" "google.com" 80 "/search" "q=cats")))
+(test "recent"
+    (uri-fragment
+     (make-uri 'http "r" "google.com" 80 "/search" "q=cats" "recent")))
+
+(let ((str "http://google.com"))
+  (test-assert (uri? (string->uri str)))
+  (test 'http (uri-scheme (string->uri str)))
+  (test "google.com" (uri-host (string->uri str)))
+  (test #f (uri-port (string->uri str)))
+  (test #f (uri-path (string->uri str)))
+  (test #f (uri-query (string->uri str)))
+  (test #f (uri-fragment (string->uri str))))
+
+(let ((str "http://google.com/"))
+  (test-assert (uri? (string->uri str)))
+  (test 'http (uri-scheme (string->uri str)))
+  (test "google.com" (uri-host (string->uri str)))
+  (test #f (uri-port (string->uri str)))
+  (test "/" (uri-path (string->uri str)))
+  (test #f (uri-query (string->uri str)))
+  (test #f (uri-fragment (string->uri str))))
+
+(let ((str "http://google.com:80/search?q=cats#recent"))
+  (test-assert (uri? (string->uri str)))
+  (test 'http (uri-scheme (string->uri str)))
+  (test "google.com" (uri-host (string->uri str)))
+  (test 80 (uri-port (string->uri str)))
+  (test "/search" (uri-path (string->uri str)))
+  (test "q=cats" (uri-query (string->uri str)))
+  (test "recent" (uri-fragment (string->uri str))))
+
+(test "/%73" (uri-path (string->uri "http://google.com/%73")))
+(test "/s" (uri-path (string->uri "http://google.com/%73" #t)))
+(test "a=1&b=2;c=3"
+    (uri-query (string->uri "http://google.com/%73?a=1&b=2;c=3" #t)))
+(test '(("a" . "1") ("b" . "2") ("c" . "3"))
+    (uri-query (string->uri "http://google.com/%73?a=1&b=2;c=3" #t #t)))
+(test '(("a" . "1") ("b" . "2+2") ("c" . "3"))
+    (uri-query (string->uri "http://google.com/%73?a=1&b=2+2;c=%33" #f #t)))
+(test '(("a" . "1") ("b" . "2 2") ("c" . "3"))
+    (uri-query (string->uri "http://google.com/%73?a=1&b=2+2;c=%33" #t #t)))
+
+(let ((str "/"))
+  (test-assert (uri? (string->path-uri 'http str)))
+  (test 'http (uri-scheme (string->path-uri 'http str)))
+  (test #f (uri-host (string->path-uri 'http str)))
+  (test #f (uri-port (string->path-uri 'http str)))
+  (test "/" (uri-path (string->path-uri 'http str)))
+  (test #f (uri-query (string->path-uri 'http str)))
+  (test #f (uri-fragment (string->path-uri 'http str))))
+
+(test-end)
diff --git a/tests/weak-tests.scm b/tests/weak-tests.scm
new file mode 100644
index 00000000..f34f35cf
--- /dev/null
+++ b/tests/weak-tests.scm
@@ -0,0 +1,46 @@
+
+(import (chibi weak) (chibi ast) (only (chibi test) test-begin test test-end))
+
+(test-begin "weak pointers")
+
+(test "preserved key and value" '("key1" "value1" #f)
+  (let ((key (string-append "key" "1"))
+        (value (string-append "value" "1")))
+    (let ((eph (make-ephemeron key value)))
+      (gc)
+      (list key (ephemeron-value eph) (ephemeron-broken? eph)))))
+
+(test "unpreserved key and value" '(#f #f #t)
+  (let ((eph (make-ephemeron (string-append "key" "2")
+                             (string-append "value" "2"))))
+    (gc)
+    (list (ephemeron-key eph) (ephemeron-value eph) (ephemeron-broken? eph))))
+
+(test "unpreserved key and preserved value" '(#f "value3" #t)
+  (let ((value (string-append "value" "3")))
+    (let ((eph (make-ephemeron (string-append "key" "3") value)))
+      (gc)
+      (list (ephemeron-key eph) value (ephemeron-broken? eph)))))
+
+(test "unpreserved value references unpreserved key" '(#f #f #t)
+  (let ((key (string-append "key")))
+    (let ((eph (make-ephemeron key (cons (string-append "value") key))))
+      (gc)
+      (list (ephemeron-key eph) (ephemeron-value eph) (ephemeron-broken? eph)))))
+
+;; disabled - we support weak keys, but not proper ephemerons
+
+'(test "preserved key and unpreserved value" '("key" "value" #f)
+  (let ((key (string-append "key")))
+    (let ((eph (make-ephemeron key (string-append "value"))))
+      (gc)
+      (list key (ephemeron-value eph) (ephemeron-broken? eph)))))
+
+'(test "preserved value references unpreserved key" '(#f #f #t)
+  (let* ((key (string-append "key"))
+         (value (cons (string-append "value") key)))
+    (let ((eph (make-ephemeron key value)))
+      (gc)
+      (list (ephemeron-key eph) value (ephemeron-broken? eph)))))
+
+(test-end)
diff --git a/tools/chibi-doc b/tools/chibi-doc
new file mode 100755
index 00000000..28274a9b
--- /dev/null
+++ b/tools/chibi-doc
@@ -0,0 +1,69 @@
+#! /usr/bin/env chibi-scheme
+
+(import (scheme base)
+        (scheme write)
+        (scheme file)
+        (scheme process-context)
+        (chibi string)
+        (chibi scribble)
+        (chibi doc)
+        (chibi sxml))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; print an error and exit without a stack trace
+(define (die . args)
+  (for-each display args)
+  (newline)
+  (exit 1))
+
+;; convert directly from scribble to the output format
+(define (convert-scribble render in)
+  ((or render sxml-display-as-html)
+   (generate-docs (scribble-parse in))))
+
+;; utility to convert from "foo.bar" to (foo bar)
+(define (split-module-name str)
+  (map (lambda (x) (or (string->number x) (string->symbol x)))
+       (string-split str #\.)))
+
+;; main
+(define (run args render)
+  (case (length args)
+    ((0)
+     (convert-scribble render (current-input-port)))
+    ((1)
+     (let ((name (car args)))
+       (cond
+        ((equal? "-" name)
+         (convert-scribble render (current-input-port)))
+        ((file-exists? name)
+         (call-with-input-file name
+           (lambda (in) (convert-scribble render in))))
+        (else
+         ;; load the module so that examples work
+         (let ((mod-name (split-module-name name)))
+           (print-module-docs mod-name (current-output-port) render))))))
+    ((2)
+     (let* ((name (car args))
+            (var (cadr args))
+            (mod-name (split-module-name name)))
+       (print-module-binding-docs
+        mod-name (string->symbol var) (current-output-port) render)))
+    (else
+     (die "usage: chibi-doc [<scribble-file> | <module-name> [<var>]]"))))
+
+;; parse the command-line
+(let lp ((args (cdr (command-line)))
+         (render #f))
+  (cond
+   ((and (pair? args) (not (equal? "" (car args)))
+         (eqv? #\- (string-ref (car args) 0)))
+    (case (string->symbol (substring (car args) 1))
+      ((h -html) (lp (cdr args) sxml-display-as-html))
+      ((s -sxml) (lp (cdr args) write))
+      ((t -text) (lp (cdr args) sxml-display-as-text))
+      ((-) (run (cdr args) render))
+      (else (die "unknown option: " (car args)))))
+   (else
+    (run args render))))
diff --git a/tools/chibi-ffi b/tools/chibi-ffi
new file mode 100755
index 00000000..3bbc9b91
--- /dev/null
+++ b/tools/chibi-ffi
@@ -0,0 +1,2020 @@
+#! /usr/bin/env chibi-scheme
+
+;; Note: this evolved as a throw-away script to provide certain core
+;; modules, and so is a mess.  Tread carefully.
+
+;; Simple C FFI.  "chibi-ffi file.stub" will read in the C function
+;; FFI definitions from file.stub and output the appropriate C
+;; wrappers into file.c.  You can then compile that file with:
+;;
+;;   cc -fPIC -shared file.c -lchibi-scheme
+;;
+;; (or using whatever flags are appropriate to generate shared libs on
+;; your platform) and then the generated .so file can be loaded
+;; directly with load, or portably using (include-shared "file") in a
+;; module definition (note that include-shared uses no suffix).
+;;
+;; Passing the -c/--compile option will attempt to compile the .so
+;; file in a single step.
+
+;; The goal of this interface is to make access to C types and
+;; functions easy, without requiring the user to write any C code.
+;; That means the stubber needs to be intelligent about various C
+;; calling conventions and idioms, such as return values passed in
+;; actual parameters.  Writing C by hand is still possible, and
+;; several of the core modules provide C interfaces directly without
+;; using the stubber.
+
+;; For bootstrapping purposes we depend only on the core language.
+(import (chibi))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; globals
+
+(define *ffi-version* "0.3")
+(define *types* '())
+(define *type-getters* '())
+(define *type-setters* '())
+(define *typedefs* '())
+(define *funcs* '())
+(define *methods* '())
+(define *consts* '())
+(define *inits* '())
+(define *tags* '())
+(define *open-namespaces* '())
+(define *c++?* #f)
+(define wdir ".")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; type objects
+
+(define (parse-type type . o)
+  (cond
+   ((vector? type)
+    type)
+   (else
+    (let lp ((type type) (free? #f) (const? #f) (null-ptr? #f)
+             (ptr? #f) (ref? #f) (struct? #f) (link? #f) (result? #f) (array #f)
+             (value #f) (default? #f) (template #f) (new? #f))
+      (define (next) (if (null? (cddr type)) (cadr type) (cdr type)))
+      (case (and (pair? type) (car type))
+        ((free)
+         (lp (next) #t const? null-ptr? ptr? ref? struct? link? result? array value default? template new?))
+        ((const)
+         (lp (next) free? #t null-ptr? ptr? ref? struct? link? result? array value default? template new?))
+        ((maybe-null)
+         (lp (next) free? const? #t ptr? ref? struct? link? result? array value default? template new?))
+        ((pointer)
+         (lp (next) free? const? null-ptr? #t ref? struct? link? result? array value default? template new?))
+        ((reference)
+         (lp (next) free? const? null-ptr? ptr? #t struct? link? result? array value default? template new?))
+        ((struct)
+         (lp (next) free? const? null-ptr? ptr? ref? #t link? result? array value default? template new?))
+        ((link)
+         (lp (next) free? const? null-ptr? ptr? ref? struct? #t result? array value default? template new?))
+        ((result)
+         (lp (next) free? const? null-ptr? ptr? ref? struct? link? #t array value default? template new?))
+        ((array)
+         (lp (cadr type) free? const? null-ptr? ref? ptr? struct? link? result? (if (pair? (cddr type)) (car (cddr type)) #t) value default? template new?))
+        ((value)
+         (lp (cddr type) free? const? null-ptr? ref? ptr? struct? link? result? array (cadr type) default? template new?))
+        ((default)
+         (lp (cddr type) free? const? null-ptr? ref? ptr? struct? link? result? array (cadr type) #t template new?))
+        ((template)
+         (lp (cddr type) free? const? null-ptr? ref? ptr? struct? link? result? array value default? (cadr type) new?))
+        ((new)
+         (lp (next) free? const? null-ptr? ref? ptr? struct? link? result? array value default? template #t))
+        (else
+         (vector (if (and (pair? type) (null? (cdr type))) (car type) type) free? const? null-ptr? ptr? ref? struct? link? result? array value default? template new? (and (pair? o) (car o)))))))))
+
+(define (type-base type) (vector-ref type 0))
+(define (type-free? type) (vector-ref type 1))
+(define (type-const? type) (vector-ref type 2))
+(define (type-null? type) (vector-ref type 3))
+(define (type-pointer? type) (vector-ref type 4))
+(define (type-reference? type) (vector-ref type 5))
+(define (type-struct? type) (vector-ref type 6))
+(define (type-link? type) (vector-ref type 7))
+(define (type-result? type) (vector-ref type 8))
+(define (type-array type) (vector-ref type 9))
+(define (type-value type) (vector-ref type 10))
+(define (type-default? type) (vector-ref type 11))
+(define (type-template type) (vector-ref type 12))
+(define (type-new? type) (vector-ref type 13))
+(define (type-index type) (vector-ref type 14))
+
+(define (type-auto-expand? type)
+  (and (pair? (type-array type))
+       (memq 'auto-expand (type-array type))))
+
+(define (type-index-string type)
+  (if (integer? (type-index type))
+      (number->string (type-index type))
+      ""))
+
+(define (struct-fields ls)
+  (let lp ((ls ls) (res '()))
+    (cond ((not (pair? ls)) (reverse res))
+          ((symbol? (car ls)) (lp (if (pair? (cdr ls)) (cddr ls) (cdr ls)) res))
+          (else (lp (cdr ls) (cons (car ls) res))))))
+
+(define (lookup-type type)
+  (or (assq type *types*)
+      (assq type *typedefs*)))
+
+(define (type-field-type type field)
+  (cond
+   ((lookup-type (type-base (parse-type type)))
+    => (lambda (x)
+         (let lp ((ls (struct-fields (cdr x))))
+           (cond
+            ((null? ls) #f)
+            ((eq? field (caar ls)) (car (cdar ls)))
+            (else (lp (cdr ls)))))))
+   (else
+    #f)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; type predicates
+
+(define *c-int-types* '())
+(define *c-enum-types* '())
+
+(define-syntax define-c-int-type
+  (syntax-rules ()
+    ((define-c-int-type type)
+     (if (not (memq 'type *c-int-types*))
+         (set! *c-int-types* (cons 'type *c-int-types*)))
+     #f)))
+
+(define-syntax define-c-enum
+  ;; TODO: support conversion to/from symbolic names
+  (syntax-rules ()
+    ((define-c-enum (scheme-name c-name) . args)
+     (if (not (assq 'scheme-name *c-enum-types*))
+         (set! *c-enum-types*
+               `((scheme-name . c-name) ,@*c-enum-types*)))
+     #f)
+    ((define-c-enum scheme-name . args)
+     (let ((c-name (mangle 'scheme-name)))
+       (if (not (assq 'scheme-name *c-enum-types*))
+           (set! *c-enum-types*
+                 `((scheme-name . ,c-name) ,@*c-enum-types*)))
+       #f))))
+
+(define (enum-type? type)
+  (assq type *c-enum-types*))
+
+(define (signed-int-type? type)
+  (or (memq type '(signed-char short int long))
+      (memq type *c-int-types*)
+      (enum-type? type)))
+
+(define (unsigned-int-type? type)
+  (memq type '(unsigned-char unsigned-short unsigned unsigned-int unsigned-long
+               size_t off_t time_t clock_t dev_t ino_t mode_t nlink_t
+               uid_t gid_t pid_t blksize_t blkcnt_t sigval_t)))
+
+(define (int-type? type)
+  (or (signed-int-type? type) (unsigned-int-type? type)))
+
+(define (float-type? type)
+  (memq type '(float double long-double long-long-double)))
+
+(define (string-type? type)
+  (or (memq type '(char* string env-string non-null-string))
+      (and (vector? type)
+           (type-array type)
+           (not (type-pointer? type))
+           (eq? 'char (type-base type)))))
+
+(define (port-type? type)
+  (memq type '(port input-port output-port input-output-port)))
+
+(define (error-type? type)
+  (memq type '(errno status-bool non-null-string non-null-pointer)))
+
+(define (array-type? type)
+  (and (type-array type) (not (eq? 'char (type-base type)))))
+
+(define (basic-type? type)
+  (let ((type (parse-type type)))
+    (and (not (type-array type))
+         (not (void-pointer-type? type))
+         (not (lookup-type (type-base type))))))
+
+(define (void-pointer-type? type)
+  (or (and (eq? 'void (type-base type)) (type-pointer? type))
+      (eq? 'void* (type-base type))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; function objects
+
+(define (parse-func func . o)
+  (if (not (and (= 3 (length func))
+                (or (identifier? (cadr func))
+                    (and (list? (cadr func))
+                         (<= 1 (length (cadr func)) 3)
+                         (every (lambda (x) (or (identifier? x) (not x) (string? x)))
+                                (cadr func))))
+                (list? (car (cddr func)))))
+      (error "bad function definition" func))
+  (let* ((method? (and (pair? o) (car o)))
+         (ret-type (parse-type (car func)))
+         (scheme-name (if (pair? (cadr func)) (car (cadr func)) (cadr func)))
+         (c-name (if (pair? (cadr func))
+                     (cadr (cadr func))
+                     (mangle scheme-name)))
+         (stub-name (if (and (pair? (cadr func)) (pair? (cddr (cadr func))))
+                        (car (cddr (cadr func)))
+                        (generate-stub-name scheme-name))))
+    (let lp ((ls (if (equal? (car (cddr func)) '(void)) '() (car (cddr func))))
+             (i 0)
+             (results '())
+             (c-args '())
+             (s-args '()))
+      (cond
+       ((null? ls)
+        (vector scheme-name c-name stub-name ret-type
+                (reverse results) (reverse c-args) (reverse s-args)
+                method?))
+       (else
+        (let ((type (parse-type (car ls) i)))
+          (cond
+           ((type-result? type)
+            (lp (cdr ls) (+ i 1) (cons type results) (cons type c-args) s-args))
+           ((and (type-value type) (not (type-default? type)))
+            (lp (cdr ls) (+ i 1) results (cons type c-args) s-args))
+           (else
+            (lp (cdr ls) (+ i 1) results (cons type c-args) (cons type s-args)))
+           )))))))
+
+(define (func-scheme-name func) (vector-ref func 0))
+(define (func-c-name func) (vector-ref func 1))
+(define (func-stub-name func) (vector-ref func 2))
+(define (func-ret-type func) (vector-ref func 3))
+(define (func-results func) (vector-ref func 4))
+(define (func-c-args func) (vector-ref func 5))
+(define (func-scheme-args func) (vector-ref func 6))
+(define (func-method? func) (vector-ref func 7))
+
+(define (func-stub-name-set! func x) (vector-set! func 2 x))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utilities
+
+(define (cat . args)
+  (for-each (lambda (x) (if (procedure? x) (x) (display x))) args))
+
+(define (join ls . o)
+  (if (pair? ls)
+      (let ((sep (if (pair? o) (car o) " ")))
+        (let lp ((ls ls))
+          (if (pair? (cdr ls))
+              (cat (car ls) sep (lambda () (lp (cdr ls))))
+              (cat (car ls)))))
+      ""))
+
+(define (x->string x)
+  (cond ((string? x) x)
+        ((symbol? x) (symbol->string x))
+        ((number? x) (number->string x))
+        (else (error "non-stringable object" x))))
+
+(define (filter pred ls)
+  (cond ((null? ls) '())
+        ((pred (car ls)) (cons (car ls) (filter pred (cdr ls))))
+        (else (filter pred (cdr ls)))))
+
+(define (remove pred ls)
+  (cond ((null? ls) '())
+        ((pred (car ls)) (remove pred (cdr ls)))
+        (else (cons (car ls) (remove pred (cdr ls))))))
+
+(define (strip-extension path)
+  (let lp ((i (- (string-length path) 1)))
+    (cond ((<= i 0) path)
+          ((eq? #\. (string-ref path i)) (substring path 0 i))
+          (else (lp (- i 1))))))
+
+(define (string-concatenate-reverse ls)
+  (cond ((null? ls) "")
+        ((null? (cdr ls)) (car ls))
+        (else (string-concatenate (reverse ls)))))
+
+(define (string-replace str c r)
+  (let ((len (string-length str)))
+    (let lp ((from 0) (i 0) (res '()))
+      (define (collect) (if (= i from) res (cons (substring str from i) res)))
+      (cond
+       ((>= i len) (string-concatenate-reverse (collect)))
+       ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect))))
+       (else (lp from (+ i 1) res))))))
+
+(define (string-split str c . o)
+  (let ((start (if (pair? o) (car o) 0))
+        (end (string-length str)))
+    (let lp ((from start) (i start) (res '()))
+      (define (collect) (if (= i from) res (cons (substring str from i) res)))
+      (cond
+       ((>= i end) (reverse (collect)))
+       ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (collect)))
+       (else (lp from (+ i 1) res))))))
+
+(define (string-scan c str . o)
+  (let ((end (string-length str)))
+    (let lp ((i (if (pair? o) (car o) 0)))
+      (cond ((>= i end) #f)
+            ((eqv? c (string-ref str i)) i)
+            (else (lp (+ i 1)))))))
+
+(define (string-downcase str)
+  (list->string (map char-downcase (string->list str))))
+
+(define (with-output-to-string thunk)
+  (call-with-output-string
+    (lambda (out)
+      (let ((old-out (current-output-port)))
+        (current-output-port out)
+        (thunk)
+        (current-output-port old-out)))))
+
+(define (warn msg . args)
+  (let ((err (current-error-port)))
+    (display "WARNING: " err)
+    (display msg err)
+    (if (pair? args) (display ":" err))
+    (for-each (lambda (x) (display " " err) (write x err)) args)
+    (newline err)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; naming
+
+(define (c-char? c)
+  (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?))))
+
+(define (c-escape str)
+  (let ((len (string-length str)))
+    (let lp ((from 0) (i 0) (res '()))
+      (define (collect) (if (= i from) res (cons (substring str from i) res)))
+      (cond
+       ((>= i len) (string-concatenate-reverse (collect)))
+       ((not (c-char? (string-ref str i)))
+        (lp (+ i 1) (+ i 1)
+            `("_" ,(number->string (char->integer (string-ref str i)) 16)
+              ,@(collect))))
+       (else (lp from (+ i 1) res))))))
+
+(define (mangle x)
+  (string-replace
+   (string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p")
+   #\! "_x"))
+
+(define (generate-stub-name sym)
+  (string-append "sexp_" (mangle sym) "_stub"))
+
+(define (type-id-name sym)
+  (string-append "sexp_" (mangle sym) "_type_obj"))
+
+(define (make-integer x)
+  (case x
+    ((-1) "SEXP_NEG_ONE")  ((0) "SEXP_ZERO")   ((1) "SEXP_ONE")
+    ((2) "SEXP_TWO")       ((3) "SEXP_THREE")  ((4) "SEXP_FOUR")
+    ((5) "SEXP_FIVE")      ((6) "SEXP_SIX")    ((7) "SEXP_SEVEN")
+    ((8) "SEXP_EIGHT")     ((9) "SEXP_NINE")   ((10) "SEXP_TEN")
+    (else (string-append "sexp_make_fixnum(" (x->string x) ")"))))
+
+(define (string-scan-right str ch)
+  (let lp ((i (string-cursor-end str)))
+    (let ((i2 (string-cursor-prev str i)))
+      (cond ((string-cursor<? i2 0) 0)
+            ((eqv? ch (string-cursor-ref str i2)) i)
+            (else (lp i2))))))
+
+(define (strip-namespace x)
+  (string->symbol
+   (let* ((x (x->string x))
+          (i (string-scan-right x #\:)))
+     (if (> i 0)
+         (substring-cursor x i)
+         x))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; .stub file interface
+
+(define (c-declare . args)
+  (apply cat args)
+  (newline))
+
+(define (c-include header)
+  (cat "\n#include \"" header "\"\n"))
+
+(define (c-system-include header)
+  (cat "\n#include <" header ">\n"))
+
+(define (c-include-verbatim file)
+  (call-with-input-file (if (eqv? #\/ (string-ref file 0))
+                            file
+                            (string-append wdir "/" file))
+    (lambda (in)
+      (let lp ()
+        (let ((c (read-char in)))
+          (cond
+           ((not (eof-object? c))
+            (write-char c)
+            (lp))))))))
+
+(define (c-init x)
+  (set! *inits* (cons x *inits*)))
+
+(define (parse-struct-like ls)
+  (let lp ((ls ls) (res '()))
+    (cond
+     ((null? ls)
+      (reverse res))
+     ((symbol? (car ls))
+      (lp (cddr ls) (cons (cadr ls) (cons (car ls) res))))
+     ((pair? (car ls))
+      (lp (cdr ls) (cons (cons (parse-type (caar ls)) (cdar ls)) res)))
+     (else
+      (lp (cdr ls) (cons (car ls) res))))))
+
+(define-syntax define-struct-like
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (set! *types*
+           `((,(cadr expr)
+              ,@(parse-struct-like (cddr expr)))
+             ,@*types*))
+     (set! *tags* `(,(type-id-name (cadr expr)) ,@*tags*))
+     #f)))
+
+(define-syntax define-c-struct
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     `(define-struct-like ,(cadr expr) type: struct ,@(cddr expr)))))
+
+(define-syntax define-c-class
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     `(define-struct-like ,(cadr expr) type: class ,@(cddr expr)))))
+
+(define-syntax define-c-union
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     `(define-struct-like ,(cadr expr) type: union ,@(cddr expr)))))
+
+(define-syntax define-c-type
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     `(define-struct-like ,(cadr expr) ,@(cddr expr)))))
+
+(define-syntax declare-c-struct
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     `(define-struct-like ,(cadr expr) type: struct imported?: #t))))
+
+(define-syntax declare-c-class
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     `(define-struct-like ,(cadr expr) type: class imported?: #t))))
+
+(define-syntax declare-c-union
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     `(define-struct-like ,(cadr expr) type: union imported?: #t))))
+
+(define-syntax define-c
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (set! *funcs* (cons (parse-func (cdr expr)) *funcs*))
+     #f)))
+
+(define-syntax define-c-const
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let ((type (parse-type (cadr expr))))
+       (for-each (lambda (x) (set! *consts* (cons (list type x) *consts*)))
+                 (cddr expr))))))
+
+(define-syntax c-typedef
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let ((type (parse-type (cadr expr)))
+           (name (car (cddr expr))))
+       (set! *typedefs* `((,name ,@type) ,@*typedefs*))
+       `(,(rename 'cat) "typedef " ,(type-c-name type) " " ',name ";\n")))))
+
+(define (c++)
+  (set! *c++?* #t))
+
+(define (ensure-c++ name)
+  (cond
+   ((not *c++?*)
+    (display "WARNING: assuming c++ mode from " (current-error-port))
+    (display name (current-error-port))
+    (display " - use (c++) to make this explicit\n" (current-error-port))
+    (c++))))
+
+(define-syntax c++-namespace
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (ensure-c++ 'c++-namespace)
+     (let ((namespace (cadr expr)))
+       (cond
+        ((null? (cddr expr))
+         (set! *open-namespaces* (cons namespace *open-namespaces*))
+         `(,(rename 'cat) "namespace " ',namespace ";\n"))
+        (else
+         `(,(rename 'begin)
+           (,(rename 'cat) "namespace " ',namespace " {\n")
+           ,@(cddr expr)
+           (,(rename 'cat) "}  // namespace " ',namespace "\n\n"))))))))
+
+(define-syntax c++-using
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (ensure-c++ 'c++-using)
+     `(,(rename 'cat) "using " ',(cadr expr) ";\n"))))
+
+(define-syntax define-c++-method
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (ensure-c++ 'define-c++-method)
+     (let* ((class (cadr expr))
+            (ret-type (car (cddr expr)))
+            (name (cadr (cddr expr)))
+            (meths (map (lambda (x)
+                          (parse-func `(,ret-type ,name (,class ,@x)) #t))
+                        (cddr (cddr expr)))))
+       (set! *methods* (cons (cons name meths) *methods*))))))
+
+(define-syntax define-c++-constructor
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (ensure-c++ 'define-c++-constructor)
+     (set! *funcs*
+           (cons (parse-func `((new ,(if (pair? (cadr expr))
+                                         (cadr (cadr expr))
+                                         (cadr expr)))
+                               ,(cadr expr)
+                               ,@(cddr expr)))
+                 *funcs*))
+     #f)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; C code generation
+
+(define (type-predicate type)
+  (let ((base (type-base (parse-type type))))
+    (cond
+     ((int-type? base) "sexp_exact_integerp")
+     ((float-type? base) "sexp_flonump")
+     ((string-type? base) "sexp_stringp")
+     ((eq? base 'bytevector) "sexp_bytesp")
+     ((eq? base 'char) "sexp_charp")
+     ((memq base '(bool boolean status-bool)) "sexp_booleanp")
+     ((eq? base 'port) "sexp_portp")
+     ((eq? base 'input-port) "sexp_iportp")
+     ((eq? base 'output-port) "sexp_oportp")
+     ((eq? base 'input-output-port) "sexp_ioportp")
+     ((memq base '(fileno fileno-nonblock)) "sexp_filenop")
+     (else #f))))
+
+(define (type-name type)
+  (let ((base (type-base (parse-type type))))
+    (cond
+     ((int-type? base) "integer")
+     ((float-type? base) "flonum")
+     ((memq base '(bool boolean status-bool)) (if *c++?* "bool" "int"))
+     (else base))))
+
+(define (type-id-number type . o)
+  (let ((base (type-base type)))
+    (cond
+     ((int-type? base) "SEXP_FIXNUM")
+     ((float-type? base) "SEXP_FLONUM")
+     ((string-type? base) "SEXP_STRING")
+     ((eq? base 'bytevector) "SEXP_BYTES")
+     ((eq? base 'char) "SEXP_CHAR")
+     ((memq base '(bool boolean status-bool)) "SEXP_BOOLEAN")
+     ((eq? base 'string) "SEXP_STRING")
+     ((eq? base 'symbol) "SEXP_SYMBOL")
+     ((eq? base 'pair) "SEXP_PAIR")
+     ((eq? base 'port) "SEXP_IPORT")
+     ((eq? base 'input-port) "SEXP_IPORT")
+     ((eq? base 'output-port) "SEXP_OPORT")
+     ((eq? base 'input-output-port) "SEXP_IPORT")
+     ((memq base '(fileno fileno-nonblock)) "SEXP_FILENO")
+     ((void-pointer-type? type) "SEXP_CPOINTER")
+     ((lookup-type base)
+      ;; (string-append "sexp_type_tag(" (type-id-name base) ")")
+      (let ((i (type-index type)))
+        (cond
+         ((not i)
+          ;;(warn "type-id-number on unknown arg" type)
+          (if (and (pair? o) (car o))
+              "sexp_unbox_fixnum(sexp_opcode_return_type(self))"
+              (string-append "sexp_type_tag(" (type-id-name base) ")")))
+         ((< i 3)
+          (string-append
+           "sexp_unbox_fixnum(sexp_opcode_arg"
+           (number->string (+ i 1)) "_type(self))"))
+         (else
+          (string-append
+           "sexp_unbox_fixnum(sexp_vector_ref(sexp_opcode_argn_type(self), "
+           (make-integer (- i 3)) "))")))))
+     (else "SEXP_OBJECT"))))
+
+(define (type-id-value type . o)
+  (cond
+   ((eq? 'void (type-base type))
+    "SEXP_VOID")
+   (else
+    (make-integer (apply type-id-number type o)))))
+
+(define (type-id-init-value type)
+  (cond
+   ((lookup-type (type-base type))
+    (make-integer
+     (string-append "sexp_type_tag(" (type-id-name (type-base type)) ")")))
+   (else
+    (type-id-value type))))
+
+(define (c-array-length type)
+  (if (memq 'result (type-array type))
+      "sexp_unbox_fixnum(res)"
+      "-1"))
+
+(define (c->scheme-converter type val . o)
+  (let ((base (type-base type)))
+    (cond
+     ((and (eq? base 'void) (not (type-pointer? type)))
+      (cat "((" val "), SEXP_VOID)"))
+     ((or (eq? base 'sexp) (error-type? base))
+      (cat val))
+     ((memq base '(bool boolean status-bool))
+      (cat "sexp_make_boolean(" val ")"))
+     ((eq? base 'time_t)
+      (cat "sexp_make_integer(ctx, sexp_shift_epoch(" val "))"))
+     ((unsigned-int-type? base)
+      (cat "sexp_make_unsigned_integer(ctx, " val ")"))
+     ((signed-int-type? base)
+      (cat "sexp_make_integer(ctx, " val ")"))
+     ((float-type? base)
+      (cat "sexp_make_flonum(ctx, " val ")"))
+     ((eq? base 'char)
+      (if (type-array type)
+          (cat "sexp_c_string(ctx, " val ", " (c-array-length type) ")")
+          (cat "sexp_make_character(" val ")")))
+     ((eq? 'env-string base)
+      (cat "(p=strchr(" val ", '=') ? "
+           "sexp_cons(ctx, str=sexp_c_string(ctx, " val
+           ", p - " val "), str=sexp_c_string(ctx, p, -1))"
+           " : sexp_cons(ctx, str=" val ", SEXP_FALSE)"))
+     ((string-type? base)
+      (if (and *c++?* (eq? 'string base))
+          (cat "sexp_c_string(ctx, " val ".c_str(), " val ".size())")
+          (cat "sexp_c_string(ctx, " val ", " (c-array-length type) ")")))
+     ((eq? 'bytevector base)
+      (if *c++?*
+          (cat "sexp_string_to_bytes(ctx, sexp_c_string(ctx, "
+               val ".data(), " val ".size()))")
+          (cat "sexp_string_to_bytes(ctx, sexp_c_string(ctx, " val ", "
+               (c-array-length type val) "))")))
+     ((eq? 'input-port base)
+      (cat "sexp_make_non_null_input_port(ctx, " val ", SEXP_FALSE)"))
+     ((eq? 'output-port base)
+      (cat "sexp_make_non_null_output_port(ctx, " val ", SEXP_FALSE)"))
+     ((eq? 'input-output-port base)
+      (cat "sexp_make_non_null_input_output_port(ctx, " val ", SEXP_FALSE)"))
+     ((memq base '(fileno fileno-nonblock))
+      (cat "sexp_make_fileno(ctx, sexp_make_fixnum(" val "), SEXP_FALSE)"))
+     (else
+      (let ((ctype (lookup-type base))
+            (void*? (void-pointer-type? type)))
+        (cond
+         ((or ctype void*?)
+          (cat "sexp_make_cpointer(ctx, "
+               (if void*?
+                   "SEXP_CPOINTER"
+                   ;;(string-append "sexp_type_tag(" (type-id-name base) ")")
+                   (type-id-number type #t))
+               ", "
+               val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", "
+               (if (or (type-free? type)
+                       (type-new? type)
+                       (and (type-result? type) (not (basic-type? type))))
+                   1
+                   0)
+               ")"))
+         (else
+          (error "unknown type" base))))))))
+
+(define (scheme->c-converter type val)
+  (let* ((type (parse-type type))
+         (base (type-base type)))
+    (cond
+     ((eq? base 'sexp)
+      (cat val))
+     ((memq base '(bool boolean status-bool))
+      (cat "sexp_truep(" val ")"))
+     ((eq? base 'time_t)
+      (cat "sexp_unshift_epoch(sexp_uint_value(" val "))"))
+     ((enum-type? base)
+      => (lambda (x) (cat "((" (cdr x) ")sexp_sint_value(" val "))")))
+     ((signed-int-type? base)
+      (cat "sexp_sint_value(" val ")"))
+     ((unsigned-int-type? base)
+      (cat "sexp_uint_value(" val ")"))
+     ((float-type? base)
+      (cat "sexp_flonum_value(" val ")"))
+     ((eq? base 'char)
+      (cat "sexp_unbox_character(" val ")"))
+     ((eq? base 'env-string)
+      (cat "sexp_concat_env_string(" val ")"))
+     ((string-type? base)
+      (cat (if (type-null? type)
+            "sexp_string_maybe_null_data"
+            "sexp_string_data")
+           "(" val ")"))
+     ((eq? base 'bytevector)
+      (cat (if (type-null? type)
+            "sexp_bytes_maybe_null_data"
+            "sexp_bytes_data")
+           "(" val ")"))
+     ((eq? base 'port-or-fileno)
+      (cat "(sexp_portp(" val ") ? sexp_port_fileno(" val ")"
+           " : sexp_filenop(" val ") ? sexp_fileno_fd(" val ")"
+           " : sexp_unbox_fixnum(" val "))"))
+     ((port-type? base)
+      (cat "sexp_port_stream(" val ")"))
+     ((memq base '(fileno fileno-nonblock))
+      (cat "(sexp_filenop(" val ") ? sexp_fileno_fd(" val ")"
+           " : sexp_unbox_fixnum(" val "))"))
+     (else
+      (let ((ctype (lookup-type base))
+            (void*? (void-pointer-type? type)))
+        (cond
+         ((or ctype void*?)
+          (cat (if (type-reference? type) "*" "")
+               "(" (type-c-name type) ")"
+               (if (type-null? type)
+                   "sexp_cpointer_maybe_null_value"
+                   "sexp_cpointer_value")
+               "(" val ")"))
+         (else
+          (error "unknown type" base))))))))
+
+(define (base-type-c-name base)
+  (case base
+    ((string env-string non-null-string bytevector)
+     (if *c++?* "string" "char*"))
+    ((fileno fileno-nonblock) "int")
+    (else (string-replace (symbol->string base) #\- " "))))
+
+(define (type-struct-type type)
+  (let ((type-spec (lookup-type (if (vector? type) (type-base type) type))))
+    (cond ((and type-spec (memq 'type: type-spec)) => cadr)
+          (else #f))))
+
+(define (type-c-name-derefed type)
+  (let* ((type (parse-type type))
+         (base (type-base type))
+         (type-spec (lookup-type base))
+         (struct-type (type-struct-type type)))
+    (string-append
+     (if (type-const? type) "const " "")
+     (if (and struct-type (not *c++?*))
+         (string-append (symbol->string struct-type) " ")
+         "")
+     (base-type-c-name base)
+     (if (type-template type)
+         (string-append
+          "<"
+          (string-concatenate (map type-c-name (type-template type)) ", ")
+          ">")
+         ""))))
+
+(define (type-c-name type)
+  (let ((type (parse-type type)))
+    (string-append
+     (type-c-name-derefed type)
+     (if (type-struct-type type) "*" "")
+     (if (type-pointer? type) "*" ""))))
+
+(define (type-finalizer-name type)
+  (let ((name (type-c-name-derefed type)))
+    (string-append "sexp_finalize_" (string-replace name #\: "_"))))
+
+(define (check-type arg type)
+  (let* ((type (parse-type type))
+         (base (type-base type)))
+    (cond
+     ((eq? base 'env-string)
+      (cat "(sexp_pairp(" arg ") && sexp_stringp(sexp_car(" arg
+           ")) && sexp_stringp(sexp_cdr(" arg ")))"))
+     ((memq base '(fileno fileno-nonblock))
+      (cat "(sexp_filenop(" arg ") || sexp_fixnump(" arg "))"))
+     ((string-type? base)
+      (cat
+       (if (type-null? type) "(" "")
+       (type-predicate type) "(" arg ")"
+       (lambda () (if (type-null? type) (cat " || sexp_not(" arg "))")))))
+     ((or (eq? base 'char) (eq? base 'bytevector) (int-type? base)
+          (float-type? base) (port-type? base))
+      (cat (type-predicate type) "(" arg ")"))
+     ((or (lookup-type base) (void-pointer-type? type))
+      (cat
+       (if (type-null? type) "(" "")
+       "(sexp_pointerp(" arg  ")"
+       " && (sexp_pointer_tag(" arg  ") == "
+       (if (void-pointer-type? type)
+           "SEXP_CPOINTER"
+           (type-id-number type))
+       "))"
+       (lambda () (if (type-null? type) (cat " || sexp_not(" arg "))")))))
+     (else
+      (warn "don't know how to check" type)
+      (cat "1")))))
+
+(define (write-validator arg type)
+  (let* ((type (parse-type type))
+         (array (type-array type))
+         (base-type (type-base type)))
+    (cond
+     ((and array (not (string-type? type)))
+      (cond
+       ((number? array)
+        (cat "  if (!sexp_listp(ctx, " arg ")"
+             "      || sexp_unbox_fixnum(sexp_length(ctx, " arg ")) != " array ")\n"
+             "    return sexp_type_exception(ctx, self, SEXP_PAIR, " arg ");\n")))
+      (cat "  for (res=" arg "; sexp_pairp(res); res=sexp_cdr(res))\n"
+           "    if (! " (lambda () (check-type "sexp_car(res)" type)) ")\n"
+           "      return sexp_xtype_exception(ctx, self, \"not a list of "
+           (type-name type) "s\", " arg ");\n")
+      (if (not (number? array))
+          (cat "  if (! sexp_nullp(res))\n"
+               "    return sexp_xtype_exception(ctx, self, \"not a list of "
+               (type-name type) "s\", " arg ");\n")))
+     ((eq? base-type 'port-or-fileno)
+      (cat "  if (! (sexp_portp(" arg ") || sexp_filenop(" arg ") || sexp_fixnump(" arg ")))\n"
+           "    return sexp_xtype_exception(ctx, self, \"not a port or file descriptor\"," arg ");\n"))
+     ((or (int-type? base-type)
+          (float-type? base-type)
+          (string-type? base-type)
+          (port-type? base-type)
+          (memq base-type '(bytevector fileno fileno-nonblock))
+          (and (not array) (eq? 'char base-type)))
+      (cat
+       "  if (! " (lambda () (check-type arg type)) ")\n"
+       "    return sexp_type_exception(ctx, self, "
+       (type-id-number type) ", " arg ");\n"))
+     ((or (lookup-type base-type) (void-pointer-type? type))
+      (cat
+       "  if (! " (lambda () (check-type arg type)) ")\n"
+       "    return sexp_type_exception(ctx, self, "
+       (type-id-number type) ", " arg ");\n"))
+     ((eq? 'sexp base-type))
+     ((string-type? type)
+      (write-validator arg 'string))
+     ((memq base-type '(bool boolean status-bool)))
+     (else
+      (warn "don't know how to validate" type)))))
+
+(define (write-parameters args)
+  (lambda () (for-each (lambda (a) (cat ", sexp arg" (type-index a))) args)))
+
+(define (take ls n)
+  (let lp ((ls ls) (n n) (res '()))
+    (if (zero? n) (reverse res) (lp (cdr ls) (- n 1) (cons (car ls) res)))))
+
+(define max-gc-vars 7)
+
+(define (write-gc-vars ls . o)
+  (let ((num-gc-vars (length ls)))
+    (cond
+     ((zero? num-gc-vars))
+     ((<= num-gc-vars max-gc-vars)
+      (cat "  sexp_gc_var" num-gc-vars "(")
+      (display (car ls))
+      (for-each (lambda (x) (display ", ") (display x)) (cdr ls))
+      (cat ");\n"))
+     (else
+      (write-gc-vars (take ls max-gc-vars))
+      (let lp ((ls (list-tail ls max-gc-vars))
+               (i (+ max-gc-vars 1)))
+        (cond
+         ((pair? ls)
+          (cat "  sexp_gc_var(" (car ls) ", __sexp_gc_preserver" i ");\n")
+          (lp (cdr ls) (+ i 1)))))))))
+
+(define (write-gc-preserves ls)
+  (let ((num-gc-vars (length ls)))
+    (cond
+     ((zero? num-gc-vars))
+     ((<= num-gc-vars max-gc-vars)
+      (cat "  sexp_gc_preserve" num-gc-vars "(ctx")
+      (for-each (lambda (x) (display ", ") (display x)) ls)
+      (cat ");\n"))
+     (else
+      (write-gc-preserves (take ls max-gc-vars))
+      (let lp ((ls (list-tail ls max-gc-vars))
+               (i (+ max-gc-vars 1)))
+        (cond
+         ((pair? ls)
+          (cat "  sexp_gc_preserve(ctx, " (car ls)
+               ", __sexp_gc_preserver" i ");\n")
+          (lp (cdr ls) (+ i 1)))))))))
+
+(define (write-gc-release ls)
+  (if (pair? ls)
+      (cat "  sexp_gc_release" (min max-gc-vars (length ls)) "(ctx);\n")))
+
+(define (get-array-length func x)
+  (let ((len (if (pair? (type-array x))
+                 (car (reverse (type-array x)))
+                 (type-array x))))
+    (cond
+     ((number? len)
+      len)
+     (else
+      (and func
+           (symbol? len)
+           (let* ((str (symbol->string len))
+                  (len2 (string-length str)))
+             (and (> len2 3)
+                  (string=? "arg" (substring str 0 3))
+                  (let ((i (string->number (substring str 3 len2))))
+                    (if i
+                        (let ((y (list-ref (func-c-args func) i)))
+                          (or (type-value y) len)))))))))))
+
+(define (write-locals func)
+  (define (arg-res x)
+    (string-append "res" (type-index-string x)))
+  (let* ((ret-type (func-ret-type func))
+         (results (func-results func))
+         (scheme-args (func-scheme-args func))
+         (return-res? (not (error-type? (type-base ret-type))))
+         (preserve-res? (> (+ (length results)) (if return-res? 0 1)))
+         (single-res? (and (= 1 (length results)) (not return-res?)))
+         (tmp-string? (any (lambda (a)
+                             (and (type-array a)
+                                  (string-type? (type-base a))))
+                           (cons ret-type results)))
+         (gc-vars (map arg-res results))
+         (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars))
+         (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars))
+         (sexps (if preserve-res? '() '("res")))
+         (ints (if (or return-res?
+                       (memq (type-base ret-type)
+                             '(status-bool non-null-string non-null-pointer)))
+                   '()
+                   '("err")))
+         (ints (if (or (array-type? ret-type)
+                       (any array-type? results)
+                       (any array-type? scheme-args))
+                   (cons "i" ints)
+                   ints)))
+    (case (type-base ret-type)
+      ((status-bool) (cat "  bool err;\n"))
+      ((non-null-string) (cat "  char *err;\n"))
+      ((non-null-pointer) (cat "  void *err;\n")))
+    (cond
+     ((pair? ints)
+      (cat "  int " (car ints))
+      (for-each (lambda (x) (display ", ") (display x)) (cdr ints))
+      (cat ";\n")))
+    (if (any (lambda (a) (eq? 'env-string (type-base a)))
+             (cons ret-type results))
+        (cat "  char *p;\n"))
+    (for-each
+     (lambda (x)
+       (let ((len (get-array-length func x)))
+         (cat "  " (if (type-const? x) "const " "")
+              (type-c-name (type-base x)) " ")
+         (if (or (and (type-array x) (not (number? len))) (type-pointer? x))
+             (cat "*"))
+         (cat (if (type-auto-expand? x) "buf" "tmp") (type-index-string x))
+         (if (number? len)
+             (cat "[" len "]"))
+         (if (type-reference? x)
+             (cat " = NULL"))
+         (cat ";\n")
+         (if (or (vector? len) (type-auto-expand? x))
+             (cat "  int len" (type-index x) ";\n"))
+         (if (type-auto-expand? x)
+             (cat "  " (type-c-name (type-base x))
+                  " *tmp" (type-index-string x) ";\n"))))
+     (append (if (or (type-array ret-type) (type-pointer? ret-type))
+                 (list ret-type)
+                 '())
+             results
+             (remove type-result? (filter type-array scheme-args))))
+    (for-each
+     (lambda (arg)
+       (cond
+        ((and (type-pointer? arg) (basic-type? arg))
+         (cat "  " (type-c-name (type-base arg))
+              " tmp" (type-index arg) ";\n"))))
+     scheme-args)
+    (cond
+     ((pair? sexps)
+      (cat "  sexp " (car sexps))
+      (for-each (lambda (x) (display ", ") (display x)) (cdr sexps))
+      (cat ";\n")))
+    ;; Declare the gc vars.
+    (write-gc-vars gc-vars)
+    ;; Shortcut returns should come before preserving.
+    (write-validators (func-scheme-args func))
+    (write-additional-checks (func-c-args func))
+    ;; Preserve the gc vars.
+    (write-gc-preserves gc-vars)))
+
+(define (write-validators args)
+  (for-each
+   (lambda (a)
+     (write-validator (string-append "arg" (type-index-string a)) a))
+   args))
+
+(define (write-additional-checks args)
+  (for-each
+   (lambda (a)
+     (if (port-type? (type-base a))
+         (cat "  if (!sexp_stream_portp(arg" (type-index a) "))\n"
+              "    return sexp_xtype_exception(ctx, self,"
+              " \"not a FILE* backed port\", arg" (type-index a) ");\n")))
+   args)
+  (for-each
+   (lambda (a)
+     (if (eq? 'input-port (type-base a))
+         (cat "  sexp_check_block_port(ctx, arg" (type-index a) ", 0);\n")))
+   args))
+
+(define (scheme-procedure->c name)
+  (cond
+   ((eq? name 'string-length) 'sexp_string_length)
+   ((eq? name 'string-size) 'sexp_string_size)
+   ((eq? name 'bytevector-length) 'sexp_bytes_length)
+   (else name)))
+
+(define (write-value func val)
+  (cond
+   ((find (lambda (x)
+            (and (type-array x)
+                 (type-auto-expand? x)
+                 (eq? val (get-array-length func x))))
+          (func-c-args func))
+    => (lambda (x) (cat "len" (type-index x))))
+   ((lookup-type val)
+    (cat (or (type-struct-type val) "") " " val))
+   ((and (pair? val) (list? val))
+    (write (scheme-procedure->c (car val)))
+    (cat
+     "("
+     (lambda ()
+       (cond
+        ((pair? (cdr val))
+         (write-value func (cadr val))
+         (for-each (lambda (x) (display ", ") (write-value func x)) (cddr val)))))
+     ")"))
+   (else
+    (write val))))
+
+(define (write-actual-parameter func arg)
+  (cond
+   ((or (type-result? arg) (type-array arg))
+    (cat (if (or (type-free? arg) (type-reference? arg) (basic-type? arg))
+             "&"
+             "")
+         "tmp" (type-index arg)))
+   ((and (not (type-default? arg)) (type-value arg))
+    => (lambda (x) (write-value func x)))
+   ((and (type-pointer? arg) (basic-type? arg))
+    (cat "&tmp" (type-index arg)))
+   (else
+    (scheme->c-converter
+     arg
+     (string-append "arg" (type-index-string arg))))))
+
+(define (write-temporaries func)
+  (for-each
+   (lambda (a)
+     (let ((len (and (type-array a) (get-array-length func a))))
+       (cond
+        ((and (type-array a) (or (vector? len) (type-auto-expand? a)))
+         (cat "  len" (type-index a) " = "
+              (lambda ()
+                (if (number? len) (cat len) (scheme->c-converter 'int len)))
+              ";\n"
+              "  tmp" (type-index a) " = buf" (type-index a) ";\n")))
+       (cond
+        ((and (not (type-result? a)) (type-array a) (not (string-type? a)))
+         (if (not (number? (type-array a)))
+             (if (and *c++?* (type-new? a))
+                 (cat "  tmp" (type-index a)
+                      " = new " (type-c-name-derefed (type-base a)) "();\n")
+                 (cat "  tmp" (type-index a)
+                      " = (" (type-c-name (type-base a)) "*) calloc("
+                      "(sexp_unbox_fixnum(sexp_length(ctx, arg" (type-index a)
+                      "))+1), sizeof(tmp" (type-index a) "[0]));\n")))
+         (cat "  for (i=0, res=arg" (type-index a)
+              "; sexp_pairp(res); res=sexp_cdr(res), i++) {\n"
+              "    tmp" (type-index a) "[i] = "
+              (lambda () (scheme->c-converter (type-base a) "sexp_car(res)"))
+              ";\n"
+              "  }\n")
+         (if (not (number? (type-array a)))
+             (cat "  tmp" (type-index a) "[i] = 0;\n")))
+        ((and (type-result? a) (not (basic-type? a))
+              (not (type-free? a)) ;;(not (type-pointer? a))
+              (not (type-reference? a))
+              (not (type-auto-expand? a))
+              (or (not (type-array a))
+                  (not (integer? len))))
+         (if (and *c++?* (type-new? a))
+             (cat "  tmp" (type-index a)
+                  " = new " (type-c-name-derefed (type-base a)) "();\n")
+             (cat "  tmp" (type-index a) " = calloc(1, 1 + "
+                  (if (and (symbol? len) (not (eq? len 'null)))
+                      (lambda () (cat (lambda () (scheme->c-converter 'unsigned-int len))
+                                 "*sizeof(tmp" (type-index a) "[0])"))
+                      (lambda () (cat "sizeof(tmp" (type-index a) "[0])")))
+                  ");\n"
+                  (lambda ()
+                    (if (and (symbol? len) (not (eq? len 'null)))
+                        (cat "  tmp" (type-index a) "["
+                             (lambda () (scheme->c-converter 'unsigned-int len))
+                             "*sizeof(tmp" (type-index a) "[0])] = 0;\n"))))))
+        ((and (type-result? a) (type-value a))
+         (cat "  tmp" (type-index a) " = "
+              (lambda () (write-value func (type-value a))) ";\n"))
+        ((and (type-pointer? a) (basic-type? a))
+         (cat "  tmp" (type-index a) " = "
+              (lambda ()
+                (scheme->c-converter
+                 a
+                 (string-append "arg" (type-index-string a))))
+              ";\n")))))
+   (func-c-args func)))
+
+(define (write-call func)
+  (let ((ret-type (func-ret-type func))
+        (c-name (func-c-name func))
+        (c-args (func-c-args func)))
+    (if (any type-auto-expand? (func-c-args func))
+        (cat " loop:\n"))
+    (cat (cond ((error-type? (type-base ret-type)) "  err = ")
+               ((type-array ret-type) "  tmp = ")
+               (else "  res = ")))
+    ((if (type-array ret-type)
+         (lambda (t f x) (f))
+         c->scheme-converter)
+     ret-type
+     (lambda ()
+       (if (and *c++?* (type-new? ret-type))
+           (cat "new "))
+       (if (func-method? func)
+           (cat "(" (lambda () (write-actual-parameter func (car c-args)))
+                ")->" c-name)
+           (cat c-name))
+       (cat "(")
+       (for-each
+        (lambda (arg)
+          (if (> (type-index arg) (if (func-method? func) 1 0)) (cat ", "))
+          (write-actual-parameter func arg))
+        (if (func-method? func) (cdr c-args) c-args))
+       (cat ")"))
+     (cond
+      ((find type-link? (func-c-args func))
+       => (lambda (a) (string-append "arg" (type-index-string a))))
+      (else #f)))
+    (cat ";\n")
+    (if (type-array ret-type)
+        (write-result ret-type)
+        (write-result-adjustment ret-type))))
+
+(define (write-result-adjustment result)
+  (cond
+   ;; new port results are automatically made non-blocking
+   ((memq (type-base result) '(input-port output-port input-output-port))
+    (let ((res (string-append "res" (type-index-string result))))
+      (cat "#ifdef SEXP_USE_GREEN_THREADS\n"
+           "  if (sexp_portp(" res "))\n"
+           "    fcntl(fileno(sexp_port_stream(" res ")), F_SETFL, O_NONBLOCK "
+           " | fcntl(fileno(sexp_port_stream(" res ")), F_GETFL));\n"
+           "#endif\n")))
+   ;; a file descriptor result can be automatically made non-blocking
+   ;; by specifying a result type of fileno-nonblock
+   ((memq (type-base result) '(fileno-nonblock))
+    (let ((res (string-append "res" (type-index-string result))))
+      (cat "#ifdef SEXP_USE_GREEN_THREADS\n"
+           "  if (sexp_filenop(" res "))\n"
+           "    fcntl(sexp_fileno_fd(" res "), F_SETFL, O_NONBLOCK "
+           " | fcntl(sexp_fileno_fd(" res "), F_GETFL));\n"
+           "#endif\n")))))
+
+(define (write-result result . o)
+  (let ((res (string-append "res" (type-index-string result)))
+        (tmp (string-append "tmp" (type-index-string result))))
+    (cond
+     ((and (type-array result) (eq? 'char (type-base result)))
+      (cat "  " res " = " (lambda () (c->scheme-converter result tmp)) ";\n"))
+     ((type-array result)
+      (cat "  " res " = SEXP_NULL;\n")
+      (let ((auto-expand?
+             (and (pair? (type-array result))
+                  (memq 'auto-expand (type-array result))))
+            (len (if (pair? (type-array result))
+                     (car (reverse (type-array result)))
+                     (type-array result))))
+        (cond
+         ((eq? 'null len)
+          (cat "  for (i=0; " tmp "[i]; i++) {\n"
+               "    sexp_push(ctx, " res ", "
+               (if (eq? 'string (type-base result))
+                   "str="
+                   (lambda () (cat "SEXP_VOID);\n    sexp_car(" res ") = ")))
+               (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]"))))
+               ");\n"
+               "  }\n"
+               "  " res " = sexp_nreverse(ctx, " res ");\n"))
+         (else
+          (cat "  for (i=" len "-1; i>=0; i--) {\n"
+               "    sexp_push(ctx, " res ", SEXP_VOID);\n"
+               "    sexp_car(" res ") = "
+               (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]"))))
+               ";\n"
+               "  }\n")))))
+     (else
+      (cat "  " res " = ")
+      (apply
+       c->scheme-converter
+       result
+       (string-append "tmp" (type-index-string result))
+       o)
+      (cat ";\n")))
+    (write-result-adjustment result)))
+
+(define (write-results func)
+  (let ((error-res? (error-type? (type-base (func-ret-type func))))
+        (void-res? (eq? 'void (type-base (func-ret-type func))))
+        (results (func-results func)))
+    (if error-res?
+        (cat "  if ("
+             (if (memq (type-base (func-ret-type func))
+                       '(status-bool non-null-string non-null-pointer))
+                 "!"
+                 "")
+             "err) {\n"
+             (cond
+              ((find type-auto-expand? (func-c-args func))
+               => (lambda (a)
+                    (lambda ()
+                      (let ((len (get-array-length func a))
+                            (i (type-index a)))
+                        (if (number? len)
+                            (cat "  if (len" i " != " len ")\n"
+                                 "    free(tmp" i ");\n"))
+                        (cat "  len" i " *= 2;\n"
+                             "  tmp" i
+                             " = calloc(len" i ", sizeof(tmp" i "[0]));\n"
+                             "  goto loop;\n")))))
+              (else
+               ;; TODO: free other results
+               "  res = SEXP_FALSE;\n"))
+             "  } else {\n"))
+    (if (null? results)
+        (if error-res?
+            (cat "  res = SEXP_TRUE;\n"))
+        (let ((first-result-link
+               ;; the `link' modifier applies to the first result when
+               ;; there are multiple results
+               (and
+                (not (lookup-type (func-ret-type func)))
+                (cond
+                 ((find type-link? (func-c-args func))
+                  => (lambda (a) (string-append "arg" (type-index-string a))))
+                 (else #f)))))
+          (write-result (car results) first-result-link)
+          (for-each write-result (cdr results))))
+    (cond
+     ((> (length results) (if (or error-res? void-res?) 1 0))
+      (if (or error-res? void-res?)
+          (cat "  res = SEXP_NULL;\n")
+          (cat "  res = sexp_cons(ctx, res, SEXP_NULL);\n"))
+      (for-each
+       (lambda (x)
+         (if (or error-res? void-res?)
+             (cat "  sexp_push(ctx, res, res" (type-index x) ");\n")
+             (cat "  sexp_push(ctx, res, sexp_car(res));\n"
+                  "  sexp_cadr(res) = res" (type-index x) ";\n")))
+       (reverse results)))
+     ((pair? results)
+      (cat "  res = res" (type-index (car results)) ";\n")))
+    (if error-res?
+        (cat "  }\n"))))
+
+(define (write-free type)
+  (if (and (type-array type) (not (number? (type-array type))))
+      (cat "  free(tmp" (type-index-string type) ");\n")))
+
+(define (write-cleanup func)
+  (for-each write-free (func-scheme-args func))
+  (for-each
+   (lambda (a)
+     (cond
+      ((type-auto-expand? a)
+       (let ((len (get-array-length func a))
+             (i (type-index a)))
+         (if (number? len)
+             (cat "  if (len" i " != " len ")\n"
+                  "    free(tmp" i ");\n"))))
+      ((memq (type-base a) '(input-port input-output-port))
+       (cat "  sexp_maybe_unblock_port(ctx, arg" (type-index a) ");\n"))
+      ((and (type-result? a) (not (basic-type? a))
+            (not (lookup-type (type-base a)))
+            (not (type-free? a)) (not (type-pointer? a))
+            (or (not (type-array a))
+                (not (integer? (get-array-length func a)))))
+       ;; the above is hairy - basically this frees temporary strings
+       (cat "  free(tmp" (type-index a) ");\n"))))
+   (func-c-args func))
+  (let* ((results (func-results func))
+         (return-res? (not (error-type? (type-base (func-ret-type func)))))
+         (preserve-res? (> (+ (length results)) (if return-res? 0 1)))
+         (single-res? (and (= 1 (length results)) (not return-res?)))
+         (tmp-string? (any (lambda (a)
+                             (and (type-array a)
+                                  (string-type? (type-base a))))
+                           (cons (func-ret-type func)
+                                 (func-results func))))
+         (gc-vars results)
+         (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars))
+         (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)))
+    (write-gc-release gc-vars)))
+
+(define (write-func-declaration func)
+  (cat "static sexp " (func-stub-name func)
+       " (sexp ctx, sexp self, sexp_sint_t n"
+       (write-parameters (func-scheme-args func)) ")"))
+
+(define (write-func func)
+  (write-func-declaration func)
+  (cat " {\n")
+  (write-locals func)
+  (write-temporaries func)
+  (write-call func)
+  (write-results func)
+  (write-cleanup func)
+  (cat "  return res;\n"
+       "}\n\n"))
+
+(define (adjust-method-name! func i)
+  (func-stub-name-set!
+   func
+   (string-append (func-stub-name func) "__" (number->string i))))
+
+(define (write-primitive-call func args)
+  (cat (func-stub-name func)
+       "(" (lambda () (join (append '(ctx self n) args) ", ")) ")"))
+
+(define (write-fixed-arity-method meth)
+  (define (write-dispatch func)
+    (write-primitive-call
+     func
+     (map (lambda (a) (string-append "arg" (type-index-string a)))
+          (func-scheme-args func))))
+  (define (write-method-validators func)
+    (cond
+     ((not (pair? (cdr (func-scheme-args func))))
+      (warn "no arguments to distinguish" func)
+      (cat "1"))
+     (else
+      (let lp ((ls (cdr (func-scheme-args func))))
+        (check-type (string-append "arg" (type-index-string (car ls))) (car ls))
+        (cond
+         ((pair? (cdr ls))
+          (cat " && ")
+          (lp (cdr ls))))))))
+  (case (length meth)
+    ((0 1)
+     (error "invalid method" meth))
+    ((2)
+     (write-func (cadr meth)))
+    (else
+     (let ((orig-stub-name (func-stub-name (cadr meth))))
+       (do ((ls (cdr meth) (cdr ls)) (i 0 (+ i 1)))
+           ((null? ls))
+         (adjust-method-name! (car ls) i)
+         (write-func (car ls)))
+       (let ((new-stub-name (func-stub-name (cadr meth))))
+         (func-stub-name-set! (cadr meth) orig-stub-name)
+         (write-func-declaration (cadr meth))
+         (func-stub-name-set! (cadr meth) new-stub-name)
+         (cat " {\n"
+              "  sexp orig_self = self;\n")
+         (write-validator "arg0" (car (func-scheme-args (cadr meth))))
+         (let lp ((ls (cdr meth)) (i 0))
+           (cat "  self = sexp_vector_ref(sexp_opcode_methods(orig_self), "
+                (make-integer i) ");\n")
+           (cond
+            ((null? (cdr ls))
+             (cat "  return " (lambda () (write-dispatch (car ls))) ";\n"))
+            (else
+             (cat "  if ("
+                  (lambda () (write-method-validators (car ls))) ") {\n"
+                  "    return " (lambda () (write-dispatch (car ls))) ";\n"
+                  "  }\n" (lambda () (lp (cdr ls) (+ i 1)))))))
+         (cat "}\n\n")
+         (func-stub-name-set! (cadr meth) orig-stub-name))))))
+
+(define (write-method meth)
+  (let ((args (map func-scheme-args (cdr meth))))
+    (if (and (> (length args) 1)
+             (not (apply = (map length args))))
+        (error "methods must have the same arity")))
+  (write-fixed-arity-method meth))
+
+(define (parameter-default? x)
+  (and (pair? x)
+       (member x '((current-input-port)
+                   (current-output-port)
+                   (current-error-port)))))
+
+(define (write-default x) ;; this is a hack but very convenient
+  (lambda ()
+    (let ((value (type-value x)))
+      (cond
+       ((equal? value '(current-input-port))
+        (cat "\"current-input-port\""))
+       ((equal? value '(current-output-port))
+        (cat "\"current-output-port\""))
+       ((equal? value '(current-error-port))
+        (cat "\"current-error-port\""))
+       ((equal? value 'NULL)
+        (cat "SEXP_FALSE"))
+       (else
+        (c->scheme-converter x value))))))
+
+(define (write-func-creation var func . o)
+  (let ((default (and (pair? (func-scheme-args func))
+                      (type-default? (car (reverse (func-scheme-args func))))
+                      (car (reverse (func-scheme-args func)))))
+        (no-bind? (and (pair? o) (car o))))
+    (cat "  " var " = "
+         (cond
+          (no-bind?
+           "sexp_make_foreign(ctx, ")
+          ((not default)
+           "sexp_define_foreign(ctx, env, ")
+          ((parameter-default? (type-value default))
+           "sexp_define_foreign_param(ctx, env, ")
+          (else
+           "sexp_define_foreign_opt(ctx, env, "))
+         (lambda () (write (symbol->string (func-scheme-name func))))
+         ", " (length (func-scheme-args func))  ", "
+         (if no-bind?
+             (lambda ()
+               (cat (cond ((not default) 0)
+                          ((parameter-default? (type-value default)) 3)
+                          (else 1))
+                    ", "))
+             "")
+         "(sexp_proc1)" (func-stub-name func)
+         (cond
+          (default (lambda () (cat ", " (write-default default))))
+          (no-bind? ", SEXP_VOID")
+          (else ""))
+         ");\n")))
+
+(define (write-func-types var func)
+  (cond
+   ((or (not (eq? 'sexp (type-base (func-ret-type func))))
+        (and (pair? (func-c-args func))
+             (any (lambda (a) (not (eq? 'sexp (type-base a))))
+                  (func-c-args func))))
+    (cat
+     "  if (sexp_opcodep(" var ")) {\n"
+     "    sexp_opcode_return_type(" var ") = "
+     (type-id-init-value (func-ret-type func)) ";\n"
+     (lambda ()
+       (do ((ls (func-c-args func) (cdr ls))
+            (i 1 (+ i 1)))
+           ((null? ls))
+         (cond
+          ((eq? 'sexp (type-base (car ls))))
+          ((<= i 3)
+           (cat "    sexp_opcode_arg" i "_type(" var ") = "
+                (type-id-init-value (car ls)) ";\n"))
+          (else
+           (if (= i 4)
+               (cat "    sexp_opcode_argn_type(" var ") = "
+                    "sexp_make_vector(ctx, "
+                    (make-integer (- (length (func-c-args func)) 3)) ", "
+                    (make-integer "SEXP_OBJECT") ");\n"))
+           (cat "    sexp_vector_set(sexp_opcode_argn_type(" var "), "
+                (make-integer (- i 4)) ", "
+                (type-id-init-value (car ls)) ");\n")))))
+     ;; "  } else {\n"
+     ;; "    sexp_warn(ctx, \"couldn't generated opcode\", " var ");\n"
+     "  }\n")))
+  (cond
+   ((assq (func-scheme-name func) *type-getters*)
+    => (lambda (x)
+         (let ((name (cadr x))
+               (i (car (cddr x))))
+           (cat "  if (sexp_vectorp(sexp_type_getters(" (type-id-name name)
+                "))) sexp_vector_set(sexp_type_getters("
+                (type-id-name name) "), "
+                (make-integer i) ", " var ");\n"))))
+   ((assq (func-scheme-name func) *type-setters*)
+    => (lambda (x)
+         (let ((name (cadr x))
+               (i (car (cddr x))))
+           (cat "  if (sexp_vectorp(sexp_type_setters(" (type-id-name name)
+                "))) sexp_vector_set(sexp_type_setters("
+                (type-id-name name) "), "
+                (make-integer i) ", " var ");\n"))))))
+
+(define (write-func-binding func . o)
+  (let ((var (if (pair? o) (car o) "op")))
+    (write-func-creation var func)
+    (write-func-types var func)))
+
+(define (write-method-binding meth)
+  (write-func-binding (cadr meth))
+  (cat "  if (sexp_opcodep(op)) {\n"
+       (lambda ()
+         (cat "    sexp_opcode_methods(op) = "
+              "sexp_make_vector(ctx, " (make-integer (length (cdr meth)))
+              ", SEXP_VOID);\n")
+         (do ((ls (cdr meth) (cdr ls)) (i 0 (+ i 1)))
+             ((null? ls))
+           (let ((var (string-append
+                       "sexp_vector_ref(sexp_opcode_methods(op), "
+                       (make-integer i) ")")))
+             (write-func-creation var (car ls) #t)
+             (write-func-types var (car ls)))))
+       "  }\n"))
+
+(define (write-type orig-type)
+  (let* ((name (car orig-type))
+         (scheme-name (strip-namespace (type-name name)))
+         (type (cdr orig-type))
+         (imported? (cond ((member 'imported?: type) => cadr) (else #f))))
+    (cond
+     (imported?
+      (cat "  name = sexp_intern(ctx, \"" scheme-name "\", -1);\n"
+           "  " (type-id-name name) " = sexp_env_ref(env, name, SEXP_FALSE);\n"
+           "  if (sexp_not(" (type-id-name name) ")) {\n"
+           "    sexp_warn(ctx, \"couldn't import declared type: \", name);\n"
+           "  }\n"))
+     (else
+      (cat "  name = sexp_c_string(ctx, \"" scheme-name "\", -1);\n"
+           "  " (type-id-name name)
+           " = sexp_register_c_type(ctx, name, "
+           (cond ((or (memq 'finalizer: type)
+                      (memq 'finalizer-method: type))
+                  => (lambda (x)
+                       (let ((name (cadr x)))
+                         (generate-stub-name
+                          (if (pair? name) (car name) name)))))
+                 (*c++?*
+                  (type-finalizer-name name))
+                 (else
+                  "sexp_finalize_c_type"))
+           ");\n"
+           "  tmp = sexp_string_to_symbol(ctx, name);\n"
+           "  sexp_env_define(ctx, env, tmp, " (type-id-name name) ");\n")
+      (if (pair? (struct-fields type))
+          (let ((len (make-integer (length (struct-fields type)))))
+            (cat "  sexp_type_slots(" (type-id-name name) ") = SEXP_NULL;\n"
+                 (lambda ()
+                   (do ((ls (reverse (struct-fields type)) (cdr ls)))
+                       ((not (pair? ls)))
+                     (cat "  sexp_push(ctx, sexp_type_slots("
+                          (type-id-name name) "), "
+                          "sexp_intern(ctx, "
+                          (lambda () (write (x->string (cadr (car ls)))))
+                          ", -1));\n")))
+                 "  sexp_type_getters(" (type-id-name name) ")"
+                 " = sexp_make_vector(ctx, " len ", SEXP_FALSE);\n"
+                 "  sexp_type_setters(" (type-id-name name) ")"
+                 " = sexp_make_vector(ctx, " len ", SEXP_FALSE);\n")))
+      (cond
+       ((memq 'predicate: type)
+        => (lambda (x)
+             (let ((pred (cadr x)))
+               (cat "  tmp = sexp_make_type_predicate(ctx, name, "
+                    (type-id-name name) ");\n"
+                    "  name = sexp_intern(ctx, \"" pred "\", "
+                    (string-length (x->string pred)) ");\n"
+                    "  sexp_env_define(ctx, env, name, tmp);\n")))))))))
+
+(define (type-getter-name type name field)
+  (let ((c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field))))
+    (string-replace
+     (string-append "sexp_" (x->string (type-name (parse-type name)))
+                    "_get_" (x->string c-name))
+     #\: "_")))
+
+(define (verify-accessor field)
+  (if (and (pair? field)
+           (not (and (= 3 (length field))
+                     (memq (cadr field) '(function: method:)))))
+      (error "accessor should be a single symbol or (scheme-name function:|method: c-name) but got" field)))
+
+(define (write-type-getter type name field)
+  (let* ((get (car (cddr field)))
+         (_ (verify-accessor get))
+         (c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field)))
+         (ptr (string-append
+               "((" (x->string (or (type-struct-type name) ""))
+               " " (x->string name) "*)"
+               "sexp_cpointer_value(x))")))
+    (cat "static sexp " (type-getter-name type name field)
+         " (sexp ctx, sexp self, sexp_sint_t n, sexp x) {\n"
+         (lambda () (write-validator "x" (parse-type name 0)))
+         "  return "
+         (lambda ()
+           (c->scheme-converter
+            (car field)
+            (cond
+             ((and (pair? get) (eq? 'function: (cadr get)))
+              (string-append (car (cddr get)) "(" ptr ")"))
+             ((and (pair? get) (eq? 'method: (cadr get)))
+              (string-append ptr "->" (car (cddr get)) "()"))
+             ((pair? get)
+              (error "invalid getter" get))
+             (else
+              (string-append
+               (if (type-struct? (car field)) "&" "")
+               ptr "->" (x->string c-name))))
+            (and (or (type-struct? (car field)) (type-link? (car field)))
+                 "x")))
+         ";\n"
+         "}\n\n")))
+
+(define (type-setter-name type name field)
+  (let ((c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field))))
+    (string-replace
+     (string-append "sexp_" (x->string (type-name (parse-type name)))
+                    "_set_" (x->string c-name))
+     #\: "_")))
+
+(define (write-type-setter-assignment type name field dst val)
+  (let* ((set (cadr (cddr field)))
+         (_ (verify-accessor set))
+         (c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field)))
+         (ptr (string-append
+               "((" (x->string (or (type-struct-type name) ""))
+               " " (x->string name) "*)"
+               "sexp_cpointer_value(" (x->string dst) "))")))
+    (cond
+     ((and (pair? set) (eq? 'function: (cadr set)))
+      (lambda ()
+        (cat (car (cddr set)) "(" ptr ", "
+             (lambda () (scheme->c-converter (car field) val)) ");\n")))
+     ((and (pair? set) (eq? 'method: (cadr set)))
+      (lambda ()
+        (cat ptr "->" (car (cddr set)) "("
+             (lambda () (scheme->c-converter (car field) val)) ");\n")))
+     ((pair? set)
+      (error "invalid setter" set))
+     ((type-struct? (car field))
+      ;; assign to a nested struct - copy field-by-field
+      (let ((field-type
+             (cond ((lookup-type (type-name (car field)))
+                    => (lambda (x) (cddr (cdr x))))
+                   (else (cdr field)))))
+        (lambda ()
+          (for-each
+           (lambda (subfield)
+             (let ((subname (x->string (cadr subfield))))
+               (cat
+                "  "
+                (string-append dst "." (x->string (cadr subfield)))
+                " = "
+                (string-append
+                 "((" (x->string (or (type-struct-type (type-name (car field)))
+                                     ""))
+                 " " (mangle (type-name (car field))) "*)"
+                 "sexp_cpointer_value(" val "))"
+                 "->" (x->string (cadr subfield)))
+                ";\n")))
+           (struct-fields field-type)))))
+     (else
+      (lambda ()
+        (cat "  " ptr "->" c-name " = "
+             (lambda () (scheme->c-converter (car field) val)) ";\n"))))))
+
+(define (write-type-setter type name field)
+  (cat "static sexp " (type-setter-name type name field)
+       " (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp v) {\n"
+       (lambda () (write-validator "x" (parse-type name 0)))
+       (lambda () (write-validator "v" (parse-type (car field) 1)))
+       (write-type-setter-assignment type name field "x" "v")
+       "  return SEXP_VOID;\n"
+       "}\n\n"))
+
+(define (write-type-funcs-helper orig-type name type)
+  ;; maybe write finalizer
+  (cond
+   ((or (memq 'finalizer: type) (memq 'finalizer-method: type))
+    => (lambda (x)
+         (let* ((y (cadr x))
+                (scheme-name (if (pair? y) (car y) y))
+                (cname (if (pair? y) (cadr y) y))
+                (method? (not (memq 'finalizer: type))))
+           (cat "static sexp " (generate-stub-name scheme-name)
+                " (sexp ctx, sexp self, sexp_sint_t n, sexp x) {\n"
+                "  if (sexp_cpointer_freep(x)) {\n"
+                "    " (if method? "" cname) "("
+                (if method? (string-append "((" (mangle name) "*)") "")
+                "sexp_cpointer_value(x)"
+                (if method? (string-append ")->" (x->string cname) "()") "")
+                ");\n"
+                ;; TODO: keep track of open/close separately from ownership
+                "    sexp_cpointer_freep(x) = 0;\n"
+                "  }\n"
+                "  return SEXP_VOID;\n"
+                "}\n\n")
+           ;; make the finalizer available
+           (set! *funcs*
+                 (cons (parse-func `(void ,y (,name))) *funcs*))))))
+  ;; maybe write constructor
+  (cond
+   ((memq 'constructor: type)
+    => (lambda (x)
+         (let ((make (car (cadr x)))
+               (args (cdr (cadr x))))
+           (cat "static sexp " (generate-stub-name make)
+                " (sexp ctx, sexp self, sexp_sint_t n"
+                (lambda ()
+                  (let lp ((ls args) (i 0))
+                    (cond ((pair? ls)
+                           (cat ", sexp arg" i)
+                           (lp (cdr ls) (+ i 1))))))
+                ") {\n"
+                "  " (type-c-name name) " r;\n"
+                "  sexp_gc_var1(res);\n"
+                "  sexp_gc_preserve1(ctx, res);\n"
+                ;; TODO: support heap-managed allocations
+                ;; "  res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer)"
+                ;; " + sizeof(struct " (type-name name) "), "
+                ;; (type-id-name name)
+                ;; ");\n"
+                ;; "  r = sexp_cpointer_value(res) = "
+                ;; "sexp_cpointer_body(res);\n"
+                ;; "  res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), sexp_type_tag("
+                ;; (type-id-name name)
+                ;; "));\n"
+                "  res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), "
+                "sexp_unbox_fixnum(sexp_opcode_return_type(self)));\n"
+                "  sexp_cpointer_value(res) = calloc(1, sizeof("
+                (type-c-name-derefed name) "));\n"
+                "  r = (" (type-c-name name) ") sexp_cpointer_value(res);\n"
+                "  memset(r, 0, sizeof("
+                (type-c-name-derefed name) "));\n"
+                "  sexp_freep(res) = 1;\n"
+                (lambda ()
+                  (let lp ((ls args) (i 0))
+                    (cond
+                     ((pair? ls)
+                      (let* ((a (car ls))
+                             (field
+                              (find (lambda (f) (and (pair? f) (eq? a (cadr f))))
+                                    (cddr x)))
+                             (arg (string-append "arg" (number->string i))))
+                        (cond
+                         ((and field (>= (length field) 4))
+                          (cat
+                           (write-type-setter-assignment
+                            type name field "res" arg)))
+                         (field
+                          (cat "  r->" (cadr field) " = "
+                               (lambda ()
+                                 (scheme->c-converter (car field) arg))
+                               ";\n")))
+                        (lp (cdr ls) (+ i 1)))))))
+                "  sexp_gc_release1(ctx);\n"
+                "  return res;\n"
+                "}\n\n")
+           (set! *funcs*
+                 (cons (parse-func
+                        `(,name ,make
+                                ,(map (lambda (a)
+                                        (cond
+                                         ((find (lambda (x) (eq? a (cadr x)))
+                                                (struct-fields type))
+                                          => car)
+                                         (else 'sexp)))
+                                      args)))
+                       *funcs*))))))
+  ;; write field accessors
+  (let lp ((ls (struct-fields type))
+           (i 0))
+    (cond
+     ((not (pair? ls)))
+     ((and (pair? (car ls)) (pair? (cdar ls)))
+      (let* ((field (car ls))
+             (get+set (cddr field)))
+        (cond
+         ((and (pair? get+set) (car get+set))
+          (let ((get-name (if (pair? (car get+set))
+                              (caar get+set)
+                              (car get+set))))
+            (write-type-getter type name field)
+            (set! *funcs*
+                  (cons (parse-func
+                         `(,(car field)
+                           (,get-name
+                            #f
+                            ,(type-getter-name type name field))
+                           (,name)))
+                        *funcs*))
+            (if (type-struct-type name)
+                (set! *type-getters*
+                      (cons `(,get-name ,name ,i) *type-getters*)))))
+         (else "SEXP_FALSE"))
+        (cond
+         ((and (pair? get+set)
+               (pair? (cdr get+set))
+               (cadr get+set))
+          (let ((set-name (if (pair? (cadr get+set))
+                              (car (cadr get+set))
+                              (cadr get+set))))
+            (write-type-setter type name field)
+            (set! *funcs*
+                  (cons (parse-func
+                         `(,(car field)
+                           (,set-name
+                            #f
+                            ,(type-setter-name type name field))
+                           (,name ,(car field))))
+                        *funcs*))
+            (if (type-struct-type name)
+                (set! *type-setters*
+                      (cons `(,set-name ,name ,i) *type-setters*)))))))
+      (lp (cdr ls) (+ i 1))))))
+
+(define (write-type-funcs orig-type)
+  (let* ((name (car orig-type))
+         (type (cdr orig-type))
+         (imported? (cond ((member 'imported?: type) => cadr) (else #f))))
+    (if (not imported?)
+        (write-type-funcs-helper orig-type name type))))
+
+(define (write-const const)
+  (let ((scheme-name
+         (if (pair? (cadr const)) (car (cadr const)) (cadr const)))
+        (c-name
+         (if (pair? (cadr const)) (cadr (cadr const)) (mangle (cadr const)))))
+    (cat "  name = sexp_intern(ctx, \"" scheme-name "\", "
+         (string-length (x->string scheme-name)) ");\n"
+         "  sexp_env_define(ctx, env, name, tmp="
+         (lambda () (c->scheme-converter (car const) c-name)) ");\n")))
+
+(define (write-utilities)
+  (define (input-env-string? x)
+    (and (eq? 'env-string (type-base x)) (not (type-result? x))))
+  (cond
+   (*c++?*
+    (for-each
+     (lambda (t)
+       (cond
+        ((and (not (memq 'finalizer: (cdr t)))
+              (not (memq 'finalizer-method: (cdr t)))
+              (type-struct-type (car t)))
+         (let ((name (type-c-name-derefed (car t)))
+               (finalizer-name (type-finalizer-name (car t))))
+           (cat
+            "static sexp " finalizer-name " ("
+            "sexp ctx, sexp self, sexp_sint_t n, sexp obj) {\n"
+            "  if (sexp_cpointer_freep(obj))\n"
+            "    delete static_cast<" name "*>"
+            "(sexp_cpointer_value(obj));\n"
+            "  sexp_cpointer_value(obj) = NULL;\n"
+            "  return SEXP_VOID;\n"
+            "}\n\n")))))
+     *types*)))
+  (cond
+   ((any (lambda (f)
+           (or (any input-env-string? (func-results f))
+               (any input-env-string? (func-scheme-args f))))
+         *funcs*)
+    (cat "static char* sexp_concat_env_string (sexp x) {\n"
+         "  int klen=sexp_string_size(sexp_car(x)), vlen=sexp_string_size(sexp_cdr(x));\n"
+         "  char *res = (char*) calloc(1, klen+vlen+2);\n"
+         "  strncpy(res, sexp_string_data(sexp_car(x)), klen);\n"
+         "  res[sexp_string_size(sexp_car(x))] = '=';\n"
+         "  strncpy(res+sexp_string_size(sexp_car(x)), sexp_string_data(sexp_cdr(x)), vlen);\n"
+         "  res[len-1] = '\\0';\n"
+         "  return res;\n"
+         "}\n\n"))))
+
+(define (write-init)
+  (newline)
+  (write-utilities)
+  (for-each write-func *funcs*)
+  (for-each write-method *methods*)
+  (for-each write-type-funcs *types*)
+  (for-each (lambda (n) (cat "}  // " n "\n")) *open-namespaces*)
+  (newline)
+  (if *c++?*
+      (cat "extern \"C\"\n"))
+  (cat "sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {\n"
+       (lambda ()
+         (for-each
+          (lambda (t) (cat "  sexp " t ";\n"))
+          *tags*))
+       "  sexp_gc_var3(name, tmp, op);\n"
+       "  if (!(sexp_version_compatible(ctx, version, sexp_version)\n"
+       "        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))\n"
+       "    return SEXP_ABI_ERROR;\n"
+       "  sexp_gc_preserve3(ctx, name, tmp, op);\n")
+  (for-each write-const *consts*)
+  (for-each write-type *types*)
+  (for-each write-func-binding *funcs*)
+  (for-each write-method-binding *methods*)
+  (for-each (lambda (x) (cat "  " x "\n")) (reverse *inits*))
+  (cat "  sexp_gc_release3(ctx);\n"
+       "  return SEXP_VOID;\n"
+       "}\n\n"))
+
+(define (generate file)
+  (cat "/* Automatically generated by chibi-ffi; version: "
+       *ffi-version* " */\n")
+  (c-system-include "chibi/eval.h")
+  (load file (current-environment))
+  (cat "/*\ntypes: " (map car *types*) "\nenums: " *c-enum-types* "\n*/\n")
+  (write-init))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; main
+
+(let ((args (command-line)))
+  (let lp ((args (if (pair? args) (cdr args) args))
+           (compile? #f)
+           (cflags '())
+           (features '()))
+    (cond
+     ((and (pair? args) (not (equal? "" (car args)))
+           (eqv? #\- (string-ref (car args) 0)))
+      (case (string->symbol (car args))
+        ((-c --compile)
+         (lp (cdr args) #t cflags features))
+        ((-f --flags)
+         (if (null? (cdr args))
+             (error "--flags requires an argument"))
+         (lp (cddr args)
+             compile?
+             (append cflags (string-split (cadr args) #\space))
+             features))
+        ((--features)
+         (if (null? (cdr args))
+             (error "--features requires an argument"))
+         (lp (cddr args)
+             compile?
+             cflags
+             (append features (string-split (cadr args) #\,))))
+        (else
+         (error "unknown option" (car args)))))
+     (else
+      (if (pair? features)
+          (set! *features* features))
+      (let* ((src (if (or (not (pair? args)) (equal? "-" (car args)))
+                      "/dev/stdin"
+                      (car args)))
+             (dest
+              (case (length args)
+                ((0) "-")
+                ((1) (string-append (strip-extension src) ".c"))
+                ((2) (cadr args))
+                (else
+                 (error "usage: chibi-ffi [-c] <file.stub> [<output.c>]")))))
+        (if (not (equal? "/dev/stdin" src))
+            (let ((slash (string-scan-right src #\/)))
+              (if (> slash 0)
+                  (set! wdir (substring-cursor src 0 slash)))))
+        (if (equal? "-" dest)
+            (generate src)
+            (with-output-to-file dest (lambda () (generate src))))
+        (cond
+         ((and compile? (not (equal? "-" dest)))
+          ;; This has to use `eval' for bootstrapping, since we need
+          ;; chibi-ffi to compile to (chibi process) module.
+          (let* ((so (string-append (strip-extension src)
+                                    *shared-object-extension*))
+                 (execute (begin (eval '(import (chibi process)))
+                                 (eval 'execute)))
+                 (base-args (append cflags `("-o" ,so ,dest "-lchibi-scheme")))
+                 (args
+                  (eval
+                   `(cond-expand
+                     (macosx (append '("-dynamiclib" "-Oz") ',base-args))
+                     (else (append '("-fPIC" "-shared" "-Os") ',base-args)))))
+                 (cc (if *c++?* "c++" "cc")))
+            (execute cc (cons cc args))))))))))
diff --git a/tools/chibi-genstatic b/tools/chibi-genstatic
new file mode 100755
index 00000000..310e0444
--- /dev/null
+++ b/tools/chibi-genstatic
@@ -0,0 +1,395 @@
+#!/usr/bin/env chibi-scheme
+
+;; This is a build-only tool (not installed) used to generate the
+;; clibs.c file used by Chibi for a SEXP_USE_STATIC_LIBS=1 build,
+;; i.e. a build of Chibi with all libraries that would be loaded
+;; dynamically included statically into libchibi-scheme (though not
+;; necessarily statically linked).
+;;
+;; Usage:
+;;   find <dir> -name \*.sld | chibi-genstatic [-x <mods> ...] > clibs.c
+;;   chibi-genstatic -i <mods> > clibs.c
+;;
+;; In the first form, chibi-genstatic takes a list of module file
+;; names on stdin to generate static bindings for, excluding any
+;; modules specified with -x (or --exclude).
+;;
+;; In the second form, we take an explicit list of module names as
+;; options with -i or --include (-x is still honored and takes
+;; precedence).
+;;
+;; Both -i and -x may be specified multiple times, or multiple module
+;; names can be separated with commas.
+;;
+;; Examples:
+;;  find lib -name \*.sld | chibi-genstatic -x chibi.net -x srfi.18 > clibs.c
+;;  chibi-genstatic -i chibi.ast,srfi.69 > clibs.c
+;;
+;; This is only intended for libraries in the core distribution, and
+;; currently makes the assumption that the .sld files contain a
+;; `define-library' form.  If you want to make a custom build with
+;; your own libraries included statically, be sure to follow this
+;; convention.
+;;
+;; Note: This relies on an external find, instead of one from (chibi
+;; filesystem), because the latter is a dynamically loaded library
+;; which presents a bootstrapping issue on platforms with no dynamic
+;; loading.
+
+(import (chibi))
+
+;; inlined from (meta) and (chibi string)
+
+(define (find-module name)
+  #f)
+
+(define (module-name->strings ls res)
+  (if (null? ls)
+      res
+      (let ((str (cond ((symbol? (car ls)) (symbol->string (car ls)))
+                       ((number? (car ls)) (number->string (car ls)))
+                       ((string? (car ls)) (car ls))
+                       (else (error "invalid module name" (car ls))))))
+        (module-name->strings (cdr ls) (cons "/" (cons str res))))))
+
+(define (module-name->file name)
+  (string-concatenate
+   (reverse (cons ".sld" (cdr (module-name->strings name '()))))))
+
+(define (make-char-predicate x)
+  (cond ((procedure? x) x)
+        ((char? x) (lambda (ch) (eq? ch x)))
+        (else (error "invalid character predicate" x))))
+
+(define (complement pred) (lambda (x) (not (pred x))))
+
+(define (string-find str x . o)
+  (let ((pred (make-char-predicate x))
+        (end (if (and (pair? o) (pair? (cdr o)))
+                 (cadr o)
+                 (string-cursor-end str))))
+    (let lp ((i (if (pair? o) (car o) (string-cursor-start str))))
+      (cond ((string-cursor>=? i end) end)
+            ((pred (string-cursor-ref str i)) i)
+            (else (lp (string-cursor-next str i)))))))
+
+(define (string-find-right str x . o)
+  (let ((pred (make-char-predicate x))
+        (start (if (pair? o) (car o) (string-cursor-start str))))
+    (let lp ((i (if (and (pair? o) (pair? (cdr o)))
+                    (cadr o)
+                    (string-cursor-end str))))
+      (let ((i2 (string-cursor-prev str i)))
+        (cond ((string-cursor<? i2 start) start)
+              ((pred (string-cursor-ref str i2)) i)
+              (else (lp i2)))))))
+
+(define (string-skip str x . o)
+  (apply string-find str (complement (make-char-predicate x)) o))
+
+(define (string-skip-right str x . o)
+  (apply string-find-right str (complement (make-char-predicate x)) o))
+
+(define (path-strip-directory path)
+  (substring-cursor path (string-find-right path #\/)))
+
+(define (path-directory path)
+  (if (string=? path "")
+      "."
+      (let ((end (string-skip-right path #\/)))
+        (if (zero? end)
+            "/"
+            (let ((start (string-find-right path #\/ 0 end)))
+              (if (zero? start)
+                  "."
+                  (let ((start2 (string-skip-right path #\/ 0 start)))
+                    (if (zero? start2)
+                        "/"
+                        (substring-cursor path 0 start2)))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (x->string x)
+  (cond ((string? x) x)
+        ((symbol? x) (symbol->string x))
+        ((number? x) (number->string x))
+        (else (error "non-stringable object" x))))
+
+(define (string-split str c . o)
+  (let ((start (if (pair? o) (car o) 0))
+        (end (string-length str)))
+    (let lp ((from start) (i start) (res '()))
+      (define (collect) (if (= i from) res (cons (substring str from i) res)))
+      (cond
+       ((>= i end) (reverse (collect)))
+       ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (collect)))
+       (else (lp from (+ i 1) res))))))
+
+(define (string-replace str c r)
+  (let ((len (string-length str)))
+    (let lp ((from 0) (i 0) (res '()))
+      (define (collect) (if (= i from) res (cons (substring str from i) res)))
+      (cond
+       ((>= i len) (string-concatenate (reverse (collect))))
+       ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect))))
+       (else (lp from (+ i 1) res))))))
+
+(define (c-char? c)
+  (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?))))
+
+(define (c-escape str)
+  (define (hex ch) (number->string (char->integer ch) 16))
+  (let ((len (string-length str)))
+    (let lp ((from 0) (i 0) (res '()))
+      (define (collect) (if (= i from) res (cons (substring str from i) res)))
+      (cond
+       ((>= i len)
+        (string-concatenate (reverse (collect))))
+       ((not (c-char? (string-ref str i)))
+        (lp (+ i 1)
+            (+ i 1)
+            (cons "_" (cons (hex (string-ref str i)) (collect)))))
+       (else
+        (lp from (+ i 1) res))))))
+
+(define (mangle x)
+  (string-replace
+   (string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p")
+   #\! "_x"))
+
+(define (read-line . o)
+  (let ((in (if (pair? o) (car o) (current-input-port))))
+    (let lp ((res '()))
+      (let ((c (read-char in)))
+        (cond
+         ((eof-object? c)
+          (if (null? res) c (list->string (reverse res))))
+         ((eqv? c #\newline)
+          (list->string (reverse res)))
+         (else
+          (lp (cons c res))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (strip-dot-slash path)
+  (if (and (>= (string-length path) 2)
+           (eq? #\. (string-ref path 0))
+           (eq? #\/ (string-ref path 1)))
+      (substring path 2)
+      path))
+
+(define (shared-file-name mod-name name)
+  (string-append
+   (path-directory
+    (strip-dot-slash (find-module-file (module-name->file mod-name))))
+   "/" name))
+
+(define (find-c-libs-from-module-names modules)
+  (define (find-c-lib mod-name)
+    (cond
+     ((find-module mod-name)
+      => (lambda (mod)
+           (cond
+            ((assq 'include-shared (vector-ref mod 2))
+             => (lambda (x)
+                  (cons (shared-file-name mod-name (cadr x)) mod-name)))
+            (else #f))))
+     (else #f)))
+  (let lp ((ls modules)
+           (c-libs '()))
+    (cond
+     ((null? ls)
+      c-libs)
+     ((find-c-lib (car ls))
+      => (lambda (x) (lp (cdr ls) (cons x c-libs))))
+     (else
+      (lp (cdr ls) c-libs)))))
+
+(define (find-c-libs-from-file-names excluded)
+  (define (check-cond-expand x)
+    (if (pair? x)
+        (case (car x)
+          ((and) (every check-cond-expand (cdr x)))
+          ((or) (any check-cond-expand (cdr x)))
+          ((not) (not (check-cond-expand (cadr x))))
+          (else (error "cond-expand: bad feature" x)))
+        (memq (identifier->symbol x) *features*)))
+  (define (extract-module-name file)
+    (call-with-input-file file
+      (lambda (in)
+        (let lp ()
+          (let ((expr (read in)))
+            (cond
+             ((eof-object? expr) #f)
+             ((and (pair? expr)
+                   (pair? (cdr expr))
+                   (memq (car expr)
+                         '(define-library define-module library module)))
+              (cadr expr))
+             (else (lp))))))))
+  (define (extract-module-shares mod-name file)
+    (call-with-input-file file
+      (lambda (in)
+        (let lp ()
+          (let ((expr (read in)))
+            (cond
+             ((eof-object? expr) '())
+             ((and (pair? expr)
+                   (pair? (cdr expr))
+                   (memq (car expr)
+                         '(define-library define-module library module)))
+              (let lp ((ls (cdr expr)) (c-libs '()))
+                (cond
+                 ((null? ls) c-libs)
+                 ((not (pair? (car ls))) (lp (cdr ls) c-libs))
+                 ((eq? 'include-shared (caar ls))
+                  (lp (cdr ls)
+                      (cons (cons (shared-file-name mod-name (cadr (car ls)))
+                                  mod-name)
+                            c-libs)))
+                 ((eq? 'cond-expand (caar ls))
+                  ;;(lp (append (cdar ls) (cdr ls)) c-libs)
+                  (let expand ((ls2 (cdar ls)) (res (cdr ls)))
+                    (cond
+                     ((null? ls2) (lp res c-libs))
+                     ((check-cond-expand (caar ls2))
+                      (expand (cdr ls2) (append (cdar ls2) res)))
+                     (else (expand (cdr ls2) res)))))
+                 (else (lp (cdr ls) c-libs)))))
+             (else (lp))))))))
+  (let lp ((modules '()))
+    (let ((file (read-line)))
+      (cond
+       ((or (eof-object? file) (equal? "" file))
+        modules)
+       ((extract-module-name file)
+        => (lambda (name)
+             (lp (if (member name excluded)
+                     modules
+                     (append (extract-module-shares name file) modules)))))
+       (else
+        (lp modules))))))
+
+(define (find-c-libs args)
+  (define (split-mod-names str)
+    (map (lambda (m)
+           (map (lambda (x) (or (string->number x) (string->symbol x)))
+                (string-split m #\.)))
+         (string-split str #\,)))
+  (let lp ((ls args)
+           (includes #f)
+           (excludes '())
+           (cfiles '()))
+    (cond
+     ((null? ls)
+      (cons
+       (if includes
+           (find-c-libs-from-module-names includes)
+           (find-c-libs-from-file-names excludes))
+       cfiles))
+     (else
+      (cond
+       ((member (car ls) '("-i" "--include"))
+        (lp (cddr ls)
+            (append (or includes '()) (split-mod-names (cadr ls)))
+            excludes
+            cfiles))
+       ((member (car ls) '("-x" "--exclude"))
+        (lp (cddr ls)
+            includes
+            (append excludes (split-mod-names (cadr ls)))
+            cfiles))
+       ((member (car ls) '("-c" "--cfiles"))
+        (lp (cddr ls)
+            includes
+            excludes
+            (append cfiles (string-split (cadr ls) #\,))))
+       (else
+        (error "unknown arg" (car ls))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define wdir "")
+
+(define (init-name mod)
+  (string-append "sexp_init_lib_"
+                 (string-concatenate (map mangle mod) "_")))
+
+(define (include-c-lib lib c-files . o)
+  (display "#define sexp_init_library ")
+  (display (init-name (cdr lib)))
+  (newline)
+  (cond
+   ((and (pair? o) (car o))  ; inline
+    (let* ((base (string-append (car lib) ".c"))
+           (in (protect
+                (exn
+                 (else
+                  (let lp ((ls c-files))
+                    (cond
+                     ((null? ls) (error "couldn't find c file" base c-files))
+                     ((equal? (path-strip-directory (car ls))
+                              (path-strip-directory base))
+                      (open-input-file (car ls)))
+                     (else (lp (cdr ls)))))))
+                (open-input-file base))))
+      (let lp ()
+        (let ((line (read-line in)))
+          (cond
+           ((eof-object? line)
+            (close-input-port in))
+           (else
+            (display line)
+            (newline)
+            (lp)))))))
+   (else
+    (display "#include \"")
+    (display (string-append (car lib) ".c"))
+    (display "\"")
+    (newline)))
+  (display "#undef sexp_init_library")
+  (newline)
+  (newline))
+
+(define (init-c-lib lib)
+  (display "  { \"")
+  (display (car lib))
+  (display "\", ")
+  (display (init-name (cdr lib)))
+  (display " },\n"))
+
+(let ((args (command-line)))
+  (if (pair? args)
+      (set! wdir (path-directory (path-directory (car args)))))
+  (let lp ((args (if (pair? args) (cdr args) args))
+           (features '()))
+    (cond
+     ((and (pair? args) (not (equal? "" (car args)))
+           (eqv? #\- (string-ref (car args) 0)))
+      (case (string->symbol (car args))
+        ((--features)
+         (if (null? (cdr args))
+             (error "--features requires an argument"))
+         (lp (cddr args) (append features (string-split (cadr args) #\,))))
+        (else
+         (error "unknown option" (car args)))))
+     (else
+      (if (pair? features)
+          (set! *features* features))
+      (let* ((c-libs+c-files (find-c-libs (if (pair? args) (cdr args) args)))
+             (c-libs (car c-libs+c-files))
+             (c-files (cdr c-libs+c-files))
+             (inline? #t))
+        (newline)
+        (for-each (lambda (x) (include-c-lib x c-files inline?)) c-libs)
+        (newline)
+        ;; (display "typedef struct {\n")
+        ;; (display "  const char *name;\n")
+        ;; (display "  sexp_init_proc init;\n")
+        ;; (display "} sexp_library_entry_t;\n")
+        ;; (newline)
+        (display "struct sexp_library_entry_t sexp_static_libraries_array[] = {\n")
+        (for-each init-c-lib c-libs)
+        (display "  { NULL, NULL }\n")
+        (display "};\n\n")
+        (display "struct sexp_library_entry_t* sexp_static_libraries = sexp_static_libraries_array;\n"))))))
diff --git a/tools/extract-case-offsets.scm b/tools/extract-case-offsets.scm
new file mode 100644
index 00000000..cf4bee6e
--- /dev/null
+++ b/tools/extract-case-offsets.scm
@@ -0,0 +1,129 @@
+#!/usr/bin/env chibi-scheme
+
+;; Extract sets of char case offsets.
+;;
+;; Usage:
+;;   extract-case-offsets.scm options CaseFolding.txt > out
+;;
+;; Recognized options are:
+;;
+;;   -c <min-count>     - the minimum required count to output a char-set
+;;                        for an offset, default 32
+;;   -m <max-char-sets> - the maximum number of character sets to output
+;;                        regardless of min-count, default umlimited
+;;   -n <name>          - the name for char-sets, defaults to
+;;                        "char-downcase-offsets"
+;;   -o <output-file>   - the output file, defaults to stdout
+
+(import (chibi) (srfi 1) (srfi 69) (srfi 95) (chibi io) (chibi string)
+        (chibi iset) (chibi iset optimize))
+
+(define (warn . args)
+  (let ((err (current-error-port)))
+    (for-each (lambda (x) (display x err)) args)
+    (newline err)))
+
+(define (write-offsets offset-map out min-count max-char-sets name)
+  (let lp ((ls (sort (hash-table->alist offset-map)
+                     (lambda (a b) (> (iset-size (cdr a)) (iset-size (cdr b))))))
+           (i 0)
+           (res '()))
+    (cond
+     ((and (pair? ls)
+           (or (not max-char-sets) (< i max-char-sets))
+           (or (not min-count) (>= (iset-size (cdar ls)) min-count)))
+      (lp (cdr ls)
+          (+ i 1)
+          (cons `(cons ,(iset->code (iset-balance (iset-optimize (cdar ls))))
+                       ,(caar ls))
+                res)))
+     (else
+      (write `(define ,(string->symbol name) (list ,@(reverse res))) out)
+      (newline out)
+      (newline out)
+      (let ((pairs
+             (sort
+              (append-map
+               (lambda (x)
+                 (map (lambda (y) (list y (+ y (car x))))
+                      (iset->list (cdr x))))
+               ls)
+              (lambda (a b) (< (car a) (car b))))))
+        (write `(define char-downcase-map
+                  ',(list->vector (append-map (lambda (x) x) pairs)))
+               out)
+        (newline out)
+        (newline out)
+        (write `(define char-upcase-map
+                  ',(list->vector
+                     (append-map (lambda (x) (list (cadr x) (car x)))
+                                 (sort pairs
+                                       (lambda (a b) (< (cadr a) (cadr b)))))))
+               out)
+        (newline out))))))
+
+(define (extract-case-folding in out min-count max-char-sets name)
+  (define (string-trim-comment str comment-ch)
+    (car (string-split str comment-ch 2)))
+  (let ((offset-map (make-hash-table eq?)))
+    (let lp ()
+      (let ((line (read-line in)))
+        (cond
+         ((eof-object? line)
+          (write-offsets offset-map out min-count max-char-sets name))
+         ((or (equal? line "") (eqv? #\# (string-ref line 0)))
+          (lp))
+         (else
+          (let ((ls (map string-trim
+                         (string-split (string-trim-comment line #\#) #\;))))
+            (cond
+             ((< (length ls) 3)
+              (warn "invalid CaseFolding.txt line: " line))
+             (else
+              (let ((upper (string->number (car ls) 16))
+                    (status (string->symbol (cadr ls))))
+                (cond
+                 ((not upper)
+                  (warn "invalid upper char in CaseFolding.txt: " line))
+                 ((eqv? 'C status)
+                  (let ((lower (string->number (car (cddr ls)) 16)))
+                    (if (not lower)
+                        (warn "invalid lower char in CaseFolding.txt: " line)
+                        (hash-table-update!
+                         offset-map
+                         (- lower upper)
+                         (lambda (is) (iset-adjoin! is upper))
+                         (lambda () (make-iset))))))))))
+            (lp))))))))
+
+(let ((args (command-line)))
+  (let lp ((ls (cdr args))
+           (min-count 26)
+           (max-char-sets #f)
+           (name "char-downcase-offsets")
+           (out (current-output-port)))
+    (cond
+     ((and (pair? ls) (not (equal? "" (car ls)))
+           (eqv? #\- (string-ref (car ls) 0)))
+      (cond
+       ((member (car ls) '("-c" "--min-count"))
+        (lp (cddr ls) (cadr ls) max-char-sets name out))
+       ((member (car ls) '("-m" "--max-char-sets"))
+        (lp (cddr ls) min-count (cadr ls) name out))
+       ((member (car ls) '("-n" "--name"))
+        (lp (cddr ls) min-count max-char-sets (cadr ls) out))
+       ((member (car ls) '("-o" "--output"))
+        (lp (cddr ls) min-count max-char-sets name
+            (open-output-file (cadr ls))))
+       (else
+        (error "unknown option: " (car ls)))))
+     ((null? ls)
+      (error "usage: extract-case-offsets <CaseFolding.txt>"))
+     (else
+      (if (equal? "-" (car ls))
+          (extract-case-folding
+           (current-input-port) out min-count max-char-sets name)
+          (call-with-input-file (car ls)
+            (lambda (in)
+              (extract-case-folding in out min-count max-char-sets name))))
+      (close-output-port out)))))
diff --git a/tools/extract-unicode-props.scm b/tools/extract-unicode-props.scm
new file mode 100755
index 00000000..2ef23c81
--- /dev/null
+++ b/tools/extract-unicode-props.scm
@@ -0,0 +1,213 @@
+#!/usr/bin/env chibi-scheme
+
+;; Simple tool to extract Unicode properties as character-sets.
+;;
+;; Usage:
+;;   extract-unicode-props.scm Lowercase Punctuation=P Blank=Zs,0009 >out
+;;
+;; Accepts a list of char-set names with optional definitions as
+;; arguments, and writes their Scheme definitions to stdout.  A
+;; char-set can be of the form:
+;;
+;;   Name: equivalent to Name=Name
+;;   Name=value,...:
+;;
+;; A value can be any of:
+;;
+;;   Property_Name: all unicode characters with the given derived property
+;;   Xx: all unicode characters with the given general category
+;;   X: all unicode characters with any general category X*
+;;   NNNN: a single unicode value in hex format
+;;   NNNN-NNNN: an inclusive range of unicode values in hex format
+;;
+;; The char-set names generated are always lowercased, replacing _
+;; with -, for convenicence when the char-set name coincides with a
+;; Unicode property name.
+;;
+;; Assumes the files UnicodeData.txt and DerivedCoreProperties.txt are
+;; in the data/ current directory, unless overridden with the --data or
+;; --derived options.
+
+(import (chibi) (chibi io) (chibi string))
+
+(define (warn . args)
+  (let ((err (current-error-port)))
+    (for-each (lambda (x) (display x err)) args)
+    (newline err)))
+
+;; Parse UnicodeData.txt for characters matching a given class.
+(define (extract-char-set-category cat data)
+  (define (join-to-range n ls)
+    (cond
+     ((null? ls)
+      (list n))
+     ((eqv? (car ls) (- n 1))
+      (cons (cons (car ls) n) (cdr ls)))
+     ((and (pair? (car ls)) (eqv? (- n 1) (cdar ls)))
+      (cons (cons (caar ls) n) (cdr ls)))
+     (else
+      (cons n ls))))
+  (call-with-input-file data
+    (lambda (in)
+      (let lp ((ranges '()))
+        (let ((line (read-line in)))
+          (cond
+           ((eof-object? line)
+            `(char-set-union
+              ,@(map (lambda (x)
+                       (if (pair? x)
+                           `(ucs-range->char-set ,(car x) ,(+ 1 (cdr x)))
+                           `(char-set ,(integer->char x))))
+                     (reverse ranges))))
+           ((or (equal? line "") (eqv? #\# (string-ref line 0)))
+            (lp ranges))
+           (else
+            (let ((ls (string-split line #\; 4)))
+              (cond
+               ((< (length ls) 3)
+                (warn "invalid UnicodeData line: " line)
+                (lp ranges))
+               (else
+                (let ((ch (string->number (car ls) 16))
+                      (name (cadr ls))
+                      (ch-cat (car (cddr ls))))
+                  (cond
+                   ((or (not ch) (not (= 2 (string-length ch-cat))))
+                    (warn "invalid UnicodeData line: " line))
+                   ((if (char? cat)
+                        (eqv? cat (string-ref ch-cat 0))
+                        (equal? cat ch-cat))
+                    (lp (join-to-range ch ranges)))
+                   (else
+                    (lp ranges))))))))))))))
+
+;; Parse DerivedCoreProperties.txt for characters matching a given
+;; property.
+(define (extract-char-set-property prop derived)
+  (define (string-trim-comment str comment-ch)
+    (car (string-split str comment-ch 2)))
+  (call-with-input-file derived
+    (lambda (in)
+      (let lp ((ranges '()))
+        (let ((line (read-line in)))
+          (cond
+           ((eof-object? line)
+            `(char-set-union ,@(reverse ranges)))
+           ((or (equal? line "") (eqv? #\# (string-ref line 0)))
+            (lp ranges))
+           (else
+            (let ((ls (string-split (string-trim-comment line #\#) #\;)))
+              (cond
+               ((< (length ls) 2)
+                (warn "invalid DerivedCoreProperties line: " line)
+                (lp ranges))
+               ((string-ci=? prop (string-trim (cadr ls)))
+                (cond
+                 ((string-contains (car ls) "..")
+                  => (lambda (i)
+                       (let* ((str (string-trim (car ls)))
+                              (start (string->number (substring str 0 i) 16))
+                              (end (string->number (substring str (+ i 2)) 16)))
+                         (if (and start end (<= 0 start end #x110000))
+                             (lp (cons `(ucs-range->char-set ,start ,(+ end 1))
+                                       ranges))
+                             (error "invalid char range: " line)))))
+                 ((string->number (cadr ls) 16)
+                  => (lambda (n)
+                       (lp (cons `(char-set ,(integer->char n)) ranges))))
+                 (else
+                  (lp ranges))))
+               (else
+                (lp ranges)))))))))))
+
+(define (extract-char-set-simple def data derived)
+  (let ((ls (string-split def #\- 2)))
+    (cond
+     ((= 2 (length ls))
+      (let ((start (string->number (car ls) 16))
+            (end (string->number (cadr ls) 16)))
+        (if (and start end (<= start end))
+            `(ucs-range->char-set ,start ,(+ end 1))
+            (error "invalid character range, expected NNNN-MMMM, got: " def))))
+     ((string->number def 16)
+      => (lambda (start) `(char-set ,(integer->char start))))
+     ((and (= 1 (string-length def))
+           (char-upper-case? (string-ref def 0)))
+      (extract-char-set-category (string-ref def 0) data))
+     ((and (= 2 (string-length def))
+           (char-upper-case? (string-ref def 0))
+           (char-lower-case? (string-ref def 1)))
+      (extract-char-set-category def data))
+     ;; derived properties
+     ((and (> (string-length def) 1)
+           (eqv? #\: (string-ref def 0)))
+      (extract-char-set-property (substring def 1) derived))
+     (else
+      (extract-char-set-property def derived)))))
+
+(define (extract-char-set def data derived)
+  (let ((defs (string-split def #\,)))
+    (cond
+     ((= 1 (length defs))
+      (extract-char-set-simple (car defs) data derived))
+     (else
+      `(char-set-union
+        ,@(map (lambda (def) (extract-char-set-simple def data derived))
+               defs))))))
+
+(define (process-char-set name def data derived out)
+  (define (normalize-char-set-name str)
+    (string-append
+     (if (eqv? #\: (string-ref str 0)) "char-set" "char-set:")
+     (string-map (lambda (ch) (if (eqv? ch #\_) #\- (char-downcase ch))) str)))
+  (display ";; " out)
+  (display def out)
+  (newline out)
+  (write
+   `(define ,(string->symbol (normalize-char-set-name name))
+      (immutable-char-set
+       ,(extract-char-set def data derived)))
+   out)
+  (newline out)
+  (newline out))
+
+(define default-char-sets
+  '("Lower-Case=Lowercase"
+    "Upper-Case=Uppercase"
+    "Title-Case=Lt"
+    "Letter=Alphabetic"
+    "Punctuation=P"
+    "Symbol=S"
+    "Blank=Zs,0009"
+    "Whitespace=Zs,Zl,Zp,0009,000A,000B,000C,000D"
+    "Digit=Nd"))
+
+(let ((args (command-line)))
+  (let lp ((ls (cdr args))
+           (data "data/UnicodeData.txt")
+           (derived "data/DerivedCoreProperties.txt")
+           (out (current-output-port)))
+    (cond
+     ((and (pair? ls) (not (equal? "" (car ls)))
+           (eqv? #\- (string-ref (car ls) 0)))
+      (cond
+       ((member (car ls) '("-d" "--data"))
+        (lp (cddr ls) (cadr ls) derived out))
+       ((member (car ls) '("-e" "--derived"))
+        (lp (cddr ls) data (cadr ls) out))
+       ((member (car ls) '("-o" "--output"))
+        (lp (cddr ls) data derived (open-output-file (cadr ls))))
+       ((member (car ls) '("f" "--default"))
+        (lp (append default-char-sets (cdr ls)) data derived out))
+       (else
+        (error "unknown option: " (car ls)))))
+     ((pair? ls)
+      (let ((ls (string-split (car ls) #\= 2)))
+        (cond
+         ((= 1 (length ls))
+          (process-char-set (car ls) (car ls) data derived out))
+         (else
+          (process-char-set (car ls) (cadr ls) data derived out))))
+      (lp (cdr ls) data derived out))
+     (else
+      (close-output-port out)))))
diff --git a/tools/generate-install-meta.scm b/tools/generate-install-meta.scm
new file mode 100755
index 00000000..accfb87c
--- /dev/null
+++ b/tools/generate-install-meta.scm
@@ -0,0 +1,47 @@
+#! /usr/bin/env chibi-scheme
+
+;; Generate a single .meta file for the chibi package listing all
+;; installed builtin packages.  Minimal information with no signature,
+;; just for the sake of tracking versions so we can install individual
+;; updates.
+
+;; Just depend on the core for simpler bootstrapping.
+(import (chibi))
+
+(define (read-line)
+  (let lp ((res '()))
+    (let ((ch (read-char)))
+      (cond ((or (eof-object? ch) (eqv? #\newline ch))
+             (if (and (null? res) (eof-object? ch))
+                 ch
+                 (list->string (reverse res))))
+            ((eqv? #\return ch) (lp))
+            (else (lp (cons ch res)))))))
+
+(define (parse-library file)
+  (protect (exn (else #f))
+    (let ((x (call-with-input-file file read)))
+      (and (pair? x)
+           (eq? 'define-library (car x))
+           (list? (cadr x))
+           (cadr x)))))
+
+(define (extract-libraries)
+  (let lp ((res '()))
+    (let ((file (read-line)))
+      (cond
+       ((eof-object? file) (reverse res))
+       ((parse-library file) => (lambda (lib) (lp (cons lib res))))
+       (else (lp res))))))
+
+;; usage: find <dir> -name \*.sld | generate-install-meta.scm <version>
+(let ((libs (extract-libraries))
+      (version (cadr (command-line))))
+  (display ";; generated by generate-install-meta.scm - do not edit\n\n")
+  (write
+   `(package
+     (version ,version)
+     ,@(map
+        (lambda (lib) `(library (name ,lib)))
+        libs)))
+  (newline))
diff --git a/tools/optimize-char-sets.scm b/tools/optimize-char-sets.scm
new file mode 100644
index 00000000..db9f0214
--- /dev/null
+++ b/tools/optimize-char-sets.scm
@@ -0,0 +1,82 @@
+#!/usr/bin/env chibi-scheme
+
+;; Simple tool to generate libraries of optimized char-sets.
+;;
+;; Usage:
+;;   optimize-char-sets.scm [--ascii] module.name > out
+;;
+;; Imports (module name) and writes optimized versions of all exported
+;; char-sets to stdout.
+
+(import (chibi) (srfi 1) (srfi 69)
+        (chibi io) (chibi string) (chibi modules)
+        (chibi char-set) (chibi iset) (chibi iset optimize)
+        (only (meta) load-module))
+
+;; Use a hash table for speedup of huge sets instead of O(n^2)
+;; srfi-1 implementation.
+(define (lset-diff ls1 ls2)
+  (let ((ls2-tab (make-hash-table eq?)))
+    (for-each (lambda (i) (hash-table-set! ls2-tab i #t)) ls2)
+    (remove (lambda (i) (hash-table-exists? ls2-tab i)) ls1)))
+
+(let ((args (command-line)))
+  (let lp ((ls (cdr args)) (ascii? #f))
+    (cond
+     ((and (pair? ls) (not (equal? "" (car ls)))
+           (eqv? #\- (string-ref (car ls) 0)))
+      (cond
+       ((member (car ls) '("-a" "--ascii"))
+        (lp (cdr ls) #t))
+       (else (error "unknown option" (car ls)))))
+     ((or (null? ls) (pair? (cdr ls)))
+      (error "usage: optimize-char-sets.scm [--ascii] module.name"))
+     (else
+      (let ((mod (load-module
+                  (map (lambda (x) (or (string->number x) (string->symbol x)))
+                       (string-split (car ls) #\.)))))
+        (for-each
+         (lambda (exp)
+           (display ";; ") (write exp) (newline)
+           (let ((value (module-ref mod exp)))
+             (cond
+              ((char-set? value)
+               (write `(optimize ,exp) (current-error-port)) (newline (current-error-port))
+               (if (not (equal? (iset->list value)
+                                (do ((cur (iset-cursor value)
+                                          (iset-cursor-next value cur))
+                                     (res '() (cons (iset-ref value cur) res)))
+                                    ((end-of-iset? cur) (reverse res)))))
+                   (error "error in iset cursors"))
+               (display "  computing intersection\n" (current-error-port))
+               (let* ((iset1 (if ascii?
+                                 (iset-intersection char-set:ascii value)
+                                 value))
+                      (_ (display "  optimizing\n" (current-error-port)))
+                      (iset-opt (iset-optimize iset1))
+                      (_ (display "  balancing\n" (current-error-port)))
+                      (iset2 (iset-balance iset-opt)))
+                 (if (and (not ascii?) (not (iset= iset1 iset2)))
+                     (begin
+                       (display "  different!\n" (current-error-port))
+                       (let* ((ls1 (iset->list iset1))
+                              (ls2 (iset->list iset2))
+                              (diff1 (lset-diff ls1 ls2))
+                              (diff2 (lset-diff ls2 ls1)))
+                         (display "  original: " (current-error-port))
+                         (write (length ls1) (current-error-port))
+                         (display " elements, missing: " (current-error-port))
+                         (write diff1 (current-error-port))
+                         (newline (current-error-port))
+                         (display "  optimized: " (current-error-port))
+                         (write (length ls2) (current-error-port))
+                         (display " elements, missing: " (current-error-port))
+                         (write diff2 (current-error-port))
+                         (newline (current-error-port))
+                         (error "optimized iset is different"))))
+                 (display "  writing\n" (current-error-port))
+                 (write `(define ,exp
+                           (immutable-char-set ,(iset->code iset2))))
+                 (newline)
+                 (newline))))))
+         (module-exports mod)))))))
diff --git a/tools/snow-chibi b/tools/snow-chibi
new file mode 100755
index 00000000..cef81c3b
--- /dev/null
+++ b/tools/snow-chibi
@@ -0,0 +1,171 @@
+#!/usr/bin/env chibi-scheme
+
+;; This code was written by Alex Shinn in 2013 and placed in the
+;; Public Domain.  All warranties are disclaimed.
+
+(import (scheme base)
+        (scheme process-context)
+        (chibi snow commands)
+        (chibi snow interface)
+        (chibi app)
+        (chibi config)
+        (chibi pathname)
+        (chibi process))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; (define repo-spec
+;;   '((repository
+;;      (conf
+;;       (sibling
+;;        (conf
+;;         (name string)
+;;         (url string)))
+;;       (package
+;;        (conf
+;;         (name (list (or symbol integer)))
+;;         (url string)
+;;         (size integer)
+;;         (checksums (alist symbol string))
+;;         (signature (alist symbol string))
+;;         (library
+;;          (conf
+;;           (name (list (or symbol integer)))
+;;           (path string)
+;;           (depends
+;;            (list (list (or symbol integer string
+;;                            (list (member < > <= >=) string)))))
+;;           (provides (list (list (or symbol string))))
+;;           (platforms (list (or symbol (list symbol))))
+;;           (features (list symbol))
+;;           (authors (list string))
+;;           (maintainers (list string))
+;;           (description string)
+;;           (created string)
+;;           (updated string)
+;;           (version string)
+;;           (licenses
+;;            (list
+;;             (or (member gpl2 gpl3 lgpl mit bsd artistic apache public-domain)
+;;                 (list 'license
+;;                       (conf (name string)
+;;                             (url string)
+;;                             (checksums (alist symbol string)))))))))))))))
+
+(define conf-spec
+  ;; name type aliases doc
+  '((verbose? boolean (#\v "verbose") "print additional informative messages")
+    (always-yes? boolean (#\y "always-yes") "answer all questions with yes")
+    (ignore-signature? boolean ("ignore-sig") "don't verify package signatures")
+    (ignore-digest? boolean ("ignore-digest") "don't verify package checksums")
+    ;;(config filename "path to configuration file")
+    (host string "base uri of snow repository")
+    (repository-uri string "uri of snow repository file")
+    (local-root-repository dirname "repository cache dir for root")
+    (local-user-repository dirname "repository cache dir for non-root users")
+    (install-prefix string "prefix directory for installation")
+    (install-source-dir dirname "directory to install library source in")
+    (library-extension string "the extension to use for library files")
+    (installer symbol "name of installer to use")
+    (implementations (list symbol) "impls to install for, or 'all'")
+    ))
+
+(define (conf-default-path name)
+  (make-path (or (get-environment-variable "HOME") ".")
+             (string-append "." name)
+             "config.scm"))
+
+(define search-spec '())
+(define show-spec '())
+(define install-spec '())
+(define upgrade-spec '())
+(define remove-spec '())
+(define status-spec '())
+(define gen-key-spec
+  '((bits integer)
+    (validity-period string)
+    (name string)
+    (library-prefix (list symbol))
+    (email string)))
+(define reg-key-spec
+  '((uri string)
+    (email string)))
+(define sign-spec
+  '((output filename #\o)
+    (digest symbol #\d)
+    (email string)))
+(define verify-spec
+  '())
+(define package-spec
+  '((authors (list string))
+    (maintainers (list string))
+    (recursive? boolean (#\r "recursive") "...")
+    (version string)
+    (version-file existing-filename)
+    (license symbol)
+    (doc existing-filename)
+    (doc-from-scribble boolean)
+    (description string)
+    (test existing-filename)
+    (sig-file existing-filename)
+    ))
+(define upload-spec
+  `((uri string)
+    ,@package-spec))
+(define update-spec
+  '())
+
+(define app-spec
+  `(snow
+    "Snow package management"
+    (@ ,conf-spec)
+    (begin: ,(lambda (cfg) (restore-history cfg)))
+    (end: ,(lambda (cfg) (save-history cfg)))
+    (or
+     (search
+      "search for packages"
+      (@ ,search-spec) (,command/search terms ...))
+     (show
+      "show package descriptions"
+      (@ ,show-spec) (,command/show names ...))
+     (install
+      "install packages"
+      (@ ,install-spec) (,command/install names ...))
+     (upgrade
+      "upgrade installed packages"
+      (@ ,upgrade-spec) (,command/upgrade names ...))
+     (remove
+      "remove packages"
+      (@ ,remove-spec) (,command/remove names ...))
+     (status
+      "print package status"
+      (@ ,status-spec) (,command/status names ...))
+     (package
+      "create a package"
+      (@ ,package-spec) (,command/package files ...))
+     (gen-key
+      "create an RSA key pair"
+      (@ ,gen-key-spec) (,command/gen-key))
+     (reg-key
+      "register an RSA key pair"
+      (@ ,reg-key-spec) (,command/reg-key))
+     (sign
+      "sign a package"
+      (@ ,sign-spec) (,command/sign file))
+     (verify
+      "verify a signature"
+      (@ ,verify-spec) (,command/verify file))
+     (upload
+      "upload a package"
+      (@ ,upload-spec) (,command/upload files ...))
+     (update
+      "update available package status"
+      (@ ,update-spec) (,command/update))
+     (help
+      "print help"
+      (,app-help-command args ...))
+     )))
+
+(run-application app-spec
+                 (command-line)
+                 (conf-load (conf-default-path "snow")))
diff --git a/vm.c b/vm.c
new file mode 100644
index 00000000..8b8ec5ed
--- /dev/null
+++ b/vm.c
@@ -0,0 +1,2199 @@
+/*  vm.c -- stack-based virtual machine backend               */
+/*  Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#if SEXP_USE_NATIVE_X86
+#include "opt/x86.c"
+#else
+/* ... the rest of this file ... */
+
+#include "chibi/eval.h"
+
+#if SEXP_USE_DEBUG_VM > 1
+static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) {
+  int i;
+  if (! sexp_oportp(out)) out = sexp_current_error_port(ctx);
+  for (i=0; i<top; i++) {
+    sexp_write_char(ctx, ((i==fp) ? '*' : ' '), out);
+    if (i < 10) sexp_write_char(ctx, '0', out);
+    sexp_write(ctx, sexp_make_fixnum(i), out);
+    sexp_write_string(ctx, ": ", out);
+    sexp_write(ctx, stack[i], out);
+    sexp_newline(ctx, out);
+  }
+}
+#else
+#define sexp_print_stack(ctx, stack, top, fp, out)
+#endif
+
+#if SEXP_USE_FULL_SOURCE_INFO
+static sexp sexp_lookup_source_info (sexp src, int ip) {
+  int i;
+  if (src && sexp_procedurep(src))
+    src = sexp_procedure_source(src);
+  if (src && sexp_vectorp(src) && sexp_vector_length(src) > 0) {
+    for (i=1; i<sexp_vector_length(src); i++)
+      if (sexp_unbox_fixnum(sexp_car(sexp_vector_ref(src, sexp_make_fixnum(i)))) > ip)
+        return sexp_cdr(sexp_vector_ref(src, sexp_make_fixnum(i-1)));
+    return sexp_cdr(sexp_vector_ref(src, sexp_make_fixnum(sexp_vector_length(src)-1)));
+  }
+  return SEXP_FALSE;
+}
+#endif
+
+void sexp_stack_trace (sexp ctx, sexp out) {
+  int i, fp=sexp_context_last_fp(ctx);
+  sexp self, bc, src, *stack=sexp_stack_data(sexp_context_stack(ctx));
+  if (! sexp_oportp(out))
+    out = sexp_current_error_port(ctx);
+  for (i=fp; i>4; i=sexp_unbox_fixnum(stack[i+3])) {
+    self = stack[i+2];
+    if (self && sexp_procedurep(self)) {
+      sexp_write_string(ctx, "  called from ", out);
+      bc = sexp_procedure_code(self);
+      if (sexp_symbolp(sexp_bytecode_name(bc)))
+        sexp_write(ctx, sexp_bytecode_name(bc), out);
+      else
+        sexp_write_string(ctx, "<anonymous>", out);
+      src = sexp_bytecode_source(bc);
+#if SEXP_USE_FULL_SOURCE_INFO
+      if (src && sexp_vectorp(src))
+        src = sexp_lookup_source_info(src, sexp_unbox_fixnum(stack[i+3]));
+#endif
+      if (src && sexp_pairp(src)) {
+        if (sexp_fixnump(sexp_cdr(src)) && (sexp_cdr(src) >= SEXP_ZERO)) {
+          sexp_write_string(ctx, " on line ", out);
+          sexp_write(ctx, sexp_cdr(src), out);
+        }
+        if (sexp_stringp(sexp_car(src))) {
+          sexp_write_string(ctx, " of file ", out);
+          sexp_write_string(ctx, sexp_string_data(sexp_car(src)), out);
+        }
+      }
+      sexp_write_char(ctx, '\n', out);
+    }
+  }
+}
+
+sexp sexp_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp out) {
+  sexp_stack_trace(ctx, out);
+  return SEXP_VOID;
+}
+
+/************************* code generation ****************************/
+
+static void sexp_inc_context_pos(sexp ctx, sexp_sint_t off) {
+  sexp_context_pos(ctx) = sexp_fx_add(sexp_context_pos(ctx), sexp_make_fixnum(off));
+}
+
+static void sexp_inc_context_depth(sexp ctx, sexp_sint_t off) {
+  sexp_context_depth(ctx) = sexp_fx_add(sexp_context_depth(ctx), sexp_make_fixnum(off));
+  if (sexp_unbox_fixnum(sexp_context_depth(ctx))
+      > sexp_unbox_fixnum(sexp_context_max_depth(ctx)))
+    sexp_context_max_depth(ctx) = sexp_context_depth(ctx);
+}
+
+static void bytecode_preserve (sexp ctx, sexp obj) {
+  sexp ls = sexp_bytecode_literals(sexp_context_bc(ctx));
+  if (sexp_pointerp(obj) && !sexp_symbolp(obj)
+      && sexp_not(sexp_memq(ctx, obj, ls)))
+    sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), obj);
+}
+
+static void sexp_emit_word (sexp ctx, sexp_uint_t val)  {
+  unsigned char *data;
+  sexp_expand_bcode(ctx, sizeof(sexp));
+  if (sexp_exceptionp(sexp_context_exception(ctx)))
+    return;
+  data = sexp_bytecode_data(sexp_context_bc(ctx));
+  sexp_context_align_pos(ctx);
+  *((sexp_uint_t*)(&(data[sexp_unbox_fixnum(sexp_context_pos(ctx))]))) = val;
+  sexp_inc_context_pos(ctx, sizeof(sexp));
+}
+
+static void sexp_emit_push (sexp ctx, sexp obj) {
+  sexp_emit(ctx, SEXP_OP_PUSH);
+  sexp_emit_word(ctx, (sexp_uint_t)obj);
+  sexp_inc_context_depth(ctx, 1);
+  bytecode_preserve(ctx, obj);
+}
+
+void sexp_emit_return (sexp ctx) {
+  sexp_emit(ctx, SEXP_OP_RET);
+}
+
+static void sexp_push_source (sexp ctx, sexp source) {
+#if SEXP_USE_FULL_SOURCE_INFO
+  sexp src, bc = sexp_context_bc(ctx);
+  sexp_gc_var1(tmp);
+  if (source && sexp_pairp(source)) {
+    src = sexp_bytecode_source(bc);
+    if (!src) src = sexp_bytecode_source(bc) = SEXP_NULL;
+    if (!sexp_pairp(src)
+        || sexp_unbox_fixnum(sexp_context_pos(ctx)) > sexp_unbox_fixnum(sexp_caar(src))) {
+      sexp_gc_preserve1(ctx, tmp);
+      tmp = sexp_cons(ctx, sexp_context_pos(ctx), source);
+      if (sexp_pairp(tmp)) {
+        tmp = sexp_cons(ctx, tmp, src);
+        if (sexp_pairp(tmp)) sexp_bytecode_source(bc) = tmp;
+      }
+      sexp_gc_release1(ctx);
+    }
+  }
+#endif
+}
+
+static sexp_sint_t sexp_context_make_label (sexp ctx) {
+  sexp_sint_t label;
+  sexp_context_align_pos(ctx);
+  label = sexp_unbox_fixnum(sexp_context_pos(ctx));
+  sexp_inc_context_pos(ctx, sizeof(sexp_uint_t));
+  return label;
+}
+
+static void sexp_context_patch_label (sexp ctx, sexp_sint_t label) {
+  sexp bc = sexp_context_bc(ctx);
+  unsigned char *data = sexp_bytecode_data(bc)+label;
+  if (!sexp_exceptionp(sexp_context_exception(ctx)))
+    *((sexp_sint_t*)data) = sexp_unbox_fixnum(sexp_context_pos(ctx))-label;
+}
+
+static void generate_lit (sexp ctx, sexp value) {
+  sexp_emit_push(ctx, value);
+}
+
+static void generate_drop_prev (sexp ctx, sexp prev) {
+#if ! SEXP_USE_ALIGNED_BYTECODE
+  if ((sexp_pairp(prev) && sexp_opcodep(sexp_car(prev))
+       && (sexp_opcode_code(sexp_car(prev)) == SEXP_OP_PUSH))
+      || sexp_setp(prev) || sexp_litp(prev) || prev == SEXP_VOID)
+    sexp_inc_context_pos(ctx, -(1 + sizeof(sexp)));
+  else
+#endif
+    sexp_emit(ctx, SEXP_OP_DROP);
+}
+
+static void generate_seq (sexp ctx, sexp name, sexp loc, sexp lam, sexp app) {
+  sexp head=app, tail=sexp_cdr(app);
+  sexp_uint_t tailp = sexp_context_tailp(ctx);
+  sexp_push_source(ctx, sexp_pair_source(app));
+  sexp_context_tailp(ctx) = 0;
+  for ( ; sexp_pairp(tail); head=tail, tail=sexp_cdr(tail))
+    if (sexp_pointerp(sexp_car(head)) && (! sexp_litp(sexp_car(head)))) {
+      sexp_generate(ctx, name, loc, lam, sexp_car(head));
+      generate_drop_prev(ctx, sexp_car(head));
+      sexp_inc_context_depth(ctx, -1);
+    }
+  sexp_context_tailp(ctx) = tailp;
+  sexp_generate(ctx, name, loc, lam, sexp_car(head));
+}
+
+static void generate_cnd (sexp ctx, sexp name, sexp loc, sexp lam, sexp cnd) {
+  sexp_sint_t label1, label2, tailp=sexp_context_tailp(ctx);
+  sexp_push_source(ctx, sexp_cnd_source(cnd));
+  sexp_context_tailp(ctx) = 0;
+  sexp_generate(ctx, name, loc, lam, sexp_cnd_test(cnd));
+  sexp_context_tailp(ctx) = tailp;
+  sexp_emit(ctx, SEXP_OP_JUMP_UNLESS);
+  sexp_inc_context_depth(ctx, -1);
+  label1 = sexp_context_make_label(ctx);
+  sexp_generate(ctx, name, loc, lam, sexp_cnd_pass(cnd));
+  sexp_context_tailp(ctx) = tailp;
+  sexp_emit(ctx, SEXP_OP_JUMP);
+  sexp_inc_context_depth(ctx, -1);
+  label2 = sexp_context_make_label(ctx);
+  sexp_context_patch_label(ctx, label1);
+  sexp_generate(ctx, name, loc, lam, sexp_cnd_fail(cnd));
+  sexp_context_patch_label(ctx, label2);
+}
+
+static void generate_non_global_ref (sexp ctx, sexp name, sexp cell,
+                                     sexp lambda, sexp fv, int unboxp) {
+  sexp_uint_t i;
+  sexp loc = sexp_cdr(cell);
+  if (loc == lambda && sexp_lambdap(lambda)) {
+    /* local ref */
+    sexp_emit(ctx, SEXP_OP_LOCAL_REF);
+    sexp_emit_word(ctx, sexp_param_index(ctx, lambda, name));
+  } else {
+    /* closure ref */
+    for (i=0; sexp_pairp(fv); fv=sexp_cdr(fv), i++)
+      if ((name == sexp_ref_name(sexp_car(fv)))
+          && (loc == sexp_ref_loc(sexp_car(fv))))
+        break;
+    sexp_emit(ctx, SEXP_OP_CLOSURE_REF);
+    sexp_emit_word(ctx, i);
+  }
+  if (unboxp && (sexp_truep(sexp_memq(ctx, name, sexp_lambda_sv(loc)))))
+    sexp_emit(ctx, SEXP_OP_CDR);
+  sexp_inc_context_depth(ctx, +1);
+}
+
+static void generate_ref (sexp ctx, sexp ref, int unboxp) {
+  sexp lam;
+  sexp_push_source(ctx, sexp_ref_source(ref));
+  if (! sexp_lambdap(sexp_ref_loc(ref))) {
+    /* global ref */
+    if (unboxp) {
+      sexp_emit(ctx, (sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF)
+		? SEXP_OP_GLOBAL_REF : SEXP_OP_GLOBAL_KNOWN_REF);
+      sexp_emit_word(ctx, (sexp_uint_t)sexp_ref_cell(ref));
+      bytecode_preserve(ctx, sexp_ref_cell(ref));
+    } else
+      sexp_emit_push(ctx, sexp_ref_cell(ref));
+  } else {
+    lam = sexp_context_lambda(ctx);
+    generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref),
+                            lam, sexp_lambda_fv(lam), unboxp);
+  }
+}
+
+static void generate_set (sexp ctx, sexp set) {
+  sexp ref = sexp_set_var(set), lambda;
+  sexp_push_source(ctx, sexp_set_source(set));
+  /* compile the value */
+  sexp_context_tailp(ctx) = 0;
+  if (sexp_lambdap(sexp_set_value(set))) {
+    sexp_lambda_name(sexp_set_value(set)) = sexp_ref_name(ref);
+    sexp_generate(ctx, sexp_ref_name(ref), sexp_ref_loc(ref), sexp_set_value(set), sexp_set_value(set));
+  } else {
+    sexp_generate(ctx, 0, 0, 0, sexp_set_value(set));
+  }
+  if (! sexp_lambdap(sexp_ref_loc(ref))) {
+    /* global vars are set directly */
+    if (sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF) {
+      /* force an undefined variable error if still undef at runtime */
+      generate_ref(ctx, ref, 1);
+      sexp_emit(ctx, SEXP_OP_DROP);
+    }
+    sexp_emit_push(ctx, sexp_ref_cell(ref));
+    sexp_emit(ctx, SEXP_OP_SET_CDR);
+  } else {
+    lambda = sexp_ref_loc(ref);
+    if (sexp_truep(sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)))) {
+      /* stack or closure mutable vars are boxed */
+      generate_ref(ctx, ref, 0);
+      sexp_emit(ctx, SEXP_OP_SET_CDR);
+    } else {
+      /* internally defined variable */
+      sexp_emit(ctx, SEXP_OP_LOCAL_SET);
+      sexp_emit_word(ctx, sexp_param_index(ctx, lambda, sexp_ref_name(ref)));
+    }
+  }
+  sexp_emit_push(ctx, SEXP_VOID);
+  sexp_inc_context_depth(ctx, +1);
+}
+
+static void generate_opcode_app (sexp ctx, sexp app) {
+  sexp op = sexp_car(app);
+  sexp_sint_t i, num_args, inv_default=0;
+  sexp_gc_var1(ls);
+  sexp_gc_preserve1(ctx, ls);
+
+  if (sexp_opcode_tail_call_p(op) && !sexp_context_tailp(ctx)) {
+    sexp_warn(ctx, "tail-call only opcode in non-tail position: ", app);
+    generate_lit(ctx, SEXP_VOID);
+    return;
+  }
+
+  num_args = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app)));
+  sexp_context_tailp(ctx) = 0;
+
+  if (sexp_opcode_class(op) != SEXP_OPC_PARAMETER) {
+
+    /* maybe push the default for an optional argument */
+    if ((num_args == sexp_opcode_num_args(op))
+        && sexp_opcode_variadic_p(op) && sexp_opcode_data(op)) {
+      if (sexp_opcode_inverse(op)) {
+        inv_default = 1;
+      } else {
+        if (sexp_opcode_opt_param_p(op) && sexp_opcodep(sexp_opcode_data(op))) {
+#if SEXP_USE_GREEN_THREADS
+          sexp_emit(ctx, SEXP_OP_PARAMETER_REF);
+          sexp_emit_word(ctx, (sexp_uint_t)sexp_opcode_data(op));
+          bytecode_preserve(ctx, sexp_opcode_data(op));
+#else
+          sexp_emit_push(ctx, sexp_opcode_data(sexp_opcode_data(op)));
+#endif
+          sexp_emit(ctx, SEXP_OP_CDR);
+        } else {
+          sexp_emit_push(ctx, sexp_opcode_data(op));
+        }
+        sexp_inc_context_depth(ctx, +1);
+        num_args++;
+      }
+    }
+
+    /* push the arguments onto the stack in reverse order */
+    if (!sexp_opcode_static_param_p(op)) {
+      ls = ((sexp_opcode_inverse(op)
+             && (sexp_opcode_class(op) != SEXP_OPC_ARITHMETIC))
+            ? sexp_cdr(app) : sexp_reverse(ctx, sexp_cdr(app)));
+      for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) {
+        sexp_generate(ctx, 0, 0, 0, sexp_car(ls));
+#if SEXP_USE_AUTO_FORCE
+        if (((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR)
+             || sexp_opcode_code(op) == SEXP_OP_MAKE_VECTOR)
+            && !(sexp_opcode_class(op) == SEXP_OPC_TYPE_PREDICATE
+                 && sexp_unbox_fixnum(sexp_opcode_data(op)) == SEXP_PROMISE))
+          sexp_emit(ctx, SEXP_OP_FORCE);
+#endif
+      }
+    }
+
+  }
+
+  /* push the default for inverse opcodes */
+  if (inv_default) {
+    sexp_emit_push(ctx, sexp_opcode_data(op));
+    if (sexp_opcode_opt_param_p(op)) sexp_emit(ctx, SEXP_OP_CDR);
+    sexp_inc_context_depth(ctx, +1);
+    num_args++;
+  }
+
+  /* emit the actual operator call */
+  switch (sexp_opcode_class(op)) {
+  case SEXP_OPC_ARITHMETIC:
+    /* fold variadic arithmetic operators */
+    for (i=num_args-1; i>0; i--)
+      sexp_emit(ctx, sexp_opcode_code(op));
+    break;
+  case SEXP_OPC_ARITHMETIC_CMP:
+    /* With [<true-value>, x] on the stack, and x boolean, */
+    /* AND is equivalent to ROT+DROP.  Note one AND for every STACK_REF. */
+    if (num_args > 2) {
+      sexp_emit(ctx, SEXP_OP_STACK_REF);
+      sexp_emit_word(ctx, 2);
+      sexp_emit(ctx, SEXP_OP_STACK_REF);
+      sexp_emit_word(ctx, 2);
+      sexp_emit(ctx, sexp_opcode_code(op));
+      sexp_emit(ctx, SEXP_OP_AND);
+      for (i=num_args-2; i>0; i--) {
+        sexp_emit(ctx, SEXP_OP_STACK_REF);
+        sexp_emit_word(ctx, 3);
+        sexp_emit(ctx, SEXP_OP_STACK_REF);
+        sexp_emit_word(ctx, 3);
+        sexp_emit(ctx, sexp_opcode_code(op));
+        sexp_emit(ctx, SEXP_OP_AND);
+        sexp_emit(ctx, SEXP_OP_AND);
+      }
+      sexp_emit(ctx, SEXP_OP_AND);
+    } else
+      sexp_emit(ctx, sexp_opcode_code(op));
+    break;
+  case SEXP_OPC_FOREIGN:
+    sexp_emit(ctx, sexp_opcode_code(op));
+    sexp_emit_word(ctx, (sexp_uint_t)op);
+    bytecode_preserve(ctx, op);
+    break;
+  case SEXP_OPC_TYPE_PREDICATE:
+  case SEXP_OPC_GETTER:
+  case SEXP_OPC_SETTER:
+  case SEXP_OPC_CONSTRUCTOR:
+    sexp_emit(ctx, sexp_opcode_code(op));
+    if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR)
+        || sexp_opcode_code(op) == SEXP_OP_MAKE) {
+      if (sexp_opcode_data(op))
+        sexp_emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op)));
+      if (sexp_opcode_data2(op))
+        sexp_emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op)));
+      if (sexp_opcode_data(op) || sexp_opcode_data2(op))
+        bytecode_preserve(ctx, op);
+    }
+    break;
+  case SEXP_OPC_PARAMETER:
+#if SEXP_USE_GREEN_THREADS
+    if (num_args > 0) {
+      if (sexp_opcode_data2(op) && sexp_applicablep(sexp_opcode_data2(op))) {
+        ls = sexp_list2(ctx, sexp_opcode_data2(op), sexp_cadr(app));
+        sexp_generate(ctx, 0, 0, 0, ls);
+      } else {
+        sexp_generate(ctx, 0, 0, 0, sexp_cadr(app));
+      }
+    }
+    sexp_emit(ctx, SEXP_OP_PARAMETER_REF);
+    sexp_emit_word(ctx, (sexp_uint_t)op);
+    bytecode_preserve(ctx, op);
+#else
+    if (num_args > 0) sexp_generate(ctx, 0, 0, 0, sexp_cadr(app));
+    sexp_emit_push(ctx, sexp_opcode_data(op));
+#endif
+    sexp_emit(ctx, ((num_args == 0) ? SEXP_OP_CDR : SEXP_OP_SET_CDR));
+    if (num_args > 0) sexp_emit_push(ctx, SEXP_VOID);
+    break;
+  default:
+    sexp_emit(ctx, sexp_opcode_code(op));
+  }
+
+  if (sexp_opcode_static_param_p(op))
+    for (ls=sexp_cdr(app); sexp_pairp(ls); ls=sexp_cdr(ls))
+      sexp_emit_word(ctx, sexp_unbox_fixnum(sexp_litp(sexp_car(ls)) ?
+					    sexp_lit_value(sexp_car(ls)) :
+					    sexp_car(ls)));
+
+  if (sexp_opcode_return_type(op) == SEXP_VOID
+      && sexp_opcode_class(op) != SEXP_OPC_FOREIGN)
+    sexp_emit_push(ctx, SEXP_VOID);
+
+  sexp_inc_context_depth(ctx, -(num_args-1));
+  sexp_gc_release1(ctx);
+}
+
+static void generate_general_app (sexp ctx, sexp app) {
+  sexp_uint_t len = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))),
+    tailp = sexp_context_tailp(ctx);
+  sexp_gc_var1(ls);
+  sexp_gc_preserve1(ctx, ls);
+
+  /* push the arguments onto the stack */
+  sexp_context_tailp(ctx) = 0;
+  for (ls=sexp_reverse(ctx, sexp_cdr(app)); sexp_pairp(ls); ls=sexp_cdr(ls))
+    sexp_generate(ctx, 0, 0, 0, sexp_car(ls));
+
+  /* push the operator onto the stack */
+  sexp_generate(ctx, 0, 0, 0, sexp_car(app));
+
+  /* maybe overwrite the current frame */
+  sexp_emit(ctx, (tailp ? SEXP_OP_TAIL_CALL : SEXP_OP_CALL));
+  sexp_emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len));
+
+  sexp_context_tailp(ctx) = tailp;
+  sexp_inc_context_depth(ctx, -len);
+  sexp_gc_release1(ctx);
+}
+
+#if SEXP_USE_TAIL_JUMPS
+static void generate_tail_jump (sexp ctx, sexp name, sexp loc, sexp lam, sexp app) {
+  sexp_gc_var3(ls1, ls2, ls3);
+  sexp_gc_preserve3(ctx, ls1, ls2, ls3);
+
+  /* overwrite the arguments that differ */
+  sexp_context_tailp(ctx) = 0;
+  for (ls1=sexp_cdr(app), ls2=sexp_lambda_params(lam), ls3=SEXP_NULL;
+       sexp_pairp(ls1); ls1=sexp_cdr(ls1), ls2=sexp_cdr(ls2)) {
+    if (!(sexp_refp(sexp_car(ls1))
+          && sexp_ref_name(sexp_car(ls1)) == sexp_car(ls2)
+          && sexp_ref_loc(sexp_car(ls1)) == lam
+          && sexp_not(sexp_memq(ctx, sexp_car(ls2), sexp_lambda_sv(lam))))) {
+      sexp_generate(ctx, 0, 0, 0, sexp_car(ls1));
+      ls3 = sexp_cons(ctx, sexp_car(ls2), ls3);
+    }
+  }
+  for (ls1=ls3; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) {
+    sexp_emit(ctx, SEXP_OP_LOCAL_SET);
+    sexp_emit_word(ctx, sexp_param_index(ctx, lam, sexp_car(ls1)));
+  }
+
+  /* drop the current result and jump */
+  sexp_emit(ctx, SEXP_OP_JUMP);
+  sexp_context_align_pos(ctx);
+  sexp_emit_word(ctx, (sexp_uint_t) (-sexp_unbox_fixnum(sexp_context_pos(ctx)) +
+				     (sexp_pairp(sexp_lambda_locals(lam))
+				      ? 1 + sizeof(sexp) : 0)));
+
+  sexp_context_tailp(ctx) = 1;
+  sexp_gc_release3(ctx);
+}
+#endif
+
+static void generate_app (sexp ctx, sexp name, sexp loc, sexp lam, sexp app) {
+  sexp_push_source(ctx, sexp_pair_source(app));
+  if (sexp_opcodep(sexp_car(app)))
+    generate_opcode_app(ctx, app);
+#if SEXP_USE_TAIL_JUMPS
+  else if (sexp_context_tailp(ctx) && sexp_refp(sexp_car(app))
+           && name == sexp_ref_name(sexp_car(app))
+           && loc == sexp_ref_loc(sexp_car(app))
+           && (sexp_length(ctx, sexp_cdr(app))
+               == sexp_length(ctx, sexp_lambda_params(lam))))
+    generate_tail_jump(ctx, name, loc, lam, app);
+#endif
+  else
+    generate_general_app(ctx, app);
+}
+
+#if SEXP_USE_UNBOXED_LOCALS
+static int sexp_internal_definep(sexp ctx, sexp x) {
+  return sexp_lambdap(sexp_ref_loc(x))
+    && sexp_truep(sexp_memq(ctx, sexp_ref_name(x),
+                            sexp_lambda_locals(sexp_ref_loc(x))));
+}
+
+static int sexp_mutual_internal_definep(sexp ctx, sexp x, sexp fv) {
+  return sexp_internal_definep(ctx, x)
+    && sexp_ref_loc(x) == sexp_ref_loc(fv) && sexp_internal_definep(ctx, fv)
+    && sexp_not(sexp_memq(ctx, sexp_ref_name(fv),
+                          sexp_lambda_sv(sexp_ref_loc(fv))));
+}
+
+static int generate_lambda_locals (sexp ctx, sexp name, sexp loc, sexp lam, sexp x) {
+  sexp ls;
+  if (sexp_seqp(x)) {
+    for (ls=sexp_seq_ls(x); sexp_pairp(ls); ls=sexp_cdr(ls))
+      if (!generate_lambda_locals(ctx, name, loc, lam, sexp_car(ls)))
+        return 0;
+    return 1;
+  } else if (sexp_setp(x) && sexp_internal_definep(ctx, sexp_set_var(x))) {
+    sexp_generate(ctx, name, loc, lam, x);
+    sexp_inc_context_pos(ctx, -(1 + sizeof(sexp)));
+    return 1;
+  }
+  return 0;
+}
+
+static int generate_lambda_body (sexp ctx, sexp name, sexp loc, sexp lam, sexp x, sexp prev_lam) {
+  sexp_uint_t k, updatep, tailp;
+  sexp ls, ref, fv, prev_fv;
+  if (sexp_exceptionp(sexp_context_exception(ctx)))
+    return 0;
+  if (sexp_seqp(x)) {
+    tailp = sexp_context_tailp(ctx);
+    sexp_context_tailp(ctx) = 0;
+    for (ls=sexp_seq_ls(x); sexp_pairp(ls); ls=sexp_cdr(ls)) {
+      if (sexp_nullp(sexp_cdr(ls))) sexp_context_tailp(ctx) = tailp;
+      if (!generate_lambda_body(ctx, name, loc, lam, sexp_car(ls), prev_lam)) {
+        if (sexp_pairp(sexp_cdr(ls))) {
+          generate_drop_prev(ctx, sexp_car(ls));
+          for (ls=sexp_cdr(ls); sexp_pairp(ls) && sexp_pairp(sexp_cdr(ls));
+               ls=sexp_cdr(ls)) {
+            sexp_generate(ctx, name, loc, lam, sexp_car(ls));
+            generate_drop_prev(ctx, sexp_car(ls));
+          }
+          sexp_context_tailp(ctx) = tailp;
+          sexp_generate(ctx, name, loc, lam, sexp_car(ls));
+        }
+        return 0;
+      }
+    }
+    return 1;
+  } else if (sexp_setp(x) && sexp_internal_definep(ctx, sexp_set_var(x))) {
+    updatep = 0;
+    if (sexp_lambdap(sexp_set_value(x))) {
+      /* update potentially changed bindings */
+      fv = sexp_lambda_fv(sexp_set_value(x));
+      prev_fv = sexp_lambdap(prev_lam) ? sexp_lambda_fv(prev_lam) : SEXP_NULL;
+      for (k=0; fv && sexp_pairp(fv); fv=sexp_cdr(fv), k++) {
+        ref = sexp_car(fv);
+        if (sexp_mutual_internal_definep(ctx, sexp_set_var(x), ref)) {
+          if (!updatep) {
+            updatep = 1;
+            generate_non_global_ref(ctx, sexp_ref_name(sexp_set_var(x)),
+                                    sexp_ref_cell(sexp_set_var(x)),
+                                    lam, sexp_lambda_fv(lam), 1);
+            sexp_emit(ctx, SEXP_OP_CLOSURE_VARS);
+          }
+          generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref),
+                                  lam, sexp_lambda_fv(lam), 1);
+          sexp_emit_push(ctx, sexp_make_fixnum(k));
+          sexp_emit(ctx, SEXP_OP_STACK_REF);
+          sexp_emit_word(ctx, 3);
+          sexp_emit(ctx, SEXP_OP_VECTOR_SET);
+          sexp_inc_context_depth(ctx, -1);
+        }
+      }
+    }
+    if (updatep) sexp_emit(ctx, SEXP_OP_DROP);
+    return 1;
+  }
+  sexp_generate(ctx, name, loc, lam, x);
+  return 0;
+}
+#endif
+
+static void generate_lambda (sexp ctx, sexp name, sexp loc, sexp lam, sexp lambda) {
+  sexp ctx2, fv, ls, flags, len, ref, prev_lambda, prev_fv;
+  sexp_sint_t k;
+  sexp_gc_var2(tmp, bc);
+  if (sexp_exceptionp(sexp_context_exception(ctx)))
+    return;
+  prev_lambda = sexp_context_lambda(ctx);
+  prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL;
+  fv = sexp_lambda_fv(lambda);
+  ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx), 0, 0);
+  if (sexp_exceptionp(ctx2)) {
+    sexp_context_exception(ctx) = ctx2;
+    return;
+  }
+  sexp_context_lambda(ctx2) = lambda;
+  sexp_gc_preserve2(ctx, tmp, bc);
+  tmp = sexp_cons(ctx2, SEXP_ZERO, sexp_lambda_source(lambda));
+  /* allocate space for local vars */
+  k = sexp_unbox_fixnum(sexp_length(ctx, sexp_lambda_locals(lambda)));
+  if (k > 0) {
+#if SEXP_USE_RESERVE_OPCODE
+    sexp_emit(ctx2, SEXP_OP_RESERVE);
+    sexp_emit_word(ctx2, k);
+#else
+    while (k--) sexp_emit_push(ctx2, SEXP_UNDEF);
+#endif
+  }
+  /* box mutable vars */
+  for (ls=sexp_lambda_sv(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) {
+    k = sexp_param_index(ctx, lambda, sexp_car(ls));
+    sexp_emit(ctx2, SEXP_OP_LOCAL_REF);
+    sexp_emit_word(ctx2, k);
+    sexp_emit_push(ctx2, sexp_car(ls));
+    sexp_emit(ctx2, SEXP_OP_CONS);
+    sexp_emit(ctx2, SEXP_OP_LOCAL_SET);
+    sexp_emit_word(ctx2, k);
+  }
+  if (lam != lambda) loc = 0;
+#if SEXP_USE_UNBOXED_LOCALS
+  sexp_context_tailp(ctx2) = 0;
+  generate_lambda_locals(ctx2, name, loc, lambda, sexp_lambda_body(lambda));
+  sexp_context_tailp(ctx2) = 1;
+  generate_lambda_body(ctx2, name, loc, lambda, sexp_lambda_body(lambda), prev_lambda);
+#else
+  sexp_context_tailp(ctx2) = 1;
+  sexp_generate(ctx2, name, loc, lam, sexp_lambda_body(lambda));
+#endif
+  flags = sexp_make_fixnum(sexp_not(sexp_listp(ctx, sexp_lambda_params(lambda)))
+                           ? (SEXP_PROC_VARIADIC + (sexp_rest_unused_p(lambda)
+                                                    ? SEXP_PROC_UNUSED_REST: 0))
+                           : SEXP_PROC_NONE);
+  len = sexp_length(ctx2, sexp_lambda_params(lambda));
+  bc = sexp_complete_bytecode(ctx2);
+  if (sexp_exceptionp(bc)) {
+    sexp_context_exception(ctx) = bc;
+  } else {
+  sexp_bytecode_name(bc) = sexp_lambda_name(lambda);
+#if ! SEXP_USE_FULL_SOURCE_INFO
+  sexp_bytecode_source(bc) = sexp_lambda_source(lambda);
+#endif
+  if (sexp_nullp(fv)) {
+    /* shortcut, no free vars */
+    tmp = sexp_make_vector(ctx2, SEXP_ZERO, SEXP_VOID);
+    tmp = sexp_make_procedure(ctx2, flags, len, bc, tmp);
+    bytecode_preserve(ctx, tmp);
+    generate_lit(ctx, tmp);
+  } else {
+    /* push the closed vars */
+    sexp_emit_push(ctx, SEXP_VOID);
+    sexp_emit_push(ctx, sexp_length(ctx, fv));
+    sexp_emit(ctx, SEXP_OP_MAKE_VECTOR);
+    sexp_inc_context_depth(ctx, -1);
+    for (k=0; sexp_pairp(fv); fv=sexp_cdr(fv), k++) {
+      ref = sexp_car(fv);
+      generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref),
+                              prev_lambda, prev_fv, 0);
+      sexp_emit_push(ctx, sexp_make_fixnum(k));
+      sexp_emit(ctx, SEXP_OP_STACK_REF);
+      sexp_emit_word(ctx, 3);
+      sexp_emit(ctx, SEXP_OP_VECTOR_SET);
+      sexp_inc_context_depth(ctx, -1);
+    }
+    /* push the additional procedure info and make the closure */
+    sexp_emit(ctx, SEXP_OP_MAKE_PROCEDURE);
+    sexp_emit_word(ctx, (sexp_uint_t)flags);
+    sexp_emit_word(ctx, (sexp_uint_t)len);
+    sexp_emit_word(ctx, (sexp_uint_t)bc);
+    bytecode_preserve(ctx, bc);
+  }
+  }
+  sexp_gc_release2(ctx);
+}
+
+void sexp_generate (sexp ctx, sexp name, sexp loc, sexp lam, sexp x) {
+  if (sexp_exceptionp(sexp_context_exception(ctx)))
+    return;
+  if (sexp_pointerp(x)) {
+    switch (sexp_pointer_tag(x)) {
+    case SEXP_PAIR:   generate_app(ctx, name, loc, lam, x); break;
+    case SEXP_LAMBDA: generate_lambda(ctx, name, loc, lam, x); break;
+    case SEXP_CND:    generate_cnd(ctx, name, loc, lam, x); break;
+    case SEXP_REF:    generate_ref(ctx, x, 1); break;
+    case SEXP_SET:    generate_set(ctx, x); break;
+    case SEXP_SEQ:    generate_seq(ctx, name, loc, lam, sexp_seq_ls(x)); break;
+    case SEXP_LIT:    generate_lit(ctx, sexp_lit_value(x)); break;
+    default:          generate_lit(ctx, x);
+    }
+  } else {
+    generate_lit(ctx, x);
+  }
+}
+
+static sexp make_param_list (sexp ctx, sexp_uint_t i) {
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  res = SEXP_NULL;
+  for ( ; i>0; i--)
+    res = sexp_cons(ctx, sexp_make_fixnum(i), res);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
+  sexp ls, res, env;
+  sexp_gc_var6(bc, params, ref, refs, lambda, ctx2);
+  if (i == sexp_opcode_num_args(op)) { /* return before preserving */
+    if (sexp_opcode_proc(op)) return sexp_opcode_proc(op);
+  } else if (i < sexp_opcode_num_args(op)) {
+    return sexp_compile_error(ctx, "not enough args for opcode", op);
+  } else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */
+    return sexp_compile_error(ctx, "too many args for opcode", op);
+  }
+  sexp_gc_preserve6(ctx, bc, params, ref, refs, lambda, ctx2);
+  params = make_param_list(ctx, i);
+  lambda = sexp_make_lambda(ctx, params);
+  ctx2 = sexp_make_child_context(ctx, lambda);
+  env = sexp_extend_env(ctx2, sexp_context_env(ctx), params, lambda);
+  if (sexp_exceptionp(env)) {
+    res = env;
+  } else {
+    sexp_context_env(ctx2) = env;
+    for (ls=params, refs=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) {
+      ref = sexp_make_ref(ctx2, sexp_car(ls), sexp_env_cell(ctx, env, sexp_car(ls), 0));
+      if (!sexp_exceptionp(ref)) sexp_push(ctx2, refs, ref);
+    }
+    if (!sexp_exceptionp(refs))
+      refs = sexp_reverse(ctx2, refs);
+    refs = sexp_cons(ctx2, op, refs);
+    if (sexp_exceptionp(refs)) {
+      res = refs;
+    } else {
+      generate_opcode_app(ctx2, refs);
+      bc = sexp_complete_bytecode(ctx2);
+      sexp_bytecode_name(bc) = sexp_opcode_name(op);
+      res=sexp_make_procedure(ctx2, SEXP_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID);
+      if (i == sexp_opcode_num_args(op))
+        sexp_opcode_proc(op) = res;
+    }
+  }
+  sexp_gc_release6(ctx);
+  return res;
+}
+
+/*********************** the virtual machine **************************/
+
+sexp sexp_make_trampoline (sexp ctx, sexp proc, sexp args) {
+  return sexp_make_exception(ctx, SEXP_TRAMPOLINE, SEXP_FALSE, args, proc, SEXP_FALSE);
+}
+
+#if SEXP_USE_GROW_STACK
+static int sexp_grow_stack (sexp ctx, int min_size) {
+  sexp stack, old_stack = sexp_context_stack(ctx), *from, *to;
+  int i, size = sexp_stack_length(old_stack), new_size;
+  new_size = size * 2;
+  if (new_size < min_size) new_size = min_size;
+  if (new_size > SEXP_MAX_STACK_SIZE) {
+    if (size == SEXP_MAX_STACK_SIZE)
+      return 0;
+    new_size = SEXP_MAX_STACK_SIZE;
+  }
+  stack = sexp_alloc_tagged(ctx, (sexp_sizeof(stack)+sizeof(sexp)*new_size),
+                            SEXP_STACK);
+  if (!stack || sexp_exceptionp(stack))
+    return 0;
+  sexp_stack_length(stack) = new_size;
+  sexp_stack_top(stack) = sexp_context_top(ctx);
+  from = sexp_stack_data(old_stack);
+  to = sexp_stack_data(stack);
+  for (i=sexp_context_top(ctx)+1; i>=0; i--)
+    to[i] = from[i];
+  for (; ctx; ctx=sexp_context_parent(ctx))
+    if (sexp_context_stack(ctx) == old_stack)
+      sexp_context_stack(ctx) = stack;
+  return 1;
+}
+#else
+#define sexp_grow_stack(ctx, min_size) 0
+#endif
+
+static sexp sexp_save_stack (sexp ctx, sexp *stack, sexp_uint_t to) {
+  sexp res, *data;
+  sexp_uint_t i;
+  res = sexp_make_vector(ctx, sexp_make_fixnum(to), SEXP_VOID);
+  data = sexp_vector_data(res);
+  for (i=0; i<to; i++)
+    data[i] = stack[i];
+  return res;
+}
+
+static sexp sexp_restore_stack (sexp ctx, sexp saved) {
+  sexp_uint_t len = sexp_vector_length(saved), i;
+  sexp *from = sexp_vector_data(saved), *to;
+#if SEXP_USE_CHECK_STACK
+  if ((len+64 >= sexp_stack_length(sexp_context_stack(ctx)))
+      && !sexp_grow_stack(ctx, len+64))
+    return sexp_global(ctx, SEXP_G_OOS_ERROR);
+#endif
+  to = sexp_stack_data(sexp_context_stack(ctx));
+  for (i=0; i<len; i++)
+    to[i] = from[i];
+  sexp_context_top(ctx) = len;
+  return SEXP_VOID;
+}
+
+#define _ARG1 stack[top-1]
+#define _ARG2 stack[top-2]
+#define _ARG3 stack[top-3]
+#define _ARG4 stack[top-4]
+#define _ARG5 stack[top-5]
+#define _ARG6 stack[top-6]
+#define _PUSH(x) (stack[top++]=(x))
+#define _POP() (stack[--top])
+
+#if SEXP_USE_ALIGNED_BYTECODE
+#define _ALIGN_IP() ip = (unsigned char *)sexp_word_align((sexp_uint_t)ip)
+#else
+#define _ALIGN_IP()
+#endif
+
+#define _WORD0 ((sexp*)ip)[0]
+#define _UWORD0 ((sexp_uint_t*)ip)[0]
+#define _SWORD0 ((sexp_sint_t*)ip)[0]
+#define _WORD1 ((sexp*)ip)[1]
+#define _UWORD1 ((sexp_uint_t*)ip)[1]
+#define _SWORD1 ((sexp_sint_t*)ip)[1]
+#define _WORD2 ((sexp*)ip)[2]
+
+#define sexp_raise(msg, args)                                       \
+  do {sexp_context_top(ctx) = top+1;                                \
+      stack[top] = args;                                            \
+      stack[top] = sexp_user_exception(ctx, self, msg, stack[top]); \
+      top++;                                                        \
+      goto call_error_handler;}                                     \
+  while (0)
+
+#define sexp_check_exception()                                 \
+  do {if (sexp_exceptionp(_ARG1)) {                            \
+      goto call_error_handler;}}                               \
+    while (0)
+
+static int sexp_check_type(sexp ctx, sexp a, sexp b) {
+  int d;
+  sexp t, v;
+  if (! sexp_pointerp(a))
+    return 0;
+  if (sexp_isa(a, b))
+    return 1;
+  t = sexp_object_type(ctx, a);
+  v = sexp_type_cpl(t);
+  if (! sexp_vectorp(v))
+    return 0;
+  if (b == sexp_type_by_index(ctx, SEXP_OBJECT))
+    return 1;
+  d = sexp_type_depth(b);
+  return (d < sexp_vector_length(v))
+    && sexp_vector_ref(v, sexp_make_fixnum(d)) == b;
+}
+
+#if SEXP_USE_GREEN_THREADS
+#define sexp_fcall_return(x, i)                             \
+  if (sexp_exceptionp(x)) {                                 \
+    if (x == sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR)) {     \
+      fuel = 0; ip--; goto loop;                            \
+    } else if (x == sexp_global(ctx, SEXP_G_IO_BLOCK_ONCE_ERROR)) { \
+      stack[top-i+1] = SEXP_ZERO;                                   \
+      fuel = 0; ip--; goto loop;                            \
+    } else {                                                \
+      top -= i;                                             \
+      _ARG1 = x;                                            \
+      ip += sizeof(sexp);                                   \
+      goto call_error_handler;                              \
+    }                                                       \
+  } else {                                                  \
+    top -= i;                                               \
+    _ARG1 = x;                                              \
+    ip += sizeof(sexp);                                     \
+  }
+#else
+#define sexp_fcall_return(x, i)                                 \
+  top -= i; _ARG1 = x; ip += sizeof(sexp); sexp_check_exception();
+#endif
+
+#if SEXP_USE_EXTENDED_FCALL
+#include "opt/fcall.c"
+#endif
+
+#if SEXP_USE_PROFILE_VM
+sexp_uint_t profile1[SEXP_OP_NUM_OPCODES];
+sexp_uint_t profile2[SEXP_OP_NUM_OPCODES][SEXP_OP_NUM_OPCODES];
+
+sexp sexp_reset_vm_profile (sexp ctx, sexp self, sexp_sint_t n) {
+  int i, j;
+  for (i=0; i<SEXP_OP_NUM_OPCODES; i++) {
+    profile1[i] = 0;
+    for (j=0; j<SEXP_OP_NUM_OPCODES; j++) profile2[i][j] = 0;
+  }
+  return SEXP_VOID;
+}
+
+sexp sexp_print_vm_profile (sexp ctx, sexp self, sexp_sint_t n) {
+  int i, j;
+  for (i=0; i<SEXP_OP_NUM_OPCODES; i++)
+    fprintf(stderr, "%s %lu\n", sexp_opcode_names[i], profile1[i]);
+  for (i=0; i<SEXP_OP_NUM_OPCODES; i++)
+    for (j=0; j<SEXP_OP_NUM_OPCODES; j++)
+      fprintf(stderr, "%s %s %lu\n", sexp_opcode_names[i],
+              sexp_opcode_names[j], profile2[i][j]);
+  return SEXP_VOID;
+}
+#endif
+
+#if SEXP_USE_DEBUG_THREADS
+static const char* sexp_thread_debug_name(sexp ctx) {
+  if (sexp_stringp(sexp_context_name(ctx)))
+    return sexp_string_data(sexp_context_name(ctx));
+  return "?";
+}
+
+static char* sexp_thread_debug_event_type(sexp ctx) {
+  sexp evt = sexp_context_event(ctx);
+  return sexp_portp(evt) ? "p" : sexp_contextp(evt) ? "c" : "?";
+}
+
+static void* sexp_thread_debug_event(sexp ctx) {
+  return (void*)sexp_context_event(ctx);
+}
+#endif
+
+#if SEXP_USE_CHECK_STACK
+#define sexp_ensure_stack(n)                                            \
+  if (top+(n) >= sexp_stack_length(sexp_context_stack(ctx))) {          \
+    sexp_context_top(ctx) = top;                                        \
+    if (sexp_grow_stack(ctx, (n))) {                                    \
+      stack = sexp_stack_data(sexp_context_stack(ctx));                 \
+    } else {                                                            \
+      _ARG1 = sexp_global(ctx, SEXP_G_OOS_ERROR);                       \
+      goto end_loop;                                                    \
+    }                                                                   \
+  }
+#else
+#define sexp_ensure_stack(n)
+#endif
+
+sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
+  unsigned char *ip;
+  sexp bc, cp, *stack = sexp_stack_data(sexp_context_stack(ctx));
+  sexp_sint_t i, j, k, fp, top = sexp_stack_top(sexp_context_stack(ctx));
+#if SEXP_USE_GREEN_THREADS
+  sexp root_thread = ctx;
+  sexp_sint_t fuel = sexp_context_refuel(ctx);
+#endif
+#if SEXP_USE_PROFILE_VM
+  unsigned char last_op = SEXP_OP_NOOP;
+#endif
+#if SEXP_USE_BIGNUMS
+  sexp_lsint_t prod;
+#endif
+  sexp_gc_var3(self, tmp1, tmp2);
+  sexp_gc_preserve3(ctx, self, tmp1, tmp2);
+  fp = top - 4;
+  self = sexp_global(ctx, SEXP_G_FINAL_RESUMER);
+  bc = sexp_procedure_code(self);
+  cp = sexp_procedure_vars(self);
+  ip = sexp_bytecode_data(bc) - sizeof(sexp);
+  tmp1 = proc, tmp2 = args;
+  i = sexp_unbox_fixnum(sexp_length(ctx, tmp2));
+  sexp_ensure_stack(i + 64 + (sexp_procedurep(tmp1) ? sexp_bytecode_max_depth(sexp_procedure_code(tmp1)) : 0));
+  for (top += i; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--)
+    _ARG1 = sexp_car(tmp2);
+  top += i+1;
+  goto make_call;
+
+ loop:
+#if SEXP_USE_GREEN_THREADS
+  if (--fuel <= 0) {
+    tmp1 = sexp_global(ctx, SEXP_G_THREADS_SCHEDULER);
+    if (sexp_applicablep(tmp1) && sexp_not(sexp_global(ctx, SEXP_G_ATOMIC_P))) {
+      /* save thread */
+      sexp_context_top(ctx) = top;
+      sexp_context_ip(ctx) = ip;
+      sexp_context_last_fp(ctx) = fp;
+      sexp_context_proc(ctx) = self;
+      /* run scheduler */
+#if SEXP_USE_DEBUG_THREADS
+      tmp2 = ctx;
+#endif
+      ctx = sexp_apply1(ctx, tmp1, root_thread);
+      /* restore thread */
+      stack = sexp_stack_data(sexp_context_stack(ctx));
+      top = sexp_context_top(ctx);
+      fp = sexp_context_last_fp(ctx);
+      ip = sexp_context_ip(ctx);
+      self = sexp_context_proc(ctx);
+      bc = sexp_procedure_code(self);
+      cp = sexp_procedure_vars(self);
+#if SEXP_USE_DEBUG_THREADS
+      if (ctx != tmp2) {
+        fprintf(stderr, "****** schedule %p: %p (%s) active:",
+                root_thread, ctx, sexp_thread_debug_name(ctx));
+        for (tmp1=sexp_global(ctx, SEXP_G_THREADS_FRONT); sexp_pairp(tmp1); tmp1=sexp_cdr(tmp1))
+          fprintf(stderr, " %p (%s)", sexp_car(tmp1), sexp_thread_debug_name(sexp_car(tmp1)));
+        fprintf(stderr, " paused:");
+        for (tmp1=sexp_global(ctx, SEXP_G_THREADS_PAUSED); sexp_pairp(tmp1); tmp1=sexp_cdr(tmp1))
+          fprintf(stderr, " %p (%s) [%s %p]", sexp_car(tmp1), sexp_thread_debug_name(sexp_car(tmp1)), sexp_thread_debug_event_type(sexp_car(tmp1)), sexp_thread_debug_event(sexp_car(tmp1)));
+        fprintf(stderr, " ******\n");
+      }
+#endif
+    }
+    fuel = sexp_context_refuel(ctx);
+    if (fuel <= 0) goto end_loop;
+  }
+#endif
+#if SEXP_USE_DEBUG_VM
+  if (sexp_context_tracep(ctx)) {
+    sexp_print_stack(ctx, stack, top, fp, SEXP_FALSE);
+    fprintf(stderr, "****** VM %s %s ip: %p stack: %p top: %ld fp: %ld (%ld)\n",
+            (*ip<=SEXP_OP_NUM_OPCODES) ? sexp_opcode_names[*ip] : "UNKNOWN",
+            (SEXP_OP_FCALL0 <= *ip && *ip <= SEXP_OP_FCALL4
+             ? sexp_string_data(sexp_opcode_name(((sexp*)(ip+1))[0])) : ""),
+            ip, stack, top, fp, (fp<1024 ? sexp_unbox_fixnum(stack[fp+3]) : -1));
+  }
+#endif
+#if SEXP_USE_PROFILE_VM
+  profile1[*ip]++;
+  profile2[last_op][*ip]++;
+  last_op = *ip;
+#endif
+  switch (*ip++) {
+  case SEXP_OP_NOOP:
+    break;
+  call_error_handler:
+    if (! sexp_exception_procedure(_ARG1))
+      sexp_exception_procedure(_ARG1) = self;
+#if SEXP_USE_FULL_SOURCE_INFO
+    if (sexp_not(sexp_exception_source(_ARG1))
+        && sexp_procedurep(sexp_exception_procedure(_ARG1))
+        && sexp_procedure_source(sexp_exception_procedure(_ARG1)))
+      sexp_exception_source(_ARG1) = sexp_lookup_source_info(sexp_exception_procedure(_ARG1), (ip-sexp_bytecode_data(bc)));
+#endif
+  case SEXP_OP_RAISE:
+    sexp_context_top(ctx) = top;
+    if (sexp_trampolinep(_ARG1)) {
+      tmp1 = sexp_trampoline_procedure(_ARG1);
+      tmp2 = sexp_trampoline_args(_ARG1);
+      top--;
+      if (sexp_not(tmp1) && sexp_pairp(tmp2)) { /* noop trampoline is */
+        _PUSH(sexp_car(tmp2));                  /* a wrapped exception */
+        goto loop;
+      }
+      goto apply1;
+    }
+    tmp1 = sexp_parameter_ref(ctx, sexp_global(ctx, SEXP_G_ERR_HANDLER));
+    sexp_context_last_fp(ctx) = fp;
+    if (! sexp_procedurep(tmp1)) {
+#if SEXP_USE_GREEN_THREADS
+      sexp_context_errorp(ctx) = 1;
+#endif
+      goto end_loop;
+    }
+    stack[top] = SEXP_ONE;
+    stack[top+1] = sexp_make_fixnum(ip-sexp_bytecode_data(bc));
+    stack[top+2] = self;
+    stack[top+3] = sexp_make_fixnum(fp);
+    top += 4;
+    self = tmp1;
+    bc = sexp_procedure_code(self);
+    ip = sexp_bytecode_data(bc);
+    cp = sexp_procedure_vars(self);
+    fp = top-4;
+    break;
+  case SEXP_OP_RESUMECC:
+    sexp_context_top(ctx) = top;
+    tmp1 = stack[fp-1];
+    tmp2 = sexp_restore_stack(ctx, sexp_vector_ref(cp, 0));
+    if (sexp_exceptionp(tmp2)) {_ARG1 = tmp2; goto call_error_handler;}
+    top = sexp_context_top(ctx);
+    fp = sexp_unbox_fixnum(_ARG1);
+    self = _ARG2;
+    bc = sexp_procedure_code(self);
+    cp = sexp_procedure_vars(self);
+    ip = sexp_bytecode_data(bc) + sexp_unbox_fixnum(_ARG3);
+    i = sexp_unbox_fixnum(_ARG4);
+    top -= 4;
+    _ARG1 = tmp1;
+    break;
+  case SEXP_OP_CALLCC:
+    stack[top] = SEXP_ONE;
+    stack[top+1] = sexp_make_fixnum(ip-sexp_bytecode_data(bc));
+    stack[top+2] = self;
+    stack[top+3] = sexp_make_fixnum(fp);
+    tmp1 = _ARG1;
+    i = 1;
+    sexp_context_top(ctx) = top;
+    tmp2 = sexp_make_vector(ctx, SEXP_ONE, SEXP_UNDEF);
+    sexp_vector_set(tmp2, SEXP_ZERO, sexp_save_stack(ctx, stack, top+4));
+    _ARG1 = sexp_make_procedure(ctx,
+                                SEXP_ZERO,
+                                SEXP_ONE,
+                                sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE),
+                                tmp2);
+    top++;
+    ip -= sizeof(sexp);
+    goto make_call;
+  case SEXP_OP_APPLY1:
+    tmp1 = _ARG1;
+    tmp2 = _ARG2;
+  apply1:
+    i = sexp_unbox_fixnum(sexp_length(ctx, tmp2)); /* number of params */
+    sexp_ensure_stack(i + 64 + (sexp_procedurep(tmp1) ? sexp_bytecode_max_depth(sexp_procedure_code(tmp1)) : 0));
+    k = sexp_unbox_fixnum(stack[fp+3]);            /* previous fp */
+    j = sexp_unbox_fixnum(stack[fp]);              /* previous num params */
+    self = stack[fp+2];
+    bc = sexp_procedure_code(self);
+    cp = sexp_procedure_vars(self);
+    ip = (sexp_bytecode_data(bc)+sexp_unbox_fixnum(stack[fp+1])) - sizeof(sexp);
+    for (top=fp-j+i-1; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--)
+      stack[top] = sexp_car(tmp2);
+    top = fp+i-j+1;
+    fp = k;
+    goto make_call;
+  case SEXP_OP_TAIL_CALL:
+    _ALIGN_IP();
+    i = sexp_unbox_fixnum(_WORD0);             /* number of params */
+    tmp1 = _ARG1;                              /* procedure to call */
+    /* save frame info */
+    tmp2 = stack[fp+3];                        /* previous fp */
+    j = sexp_unbox_fixnum(stack[fp]);          /* previous num params */
+    self = stack[fp+2];
+    bc = sexp_procedure_code(self);
+    cp = sexp_procedure_vars(self);
+    ip = (sexp_bytecode_data(bc)+sexp_unbox_fixnum(stack[fp+1])) - sizeof(sexp);
+    /* copy new args into place */
+    for (k=0; k<i; k++)
+      stack[fp-j+k] = stack[top-1-i+k];
+    top = fp+i-j+1;
+    fp = sexp_unbox_fixnum(tmp2);
+    goto make_call;
+  case SEXP_OP_CALL:
+    _ALIGN_IP();
+    i = sexp_unbox_fixnum(_WORD0);
+    tmp1 = _ARG1;
+  make_call:
+    sexp_context_top(ctx) = top;
+    if (sexp_opcodep(tmp1)) {
+      /* compile non-inlined opcode applications on the fly */
+      tmp1 = make_opcode_procedure(ctx, tmp1, i);
+      if (sexp_exceptionp(tmp1)) {
+        _ARG1 = tmp1;
+        goto call_error_handler;
+      }
+    }
+    if (! sexp_procedurep(tmp1))
+      sexp_raise("non procedure application", sexp_list1(ctx, tmp1));
+    j = i - sexp_procedure_num_args(tmp1);
+    if (j < 0)
+      sexp_raise("not enough args",
+                 sexp_list2(ctx, tmp1, sexp_make_fixnum(i)));
+    /* ensure there's sufficient stack space before pushing args */
+    sexp_ensure_stack(sexp_bytecode_max_depth(sexp_procedure_code(tmp1))+64);
+    if (j > 0) {
+      if (sexp_procedure_variadic_p(tmp1)) {
+        if (!sexp_procedure_unused_rest_p(tmp1)) {
+          stack[top-i-1] = sexp_cons(ctx, stack[top-i-1], SEXP_NULL);
+          for (k=top-i; k<top-(i-j)-1; k++)
+            stack[top-i-1] = sexp_cons(ctx, stack[k], stack[top-i-1]);
+          for ( ; k<top; k++)
+            stack[k-j+1] = stack[k];
+          top -= (j-1);
+          i -= (j-1);
+        }
+      } else {
+        sexp_raise("too many args", sexp_list2(ctx, tmp1, sexp_make_fixnum(i)));
+      }
+    } else if (sexp_procedure_variadic_p(tmp1) &&
+               !sexp_procedure_unused_rest_p(tmp1)) {
+      /* shift stack, set extra arg to null */
+      for (k=top; k>=top-i; k--)
+        stack[k] = stack[k-1];
+      stack[top-i-1] = SEXP_NULL;
+      top++;
+      i++;
+    }
+    _ARG1 = sexp_make_fixnum(i);
+    stack[top] = sexp_make_fixnum(ip+sizeof(sexp)-sexp_bytecode_data(bc));
+    stack[top+1] = self;
+    stack[top+2] = sexp_make_fixnum(fp);
+    top += 3;
+    self = tmp1;
+    bc = sexp_procedure_code(self);
+    ip = sexp_bytecode_data(bc);
+    cp = sexp_procedure_vars(self);
+    fp = top-4;
+    break;
+  case SEXP_OP_FCALL0:
+    _ALIGN_IP();
+    sexp_context_top(ctx) = top;
+    sexp_context_last_fp(ctx) = fp;
+    tmp1 = ((sexp_proc1)sexp_opcode_func(_WORD0))(ctx, _WORD0, 0);
+    sexp_fcall_return(tmp1, -1)
+    break;
+  case SEXP_OP_FCALL1:
+    _ALIGN_IP();
+    sexp_context_top(ctx) = top;
+    sexp_context_last_fp(ctx) = fp;
+    tmp1 = ((sexp_proc2)sexp_opcode_func(_WORD0))(ctx, _WORD0, 1, _ARG1);
+    sexp_fcall_return(tmp1, 0)
+    break;
+  case SEXP_OP_FCALL2:
+    _ALIGN_IP();
+    sexp_context_top(ctx) = top;
+    sexp_context_last_fp(ctx) = fp;
+    tmp1 = ((sexp_proc3)sexp_opcode_func(_WORD0))(ctx, _WORD0, 2, _ARG1, _ARG2);
+    sexp_fcall_return(tmp1, 1)
+    break;
+  case SEXP_OP_FCALL3:
+    _ALIGN_IP();
+    sexp_context_top(ctx) = top;
+    sexp_context_last_fp(ctx) = fp;
+    tmp1 = ((sexp_proc4)sexp_opcode_func(_WORD0))(ctx, _WORD0, 3, _ARG1, _ARG2, _ARG3);
+    sexp_fcall_return(tmp1, 2)
+    break;
+  case SEXP_OP_FCALL4:
+    _ALIGN_IP();
+    sexp_context_top(ctx) = top;
+    sexp_context_last_fp(ctx) = fp;
+    tmp1 = ((sexp_proc5)sexp_opcode_func(_WORD0))(ctx, _WORD0, 4, _ARG1, _ARG2, _ARG3, _ARG4);
+    sexp_fcall_return(tmp1, 3)
+    break;
+#if SEXP_USE_EXTENDED_FCALL
+  case SEXP_OP_FCALLN:
+    _ALIGN_IP();
+    sexp_context_top(ctx) = top;
+    sexp_context_last_fp(ctx) = fp;
+    i = sexp_opcode_num_args(_WORD0);
+    tmp1 = sexp_fcall(ctx, self, i, _WORD0);
+    sexp_fcall_return(tmp1, i-1)
+    break;
+#endif
+  case SEXP_OP_JUMP_UNLESS:
+    _ALIGN_IP();
+    if (stack[--top] == SEXP_FALSE)
+      ip += _SWORD0;
+    else
+      ip += sizeof(sexp_sint_t);
+    break;
+  case SEXP_OP_JUMP:
+    _ALIGN_IP();
+    ip += _SWORD0;
+    break;
+  case SEXP_OP_PUSH:
+    _ALIGN_IP();
+    _PUSH(_WORD0);
+    ip += sizeof(sexp);
+    break;
+#if SEXP_USE_RESERVE_OPCODE
+  case SEXP_OP_RESERVE:
+    _ALIGN_IP();
+    for (i=_SWORD0; i > 0; i--)
+      stack[top++] = SEXP_VOID;
+    ip += sizeof(sexp);
+    break;
+#endif
+  case SEXP_OP_DROP:
+    top--;
+    break;
+  case SEXP_OP_GLOBAL_REF:
+    _ALIGN_IP();
+    if (sexp_cdr(_WORD0) == SEXP_UNDEF)
+      sexp_raise("undefined variable", sexp_list1(ctx, sexp_car(_WORD0)));
+    /* ... FALLTHROUGH ... */
+  case SEXP_OP_GLOBAL_KNOWN_REF:
+    _ALIGN_IP();
+    _PUSH(sexp_cdr(_WORD0));
+    ip += sizeof(sexp);
+    break;
+#if SEXP_USE_GREEN_THREADS
+  case SEXP_OP_PARAMETER_REF:
+    _ALIGN_IP();
+    sexp_context_top(ctx) = top;
+    tmp2 = _WORD0;
+    ip += sizeof(sexp);
+    for (tmp1=sexp_context_params(ctx); sexp_pairp(tmp1); tmp1=sexp_cdr(tmp1))
+      if (sexp_caar(tmp1) == tmp2) {
+        _PUSH(sexp_car(tmp1));
+        goto loop;
+      }
+    _PUSH(sexp_opcode_data(tmp2));
+    break;
+#endif
+  case SEXP_OP_STACK_REF:
+    _ALIGN_IP();
+    stack[top] = stack[top - _SWORD0];
+    ip += sizeof(sexp);
+    top++;
+    break;
+  case SEXP_OP_LOCAL_REF:
+    _ALIGN_IP();
+    stack[top] = stack[fp - 1 - _SWORD0];
+    ip += sizeof(sexp);
+    top++;
+    break;
+  case SEXP_OP_LOCAL_SET:
+    _ALIGN_IP();
+    stack[fp - 1 - _SWORD0] = _POP();
+    ip += sizeof(sexp);
+    break;
+  case SEXP_OP_CLOSURE_REF:
+    _ALIGN_IP();
+    _PUSH(sexp_vector_ref(cp, sexp_make_fixnum(_SWORD0)));
+    ip += sizeof(sexp);
+    break;
+  case SEXP_OP_CLOSURE_VARS:
+    _ARG1 = sexp_procedure_vars(_ARG1);
+    break;
+  case SEXP_OP_VECTOR_REF:
+    if (! sexp_vectorp(_ARG1))
+      sexp_raise("vector-ref: not a vector", sexp_list1(ctx, _ARG1));
+    else if (! sexp_fixnump(_ARG2))
+      sexp_raise("vector-ref: not an integer", sexp_list1(ctx, _ARG2));
+    i = sexp_unbox_fixnum(_ARG2);
+    if ((i < 0) || (i >= sexp_vector_length(_ARG1)))
+      sexp_raise("vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
+    _ARG2 = sexp_vector_ref(_ARG1, _ARG2);
+    top--;
+    break;
+  case SEXP_OP_VECTOR_SET:
+    if (! sexp_vectorp(_ARG1))
+      sexp_raise("vector-set!: not a vector", sexp_list1(ctx, _ARG1));
+    else if (sexp_immutablep(_ARG1))
+      sexp_raise("vector-set!: immutable vector", sexp_list1(ctx, _ARG1));
+    else if (! sexp_fixnump(_ARG2))
+      sexp_raise("vector-set!: not an integer", sexp_list1(ctx, _ARG2));
+    i = sexp_unbox_fixnum(_ARG2);
+    if ((i < 0) || (i >= sexp_vector_length(_ARG1)))
+      sexp_raise("vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
+    sexp_vector_set(_ARG1, _ARG2, _ARG3);
+    top-=3;
+    break;
+  case SEXP_OP_VECTOR_LENGTH:
+    if (! sexp_vectorp(_ARG1))
+      sexp_raise("vector-length: not a vector", sexp_list1(ctx, _ARG1));
+    _ARG1 = sexp_make_fixnum(sexp_vector_length(_ARG1));
+    break;
+  case SEXP_OP_BYTES_REF:
+    if (! sexp_bytesp(_ARG1))
+      sexp_raise("byte-vector-ref: not a byte-vector", sexp_list1(ctx, _ARG1));
+    if (! sexp_fixnump(_ARG2))
+      sexp_raise("byte-vector-ref: not an integer", sexp_list1(ctx, _ARG2));
+    i = sexp_unbox_fixnum(_ARG2);
+    if ((i < 0) || (i >= sexp_bytes_length(_ARG1)))
+      sexp_raise("byte-vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
+    _ARG2 = sexp_bytes_ref(_ARG1, _ARG2);
+    top--;
+    break;
+  case SEXP_OP_STRING_REF:
+    if (! sexp_stringp(_ARG1))
+      sexp_raise("string-ref: not a string", sexp_list1(ctx, _ARG1));
+    else if (! sexp_fixnump(_ARG2))
+      sexp_raise("string-ref: not an integer", sexp_list1(ctx, _ARG2));
+    i = sexp_unbox_fixnum(_ARG2);
+    if ((i < 0) || (i >= sexp_string_size(_ARG1)))
+      sexp_raise("string-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
+    _ARG2 = sexp_string_cursor_ref(ctx, _ARG1, _ARG2);
+    top--;
+    sexp_check_exception();
+    break;
+  case SEXP_OP_BYTES_SET:
+    if (! sexp_bytesp(_ARG1))
+      sexp_raise("byte-vector-set!: not a byte-vector", sexp_list1(ctx, _ARG1));
+    else if (sexp_immutablep(_ARG1))
+      sexp_raise("byte-vector-set!: immutable byte-vector", sexp_list1(ctx, _ARG1));
+    else if (! sexp_fixnump(_ARG2))
+      sexp_raise("byte-vector-set!: not an integer", sexp_list1(ctx, _ARG2));
+    else if (!(sexp_fixnump(_ARG3) && sexp_unbox_fixnum(_ARG3)>=0
+               && sexp_unbox_fixnum(_ARG3)<0x100))
+      sexp_raise("byte-vector-set!: not an octet", sexp_list1(ctx, _ARG3));
+    i = sexp_unbox_fixnum(_ARG2);
+    if ((i < 0) || (i >= sexp_bytes_length(_ARG1)))
+      sexp_raise("byte-vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
+    sexp_bytes_set(_ARG1, _ARG2, _ARG3);
+    top-=3;
+    break;
+#if SEXP_USE_MUTABLE_STRINGS
+  case SEXP_OP_STRING_SET:
+    if (! sexp_stringp(_ARG1))
+      sexp_raise("string-set!: not a string", sexp_list1(ctx, _ARG1));
+    else if (sexp_immutablep(_ARG1))
+      sexp_raise("string-set!: immutable string", sexp_list1(ctx, _ARG1));
+    else if (! sexp_fixnump(_ARG2))
+      sexp_raise("string-set!: not an integer", sexp_list1(ctx, _ARG2));
+    else if (! sexp_charp(_ARG3))
+      sexp_raise("string-set!: not a char", sexp_list1(ctx, _ARG3));
+    i = sexp_unbox_fixnum(_ARG2);
+    if ((i < 0) || (i >= sexp_string_size(_ARG1)))
+      sexp_raise("string-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
+    sexp_context_top(ctx) = top;
+    sexp_string_set(ctx, _ARG1, _ARG2, _ARG3);
+    top-=3;
+    break;
+#endif
+#if SEXP_USE_UTF8_STRINGS
+  case SEXP_OP_STRING_CURSOR_NEXT:
+    if (! sexp_stringp(_ARG1))
+      sexp_raise("string-cursor-next: not a string", sexp_list1(ctx, _ARG1));
+    else if (! sexp_fixnump(_ARG2))
+      sexp_raise("string-cursor-next: not an integer", sexp_list1(ctx, _ARG2));
+    _ARG2 = sexp_string_cursor_next(_ARG1, _ARG2);
+    top--;
+    sexp_check_exception();
+    break;
+  case SEXP_OP_STRING_CURSOR_PREV:
+    if (! sexp_stringp(_ARG1))
+      sexp_raise("string-cursor-prev: not a string", sexp_list1(ctx, _ARG1));
+    else if (! sexp_fixnump(_ARG2))
+      sexp_raise("string-cursor-prev: not an integer", sexp_list1(ctx, _ARG2));
+    _ARG2 = sexp_string_cursor_prev(_ARG1, _ARG2);
+    top--;
+    sexp_check_exception();
+    break;
+  case SEXP_OP_STRING_SIZE:
+    if (! sexp_stringp(_ARG1))
+      sexp_raise("string-size: not a string", sexp_list1(ctx, _ARG1));
+    _ARG1 = sexp_make_fixnum(sexp_string_size(_ARG1));
+    break;
+#endif
+  case SEXP_OP_BYTES_LENGTH:
+    if (! sexp_bytesp(_ARG1))
+      sexp_raise("bytes-length: not a byte-vector", sexp_list1(ctx, _ARG1));
+    _ARG1 = sexp_make_fixnum(sexp_bytes_length(_ARG1));
+    break;
+  case SEXP_OP_STRING_LENGTH:
+    if (! sexp_stringp(_ARG1))
+      sexp_raise("string-length: not a string", sexp_list1(ctx, _ARG1));
+    _ARG1 = sexp_make_fixnum(sexp_string_length(_ARG1));
+    break;
+  case SEXP_OP_MAKE_PROCEDURE:
+    sexp_context_top(ctx) = top;
+    _ALIGN_IP();
+    _ARG1 = sexp_make_procedure(ctx, _WORD0, _WORD1, _WORD2, _ARG1);
+    ip += (3 * sizeof(sexp));
+    break;
+  case SEXP_OP_MAKE_VECTOR:
+    sexp_context_top(ctx) = top;
+    if (! sexp_fixnump(_ARG1))
+      sexp_raise("make-vector: not an integer", sexp_list1(ctx, _ARG1));
+    if (sexp_unbox_fixnum(_ARG1) < 0)
+      sexp_raise("make-vector: length must be non-negative", sexp_list1(ctx, _ARG1));
+    _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2);
+    top--;
+    break;
+  case SEXP_OP_MAKE_EXCEPTION:
+    sexp_context_top(ctx) = top;
+    _ARG5 = sexp_make_exception(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5);
+    top -= 4;
+    break;
+  case SEXP_OP_AND:
+    _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE));
+    top--;
+    break;
+  case SEXP_OP_EOFP:
+    _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break;
+  case SEXP_OP_NULLP:
+    _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break;
+  case SEXP_OP_FIXNUMP:
+    _ARG1 = sexp_make_boolean(sexp_fixnump(_ARG1)); break;
+  case SEXP_OP_SYMBOLP:
+    _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break;
+  case SEXP_OP_CHARP:
+    _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break;
+  case SEXP_OP_ISA:
+    tmp1 = _ARG1, tmp2 = _ARG2;
+    if (! sexp_typep(tmp2)) sexp_raise("is-a?: not a type", tmp2);
+    top--;
+    goto do_check_type;
+  case SEXP_OP_TYPEP:
+    _ALIGN_IP();
+    tmp1 = _ARG1, tmp2 = sexp_type_by_index(ctx, _UWORD0);
+    ip += sizeof(sexp);
+  do_check_type:
+    _ARG1 = sexp_make_boolean(sexp_check_type(ctx, tmp1, tmp2));
+    break;
+  case SEXP_OP_MAKE:
+    _ALIGN_IP();
+    sexp_context_top(ctx) = top;
+    _PUSH(sexp_alloc_tagged(ctx, _UWORD1, _UWORD0));
+    /* initialize fields to void */
+    for (i=(_UWORD1-sexp_sizeof_header)/sizeof(sexp_uint_t) - 1; i>=0; i--)
+      sexp_slot_set(_ARG1, i, SEXP_VOID);
+    ip += sizeof(sexp)*2;
+    break;
+  case SEXP_OP_SLOT_REF:
+    _ALIGN_IP();
+    if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0)))
+      sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_type_name_by_index(ctx, _UWORD0), _ARG1));
+    _ARG1 = sexp_slot_ref(_ARG1, _UWORD1);
+    ip += sizeof(sexp)*2;
+    break;
+  case SEXP_OP_SLOT_SET:
+    _ALIGN_IP();
+    if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0)))
+      sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_type_name_by_index(ctx, _UWORD0), _ARG1));
+    else if (sexp_immutablep(_ARG1))
+      sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1));
+    sexp_slot_set(_ARG1, _UWORD1, _ARG2);
+    ip += sizeof(sexp)*2;
+    top-=2;
+    break;
+  case SEXP_OP_SLOTN_REF:
+    if (! sexp_typep(_ARG1))
+      sexp_raise("slotn-ref: not a record type", sexp_list1(ctx, _ARG1));
+    else if (! sexp_check_type(ctx, _ARG2, _ARG1))
+      sexp_raise("slotn-ref: bad type", sexp_list1(ctx, _ARG2));
+    if (! sexp_fixnump(_ARG3))
+      for (i = 0, tmp1 = sexp_type_slots(_ARG1); sexp_pairp(tmp1); tmp1 = sexp_cdr(tmp1), ++i)
+        if (sexp_car(tmp1) == _ARG3) { _ARG3 = sexp_make_fixnum(i); break; }
+    if (! sexp_fixnump(_ARG3))
+      sexp_raise("slotn-ref: not an integer", sexp_list1(ctx, _ARG3));
+    if (sexp_vectorp(sexp_type_getters(_ARG1))) {
+      if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= sexp_vector_length(sexp_type_getters(_ARG1)))
+        sexp_raise("slotn-ref: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
+      tmp1 = sexp_vector_ref(sexp_type_getters(_ARG1), _ARG3);
+      if (sexp_opcodep(tmp1))
+        _ARG3 = ((sexp_proc2)sexp_opcode_func(tmp1))(ctx, tmp1, 1, _ARG2);
+      else
+        sexp_raise("slotn-ref: no getter defined", sexp_list1(ctx, _ARG3));
+    } else {
+      if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= sexp_type_field_len_base(_ARG1))
+        sexp_raise("slotn-ref: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
+      _ARG3 = sexp_slot_ref(_ARG2, sexp_unbox_fixnum(_ARG3));
+    }
+    top-=2;
+    if (!_ARG1) _ARG1 = SEXP_VOID;
+    else sexp_check_exception();
+    break;
+  case SEXP_OP_SLOTN_SET:
+    if (! sexp_typep(_ARG1))
+      sexp_raise("slotn-set!: not a record type", sexp_list1(ctx, _ARG1));
+    else if (! sexp_check_type(ctx, _ARG2, _ARG1))
+      sexp_raise("slotn-set!: bad type", sexp_list1(ctx, _ARG2));
+    else if (sexp_immutablep(_ARG2))
+      sexp_raise("slotn-set!: immutable object", sexp_list1(ctx, _ARG2));
+    if (! sexp_fixnump(_ARG3))
+      for (i = 0, tmp1 = sexp_type_slots(_ARG1); sexp_pairp(tmp1); tmp1 = sexp_cdr(tmp1), ++i)
+        if (sexp_car(tmp1) == _ARG3) { _ARG3 = sexp_make_fixnum(i); break; }
+    if (! sexp_fixnump(_ARG3))
+      sexp_raise("slotn-set!: not an integer", sexp_list1(ctx, _ARG3));
+    if (sexp_vectorp(sexp_type_setters(_ARG1))) {
+      if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= sexp_vector_length(sexp_type_setters(_ARG1)))
+        sexp_raise("slotn-set!: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
+      tmp1 = sexp_vector_ref(sexp_type_setters(_ARG1), _ARG3);
+      if (sexp_opcodep(tmp1))
+        _ARG4 = ((sexp_proc3)sexp_opcode_func(tmp1))(ctx, tmp1, 2, _ARG2, _ARG4);
+      else
+        sexp_raise("slotn-set!: no setter defined", sexp_list1(ctx, _ARG3));
+    } else {
+      if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= sexp_type_field_len_base(_ARG1))
+        sexp_raise("slotn-set!: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
+      sexp_slot_set(_ARG2, sexp_unbox_fixnum(_ARG3), _ARG4);
+    }
+    top-=4;
+    sexp_check_exception();
+    break;
+  case SEXP_OP_CAR:
+    if (! sexp_pairp(_ARG1))
+      sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1));
+    _ARG1 = sexp_car(_ARG1); break;
+  case SEXP_OP_CDR:
+    if (! sexp_pairp(_ARG1))
+      sexp_raise("cdr: not a pair", sexp_list1(ctx, _ARG1));
+    _ARG1 = sexp_cdr(_ARG1); break;
+  case SEXP_OP_SET_CAR:
+    if (! sexp_pairp(_ARG1))
+      sexp_raise("set-car!: not a pair", sexp_list1(ctx, _ARG1));
+    else if (sexp_immutablep(_ARG1))
+      sexp_raise("set-car!: immutable pair", sexp_list1(ctx, _ARG1));
+    sexp_car(_ARG1) = _ARG2;
+    top-=2;
+    break;
+  case SEXP_OP_SET_CDR:
+    if (! sexp_pairp(_ARG1))
+      sexp_raise("set-cdr!: not a pair", sexp_list1(ctx, _ARG1));
+    else if (sexp_immutablep(_ARG1))
+      sexp_raise("set-cdr!: immutable pair", sexp_list1(ctx, _ARG1));
+    sexp_cdr(_ARG1) = _ARG2;
+    top-=2;
+    break;
+  case SEXP_OP_CONS:
+    sexp_context_top(ctx) = top;
+    _ARG2 = sexp_cons(ctx, _ARG1, _ARG2);
+    top--;
+    break;
+  case SEXP_OP_ADD:
+    tmp1 = _ARG1, tmp2 = _ARG2;
+    sexp_context_top(ctx) = --top;
+#if SEXP_USE_BIGNUMS
+    if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
+      j = sexp_unbox_fixnum(tmp1) + sexp_unbox_fixnum(tmp2);
+      if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM))
+        _ARG1 = sexp_add(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2);
+      else
+        _ARG1 = sexp_make_fixnum(j);
+    }
+    else {
+      _ARG1 = sexp_add(ctx, tmp1, tmp2);
+      sexp_check_exception();
+    }
+#else
+    if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2))
+      _ARG1 = sexp_fx_add(tmp1, tmp2);
+#if SEXP_USE_FLONUMS
+    else if (sexp_flonump(tmp1) && sexp_flonump(tmp2))
+      _ARG1 = sexp_fp_add(ctx, tmp1, tmp2);
+    else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2))
+      _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) + (double)sexp_unbox_fixnum(tmp2));
+    else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2))
+      _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) + sexp_flonum_value(tmp2));
+#endif
+    else sexp_raise("+: not a number", sexp_list2(ctx, tmp1, tmp2));
+#endif
+    break;
+  case SEXP_OP_SUB:
+    tmp1 = _ARG1, tmp2 = _ARG2;
+    sexp_context_top(ctx) = --top;
+#if SEXP_USE_BIGNUMS
+    if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
+      j = sexp_unbox_fixnum(tmp1) - sexp_unbox_fixnum(tmp2);
+      if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM))
+        _ARG1 = sexp_sub(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2);
+      else
+        _ARG1 = sexp_make_fixnum(j);
+    }
+    else {
+      _ARG1 = sexp_sub(ctx, tmp1, tmp2);
+      sexp_check_exception();
+    }
+#else
+    if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2))
+      _ARG1 = sexp_fx_sub(tmp1, tmp2);
+#if SEXP_USE_FLONUMS
+    else if (sexp_flonump(tmp1) && sexp_flonump(tmp2))
+      _ARG1 = sexp_fp_sub(ctx, tmp1, tmp2);
+    else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2))
+      _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) - (double)sexp_unbox_fixnum(tmp2));
+    else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2))
+      _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) - sexp_flonum_value(tmp2));
+#endif
+    else sexp_raise("-: not a number", sexp_list2(ctx, tmp1, tmp2));
+#endif
+    break;
+  case SEXP_OP_MUL:
+    tmp1 = _ARG1, tmp2 = _ARG2;
+    sexp_context_top(ctx) = --top;
+#if SEXP_USE_BIGNUMS
+    if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
+      prod = (sexp_lsint_t)sexp_unbox_fixnum(tmp1) * sexp_unbox_fixnum(tmp2);
+      if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM))
+        _ARG1 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2);
+      else
+        _ARG1 = sexp_make_fixnum(prod);
+    }
+    else {
+      _ARG1 = sexp_mul(ctx, tmp1, tmp2);
+      sexp_check_exception();
+    }
+#else
+    if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2))
+      _ARG1 = sexp_fx_mul(tmp1, tmp2);
+#if SEXP_USE_FLONUMS
+    else if (sexp_flonump(tmp1) && sexp_flonump(tmp2))
+      _ARG1 = sexp_fp_mul(ctx, tmp1, tmp2);
+    else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2))
+      _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) * (double)sexp_unbox_fixnum(tmp2));
+    else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2))
+      _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) * sexp_flonum_value(tmp2));
+#endif
+    else sexp_raise("*: not a number", sexp_list2(ctx, tmp1, tmp2));
+#endif
+    break;
+  case SEXP_OP_DIV:
+    tmp1 = _ARG1, tmp2 = _ARG2;
+    sexp_context_top(ctx) = --top;
+    if (tmp2 == SEXP_ZERO) {
+#if SEXP_USE_FLONUMS
+      if (sexp_flonump(tmp1) && sexp_flonum_value(tmp1) == 0.0)
+        _ARG1 = sexp_make_flonum(ctx, 0.0);
+      else
+#endif
+        sexp_raise("divide by zero", SEXP_NULL);
+    } else if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
+#if SEXP_USE_RATIOS
+      _ARG1 = sexp_make_ratio(ctx, tmp1, tmp2);
+      _ARG1 = sexp_ratio_normalize(ctx, _ARG1, SEXP_FALSE);
+#else
+#if SEXP_USE_FLONUMS
+      tmp1 = sexp_fixnum_to_flonum(ctx, tmp1);
+      tmp2 = sexp_fixnum_to_flonum(ctx, tmp2);
+      _ARG1 = sexp_fp_div(ctx, tmp1, tmp2);
+      if (sexp_flonum_value(_ARG1) == trunc(sexp_flonum_value(_ARG1)))
+        _ARG1 = sexp_make_fixnum(sexp_flonum_value(_ARG1));
+#else
+      _ARG1 = sexp_fx_div(tmp1, tmp2);
+#endif
+#endif
+    }
+#if SEXP_USE_BIGNUMS
+    else {
+      _ARG1 = sexp_div(ctx, tmp1, tmp2);
+      sexp_check_exception();
+    }
+#else
+#if SEXP_USE_FLONUMS
+    else if (sexp_flonump(tmp1) && sexp_flonump(tmp2))
+      _ARG1 = sexp_fp_div(ctx, tmp1, tmp2);
+    else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2))
+      _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) / (double)sexp_unbox_fixnum(tmp2));
+    else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2))
+      _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) / sexp_flonum_value(tmp2));
+#endif
+    else sexp_raise("/: not a number", sexp_list2(ctx, tmp1, tmp2));
+#endif
+    break;
+  case SEXP_OP_QUOTIENT:
+    tmp1 = _ARG1, tmp2 = _ARG2;
+    sexp_context_top(ctx) = --top;
+    if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
+      if (tmp2 == SEXP_ZERO)
+        sexp_raise("divide by zero", SEXP_NULL);
+      _ARG1 = sexp_fx_div(tmp1, tmp2);
+    }
+#if SEXP_USE_BIGNUMS
+    else {
+      _ARG1 = sexp_quotient(ctx, tmp1, tmp2);
+      sexp_check_exception();
+    }
+#else
+    else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, tmp2));
+#endif
+    break;
+  case SEXP_OP_REMAINDER:
+    tmp1 = _ARG1, tmp2 = _ARG2;
+    sexp_context_top(ctx) = --top;
+    if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
+      if (tmp2 == SEXP_ZERO)
+        sexp_raise("divide by zero", SEXP_NULL);
+      _ARG1 = sexp_fx_rem(tmp1, tmp2);
+    }
+#if SEXP_USE_BIGNUMS
+    else {
+      _ARG1 = sexp_remainder(ctx, tmp1, tmp2);
+      sexp_check_exception();
+    }
+#else
+    else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, tmp2));
+#endif
+    break;
+  case SEXP_OP_LT:
+    tmp1 = _ARG1, tmp2 = _ARG2;
+    sexp_context_top(ctx) = --top;
+    if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
+      i = (sexp_sint_t)tmp1 < (sexp_sint_t)tmp2;
+#if SEXP_USE_BIGNUMS
+      _ARG1 = sexp_make_boolean(i);
+    } else {
+      _ARG1 = sexp_compare(ctx, tmp1, tmp2);
+      if (sexp_exceptionp(_ARG1)) {
+        if (strcmp("can't compare NaN", sexp_string_data(sexp_exception_message(_ARG1))) == 0)
+          _ARG1 = SEXP_FALSE;
+        else
+          goto call_error_handler;
+      } else {
+        _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) < 0);
+      }
+    }
+#else
+#if SEXP_USE_FLONUMS
+    } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) {
+      i = sexp_flonum_value(tmp1) < sexp_flonum_value(tmp2);
+    } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) {
+      i = sexp_flonum_value(tmp1) < (double)sexp_unbox_fixnum(tmp2); 
+    } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) {
+      i = (double)sexp_unbox_fixnum(tmp1) < sexp_flonum_value(tmp2);
+#endif
+    } else sexp_raise("<: not a number", sexp_list2(ctx, tmp1, tmp2));
+    _ARG1 = sexp_make_boolean(i);
+#endif
+    break;
+  case SEXP_OP_LE:
+    tmp1 = _ARG1, tmp2 = _ARG2;
+    sexp_context_top(ctx) = --top;
+    if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
+      i = (sexp_sint_t)tmp1 <= (sexp_sint_t)tmp2;
+#if SEXP_USE_BIGNUMS
+      _ARG1 = sexp_make_boolean(i);
+    } else {
+      _ARG1 = sexp_compare(ctx, tmp1, tmp2);
+      if (sexp_exceptionp(_ARG1)) {
+        if (strcmp("can't compare NaN", sexp_string_data(sexp_exception_message(_ARG1))) == 0)
+          _ARG1 = SEXP_FALSE;
+        else
+          goto call_error_handler;
+      } else {
+        _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) <= 0);
+      }
+    }
+#else
+#if SEXP_USE_FLONUMS
+    } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) {
+      i = sexp_flonum_value(tmp1) <= sexp_flonum_value(tmp2);
+    } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) {
+      i = sexp_flonum_value(tmp1) <= (double)sexp_unbox_fixnum(tmp2);
+    } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) {
+      i = (double)sexp_unbox_fixnum(tmp1) <= sexp_flonum_value(tmp2);
+#endif
+    } else sexp_raise("<=: not a number", sexp_list2(ctx, tmp1, tmp2));
+    _ARG1 = sexp_make_boolean(i);
+#endif
+    break;
+  case SEXP_OP_EQN:
+    tmp1 = _ARG1, tmp2 = _ARG2;
+    sexp_context_top(ctx) = --top;
+    if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
+      i = tmp1 == tmp2;
+#if SEXP_USE_BIGNUMS
+      _ARG1 = sexp_make_boolean(i);
+    } else {
+#if SEXP_USE_COMPLEX
+      if (sexp_complexp(tmp1)) {
+        if (sexp_flonump(sexp_complex_imag(tmp1))
+            && sexp_flonum_value(sexp_complex_imag(tmp1)) == 0.0) {
+          tmp1 = sexp_complex_real(tmp1);
+        } else if (sexp_complexp(tmp2)) { /* both complex */
+          _ARG1 = sexp_make_boolean(
+            (sexp_compare(ctx, sexp_complex_real(tmp1), sexp_complex_real(tmp2))
+             == SEXP_ZERO)
+            && (sexp_compare(ctx, sexp_complex_imag(tmp1), sexp_complex_imag(tmp2))
+                == SEXP_ZERO));
+          break;
+        } else if (sexp_numberp(tmp2)) {
+          _ARG1 = SEXP_FALSE;
+          break;
+        }
+      }
+      if (sexp_complexp(tmp2)) {
+        if (sexp_flonump(sexp_complex_imag(tmp2))
+            && sexp_flonum_value(sexp_complex_imag(tmp2)) == 0.0) {
+          tmp2 = sexp_complex_real(tmp2);
+        } else if (sexp_numberp(tmp1)) {
+          _ARG1 = SEXP_FALSE;
+          break;
+        }
+      }
+#endif
+      /* neither is complex */
+      _ARG1 = sexp_compare(ctx, tmp1, tmp2);
+      if (sexp_exceptionp(_ARG1)) {
+        if (strcmp("can't compare NaN", sexp_string_data(sexp_exception_message(_ARG1))) == 0)
+          _ARG1 = SEXP_FALSE;
+        else
+          goto call_error_handler;
+      } else {
+        _ARG1 = sexp_make_boolean(_ARG1 == SEXP_ZERO);
+      }
+    }
+#else
+#if SEXP_USE_FLONUMS
+    } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) {
+      i = sexp_flonum_value(tmp1) == sexp_flonum_value(tmp2);
+    } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) {
+      i = sexp_flonum_value(tmp1) == (double)sexp_unbox_fixnum(tmp2);
+    } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) {
+      i = (double)sexp_unbox_fixnum(tmp1) == sexp_flonum_value(tmp2);
+#endif
+    } else sexp_raise("=: not a number", sexp_list2(ctx, tmp1, tmp2));
+    _ARG1 = sexp_make_boolean(i);
+#endif
+    break;
+  case SEXP_OP_EQ:
+    _ARG2 = sexp_make_boolean(_ARG1 == _ARG2);
+    top--;
+    break;
+  case SEXP_OP_CHAR2INT:
+    if (! sexp_charp(_ARG1))
+      sexp_raise("char->integer: not a character", sexp_list1(ctx, _ARG1));
+    _ARG1 = sexp_make_fixnum(sexp_unbox_character(_ARG1));
+    break;
+  case SEXP_OP_INT2CHAR:
+    if (! sexp_fixnump(_ARG1))
+      sexp_raise("integer->char: not an integer", sexp_list1(ctx, _ARG1));
+    _ARG1 = sexp_make_character(sexp_unbox_fixnum(_ARG1));
+    break;
+  case SEXP_OP_CHAR_UPCASE:
+    if (! sexp_charp(_ARG1))
+      sexp_raise("char-upcase: not a character", sexp_list1(ctx, _ARG1));
+    _ARG1 = sexp_make_character(sexp_toupper(sexp_unbox_character(_ARG1)));
+    break;
+  case SEXP_OP_CHAR_DOWNCASE:
+    if (! sexp_charp(_ARG1))
+      sexp_raise("char-downcase: not a character", sexp_list1(ctx, _ARG1));
+    _ARG1 = sexp_make_character(sexp_tolower(sexp_unbox_character(_ARG1)));
+    break;
+  case SEXP_OP_WRITE_CHAR:
+    if (! sexp_charp(_ARG1))
+      sexp_raise("write-char: not a character", sexp_list1(ctx, _ARG1));
+    if (! sexp_oportp(_ARG2))
+      sexp_raise("write-char: not an output-port", sexp_list1(ctx, _ARG2));
+    sexp_context_top(ctx) = top;
+#if SEXP_USE_GREEN_THREADS
+    errno = 0;
+#endif
+#if SEXP_USE_UTF8_STRINGS
+    if (sexp_unbox_character(_ARG1) >= 0x80)
+      i = sexp_write_utf8_char(ctx, sexp_unbox_character(_ARG1), _ARG2);
+    else
+#endif
+    i = sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2);
+    if (i == EOF) {
+      if (!sexp_port_openp(_ARG2))
+        sexp_raise("write-char: port is closed", _ARG2);
+      else
+#if SEXP_USE_GREEN_THREADS
+      if ((sexp_port_stream(_ARG2) ? ferror(sexp_port_stream(_ARG2)) : 1)
+          && (errno == EAGAIN)) {
+        if (sexp_port_stream(_ARG2)) clearerr(sexp_port_stream(_ARG2));
+        if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER)))
+          sexp_apply2(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG2, SEXP_FALSE);
+        else               /* no scheduler but output full, wait 5ms */
+          usleep(5*1000);
+        fuel = 0;
+        ip--;      /* try again */
+        goto loop;
+      } else
+#endif
+      sexp_raise("failed to write char to port", _ARG2);
+    }
+    top--;
+    _ARG1 = SEXP_VOID;
+    break;
+  case SEXP_OP_WRITE_STRING:
+    if (sexp_stringp(_ARG1))
+#if SEXP_USE_PACKED_STRINGS
+      tmp1 = _ARG1;
+#else
+      tmp1 = sexp_string_bytes(_ARG1);
+#endif
+    else if (sexp_bytesp(_ARG1))
+      tmp1 = _ARG1;
+    else
+      sexp_raise("write-string: not a string or bytes", sexp_list1(ctx, _ARG1));
+    if (_ARG2 == SEXP_TRUE)
+      _ARG2 = sexp_make_fixnum(sexp_bytes_length(tmp1));
+    else if (! sexp_fixnump(_ARG2))
+      sexp_raise("write-string: not an integer", sexp_list1(ctx, _ARG2));
+    if (sexp_unbox_fixnum(_ARG2) < 0 || sexp_unbox_fixnum(_ARG2) > sexp_bytes_length(tmp1))
+      sexp_raise("write-string: not a valid string count", sexp_list2(ctx, tmp1, _ARG2));
+    if (! sexp_oportp(_ARG3))
+      sexp_raise("write-string: not an output-port", sexp_list1(ctx, _ARG3));
+    if (!sexp_port_openp(_ARG3))
+      sexp_raise("write-string: port is closed", _ARG3);
+    sexp_context_top(ctx) = top;
+#if SEXP_USE_GREEN_THREADS
+    errno = 0;
+#endif
+    i = sexp_write_string_n(ctx, sexp_bytes_data(tmp1), sexp_unbox_fixnum(_ARG2), _ARG3);
+#if SEXP_USE_GREEN_THREADS
+    if (i < sexp_unbox_fixnum(_ARG2) && errno == EAGAIN) {
+      if (sexp_port_stream(_ARG3)) clearerr(sexp_port_stream(_ARG3));
+      /* modify stack in-place so we continue where we left off next time */
+      if (i > 0) {
+        _ARG1 = sexp_subbytes(ctx, tmp1, sexp_make_fixnum(i), SEXP_FALSE);
+        _ARG2 = sexp_make_fixnum(sexp_unbox_fixnum(_ARG2) - i);
+      }
+      /* yield if threads are enabled (otherwise busy loop) */
+      /* TODO: the wait seems necessary on OS X to stop a print loop to ptys */
+      if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER)))
+        sexp_apply2(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG3, SEXP_FALSE);
+      else               /* no scheduler but output full, wait 5ms */
+        usleep(5*1000);
+      fuel = 0;
+      ip--;      /* try again */
+      goto loop;
+    }
+#endif
+    tmp1 = sexp_make_fixnum(i);     /* return the number of bytes written */
+    top-=2;
+    _ARG1 = tmp1;
+    break;
+  case SEXP_OP_READ_CHAR:
+    if (! sexp_iportp(_ARG1))
+      sexp_raise("read-char: not an input-port", sexp_list1(ctx, _ARG1));
+    sexp_context_top(ctx) = top;
+#if SEXP_USE_GREEN_THREADS
+    errno = 0;
+#endif
+    i = sexp_read_char(ctx, _ARG1);
+#if SEXP_USE_UTF8_STRINGS
+    if (i >= 0x80)
+      _ARG1 = sexp_read_utf8_char(ctx, _ARG1, i);
+    else
+#endif
+    if (i == EOF) {
+      if (!sexp_port_openp(_ARG1))
+        sexp_raise("peek-char: port is closed", _ARG1);
+      else
+#if SEXP_USE_GREEN_THREADS
+      if ((sexp_port_stream(_ARG1) ? ferror(sexp_port_stream(_ARG1)) : 1)
+          && (errno == EAGAIN)) {
+        if (sexp_port_stream(_ARG1)) clearerr(sexp_port_stream(_ARG1));
+        /* TODO: block and unblock */
+        if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER)))
+          sexp_apply2(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG1, SEXP_FALSE);
+        fuel = 0;
+        ip--;      /* try again */
+      } else
+#endif
+        _ARG1 = SEXP_EOF;
+    } else {
+      if (i == '\n') sexp_port_line(_ARG1)++;
+      _ARG1 = sexp_make_character(i);
+    }
+    sexp_check_exception();
+    break;
+  case SEXP_OP_PEEK_CHAR:
+    if (! sexp_iportp(_ARG1))
+      sexp_raise("peek-char: not an input-port", sexp_list1(ctx, _ARG1));
+    sexp_context_top(ctx) = top;
+#if SEXP_USE_GREEN_THREADS
+    errno = 0;
+#endif
+    i = sexp_read_char(ctx, _ARG1);
+    if (i == EOF) {
+      if (!sexp_port_openp(_ARG1))
+        sexp_raise("read-char: port is closed", _ARG1);
+      else
+#if SEXP_USE_GREEN_THREADS
+      if ((sexp_port_stream(_ARG1) ? ferror(sexp_port_stream(_ARG1)) : 1)
+          && (errno == EAGAIN)) {
+        if (sexp_port_stream(_ARG1)) clearerr(sexp_port_stream(_ARG1));
+        if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER)))
+          sexp_apply2(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG1, SEXP_FALSE);
+        fuel = 0;
+        ip--;      /* try again */
+      } else
+#endif
+        _ARG1 = SEXP_EOF;
+    } else {
+      sexp_push_char(ctx, i, _ARG1);
+      _ARG1 = sexp_make_character(i);
+    }
+    sexp_check_exception();
+    break;
+  case SEXP_OP_YIELD:
+#if SEXP_USE_GREEN_THREADS
+    fuel = 0;
+#endif
+    break;
+  case SEXP_OP_FORCE:
+#if SEXP_USE_AUTO_FORCE
+    sexp_context_top(ctx) = top;
+    while (sexp_promisep(_ARG1)) {
+      if (sexp_promise_donep(_ARG1)) {
+        _ARG1 = sexp_promise_value(_ARG1);
+      } else {
+        sexp_context_top(ctx) = top;
+        tmp1 = sexp_apply(ctx, sexp_promise_value(_ARG1), SEXP_NULL);
+        if (!sexp_promise_donep(_ARG1)) {
+          sexp_promise_value(_ARG1) = tmp1;
+          sexp_promise_donep(_ARG1) = 1;
+        }
+        _ARG1 = tmp1;
+      }
+    }
+#endif
+    break;
+  case SEXP_OP_RET:
+    i = sexp_unbox_fixnum(stack[fp]);
+    stack[fp-i] = _ARG1;
+    top = fp-i+1;
+    self = stack[fp+2];
+    bc = sexp_procedure_code(self);
+    ip = sexp_bytecode_data(bc) + sexp_unbox_fixnum(stack[fp+1]);
+    cp = sexp_procedure_vars(self);
+    fp = sexp_unbox_fixnum(stack[fp+3]);
+    break;
+  case SEXP_OP_DONE:
+    sexp_context_last_fp(ctx) = fp;
+    goto end_loop;
+  default:
+    sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_fixnum(*(ip-1))));
+  }
+#if SEXP_USE_DEBUG_VM
+  if (sexp_context_tracep(ctx))
+    fprintf(stderr, "****** VM => %p (%d)\n", _ARG1,
+            sexp_pointerp(_ARG1) && sexp_in_heap_p(ctx, _ARG1)
+            ? sexp_pointer_tag(_ARG1) : -1);
+#endif
+  goto loop;
+
+ end_loop:
+#if SEXP_USE_GREEN_THREADS
+  sexp_context_result(ctx) = _ARG1;
+  if (ctx != root_thread) {
+    if (sexp_context_refuel(root_thread) <= 0) {
+      /* the root already terminated */
+      _ARG1 = sexp_context_result(root_thread);
+    } else {
+      /* don't return from child threads */
+      if (sexp_exceptionp(_ARG1)) {
+        tmp1 = sexp_current_error_port(ctx);
+        sexp_write_string(ctx, "ERROR in child thread: ", tmp1);
+        sexp_write(ctx, ctx, tmp1);
+        sexp_newline(ctx, tmp1);
+        sexp_print_exception(ctx, _ARG1, tmp1);
+      }
+#if SEXP_USE_DEBUG_THREADS
+      fprintf(stderr, "****** schedule %p: terminating %p (%s)\n",
+              root_thread, ctx, sexp_thread_debug_name(ctx));
+#endif
+      sexp_context_refuel(ctx) = fuel = 0;
+      goto loop;
+    }
+  }
+#endif
+  sexp_gc_release3(ctx);
+  tmp1 = _ARG1;
+  sexp_context_top(ctx) = --top;
+  return tmp1;
+}
+
+sexp sexp_apply1 (sexp ctx, sexp f, sexp x) {
+  sexp res;
+  sexp_gc_var1(args);
+  if (sexp_opcodep(f) && sexp_opcode_func(f)) {
+    res = ((sexp_proc2)sexp_opcode_func(f))(ctx, f, 1, x);
+  } else {
+    sexp_gc_preserve1(ctx, args);
+    res = sexp_apply(ctx, f, args=sexp_list1(ctx, x));
+    sexp_gc_release1(ctx);
+  }
+  return res;
+}
+
+sexp sexp_apply2 (sexp ctx, sexp f, sexp x, sexp y) {
+  sexp res;
+  sexp_gc_var1(args);
+  if (sexp_opcodep(f) && sexp_opcode_func(f)) {
+    res = ((sexp_proc3)sexp_opcode_func(f))(ctx, f, 2, x, y);
+  } else {
+    sexp_gc_preserve1(ctx, args);
+    res = sexp_apply(ctx, f, args=sexp_list2(ctx, x, y));
+    sexp_gc_release1(ctx);
+  }
+  return res;
+}
+
+sexp sexp_apply_no_err_handler (sexp ctx, sexp proc, sexp args) {
+  sexp res, err_cell;
+  sexp_gc_var2(handler, params);
+  sexp_gc_preserve2(ctx, handler, params);
+#if SEXP_USE_GREEN_THREADS
+  params = sexp_context_params(ctx);
+  sexp_context_params(ctx) = SEXP_NULL;
+  ++sexp_context_refuel(ctx);
+#endif
+  err_cell = sexp_global(ctx, SEXP_G_ERR_HANDLER);
+  err_cell = sexp_opcodep(err_cell) ? sexp_opcode_data(err_cell) : SEXP_FALSE;
+  handler = sexp_pairp(err_cell) ? sexp_cdr(err_cell) : SEXP_FALSE;
+  if (sexp_pairp(err_cell)) sexp_cdr(err_cell) = SEXP_FALSE;
+  res = sexp_apply(ctx, proc, args);
+  if (sexp_pairp(err_cell)) sexp_cdr(err_cell) = handler;
+#if SEXP_USE_GREEN_THREADS
+  sexp_context_params(ctx) = params;
+#endif
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+#endif