Forgot to install regexp (patch from Lorenzo)

.hgignore

@@ -0,0 +1,44 @@
+syntax: glob
+*~
+*.i
+*.s
+*.o
+*.so
+*.so.*
+*.pc
+*.sch
+*.sps
+*.txt
+*.image
+*.wav
+*.dylib
+*.class
+*.dSYM
+*.orig
+.hg
+junk*
+*.tgz
+*.tar.gz
+*.tar.bz2
+*.log
+*.err
+*.out
+gc
+gc6.8
+clibs.c
+chibi-scheme
+chibi-scheme-static
+build-lib/chibi/char-set/derived.scm
+include/chibi/install.h
+lib/chibi/filesystem.c
+lib/chibi/io/io.c
+lib/chibi/net.c
+lib/chibi/process.c
+lib/chibi/system.c
+lib/chibi/time.c
+lib/chibi/stty.c
+doc/*.html
+doc/lib/chibi/*.html
+misc/*
+tests/ffi/*.c
+tests/ffi/*.stub

AUTHORS

@@ -0,0 +1,51 @@
+Alex Shinn wrote the initial version of chibi-scheme and all
+distributed modules.
+
+The `dynamic-wind' implementation is adapted from the implementation
+in the appendix to the Scheme48 reference manual, reportedly first
+written by Chris Hanson and John Lamping.
+
+The (scheme time) module includes code for handling leap seconds
+from Alan Watson's Scheme clock library at
+http://code.google.com/p/scheme-clock/ under the same license.
+
+The benchmarks are based on the Racket versions of the classic
+Gabriel benchmarks from
+http://www.cs.utah.edu/~mflatt/benchmarks-20100126/log3/index.html.
+They are not installed or needed but are included for convenience.
+
+Thanks to the following people for patches and bug reports:
+
+  * Alan Watson
+  * Alexander Shendi
+  * Andreas Rottman
+  * Bakul Shah
+  * Ben Mather
+  * Ben Weaver
+  * Bruno Deferrari
+  * Doug Currie
+  * Derrick Eddington
+  * Dmitry Chestnykh
+  * Eduardo Cavazos
+  * Felix Winkelmann
+  * Gregor Klinke
+  * Jeremy Wolff
+  * Jeronimo Pellegrini
+  * John Cowan
+  * John Samsa
+  * Lars J Aas
+  * Lorenzo Campedelli
+  * Meng Zhang
+  * Michal Kowalski (sladegen)
+  * Miroslav Urbanek
+  * Rajesh Krishnan
+  * Seth Alves
+  * Stephen Lewis
+  * Taylor Venable
+  * Travis Cross
+  * Zhang Meng
+
+If you would prefer not to be listed, or are one of the users listed
+without a full name, please contact me.  If you've made a contribution
+and are not listed, please accept my apologies and contact me
+immediately!

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,410 @@
+# -*- makefile-gmake -*-
+
+.PHONY: dist mips-dist cleaner test test-all test-dist checkdefs
+.DEFAULT_GOAL := all
+
+SOVERSION ?= $(shell cat VERSION)
+SOVERSION_MAJOR ?= $(shell echo "$(SOVERSION)" | sed "s/\..*//")
+
+CHIBI_FFI ?= $(CHIBI) -q tools/chibi-ffi
+CHIBI_FFI_DEPENDENCIES ?= $(CHIBI_DEPENDENCIES) tools/chibi-ffi
+
+CHIBI_DOC ?= $(CHIBI) tools/chibi-doc
+CHIBI_DOC_DEPENDENCIES ?= $(CHIBI_DEPENDENCIES) tools/chibi-doc
+
+GENSTATIC ?= ./tools/chibi-genstatic
+
+CHIBI ?= LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH=".:$(DYLD_LIBRARY_PATH)" CHIBI_MODULE_PATH=lib ./chibi-scheme$(EXE)
+CHIBI_DEPENDENCIES = ./chibi-scheme$(EXE)
+
+########################################################################
+
+CHIBI_COMPILED_LIBS = lib/chibi/filesystem$(SO) lib/chibi/process$(SO) \
+	lib/chibi/time$(SO) lib/chibi/system$(SO) lib/chibi/stty$(SO) \
+	lib/chibi/weak$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) \
+	lib/chibi/net$(SO) lib/chibi/ast$(SO)
+CHIBI_IO_COMPILED_LIBS = lib/chibi/io/io$(SO)
+CHIBI_OPT_COMPILED_LIBS = lib/chibi/optimize/rest$(SO) \
+	lib/chibi/optimize/profile$(SO)
+COMPILED_LIBS = $(CHIBI_COMPILED_LIBS) $(CHIBI_IO_COMPILED_LIBS) \
+	$(CHIBI_OPT_COMPILED_LIBS) lib/srfi/18/threads$(SO) \
+	lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) lib/srfi/39/param$(SO) \
+	lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) lib/srfi/98/env$(SO) \
+	lib/scheme/time$(SO)
+
+BASE_INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h include/chibi/bignum.h
+INCLUDES = $(BASE_INCLUDES) include/chibi/eval.h
+
+MODULE_DOCS := ast config disasm equiv filesystem generic heap-stats io \
+	loop match mime modules net pathname process repl scribble stty \
+	system test time trace type-inference uri weak monad/environment \
+	show show/base
+
+HTML_LIBS = $(MODULE_DOCS:%=doc/lib/chibi/%.html)
+
+META_FILES = lib/.chibi.meta lib/.srfi.meta lib/.scheme.meta
+
+########################################################################
+
+include Makefile.libs
+
+########################################################################
+# Library config.
+#
+# This is to allow "make SEXP_USE_BOEHM=1" and "make SEXP_USE_DL=0" to
+# automatically include the necessary compiler and linker flags in
+# addition to setting those features.  If not using GNU make just
+# comment out the ifs and use the else branches for the defaults.
+
+ifeq ($(SEXP_USE_BOEHM),1)
+GCLDFLAGS := -lgc
+XCPPFLAGS := $(CPPFLAGS) -Iinclude $(D:%=-DSEXP_USE_%) -DSEXP_USE_BOEHM=1
+else
+GCLDFLAGS :=
+XCPPFLAGS := $(CPPFLAGS) -Iinclude $(D:%=-DSEXP_USE_%)
+endif
+
+ifeq ($(SEXP_USE_DL),0)
+XLDFLAGS  := $(LDFLAGS) $(RLDFLAGS) $(GCLDFLAGS) -lm
+XCFLAGS   := -Wall -DSEXP_USE_DL=0 -g -g3 -O3 $(CFLAGS)
+else
+XLDFLAGS  := $(LDFLAGS) $(RLDFLAGS) $(GCLDFLAGS) $(LIBDL) -lm
+XCFLAGS   := -Wall -g -g3 -O3 $(CFLAGS)
+endif
+
+########################################################################
+
+all: chibi-scheme$(EXE) all-libs chibi-scheme.pc $(META_FILES)
+
+include/chibi/install.h: Makefile
+	echo '#define sexp_so_extension "'$(SO)'"' > $@
+	echo '#define sexp_default_module_path "'$(MODDIR):$(BINMODDIR)'"' >> $@
+	echo '#define sexp_platform "'$(PLATFORM)'"' >> $@
+	echo '#define sexp_version "'`cat VERSION`'"' >> $@
+	echo '#define sexp_release_name "'`cat RELEASE`'"' >> $@
+
+%.o: %.c $(BASE_INCLUDES)
+	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $<
+
+gc-ulimit.o: gc.c $(BASE_INCLUDES)
+	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -DSEXP_USE_LIMITED_MALLOC -o $@ $<
+
+sexp-ulimit.o: sexp.c $(BASE_INCLUDES)
+	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -DSEXP_USE_LIMITED_MALLOC -o $@ $<
+
+main.o: main.c $(INCLUDES)
+	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $<
+
+SEXP_OBJS = gc.o sexp.o bignum.o
+SEXP_ULIMIT_OBJS = gc-ulimit.o sexp-ulimit.o bignum.o
+EVAL_OBJS = opcodes.o vm.o eval.o simplify.o
+
+libchibi-sexp$(SO): $(SEXP_OBJS)
+	$(CC) $(CLIBFLAGS) $(CLINKFLAGS) -o $@ $^ $(XLDFLAGS)
+
+libchibi-scheme$(SO_VERSIONED_SUFFIX): $(SEXP_OBJS) $(EVAL_OBJS)
+	$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(LIBCHIBI_FLAGS) -o $@ $^ $(XLDFLAGS)
+
+libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX): libchibi-scheme$(SO_VERSIONED_SUFFIX)
+	$(LN) -sf $< $@
+
+libchibi-scheme$(SO): libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX)
+	$(LN) -sf $< $@
+
+libchibi-scheme.a: $(SEXP_OBJS) $(EVAL_OBJS)
+	$(AR) rcs $@ $^
+
+chibi-scheme$(EXE): main.o libchibi-scheme$(SO)
+	$(CC) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< -L. -lchibi-scheme
+
+chibi-scheme-static$(EXE): main.o $(SEXP_OBJS) $(EVAL_OBJS)
+	$(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) -lm
+
+chibi-scheme-ulimit$(EXE): main.o $(SEXP_ULIMIT_OBJS) $(EVAL_OBJS)
+	$(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) -lm
+
+clibs.c: $(GENSTATIC) chibi-scheme$(EXE)
+	$(FIND) lib -name \*.sld | $(CHIBI) $(GENSTATIC) > $@
+
+chibi-scheme.pc: chibi-scheme.pc.in
+	echo "# pkg-config" > chibi-scheme.pc
+	echo "prefix=$(PREFIX)" >> chibi-scheme.pc
+	echo "exec_prefix=\$${prefix}" >> chibi-scheme.pc
+	echo "libdir=$(LIBDIR)" >> chibi-scheme.pc
+	echo "includedir=\$${prefix}/include" >> chibi-scheme.pc
+	echo "version=$(VERSION)" >> chibi-scheme.pc
+	echo "" >> chibi-scheme.pc
+	cat chibi-scheme.pc.in >> chibi-scheme.pc
+
+# A special case, this needs to be linked with the LDFLAGS in case
+# we're using Boehm.
+lib/chibi/ast$(SO): lib/chibi/ast.c $(INCLUDES) libchibi-scheme$(SO)
+	-$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< $(GCLDFLAGS) -L. -lchibi-scheme
+
+doc: doc/chibi.html doc-libs
+
+%.html: %.scrbl $(CHIBI_DOC_DEPENDENCIES)
+	$(CHIBI_DOC) --html $< > $@
+
+lib/.%.meta: lib/%/ tools/generate-install-meta.scm
+	-$(FIND) $< -name \*.sld | \
+	 $(CHIBI) tools/generate-install-meta.scm `cat VERSION` > $@
+
+########################################################################
+# Dist builds - rules to build generated files included in distribution
+# (currently just char-sets since it takes a long time and we don't want
+# to bundle the raw Unicode files or require a net connection to build).
+
+data/%.txt:
+	curl --silent http://www.unicode.org/Public/UNIDATA/$*.txt > $@
+
+build-lib/chibi/char-set/derived.scm: data/UnicodeData.txt data/DerivedCoreProperties.txt chibi-scheme$(EXE)
+	$(CHIBI) tools/extract-unicode-props.scm --default > $@
+
+lib/chibi/char-set/ascii.scm: build-lib/chibi/char-set/derived.scm chibi-scheme$(EXE)
+	$(CHIBI) -Abuild-lib tools/optimize-char-sets.scm --ascii chibi.char-set.compute > $@
+
+lib/chibi/char-set/full.scm: build-lib/chibi/char-set/derived.scm chibi-scheme$(EXE)
+	$(CHIBI) -Abuild-lib tools/optimize-char-sets.scm chibi.char-set.compute > $@
+
+lib/scheme/char/case-offsets.scm: data/CaseFolding.txt chibi-scheme$(EXE) all-libs
+	$(CHIBI) tools/extract-case-offsets.scm $< > $@
+
+########################################################################
+# Tests
+
+checkdefs:
+	@for d in $(D); do \
+	    if ! $(GREP) -q " SEXP_USE_$${d%%=*} " include/chibi/features.h; then \
+	        echo "WARNING: unknown definition $$d"; \
+	    fi; \
+	done
+
+test-basic: chibi-scheme$(EXE)
+	@for f in tests/basic/*.scm; do \
+	    $(CHIBI) -xchibi $$f >$${f%.scm}.out 2>$${f%.scm}.err; \
+	    if $(DIFF) -q $(DIFFOPTS) $${f%.scm}.out $${f%.scm}.res; then \
+	        echo "[PASS] $${f%.scm}"; \
+	    else \
+	        echo "[FAIL] $${f%.scm}"; \
+	    fi; \
+	done
+
+test-memory: chibi-scheme-ulimit$(EXE)
+	./tests/memory/memory-tests.sh
+
+test-build:
+	MAKE=$(MAKE) ./tests/build/build-tests.sh
+
+test-ffi: chibi-scheme$(EXE)
+	$(CHIBI) tests/ffi/ffi-tests.scm
+
+test-threads: chibi-scheme$(EXE) lib/srfi/18/threads$(SO) lib/srfi/39/param$(SO) lib/srfi/98/env$(SO) lib/chibi/ast$(SO) lib/chibi/time$(SO)
+	$(CHIBI) -xchibi tests/thread-tests.scm
+
+test-numbers: chibi-scheme$(EXE)
+	$(CHIBI) -xchibi tests/numeric-tests.scm
+
+test-flonums: chibi-scheme$(EXE)
+	$(CHIBI) -xchibi tests/flonum-tests.scm
+
+test-hash: chibi-scheme$(EXE) lib/srfi/69/hash$(SO)
+	$(CHIBI) -xchibi tests/hash-tests.scm
+
+test-io: chibi-scheme$(EXE) lib/chibi/io/io$(SO)
+	$(CHIBI) -xchibi tests/io-tests.scm
+
+test-match: chibi-scheme$(EXE)
+	$(CHIBI) -xchibi tests/match-tests.scm
+
+test-loop: chibi-scheme$(EXE)
+	$(CHIBI) -xchibi tests/loop-tests.scm
+
+test-sort: chibi-scheme$(EXE) lib/srfi/33/bit$(SO)
+	$(CHIBI) -xchibi tests/sort-tests.scm
+
+test-srfi-1: chibi-scheme$(EXE)
+	$(CHIBI) -xchibi tests/srfi-1-tests.scm
+
+test-records: chibi-scheme$(EXE)
+	$(CHIBI) -xchibi tests/record-tests.scm
+
+test-weak: chibi-scheme$(EXE) lib/chibi/weak$(SO)
+	$(CHIBI) -xchibi tests/weak-tests.scm
+
+test-unicode: chibi-scheme$(EXE)
+	$(CHIBI) -xchibi tests/unicode-tests.scm
+
+test-process: chibi-scheme$(EXE) lib/chibi/process$(SO)
+	$(CHIBI) -xchibi tests/process-tests.scm
+
+test-system: chibi-scheme$(EXE) lib/chibi/system$(SO)
+	$(CHIBI) -xchibi tests/system-tests.scm
+
+test-libs: chibi-scheme$(EXE)
+	$(CHIBI) -xchibi tests/lib-tests.scm
+
+test-r5rs: chibi-scheme$(EXE)
+	$(CHIBI) -xchibi tests/r5rs-tests.scm
+
+test-r7rs: chibi-scheme$(EXE)
+	$(CHIBI) tests/r7rs-tests.scm
+
+test: test-r7rs
+
+test-all: test test-libs test-ffi
+
+test-dist: test-all test-memory test-build
+
+bench-gabriel: chibi-scheme$(EXE)
+	./benchmarks/gabriel/run.sh
+
+########################################################################
+# Packaging
+
+clean: clean-libs
+	-$(RM) *.o *.i *.s *.8 tests/basic/*.out tests/basic/*.err
+
+cleaner: clean
+	-$(RM) chibi-scheme$(EXE) chibi-scheme-static$(EXE) chibi-scheme-ulimit$(EXE) \
+	    libchibi-scheme$(SO)* *.a *.pc include/chibi/install.h lib/.*.meta \
+	    $(shell $(FIND) lib -name \*.o)
+
+dist-clean: dist-clean-libs cleaner
+
+install: all
+	$(MKDIR) $(DESTDIR)$(BINDIR)
+	$(INSTALL) -m0755 chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/
+	$(INSTALL) -m0755 tools/chibi-ffi $(DESTDIR)$(BINDIR)/
+	$(INSTALL) -m0755 tools/chibi-doc $(DESTDIR)$(BINDIR)/
+	$(INSTALL) -m0755 tools/snow-chibi $(DESTDIR)$(BINDIR)/
+	$(MKDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(MODDIR)/chibi/crypto $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(MODDIR)/chibi/iset $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(MODDIR)/chibi/math $(DESTDIR)$(MODDIR)/chibi/monad $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(MODDIR)/chibi/regexp $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(MODDIR)/chibi/snow $(DESTDIR)$(MODDIR)/chibi/term
+	$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/char
+	$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/time
+	$(MKDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(MODDIR)/srfi/33 $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(MODDIR)/srfi/99/records
+	$(INSTALL) -m0644 $(META_FILES) $(DESTDIR)$(MODDIR)/
+	$(INSTALL) -m0644 lib/*.scm $(DESTDIR)$(MODDIR)/
+	$(INSTALL) -m0644 lib/chibi/*.sld lib/chibi/*.scm $(DESTDIR)$(MODDIR)/chibi/
+	$(INSTALL) -m0644 lib/chibi/char-set/*.sld lib/chibi/char-set/*.scm $(DESTDIR)$(MODDIR)/chibi/char-set/
+	$(INSTALL) -m0644 lib/chibi/crypto/*.sld lib/chibi/crypto/*.scm $(DESTDIR)$(MODDIR)/chibi/crypto/
+	$(INSTALL) -m0644 lib/chibi/io/*.scm $(DESTDIR)$(MODDIR)/chibi/io/
+	$(INSTALL) -m0644 lib/chibi/iset/*.sld lib/chibi/iset/*.scm $(DESTDIR)$(MODDIR)/chibi/iset/
+	$(INSTALL) -m0644 lib/chibi/loop/*.scm $(DESTDIR)$(MODDIR)/chibi/loop/
+	$(INSTALL) -m0644 lib/chibi/match/*.scm $(DESTDIR)$(MODDIR)/chibi/match/
+	$(INSTALL) -m0644 lib/chibi/math/*.sld lib/chibi/math/*.scm $(DESTDIR)$(MODDIR)/chibi/math/
+	$(INSTALL) -m0644 lib/chibi/monad/*.sld lib/chibi/monad/*.scm $(DESTDIR)$(MODDIR)/chibi/monad/
+	$(INSTALL) -m0644 lib/chibi/net/*.sld lib/chibi/net/*.scm $(DESTDIR)$(MODDIR)/chibi/net/
+	$(INSTALL) -m0644 lib/chibi/optimize/*.sld lib/chibi/optimize/*.scm $(DESTDIR)$(MODDIR)/chibi/optimize/
+	$(INSTALL) -m0644 lib/chibi/parse/*.sld lib/chibi/parse/*.scm $(DESTDIR)$(MODDIR)/chibi/parse/
+	$(INSTALL) -m0644 lib/chibi/regexp/*.sld lib/chibi/regexp/*.scm $(DESTDIR)$(MODDIR)/chibi/regexp/
+	$(INSTALL) -m0644 lib/chibi/show/*.sld lib/chibi/show/*.scm $(DESTDIR)$(MODDIR)/chibi/show/
+	$(INSTALL) -m0644 lib/chibi/snow/*.sld lib/chibi/snow/*.scm $(DESTDIR)$(MODDIR)/chibi/snow/
+	$(INSTALL) -m0644 lib/chibi/term/*.sld lib/chibi/term/*.scm $(DESTDIR)$(MODDIR)/chibi/term/
+	$(INSTALL) -m0644 lib/scheme/*.sld lib/scheme/*.scm $(DESTDIR)$(MODDIR)/scheme/
+	$(INSTALL) -m0644 lib/scheme/char/*.sld lib/scheme/char/*.scm $(DESTDIR)$(MODDIR)/scheme/char/
+	$(INSTALL) -m0644 lib/scheme/time/*.sld $(DESTDIR)$(MODDIR)/scheme/time/
+	$(INSTALL) -m0644 lib/srfi/*.sld lib/srfi/*.scm $(DESTDIR)$(MODDIR)/srfi/
+	$(INSTALL) -m0644 lib/srfi/1/*.scm $(DESTDIR)$(MODDIR)/srfi/1/
+	$(INSTALL) -m0644 lib/srfi/18/*.scm $(DESTDIR)$(MODDIR)/srfi/18/
+	$(INSTALL) -m0644 lib/srfi/27/*.scm $(DESTDIR)$(MODDIR)/srfi/27/
+	$(INSTALL) -m0644 lib/srfi/33/*.scm $(DESTDIR)$(MODDIR)/srfi/33/
+	$(INSTALL) -m0644 lib/srfi/39/*.scm $(DESTDIR)$(MODDIR)/srfi/39/
+	$(INSTALL) -m0644 lib/srfi/69/*.scm $(DESTDIR)$(MODDIR)/srfi/69/
+	$(INSTALL) -m0644 lib/srfi/95/*.scm $(DESTDIR)$(MODDIR)/srfi/95/
+	$(INSTALL) -m0644 lib/srfi/99/*.sld $(DESTDIR)$(MODDIR)/srfi/99/
+	$(INSTALL) -m0644 lib/srfi/99/records/*.sld lib/srfi/99/records/*.scm $(DESTDIR)$(MODDIR)/srfi/99/records/
+	$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/io/
+	$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
+	$(MKDIR) $(DESTDIR)$(BINMODDIR)/scheme/
+	$(MKDIR) $(DESTDIR)$(BINMODDIR)/srfi/18 $(DESTDIR)$(BINMODDIR)/srfi/27 $(DESTDIR)$(BINMODDIR)/srfi/33 $(DESTDIR)$(BINMODDIR)/srfi/39 $(DESTDIR)$(BINMODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/98
+	$(INSTALL) -m0755 $(CHIBI_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/
+	$(INSTALL) -m0755 $(CHIBI_IO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/io/
+	$(INSTALL) -m0755 $(CHIBI_OPT_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
+	$(INSTALL) -m0755 lib/scheme/time$(SO) $(DESTDIR)$(BINMODDIR)/scheme/
+	$(INSTALL) -m0755 lib/srfi/18/threads$(SO) $(DESTDIR)$(BINMODDIR)/srfi/18
+	$(INSTALL) -m0755 lib/srfi/27/rand$(SO) $(DESTDIR)$(BINMODDIR)/srfi/27
+	$(INSTALL) -m0755 lib/srfi/33/bit$(SO) $(DESTDIR)$(BINMODDIR)/srfi/33
+	$(INSTALL) -m0755 lib/srfi/39/param$(SO) $(DESTDIR)$(BINMODDIR)/srfi/39
+	$(INSTALL) -m0755 lib/srfi/69/hash$(SO) $(DESTDIR)$(BINMODDIR)/srfi/69
+	$(INSTALL) -m0755 lib/srfi/95/qsort$(SO) $(DESTDIR)$(BINMODDIR)/srfi/95
+	$(INSTALL) -m0755 lib/srfi/98/env$(SO) $(DESTDIR)$(BINMODDIR)/srfi/98
+	$(MKDIR) $(DESTDIR)$(INCDIR)
+	$(INSTALL) -m0644 $(INCLUDES) $(DESTDIR)$(INCDIR)/
+	$(MKDIR) $(DESTDIR)$(LIBDIR)
+	$(MKDIR) $(DESTDIR)$(SOLIBDIR)
+	$(INSTALL) -m0755 libchibi-scheme$(SO_VERSIONED_SUFFIX) $(DESTDIR)$(SOLIBDIR)/
+	$(LN) -s -f libchibi-scheme$(SO_VERSIONED_SUFFIX) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX)
+	$(LN) -s -f libchibi-scheme$(SO_VERSIONED_SUFFIX) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO)
+	-$(INSTALL) -m0644 libchibi-scheme.a $(DESTDIR)$(SOLIBDIR)/
+	$(MKDIR) $(DESTDIR)$(SOLIBDIR)/pkgconfig
+	$(INSTALL) -m0644 chibi-scheme.pc $(DESTDIR)$(SOLIBDIR)/pkgconfig/
+	$(MKDIR) $(DESTDIR)$(MANDIR)
+	$(INSTALL) -m0644 doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/
+	$(INSTALL) -m0644 doc/chibi-ffi.1 $(DESTDIR)$(MANDIR)/
+	$(INSTALL) -m0644 doc/chibi-doc.1 $(DESTDIR)$(MANDIR)/
+	-if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi
+
+uninstall:
+	-$(RM) $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE)
+	-$(RM) $(DESTDIR)$(BINDIR)/chibi-scheme-static$(EXE)
+	-$(RM) $(DESTDIR)$(BINDIR)/chibi-ffi
+	-$(RM) $(DESTDIR)$(BINDIR)/chibi-doc
+	-$(RM) $(DESTDIR)$(BINDIR)/snow-chibi
+	-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO)
+	-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO_VERSIONED_SUFFIX)
+	-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO_MAJOR_VERSIONED_SUFFIX)
+	-$(RM) $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a
+	-$(RM) $(DESTDIR)$(SOLIBDIR)/pkgconfig/chibi-scheme.pc
+	-$(CD) $(DESTDIR)$(INCDIR) && $(RM) $(INCLUDES)
+	-$(RM) $(DESTDIR)$(MODDIR)/srfi/99/records/*.{sld,scm}
+	-$(RM) $(DESTDIR)$(MODDIR)/.*.meta
+	-$(RM) $(DESTDIR)$(MODDIR)/*.{sld,scm} $(DESTDIR)$(MODDIR)/*/*.{sld,scm} $(DESTDIR)$(MODDIR)/*/*/*.{sld,scm}
+	-$(CD) $(DESTDIR)$(MODDIR) && $(RM) $(COMPILED_LIBS:lib/%=%)
+	-$(CD) $(DESTDIR)$(BINMODDIR) && $(RM) $(COMPILED_LIBS:lib/%=%)
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(BINMODDIR)/chibi/char-set
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/crypto $(DESTDIR)$(BINMODDIR)/chibi/crypto
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(BINMODDIR)/chibi/io
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/iset $(DESTDIR)$(BINMODDIR)/chibi/iset
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(BINMODDIR)/chibi/loop
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(BINMODDIR)/chibi/match
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/math $(DESTDIR)$(BINMODDIR)/chibi/math
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/monad $(DESTDIR)$(BINMODDIR)/chibi/monad
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(BINMODDIR)/chibi/net
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(BINMODDIR)/chibi/optimize
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(BINMODDIR)/chibi/parse
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/regexp $(DESTDIR)$(BINMODDIR)/chibi/regexp
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(BINMODDIR)/chibi/show
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/snow $(DESTDIR)$(BINMODDIR)/chibi/snow
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/term $(DESTDIR)$(BINMODDIR)/chibi/term
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi $(DESTDIR)$(BINMODDIR)/chibi
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/char $(DESTDIR)$(BINMODDIR)/scheme/char
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/time $(DESTDIR)$(BINMODDIR)/scheme/time
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme $(DESTDIR)$(BINMODDIR)/scheme
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(BINMODDIR)/srfi/1
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(BINMODDIR)/srfi/18
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(BINMODDIR)/srfi/27
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/33 $(DESTDIR)$(BINMODDIR)/srfi/33
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(BINMODDIR)/srfi/39
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/69
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/95
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/98 $(DESTDIR)$(BINMODDIR)/srfi/98
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/99/records $(DESTDIR)$(BINMODDIR)/srfi/99/records
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(BINMODDIR)/srfi/99
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi $(DESTDIR)$(BINMODDIR)/srfi
+	-$(RMDIR) $(DESTDIR)$(MODDIR) $(DESTDIR)$(BINMODDIR)
+	-$(RM) $(DESTDIR)$(MANDIR)/chibi-scheme.1 $(DESTDIR)$(MANDIR)/chibi-ffi.1 $(DESTDIR)$(MANDIR)/chibi-doc.1
+	-$(RM) $(DESTDIR)$(SOLIBDIR)/pkgconfig/chibi-scheme.pc
+
+dist: dist-clean
+	$(RM) chibi-scheme-`cat VERSION`.tgz
+	$(MKDIR) chibi-scheme-`cat VERSION`
+	@for f in `hg manifest | grep -v ^benchmarks/`; do $(MKDIR) chibi-scheme-`cat VERSION`/`dirname $$f`; $(SYMLINK) `pwd`/$$f chibi-scheme-`cat VERSION`/$$f; done
+	$(TAR) cphzvf chibi-scheme-`cat VERSION`.tgz chibi-scheme-`cat VERSION`
+	$(RM) -r chibi-scheme-`cat VERSION`
+
+mips-dist: dist-clean
+	$(RM) chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz
+	$(MKDIR) chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`
+	@for f in `hg manifest | grep -v ^benchmarks/`; do $(MKDIR) chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/`dirname $$f`; $(SYMLINK) `pwd`/$$f chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/$$f; done
+	$(TAR) cphzvf chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`
+	$(RM) -r chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`

Makefile.detect

@@ -0,0 +1,119 @@
+# -*- makefile-gmake -*-
+
+########################################################################
+# Detect the PLATFORM with uname.
+
+ifndef PLATFORM
+ifeq ($(shell uname),Darwin)
+PLATFORM=macosx
+else
+ifeq ($(shell uname),FreeBSD)
+PLATFORM=bsd
+else
+ifeq ($(shell uname),NetBSD)
+PLATFORM=bsd
+else
+ifeq ($(shell uname),OpenBSD)
+PLATFORM=bsd
+else
+ifeq ($(shell uname),DragonFly)
+PLATFORM=bsd
+else
+ifeq ($(shell uname -o),Msys)
+PLATFORM=mingw
+SOLIBDIR = $(BINDIR)
+DIFFOPTS = -b
+else
+ifeq ($(shell uname -o),Cygwin)
+PLATFORM=cygwin
+SOLIBDIR = $(BINDIR)
+DIFFOPTS = -b
+else
+ifeq ($(shell uname -o),GNU/Linux)
+PLATFORM=linux
+else
+PLATFORM=unix
+endif
+endif
+endif
+endif
+endif
+endif
+endif
+endif
+
+########################################################################
+# Set default variables for the platform.
+
+LIBDL = -ldl
+SO_VERSIONED_SUFFIX = $(SO).$(SOVERSION)
+SO_MAJOR_VERSIONED_SUFFIX = $(SO).$(SOVERSION_MAJOR)
+
+ifeq ($(PLATFORM),macosx)
+SO  = .dylib
+SO_VERSIONED_SUFFIX = .$(SOVERSION)$(SO)
+SO_MAJOR_VERSIONED_SUFFIX = .$(SOVERSION_MAJOR)$(SO)
+EXE =
+CLIBFLAGS =
+CLINKFLAGS = -dynamiclib
+STATICFLAGS = -DSEXP_USE_DL=0  # -static-libgcc
+LIBCHIBI_FLAGS = -install_name $(DESTDIR)$(SOLIBDIR)/libchibi-scheme.$(SOVERSION).dylib
+else
+ifeq ($(PLATFORM),bsd)
+SO  = .so
+EXE =
+CLIBFLAGS = -fPIC
+CLINKFLAGS = -shared
+LIBDL = 
+else
+ifeq ($(PLATFORM),mingw)
+SO  = .dll
+EXE = .exe
+CC = gcc
+CLIBFLAGS =
+CLINKFLAGS = -shared
+CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL
+LIBCHIBI_FLAGS = -Wl,--out-implib,libchibi-scheme$(SO).a
+STATICFLAGS = -DSEXP_USE_DL=0
+LIBDL = 
+else
+ifeq ($(PLATFORM),cygwin)
+SO  = .dll
+EXE = .exe
+CC = gcc
+CLIBFLAGS =
+CLINKFLAGS = -shared
+CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0
+LIBCHIBI_FLAGS = -Wl,--out-implib,libchibi-scheme$(SO).a
+else
+SO  = .so
+EXE =
+CLIBFLAGS = -fPIC
+CLINKFLAGS = -shared
+STATICFLAGS = -static -DSEXP_USE_DL=0
+LIBCHIBI_FLAGS = -Wl,-soname,libchibi-scheme$(SO).$(SOVERSION_MAJOR)
+ifeq ($(PLATFORM),BSD)
+LIBDL=
+RLDFLAGS=-Wl,-R$(DESTDIR)$(LIBDIR)
+endif
+endif
+endif
+endif
+endif
+endif
+
+ifeq ($(PLATFORM),unix)
+#RLDFLAGS=-rpath $(LIBDIR)
+RLDFLAGS=-Wl,-R$(DESTDIR)$(LIBDIR)
+endif
+
+########################################################################
+# Check for NTP (who needs autoconf?)
+
+ifndef $(SEXP_USE_NTP_GETTIME)
+SEXP_USE_NTP_GETTIME := $(shell echo "main(){struct ntptimeval n; ntp_gettime(&n);}" | gcc -fsyntax-only -include sys/timex.h -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
+endif
+
+ifeq ($(SEXP_USE_NTP_GETTIME),1)
+CPPFLAGS += -DSEXP_USE_NTPGETTIME
+endif

Makefile.libs

@@ -0,0 +1,88 @@
+# -*- makefile-gmake -*-
+
+# Include-able makefile for building Chibi libraries - see README.libs
+# for usage.
+
+.PHONY: all all-libs clean clean-libs dist-clean dist-clean-libs install install-libs uninstall uninstall-libs doc doc-libs
+.PRECIOUS: %.c lib/%.c
+
+# install configuration
+
+CC        ?= cc
+AR        ?= ar
+CD        ?= cd
+RM        ?= rm -f
+LS        ?= ls
+CP        ?= cp
+LN        ?= ln
+INSTALL   ?= install
+MKDIR     ?= $(INSTALL) -d
+RMDIR     ?= rmdir
+TAR       ?= tar
+DIFF      ?= diff
+GREP      ?= grep
+FIND      ?= find
+SYMLINK   ?= ln -s
+
+PREFIX    ?= /usr/local
+BINDIR    ?= $(PREFIX)/bin
+LIBDIR    ?= $(PREFIX)/lib
+SOLIBDIR  ?= $(PREFIX)/lib
+INCDIR    ?= $(PREFIX)/include/chibi
+MODDIR    ?= $(PREFIX)/share/chibi
+BINMODDIR ?= $(PREFIX)/lib/chibi
+MANDIR    ?= $(PREFIX)/share/man/man1
+
+DESTDIR   ?=
+
+########################################################################
+# System configuration - if not using GNU make, set PLATFORM and the
+# flags from Makefile.detect (at least SO, EXE, CLIBFLAGS) as necessary.
+
+include Makefile.detect
+
+########################################################################
+
+all-libs: $(COMPILED_LIBS)
+
+lib/%.c: lib/%.stub $(CHIBI_FFI_DEPENDENCIES)
+	$(CHIBI_FFI) $<
+
+lib/%$(SO): lib/%.c $(INCLUDES) libchibi-scheme$(SO)
+	$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< -L. $(XLIBS) -lchibi-scheme
+
+doc-libs: $(HTML_LIBS)
+
+doc/lib/%.html: lib/%.sld $(CHIBI_DOC_DEPENDENCIES)
+	$(MKDIR) $(dir $@)
+	$(CHIBI_DOC) --html $(subst /,.,$*) > $@
+
+clean-libs:
+	$(RM) $(COMPILED_LIBS)
+	$(RM) -r $(patsubst %,%.dSYM,$(COMPILED_LIBS))
+	$(RM) $(HTML_LIBS)
+
+dist-clean-libs: clean-libs
+	$(RM) $(patsubst %.stub, %.c, $(shell $(FIND) lib -name \*.stub))
+
+install-libs: all-libs
+	for dir in $(dir $(patsubst lib/%,%,$(COMPILED_LIBS))) ; do \
+	$(MKDIR) $(DESTDIR)$(BINMODDIR)/$$dir; \
+	done
+	for file in $(patsubst lib/%,%,$(COMPILED_LIBS)) ; do \
+	$(INSTALL) lib/$$file $(DESTDIR)$(BINMODDIR)/$$file ; \
+	done
+	for dir in $(dir $(patsubst lib/%,%,$(SCM_LIBS))) ; do \
+	$(MKDIR) $(DESTDIR)$(MODDIR)/$$dir; \
+	done
+	for file in $(patsubst lib/%,%,$(SCM_LIBS)) ; do \
+	$(INSTALL) lib/$$file $(DESTDIR)$(MODDIR)/$$file ; \
+	done
+
+uninstall-libs:
+	for file in $(patsubst lib/%,%,$(COMPILED_LIBS)) ; do \
+	$(RM) $(DESTDIR)$(BINMODDIR)/$$file ; \
+	done
+	for file in $(patsubst lib/%,%,$(SCM_LIBS)) ; do \
+	$(RM) $(DESTDIR)$(MODDIR)/$$file ; \
+	done

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 @@
+nitrogen

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

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.pc.in

@@ -0,0 +1,7 @@
+Name: chibi-scheme
+URL: http://synthcode.com/scheme/chibi/
+Description: Minimal Scheme Implementation for use as an Extension Language
+Version: ${version}
+Libs: -L${libdir} -lchibi-scheme
+Libs.private: -dl -lm
+Cflags: -I${includedir}

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,239 @@
+.TH "chibi-scheme" "1" "" ""
+.UC 4
+.SH NAME
+.PP
+chibi-scheme \- a tiny Scheme interpreter
+
+.SH SYNOPSIS
+.B chibi-scheme
+[-qQrRfV]
+[-I
+.I path
+]
+[-A
+.I path
+]
+[-m
+.I module
+]
+[-x
+.I module
+]
+[-l
+.I file
+]
+[-e
+.I expr
+]
+[-p
+.I expr
+]
+[-t
+.I module.id
+]
+[-d
+.I image-file
+]
+[-i
+.I image-file
+]
+[--]
+[
+.I script argument ...
+]
+.br
+.sp 0.4
+
+.SH DESCRIPTION
+.I chibi-scheme
+is a sample interactive Scheme interpreter for the
+.I chibi-scheme
+library.  It serves as an example of how to embed
+.I chibi-scheme
+in applications, and can be useful on its own for writing
+scripts and interactive development.
+
+When
+.I script
+is given, the script will be loaded with SRFI-22 semantics,
+calling the procedure
+.I main
+(if defined) with a single parameter as a list of the
+command-line arguments beginning with the script name.  This
+works as expected with shell #! semantics.
+
+Otherwise, if no script is given and no -e or -p options
+are given an interactive repl is entered, reading, evaluating,
+then printing expressions until EOF is reached.  The repl
+provided is very minimal - if you want readline
+completion you may want to wrap it with the
+.I rlwrap(1)
+program.  Signals aren't caught either - to enable handling keyboard
+interrupts you can use the (chibi process) module.  For a more
+sophisticated REPL with readline support, signal handling, module
+management and smarter read/write you may want to use the (chibi repl)
+module.  This can be launched automatically with:
+.I chibi-scheme -R
+\[char46]
+
+The default language the R7RS
+(scheme base) module.  To get a mostly R5RS-compatible language, use
+.I chibi-scheme -xscheme.r5rs
+or to get just the core language used for bootstrapping, use
+.I chibi-scheme -xchibi
+or its shortcut
+.I chibi-scheme -q
+\[char46]
+
+.SH OPTIONS
+
+Space is optional between options and their arguments.  Options
+without arguments may not be chained together.
+
+To reduce the need for shell escapes, options with module arguments
+(
+.I -m
+,
+.I -x
+and
+.I -R
+) are written in a dot notation, so that the module
+.I (foo bar)
+is written as
+.I foo.bar
+\[char46]
+
+.TP 5
+.BI -V
+Prints the version information and exits.
+.TP
+.BI -q
+"Quick" load, shortcut for
+.I chibi-scheme -xchibi
+This is a slightly different language from (scheme base),
+which may load faster, and is guaranteed not to load any
+additional shared libraries.
+.TP
+.BI -Q
+Extra "quick" load, shortcut for
+.I chibi-scheme -xchibi.primitive
+The resulting environment will only contain the core syntactic
+forms and primitives coded in C.  This is very fast and guaranteed
+not to load any external files, but is also very limited.
+.TP
+.BI -r [main]
+Run the "main" procedure when the script finishes loading as in SRFI-22.
+.TP
+.BI -R [module]
+Loads the given module and runs the "main" procedure it defines (which
+need not be exported) with a single argument of the list of command-line
+arguments as in SRFI-22.  The name "main" can be overridden with the -r
+option.
+.I [module]
+may be omitted, in which case it default to chibi.repl.  Thus
+.I chibi-scheme -R
+is the recommended means to obtain the advanced REPL.
+.TP
+.BI -s
+Strict mode, escalating warnings to fatal errors.
+.TP
+.BI -f
+Change the reader to case-fold symbols as in R5RS.
+.TP
+.BI -h size[/max_size]
+Specifies the initial size of the heap, in bytes,
+optionally followed by the maximum size the heap can
+grow to.
+.I size
+can be any integer value, optionally suffixed by
+"K", for kilobytes, "M" for megabytes, or "G" for gigabytes.
+.I -h
+must be specified before any options which load or
+evaluate Scheme code.
+.TP
+.BI -I path
+Inserts
+.I path
+on front of the load path list.  
+.TP
+.BI -A path
+Appends
+.I path
+to the load path list.  
+.TP
+.BI -m module
+.TP
+.BI -x module
+Imports
+.I module
+as though "(import
+.I module
+)" were evaluated.
+If the
+.BI -x
+version is used, then
+.I module
+replaces the current environment instead of being added to it.
+.TP
+.BI -l file
+Loads the Scheme source from the file
+.I file
+searched for in the default load path.
+.TP
+.BI -e expr
+Evaluates the Scheme expression
+.I expr.
+.TP
+.BI -p expr
+Evaluates the Scheme expression
+.I expr
+then prints the result to stdout.
+.TP
+.BI -t module.id
+Enables tracing for the given identifier
+.I id
+in the module
+.I module.
+.TP
+.BI -d image-file
+Dumps the current Scheme heap to
+.I image-file
+and exits.  This feature is still experimental.
+.TP
+.BI -i image-file
+Loads the Scheme heap from
+.I image-file
+instead of compiling the init file on the fly.
+This feature is still experimental.
+
+.SH ENVIRONMENT
+.TP
+.B CHIBI_MODULE_PATH
+A colon separated list of directories to search for module
+files, inserted before the system default load paths.  chibi-scheme
+searchs for modules in directories in the following order:
+
+.TP
+          directories included with the -I path option
+.TP
+          directories included from CHIBI_MODULE_PATH
+.TP
+          system directories 
+.TP
+          directories included with -A path option
+
+If CHIBI_MODULE_PATH is unset, the directoriese "./lib", and "." are
+search in order.
+
+.SH AUTHORS
+.PP
+Alex Shinn (alexshinn @ gmail . com)
+
+.SH SEE ALSO
+.PP
+More detailed information can be found in the manuale included in
+doc/chibi.scrbl included in the distribution.
+
+The chibi-scheme home-page:
+.br
+http://code.google.com/p/chibi-scheme/

doc/lib/chibi/README

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

examples/echo-server-inet6.scm

@@ -0,0 +1,29 @@
+#!/usr/bin/env chibi-scheme
+
+(import (scheme base) (scheme write) (chibi net) (chibi net server))
+
+;; Copy each input line to output.
+(define (echo-handler in out sock addr)
+  (let ((line (read-line in)))
+    (cond
+     ((not (or (eof-object? line) (equal? line "")))
+      ;; log the request to stdout
+      (display "read: ") (write line)
+      (display " from ")
+      (display (sockaddr-name (address-info-address addr)))
+      (display " port ") (write (sockaddr-port (address-info-address addr)))
+      (newline)
+      ;; write and flush the response
+      (display line out)
+      (newline out)
+      (flush-output-port out)
+      (echo-handler in out sock addr)))))
+
+(define (get-inet6-address-info host service)
+  (let ((hints (make-address-info address-family/inet6
+                                  socket-type/stream
+                                  ip-proto/tcp)))
+    (get-address-info host service hints)))
+
+;; Start the server on local ipv6 addresses on port 5556.
+(run-net-server (get-inet6-address-info #f 5556) echo-handler)

examples/echo-server-udp.scm

@@ -0,0 +1,22 @@
+#!/usr/bin/env chibi-scheme
+
+(import (scheme base) (chibi net))
+
+(define (get-udp-address-info host service)
+  (let ((hints (make-address-info address-family/inet
+                                  socket-type/datagram
+                                  ip-proto/udp)))
+    (get-address-info host service hints)))
+
+;; create and bind a udp socket
+(let* ((addr (get-udp-address-info #f 5556))
+       (sock (socket (address-info-family addr)
+                     (address-info-socket-type addr)
+                     (address-info-protocol addr))))
+  (bind sock (address-info-address addr) (address-info-address-length addr))
+  ;; for every packet we receive, just send it back
+  (let lp ()
+    (cond
+     ((receive sock 512 0 addr)
+      => (lambda (bv) (send sock bv 0 addr))))
+    (lp)))

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)

examples/repl-server.scm

@@ -0,0 +1,26 @@
+#!/usr/bin/env chibi-scheme
+
+(import (scheme base) (scheme read) (scheme write) (scheme eval)
+        (chibi net) (chibi net server))
+
+(define (repl-handler in out sock addr)
+  (let ((env (environment '(scheme base)
+                          '(only (chibi) import))))
+    (let lp ()
+      (let ((expr (read in)))
+        (cond
+         ((not (eof-object? expr))
+          (let ((result (guard (exn (else
+                                     (display "ERROR: " out)
+                                     (write exn out)
+                                     (newline out)
+                                     (if #f #f)))
+                          (eval expr env))))
+            (cond
+             ((not (eq? result (if #f #f)))
+              (write result out)
+              (newline out)))
+            (flush-output-port out)
+            (lp))))))))
+
+(run-net-server 5556 repl-handler)

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,742 @@
+/*  gc.c -- simple mark&sweep garbage collector               */
+/*  Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#if ! SEXP_USE_BOEHM && ! SEXP_USE_MALLOC
+
+#include "chibi/sexp.h"
+
+#if SEXP_USE_MMAP_GC
+#include <sys/mman.h>
+#endif
+
+#ifdef __APPLE__
+#define SEXP_RTLD_DEFAULT RTLD_SELF
+#else
+#define SEXP_RTLD_DEFAULT RTLD_DEFAULT
+#endif
+
+#define SEXP_BANNER(x) ("**************** GC "x"\n")
+
+#define SEXP_MINIMUM_OBJECT_SIZE (sexp_heap_align(1))
+
+#if SEXP_USE_GLOBAL_HEAP
+sexp_heap sexp_global_heap;
+#endif
+
+#if SEXP_USE_CONSERVATIVE_GC
+static sexp* stack_base;
+#endif
+
+#if SEXP_USE_DEBUG_GC
+#define sexp_debug_printf(fmt, ...) fprintf(stderr, SEXP_BANNER(fmt),__VA_ARGS__)
+#else
+#define sexp_debug_printf(fmt, ...)
+#endif
+
+static sexp_heap sexp_heap_last (sexp_heap h) {
+  while (h->next) h = h->next;
+  return h;
+}
+
+static size_t sexp_heap_total_size (sexp_heap h) {
+  size_t total_size = 0;
+  for (; h; h=h->next)
+    total_size += h->size;
+  return total_size;
+}
+
+#if ! SEXP_USE_GLOBAL_HEAP
+void sexp_free_heap (sexp_heap heap) {
+#if SEXP_USE_MMAP_GC
+  munmap(heap, sexp_heap_pad_size(heap->size));
+#else
+  free(heap);
+#endif
+}
+#endif
+
+#if SEXP_USE_LIMITED_MALLOC
+static sexp_sint_t allocated_bytes=0, max_allocated_bytes=-1;
+void* sexp_malloc(size_t size) {
+  char* max_alloc;
+  void* res;
+  if (max_allocated_bytes < 0) {
+    max_alloc = getenv("CHIBI_MAX_ALLOC");
+    max_allocated_bytes = max_alloc ? atoi(max_alloc) : 8192000; /* 8MB */
+  }
+  if (max_allocated_bytes > 0 && allocated_bytes + size > max_allocated_bytes)
+    return NULL;
+  if (!(res = malloc(size))) return NULL;
+  allocated_bytes += size;
+  return res;
+}
+/* TODO: subtract freed memory from max_allocated_bytes */
+void sexp_free(void* ptr) {
+  free(ptr);
+}
+#endif
+
+void sexp_preserve_object(sexp ctx, sexp x) {
+  sexp_global(ctx, SEXP_G_PRESERVATIVES) = sexp_cons(ctx, x, sexp_global(ctx, SEXP_G_PRESERVATIVES));
+}
+
+void sexp_release_object(sexp ctx, sexp x) {
+  sexp ls1, ls2;
+  for (ls1=NULL, ls2=sexp_global(ctx, SEXP_G_PRESERVATIVES); sexp_pairp(ls2);
+       ls1=ls2, ls2=sexp_cdr(ls2))
+    if (sexp_car(ls2) == x) {
+      if (ls1) sexp_cdr(ls1) = sexp_cdr(ls2);
+      else sexp_global(ctx, SEXP_G_PRESERVATIVES) = sexp_cdr(ls2);
+      break;
+    }
+}
+
+sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) {
+  sexp_uint_t res;
+  sexp t;
+  if (!sexp_pointerp(x) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx)))
+    return sexp_heap_align(1);
+  t = sexp_object_type(ctx, x);
+  res = sexp_type_size_of_object(t, x) + SEXP_GC_PAD;
+#if SEXP_USE_DEBUG_GC
+  if (res == 0) {
+    fprintf(stderr, SEXP_BANNER("%p zero-size object: %p"), ctx, x);
+    return 1;
+  }
+#endif
+  return res;
+}
+
+#if SEXP_USE_SAFE_GC_MARK
+
+#if SEXP_USE_DEBUG_GC > 2
+int sexp_valid_heap_position(sexp ctx, sexp_heap h, sexp x) {
+  sexp p = sexp_heap_first_block(h), end = sexp_heap_end(h);
+  sexp_free_list q = h->free_list, r;
+  while (p < end) {
+    for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
+      ;
+    if ((char*)r == (char*)p) {
+      p = (sexp) (((char*)p) + r->size);
+      continue;
+    }
+    if (p == x) {
+      return 1;
+    } else if (p > x) {
+      fprintf(stderr, SEXP_BANNER("bad heap position: %p free: %p-%p : %p-%p"),
+              x, q, ((char*)q)+q->size, r, ((char*)r)+r->size);
+      return 0;
+    }
+    p = (sexp) (((char*)p)+sexp_heap_align(sexp_allocated_bytes(ctx, p)));
+  }
+  fprintf(stderr, SEXP_BANNER("bad heap position: %p heap: %p-%p"), x, h, end);
+  return 0;
+}
+#else
+#define sexp_valid_heap_position(ctx, h, x) 1
+#endif
+
+int sexp_in_heap_p(sexp ctx, sexp x) {
+  sexp_heap h;
+  if ((sexp_uint_t)x & (sexp_heap_align(1)-1)) {
+    fprintf(stderr, SEXP_BANNER("invalid heap alignment: %p"), x);
+    return 0;
+  }
+  for (h=sexp_context_heap(ctx); h; h=h->next)
+    if (((sexp)h < x) && (x < (sexp)(h->data + h->size)))
+      return sexp_valid_heap_position(ctx, h, x);
+  fprintf(stderr, SEXP_BANNER("invalid object outside heap: %p"), x);
+  return 0;
+}
+#endif
+
+#if SEXP_USE_DEBUG_GC > 1
+int sexp_valid_object_type_p (sexp ctx, sexp x) {
+  if (sexp_pointer_tag(x)<=0 || sexp_pointer_tag(x)>sexp_context_num_types(ctx)){
+    fprintf(stderr, SEXP_BANNER("%p mark: bad object at %p: tag: %d"),
+            ctx, x, sexp_pointer_tag(x));
+    return 0;
+  }
+  return 1;
+}
+#else
+#define sexp_valid_object_type_p(ctx, x) 1
+#endif
+
+#if SEXP_USE_HEADER_MAGIC
+int sexp_valid_header_magic_p (sexp ctx, sexp x) {
+  if (sexp_pointer_magic(x)  != SEXP_POINTER_MAGIC
+      && sexp_pointer_tag(x) != SEXP_TYPE && sexp_pointer_tag(x) != SEXP_OPCODE
+      && sexp_pointer_tag(x) != SEXP_CORE && sexp_pointer_tag(x) != SEXP_STACK) {
+    fprintf(stderr, SEXP_BANNER("%p mark: bad magic at %p: %x"),
+            ctx, x, sexp_pointer_magic(x));
+    return 0;
+  }
+  return 1;
+}
+#else
+#define sexp_valid_header_magic_p(ctx, x) 1
+#endif
+
+#if SEXP_DEBUG_GC > 1 || SEXP_USE_SAFE_GC_MARK || SEXP_USE_HEADER_MAGIC
+int sexp_valid_object_p (sexp ctx, sexp x) {
+  return sexp_in_heap_p(ctx, x) && sexp_valid_object_type_p(ctx, x)
+    && sexp_valid_header_magic_p(ctx, x);
+}
+#endif
+
+void sexp_mark (sexp ctx, sexp x) {
+  sexp_sint_t len;
+  sexp t, *p, *q;
+  struct sexp_gc_var_t *saves;
+ loop:
+  if (!x || !sexp_pointerp(x) || !sexp_valid_object_p(ctx, x) || sexp_markedp(x))
+    return;
+  sexp_markedp(x) = 1;
+  if (sexp_contextp(x)) {
+    for (saves=sexp_context_saves(x); saves; saves=saves->next)
+      if (saves->var) sexp_mark(ctx, *(saves->var));
+  }
+  t = sexp_object_type(ctx, x);
+  len = sexp_type_num_slots_of_object(t, x) - 1;
+  if (len >= 0) {
+    p = (sexp*) (((char*)x) + sexp_type_field_base(t));
+    q = p + len;
+    while (p < q && ! (*q && sexp_pointerp(*q)))
+      q--;                      /* skip trailing immediates */
+    while (p < q && *q == q[-1])
+      q--;                      /* skip trailing duplicates */
+    while (p < q)
+      sexp_mark(ctx, *p++);
+    x = *p;
+    goto loop;
+  }
+}
+
+#if SEXP_USE_CONSERVATIVE_GC
+
+int stack_references_pointer_p (sexp ctx, sexp x) {
+  sexp *p;
+  for (p=(&x)+1; p<stack_base; p++)
+    if (*p == x)
+      return 1;
+  return 0;
+}
+
+#if SEXP_USE_TRACK_ALLOC_BACKTRACE
+void sexp_print_gc_trace(sexp ctx, sexp p) {
+  int i;
+  char **debug_text = backtrace_symbols(p->backtrace, SEXP_BACKTRACE_SIZE);
+  for (i=0; i < SEXP_BACKTRACE_SIZE; i++)
+    fprintf(stderr, SEXP_BANNER("    : %s"), debug_text[i]);
+  free(debug_text);
+}
+#else
+#define sexp_print_gc_trace(ctx, p)
+#endif
+
+void sexp_conservative_mark (sexp ctx) {
+  sexp_heap h = sexp_context_heap(ctx);
+  sexp p, end;
+  sexp_free_list q, r;
+  for ( ; h; h=h->next) {   /* just scan the whole heap */
+    p = sexp_heap_first_block(h);
+    q = h->free_list;
+    end = sexp_heap_end(h);
+    while (p < end) {
+      for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
+        ;
+      if ((char*)r == (char*)p) {
+        p = (sexp) (((char*)p) + r->size);
+        continue;
+      }
+      if (!sexp_markedp(p) && stack_references_pointer_p(ctx, p)) {
+#ifdef SEXP_USE_CONSERVATIVE_GC_PRESERVE_TAG
+        if (sexp_pointer_tag(p) == SEXP_USE_CONSERVATIVE_GC_PRESERVE_TAG)
+#endif
+        if (1) {
+#if SEXP_USE_DEBUG_GC > 3
+          if (p && sexp_pointerp(p)) {
+            fprintf(stderr, SEXP_BANNER("MISS: %p [%d]: %s"), p,
+                    sexp_pointer_tag(p), sexp_pointer_source(p));
+            sexp_print_gc_trace(ctx, p);
+            fflush(stderr);
+          }
+#endif
+          sexp_mark(ctx, p);
+        }
+      }
+      p = (sexp) (((char*)p)+sexp_heap_align(sexp_allocated_bytes(ctx, p)));
+    }
+  }
+}
+
+#else
+#define sexp_conservative_mark(ctx)
+#endif
+
+#if SEXP_USE_WEAK_REFERENCES
+void sexp_reset_weak_references(sexp ctx) {
+  int i, len, all_reset_p;
+  sexp_heap h = sexp_context_heap(ctx);
+  sexp p, t, end, *v;
+  sexp_free_list q, r;
+  for ( ; h; h=h->next) {   /* just scan the whole heap */
+    p = sexp_heap_first_block(h);
+    q = h->free_list;
+    end = sexp_heap_end(h);
+    while (p < end) {
+      /* find the preceding and succeeding free list pointers */
+      for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
+        ;
+      if ((char*)r == (char*)p) { /* this is a free block, skip it */
+        p = (sexp) (((char*)p) + r->size);
+        continue;
+      }
+      if (sexp_valid_object_p(ctx, p) && sexp_markedp(p)) {
+        t = sexp_object_type(ctx, p);
+        if (sexp_type_weak_base(t) > 0) {
+          all_reset_p = 1;
+          v = (sexp*) ((char*)p + sexp_type_weak_base(t));
+          len = sexp_type_num_weak_slots_of_object(t, p);
+          for (i=0; i<len; i++) {
+            if (v[i] && sexp_pointerp(v[i]) && ! sexp_markedp(v[i])) {
+              v[i] = SEXP_FALSE;
+              sexp_brokenp(p) = 1;
+            } else {
+              all_reset_p = 0;
+            }
+          }
+          if (all_reset_p) {      /* ephemerons */
+            len += sexp_type_weak_len_extra(t);
+            for ( ; i<len; i++) v[i] = SEXP_FALSE;
+          }
+        }
+      }
+      p = (sexp) (((char*)p)+sexp_heap_align(sexp_allocated_bytes(ctx, p)));
+    }
+  }
+}
+#else
+#define sexp_reset_weak_references(ctx)
+#endif
+
+sexp sexp_finalize (sexp ctx) {
+  size_t size;
+  sexp p, t, end;
+  sexp_free_list q, r;
+  sexp_proc2 finalizer;
+  sexp_sint_t finalize_count = 0;
+  sexp_heap h = sexp_context_heap(ctx);
+#if SEXP_USE_DL
+  sexp_sint_t free_dls = 0, pass = 0;
+ loop:
+#endif
+  /* scan over the whole heap */
+  for ( ; h; h=h->next) {
+    p = sexp_heap_first_block(h);
+    q = h->free_list;
+    end = sexp_heap_end(h);
+    while (p < end) {
+      /* find the preceding and succeeding free list pointers */
+      for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
+        ;
+      if ((char*)r == (char*)p) { /* this is a free block, skip it */
+        p = (sexp) (((char*)p) + r->size);
+        continue;
+      }
+      size = sexp_heap_align(sexp_allocated_bytes(ctx, p));
+      if (!sexp_markedp(p)) {
+        t = sexp_object_type(ctx, p);
+        finalizer = sexp_type_finalize(t);
+        if (finalizer) {
+          finalize_count++;
+#if SEXP_USE_DL
+          if (sexp_type_tag(t) == SEXP_DL && pass <= 0)
+            free_dls = 1;
+          else
+#endif
+            finalizer(ctx, NULL, 1, p);
+        }
+      }
+      p = (sexp) (((char*)p)+size);
+    }
+  }
+#if SEXP_USE_DL
+  if (free_dls && pass++ <= 0) goto loop;
+#endif
+  return sexp_make_fixnum(finalize_count);
+}
+
+sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) {
+  size_t freed, max_freed=0, sum_freed=0, size;
+  sexp_heap h = sexp_context_heap(ctx);
+  sexp p, end;
+  sexp_free_list q, r, s;
+  /* scan over the whole heap */
+  for ( ; h; h=h->next) {
+    p = sexp_heap_first_block(h);
+    q = h->free_list;
+    end = sexp_heap_end(h);
+    while (p < end) {
+      /* find the preceding and succeeding free list pointers */
+      for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
+        ;
+      if ((char*)r == (char*)p) { /* this is a free block, skip it */
+        p = (sexp) (((char*)p) + r->size);
+        continue;
+      }
+      size = sexp_heap_align(sexp_allocated_bytes(ctx, p));
+#if SEXP_USE_DEBUG_GC
+      if (!sexp_valid_object_p(ctx, p))
+        fprintf(stderr, SEXP_BANNER("%p sweep: invalid object at %p"), ctx, p);
+      if ((char*)q + q->size > (char*)p)
+        fprintf(stderr, SEXP_BANNER("%p sweep: bad size at %p < %p + %lu"),
+                ctx, p, q, q->size);
+      if (r && ((char*)p)+size > (char*)r)
+        fprintf(stderr, SEXP_BANNER("%p sweep: bad size at %p + %lu > %p"),
+                ctx, p, size, r);
+#endif
+      if (!sexp_markedp(p)) {
+        /* free p */
+        sum_freed += size;
+        if (((((char*)q) + q->size) == (char*)p) && (q != h->free_list)) {
+          /* merge q with p */
+          if (r && r->size && ((((char*)p)+size) == (char*)r)) {
+            /* ... and with r */
+            q->next = r->next;
+            freed = q->size + size + r->size;
+            p = (sexp) (((char*)p) + size + r->size);
+          } else {
+            freed = q->size + size;
+            p = (sexp) (((char*)p)+size);
+          }
+          q->size = freed;
+        } else {
+          s = (sexp_free_list)p;
+          if (r && r->size && ((((char*)p)+size) == (char*)r)) {
+            /* merge p with r */
+            s->size = size + r->size;
+            s->next = r->next;
+            q->next = s;
+            freed = size + r->size;
+          } else {
+            s->size = size;
+            s->next = r;
+            q->next = s;
+            freed = size;
+          }
+          p = (sexp) (((char*)p)+freed);
+        }
+        if (freed > max_freed)
+          max_freed = freed;
+      } else {
+        sexp_markedp(p) = 0;
+        p = (sexp) (((char*)p)+size);
+      }
+    }
+  }
+  if (sum_freed_ptr) *sum_freed_ptr = sum_freed;
+  return sexp_make_fixnum(max_freed);
+}
+
+#if SEXP_USE_GLOBAL_SYMBOLS
+void sexp_mark_global_symbols(sexp ctx) {
+  int i;
+  for (i=0; i<SEXP_SYMBOL_TABLE_SIZE; i++)
+    sexp_mark(ctx, sexp_symbol_table[i]);
+}
+#else
+#define sexp_mark_global_symbols(ctx)
+#endif
+
+sexp sexp_gc (sexp ctx, size_t *sum_freed) {
+  sexp res, finalized SEXP_NO_WARN_UNUSED;
+  sexp_debug_printf("%p (heap: %p size: %lu)", ctx, sexp_context_heap(ctx),
+                    sexp_heap_total_size(sexp_context_heap(ctx)));
+  sexp_mark_global_symbols(ctx);
+  sexp_mark(ctx, ctx);
+  sexp_conservative_mark(ctx);
+  sexp_reset_weak_references(ctx);
+  finalized = sexp_finalize(ctx);
+  res = sexp_sweep(ctx, sum_freed);
+  sexp_debug_printf("%p (freed: %lu max_freed: %lu finalized: %lu)", ctx,
+                    (sum_freed ? *sum_freed : 0), sexp_unbox_fixnum(res),
+                    sexp_unbox_fixnum(finalized));
+  return res;
+}
+
+sexp_heap sexp_make_heap (size_t size, size_t max_size) {
+  sexp_free_list free, next;
+  sexp_heap h;
+#if SEXP_USE_MMAP_GC
+  h =  mmap(NULL, sexp_heap_pad_size(size), PROT_READ|PROT_WRITE|PROT_EXEC,
+            MAP_ANON|MAP_PRIVATE, 0, 0);
+#else
+  h =  sexp_malloc(sexp_heap_pad_size(size));
+#endif
+  if (! h) return NULL;
+  h->size = size;
+  h->max_size = max_size;
+  h->data = (char*) sexp_heap_align(sizeof(h->data)+(sexp_uint_t)&(h->data));
+  free = h->free_list = (sexp_free_list) h->data;
+  h->next = NULL;
+  next = (sexp_free_list) (((char*)free)+sexp_heap_align(sexp_free_chunk_size));
+  free->size = 0; /* actually sexp_heap_align(sexp_free_chunk_size) */
+  free->next = next;
+  next->size = size - sexp_heap_align(sexp_free_chunk_size);
+  next->next = NULL;
+#if SEXP_USE_DEBUG_GC
+  fprintf(stderr, SEXP_BANNER("heap: %p-%p data: %p-%p"),
+          h, ((char*)h)+sexp_heap_pad_size(size), h->data, h->data + size);
+  fprintf(stderr, SEXP_BANNER("first: %p end: %p"),
+          sexp_heap_first_block(h), sexp_heap_end(h));
+  fprintf(stderr, SEXP_BANNER("free1: %p-%p free2: %p-%p"),
+          free, ((char*)free)+free->size, next, ((char*)next)+next->size);
+#endif
+  return h;
+}
+
+int sexp_grow_heap (sexp ctx, size_t size) {
+  size_t cur_size, new_size;
+  sexp_heap h = sexp_heap_last(sexp_context_heap(ctx));
+  cur_size = h->size;
+  new_size = sexp_heap_align(((cur_size > size) ? cur_size : size) * 2);
+  h->next = sexp_make_heap(new_size, h->max_size);
+  return (h->next != NULL);
+}
+
+void* sexp_try_alloc (sexp ctx, size_t size) {
+  sexp_free_list ls1, ls2, ls3;
+  sexp_heap h;
+  for (h=sexp_context_heap(ctx); h; h=h->next)
+    for (ls1=h->free_list, ls2=ls1->next; ls2; ls1=ls2, ls2=ls2->next)
+      if (ls2->size >= size) {
+#if SEXP_USE_DEBUG_GC
+        ls3 = (sexp_free_list) sexp_heap_end(h);
+        if (ls2 >= ls3)
+          fprintf(stderr, "alloced %lu bytes past end of heap: %p (%lu) >= %p"
+                  " next: %p (%lu)\n", size, ls2, ls2->size, ls3, ls2->next,
+                  (ls2->next ? ls2->next->size : 0));
+#endif
+        if (ls2->size >= (size + SEXP_MINIMUM_OBJECT_SIZE)) {
+          ls3 = (sexp_free_list) (((char*)ls2)+size); /* the tail after ls2 */
+          ls3->size = ls2->size - size;
+          ls3->next = ls2->next;
+          ls1->next = ls3;
+        } else {                  /* take the whole chunk */
+          ls1->next = ls2->next;
+        }
+        memset((void*)ls2, 0, size);
+        return ls2;
+      }
+  return NULL;
+}
+
+void* sexp_alloc (sexp ctx, size_t size) {
+  void *res;
+  size_t max_freed, sum_freed, total_size;
+  sexp_heap h = sexp_context_heap(ctx);
+  size = sexp_heap_align(size) + SEXP_GC_PAD;
+  res = sexp_try_alloc(ctx, size);
+  if (! res) {
+    max_freed = sexp_unbox_fixnum(sexp_gc(ctx, &sum_freed));
+    total_size = sexp_heap_total_size(sexp_context_heap(ctx));
+    if (((max_freed < size)
+         || ((total_size > sum_freed)
+             && (total_size - sum_freed) > (total_size*SEXP_GROW_HEAP_RATIO)))
+        && ((!h->max_size) || (total_size < h->max_size)))
+      sexp_grow_heap(ctx, size);
+    res = sexp_try_alloc(ctx, size);
+    if (! res) {
+      res = sexp_global(ctx, SEXP_G_OOM_ERROR);
+      sexp_debug_printf("ran out of memory allocating %lu bytes => %p", size, res);
+    }
+  }
+  return res;
+}
+
+#if ! SEXP_USE_GLOBAL_HEAP
+
+void sexp_offset_heap_pointers (sexp_heap heap, sexp_heap from_heap, sexp* types, sexp flags) {
+  sexp_sint_t i, off, len, freep, loadp;
+  sexp_free_list q;
+  sexp p, t, end, *v;
+#if SEXP_USE_DL
+  sexp name;
+#endif
+  freep = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_FREEP);
+  loadp = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_LOADP);
+
+  off = (sexp_sint_t)((sexp_sint_t)heap - (sexp_sint_t)from_heap);
+  heap->data += off;
+  end = (sexp) (heap->data + heap->size);
+
+  /* adjust the free list */
+  heap->free_list = (sexp_free_list) ((char*)heap->free_list + off);
+  for (q=heap->free_list; q->next; q=q->next)
+    q->next = (sexp_free_list) ((char*)q->next + off);
+
+  /* adjust data by traversing over the new heap */
+  p = (sexp) (heap->data + sexp_heap_align(sexp_free_chunk_size));
+  q = heap->free_list;
+  while (p < end) {
+    /* find the next free list pointer */
+    for ( ; q && ((char*)q < (char*)p); q=q->next)
+      ;
+    if ((char*)q == (char*)p) { /* this is a free block, skip it */
+      p = (sexp) (((char*)p) + q->size);
+    } else {
+      t = (sexp)((char*)(types[sexp_pointer_tag(p)])
+                 + ((char*)types > (char*)p ? off : 0));
+      len = sexp_type_num_slots_of_object(t, p);
+      v = (sexp*) ((char*)p + sexp_type_field_base(t));
+      /* offset any pointers in the _destination_ heap */
+      for (i=0; i<len; i++)
+        if (v[i] && sexp_pointerp(v[i]))
+          v[i] = (sexp) ((char*)v[i] + off);
+      /* don't free unless specified - only the original cleans up */
+      if (! freep)
+        sexp_freep(p) = 0;
+      /* adjust context heaps, don't copy saved sexp_gc_vars */
+      if (sexp_contextp(p)) {
+#if SEXP_USE_GREEN_THREADS
+        sexp_context_ip(p) += off;
+#endif
+        sexp_context_last_fp(p) += off;
+        sexp_stack_top(sexp_context_stack(p)) = 0;
+        sexp_context_saves(p) = NULL;
+        sexp_context_heap(p) = heap;
+      } else if (sexp_bytecodep(p) && off != 0) {
+        for (i=0; i<sexp_bytecode_length(p); ) {
+          switch (sexp_bytecode_data(p)[i++]) {
+            case SEXP_OP_FCALL0:      case SEXP_OP_FCALL1:
+            case SEXP_OP_FCALL2:      case SEXP_OP_FCALL3:
+            case SEXP_OP_FCALL4:      case SEXP_OP_CALL:
+            case SEXP_OP_TAIL_CALL:   case SEXP_OP_PUSH:
+            case SEXP_OP_GLOBAL_REF:  case SEXP_OP_GLOBAL_KNOWN_REF:
+#if SEXP_USE_GREEN_THREADS
+            case SEXP_OP_PARAMETER_REF:
+#endif
+#if SEXP_USE_EXTENDED_FCALL
+            case SEXP_OP_FCALLN:
+#endif
+              v = (sexp*)(&(sexp_bytecode_data(p)[i]));
+              if (v[0] && sexp_pointerp(v[0])) v[0] = (sexp) (((char*)v[0]) + off);
+              /* ... FALLTHROUGH ... */
+            case SEXP_OP_JUMP:        case SEXP_OP_JUMP_UNLESS:
+            case SEXP_OP_STACK_REF:   case SEXP_OP_CLOSURE_REF:
+            case SEXP_OP_LOCAL_REF:   case SEXP_OP_LOCAL_SET:
+            case SEXP_OP_TYPEP:
+#if SEXP_USE_RESERVE_OPCODE
+            case SEXP_OP_RESERVE:
+#endif
+              i += sizeof(sexp); break;
+            case SEXP_OP_MAKE: case SEXP_OP_SLOT_REF: case SEXP_OP_SLOT_SET:
+              i += 2*sizeof(sexp); break;
+            case SEXP_OP_MAKE_PROCEDURE:
+              v = (sexp*)(&(sexp_bytecode_data(p)[i]));
+              if (v[2] && sexp_pointerp(v[2])) v[2] = (sexp) (((char*)v[2]) + off);
+              i += 3*sizeof(sexp); break;
+          }
+        }
+      } else if (sexp_portp(p) && sexp_port_stream(p)) {
+        sexp_port_stream(p) = 0;
+        sexp_port_openp(p) = 0;
+        sexp_freep(p) = 0;
+#if SEXP_USE_DL
+      } else if (loadp && sexp_dlp(p)) {
+        sexp_dl_handle(p) = NULL;
+#endif
+      }
+      p = (sexp) (((char*)p)+sexp_heap_align(sexp_type_size_of_object(t, p))+SEXP_GC_PAD);
+    }
+  }
+
+  /* make a second pass to fix code references */
+  if (loadp) {
+    p = (sexp) (heap->data + sexp_heap_align(sexp_free_chunk_size));
+    q = heap->free_list;
+    while (p < end) {
+      /* find the next free list pointer */
+      for ( ; q && ((char*)q < (char*)p); q=q->next)
+        ;
+      if ((char*)q == (char*)p) { /* this is a free block, skip it */
+        p = (sexp) (((char*)p) + q->size);
+      } else {
+#if SEXP_USE_DL
+        if (sexp_opcodep(p) && sexp_opcode_func(p)) {
+          name = (sexp_opcode_data2(p) && sexp_stringp(sexp_opcode_data2(p))) ? sexp_opcode_data2(p) : sexp_opcode_name(p);
+          if (sexp_dlp(sexp_opcode_dl(p))) {
+            if (!sexp_dl_handle(sexp_opcode_dl(p)))
+              sexp_dl_handle(sexp_opcode_dl(p)) = dlopen(sexp_string_data(sexp_dl_file(sexp_opcode_dl(p))), RTLD_LAZY);
+            sexp_opcode_func(p) = dlsym(sexp_dl_handle(sexp_opcode_dl(p)), sexp_string_data(name));
+          } else {
+            sexp_opcode_func(p) = dlsym(SEXP_RTLD_DEFAULT, sexp_string_data(name));
+          }
+        } else
+#endif
+        if (sexp_typep(p)) {
+          if (sexp_type_finalize(p)) {
+            /* TODO: handle arbitrary finalizers in images */
+#if SEXP_USE_DL
+            if (sexp_type_tag(p) == SEXP_DL)
+              sexp_type_finalize(p) = SEXP_FINALIZE_DL;
+            else
+#endif
+              sexp_type_finalize(p) = SEXP_FINALIZE_PORT;
+          }
+        }
+        t = types[sexp_pointer_tag(p)];
+        p = (sexp) (((char*)p)+sexp_heap_align(sexp_type_size_of_object(t, p)+SEXP_GC_PAD));
+      }
+    }
+  }
+}
+
+sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) {
+  sexp_sint_t off;
+  sexp_heap to, from = sexp_context_heap(ctx);
+
+  /* validate input, creating a new heap if needed */
+  if (from->next) {
+    return sexp_user_exception(ctx, NULL, "can't copy a non-contiguous heap", ctx);
+  } else if (! dst || sexp_not(dst)) {
+    to = sexp_make_heap(from->size, from->max_size);
+    if (!to) return sexp_global(ctx, SEXP_G_OOM_ERROR);
+    dst = (sexp) ((char*)ctx + ((char*)to - (char*)from));
+  } else if (! sexp_contextp(dst)) {
+    return sexp_type_exception(ctx, NULL, SEXP_CONTEXT, dst);
+  } else if (sexp_context_heap(dst)->size < from->size) {
+    return sexp_user_exception(ctx, NULL, "destination context too small", dst);
+  } else {
+    to = sexp_context_heap(dst);
+  }
+
+  /* copy the raw data */
+  off = (char*)to - (char*)from;
+  memcpy(to, from, sexp_heap_pad_size(from->size));
+
+  /* adjust the pointers */
+  sexp_offset_heap_pointers(to, from, sexp_context_types(ctx) + off, flags);
+
+  return dst;
+}
+
+#endif
+
+void sexp_gc_init (void) {
+#if SEXP_USE_GLOBAL_HEAP || SEXP_USE_CONSERVATIVE_GC
+  sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE);
+#endif
+#if SEXP_USE_GLOBAL_HEAP
+  sexp_global_heap = sexp_make_heap(size, SEXP_MAXIMUM_HEAP_SIZE);
+#endif
+#if SEXP_USE_CONSERVATIVE_GC
+  /* the +32 is a hack, but this is just for debugging anyway */
+  stack_base = ((sexp*)&size) + 32;
+#endif
+}
+
+#endif

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,271 @@
+/*  eval.h -- headers for eval library                        */
+/*  Copyright (c) 2009-2011 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#ifndef SEXP_EVAL_H
+#define SEXP_EVAL_H
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#include "chibi/sexp.h"
+
+/************************* additional types ***************************/
+
+#define sexp_init_file "init-"
+#define sexp_init_file_suffix ".scm"
+#define sexp_meta_file "meta-7.scm"
+#define sexp_leap_seconds_file "leap.txt"
+
+enum sexp_core_form_names {
+  SEXP_CORE_DEFINE = 1,
+  SEXP_CORE_SET,
+  SEXP_CORE_LAMBDA,
+  SEXP_CORE_IF,
+  SEXP_CORE_BEGIN,
+  SEXP_CORE_QUOTE,
+  SEXP_CORE_SYNTAX_QUOTE,
+  SEXP_CORE_DEFINE_SYNTAX,
+  SEXP_CORE_LET_SYNTAX,
+  SEXP_CORE_LETREC_SYNTAX
+};
+
+enum sexp_opcode_classes {
+  SEXP_OPC_GENERIC = 1,
+  SEXP_OPC_TYPE_PREDICATE,
+  SEXP_OPC_PREDICATE,
+  SEXP_OPC_ARITHMETIC,
+  SEXP_OPC_ARITHMETIC_CMP,
+  SEXP_OPC_IO,
+  SEXP_OPC_CONSTRUCTOR,
+  SEXP_OPC_GETTER,
+  SEXP_OPC_SETTER,
+  SEXP_OPC_PARAMETER,
+  SEXP_OPC_FOREIGN,
+  SEXP_OPC_NUM_OP_CLASSES
+};
+
+SEXP_API struct sexp_opcode_struct* sexp_primitive_opcodes;
+
+#if SEXP_USE_DEBUG_VM || SEXP_USE_PROFILE_VM || SEXP_USE_STATIC_LIBS
+SEXP_API const char** sexp_opcode_names;
+#endif
+
+/**************************** prototypes ******************************/
+
+SEXP_API void sexp_warn (sexp ctx, const char *msg, sexp x);
+SEXP_API void sexp_scheme_init (void);
+SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env, sexp_uint_t size, sexp_uint_t max_size);
+SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda);
+SEXP_API sexp sexp_compile_error (sexp ctx, const char *message, sexp obj);
+SEXP_API sexp sexp_maybe_wrap_error (sexp ctx, sexp obj);
+SEXP_API sexp sexp_analyze (sexp context, sexp x);
+SEXP_API sexp sexp_simplify (sexp ctx, sexp self, sexp_sint_t n, sexp ast);
+SEXP_API sexp sexp_make_lambda (sexp ctx, sexp params);
+SEXP_API sexp sexp_make_ref (sexp ctx, sexp name, sexp cell);
+SEXP_API void sexp_generate (sexp ctx, sexp name, sexp loc, sexp lam, sexp x);
+SEXP_API void sexp_emit (sexp ctx, unsigned char c);
+SEXP_API void sexp_emit_return (sexp ctx);
+#if SEXP_USE_NATIVE_X86
+SEXP_API void sexp_emit_enter (sexp ctx);
+SEXP_API void sexp_bless_bytecode (sexp ctx, sexp bc);
+#else
+#define sexp_emit_enter(ctx)
+#define sexp_bless_bytecode(ctx, bc)
+#endif
+SEXP_API sexp sexp_complete_bytecode (sexp ctx);
+SEXP_API void sexp_shrink_bcode (sexp ctx, sexp_uint_t i);
+SEXP_API void sexp_expand_bcode (sexp ctx, sexp_uint_t size);
+SEXP_API void sexp_stack_trace (sexp ctx, sexp out);
+SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv);
+SEXP_API int sexp_param_index (sexp ctx, sexp lambda, sexp name);
+SEXP_API sexp sexp_compile_op (sexp context, sexp self, sexp_sint_t n, sexp obj, sexp env);
+SEXP_API sexp sexp_generate_op (sexp context, sexp self, sexp_sint_t n, sexp obj, sexp env);
+SEXP_API sexp sexp_eval_op (sexp context, sexp self, sexp_sint_t n, sexp obj, sexp env);
+SEXP_API sexp sexp_eval_string (sexp context, const char *str, sexp_sint_t len, sexp env);
+SEXP_API sexp sexp_load_op (sexp context, sexp self, sexp_sint_t n, sexp expr, sexp env);
+SEXP_API sexp sexp_exception_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn);
+SEXP_API sexp sexp_make_env_op (sexp context, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_make_null_env_op (sexp context, sexp self, sexp_sint_t n, sexp version);
+SEXP_API sexp sexp_env_cell_define (sexp ctx, sexp env, sexp name, sexp value, sexp* varenv);
+SEXP_API sexp sexp_make_primitive_env_op (sexp context, sexp self, sexp_sint_t n, sexp version);
+SEXP_API sexp sexp_make_standard_env_op (sexp context, sexp self, sexp_sint_t n, sexp version);
+SEXP_API void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value);
+SEXP_API sexp sexp_load_standard_ports (sexp context, sexp env, FILE* in, FILE* out, FILE* err, int no_close);
+SEXP_API sexp sexp_load_standard_env (sexp context, sexp env, sexp version);
+SEXP_API sexp sexp_find_module_file (sexp ctx, const char *file);
+SEXP_API sexp sexp_load_module_file (sexp ctx, const char *file, sexp env);
+SEXP_API sexp sexp_current_module_path_op (sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_find_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file);
+SEXP_API sexp sexp_load_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file, sexp env);
+SEXP_API sexp sexp_add_module_directory_op (sexp ctx, sexp self, sexp_sint_t n, sexp dir, sexp appendp);
+SEXP_API sexp sexp_current_environment (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_set_current_environment (sexp ctx, sexp self, sexp_sint_t n, sexp env);
+SEXP_API sexp sexp_meta_environment (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value);
+SEXP_API sexp sexp_env_import_op (sexp ctx, sexp self, sexp_sint_t n, sexp to, sexp from, sexp ls, sexp immutp);
+SEXP_API sexp sexp_env_exports_op (sexp ctx, sexp self, sexp_sint_t n, sexp env);
+SEXP_API sexp sexp_identifierp_op(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_identifier_eq_op(sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b, sexp c, sexp d);
+SEXP_API sexp sexp_make_synclo_op(sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp fv, sexp expr);
+SEXP_API sexp sexp_strip_synclos(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_syntactic_closure_expr_op(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_open_input_file_op(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_open_output_file_op(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_open_binary_input_file(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_open_binary_output_file(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_close_port_op(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_set_port_line_op (sexp ctx, sexp self, sexp_sint_t n, sexp port, sexp line);
+SEXP_API sexp sexp_env_define (sexp ctx, sexp env, sexp sym, sexp val);
+SEXP_API sexp sexp_env_cell (sexp ctx, sexp env, sexp sym, int localp);
+SEXP_API sexp sexp_env_ref (sexp ctx, sexp env, sexp sym, sexp dflt);
+SEXP_API sexp sexp_env_parent_op (sexp ctx, sexp self, sexp_sint_t n, sexp env);
+SEXP_API sexp sexp_parameter_ref (sexp ctx, sexp param);
+#if SEXP_USE_RENAME_BINDINGS
+SEXP_API sexp sexp_env_rename (sexp ctx, sexp env, sexp key, sexp value);
+#endif
+SEXP_API sexp sexp_warn_undefs_op (sexp ctx, sexp self, sexp_sint_t n, sexp from, sexp to, sexp res);
+SEXP_API sexp sexp_make_lit (sexp ctx, sexp value);
+SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1);
+SEXP_API sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags, sexp num_args, sexp bc, sexp vars);
+SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data);
+SEXP_API sexp sexp_register_optimization(sexp ctx, sexp self, sexp_sint_t n, sexp f, sexp i);
+#if SEXP_USE_AUTO_FORCE
+SEXP_API sexp sexp_make_promise (sexp ctx, sexp self, sexp_sint_t n, sexp done, sexp val);
+#endif
+#if SEXP_USE_UTF8_STRINGS
+SEXP_API sexp sexp_read_utf8_char (sexp ctx, sexp port, int i);
+SEXP_API void sexp_string_utf8_set (sexp ctx, sexp str, sexp index, sexp ch);
+SEXP_API sexp sexp_string_utf8_index_ref (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i);
+SEXP_API sexp sexp_string_utf8_index_set (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i, sexp ch);
+#endif
+#if SEXP_USE_GREEN_THREADS
+SEXP_API sexp sexp_dk (sexp ctx, sexp self, sexp_sint_t n, sexp val);
+#endif
+SEXP_API sexp sexp_thread_parameters (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_thread_parameters_set (sexp ctx, sexp self, sexp_sint_t n, sexp val);
+SEXP_API sexp sexp_string_cmp_op (sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b, sexp ci);
+#if SEXP_USE_RATIOS
+SEXP_API sexp sexp_ratio_numerator_op (sexp ctx, sexp self, sexp_sint_t n, sexp rat);
+SEXP_API sexp sexp_ratio_denominator_op (sexp ctx, sexp self, sexp_sint_t n, sexp rat);
+#endif
+#if SEXP_USE_COMPLEX
+SEXP_API sexp sexp_complex_real_op (sexp ctx, sexp self, sexp_sint_t n, sexp rat);
+SEXP_API sexp sexp_complex_imag_op (sexp ctx, sexp self, sexp_sint_t n, sexp rat);
+#endif
+#if SEXP_USE_PROFILE_VM
+SEXP_API sexp sexp_reset_vm_profile (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_print_vm_profile (sexp ctx, sexp self, sexp_sint_t n);
+#endif
+
+#if SEXP_USE_MATH
+SEXP_API sexp sexp_exp(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_log(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_sin(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_cos(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_tan(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_asin(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_acos(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_atan(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_sqrt(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_exact_sqrt(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_inexact_sqrt(sexp ctx, sexp self, sexp_sint_t n, sexp z);
+SEXP_API sexp sexp_round(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_trunc(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_floor(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_ceiling(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+#endif
+SEXP_API sexp sexp_expt_op(sexp ctx, sexp self, sexp_sint_t n, sexp z1, sexp z2);
+SEXP_API sexp sexp_exact_to_inexact(sexp ctx, sexp self, sexp_sint_t n, sexp i);
+SEXP_API sexp sexp_inexact_to_exact(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+
+#if SEXP_USE_NATIVE_X86
+SEXP_API sexp sexp_write_char_op(sexp ctx, sexp self, sexp_sint_t n, sexp ch, sexp out);
+SEXP_API sexp sexp_newline_op(sexp ctx, sexp self, sexp_sint_t n, sexp out);
+SEXP_API sexp sexp_read_char_op(sexp ctx, sexp self, sexp_sint_t n, sexp in);
+SEXP_API sexp sexp_peek_char_op(sexp ctx, sexp self, sexp_sint_t n, sexp in);
+SEXP_API sexp sexp_char_upcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch);
+SEXP_API sexp sexp_char_downcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch);
+#endif
+
+#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(sexp_proc1)f,NULL)
+#define sexp_define_foreign_opt(c,e,s,n,f,d) sexp_define_foreign_aux(c,e,s,n,1,(sexp_proc1)f,d)
+
+SEXP_API sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_args, sexp_proc1 f, const char *param);
+
+#define sexp_env_key(x) sexp_car(x)
+#define sexp_env_value(x) sexp_cdr(x)
+#define sexp_env_next_cell(x) sexp_pair_source(x)
+#define sexp_env_push(ctx, env, tmp, name, value) (tmp=sexp_cons(ctx,name,value), sexp_env_next_cell(tmp)=sexp_env_bindings(env), sexp_env_bindings(env)=tmp)
+#define sexp_env_push_rename(ctx, env, tmp, name, value) (tmp=sexp_cons(ctx,name,value), sexp_env_next_cell(tmp)=sexp_env_renames(env), sexp_env_renames(env)=tmp)
+
+#if SEXP_USE_TYPE_DEFS
+SEXP_API sexp sexp_make_type_predicate_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type);
+SEXP_API sexp sexp_make_constructor_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type);
+SEXP_API sexp sexp_make_getter_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type, sexp index);
+SEXP_API sexp sexp_make_setter_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type, sexp index);
+SEXP_API sexp sexp_type_slot_offset_op (sexp ctx, sexp self, sexp_sint_t n, sexp type, sexp index);
+#endif
+
+#ifdef PLAN9
+SEXP_API sexp sexp_rand (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_srand (sexp ctx, sexp self, sexp_sint_t n, sexp seed);
+SEXP_API sexp sexp_file_exists_p (sexp ctx, sexp self, sexp_sint_t n, sexp path);
+SEXP_API sexp sexp_fdopen (sexp ctx, sexp self, sexp_sint_t n, sexp fd, sexp mode);
+SEXP_API sexp sexp_fileno (sexp ctx, sexp self, sexp_sint_t n, sexp port);
+SEXP_API sexp sexp_fork (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_exec (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp args);
+SEXP_API void sexp_exits (sexp ctx, sexp self, sexp_sint_t n, sexp msg);
+SEXP_API sexp sexp_dup (sexp ctx, sexp self, sexp_sint_t n, sexp oldfd, sexp newfd);
+SEXP_API sexp sexp_pipe (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_sleep (sexp ctx, sexp self, sexp_sint_t n, sexp msecs);
+SEXP_API sexp sexp_getenv (sexp ctx, sexp self, sexp_sint_t n, sexp name);
+SEXP_API sexp sexp_getwd (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_chdir (sexp ctx, sexp self, sexp_sint_t n, sexp path);
+SEXP_API sexp sexp_getuser (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_sysname (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_wait (sexp ctx, sexp self, sexp_sint_t n);
+SEXP_API sexp sexp_postnote (sexp ctx, sexp self, sexp_sint_t n, sexp pid, sexp note);
+SEXP_API sexp sexp_postmountsrv (sexp ctx, sexp self, sexp_sint_t n, sexp ls, sexp name, sexp mtpt, sexp flags);
+SEXP_API sexp sexp_9p_req_offset (sexp ctx, sexp self, sexp_sint_t n, sexp req);
+SEXP_API sexp sexp_9p_req_count (sexp ctx, sexp self, sexp_sint_t n, sexp req);
+SEXP_API sexp sexp_9p_req_fid (sexp ctx, sexp self, sexp_sint_t n, sexp req);
+SEXP_API sexp sexp_9p_req_newfid (sexp ctx, sexp self, sexp_sint_t n, sexp req);
+SEXP_API sexp sexp_9p_respond (sexp ctx, sexp self, sexp_sint_t n, sexp req, sexp err);
+SEXP_API sexp sexp_9p_responderror (sexp ctx, sexp self, sexp_sint_t n, sexp req);
+#else
+SEXP_API sexp sexp_get_port_fileno (sexp ctx, sexp self, sexp_sint_t n, sexp port);
+#endif
+
+#if SEXP_USE_SIMPLIFY
+SEXP_API int sexp_rest_unused_p (sexp lambda);
+#else
+#define sexp_rest_unused_p(lambda) 0
+#endif
+
+/* simplify primitive API interface */
+#define sexp_make_synclo(ctx, a, b, c) sexp_make_synclo_op(ctx, NULL, 3, a, b, c)
+#define sexp_make_procedure(ctx, f, n, b, v) sexp_make_procedure_op(ctx, NULL, 4, f, n, b, v)
+#define sexp_make_env(ctx) sexp_make_env_op(ctx, NULL, 0)
+#define sexp_make_null_env(ctx, v) sexp_make_null_env_op(ctx, NULL, 0, v)
+#define sexp_make_primitive_env(ctx, v) sexp_make_primitive_env_op(ctx, NULL, 1, v)
+#define sexp_make_standard_env(ctx, v) sexp_make_standard_env_op(ctx, NULL, 1, v)
+#define sexp_add_module_directory(ctx, d, a) sexp_add_module_directory_op(ctx, NULL, 1, d, a)
+#define sexp_eval(ctx, x, e) sexp_eval_op(ctx, NULL, 2, x, e)
+#define sexp_load(ctx, f, e) sexp_load_op(ctx, NULL, 2, f, e)
+#define sexp_env_import(ctx, a, b, c, d) sexp_env_import_op(ctx, NULL, 4, a, b, c, d)
+#define sexp_identifierp(ctx, x) sexp_identifierp_op(ctx, NULL, 1, x)
+#define sexp_identifier_to_symbol(ctx, x) sexp_syntactic_closure_expr_op(ctx, NULL, 1, x)
+#define sexp_identifier_eq(ctx, a, b, c, d) sexp_identifier_eq_op(ctx, NULL, 4, a, b, c, d)
+#define sexp_open_input_file(ctx, x) sexp_open_input_file_op(ctx, NULL, 1, x)
+#define sexp_open_output_file(ctx, x) sexp_open_output_file_op(ctx, NULL, 1, x)
+#define sexp_close_port(ctx, x) sexp_close_port_op(ctx, NULL, 1, x)
+#define sexp_warn_undefs(ctx, from, to, res) sexp_warn_undefs_op(ctx, NULL, 3, from, to, res)
+#define sexp_string_cmp(ctx, a, b, c) sexp_string_cmp_op(ctx, NULL, 3, a, b, c)
+
+#ifdef __cplusplus
+} /* extern "C" */
+#endif
+
+#endif /* ! SEXP_EVAL_H */

include/chibi/features.h

@@ -0,0 +1,835 @@
+/*  features.h -- general feature configuration               */
+/*  Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+/* uncomment this to disable most features */
+/*   Most features are enabled by default, but setting this */
+/*   option will disable any not explicitly enabled. */
+/* #define SEXP_USE_NO_FEATURES 1 */
+
+/* uncomment this to disable interpreter-based threads */
+/* #define SEXP_USE_GREEN_THREADS 0 */
+
+/* uncomment this to enable the experimental native x86 backend */
+/* #define SEXP_USE_NATIVE_X86 1 */
+
+/* uncomment this to disable the module system */
+/*   Currently this just loads the meta.scm from main and */
+/*   sets up an (import (module name)) macro. */
+/* #define SEXP_USE_MODULES 0 */
+
+/* uncomment this to disable dynamic loading */
+/*   If enabled, you can LOAD .so files with a */
+/*   sexp_init_library(ctx, env) function provided. */
+/* #define SEXP_USE_DL 0 */
+
+/* uncomment this to statically compile all C libs */
+/*   If set, this will statically include the clibs.c file */
+/*   into the standard environment, so that you can have */
+/*   access to a predefined set of C libraries without */
+/*   needing dynamic loading.  The clibs.c file is generated */
+/*   automatically by searching the lib directory for */
+/*   modules with include-shared, but can be hand-tailored */
+/*   to your needs. */
+/* #define SEXP_USE_STATIC_LIBS 1 */
+
+/* uncomment this to disable detailed source info for debugging */
+/*   By default Chibi will associate source info with every */
+/*   bytecode offset.  By disabling this only lambda-level source */
+/*   info will be recorded (the line of the opening paren for the */
+/*   lambda). */
+/* #define SEXP_USE_FULL_SOURCE_INFO 0 */
+
+/* uncomment this to disable a simplifying optimization pass */
+/*   This performs some simple optimizations such as dead-code */
+/*   elimination, constant-folding, and directly propagating */
+/*   non-mutated let values bound to constants or non-mutated */
+/*   references.  More than performance, this is aimed at reducing the */
+/*   size of the compiled code, especially as the result of macro */
+/*   expansions, so it's a good idea to leave it enabled. */
+/* #define SEXP_USE_SIMPLIFY 0 */
+
+/* uncomment this to disable dynamic type definitions */
+/*   This enables register-simple-type and related */
+/*   opcodes for defining types, needed by the default */
+/*   implementation of (srfi 9). */
+/* #define SEXP_USE_TYPE_DEFS 0 */
+
+/* uncomment this to use the Boehm conservative GC */
+/*   Conservative GCs make it easier to write extensions, */
+/*   since you don't have to keep track of intermediate */
+/*   variables, but can leak memory.  Boehm is also a */
+/*   very large library to link in.  You may want to */
+/*   enable this when debugging your own extensions, or */
+/*   if you suspect a bug in the native GC. */
+/* #define SEXP_USE_BOEHM 1 */
+
+/* uncomment this to disable weak references */
+/* #define SEXP_USE_WEAK_REFERENCES 0 */
+
+/* uncomment this to just malloc manually instead of any GC */
+/*   Mostly for debugging purposes, this is the no GC option. */
+/*   You can use just the read/write API and */
+/*   explicitly free sexps, though. */
+/* #define SEXP_USE_MALLOC 1 */
+
+/* uncomment this to allocate heaps with mmap instead of malloc */
+/* #define SEXP_USE_MMAP_GC 1 */
+
+/* uncomment this to add conservative checks to the native GC */
+/*   Please mail the author if enabling this makes a bug */
+/*   go away and you're not working on your own C extension. */
+/* #define SEXP_USE_CONSERVATIVE_GC 1 */
+
+/* uncomment this to add additional native checks to only mark objects in the heap */
+/* #define SEXP_USE_SAFE_GC_MARK 1 */
+
+/* uncomment this to track what C source line each object is allocated from */
+/* #define SEXP_USE_TRACK_ALLOC_SOURCE 1 */
+
+/* uncomment this to take a short backtrace of where each object is */
+/* allocated from */
+/* #define SEXP_USE_TRACK_ALLOC_BACKTRACE 1 */
+
+/* uncomment this to add additional native gc checks to verify a magic header */
+/* #define SEXP_USE_HEADER_MAGIC 1 */
+
+/* uncomment this to add very verbose debugging stats to the native GC */
+/* #define SEXP_USE_DEBUG_GC 1 */
+
+/* uncomment this to enable "safe" field accessors for primitive types */
+/*   The sexp union type fields are abstracted away with macros of the */
+/*   form sexp_<type>_<field>(<obj>), however these are just convenience */
+/*   macros equivalent to directly accessing the union field, and will */
+/*   return incorrect results (or segfault) if <obj> isn't of the correct */
+/*   <type>.  Thus you're required to check the types manually before */
+/*   accessing them.  However, to detect errors earlier you can enable */
+/*   SEXP_USE_SAFE_ACCESSORS, and on invalid accesses chibi will print */
+/*   a friendly error message and immediately segfault itself so you */
+/*   can see where the invalid access was made. */
+/*   Note this is only intended for debugging, and mostly for user code. */
+/*   If you want to build chibi itself with this option, compilation */
+/*   may be very slow and using CFLAGS=-O0 is recommended. */
+/* #define SEXP_USE_SAFE_ACCESSORS 1 */
+
+/* uncomment to install a default signal handler in main() for segfaults */
+/*   This will print a helpful backtrace. */
+/* #define SEXP_USE_PRINT_BACKTRACE_ON_SEGFAULT 1 */
+
+/* uncomment this to make the heap common to all contexts */
+/*   By default separate contexts can have separate heaps, */
+/*   and are thus thread-safe and independant. */
+/* #define SEXP_USE_GLOBAL_HEAP 1 */
+
+/* uncomment this to make the symbol table common to all contexts */
+/*   Will still be restricted to all contexts sharing the same */
+/*   heap, of course. */
+/* #define SEXP_USE_GLOBAL_SYMBOLS 1 */
+
+/* uncomment this to disable foreign function bindings with > 6 args */
+/* #define SEXP_USE_EXTENDED_FCALL 0 */
+
+/* uncomment this if you don't need flonum support */
+/*   This is only for EVAL - you'll still be able to read */
+/*   and write flonums directly through the sexp API. */
+/* #define SEXP_USE_FLONUMS 0 */
+
+/* uncomment this to disable reading/writing IEEE infinities */
+/*   By default you can read/write +inf.0, -inf.0 and +nan.0 */
+/* #define SEXP_USE_INFINITIES 0 */
+
+/* uncomment this if you want immediate flonums */
+/*   This is experimental, enable at your own risk. */
+/* #define SEXP_USE_IMMEDIATE_FLONUMS 1 */
+
+/* uncomment this if you don't want bignum support */
+/*   Bignums are implemented with a small, custom library  */
+/*   in opt/bignum.c. */
+/* #define SEXP_USE_BIGNUMS 0 */
+
+/* uncomment this if you don't want exact ratio support */
+/*   Ratios are part of the bignum library and imply bignums. */
+/* #define SEXP_USE_RATIOS 0 */
+
+/* uncomment this if you don't want imaginary number support */
+/* #define SEXP_USE_COMPLEX 0 */
+
+/* uncomment this if you don't want 1## style approximate digits */
+/* #define SEXP_USE_PLACEHOLDER_DIGITS 0 */
+
+/* uncomment this if you don't need extended math operations */
+/*   This includes the trigonometric and expt functions. */
+/*   Automatically disabled if you've disabled flonums. */
+/* #define SEXP_USE_MATH 0 */
+
+/* uncomment this to disable warning about references to undefined variables */
+/*   This is something of a hack, but can be quite useful. */
+/*   It's very fast and doesn't involve any separate analysis */
+/*   passes. */
+/* #define SEXP_USE_WARN_UNDEFS 0 */
+
+/* uncomment this to disable huffman-coded immediate symbols */
+/*   By default (this may change) small symbols are represented */
+/*   as immediates using a simple huffman encoding.  This keeps */
+/*   the symbol table small, and minimizes hashing when doing a */
+/*   lot of reading. */
+/* #define SEXP_USE_HUFF_SYMS 0 */
+
+/* uncomment this to just use a single list for hash tables */
+/*   You can trade off some space in exchange for longer read */
+/*   times by disabling hashing and just putting all */
+/*   non-immediate symbols in a single list. */
+/* #define SEXP_USE_HASH_SYMS 0 */
+
+/* uncomment this to disable extended char names as defined in R7RS */
+/* #define SEXP_USE_EXTENDED_CHAR_NAMES 0 */
+
+/* uncomment this to disable UTF-8 string support */
+/*   The default settings store strings in memory as UTF-8, */
+/*   and assumes strings passed to/from the C FFI are UTF-8.  */
+/* #define SEXP_USE_UTF8_STRINGS 0 */
+
+/* uncomment this to disable the string-set! opcode */
+/*   By default (non-literal) strings are mutable. */
+/*   Making them immutable allows for packed UTF-8 strings. */
+/* #define SEXP_USE_MUTABLE_STRINGS 0 */
+
+/* uncomment this to base string ports on C streams */
+/*   This historic option enables string and custom ports backed */
+/*   by FILE* objects using memstreams and funopen/fopencookie. */
+/* #define SEXP_USE_STRING_STREAMS 1 */
+
+/* uncomment this to disable automatic closing of ports */
+/*   If enabled, the underlying FILE* for file ports will be */
+/*   automatically closed when they're garbage collected.  Doesn't */
+/*   apply to stdin/stdout/stderr. */
+/* #define SEXP_USE_AUTOCLOSE_PORTS 0 */
+
+/* uncomment this to use the normal 1970 unix epoch */
+/*   By default chibi uses an datetime epoch starting at */
+/*   2010/01/01 00:00:00 in order to be able to represent */
+/*   more common times as fixnums. */
+/* #define SEXP_USE_2010_EPOCH 0 */
+
+/* uncomment this to disable stack overflow checks */
+/*   By default stacks are fairly small, so it's good to leave */
+/*   this enabled. */
+/* #define SEXP_USE_CHECK_STACK 0 */
+
+/* uncomment this to disable growing the stack on overflow */
+/*   If enabled, chibi attempts to grow the stack on overflow, */
+/*   up to SEXP_MAX_STACK_SIZE, otherwise a failed stack check */
+/*   will just raise an error immediately. */
+/* #define SEXP_USE_GROW_STACK 0 */
+
+/* #define SEXP_USE_DEBUG_VM 0 */
+/*   Experts only. */
+/*   For *very* verbose output on every VM operation. */
+
+/* uncomment this to make the VM adhere to alignment rules */
+/*   This is required on some platforms, e.g. ARM */
+/* #define SEXP_USE_ALIGNED_BYTECODE */
+
+/************************************************************************/
+/* These settings are configurable but only recommended for */
+/* experienced users, and only apply when using the native GC.  */
+/************************************************************************/
+
+/* the initial heap size in bytes */
+#ifndef SEXP_INITIAL_HEAP_SIZE
+#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024)
+#endif
+
+/* the maximum heap size in bytes - if 0 there is no limit */
+#ifndef SEXP_MAXIMUM_HEAP_SIZE
+#define SEXP_MAXIMUM_HEAP_SIZE 0
+#endif
+#ifndef SEXP_MINIMUM_HEAP_SIZE
+#define SEXP_MINIMUM_HEAP_SIZE 8*1024
+#endif
+
+/* if after GC more than this percentage of memory is still in use, */
+/* and we've not exceeded the maximum size, grow the heap */
+#ifndef SEXP_GROW_HEAP_RATIO
+#define SEXP_GROW_HEAP_RATIO 0.75
+#endif
+
+/* the default number of opcodes to run each thread for */
+#ifndef SEXP_DEFAULT_QUANTUM
+#define SEXP_DEFAULT_QUANTUM 500
+#endif
+
+#ifndef SEXP_MAX_ANALYZE_DEPTH
+#define SEXP_MAX_ANALYZE_DEPTH 8192
+#endif
+
+/************************************************************************/
+/*         DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE            */
+/************************************************************************/
+
+#ifndef SEXP_64_BIT
+#if defined(__amd64) || defined(__x86_64) || defined(_WIN64) || defined(_Wp64) || defined(__LP64__) || defined(__PPC64__)
+#define SEXP_64_BIT 1
+#else
+#define SEXP_64_BIT 0
+#endif
+#endif
+
+#if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__)
+#define SEXP_BSD 1
+#else
+#define SEXP_BSD 0
+#if ! defined(_GNU_SOURCE) && ! defined(_WIN32) && ! defined(PLAN9)
+#define _GNU_SOURCE
+#endif
+#endif
+
+#ifndef SEXP_USE_NO_FEATURES
+#define SEXP_USE_NO_FEATURES 0
+#endif
+
+#ifndef SEXP_USE_PEDANTIC
+#define SEXP_USE_PEDANTIC 0
+#endif
+
+#ifndef SEXP_USE_GREEN_THREADS
+#define SEXP_USE_GREEN_THREADS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_DEBUG_THREADS
+#define SEXP_USE_DEBUG_THREADS 0
+#endif
+
+#ifndef SEXP_USE_AUTO_FORCE
+#define SEXP_USE_AUTO_FORCE 0
+#endif
+
+#ifndef SEXP_USE_NATIVE_X86
+#define SEXP_USE_NATIVE_X86 0
+#endif
+
+#ifndef SEXP_USE_MODULES
+#define SEXP_USE_MODULES ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef sexp_default_user_module_path
+#define sexp_default_user_module_path "./lib:."
+#endif
+
+#ifndef SEXP_USE_TYPE_DEFS
+#define SEXP_USE_TYPE_DEFS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_MAXIMUM_TYPES
+#define SEXP_MAXIMUM_TYPES ((sexp_tag_t)-1)
+#endif
+
+#ifndef SEXP_USE_DL
+#if defined(PLAN9) || defined(_WIN32)
+#define SEXP_USE_DL 0
+#else
+#define SEXP_USE_DL ! SEXP_USE_NO_FEATURES
+#endif
+#endif
+
+#ifndef SEXP_USE_STATIC_LIBS
+#define SEXP_USE_STATIC_LIBS 0
+#endif
+
+/* don't include clibs.c - include separately or link */
+#ifndef SEXP_USE_STATIC_LIBS_NO_INCLUDE
+#define SEXP_USE_STATIC_LIBS_NO_INCLUDE defined(PLAN9)
+#endif
+
+#ifndef SEXP_USE_FULL_SOURCE_INFO
+#define SEXP_USE_FULL_SOURCE_INFO ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_SIMPLIFY
+#define SEXP_USE_SIMPLIFY ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_BOEHM
+#define SEXP_USE_BOEHM 0
+#endif
+
+#ifndef SEXP_USE_WEAK_REFERENCES
+#define SEXP_USE_WEAK_REFERENCES ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_MALLOC
+#define SEXP_USE_MALLOC 0
+#endif
+
+#ifndef SEXP_USE_LIMITED_MALLOC
+#define SEXP_USE_LIMITED_MALLOC 0
+#endif
+
+#ifndef SEXP_USE_MMAP_GC
+#define SEXP_USE_MMAP_GC 0
+#endif
+
+#ifndef SEXP_USE_DEBUG_GC
+#define SEXP_USE_DEBUG_GC 0
+#endif
+
+#ifndef SEXP_USE_SAFE_GC_MARK
+#define SEXP_USE_SAFE_GC_MARK SEXP_USE_DEBUG_GC > 1
+#endif
+
+#ifndef SEXP_USE_CONSERVATIVE_GC
+#define SEXP_USE_CONSERVATIVE_GC 0
+#endif
+
+#ifndef SEXP_USE_TRACK_ALLOC_SOURCE
+#define SEXP_USE_TRACK_ALLOC_SOURCE SEXP_USE_DEBUG_GC > 2
+#endif
+
+#ifndef SEXP_USE_TRACK_ALLOC_BACKTRACE
+#define SEXP_USE_TRACK_ALLOC_BACKTRACE SEXP_USE_TRACK_ALLOC_SOURCE
+#endif
+
+#ifndef SEXP_BACKTRACE_SIZE
+#define SEXP_BACKTRACE_SIZE 3
+#endif
+
+#ifndef SEXP_USE_HEADER_MAGIC
+#define SEXP_USE_HEADER_MAGIC 0
+#endif
+
+#ifndef SEXP_GC_PAD
+#define SEXP_GC_PAD 0
+#endif
+
+#ifndef SEXP_USE_SAFE_ACCESSORS
+#define SEXP_USE_SAFE_ACCESSORS 0
+#endif
+
+#ifndef SEXP_USE_SAFE_VECTOR_ACCESSORS
+#define SEXP_USE_SAFE_VECTOR_ACCESSORS 0
+#endif
+
+#ifndef SEXP_USE_GLOBAL_HEAP
+#if SEXP_USE_BOEHM || SEXP_USE_MALLOC
+#define SEXP_USE_GLOBAL_HEAP 1
+#else
+#define SEXP_USE_GLOBAL_HEAP 0
+#endif
+#endif
+
+#ifndef SEXP_USE_GLOBAL_SYMBOLS
+#if SEXP_USE_BOEHM || SEXP_USE_MALLOC
+#define SEXP_USE_GLOBAL_SYMBOLS 1
+#else
+#define SEXP_USE_GLOBAL_SYMBOLS 0
+#endif
+#endif
+
+#ifndef SEXP_USE_STRICT_TOPLEVEL_BINDINGS
+#define SEXP_USE_STRICT_TOPLEVEL_BINDINGS 0
+#endif
+
+#if SEXP_USE_STRICT_TOPLEVEL_BINDINGS
+#define SEXP_USE_RENAME_BINDINGS 1
+#else
+#ifndef SEXP_USE_RENAME_BINDINGS
+#define SEXP_USE_RENAME_BINDINGS 1
+#endif
+#endif
+
+#ifndef SEXP_USE_SPLICING_LET_SYNTAX
+#define SEXP_USE_SPLICING_LET_SYNTAX 0
+#endif
+
+#ifndef SEXP_USE_FLAT_SYNTACTIC_CLOSURES
+#define SEXP_USE_FLAT_SYNTACTIC_CLOSURES 0
+#endif
+
+#ifndef SEXP_USE_UNWRAPPED_TOPLEVEL_BINDINGS
+#define SEXP_USE_UNWRAPPED_TOPLEVEL_BINDINGS 0
+#endif
+
+#ifndef SEXP_USE_EXTENDED_FCALL
+#define SEXP_USE_EXTENDED_FCALL (!SEXP_USE_NO_FEATURES)
+#endif
+
+#ifndef SEXP_USE_FLONUMS
+#define SEXP_USE_FLONUMS (!SEXP_USE_NO_FEATURES)
+#endif
+
+#ifndef SEXP_USE_BIGNUMS
+#define SEXP_USE_BIGNUMS (!SEXP_USE_NO_FEATURES)
+#endif
+
+#ifndef SEXP_USE_RATIOS
+#define SEXP_USE_RATIOS SEXP_USE_FLONUMS
+#endif
+
+#ifndef SEXP_USE_COMPLEX
+#define SEXP_USE_COMPLEX SEXP_USE_FLONUMS
+#endif
+
+#if (SEXP_USE_RATIOS || SEXP_USE_COMPLEX)
+#undef SEXP_USE_BIGNUMS
+#define SEXP_USE_BIGNUMS 1
+#undef SEXP_USE_FLONUMS
+#define SEXP_USE_FLONUMS 1
+#endif
+
+#ifndef SEXP_USE_INFINITIES
+#if defined(PLAN9) || ! SEXP_USE_FLONUMS
+#define SEXP_USE_INFINITIES 0
+#else
+#define SEXP_USE_INFINITIES ! SEXP_USE_NO_FEATURES
+#endif
+#endif
+
+#ifndef SEXP_USE_IMMEDIATE_FLONUMS
+#define SEXP_USE_IMMEDIATE_FLONUMS 0
+#endif
+
+#ifndef SEXP_USE_IEEE_EQV
+#define SEXP_USE_IEEE_EQV SEXP_USE_FLONUMS
+#endif
+
+#ifndef SEXP_USE_PLACEHOLDER_DIGITS
+#define SEXP_USE_PLACEHOLDER_DIGITS 0
+#endif
+
+#ifndef SEXP_PLACEHOLDER_DIGIT
+#define SEXP_PLACEHOLDER_DIGIT '#'
+#endif
+
+#ifndef SEXP_USE_MATH
+#define SEXP_USE_MATH SEXP_USE_FLONUMS && ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_ESCAPE_NEWLINE
+#define SEXP_USE_ESCAPE_NEWLINE ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_ESCAPE_REQUIRES_TRAILING_SEMI_COLON
+#define SEXP_USE_ESCAPE_REQUIRES_TRAILING_SEMI_COLON SEXP_USE_PEDANTIC
+#endif
+
+#ifndef SEXP_USE_OBJECT_BRACE_LITERALS
+#define SEXP_USE_OBJECT_BRACE_LITERALS (SEXP_USE_TYPE_DEFS && !SEXP_USE_NO_FEATURES)
+#endif
+
+/* Dangerous without shared object detection. */
+#ifndef SEXP_USE_TYPE_PRINTERS
+#define SEXP_USE_TYPE_PRINTERS 0
+#endif
+
+#ifndef SEXP_USE_BYTEVECTOR_LITERALS
+#define SEXP_USE_BYTEVECTOR_LITERALS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_SELF_PARAMETER
+#define SEXP_USE_SELF_PARAMETER 1
+#endif
+
+#ifndef SEXP_USE_WARN_UNDEFS
+#define SEXP_USE_WARN_UNDEFS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_HUFF_SYMS
+#define SEXP_USE_HUFF_SYMS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_HASH_SYMS
+#define SEXP_USE_HASH_SYMS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_FOLD_CASE_SYMS
+#define SEXP_USE_FOLD_CASE_SYMS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_DEFAULT_FOLD_CASE_SYMS
+#define SEXP_DEFAULT_FOLD_CASE_SYMS 0
+#endif
+
+/* experimental optimization to use jumps instead of the TAIL-CALL opcode */
+#ifndef SEXP_USE_TAIL_JUMPS
+/* #define SEXP_USE_TAIL_JUMPS ! SEXP_USE_NO_FEATURES */
+#define SEXP_USE_TAIL_JUMPS 0
+#endif
+
+#ifndef SEXP_USE_RESERVE_OPCODE
+#define SEXP_USE_RESERVE_OPCODE SEXP_USE_TAIL_JUMPS
+#endif
+
+/* experimental optimization to avoid boxing locals which aren't set! */
+#ifndef SEXP_USE_UNBOXED_LOCALS
+/* #define SEXP_USE_UNBOXED_LOCALS ! SEXP_USE_NO_FEATURES */
+#define SEXP_USE_UNBOXED_LOCALS 0
+#endif
+
+#ifndef SEXP_USE_DEBUG_VM
+#define SEXP_USE_DEBUG_VM 0
+#endif
+
+#ifndef SEXP_USE_PROFILE_VM
+#define SEXP_USE_PROFILE_VM 0
+#endif
+
+#ifndef SEXP_USE_EXTENDED_CHAR_NAMES
+#define SEXP_USE_EXTENDED_CHAR_NAMES ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_UTF8_STRINGS
+#define SEXP_USE_UTF8_STRINGS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_MUTABLE_STRINGS
+#define SEXP_USE_MUTABLE_STRINGS 1
+#endif
+
+#if (SEXP_USE_UTF8_STRINGS && SEXP_USE_MUTABLE_STRINGS)
+#define SEXP_USE_PACKED_STRINGS 0
+#endif
+#ifndef SEXP_USE_PACKED_STRINGS
+#define SEXP_USE_PACKED_STRINGS 1
+#endif
+
+#ifndef SEXP_USE_STRING_STREAMS
+#define SEXP_USE_STRING_STREAMS 0
+#endif
+
+#ifndef SEXP_USE_AUTOCLOSE_PORTS
+#define SEXP_USE_AUTOCLOSE_PORTS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_GC_FILE_DESCRIPTORS
+#define SEXP_USE_GC_FILE_DESCRIPTORS (SEXP_USE_AUTOCLOSE_PORTS &&!SEXP_USE_BOEHM && !defined(PLAN9))
+#endif
+
+#ifndef SEXP_USE_BIDIRECTIONAL_PORTS
+#define SEXP_USE_BIDIRECTIONAL_PORTS 0
+#endif
+
+#ifndef SEXP_PORT_BUFFER_SIZE
+#define SEXP_PORT_BUFFER_SIZE 4096
+#endif
+
+#ifndef SEXP_USE_NTP_GETTIME
+#define SEXP_USE_NTP_GETTIME 0
+#endif
+
+#ifndef SEXP_USE_2010_EPOCH
+#define SEXP_USE_2010_EPOCH ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_EPOCH_OFFSET
+#if SEXP_USE_2010_EPOCH
+#define SEXP_EPOCH_OFFSET 1262271600
+#else
+#define SEXP_EPOCH_OFFSET 0
+#endif
+#endif
+
+#ifndef SEXP_USE_CHECK_STACK
+#define SEXP_USE_CHECK_STACK ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_GROW_STACK
+#define SEXP_USE_GROW_STACK SEXP_USE_CHECK_STACK && ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_LONG_PROCEDURE_ARGS
+#define SEXP_USE_LONG_PROCEDURE_ARGS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_INIT_BCODE_SIZE
+#define SEXP_INIT_BCODE_SIZE 128
+#endif
+#ifndef SEXP_INIT_STACK_SIZE
+#if SEXP_USE_CHECK_STACK
+#define SEXP_INIT_STACK_SIZE 1024
+#else
+#define SEXP_INIT_STACK_SIZE 8192
+#endif
+#endif
+#ifndef SEXP_MAX_STACK_SIZE
+#define SEXP_MAX_STACK_SIZE SEXP_INIT_STACK_SIZE*1000
+#endif
+
+#ifndef SEXP_DEFAULT_EQUAL_DEPTH
+#define SEXP_DEFAULT_EQUAL_DEPTH 10000
+#endif
+
+#ifndef SEXP_DEFAULT_EQUAL_BOUND
+#define SEXP_DEFAULT_EQUAL_BOUND 100000000
+#endif
+
+#ifndef SEXP_USE_IMAGE_LOADING
+#define SEXP_USE_IMAGE_LOADING SEXP_USE_DL && !SEXP_USE_GLOBAL_HEAP && !SEXP_USE_BOEHM && !SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_UNSAFE_PUSH
+#define SEXP_USE_UNSAFE_PUSH 0
+#endif
+
+#ifndef SEXP_USE_MAIN_HELP
+#define SEXP_USE_MAIN_HELP ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_MAIN_ERROR_ADVISE
+#define SEXP_USE_MAIN_ERROR_ADVISE ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_SEND_FILE
+#define SEXP_USE_SEND_FILE 0
+/* #define SEXP_USE_SEND_FILE (__linux || SEXP_BSD) */
+#endif
+
+#if SEXP_USE_NATIVE_X86
+#undef SEXP_USE_BOEHM
+#define SEXP_USE_BOEHM 1
+#undef SEXP_USE_FLONUMS
+#define SEXP_USE_FLONUMS 0
+#undef SEXP_USE_BIGNUMS
+#define SEXP_USE_BIGNUMS 0
+#undef SEXP_USE_RATIOS
+#define SEXP_USE_RATIOS 0
+#undef SEXP_USE_COMPLEX
+#define SEXP_USE_COMPLEX 0
+#undef SEXP_USE_UTF8_STRINGS
+#define SEXP_USE_UTF8_STRINGS 0
+#undef SEXP_USE_SIMPLIFY
+#define SEXP_USE_SIMPLIFY 0
+#endif
+
+#ifndef SEXP_USE_ALIGNED_BYTECODE
+#if defined(__arm__)
+#define SEXP_USE_ALIGNED_BYTECODE 1
+#else
+#define SEXP_USE_ALIGNED_BYTECODE 0
+#endif
+#endif
+
+#ifdef PLAN9
+#define strcasecmp cistrcmp
+#define strncasecmp cistrncmp
+#define strcasestr cistrstr
+#define round(x) floor((x)+0.5)
+#define trunc(x) floor((x)+0.5*(((x)<0)?1:0))
+#define isinf(x) (isInf(x,1) || isInf(x,-1))
+#define isnan(x) isNaN(x)
+#elif defined(_WIN32)
+#define snprintf(buf, len, fmt, val) sprintf(buf, fmt, val)
+#define strcasecmp lstrcmpi
+#define strncasecmp(s1, s2, n) lstrcmpi(s1, s2)
+#define round(x) floor((x)+0.5)
+#define trunc(x) floor((x)+0.5*(((x)<0)?1:0))
+#define isnan(x) (x!=x)
+#define isinf(x) (x > DBL_MAX || x < -DBL_MAX)
+#endif
+
+#ifdef _WIN32
+#define sexp_pos_infinity (DBL_MAX*DBL_MAX)
+#define sexp_neg_infinity -sexp_pos_infinity
+#define sexp_nan log(-2)
+#elif PLAN9
+#define sexp_pos_infinity Inf(1)
+#define sexp_neg_infinity Inf(-1)
+#define sexp_nan NaN()
+#else
+#define sexp_pos_infinity (1.0/0.0)
+#define sexp_neg_infinity -sexp_pos_infinity
+#define sexp_nan (0.0/0.0)
+#endif
+
+#ifdef __MINGW32__
+#ifdef BUILDING_DLL
+#define SEXP_API    __declspec(dllexport)
+#else
+#define SEXP_API    __declspec(dllimport)
+#endif
+#else
+#define SEXP_API    extern
+#endif
+
+/************************************************************************/
+/* Feature signature.  Used for image files and dynamically loaded      */
+/* libraries to verify they are compatible with the compiled options .  */
+/************************************************************************/
+
+typedef char sexp_abi_identifier_t[8];
+
+#if SEXP_USE_BOEHM
+#define SEXP_ABI_GC "b"
+#elif (SEXP_USE_HEADER_MAGIC && SEXP_USE_TRACK_ALLOC_SOURCE)
+#define SEXP_ABI_GC "d"
+#elif SEXP_USE_HEADER_MAGIC
+#define SEXP_ABI_GC "m"
+#elif SEXP_USE_TRACK_ALLOC_SOURCE
+#define SEXP_ABI_GC "s"
+#else
+#define SEXP_ABI_GC "c"
+#endif
+
+#if SEXP_USE_NATIVE_X86
+#define SEXP_ABI_BACKEND "x"
+#else
+#define SEXP_ABI_BACKEND "v"
+#endif
+
+#if (SEXP_USE_RESERVE_OPCODE && SEXP_USE_AUTO_FORCE)
+#define SEXP_ABI_INSTRUCTIONS "*"
+#elif SEXP_USE_RESERVE_OPCODE
+#define SEXP_ABI_INSTRUCTIONS "r"
+#elif SEXP_USE_AUTO_FORCE
+#define SEXP_ABI_INSTRUCTIONS "f"
+#else
+#define SEXP_ABI_INSTRUCTIONS "-"
+#endif
+
+#if SEXP_USE_GREEN_THREADS
+#define SEXP_ABI_THREADS "g"
+#else
+#define SEXP_ABI_THREADS "-"
+#endif
+
+#if SEXP_USE_MODULES
+#define SEXP_ABI_MODULES "m"
+#else
+#define SEXP_ABI_MODULES "-"
+#endif
+
+#if (SEXP_USE_COMPLEX && SEXP_USE_RATIOS)
+#define SEXP_ABI_NUMBERS "*"
+#elif SEXP_USE_COMPLEX
+#define SEXP_ABI_NUMBERS "c"
+#elif SEXP_USE_RATIOS
+#define SEXP_ABI_NUMBERS "r"
+#elif SEXP_USE_BIGNUMS
+#define SEXP_ABI_NUMBERS "b"
+#elif SEXP_USE_INFINITIES
+#define SEXP_ABI_NUMBERS "i"
+#elif SEXP_USE_FLONUMS
+#define SEXP_ABI_NUMBERS "f"
+#else
+#define SEXP_ABI_NUMBERS "-"
+#endif
+
+#if SEXP_USE_UTF8_STRINGS
+#define SEXP_ABI_STRINGS "u"
+#elif SEXP_USE_PACKED_STRINGS
+#define SEXP_ABI_STRINGS "p"
+#else
+#define SEXP_ABI_STRINGS "-"
+#endif
+
+#if SEXP_USE_HUFF_SYMS
+#define SEXP_ABI_SYMS "h"
+#else
+#define SEXP_ABI_SYMS "-"
+#endif
+
+#define SEXP_ABI_IDENTIFIER \
+  (SEXP_ABI_GC SEXP_ABI_BACKEND SEXP_ABI_INSTRUCTIONS SEXP_ABI_THREADS \
+   SEXP_ABI_MODULES SEXP_ABI_NUMBERS SEXP_ABI_STRINGS SEXP_ABI_SYMS)
+
+#define sexp_version_compatible(ctx, subver, genver) (strcmp((subver), (genver)) == 0)
+#define sexp_abi_compatible(ctx, subabi, genabi) (strncmp((subabi), (genabi), sizeof(sexp_abi_identifier_t)) == 0)

include/chibi/sexp-huff.c

@@ -0,0 +1,128 @@
+ {12, 0x0C00},   /* '\x00' */
+ {15, 0x0000},   /* '\x01' */
+ {15, 0x4000},   /* '\x02' */
+ {15, 0x2000},   /* '\x03' */
+ {15, 0x6000},   /* '\x04' */
+ {15, 0x0800},   /* '\x05' */
+ {15, 0x4800},   /* '\x06' */
+ {15, 0x2800},   /* '\x07' */
+ {15, 0x6800},   /* '\x08' */
+ {15, 0x1800},   /* '\x09' */
+ {15, 0x5800},   /* '\x0a' */
+ {15, 0x3800},   /* '\x0b' */
+ {15, 0x7800},   /* '\x0c' */
+ {15, 0x0100},   /* '\x0d' */
+ {15, 0x4100},   /* '\x0e' */
+ {15, 0x2100},   /* '\x0f' */
+ {15, 0x6100},   /* '\x10' */
+ {15, 0x1100},   /* '\x11' */
+ {15, 0x5100},   /* '\x12' */
+ {15, 0x3100},   /* '\x13' */
+ {15, 0x7100},   /* '\x14' */
+ {15, 0x0900},   /* '\x15' */
+ {15, 0x4900},   /* '\x16' */
+ {15, 0x2900},   /* '\x17' */
+ {15, 0x6900},   /* '\x18' */
+ {15, 0x1900},   /* '\x19' */
+ {15, 0x5900},   /* '\x1a' */
+ {15, 0x3900},   /* '\x1b' */
+ {15, 0x7900},   /* '\x1c' */
+ {15, 0x0500},   /* '\x1d' */
+ {15, 0x4500},   /* '\x1e' */
+ {15, 0x2500},   /* '\x1f' */
+ {15, 0x6500},   /* '\x20' */
+ { 8, 0x0040},   /* '!'   */
+ {15, 0x1500},   /* '"'   */
+ {15, 0x5500},   /* '#'   */
+ {15, 0x3500},   /* '$'   */
+ {15, 0x7500},   /* '%'   */
+ {15, 0x0D00},   /* '&'   */
+ {15, 0x4D00},   /* '\''  */
+ {15, 0x2D00},   /* '('   */
+ {15, 0x6D00},   /* ')'   */
+ {11, 0x0300},   /* '*'   */
+ {10, 0x0180},   /* '+'   */
+ {15, 0x1D00},   /* ','   */
+ { 4, 0x000D},   /* '-'   */
+ {15, 0x5D00},   /* '.'   */
+ {10, 0x0380},   /* '/'   */
+ {15, 0x3D00},   /* '0'   */
+ {15, 0x7D00},   /* '1'   */
+ {14, 0x0080},   /* '2'   */
+ {14, 0x2080},   /* '3'   */
+ {14, 0x1080},   /* '4'   */
+ {14, 0x3080},   /* '5'   */
+ {14, 0x0880},   /* '6'   */
+ {14, 0x2880},   /* '7'   */
+ {14, 0x1880},   /* '8'   */
+ {14, 0x3880},   /* '9'   */
+ {14, 0x0480},   /* ':'   */
+ {14, 0x2480},   /* ';'   */
+ { 7, 0x0050},   /* '<'   */
+ { 7, 0x0042},   /* '='   */
+ { 7, 0x0022},   /* '>'   */
+ { 5, 0x0009},   /* '?'   */
+ {14, 0x1480},   /* '@'   */
+ {14, 0x3480},   /* 'A'   */
+ {14, 0x0C80},   /* 'B'   */
+ {14, 0x2C80},   /* 'C'   */
+ {14, 0x1C80},   /* 'D'   */
+ {14, 0x3C80},   /* 'E'   */
+ {14, 0x0280},   /* 'F'   */
+ {14, 0x2280},   /* 'G'   */
+ {14, 0x1280},   /* 'H'   */
+ {14, 0x3280},   /* 'I'   */
+ {14, 0x0A80},   /* 'J'   */
+ {14, 0x2A80},   /* 'K'   */
+ {14, 0x1A80},   /* 'L'   */
+ {14, 0x3A80},   /* 'M'   */
+ {14, 0x0680},   /* 'N'   */
+ {14, 0x2680},   /* 'O'   */
+ {14, 0x1680},   /* 'P'   */
+ {14, 0x3680},   /* 'Q'   */
+ {14, 0x0E80},   /* 'R'   */
+ {14, 0x2E80},   /* 'S'   */
+ {14, 0x1E80},   /* 'T'   */
+ {14, 0x3E80},   /* 'U'   */
+ {14, 0x0200},   /* 'V'   */
+ {14, 0x2200},   /* 'W'   */
+ {14, 0x1200},   /* 'X'   */
+ {14, 0x3200},   /* 'Y'   */
+ {14, 0x0A00},   /* 'Z'   */
+ {14, 0x2A00},   /* '['   */
+ {14, 0x1A00},   /* '\\'  */
+ {14, 0x3A00},   /* ']'   */
+ {14, 0x0600},   /* '^'   */
+ {14, 0x2600},   /* '_'   */
+ {14, 0x1600},   /* '`'   */
+ { 3, 0x0007},   /* 'a'   */
+ { 7, 0x0020},   /* 'b'   */
+ { 4, 0x0004},   /* 'c'   */
+ { 5, 0x001A},   /* 'd'   */
+ { 4, 0x0006},   /* 'e'   */
+ { 7, 0x0002},   /* 'f'   */
+ { 5, 0x0011},   /* 'g'   */
+ { 6, 0x0012},   /* 'h'   */
+ { 4, 0x000C},   /* 'i'   */
+ {12, 0x0400},   /* 'j'   */
+ { 8, 0x00C0},   /* 'k'   */
+ { 5, 0x0018},   /* 'l'   */
+ { 6, 0x0032},   /* 'm'   */
+ { 4, 0x0005},   /* 'n'   */
+ { 5, 0x000A},   /* 'o'   */
+ { 5, 0x0001},   /* 'p'   */
+ { 7, 0x0070},   /* 'q'   */
+ { 3, 0x0003},   /* 'r'   */
+ { 5, 0x0008},   /* 's'   */
+ { 4, 0x000E},   /* 't'   */
+ { 5, 0x0019},   /* 'u'   */
+ { 7, 0x0062},   /* 'v'   */
+ { 7, 0x0030},   /* 'w'   */
+ { 7, 0x0060},   /* 'x'   */
+ { 7, 0x0010},   /* 'y'   */
+ {11, 0x0700},   /* 'z'   */
+ {14, 0x3600},   /* '{'   */
+ {14, 0x0E00},   /* '|'   */
+ {14, 0x2E00},   /* '}'   */
+ {14, 0x1E00},   /* '~'   */
+ {14, 0x3E00},   /* '\x7f' */

