File descriptors maintain a reference count of ports open on them

They can be close()d explicitly with close-file-descriptor, and
will close() on gc, but only explicitly closing the last port on
them will close the fileno.  Notably needed for network sockets
where we open separate input and output ports on the same socket.

.hgignore

@@ -0,0 +1,42 @@
+syntax: glob
+*~
+*.i
+*.s
+*.o
+*.so
+*.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

AUTHORS

@@ -0,0 +1,47 @@
+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
+  * Michal Kowalski (sladegen)
+  * Rajesh Krishnan
+  * 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!

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.

Makefile

@@ -0,0 +1,369 @@
+# -*- makefile-gmake -*-
+
+.PHONY: dist mips-dist cleaner test test-all test-dist checkdefs
+.DEFAULT_GOAL := all
+
+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)" 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
+
+HTML_LIBS = $(MODULE_DOCS:%=doc/lib/chibi/%.html)
+
+########################################################################
+
+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
+
+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): $(SEXP_OBJS) $(EVAL_OBJS)
+	$(CC) $(CLIBFLAGS) $(CLINKFLAGS) -o $@ $^ $(XLDFLAGS)
+
+libchibi-scheme.a: $(SEXP_OBJS) $(EVAL_OBJS)
+	$(AR) rcs $@ $^
+
+chibi-scheme$(EXE): main.o libchibi-scheme$(SO)
+	$(CC) $(XCPPFLAGS) $(XCFLAGS) -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) > $@
+
+# 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)
+	-$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< $(GCLDFLAGS) -L. -lchibi-scheme
+
+doc/lib/chibi/%.html: lib/chibi/%.sld $(CHIBI_DOC_DEPENDENCIES)
+	$(CHIBI_DOC) --html chibi.$* > $@
+
+doc: doc/chibi.html doc-libs
+
+%.html: %.scrbl $(CHIBI_DOC_DEPENDENCIES)
+	$(CHIBI_DOC) --html $< > $@
+
+########################################################################
+# 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 include/chibi/install.h \
+	    $(shell $(FIND) lib -name \*.o)
+
+dist-clean: dist-clean-libs cleaner
+
+install: all
+	$(MKDIR) $(DESTDIR)$(BINDIR)
+	$(INSTALL) chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/
+	$(INSTALL) tools/chibi-ffi $(DESTDIR)$(BINDIR)/
+	$(INSTALL) tools/chibi-doc $(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/show $(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) lib/*.scm $(DESTDIR)$(MODDIR)/
+	$(INSTALL) lib/chibi/*.sld lib/chibi/*.scm $(DESTDIR)$(MODDIR)/chibi/
+	$(INSTALL) lib/chibi/char-set/*.sld lib/chibi/char-set/*.scm $(DESTDIR)$(MODDIR)/chibi/char-set/
+	$(INSTALL) lib/chibi/crypto/*.sld lib/chibi/crypto/*.scm $(DESTDIR)$(MODDIR)/chibi/crypto/
+	$(INSTALL) lib/chibi/io/*.scm $(DESTDIR)$(MODDIR)/chibi/io/
+	$(INSTALL) lib/chibi/iset/*.sld lib/chibi/iset/*.scm $(DESTDIR)$(MODDIR)/chibi/iset/
+	$(INSTALL) lib/chibi/loop/*.scm $(DESTDIR)$(MODDIR)/chibi/loop/
+	$(INSTALL) lib/chibi/match/*.scm $(DESTDIR)$(MODDIR)/chibi/match/
+	$(INSTALL) lib/chibi/math/*.sld lib/chibi/math/*.scm $(DESTDIR)$(MODDIR)/chibi/math/
+	$(INSTALL) lib/chibi/monad/*.sld lib/chibi/monad/*.scm $(DESTDIR)$(MODDIR)/chibi/monad/
+	$(INSTALL) lib/chibi/net/*.sld lib/chibi/net/*.scm $(DESTDIR)$(MODDIR)/chibi/net/
+	$(INSTALL) lib/chibi/optimize/*.sld lib/chibi/optimize/*.scm $(DESTDIR)$(MODDIR)/chibi/optimize/
+	$(INSTALL) lib/chibi/parse/*.sld lib/chibi/parse/*.scm $(DESTDIR)$(MODDIR)/chibi/parse/
+	$(INSTALL) lib/chibi/show/*.sld lib/chibi/show/*.scm $(DESTDIR)$(MODDIR)/chibi/show/
+	$(INSTALL) lib/chibi/term/*.sld lib/chibi/term/*.scm $(DESTDIR)$(MODDIR)/chibi/term/
+	$(INSTALL) lib/scheme/*.sld lib/scheme/*.scm $(DESTDIR)$(MODDIR)/scheme/
+	$(INSTALL) lib/scheme/char/*.sld lib/scheme/char/*.scm $(DESTDIR)$(MODDIR)/scheme/char/
+	$(INSTALL) lib/scheme/time/*.sld $(DESTDIR)$(MODDIR)/scheme/time/
+	$(INSTALL) lib/srfi/*.sld lib/srfi/*.scm $(DESTDIR)$(MODDIR)/srfi/
+	$(INSTALL) lib/srfi/1/*.scm $(DESTDIR)$(MODDIR)/srfi/1/
+	$(INSTALL) lib/srfi/18/*.scm $(DESTDIR)$(MODDIR)/srfi/18/
+	$(INSTALL) lib/srfi/27/*.scm $(DESTDIR)$(MODDIR)/srfi/27/
+	$(INSTALL) lib/srfi/33/*.scm $(DESTDIR)$(MODDIR)/srfi/33/
+	$(INSTALL) lib/srfi/39/*.scm $(DESTDIR)$(MODDIR)/srfi/39/
+	$(INSTALL) lib/srfi/69/*.scm $(DESTDIR)$(MODDIR)/srfi/69/
+	$(INSTALL) lib/srfi/95/*.scm $(DESTDIR)$(MODDIR)/srfi/95/
+	$(INSTALL) lib/srfi/99/*.sld $(DESTDIR)$(MODDIR)/srfi/99/
+	$(INSTALL) 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) $(CHIBI_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/
+	$(INSTALL) $(CHIBI_IO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/io/
+	$(INSTALL) $(CHIBI_OPT_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
+	$(INSTALL) lib/scheme/time$(SO) $(DESTDIR)$(BINMODDIR)/scheme/
+	$(INSTALL) lib/srfi/18/threads$(SO) $(DESTDIR)$(BINMODDIR)/srfi/18
+	$(INSTALL) lib/srfi/27/rand$(SO) $(DESTDIR)$(BINMODDIR)/srfi/27
+	$(INSTALL) lib/srfi/33/bit$(SO) $(DESTDIR)$(BINMODDIR)/srfi/33
+	$(INSTALL) lib/srfi/39/param$(SO) $(DESTDIR)$(BINMODDIR)/srfi/39
+	$(INSTALL) lib/srfi/69/hash$(SO) $(DESTDIR)$(BINMODDIR)/srfi/69
+	$(INSTALL) lib/srfi/95/qsort$(SO) $(DESTDIR)$(BINMODDIR)/srfi/95
+	$(INSTALL) lib/srfi/98/env$(SO) $(DESTDIR)$(BINMODDIR)/srfi/98
+	$(MKDIR) $(DESTDIR)$(INCDIR)
+	$(INSTALL) $(INCLUDES) $(DESTDIR)$(INCDIR)/
+	$(MKDIR) $(DESTDIR)$(LIBDIR)
+	$(MKDIR) $(DESTDIR)$(SOLIBDIR)
+	$(INSTALL) libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/
+	-$(INSTALL) libchibi-scheme.a $(DESTDIR)$(SOLIBDIR)/
+	$(MKDIR) $(DESTDIR)$(MANDIR)
+	$(INSTALL) doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/
+	$(INSTALL) doc/chibi-ffi.1 $(DESTDIR)$(MANDIR)/
+	$(INSTALL) 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)$(SOLIBDIR)/libchibi-scheme$(SO)
+	-$(RM) $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a
+	-$(CD) $(DESTDIR)$(INCDIR) && $(RM) $(INCLUDES)
+	-$(RM) $(DESTDIR)$(MODDIR)/srfi/99/records/*.{sld,scm}
+	-$(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/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/show $(DESTDIR)$(BINMODDIR)/chibi/show
+	-$(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 $(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
+
+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'`

Makefile.detect

@@ -0,0 +1,113 @@
+# -*- 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
+
+ifeq ($(PLATFORM),macosx)
+SO  = .dylib
+EXE =
+CLIBFLAGS =
+CLINKFLAGS = -dynamiclib
+STATICFLAGS = -static-libgcc -DSEXP_USE_DL=0
+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
+LDFLAGS += -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
+LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a
+else
+SO  = .so
+EXE =
+CLIBFLAGS = -fPIC
+CLINKFLAGS = -shared
+STATICFLAGS = -static -DSEXP_USE_DL=0
+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

Makefile.libs

@@ -0,0 +1,86 @@
+# -*- 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
+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)
+	$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. $(XLIBS) -lchibi-scheme
+
+doc-libs: $(HTML_LIBS)
+
+doc/lib/%.html: lib/%.sld
+	$(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

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".

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

RELEASE

@@ -0,0 +1 @@
+carbon

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
+

VERSION

@@ -0,0 +1 @@
+0.6.99

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)))))

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))))))
+
+
+

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))

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)))))))
+

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))
+
+

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))
+

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))))))
+

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* '()))))))))

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))

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))
+

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
+                               '())))))))

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))

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))

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))))))

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))))))

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)))))))

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)
+

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))))
+

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)))))))
+
+
+

benchmarks/gabriel/nothing.sch

@@ -0,0 +1 @@
+(time 1)

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)))))))

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)))))))

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)))))))

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))
+
+

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 -

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)

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)
+

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)))))))

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)))

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)))))))

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)))))))

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))))))

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))))

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))

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

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"))

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)))

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))

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>

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
+
+}

data/.hgignore

@@ -0,0 +1,2 @@
+syntax: glob
+*.txt

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/

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/

doc/chibi-scheme.1

@@ -0,0 +1,215 @@
+.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
+]
+[-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.  For example,
+.I chibi-scheme -mchibi.repl -e'(repl)'
+
+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
+
+.SH OPTIONS
+
+Space is optional between options and their arguments.
+Options without arguments may not be chained together.
+
+.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.
+.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.  However, to reduce the need for shell
+escapes, modules are written in a dot notation, so that the module
+.I (foo bar)
+is written as
+.I foo.bar
+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 -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/

doc/lib/chibi/README

@@ -0,0 +1 @@
+Auto-generated module documentation with tools/chibi-doc.

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)

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

gc.c

@@ -0,0 +1,741 @@
+/*  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

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 */
+

include/chibi/eval.h

@@ -0,0 +1,270 @@
+/*  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.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_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 */

include/chibi/features.h

@@ -0,0 +1,825 @@
+/*  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 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
+
+#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 0
+#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
+
+#if 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 (__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)

lib/chibi/accept.c

@@ -0,0 +1,56 @@
+
+/* 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_opcodep(f)) {
+      ((sexp_proc2)sexp_opcode_func(f))(ctx, f, 1, sexp_make_fixnum(sock));
+      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);
+}
+
+/* If we're listening on a socket from Scheme, we most likely want it */
+/* to be non-blocking. */
+
+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[20];
+  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]);
+  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;
+}