include/chibi/sexp-huff.h

@@ -0,0 +1,128 @@
+ {12, 0x0C00},   /* '\x00' */
+ {15, 0x0000},   /* '\x01' */
+ {15, 0x4000},   /* '\x02' */
+ {15, 0x2000},   /* '\x03' */
+ {15, 0x6000},   /* '\x04' */
+ {15, 0x0800},   /* '\x05' */
+ {15, 0x4800},   /* '\x06' */
+ {15, 0x2800},   /* '\x07' */
+ {15, 0x6800},   /* '\x08' */
+ {15, 0x1800},   /* '\x09' */
+ {15, 0x5800},   /* '\x0a' */
+ {15, 0x3800},   /* '\x0b' */
+ {15, 0x7800},   /* '\x0c' */
+ {15, 0x0100},   /* '\x0d' */
+ {15, 0x4100},   /* '\x0e' */
+ {15, 0x2100},   /* '\x0f' */
+ {15, 0x6100},   /* '\x10' */
+ {15, 0x1100},   /* '\x11' */
+ {15, 0x5100},   /* '\x12' */
+ {15, 0x3100},   /* '\x13' */
+ {15, 0x7100},   /* '\x14' */
+ {15, 0x0900},   /* '\x15' */
+ {15, 0x4900},   /* '\x16' */
+ {15, 0x2900},   /* '\x17' */
+ {15, 0x6900},   /* '\x18' */
+ {15, 0x1900},   /* '\x19' */
+ {15, 0x5900},   /* '\x1a' */
+ {15, 0x3900},   /* '\x1b' */
+ {15, 0x7900},   /* '\x1c' */
+ {15, 0x0500},   /* '\x1d' */
+ {15, 0x4500},   /* '\x1e' */
+ {15, 0x2500},   /* '\x1f' */
+ {15, 0x6500},   /* '\x20' */
+ { 8, 0x0040},   /* '!'   */
+ {15, 0x1500},   /* '"'   */
+ {15, 0x5500},   /* '#'   */
+ {15, 0x3500},   /* '$'   */
+ {15, 0x7500},   /* '%'   */
+ {15, 0x0D00},   /* '&'   */
+ {15, 0x4D00},   /* '\''  */
+ {15, 0x2D00},   /* '('   */
+ {15, 0x6D00},   /* ')'   */
+ {11, 0x0300},   /* '*'   */
+ {10, 0x0180},   /* '+'   */
+ {15, 0x1D00},   /* ','   */
+ { 4, 0x000D},   /* '-'   */
+ {15, 0x5D00},   /* '.'   */
+ {10, 0x0380},   /* '/'   */
+ {15, 0x3D00},   /* '0'   */
+ {15, 0x7D00},   /* '1'   */
+ {14, 0x0080},   /* '2'   */
+ {14, 0x2080},   /* '3'   */
+ {14, 0x1080},   /* '4'   */
+ {14, 0x3080},   /* '5'   */
+ {14, 0x0880},   /* '6'   */
+ {14, 0x2880},   /* '7'   */
+ {14, 0x1880},   /* '8'   */
+ {14, 0x3880},   /* '9'   */
+ {14, 0x0480},   /* ':'   */
+ {14, 0x2480},   /* ';'   */
+ { 7, 0x0050},   /* '<'   */
+ { 7, 0x0042},   /* '='   */
+ { 7, 0x0022},   /* '>'   */
+ { 5, 0x0009},   /* '?'   */
+ {14, 0x1480},   /* '@'   */
+ {14, 0x3480},   /* 'A'   */
+ {14, 0x0C80},   /* 'B'   */
+ {14, 0x2C80},   /* 'C'   */
+ {14, 0x1C80},   /* 'D'   */
+ {14, 0x3C80},   /* 'E'   */
+ {14, 0x0280},   /* 'F'   */
+ {14, 0x2280},   /* 'G'   */
+ {14, 0x1280},   /* 'H'   */
+ {14, 0x3280},   /* 'I'   */
+ {14, 0x0A80},   /* 'J'   */
+ {14, 0x2A80},   /* 'K'   */
+ {14, 0x1A80},   /* 'L'   */
+ {14, 0x3A80},   /* 'M'   */
+ {14, 0x0680},   /* 'N'   */
+ {14, 0x2680},   /* 'O'   */
+ {14, 0x1680},   /* 'P'   */
+ {14, 0x3680},   /* 'Q'   */
+ {14, 0x0E80},   /* 'R'   */
+ {14, 0x2E80},   /* 'S'   */
+ {14, 0x1E80},   /* 'T'   */
+ {14, 0x3E80},   /* 'U'   */
+ {14, 0x0200},   /* 'V'   */
+ {14, 0x2200},   /* 'W'   */
+ {14, 0x1200},   /* 'X'   */
+ {14, 0x3200},   /* 'Y'   */
+ {14, 0x0A00},   /* 'Z'   */
+ {14, 0x2A00},   /* '['   */
+ {14, 0x1A00},   /* '\\'  */
+ {14, 0x3A00},   /* ']'   */
+ {14, 0x0600},   /* '^'   */
+ {14, 0x2600},   /* '_'   */
+ {14, 0x1600},   /* '`'   */
+ { 3, 0x0007},   /* 'a'   */
+ { 7, 0x0020},   /* 'b'   */
+ { 4, 0x0004},   /* 'c'   */
+ { 5, 0x001A},   /* 'd'   */
+ { 4, 0x0006},   /* 'e'   */
+ { 7, 0x0002},   /* 'f'   */
+ { 5, 0x0011},   /* 'g'   */
+ { 6, 0x0012},   /* 'h'   */
+ { 4, 0x000C},   /* 'i'   */
+ {12, 0x0400},   /* 'j'   */
+ { 8, 0x00C0},   /* 'k'   */
+ { 5, 0x0018},   /* 'l'   */
+ { 6, 0x0032},   /* 'm'   */
+ { 4, 0x0005},   /* 'n'   */
+ { 5, 0x000A},   /* 'o'   */
+ { 5, 0x0001},   /* 'p'   */
+ { 7, 0x0070},   /* 'q'   */
+ { 3, 0x0003},   /* 'r'   */
+ { 5, 0x0008},   /* 's'   */
+ { 4, 0x000E},   /* 't'   */
+ { 5, 0x0019},   /* 'u'   */
+ { 7, 0x0062},   /* 'v'   */
+ { 7, 0x0030},   /* 'w'   */
+ { 7, 0x0060},   /* 'x'   */
+ { 7, 0x0010},   /* 'y'   */
+ {11, 0x0700},   /* 'z'   */
+ {14, 0x3600},   /* '{'   */
+ {14, 0x0E00},   /* '|'   */
+ {14, 0x2E00},   /* '}'   */
+ {14, 0x1E00},   /* '~'   */
+ {14, 0x3E00},   /* '\x7f' */

include/chibi/sexp-hufftabdefs.h

@@ -0,0 +1,7 @@
+
+char _huff_tab1[8], _huff_tab2[8], _huff_tab3[2], _huff_tab4[2],
+  _huff_tab5[4], _huff_tab6[2], _huff_tab7[4], _huff_tab8[4],
+  _huff_tab9[4], _huff_tab10[4], _huff_tab11[4], _huff_tab12[2],
+  _huff_tab13[8], _huff_tab14[2], _huff_tab15[8], _huff_tab16[8],
+  _huff_tab17[8], _huff_tab18[8], _huff_tab19[4], _huff_tab20[8],
+  _huff_tab21[8];

include/chibi/sexp-hufftabs.c

@@ -0,0 +1,92 @@
+/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */
+
+char _huff_tab21[] = {
+  '\x01',  '\x00',  '\x03',  '\x00',  '\x02',  '\x00',  '\x04',  '\x00',
+};
+
+char _huff_tab19[] = {
+  '\x01',     'j',  '\x01',  '\x00',
+};
+
+char _huff_tab20[] = {
+  '\x05',  '\x09',  '\x07',  '\x0b',  '\x06',  '\x0a',  '\x08',  '\x0c',
+};
+
+char _huff_tab18[] = {
+     '2',     ':',     '6',     'B',     '4',     '@',     '8',     'D',
+     '3',     ';',     '7',     'C',     '5',     'A',     '9',     'E',
+};
+
+char _huff_tab17[] = {
+  '\x0d',  '\x1d',  '\x15',     '&',  '\x11',     '"',  '\x19',     ',',
+  '\x0f',  '\x1f',  '\x17',     '(',  '\x13',     '$',  '\x1b',     '0',
+  '\x0e',  '\x1e',  '\x16',    '\'',  '\x12',     '#',  '\x1a',     '.',
+  '\x10',  '\x20',  '\x18',     ')',  '\x14',     '%',  '\x1c',     '1',
+};
+
+char _huff_tab16[] = {
+     'V',     '^',     'Z',     '|',     'X',     '`',    '\\',     '~',
+     'W',     '_',     '[',     '}',     'Y',     '{',     ']',  '\x7f',
+};
+
+char _huff_tab15[] = {
+     'F',     'N',     'J',     'R',     'H',     'P',     'L',     'T',
+     'G',     'O',     'K',     'S',     'I',     'Q',     'M',     'U',
+};
+
+char _huff_tab13[] = {
+  '\x00',  '\x00',  '\x00',     '+',  '\x00',  '\x00',  '\x00',     '/',
+};
+
+char _huff_tab14[] = {
+     '*',     'z',
+};
+
+char _huff_tab11[] = {
+  '\x00',     'b',  '\x00',     'x',
+};
+
+char _huff_tab12[] = {
+     '!',     'k',
+};
+
+char _huff_tab9[] = {
+  '\x00',     's',  '\x00',     'l',
+};
+
+char _huff_tab10[] = {
+     'y',     'w',     '<',     'q',
+};
+
+char _huff_tab8[] = {
+     'p',     '?',     'g',     'u',
+};
+
+char _huff_tab7[] = {
+     'f',     '>',     '=',     'v',
+};
+
+char _huff_tab5[] = {
+  '\x00',     'o',  '\x00',     'd',
+};
+
+char _huff_tab6[] = {
+     'h',     'm',
+};
+
+char _huff_tab4[] = {
+     'c',     'i',
+};
+
+char _huff_tab3[] = {
+     'n',     '-',
+};
+
+char _huff_tab1[] = {
+  '\x00',  '\x00',  '\x00',     'r',  '\x00',  '\x00',  '\x00',     'a',
+};
+
+char _huff_tab2[] = {
+     'e',     't',
+};
+