lib/chibi/app.scm

@@ -0,0 +1,261 @@
+;; 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 (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) (car args)) (cdr args))))))
+  (define (parse-long-option str args)
+    (let* ((str+val (string-split str #\= 2))
+           (str (car str+val))
+           (args (if (pair? (cdr str+val)) (cons (cadr str+val) args) args)))
+      (or (parse-conf-spec str args)
+          (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))) (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))
+       ((string? (car ls))
+        (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 (if (pair? o) (car o) (command-line))))
+    (cond
+     ((parse-app '() (cdr spec) '() (cdr args) #f #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)))))
+     (else
+      (error "Unknown command: " args)))))

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"))

lib/chibi/ast.c

@@ -0,0 +1,629 @@
+/*  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, 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, char* get, 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_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_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_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, 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", 1, sexp_env_parent_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, "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;
+}

lib/chibi/ast.scm

@@ -0,0 +1,377 @@
+;; 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{(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))))))

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 errno integer->error-string
+   flatten-dot update-free-vars! setenv unsetenv)
+  (import (chibi))
+  (include-shared "ast")
+  (include "ast.scm"))

lib/chibi/base64.scm

@@ -0,0 +1,347 @@
+;; 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-char c)
+  (vector-ref *base64-decode-table* (char->integer c)))
+
+(define *base64-encode-table*
+  (let ((res (make-vector 64)))
+    (let lp ((i 0)) ; map letters
+      (cond
+       ((<= i 25)
+        (vector-set! res i (integer->char (+ i 65)))
+        (vector-set! res (+ i 26) (integer->char (+ i 97)))
+        (lp (+ i 1)))))
+    (let lp ((i 0)) ; map numbers
+      (cond
+       ((<= i 9)
+        (vector-set! res (+ i 52) (integer->char (+ i 48)))
+        (lp (+ i 1)))))
+    (vector-set! res 62 #\+)
+    (vector-set! res 63 #\/)
+    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 src)
+  (let* ((len (string-length src))
+         (dst-len (* 3 (arithmetic-shift (+ 3 len) -2)))
+         (dst (make-string dst-len)))
+    (base64-decode-string!
+     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
+             (substring 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-string! 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-char (string-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
+            (string-set! dst
+                         j
+                         (integer->char
+                          (bitwise-ior (arithmetic-shift b1 2)
+                                       (extract-bit-field 2 4 b2))))
+            (string-set! dst
+                         (+ j 1)
+                         (integer->char
+                          (bitwise-ior
+                           (arithmetic-shift (extract-bit-field 4 0 b2) 4)
+                           (extract-bit-field 4 2 b3))))
+            (string-set! dst
+                         (+ j 2)
+                         (integer->char
+                          (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*)
+    (string-set! dst j (integer->char (arithmetic-shift b1 2)))
+    (+ j 1))
+   (else
+    (string-set! dst
+                 j
+                 (integer->char
+                  (bitwise-ior (arithmetic-shift b1 2)
+                               (extract-bit-field 2 4 b2))))
+    (cond
+     ((eqv? b3 *outside-char*)
+      (+ j 1))
+     (else
+      (string-set! dst
+                   (+ j 1)
+                   (integer->char
+                    (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))))
+    (let ((src (make-string decode-src-length))
+          (dst (make-string decode-dst-length)))
+      (let lp ((offset 0))
+        (let ((src-len (+ offset
+                          (read-string! decode-src-length src in offset))))
+          (cond
+           ((= src-len decode-src-length)
+            ;; read a full chunk: decode, write and loop
+            (base64-decode-string!
+             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-string dst out 0 dst-len)))
+                ((eqv? b1 *outside-char*)
+                 (write-string dst out 0 dst-len)
+                 (lp 0))
+                (else
+                 (write-string dst out 0 dst-len)
+                 ;; one to three chars left in buffer
+                 (string-set! src 0 (enc b1))
+                 (cond
+                  ((eqv? b2 *outside-char*)
+                   (lp 1))
+                  (else
+                   (string-set! src 1 (enc b2))
+                   (cond
+                    ((eqv? b3 *outside-char*)
+                     (lp 2))
+                    (else
+                     (string-set! src 2 (enc b3))
+                     (lp 3))))))))))
+           (else
+            ;; end of source - just decode and write once
+            (base64-decode-string!
+             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)
+  (let* ((len (string-length str))
+         (quot (quotient len 3))
+         (rem (- len (* quot 3)))
+         (res-len (arithmetic-shift (+ quot (if (zero? rem) 0 1)) 2))
+         (res (make-string res-len)))
+    (base64-encode-string! str 0 len res)
+    res))
+
+(define (base64-encode-string! str start end res)
+  (let* ((res-len (string-length res))
+         (limit (- end 2)))
+    (let lp ((i start) (j 0))
+      (if (>= i limit)
+          (case (- end i)
+            ((1)
+             (let ((b1 (char->integer (string-ref str i))))
+               (string-set! res j (enc (arithmetic-shift b1 -2)))
+               (string-set! res
+                            (+ j 1)
+                            (enc (arithmetic-shift (bitwise-and #b11 b1) 4)))
+               (string-set! res (+ j 2) #\=)
+               (string-set! res (+ j 3) #\=)))
+            ((2)
+             (let ((b1 (char->integer (string-ref str i)))
+                   (b2 (char->integer (string-ref str (+ i 1)))))
+               (string-set! res j (enc (arithmetic-shift b1 -2)))
+               (string-set! res
+                            (+ j 1)
+                            (enc (bitwise-ior
+                                  (arithmetic-shift (bitwise-and #b11 b1) 4)
+                                  (extract-bit-field 4 4 b2))))
+               (string-set! res
+                            (+ j 2)
+                            (enc (arithmetic-shift (extract-bit-field 4 0 b2)
+                                                   2)))
+               (string-set! res (+ j 3) #\=))))
+          (let ((b1 (char->integer (string-ref str i)))
+                (b2 (char->integer (string-ref str (+ i 1))))
+                (b3 (char->integer (string-ref str (+ i 2)))))
+            (string-set! res j (enc (arithmetic-shift b1 -2)))
+            (string-set! res
+                         (+ j 1)
+                         (enc (bitwise-ior
+                               (arithmetic-shift (bitwise-and #b11 b1) 4)
+                               (extract-bit-field 4 4 b2))))
+            (string-set! res
+                         (+ j 2)
+                         (enc (bitwise-ior
+                               (arithmetic-shift (extract-bit-field 4 0 b2) 2)
+                               (extract-bit-field 2 6 b3))))
+            (string-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))))
+    (let ((src (make-string encode-src-length))
+          (dst (make-string
+                (arithmetic-shift (quotient encode-src-length 3) 2))))
+      (let lp ()
+        (let ((n (read-string! 2048 src in)))
+          (base64-encode-string! src 0 n dst)
+          (write-string 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))
+           "?=")))))
+

lib/chibi/base64.sld

@@ -0,0 +1,7 @@
+
+(define-library (chibi base64)
+  (export base64-encode base64-encode-string
+          base64-decode base64-decode-string
+          base64-encode-header)
+  (import (chibi) (srfi 33) (chibi io))
+  (include "base64.scm"))

lib/chibi/bytevector.scm

@@ -0,0 +1,70 @@
+
+;;> \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)))))))
+
+;;> \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)
+  (integer->hex-string (bytevector->integer bv)))
+
+(define (hex-string->bytevector str)
+  (integer->bytevector (hex-string->integer str)))

lib/chibi/bytevector.sld

@@ -0,0 +1,10 @@
+
+(define-library (chibi bytevector)
+  (export
+   bytevector-u16-ref-le bytevector-u16-ref-be
+   bytevector-u32-ref-le bytevector-u32-ref-be
+   integer->bytevector bytevector->integer
+   integer->hex-string hex-string->integer
+   bytevector->hex-string hex-string->bytevector)
+  (import (chibi) (srfi 33))
+  (include "bytevector.scm"))

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-signal! (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)))))

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"))

lib/chibi/char-set.sld

@@ -0,0 +1,12 @@
+
+(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
+   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))

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)))
+

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"))

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)))))

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"))

lib/chibi/char-set/extras.scm

@@ -0,0 +1,47 @@
+
+(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 (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))

lib/chibi/char-set/extras.sld

@@ -0,0 +1,11 @@
+
+(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
+   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))

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"))

lib/chibi/config.scm

@@ -0,0 +1,488 @@
+;; 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)
+  (cond
+   ((assoc key alist (or (and (pair? o) (car o)) equal?))
+    => (lambda (x)
+         (if (and (pair? (cdr x)) (null? (cddr x))) (cadr x) (cdr x))))
+   (else
+    (and (pair? o) (pair? (cdr o)) (cadr 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 ((ls config) (res '()))
+    (cond
+     ((null? ls) (reverse res))
+     ((assq key (car ls))
+      => (lambda (specialized)
+           (let ((named (assq name (cdr specialized))))
+             (if named
+                 (lp (cdr ls) (cons (car ls) (cons (cdr named) res)))
+                 (lp (cdr ls) (cons (car ls) res))))))
+     (else (lp (cdr ls) (cons (car ls) 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)))))))

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)
+  (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"))

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.

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"))

lib/chibi/crypto/rsa.scm

@@ -0,0 +1,124 @@
+;; 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"))
+  (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 padded bytevectors
+;; to and from integers.
+;; TODO: user better padding
+
+(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 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)
+  (if (not (rsa-key-e pub-key))
+      (error "can't verify without a public key" pub-key)
+      (equal? (if (string? msg) (string->utf8 msg) msg)
+              (convert-cipher rsa-encrypt-integer pub-key sig))))

lib/chibi/crypto/rsa.sld

@@ -0,0 +1,7 @@
+
+(define-library (chibi crypto rsa)
+  (import (scheme base) (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-key? rsa-key-bits rsa-key-n rsa-key-e rsa-key-d)
+  (include "rsa.scm"))

lib/chibi/crypto/sha2.scm

@@ -0,0 +1,196 @@
+;; 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)
+            ;; Repeat on next block.
+            (cond
+             ((< n 64)
+              (if (>= n 56)
+                  (chunk (+ i n) 0
+                         (u32+ h0 a) (u32+ h1 b) (u32+ h2 c) (u32+ h3 d)
+                         (u32+ h4 e) (u32+ h5 f) (u32+ h6 g) (u32+ h7 h))
+                  ;; Done - add back in the has inits and serialize.
+                  (string-append
+                   (hex (u32+ a (vector-ref inits 0)))
+                   (hex (u32+ b (vector-ref inits 1)))
+                   (hex (u32+ c (vector-ref inits 2)))
+                   (hex (u32+ d (vector-ref inits 3)))
+                   (hex (u32+ e (vector-ref inits 4)))
+                   (hex (u32+ f (vector-ref inits 5)))
+                   (hex (u32+ g (vector-ref inits 6)))
+                   (if full?
+                       (hex (u32+ h #x5be0cd19))
+                       ""))))
+             (else
+              (chunk (+ i 64) pad
+                     (u32+ h0 a) (u32+ h1 b) (u32+ h2 c) (u32+ h3 d)
+                     (u32+ h4 e) (u32+ h5 f) (u32+ h6 g) (u32+ h7 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))