include/chibi/sexp-hufftabs.h

@@ -0,0 +1,92 @@
+/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */
+
+char _huff_tab21[] = {
+  '\x01',  '\x00',  '\x03',  '\x00',  '\x02',  '\x00',  '\x04',  '\x00',
+};
+
+char _huff_tab19[] = {
+  '\x01',     'j',  '\x01',  '\x00',
+};
+
+char _huff_tab20[] = {
+  '\x05',  '\x09',  '\x07',  '\x0b',  '\x06',  '\x0a',  '\x08',  '\x0c',
+};
+
+char _huff_tab18[] = {
+     '2',     ':',     '6',     'B',     '4',     '@',     '8',     'D',
+     '3',     ';',     '7',     'C',     '5',     'A',     '9',     'E',
+};
+
+char _huff_tab17[] = {
+  '\x0d',  '\x1d',  '\x15',     '&',  '\x11',     '"',  '\x19',     ',',
+  '\x0f',  '\x1f',  '\x17',     '(',  '\x13',     '$',  '\x1b',     '0',
+  '\x0e',  '\x1e',  '\x16',    '\'',  '\x12',     '#',  '\x1a',     '.',
+  '\x10',  '\x20',  '\x18',     ')',  '\x14',     '%',  '\x1c',     '1',
+};
+
+char _huff_tab16[] = {
+     'V',     '^',     'Z',     '|',     'X',     '`',    '\\',     '~',
+     'W',     '_',     '[',     '}',     'Y',     '{',     ']',  '\x7f',
+};
+
+char _huff_tab15[] = {
+     'F',     'N',     'J',     'R',     'H',     'P',     'L',     'T',
+     'G',     'O',     'K',     'S',     'I',     'Q',     'M',     'U',
+};
+
+char _huff_tab13[] = {
+  '\x00',  '\x00',  '\x00',     '+',  '\x00',  '\x00',  '\x00',     '/',
+};
+
+char _huff_tab14[] = {
+     '*',     'z',
+};
+
+char _huff_tab11[] = {
+  '\x00',     'b',  '\x00',     'x',
+};
+
+char _huff_tab12[] = {
+     '!',     'k',
+};
+
+char _huff_tab9[] = {
+  '\x00',     's',  '\x00',     'l',
+};
+
+char _huff_tab10[] = {
+     'y',     'w',     '<',     'q',
+};
+
+char _huff_tab8[] = {
+     'p',     '?',     'g',     'u',
+};
+
+char _huff_tab7[] = {
+     'f',     '>',     '=',     'v',
+};
+
+char _huff_tab5[] = {
+  '\x00',     'o',  '\x00',     'd',
+};
+
+char _huff_tab6[] = {
+     'h',     'm',
+};
+
+char _huff_tab4[] = {
+     'c',     'i',
+};
+
+char _huff_tab3[] = {
+     'n',     '-',
+};
+
+char _huff_tab1[] = {
+  '\x00',  '\x00',  '\x00',     'r',  '\x00',  '\x00',  '\x00',     'a',
+};
+
+char _huff_tab2[] = {
+     'e',     't',
+};
+

include/chibi/sexp-unhuff.c

@@ -0,0 +1,71 @@
+/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */
+
+res = c & 7;
+c = c >> 3;
+if (res == 0) {
+  res = c & 3;
+  c = c >> 2;
+  if (res == 0) {
+    res = c & 3;
+    c = c >> 2;
+    if (res == 0) {
+      res = c & 7;
+      c = c >> 3;
+      if (res == 0) {
+        res = c & 3;
+        c = c >> 2;
+        if (res == 0) {
+          res = _huff_tab21[c & 7];
+          c = c >> 3;
+        } else if ((res = _huff_tab19[res]) == '\x01') {
+          res = _huff_tab20[c & 7];
+          c = c >> 3;
+        }
+      } else if (res == 1) {
+        res = _huff_tab18[c & 15];
+        c = c >> 4;
+      } else if (res == 2) {
+        res = _huff_tab17[c & 31];
+        c = c >> 5;
+      } else if (res == 4) {
+        res = _huff_tab16[c & 15];
+        c = c >> 4;
+      } else if (res == 5) {
+        res = _huff_tab15[c & 15];
+        c = c >> 4;
+      } else if ((res = _huff_tab13[res]) == '\x00') {
+        res = _huff_tab14[c & 1];
+        c = c >> 1;
+      }
+    } else if ((res = _huff_tab11[res]) == '\x00') {
+      res = _huff_tab12[c & 1];
+      c = c >> 1;
+    }
+  } else if ((res = _huff_tab9[res]) == '\x00') {
+    res = _huff_tab10[c & 3];
+    c = c >> 2;
+  }
+ } else if (res == 1) {
+  res = _huff_tab8[c & 3];
+  c = c >> 2;
+ } else if (res == 2) {
+  res = c & 3;
+  c = c >> 2;
+  if (res == 0) {
+    res = _huff_tab7[c & 3];
+    c = c >> 2;
+  } else if ((res = _huff_tab5[res]) == '\x00') {
+    res = _huff_tab6[c & 1];
+    c = c >> 1;
+  }
+ } else if (res == 4) {
+  res = _huff_tab4[c & 1];
+  c = c >> 1;
+ } else if (res == 5) {
+  res = _huff_tab3[c & 1];
+  c = c >> 1;
+ } else if ((res = _huff_tab1[res]) == '\x00') {
+  res = _huff_tab2[c & 1];
+  c = c >> 1;
+ }
+

include/chibi/sexp-unhuff.h

@@ -0,0 +1,71 @@
+/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */
+
+res = c & 7;
+c = c >> 3;
+if (res == 0) {
+  res = c & 3;
+  c = c >> 2;
+  if (res == 0) {
+    res = c & 3;
+    c = c >> 2;
+    if (res == 0) {
+      res = c & 7;
+      c = c >> 3;
+      if (res == 0) {
+        res = c & 3;
+        c = c >> 2;
+        if (res == 0) {
+          res = _huff_tab21[c & 7];
+          c = c >> 3;
+        } else if ((res = _huff_tab19[res]) == '\x01') {
+          res = _huff_tab20[c & 7];
+          c = c >> 3;
+        }
+      } else if (res == 1) {
+        res = _huff_tab18[c & 15];
+        c = c >> 4;
+      } else if (res == 2) {
+        res = _huff_tab17[c & 31];
+        c = c >> 5;
+      } else if (res == 4) {
+        res = _huff_tab16[c & 15];
+        c = c >> 4;
+      } else if (res == 5) {
+        res = _huff_tab15[c & 15];
+        c = c >> 4;
+      } else if ((res = _huff_tab13[res]) == '\x00') {
+        res = _huff_tab14[c & 1];
+        c = c >> 1;
+      }
+    } else if ((res = _huff_tab11[res]) == '\x00') {
+      res = _huff_tab12[c & 1];
+      c = c >> 1;
+    }
+  } else if ((res = _huff_tab9[res]) == '\x00') {
+    res = _huff_tab10[c & 3];
+    c = c >> 2;
+  }
+ } else if (res == 1) {
+  res = _huff_tab8[c & 3];
+  c = c >> 2;
+ } else if (res == 2) {
+  res = c & 3;
+  c = c >> 2;
+  if (res == 0) {
+    res = _huff_tab7[c & 3];
+    c = c >> 2;
+  } else if ((res = _huff_tab5[res]) == '\x00') {
+    res = _huff_tab6[c & 1];
+    c = c >> 1;
+  }
+ } else if (res == 4) {
+  res = _huff_tab4[c & 1];
+  c = c >> 1;
+ } else if (res == 5) {
+  res = _huff_tab3[c & 1];
+  c = c >> 1;
+ } else if ((res = _huff_tab1[res]) == '\x00') {
+  res = _huff_tab2[c & 1];
+  c = c >> 1;
+ }
+

lib/chibi/accept.c

@@ -0,0 +1,110 @@
+
+/* chibi-ffi should probably be able to detect these patterns automatically, */
+/* but for now we manually check two special cases - accept should check for */
+/* EWOULDBLOCK and block on the socket, and listen should automatically make */
+/* sockets non-blocking. */
+
+sexp sexp_accept (sexp ctx, sexp self, int sock, struct sockaddr* addr, socklen_t len) {
+#if SEXP_USE_GREEN_THREADS
+  sexp f;
+#endif
+  int res;
+  res = accept(sock, addr, &len);
+#if SEXP_USE_GREEN_THREADS
+  if (res < 0 && errno == EWOULDBLOCK) {
+    f = sexp_global(ctx, SEXP_G_THREADS_BLOCKER);
+    if (sexp_applicablep(f)) {
+      sexp_apply2(ctx, f, sexp_make_fixnum(sock), SEXP_FALSE);
+      return sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR);
+    }
+  }
+  if (res >= 0)
+    fcntl(res, F_SETFL, fcntl(res, F_GETFL) | O_NONBLOCK);
+#endif
+  return sexp_make_fileno(ctx, sexp_make_fixnum(res), SEXP_FALSE);
+}
+
+/* likewise sendto and recvfrom should suspend the thread gracefully */
+
+#define sexp_zerop(x) ((x) == SEXP_ZERO || (sexp_flonump(x) && sexp_flonum_value(x) == 0.0))
+
+sexp sexp_sendto (sexp ctx, sexp self, int sock, const void* buffer, size_t len, int flags, struct sockaddr* addr, socklen_t addr_len, sexp timeout) {
+#if SEXP_USE_GREEN_THREADS
+  sexp f;
+#endif
+  ssize_t res;
+  res = sendto(sock, buffer, len, flags, addr, addr_len);
+#if SEXP_USE_GREEN_THREADS
+  if (res < 0 && errno == EWOULDBLOCK && !sexp_zerop(timeout)) {
+    f = sexp_global(ctx, SEXP_G_THREADS_BLOCKER);
+    if (sexp_applicablep(f)) {
+      sexp_apply2(ctx, f, sexp_make_fixnum(sock), timeout);
+      return sexp_global(ctx, SEXP_G_IO_BLOCK_ONCE_ERROR);
+    }
+  }
+#endif
+  return sexp_make_fixnum(res);
+}
+
+sexp sexp_recvfrom (sexp ctx, sexp self, int sock, void* buffer, size_t len, int flags, struct sockaddr* addr, socklen_t addr_len, sexp timeout) {
+#if SEXP_USE_GREEN_THREADS
+  sexp f;
+#endif
+  ssize_t res;
+  res = recvfrom(sock, buffer, len, flags, addr, &addr_len);
+#if SEXP_USE_GREEN_THREADS
+  if (res < 0 && errno == EWOULDBLOCK && !sexp_zerop(timeout)) {
+    f = sexp_global(ctx, SEXP_G_THREADS_BLOCKER);
+    if (sexp_applicablep(f)) {
+      sexp_apply2(ctx, f, sexp_make_fixnum(sock), timeout);
+      return sexp_global(ctx, SEXP_G_IO_BLOCK_ONCE_ERROR);
+    }
+  }
+#endif
+  return sexp_make_fixnum(res);
+}
+
+/* If we're binding or listening on a socket from Scheme, we most */
+/* likely want it to be non-blocking. */
+
+sexp sexp_bind (sexp ctx, sexp self, int fd, struct sockaddr* addr, socklen_t addr_len) {
+  int res = bind(fd, addr, addr_len);
+#if SEXP_USE_GREEN_THREADS
+  if (res >= 0)
+    fcntl(fd, F_SETFL, fcntl(fd, F_GETFL) | O_NONBLOCK);
+#endif
+  return (res == 0) ? SEXP_TRUE : SEXP_FALSE;
+}
+
+sexp sexp_listen (sexp ctx, sexp self, sexp fileno, sexp backlog) {
+  int fd, res;
+  sexp_assert_type(ctx, sexp_filenop, SEXP_FILENO, fileno);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, backlog);
+  fd = sexp_fileno_fd(fileno);
+  res = listen(fd, sexp_unbox_fixnum(backlog));
+#if SEXP_USE_GREEN_THREADS
+  if (res >= 0)
+    fcntl(fd, F_SETFL, fcntl(fd, F_GETFL) | O_NONBLOCK);
+#endif
+  return (res == 0) ? SEXP_TRUE : SEXP_FALSE;
+}
+
+/* Additional utilities. */
+
+sexp sexp_sockaddr_name (sexp ctx, sexp self, struct sockaddr* addr) {
+  char buf[24];
+  /* struct sockaddr_in *sa = (struct sockaddr_in *)addr; */
+  /* unsigned char *ptr = (unsigned char *)&(sa->sin_addr); */
+  /* sprintf(buf, "%d.%d.%d.%d", ptr[0], ptr[1], ptr[2], ptr[3]); */
+  inet_ntop(addr->sa_family,
+            (addr->sa_family == AF_INET6 ?
+             (void*)(&(((struct sockaddr_in6 *)addr)->sin6_addr)) :
+             (void*)(&(((struct sockaddr_in *)addr)->sin_addr))),
+            buf, 24);
+  return sexp_c_string(ctx, buf, -1);
+}
+
+int sexp_sockaddr_port (sexp ctx, sexp self, struct sockaddr* addr) {
+  struct sockaddr_in *sa = (struct sockaddr_in *)addr;
+  return sa->sin_port;
+}

lib/chibi/app.scm

@@ -0,0 +1,283 @@
+;; app.scm -- unified option parsing and config
+;; Copyright (c) 2012-2013 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> Parses command-line options into a config object.
+
+(define (parse-option prefix conf-spec args fail)
+  (define (parse-value type str)
+    (cond
+     ((not (string? str))
+      str)
+     ((and (pair? type) (eq? 'list (car type)))
+      (map (lambda (x) (parse-value (cadr type) x))
+           (string-split str #\,)))
+     (else
+      (case type
+        ((boolean) (not (member str '("#f" "#false" "#F" "#FALSE"))))
+        ((number) (string->number str))
+        ((symbol) (string->symbol str))
+        ((char) (string-ref str 0))
+        (else str)))))
+  (define (lookup-conf-spec conf-spec syms strs)
+    (let ((sym (car syms))
+          (str (car strs)))
+      (cond
+       ((= 1 (length syms))
+        (let lp ((ls conf-spec))
+          (and (pair? ls)
+               (let ((x (car ls)))
+                 (cond
+                  ((eq? sym (car x)) x)
+                  ((and (pair? (cddr x)) (member str (car (cddr x)))) x)
+                  ((and (pair? (cddr x)) (member `(not ,str) (car (cddr x))))
+                   `(not ,x))
+                  (else (lp (cdr ls))))))))
+       (else
+        (let lp ((ls conf-spec))
+          (and (pair? ls)
+               (let ((x (car ls)))
+                 (cond
+                  ((or (eq? sym (car x))
+                       (and (pair? (cddr x)) (member str (car (cddr x)))))
+                   (let ((type (cadr x)))
+                     (if (not (and (pair? type) (eq? 'conf (car type))))
+                         (error "option prefix not a subconf" sym)
+                         (lookup-conf-spec (cdr type) (cdr syms) (cdr strs)))))
+                  (else (lp (cdr ls)))))))))))
+  (define (lookup-short-option ch spec)
+    (let lp ((ls spec))
+      (and (pair? ls)
+           (let ((x (car ls)))
+             (cond
+              ((and (pair? (cddr x)) (memv ch (car (cddr x))))
+               x)
+              ((and (pair? (cddr x)) (member `(not ,ch) (car (cddr x))))
+               `(not ,x))
+              (else (lp (cdr ls))))))))
+  (define (parse-conf-spec str args)
+    (let* ((strs (string-split str #\.))
+           (syms (map string->symbol strs))
+           (spec (lookup-conf-spec conf-spec syms strs)))
+      (cond
+       ((not spec)
+        #f)
+       ((and (pair? spec) (eq? 'not (car spec)))
+        (cons (cons (append prefix (list (car spec))) #f) args))
+       ((eq? 'boolean (cadr spec))
+        (cons (cons (append prefix (list (car spec))) #t) args))
+       ((null? args)
+        (error "missing argument to option " str))
+       (else
+        (cons (cons (append prefix syms) (parse-value (cadr spec) (car args)))
+              (cdr args))))))
+  (define (parse-long-option str args)
+    (let* ((str+val (string-split str #\= 2))
+           (str (car str+val))
+           (args2 (if (pair? (cdr str+val)) (cons (cadr str+val) args) args)))
+      (or (parse-conf-spec str args2)
+          (and (string-prefix? "no-" str)
+               (let ((res (parse-long-option (substring str 3) args)))
+                 (cond
+                  ((not res)
+                   #f)
+                  ((not (boolean? (cdar res)))
+                   (error "'no-' prefix only valid on boolean options"))
+                  (else
+                   `(((,@prefix ,(caar res)) . ,(not (cdar res)))
+                     ,@(cdr res)))))))))
+  (define (parse-short-option str args)
+    (let* ((ch (string-ref str 0))
+           (x (lookup-short-option ch conf-spec)))
+      (cond
+       ((not x)
+        #f)
+       ((and (pair? x) (eq? 'not (car x)))
+        (cons (cons (append prefix (list (car (cadr x)))) #f)
+              (if (= 1 (string-length str))
+                  args
+                  (cons (string-append "-" (substring str 1)) args))))
+       ((eq? 'boolean (cadr x))
+        (cons (cons (append prefix (list (car x))) #t)
+              (if (= 1 (string-length str))
+                  args
+                  (cons (string-append "-" (substring str 1)) args))))
+       ((> (string-length str) 1)
+        (cons (cons (append prefix (list (car x)))
+                    (parse-value (cadr x) (substring str 1)))
+              args))
+       ((null? args)
+        (error "missing argument to option " x))
+       (else
+        (cons (cons (append prefix (list (car x))) (car args)) (cdr args))))))
+  (or (if (eqv? #\- (string-ref (car args) 1))
+          (parse-long-option (substring (car args) 2) (cdr args))
+          (parse-short-option (substring (car args) 1) (cdr args)))
+      (fail prefix conf-spec (car args) args)))
+
+(define (parse-options prefix conf-spec orig-args fail)
+  (let lp ((args orig-args)
+           (opts (make-conf '() #f (cons 'options orig-args) #f)))
+    (cond
+     ((null? args)
+      (cons opts args))
+     ((or (member (car args) '("" "-" "--"))
+          (not (eqv? #\- (string-ref (car args) 0))))
+      (cons opts (if (equal? (car args) "--") (cdr args) args)))
+     (else
+      (let ((val+args (parse-option prefix conf-spec args fail)))
+        (lp (cdr val+args)
+            (conf-set opts (caar val+args) (cdar val+args))))))))
+
+(define (parse-app prefix spec opt-spec args config init end . o)
+  (define (next-prefix prefix name)
+    (append (if (null? prefix) '(command) prefix) (list name)))
+  (define (prev-prefix prefix)
+    (cond ((and (= 2 (length prefix))))
+          ((null? prefix) '())
+          (else (reverse (cdr (reverse  prefix))))))
+  (let ((fail (if (pair? o)
+                  (car o)
+                  (lambda (prefix spec opt args)
+                    ;; TODO: search for closest option
+                    (error "unknown option: " opt)))))
+    (cond
+     ((null? spec)
+      (error "no procedure in application spec"))
+     ((pair? (car spec))
+      (case (caar spec)
+        ((@)
+         (let* ((new-opt-spec (cadr (car spec)))
+                (new-fail
+                 (lambda (new-prefix new-spec opt args)
+                   (parse-option (prev-prefix prefix) opt-spec args fail)))
+                (cfg+args (parse-options prefix new-opt-spec args new-fail))
+                (config (conf-append (car cfg+args) config))
+                (args (cdr cfg+args)))
+           (parse-app prefix (cdr spec) new-opt-spec args config init end new-fail)))
+        ((or)
+         (any (lambda (x) (parse-app prefix x opt-spec args config init end))
+              (cdar spec)))
+        ((begin:)
+         (parse-app prefix (cdr spec) opt-spec args config (cadr (car spec)) end fail))
+        ((end:)
+         (parse-app prefix (cdr spec) opt-spec args config init (cadr (car spec)) fail))
+        (else
+         (if (procedure? (caar spec))
+             (vector (caar spec) config args init end) ; TODO: verify
+             (parse-app prefix (car spec) opt-spec args config init end fail)))))
+     ((symbol? (car spec))
+      (and (pair? args)
+           (eq? (car spec) (string->symbol (car args)))
+           (let ((prefix (next-prefix prefix (car spec))))
+             (parse-app prefix (cdr spec) opt-spec (cdr args) config init end fail))))
+     ((procedure? (car spec))
+      (vector (car spec) config args init end))
+     (else
+      (if (not (string? (car spec)))
+          (error "unknown application spec" (car spec)))
+      (parse-app prefix (cdr spec) opt-spec args config init end fail)))))
+
+(define (print-command-help command out)
+  (cond
+   ((and (pair? command) (symbol? (car command)))
+    (display "  " out)
+    (display (car command) out)
+    (cond
+     ((find (lambda (x) (and (pair? x) (procedure? (car x)))) command)
+      => (lambda (x)
+           (let lp ((args (cdr x)) (opt-depth 0))
+             (cond
+              ((null? args)
+               (display (make-string opt-depth #\]) out))
+              ((pair? (car args))
+               (display " [" out)
+               (display (caar args) out)
+               (lp (cdr args) (+ opt-depth 1)))
+              (else
+               (display " " out)
+               (display (car args) out)
+               (lp (cdr args) opt-depth)))))))
+    (cond
+     ((find string? command)
+      => (lambda (doc-string) (display " - " out) (display doc-string out))))
+    (newline out))))
+
+(define (print-option-help option out)
+  (let* ((str (symbol->string (car option)))
+         (names (if (and (pair? (cdr option)) (pair? (cddr option)))
+                    (car (cddr option))
+                    '()))
+         (pref-str (cond ((find string? names) => values) (else str)))
+         (pref-ch (find char? names))
+         (doc (find string? (cdr option))))
+    ;; TODO: consider aligning these
+    (cond
+     (pref-ch (display "  -" out) (write-char pref-ch out))
+     (else (display "    " out)))
+    (cond
+     (pref-str
+      (display (if pref-ch ", " "  ") out)
+      (display "--" out) (display pref-str out)))
+    (cond (doc (display " - " out) (display doc out)))
+    (newline out)))
+
+(define (print-help name docs commands options . o)
+  (let ((out (if (pair? o) (car o) (current-output-port))))
+    (display "Usage: " out) (display name out)
+    (if (pair? options) (display " [options]" out))
+    (case (length commands)
+      ((0) (newline out))
+      (else
+       (display " <command>\nCommands:\n" out)
+       (for-each (lambda (c) (print-command-help c out)) commands))
+      ((1) (print-command-help (car commands) out)))
+    (if (pair? options) (display "Options:\n" out))
+    (for-each (lambda (o) (print-option-help o out)) options)))
+
+(define (app-help spec args . o)
+  (let ((out (if (pair? o) (car o) (current-output-port))))
+    (let lp ((ls (cdr spec))
+             (docs #f)
+             (commands '())
+             (options '()))
+      (cond
+       ((null? ls)
+        (print-help (car spec) docs commands options out))
+       ((or (string? (car ls))
+            (and (pair? (car ls)) (memq (caar ls) '(begin: end:) )))
+        (lp (cdr ls) (car ls) commands options))
+       ((and (pair? (car ls)) (eq? '@ (caar ls)))
+        (lp (cdr ls) docs commands (append options (cadr (car ls)))))
+       ((and (pair? (car ls)) (symbol? (caar ls)))
+        ;; don't print nested commands
+        (if (pair? commands)
+            (print-help (car spec) docs commands options out)
+            (if (eq? 'or (caar ls))
+                (lp (cdr ls) docs (cdar ls) options)
+                (lp (cdr ls) docs (list (car ls)) options))))
+       (else
+        (lp (cdr ls) docs commands options))))))
+
+(define (app-help-command config spec . args)
+  (app-help spec args (current-output-port)))
+
+(define (run-application spec . o)
+  (let ((args (or (and (pair? o) (car o)) (command-line)))
+        (config (and (pair? o) (pair? (cdr o)) (cadr o))))
+    (cond
+     ((parse-app '() (cdr spec) '() (cdr args) config #f #f)
+      => (lambda (v)
+           (let ((proc (vector-ref v 0))
+                 (cfg (vector-ref v 1))
+                 (args (vector-ref v 2))
+                 (init (vector-ref v 3))
+                 (end (vector-ref v 4)))
+             (if init (init cfg))
+             (apply proc cfg spec args)
+             (if end (end cfg)))))
+     ((null? (cdr args))
+      (apply app-help-command config spec args)
+      (error "Expected a command"))
+     (else
+      (error "Unknown command: " (cdr args))))))

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,656 @@
+/*  ast.c -- interface to the Abstract Syntax Tree            */
+/*  Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+
+#ifndef PLAN9
+#include <errno.h>
+#endif
+
+#if ! SEXP_USE_BOEHM
+extern sexp sexp_gc (sexp ctx, size_t *sum_freed);
+#endif
+
+static void sexp_define_type_predicate (sexp ctx, sexp env, const char *cname, sexp_uint_t type) {
+  sexp_gc_var2(name, op);
+  sexp_gc_preserve2(ctx, name, op);
+  name = sexp_c_string(ctx, cname, -1);
+  op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type));
+  sexp_env_define(ctx, env, name=sexp_intern(ctx, cname, -1), op);
+  sexp_gc_release2(ctx);
+}
+
+static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype,
+                                   sexp_uint_t cindex,
+                                   const char* get, const char *set) {
+  sexp type, index;
+  sexp_gc_var2(name, op);
+  sexp_gc_preserve2(ctx, name, op);
+  type = sexp_make_fixnum(ctype);
+  index = sexp_make_fixnum(cindex);
+  if (get) {
+    op = sexp_make_getter(ctx, name=sexp_c_string(ctx, get, -1), type, index);
+    sexp_env_define(ctx, env, name=sexp_intern(ctx, get, -1), op);
+  }
+  if (set) {
+    op = sexp_make_setter(ctx, name=sexp_c_string(ctx, set, -1), type, index);
+    sexp_env_define(ctx, env, name=sexp_intern(ctx, set, -1), op);
+  }
+  sexp_gc_release2(ctx);
+}
+
+static sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id, sexp createp) {
+  sexp cell;
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
+  cell = sexp_env_cell(ctx, env, id, 0);
+  if (! cell) {
+    if (sexp_synclop(id)) {
+      env = sexp_synclo_env(id);
+      id = sexp_synclo_expr(id);
+    }
+    cell = sexp_env_cell(ctx, env, id, 0);
+    if (!cell && createp)
+      cell = sexp_env_cell_define(ctx, env, id, SEXP_UNDEF, NULL);
+  }
+  return cell ? cell : SEXP_FALSE;
+}
+
+static sexp sexp_get_procedure_code (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
+  return sexp_procedure_code(proc);
+}
+
+static sexp sexp_get_procedure_vars (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
+  return sexp_procedure_vars(proc);
+}
+
+static sexp sexp_get_procedure_arity (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
+  return sexp_make_fixnum(sexp_procedure_num_args(proc));
+}
+
+static sexp sexp_get_procedure_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
+  return sexp_make_boolean(sexp_procedure_variadic_p(proc));
+}
+
+static sexp sexp_get_opcode_name (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+  if (! sexp_opcodep(op))
+    return sexp_type_exception(ctx, self, SEXP_OPCODE, op);
+  else if (! sexp_opcode_name(op))
+    return SEXP_FALSE;
+  else
+    return sexp_opcode_name(op);
+}
+
+static sexp sexp_translate_opcode_type (sexp ctx, sexp type) {
+  sexp_gc_var2(res, tmp);
+  res = type;
+  if (! res) {
+    res = sexp_type_by_index(ctx, SEXP_OBJECT);
+  } if (sexp_fixnump(res)) {
+    res = sexp_type_by_index(ctx, sexp_unbox_fixnum(res));
+  } else if (sexp_nullp(res)) {        /* opcode list types */
+    sexp_gc_preserve2(ctx, res, tmp);
+    tmp = sexp_intern(ctx, "or", -1);
+    res = sexp_cons(ctx, SEXP_NULL, SEXP_NULL);
+    res = sexp_cons(ctx, sexp_type_by_index(ctx, SEXP_PAIR), res);
+    res = sexp_cons(ctx, tmp, res);
+    sexp_gc_release2(ctx);
+  }
+  return res;
+}
+
+static sexp sexp_get_opcode_ret_type (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+  sexp res;
+  if (!op)
+    return sexp_type_by_index(ctx, SEXP_OBJECT);
+  if (! sexp_opcodep(op))
+    return sexp_type_exception(ctx, self, SEXP_OPCODE, op);
+  if (sexp_opcode_code(op) == SEXP_OP_RAISE)
+    return sexp_list1(ctx, sexp_intern(ctx, "error", -1));
+  res = sexp_opcode_return_type(op);
+  if (sexp_fixnump(res))
+    res = sexp_type_by_index(ctx, sexp_unbox_fixnum(res));
+  return sexp_translate_opcode_type(ctx, res);
+}
+
+static sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp op, sexp k) {
+  sexp res;
+  int p = sexp_unbox_fixnum(k);
+  if (! sexp_opcodep(op))
+    return sexp_type_exception(ctx, self, SEXP_OPCODE, op);
+  else if (! sexp_fixnump(k))
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, k);
+  if (p > sexp_opcode_num_args(op) && sexp_opcode_variadic_p(op))
+    p = sexp_opcode_num_args(op);
+  switch (p) {
+  case 0:
+    res = sexp_opcode_arg1_type(op);
+    break;
+  case 1:
+    res = sexp_opcode_arg2_type(op);
+    break;
+  default:
+    res = sexp_opcode_arg3_type(op);
+    if (res && sexp_vectorp(res)) {
+      if (sexp_vector_length(res) > (sexp_unbox_fixnum(k)-2))
+        res = sexp_vector_ref(res, sexp_fx_sub(k, SEXP_TWO));
+      else
+        res = sexp_type_by_index(ctx, SEXP_OBJECT);
+    }
+    break;
+  }
+  return sexp_translate_opcode_type(ctx, res);
+}
+
+static sexp sexp_get_opcode_class (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+  sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
+  return sexp_make_fixnum(sexp_opcode_class(op));
+}
+
+static sexp sexp_get_opcode_code (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+  sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
+  return sexp_make_fixnum(sexp_opcode_code(op));
+}
+
+static sexp sexp_get_opcode_data (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+  sexp data;
+  sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
+  data = sexp_opcode_data(op);
+  if (!data) return SEXP_VOID;
+  return sexp_opcode_class(op) == SEXP_OPC_TYPE_PREDICATE
+    && 0 <= sexp_unbox_fixnum(data)
+    && sexp_unbox_fixnum(data) <= sexp_context_num_types(ctx) ?
+    sexp_type_by_index(ctx, sexp_unbox_fixnum(data)) : data;
+}
+
+static sexp sexp_get_opcode_num_params (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+  sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
+  return sexp_make_fixnum(sexp_opcode_num_args(op));
+}
+
+static sexp sexp_get_opcode_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+  sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
+  return sexp_make_boolean(sexp_opcode_variadic_p(op));
+}
+
+static sexp sexp_get_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p) {
+  sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p);
+  return sexp_make_fixnum(sexp_port_line(p));
+}
+
+static sexp sexp_set_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p, sexp i) {
+  sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
+  sexp_port_line(p) = sexp_unbox_fixnum(i);
+  return SEXP_VOID;
+}
+
+static sexp sexp_type_of (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  if (!x)
+    return sexp_type_by_index(ctx, SEXP_OBJECT);
+  if (sexp_pointerp(x))
+    return sexp_object_type(ctx, x);
+  else if (sexp_fixnump(x))
+    return sexp_type_by_index(ctx, SEXP_FIXNUM);
+  else if (sexp_booleanp(x))
+    return sexp_type_by_index(ctx, SEXP_BOOLEAN);
+  else if (sexp_charp(x))
+    return sexp_type_by_index(ctx, SEXP_CHAR);
+#if SEXP_USE_HUFF_SYMS
+  else if (sexp_symbolp(x))
+    return sexp_type_by_index(ctx, SEXP_SYMBOL);
+#endif
+#if SEXP_USE_IMMEDIATE_FLONUMS
+  else if (sexp_flonump(x))
+    return sexp_type_by_index(ctx, SEXP_FLONUM);
+#endif
+  else
+    return sexp_type_by_index(ctx, SEXP_OBJECT);
+}
+
+static sexp sexp_env_parent_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
+  return sexp_env_parent(e) ? sexp_env_parent(e) : SEXP_FALSE;
+}
+
+static sexp sexp_env_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
+  return sexp_env_lambda(e) ? sexp_env_lambda(e) : SEXP_FALSE;
+}
+
+static sexp sexp_env_lambda_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp lam) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
+  sexp_assert_type(ctx, sexp_lambdap, SEXP_LAMBDA, lam);
+  sexp_env_lambda(e) = lam;
+  return SEXP_VOID;
+}
+
+static sexp sexp_env_syntactic_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
+  return sexp_make_boolean(sexp_env_syntactic_p(e));
+}
+
+static sexp sexp_env_syntactic_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp synp) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
+  sexp_env_syntactic_p(e) = sexp_truep(synp);
+  return SEXP_VOID;
+}
+
+static sexp sexp_env_define_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
+  sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name);
+  return sexp_env_cell_define(ctx, env, name, value, NULL);
+}
+
+static sexp sexp_env_push_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
+  sexp_gc_var1(tmp);
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
+  sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name);
+  sexp_gc_preserve1(ctx, tmp);
+  sexp_env_push(ctx, env, tmp, name, value);
+  sexp_gc_release1(ctx);
+  return SEXP_VOID;
+}
+
+static sexp sexp_core_code_op (sexp ctx, sexp self, sexp_sint_t n, sexp c) {
+  sexp_assert_type(ctx, sexp_corep, SEXP_CORE, c);
+  return sexp_make_fixnum(sexp_core_code(c));
+}
+
+static sexp sexp_type_name_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+  sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
+  return sexp_type_name(t);
+}
+
+static sexp sexp_type_cpl_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+  sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
+  return sexp_type_cpl(t);
+}
+
+static sexp sexp_type_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+  sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
+  return sexp_type_slots(t);
+}
+
+static sexp sexp_type_num_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+  sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
+  return sexp_truep(sexp_type_slots(t)) ? sexp_length(ctx, sexp_type_slots(t))
+    : sexp_make_fixnum(sexp_type_field_eq_len_base(t));
+}
+
+static sexp sexp_type_printer_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+  sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
+  return sexp_type_print(t) ? sexp_type_print(t) : SEXP_FALSE;
+}
+
+static sexp sexp_object_size (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  sexp t;
+  if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx)))
+    return SEXP_ZERO;
+  t = sexp_object_type(ctx, x);
+  return sexp_make_fixnum(sexp_type_size_of_object(t, x));
+}
+
+static sexp sexp_integer_to_immediate (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp dflt) {
+  sexp x = (sexp)sexp_unbox_fixnum(i);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
+  if (sexp_pointerp(x))
+    return dflt;
+  return x;
+}
+
+static sexp sexp_make_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp params, sexp body, sexp locals) {
+  sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA);
+  sexp_lambda_name(res) = name;
+  sexp_lambda_params(res) = params;
+  sexp_lambda_body(res) = body;
+  sexp_lambda_locals(res) = locals;
+  sexp_lambda_fv(res) = SEXP_NULL;
+  sexp_lambda_sv(res) = SEXP_NULL;
+  sexp_lambda_defs(res) = SEXP_NULL;
+  sexp_lambda_return_type(res) = SEXP_FALSE;
+  sexp_lambda_param_types(res) = SEXP_NULL;
+  return res;
+}
+
+static sexp sexp_copy_lambda (sexp ctx, sexp self, sexp_sint_t n, sexp lambda) {
+  sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA);
+  sexp_lambda_name(res) = sexp_lambda_name(lambda);
+  sexp_lambda_params(res) = sexp_lambda_params(lambda);
+  sexp_lambda_body(res) = sexp_lambda_body(lambda);
+  sexp_lambda_locals(res) = sexp_lambda_locals(lambda);
+  sexp_lambda_fv(res) = sexp_lambda_fv(lambda);
+  sexp_lambda_sv(res) = sexp_lambda_sv(lambda);
+  sexp_lambda_defs(res) = sexp_lambda_defs(lambda);
+  sexp_lambda_return_type(res) = sexp_lambda_return_type(lambda);
+  sexp_lambda_param_types(res) = sexp_lambda_param_types(lambda);
+  return res;
+}
+
+static sexp sexp_make_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp var, sexp value) {
+  sexp res = sexp_alloc_type(ctx, set, SEXP_SET);
+  sexp_set_var(res) = var;
+  sexp_set_value(res) = value;
+  return res;
+}
+
+static sexp sexp_make_ref_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp cell) {
+  sexp res = sexp_alloc_type(ctx, ref, SEXP_REF);
+  sexp_ref_name(res) = name;
+  sexp_ref_cell(res) = cell;
+  return res;
+}
+
+static sexp sexp_make_cnd_op (sexp ctx, sexp self, sexp_sint_t n, sexp test, sexp pass, sexp fail) {
+  sexp res = sexp_alloc_type(ctx, cnd, SEXP_CND);
+  sexp_cnd_test(res) = test;
+  sexp_cnd_pass(res) = pass;
+  sexp_cnd_fail(res) = fail;
+  return res;
+}
+
+static sexp sexp_make_seq (sexp ctx, sexp self, sexp_sint_t n, sexp ls) {
+  sexp res = sexp_alloc_type(ctx, seq, SEXP_SEQ);
+  sexp_seq_ls(res) = ls;
+  return res;
+}
+
+static sexp sexp_make_lit_op (sexp ctx, sexp self, sexp_sint_t n, sexp value) {
+  sexp res = sexp_alloc_type(ctx, lit, SEXP_LIT);
+  sexp_lit_value(res) = value;
+  return res;
+}
+
+static sexp sexp_make_macro_op (sexp ctx, sexp self, sexp_sint_t n, sexp proc, sexp env) {
+  sexp res = sexp_alloc_type(ctx, macro, SEXP_MACRO);
+  sexp_macro_proc(res) = proc;
+  sexp_macro_env(res) = env;
+  return res;
+}
+
+static sexp sexp_analyze_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) {
+  sexp ctx2 = ctx;
+  if (sexp_envp(e)) {
+    ctx2 = sexp_make_child_context(ctx, NULL);
+    sexp_context_env(ctx2) = e;
+  }
+  return sexp_analyze(ctx2, x);
+}
+
+static sexp sexp_extend_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp vars, sexp value) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
+  return sexp_extend_env(ctx, env, vars, value);
+}
+
+static sexp sexp_optimize (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  sexp_gc_var2(ls, res);
+  sexp_gc_preserve2(ctx, ls, res);
+  res = x;
+  ls = sexp_global(ctx, SEXP_G_OPTIMIZATIONS);
+  for ( ; sexp_pairp(ls); ls=sexp_cdr(ls))
+    res = sexp_apply1(ctx, sexp_cdar(ls), res);
+  sexp_free_vars(ctx, res, SEXP_NULL);
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+static sexp sexp_gc_op (sexp ctx, sexp self, sexp_sint_t n) {
+  size_t sum_freed=0;
+#if SEXP_USE_BOEHM
+  GC_gcollect();
+#else
+  sexp_gc(ctx, &sum_freed);
+#endif
+  return sexp_make_unsigned_integer(ctx, sum_freed);
+}
+
+#if SEXP_USE_GREEN_THREADS
+static sexp sexp_set_atomic (sexp ctx, sexp self, sexp_sint_t n, sexp new) {
+  sexp res = sexp_global(ctx, SEXP_G_ATOMIC_P);
+  sexp_global(ctx, SEXP_G_ATOMIC_P) = new;
+  return res;
+}
+#endif
+
+sexp sexp_thread_list (sexp ctx, sexp self, sexp_sint_t n) {
+  sexp ls;
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  res = SEXP_NULL;
+#if SEXP_USE_GREEN_THREADS
+  for (ls=sexp_global(ctx, SEXP_G_THREADS_FRONT); sexp_pairp(ls); ls=sexp_cdr(ls))
+    sexp_push(ctx, res, sexp_car(ls));
+  for (ls=sexp_global(ctx, SEXP_G_THREADS_PAUSED); sexp_pairp(ls); ls=sexp_cdr(ls))
+    sexp_push(ctx, res, sexp_car(ls));
+#endif
+  if (sexp_not(sexp_memq(ctx, ctx, res))) sexp_push(ctx, res, ctx);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+static sexp sexp_string_contains (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
+  const char *res;
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, x);
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, y);
+  res = strstr(sexp_string_data(x), sexp_string_data(y));
+  return res ? sexp_make_fixnum(res-sexp_string_data(x)) : SEXP_FALSE;
+}
+
+static sexp sexp_string_cursor_copy (sexp ctx, sexp self, sexp_sint_t n, sexp dst, sexp sfrom, sexp src, sexp sstart, sexp send) {
+  unsigned char *pfrom, *pto, *pstart, *pend, *prev, *p;
+  sexp_sint_t from = sexp_unbox_fixnum(sfrom), to = sexp_string_size(dst),
+    start = sexp_unbox_fixnum(sstart), end = sexp_unbox_fixnum(send);
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, dst);
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, src);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, sfrom);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, sstart);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, send);
+  if (from < 0 || from > to)
+    return sexp_user_exception(ctx, self, "string-cursor-copy!: from out of range", sfrom);
+  if (start < 0 || start > sexp_string_size(src))
+    return sexp_user_exception(ctx, self, "string-cursor-copy!: start out of range", sstart);
+  if (end < start || end > sexp_string_size(src))
+    return sexp_user_exception(ctx, self, "string-cursor-copy!: end out of range", send);
+  pfrom = (unsigned char*)sexp_string_data(dst) + from;
+  pto = (unsigned char*)sexp_string_data(dst) + to;
+  pstart = (unsigned char*)sexp_string_data(src) + start;
+  pend = (unsigned char*)sexp_string_data(src) + end;
+  for ( ; pfrom < pto && pstart < pend; ++pfrom, ++pstart)
+    *pfrom = *pstart;
+  /* adjust for incomplete trailing chars */
+  prev = (unsigned char*)sexp_string_utf8_prev(pfrom);
+  if (sexp_utf8_initial_byte_count(*prev) > pfrom - prev) {
+    for (p = prev; p < pfrom; ++p)
+      *p = '\0';
+    pstart -= pfrom - prev;
+  }
+  return sexp_make_fixnum(pstart - (unsigned char*)sexp_string_data(src));
+}
+
+static sexp sexp_errno (sexp ctx, sexp self, sexp_sint_t n) {
+#ifdef PLAN9
+  return SEXP_FALSE;
+#else
+  return sexp_make_fixnum(errno);
+#endif
+}
+
+static sexp sexp_error_string (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+#ifdef PLAN9
+  return SEXP_FALSE;
+#else
+  int err;
+  if (x == SEXP_FALSE) {
+    err = errno;
+  } else {
+    sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, x);
+    err = sexp_unbox_fixnum(x);
+  }
+  return sexp_c_string(ctx, strerror(err), -1);
+#endif
+}
+
+static sexp sexp_update_free_vars (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  return sexp_free_vars(ctx, x, SEXP_NULL);
+}
+
+static sexp sexp_setenv (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp value) {
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name);
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, value);
+  return sexp_make_boolean(setenv(sexp_string_data(name), sexp_string_data(value), 1));
+}
+
+static sexp sexp_unsetenv (sexp ctx, sexp self, sexp_sint_t n, sexp name) {
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name);
+  return sexp_make_boolean(unsetenv(sexp_string_data(name)));
+}
+
+#define sexp_define_type(ctx, name, tag) \
+  sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), sexp_type_by_index(ctx, tag));
+
+sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
+  if (!(sexp_version_compatible(ctx, version, sexp_version)
+        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
+    return SEXP_ABI_ERROR;
+  sexp_define_type(ctx, "Object", SEXP_OBJECT);
+  sexp_define_type(ctx, "Number", SEXP_NUMBER);
+  sexp_define_type(ctx, "Bignum", SEXP_BIGNUM);
+  sexp_define_type(ctx, "Flonum", SEXP_FLONUM);
+  sexp_define_type(ctx, "Integer", SEXP_FIXNUM);
+#if SEXP_USE_RATIOS
+  sexp_define_type(ctx, "Ratio", SEXP_RATIO);
+#endif
+#if SEXP_USE_COMPLEX
+  sexp_define_type(ctx, "Complex", SEXP_COMPLEX);
+#endif
+  sexp_define_type(ctx, "Symbol", SEXP_SYMBOL);
+  sexp_define_type(ctx, "Char", SEXP_CHAR);
+  sexp_define_type(ctx, "Boolean", SEXP_BOOLEAN);
+  sexp_define_type(ctx, "String", SEXP_STRING);
+  sexp_define_type(ctx, "Byte-Vector", SEXP_BYTES);
+  sexp_define_type(ctx, "Pair", SEXP_PAIR);
+  sexp_define_type(ctx, "Vector", SEXP_VECTOR);
+  sexp_define_type(ctx, "Input-Port", SEXP_IPORT);
+  sexp_define_type(ctx, "Output-Port", SEXP_OPORT);
+  sexp_define_type(ctx, "File-Descriptor", SEXP_FILENO);
+  sexp_define_type(ctx, "Opcode", SEXP_OPCODE);
+  sexp_define_type(ctx, "Procedure", SEXP_PROCEDURE);
+  sexp_define_type(ctx, "Bytecode", SEXP_BYTECODE);
+  sexp_define_type(ctx, "Env", SEXP_ENV);
+  sexp_define_type(ctx, "Macro", SEXP_MACRO);
+  sexp_define_type(ctx, "Lam", SEXP_LAMBDA);
+  sexp_define_type(ctx, "Cnd", SEXP_CND);
+  sexp_define_type(ctx, "Set", SEXP_SET);
+  sexp_define_type(ctx, "Ref", SEXP_REF);
+  sexp_define_type(ctx, "Seq", SEXP_SEQ);
+  sexp_define_type(ctx, "Lit", SEXP_LIT);
+  sexp_define_type(ctx, "Sc", SEXP_SYNCLO);
+  sexp_define_type(ctx, "Context", SEXP_CONTEXT);
+  sexp_define_type(ctx, "Exception", SEXP_EXCEPTION);
+  sexp_define_type(ctx, "Core", SEXP_CORE);
+  sexp_define_type_predicate(ctx, env, "environment?", SEXP_ENV);
+  sexp_define_type_predicate(ctx, env, "bytecode?", SEXP_BYTECODE);
+  sexp_define_type_predicate(ctx, env, "macro?", SEXP_MACRO);
+  sexp_define_type_predicate(ctx, env, "syntactic-closure?", SEXP_SYNCLO);
+  sexp_define_type_predicate(ctx, env, "lambda?", SEXP_LAMBDA);
+  sexp_define_type_predicate(ctx, env, "cnd?", SEXP_CND);
+  sexp_define_type_predicate(ctx, env, "set?", SEXP_SET);
+  sexp_define_type_predicate(ctx, env, "ref?", SEXP_REF);
+  sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ);
+  sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT);
+  sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE);
+  sexp_define_type_predicate(ctx, env, "type?", SEXP_TYPE);
+  sexp_define_type_predicate(ctx, env, "core?", SEXP_CORE);
+  sexp_define_type_predicate(ctx, env, "context?", SEXP_CONTEXT);
+  sexp_define_type_predicate(ctx, env, "file-descriptor?", SEXP_FILENO);
+  sexp_define_accessors(ctx, env, SEXP_SYNCLO, 0, "syntactic-closure-env", NULL);
+  sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", NULL);
+  sexp_define_accessors(ctx, env, SEXP_SYNCLO, 2, "syntactic-closure-expr", NULL);
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 0, "lambda-name", "lambda-name-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 1, "lambda-params", "lambda-params-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 2, "lambda-body", "lambda-body-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 3, "lambda-defs", "lambda-defs-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 4, "lambda-locals", "lambda-locals-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 5, "lambda-flags", "lambda-flags-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 6, "lambda-free-vars", "lambda-free-vars-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 7, "lambda-set-vars", "lambda-set-vars-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 8, "lambda-return-type", "lambda-return-type-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 9, "lambda-param-types", "lambda-param-types-set!");
+  sexp_define_accessors(ctx, env, SEXP_LAMBDA, 10, "lambda-source", "lambda-source-set!");
+  sexp_define_accessors(ctx, env, SEXP_CND, 0, "cnd-test", "cnd-test-set!");
+  sexp_define_accessors(ctx, env, SEXP_CND, 1, "cnd-pass", "cnd-pass-set!");
+  sexp_define_accessors(ctx, env, SEXP_CND, 2, "cnd-fail", "cnd-fail-set!");
+  sexp_define_accessors(ctx, env, SEXP_SET, 0, "set-var", "set-var-set!");
+  sexp_define_accessors(ctx, env, SEXP_SET, 1, "set-value", "set-value-set!");
+  sexp_define_accessors(ctx, env, SEXP_REF, 0, "ref-name", "ref-name-set!");
+  sexp_define_accessors(ctx, env, SEXP_REF, 1, "ref-cell", "ref-cell-set!");
+  sexp_define_accessors(ctx, env, SEXP_SEQ, 0, "seq-ls", "seq-ls-set!");
+  sexp_define_accessors(ctx, env, SEXP_LIT, 0, "lit-value", "lit-value-set!");
+  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 2, "bytecode-name", "bytecode-name-set!");
+  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 3, "bytecode-literals", NULL);
+  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 4, "bytecode-source", NULL);
+  sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 1, "exception-message", NULL);
+  sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 4, "exception-source", NULL);
+  sexp_define_accessors(ctx, env, SEXP_MACRO, 0, "macro-procedure", NULL);
+  sexp_define_accessors(ctx, env, SEXP_MACRO, 1, "macro-env", NULL);
+  sexp_define_accessors(ctx, env, SEXP_MACRO, 2, "macro-source", NULL);
+  sexp_define_foreign(ctx, env, "procedure-code", 1, sexp_get_procedure_code);
+  sexp_define_foreign(ctx, env, "procedure-vars", 1, sexp_get_procedure_vars);
+  sexp_define_foreign(ctx, env, "procedure-arity", 1, sexp_get_procedure_arity);
+  sexp_define_foreign(ctx, env, "procedure-variadic?", 1, sexp_get_procedure_variadic_p);
+  sexp_define_foreign(ctx, env, "copy-lambda", 1, sexp_copy_lambda);
+  sexp_define_foreign_opt(ctx, env, "make-lambda", 4, sexp_make_lambda_op, SEXP_NULL);
+  sexp_define_foreign_opt(ctx, env, "make-cnd", 3, sexp_make_cnd_op, SEXP_VOID);
+  sexp_define_foreign(ctx, env, "make-ref", 2, sexp_make_ref_op);
+  sexp_define_foreign(ctx, env, "make-set", 2, sexp_make_set_op);
+  sexp_define_foreign(ctx, env, "make-lit", 1, sexp_make_lit_op);
+  sexp_define_foreign(ctx, env, "make-seq", 1, sexp_make_seq);
+  sexp_define_foreign(ctx, env, "make-macro", 2, sexp_make_macro_op);
+  sexp_define_foreign_opt(ctx, env, "analyze", 2, sexp_analyze_op, SEXP_FALSE);
+  sexp_define_foreign(ctx, env, "optimize", 1, sexp_optimize);
+  sexp_define_foreign(ctx, env, "extend-env", 3, sexp_extend_env_op);
+  sexp_define_foreign_opt(ctx, env, "env-cell", 3, sexp_get_env_cell, SEXP_FALSE);
+  sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name);
+  sexp_define_foreign(ctx, env, "opcode-class", 1, sexp_get_opcode_class);
+  sexp_define_foreign(ctx, env, "opcode-code", 1, sexp_get_opcode_code);
+  sexp_define_foreign(ctx, env, "opcode-data", 1, sexp_get_opcode_data);
+  sexp_define_foreign(ctx, env, "opcode-variadic?", 1, sexp_get_opcode_variadic_p);
+  sexp_define_foreign(ctx, env, "opcode-num-params", 1, sexp_get_opcode_num_params);
+  sexp_define_foreign(ctx, env, "opcode-return-type", 1, sexp_get_opcode_ret_type);
+  sexp_define_foreign(ctx, env, "opcode-param-type", 2, sexp_get_opcode_param_type);
+  sexp_define_foreign(ctx, env, "port-line", 1, sexp_get_port_line);
+  sexp_define_foreign(ctx, env, "port-line-set!", 2, sexp_set_port_line);
+  sexp_define_foreign(ctx, env, "type-of", 1, sexp_type_of);
+  sexp_define_foreign(ctx, env, "type-name", 1, sexp_type_name_op);
+  sexp_define_foreign(ctx, env, "type-cpl", 1, sexp_type_cpl_op);
+  sexp_define_foreign(ctx, env, "type-slots", 1, sexp_type_slots_op);
+  sexp_define_foreign(ctx, env, "type-num-slots", 1, sexp_type_num_slots_op);
+  sexp_define_foreign(ctx, env, "type-printer", 1, sexp_type_printer_op);
+  sexp_define_foreign(ctx, env, "env-parent-set!", 2, sexp_env_parent_set_op);
+  sexp_define_foreign(ctx, env, "env-lambda", 1, sexp_env_lambda_op);
+  sexp_define_foreign(ctx, env, "env-lambda-set!", 2, sexp_env_lambda_set_op);
+  sexp_define_foreign(ctx, env, "env-syntactic?", 1, sexp_env_syntactic_op);
+  sexp_define_foreign(ctx, env, "env-syntactic?-set!", 2, sexp_env_syntactic_set_op);
+  sexp_define_foreign(ctx, env, "env-define!", 3, sexp_env_define_op);
+  sexp_define_foreign(ctx, env, "env-push!", 3, sexp_env_push_op);
+  sexp_define_foreign(ctx, env, "core-code", 1, sexp_core_code_op);
+  sexp_define_foreign(ctx, env, "object-size", 1, sexp_object_size);
+  sexp_define_foreign_opt(ctx, env, "integer->immediate", 2, sexp_integer_to_immediate, SEXP_FALSE);
+  sexp_define_foreign(ctx, env, "gc", 0, sexp_gc_op);
+#if SEXP_USE_GREEN_THREADS
+  sexp_define_foreign(ctx, env, "%set-atomic!", 1, sexp_set_atomic);
+#endif
+  sexp_define_foreign(ctx, env, "thread-list", 0, sexp_thread_list);
+  sexp_define_foreign(ctx, env, "string-contains", 2, sexp_string_contains);
+  sexp_define_foreign(ctx, env, "string-cursor-copy!", 5, sexp_string_cursor_copy);
+  sexp_define_foreign(ctx, env, "errno", 0, sexp_errno);
+  sexp_define_foreign_opt(ctx, env, "integer->error-string", 1, sexp_error_string, SEXP_FALSE);
+  sexp_define_foreign(ctx, env, "update-free-vars!", 1, sexp_update_free_vars);
+  sexp_define_foreign(ctx, env, "setenv", 2, sexp_setenv);
+  sexp_define_foreign(ctx, env, "unsetenv", 1, sexp_unsetenv);
+  return SEXP_VOID;
+}

lib/chibi/ast.scm

@@ -0,0 +1,390 @@
+;; ast.scm -- ast utilities
+;; Copyright (c) 2010-2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> Abstract Syntax Tree.  Interface to the types used by
+;;> the compiler, and other core types less commonly
+;;> needed in user code, plus related utilities.
+
+;;> \section{Analysis and Expansion}
+
+;;> \procedure{(analyze x [env])}
+
+;;> Expands and analyzes the expression \var{x} and returns the
+;;> resulting AST.
+
+;;> \procedure{(optimize ast)}
+
+;;> Runs an optimization pass on \var{ast} and returns the
+;;> resulting simplified expression.
+
+(define (ast-renames ast)
+  (define i 0)
+  (define renames '())
+  (define (rename-symbol id)
+    (set! i (+ i 1))
+    (string->symbol
+     (string-append (symbol->string (identifier->symbol id))
+                    "." (number->string i))))
+  (define (rename-lambda lam)
+    (or (assq lam renames)
+        (let ((res (list lam)))
+          (set! renames (cons res renames))
+          res)))
+  (define (rename! id lam)
+    (let ((cell (rename-lambda lam)))
+      (set-cdr! cell (cons (cons id (rename-symbol id)) (cdr cell)))))
+  (define (check-ref id lam env)
+    (let ((sym (identifier->symbol id)))
+      (let lp1 ((ls env))
+        (cond
+         ((pair? ls)
+          (let lp2 ((ls2 (car ls)) (found? #f))
+            (cond
+             ((null? ls2)
+              (if (not found?) (lp1 (cdr ls))))
+             ((and (eq? id (caar ls2)) (eq? lam (cdar ls2)))
+               (lp2 (cdr ls2) #t))
+             ((eq? sym (identifier->symbol (caar ls2)))
+              (rename! (caar ls2) (cdar ls2))
+              (lp2 (cdr ls2) found?))
+             (else
+              (lp2 (cdr ls2) found?)))))))))
+  (define (extend-env lam env)
+    (cons (map (lambda (x) (cons x lam)) (flatten-dot (lambda-params lam))) env))
+  (let lp ((x ast) (env '()))
+    (cond
+     ((lambda? x) (lp (lambda-body x) (extend-env x env)))
+     ((ref? x) (check-ref (ref-name x) (cdr (ref-cell x)) env))
+     ((cnd? x) (lp (cnd-test x) env) (lp (cnd-pass x) env) (lp (cnd-fail x) env))
+     ((set? x) (lp (set-var x) env) (lp (set-value x) env))
+     ((seq? x) (for-each (lambda (x) (lp x env)) (seq-ls x)))
+     ((pair? x) (for-each (lambda (x) (lp x env)) x))))
+  renames)
+
+(define (flatten-dot x)
+  (cond ((pair? x) (cons (car x) (flatten-dot (cdr x))))
+        ((null? x) x)
+        (else (list x))))
+
+(define (get-rename id lam renames)
+  (let ((ls (assq lam renames)))
+    (if (not ls)
+        (identifier->symbol id)
+        (cond ((assq id (cdr ls)) => cdr) (else (identifier->symbol id))))))
+
+(define (map* f ls)
+  (cond ((pair? ls) (cons (f (car ls)) (map* f (cdr ls))))
+        ((null? ls) '())
+        (else (f ls))))
+
+;;> Performs a full syntax expansion of the form \var{x} and
+;;> returns the resulting s-expression.
+
+(define (macroexpand x)
+  (ast->sexp (analyze x)))
+
+;;> Convert \var{ast} to a s-expression, renaming variables if
+;;> necessary.
+
+(define (ast->sexp ast)
+  (let ((renames (ast-renames ast)))
+    (let a2s ((x ast))
+      (cond
+       ((lambda? x)
+        `(lambda ,(map* (lambda (id) (get-rename id x renames)) (lambda-params x))
+           ,@(map (lambda (d) `(define ,(identifier->symbol (caar d)) #f))
+                  (lambda-defs x))
+           ,@(if (seq? (lambda-body x))
+                 (map a2s (seq-ls (lambda-body x)))
+                 (list (a2s (lambda-body x))))))
+       ((cnd? x) `(if ,(a2s (cnd-test x)) ,(a2s (cnd-pass x)) ,(a2s (cnd-fail x))))
+       ((set? x) `(set! ,(a2s (set-var x)) ,(a2s (set-value x))))
+       ((ref? x) (get-rename (ref-name x) (cdr (ref-cell x)) renames))
+       ((seq? x) `(begin ,@(map a2s (seq-ls x))))
+       ((lit? x)
+        (let ((v (lit-value x)))
+          (if (or (pair? v) (null? v) (symbol? v)) `',v v)))
+       ((pair? x) (cons (a2s (car x)) (a2s (cdr x))))
+       ((opcode? x) (cond ((opcode-name x) => string->symbol) (else x)))
+       (else x)))))
+
+;;> \section{Types}
+
+;;> All objects have an associated type, and types may have parent
+;;> types.  When using
+;;> \hyperlink["http://srfi.schemers.org/srfi-9/srfi-9/html"]{SRFI-9}
+;;> \scheme{define-record-type}, the name is bound to a first class
+;;> type object.
+
+;;> The following core types are also available by name, and may be
+;;> used in the \scheme{match} \scheme{($ ...)} syntax.
+
+;;> \itemlist[
+;;> \item{\scheme{<object>} - the parent of all types}
+;;> \item{\scheme{<number>} - abstract numeric type}
+;;> \item{\scheme{<bignum>} - arbitrary precision exact integers}
+;;> \item{\scheme{<flonum>} - inexact real numbers}
+;;> \item{\scheme{<integer>} - abstract integer type}
+;;> \item{\scheme{<symbol>} - symbols}
+;;> \item{\scheme{<char>} - character}
+;;> \item{\scheme{<boolean>} - \scheme{#t} or \scheme{#f}}
+;;> \item{\scheme{<string>} - strings of characters}
+;;> \item{\scheme{<byte-vector>} - uniform vector of octets}
+;;> \item{\scheme{<pair>} - a \var{car} and \var{cdr}, the basis for lists}
+;;> \item{\scheme{<vector>} - vectors}
+;;> \item{\scheme{<opcode>} - a primitive opcode or C function}
+;;> \item{\scheme{<procedure>} - a closure}
+;;> \item{\scheme{<bytecode>} - the compiled code for a closure}
+;;> \item{\scheme{<env>} - an environment structure}
+;;> \item{\scheme{<macro>} - a macro object, usually not first-class}
+;;> \item{\scheme{<lam>} - a lambda AST type}
+;;> \item{\scheme{<cnd>} - an conditional AST type (i.e. \scheme{if})}
+;;> \item{\scheme{<ref>} - a reference AST type}
+;;> \item{\scheme{<set>} - a mutation AST type (i.e. \scheme{set!})}
+;;> \item{\scheme{<seq>} - a sequence AST type}
+;;> \item{\scheme{<lit>} - a literal AST type}
+;;> \item{\scheme{<sc>} - a syntactic closure}
+;;> \item{\scheme{<context>} - a context object (including threads)}
+;;> \item{\scheme{<exception>} - an exception object}
+;;> ]
+
+;;> The following extended type predicates may also be used to test
+;;> individual objects for their type:
+
+;;> \itemlist[
+;;> \item{\scheme{environment?}}
+;;> \item{\scheme{bytecode?}}
+;;> \item{\scheme{macro?}}
+;;> \item{\scheme{syntactic-closure?}}
+;;> \item{\scheme{lambda?}}
+;;> \item{\scheme{cnd?}}
+;;> \item{\scheme{ref?}}
+;;> \item{\scheme{set?}}
+;;> \item{\scheme{seq?}}
+;;> \item{\scheme{lit?}}
+;;> \item{\scheme{opcode?}}
+;;> \item{\scheme{type?}}
+;;> \item{\scheme{context?}}
+;;> \item{\scheme{exception?}}
+;;> ]
+
+;;> \procedure{(type-of x)}
+
+;;> Returns the type of any object \var{x}.
+
+;;> \procedure{(type-name type)}
+
+;;> Returns the name of type \var{type}.
+
+;;> \procedure{(type-parent type)}
+
+;;> Returns the immediate parent of type \var{type},
+;;> or \scheme{#f} for a type with no parent.
+
+(define (type-parent type)
+  (let ((v (type-cpl type)))
+    (and (vector? v)
+         (> (vector-length v) 1)
+         (vector-ref v (- (vector-length v) 2)))))
+
+;;> \procedure{(type-cpl type)}
+
+;;> Returns the class precedence list of type \var{type} as a
+;;> vector, or \scheme{#f} for a type with no parent.
+
+;;> \procedure{(type-slots type)}
+
+;;> Returns the slot list of type \var{type}.
+
+;;> \section{Accessors}
+
+;;> This section describes additional accessors on AST and other core
+;;> types.
+
+;;> \subsection{Procedures}
+
+;;> \itemlist[
+;;> \item{\scheme{(procedure-code f)} - the compiled bytecode object}
+;;> \item{\scheme{(procedure-vars f)} - the variables closed over by \var{f}}
+;;> \item{\scheme{(procedure-name f)} - the name of \var{f} if known, else \scheme{#f}}
+;;> ]
+
+(define (procedure-name x)
+  (bytecode-name (procedure-code x)))
+
+(define (procedure-name-set! x name)
+  (bytecode-name-set! (procedure-code x) name))
+
+;;> \subsection{Macros}
+
+;;> \itemlist[
+;;> \item{\scheme{(macro-procedure f)} - the macro procedure}
+;;> \item{\scheme{(macro-env f)} - the environment the macro was defined in}
+;;> \item{\scheme{(macro-source f)} - the source location the macro was defined in}
+;;> ]
+
+;;> \subsection{Bytecode Objects}
+
+;;> \itemlist[
+;;> \item{\scheme{(bytecode-name bc)} - the macro procedure}
+;;> \item{\scheme{(bytecode-literals bc)} - literals the bytecode references}
+;;> \item{\scheme{(bytecode-source bc)} - the source location the procedure was defined in}
+;;> ]
+
+;;> \subsection{Syntactic Closures}
+
+;;> \itemlist[
+;;> \item{\scheme{(syntactic-closure-env sc)}}
+;;> \item{\scheme{(syntactic-closure-vars sc)}}
+;;> \item{\scheme{(syntactic-closure-expr sc)}}
+;;> ]
+
+;;> Return the environment, free variables, and expression
+;;> associated with \var{sc} respectively.
+
+;;> \subsection{Exceptions}
+
+;;> \itemlist[
+;;> \item{\scheme{(exception-kind exn)}}
+;;> \item{\scheme{(exception-message exn)}}
+;;> \item{\scheme{(exception-irritants exn)}}
+;;> ]
+
+;;> Return the kind, message, and irritants
+;;> associated with \var{exn} respectively.
+
+;;> \subsection{Lambdas}
+
+;;> \itemlist[
+;;> \item{\scheme{(lambda-name lam)} - the name of the lambda, if known}
+;;> \item{\scheme{(lambda-name-set! lam x)}}
+;;> \item{\scheme{(lambda-params lam)} - the lambda parameter list}
+;;> \item{\scheme{(lambda-params-set! lam x)}}
+;;> \item{\scheme{(lambda-body lam)} - the body of the lambda}
+;;> \item{\scheme{(lambda-body-set! lam x)}}
+;;> \item{\scheme{(lambda-defs lam)} - internal definitions of the lambda}
+;;> \item{\scheme{(lambda-defs-set! lam x)}}
+;;> \item{\scheme{(lambda-locals lam)} - local variables as a list of identifiers}
+;;> \item{\scheme{(lambda-locals-set! lam x)}}
+;;> \item{\scheme{(lambda-flags lam)} - various flags describing the lambda}
+;;> \item{\scheme{(lambda-flags-set! lam x)}}
+;;> \item{\scheme{(lambda-free-vars lam)} - free variables the lambda will need to close over}
+;;> \item{\scheme{(lambda-free-vars-set! lam x)}}
+;;> \item{\scheme{(lambda-set-vars lam)} - variables the lambda mutates}
+;;> \item{\scheme{(lambda-set-vars-set! lam x)}}
+;;> \item{\scheme{(lambda-return-type lam)} - the return type of the lambda}
+;;> \item{\scheme{(lambda-return-type-set! lam x)}}
+;;> \item{\scheme{(lambda-param-types lam)} - the types of the input parameters}
+;;> \item{\scheme{(lambda-param-types-set! lam x)}}
+;;> \item{\scheme{(lambda-source lam)} - the source code of the lambda}
+;;> \item{\scheme{(lambda-source-set! lam x)}}
+;;> ]
+
+;;> \subsection{Conditionals}
+
+;;> \itemlist[
+;;> \item{\scheme{(cnd-test cnd)} - the test for the conditional}
+;;> \item{\scheme{(cnd-test-set! cnd x)}}
+;;> \item{\scheme{(cnd-pass cnd)} - the success branch}
+;;> \item{\scheme{(cnd-pass-set! cnd x)}}
+;;> \item{\scheme{(cnd-fail cnd)} - the failure branch}
+;;> \item{\scheme{(cnd-fail-set! cnd x)}}
+;;> ]
+
+;;> \subsection{Sequences}
+
+;;> \itemlist[
+;;> \item{\scheme{(seq-ls seq)} - the list of sequence expressions}
+;;> \item{\scheme{(seq-ls-set! seq x)}}
+;;> ]
+
+;;> \subsection{References}
+
+;;> \itemlist[
+;;> \item{\scheme{(ref-name ref)} - the name of the referenced variable}
+;;> \item{\scheme{(ref-name-set! ref x)}}
+;;> \item{\scheme{(ref-cell ref)} - the environment cell the reference resolves to}
+;;> \item{\scheme{(ref-cell-set! ref x)}}
+;;> ]
+
+;;> \subsection{Mutations}
+
+;;> \itemlist[
+;;> \item{\scheme{(set-var set)} - a reference to the mutated variable}
+;;> \item{\scheme{(set-var-set! set x)}}
+;;> \item{\scheme{(set-value set)} - the value to set the variable to}
+;;> \item{\scheme{(set-value-set! set x)}}
+;;> ]
+
+;;> \subsection{Literals}
+
+;;> \itemlist[
+;;> \item{\scheme{(lit-value lit)} - the literal value}
+;;> \item{\scheme{(lit-value-set! lit x)}}
+;;> ]
+
+;;> \subsection{Pairs}
+
+;;> \itemlist[
+;;> \item{\scheme{(pair-source x)}}
+;;> \item{\scheme{(pair-source-set! x source)}}
+;;> ]
+
+;;> Set or return the source code info associated with a pair x.
+;;> Source info is represented as another pair whose \var{car} is
+;;> the source file name and whose \var{cdr} is the line number.
+
+;;> \section{Miscellaneous Utilities}
+
+;;> \procedure{(gc)}
+
+;;> Force a garbage collection.
+
+;;> \procedure{(object-size x)}
+
+;;> Returns the heap space directly used by \var{x}, not
+;;> counting any elements of \var{x}.
+
+;;> \procedure{(integer->immediate n)}
+
+;;> Returns the interpretation of the integer \var{n} as
+;;> an immediate object, useful for debugging.
+
+;;> \procedure{(string-contains str pat)}
+
+;;> Returns the first string cursor of \var{pat} in \var{str},
+;;> of \scheme{#f} if it's not found.
+
+;;> \procedure{(safe-setenv name value)}
+
+;;> Equivalent to \scheme{setenv} but does nothing and returns
+;;> \scheme{#f} if \var{value} is a function definition.  Used to
+;;> circumvent the vulnerability of the shellshock bug.
+
+(define (safe-setenv name value)
+  (define (function-def? str)
+    (and (> (string-size value) 5)
+         (equal? "() {" (substring value 0 4))))
+  (and (not (function-def? value))
+       (setenv name value)))
+
+;;> \procedure{(atomically expr)}
+
+;;> Run \var{expr} atomically, disabling yields.  Ideally should only be
+;;> used for brief, deterministic expressions.  If used incorrectly (e.g.
+;;> running an infinite loop) can render the system unusable.
+;;> Never expose to a sandbox.
+
+(cond-expand
+ (threads
+  (define-syntax atomically
+    (syntax-rules ()
+      ((atomically . body)
+       (let* ((atomic? (%set-atomic! #t))
+              (res (begin . body)))
+         (%set-atomic! atomic?)
+         res)))))
+ (else
+  (define-syntax atomically
+    (syntax-rules () ((atomically . body) (begin . body))))))

lib/chibi/ast.sld

@@ -0,0 +1,42 @@
+
+(define-library (chibi ast)
+  (export
+   analyze optimize env-cell ast->sexp macroexpand type-of
+   Object Input-Port Output-Port Opcode Procedure Bytecode Macro Env
+   Number Bignum Flonum Integer Complex Char Boolean
+   Symbol String Byte-Vector Vector Pair File-Descriptor
+   Context Lam Cnd Set Ref Seq Lit Sc Exception Core
+   syntactic-closure? lambda? cnd? set? ref? seq? lit? type? core?
+   environment? bytecode? exception? macro? context? file-descriptor?
+   syntactic-closure-expr syntactic-closure-env syntactic-closure-vars
+   copy-lambda make-lambda make-cnd make-ref make-set make-seq make-lit
+   make-macro
+   lambda-name lambda-params lambda-body lambda-defs lambda-locals
+   lambda-flags lambda-free-vars lambda-set-vars lambda-return-type
+   lambda-param-types lambda-source
+   lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-set!
+   lambda-locals-set! lambda-flags-set! lambda-free-vars-set!
+   lambda-set-vars-set! lambda-return-type-set! lambda-param-types-set!
+   lambda-source-set!
+   cnd-test cnd-pass cnd-fail
+   cnd-test-set! cnd-pass-set! cnd-fail-set!
+   set-var set-value set-var-set! set-value-set!
+   ref-name ref-cell ref-name-set! ref-cell-set!
+   seq-ls seq-ls-set! lit-value lit-value-set!
+   exception-kind exception-message exception-irritants exception-source
+   opcode-name opcode-num-params opcode-return-type opcode-param-type
+   opcode-class opcode-code opcode-data opcode-variadic?
+   macro-procedure macro-env macro-source
+   procedure-code procedure-vars procedure-name procedure-name-set!
+   procedure-arity procedure-variadic?
+   bytecode-name bytecode-literals bytecode-source
+   port-line port-line-set!
+   extend-env env-parent env-parent-set! env-lambda env-lambda-set!
+   env-define! env-push! env-syntactic? env-syntactic?-set! core-code
+   type-name type-cpl type-parent type-slots type-num-slots type-printer
+   object-size integer->immediate gc atomically thread-list
+   string-contains string-cursor-copy! errno integer->error-string
+   flatten-dot update-free-vars! setenv unsetenv safe-setenv)
+  (import (chibi))
+  (include-shared "ast")
+  (include "ast.scm"))

lib/chibi/base64.scm

@@ -0,0 +1,366 @@
+;; Copyright (c) 2005-2014 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> RFC 3548 base64 encoding and decoding utilities.
+;;> This API is compatible with the Gauche library rfc.base64.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; string utils
+
+(define (string-chop str n)
+  (let ((len (string-length str)))
+    (let lp ((i 0) (res '()))
+      (let ((j (+ i n)))
+        (if (>= j len)
+            (reverse (cons (substring str i len) res))
+            (lp j (cons (substring str i j) res)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; constants and tables
+
+(define *default-max-col* 76)
+
+(define *outside-char* 99) ; luft-balloons
+(define *pad-char* 101)    ; dalmations
+
+(define *base64-decode-table*
+  (let ((res (make-vector #x100 *outside-char*)))
+    (let lp ((i 0)) ; map letters
+      (cond
+       ((<= i 25)
+        (vector-set! res (+ i 65) i)
+        (vector-set! res (+ i 97) (+ i 26))
+        (lp (+ i 1)))))
+    (let lp ((i 0)) ; map numbers
+      (cond
+       ((<= i 9)
+        (vector-set! res (+ i 48) (+ i 52))
+        (lp (+ i 1)))))
+    ;; extras (be liberal for different common base64 formats)
+    (vector-set! res (char->integer #\+) 62)
+    (vector-set! res (char->integer #\-) 62)
+    (vector-set! res (char->integer #\/) 63)
+    (vector-set! res (char->integer #\_) 63)
+    (vector-set! res (char->integer #\~) 63)
+    (vector-set! res (char->integer #\=) *pad-char*)
+    res))
+
+(define (base64-decode-u8 u8)
+  (vector-ref *base64-decode-table* u8))
+
+(define *base64-encode-table*
+  (let ((res (make-vector 64)))
+    (let lp ((i 0)) ; map letters
+      (cond
+       ((<= i 25)
+        (vector-set! res i (+ i 65))
+        (vector-set! res (+ i 26) (+ i 97))
+        (lp (+ i 1)))))
+    (let lp ((i 0)) ; map numbers
+      (cond
+       ((<= i 9)
+        (vector-set! res (+ i 52) (+ i 48))
+        (lp (+ i 1)))))
+    (vector-set! res 62 (char->integer #\+))
+    (vector-set! res 63 (char->integer #\/))
+    res))
+
+(define (enc i)
+  (vector-ref *base64-encode-table* i))
+
+;; try to match common boundaries
+(define decode-src-length
+  (lcm 76 78))
+
+(define decode-dst-length
+  (* 3 (arithmetic-shift (+ 3 decode-src-length) -2)))
+
+(define encode-src-length
+  (* 3 1024))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; decoding
+
+;;> Return a base64 decoded representation of string, also interpreting
+;;> the alternate 62 & 63 valued characters as described in RFC3548.
+;;> Other out-of-band characters are silently stripped, and = signals
+;;> the end of the encoded string.  No errors will be raised.
+
+;; Create a result buffer with the maximum possible length for the
+;; input, and pass it to the internal base64-decode-string! utility.
+;; If the resulting length used is exact, we can return that buffer,
+;; otherwise we return the appropriate substring.
+
+(define (base64-decode-string str)
+  (utf8->string (base64-decode-bytevector (string->utf8 str))))
+
+(define (base64-decode-bytevector src)
+  (let* ((len (bytevector-length src))
+         (dst-len (* 3 (arithmetic-shift (+ 3 len) -2)))
+         (dst (make-bytevector dst-len)))
+    (base64-decode-bytevector!
+     src 0 len dst
+     (lambda (src-offset res-len b1 b2 b3)
+       (let ((res-len (base64-decode-finish dst res-len b1 b2 b3)))
+         (if (= res-len dst-len)
+             dst
+             (bytevector-copy dst 0 res-len)))))))
+
+;; This is a little funky.
+;;
+;;   We want to skip over "outside" characters (e.g. newlines inside
+;;   base64-encoded data, as would be passed in mail clients and most
+;;   large base64 data).  This would normally mean two nested loops -
+;;   one for overall processing the input, and one for looping until
+;;   we get to a valid character.  However, many Scheme compilers are
+;;   really bad about optimizing nested loops of primitives, so we
+;;   flatten this into a single loop, using conditionals to determine
+;;   which character is currently being read.
+(define (base64-decode-bytevector! src start end dst kont)
+  (let lp ((i start)
+           (j 0)
+           (b1 *outside-char*)
+           (b2 *outside-char*)
+           (b3 *outside-char*))
+    (if (>= i end)
+        (kont i j b1 b2 b3)
+        (let ((c (base64-decode-u8 (bytevector-u8-ref src i))))
+          (cond
+           ((eqv? c *pad-char*)
+            (kont i j b1 b2 b3))
+           ((eqv? c *outside-char*)
+            (lp (+ i 1) j b1 b2 b3))
+           ((eqv? b1 *outside-char*)
+            (lp (+ i 1) j c b2 b3))
+           ((eqv? b2 *outside-char*)
+            (lp (+ i 1) j b1 c b3))
+           ((eqv? b3 *outside-char*)
+            (lp (+ i 1) j b1 b2 c))
+           (else
+            (bytevector-u8-set!
+             dst
+             j
+             (bitwise-ior (arithmetic-shift b1 2)
+                          (extract-bit-field 2 4 b2)))
+            (bytevector-u8-set!
+             dst
+             (+ j 1)
+             (bitwise-ior
+              (arithmetic-shift (extract-bit-field 4 0 b2) 4)
+              (extract-bit-field 4 2 b3)))
+            (bytevector-u8-set!
+             dst
+             (+ j 2)
+             (bitwise-ior
+              (arithmetic-shift (extract-bit-field 2 0 b3) 6)
+              c))
+            (lp (+ i 1) (+ j 3)
+                *outside-char* *outside-char* *outside-char*)))))))
+
+;; If requested, account for any "partial" results (i.e. trailing 2 or
+;; 3 chars) by writing them into the destination (additional 1 or 2
+;; bytes) and returning the adjusted offset for how much data we've
+;; written.
+(define (base64-decode-finish dst j b1 b2 b3)
+  (cond
+   ((eqv? b1 *outside-char*)
+    j)
+   ((eqv? b2 *outside-char*)
+    (bytevector-u8-set! dst j (arithmetic-shift b1 2))
+    (+ j 1))
+   (else
+    (bytevector-u8-set! dst
+                        j
+                        (bitwise-ior (arithmetic-shift b1 2)
+                                     (extract-bit-field 2 4 b2)))
+    (cond
+     ((eqv? b3 *outside-char*)
+      (+ j 1))
+     (else
+      (bytevector-u8-set! dst
+                          (+ j 1)
+                          (bitwise-ior
+                           (arithmetic-shift (extract-bit-field 4 0 b2) 4)
+                           (extract-bit-field 4 2 b3)))
+      (+ j 2))))))
+
+;;>  Variation of the above to read and write to ports.
+
+(define (base64-decode . o)
+  (let ((in (if (pair? o) (car o) (current-input-port)))
+        (out (if (and (pair? o) (pair? (cdr o)))
+                 (cadr o)
+                 (current-output-port))))
+    (cond
+     ((not (binary-port? in))
+      (write-string (base64-decode-string (port->string in)) out))
+     (else
+      (let ((src (make-bytevector decode-src-length))
+            (dst (make-bytevector decode-dst-length)))
+        (let lp ((offset 0))
+          (let ((src-len
+                 (+ offset
+                    (read-bytevector! decode-src-length src in offset))))
+            (cond
+             ((= src-len decode-src-length)
+              ;; read a full chunk: decode, write and loop
+              (base64-decode-bytevector!
+               src 0 decode-src-length dst
+               (lambda (src-offset dst-len b1 b2 b3)
+                 (cond
+                  ((and (< src-offset src-len)
+                        (eqv? #\= (string-ref src src-offset)))
+                   ;; done
+                   (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3)))
+                     (write-bytevector dst out 0 dst-len)))
+                  ((eqv? b1 *outside-char*)
+                   (write-string dst out 0 dst-len)
+                   (lp 0))
+                  (else
+                   (write-bytevector dst out 0 dst-len)
+                   ;; one to three chars left in buffer
+                   (bytevector-u8-set! src 0 (enc b1))
+                   (cond
+                    ((eqv? b2 *outside-char*)
+                     (lp 1))
+                    (else
+                     (bytevector-u8-set! src 1 (enc b2))
+                     (cond
+                      ((eqv? b3 *outside-char*)
+                       (lp 2))
+                      (else
+                       (bytevector-u8-set! src 2 (enc b3))
+                       (lp 3))))))))))
+             (else
+              ;; end of source - just decode and write once
+              (base64-decode-bytevector!
+               src 0 src-len dst
+               (lambda (src-offset dst-len b1 b2 b3)
+                 (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3)))
+                   (write-string dst out 0 dst-len)))))))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; encoding
+
+;;> Return a base64 encoded representation of string according to the
+;;> official base64 standard as described in RFC3548.
+
+(define (base64-encode-string str)
+  (utf8->string (base64-encode-bytevector (string->utf8 str))))
+
+(define (base64-encode-bytevector bv)
+  (let* ((len (bytevector-length bv))
+         (quot (quotient len 3))
+         (rem (- len (* quot 3)))
+         (res-len (arithmetic-shift (+ quot (if (zero? rem) 0 1)) 2))
+         (res (make-bytevector res-len)))
+    (base64-encode-bytevector! bv 0 len res)
+    res))
+
+(define (base64-encode-bytevector! bv start end res)
+  (let* ((res-len (bytevector-length res))
+         (limit (- end 2)))
+    (let lp ((i start) (j 0))
+      (if (>= i limit)
+          (case (- end i)
+            ((1)
+             (let ((b1 (bytevector-u8-ref bv i)))
+               (bytevector-u8-set! res j (enc (arithmetic-shift b1 -2)))
+               (bytevector-u8-set!
+                res
+                (+ j 1)
+                (enc (arithmetic-shift (bitwise-and #b11 b1) 4)))
+               (bytevector-u8-set! res (+ j 2) (char->integer #\=))
+               (bytevector-u8-set! res (+ j 3) (char->integer #\=))))
+            ((2)
+             (let ((b1 (bytevector-u8-ref bv i))
+                   (b2 (bytevector-u8-ref bv (+ i 1))))
+               (bytevector-u8-set! res j (enc (arithmetic-shift b1 -2)))
+               (bytevector-u8-set!
+                res
+                (+ j 1)
+                (enc (bitwise-ior
+                      (arithmetic-shift (bitwise-and #b11 b1) 4)
+                      (extract-bit-field 4 4 b2))))
+               (bytevector-u8-set!
+                res
+                (+ j 2)
+                (enc (arithmetic-shift (extract-bit-field 4 0 b2)
+                                       2)))
+               (bytevector-u8-set! res (+ j 3) (char->integer #\=)))))
+          (let ((b1 (bytevector-u8-ref bv i))
+                (b2 (bytevector-u8-ref bv (+ i 1)))
+                (b3 (bytevector-u8-ref bv (+ i 2))))
+            (bytevector-u8-set! res j (enc (arithmetic-shift b1 -2)))
+            (bytevector-u8-set!
+             res
+             (+ j 1)
+             (enc (bitwise-ior
+                   (arithmetic-shift (bitwise-and #b11 b1) 4)
+                   (extract-bit-field 4 4 b2))))
+            (bytevector-u8-set!
+             res
+             (+ j 2)
+             (enc (bitwise-ior
+                   (arithmetic-shift (extract-bit-field 4 0 b2) 2)
+                   (extract-bit-field 2 6 b3))))
+            (bytevector-u8-set! res (+ j 3) (enc (bitwise-and #b111111 b3)))
+            (lp (+ i 3) (+ j 4)))))))
+
+;;>  Variation of the above to read and write to ports.
+
+(define (base64-encode . o)
+  (let ((in (if (pair? o) (car o) (current-input-port)))
+        (out (if (and (pair? o) (pair? (cdr o)))
+                 (cadr o)
+                 (current-output-port))))
+    (cond
+     ((not (binary-port? in))
+      (write-string (base64-encode-string (port->string in)) out))
+     (else
+      (let ((src (make-string encode-src-length))
+            (dst (make-string
+                  (arithmetic-shift (quotient encode-src-length 3) 2))))
+        (let lp ()
+          (let ((n (read-bytevector! src in 0 2048)))
+            (base64-encode-bytevector! src 0 n dst)
+            (write-bytevector dst out 0 (* 3 (quotient (+ n 3) 4)))
+            (if (= n 2048)
+                (lp)))))))))
+
+;;> Return a base64 encoded representation of the string \var{str} as
+;;> above, wrapped in =?ENC?B?...?= as per RFC1522, split across
+;;> multiple MIME-header lines as needed to keep each lines length
+;;> less than \var{max-col}.  The string is encoded as is, and the
+;;> encoding \var{enc} is just used for the prefix, i.e. you are
+;;> responsible for ensuring \var{str} is already encoded according to
+;;> \var{enc}.  The optional argument \var{nl} is the newline
+;;> separator, defaulting to \var{crlf}.
+
+(define (base64-encode-header encoding str . o)
+  (define (round4 i) (arithmetic-shift (arithmetic-shift i -2) 2))
+  (let ((start-col (if (pair? o) (car o) 0))
+        (max-col (if (and (pair? o) (pair? (cdr o)))
+                     (car (cdr o))
+                     *default-max-col*))
+        (nl (if (and (pair? o) (pair? (cdr o)) (pair? (cdr (cdr o))))
+                (car (cdr (cdr o)))
+                "\r\n")))
+    (let* ((prefix (string-append "=?" encoding "?B?"))
+           (prefix-length (+ 2 (string-length prefix)))
+           (effective-max-col (round4 (- max-col prefix-length)))
+           (first-max-col (round4 (- effective-max-col start-col)))
+           (str (base64-encode-string str))
+           (len (string-length str)))
+      (if (<= len first-max-col)
+          (string-append prefix str "?=")
+          (string-append
+           (if (positive? first-max-col)
+               (string-append
+                prefix (substring str 0 first-max-col) "?=" nl "\t" prefix)
+               "")
+           (string-concatenate (string-chop (substring str first-max-col len)
+                                            effective-max-col)
+                               (string-append "?=" nl "\t" prefix))
+           "?=")))))
+

lib/chibi/base64.sld

@@ -0,0 +1,8 @@
+
+(define-library (chibi base64)
+  (export base64-encode base64-encode-string base64-encode-bytevector
+          base64-decode base64-decode-string base64-decode-bytevector
+          base64-encode-header)
+  (import (scheme base) (srfi 33) (chibi io)
+          (only (chibi) string-concatenate))
+  (include "base64.scm"))

lib/chibi/binary-record.scm

@@ -0,0 +1,300 @@
+
+(define (read-u16/be in)
+  (let* ((i (read-u8 in))
+         (j (read-u8 in)))
+    (if (eof-object? j)
+        (error "end of input")
+        (+ (arithmetic-shift i 8) j))))
+
+(define (read-u16/le in)
+  (let* ((i (read-u8 in))
+         (j (read-u8 in)))
+    (if (eof-object? j)
+        (error "end of input")
+        (+ (arithmetic-shift j 8) i))))
+
+;; Record types with user-specified binary formats.
+;; A work in progress, but sufficient for tar files.
+
+(define (assert-read-u8 in i)
+  (let ((i2 (read-u8 in)))
+    (if (not (eqv? i i2))
+        (error "unexpected value: " i i2)
+        i2)))
+
+(define (assert-read-char in ch)
+  (let ((ch2 (read-char in)))
+    (if (not (eqv? ch ch2))
+        (error "unexpected value: " ch ch2)
+        ch2)))
+
+(define (assert-read-string in s)
+  (let ((s2 (read-string (string-length s) in)))
+    (if (not (equal? s s2))
+        (error "unexpected value: " s s2)
+        s2)))
+
+(define (assert-read-bytevector in bv)
+  (let ((bv2 (read-bytevector (bytevector-length bv) in)))
+    (if (not (equal? bv bv2))
+        (error "unexpected value: " bv bv2)
+        bv2)))
+
+(define (assert-read-integer in len radix)
+  (let* ((s (string-trim (read-string len in)
+                         (lambda (ch) (or (eqv? ch #\space) (eqv? ch #\null)))))
+         (n (if (equal? s "") 0 (string->number s radix))))
+    (or n (error "invalid number syntax: " s))))
+
+(define (read-padded-string in len pad)
+  (string-trim-right (read-string len in) pad))
+
+(define (expand-read rename in spec)
+  (case (car spec)
+    ((literal)
+     (let ((val (cadr spec)))
+       (cond ((integer? val) `(,(rename 'assert-read-u8) ,in ,val))
+             ((char? val) `(,(rename 'assert-read-char) ,in ,val))
+             ((string? val) `(,(rename 'assert-read-string) ,in ,val))
+             ((bytevector? val) `(,(rename 'assert-read-bytevector) ,in ,val))
+             (else (error "unknown binary literal: " val)))))
+    ((u8)
+     `(,(rename 'read-u8) ,in))
+    ((u16/be)
+     `(,(rename 'read-u16/be) ,in))
+    ((u16/le)
+     `(,(rename 'read-u16/le) ,in))
+    ((octal)
+     `(,(rename 'assert-read-integer) ,in ,(cadr spec) 8))
+    ((decimal)
+     `(,(rename 'assert-read-integer) ,in ,(cadr spec) 10))
+    ((hexadecimal)
+     `(,(rename 'assert-read-integer) ,in ,(cadr spec) 16))
+    ((fixed-string)
+     (let ((len (cadr spec)))
+       `(,(rename 'read-string) ,len ,in)))
+    ((padded-string)
+     (let ((len (cadr spec))
+           (pad (if (pair? (cddr spec)) (car (cddr spec)) #\null)))
+       `(,(rename 'read-padded-string) ,in ,len ,pad)))
+    (else
+     (error "unknown binary format: " spec))))
+
+(define (string-pad-left str len . o)
+  (let ((diff (- len (string-length str)))
+        (pad-ch (if (pair? o) (car o) #\space)))
+    (if (positive? diff)
+        (string-append (make-string diff pad-ch) str)
+        str)))
+
+(define (string-pad-right str len . o)
+  (let ((diff (- len (string-length str)))
+        (pad-ch (if (pair? o) (car o) #\space)))
+    (if (positive? diff)
+        (string-append str (make-string diff pad-ch))
+        str)))
+
+(define (write-padded-integer out n radix len left-pad-ch right-pad-ch)
+  (let ((s (string-pad-left (number->string n radix) (- len 1) left-pad-ch)))
+    (cond
+     ((>= (string-length s) len)
+      (error "number too large for width" n radix len))
+     (else
+      (write-string s out)
+      (write-char right-pad-ch out)))))
+
+(define (write-u16/be n out)
+  (write-u8 (arithmetic-shift n -8) out)
+  (write-u8 (bitwise-and n #xFF) out))
+
+(define (write-u16/le n out)
+  (write-u8 (bitwise-and n #xFF) out)
+  (write-u8 (arithmetic-shift n -8) out))
+
+(define (expand-write rename out val spec)
+  (let ((_if (rename 'if))
+        (_not (rename 'not))
+        (_let (rename 'let))
+        (_string-length (rename 'string-length))
+        (_write-string (rename 'write-string))
+        (_write-bytevector (rename 'write-bytevector))
+        (_error (rename 'error))
+        (_> (rename '>))
+        (_= (rename '=)))
+    (case (car spec)
+      ((literal)
+       (let ((val (cadr spec)))
+         (cond ((integer? val) `(,(rename 'write-u8) ,val ,out))
+               ((char? val) `(,(rename 'write-char) ,val ,out))
+               ((string? val) `(,_write-string ,val ,out))
+               ((bytevector? val) `(,_write-bytevector ,val ,out))
+               (else (error "unknown binary literal: " val)))))
+      ((u8)
+       `(,(rename 'write-u8) ,val ,out))
+      ((u16/be)
+       `(,(rename 'write-u16/be) ,val ,out))
+      ((u16/le)
+       `(,(rename 'write-u16/le) ,val ,out))
+      ((octal)
+       `(,(rename 'write-padded-integer) ,out ,val 8 ,(cadr spec) #\0 #\null))
+      ((decimal)
+       `(,(rename 'write-padded-integer) ,out ,val 10 ,(cadr spec) #\0 #\null))
+      ((hexadecimal)
+       `(,(rename 'write-padded-integer) ,out ,val 16 ,(cadr spec) #\0 #\null))
+      ((fixed-string)
+       (let ((len (cadr spec)))
+         `(,_if (,_not (,_= ,len (,_string-length ,val)))
+              (,_error "wrong field length: " ,val ,len)
+              (,_write-string ,val ,out))))
+      ((padded-string)
+       (let ((len (cadr spec))
+             (pad (if (pair? (cddr spec)) (car (cddr spec)) #\null)))
+         `(,_let ((l (,_string-length ,val)))
+            (,_if (,_> l ,len)
+                (,_error "field too large: " ,val ,len)
+                (,_write-string (,(rename 'string-pad-right) ,val ,len ,pad)
+                                ,out)))))
+      (else
+       (error "unknown binary format: " spec)))))
+
+(define (expand-assert rename spec x v)
+  (let ((_if (rename 'if))
+        (_not (rename 'not))
+        (_error (rename 'error))
+        (_integer? (rename 'integer?))
+        (_string? (rename 'string?))
+        (_string-length (rename 'string-length))
+        (_> (rename '>)))
+    (case (car spec)
+      ((literal) #t)
+      ((u8 u16/be u16/le octal decimal hexadecimal)
+       `(,_if (,_not (,_integer? ,v))
+            (,_error "expected an integer" ,v)))
+      ((fixed-string padded-string)
+       (let ((len (cadr spec)))
+         `(,_if (,_not (,_string? ,v))
+              (,_error "expected a string" ,v)
+              (,_if (,_> (,_string-length ,v) ,len)
+                  (,_error "string too long" ,v ,len)))))
+      (else (error "unknown binary format: " spec)))))
+
+(define (expand-default rename spec)
+  (case (car spec)
+    ((literal) (cadr spec))
+    ((u8 u16/be u16/le octal decimal hexadecimal) 0)
+    ((fixed-string) (make-string (cadr spec) #\space))
+    ((padded-string) "")
+    (else (error "unknown binary format: " spec))))
+
+(define (param-ref ls key . o)
+  (cond ((assq key ls) => cadr) ((pair? o) (car o)) (else #f)))
+
+(define (symbol-append a b)
+  (string->symbol (string-append (symbol->string a) (symbol->string b))))
+
+(define-record-type Field
+  (make-field name get set raw-set spec)
+  field?
+  (name field-name)
+  (get field-get)
+  (set field-set)
+  (raw-set field-raw-set)
+  (spec field-spec))
+
+(define (extract-fields type ls)
+  (let lp ((ls ls) (res '()))
+    (cond
+     ((null? ls)
+      (reverse res))
+     ((not (pair? (car ls)))
+      (lp (cdr ls) (cons (make-field '_ #f #f #f `(literal ,(car ls))) res)))
+     (else
+      (let* ((name (caar ls))
+             (get (or (param-ref (car ls) 'getter)
+                      (and (not (eq? name '_))
+                           (symbol-append type (symbol-append '- name)))))
+             (set (or (param-ref (car ls) 'setter)
+                      (and (not (eq? name '_))
+                           (symbol-append (symbol-append type '-)
+                                          (symbol-append name '-set!)))))
+             (raw-set (and set (symbol-append '% set)))
+             (spec0 (cadr (car ls)))
+             (spec (if (pair? spec0) spec0 (list spec0))))
+        (lp (cdr ls) (cons (make-field name get set raw-set spec) res)))))))
+
+(define-syntax define-binary-record-type
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let ((name (cadr expr))
+           (ls (cddr expr)))
+       (if (not (and (identifier? name) (every list? ls)))
+           (error "invalid syntax: " expr))
+       (let* ((type (or (param-ref ls 'type) (symbol-append 'type- name)))
+              (pred (or (param-ref ls 'predicate) (symbol-append name '?)))
+              (make (or (param-ref ls 'make) (symbol-append 'make- name)))
+              (make-spec (if (pair? make) make (list make)))
+              (%make (rename (symbol-append '% (car make-spec))))
+              (%%make (rename (symbol-append '%% (car make-spec))))
+              (reader (or (param-ref ls 'read) (symbol-append 'read- name)))
+              (writer (or (param-ref ls 'write) (symbol-append 'write- name)))
+              (block (assq 'block ls))
+              (_begin (rename 'begin))
+              (_define (rename 'define))
+              (_define-record-type (rename 'define-record-type))
+              (_let (rename 'let)))
+         (if (not block)
+             (error "missing binary record block: " expr))
+         (let* ((fields (extract-fields name (cdr block)))
+                (named-fields (filter (lambda (f) (not (eq? '_ (field-name f))))
+                                      fields)))
+           `(,_begin
+             (,_define ,name ',ls)
+             (,_define-record-type
+              ,type (,%%make) ,pred
+              ,@(map
+                 (lambda (f)
+                   `(,(field-name f) ,(field-get f) ,(field-raw-set f)))
+                 named-fields))
+             ,@(map
+                (lambda (f)
+                  `(,_define (,(field-set f) x v)
+                     ,(expand-assert rename (field-spec f) 'x 'v)
+                     (,(field-raw-set f) x v)))
+                named-fields)
+             (,_define (,%make)
+               (let ((res (,%%make)))
+                 ,@(map
+                    (lambda (f)
+                      `(,(field-raw-set f)
+                        res
+                        ,(expand-default rename (field-spec f))))
+                    named-fields)
+                 res))
+             (,_define ,make-spec
+               (,_let ((res (,%make)))
+                 ,@(map
+                    (lambda (x)
+                      (let ((field (find (lambda (f) (eq? x (field-name f)))
+                                         fields)))
+                        `(,(field-set field) res ,x)))
+                    (cdr make-spec))
+                 res))
+             (,_define (,reader in)
+               (,_let ((res (,%make)))
+                 ,@(map
+                    (lambda (f)
+                      (if (eq? '_ (field-name f))
+                          (expand-read rename 'in (field-spec f))
+                          `(,(field-set f)
+                            res
+                            ,(expand-read rename 'in (field-spec f)))))
+                    fields)
+                 res))
+             (,_define (,writer x out)
+               ,@(map
+                  (lambda (f)
+                    (expand-write rename
+                                  'out
+                                  `(,(field-get f) x)
+                                  (field-spec f)))
+                  fields)))))))))

lib/chibi/binary-record.sld

@@ -0,0 +1,8 @@
+
+(define-library (chibi binary-record)
+  (import (scheme base)
+          (srfi 1) (srfi 9) (srfi 33)
+          (chibi io) (chibi string)
+          (only (chibi) identifier? er-macro-transformer))
+  (export define-binary-record-type)
+  (include "binary-record.scm"))

lib/chibi/bytevector.scm

@@ -0,0 +1,84 @@
+
+;;> \section{Additional accessors}
+
+(define (bytevector-u16-ref-le str i)
+  (+ (bytevector-u8-ref str i)
+     (arithmetic-shift (bytevector-u8-ref str (+ i 1)) 8)))
+
+(define (bytevector-u16-ref-be str i)
+  (+ (arithmetic-shift (bytevector-u8-ref str i) 8)
+     (bytevector-u8-ref str (+ i 1))))
+
+(define (bytevector-u32-ref-le str i)
+  (+ (bytevector-u8-ref str i)
+     (arithmetic-shift (bytevector-u8-ref str (+ i 1)) 8)
+     (arithmetic-shift (bytevector-u8-ref str (+ i 2)) 16)
+     (arithmetic-shift (bytevector-u8-ref str (+ i 3)) 24)))
+
+(define (bytevector-u32-ref-be str i)
+  (+ (arithmetic-shift (bytevector-u8-ref str i) 24)
+     (arithmetic-shift (bytevector-u8-ref str (+ i 1)) 16)
+     (arithmetic-shift (bytevector-u8-ref str (+ i 2)) 8)
+     (bytevector-u8-ref str (+ i 3))))
+
+;;> \section{Integer conversion}
+
+(define (integer->bytevector n)
+  (cond
+   ((zero? n)
+    (make-bytevector 1 0))
+   ((negative? n)
+    (error "can't convert a negative integer to bytevector" n))
+   (else
+    (let lp ((n n) (res '()))
+      (if (zero? n)
+          (let* ((len (length res))
+                 (bv (make-bytevector len 0)))
+            (do ((i 0 (+ i 1))
+                 (ls res (cdr ls)))
+                ((= i len) bv)
+              (bytevector-u8-set! bv i (car ls))))
+          (lp (quotient n 256) (cons (remainder n 256) res)))))))
+
+(define (bytevector->integer bv)
+  (let ((len (bytevector-length bv)))
+    (let lp ((i 0) (n 0))
+      (if (>= i len)
+          n
+          (lp (+ i 1)
+              (+ (arithmetic-shift n 8)
+                 (bytevector-u8-ref bv i)))))))
+
+(define (bytevector-pad-left bv len)
+  (let ((diff (- len (bytevector-length bv))))
+    (if (positive? diff)
+        (bytevector-append bv (make-bytevector diff 0))
+        bv)))
+
+;;> \section{Hex string conversion}
+
+;;> Big-endian conversion, guaranteed padded to even length.
+
+(define (integer->hex-string n)
+  (let* ((res (number->string n 16))
+         (len (string-length res)))
+    (if (even? len)
+        res
+        (string-append "0" res))))
+
+(define (hex-string->integer str)
+  (string->number str 16))
+
+(define (bytevector->hex-string bv)
+  (let ((out (open-output-string))
+        (len (bytevector-length bv)))
+    (let lp ((i 0))
+      (cond
+       ((>= i len)
+        (get-output-string out))
+       (else
+        (write-string (integer->hex-string (bytevector-u8-ref bv i)) out)
+        (lp (+ i 1)))))))
+
+(define (hex-string->bytevector str)
+  (integer->bytevector (hex-string->integer str)))

lib/chibi/bytevector.sld

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

lib/chibi/channel.scm

@@ -0,0 +1,44 @@
+;; channel.scm -- thread-safe channel (FIFO) library
+;; Copyright (c) 2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define-record-type Channel
+  (%make-channel mutex condvar front rear)
+  channel?
+  (mutex channel-mutex channel-mutex-set!)
+  (condvar channel-condvar channel-condvar-set!)
+  (front channel-front channel-front-set!)
+  (rear channel-rear channel-rear-set!))
+
+(define (make-channel)
+  (%make-channel (make-mutex) (make-condition-variable) '() '()))
+
+(define (channel-empty? chan)
+  (null? (channel-front chan)))
+
+(define (channel-send! chan obj)
+  (mutex-lock! (channel-mutex chan))
+  (let ((new (list obj))
+        (rear (channel-rear chan)))
+    (channel-rear-set! chan new)
+    (cond
+     ((pair? rear)
+      (set-cdr! rear new))
+     (else  ; sending to empty channel
+      (channel-front-set! chan new)
+      (condition-variable-broadcast! (channel-condvar chan)))))
+  (mutex-unlock! (channel-mutex chan)))
+
+(define (channel-receive! chan)
+  (mutex-lock! (channel-mutex chan))
+  (let ((front (channel-front chan)))
+    (cond
+     ((null? front)  ; receiving from empty channel
+      (mutex-unlock! (channel-mutex chan) (channel-condvar chan))
+      (channel-receive! chan))
+     (else
+      (channel-front-set! chan (cdr front))
+      (if (null? (cdr front))
+          (channel-rear-set! chan '()))
+      (mutex-unlock! (channel-mutex chan))
+      (car front)))))

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,13 @@
+
+(define-library (chibi char-set)
+  (import (chibi) (chibi char-set base) (chibi char-set extras))
+  (export
+   Char-Set char-set? char-set-contains?
+   char-set ucs-range->char-set char-set-copy char-set-size
+   char-set-fold char-set-for-each
+   list->char-set char-set->list string->char-set char-set->string
+   char-set-adjoin! char-set-adjoin char-set-union char-set-union!
+   char-set-intersection char-set-intersection!
+   char-set-difference char-set-difference!
+   immutable-char-set char-set-complement
+   char-set:empty char-set:ascii char-set:full))

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