automatically making sockets non-blocking on accept

.hgignore

@@ -0,0 +1,39 @@
+syntax: glob
+*~
+*.i
+*.s
+*.o
+*.so
+*.sch
+*.sps
+*.txt
+*.image
+*.wav
+*.dylib
+*.class
+*.dSYM
+*.orig
+.hg
+junk*
+*.tgz
+*.tar.gz
+*.tar.bz2
+*.log
+*.err
+*.out
+gc
+gc6.8
+clibs.c
+chibi-scheme
+chibi-scheme-static
+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/*

AUTHORS

@@ -0,0 +1,36 @@
+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.
+
+Thanks to the following people for patches and bug reports:
+
+  * Alan Watson
+  * Alexander Shendi
+  * Andreas Rottman
+  * Bakul Shah
+  * Bruno Deferrari
+  * Doug Currie
+  * Derrick Eddington
+  * Dmitry Chestnykh
+  * Eduardo Cavazos
+  * Felix Winkelmann
+  * Gregor Klinke
+  * Jeremy Wolff
+  * Jeronimo Pellegrini
+  * John Cowan
+  * John Samsa
+  * Lars J Aas
+  * Lorenzo Campedelli
+  * Michal Kowalski (sladegen)
+  * Rajesh Krishnan
+  * Taylor Venable
+  * Travis Cross
+  * Zhang Meng
+
+If you would prefer not to be listed, or are one of the users listed
+without a full name, please contact me.  If you've made a contribution
+and are not listed, please accept my apologies and contact me
+immediately!

COPYING

@@ -0,0 +1,24 @@
+Copyright (c) 2009 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,306 @@
+# -*- makefile-gmake -*-
+
+.PHONY: dist mips-dist cleaner test checkdefs
+.DEFAULT_GOAL := all
+
+CHIBI_FFI ?= $(CHIBI) tools/chibi-ffi
+CHIBI_FFI_DEPENDENCIES ?= $(CHIBI_DEPENDENCIES) tools/chibi-ffi
+
+CHIBI_DOC ?= $(CHIBI) tools/chibi-doc
+CHIBI_DOC_DEPENDENCIES ?= $(CHIBI_DEPENDENCIES) tools/chibi-doc
+
+GENSTATIC ?= ./tools/chibi-genstatic
+
+CHIBI ?= LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-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)
+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 disasm equiv filesystem generic heap-stats io loop \
+	match mime modules net pathname process repl scribble stty \
+	system test time trace type-inference uri weak
+
+HTML_LIBS = $(MODULE_DOCS:%=doc/lib/chibi/%.html)
+
+########################################################################
+
+include Makefile.libs
+
+########################################################################
+# Library config.
+#
+# This is to allow "make SEXP_USE_BOEHM=1" and "make SEXP_USE_DL=0" to
+# automatically include the necessary compiler and linker flags in
+# addition to setting those features.  If not using GNU make just
+# comment out the ifs and use the else branches for the defaults.
+
+ifeq ($(SEXP_USE_BOEHM),1)
+GCLDFLAGS := -lgc
+XCPPFLAGS := $(CPPFLAGS) -Iinclude $(D:%=-DSEXP_USE_%) -DSEXP_USE_BOEHM=1
+else
+GCLDFLAGS :=
+XCPPFLAGS := $(CPPFLAGS) -Iinclude $(D:%=-DSEXP_USE_%)
+endif
+
+ifeq ($(SEXP_USE_DL),0)
+XLDFLAGS  := $(LDFLAGS) $(RLDFLAGS) $(GCLDFLAGS) -lm
+XCFLAGS   := -Wall -DSEXP_USE_DL=0 -g -g3 -Os $(CFLAGS)
+else
+XLDFLAGS  := $(LDFLAGS) $(RLDFLAGS) $(GCLDFLAGS) $(LIBDL) -lm
+XCFLAGS   := -Wall -g -g3 -Os $(CFLAGS)
+endif
+
+########################################################################
+
+all: chibi-scheme$(EXE) all-libs lib/chibi/ast$(SO)
+
+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`'"' >> $@
+
+sexp.o: sexp.c gc.c opt/bignum.c $(BASE_INCLUDES) Makefile
+	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $<
+
+sexp-ulimit.o: sexp.c gc.c opt/bignum.c $(BASE_INCLUDES) Makefile
+	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -DSEXP_USE_LIMITED_MALLOC -o $@ $<
+
+eval.o: eval.c opcodes.c vm.c opt/simplify.c $(INCLUDES) Makefile
+	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $<
+
+main.o: main.c $(INCLUDES) Makefile
+	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $<
+
+libchibi-sexp$(SO): sexp.o
+	$(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS)
+
+libchibi-scheme$(SO): eval.o sexp.o
+	$(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS)
+
+chibi-scheme$(EXE): main.o libchibi-scheme$(SO)
+	$(CC) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme
+
+chibi-scheme-static$(EXE): main.o eval.o sexp.o
+	$(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) -lm
+
+chibi-scheme-ulimit$(EXE): main.o eval.o sexp-ulimit.o
+	$(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) -lm
+
+clibs.c: $(GENSTATIC) chibi-scheme$(EXE)
+	$(FIND) lib -name \*.sld | $(CHIBI) $(GENSTATIC) > $@
+
+# A special case, this needs to be linked with the LDFLAGS in case
+# we're using Boehm.
+lib/chibi/ast$(SO): lib/chibi/ast.c $(INCLUDES)
+	-$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< $(XLDFLAGS) -L. -lchibi-scheme
+
+doc/lib/chibi/%.html: lib/chibi/%.sld $(CHIBI_DOC_DEPENDENCIES)
+	$(CHIBI_DOC) chibi.$* > $@
+
+doc: doc/chibi.html doc-libs
+
+%.html: %.scrbl $(CHIBI_DOC_DEPENDENCIES)
+	$(CHIBI_DOC) $< > $@
+
+clean: clean-libs
+	-$(RM) *.o *.i *.s *.8 tests/basic/*.out tests/basic/*.err
+
+cleaner: clean
+	-$(RM) chibi-scheme$(EXE) chibi-scheme-static$(EXE) chibi-scheme-ulimit$(EXE) \
+	    libchibi-scheme$(SO) *.a include/chibi/install.h \
+	    $(shell $(FIND) lib -name \*.o)
+
+dist-clean: dist-clean-libs cleaner
+
+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) -xscheme $$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-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) -xscheme tests/thread-tests.scm
+
+test-numbers: chibi-scheme$(EXE)
+	$(CHIBI) -xscheme tests/numeric-tests.scm
+
+test-flonums: chibi-scheme$(EXE)
+	$(CHIBI) -xscheme tests/flonum-tests.scm
+
+test-hash: chibi-scheme$(EXE) lib/srfi/69/hash$(SO)
+	$(CHIBI) -xscheme tests/hash-tests.scm
+
+test-io: chibi-scheme$(EXE) lib/chibi/io/io$(SO)
+	$(CHIBI) -xscheme tests/io-tests.scm
+
+test-match: chibi-scheme$(EXE)
+	$(CHIBI) -xscheme tests/match-tests.scm
+
+test-loop: chibi-scheme$(EXE)
+	$(CHIBI) -xscheme tests/loop-tests.scm
+
+test-sort: chibi-scheme$(EXE) lib/srfi/33/bit$(SO)
+	$(CHIBI) -xscheme tests/sort-tests.scm
+
+test-srfi-1: chibi-scheme$(EXE)
+	$(CHIBI) -xscheme tests/srfi-1-tests.scm
+
+test-records: chibi-scheme$(EXE)
+	$(CHIBI) -xscheme tests/record-tests.scm
+
+test-weak: chibi-scheme$(EXE) lib/chibi/weak$(SO)
+	$(CHIBI) -xscheme tests/weak-tests.scm
+
+test-unicode: chibi-scheme$(EXE)
+	$(CHIBI) -xscheme tests/unicode-tests.scm
+
+test-process: chibi-scheme$(EXE) lib/chibi/process$(SO)
+	$(CHIBI) -xscheme tests/process-tests.scm
+
+test-system: chibi-scheme$(EXE) lib/chibi/system$(SO)
+	$(CHIBI) -xscheme tests/system-tests.scm
+
+test-libs: chibi-scheme$(EXE)
+	$(CHIBI) -xscheme tests/lib-tests.scm
+
+test: chibi-scheme$(EXE)
+	$(CHIBI) -xscheme tests/r5rs-tests.scm
+
+install: all
+	$(MKDIR) $(DESTDIR)$(BINDIR)
+	$(INSTALL) chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/
+	$(INSTALL) tools/chibi-ffi $(DESTDIR)$(BINDIR)/
+	$(INSTALL) tools/chibi-doc $(DESTDIR)$(BINDIR)/
+	$(MKDIR) $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(MODDIR)/chibi/term
+	$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/char
+	$(MKDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(MODDIR)/srfi/33 $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(MODDIR)/srfi/99/records
+	$(INSTALL) lib/*.scm $(DESTDIR)$(MODDIR)/
+	$(INSTALL) lib/chibi/*.sld lib/chibi/*.scm $(DESTDIR)$(MODDIR)/chibi/
+	$(INSTALL) lib/chibi/io/*.scm $(DESTDIR)$(MODDIR)/chibi/io/
+	$(INSTALL) lib/chibi/loop/*.scm $(DESTDIR)$(MODDIR)/chibi/loop/
+	$(INSTALL) lib/chibi/match/*.scm $(DESTDIR)$(MODDIR)/chibi/match/
+	$(INSTALL) lib/chibi/net/*.sld lib/chibi/net/*.scm $(DESTDIR)$(MODDIR)/chibi/net/
+	$(INSTALL) lib/chibi/optimize/*.sld lib/chibi/optimize/*.scm $(DESTDIR)$(MODDIR)/chibi/optimize/
+	$(INSTALL) lib/chibi/term/*.sld lib/chibi/term/*.scm $(DESTDIR)$(MODDIR)/chibi/term/
+	$(INSTALL) lib/scheme/*.sld lib/scheme/*.scm $(DESTDIR)$(MODDIR)/scheme/
+	$(INSTALL) lib/scheme/char/*.sld $(DESTDIR)$(MODDIR)/scheme/char/
+	$(INSTALL) lib/srfi/*.sld lib/srfi/*.scm $(DESTDIR)$(MODDIR)/srfi/
+	$(INSTALL) lib/srfi/1/*.scm $(DESTDIR)$(MODDIR)/srfi/1/
+	$(INSTALL) lib/srfi/18/*.scm $(DESTDIR)$(MODDIR)/srfi/18/
+	$(INSTALL) lib/srfi/27/*.scm $(DESTDIR)$(MODDIR)/srfi/27/
+	$(INSTALL) lib/srfi/33/*.scm $(DESTDIR)$(MODDIR)/srfi/33/
+	$(INSTALL) lib/srfi/39/*.scm $(DESTDIR)$(MODDIR)/srfi/39/
+	$(INSTALL) lib/srfi/69/*.scm $(DESTDIR)$(MODDIR)/srfi/69/
+	$(INSTALL) lib/srfi/95/*.scm $(DESTDIR)$(MODDIR)/srfi/95/
+	$(INSTALL) lib/srfi/99/*.sld $(DESTDIR)$(MODDIR)/srfi/99/
+	$(INSTALL) lib/srfi/99/records/*.sld lib/srfi/99/records/*.scm $(DESTDIR)$(MODDIR)/srfi/99/records/
+	$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/io/
+	$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
+	$(MKDIR) $(DESTDIR)$(BINMODDIR)/scheme/
+	$(MKDIR) $(DESTDIR)$(BINMODDIR)/srfi/18 $(DESTDIR)$(BINMODDIR)/srfi/27 $(DESTDIR)$(BINMODDIR)/srfi/33 $(DESTDIR)$(BINMODDIR)/srfi/39 $(DESTDIR)$(BINMODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/98
+	$(INSTALL) $(CHIBI_COMPILED_LIBS) lib/chibi/ast$(SO) $(DESTDIR)$(BINMODDIR)/chibi/
+	$(INSTALL) $(CHIBI_IO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/io/
+	$(INSTALL) $(CHIBI_OPT_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
+	$(INSTALL) lib/scheme/time$(SO) $(DESTDIR)$(BINMODDIR)/scheme/
+	$(INSTALL) lib/srfi/18/threads$(SO) $(DESTDIR)$(BINMODDIR)/srfi/18
+	$(INSTALL) lib/srfi/27/rand$(SO) $(DESTDIR)$(BINMODDIR)/srfi/27
+	$(INSTALL) lib/srfi/33/bit$(SO) $(DESTDIR)$(BINMODDIR)/srfi/33
+	$(INSTALL) lib/srfi/39/param$(SO) $(DESTDIR)$(BINMODDIR)/srfi/39
+	$(INSTALL) lib/srfi/69/hash$(SO) $(DESTDIR)$(BINMODDIR)/srfi/69
+	$(INSTALL) lib/srfi/95/qsort$(SO) $(DESTDIR)$(BINMODDIR)/srfi/95
+	$(INSTALL) lib/srfi/98/env$(SO) $(DESTDIR)$(BINMODDIR)/srfi/98
+	$(MKDIR) $(DESTDIR)$(INCDIR)
+	$(INSTALL) $(INCLUDES) $(DESTDIR)$(INCDIR)/
+	$(MKDIR) $(DESTDIR)$(LIBDIR)
+	$(MKDIR) $(DESTDIR)$(SOLIBDIR)
+	$(INSTALL) libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/
+	-$(INSTALL) libchibi-scheme.a $(DESTDIR)$(SOLIBDIR)/
+	$(MKDIR) $(DESTDIR)$(MANDIR)
+	$(INSTALL) doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/
+	$(INSTALL) doc/chibi-ffi.1 $(DESTDIR)$(MANDIR)/
+	$(INSTALL) doc/chibi-doc.1 $(DESTDIR)$(MANDIR)/
+	-if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi
+
+uninstall:
+	-$(RM) $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE)
+	-$(RM) $(DESTDIR)$(BINDIR)/chibi-scheme-static$(EXE)
+	-$(RM) $(DESTDIR)$(BINDIR)/chibi-ffi
+	-$(RM) $(DESTDIR)$(BINDIR)/chibi-doc
+	-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO)
+	-$(RM) $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a
+	-$(CD) $(DESTDIR)$(INCDIR) && $(RM) $(INCLUDES)
+	-$(RM) $(DESTDIR)$(MODDIR)/srfi/99/records/*.{sld,scm}
+	-$(RM) $(DESTDIR)$(MODDIR)/*.{sld,scm} $(DESTDIR)$(MODDIR)/*/*.{sld,scm} $(DESTDIR)$(MODDIR)/*/*/*.{sld,scm}
+	-$(CD) $(DESTDIR)$(MODDIR) && $(RM) $(COMPILED_LIBS:lib/%=%) chibi/ast$(SO)
+	-$(CD) $(DESTDIR)$(BINMODDIR) && $(RM) $(COMPILED_LIBS:lib/%=%) chibi/ast$(SO)
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(BINMODDIR)/chibi/io
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(BINMODDIR)/chibi/loop
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(BINMODDIR)/chibi/match
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(BINMODDIR)/chibi/net
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(BINMODDIR)/chibi/optimize
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/term $(DESTDIR)$(BINMODDIR)/chibi/term
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi $(DESTDIR)$(BINMODDIR)/chibi
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/char $(DESTDIR)$(BINMODDIR)/scheme/char
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme $(DESTDIR)$(BINMODDIR)/scheme
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(BINMODDIR)/srfi/1
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(BINMODDIR)/srfi/18
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(BINMODDIR)/srfi/27
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/33 $(DESTDIR)$(BINMODDIR)/srfi/33
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(BINMODDIR)/srfi/39
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/69
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/95
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/98 $(DESTDIR)$(BINMODDIR)/srfi/98
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/99/records $(DESTDIR)$(BINMODDIR)/srfi/99/records
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(BINMODDIR)/srfi/99
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi $(DESTDIR)$(BINMODDIR)/srfi
+	-$(RMDIR) $(DESTDIR)$(MODDIR) $(DESTDIR)$(BINMODDIR)
+	-$(RM) $(DESTDIR)$(MANDIR)/chibi-scheme.1 $(DESTDIR)$(MANDIR)/chibi-ffi.1 $(DESTDIR)$(MANDIR)/chibi-doc.1
+
+dist: dist-clean
+	$(RM) chibi-scheme-`cat VERSION`.tgz
+	$(MKDIR) chibi-scheme-`cat VERSION`
+	@for f in `hg manifest`; 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`; 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,78 @@
+# -*- makefile-gmake -*-
+
+########################################################################
+# Detect the PLATFORM with uname.
+
+ifndef PLATFORM
+ifeq ($(shell uname),Darwin)
+PLATFORM=macosx
+else
+ifeq ($(shell uname),FreeBSD)
+PLATFORM=FreeBSD
+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
+
+########################################################################
+# Set default variables for the platform.
+
+LIBDL = -ldl
+
+ifeq ($(PLATFORM),macosx)
+SO  = .dylib
+EXE =
+CLIBFLAGS = -dynamiclib
+STATICFLAGS = -static-libgcc -DSEXP_USE_DL=0
+else
+ifeq ($(PLATFORM),mingw)
+SO  = .dll
+EXE = .exe
+CC = gcc
+CLIBFLAGS = -shared
+CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL
+LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a
+STATICFLAGS = -DSEXP_USE_DL=0
+LIBDL = 
+else
+ifeq ($(PLATFORM),cygwin)
+SO  = .dll
+EXE = .exe
+CC = gcc
+CLIBFLAGS = -shared
+CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0
+LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a
+else
+SO  = .so
+EXE =
+CLIBFLAGS = -fPIC -shared
+STATICFLAGS = -static -DSEXP_USE_DL=0
+ifeq ($(PLATFORM),FreeBSD)
+LIBDL=
+RLDFLAGS=-Wl,-R$(DESTDIR)$(LIBDIR)
+endif
+endif
+endif
+endif
+
+ifeq ($(PLATFORM),unix)
+#RLDFLAGS=-rpath $(LIBDIR)
+RLDFLAGS=-Wl,-R$(LIBDIR)
+endif

Makefile.libs

@@ -0,0 +1,89 @@
+# -*- 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
+
+# install configuration
+
+CC        ?= cc
+CD        ?= cd
+RM        ?= rm -f
+LS        ?= ls
+INSTALL   ?= install
+MKDIR     ?= $(INSTALL) -d
+RMDIR     ?= rmdir
+TAR       ?= tar
+DIFF      ?= diff
+GREP      ?= grep
+FIND      ?= find
+SYMLINK   ?= ln -s
+
+PREFIX    ?= /usr/local
+BINDIR    ?= $(PREFIX)/bin
+LIBDIR    ?= $(PREFIX)/lib
+SOLIBDIR  ?= $(PREFIX)/lib
+INCDIR    ?= $(PREFIX)/include/chibi
+MODDIR    ?= $(PREFIX)/share/chibi
+BINMODDIR ?= $(PREFIX)/lib/chibi
+MANDIR    ?= $(PREFIX)/share/man/man1
+
+DESTDIR   ?=
+
+CHIBI     ?= chibi-scheme$(EXE)
+CHIBI_FFI ?= chibi-ffi
+CHIBI_DOC ?= chibi-doc
+
+########################################################################
+# System configuration - if not using GNU make, set PLATFORM and the
+# flags from Makefile.detect (at least SO, EXE, CLIBFLAGS) as necessary.
+
+include Makefile.detect
+
+########################################################################
+
+all-libs: $(COMPILED_LIBS)
+
+lib/%.c: lib/%.stub $(CHIBI_FFI_DEPENDENCIES)
+	$(CHIBI_FFI) $<
+
+lib/%$(SO): lib/%.c $(INCLUDES)
+	$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme
+
+doc-libs: $(HTML_LIBS)
+
+doc/lib/%.html: lib/%.sld
+	$(MKDIR) $(dir $@)
+	$(CHIBI_DOC) $(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,33 @@
+
+                             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 an extended subset of the current draft R7RS
+Scheme, with support for all libraries.  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 PREFIX=/usr/local install
+
+to install the binaries, leaving out the PREFIX for the default
+/usr/local or specifying an alternate install location.  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,108 @@
+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 and XCFLAGS.
+   These flags are passed to the compiler and linker when they
+   generate the shared library. These should probably include at
+   least:
+
+      XCPPFLAGS += -I$(PREFIX)/include
+      XCFLAGS += -L$(PREFIX)/lib
+  
+   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
+
+   include Makefile.libs

RELEASE

@@ -0,0 +1 @@
+boron

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

benchmarks/shootout/binarytrees.chibi

@@ -0,0 +1,46 @@
+#! /usr/bin/env chibi-scheme
+
+;;; The Computer Language Benchmarks Game
+;;; http://shootout.alioth.debian.org/
+
+(import (scheme) (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))
+
+(define (main args)
+  (let* ((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 (scheme)
+        (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 (scheme)
+        (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"))

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

doc/chibi-doc.1

@@ -0,0 +1,40 @@
+.TH "chibi-doc" "1" "" ""
+.UC 4
+.SH NAME
+.PP
+chibi-doc \- generate docs from Scheme scribble syntax
+
+.SH SYNOPSIS
+.B chibi-doc
+[
+.I file
+]
+.BR
+
+.B chibi-doc
+.I dotted-name.of.module
+.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 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,174 @@
+.TH "chibi-scheme" "1" "" ""
+.UC 4
+.SH NAME
+.PP
+chibi-scheme \- a tiny Scheme interpreter
+
+.SH SYNOPSIS
+.B chibi-scheme
+[-qfV]
+[-I
+.I path
+]
+[-A
+.I path
+]
+[-m
+.I module
+]
+[-x
+.I module
+]
+[-l
+.I file
+]
+[-e
+.I expr
+]
+[-p
+.I expr
+]
+[-d
+.I image-file
+]
+[-i
+.I image-file
+]
+[--]
+[
+.I script argument ...
+]
+.br
+.sp 0.4
+
+.SH DESCRIPTION
+.I chibi-scheme
+is a sample interactive Scheme interpreter for the
+.I chibi-scheme
+library.  It serves as an example of how to embed
+.I chibi-scheme
+in applications, and can be useful on its own for writing
+scripts and interactive development.
+
+When
+.I script
+is given, the script will be loaded with SRFI-22 semantics,
+calling the procedure
+.I main
+(if defined) with a single parameter as a list of the
+command-line arguments beginning with the script name.  This
+works as expected with shell #! semantics.
+
+Otherwise, if no script is given and no -e or -p options
+are given an interactive repl is entered, reading, evaluating,
+then printing expressions until EOF is reached.  The repl
+provided is very minimal - if you want readline
+completion you may want to wrap it with the
+.I rlwrap(1)
+program.  Signals aren't caught either - to enable handling keyboard
+interrupts you can use the (chibi process) module.  For a more
+sophisticated REPL with readline support, signal handling, module
+management and smarter read/write you may want to use the (chibi repl)
+module.  For example,
+.I chibi-scheme -mchibi.repl -e'(repl)'
+
+The default language is an extended subset of the draft R7RS
+(scheme base) module.  To get exactly the base module, use
+.I chibi-scheme -xscheme.base
+
+.SH OPTIONS
+.TP 5
+.BI -V
+Prints the version information and exits.
+.TP
+.BI -q
+Don't load the initialization file.  The resulting
+environment will only contain the core syntactic forms
+and primitives coded in C.
+.TP
+.BI -f
+Change the reader to case-fold symbols as in R5RS.
+.TP
+.BI -h size[/max_size]
+Specifies the initial size of the heap, in bytes,
+optionally followed by the maximum size the heap can
+grow to.
+.I size
+can be any integer value, optionally suffixed by
+"K", for kilobytes, "M" for megabytes, or "G" for gigabytes.
+.I -h
+must be specified before any options which load or
+evaluate Scheme code.
+.TP
+.BI -I path
+Inserts
+.I path
+on front of the load path list.  
+.TP
+.BI -A path
+Appends
+.I path
+to the load path list.  
+.TP
+.BI -m module
+.TP
+.BI -x module
+Imports
+.I module
+as though "(import
+.I module
+)" were evaluated.  However, to reduce the need for shell
+escapes, modules are written in a dot notation, so that the module
+.I (foo bar)
+is written as
+.I foo.bar
+If the
+.BI -x
+version is used, then
+.I module
+replaces the current environment instead of being added to it.
+.TP
+.BI -l file
+Loads the Scheme source from the file
+.I file
+searched for in the default load path.
+.TP
+.BI -e expr
+Evaluates the Scheme expression
+.I expr.
+.TP
+.BI -p expr
+Evaluates the Scheme expression
+.I expr
+then prints the result to stdout.
+.TP
+.BI -d image-file
+Dumps the current Scheme heap to
+.I image-file
+and exits.  This feature is still experimental.
+.TP
+.BI -i image-file
+Loads the Scheme heap from
+.I image-file
+instead of compiling the init file on the fly.
+This feature is still experimental.
+
+.SH ENVIRONMENT
+.TP
+.B CHIBI_MODULE_PATH
+.TQ
+A colon separated list of directories to search for module
+files, inserted before the system default load paths.
+
+.SH AUTHORS
+.PP
+Alex Shinn (alexshinn @ gmail . com)
+
+.SH SEE ALSO
+.PP
+More detailed information can be found in the README file
+included in the distribution.
+
+The chibi-scheme home-page:
+.br
+http://code.google.com/p/chibi-scheme/

doc/lib/chibi/README

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

examples/echo-server.scm

@@ -0,0 +1,38 @@
+
+(import (scheme) (srfi 18) (chibi net) (chibi io) (chibi filesystem))
+
+;; Copy each input line to output.
+(define (echo-handler in out)
+  (let ((line (read-line in)))
+    (cond
+     ((not (eof-object? line))
+      (display line out)
+      (newline out)
+      (flush-output out)
+      (echo-handler in out)))))
+
+;; Run a handler in a separate thread on the input and output ports,
+;; then cleanup.
+(define (run-io-handler sock handler)
+  (let ((in (open-input-file-descriptor sock))
+        (out (open-output-file-descriptor sock)))
+    (thread-start!
+     (make-thread
+      (lambda ()
+        (handler in out)
+        (close-input-port in)
+        (close-output-port out)
+        (close-file-descriptor sock))))))
+
+;; Basic server loop - repeatedly call accept, and dispatch the new
+;; socket to a handler.
+(define (serve host port)
+  (let* ((addrinfo (get-address-info host port))
+         (sock (make-listener-socket addrinfo)))
+    (do () (#f)
+      (let ((fd (accept sock
+                        (address-info-address addrinfo)
+                        (address-info-address-length addrinfo))))
+        (run-io-handler fd echo-handler)))))
+
+(serve "localhost" 5556)

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,721 @@
+/*  gc.c -- simple mark&sweep garbage collector               */
+/*  Copyright (c) 2009-2011 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#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) = ls2;
+    }
+}
+
+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);
+#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;
+}
+
+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));
+            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);
+  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);
+  }
+  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)));
+    }
+  }
+
+  /* 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 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
+}

include/chibi/bignum.h

@@ -0,0 +1,68 @@
+/*  bignum.h -- header for bignum utilities                   */
+/*  Copyright (c) 2009-2011 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#ifndef SEXP_BIGNUM_H
+#define SEXP_BIGNUM_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_sint_t sexp_bignum_compare (sexp a, sexp b);
+sexp sexp_compare (sexp ctx, sexp a, sexp b);
+sexp sexp_make_bignum (sexp ctx, sexp_uint_t len);
+sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len);
+sexp sexp_bignum_normalize (sexp a);
+sexp_uint_t sexp_bignum_hi (sexp a);
+sexp sexp_fixnum_to_bignum (sexp ctx, sexp a);
+double sexp_bignum_to_double (sexp a);
+sexp sexp_double_to_bignum (sexp ctx, double f);
+sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b);
+sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset);
+sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset);
+sexp sexp_bignum_add (sexp ctx, sexp dst, sexp a, sexp b);
+sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b);
+sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b);
+sexp sexp_bignum_div (sexp ctx, sexp dst, sexp a, sexp b);
+sexp sexp_bignum_expt (sexp ctx, sexp n, sexp e);
+sexp sexp_add (sexp ctx, sexp a, sexp b);
+sexp sexp_sub (sexp ctx, sexp a, sexp b);
+sexp sexp_mul (sexp ctx, sexp a, sexp b);
+sexp sexp_div (sexp ctx, sexp a, sexp b);
+sexp sexp_quotient (sexp ctx, sexp a, sexp b);
+sexp sexp_remainder (sexp ctx, sexp a, sexp b);
+#if SEXP_USE_RATIOS
+sexp sexp_double_to_ratio (sexp ctx, double f);
+double sexp_ratio_to_double (sexp rat);
+sexp sexp_make_ratio (sexp ctx, sexp num, sexp den);
+sexp sexp_ratio_normalize (sexp ctx, sexp rat, sexp in);
+sexp sexp_ratio_round (sexp ctx, sexp a);
+sexp sexp_ratio_trunc (sexp ctx, sexp a);
+sexp sexp_ratio_floor (sexp ctx, sexp a);
+sexp sexp_ratio_ceiling (sexp ctx, sexp a);
+#endif
+#if SEXP_USE_COMPLEX
+sexp sexp_make_complex (sexp ctx, sexp real, sexp image);
+sexp sexp_complex_normalize (sexp real);
+sexp sexp_complex_math_error (sexp ctx, sexp z);
+sexp sexp_complex_sqrt (sexp ctx, sexp z);
+sexp sexp_complex_exp (sexp ctx, sexp z);
+sexp sexp_complex_expt (sexp ctx, sexp a, sexp b);
+sexp sexp_complex_log (sexp ctx, sexp z);
+sexp sexp_complex_sin (sexp ctx, sexp z);
+sexp sexp_complex_cos (sexp ctx, sexp z);
+sexp sexp_complex_tan (sexp ctx, sexp z);
+sexp sexp_complex_asin (sexp ctx, sexp z);
+sexp sexp_complex_acos (sexp ctx, sexp z);
+sexp sexp_complex_atan (sexp ctx, sexp z);
+#endif
+
+#endif  /* ! SEXP_BIGNUM_H */
+

include/chibi/eval.h

@@ -0,0 +1,155 @@
+/*  eval.h -- headers for eval library                        */
+/*  Copyright (c) 2009-2011 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#ifndef SEXP_EVAL_H
+#define SEXP_EVAL_H
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#include "chibi/sexp.h"
+
+/************************* additional types ***************************/
+
+#define sexp_init_file "init-"
+#define sexp_init_file_suffix ".scm"
+#define sexp_meta_file "meta.scm"
+#define sexp_leap_seconds_file "leap.txt"
+
+enum sexp_core_form_names {
+  SEXP_CORE_DEFINE = 1,
+  SEXP_CORE_SET,
+  SEXP_CORE_LAMBDA,
+  SEXP_CORE_IF,
+  SEXP_CORE_BEGIN,
+  SEXP_CORE_QUOTE,
+  SEXP_CORE_SYNTAX_QUOTE,
+  SEXP_CORE_DEFINE_SYNTAX,
+  SEXP_CORE_LET_SYNTAX,
+  SEXP_CORE_LETREC_SYNTAX
+};
+
+enum sexp_opcode_classes {
+  SEXP_OPC_GENERIC = 1,
+  SEXP_OPC_TYPE_PREDICATE,
+  SEXP_OPC_PREDICATE,
+  SEXP_OPC_ARITHMETIC,
+  SEXP_OPC_ARITHMETIC_CMP,
+  SEXP_OPC_IO,
+  SEXP_OPC_CONSTRUCTOR,
+  SEXP_OPC_GETTER,
+  SEXP_OPC_SETTER,
+  SEXP_OPC_PARAMETER,
+  SEXP_OPC_FOREIGN,
+  SEXP_OPC_NUM_OP_CLASSES
+};
+
+/**************************** prototypes ******************************/
+
+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_analyze (sexp context, sexp x);
+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 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_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_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_make_primitive_env (sexp context, 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_add_module_directory_op (sexp ctx, sexp self, sexp_sint_t n, sexp dir, sexp appendp);
+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_identifier_op(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_syntactic_closure_expr(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_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_close_port_op(sexp ctx, sexp self, sexp_sint_t n, sexp x);
+SEXP_API sexp sexp_env_define (sexp ctx, sexp env, sexp sym, sexp val);
+SEXP_API sexp sexp_env_cell (sexp env, sexp sym, int localp);
+SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt);
+SEXP_API sexp sexp_parameter_ref (sexp ctx, sexp param);
+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);
+#if SEXP_USE_GREEN_THREADS
+SEXP_API sexp sexp_dk (sexp ctx, sexp self, sexp_sint_t n, sexp val);
+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);
+#endif
+#if SEXP_USE_UTF8_STRINGS
+SEXP_API int sexp_utf8_initial_byte_count (int c);
+SEXP_API int sexp_utf8_char_byte_count (int c);
+SEXP_API int sexp_string_utf8_length (unsigned char *p, int len);
+SEXP_API char* sexp_string_utf8_prev (unsigned char *p);
+SEXP_API sexp sexp_string_utf8_ref (sexp ctx, sexp str, sexp i);
+#endif
+
+#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_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);
+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);
+#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_standard_env(ctx) sexp_make_standard_env_op(ctx, NULL, 0)
+#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(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)
+
+#ifdef __cplusplus
+} /* extern "C" */
+#endif
+
+#endif /* ! SEXP_EVAL_H */

include/chibi/features.h

@@ -0,0 +1,740 @@
+/*  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 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 add additional native gc checks to verify a magic header */
+/* #define SEXP_USE_HEADER_MAGIC 1 */
+
+/* uncomment this to add very verbose debugging stats to the native GC */
+/* #define SEXP_USE_DEBUG_GC 1 */
+
+/* uncomment this to enable "safe" field accessors for primitive types */
+/*   The sexp union type fields are abstracted away with macros of the */
+/*   form sexp_<type>_<field>(<obj>), however these are just convenience */
+/*   macros equivalent to directly accessing the union field, and will */
+/*   return incorrect results (or segfault) if <obj> isn't of the correct */
+/*   <type>.  Thus you're required to check the types manually before */
+/*   accessing them.  However, to detect errors earlier you can enable */
+/*   SEXP_USE_SAFE_ACCESSORS, and on invalid accesses chibi will print */
+/*   a friendly error message and immediately segfault itself so you */
+/*   can see where the invalid access was made. */
+/*   Note this is only intended for debugging, and mostly for user code. */
+/*   If you want to build chibi itself with this option, compilation */
+/*   may be very slow and using CFLAGS=-O0 is recommended. */
+/* #define SEXP_USE_SAFE_ACCESSORS 1 */
+
+/* uncomment this to make the heap common to all contexts */
+/*   By default separate contexts can have separate heaps, */
+/*   and are thus thread-safe and independant. */
+/* #define SEXP_USE_GLOBAL_HEAP 1 */
+
+/* uncomment this to make the symbol table common to all contexts */
+/*   Will still be restricted to all contexts sharing the same */
+/*   heap, of course. */
+/* #define SEXP_USE_GLOBAL_SYMBOLS 1 */
+
+/* uncomment this to disable foreign function bindings with > 6 args */
+/* #define SEXP_USE_EXTENDED_FCALL 0 */
+
+/* uncomment this if you don't need flonum support */
+/*   This is only for EVAL - you'll still be able to read */
+/*   and write flonums directly through the sexp API. */
+/* #define SEXP_USE_FLONUMS 0 */
+
+/* uncomment this to disable reading/writing IEEE infinities */
+/*   By default you can read/write +inf.0, -inf.0 and +nan.0 */
+/* #define SEXP_USE_INFINITIES 0 */
+
+/* uncomment this if you want immediate flonums */
+/*   This is experimental, enable at your own risk. */
+/* #define SEXP_USE_IMMEDIATE_FLONUMS 1 */
+
+/* uncomment this if you don't want bignum support */
+/*   Bignums are implemented with a small, custom library  */
+/*   in opt/bignum.c. */
+/* #define SEXP_USE_BIGNUMS 0 */
+
+/* uncomment this if you don't want exact ratio support */
+/*   Ratios are part of the bignum library and imply bignums. */
+/* #define SEXP_USE_RATIOS 0 */
+
+/* uncomment this if you don't want imaginary number support */
+/* #define SEXP_USE_COMPLEX 0 */
+
+/* uncomment this if you don't want 1## style approximate digits */
+/* #define SEXP_USE_PLACEHOLDER_DIGITS 0 */
+
+/* uncomment this if you don't need extended math operations */
+/*   This includes the trigonometric and expt functions. */
+/*   Automatically disabled if you've disabled flonums. */
+/* #define SEXP_USE_MATH 0 */
+
+/* uncomment this to disable warning about references to undefined variables */
+/*   This is something of a hack, but can be quite useful. */
+/*   It's very fast and doesn't involve any separate analysis */
+/*   passes. */
+/* #define SEXP_USE_WARN_UNDEFS 0 */
+
+/* uncomment this to disable huffman-coded immediate symbols */
+/*   By default (this may change) small symbols are represented */
+/*   as immediates using a simple huffman encoding.  This keeps */
+/*   the symbol table small, and minimizes hashing when doing a */
+/*   lot of reading. */
+/* #define SEXP_USE_HUFF_SYMS 0 */
+
+/* uncomment this to just use a single list for hash tables */
+/*   You can trade off some space in exchange for longer read */
+/*   times by disabling hashing and just putting all */
+/*   non-immediate symbols in a single list. */
+/* #define SEXP_USE_HASH_SYMS 0 */
+
+/* uncomment this to disable extended char names as defined in R7RS */
+/* #define SEXP_USE_EXTENDED_CHAR_NAMES 0 */
+
+/* uncomment this to disable UTF-8 string support */
+/*   The default settings store strings in memory as UTF-8, */
+/*   and assumes strings passed to/from the C FFI are UTF-8.  */
+/* #define SEXP_USE_UTF8_STRINGS 0 */
+
+/* uncomment this to disable the string-set! opcode */
+/*   By default (non-literal) strings are mutable. */
+/*   Making them immutable allows for packed UTF-8 strings. */
+/* #define SEXP_USE_MUTABLE_STRINGS 0 */
+
+/* uncomment this to base string ports on C streams */
+/*   This historic option enables string and custom ports backed */
+/*   by FILE* objects using memstreams and funopen/fopencookie. */
+/* #define SEXP_USE_STRING_STREAMS 1 */
+
+/* uncomment this to disable automatic closing of ports */
+/*   If enabled, the underlying FILE* for file ports will be */
+/*   automatically closed when they're garbage collected.  Doesn't */
+/*   apply to stdin/stdout/stderr. */
+/* #define SEXP_USE_AUTOCLOSE_PORTS 0 */
+
+/* uncomment this to use the normal 1970 unix epoch */
+/*   By default chibi uses an datetime epoch starting at */
+/*   2010/01/01 00:00:00 in order to be able to represent */
+/*   more common times as fixnums. */
+/* #define SEXP_USE_2010_EPOCH 0 */
+
+/* uncomment this to disable stack overflow checks */
+/*   By default stacks are fairly small, so it's good to leave */
+/*   this enabled. */
+/* #define SEXP_USE_CHECK_STACK 0 */
+
+/* uncomment this to disable growing the stack on overflow */
+/*   If enabled, chibi attempts to grow the stack on overflow, */
+/*   up to SEXP_MAX_STACK_SIZE, otherwise a failed stack check */
+/*   will just raise an error immediately. */
+/* #define SEXP_USE_GROW_STACK 0 */
+
+/* #define SEXP_USE_DEBUG_VM 0 */
+/*   Experts only. */
+/*   For *very* verbose output on every VM operation. */
+
+/* uncomment this to make the VM adhere to alignment rules */
+/*   This is required on some platforms, e.g. ARM */
+/* #define SEXP_USE_ALIGNED_BYTECODE */
+
+/************************************************************************/
+/* These settings are configurable but only recommended for */
+/* experienced users, and only apply when using the native GC.  */
+/************************************************************************/
+
+/* the initial heap size in bytes */
+#ifndef SEXP_INITIAL_HEAP_SIZE
+#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024)
+#endif
+
+/* the maximum heap size in bytes - if 0 there is no limit */
+#ifndef SEXP_MAXIMUM_HEAP_SIZE
+#define SEXP_MAXIMUM_HEAP_SIZE 0
+#endif
+#ifndef SEXP_MINIMUM_HEAP_SIZE
+#define SEXP_MINIMUM_HEAP_SIZE 8*1024
+#endif
+
+/* if after GC more than this percentage of memory is still in use, */
+/* and we've not exceeded the maximum size, grow the heap */
+#ifndef SEXP_GROW_HEAP_RATIO
+#define SEXP_GROW_HEAP_RATIO 0.75
+#endif
+
+/* the default number of opcodes to run each thread for */
+#ifndef SEXP_DEFAULT_QUANTUM
+#define SEXP_DEFAULT_QUANTUM 500
+#endif
+
+/************************************************************************/
+/*         DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE            */
+/************************************************************************/
+
+#ifndef SEXP_64_BIT
+#if defined(__amd64) || defined(__x86_64) || defined(_WIN64) || defined(_Wp64)
+#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_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_USE_TYPE_DEFS
+#define SEXP_USE_TYPE_DEFS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_MAXIMUM_TYPES
+#define SEXP_MAXIMUM_TYPES ((sexp_tag_t)-1)
+#endif
+
+#ifndef SEXP_USE_DL
+#if defined(PLAN9) || defined(_WIN32)
+#define SEXP_USE_DL 0
+#else
+#define SEXP_USE_DL ! SEXP_USE_NO_FEATURES
+#endif
+#endif
+
+#ifndef SEXP_USE_STATIC_LIBS
+#define SEXP_USE_STATIC_LIBS 0
+#endif
+
+#ifndef SEXP_USE_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_HEADER_MAGIC
+#define SEXP_USE_HEADER_MAGIC 0
+#endif
+
+#ifndef SEXP_USE_SAFE_ACCESSORS
+#define SEXP_USE_SAFE_ACCESSORS 0
+#endif
+
+#ifndef SEXP_USE_GLOBAL_HEAP
+#if SEXP_USE_BOEHM || SEXP_USE_MALLOC
+#define SEXP_USE_GLOBAL_HEAP 1
+#else
+#define SEXP_USE_GLOBAL_HEAP 0
+#endif
+#endif
+
+#ifndef SEXP_USE_GLOBAL_SYMBOLS
+#if SEXP_USE_BOEHM || SEXP_USE_MALLOC
+#define SEXP_USE_GLOBAL_SYMBOLS 1
+#else
+#define SEXP_USE_GLOBAL_SYMBOLS 0
+#endif
+#endif
+
+#ifndef SEXP_USE_STRICT_TOPLEVEL_BINDINGS
+#define SEXP_USE_STRICT_TOPLEVEL_BINDINGS 0
+#endif
+
+#if SEXP_USE_STRICT_TOPLEVEL_BINDINGS
+#define SEXP_USE_RENAME_BINDINGS 1
+#else
+#ifndef SEXP_USE_RENAME_BINDINGS
+#define SEXP_USE_RENAME_BINDINGS 0
+#endif
+#endif
+
+#ifndef SEXP_USE_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_PLACEHOLDER_DIGITS
+#define SEXP_USE_PLACEHOLDER_DIGITS SEXP_USE_FLONUMS
+#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 ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_PORT_BUFFER_SIZE
+#define SEXP_PORT_BUFFER_SIZE 4096
+#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_BOUND
+#define SEXP_DEFAULT_EQUAL_BOUND 100000
+#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_MAIN_HELP
+#define SEXP_USE_MAIN_HELP ! SEXP_USE_NO_FEATURES
+#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))
+#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)
+#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
+#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) (strcmp((subabi), (genabi)) == 0)

lib/chibi/accept.c

@@ -0,0 +1,41 @@
+
+/* chibi-ffi should probably be able to detect these patterns automatically, */
+/* but for now we manually check two special cases - accept should check for */
+/* EWOULDBLOCK and block on the socket, and listen should automatically make */
+/* sockets non-blocking. */
+
+sexp sexp_accept (sexp ctx, sexp self, int sock, struct sockaddr* addr, socklen_t len) {
+#if SEXP_USE_GREEN_THREADS
+  sexp f;
+#endif
+  int res;
+  res = accept(sock, addr, &len);
+#if SEXP_USE_GREEN_THREADS
+  if (res < 0 && errno == EWOULDBLOCK) {
+    f = sexp_global(ctx, SEXP_G_THREADS_BLOCKER);
+    if (sexp_opcodep(f)) {
+      ((sexp_proc2)sexp_opcode_func(f))(ctx, f, 1, sexp_make_fixnum(sock));
+      return sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR);
+    }
+  }
+  if (res >= 0)
+    fcntl(res, F_SETFL, fcntl(res, F_GETFL) | O_NONBLOCK);
+#endif
+  return sexp_make_fileno(ctx, sexp_make_fixnum(res), SEXP_FALSE);
+}
+
+/* If we're listening on a socket from Scheme, we most likely want it */
+/* to be non-blocking. */
+
+sexp sexp_listen (sexp ctx, sexp self, sexp fileno, sexp backlog) {
+  int fd, res;
+  sexp_assert_type(ctx, sexp_filenop, SEXP_FILENO, fileno);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, backlog);
+  fd = sexp_fileno_fd(fileno);
+  res = listen(fd, sexp_unbox_fixnum(backlog));
+#if SEXP_USE_GREEN_THREADS
+  if (res >= 0)
+    fcntl(fd, F_SETFL, fcntl(fd, F_GETFL) | O_NONBLOCK);
+#endif
+  return (res == 0) ? SEXP_TRUE : SEXP_FALSE;
+}

lib/chibi/ast.c

@@ -0,0 +1,494 @@
+/*  ast.c -- interface to the Abstract Syntax Tree            */
+/*  Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+
+#ifndef PLAN9
+#include <errno.h>
+#endif
+
+#if ! SEXP_USE_BOEHM
+extern sexp sexp_gc (sexp ctx, size_t *sum_freed);
+#endif
+
+static void sexp_define_type_predicate (sexp ctx, sexp env, char *cname, sexp_uint_t type) {
+  sexp_gc_var2(name, op);
+  sexp_gc_preserve2(ctx, name, op);
+  name = sexp_c_string(ctx, cname, -1);
+  op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type));
+  sexp_env_define(ctx, env, name=sexp_intern(ctx, cname, -1), op);
+  sexp_gc_release2(ctx);
+}
+
+static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype,
+                                   sexp_uint_t cindex, char* get, char *set) {
+  sexp type, index;
+  sexp_gc_var2(name, op);
+  sexp_gc_preserve2(ctx, name, op);
+  type = sexp_make_fixnum(ctype);
+  index = sexp_make_fixnum(cindex);
+  if (get) {
+    op = sexp_make_getter(ctx, name=sexp_c_string(ctx, get, -1), type, index);
+    sexp_env_define(ctx, env, name=sexp_intern(ctx, get, -1), op);
+  }
+  if (set) {
+    op = sexp_make_setter(ctx, name=sexp_c_string(ctx, set, -1), type, index);
+    sexp_env_define(ctx, env, name=sexp_intern(ctx, set, -1), op);
+  }
+  sexp_gc_release2(ctx);
+}
+
+static sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id) {
+  sexp cell;
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
+  cell = sexp_env_cell(env, id, 0);
+  while ((! cell) && sexp_synclop(id)) {
+    env = sexp_synclo_env(id);
+    id = sexp_synclo_expr(id);
+  }
+  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_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 (sexp_pointerp(x))
+    return sexp_object_type(ctx, x);
+  else if (sexp_fixnump(x))
+    return sexp_type_by_index(ctx, SEXP_FIXNUM);
+  else if (sexp_booleanp(x))
+    return sexp_type_by_index(ctx, SEXP_BOOLEAN);
+  else if (sexp_charp(x))
+    return sexp_type_by_index(ctx, SEXP_CHAR);
+#if SEXP_USE_HUFF_SYMS
+  else if (sexp_symbolp(x))
+    return sexp_type_by_index(ctx, SEXP_SYMBOL);
+#endif
+#if SEXP_USE_IMMEDIATE_FLONUMS
+  else if (sexp_flonump(x))
+    return sexp_type_by_index(ctx, SEXP_FLONUM);
+#endif
+  else
+    return sexp_type_by_index(ctx, SEXP_OBJECT);
+}
+
+static sexp sexp_env_parent_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
+  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
+  return sexp_env_parent(e) ? sexp_env_parent(e) : SEXP_FALSE;
+}
+
+static sexp sexp_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_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_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);
+}
+
+#ifdef 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
+
+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_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);
+}
+
+#define sexp_define_type(ctx, name, tag) \
+  sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), sexp_type_by_index(ctx, tag));
+
+sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, sexp_abi_identifier_t abi) {
+  if (!(sexp_version_compatible(ctx, version, sexp_version)
+        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
+    return sexp_global(ctx, SEXP_G_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);
+  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, "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_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, "context?", SEXP_CONTEXT);
+  sexp_define_type_predicate(ctx, env, "exception?", SEXP_EXCEPTION);
+  sexp_define_accessors(ctx, env, SEXP_PAIR, 2, "pair-source", "pair-source-set!");
+  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, 1, "bytecode-name", "bytecode-name-set!");
+  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 2, "bytecode-literals", NULL);
+  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 3, "bytecode-source", NULL);
+  sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 0, "exception-kind", NULL);
+  sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 1, "exception-message", NULL);
+  sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 2, "exception-irritants", 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, "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_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", 2, sexp_extend_env);
+  sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell);
+  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, "environment-parent", 1, sexp_env_parent_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);
+#ifdef SEXP_USE_GREEN_THREADS
+  sexp_define_foreign(ctx, env, "%set-atomic!", 1, sexp_set_atomic);
+#endif
+  sexp_define_foreign(ctx, env, "string-contains", 2, sexp_string_contains);
+  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);
+  return SEXP_VOID;
+}

lib/chibi/ast.scm

@@ -0,0 +1,377 @@
+;; ast.scm -- ast utilities
+;; Copyright (c) 2010-2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> Abstract Syntax Tree.  Interface to the types used by
+;;> the compiler, and other core types less commonly
+;;> needed in user code, plus related utilities.
+
+;;> @subsubsection{Analysis and Expansion}
+
+;;> @subsubsubsection{@scheme{(analyze x [env])}}
+
+;;> Expands and analyzes the expression @var{x} and returns the
+;;> resulting AST.
+
+;;> @subsubsubsection{@scheme{(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)))))
+
+;;> @subsubsection{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?}}
+;;> ]
+
+;;> @subsubsubsection{@scheme{(type-of x)}}
+
+;;> Returns the type of any object @var{x}.
+
+;;> @subsubsubsection{@scheme{(type-name type)}}
+
+;;> Returns the name of type @var{type}.
+
+;;> @subsubsubsection{@scheme{(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)))))
+
+;;> @subsubsubsection{@scheme{(type-cpl type)}}
+
+;;> Returns the class precedence list of type @var{type} as a
+;;> vector, or @scheme{#f} for a type with no parent.
+
+;;> @subsubsubsection{@scheme{(type-slots type)}}
+
+;;> Returns the slot list of type @var{type}.
+
+;;> @subsubsection{Accessors}
+
+;;> This section describes additional accessors on AST and other core
+;;> types.
+
+;;> @subsubsubsection{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))
+
+;;> @subsubsubsection{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}
+;;> ]
+
+;;> @subsubsubsection{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}
+;;> ]
+
+;;> @subsubsubsection{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.
+
+;;> @subsubsubsection{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.
+
+;;> @subsubsubsection{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)}}
+;;> ]
+
+;;> @subsubsubsection{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)}}
+;;> ]
+
+;;> @subsubsubsection{Sequences}
+
+;;> @itemlist[
+;;> @item{@scheme{(seq-ls seq)} - the list of sequence expressions}
+;;> @item{@scheme{(seq-ls-set! seq x)}}
+;;> ]
+
+;;> @subsubsubsection{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)}}
+;;> ]
+
+;;> @subsubsubsection{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)}}
+;;> ]
+
+;;> @subsubsubsection{Literals}
+
+;;> @itemlist[
+;;> @item{@scheme{(lit-value lit)} - the literal value}
+;;> @item{@scheme{(lit-value-set! lit x)}}
+;;> ]
+
+;;> @subsubsubsection{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.
+
+;;> @subsubsection{Miscellaneous Utilities}
+
+;;> @subsubsubsection{@scheme{(gc)}}
+
+;;> Force a garbage collection.
+
+;;> @subsubsubsection{@scheme{(object-size x)}}
+
+;;> Returns the heap space directly used by @var{x}, not
+;;> counting any elements of @var{x}.
+
+;;> @subsubsubsection{@scheme{(integer->immediate n)}}
+
+;;> Returns the interpretation of the integer @var{n} as
+;;> an immediate object, useful for debugging.
+
+;;> @subsubsubsection{@scheme{(string-contains str pat)}}
+
+;;> Returns the first string cursor of @var{pat} in @var{str},
+;;> of @scheme{#f} if it's not found.
+
+;;> @subsubsubsection{@scheme{(atomically @var{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,40 @@
+
+(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 Char Boolean
+   Symbol String Byte-Vector Vector Pair
+   Context Lam Cnd Set Ref Seq Lit Sc Exception
+   syntactic-closure? lambda? cnd? set? ref? seq? lit? type?
+   environment? bytecode? exception? macro? context?
+   syntactic-closure-expr syntactic-closure-env syntactic-closure-vars
+   copy-lambda make-lambda make-cnd make-ref make-set make-seq make-lit
+   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
+   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!
+   bytecode-name bytecode-literals bytecode-source
+   pair-source pair-source-set!
+   port-line port-line-set!
+   environment-parent
+   type-name type-cpl type-parent type-slots type-num-slots type-printer
+   object-size integer->immediate gc atomically
+   string-contains integer->error-string
+   flatten-dot update-free-vars!)
+  (import (scheme))
+  (include-shared "ast")
+  (include "ast.scm"))

lib/chibi/base64.scm

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

lib/chibi/base64.sld

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

lib/chibi/channel.scm

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

lib/chibi/channel.sld

@@ -0,0 +1,6 @@
+
+(define-library (chibi channel)
+  (import (scheme) (srfi 9) (srfi 18))
+  (export Channel make-channel channel? channel-empty?
+          channel-send! channel-receive!)
+  (include "channel.scm"))

lib/chibi/disasm.c

@@ -0,0 +1,202 @@
+/*  disasm.c -- optional debugging utilities                  */
+/*  Copyright (c) 2009-2011 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include "chibi/eval.h"
+#include "../../opt/opcode_names.h"
+
+#define SEXP_DISASM_MAX_DEPTH 16
+#define SEXP_DISASM_PAD_WIDTH 4
+
+#if SEXP_64_BIT
+#define SEXP_PRId "%ld"
+#else
+#define SEXP_PRId "%d"
+#endif
+
+static void sexp_write_pointer (sexp ctx, void *p, sexp out) {
+  char buf[32];
+  sprintf(buf, "%p", p);
+  sexp_write_string(ctx, buf, out);
+}
+
+static void sexp_write_integer (sexp ctx, sexp_sint_t n, sexp out) {
+  char buf[32];
+  sprintf(buf, SEXP_PRId, n);
+  sexp_write_string(ctx, buf, out);
+}
+
+static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
+  unsigned char *ip, opcode, i;
+  sexp tmp=NULL;
+  sexp_sint_t *labels, label=1, off;
+
+  if (sexp_procedurep(bc)) {
+    bc = sexp_procedure_code(bc);
+  } else if (sexp_opcodep(bc)) {
+    sexp_write(ctx, sexp_opcode_name(bc), out);
+    sexp_write_string(ctx, " is a primitive\n", out);
+    return SEXP_VOID;
+  } else if (! sexp_bytecodep(bc)) {
+    return sexp_type_exception(ctx, self, SEXP_BYTECODE, bc);
+  }
+  if (! sexp_oportp(out)) {
+    return sexp_type_exception(ctx, self, SEXP_OPORT, out);
+  }
+
+  for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++)
+    sexp_write_char(ctx, ' ', out);
+  sexp_write_string(ctx, "      -------------- ", out);
+  if (sexp_truep(sexp_bytecode_name(bc))) {
+    sexp_write(ctx, sexp_bytecode_name(bc), out);
+    sexp_write_char(ctx, ' ', out);
+  }
+  sexp_write_pointer(ctx, bc, out);
+  sexp_newline(ctx, out);
+
+  /* build a table of labels that are jumped to */
+  labels = calloc(sexp_bytecode_length(bc), sizeof(sexp_sint_t));
+  ip = sexp_bytecode_data(bc);
+  while (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) {
+    switch (*ip++) {
+    case SEXP_OP_JUMP:
+    case SEXP_OP_JUMP_UNLESS:
+      off = ip - sexp_bytecode_data(bc) + ((sexp_sint_t*)ip)[0];
+      if (off >= 0 && off < sexp_bytecode_length(bc) && labels[off] == 0)
+        labels[off] = label++;
+    case SEXP_OP_CALL:
+    case SEXP_OP_CLOSURE_REF:
+    case SEXP_OP_GLOBAL_KNOWN_REF:
+    case SEXP_OP_GLOBAL_REF:
+    case SEXP_OP_LOCAL_REF:
+    case SEXP_OP_LOCAL_SET:
+    case SEXP_OP_PARAMETER_REF:
+    case SEXP_OP_PUSH:
+    case SEXP_OP_RESERVE:
+    case SEXP_OP_STACK_REF:
+    case SEXP_OP_TAIL_CALL:
+    case SEXP_OP_TYPEP:
+      ip += sizeof(sexp);
+      break;
+    case SEXP_OP_SLOT_REF:
+    case SEXP_OP_SLOT_SET:
+    case SEXP_OP_MAKE:
+      ip += sizeof(sexp)*2;
+      break;
+    case SEXP_OP_MAKE_PROCEDURE:
+      ip += sizeof(sexp)*3;
+      break;
+    default:
+      /* opcode takes no additional instruction args */
+      break;
+    }
+  }
+
+  ip = sexp_bytecode_data(bc);
+ loop:
+  for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++)
+    sexp_write_char(ctx, ' ', out);
+  if (labels[ip - sexp_bytecode_data(bc)] == 0) {
+    sexp_write_string(ctx, "     ", out);
+  } else {
+    sexp_write_char(ctx, 'L', out);
+    sexp_write_integer(ctx, labels[ip - sexp_bytecode_data(bc)], out);
+    sexp_write_string(ctx, ": ", out);
+    if (labels[ip - sexp_bytecode_data(bc)] < 10)
+      sexp_write_char(ctx, ' ', out);
+  }
+  opcode = *ip++;
+  if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) {
+    sexp_write_char(ctx, ' ', out);
+    sexp_write_string(ctx, reverse_opcode_names[opcode], out);
+    sexp_write_char(ctx, ' ', out);
+  } else {
+    sexp_write_string(ctx, "  <unknown> ", out);
+    sexp_write(ctx, sexp_make_fixnum(opcode), out);
+    sexp_write_char(ctx, ' ', out);
+  }
+  switch (opcode) {
+  case SEXP_OP_STACK_REF:
+  case SEXP_OP_LOCAL_REF:
+  case SEXP_OP_LOCAL_SET:
+  case SEXP_OP_CLOSURE_REF:
+  case SEXP_OP_TYPEP:
+  case SEXP_OP_RESERVE:
+    sexp_write_integer(ctx, ((sexp_sint_t*)ip)[0], out);
+    ip += sizeof(sexp);
+    break;
+  case SEXP_OP_JUMP:
+  case SEXP_OP_JUMP_UNLESS:
+    sexp_write_integer(ctx, ((sexp_sint_t*)ip)[0], out);
+    off = ip - sexp_bytecode_data(bc) + ((sexp_sint_t*)ip)[0];
+    if (off >= 0 && off < sexp_bytecode_length(bc) && labels[off] > 0) {
+      sexp_write_string(ctx, " L", out);
+      sexp_write_integer(ctx, labels[off], out);
+    }
+    ip += sizeof(sexp);
+    break;
+  case SEXP_OP_FCALL0:
+  case SEXP_OP_FCALL1:
+  case SEXP_OP_FCALL2:
+  case SEXP_OP_FCALL3:
+  case SEXP_OP_FCALL4:
+    sexp_write_pointer(ctx, ((sexp*)ip)[0], out);
+    sexp_write_char(ctx, ' ', out);
+    sexp_write(ctx, sexp_opcode_name(((sexp*)ip)[0]), out);
+    ip += sizeof(sexp);
+    break;
+  case SEXP_OP_SLOT_REF:
+  case SEXP_OP_SLOT_SET:
+  case SEXP_OP_MAKE:
+    ip += sizeof(sexp)*2;
+    break;
+  case SEXP_OP_MAKE_PROCEDURE:
+    sexp_write_integer(ctx, ((sexp_sint_t*)ip)[0], out);
+    sexp_write_char(ctx, ' ', out);
+    sexp_write_integer(ctx, ((sexp_sint_t*)ip)[1], out);
+    tmp = ((sexp*)ip)[2];
+    ip += sizeof(sexp)*3;
+    break;
+  case SEXP_OP_GLOBAL_REF:
+  case SEXP_OP_GLOBAL_KNOWN_REF:
+  case SEXP_OP_PARAMETER_REF:
+  case SEXP_OP_TAIL_CALL:
+  case SEXP_OP_CALL:
+  case SEXP_OP_PUSH:
+    tmp = ((sexp*)ip)[0];
+    if (((opcode == SEXP_OP_GLOBAL_REF) || (opcode == SEXP_OP_GLOBAL_KNOWN_REF))
+        && sexp_pairp(tmp))
+      tmp = sexp_car(tmp);
+    else if ((opcode == SEXP_OP_PARAMETER_REF)
+             && sexp_opcodep(tmp) && sexp_opcode_data(tmp)
+             && sexp_pairp(sexp_opcode_data(tmp)))
+      tmp = sexp_car(sexp_opcode_data(tmp));
+    else if ((opcode == SEXP_OP_PUSH) && (sexp_pairp(tmp) || sexp_idp(tmp)))
+      sexp_write_char(ctx, '\'', out);
+    sexp_write(ctx, tmp, out);
+    ip += sizeof(sexp);
+    break;
+  }
+  sexp_write_char(ctx, '\n', out);
+  if ((opcode == SEXP_OP_PUSH || opcode == SEXP_OP_MAKE_PROCEDURE)
+      && (depth < SEXP_DISASM_MAX_DEPTH)
+      && tmp && (sexp_bytecodep(tmp) || sexp_procedurep(tmp)))
+    disasm(ctx, self, tmp, out, depth+1);
+  if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc))
+    goto loop;
+
+  free(labels);
+  return SEXP_VOID;
+}
+
+static sexp sexp_disasm (sexp ctx, sexp self, sexp_sint_t n, sexp bc, sexp out) {
+  return disasm(ctx, self, bc, out, 0);
+}
+
+sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, sexp_abi_identifier_t abi) {
+  if (!(sexp_version_compatible(ctx, version, sexp_version)
+        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
+    return sexp_global(ctx, SEXP_G_ABI_ERROR);
+  sexp_define_foreign_param(ctx, env, "disasm", 2, (sexp_proc1)sexp_disasm, "current-output-port");
+  return SEXP_VOID;
+}

lib/chibi/disasm.sld

@@ -0,0 +1,10 @@
+
+;;> @subsubsubsection{(disasm f [out])}
+
+;;> Write a human-readable disassembly for the procedure @var{f} to
+;;> the port @var{out}, defaulting to @scheme{(current-output-port)}.
+
+(define-library (chibi disasm)
+  (export disasm)
+  (import (scheme))
+  (include-shared "disasm"))

lib/chibi/equiv.scm

@@ -0,0 +1,49 @@
+
+;;> Cycle-aware equality.  Returns @scheme{#t} iff @scheme{a} and
+;;> @scheme{b} are @scheme{equal?}, including cycles.  Another way
+;;> to think of it is they are @scheme{equiv} if they print the
+;;> same, assuming all elements can be printed.
+
+(define (equiv? a b)
+  (let ((equivs (make-hash-table eq?)))
+    (define (get-equivs x)
+      (or (hash-table-ref/default equivs x #f)
+          (let ((tmp (make-hash-table eq?)))
+            (hash-table-set! equivs x tmp)
+            tmp)))
+    (define (merge! tab x)
+      (hash-table-set! tab x tab)
+      (cond ((hash-table-ref/default equivs x #f)
+             => (lambda (tab2)
+                  (hash-table-walk tab2 (lambda (key value)
+                                          (hash-table-set! tab key tab)))))))
+    (define (equiv? a b)
+      (cond
+       ((eq? a b))
+       ((pair? a)
+        (and (pair? b)
+             (let ((a-tab (get-equivs a)))
+               (hash-table-ref
+                a-tab
+                b
+                (lambda ()
+                  (merge! a-tab b)
+                  (and (equiv? (car a) (car b))
+                       (equiv? (cdr a) (cdr b))))))))
+       ((vector? a)
+        (and (vector? b)
+             (= (vector-length a) (vector-length b))
+             (let ((a-tab (get-equivs a)))
+               (hash-table-ref
+                a-tab
+                b
+                (lambda ()
+                  (merge! a-tab b)
+                  (let lp ((i (- (vector-length a) 1)))
+                    (or (< i 0)
+                        (and (equiv? (vector-ref a i) (vector-ref b i))
+                             (lp (- i 1))))))))))
+       (else
+        (equal? a b))))
+    (let ((res (equal?/bounded a b 1000000)))
+      (and res (or (> res 0) (equiv? a b)) #t))))

lib/chibi/equiv.sld

@@ -0,0 +1,6 @@
+
+(define-library (chibi equiv)
+  (export equiv?)
+  (import (scheme))
+  (import (srfi 69))
+  (include "equiv.scm"))

lib/chibi/filesystem.scm

@@ -0,0 +1,68 @@
+;; filesystem.scm -- additional filesystem utilities
+;; Copyright (c) 2009-2011 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> The fundamental directory iterator.  Applies @var{kons} to
+;;> each filename in directory @var{dir} and the result of the
+;;> previous application, beginning with @var{knil}.  With
+;;> @var{kons} as @scheme{cons} and @var{knil} as @scheme{'()},
+;;> equivalent to @scheme{directory-files}.
+
+(define (directory-fold dir kons knil)
+  (let ((dir (opendir dir)))
+    (let lp ((res knil))
+      (let ((file (readdir dir)))
+        (if file (lp (kons (dirent-name file) res)) res)))))
+
+;;> Returns a list of the files in @var{dir} in an unspecified
+;;> order.
+
+(define (directory-files dir)
+  (directory-fold dir cons '()))
+
+;;> Returns the @scheme{status} object for the given @var{file},
+;;> which should be a string indicating the path or a file
+;;> descriptor.
+
+(define (file-status file)
+  (if (string? file) (stat file) (fstat file)))
+
+(define (file-device x) (stat-dev (if (stat? x) x (file-status x))))
+(define (file-inode x) (stat-ino (if (stat? x) x (file-status x))))
+(define (file-mode x) (stat-mode (if (stat? x) x (file-status x))))
+(define (file-num-links x) (stat-nlinks (if (stat? x) x (file-status x))))
+(define (file-owner x) (stat-uid (if (stat? x) x (file-status x))))
+(define (file-group x) (stat-gid (if (stat? x) x (file-status x))))
+(define (file-represented-device x) (stat-rdev (if (stat? x) x (file-status x))))
+(define (file-size x) (stat-size (if (stat? x) x (file-status x))))
+(define (file-block-size x) (stat-blksize (if (stat? x) x (file-status x))))
+(define (file-num-blocks x) (stat-blocks (if (stat? x) x (file-status x))))
+(define (file-access-time x) (stat-atime (if (stat? x) x (file-status x))))
+(define (file-modification-time x) (stat-mtime (if (stat? x) x (file-status x))))
+(define (file-change-time x) (stat-ctime (if (stat? x) x (file-status x))))
+
+;;> File status accessors.  @var{x} should be a string indicating
+;;> the file to lookup the status for, or an existing status object.
+;;/
+
+(define (file-regular? x) (S_ISREG (file-mode x)))
+(define (file-directory? x) (S_ISDIR (file-mode x)))
+(define (file-character? x) (S_ISCHR (file-mode x)))
+(define (file-block? x) (S_ISBLK (file-mode x)))
+(define (file-fifo? x) (S_ISFIFO (file-mode x)))
+(define (file-link? x) (S_ISLNK (file-mode x)))
+(define (file-socket? x) (S_ISSOCK (file-mode x)))
+(define (file-exists? x) (and (file-status x) #t))
+
+;;> File type tests.  @var{x} should be a string indicating the
+;;> file to lookup the status for, or an existing status object.
+;;> Returns @scheme{#t} if the file exists and the given type
+;;> is satisfied, and @scheme{#f} otherwise.
+;;/
+
+;;> Equivalent to duplicating the file descriptor @var{old} to
+;;> @var{new} and closing @var{old}.
+
+(define (renumber-file-descriptor old new)
+  (and (duplicate-file-descriptor-to old new)
+       (close-file-descriptor old)))

lib/chibi/filesystem.sld

@@ -0,0 +1,32 @@
+
+;;> Interface to the filesystem and file descriptor objects.
+;;> Note that file descriptors are currently represented as
+;;> integers, but may be replaced with opaque (and gc-managed)
+;;> objects in a future release.
+
+(define-library (chibi filesystem)
+  (export duplicate-file-descriptor duplicate-file-descriptor-to
+          close-file-descriptor renumber-file-descriptor
+          delete-file link-file symbolic-link-file rename-file
+          directory-files directory-fold create-directory delete-directory
+          open open-pipe make-fifo
+          file-status
+          file-device               file-inode
+          file-mode                 file-num-links
+          file-owner                file-group
+          file-represented-device   file-size
+          file-block-size           file-num-blocks
+          file-access-time file-modification-time file-change-time
+          file-regular?    file-directory?        file-character?
+          file-block?      file-fifo?             file-link?
+          file-socket?     file-exists?
+          get-file-descriptor-flags   set-file-descriptor-flags!
+          get-file-descriptor-status  set-file-descriptor-status!
+          open/read        open/write             open/read-write
+          open/create      open/exclusive         open/truncate
+          open/append      open/non-block
+          is-a-tty?)
+  (import (scheme))
+  (include-shared "filesystem")
+  (include "filesystem.scm"))
+

lib/chibi/filesystem.stub

@@ -0,0 +1,190 @@
+;; filesystem.stub -- filesystem bindings
+;; Copyright (c) 2009-2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(c-system-include "sys/types.h")
+(c-system-include "unistd.h")
+(c-system-include "dirent.h")
+(c-system-include "fcntl.h")
+
+(define-c-type DIR
+  finalizer: closedir)
+
+(define-c-struct dirent
+  (string d_name dirent-name))
+
+(define-c-struct stat
+  predicate: stat?
+  (dev_t      st_dev      stat-dev)
+  (ino_t      st_ino      stat-ino)
+  (mode_t     st_mode     stat-mode)
+  (nlink_t    st_nlink    stat-nlinks)
+  (uid_t      st_uid      stat-uid)
+  (gid_t      st_gid      stat-gid)
+  (dev_t      st_rdev     stat-rdev)
+  (off_t      st_size     stat-size)
+  (blksize_t  st_blksize  stat-blksize)
+  (blkcnt_t   st_blocks   stat-blocks)
+  (time_t     st_atime    stat-atime)
+  (time_t     st_mtime    stat-mtime)
+  (time_t     st_ctime    stat-ctime))
+
+(define-c boolean S_ISREG (mode_t))
+(define-c boolean S_ISDIR (mode_t))
+(define-c boolean S_ISCHR (mode_t))
+(define-c boolean S_ISBLK (mode_t))
+(define-c boolean S_ISFIFO (mode_t))
+(define-c boolean S_ISLNK (mode_t))
+(define-c boolean S_ISSOCK (mode_t))
+
+;;(define-c-const int ("S_IFMT"))
+(define-c-const int (file/socket "S_IFSOCK"))
+(define-c-const int (file/link "S_IFLNK"))
+(define-c-const int (file/regular "S_IFREG"))
+(define-c-const int (file/block "S_IFBLK"))
+(define-c-const int (file/directory "S_IFDIR"))
+(define-c-const int (file/character "S_IFCHR"))
+(define-c-const int (file/fifo "S_IFIFO"))
+(define-c-const int (file/suid "S_ISUID"))
+(define-c-const int (file/sgid "S_ISGID"))
+(define-c-const int (file/sticky "S_ISVTX"))
+;;(define-c-const int ("S_IRWXU"))
+(define-c-const int (perm/user-read "S_IRUSR"))
+(define-c-const int (perm/user-write "S_IWUSR"))
+(define-c-const int (perm/user-execute "S_IXUSR"))
+;;(define-c-const int ("S_IRWXG"))
+(define-c-const int (perm/group-read "S_IRGRP"))
+(define-c-const int (perm/group-write "S_IWGRP"))
+(define-c-const int (perm/group-execute "S_IXGRP"))
+;;(define-c-const int ("S_IRWXO"))
+(define-c-const int (perm/others-read "S_IROTH"))
+(define-c-const int (perm/others-write "S_IWOTH"))
+(define-c-const int (perm/others-execute "S_IXOTH"))
+
+(define-c errno stat (string (result stat)))
+(define-c errno fstat (int (result stat)))
+(define-c errno (file-link-status "lstat") (string (result stat)))
+
+;; Creates a new input-port from the file descriptor @var{int}.
+
+;; (define-c input-port (open-input-file-descriptor "fdopen")
+;;   (fileno (value "r" string)))
+
+;; Creates a new output-port from the file descriptor @var{int}.
+
+;; (define-c output-port (open-output-file-descriptor "fdopen")
+;;   (fileno (value "w" string)))
+
+;; Creates a new bidirectional port from the file descriptor @var{int}.
+
+;; (define-c input-output-port (open-input-output-file-descriptor "fdopen")
+;;   (fileno (value "r+" string)))
+
+;;> Unlinks the file named @var{string} from the filesystem.
+;;> Returns @scheme{#t} on success and @scheme{#f} on failure.
+
+(define-c errno (delete-file "unlink") (string))
+
+;;> Creates a hard link to the first arg from the second.
+;;> Returns @scheme{#t} on success and @scheme{#f} on failure.
+
+(define-c errno (link-file "link") (string string))
+
+;;> Creates a symbolic link to the first arg from the second.
+;;> Returns @scheme{#t} on success and @scheme{#f} on failure.
+
+(define-c errno (symbolic-link-file "symlink") (string string))
+
+;;> Renames the first arg to the second.
+;;> Returns @scheme{#t} on success and @scheme{#f} on failure.
+
+(define-c errno (rename-file "rename") (string string))
+
+;;> Returns the current working directory of the process as a string.
+
+(define-c non-null-string (current-directory "getcwd")
+  ((result (array char (auto-expand arg1))) (value 256 int)))
+
+;;> Creates a new directory with the given mode.
+;;> Returns @scheme{#t} on success and @scheme{#f} on failure.
+
+(define-c errno (create-directory "mkdir") (string int))
+
+;;> Deletes the directory named @var{string} from the filesystem.
+;;> Does not attempt to delete recursively.
+;;> Returns @scheme{#t} on success and @scheme{#f} on failure.
+
+(define-c errno (delete-directory "rmdir") (string))
+
+(define-c (free DIR) opendir (string))
+(define-c dirent readdir ((link (pointer DIR))))
+
+;;> Duplicates the given file descriptor, returning he new value,
+;; or -1 on failure.
+
+(define-c fileno (duplicate-file-descriptor "dup") (fileno))
+
+;;> Copies the first file descriptor to the second, closing
+;;> it if needed.
+;;> Returns @scheme{#t} on success and @scheme{#f} on failure.
+
+(define-c errno (duplicate-file-descriptor-to "dup2") (fileno fileno))
+
+;;> Closes the given file descriptor.
+;;> Returns @scheme{#t} on success and @scheme{#f} on failure.
+
+(define-c errno (close-file-descriptor "close") (fileno))
+
+;;> Opens the given file and returns a file descriptor.
+
+(define-c fileno open (string int (default #o644 int)))
+
+;;> Returns a list of 2 new file descriptors, the input and
+;;> output end of a new pipe, respectively.
+
+(define-c errno (open-pipe "pipe") ((result (array fileno 2))))
+
+;;> Creates a new named pipe in the given path.
+;;> Returns @scheme{#t} on success and @scheme{#f} on failure.
+
+(define-c errno (make-fifo "mkfifo") (string (default #o644 int)))
+
+(define-c int (get-file-descriptor-flags "fcntl")
+  (fileno (value F_GETFD int)))
+(define-c errno (set-file-descriptor-flags! "fcntl")
+  (fileno (value F_SETFD int) long))
+
+;;> Get and set the flags for the given file descriptor.
+;;/
+
+(define-c int (get-file-descriptor-status "fcntl")
+  (fileno (value F_GETFL int)))
+(define-c errno (set-file-descriptor-status! "fcntl")
+  (fileno (value F_SETFL int) long))
+
+;;> Get and set the status for the given file descriptor.
+;;/
+
+;; (define-c int (get-file-descriptor-lock "fcntl")
+;;   (int (value F_GETLK int) flock))
+;; (define-c errno (set-file-descriptor-lock! "fcntl")
+;;   (int (value F_SETLK int) flock))
+;; (define-c errno (try-set-file-descriptor-lock! "fcntl")
+;;   (int (value F_SETLKW int) flock))
+
+(define-c-const int (open/read "O_RDONLY"))
+(define-c-const int (open/write "O_WRONLY"))
+(define-c-const int (open/read-write "O_RDWR"))
+(define-c-const int (open/create "O_CREAT"))
+(define-c-const int (open/exclusive "O_EXCL"))
+(define-c-const int (open/truncate "O_TRUNC"))
+(define-c-const int (open/append "O_APPEND"))
+(define-c-const int (open/non-block "O_NONBLOCK"))
+
+;;> File opening modes.
+;;/
+
+;;> Returns @scheme{#t} if the given port of file descriptor
+;;> if backed by a TTY object, and @scheme{#f} otherwise.
+
+(define-c boolean (is-a-tty? "isatty") (port-or-fileno))

lib/chibi/generic.scm

@@ -0,0 +1,93 @@
+
+;;> Define a new generic function named @var{name}.
+
+(define-syntax define-generic
+  (syntax-rules ()
+    ((define-generic name)
+     (define name (make-generic 'name)))))
+
+;; call-next-method needs to be unhygienic
+'(define-syntax define-method
+  (syntax-rules ()
+    ((define-method (name (param type) ...) . body)
+     (generic-add! name
+                   (list type ...)
+                   (lambda (next param ...)
+                     (let-syntax ((call))
+                       . body))))))
+
+;;> @subsubsubsection{(define-method (name (param type) ...) body ...)}
+
+;;> Extends the generic function @var{name} with a new method that
+;;> applies when the given param types all match.
+
+(define-syntax define-method
+  (er-macro-transformer
+   (lambda (e r c)
+     (let ((name (caadr e))
+           (params (cdadr e))
+           (body (cddr e)))
+       `(,(r 'generic-add!) ,name
+         (,(r 'list) ,@(map cadr params))
+         (,(r 'lambda) (next ,@(map car params))
+          (,(r 'let-syntax) ((call-next-method
+                              (,(r 'syntax-rules) ()
+                               ((_) (next)))))
+           ,@body)))))))
+
+(define (no-applicable-method-error name args)
+  (error "no applicable method" name args))
+
+(define (satisfied? preds args)
+  (cond ((null? preds) (null? args))
+        ((null? args) #f)
+        (((car preds) (car args)) (satisfied? (cdr preds) (cdr args)))
+        (else #f)))
+
+(define add-method-tag (list 'add-method-tag))
+
+;;> Create a new first-class generic function named @var{name}.
+
+(define (make-generic name)
+  (let ((name name)
+        (methods (make-vector 6 '())))
+    (vector-set! methods
+                 3
+                 (list (cons (list (lambda (x) (eq? x add-method-tag))
+                                   (lambda (x) (list? x))
+                                   procedure?)
+                             (lambda (next t p f)
+                               (set! methods (insert-method! methods p f))))))
+    (lambda args
+      (let ((len (length args)))
+        (cond
+         ((>= len (vector-length methods))
+          (no-applicable-method-error name args))
+         (else
+          (let lp ((ls (vector-ref methods len)))
+            (cond
+             ((null? ls)
+              (no-applicable-method-error name args))
+             ((satisfied? (car (car ls)) args)
+              (apply (cdr (car ls)) (lambda () (lp (cdr ls))) args))
+             (else
+              (lp (cdr ls)))))))))))
+
+(define (insert-method! vec preds f)
+  (let ((vlen (vector-length vec))
+        (plen (length preds)))
+    (let ((res (if (>= plen vlen)
+                   (let ((r (make-vector (+ vlen 1) '())))
+                     (do ((i 0 (+ i 1)))
+                         ((>= i vlen) r)
+                       (vector-set! r i (vector-ref vec i))))
+                   vec)))
+      (vector-set! res plen (cons (cons preds f) (vector-ref res plen)))
+      res)))
+
+;;> Extend the generic @var{g} with a new method @var{f}
+;;> that applies when all parameters match the given list
+;;> of predicates @var{preds}.
+
+(define (generic-add! g preds f)
+  (g add-method-tag preds f))

lib/chibi/generic.sld

@@ -0,0 +1,7 @@
+
+;;> Simple generic function interface.
+
+(define-library (chibi generic)
+  (export define-generic define-method make-generic generic-add!)
+  (import (scheme))
+  (include "generic.scm"))

lib/chibi/heap-stats.c

@@ -0,0 +1,137 @@
+/* heap-stats.c -- count or dump heap objects                */
+/* Copyright (c) 2009-2011 Alex Shinn.  All rights reserved. */
+/* BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+
+#define SEXP_HEAP_VECTOR_DEPTH 1
+
+#if ! SEXP_USE_BOEHM
+
+extern sexp sexp_gc (sexp ctx, size_t *sum_freed);
+extern sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x);
+
+static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) {
+  int i;
+  if ((!sexp_pointerp(x)) || sexp_symbolp(x) || sexp_stringp(x)
+      || sexp_flonump(x) || sexp_bignump(x)) {
+    sexp_write(ctx, x, out);
+  } else if (depth <= 0) {
+    goto print_name;
+  } else if (sexp_synclop(x)) {
+    sexp_write_string(ctx, "#<sc ", out);
+    sexp_print_simple(ctx, sexp_synclo_expr(x), out, depth);
+    sexp_write_string(ctx, ">", out);
+  } else if (sexp_pairp(x)) {
+    sexp_write_char(ctx, '(', out);
+    sexp_print_simple(ctx, sexp_car(x), out, depth-1);
+    sexp_write_string(ctx, " . ", out);
+    sexp_print_simple(ctx, sexp_cdr(x), out, depth-1);
+    sexp_write_char(ctx, ')', out);
+  } else if (sexp_vectorp(x)) {
+    sexp_write_string(ctx, "#(", out);
+    for (i=0; i<SEXP_HEAP_VECTOR_DEPTH && i<sexp_vector_length(x); i++) {
+      if (i>0)
+        sexp_write_char(ctx, ' ', out);
+      sexp_print_simple(ctx, sexp_vector_ref(x, i), out, depth-1);
+    }
+    if (i<sexp_vector_length(x))
+      sexp_write_string(ctx, " ...", out);
+    sexp_write_char(ctx, ')', out);
+  } else {
+  print_name:
+    sexp_write_string(ctx, "#<", out);
+    sexp_write(ctx, sexp_object_type_name(ctx, x), out);
+    sexp_write_string(ctx, ">", out);
+  }
+}
+
+static sexp sexp_heap_walk (sexp ctx, int depth, int printp) {
+  size_t freed;
+  sexp_uint_t stats[256], hi_type=0, i;
+  sexp_heap h = sexp_context_heap(ctx);
+  sexp p, out=SEXP_FALSE;
+  sexp_free_list q, r;
+  char *end;
+  sexp_gc_var3(res, tmp, name);
+
+  if (printp)
+    out = sexp_parameter_ref(ctx,
+                             sexp_env_ref(sexp_context_env(ctx),
+                                          sexp_global(ctx,SEXP_G_CUR_OUT_SYMBOL),
+                                          SEXP_FALSE));
+
+  /* run gc once to remove unused variables */
+  sexp_gc(ctx, &freed);
+
+  /* initialize stats */
+  for (i=0; i<256; i++) stats[i]=0;
+
+  /* loop over each heap chunk */
+  for ( ; h; h=h->next) {
+    p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair)));
+    q = h->free_list;
+    end = (char*)h->data + h->size;
+    while (((char*)p) < end) {
+      /* find the preceding and succeeding free list pointers */
+      for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
+        ;
+      if ((char*)r == (char*)p) { /* this is a free block, skip */
+        p = (sexp) (((char*)p) + r->size);
+        continue;
+      }
+      /* otherwise maybe print, then increment the stat and continue */
+      if (sexp_oportp(out)) {
+        sexp_print_simple(ctx, p, out, depth);
+        sexp_write_char(ctx, '\n', out);
+      }
+      stats[sexp_pointer_tag(p)]++;
+      if (sexp_pointer_tag(p) > hi_type)
+        hi_type = sexp_pointer_tag(p);
+      p = (sexp) (((char*)p) + sexp_heap_align(sexp_allocated_bytes(ctx, p)));
+    }
+  }
+
+  /* build and return results */
+  sexp_gc_preserve3(ctx, res, tmp, name);
+  res = SEXP_NULL;
+  for (i=hi_type; i>0; i--)
+    if (stats[i]) {
+      name = sexp_string_to_symbol(ctx, sexp_type_name_by_index(ctx, i));
+      tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i]));
+      res = sexp_cons(ctx, tmp, res);
+    }
+  sexp_gc_release3(ctx);
+  return res;
+}
+
+static sexp sexp_heap_stats (sexp ctx, sexp self, sexp_sint_t n) {
+  return sexp_heap_walk(ctx, 0, 0);
+}
+
+static sexp sexp_heap_dump (sexp ctx, sexp self, sexp_sint_t n, sexp depth) {
+  if (! sexp_fixnump(depth) || (sexp_unbox_fixnum(depth) < 0))
+    return sexp_xtype_exception(ctx, self, "bad heap-dump depth", depth);
+  return sexp_heap_walk(ctx, sexp_unbox_fixnum(depth), 1);
+}
+
+#else
+
+static sexp sexp_heap_stats (sexp ctx, sexp self, sexp_sint_t n) {
+  return SEXP_NULL;
+}
+
+static sexp sexp_heap_dump (sexp ctx, sexp self, sexp_sint_t n, sexp depth) {
+  return SEXP_NULL;
+}
+
+#endif
+
+sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, sexp_abi_identifier_t abi) {
+  if (!(sexp_version_compatible(ctx, version, sexp_version)
+        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
+    return sexp_global(ctx, SEXP_G_ABI_ERROR);
+  sexp_define_foreign(ctx, env, "heap-stats", 0, sexp_heap_stats);
+  sexp_define_foreign_opt(ctx, env, "heap-dump", 1, sexp_heap_dump, SEXP_ONE);
+  return SEXP_VOID;
+}

lib/chibi/heap-stats.sld

@@ -0,0 +1,24 @@
+
+;;> Utilities for gathering statistics on the heap.  Just measuring
+;;> runtime memory usage doesn't give a good idea of how to optimize
+;;> that usage, so this module is provided for profiling.
+
+;;> @subsubsubsection{(heap-stats)}
+
+;;> Returns an alist summarizing all heap allocated objects.  The
+;;> @var{car} of each cell is the type-name, and the @var{cdr} is the
+;;> count of objects of that type in the heap.  Garbage is collected
+;;> before the counts are taken.
+
+;;> @subsubsubsection{(heap-dump [depth])}
+
+;;> Returns the same value as @scheme{(heap-stats)}, but also prints
+;;> all objects on the heap as it runs.  @var{depth} indicates the
+;;> printing depth for compound objects and defaults to 1.
+
+;;> These functions just return @scheme{'()} when using the Boehm GC.
+
+(define-library (chibi heap-stats)
+  (export heap-stats heap-dump)
+  (import (scheme))
+  (include-shared "heap-stats"))

lib/chibi/highlight.scm

@@ -0,0 +1,453 @@
+;; highlight.scm -- source code highlighting library
+;; Copyright (c) 2011 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> Library for highlighting source code in different
+;;> languages.  Currently supports Scheme, C and Assembly.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (string-concatenate-reverse ls)
+  (string-concatenate (reverse ls)))
+
+(define (reverse-list->string ls)
+  (list->string (reverse ls)))
+
+;;> Returns an sxml structure representing the code from source
+;;> with various language constructs wrapped in highlighting
+;;> forms.  @var{source} should be a string or port.  The
+;;> language to highlight for is auto-detected.
+
+(define (highlight source)
+  (let ((str (if (string? source) source (port->string source))))
+    ((highlighter-for (highlight-detect-language str)) str)))
+
+;;> Attempst to auto-detect which language @var{str} is code
+;;> for, and returns a symbol representing that language.
+
+(define (highlight-detect-language str)
+  (cond
+   ((guard (exn (else #f))
+      (call-with-input-string str
+        (lambda (in) (do ((x #f (read in))) ((eof-object? x)))))
+      #t)
+    'scheme)
+   (else
+    'c)))
+
+;;> Return a procedure for highlighting the given language.
+
+(define (highlighter-for language)
+  (case language
+    ((scheme) highlight-scheme)
+    ((asm) highlight-assembly)
+    ((none) (lambda (x) x))
+    (else highlight-c)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define highlight-themes
+  '((light
+     (keyword      . "#800080")
+     (type         . "#008000")
+     (function     . "#0000FF")
+     (variable     . "#B8860B")
+     (comment      . "#FF0000")
+     (string       . "#BC8F8F")
+     (attribute    . "#FF5000")
+     (preprocessor . "#FF00FF")
+     (builtin      . "#FF00FF")
+     (character    . "#0055AA")
+     (syntaxerror  . "#FF0000")
+     (diff-deleted . "#5F2121")
+     (diff-added   . "#215F21")
+     )))
+
+(define highlight-paren-styles
+  ;;'("#BAFFFF" "#FFCACA" "#FFFFBA" "#CACAFF" "#CAFFCA" "FFBAFF")
+  '("#AAAAAA" "#888888" "#666666" "#444444" "#222222" "#000000"))
+
+;;> Returns a string representing the CSS needed for the output
+;;> of @var{highlight}.  This should be included in a referenced
+;;> CSS file, or in a @var{<script>} section in the generated in
+;;> the generated HTML output.
+
+(define (highlight-style . theme)
+  (string-concatenate
+   (append
+    (map
+     (lambda (x)
+       (if (and (list? x) (= 3 (length x)))
+           (string-append
+            "." (symbol->string (car x)) " { color: " (cadr x)
+            "; background-color: " (caddr x) "; }\n")
+           (string-append
+            "." (symbol->string (car x)) " { color: "
+            (if (pair? (cdr x)) (cadr x) (cdr x))
+            "; background-color: inherit; }\n")))
+     (cond ((assq (and (pair? theme) (car theme)) highlight-themes) => cdr)
+           (else (cdar highlight-themes))))
+    (map
+     (lambda (s i)
+       (string-append
+        ;;"span.paren" (number->string i)
+        ;;":hover { color: inherit; background-color: " s "; }\n"
+        "span.paren" (number->string i)
+        " { color: " s "; background-color: inherit; }\n"))
+     highlight-paren-styles
+     (cdr (iota (+ 1 (length highlight-paren-styles))))))))
+
+(define (highlight-class class x)
+  `(span (^ (class . ,class)) ,@(if (list? x) x (list x))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (read-whitespace in)
+  (let lp ((res '()))
+    (if (char-whitespace? (peek-char in))
+        (lp (cons (read-char in) res))
+        (reverse-list->string res))))
+
+(define (read-to-whitespace in res)
+  (let ((c (peek-char in)))
+    (cond
+     ((or (eof-object? c) (char-whitespace? c))
+      (reverse-list->string res))
+     (else
+      (read-to-whitespace in (cons (read-char in) res))))))
+
+(define (read-escaped in term ls)
+  (let ((c (read-char in)))
+    (cond
+     ((eof-object? c) (reverse-list->string ls))
+     ((eqv? c term) (reverse-list->string (cons c ls)))
+     ((eqv? c #\<) (read-escaped in term `(#\; #\t #\l #\& ,@ls)))
+     ;;((eqv? c #\>) (read-escaped in term `(#\; #\t #\g #\& ,@ls)))
+     ((eqv? c #\&) (read-escaped in term `(#\; #\p #\m #\a #\& ,@ls)))
+     ;;((eqv? c #\\) (read-escaped in term (cons (read-char in) (cons c ls))))
+     (else (read-escaped in term (cons c ls))))))
+
+(define (read-to-eol in ls)
+  (let ((c (read-char in)))
+    (cond
+     ((eof-object? c) (reverse-list->string ls))
+     ((eqv? c #\newline) (reverse-list->string (cons c ls)))
+     (else (read-to-eol in (cons c ls))))))
+
+(define (html-escape str)
+  (call-with-input-string str (lambda (in) (read-escaped in #f '()))))
+
+(define (collect str res)
+  (if (pair? str) (cons (reverse-list->string str) res) res))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (highlight-scheme-delimiter? ch)
+  (or (eof-object? ch)
+      (char-whitespace? ch)
+      (memq ch '(#\; #\# #\( #\) #\[ #\] #\{ #\} #\' #\` #\, #\"))))
+
+(define (highlight-scheme-definition? id)
+  (memq id '(define define-syntax define-module define-class
+             define-record define-record-type)))
+
+(define (highlight-scheme-syntax? id)
+  (memq id '(if lambda define set! cond case let let* letrec letrec*
+             let-values let-values* let-optionals let-optionals*
+             let-keywords let-keywords* and-let* rec receive do
+             loop rxmatch-cond rxmatch-case begin when unless
+             match match-lambda match-let match-let* dotimes dolist
+             quote quasiquote unquote unquote-splicing error errorf
+             define-syntax let-syntax letrec-syntax syntax-rules
+             syntax-case parameterize module library require
+             require-extension use use-modules import import-immutable
+             define-module select-module provide autoload export
+             only except rename prefix include include-shared
+             condition-case guard cond-expand for with to by
+             in-list in-lists in-string in-string-reverse
+             in-vector in-vector-reverse in-file listing appending
+             summing multpliying up-from down-from else
+             )))
+
+;;> Highlighter for Scheme source code.
+
+(define (highlight-scheme source)
+  (let ((in (if (string? source) (open-input-string source) source)))
+    (define (read-identifier ls)
+      (let ((c (peek-char in)))
+        (cond
+         ((highlight-scheme-delimiter? c)
+          (reverse-list->string ls))
+         (else
+          (read-char in)
+          (read-identifier (cons c ls))))))
+    (define (hash-mark)
+      (let ((c (read-char in)))
+        (case c
+          ((#\;)
+           (highlight-class "comment" (highlight 0 '(#\; #\#) '())))
+          ((#\\)
+           (highlight-class "string"
+                            (read-identifier (list (read-char in) #\\ #\#))))
+          (else
+           (string-append "#" (if (char? c) (string c) ""))))))
+    (define (highlight n str res)
+      (let ((c (read-char in)))
+        (if (eof-object? c)
+            (reverse (collect str res))
+            (case c
+              ((#\;)
+               (let lp ((ls '()))
+                 (let ((ls (cons (read-to-eol in (list #\;)) ls)))
+                   (cond
+                    ((eqv? #\; (peek-char in))
+                     (lp ls))
+                    (else
+                     (highlight n
+                                '()
+                                (cons (highlight-class
+                                       "comment"
+                                       (string-concatenate-reverse ls))
+                                      (collect str res))))))))
+              ((#\")
+               (let ((s (read-escaped in #\" (list #\"))))
+                 (highlight n
+                            '()
+                            (cons (highlight-class "string" s)
+                                  (collect str res)))))
+              ((#\()
+               ;;(highlight-start
+               ;; (string->symbol
+               ;;  (string-append
+               ;;   "paren"
+               ;;   (number->string
+               ;;    (+ 1 (modulo n (length highlight-paren-styles))))))
+               ;;out)
+               (let ((res (collect (cons #\( str) res)))
+                 (if (highlight-scheme-delimiter? (peek-char in))
+                     (highlight (+ n 1) '() res)
+                     (let* ((id (read-identifier '()))
+                            (sym (string->symbol id)))
+                       (cond
+                        ((highlight-scheme-definition? sym)
+                         (let* ((res (cons (highlight-class "keyword" id) res))
+                                (res (cons (read-whitespace in) res))
+                                (res (if (eqv? #\( (peek-char in))
+                                         (cons (string (read-char in)) res)
+                                         res)))
+                           (highlight
+                            (+ n 1)
+                            '()
+                            (cons
+                             (highlight-class "function" (read-identifier '()))
+                             res))))
+                        ((highlight-scheme-syntax? sym)
+                         (highlight (+ n 1)
+                                    '()
+                                    (cons (highlight-class "keyword" id) res)))
+                        (else
+                         (highlight (+ n 1) '() (cons id res))))))))
+              ((#\))
+               (cond
+                ((zero? n)
+                 (highlight n
+                            '()
+                            (cons (highlight-class "syntaxerror" c)
+                                  (collect str res))))
+                (else
+                 ;;(highlight-end 'paren
+                 (highlight (- n 1) (cons c str) res))))
+              ((#\#)
+               (highlight n '() (cons (hash-mark) (collect str res))))
+              (else
+               (cond
+                ((highlight-scheme-delimiter? c)
+                 (highlight n (cons c str) res))
+                (else
+                 (let ((id (read-identifier (list c))))
+                   (highlight n '() (cons `(span ,id) (collect str res)))))))))))
+    (highlight 0 '() '())))
+
+(define (highlight-c-keyword? id)
+  (memq id '(asm break case catch const_cast continue default delete
+             do dynamic_cast else explicit export false for friend goto
+             if mutable namespace new operator private protected public
+             register reinterpret_cast return sizeof static_cast switch
+             template this throw true try typedef typeid typename using
+             virtual while)))
+
+(define (highlight-c-type? id)
+  (memq id '(auto bool char class const double enum extern float inline int long
+             short signed static struct union unsigned void volatile wchar_t
+             sexp sexp_uint_t sexp_sint_t)))
+
+;;> Highlighter for C source code.
+
+(define (highlight-c source)
+  (let ((in (if (string? source) (open-input-string source) source)))
+    (define (char-c-initial? c)
+      (and (char? c) (or (char-alphabetic? c) (eqv? c #\_) (eqv? c #\$))))
+    (define (char-c-identifier? c)
+      (and (char? c) (or (char-c-initial? c) (char-numeric? c))))
+    (define (read-identifier in ls)
+      (let ((c (peek-char in)))
+        (if (char-c-identifier? c)
+            (read-identifier in (cons (read-char in) ls))
+            (reverse-list->string ls))))
+    (define (highlight-identifier id)
+      (let ((sym (string->symbol id)))
+        (cond
+         ((highlight-c-keyword? sym)
+          (highlight-class "keyword" id))
+         ((highlight-c-type? sym)
+          (highlight-class "type" id))
+         (else
+          id))))
+    (define (highlight-line res)
+      (highlight
+       '()
+       (cond
+        ((eqv? #\# (peek-char in))
+         (read-char in)
+         (let* ((res (cons (read-whitespace in) (cons "#" res)))
+                (id (read-identifier in '()))
+                (res (cons (read-whitespace in)
+                           (cons (highlight-class "preprocessor" id) res))))
+           (case (string->symbol id)
+            ((define)
+             (cons (highlight-class "function" (read-to-whitespace in '())) res))
+            ((include import)
+             (cons (highlight-class "string" (read-to-whitespace in '())) res))
+            (else
+             res))))
+        ((char-c-initial? (peek-char in))
+         ;; line beginning w/ an identifier is probably a
+         ;; function declaration
+         (let ((id1 (read-identifier in '())))
+           (cond
+            ((eqv? #\: (peek-char in))
+             (cons (highlight-class "function" id1) res))
+            (else
+             (let lp ((decls '())
+                      (id id1))
+               (let ((space (read-whitespace in)))
+                 (cond
+                  ((char-c-initial? (peek-char in))
+                   (lp (cons space (cons id decls))
+                       (read-identifier in '())))
+                  ((eqv? #\( (peek-char in))
+                   `(,space
+                     ,(highlight-class "function" id)
+                     ,(highlight-class "type" (reverse decls))
+                     ,@res))
+                  (else
+                   `(,space ,id ,@decls ,@res)))))))))
+        (else
+         res))))
+    (define (highlight str res)
+      (let ((c (read-char in)))
+        (if (eof-object? c)
+            (reverse (collect str res))
+            (case c
+              ((#\/)
+               (case (peek-char in)
+                 ((#\/)
+                  (highlight
+                   '()
+                   (cons (highlight-class "comment" (read-to-eol in '(#\/ #\/)))
+                         (collect str res))))
+                 ((#\*)
+                  (let lp ((ls (cons (read-char in) '(#\/))))
+                    (let ((c (read-char in)))
+                      (if (not (and (eqv? (car ls) #\*) (eqv? c #\/)))
+                          (lp (cons c ls))
+                          (highlight
+                           '()
+                           (cons (highlight-class "comment"
+                                                  (reverse-list->string ls))
+                                 (collect str res)))))))
+                 (else
+                  (highlight (cons c str) res))))
+              ((#\" #\')
+               (let ((res (collect str res))
+                     (s (read-escaped in c (list c))))
+                 (highlight '() (cons (highlight-class "string" s) res))))
+              ((#\newline)
+               (highlight-line (collect (cons #\newline str) res)))
+              (else
+               (cond
+                ((char-c-initial? c)
+                 (highlight
+                  '()
+                  (cons
+                   (let ((id (read-identifier in (list c))))
+                     (if (eqv? #\: (peek-char in))
+                         (highlight-class "function" id)
+                         (highlight-identifier id)))
+                   (collect str res))))
+                (else
+                 (highlight (cons c str) res))))))))
+    (highlight-line '())))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> Highlighter for Assembly source code.
+
+(define (highlight-assembly source)
+  (let ((in (if (string? source) (open-input-string source) source)))
+    (define (char-asm-initial? c)
+      (and (char? c) (or (char-alphabetic? c) (memv c '(#\_ #\$ #\.)))))
+    (define (char-asm-identifier? c)
+      (and (char? c) (or (char-asm-initial? c) (char-numeric? c))))
+    (define (read-identifier in ls)
+      (let ((c (peek-char in)))
+        (if (char-asm-identifier? c)
+            (read-identifier (cons (read-char in) ls))
+            (reverse-list->string ls))))
+    (define (highlight str res)
+      (let ((c (read-char in)))
+        (cond
+         ((eof-object? c)
+          (reverse (collect str res)))
+         (else
+          (case c
+            ((#\newline)
+             (highlight-line (collect str res)))
+            ((#\")
+             (let ((s (read-escaped in c (list c))))
+               (highlight
+                '()
+                (cons (highlight-class "string" s) (collect str res)))))
+            ((#\%)
+             (highlight
+              '()
+              (cons (highlight-class "variable" (read-identifier in (list c)))
+                    (collect str res))))
+            ((#\;)
+             (highlight
+              '()
+              (cons (highlight-class "comment" (read-to-eol in (list c)))
+                    (collect str res))))
+            (else
+             (highlight (cons c str) res)))))))
+    (define (highlight-line res) 
+      (cond
+       ((eof-object? (peek-char in))
+        (highlight '() res))
+       ((char-asm-initial? (peek-char in))
+        (let ((id (read-identifier in '())))
+          (highlight
+           '()
+           (cons
+            (if (eqv? #\: (peek-char in))
+                (highlight-class "function" id)
+                (highlight-class "keyword" id))
+            res))))
+       ((eqv? #\tab (peek-char in))
+        (highlight
+         '()
+         (cons (highlight-class "keyword" (read-identifier in '()))
+               (cons "\t" res))))
+       (else
+        (highlight '() res))))
+    (highlight-line '())))

lib/chibi/highlight.sld

@@ -0,0 +1,6 @@
+
+(define-library (chibi highlight)
+  (export highlight highlight-detect-language highlighter-for highlight-style
+          highlight-scheme highlight-c highlight-assembly)
+  (import (scheme) (srfi 1) (chibi io))
+  (include "highlight.scm"))

lib/chibi/io.sld

@@ -0,0 +1,17 @@
+
+(define-library (chibi io)
+  (export read-string read-string! read-line write-line
+          port-fold port-fold-right port-map
+          port->list port->string-list port->sexp-list port->string
+          file-position set-file-position! seek/set seek/cur seek/end
+          make-custom-input-port make-custom-output-port
+          make-null-output-port make-null-input-port
+          make-broadcast-port make-concatenated-port
+          make-generated-input-port make-filtered-output-port
+          make-filtered-input-port string-count
+          open-input-bytevector open-output-bytevector get-output-bytevector
+          string->utf8 utf8->string
+          write-u8 read-u8 peek-u8)
+  (import (scheme) (chibi ast))
+  (include-shared "io/io")
+  (include "io/io.scm"))

lib/chibi/io/io.scm

@@ -0,0 +1,269 @@
+;; io.scm -- various input/output utilities
+;; Copyright (c) 2010-2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utilities
+
+(define eof
+  (call-with-input-string " "
+    (lambda (in) (read-char in) (read-char in))))
+
+(define (string-copy! dst start src from to)
+  (do ((i from (+ i 1)) (j start (+ j 1)))
+      ((>= i to))
+    (string-set! dst j (string-ref src i))))
+
+(define (utf8->string vec)
+  (string-copy (utf8->string! vec)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; reading and writing
+
+;; Display @var{str} to the given output port, defaulting to
+;; @scheme{(current-output-port)}, followed by a newline.
+
+(define (write-line str . o)
+  (let ((out (if (pair? o) (car o) (current-output-port))))
+    (display str out)
+    (newline out)))
+
+;;> @subsubsubsection{(write-string str n [out])}
+
+;;> Writes the first @var{n} bytes of @var{str} to output port
+;;> @var{out}.
+
+(cond-expand
+ ((not string-streams)
+  (define (write-string str n . o)
+    (let ((out (if (pair? o) (car o) (current-output-port))))
+      (display (substring str 0 n) out)))))
+
+;;> @subsubsubsection{(read-line [in [n]])}
+
+;;> Read a line from the input port @var{in}, defaulting to
+;;> @scheme{(current-input-port)}, and return the result as
+;;> a string not including the newline.  Reads at most @var{n}
+;;> characters, defaulting to 8192.
+
+(cond-expand
+ ((not string-streams)
+  (define (%read-line n in)
+    (let ((out (open-output-string)))
+      (let lp ()
+        (let ((ch (read-char in)))
+          (cond
+           ((eof-object? ch)
+            (get-output-string out))
+           (else
+            (write-char ch out)
+            (if (eqv? ch #\newline)
+                (get-output-string out)
+                (lp))))))))))
+
+(define (read-line . o)
+  (let ((in (if (pair? o) (car o) (current-input-port)))
+        (n (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) 8192)))
+    (let ((res (%read-line n in)))
+      (port-line-set! in (+ 1 (port-line in)))
+      (if (not res)
+          eof
+          (let ((len (string-length res)))
+            (if (and (> len 0) (eqv? #\newline (string-ref res (- len 1))))
+                (if (and (> len 1) (eqv? #\return (string-ref res (- len 2))))
+                    (substring res 0 (- len 2))
+                    (substring res 0 (- len 1)))
+                res))))))
+
+;;> @subsubsubsection{(read-string n [in])}
+
+;;> Reads @var{n} characters from input-port @var{in},
+;;> defaulting to @scheme{(current-input-port)}, and
+;;> returns the result as a string.  Returns @scheme{""}
+;;> if @var{n} is zero.  May return a string with fewer
+;;> than @var{n} characters if the end of file is reached,
+;;> or the eof-object if no characters are available.
+
+(cond-expand
+ ((not string-streams)
+  (define (%read-string n in)
+    (let ((out (open-output-string)))
+      (do ((i 0 (+ i 1))
+           (ch (read-char in) (read-char in)))
+          ((or (= i n) (eof-object? ch)) (list i (get-output-string out)))
+        (write-char ch out))))))
+
+(define (read-string n . o)
+  (if (zero? n)
+      ""
+      (let ((in (if (pair? o) (car o) (current-input-port))))
+        (let ((res (%read-string n in)))
+          (cond
+           ((if (pair? res) (= 0 (car res)) #t)
+            eof)
+           (else
+            (port-line-set! in (+ (string-count #\newline (cadr res) 0)
+                                  (port-line in)))
+            (cadr res)))))))
+
+;;> @subsubsubsection{(read-string! str n [in])}
+
+;;> Reads @var{n} characters from port @var{in}, which
+;;> defaults to @scheme{(current-input-port)}, and writes
+;;> them into the string @var{str} starting at index 0.
+;;> Returns the number of characters read.
+;;> An error is signalled if the length of @var{str} is smaller
+;;> than @var{n}.
+
+(cond-expand
+ ((not string-streams)
+  (define (%read-string! str n in)
+    (do ((i 0 (+ i 1))
+         (ch (read-char in) (read-char in)))
+        ((or (= i n) (eof-object? ch)) i)
+      (string-set! str i ch)))))
+
+(define (read-string! str n . o)
+  (if (>= n (string-length str))
+      (error "string to small to read chars" str n))
+  (let* ((in (if (pair? o) (car o) (current-input-port)))
+         (res (%read-string! str n in)))
+    (port-line-set! in (+ (string-count #\newline str 0 n) (port-line in)))
+    res))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; higher order port operations
+
+;;> The fundamental port iterator.
+
+(define (port-fold kons knil . o)
+  (let ((read (if (pair? o) (car o) read))
+        (in (if (and (pair? o) (pair? (cdr o)))
+                (car (cdr o))
+                (current-input-port))))
+    (let lp ((acc knil))
+      (let ((x (read in)))
+        (if (eof-object? x) acc (lp (kons x acc)))))))
+
+(define (port-fold-right kons knil . o)
+  (let ((read (if (pair? o) (car o) read))
+        (in (if (and (pair? o) (pair? (cdr o)))
+                (car (cdr o))
+                (current-input-port))))
+    (let lp ()
+      (let ((x (read in)))
+        (if (eof-object? x) knil (kons x (lp)))))))
+
+(define (port-map fn . o)
+  (reverse (apply port-fold (lambda (x ls) (cons (fn x) ls)) '() o)))
+
+(define (port->list read in)
+  (port-map (lambda (x) x) read in))
+
+(define (port->sexp-list in)
+  (port->list read in))
+
+(define (port->string-list in)
+  (port->list read-line in))
+
+(define (port->string in)
+  (string-concatenate (port->list (lambda (in) (read-string 1024 in)) in)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; custom port utilities
+
+(define (make-custom-input-port read . o)
+  (let ((seek (and (pair? o) (car o)))
+        (close (and (pair? o) (pair? (cdr o)) (car (cdr o)))))
+    (%make-custom-input-port read seek close)))
+
+(define (make-custom-output-port write . o)
+  (let ((seek (and (pair? o) (car o)))
+        (close (and (pair? o) (pair? (cdr o)) (car (cdr o)))))
+    (%make-custom-output-port write seek close)))
+
+(define (make-null-output-port)
+  (make-custom-output-port (lambda (str start end) 0)))
+
+(define (make-broadcast-port . ports)
+  (make-custom-output-port
+   (lambda (str start end)
+     (let ((str (if (zero? start) str (substring str start)))
+           (n (- end start)))
+       (for-each (lambda (p) (write-string str n p)) ports)
+       n))))
+
+(define (make-filtered-output-port filter out)
+  (make-custom-output-port
+   (lambda (str start end)
+     (let* ((len (string-length str))
+            (s1 (if (and (zero? start) (= end len)) str (substring str start end)))
+            (s2 (filter s1)))
+       (if (string? s2)
+           (write-string s2 (string-length s2) out))))))
+
+(define (make-concatenated-port . ports)
+  (make-custom-input-port
+   (lambda (str start end)
+     (if (null? ports)
+         0
+         (let ((str (if (zero? start) str (substring str start)))
+               (n (- end start)))
+           (let lp ((i (read-string! str n (car ports))))
+             (cond
+              ((>= i n)
+               i)
+              (else
+               (set! ports (cdr ports))
+               (cond
+                ((null? ports)
+                 i)
+                (else
+                 (let* ((s (read-string (- n i) (car ports)))
+                        (len (if (string? s) (string-length s) 0)))
+                   (if (and (string? str) (> len 0))
+                       (string-copy! str i s 0 len))
+                   (lp (+ i len)))))))))))))
+
+(define (make-null-input-port)
+  (make-concatenated-port))
+
+(define (make-generated-input-port generator)
+  (let ((buf "")
+        (len 0)
+        (offset 0))
+    (make-custom-input-port
+     (lambda (str start end)
+       (let ((n (- end start)))
+         (cond
+          ((>= (- len offset) n)
+           (string-copy! str start buf offset (+ offset n))
+           (set! offset (+ offset n))
+           n)
+          (else
+           (string-copy! str start buf offset len)
+           (let lp ((i (+ start (- len offset))))
+             (set! buf (generator))
+             (cond
+              ((not (string? buf))
+               (set! buf "")
+               (set! len 0)
+               (set! offset 0)
+               (- i start))
+              (else
+               (set! len (string-length buf))
+               (set! offset 0)
+               (cond
+                ((>= (- len offset) (- n i))
+                 (string-copy! str i buf offset (+ offset (- n i)))
+                 (set! offset (+ offset (- n i)))
+                 n)
+                (else
+                 (string-copy! str i buf offset len)
+                 (lp (+ i (- len offset)))))))))))))))
+
+(define (make-filtered-input-port filter in)
+  (make-generated-input-port
+   (lambda ()
+     (let ((res (read-string 1024 in)))
+       (if (string? res) (filter res) res)))))

lib/chibi/io/io.stub

@@ -0,0 +1,48 @@
+
+(cond-expand
+ (string-streams
+  (define-c non-null-string (%read-line "fgets")
+    ((result (array char arg1)) int (default (current-input-port) input-port)))
+
+  (define-c size_t (%read-string "fread")
+    ((result (array char (result arg2))) (value 1 size_t) size_t (default (current-input-port) input-port)))
+
+  (define-c size_t (%read-string! "fread")
+    (string (value 1 size_t) size_t (default (current-input-port) input-port)))
+  ))
+
+(define-c-const int (seek/set "SEEK_SET"))
+(define-c-const int (seek/cur "SEEK_CUR"))
+(define-c-const int (seek/end "SEEK_END"))
+
+(define-c long (file-position "ftell") (port))
+(define-c long (set-file-position! "fseek") (port long int))
+
+(c-include "port.c")
+
+(define-c sexp (%make-custom-input-port "sexp_make_custom_input_port")
+  ((value ctx sexp) (value self sexp) sexp sexp sexp))
+
+(define-c sexp (%make-custom-output-port "sexp_make_custom_output_port")
+  ((value ctx sexp) (value self sexp) sexp sexp sexp))
+
+(define-c sexp (open-input-bytevector "sexp_open_input_bytevector")
+  ((value ctx sexp) (value self sexp) sexp))
+(define-c sexp (open-output-bytevector "sexp_open_output_bytevector")
+  ((value ctx sexp) (value self sexp)))
+(define-c sexp (get-output-bytevector "sexp_get_output_bytevector")
+  ((value ctx sexp) (value self sexp) sexp))
+
+(define-c sexp (string-count "sexp_string_count")
+  ((value ctx sexp) (value self sexp) sexp sexp sexp (default NULL sexp)))
+(define-c sexp (string->utf8 "sexp_string_to_utf8")
+  ((value ctx sexp) (value self sexp) sexp))
+(define-c sexp (utf8->string! "sexp_utf8_to_string_x")
+  ((value ctx sexp) (value self sexp) sexp))
+
+(define-c sexp (write-u8 "sexp_write_u8")
+  ((value ctx sexp) (value self sexp) sexp (default (current-output-port) sexp)))
+(define-c sexp (read-u8 "sexp_read_u8")
+  ((value ctx sexp) (value self sexp) (default (current-input-port) sexp)))
+(define-c sexp (peek-u8 "sexp_peek_u8")
+  ((value ctx sexp) (value self sexp) (default (current-input-port) sexp)))

lib/chibi/io/port.c

@@ -0,0 +1,358 @@
+
+#include <stdio.h>
+#include <chibi/eval.h>
+
+#define SEXP_LAST_CONTEXT_CHECK_LIMIT 256
+
+#define sexp_cookie_ctx(vec) sexp_vector_ref((sexp)vec, SEXP_ZERO)
+#define sexp_cookie_buffer(vec) sexp_vector_ref((sexp)vec, SEXP_ONE)
+#define sexp_cookie_read(vec) sexp_vector_ref((sexp)vec, SEXP_TWO)
+#define sexp_cookie_write(vec) sexp_vector_ref((sexp)vec, SEXP_THREE)
+#define sexp_cookie_seek(vec) sexp_vector_ref((sexp)vec, SEXP_FOUR)
+#define sexp_cookie_close(vec) sexp_vector_ref((sexp)vec, SEXP_FIVE)
+
+#define sexp_cookie_ctx_set(vec, x) sexp_vector_set((sexp)vec, SEXP_ZERO, x)
+#define sexp_cookie_buffer_set(vec, x) sexp_vector_set((sexp)vec, SEXP_ONE, x)
+#define sexp_cookie_read_set(vec, x) sexp_vector_set((sexp)vec, SEXP_TWO, x)
+#define sexp_cookie_write_set(vec, x) sexp_vector_set((sexp)vec, SEXP_THREE, x)
+#define sexp_cookie_seek_set(vec, x) sexp_vector_set((sexp)vec, SEXP_FOUR, x)
+#define sexp_cookie_close_set(vec, x) sexp_vector_set((sexp)vec, SEXP_FIVE, x)
+
+#if SEXP_USE_STRING_STREAMS
+#if ! SEXP_USE_BOEHM
+static int in_heap_p (sexp_heap h, sexp p) {
+  for ( ; h; h = h->next)
+    if (((sexp)h < p) && (p < (sexp)((char*)h + h->size)))
+      return 1;
+  return 0;
+}
+#endif
+
+static sexp sexp_last_context (sexp ctx, sexp *cstack) {
+  sexp res=SEXP_FALSE;
+#if ! SEXP_USE_BOEHM
+  sexp p;
+  sexp_sint_t i;
+  sexp_heap h = sexp_context_heap(ctx);
+  for (i=0; i<SEXP_LAST_CONTEXT_CHECK_LIMIT; i++) {
+    p = cstack[i];
+    if (p && (p != ctx) && sexp_pointerp(p) && in_heap_p(h, p)
+        && (sexp_pointer_tag(p) == SEXP_CONTEXT)
+        && (sexp_context_heap(p) == h)) {
+      res = p;
+      break;
+    }
+  }
+#endif
+  return res;
+}
+
+#if SEXP_BSD
+static int sexp_cookie_reader (void *cookie, char *buffer, int size)
+#else
+static ssize_t sexp_cookie_reader (void *cookie, char *buffer, size_t size)
+#endif
+{
+  sexp vec = (sexp)cookie, ctx, res;
+  if (! sexp_procedurep(sexp_cookie_read(vec))) return -1;
+  sexp_gc_var2(ctx2, args);
+  ctx = sexp_cookie_ctx(vec);
+  ctx2 = sexp_last_context(ctx, (sexp*)&cookie);
+  sexp_gc_preserve2(ctx, ctx2, args);
+  if (size > sexp_string_length(sexp_cookie_buffer(vec)))
+    sexp_cookie_buffer_set(vec, sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID));
+  args = sexp_list2(ctx, SEXP_ZERO, sexp_make_fixnum(size));
+  args = sexp_cons(ctx, sexp_cookie_buffer(vec), args);
+  res = sexp_apply(ctx, sexp_cookie_read(vec), args);
+  sexp_gc_release2(ctx);
+  if (sexp_fixnump(res)) {
+    memcpy(buffer, sexp_string_data(sexp_cookie_buffer(vec)), sexp_unbox_fixnum(res));
+    return sexp_unbox_fixnum(res);
+  } else {
+    return -1;
+  }
+}
+
+#if SEXP_BSD
+static int sexp_cookie_writer (void *cookie, const char *buffer, int size)
+#else
+static ssize_t sexp_cookie_writer (void *cookie, const char *buffer, size_t size)
+#endif
+{
+  sexp vec = (sexp)cookie, ctx, res;
+  if (! sexp_procedurep(sexp_cookie_write(vec))) return -1;
+  sexp_gc_var2(ctx2, args);
+  ctx = sexp_cookie_ctx(vec);
+  ctx2 = sexp_last_context(ctx, (sexp*)&cookie);
+  sexp_gc_preserve2(ctx, ctx2, args);
+  if (size > sexp_string_length(sexp_cookie_buffer(vec)))
+    sexp_cookie_buffer_set(vec, sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID));
+  memcpy(sexp_string_data(sexp_cookie_buffer(vec)), buffer, size);
+  args = sexp_list2(ctx, SEXP_ZERO, sexp_make_fixnum(size));
+  args = sexp_cons(ctx, sexp_cookie_buffer(vec), args);
+  res = sexp_apply(ctx, sexp_cookie_write(vec), args);
+  sexp_gc_release2(ctx);
+  return (sexp_fixnump(res) ? sexp_unbox_fixnum(res) : -1);
+}
+
+#if ! SEXP_BSD
+
+#ifdef __CYGWIN__
+#define off64_t off_t
+#endif
+
+static int sexp_cookie_seeker (void *cookie, off64_t *position, int whence) {
+  sexp vec = (sexp)cookie, ctx, res;
+  if (! sexp_procedurep(sexp_cookie_seek(vec))) return -1;
+  sexp_gc_var2(ctx2, args);
+  ctx = sexp_cookie_ctx(vec);
+  ctx2 = sexp_last_context(ctx, (sexp*)&cookie);
+  sexp_gc_preserve2(ctx, ctx2, args);
+  args = sexp_make_integer(ctx, *position);
+  args = sexp_list2(ctx, args, sexp_make_fixnum(whence));
+  res = sexp_apply(ctx, sexp_cookie_seek(vec), args);
+  if (sexp_fixnump(res))
+    *position = sexp_unbox_fixnum(res);
+  sexp_gc_release2(ctx);
+  return sexp_fixnump(res);
+}
+#endif  /* !SEXP_BSD */
+
+static int sexp_cookie_cleaner (void *cookie) {
+  sexp vec = (sexp)cookie, ctx, res;
+  if (! sexp_procedurep(sexp_cookie_close(vec))) return 0;
+  ctx = sexp_cookie_ctx(vec);
+  res = sexp_apply(ctx, sexp_cookie_close(vec), SEXP_NULL);
+  return (sexp_exceptionp(res) ? -1 : sexp_truep(res));
+}
+
+#if !SEXP_BSD
+
+static cookie_io_functions_t sexp_cookie = {
+  .read  = (cookie_read_function_t*)sexp_cookie_reader,
+  .write = (cookie_write_function_t*)sexp_cookie_writer,
+  .seek  = (cookie_seek_function_t*)sexp_cookie_seeker,
+  .close = (cookie_close_function_t*)sexp_cookie_cleaner,
+};
+
+static cookie_io_functions_t sexp_cookie_no_seek = {
+  .read  = (cookie_read_function_t*)sexp_cookie_reader,
+  .write = (cookie_write_function_t*)sexp_cookie_writer,
+  .seek  = NULL,
+  .close = (cookie_close_function_t*)sexp_cookie_cleaner,
+};
+
+#endif  /* !SEXP_BSD */
+
+static sexp sexp_make_custom_port (sexp ctx, sexp self, char *mode,
+                                   sexp read, sexp write,
+                                   sexp seek, sexp close) {
+  FILE *in;
+  sexp res;
+  sexp_gc_var1(vec);
+  if (sexp_truep(read) && ! sexp_procedurep(read))
+    return sexp_type_exception(ctx, self, SEXP_PROCEDURE, read);
+  if (sexp_truep(write) && ! sexp_procedurep(write))
+    return sexp_type_exception(ctx, self, SEXP_PROCEDURE, write);
+  if (sexp_truep(seek) && ! sexp_procedurep(seek))
+    return sexp_type_exception(ctx, self, SEXP_PROCEDURE, seek);
+  if (sexp_truep(close) && ! sexp_procedurep(close))
+    return sexp_type_exception(ctx, self, SEXP_PROCEDURE, close);
+  sexp_gc_preserve1(ctx, vec);
+  vec = sexp_make_vector(ctx, SEXP_SIX, SEXP_VOID);
+  sexp_cookie_ctx_set(vec, ctx);
+  sexp_cookie_buffer_set(vec, sexp_make_string(ctx, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE), SEXP_VOID));
+  sexp_cookie_read_set(vec, read);
+  sexp_cookie_write_set(vec, write);
+  sexp_cookie_seek_set(vec, seek);
+  sexp_cookie_close_set(vec, close);
+#if SEXP_BSD
+  in = funopen(vec,
+               (sexp_procedurep(read) ? sexp_cookie_reader : NULL),
+               (sexp_procedurep(write) ? sexp_cookie_writer : NULL),
+               NULL, /* (sexp_procedurep(seek) ? sexp_cookie_reader : NULL), */
+               (sexp_procedurep(close) ? sexp_cookie_cleaner : NULL));
+#else
+  in = fopencookie(vec, mode, (sexp_truep(seek) ? sexp_cookie : sexp_cookie_no_seek));
+#endif
+  if (! in) {
+    res = sexp_user_exception(ctx, self, "couldn't make custom port", read);
+  } else {
+    res = sexp_make_input_port(ctx, in, SEXP_FALSE);
+    sexp_port_cookie(res) = vec;  /* for gc preserving */
+  }
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+#else  /* ! SEXP_USE_STRING_STREAMS */
+
+static sexp sexp_make_custom_port (sexp ctx, sexp self,
+                                   char *mode, sexp read, sexp write,
+                                   sexp seek, sexp close) {
+  sexp vec;
+  sexp_gc_var2(res, str);
+  sexp_gc_preserve2(ctx, res, str);
+  str = sexp_make_string(ctx, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE), SEXP_VOID);
+  if (sexp_exceptionp(str)) return str;
+  res = sexp_make_input_string_port(ctx, str);
+  if (sexp_exceptionp(res)) return res;
+  if (mode && mode[0] == 'w') {
+    sexp_pointer_tag(res) = SEXP_OPORT;
+    sexp_port_cookie(res) = str;
+  } else {
+    sexp_port_offset(res) = 0;
+    sexp_port_size(res) = 0;
+  }
+  vec = sexp_make_vector(ctx, SEXP_SIX, SEXP_VOID);
+  if (sexp_exceptionp(vec)) return vec;
+  sexp_vector_set(vec, SEXP_ZERO, SEXP_FALSE);
+  sexp_vector_set(vec, SEXP_ONE, sexp_port_cookie(res));
+  sexp_vector_set(vec, SEXP_TWO, read);
+  sexp_vector_set(vec, SEXP_THREE, write);
+  sexp_vector_set(vec, SEXP_FOUR, seek);
+  sexp_vector_set(vec, SEXP_FIVE, close);
+  sexp_port_cookie(res) = vec;
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+#endif
+
+sexp sexp_make_custom_input_port (sexp ctx, sexp self,
+                                  sexp read, sexp seek, sexp close) {
+  return sexp_make_custom_port(ctx, self, "r", read, SEXP_FALSE, seek, close);
+}
+
+sexp sexp_make_custom_output_port (sexp ctx, sexp self,
+                                   sexp write, sexp seek, sexp close) {
+  sexp res = sexp_make_custom_port(ctx, self, "w", SEXP_FALSE, write, seek, close);
+#if SEXP_USE_STRING_STREAMS
+  if (!sexp_exceptionp(res))
+    sexp_pointer_tag(res) = SEXP_OPORT;
+#endif
+  return res;
+}
+
+sexp sexp_bytes_to_string (sexp ctx, sexp vec) {
+  sexp res;
+#if SEXP_USE_PACKED_STRINGS
+  res = sexp_c_string(ctx, sexp_bytes_data(vec), sexp_bytes_length(vec));
+#else
+  res = sexp_alloc_type(ctx, string, SEXP_STRING);
+  sexp_string_bytes(res) = vec;
+  sexp_string_offset(res) = 0;
+  sexp_string_length(res) = sexp_bytes_length(vec);
+#endif
+  return res;
+}
+
+sexp sexp_open_input_bytevector (sexp ctx, sexp self, sexp vec) {
+  sexp_gc_var2(str, res);
+  sexp_assert_type(ctx, sexp_bytesp, SEXP_BYTES, vec);
+  sexp_gc_preserve2(ctx, str, res);
+  str = sexp_bytes_to_string(ctx, vec);
+  res = sexp_make_input_string_port(ctx, str);
+  sexp_port_binaryp(res) = 1;
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+sexp sexp_open_output_bytevector (sexp ctx, sexp self) {
+  sexp res = sexp_make_output_string_port(ctx);
+  sexp_port_binaryp(res) = 1;
+  return res;
+}
+
+sexp sexp_get_output_bytevector (sexp ctx, sexp self, sexp port) {
+  sexp_gc_var1(res);
+  sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, port);
+  if (!sexp_port_binaryp(port))
+    return sexp_xtype_exception(ctx, self, "not a binary port", port);
+  sexp_gc_preserve1(ctx, res);
+  res = sexp_get_output_string(ctx, port);
+  res = sexp_string_to_bytes(ctx, res);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_string_count (sexp ctx, sexp self, sexp ch, sexp str, sexp start, sexp end) {
+  const unsigned char *s, *e;
+  sexp_sint_t c, count = 0;
+#if SEXP_USE_UTF8_STRINGS
+  sexp_sint_t i;
+#endif
+  sexp_assert_type(ctx, sexp_charp, SEXP_CHAR, ch);
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, start);
+  if (sexp_not(end)) end = sexp_make_fixnum(sexp_string_length(str));
+  else sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, end);
+  c = sexp_unbox_character(ch);
+#if SEXP_USE_UTF8_STRINGS
+  if (c < 128) {
+#endif
+    s = (unsigned char*)sexp_string_data(str) + sexp_unbox_fixnum(start);
+    e = (unsigned char*)sexp_string_data(str) + sexp_unbox_fixnum(end);
+    if (e > (unsigned char*)sexp_string_data(str) + sexp_string_length(str))
+      return sexp_user_exception(ctx, self, "string-count: end index out of range", end);
+    /* fast case for ASCII chars */
+    while (s < e) if (*s++ == c) count++;
+#if SEXP_USE_UTF8_STRINGS
+  } else {
+    /* decode utf8 chars */
+    s = (unsigned char*)sexp_string_data(str);
+    for (i = sexp_unbox_fixnum(start); i < sexp_unbox_fixnum(end);
+         i += sexp_utf8_initial_byte_count(s[i]))
+      if (sexp_string_utf8_ref(ctx, str, sexp_make_fixnum(i)) == ch) count++;
+  }
+#endif
+  return sexp_make_fixnum(count);
+}
+
+sexp sexp_string_to_utf8 (sexp ctx, sexp self, sexp str) {
+  sexp res;
+  sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
+  res = sexp_c_string(ctx, sexp_string_data(str), sexp_string_length(str));
+  return sexp_string_to_bytes(ctx, res);
+}
+
+/* TODO: add validation */
+sexp sexp_utf8_to_string_x (sexp ctx, sexp self, sexp vec) {
+  sexp_assert_type(ctx, sexp_bytesp, SEXP_BYTES, vec);
+  return sexp_bytes_to_string(ctx, vec);
+}
+
+sexp sexp_write_u8 (sexp ctx, sexp self, sexp u8, sexp out) {
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, u8);
+  if (sexp_unbox_fixnum(u8) < 0 || sexp_unbox_fixnum(u8) > 255)
+    return sexp_xtype_exception(ctx, self, "not a u8 value", u8);
+  sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out);
+  if (!sexp_port_binaryp(out))
+    return sexp_xtype_exception(ctx, self, "not a binary port", out);
+  if (sexp_write_char(ctx, sexp_unbox_fixnum(u8), out) == EOF)
+    return sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR);
+  return SEXP_VOID;
+}
+
+sexp sexp_read_u8 (sexp ctx, sexp self, sexp in) {
+  int c;
+  sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in);
+  if (!sexp_port_binaryp(in))
+    return sexp_xtype_exception(ctx, self, "not a binary port", in);
+  sexp_check_block_port(ctx, in, 0);
+  c = sexp_read_char(ctx, in);
+  return c == EOF ? SEXP_EOF : sexp_make_fixnum(c);
+}
+
+sexp sexp_peek_u8 (sexp ctx, sexp self, sexp in) {
+  int c;
+  sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in);
+  if (!sexp_port_binaryp(in))
+    return sexp_xtype_exception(ctx, self, "not a binary port", in);
+  sexp_check_block_port(ctx, in, 0);
+  c = sexp_read_char(ctx, in);
+  if (c == EOF)
+    return SEXP_EOF;
+  sexp_push_char(ctx, c, in);
+  return sexp_make_fixnum(c);
+}

lib/chibi/loop.sld

@@ -0,0 +1,9 @@
+
+(define-library (chibi loop)
+  (export loop in-list in-lists in-port in-file up-from down-from
+          listing listing-reverse appending appending-reverse
+          summing multiplying in-string in-string-reverse
+          in-vector in-vector-reverse)
+  (import (scheme))
+  (include "loop/loop.scm"))
+

lib/chibi/loop/loop.scm

@@ -0,0 +1,417 @@
+;;;; loop.scm - the chibi loop (aka foof-loop)
+;;
+;; Copyright (c) 2009-2011 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> The loop API is mostly compatible with Taylor Campbell's
+;;> @hyperlink["http://mumble.net/~campbell/scheme/foof-loop.txt"]{foof-loop},
+;;> but the iterator API is different and subject to change.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (assoc-pred equal elt ls)
+  (and (pair? ls)
+       (if (equal elt (car (car ls)))
+           (car ls)
+           (assoc-pred equal elt (cdr ls)))))
+
+(define-syntax let-keyword-form
+  (syntax-rules ()
+    ((let-keyword-form
+      ((labeled-arg-macro-name (positional-name . params)))
+      . body)
+     (let-syntax
+         ((labeled-arg-macro-name
+           (er-macro-transformer
+            (lambda (expr rename compare)
+              (let lp ((ls (cdr expr)) (named '()) (posns '()))
+                (cond
+                 ((pair? ls)
+                  (if (and (list? (car ls)) (compare (caar ls) (rename '=>)))
+                      (lp (cdr ls) (cons (cdar ls) named) posns)
+                      (lp (cdr ls) named (cons (car ls) posns))))
+                 (else
+                  (let lp ((ls (syntax-quote params))
+                           (posns (reverse posns))
+                           (args '()))
+                    (cond
+                     ((null? ls)
+                      (if (pair? posns)
+                          (error "let-keyword-form: too many args" expr)
+                          (cons (syntax-quote positional-name) (reverse args))))
+                     ((assoc-pred compare (caar ls) named)
+                      => (lambda (x) (lp (cdr ls) posns (cons (cadr x) args))))
+                     ((pair? posns)
+                      (lp (cdr ls) (cdr posns) (cons (car posns) args)))
+                     (else
+                      (lp (cdr ls) posns (cons (cadar ls) args))))))))))))
+       . body))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> @subsubsubsection{@scheme{(loop [name] (vars ...) [=> result] body ...)}}
+
+(define-syntax loop
+  (syntax-rules ()
+    ;; unnamed, implicit recursion
+    ((loop (vars ...) body ...)
+     (%loop tmp-loop () () () () () (vars ...) body ... (tmp-loop)))
+    ;; named, explicit recursion
+    ((loop name (vars ...) body ...)
+     (%loop name () () () () () (vars ...) body ...))))
+
+;; Main LOOP macro. Separate the variables from the iterator and
+;; parameters, then walk through each parameter expanding the
+;; bindings, and build the final form.
+
+(define-syntax %loop
+  (syntax-rules (=> for with let while until)
+    ;; automatic iteration
+    ((_ name l v c r f ((for var1 (iterator source ...)) rest ...) . body)
+     (iterator ((var1) (source ...)) %loop-next name l v c r f (rest ...) . body))
+    ((_ name l v c r f ((for var1 var2 (iterator source ...)) rest ...) . body)
+     (iterator ((var1 var2) (source ...)) %loop-next name l v c r f (rest ...) . body))
+    ((_ name l v c r f ((for var1 var2 var3 (iterator source ...)) rest ...) . body)
+     (iterator ((var1 var2 var3) (source ...)) %loop-next name l v c r f (rest ...) . body))
+    ((_ name l v c r f ((for var1 var2 var3 var4 (iterator source ...)) rest ...) . body)
+     (iterator ((var1 var2 var3 var4) (source ...)) %loop-next name l v c r f (rest ...) . body))
+    ;; do equivalents, with optional guards
+    ((_ name l (vars ...) (checks ...) r f ((with var init step guard) rest ...) . body)
+     (%loop name l (vars ... (var init step)) (checks ... (guard var)) r f (rest ...) . body))
+    ((_ name l (vars ...) c r f ((with var init step) rest ...) . body)
+     (%loop name l (vars ... (var init step)) c r f (rest ...) . body))
+    ((_ name l (vars ...) c r f ((with var init) rest ...) . body)
+     (%loop name l (vars ... (var init var)) c r f (rest ...) . body))
+    ;; user-specified terminators
+    ((_ name l vars (checks ...) r f ((until expr) rest ...) . body)
+     (%loop name l vars (checks ... expr) r f (rest ...) . body))
+    ((_ name l vars (checks ...) r f ((while expr) rest ...) . body)
+     (%loop name l vars (checks ... (not expr)) r f (rest ...) . body))
+    ;; specify a default done?
+    ((_ name l v c r f ())
+     (%loop name l v c r f () (#f #f)))
+    ((_ name l v c r f () () . body)
+     (%loop name l v c r f () (#f #f) . body))
+    ;; final expansion
+    ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
+        => result
+        . body)
+     (let* (lets ...)
+       (letrec ((tmp (lambda (var ...)
+                       (if (or checks ...)
+                           (let-keyword-form ((name (tmp (var step) ...)))
+                             (let (finals ...) result))
+                           (let (refs ...)
+                             (let-keyword-form ((name (tmp (var step) ...)))
+                               (if #f #f)
+                               . body))))))
+         (tmp init ...))))
+    ;; unspecified return value case
+    ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
+        . body)
+     (%loop name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
+            => (if #f #f) . body))
+    ))
+
+(define-syntax %loop-next
+  (syntax-rules ()
+    ((_ (new-lets ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...)
+        name (lets ...) (vars ...) (checks ...) (refs ...) (finals ...)
+        . rest)
+     (%loop name (lets ... new-lets ...) (vars ... new-vars ...)
+                 (checks ... new-checks ...) (refs ... new-refs ...)
+                 (finals ... new-finals ...)
+        . rest))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;> @subsubsection{Iterators}
+
+;; Each gets passed two lists, those items left of the macro and those to
+;; the right, followed by a NEXT and REST continuation.
+;;
+;; Should finish with
+;;
+;; @schemeblock{
+;;  (next (outer-vars ...) (cursor-vars ...) (done?-tests ...)
+;;        (loop-vars ...) (final-vars ...) . rest)
+;; }
+;;
+;; @itemlist[
+;; @item{@var{outer-vars} - bound once outside the loop in a LET*}
+;; @item{@var{cursor-vars} - DO-style bindings of the form (name init update)}
+;; @item{@var{done?-tests} - possibly empty list of forms that terminate the loop on #t}
+;; @item{@var{loop-vars} - inner variables, updated in parallel after the cursors}
+;; @item{@var{final-vars} - final variables, bound only in the => result}
+;; ]
+
+;;> @subsubsubsection{@scheme{(for var [pair] (in-list ls [cdr]))}}
+
+;;> Basic list iterator.
+
+(define-syntax in-list                  ; called just "IN" in ITER
+  (syntax-rules ()
+    ((in-list ((var) source) next . rest)
+     (in-list ((var cursor) source) next . rest))
+    ((in-list ((var cursor) source) next . rest)
+     (in-list ((var cursor succ) source) next . rest))
+    ((in-list ((var cursor succ) (source)) next . rest)
+     (next ()                         ; outer let bindings
+           ((cursor source succ))     ; iterator, init, step
+           ((not (pair? cursor)))     ; finish tests for iterator vars
+           ;; step variables and values
+           ((var (car cursor))
+            (succ (cdr cursor)))
+           ()                           ; final result bindings
+           . rest))
+    ((in-list ((var cursor succ) (source step)) next . rest)
+     (next ()
+           ((cursor source succ))
+           ((not (pair? cursor)))
+           ((var (car cursor))
+            (succ (step cursor)))
+           ()
+           . rest))))
+
+;;> @subsubsubsection{@scheme{(for elts [pairs] (in-lists lol [cdr [done?]]))}}
+
+;;> Iterator from Taylor R. Campbell.  If you know the number of lists
+;;> ahead of time it's much more efficient to iterate over each one
+;;> separately.
+
+(define-syntax in-lists
+  (syntax-rules ()
+    ((in-lists ((elts) lol) next . rest)
+     (in-lists ((elts pairs) lol) next . rest))
+    ((in-lists ((elts pairs) lol) next . rest)
+     (in-lists ((elts pairs succ) lol) next . rest))
+    ((in-lists ((elts pairs succ) (lol)) next . rest)
+     (in-lists ((elts pairs succ) (lol cdr)) next . rest))
+    ((in-lists ((elts pairs succ) (lol)) next . rest)
+     (in-lists ((elts pairs succ) (lol cdr)) next . rest))
+    ((in-lists ((elts pairs succ) (lol step)) next . rest)
+     (in-lists ((elts pairs succ) (lol step null?)) next . rest))
+    ((in-lists ((elts pairs succ) (lol step done?)) next . rest)
+     (next ()
+           ((pairs lol succ))
+           ((let lp ((ls pairs)) ; an in-lined ANY
+              (and (pair? ls) (if (done? (car ls)) #t (lp (cdr ls))))))
+           ((elts (map car pairs))
+            (succ (map step pairs)))
+           ()
+           . rest))
+    ))
+
+(define-syntax define-in-indexed
+  (syntax-rules ()
+    ((define-in-indexed in-type in-type-reverse length ref)
+     (begin
+       (define-syntax in-type
+         (syntax-rules ()
+           ((in-type seq next . rest)
+            (%in-idx >= (lambda (x i) (+ i 1)) (lambda (x) 0) length ref tmp seq next . rest))))
+       (define-syntax in-type-reverse
+         (syntax-rules ()
+           ((in-type-reverse seq next . rest)
+            (%in-idx < (lambda (x i) (- i 1)) (lambda (x) (- (length x) 1)) (lambda (x) 0) ref tmp seq next . rest))))
+       ))))
+
+;;> @subsubsubsection{@scheme{(for var [index] (in-vector vec))}}
+;;> @subsubsubsection{@scheme{(for var [index] (in-vector-reverse vec))}}
+
+(define-in-indexed in-vector in-vector-reverse vector-length vector-ref)
+
+;;> @subsubsubsection{@scheme{(for ch [cursor] (in-string str))}}
+
+(define-syntax in-string
+  (syntax-rules ()
+    ((in-string s next . rest)
+     (%in-idx string-cursor>=? string-cursor-next
+              string-cursor-start string-cursor-end string-cursor-ref
+              tmp s next . rest))))
+
+;;> @subsubsubsection{@scheme{(for ch [cursor] (in-string-reverse str))}}
+
+(define-syntax in-string-reverse
+  (syntax-rules ()
+    ((in-string-reverse s next . rest)
+     (%in-idx string-cursor<? string-cursor-prev
+              (lambda (x) (string-cursor-prev x (string-cursor-end x)))
+              string-cursor-start string-cursor-ref
+              tmp s next . rest))))
+
+;; helper for the above string and vector iterators
+(define-syntax %in-idx
+  (syntax-rules ()
+    ;;   cmp inc start end ref
+    ((%in-idx ge + s e r tmp ((var) (seq ...)) next . rest)
+     (%in-idx ge + s e r tmp ((var seq-index) (seq ...)) next . rest))
+    ((%in-idx ge + s e r tmp ((var index) (seq)) next . rest)
+     (%in-idx ge + s e r tmp ((var index) (seq (s tmp) (e tmp))) next . rest))
+    ((%in-idx ge + s e r tmp ((var index) (seq from)) next . rest)
+     (%in-idx ge + s e r tmp ((var index) (seq from (e tmp))) next . rest))
+    ((%in-idx ge + s e r tmp ((var index) (seq from to)) next . rest)
+     (next ((tmp seq) (end to))
+           ((index from (+ tmp index)))
+           ((ge index end))
+           ((var (r tmp index)))
+           ()
+       . rest))
+    ))
+
+;;> @subsubsubsection{@scheme{(for ch (in-port [input-port [reader [eof?]]]))}}
+
+(define-syntax in-port
+  (syntax-rules ()
+    ((in-port ((var) source) next . rest)
+     (in-port ((var p) source) next . rest))
+    ((in-port ((var p) ()) next . rest)
+     (in-port ((var p) ((current-input-port))) next . rest))
+    ((in-port ((var p) (port)) next . rest)
+     (in-port ((var p) (port read-char)) next . rest))
+    ((in-port ((var p) (port read-char)) next . rest)
+     (in-port ((var p) (port read-char eof-object?)) next . rest))
+    ((in-port ((var p) (port reader eof?)) next . rest)
+     (next ((p port) (r reader) (e? eof?))
+           ((var (r p) (r p)))
+           ((e? var))
+           ()
+           ()
+       . rest))))
+
+;;> @subsubsubsection{@scheme{(for ch (in-file [input-port [reader [eof?]]]))}}
+
+(define-syntax in-file
+  (syntax-rules ()
+    ((in-file ((var) source) next . rest)
+     (in-file ((var p) source) next . rest))
+    ((in-file ((var p) (file)) next . rest)
+     (in-file ((var p) (file read-char)) next . rest))
+    ((in-file ((var p) (file reader)) next . rest)
+     (in-file ((var p) (file reader eof-object?)) next . rest))
+    ((in-file ((var p) (file reader eof?)) next . rest)
+     (next ((p (open-input-file file)) (r reader) (e? eof?))
+           ((var (r p) (r p)))
+           ((e? var))
+           ()
+           ((dummy (close-input-port p)))
+       . rest))))
+
+;;> @subsubsubsection{@scheme{(for x (up-from [start] [(to limit)] [(by step)]))}}
+
+(define-syntax up-from
+  (syntax-rules (to by)
+    ((up-from (() . args) next . rest)
+     (up-from ((var) . args) next . rest))
+    ((up-from ((var) (start (to limit) (by step))) next . rest)
+     (next ((s start) (l limit) (e step))
+           ((var s (+ var e)))
+           ((>= var l))
+           ()
+           ()
+           . rest))
+    ((up-from ((var) (start (to limit))) next . rest)
+     (next ((s start) (l limit))
+           ((var s (+ var 1)))
+           ((>= var l))
+           ()
+           ()
+           . rest))
+    ((up-from ((var) (start (by step))) next . rest)
+     (next ((s start) (e step)) ((var s (+ var e))) () () () . rest))
+    ((up-from ((var) (start)) next . rest)
+     (next ((s start)) ((var s (+ var 1))) () () () . rest))
+    ))
+
+;;> @subsubsubsection{@scheme{(for x (down-from [start] [(to limit)] [(by step)]))}}
+
+(define-syntax down-from
+  (syntax-rules (to by)
+    ((down-from (() . args) next . rest)
+     (down-from ((var) . args) next . rest))
+    ((down-from ((var) (start (to limit) (by step))) next . rest)
+     (next ((s start) (l limit) (e step))
+           ((var (- s e) (- var e)))
+           ((< var l))
+           ()
+           ()
+           . rest))
+    ((down-from ((var) (start (to limit))) next . rest)
+     (next ((s start) (l limit))
+           ((var (- s 1) (- var 1)))
+           ((< var l))
+           ()
+           ()
+           . rest))
+    ((down-from ((var) (start (by step))) next . rest)
+     (next ((s start) (e step)) ((var (- s e) (- var e))) () () ()
+           . rest))
+    ((down-from ((var) (start)) next . rest)
+     (next ((s start)) ((var (- s 1) (- var 1))) () () ()
+           . rest))
+    ))
+
+(define-syntax accumulating
+  (syntax-rules (initial if)
+    ((accumulating (kons final init) ((var) . x) next . rest)
+     (accumulating (kons final init) ((var cursor) . x) next . rest))
+    ((accumulating (kons final init) ((var cursor) ((initial i) . x)) n . rest)
+     (accumulating (kons final i) ((var cursor) x) n . rest))
+    ((accumulating (kons final init) ((var cursor) (expr (if check))) n . rest)
+     (n ((tmp-kons kons))
+        ((cursor '() (if check (tmp-kons expr cursor) cursor)))
+        ()
+        ()
+        ((var (final cursor)))
+        . rest))
+    ((accumulating (kons final init) ((var cursor) (expr)) n . rest)
+     (n ((tmp-kons kons))
+        ((cursor '() (tmp-kons expr cursor)))
+        ()
+        ()
+        ((var (final cursor)))
+        . rest))))
+
+;;> @subsubsubsection{@scheme{(for x [pair] (listing expr))}}
+
+(define-syntax listing
+  (syntax-rules ()
+    ((listing args next . rest)
+     (accumulating (cons reverse '()) args next . rest))))
+
+;;> @subsubsubsection{@scheme{(for x [pair] (listing-reverse expr))}}
+
+(define-syntax listing-reverse
+  (syntax-rules ()
+    ((listing-reverse args next . rest)
+     (accumulating (cons (lambda (x) x) '()) args next . rest))))
+
+(define (append-reverse rev tail)
+  (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail))))
+
+;;> @subsubsubsection{@scheme{(for x [pair] (appending expr))}}
+
+(define-syntax appending
+  (syntax-rules ()
+    ((appending args next . rest)
+     (accumulating (append-reverse reverse '()) args next . rest))))
+
+;;> @subsubsubsection{@scheme{(for x [pair] (appending-reverse expr))}}
+
+(define-syntax appending-reverse
+  (syntax-rules ()
+    ((appending-reverse args next . rest)
+     (accumulating (append-reverse (lambda (x) x) '()) args next . rest))))
+
+;;> @subsubsubsection{@scheme{(for x (summing expr))}}
+
+(define-syntax summing
+  (syntax-rules ()
+    ((summing args next . rest)
+     (accumulating (+ (lambda (x) x) 0) args next . rest))))
+
+;;> @subsubsubsection{@scheme{(for x (multiplying expr))}}
+
+(define-syntax multiplying
+  (syntax-rules ()
+    ((multiplying args next . rest)
+     (accumulating (* (lambda (x) x) 1) args next . rest))))

lib/chibi/match.sld

@@ -0,0 +1,6 @@
+
+(define-library (chibi match)
+  (export match match-lambda match-lambda* match-let match-letrec match-let*)
+  (import (scheme))
+  (include "match/match.scm"))
+

lib/chibi/match/match.scm

@@ -0,0 +1,906 @@
+;;;; match.scm -- portable hygienic pattern matcher -*- coding: utf-8 -*-
+;;
+;; This code is written by Alex Shinn and placed in the
+;; Public Domain.  All warranties are disclaimed.
+
+;;> @example-import[(srfi 9)]
+
+;;> This is a full superset of the popular @hyperlink[
+;;> "http://www.cs.indiana.edu/scheme-repository/code.match.html"]{match}
+;;> package by Andrew Wright, written in fully portable @scheme{syntax-rules}
+;;> and thus preserving hygiene.
+
+;;> The most notable extensions are the ability to use @emph{non-linear}
+;;> patterns - patterns in which the same identifier occurs multiple
+;;> times, tail patterns after ellipsis, and the experimental tree patterns.
+
+;;> @subsubsection{Patterns}
+
+;;> Patterns are written to look like the printed representation of
+;;> the objects they match.  The basic usage is
+
+;;> @scheme{(match expr (pat body ...) ...)}
+
+;;> where the result of @var{expr} is matched against each pattern in
+;;> turn, and the corresponding body is evaluated for the first to
+;;> succeed.  Thus, a list of three elements matches a list of three
+;;> elements.
+
+;;> @example{(let ((ls (list 1 2 3))) (match ls ((1 2 3) #t)))}
+
+;;> If no patterns match an error is signalled.
+
+;;> Identifiers will match anything, and make the corresponding
+;;> binding available in the body.
+
+;;> @example{(match (list 1 2 3) ((a b c) b))}
+
+;;> If the same identifier occurs multiple times, the first instance
+;;> will match anything, but subsequent instances must match a value
+;;> which is @scheme{equal?} to the first.
+
+;;> @example{(match (list 1 2 1) ((a a b) 1) ((a b a) 2))}
+
+;;> The special identifier @scheme{_} matches anything, no matter how
+;;> many times it is used, and does not bind the result in the body.
+
+;;> @example{(match (list 1 2 1) ((_ _ b) 1) ((a b a) 2))}
+
+;;> To match a literal identifier (or list or any other literal), use
+;;> @scheme{quote}.
+
+;;> @example{(match 'a ('b 1) ('a 2))}
+
+;;> Analogous to its normal usage in scheme, @scheme{quasiquote} can
+;;> be used to quote a mostly literally matching object with selected
+;;> parts unquoted.
+
+;;> @example|{(match (list 1 2 3) (`(1 ,b ,c) (list b c)))}|
+
+;;> Often you want to match any number of a repeated pattern.  Inside
+;;> a list pattern you can append @scheme{...} after an element to
+;;> match zero or more of that pattern (like a regexp Kleene star).
+
+;;> @example{(match (list 1 2) ((1 2 3 ...) #t))}
+;;> @example{(match (list 1 2 3) ((1 2 3 ...) #t))}
+;;> @example{(match (list 1 2 3 3 3) ((1 2 3 ...) #t))}
+
+;;> Pattern variables matched inside the repeated pattern are bound to
+;;> a list of each matching instance in the body.
+
+;;> @example{(match (list 1 2) ((a b c ...) c))}
+;;> @example{(match (list 1 2 3) ((a b c ...) c))}
+;;> @example{(match (list 1 2 3 4 5) ((a b c ...) c))}
+
+;;> More than one @scheme{...} may not be used in the same list, since
+;;> this would require exponential backtracking in the general case.
+;;> However, @scheme{...} need not be the final element in the list,
+;;> and may be succeeded by a fixed number of patterns.
+
+;;> @example{(match (list 1 2 3 4) ((a b c ... d e) c))}
+;;> @example{(match (list 1 2 3 4 5) ((a b c ... d e) c))}
+;;> @example{(match (list 1 2 3 4 5 6 7) ((a b c ... d e) c))}
+
+;;> @scheme{___} is provided as an alias for @scheme{...} when it is
+;;> inconvenient to use the ellipsis (as in a syntax-rules template).
+
+;;> The @scheme{..1} syntax is exactly like the @scheme{...} except
+;;> that it matches one or more repetitions (like a regexp "+").
+
+;;> @example{(match (list 1 2) ((a b c ..1) c))}
+;;> @example{(match (list 1 2 3) ((a b c ..1) c))}
+
+;;> The boolean operators @scheme{and}, @scheme{or} and @scheme{not}
+;;> can be used to group and negate patterns analogously to their
+;;> Scheme counterparts.
+
+;;> The @scheme{and} operator ensures that all subpatterns match.
+;;> This operator is often used with the idiom @scheme{(and x pat)} to
+;;> bind @var{x} to the entire value that matches @var{pat}
+;;> (c.f. "as-patterns" in ML or Haskell).  Another common use is in
+;;> conjunction with @scheme{not} patterns to match a general case
+;;> with certain exceptions.
+
+;;> @example{(match 1 ((and) #t))}
+;;> @example{(match 1 ((and x) x))}
+;;> @example{(match 1 ((and x 1) x))}
+
+;;> The @scheme{or} operator ensures that at least one subpattern
+;;> matches.  If the same identifier occurs in different subpatterns,
+;;> it is matched independently.  All identifiers from all subpatterns
+;;> are bound if the @scheme{or} operator matches, but the binding is
+;;> only defined for identifiers from the subpattern which matched.
+
+;;> @example{(match 1 ((or) #t) (else #f))}
+;;> @example{(match 1 ((or x) x))}
+;;> @example{(match 1 ((or x 2) x))}
+
+;;> The @scheme{not} operator succeeds if the given pattern doesn't
+;;> match.  None of the identifiers used are available in the body.
+
+;;> @example{(match 1 ((not 2) #t))}
+
+;;> The more general operator @scheme{?} can be used to provide a
+;;> predicate.  The usage is @scheme{(? predicate pat ...)} where
+;;> @var{predicate} is a Scheme expression evaluating to a predicate
+;;> called on the value to match, and any optional patterns after the
+;;> predicate are then matched as in an @scheme{and} pattern.
+
+;;> @example{(match 1 ((? odd? x) x))}
+
+;;> The field operator @scheme{=} is used to extract an arbitrary
+;;> field and match against it.  It is useful for more complex or
+;;> conditional destructuring that can't be more directly expressed in
+;;> the pattern syntax.  The usage is @scheme{(= field pat)}, where
+;;> @var{field} can be any expression, and should result in a
+;;> procedure of one argument, which is applied to the value to match
+;;> to generate a new value to match against @var{pat}.
+
+;;> Thus the pattern @scheme{(and (= car x) (= cdr y))} is equivalent
+;;> to @scheme{(x . y)}, except it will result in an immediate error
+;;> if the value isn't a pair.
+
+;;> @example{(match '(1 . 2) ((= car x) x))}
+;;> @example{(match 4 ((= sqrt x) x))}
+
+;;> The record operator @scheme{$} is used as a concise way to match
+;;> records defined by SRFI-9 (or SRFI-99).  The usage is
+;;> @scheme{($ rtd field ...)}, where @var{rtd} should be the record
+;;> type descriptor specified as the first argument to
+;;> @scheme{define-record-type}, and each @var{field} is a subpattern
+;;> matched against the fields of the record in order.  Not all fields
+;;> must be present.
+
+;;> @example{
+;;> (let ()
+;;>   (define-record-type employee
+;;>     (make-employee name title)
+;;>     employee?
+;;>     (name get-name)
+;;>     (title get-title))
+;;>   (match (make-employee "Bob" "Doctor")
+;;>     (($ employee n t) (list t n))))
+;;> }
+
+;;> The @scheme{set!} and @scheme{get!} operators are used to bind an
+;;> identifier to the setter and getter of a field, respectively.  The
+;;> setter is a procedure of one argument, which mutates the field to
+;;> that argument.  The getter is a procedure of no arguments which
+;;> returns the current value of the field.
+
+;;> @example{(let ((x (cons 1 2))) (match x ((1 . (set! s)) (s 3) x)))}
+;;> @example{(match '(1 . 2) ((1 . (get! g)) (g)))}
+
+;;> The new operator @scheme{***} can be used to search a tree for
+;;> subpatterns.  A pattern of the form @scheme{(x *** y)} represents
+;;> the subpattern @var{y} located somewhere in a tree where the path
+;;> from the current object to @var{y} can be seen as a list of the
+;;> form @scheme{(x ...)}.  @var{y} can immediately match the current
+;;> object in which case the path is the empty list.  In a sense it's
+;;> a 2-dimensional version of the @scheme{...} pattern.
+
+;;> As a common case the pattern @scheme{(_ *** y)} can be used to
+;;> search for @var{y} anywhere in a tree, regardless of the path
+;;> used.
+
+;;> @example{(match '(a (a (a b))) ((x *** 'b) x))}
+;;> @example{(match '(a (b) (c (d e) (f g))) ((x *** 'g) x))}
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Notes
+
+;; The implementation is a simple generative pattern matcher - each
+;; pattern is expanded into the required tests, calling a failure
+;; continuation if the tests fail.  This makes the logic easy to
+;; follow and extend, but produces sub-optimal code in cases where you
+;; have many similar clauses due to repeating the same tests.
+;; Nonetheless a smart compiler should be able to remove the redundant
+;; tests.  For MATCH-LET and DESTRUCTURING-BIND type uses there is no
+;; performance hit.
+
+;; The original version was written on 2006/11/29 and described in the
+;; following Usenet post:
+;;   http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd
+;; and is still available at
+;;   http://synthcode.com/scheme/match-simple.scm
+;; It's just 80 lines for the core MATCH, and an extra 40 lines for
+;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar.
+;;
+;; A variant of this file which uses COND-EXPAND in a few places for
+;; performance can be found at
+;;   http://synthcode.com/scheme/match-cond-expand.scm
+;;
+;; 2011/09/25 - fixing bug when directly matching an identifier repeated in
+;;              the pattern (thanks to Stefan Israelsson Tampe)
+;; 2011/01/27 - fixing bug when matching tail patterns against improper lists
+;; 2010/09/26 - adding `..1' patterns (thanks to Ludovic Courtès)
+;; 2010/09/07 - fixing identifier extraction in some `...' and `***' patterns
+;; 2009/11/25 - adding `***' tree search patterns
+;; 2008/03/20 - fixing bug where (a ...) matched non-lists
+;; 2008/03/15 - removing redundant check in vector patterns
+;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell)
+;; 2007/09/04 - fixing quasiquote patterns
+;; 2007/07/21 - allowing ellipse patterns in non-final list positions
+;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse
+;;              (thanks to Taylor Campbell)
+;; 2007/04/08 - clean up, commenting
+;; 2006/12/24 - bugfixes
+;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set!
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; force compile-time syntax errors with useful messages
+
+(define-syntax match-syntax-error
+  (syntax-rules ()
+    ((_) (match-syntax-error "invalid match-syntax-error usage"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> @subsubsection{Syntax}
+
+;;> @subsubsubsection{@rawcode{(match expr (pattern . body) ...)@br{}
+;;> (match expr (pattern (=> failure) . body) ...)}}
+
+;;> The result of @var{expr} is matched against each @var{pattern} in
+;;> turn, according to the pattern rules described in the previous
+;;> section, until the the first @var{pattern} matches.  When a match is
+;;> found, the corresponding @var{body}s are evaluated in order,
+;;> and the result of the last expression is returned as the result
+;;> of the entire @scheme{match}.  If a @var{failure} is provided,
+;;> then it is bound to a procedure of no arguments which continues,
+;;> processing at the next @var{pattern}.  If no @var{pattern} matches,
+;;> an error is signalled.
+
+;; The basic interface.  MATCH just performs some basic syntax
+;; validation, binds the match expression to a temporary variable `v',
+;; and passes it on to MATCH-NEXT.  It's a constant throughout the
+;; code below that the binding `v' is a direct variable reference, not
+;; an expression.
+
+(define-syntax match
+  (syntax-rules ()
+    ((match)
+     (match-syntax-error "missing match expression"))
+    ((match atom)
+     (match-syntax-error "no match clauses"))
+    ((match (app ...) (pat . body) ...)
+     (let ((v (app ...)))
+       (match-next v ((app ...) (set! (app ...))) (pat . body) ...)))
+    ((match #(vec ...) (pat . body) ...)
+     (let ((v #(vec ...)))
+       (match-next v (v (set! v)) (pat . body) ...)))
+    ((match atom (pat . body) ...)
+     (let ((v atom))
+       (match-next v (atom (set! atom)) (pat . body) ...)))
+    ))
+
+;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure
+;; thunk, which is expanded by recursing MATCH-NEXT on the remaining
+;; clauses.  `g+s' is a list of two elements, the get! and set!
+;; expressions respectively.
+
+(define-syntax match-next
+  (syntax-rules (=>)
+    ;; no more clauses, the match failed
+    ((match-next v g+s)
+     (error 'match "no matching pattern"))
+    ;; named failure continuation
+    ((match-next v g+s (pat (=> failure) . body) . rest)
+     (let ((failure (lambda () (match-next v g+s . rest))))
+       ;; match-one analyzes the pattern for us
+       (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ())))
+    ;; anonymous failure continuation, give it a dummy name
+    ((match-next v g+s (pat . body) . rest)
+     (match-next v g+s (pat (=> failure) . body) . rest))))
+
+;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to
+;; MATCH-TWO.
+
+(define-syntax match-one
+  (syntax-rules ()
+    ;; If it's a list of two or more values, check to see if the
+    ;; second one is an ellipse and handle accordingly, otherwise go
+    ;; to MATCH-TWO.
+    ((match-one v (p q . r) g+s sk fk i)
+     (match-check-ellipse
+      q
+      (match-extract-vars p (match-gen-ellipses v p r  g+s sk fk i) i ())
+      (match-two v (p q . r) g+s sk fk i)))
+    ;; Go directly to MATCH-TWO.
+    ((match-one . x)
+     (match-two . x))))
+
+;; This is the guts of the pattern matcher.  We are passed a lot of
+;; information in the form:
+;;
+;;   (match-two var pattern getter setter success-k fail-k (ids ...))
+;;
+;; usually abbreviated
+;;
+;;   (match-two v p g+s sk fk i)
+;;
+;; where VAR is the symbol name of the current variable we are
+;; matching, PATTERN is the current pattern, getter and setter are the
+;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding
+;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure
+;; continuation (which is just a thunk call and is thus safe to expand
+;; multiple times) and IDS are the list of identifiers bound in the
+;; pattern so far.
+
+(define-syntax match-two
+  (syntax-rules (_ ___ ..1 *** quote quasiquote ? $ = and or not set! get!)
+    ((match-two v () g+s (sk ...) fk i)
+     (if (null? v) (sk ... i) fk))
+    ((match-two v (quote p) g+s (sk ...) fk i)
+     (if (equal? v 'p) (sk ... i) fk))
+    ((match-two v (quasiquote p) . x)
+     (match-quasiquote v p . x))
+    ((match-two v (and) g+s (sk ...) fk i) (sk ... i))
+    ((match-two v (and p q ...) g+s sk fk i)
+     (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i))
+    ((match-two v (or) g+s sk fk i) fk)
+    ((match-two v (or p) . x)
+     (match-one v p . x))
+    ((match-two v (or p ...) g+s sk fk i)
+     (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ()))
+    ((match-two v (not p) g+s (sk ...) fk i)
+     (match-one v p g+s (match-drop-ids fk) (sk ... i) i))
+    ((match-two v (get! getter) (g s) (sk ...) fk i)
+     (let ((getter (lambda () g))) (sk ... i)))
+    ((match-two v (set! setter) (g (s ...)) (sk ...) fk i)
+     (let ((setter (lambda (x) (s ... x)))) (sk ... i)))
+    ((match-two v (? pred . p) g+s sk fk i)
+     (if (pred v) (match-one v (and . p) g+s sk fk i) fk))
+    ((match-two v (= proc p) . x)
+     (let ((w (proc v))) (match-one w p . x)))
+    ((match-two v (p ___ . r) g+s sk fk i)
+     (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()))
+    ((match-two v (p) g+s sk fk i)
+     (if (and (pair? v) (null? (cdr v)))
+         (let ((w (car v)))
+           (match-one w p ((car v) (set-car! v)) sk fk i))
+         fk))
+    ((match-two v (p *** q) g+s sk fk i)
+     (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ()))
+    ((match-two v (p *** . q) g+s sk fk i)
+     (match-syntax-error "invalid use of ***" (p *** . q)))
+    ((match-two v (p ..1) g+s sk fk i)
+     (if (pair? v)
+         (match-one v (p ___) g+s sk fk i)
+         fk))
+    ((match-two v ($ rec p ...) g+s sk fk i)
+     (if (is-a? v rec)
+         (match-record-refs v rec 0 (p ...) g+s sk fk i)
+         fk))
+    ((match-two v (p . q) g+s sk fk i)
+     (if (pair? v)
+         (let ((w (car v)) (x (cdr v)))
+           (match-one w p ((car v) (set-car! v))
+                      (match-one x q ((cdr v) (set-cdr! v)) sk fk)
+                      fk
+                      i))
+         fk))
+    ((match-two v #(p ...) g+s . x)
+     (match-vector v 0 () (p ...) . x))
+    ((match-two v _ g+s (sk ...) fk i) (sk ... i))
+    ;; Not a pair or vector or special literal, test to see if it's a
+    ;; new symbol, in which case we just bind it, or if it's an
+    ;; already bound symbol or some other literal, in which case we
+    ;; compare it with EQUAL?.
+    ((match-two v x g+s (sk ...) fk (id ...))
+     (let-syntax
+         ((new-sym?
+           (syntax-rules (id ...)
+             ((new-sym? x sk2 fk2) sk2)
+             ((new-sym? y sk2 fk2) fk2))))
+       (new-sym? random-sym-to-match
+                 (let ((x v)) (sk ... (id ... x)))
+                 (if (equal? v x) (sk ... (id ...)) fk))))
+    ))
+
+;; QUASIQUOTE patterns
+
+(define-syntax match-quasiquote
+  (syntax-rules (unquote unquote-splicing quasiquote)
+    ((_ v (unquote p) g+s sk fk i)
+     (match-one v p g+s sk fk i))
+    ((_ v ((unquote-splicing p) . rest) g+s sk fk i)
+     (if (pair? v)
+       (match-one v
+                  (p . tmp)
+                  (match-quasiquote tmp rest g+s sk fk)
+                  fk
+                  i)
+       fk))
+    ((_ v (quasiquote p) g+s sk fk i . depth)
+     (match-quasiquote v p g+s sk fk i #f . depth))
+    ((_ v (unquote p) g+s sk fk i x . depth)
+     (match-quasiquote v p g+s sk fk i . depth))
+    ((_ v (unquote-splicing p) g+s sk fk i x . depth)
+     (match-quasiquote v p g+s sk fk i . depth))
+    ((_ v (p . q) g+s sk fk i . depth)
+     (if (pair? v)
+       (let ((w (car v)) (x (cdr v)))
+         (match-quasiquote
+          w p g+s
+          (match-quasiquote-step x q g+s sk fk depth)
+          fk i . depth))
+       fk))
+    ((_ v #(elt ...) g+s sk fk i . depth)
+     (if (vector? v)
+       (let ((ls (vector->list v)))
+         (match-quasiquote ls (elt ...) g+s sk fk i . depth))
+       fk))
+    ((_ v x g+s sk fk i . depth)
+     (match-one v 'x g+s sk fk i))))
+
+(define-syntax match-quasiquote-step
+  (syntax-rules ()
+    ((match-quasiquote-step x q g+s sk fk depth i)
+     (match-quasiquote x q g+s sk fk i . depth))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Utilities
+
+;; Takes two values and just expands into the first.
+(define-syntax match-drop-ids
+  (syntax-rules ()
+    ((_ expr ids ...) expr)))
+
+(define-syntax match-tuck-ids
+  (syntax-rules ()
+    ((_ (letish args (expr ...)) ids ...)
+     (letish args (expr ... ids ...)))))
+
+(define-syntax match-drop-first-arg
+  (syntax-rules ()
+    ((_ arg expr) expr)))
+
+;; To expand an OR group we try each clause in succession, passing the
+;; first that succeeds to the success continuation.  On failure for
+;; any clause, we just try the next clause, finally resorting to the
+;; failure continuation fk if all clauses fail.  The only trick is
+;; that we want to unify the identifiers, so that the success
+;; continuation can refer to a variable from any of the OR clauses.
+
+(define-syntax match-gen-or
+  (syntax-rules ()
+    ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...))
+     (let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
+       (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...))))))
+
+(define-syntax match-gen-or-step
+  (syntax-rules ()
+    ((_ v () g+s sk fk . x)
+     ;; no OR clauses, call the failure continuation
+     fk)
+    ((_ v (p) . x)
+     ;; last (or only) OR clause, just expand normally
+     (match-one v p . x))
+    ((_ v (p . q) g+s sk fk i)
+     ;; match one and try the remaining on failure
+     (match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i))
+    ))
+
+;; We match a pattern (p ...) by matching the pattern p in a loop on
+;; each element of the variable, accumulating the bound ids into lists.
+
+;; Look at the body of the simple case - it's just a named let loop,
+;; matching each element in turn to the same pattern.  The only trick
+;; is that we want to keep track of the lists of each extracted id, so
+;; when the loop recurses we cons the ids onto their respective list
+;; variables, and on success we bind the ids (what the user input and
+;; expects to see in the success body) to the reversed accumulated
+;; list IDs.
+
+(define-syntax match-gen-ellipses
+  (syntax-rules ()
+    ((_ v p () g+s (sk ...) fk i ((id id-ls) ...))
+     (match-check-identifier p
+       ;; simplest case equivalent to (p ...), just bind the list
+       (let ((p v))
+         (if (list? p)
+             (sk ... i)
+             fk))
+       ;; simple case, match all elements of the list
+       (let loop ((ls v) (id-ls '()) ...)
+         (cond
+           ((null? ls)
+            (let ((id (reverse id-ls)) ...) (sk ... i)))
+           ((pair? ls)
+            (let ((w (car ls)))
+              (match-one w p ((car ls) (set-car! ls))
+                         (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
+                         fk i)))
+           (else
+            fk)))))
+    ((_ v p r g+s (sk ...) fk i ((id id-ls) ...))
+     ;; general case, trailing patterns to match, keep track of the
+     ;; remaining list length so we don't need any backtracking
+     (match-verify-no-ellipses
+      r
+      (let* ((tail-len (length 'r))
+             (ls v)
+             (len (and (list? ls) (length ls))))
+        (if (or (not len) (< len tail-len))
+            fk
+            (let loop ((ls ls) (n len) (id-ls '()) ...)
+              (cond
+                ((= n tail-len)
+                 (let ((id (reverse id-ls)) ...)
+                   (match-one ls r (#f #f) (sk ...) fk i)))
+                ((pair? ls)
+                 (let ((w (car ls)))
+                   (match-one w p ((car ls) (set-car! ls))
+                              (match-drop-ids
+                               (loop (cdr ls) (- n 1) (cons id id-ls) ...))
+                              fk
+                              i)))
+                (else
+                 fk)))))))))
+
+;; This is just a safety check.  Although unlike syntax-rules we allow
+;; trailing patterns after an ellipses, we explicitly disable multiple
+;; ellipses at the same level.  This is because in the general case
+;; such patterns are exponential in the number of ellipses, and we
+;; don't want to make it easy to construct very expensive operations
+;; with simple looking patterns.  For example, it would be O(n^2) for
+;; patterns like (a ... b ...) because we must consider every trailing
+;; element for every possible break for the leading "a ...".
+
+(define-syntax match-verify-no-ellipses
+  (syntax-rules ()
+    ((_ (x . y) sk)
+     (match-check-ellipse
+      x
+      (match-syntax-error
+       "multiple ellipse patterns not allowed at same level")
+      (match-verify-no-ellipses y sk)))
+    ((_ () sk)
+     sk)
+    ((_ x sk)
+     (match-syntax-error "dotted tail not allowed after ellipse" x))))
+
+;; To implement the tree search, we use two recursive procedures.  TRY
+;; attempts to match Y once, and on success it calls the normal SK on
+;; the accumulated list ids as in MATCH-GEN-ELLIPSES.  On failure, we
+;; call NEXT which first checks if the current value is a list
+;; beginning with X, then calls TRY on each remaining element of the
+;; list.  Since TRY will recursively call NEXT again on failure, this
+;; effects a full depth-first search.
+;;
+;; The failure continuation throughout is a jump to the next step in
+;; the tree search, initialized with the original failure continuation
+;; FK.
+
+(define-syntax match-gen-search
+  (syntax-rules ()
+    ((match-gen-search v p q g+s sk fk i ((id id-ls) ...))
+     (letrec ((try (lambda (w fail id-ls ...)
+                     (match-one w q g+s
+                                (match-tuck-ids
+                                 (let ((id (reverse id-ls)) ...)
+                                   sk))
+                                (next w fail id-ls ...) i)))
+              (next (lambda (w fail id-ls ...)
+                      (if (not (pair? w))
+                          (fail)
+                          (let ((u (car w)))
+                            (match-one
+                             u p ((car w) (set-car! w))
+                             (match-drop-ids
+                              ;; accumulate the head variables from
+                              ;; the p pattern, and loop over the tail
+                              (let ((id-ls (cons id id-ls)) ...)
+                                (let lp ((ls (cdr w)))
+                                  (if (pair? ls)
+                                      (try (car ls)
+                                           (lambda () (lp (cdr ls)))
+                                           id-ls ...)
+                                      (fail)))))
+                             (fail) i))))))
+       ;; the initial id-ls binding here is a dummy to get the right
+       ;; number of '()s
+       (let ((id-ls '()) ...)
+         (try v (lambda () fk) id-ls ...))))))
+
+;; Vector patterns are just more of the same, with the slight
+;; exception that we pass around the current vector index being
+;; matched.
+
+(define-syntax match-vector
+  (syntax-rules (___)
+    ((_ v n pats (p q) . x)
+     (match-check-ellipse q
+                          (match-gen-vector-ellipses v n pats p . x)
+                          (match-vector-two v n pats (p q) . x)))
+    ((_ v n pats (p ___) sk fk i)
+     (match-gen-vector-ellipses v n pats p sk fk i))
+    ((_ . x)
+     (match-vector-two . x))))
+
+;; Check the exact vector length, then check each element in turn.
+
+(define-syntax match-vector-two
+  (syntax-rules ()
+    ((_ v n ((pat index) ...) () sk fk i)
+     (if (vector? v)
+         (let ((len (vector-length v)))
+           (if (= len n)
+               (match-vector-step v ((pat index) ...) sk fk i)
+               fk))
+         fk))
+    ((_ v n (pats ...) (p . q) . x)
+     (match-vector v (+ n 1) (pats ... (p n)) q . x))))
+
+(define-syntax match-vector-step
+  (syntax-rules ()
+    ((_ v () (sk ...) fk i) (sk ... i))
+    ((_ v ((pat index) . rest) sk fk i)
+     (let ((w (vector-ref v index)))
+       (match-one w pat ((vector-ref v index) (vector-set! v index))
+                  (match-vector-step v rest sk fk)
+                  fk i)))))
+
+;; With a vector ellipse pattern we first check to see if the vector
+;; length is at least the required length.
+
+(define-syntax match-gen-vector-ellipses
+  (syntax-rules ()
+    ((_ v n ((pat index) ...) p sk fk i)
+     (if (vector? v)
+       (let ((len (vector-length v)))
+         (if (>= len n)
+           (match-vector-step v ((pat index) ...)
+                              (match-vector-tail v p n len sk fk)
+                              fk i)
+           fk))
+       fk))))
+
+(define-syntax match-vector-tail
+  (syntax-rules ()
+    ((_ v p n len sk fk i)
+     (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ()))))
+
+(define-syntax match-vector-tail-two
+  (syntax-rules ()
+    ((_ v p n len (sk ...) fk i ((id id-ls) ...))
+     (let loop ((j n) (id-ls '()) ...)
+       (if (>= j len)
+         (let ((id (reverse id-ls)) ...) (sk ... i))
+         (let ((w (vector-ref v j)))
+           (match-one w p ((vector-ref v j) (vetor-set! v j))
+                      (match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
+                      fk i)))))))
+
+(define-syntax match-record-refs
+  (syntax-rules ()
+    ((_ v rec n (p . q) g+s sk fk i)
+     (let ((w (slot-ref rec v n)))
+       (match-one w p ((slot-ref rec v n) (slot-set! rec v n))
+                  (match-record-refs v rec (+ n 1) q g+s sk fk) fk i)))
+    ((_ v rec n () g+s (sk ...) fk i)
+     (sk ... i))))
+
+;; Extract all identifiers in a pattern.  A little more complicated
+;; than just looking for symbols, we need to ignore special keywords
+;; and non-pattern forms (such as the predicate expression in ?
+;; patterns), and also ignore previously bound identifiers.
+;;
+;; Calls the continuation with all new vars as a list of the form
+;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely
+;; pair with the original variable (e.g. it's used in the ellipse
+;; generation for list variables).
+;;
+;; (match-extract-vars pattern continuation (ids ...) (new-vars ...))
+
+(define-syntax match-extract-vars
+  (syntax-rules (_ ___ ..1 *** ? $ = quote quasiquote and or not get! set!)
+    ((match-extract-vars (? pred . p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars ($ rec . p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (= proc p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (quote x) (k ...) i v)
+     (k ... v))
+    ((match-extract-vars (quasiquote x) k i v)
+     (match-extract-quasiquote-vars x k i v (#t)))
+    ((match-extract-vars (and . p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (or . p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (not . p) . x)
+     (match-extract-vars p . x))
+    ;; A non-keyword pair, expand the CAR with a continuation to
+    ;; expand the CDR.
+    ((match-extract-vars (p q . r) k i v)
+     (match-check-ellipse
+      q
+      (match-extract-vars (p . r) k i v)
+      (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
+    ((match-extract-vars (p . q) k i v)
+     (match-extract-vars p (match-extract-vars-step q k i v) i ()))
+    ((match-extract-vars #(p ...) . x)
+     (match-extract-vars (p ...) . x))
+    ((match-extract-vars _ (k ...) i v)    (k ... v))
+    ((match-extract-vars ___ (k ...) i v)  (k ... v))
+    ((match-extract-vars *** (k ...) i v)  (k ... v))
+    ((match-extract-vars ..1 (k ...) i v)  (k ... v))
+    ;; This is the main part, the only place where we might add a new
+    ;; var if it's an unbound symbol.
+    ((match-extract-vars p (k ...) (i ...) v)
+     (let-syntax
+         ((new-sym?
+           (syntax-rules (i ...)
+             ((new-sym? p sk fk) sk)
+             ((new-sym? any sk fk) fk))))
+       (new-sym? random-sym-to-match
+                 (k ... ((p p-ls) . v))
+                 (k ... v))))
+    ))
+
+;; Stepper used in the above so it can expand the CAR and CDR
+;; separately.
+
+(define-syntax match-extract-vars-step
+  (syntax-rules ()
+    ((_ p k i v ((v2 v2-ls) ...))
+     (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))
+    ))
+
+(define-syntax match-extract-quasiquote-vars
+  (syntax-rules (quasiquote unquote unquote-splicing)
+    ((match-extract-quasiquote-vars (quasiquote x) k i v d)
+     (match-extract-quasiquote-vars x k i v (#t . d)))
+    ((match-extract-quasiquote-vars (unquote-splicing x) k i v d)
+     (match-extract-quasiquote-vars (unquote x) k i v d))
+    ((match-extract-quasiquote-vars (unquote x) k i v (#t))
+     (match-extract-vars x k i v))
+    ((match-extract-quasiquote-vars (unquote x) k i v (#t . d))
+     (match-extract-quasiquote-vars x k i v d))
+    ((match-extract-quasiquote-vars (x . y) k i v (#t . d))
+     (match-extract-quasiquote-vars
+      x
+      (match-extract-quasiquote-vars-step y k i v d) i ()))
+    ((match-extract-quasiquote-vars #(x ...) k i v (#t . d))
+     (match-extract-quasiquote-vars (x ...) k i v d))
+    ((match-extract-quasiquote-vars x (k ...) i v (#t . d))
+     (k ... v))
+    ))
+
+(define-syntax match-extract-quasiquote-vars-step
+  (syntax-rules ()
+    ((_ x k i v d ((v2 v2-ls) ...))
+     (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d))
+    ))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Gimme some sugar baby.
+
+;;> Shortcut for @scheme{lambda} + @scheme{match}.  Creates a
+;;> procedure of one argument, and matches that argument against each
+;;> clause.
+
+(define-syntax match-lambda
+  (syntax-rules ()
+    ((_ (pattern . body) ...) (lambda (expr) (match expr (pattern . body) ...)))))
+
+;;> Similar to @scheme{match-lambda}.  Creates a procedure of any
+;;> number of arguments, and matches the argument list against each
+;;> clause.
+
+(define-syntax match-lambda*
+  (syntax-rules ()
+    ((_ (pattern . body) ...) (lambda expr (match expr (pattern . body) ...)))))
+
+;;> Matches each var to the corresponding expression, and evaluates
+;;> the body with all match variables in scope.  Raises an error if
+;;> any of the expressions fail to match.  Syntax analogous to named
+;;> let can also be used for recursive functions which match on their
+;;> arguments as in @scheme{match-lambda*}.
+
+(define-syntax match-let
+  (syntax-rules ()
+    ((_ ((var value) ...) . body)
+     (match-let/helper let () () ((var value) ...) . body))
+    ((_ loop ((var init) ...) . body)
+     (match-named-let loop ((var init) ...) . body))))
+
+;;> Similar to @scheme{match-let}, but analogously to @scheme{letrec}
+;;> matches and binds the variables with all match variables in scope.
+
+(define-syntax match-letrec
+  (syntax-rules ()
+    ((_ ((var value) ...) . body)
+     (match-let/helper letrec () () ((var value) ...) . body))))
+
+(define-syntax match-let/helper
+  (syntax-rules ()
+    ((_ let ((var expr) ...) () () . body)
+     (let ((var expr) ...) . body))
+    ((_ let ((var expr) ...) ((pat tmp) ...) () . body)
+     (let ((var expr) ...)
+       (match-let* ((pat tmp) ...)
+         . body)))
+    ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body)
+     (match-let/helper
+      let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body))
+    ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body)
+     (match-let/helper
+      let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body))
+    ((_ let (v ...) (p ...) ((a expr) . rest) . body)
+     (match-let/helper let (v ... (a expr)) (p ...) rest . body))))
+
+(define-syntax match-named-let
+  (syntax-rules ()
+    ((_ loop ((pat expr var) ...) () . body)
+     (let loop ((var expr) ...)
+       (match-let ((pat var) ...)
+         . body)))
+    ((_ loop (v ...) ((pat expr) . rest) . body)
+     (match-named-let loop (v ... (pat expr tmp)) rest . body))))
+
+;;> @subsubsubsection{@rawcode{(match-let* ((var value) ...) body ...)}}
+
+;;> Similar to @scheme{match-let}, but analogously to @scheme{let*}
+;;> matches and binds the variables in sequence, with preceding match
+;;> variables in scope.
+
+(define-syntax match-let*
+  (syntax-rules ()
+    ((_ () . body)
+     (begin . body))
+    ((_ ((pat expr) . rest) . body)
+     (match expr (pat (match-let* rest . body))))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Otherwise COND-EXPANDed bits.
+
+;; This *should* work, but doesn't :(
+;;   (define-syntax match-check-ellipse
+;;     (syntax-rules (...)
+;;       ((_ ... sk fk) sk)
+;;       ((_ x sk fk) fk)))
+
+;; This is a little more complicated, and introduces a new let-syntax,
+;; but should work portably in any R[56]RS Scheme.  Taylor Campbell
+;; originally came up with the idea.
+(define-syntax match-check-ellipse
+  (syntax-rules ()
+    ;; these two aren't necessary but provide fast-case failures
+    ((match-check-ellipse (a . b) success-k failure-k) failure-k)
+    ((match-check-ellipse #(a ...) success-k failure-k) failure-k)
+    ;; matching an atom
+    ((match-check-ellipse id success-k failure-k)
+     (let-syntax ((ellipse? (syntax-rules ()
+                              ;; iff `id' is `...' here then this will
+                              ;; match a list of any length
+                              ((ellipse? (foo id) sk fk) sk)
+                              ((ellipse? other sk fk) fk))))
+       ;; this list of three elements will only many the (foo id) list
+       ;; above if `id' is `...'
+       (ellipse? (a b c) success-k failure-k)))))
+
+
+;; This is portable but can be more efficient with non-portable
+;; extensions.  This trick was originally discovered by Oleg Kiselyov.
+
+(define-syntax match-check-identifier
+  (syntax-rules ()
+    ;; fast-case failures, lists and vectors are not identifiers
+    ((_ (x . y) success-k failure-k) failure-k)
+    ((_ #(x ...) success-k failure-k) failure-k)
+    ;; x is an atom
+    ((_ x success-k failure-k)
+     (let-syntax
+         ((sym?
+           (syntax-rules ()
+             ;; if the symbol `abracadabra' matches x, then x is a
+             ;; symbol
+             ((sym? x sk fk) sk)
+             ;; otherwise x is a non-symbol datum
+             ((sym? y sk fk) fk))))
+       (sym? abracadabra success-k failure-k)))))

lib/chibi/mime.scm

@@ -0,0 +1,401 @@
+;; mime.scm -- RFC2045 MIME library
+;; Copyright (c) 2005-2011 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> A library to parse MIME headers and bodies into SXML.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define mime-line-length-limit 4096)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; association lists
+
+(define (assoc* key ls . o)
+  (let ((eq (if (pair? o) (car o) equal?)))
+    (let lp ((ls ls))
+      (cond
+        ((null? ls) #f)
+        ((eq key (caar ls)) (car ls))
+        (else (lp (cdr ls)))))))
+
+(define (assoc-ref ls key . o)
+  (let ((default (and (pair? o) (car o)))
+        (eq (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) equal?)))
+    (cond ((assoc* key ls eq) => cdr)
+          (else default))))
+
+;;> @subsubsubsection{@scheme{(mime-ref headers str [default])}}
+;;> A case-insensitive @scheme{assoc-ref}.
+
+(define (mime-ref ls key . o)
+  (assoc-ref ls key (and (pair? o) (car o)) string-ci=?))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; simple matching instead of regexps
+
+(define (match-mbox-from-line line)
+  (let ((len (string-length line)))
+    (and (> len 5)
+         (string=? (substring line 0 5) "From ")
+         (let lp ((i 6))
+           (cond
+             ((= i len) (list (substring line 5 len) ""))
+             ((memq (string-ref line i) '(#\space #\tab))
+              (list (substring line 5 i) (substring line (+ i 1) len)))
+             (else (lp (+ i 1))))))))
+
+(define (string-scan-colon-or-maybe-equal str)
+  (let ((len (string-length str)))
+    (let lp ((i 0) (best #f))
+      (if (= i len)
+          best
+          (let ((c (string-ref str i)))
+            (cond ((or (char-alphabetic? c)
+                       (char-numeric? c)
+                       (memv c '(#\- #\_)))
+                   (lp (+ i 1) best))
+                  ((eq? c #\:)
+                   (if (= i 0) #f i))
+                  ((eqv? c #\=)
+                   (lp (+ i 1) (or best i)))
+                  (else
+                   best)))))))
+
+(define (string-skip-white-space str i)
+  (let ((lim (string-length str)))
+    (let lp ((i i))
+      (cond ((>= i lim) lim)
+            ((char-whitespace? (string-ref str i)) (lp (+ i 1)))
+            (else i)))))
+
+(define (match-mime-header-line line)
+  (let ((i (string-scan-colon-or-maybe-equal line)))
+    (and i
+         (let ((j (string-skip-white-space line (+ i 1))))
+           (list (substring line 0 i)
+                 (substring line j (string-length line)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; dummy encoder
+
+(define (ces-convert str . x)
+  str)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; some srfi-13 & string utils
+
+(define (string-copy! to tstart from . o)
+  (let ((start (if (pair? o) (car o) 0))
+        (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length from))))
+    (let lp ((i start) (j tstart))
+      (cond
+       ((< i end)
+        (string-set! to j (string-ref from i))
+        (lp (+ i 1) (+ j 1)))))))
+
+(define (string-concatenate-reverse ls)
+  (let lp ((ls ls) (rev '()) (len 0))
+    (if (null? ls)
+        (let ((res (make-string len)))
+          (let lp ((ls rev) (i 0))
+            (cond
+             ((null? ls)
+              res)
+             (else
+              (string-copy! res i (car ls))
+              (lp (cdr ls) (+ i (string-length (car ls))))))))
+        (lp (cdr ls) (cons (car ls) rev) (+ len (string-length (car ls)))))))
+
+(define (string-downcase s . o)
+  (let ((start (if (pair? o) (car o) 0))
+        (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length s))))
+    (let* ((len (- end start)) (s2 (make-string len)))
+      (let lp ((i start) (j 0))
+        (cond
+         ((>= i end)
+          s2)
+         (else
+          (string-set! s2 j (char-downcase (string-ref s i)))
+          (lp (+ i 1) (+ j 1))))))))
+
+(define (string-char-index str c . o)
+  (let ((start (if (pair? o) (car o) 0))
+        (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str))))
+    (let lp ((i start))
+      (cond
+       ((= i end) #f)
+       ((eq? c (string-ref str i)) i)
+       (else (lp (+ i 1)))))))
+
+(define (string-trim-white-space s)
+  (let ((len (string-length s)))
+    (let lp ((i 0))
+      (cond ((= i len) "")
+            ((char-whitespace? (string-ref s i)) (lp (+ i 1)))
+            (else
+             (let lp ((j (- len 1)))
+               (cond ((<= j i) "")
+                     ((char-whitespace? (string-ref s j)) (lp (- j 1)))
+                     (else (substring s i (+ j 1))))))))))
+
+(define (string-split str ch)
+  (let ((len (string-length str)))
+    (let lp ((i 0) (res '()))
+      (let ((j (string-char-index str ch i)))
+        (if j
+            (lp (+ j 1) (cons (substring str i j) res))
+            (reverse (cons (substring str i len) res)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;> @subsubsection{RFC2822 Headers}
+
+;;> @subsubsubsection{@scheme{(mime-header-fold kons knil [source [limit [kons-from]]])}}
+;;>
+;;> Performs a fold operation on the MIME headers of source which can be
+;;> either a string or port, and defaults to current-input-port.  @var{kons}
+;;> is called on the three values:
+;;>    @scheme{(kons header value accumulator)}
+;;> where accumulator begins with @var{knil}.  Neither the header nor the
+;;> value are modified, except wrapped lines are handled for the value.
+;;>
+;;> The optional procedure @var{kons-from} is a procedure to be called when
+;;> the first line of the headers is an "From <address> <date>" line, to
+;;> enable this procedure to be used as-is on mbox files and the like.
+;;> It defaults to @var{kons}, and if such a line is found the fold will begin
+;;> with @scheme{(kons-from "%from" <address> (kons-from "%date" <date> knil))}.
+;;>
+;;> The optional @var{limit} gives a limit on the number of headers to read.
+
+(define (mime-header-fold kons knil . o)
+  (let ((src (and (pair? o) (car o)))
+        (limit (and (pair? o) (pair? (cdr o)) (car (cdr o))))
+        (kons-from (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) (caddr o) kons)))
+    ((if (string? src) mime-header-fold-string mime-header-fold-port)
+     kons knil (or src (current-input-port)) limit kons-from)))
+
+(define (mime-header-fold-string kons knil str limit kons-from)
+  (call-with-input-string str
+    (lambda (in) (mime-header-fold-port kons knil in limit kons-from))))
+
+(define (mime-header-fold-port kons knil port limit kons-from)
+  (define (out line acc count)
+    (cond
+     ((or (and limit (> count limit)) (eof-object? line) (string=? line ""))
+      acc)
+     ((match-mime-header-line line)
+      => (lambda (m) (in (car m) (list (cadr m)) acc (+ count 1))))
+     (else
+      ;;(warn "invalid header line: ~S\n" line)
+      (out (read-line port mime-line-length-limit) acc (+ count 1)))))
+  (define (in header value acc count)
+    (let ((line (read-line port mime-line-length-limit)))
+      (cond
+       ((and limit (> count limit))
+        acc)
+       ((or (eof-object? line) (string=? line ""))
+        (kons header (string-concatenate-reverse value) acc))
+       ((char-whitespace? (string-ref line 0))
+        (in header (cons line value) acc (+ count 1)))
+       (else
+        (out line
+             (kons header (string-concatenate-reverse value) acc)
+             (+ count 1))))))
+  (let ((first-line (read-line port mime-line-length-limit)))
+    (cond
+     ((eof-object? first-line)
+      knil)
+     ((and kons-from (match-mbox-from-line first-line))
+      => (lambda (m) ; special case check on first line for mbox files
+           (out (read-line port mime-line-length-limit)
+                (kons-from "%from" (car m)
+                           (kons-from "%date" (cadr m) knil))
+                0)))
+     (else
+      (out first-line knil 0)))))
+
+;;> @subsubsubsection{@scheme{(mime-headers->list [source])}}
+;;> Return an alist of the MIME headers from source with headers all
+;;> downcased.
+
+(define (mime-headers->list . o)
+  (reverse
+   (apply
+    mime-header-fold
+    (lambda (h v acc) (cons (cons (string-downcase h) v) acc))
+    '()
+    o)))
+
+(define (mime-split-name+value s)
+  (let ((i (string-char-index s #\=)))
+    (if i
+      (cons (string-downcase (string-trim-white-space (substring s 0 i)))
+            (if (= i (string-length s))
+              ""
+              (if (eqv? #\" (string-ref s (+ i 1)))
+                (substring s (+ i 2) (- (string-length s) 1))
+                (substring s (+ i 1) (string-length s)))))
+      (cons (string-downcase (string-trim-white-space s)) ""))))
+
+;;> @subsubsubsection{@scheme{(mime-parse-content-type str)}}
+;;> Parses @var{str} as a Content-Type style-value returning the list
+;;> @scheme{(type (attr . val) ...)}.
+
+;;> @example{
+;;> (mime-parse-content-type "text/html; CHARSET=UTF-8; filename=index.html")
+;;> }
+
+(define (mime-parse-content-type str)
+  (map mime-split-name+value (string-split str #\;)))
+
+;;> @subsubsubsection{@scheme{(mime-decode-header str)}}
+;;> Replace all occurrences of RFC1522 =?ENC?...?= escapes in @var{str} with
+;;> the appropriate decoded and charset converted value.
+
+(define (mime-decode-header str)
+  (let* ((len (string-length str))
+         (limit (- len 8))) ; need at least 8 chars: "=?Q?X??="
+    (let lp ((i 0) (from 0) (res '()))
+      (if (>= i limit)
+        (string-concatenate (reverse (cons (substring str from len) res)))
+        (if (and (eqv? #\= (string-ref str i))
+                 (eqv? #\? (string-ref str (+ i 1))))
+          (let* ((j (string-char-index str #\? (+ i 3)))
+                 (k (string-char-index str #\? (+ j 3))))
+            (if (and j k (< (+ k 1) len)
+                     (eqv? #\? (string-ref str (+ j 2)))
+                     (memq (string-ref str (+ j 1)) '(#\Q #\B #\q #\b))
+                     (eqv? #\= (string-ref str (+ k 1))))
+              (let ((decode (if (memq (string-ref str (+ j 1)) '(#\Q #\q))
+                               quoted-printable-decode-string
+                               base64-decode-string))
+                    (cset (substring str (+ i 2) j))
+                    (content (substring str (+ j 3) k))
+                    (k2 (+ k 2)))
+                (lp k2 k2 (cons (ces-convert (decode content) cset)
+                                (cons (substring str from i) res))))
+              (lp (+ i 2) from res)))
+          (lp (+ i 1) from res))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; message parsing
+
+(define (mime-read-to-boundary port boundary next final)
+  (let ((final-boundary (and boundary (string-append boundary "--"))))
+    (let lp ((res '()))
+      (let ((line (read-line port mime-line-length-limit)))
+        (cond
+         ((or (eof-object? line) (equal? line final-boundary))
+          (final (string-concatenate (reverse res)
+                                     (call-with-output-string newline))))
+         ((equal? line boundary)
+          (next (string-concatenate (reverse res)
+                                    (call-with-output-string newline))))
+         (else
+          (lp (cons line res))))))))
+
+(define (mime-convert-part str cte enc)
+  (let ((str (cond
+              ((and (string? cte) (string-ci=? cte "quoted-printable"))
+               (quoted-printable-decode-string str))
+              ((and (string? cte) (string-ci=? cte "base64"))
+               (base64-decode-string str))
+              (else
+               str))))
+    (if (string? enc) (ces-convert str enc) str)))
+
+(define (mime-read-part port cte enc boundary next final)
+  (mime-read-to-boundary
+   port boundary
+   (lambda (x) (next (mime-convert-part x cte enc)))
+   (lambda (x) (final (mime-convert-part x cte enc)))))
+
+;;> @subsubsection{RFC2045 MIME Encoding}
+
+;;> @subsubsubsection{@scheme{(mime-message-fold src kons knil [start end headers])}}
+;;> Performs a fold operation on the given string or port @var{src} as a
+;;> MIME body corresponding to the headers give in @var{headers}.  @var{kons}
+;;> is called on the successive values:
+;;>
+;;> @schemeblock{(kons parent-headers part-headers part-body accumulator)}
+;;>
+;;> where @var{part-headers} are the headers for the given MIME part (the
+;;> original headers for single-part MIME), @var{part-body} is the
+;;> appropriately decoded and charset-converted body of the message,
+;;> and the @var{accumulator} begins with @var{knil}.
+
+(define (mime-message-fold src kons init-seed . o)
+  (let ((port (if (string? src) (open-input-string src) src)))
+    (let ((kons-start
+           (if (pair? o) (car o) (lambda (headers seed) '())))
+          (kons-end
+           (if (and (pair? o) (pair? (cdr o)))
+               (car (cdr o))
+               (lambda (headers parent-seed seed)
+                 `((mime (^ ,@headers)
+                         ,@(if (pair? seed) (reverse seed) seed))
+                   ,@parent-seed))))
+          (headers
+           (if (and (pair? o) (pair? (cdr o)) (pair? (cdr (cdr o))))
+               (car (cdr (cdr o)))
+               (mime-headers->list port))))
+      (let tfold ((parent-headers '())
+                  (headers headers)
+                  (seed init-seed)
+                  (boundary #f)
+                  (next (lambda (x) x))
+                  (final (lambda (x) x)))
+        (let* ((ctype (mime-parse-content-type
+                       (mime-ref headers "Content-Type" "text/plain")))
+               (type (string-trim-white-space (caar ctype)))
+               (enc (string-trim-white-space
+                     (or (mime-ref ctype "charset")
+                         (mime-ref headers "charset" "ASCII"))))
+               (cte (string-trim-white-space
+                     (or (mime-ref headers "Content-Transfer-Encoding")
+                         (mime-ref headers "Encoding" "7-bit")))))
+          (cond
+           ((and (string-ci=? type "multipart/")
+                 (mime-ref ctype "boundary"))
+            => (lambda (boundary2)
+                 (let ((boundary2 (string-append "--" boundary2)))
+                   ;; skip preamble
+                   (mime-read-to-boundary port boundary2 (lambda (x) x) (lambda (x) x))
+                   (let lp ((part-seed (kons-start headers seed)))
+                     (let ((part-headers (mime-headers->list port)))
+                       (tfold parent-headers part-headers
+                              part-seed boundary2
+                              lp
+                              (lambda (x)
+                                ;; skip epilogue
+                                (if boundary
+                                    (mime-read-to-boundary port boundary
+                                                           (lambda (x) x) (lambda (x) x)))
+                                (next (kons-end headers seed x)))
+                              ))))))
+           (else
+            (mime-read-part
+             port cte enc boundary
+             (lambda (x) (next (kons parent-headers headers x seed)))
+             (lambda (x) (final (kons parent-headers headers x seed)))))))))))
+
+;;> @subsubsubsection{@scheme{(mime-message->sxml [src])}}
+;;> 
+;;> Parse the given source as a MIME message and return
+;;> the result as an SXML object of the form:
+;;> @scheme{(mime (^ (header . value) ...) parts ...)}.
+
+(define (mime-message->sxml . o)
+  (car
+   (apply
+    mime-message-fold
+    (if (pair? o) (car o) (current-input-port))
+    (lambda (parent-headers headers body seed)
+      `((mime (^ ,@headers) ,body) ,@seed))
+    '()
+    (lambda (headers seed) '())
+    (lambda (headers parent-seed seed)
+      `((mime (^ ,@headers)
+              ,@(if (pair? seed) (reverse seed) seed))
+        ,@parent-seed))
+    (if (pair? o) (cdr o) '()))))

lib/chibi/mime.sld

@@ -0,0 +1,7 @@
+
+(define-library (chibi mime)
+  (export mime-ref assoc-ref mime-header-fold mime-headers->list
+          mime-parse-content-type mime-decode-header
+          mime-message-fold mime-message->sxml)
+  (import (scheme) (chibi base64) (chibi quoted-printable) (chibi io))
+  (include "mime.scm"))

lib/chibi/modules.scm

@@ -0,0 +1,143 @@
+;; modules.scm -- module introspection utilities
+;; Copyright (c) 2011 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> Module introspection library.
+
+(define (file->sexp-list file)
+  (call-with-input-file file
+    (lambda (in)
+      (let lp ((res '()))
+        (let ((x (read in)))
+          (if (eof-object? x)
+              (reverse res)
+              (lp (cons x res))))))))
+
+(define (module? x)
+  (and (vector? x) (>= (vector-length x) 4) (list? (vector-ref x 0))))
+
+(define (module-ast mod) (vector-ref mod 3))
+(define (module-ast-set! mod x) (vector-set! mod 3 x))
+
+(define (module-name mod)
+  (let lp ((ls *modules*))
+    (and (pair? ls)
+         (if (eq? mod (cdar ls))
+             (caar ls)
+             (lp (cdr ls))))))
+
+(define (module-dir mod)
+  (let ((name (module-name mod)))
+    (if (member name '((scheme) (meta)))
+        ""
+        (module-name-prefix name))))
+
+(define (module-metas mod metas)
+  (let ((mod (if (module? mod) mod (find-module mod))))
+    (let lp ((ls (module-meta-data mod)) (res '()))
+      (cond
+       ((not (pair? ls)) (reverse res))
+       ((and (pair? (car ls)) (memq (caar ls) metas))
+        (lp (cdr ls) (append (reverse (cdar ls)) res)))
+       (else (lp (cdr ls) res))))))
+
+(define (module-includes mod)
+  (let* ((mod (if (module? mod) mod (find-module mod)))
+         (dir (module-dir mod)))
+    (define (module-file f)
+      (find-module-file (string-append dir f)))
+    (map module-file (module-metas mod '(include)))))
+
+(define (module-shared-includes mod)
+  (let* ((mod (if (module? mod) mod (find-module mod)))
+         (dir (module-dir mod)))
+    (define (module-file f)
+      (find-module-file (string-append dir f ".stub")))
+    (let lp ((ls (module-metas mod '(include-shared))) (res '()))
+      (cond ((null? ls) (reverse res))
+            ((module-file (car ls)) => (lambda (x) (lp (cdr ls) (cons x res))))
+            (else (lp (cdr ls) res))))))
+
+(define (analyze-module-source name mod recursive?)
+  (let ((env (module-env mod))
+        (dir (module-dir mod)))
+    (define (include-source file)
+      (cond ((find-module-file (string-append dir file))
+             => (lambda (x) (cons 'body (file->sexp-list x))))
+            (else (error "couldn't find include" file))))
+    (let lp ((ls (module-meta-data mod)) (res '()))
+      (cond
+       ((not (pair? ls))
+        (reverse res))
+       (else
+        (case (and (pair? (car ls)) (caar ls))
+          ((import import-immutable)
+           (for-each
+            (lambda (m)
+              (let* ((mod2-name+imports (resolve-import m))
+                     (mod2-name (car mod2-name+imports)))
+                (if recursive?
+                    (analyze-module mod2-name #t))))
+            (cdar ls))
+           (lp (cdr ls) res))
+          ((include)
+           (lp (append (map include-source (cdar ls)) (cdr ls)) res))
+          ((body)
+           (let lp2 ((ls2 (cdar ls)) (res res))
+             (cond
+              ((pair? ls2)
+               (lp2 (cdr ls2) (cons (analyze (car ls2) env) res)))
+              (else
+               (lp (cdr ls) res)))))
+          (else
+           (lp (cdr ls) res))))))))
+
+(define (analyze-module name . o)
+  (let ((recursive? (and (pair? o) (car o)))
+        (res (load-module name)))
+    (if (not (module-ast res))
+        (module-ast-set! res (analyze-module-source name res recursive?)))
+    res))
+
+(define (module-ref mod var-name . o)
+  (let ((cell (env-cell (module-env (if (module? mod) mod (load-module mod)))
+                        var-name)))
+    (if cell
+        (cdr cell)
+        (if (pair? o) (car o) (error "no binding in module" mod var-name)))))
+
+(define (module-contains? mod var-name)
+  (and (env-cell (module-env (if (module? mod) mod (load-module mod))) var-name)
+       #t))
+
+(define (module-defines? name mod var-name)
+  (if (not (module-ast mod))
+      (module-ast-set! mod (analyze-module-source name mod #f)))
+  (let lp ((ls (module-ast mod)))
+    (and (pair? ls)
+         (or (and (set? (car ls))
+                  (eq? var-name (ref-name (set-var (car ls)))))
+             (lp (cdr ls))))))
+
+(define (containing-module x)
+  (let lp1 ((ls (reverse *modules*)))
+    (and (pair? ls)
+         (let ((env (module-env (cdar ls))))
+           (let lp2 ((e-ls (env-exports env)))
+             (if (null? e-ls)
+                 (lp1 (cdr ls))
+                 (let ((cell (env-cell env (car e-ls))))
+                   (if (and (eq? x (cdr cell))
+                            (module-defines? (caar ls) (cdar ls) (car cell)))
+                       (car ls)
+                       (lp2 (cdr e-ls))))))))))
+
+(define (procedure-analysis x)
+  (let ((mod (containing-module x)))
+    (and mod
+         (let lp ((ls (module-ast (analyze-module (car mod)))))
+           (and (pair? ls)
+                (if (and (set? (car ls))
+                         (eq? (procedure-name x) (ref-name (set-var (car ls)))))
+                    (set-value (car ls))
+                    (lp (cdr ls))))))))

lib/chibi/modules.sld

@@ -0,0 +1,8 @@
+
+(define-library (chibi modules)
+  (export module-name module-dir module-includes module-shared-includes
+          module-ast module-ast-set! module-ref module-contains?
+          analyze-module containing-module load-module module-exports
+          module-name->file procedure-analysis)
+  (import (scheme) (meta) (chibi ast))
+  (include "modules.scm"))

lib/chibi/net.scm

@@ -0,0 +1,101 @@
+;; Copyright (c) 2010-2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> @subsubsubsection{@scheme{(get-address-info host service [addrinfo])}}
+
+;;> Create and return a new addrinfo structure for the given host
+;;> and service.  @var{host} should be a string and @var{service} a
+;;> string or integer.  The optional @var{addrinfo} defaults to
+;;> a TCP/IP stream setting.
+
+(define (get-address-info host service . o)
+  (%get-address-info host
+                     (if (integer? service) (number->string service) service)
+                     (if (and (pair? o) (car o))
+                         (car o)
+                         (make-address-info address-family/inet
+                                            socket-type/stream
+                                            ip-proto/tcp))))
+
+;;> Opens a client net connection to @var{host}, a string,
+;;> on port @var{service}, which can be a string such as
+;;> @scheme{"http"} or an integer.  Returns a list of three
+;;> values on success - the socket, an input port, and an
+;;> output port - or @scheme{#f} on failure.
+
+(define (open-net-io host service)
+  (let lp ((addr (get-address-info host service)))
+    (if (not addr)
+        (error "couldn't find address" host service)
+        (let ((sock (socket (address-info-family addr)
+                            (address-info-socket-type addr)
+                            (address-info-protocol addr))))
+          (if (negative? sock)
+              (lp (address-info-next addr))
+              (cond
+               ((negative?
+                 (connect sock
+                          (address-info-address addr)
+                          (address-info-address-length addr)))
+                (lp (address-info-next addr)))
+               (else
+                (cond-expand
+                 (threads (set-file-descriptor-flags! sock open/non-block))
+                 (else #f))
+                (list (open-input-file-descriptor sock #t)
+                      (open-output-file-descriptor sock #t)))))))))
+
+;;> Convenience wrapper around @scheme{open-net-io}, opens
+;;> the connection then calls @var{proc} with two arguments,
+;;> the input port and the output port connected to the
+;;> service, then closes the connection.  Returns the result
+;;> of @var{proc}.  Raises an error if a connection can't
+;;> be made.
+
+(define (with-net-io host service proc)
+  (let ((io (open-net-io host service)))
+    (if (not (pair? io))
+        (error "couldn't find address" host service)
+        (let ((res (proc (cadr io) (caddr io))))
+          (close-input-port (cadr io))
+          (close-output-port (caddr io))
+          (close-file-descriptor (car io))
+          res))))
+
+;;> @subsubsubsection{@scheme{(make-listener-socket addrinfo [max-conn])}}
+
+;;> Convenience wrapper to call socket, bind and listen to return
+;;> a socket suitable for accepting connections on the given
+;;> @var{addrinfo}.  @var{max-conn} is the maximum number of pending
+;;> connections, and defaults to 128.  Automatically specifies
+;;> @scheme{socket-opt/reuseaddr}.
+
+(define (make-listener-socket addrinfo . o)
+  (let* ((max-connections (if (pair? o) (car o) 128))
+         (sock (socket (address-info-family addrinfo)
+                       (address-info-socket-type addrinfo)
+                       (address-info-protocol addrinfo))))
+    (cond
+     ((not sock)
+      (error "couldn't create socket for: " addrinfo))
+     ((not (set-socket-option! sock level/socket socket-opt/reuseaddr 1))
+      (error "couldn't set the socket to be reusable" addrinfo))
+     ((not (bind sock
+                 (address-info-address addrinfo)
+                 (address-info-address-length addrinfo)))
+      (close-file-descriptor sock)
+      (error "couldn't bind socket" sock addrinfo))
+     ((not (listen sock max-connections))
+      (close-file-descriptor sock)
+      (error "couldn't listen on socket" sock addrinfo))
+     (else
+      sock))))
+
+;;> Returns the socket option of the given @var{name} for @var{socket}.
+;;> @var{socket} should be a file descriptor, level the constant
+;;> @scheme{level/socket}, and name one of the constants beginning with
+;;> "socket-opt/".
+
+(define (get-socket-option socket level name)
+  (let ((res (getsockopt socket level name)))
+    (and (pair? res) (car res))))

lib/chibi/net.sld

@@ -0,0 +1,18 @@
+
+(define-library (chibi net)
+  (export sockaddr? address-info? get-address-info make-address-info
+          socket connect bind accept listen
+          with-net-io open-net-io make-listener-socket
+          address-info-family address-info-socket-type address-info-protocol
+          address-info-address address-info-address-length address-info-next
+          address-family/unix address-family/inet
+          socket-type/stream socket-type/datagram socket-type/raw
+          ip-proto/tcp ip-proto/udp
+          get-socket-option set-socket-option! level/socket
+          socket-opt/debug socket-opt/broadcast socket-opt/reuseaddr
+          socket-opt/keepalive socket-opt/oobinline socket-opt/sndbuf
+          socket-opt/rcvbuf socket-opt/dontroute socket-opt/rcvlowat
+          socket-opt/sndlowat)
+  (import (scheme) (chibi filesystem))
+  (include-shared "net")
+  (include "net.scm"))

lib/chibi/net.stub

@@ -0,0 +1,89 @@
+
+(c-system-include "sys/types.h")
+(c-system-include "sys/socket.h")
+(c-system-include "netinet/in.h")
+(c-system-include "netdb.h")
+
+(define-c-int-type socklen_t)
+
+(define-c-struct sockaddr
+  predicate:   sockaddr?)
+
+(define-c-struct addrinfo
+  constructor: (make-address-info ai_family ai_socktype ai_protocol)
+  finalizer: freeaddrinfo
+  predicate: address-info?
+  (int              ai_family    address-info-family)
+  (int              ai_socktype  address-info-socket-type)
+  (int              ai_protocol  address-info-protocol)
+  ((link sockaddr)  ai_addr      address-info-address)
+  (size_t           ai_addrlen   address-info-address-length)
+  ((link addrinfo)  ai_next      address-info-next))
+
+;;> The addrinfo struct accessors.
+;;/
+
+(define-c errno (%get-address-info getaddrinfo)
+  (string string (maybe-null addrinfo) (result free addrinfo)))
+
+;;> Bind a name to a socket.
+
+(define-c errno bind (fileno sockaddr int))
+
+;;> Listen on a socket.
+
+(define-c sexp (listen "sexp_listen")
+  ((value ctx sexp) (value self sexp) sexp sexp))
+
+;;> Accept a connection on a socket.
+
+(define-c sexp (accept "sexp_accept")
+  ((value ctx sexp) (value self sexp) fileno sockaddr int))
+
+;;> Create an endpoint for communication.
+
+(define-c fileno socket (int int int))
+
+;;> Initiate a connection on a socket.
+
+(define-c int connect (fileno sockaddr int))
+
+(define-c-const int (address-family/unix "AF_UNIX"))
+(define-c-const int (address-family/inet "AF_INET"))
+(define-c-const int (socket-type/stream "SOCK_STREAM"))
+(define-c-const int (socket-type/datagram "SOCK_DGRAM"))
+(define-c-const int (socket-type/raw "SOCK_RAW"))
+(define-c-const int (ip-proto/tcp "IPPROTO_TCP"))
+(define-c-const int (ip-proto/udp "IPPROTO_UDP"))
+
+;;> The constants for the addrinfo struct.
+;;/
+
+(c-include "accept.c")
+
+(define-c errno getsockopt
+  (fileno int int (result int) (result (value (sizeof int) socklen_t))))
+
+;;> Set an option for the given socket.  For example, to make the
+;;> address reusable:
+;;> @scheme{(set-socket-option! sock level/socket socket-opt/reuseaddr 1)}
+
+(define-c errno (set-socket-option! "setsockopt")
+  (fileno int int (pointer int) (value (sizeof int) socklen_t)))
+
+(define-c-const int (level/socket "SOL_SOCKET"))
+
+(define-c-const int (socket-opt/debug "SO_DEBUG"))
+(define-c-const int (socket-opt/broadcast "SO_BROADCAST"))
+(define-c-const int (socket-opt/reuseaddr "SO_REUSEADDR"))
+(define-c-const int (socket-opt/keepalive "SO_KEEPALIVE"))
+(define-c-const int (socket-opt/oobinline "SO_OOBINLINE"))
+(define-c-const int (socket-opt/sndbuf "SO_SNDBUF"))
+(define-c-const int (socket-opt/rcvbuf "SO_RCVBUF"))
+(define-c-const int (socket-opt/dontroute "SO_DONTROUTE"))
+(define-c-const int (socket-opt/rcvlowat "SO_RCVLOWAT"))
+(define-c-const int (socket-opt/sndlowat "SO_SNDLOWAT"))
+
+;;> The constants for the @scheme{get-socket-option} and
+;;> @scheme{set-socket-option!}.
+;;/

lib/chibi/net/http.scm

@@ -0,0 +1,180 @@
+;; http.scm -- http client
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; string utils
+
+(define (string-char-index str c . o)
+  (let ((start (if (pair? o) (car o) 0))
+        (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str))))
+    (let lp ((i start))
+      (cond
+       ((= i end) #f)
+       ((eq? c (string-ref str i)) i)
+       (else (lp (+ i 1)))))))
+
+(define (string-split str ch)
+  (let ((len (string-length str)))
+    (let lp ((i 0) (res '()))
+      (let ((j (string-char-index str ch i)))
+        (if j
+            (lp (+ j 1) (cons (substring str i j) res))
+            (reverse (cons (substring str i len) res)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; client utils
+
+(define http-user-agent "chibi")
+
+(define http-redirect-limit 10)
+(define http-chunked-buffer-size 4096)
+(define http-chunked-size-limit 409600)
+
+(define (string-scan str ch . o)
+  (let ((start (if (pair? o) (car o) 0))
+        (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str))))
+    (let lp ((i start))
+      (and (< i end)
+           (if (eqv? ch (string-ref str i))
+               i
+               (lp (+ i 1)))))))
+
+(define (http-parse-response line)
+  (let* ((len (string-length line))
+         (i (or (string-scan line #\space 0 len) len))
+         (j (or (string-scan line #\space (+ i 1) len) len))
+         (n (and (< i j) (string->number (substring line (+ i 1) j)))))
+    (if (not (integer? n))
+        (error "bad response" line i j)
+        (list (substring line 0 i)
+              n
+              (if (>= j len) "" (substring line (+ j 1) len))))))
+
+(define (http-wrap-chunked-input-port in)
+  (define (read-chunk in)
+    (let* ((line (read-line in))
+           (n (and (string? line) (string->number line 16))))
+      (display "read-chunk ") (write line) (newline)
+      (cond
+       ((not (and (integer? n) (<= 0 n http-chunked-size-limit)))
+        (error "invalid chunked size line" line))
+       ((zero? n) "")
+       (else (read-string n in)))))
+  (make-generated-input-port
+   (lambda () (read-chunk in))))
+
+(define (http-get/raw url in-headers limit)
+  (if (<= limit 0)
+      (error "http-get: redirect limit reached" url)
+      (let* ((uri (if (uri? url) url (string->uri url)))
+             (host (and uri (uri-host uri))))
+        (if (not host)
+            (error "invalid url" url)
+            (let* ((io (open-net-io
+                        host
+                        (or (uri-port uri)
+                            (if (eq? 'https (uri-scheme uri)) 443 80))))
+                   (in (car io))
+                   (out (car (cdr io))))
+              (display "GET " out)
+              (display (or (uri-path uri) "/") out)
+              (display " HTTP/1.0\r\n" out)
+              (display "Host: " out) (display host out) (display "\r\n" out)
+              (cond
+               ((not (mime-ref in-headers "user-agent"))
+                (display "User-Agent: " out)
+                (display http-user-agent out)
+                (display "\r\n" out)))
+              (for-each
+               (lambda (x)
+                 (display (car x) out)  (display ": " out)
+                 (display (cdr x) out) (display "\r\n" out))
+               in-headers)
+              (display "Connection: close\r\n\r\n" out)
+              (flush-output out)
+              (let* ((resp (http-parse-response (read-line in)))
+                     (headers (mime-headers->list in))
+                     (status (quotient (cadr resp) 100)))
+                (case status
+                  ((2)
+                   (let ((enc (mime-ref headers "transfer-encoding")))
+                     (cond
+                      ((equal? enc "chunked")
+                       (http-wrap-chunked-input-port in))
+                      (else
+                       in))))
+                  ((3)
+                   (close-input-port in)
+                   (close-output-port out)
+                   (let ((url2 (mime-ref headers "location")))
+                     (if url2
+                         (http-get/raw url2 in-headers (- limit 1))
+                         (error "redirect with no location header"))))
+                  (else
+                   (close-input-port in)
+                   (close-output-port out)
+                   (error "couldn't retrieve url" url resp)))))))))
+
+(define (http-get url . headers)
+  (http-get/raw url
+                (if (pair? headers) (car headers) '())
+                http-redirect-limit))
+
+(define (call-with-input-url url proc)
+  (let* ((p (http-get url))
+         (res (proc p)))
+    (close-input-port p)
+    res))
+
+(define (with-input-from-url url thunk)
+  (let ((p (http-get url)))
+    (let ((res (parameterize ((current-input-port p)) (thunk))))
+      (close-input-port p)
+      res)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; server utils
+
+;; read and parse a request line
+(define (http-parse-request . o)
+  (let ((line (string-split
+               (read-line (if (pair? o) (car o) (current-input-port)) 4096))))
+    (cons (string->symbol (car line)) (cdr line))))
+
+;; Parse a form body with a given URI and MIME headers (as parsed with
+;; mime-headers->list).  Returns an alist of (name . value) for every
+;; query or form parameter.
+(define (http-parse-form uri headers . o)
+  (let* ((in (if (pair? o) (car o) (current-input-port)))
+         (type (mime-ref headers
+                         "content-type"
+                         "application/x-www-form-urlencoded")) 
+         (query0 (or (uri-query (if (string? uri) (string->uri uri) uri)) '()))
+         (query (if (string? query0) (uri-query->alist query0) query0)))
+    (cond
+     ((string-ci=? "multipart/" type)
+      (let ((mime (mime-message->sxml in headers)))
+        (append
+         (let lp ((ls (cddr mime))
+                  (res '()))
+           (cond
+            ((null? ls)
+             res)
+            ((and (pair? (car ls))
+                  (eq? 'mime (caar ls))
+                  (pair? (cdar ls))
+                  (pair? (cadar ls))
+                  (memq (caadar ls) '(^ @)))
+             (let* ((disp0 (mime-ref (cdadar ls) "content-disposition" ""))
+                    (disp (mime-parse-content-type disp0))
+                    (name (mime-ref disp "name")))
+               (if name
+                   (lp (cdr ls) (cons (cons name (caddar ls)) res))
+                   (lp (cdr ls) res))))
+            (else
+             (lp (cdr ls) res))))
+         query)))
+     (else
+      query))))
+

lib/chibi/net/http.sld

@@ -0,0 +1,7 @@
+
+(define-library (chibi net http)
+  (export http-get call-with-input-url with-input-from-url
+          http-parse-request http-parse-form)
+  (import (scheme) (srfi 39) (chibi net) (chibi io)
+          (chibi uri) (chibi mime))
+  (include "http.scm"))

lib/chibi/net/server.scm

@@ -0,0 +1,62 @@
+;; Copyright (c) 2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define default-max-requests 10000)
+
+(define (run-net-server listener-or-addr handler . o)
+  (let* ((listener (if (integer? listener-or-addr)
+                       listener-or-addr
+                       (make-listener-socket listener-or-addr)))
+         (max-requests (if (pair? o) (car o) default-max-requests))
+         (debug? (and (pair? o) (pair? (cdr o)))))
+    (define (log-error msg . args)
+      (display msg (current-error-port))
+      (for-each
+       (lambda (x)
+         (write-char #\space (current-error-port))
+         (display x (current-error-port)))
+       args)
+      (newline (current-error-port)))
+    (define (log-debug msg . args)
+      (if debug? (apply log-error msg args)))
+    (define (run sock addr count)
+      (log-debug "net-server: accepting request:" count)
+      (let ((ports
+             (guard (exn
+                     (else
+                      (log-error "net-server: couldn't create port:" sock)
+                      (close-file-descriptor sock)))
+               (cons (open-input-file-descriptor sock)
+                     (open-output-file-descriptor sock)))))
+        (guard (exn
+                (else (log-error "net-server: error in request:" count)
+                      (print-exception exn)
+                      (print-stack-trace exn)
+                      (close-input-port (car ports))
+                      (close-output-port (cdr ports))
+                      (close-file-descriptor sock)))
+          (handler (car ports) (cdr ports) sock addr)
+          (close-input-port (car ports))
+          (close-output-port (cdr ports))
+          (close-file-descriptor sock)))
+      (log-debug "net-server: finished: " count))
+    (let ((requests 0))
+      (let serve ((count 0))
+        (if (>= requests  max-requests)
+            (thread-yield!)
+            (let* ((addr (get-address-info "127.0.0.1" "8000"))
+                   (sock (accept listener
+                                 (address-info-address addr)
+                                 (address-info-address-length addr))))
+              (cond
+               ((not sock)
+                (serve count))
+               (else
+                (thread-start!
+                 (make-thread
+                  (lambda ()
+                    (set! requests (+ requests 1))
+                    (run sock addr count)
+                    (set! requests (- requests 1)))
+                  "net-client"))
+                (serve (+ 1 count))))))))))

lib/chibi/net/server.sld

@@ -0,0 +1,5 @@
+
+(define-library (chibi net server)
+  (import (scheme) (chibi net) (chibi filesystem) (srfi 18))
+  (export run-net-server)
+  (include "server.scm"))

lib/chibi/optimize.scm

@@ -0,0 +1,52 @@
+
+(define (register-lambda-optimization! proc . o)
+  (define (optimize ast)
+    (match ast
+      (($ Set ref value)
+       (make-set ref (optimize value)))
+      (($ Cnd test pass fail)
+       (make-cnd (optimize test) (optimize pass) (optimize fail)))
+      (($ Seq ls)
+       (make-seq (map optimize ls)))
+      (($ Lam name params body)
+       (lambda-body-set! ast (optimize body))
+       (proc ast))
+      ((app ...)
+       (map optimize app))
+      (else
+       ast)))
+  (register-optimization! optimize (if (pair? o) (car o) 600)))
+
+(define (replace-references ast name lam new)
+  (let replace ((x ast))
+    (match x
+      (($ Ref _ (n . (? lambda? f)))
+       (if (and (eq? n name) (eq? f lam))
+           new
+           x))
+      (($ Set ref value)
+       (make-set (replace ref) (replace value)))
+      (($ Cnd test pass fail)
+       (make-cnd (replace test) (replace pass) (replace fail)))
+      (($ Seq ls)
+       (make-seq (map replace ls)))
+      (($ Lam name params body)
+       (lambda-body-set! x (replace body))
+       x)
+      ((app ...)
+       (map replace app))
+      (else
+       x))))
+
+(define (join-seq a b)
+  (make-seq (append (if (seq? a) (seq-ls a) (list a))
+                    (if (seq? b) (seq-ls b) (list b)))))
+
+(define (dotted-tail ls)
+  (if (pair? ls) (dotted-tail (cdr ls)) ls))
+
+(define (fold-every kons knil ls)
+  (if (null? ls)
+      knil
+      (let ((knil (kons (car ls) knil)))
+        (and knil (fold-every kons knil (cdr ls))))))

lib/chibi/optimize.sld

@@ -0,0 +1,7 @@
+
+(define-library (chibi optimize)
+  (import (scheme) (chibi ast) (chibi match) (srfi 1))
+  (export register-lambda-optimization!
+          replace-references
+          fold-every join-seq dotted-tail)
+  (include "optimize.scm"))

lib/chibi/optimize/profile.c

@@ -0,0 +1,19 @@
+/*  profile.c -- low-level utilities for VM profiling         */
+/*  Copyright (c) 2011 Alex Shinn.  All rights reserved.      */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+
+static sexp sexp_increment_cdr (sexp ctx, sexp self, sexp_sint_t n, sexp pair) {
+  sexp_assert_type(ctx, sexp_pairp, SEXP_PAIR, pair);
+  sexp_cdr(pair) = sexp_make_fixnum(1 + sexp_unbox_fixnum(sexp_cdr(pair)));
+  return SEXP_VOID;
+}
+
+sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, sexp_abi_identifier_t abi) {
+  if (!(sexp_version_compatible(ctx, version, sexp_version)
+        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
+    return sexp_global(ctx, SEXP_G_ABI_ERROR);
+  sexp_define_foreign(ctx, env, "increment-cdr!", 1, sexp_increment_cdr);
+  return SEXP_VOID;
+}

lib/chibi/optimize/profile.scm

@@ -0,0 +1,65 @@
+
+(define (ref=? a b)
+  (or (eq? a b)
+      (and (ref? a) (ref? b)
+           (eq? (ref-name a) (ref-name b))
+           (eq? (car (ref-cell a)) (car (ref-cell b)))
+           (eq? (cdr (ref-cell a)) (cdr (ref-cell b))))))
+
+(define profile-cells '())
+
+(define (profile-get-cell f)
+  (or (assoc f profile-cells ref=?)
+      (let ((cell (cons f 0)))
+        (set! profile-cells (cons cell profile-cells))
+        cell)))
+
+(define (profile-reset)
+  (for-each (lambda (x) (set-cdr! x 0)) profile-cells))
+
+(define (profile-report)
+  (define (report-op op)
+    (match op
+      (($ Ref name (p . (and ($ Lam lam-name) f)))
+       (write name)
+       (cond
+        ((not (eq? p name))
+         (display " ")
+         (write p)))
+       (cond
+        ((lambda-source f)
+         (display " [") (write (lambda-source f)) (display "]"))))
+      (($ Ref name (_ . f))
+       (write name) (display " (") (write f) (display ")"))
+      (else
+       (write op))))
+  (let ((ls (filter (lambda (x) (> (cdr x) 0))
+                    profile-cells)))
+    (for-each (lambda (x)
+                (write (cdr x)) (display ": ")
+                (report-op (car x)) (newline))
+              (sort ls > cdr))))
+
+(define (optimize-profile ast)
+  (let-syntax ((opt (syntax-rules () ((opt x) (optimize-profile x)))))
+    (match ast
+      (($ Set ref value)
+       (set-value-set! ast (opt value))
+       ast)
+      (($ Cnd test pass fail)
+       (make-cnd (opt test) (opt pass) (opt fail)))
+      (($ Seq ls)
+       (make-seq (map optimize-profile ls)))
+      (($ Lam name params body)
+       (lambda-body-set! ast (opt body))
+       ast)
+      ((($ Ref name cell) args ...)
+       (make-seq (list (list increment-cdr!
+                             (make-lit (profile-get-cell (car ast))))
+                       (cons (car ast) (map optimize-profile args)))))
+      ((app ...)
+       (map optimize-profile app))
+      (else
+       ast))))
+
+(register-lambda-optimization! optimize-profile)

lib/chibi/optimize/profile.sld

@@ -0,0 +1,7 @@
+
+(define-library (chibi optimize profile)
+  (export optimize-profile increment-cdr! profile-reset profile-report)
+  (import (scheme) (srfi 1) (srfi 69) (srfi 95)
+          (chibi ast) (chibi match) (chibi optimize))
+  (include-shared "profile")
+  (include "profile.scm"))

lib/chibi/optimize/rest.c

@@ -0,0 +1,35 @@
+/*  rest.c -- low-level utilities for VM rest optimization    */
+/*  Copyright (c) 2011 Alex Shinn.  All rights reserved.      */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+
+static sexp sexp_num_parameters (sexp ctx, sexp self, sexp_sint_t n) {
+  return sexp_stack_data(sexp_context_stack(ctx))[sexp_context_last_fp(ctx)];
+}
+
+struct sexp_opcode_struct local_ref_op =
+  {SEXP_OPC_GENERIC, SEXP_OP_LOCAL_REF, 1, 8, 0, (sexp)"local-ref", SEXP_VOID,
+   NULL, NULL, sexp_make_fixnum(SEXP_OBJECT), sexp_make_fixnum(SEXP_FIXNUM),
+   0, 0, NULL};
+
+static sexp copy_opcode (sexp ctx, struct sexp_opcode_struct *op) {
+  sexp res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE);
+  memcpy(&(res->value), op, sizeof(op[0]));
+  return res;
+}
+
+sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, sexp_abi_identifier_t abi) {
+  sexp_gc_var2(name, op);
+  if (!(sexp_version_compatible(ctx, version, sexp_version)
+        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
+    return sexp_global(ctx, SEXP_G_ABI_ERROR);
+  sexp_gc_preserve2(ctx, name, op);
+  sexp_define_foreign(ctx, env, "num-parameters", 0, sexp_num_parameters);
+  op = copy_opcode(ctx, &local_ref_op);
+  sexp_opcode_name(op) = sexp_c_string(ctx, (char*)sexp_opcode_name(op), -1);
+  name = sexp_string_to_symbol(ctx, sexp_opcode_name(op));
+  sexp_env_define(ctx, env, name, op);
+  sexp_gc_release2(ctx);
+  return SEXP_VOID;
+}

lib/chibi/optimize/rest.scm

@@ -0,0 +1,126 @@
+
+(define (optimize-rest ast)
+  (cond
+   ((and (lambda? ast)
+         (not (list? (lambda-params ast)))
+         (rest-parameter-cdrs ast))
+    => (lambda (cdrs)
+         (replace-rest-destructuring-with-stack-references
+          (length (lambda-params ast))
+          ast
+          cdrs)))
+   (else
+    ast)))
+
+(define safe-primitives (list car cdr null? pair?))
+
+(define (adjust-cdrs cdrs f params args)
+  (filter-map
+   (lambda (p a)
+     (match a
+       (((? (lambda (op) (eq? op cdr))) ($ Ref name (_ . (? lambda? lam))))
+        (let ((x (find (lambda (r)
+                         (and (eq? name (car r)) (eq? lam (cadr r))))
+                       cdrs)))
+          (and x (list p f (+ (caddr x) 1)))))
+       (($ Cnd
+           ((? (lambda (op) (eq? op pair?))) ($ Ref name (_ . (? lambda? lam))))
+           ((? (lambda (op) (eq? op cdr))) ($ Ref name (_ . (? lambda? lam))))
+           (or () ($ Lit ())))
+        (let ((x (find (lambda (r)
+                         (and (eq? name (car r)) (eq? lam (cadr r))))
+                       cdrs)))
+          (and x (list p f (+ (caddr x) 1.0)))))
+       (else #f)))
+   params
+   args))
+
+(define (rest-parameter-cdrs ast)
+  (let analyze ((x (lambda-body ast))
+                (cdrs (list (list (dotted-tail (lambda-params ast)) ast 0)))
+                (safe? #t))
+    (define (recurse x cdrs) (analyze x cdrs safe?))
+    (match x
+      (($ Ref name (_ . (? lambda? f)))
+       (and (not (any (lambda (r) (and (eq? name (car r)) (eq? f (cadr r)))) cdrs))
+            cdrs))
+      (($ Set ref value)
+       (and (recurse ref cdrs) (recurse value cdrs)))
+      (($ Cnd test pass fail)
+       (fold-every recurse cdrs (list test pass fail)))
+      (($ Seq ls)
+       (fold-every recurse cdrs ls))
+      (($ Lam name params body)
+       (analyze body cdrs #f))
+      (((and ($ Lam _ (params ...) body) f) args ...)
+       (let ((cdrs (fold-every recurse cdrs args)))
+         (and (equal? (length params) (length args))
+              (recurse body (append (adjust-cdrs cdrs f params args) cdrs)))))
+      (((? opcode? op) ($ Ref _ (_ . (? lambda?))))
+       (if (and safe? (memq op safe-primitives))
+           cdrs
+           (recurse (cadr x) cdrs)))
+      ((app ...)
+       (fold-every recurse cdrs app))
+      (else
+       cdrs))))
+
+(define (replace-rest-destructuring-with-stack-references base ast cdrs)
+  (define (rename p)
+    (make-syntactic-closure
+     (current-environment) '() (strip-syntactic-closures p)))
+  (define (replace-param x)
+    (match x
+      (($ Cnd test pass fail)
+       (make-cnd (replace-param test)
+                 (replace-param pass)
+                 (replace-param fail)))
+      (($ Seq ls)
+       (let ((ls (map replace-param ls)))
+         (and ls (make-seq ls))))
+      (((? opcode? op) ($ Ref name (_ . (? lambda? f))))
+       (let ((r (and (memq op safe-primitives)
+                     (find (lambda (r) (and (eq? name (car r)) (eq? f (cadr r))))
+                           cdrs))))
+         (cond
+          ((not r)
+           x)
+          ((eq? op car)
+           `(,local-ref ,(+ 1 (inexact->exact (caddr r)))))
+          ((eq? op cdr)
+           (make-lit '()))
+          ((eq? op pair?)
+           `(,> (,num-parameters) ,(+ base (inexact->exact (caddr r)))))
+          ((eq? op null?)
+           `(,<= (,num-parameters) ,(+ base (inexact->exact (caddr r)))))
+          (else
+           x))))
+      (($ Set ref value)
+       #f)
+      (($ Lam name params body)
+       #f)
+      ((app ...)
+       #f)
+      (else
+       x)))
+  (lambda-body-set!
+   ast
+   (let replace ((x (lambda-body ast)))
+     (match x
+       ((($ Lam name (params ...) body) args ...)
+        (let* ((locals (map replace-param args))
+               (names (map rename params))
+               (refs (map (lambda (name) (make-ref name (cons name ast))) names)))
+          (let ((res (fold (lambda (p new res)
+                             (replace-references res p (car x) new))
+                           (replace body)
+                           params
+                           refs)))
+            (lambda-locals-set! ast (append names (lambda-locals ast)))
+            (join-seq (make-seq (map make-set refs locals))
+                      res))))
+       (else
+        x))))
+  ast)
+
+(register-lambda-optimization! optimize-rest)

lib/chibi/optimize/rest.sld

@@ -0,0 +1,6 @@
+
+(define-library (chibi optimize rest)
+  (export optimize-rest rest-parameter-cdrs num-parameters local-ref)
+  (import (scheme) (srfi 1) (chibi ast) (chibi match) (chibi optimize))
+  (include-shared "rest")
+  (include "rest.scm"))

lib/chibi/pathname.scm

@@ -0,0 +1,212 @@
+;; Copyright (c) 2009-2011 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> A general, non-host-specific pathname library.
+
+(define (string-scan c str . o)
+  (let ((limit (string-length str)))
+    (let lp ((i (if (pair? o) (car o) 0)))
+      (cond ((>= i limit) #f)
+            ((eqv? c (string-ref str i)) i)
+            (else (lp (+ i 1)))))))
+
+(define (string-scan-right c str . o)
+  (let lp ((i (if (pair? o) (car o) (- (string-length str) 1))))
+    (cond ((negative? i) #f)
+          ((eqv? c (string-ref str i)) i)
+          (else (lp (- i 1))))))
+
+(define (string-skip c str . o)
+  (let ((limit (string-length str)))
+    (let lp ((i (if (pair? o) (car o) 0)))
+      (cond ((>= i limit) #f)
+            ((not (eqv? c (string-ref str i))) i)
+            (else (lp (+ i 1)))))))
+
+(define (string-skip-right c str . o)
+  (let lp ((i (if (pair? o) (car o) (- (string-length str) 1))))
+    (cond ((negative? i) #f)
+          ((not (eqv? c (string-ref str i))) i)
+          (else (lp (- i 1))))))
+
+;; POSIX basename
+;; (define (path-strip-directory path)
+;;   (if (string=? path "")
+;;       path
+;;       (let ((end (string-skip-right #\/ path)))
+;;         (if (not end)
+;;             "/"
+;;             (let ((start (string-scan-right #\/ path (- end 1))))
+;;               (substring path (if start (+ start 1) 0) (+ end 1)))))))
+
+;;> Returns just the basename of @var{path}, with any directory
+;;> removed.  If @var{path} does not contain a directory separator,
+;;> return the whole @var{path}.  If @var{path} ends in a directory
+;;> separator (i.e. path is a directory) return the empty string.
+
+;; GNU basename
+(define (path-strip-directory path)
+  (if (string=? path "")
+      path
+      (let ((len (string-length path)))
+        (if (eqv? #\/ (string-ref path (- len 1)))
+            ""
+            (let ((slash (string-scan-right #\/ path)))
+              (if (not slash)
+                  path
+                  (substring path (+ slash 1) len)))))))
+
+;;> Returns just the directory of @var{path}.
+;;> If @var{path} is relative, return @scheme{"."}.
+
+(define (path-directory path)
+  (if (string=? path "")
+      "."
+      (let ((end (string-skip-right #\/ path)))
+        (if (not end)
+            "/"
+            (let ((start (string-scan-right #\/ path (- end 1))))
+              (if (not start)
+                  "."
+                  (let ((start (string-skip-right #\/ path start)))
+                    (if (not start) "/" (substring path 0 (+ start 1))))))))))
+
+(define (path-extension-pos path) (string-scan-right #\. path))
+
+;;> Returns the rightmost extension of @var{path}, not including
+;;> the @scheme{"."}.  If there is no extension, returns @scheme{#f}.
+
+(define (path-extension path)
+  (let ((i (path-extension-pos path)))
+    (and i
+         (let ((start (+ i 1)) (end (string-length path)))
+           (and (< start end) (substring path start end))))))
+
+;;> Returns @var{path} with the extension, if any, removed,
+;;> along with the @scheme{"."}.
+
+(define (path-strip-extension path)
+  (let ((i (path-extension-pos path)))
+    (if (and i (< (+ i 1) (string-length path)))
+        (substring path 0 i)
+        path)))
+
+;;> Returns @var{path} with the extension, if any, replaced
+;;> with @var{ext}.
+
+(define (path-replace-extension path ext)
+  (string-append (path-strip-extension path) "." ext))
+
+;;> Returns @scheme{#t} iff @var{path} is an absolute path.
+
+(define (path-absolute? path)
+  (and (not (string=? "" path)) (eqv? #\/ (string-ref path 0))))
+
+;;> Returns @scheme{#t} iff @var{path} is a relative path.
+
+(define (path-relative? path) (not (path-absolute? path)))
+
+;; This looks big and hairy, but it's mutation-free and guarantees:
+;;   (string=? s (path-normalize s))  <=>  (eq? s (path-normalize s))
+;; i.e. fast and simple for already normalized paths.
+
+;;> Returns a normalized version of path, with duplicate directory
+;;> separators removed and "/./" and "x/../" references removed.
+;;> Does not take symbolic links into account - this is meant to
+;;> be abstract and applicable to paths on remote systems and in
+;;> URIs.  Returns @var{path} itself if @var{path} is already
+;;> normalized.
+
+(define (path-normalize path)
+  (let* ((len (string-length path)) (len-1 (- len 1)))
+    (define (collect i j res)
+      (if (>= i j) res (cons (substring path i j) res)))
+    (define (finish i res)
+      (if (zero? i)
+          path
+          (apply string-append (reverse (collect i len res)))))
+    ;; loop invariants:
+    ;;   - res is a list such that (string-concatenate-reverse res)
+    ;;     is always the normalized string up to j
+    ;;   - the tail of the string from j onward can be concatenated to
+    ;;     the above value to get a partially normalized path referring
+    ;;     to the same location as the original path
+    (define (inside i j res)
+      (if (>= j len)
+          (finish i res)
+          (if (eqv? #\/ (string-ref path j))
+              (boundary i (+ j 1) res)
+              (inside i (+ j 1) res))))
+    (define (boundary i j res)
+      (if (>= j len-1)
+          (finish i res)
+          (case (string-ref path j)
+            ((#\.)
+             (case (string-ref path (+ j 1))
+               ((#\.)
+                (if (or (>= j (- len 2)) (eqv? #\/ (string-ref path (+ j 2))))
+                    (if (>= i (- j 1))
+                        (if (null? res)
+                            (backup j "" '())
+                            (backup j (car res) (cdr res)))
+                        (backup j (substring path i j) res))
+                    (inside i (+ j 2) res)))
+               ((#\/)
+                (if (= i j)
+                    (boundary (+ j 2) (+ j 2) res)
+                    (let ((s (substring path i j)))
+                      (boundary (+ j 2) (+ j 2) (cons s res)))))
+               (else (inside i (+ j 1) res))))
+            ((#\/) (boundary (+ j 1) (+ j 1) (collect i j res)))
+            (else (inside i (+ j 1) res)))))
+    (define (backup j s res)
+      (let ((pos (+ j 3)))
+        (cond
+         ;; case 1: we're reduced to accumulating parents of the cwd
+         ((or (string=? s "/..") (string=? s ".."))
+          (boundary pos pos (cons "/.." (cons s res))))
+         ;; case 2: the string isn't a component itself, skip it
+         ((or (string=? s "") (string=? s ".") (string=? s "/"))
+          (if (pair? res)
+              (backup j (car res) (cdr res))
+              (boundary pos pos (if (string=? s "/") '("/") '("..")))))
+         ;; case3: just take the directory of the string
+         (else
+          (let ((d (path-directory s)))
+            (cond
+             ((string=? d "/")
+              (boundary pos pos (if (null? res) '("/") res)))
+             ((string=? d ".")
+              (boundary pos pos res))
+             (else (boundary pos pos (cons "/" (cons d res))))))))))
+    ;; start with boundary if abs path, otherwise inside
+    (if (zero? len)
+        path
+        ((if (eqv? #\/ (string-ref path 0)) boundary inside) 0 1 '()))))
+
+;;> Return a new string representing the path where each of @var{args}
+;;> is a path component, separated with the directory separator.
+
+(define (make-path . args)
+  (define (x->string x)
+    (cond ((string? x) x)
+          ((symbol? x) (symbol->string x))
+          ((number? x) (number->string x))
+          (else (error "not a valid path component" x))))
+  (define (trim-trailing-slash s)
+    (let ((i (string-skip-right #\/ s)))
+      (if i (substring s 0 (+ i 1)) "")))
+  (if (null? args)
+      ""
+      (let ((start (trim-trailing-slash (x->string (car args)))))
+        (let lp ((ls (cdr args))
+                 (res (if (string=? "" start) '() (list start))))
+          (cond
+           ((null? ls)
+            (apply string-append (reverse res)))
+           ((pair? (car ls))
+            (lp (append (car ls) (cdr ls)) res))
+           (else
+            (let ((x (trim-trailing-slash (x->string (car ls)))))
+              (lp (cdr ls)
+                  (if (string=? x "") res (cons x (cons "/" res)))))))))))

lib/chibi/pathname.sld

@@ -0,0 +1,7 @@
+
+(define-library (chibi pathname)
+  (export path-strip-directory path-directory ;; path-extension-pos
+          path-extension path-strip-extension path-replace-extension
+          path-absolute? path-relative? path-normalize make-path)
+  (import (scheme))
+  (include "pathname.scm"))

lib/chibi/process.scm

@@ -0,0 +1,108 @@
+
+(cond-expand
+ (bsd
+  (define (process-command-line pid)
+    (let ((res (%process-command-line pid)))
+      ;; TODO: get command-line arguments
+      (if (string? res) (list res) res))))
+ (else
+  (define (process-command-line pid)
+    (call-with-current-continuation
+     (lambda (return)
+       (with-exception-handler
+        (lambda (exn) (return #f))
+        (lambda ()
+          (let ((file (string-append "/proc/" (number->string pid) "/cmdline")))
+            (call-with-input-file file
+              (lambda (in)
+                (let lp ((arg '()) (res '()))
+                  (let ((ch (read-char in)))
+                    (if (or (eof-object? ch) (eqv? (char->integer ch) 0))
+                        (let ((res (cons (list->string (reverse arg)) res))
+                              (ch2 (peek-char in)))
+                          (if (or (eof-object? ch2)
+                                  (eqv? (char->integer ch2) 0))
+                              (reverse res)
+                              (lp '() res)))
+                        (lp (cons ch arg) res))))))))))))))
+
+(define (process-running? pid . o)
+  (let ((cmdline (process-command-line pid)))
+    (and (pair? cmdline)
+         (or (null? o)
+             (not (car o))
+             (equal? (car o) (car cmdline))))))
+
+(define (system cmd . args)
+  (let ((pid (fork)))
+    (cond
+     ((zero? pid)
+      (let* ((res (execute cmd (cons cmd args)))
+             (err (current-error-port)))
+        ;; we only arrive here if execute fails
+        (cond
+         ((output-port? err)
+          (display "ERROR: couldn't execute: " (current-error-port))
+          (write cmd (current-error-port))
+          (newline (current-error-port))))
+        (exit 1)))
+     (else
+      (waitpid pid 0)))))
+
+(define (call-with-process-io command proc)
+  (let ((command-ls (if (string? command) (string-split command) command))
+        (in-pipe (open-pipe))
+        (out-pipe (open-pipe))
+        (err-pipe (open-pipe)))
+    (and in-pipe out-pipe err-pipe
+         (let ((pid (fork)))
+           (cond
+            ((not pid)
+             (error "couldn't fork"))
+            ((zero? pid)  ;; child
+             (close-file-descriptor (car in-pipe))
+             (close-file-descriptor (car out-pipe))
+             (close-file-descriptor (car err-pipe))
+             (duplicate-file-descriptor-to (cadr in-pipe) 0)
+             (duplicate-file-descriptor-to (cadr out-pipe) 1)
+             (duplicate-file-descriptor-to (cadr err-pipe) 2)
+             (close-file-descriptor (cadr in-pipe))
+             (close-file-descriptor (cadr out-pipe))
+             (close-file-descriptor (cadr err-pipe))
+             (execute (car command-ls) command-ls))
+            (else         ;; parent
+             (close-file-descriptor (car in-pipe))
+             (close-file-descriptor (cadr out-pipe))
+             (close-file-descriptor (cadr err-pipe))
+             (proc pid
+                   (open-output-file-descriptor (cadr in-pipe))
+                   (open-input-file-descriptor (car out-pipe))
+                   (open-input-file-descriptor (car err-pipe)))))))))
+
+(define (process->string str)
+  (call-with-process-io
+   str
+   (lambda (pid in out err)
+     (close-output-port in)
+     (let ((res (port->string out)))
+       (waitpid pid 0)
+       res))))
+
+(define (process->output+error str)
+  (call-with-process-io
+   str
+   (lambda (pid in out err)
+     (close-output-port in)
+     (let ((out (port->string out))
+           (err (port->string err)))
+       (waitpid pid 0)
+       (list out err)))))
+
+(define (process->string-list str)
+  (call-with-process-io
+   str
+   (lambda (pid in out err)
+     (close-output-port in)
+     (let ((res (port->string-list out)))
+       (waitpid pid 0)
+       res))))

lib/chibi/process.sld

@@ -0,0 +1,22 @@
+
+(define-library (chibi process)
+  (export exit sleep alarm fork kill execute waitpid system
+          process-command-line  process-running?
+          set-signal-action! make-signal-set
+          signal-set? signal-set-contains?
+          signal-set-fill! signal-set-add! signal-set-delete!
+          current-signal-mask current-process-id parent-process-id
+          signal-mask-block! signal-mask-unblock! signal-mask-set!
+          signal/hang-up    signal/interrupt   signal/quit
+          signal/illegal    signal/abort       signal/fpe
+          signal/kill       signal/segv        signal/pipe
+          signal/alarm      signal/term        signal/user1
+          signal/user2      signal/child       signal/continue
+          signal/stop       signal/tty-stop    signal/tty-input
+          signal/tty-output wait/no-hang
+          call-with-process-io
+          process->string process->string-list process->output+error)
+  (import (scheme) (chibi io) (chibi strings) (chibi filesystem))
+  (cond-expand (threads (import (srfi 18))) (else #f))
+  (include-shared "process")
+  (include "process.scm"))

lib/chibi/process.stub

@@ -0,0 +1,141 @@
+
+;;> An interface to spawning processes and sending and
+;;> receiving signals between processes.
+
+(c-system-include "sys/types.h")
+(c-system-include "sys/wait.h")
+(c-system-include "signal.h")
+(c-system-include "unistd.h")
+
+;;> The siginfo_t struct is used to return info about the status,
+;;> process and user info of a called signal handler.
+
+(define-c-type siginfo_t
+  predicate: signal-info?
+  (int      si_signo    signal-number)
+  (int      si_errno    signal-error-number)
+  (int      si_code     signal-code)
+  (pid_t    si_pid      signal-pid)
+  (uid_t    si_uid      signal-uid)
+  (int      si_status   signal-status)
+  ;;(clock_t  si_utime    signal-user-time)
+  ;;(clock_t  si_stime    signal-system-time)
+  )
+
+(define-c-const int (signal/hang-up "SIGHUP"))
+(define-c-const int (signal/interrupt "SIGINT"))
+(define-c-const int (signal/quit "SIGQUIT"))
+(define-c-const int (signal/illegal "SIGILL"))
+(define-c-const int (signal/abort "SIGABRT"))
+(define-c-const int (signal/fpe "SIGFPE"))
+(define-c-const int (signal/kill "SIGKILL"))
+(define-c-const int (signal/segv "SIGSEGV"))
+(define-c-const int (signal/pipe "SIGPIPE"))
+(define-c-const int (signal/alarm "SIGALRM"))
+(define-c-const int (signal/term "SIGTERM"))
+(define-c-const int (signal/user1"SIGUSR1"))
+(define-c-const int (signal/user2 "SIGUSR2"))
+(define-c-const int (signal/child "SIGCHLD"))
+(define-c-const int (signal/continue "SIGCONT"))
+(define-c-const int (signal/stop "SIGSTOP"))
+(define-c-const int (signal/tty-stop "SIGTSTP"))
+(define-c-const int (signal/tty-input "SIGTTIN"))
+(define-c-const int (signal/tty-output "SIGTTOU"))
+
+(c-include "signal.c")
+
+;;> @subsubsubsection{@rawcode{(set-signal-action! signal handler)}}
+
+;;> Sets the signal handler for @var{signal} to @var{handler}
+;;> and returns the old handler.  @var{handler} should be a procedure
+;;> of one argument, the signal number, the value @scheme{#t} for
+;;> the default signal handler, or @scheme{#f} for no handler.
+
+;;> Signal handlers are queued run in a dedicated thread after the
+;;> system handler has returned.
+
+(define-c sexp (set-signal-action! "sexp_set_signal_action")
+  ((value ctx sexp) (value self sexp) sexp sexp))
+
+;;> The sigset_t struct represents a set of signals for masking.
+
+(define-c-type sigset_t
+  predicate: signal-set?)
+
+(define-c errno (make-signal-set "sigemptyset") ((pointer result sigset_t)))
+(define-c errno (signal-set-fill! "sigfillset") ((pointer sigset_t)))
+(define-c errno (signal-set-add! "sigaddset") ((pointer sigset_t) int))
+(define-c errno (signal-set-delete! "sigdelset") ((pointer sigset_t) int))
+(define-c boolean (signal-set-contains? "sigismember") ((pointer sigset_t) int))
+
+(define-c errno (signal-mask-block! "sigprocmask")
+  ((value SIG_BLOCK int) (pointer sigset_t) (pointer value NULL sigset_t)))
+(define-c errno (signal-mask-unblock! "sigprocmask")
+  ((value SIG_UNBLOCK int) (pointer sigset_t) (pointer value NULL sigset_t)))
+(define-c errno (signal-mask-set! "sigprocmask")
+  ((value SIG_SETMASK int) (pointer sigset_t) (pointer value NULL sigset_t)))
+(define-c errno (current-signal-mask "sigprocmask")
+  ((value SIG_BLOCK int) (pointer value NULL sigset_t) (pointer result sigset_t)))
+
+;;> Send a @var{signal/alarm} signal to the current process
+;;> after @var{unsigned-int} seconds have elapsed.
+
+(define-c unsigned-int alarm (unsigned-int))
+
+;;> Suspend the current process for @var{unsigned-int} seconds.
+;;> See @hyperlink["http://srfi.schemers.org/srfi-18/srfi-18.html"]{SRFI-18}
+;;> @scheme{thread-sleep!} for a light-weight sleep for only the
+;;> current thread.
+
+(define-c unsigned-int sleep (unsigned-int))
+
+;;> Fork the current process.  Returns @rawcode{0} for the newly
+;;> created process, and the process id of the new process for
+;;> the parent.
+
+(define-c pid_t fork ())
+
+(define-c-const int (wait/no-hang "WNOHANG"))
+
+;;(define-c pid_t wait ((result int)))
+
+;;> @subsubsubsection{@rawcode{(waitpid pid options)}}
+
+;;> Wait on the process @var{pid}, or any child process if @var{pid}
+;;> is @rawcode{-1}.  @var{options} should be 0, or @var{wait/no-hang}
+;;> to return immediately if no processes have reported status.  Returns
+;;> a list whose first element is the actual @var{pid} reporting, and
+;;> the second element is the integer status.
+
+(define-c pid_t waitpid (int (result int) int))
+
+;;> Send a signal to the given process.
+
+(define-c errno kill (int int))
+
+;;(define-c errno raise (int))
+
+;;> Exits the current process immediately.  Finalizers are not run.
+
+(define-c void exit (int))
+
+;;> Replace the current process with the given command.  Finalizers
+;;> are not run.
+
+(define-c int (execute execvp) (string (array string)))
+
+;;> Returns the current process id.
+
+(define-c pid_t (current-process-id getpid) ())
+
+;;> Returns the parent process id.
+
+(define-c pid_t (parent-process-id getppid) ())
+
+(cond-expand
+ (bsd
+  (define-c sexp (%process-command-line sexp_pid_cmdline)
+    ((value ctx sexp) int)))
+ (else #f))
+
+(c-init "sexp_init_signals(ctx, env);")

lib/chibi/quoted-printable.scm

@@ -0,0 +1,157 @@
+;; quoted-printable.scm -- RFC2045 implementation
+;; Copyright (c) 2005-2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;; Procedure: quoted-printable-encode-string str [start-col max-col]
+;;   Return a quoted-printable encoded representation of string
+;;   according to the official standard as described in RFC2045.
+;;
+;;   ? and _ are always encoded for compatibility with RFC1522 encoding,
+;;   and soft newlines are inserted as necessary to keep each lines
+;;   length less than MAX-COL (default 76).  The starting column may be
+;;   overridden with START-COL (default 0).
+
+;; Procedure: quoted-printable-decode-string str [mime?]
+;;   Return a quoted-printable decoded representation of string.  If
+;;   MIME? is specified and true, _ will be decoded as as space in
+;;   accordance with RFC1522.  No errors will be raised on invalid
+;;   input.
+
+;; Procedure: quoted-printable-encode [port start-col max-col]
+;; Procedure: quoted-printable-decode [port start-col max-col]
+;;   Variations of the above which read and write to ports.
+
+;; Procedure: quoted-printable-encode-header enc str [start-col max-col]
+;;   Return a quoted-printable encoded representation of string as
+;;   above, wrapped in =?ENC?Q?...?= as per RFC1522, split across
+;;   multiple MIME-header lines as needed to keep each lines length less
+;;   than MAX-COL.  The string is encoded as is, and the encoding ENC is
+;;   just used for the prefix, i.e. you are responsible for ensuring STR
+;;   is already encoded according to ENC.
+
+;; Example:
+
+;; (define (mime-encode-header header value charset)
+;;   (let ((prefix (string-append header ": "))
+;;         (str (ces-convert value "UTF8" charset)))
+;;     (string-append
+;;      prefix
+;;      (quoted-printable-encode-header charset str (string-length prefix)))))
+
+;; This API is backwards compatible with the Gauche library
+;; rfc.quoted-printable.
+
+(define *default-max-col* 76)
+
+;; Allow for RFC1522 quoting for headers by always escaping ? and _
+(define (qp-encode str start-col max-col separator)
+  (define (hex i) (integer->char (+ i (if (<= i 9) 48 55))))
+  (let ((end (string-length str))
+        (buf (make-string max-col)))
+    (let lp ((i 0) (col start-col) (res '()))
+      (cond
+        ((= i end)
+         (if (pair? res)
+           (string-concatenate (reverse (cons (substring buf 0 col) res))
+                               separator)
+           (substring buf start-col col)))
+        ((>= col (- max-col 3))
+         (lp i 0 (cons (substring buf (if (pair? res) 0 start-col) col) res)))
+        (else
+         (let ((c (char->integer (string-ref str i))))
+           (cond
+             ((and (<= 33 c 126) (not (memq c '(61 63 95))))
+              (string-set! buf col (integer->char c))
+              (lp (+ i 1) (+ col 1) res))
+             (else
+              (string-set! buf col #\=)
+              (string-set! buf (+ col 1) (hex (arithmetic-shift c -4)))
+              (string-set! buf (+ col 2) (hex (bitwise-and c #b1111)))
+              (lp (+ i 1) (+ col 3) res)))))))))
+
+(define (quoted-printable-encode-string . o)
+  (let ((src (if (pair? o) (car o) (current-input-port)))
+        (start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0))
+        (max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)))
+                     (caddr o)
+                     *default-max-col*)))
+    (qp-encode (if (string? src) src (read-string #f src))
+               start-col max-col "=\r\n")))
+
+(define (quoted-printable-encode . o)
+  (display (apply (quoted-printable-encode-string o))))
+
+(define (quoted-printable-encode-header encoding . o)
+  (let ((src (if (pair? o) (car o) (current-input-port)))
+        (start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0))
+        (max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)))
+                     (caddr o)
+                     *default-max-col*))
+        (nl (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)) (pair? (cdddr o)))
+                (cadddr o)
+                "\r\n")))
+    (let* ((prefix (string-append "=?" encoding "?Q?"))
+           (prefix-length (+ 2 (string-length prefix)))
+           (separator (string-append "?=" nl "\t" prefix))
+           (effective-max-col (- max-col prefix-length)))
+      (string-append prefix
+                     (qp-encode (if (string? src) src (read-string #f src))
+                                start-col effective-max-col separator)
+                     "?="))))
+
+(define (quoted-printable-decode-string  . o)
+  (define (hex? c) (or (char-numeric? c) (<= 65 (char->integer c) 70)))
+  (define (unhex1 c)
+    (let ((i (char->integer c))) (if (>= i 65) (- i 55) (- i 48))))
+  (define (unhex c1 c2)
+    (integer->char (+ (arithmetic-shift (unhex1 c1) 4) (unhex1 c2))))
+  (let ((src (if (pair? o) (car o) (current-input-port)))
+        (mime-header? (and (pair? o) (pair? (cdr o)) (car (cdr o)))))
+    (let* ((str (if (string? src) src (read-string #f src)))
+           (end (string-length str)))
+      (call-with-output-string
+        (lambda (out)
+          (let lp ((i 0))
+            (cond
+             ((< i end)
+              (let ((c (string-ref str i)))
+                (case c
+                  ((#\=)                ; = escapes
+                   (cond
+                    ((< (+ i 2) end)
+                     (let ((c2 (string-ref str (+ i 1))))
+                       (cond
+                        ((eq? c2 #\newline) (lp (+ i 2)))
+                        ((eq? c2 #\return)
+                         (lp (if (eq? (string-ref str (+ i 2)) #\newline)
+                                 (+ i 3)
+                                 (+ i 2))))
+                        ((hex? c2)
+                         (let ((c3 (string-ref str (+ i 2))))
+                           (if (hex? c3) (write-char (unhex c2 c3) out))
+                           (lp (+ i 3))))
+                        (else (lp (+ i 3))))))))
+                  ((#\_)                ; maybe translate _ to space
+                   (write-char (if mime-header? #\space c) out)
+                   (lp (+ i 1)))
+                  ((#\space #\tab)      ; strip trailing whitespace
+                   (let lp2 ((j (+ i 1)))
+                     (cond
+                      ((not (= j end))
+                       (case (string-ref str j)
+                         ((#\space #\tab) (lp2 (+ j 1)))
+                         ((#\newline)
+                          (lp (+ j 1)))
+                         ((#\return)
+                          (let ((k (+ j 1)))
+                            (lp (if (and (< k end)
+                                         (eqv? #\newline (string-ref str k)))
+                                    (+ k 1) k))))
+                         (else (display (substring str i j) out) (lp j)))))))
+                  (else                 ; a literal char
+                   (write-char c out)
+                   (lp (+ i 1)))))))))))))
+
+(define (quoted-printable-decode . o)
+  (display (apply quoted-printable-decode-string o)))
+

lib/chibi/quoted-printable.sld

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

lib/chibi/repl.scm

@@ -0,0 +1,237 @@
+;; repl.scm - friendlier repl with line editing and signal handling
+;; Copyright (c) 2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> A user-friendly REPL with line editing and signal handling.
+;;> The default REPL provided by chibi-scheme is very minimal,
+;;> meant primarily to be small and work on any platform.  This
+;;> module provides an advanced REPL that handles vt100 line
+;;> editing and signal handling, so that C-c will interrupt a
+;;> computation and bring you back to the REPL prompt.  To use
+;;> this repl, run
+;;> @command{chibi-scheme -mchibi.repl -e'(repl)'}
+;;> from the command line or within Emacs.
+
+(define (with-signal-handler sig handler thunk)
+  (let ((old-handler #f))
+    (dynamic-wind
+      (lambda () (set! old-handler (set-signal-action! sig handler)))
+      thunk
+      (lambda () (set-signal-action! sig old-handler)))))
+
+(define (warn msg . args)
+  (let ((out (current-error-port)))
+    (display msg out)
+    (for-each (lambda (x) (write-char #\space out) (write x out)) args)
+    (newline out)))
+
+(define (write-to-string x)
+  (call-with-output-string (lambda (out) (write x out))))
+
+(define (buffer-complete-sexp? buf)
+  (call-with-input-string (buffer->string buf)
+    (lambda (in)
+      (let lp () (if (not (eof-object? (read/ss in))) (lp))))))
+
+(define module? vector?)
+(define (module-env mod) (vector-ref mod 1))
+
+(define (all-exports env)
+  (let lp ((env env) (res '()))
+    (if (not env)
+        res
+        (lp (environment-parent env) (append (env-exports env) res)))))
+
+(define (make-sexp-buffer-completer)
+  (buffer-make-completer
+   (lambda (buf word)
+     (let ((len (string-length word)))
+       (sort
+        (filter
+         (lambda (w)
+           (and (>= (string-length w) len)
+                (equal? word (substring w 0 len))))
+         (map symbol->string (all-exports (interaction-environment)))))))))
+
+;;> Runs an interactive REPL.  Repeatedly displays a prompt,
+;;> then Reads an expression, Evaluates the expression, Prints
+;;> the result then Loops.  Terminates when the end of input is
+;;> reached or the @scheme|{@exit}| command is given.
+;;>
+;;> Basic Emacs-style line editing with persistent history
+;;> completion is provided.  C-c can be used to interrupt the
+;;> current computation and drop back to the prompt.  The
+;;> following keyword arguments customize the REPL:
+;;>
+;;> @itemlist[
+;;> @item{@scheme{in:} - the input port (default @scheme{(current-input-port)})}
+;;> @item{@scheme{out:} - the output port (default @scheme{(current-output-port)})}
+;;> @item{@scheme{module:} - the initial module (default @scheme{(interaction-environment)})}
+;;> @item{@scheme{escape:} - the command escape character (default @scheme|{#\@}|)}
+;;> @item{@scheme{history:} - the initial command history}
+;;> @item{@scheme{history-file:} - the file to save history to (default ~/.chibi-repl-history)}
+;;> ]
+;;>
+;;> REPL commands in the style of @hyperlink["http://s48.org/"]{Scheme48}
+;;> are available to control out-of-band properties.  By default a command
+;;> is written as an identifier beginning with an "@"@"" character (which
+;;> would not be a portable identifier), but this can be customized with
+;;> the @scheme{escape:} keyword.  The following commands are available:
+;;>
+;;> @itemlist[
+;;> @item{@scheme|{@import <import-spec>}| - import the @var{<import-spec>} in the @scheme{interaction-environment}, useful if the @scheme{import} binding is not available}
+;;> @item{@scheme|{@import-only <import-spec>}| - replace the @scheme{interaction-environment} with the given @var{<import-spec>}}
+;;> @item{@scheme|{@in [<module>]}| - switch to @var{<module>}, or the @scheme{interaction-environment} if @var{<module>} is not specified}
+;;> @item{@scheme|{@meta <expr>}| - evaluate @var{<expr>} in the @scheme{(meta)} module}
+;;> @item{@scheme|{@meta-module-is <module>}| - switch the meta module to @var{<module>}}
+;;> @item{@scheme|{@exit}| - exit the REPL}
+;;> ]
+
+(define (repl . o)
+  (let* ((in (cond ((memq 'in: o) => cadr) (else (current-input-port))))
+         (out (cond ((memq 'out: o) => cadr) (else (current-output-port))))
+         (escape (cond ((memq 'escape: o) => cadr) (else #\@)))
+         (module (cond ((memq 'module: o) => cadr) (else #f)))
+         (env (if module
+                  (module-env
+                   (if (module? module) module (load-module module)))
+                  (interaction-environment)))
+         (history-file
+          (cond ((memq 'history-file: o) => cadr)
+                (else (string-append (get-environment-variable "HOME")
+                                     "/.chibi-repl-history"))))
+         (history
+          (cond ((memq 'history: o) => cadr)
+                (else
+                 (or (guard (exn (else #f))
+                       (list->history
+                        (call-with-input-file history-file read)))
+                     (make-history)))))
+         (raw? (cond ((memq 'raw?: o) => cadr)
+                     (else (member (get-environment-variable "TERM")
+                                   '("emacs" "dumb"))))))
+    (let lp ((module module)
+             (env env)
+             (meta-env (module-env (load-module '(meta)))))
+      (let* ((prompt
+              (string-append (if module (write-to-string module) "") "> "))
+             (line
+              (cond
+               (raw?
+                (display prompt out)
+                (flush-output out)
+                (read-line in))
+               (else
+                (edit-line in out
+                           'prompt: prompt
+                           'history: history
+                           'complete?: buffer-complete-sexp?
+                           'completion: (make-sexp-buffer-completer))))))
+        (cond
+         ((or (not line) (eof-object? line)))
+         ((equal? line "") (lp module env meta-env))
+         (else
+          (history-commit! history line)
+          (cond
+           ((and (> (string-length line) 0) (eqv? escape (string-ref line 0)))
+            (let meta ((env env)
+                       (line (substring line 1 (string-length line)))
+                       (continue lp))
+              (define (fail msg . args)
+                (apply warn msg args)
+                (continue module env meta-env))
+              (call-with-input-string line
+                (lambda (in)
+                  (let ((op (read/ss in)))
+                    (case op
+                      ((import import-only)
+                       (let* ((mod-name (read in))
+                              (mod+imps (eval `(resolve-import ',mod-name)
+                                              meta-env)))
+                         (if (pair? mod+imps)
+                             (let ((env (if (eq? op 'import-only)
+                                            (let ((env (make-environment)))
+                                              (interaction-environment env)
+                                              env)
+                                            env))
+                                   (imp-env
+                                    (vector-ref
+                                     (eval `(load-module ',(car mod+imps)) meta-env)
+                                     1)))
+                               (%import env imp-env (cdr mod+imps) #f)
+                               (continue module env meta-env))
+                             (fail "couldn't find module:" mod-name))))
+                      ((in)
+                       (let ((name (read/ss in)))
+                         (cond
+                          ((eof-object? name)
+                           (continue #f (interaction-environment) meta-env))
+                          ((eval `(load-module ',name) meta-env)
+                           => (lambda (m)
+                                (continue name (module-env m) meta-env)))
+                          (else
+                           (fail "couldn't find module:" name)))))
+                      ((meta config)
+                       (if (eq? op 'config)
+                           (display "Note: @config has been renamed @meta\n" out))
+                       (let ((expr (read/ss in)))
+                         (cond
+                          ((and
+                            (symbol? expr)
+                            (eqv? escape (string-ref (symbol->string expr) 0)))
+                           (meta meta-env
+                                 (substring line 6 (string-length line))
+                                 (lambda _ (continue module env meta-env))))
+                          (else
+                           (eval expr meta-env)
+                           (continue module env meta-env)))))
+                      ((meta-module-is)
+                       (let ((name (read/ss in)))
+                         (cond
+                          ((eval `(load-module ',name) meta-env)
+                           => (lambda (m) (lp module env (module-env m))))
+                          (else
+                           (fail "couldn't find module:" name)))))
+                      ((exit))
+                      (else
+                       (fail "unknown repl command:" op))))))))
+           (else
+            ;; The outer guard in the parent thread catches read
+            ;; errors and errors in the repl logic itself.
+            (guard (exn (else (print-exception exn (current-error-port))))
+              (let* ((expr (call-with-input-string line
+                             (lambda (in2)
+                               ;; Ugly wrapper to account for the
+                               ;; implicit state mutation implied by
+                               ;; the #!fold-case read syntax.
+                               (set-port-fold-case! in2 (port-fold-case? in))
+                               (let ((expr (read/ss in2)))
+                                 (set-port-fold-case! in (port-fold-case? in2))
+                                 expr))))
+                     (thread
+                      (make-thread
+                       (lambda ()
+                         ;; The inner guard in the child thread
+                         ;; catches errors from eval.
+                         (guard
+                             (exn
+                              (else (print-exception exn (current-output-port))))
+                           (let ((res (eval expr env)))
+                             (cond
+                              ((not (eq? res (if #f #f)))
+                               (write/ss res out)
+                               (newline out)))))))))
+                ;; If an interrupt occurs while the child thread is
+                ;; still running, terminate it, otherwise wait for it
+                ;; to complete.
+                (with-signal-handler
+                 signal/interrupt
+                 (lambda (n)
+                   (display "Interrupt\n" (current-error-port))
+                   (thread-terminate! thread))
+                 (lambda () (thread-join! (thread-start! thread))))))
+            ;; Loop whether there were errors or interrupts or not.
+            (lp module env meta-env)))))))
+    (if history-file
+        (call-with-output-file history-file
+          (lambda (out) (write (history->list history) out))))))

lib/chibi/repl.sld

@@ -0,0 +1,7 @@
+
+(define-library (chibi repl)
+  (export repl)
+  (import (scheme) (only (meta) load-module)
+          (chibi ast) (chibi io) (chibi process) (chibi term edit-line)
+          (srfi 1) (srfi 18) (srfi 38) (srfi 95) (srfi 98))
+  (include "repl.scm"))

lib/chibi/scribble.scm

@@ -0,0 +1,250 @@
+;; scribble.scm - scribble parsing
+;; Copyright (c) 2011 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> A library used for parsing "scribble" format, introduced
+;;> by @hyperlink["http://www.racket-lang.org/"]{Racket} and
+;;> the format used to write this manual.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; general character utils
+
+(define (char-mirror ch)
+  (case ch ((#\() #\)) ((#\[) #\]) ((#\{) #\}) ((#\<) #\>) (else ch)))
+
+(define (char-delimiter? ch)
+  (or (eof-object? ch) (char-whitespace? ch)
+      (memv ch '(#\( #\) #\[ #\] #\{ #\} #\" #\|))))
+
+(define (char-punctuation? ch)
+  (memv ch '(#\- #\+ #\! #\< #\> #\[ #\] #\|)))
+
+(define (char-digit ch) (- (char->integer ch) (char->integer #\0)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; list utils
+
+(define (drop ls n) (if (<= n 0) ls (drop (cdr ls) (- n 1))))
+
+(define (drop-while pred ls)
+  (if (or (null? ls) (not (pred (car ls)))) ls (drop-while pred (cdr ls))))
+
+(define (list-prefix? prefix ls)
+  (cond ((null? prefix) #t)
+        ((null? ls) #f)
+        ((equal? (car prefix) (car ls)) (list-prefix? (cdr prefix) (cdr ls)))
+        (else #f)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; scribble reader (standalone, don't use the native reader)
+
+(define scribble-dot (list "."))
+(define scribble-close (list ")"))
+
+(define (if-peek-char ch in pass fail)
+  (cond ((eqv? ch (peek-char in)) (read-char in) pass) (else fail)))
+
+(define (skip-line in)
+  (do ((c #f (read-char in))) ((or (eof-object? c) (eqv? c #\newline)))))
+
+(define (read-float-tail in acc)
+  (let lp ((res acc) (k 0.1))
+    (let ((ch (read-char in)))
+      (cond ((or (eof-object? ch) (char-delimiter? ch)) res)
+            ((char-numeric? ch) (lp (+ res (* k (char-digit ch))) (* k 0.1)))
+            (else (error "invalid numeric syntax"))))))
+
+(define (read-number in acc base)
+  (let lp ((acc acc))
+    (let ((ch (peek-char in)))
+      (cond
+       ((or (eof-object? ch) (char-delimiter? ch)) acc)
+       ((char-numeric? ch) (read-char in) (lp (+ (* acc base) (char-digit ch))))
+       ((eqv? #\. ch)
+        (read-char in)
+        (if (= base 10)
+            (begin (read-char in) (read-float-tail in (exact->inexact acc)))
+            (error "non-base-10 floating point")))
+       (else (error "invalid numeric syntax"))))))
+
+(define (read-escaped in terminal)
+  (let lp ((ls '()))
+    (let ((ch (read-char in)))
+      (cond
+       ((or (eof-object? ch) (eqv? ch terminal)) (list->string (reverse ls)))
+       ((eqv? ch #\\) (lp (cons (read-char in) ls)))
+       (else (lp (cons ch ls)))))))
+
+(define (read-symbol in ls)
+  (do ((ls ls (cons c ls)) (c (peek-char in) (peek-char in)))
+      ((char-delimiter? c) (string->symbol (list->string (reverse ls))))
+    (read-char in)))
+
+(define (scrib-read in)
+  (define ch (read-char in))
+  (cond
+   ((eof-object? ch) ch)
+   ((char-whitespace? ch) (scrib-read in))
+   (else
+    (case ch
+      ((#\( #\[ #\{)
+       (let lp ((res '()))
+         (let ((x (scrib-read in)))
+           (cond ((eof-object? x) (error "unterminated list" x))
+                 ((eq? x scribble-close) (reverse res))
+                 ((eq? x scribble-dot)
+                  (let ((y (scrib-read in)))
+                    (if (or (eof-object? y) (eq? y scribble-close))
+                        (error "unterminated dotted list")
+                        (let ((z (scrib-read in)))
+                          (if (not (eq? z scribble-close))
+                              (error "dot in non-terminal position in list" y z)
+                              (append (reverse res) y))))))
+                 (else (lp (cons x res)))))))
+      ((#\} #\] #\)) scribble-close)
+      ((#\.) (if (char-delimiter? (peek-char in)) scribble-dot (read-float-tail in 0.0)))
+      ((#\') (list 'quote (scrib-read in)))
+      ((#\`) (list 'quasiquote (scrib-read in)))
+      ((#\,) (list (if-peek-char #\@ in 'unquote-splicing 'unquote) (scrib-read in)))
+      ((#\@) (scribble-parse-escape in #\@))
+      ((#\;) (skip-line in) (scrib-read in))
+      ((#\|) (string->symbol (read-escaped in #\|)))
+      ((#\") (read-escaped in #\"))
+      ((#\+ #\-)
+       (cond ((char-numeric? (peek-char in))
+              ((if (eqv? ch #\+) + -) 0 (read-number in 0 10)))
+             (else (read-symbol in (list ch)))))
+      ((#\#)
+       (case (peek-char in)
+         ((#\t #\f) (eqv? (read-char in) #\t))
+         ((#\() (list->vector (scrib-read in)))
+         ((#\\)
+          (read-char in)
+          (if (char-alphabetic? (peek-char in))
+              (let ((name (scrib-read in)))
+                (case name
+                  ((space) #\space) ((newline) #\newline)
+                  (else (string-ref (symbol->string name) 0))))
+              (read-char in)))
+         (else (error "unknown # syntax"))))
+      (else
+       (if (char-numeric? ch)
+           (read-number in (char-digit ch) 10)
+           (read-symbol in (list ch))))))))
+
+(define (scribble-read in)
+  (let ((res (scrib-read in)))
+    (cond ((eq? res scribble-dot) (error "invalid . in source"))
+          ((eq? res scribble-close) (error "too many )'s"))
+          (else res))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; scribble parser
+
+(define (read-punctuation in)
+  (if (not (eqv? #\| (peek-char in)))
+      '()
+      (let lp ((ls '()))
+        (let ((c (peek-char in)))
+          (cond ((or (eof-object? c) (not(char-punctuation? c))) ls)
+                (else (lp (cons (char-mirror (read-char in)) ls))))))))
+
+(define (read-prefix-wrapper in)
+  (let lp ((wrap (lambda (x) x)))
+    (case (peek-char in)
+      ((#\') (read-char in) (lp (lambda (x) (wrap (list 'quote x)))))
+      ((#\`) (read-char in) (lp (lambda (x) (wrap (list 'quasiquote x)))))
+      ((#\,)
+       (read-char in)
+       (cond ((eqv? #\@ (peek-char in))
+              (read-char in)
+              (lp (lambda (x) (wrap (list 'unquote-splicing x)))))
+             (else (lp (lambda (x) (wrap (list 'unquote x)))))))
+      (else wrap))))
+
+(define (scribble-parse-escape in ec)
+  (define bracket-char #\[)
+  (define brace-char #\{)
+  (let* ((wrap (read-prefix-wrapper in))
+         (c (peek-char in))
+         (cmd (if (or (eqv? c bracket-char) (eqv? c brace-char)) '() (list (scribble-read in))))
+         (data? (eqv? (peek-char in) bracket-char))
+         (data (if data? (scribble-read in) '()))
+         (punc (read-punctuation in))
+         (body? (eqv? (peek-char in) brace-char))
+         (body (cond (body? (read-char in) (scribble-parse in punc ec)) (else '()))))
+    (wrap (if (or data? body?) (append cmd data body) (car cmd)))))
+
+(define (scribble-parse in . o)
+  (define init-punc (if (pair? o) (car o) '()))
+  (define escape-char (if (and (pair? o) (pair? (cdr o))) (cadr o) #\@))
+  (define comment-char #\;)
+  (define bracket-char #\[)
+  (define brace-char #\{)
+  (define close-bracket-char (char-mirror bracket-char))
+  (define close-brace-char (char-mirror brace-char))
+  (define (collect str res)
+    (if (pair? str) (cons (list->string (reverse str)) res) res))
+  (define (skip-space in)
+    (let ((ch (peek-char in)))
+      (cond ((char-whitespace? ch) (read-char in) (skip-space in))
+            ((eqv? ch #\;) (skip-line in) (skip-space in)))))
+  (define (tok str res punc depth)
+    (let ((c (read-char in)))
+      (cond
+        ((eof-object? c)
+         (if (zero? depth)
+             (reverse (collect str res))
+             (error "unterminated expression" punc)))
+        ((and (eqv? c escape-char) (list-prefix? punc str))
+         (let ((c (peek-char in)))
+           (cond
+            ((eof-object? c)
+             (tok str res punc depth))
+            ((char-whitespace? c)
+             (tok (cons c str) res punc depth))
+            ((eqv? c comment-char)
+             (read-char in)
+             (cond ((eqv? brace-char (peek-char in))
+                    (scribble-parse-escape in escape-char))
+                   (else
+                    (skip-line in)
+                    ;; (let lp ()
+                    ;;   (cond ((char-whitespace? (peek-char in)) (read-char in) (lp))))
+                    ))
+             (tok str res punc depth))
+            ((eqv? c #\|)
+             (read-char in)
+             (let lp ((ls (collect str res)))
+               (skip-space in)
+               (cond ((eqv? #\| (peek-char in)) (read-char in) (tok '() ls punc depth))
+                     (else (lp (cons (scribble-read in) ls))))))
+            (else
+             (let ((str (drop str (length punc)))
+                   (x (scribble-parse-escape in escape-char)))
+               (if (string? x)
+                   (tok (append (reverse (string->list x)) str) res punc depth)
+                   (tok '() (cons x (collect str res)) punc depth)))))))
+        ((eqv? c brace-char)
+         (tok (cons c str) res punc (+ depth 1)))
+        ((eqv? c close-brace-char)
+         (cond
+          ((zero? depth)
+           (let lp ((p punc) (ls '()))
+             (cond ((null? p)
+                    (reverse (collect str res)))
+                   ((not (eqv? (car p) (peek-char in)))
+                    (tok (append ls (cons c str)) res punc (- depth 1)))
+                   (else
+                    (lp (cdr p) (cons (read-char in) ls))))))
+          (else (tok (cons c str) res punc (- depth 1)))))
+        ((eqv? c #\newline)
+         (let* ((res (collect str res))
+                (res (if (and (null? res) (null? str))
+                         res
+                         (cons "\n" res))))
+           (tok '() res punc depth)))
+        (else
+         (tok (cons c str) res punc depth)))))
+  ;; begin
+  (tok '() '() init-punc 0))

lib/chibi/scribble.sld

@@ -0,0 +1,5 @@
+
+(define-library (chibi scribble)
+  (export scribble-parse scribble-read)
+  (import (scheme))
+  (include "scribble.scm"))

lib/chibi/signal.c

@@ -0,0 +1,124 @@
+/*  signal.c -- process signals interface                     */
+/*  Copyright (c) 2009-2011 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#define SEXP_MAX_SIGNUM 32
+
+static sexp sexp_signal_contexts[SEXP_MAX_SIGNUM];
+
+static struct sigaction call_sigaction, call_sigdefault, call_sigignore;
+
+static void sexp_call_sigaction (int signum, siginfo_t *info, void *uctx) {
+  sexp ctx;
+#if ! SEXP_USE_GREEN_THREADS
+  sexp sigctx, handler;
+  sexp_gc_var1(args);
+#endif
+  ctx = sexp_signal_contexts[signum];
+  if (ctx) {
+#if SEXP_USE_GREEN_THREADS
+    sexp_global(ctx, SEXP_G_THREADS_SIGNALS) =
+      (sexp) ((sexp_uint_t)sexp_global(ctx, SEXP_G_THREADS_SIGNALS)
+              | (sexp_uint_t)sexp_make_fixnum(1UL<<signum));
+#else
+    handler = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS),
+                              sexp_make_fixnum(signum));
+    if (sexp_applicablep(handler)) {
+      sigctx = sexp_make_child_context(ctx, NULL);
+      sexp_gc_preserve1(sigctx, args);
+      args = sexp_cons(sigctx, sexp_make_fixnum(signum), SEXP_NULL);
+      sexp_apply(sigctx, handler, args);
+      sexp_gc_release1(sigctx);
+    }
+#endif
+  }
+}
+
+static sexp sexp_set_signal_action (sexp ctx, sexp self, sexp signum, sexp newaction) {
+  int res;
+  sexp oldaction;
+  if (! (sexp_fixnump(signum) && sexp_unbox_fixnum(signum) > 0
+         && sexp_unbox_fixnum(signum) < SEXP_MAX_SIGNUM))
+    return sexp_xtype_exception(ctx, self, "not a valid signal number", signum);
+  if (! (sexp_procedurep(newaction) || sexp_opcodep(newaction)
+         || sexp_booleanp(newaction)))
+    return sexp_type_exception(ctx, self, SEXP_PROCEDURE, newaction);
+  if (! sexp_vectorp(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS)))
+    sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS)
+      = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_MAX_SIGNUM), SEXP_FALSE);
+  oldaction = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum);
+  res = sigaction(sexp_unbox_fixnum(signum),
+                  (sexp_booleanp(newaction) ?
+                   (sexp_truep(newaction) ? &call_sigdefault : &call_sigignore)
+                   : &call_sigaction),
+                  NULL);
+  if (res)
+    return sexp_user_exception(ctx, self, "couldn't set signal", signum);
+  sexp_vector_set(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum, newaction);
+  sexp_signal_contexts[sexp_unbox_fixnum(signum)] = ctx;
+  return oldaction;
+}
+
+#if SEXP_BSD
+
+#include <sys/time.h>
+#include <sys/proc.h>
+#include <sys/sysctl.h>
+#include <sys/user.h>
+
+static sexp sexp_pid_cmdline (sexp ctx, int pid) {
+  size_t reslen = sizeof(struct kinfo_proc);
+  struct kinfo_proc res;
+  int name[4] = {CTL_KERN, KERN_PROC, KERN_PROC_PID, pid};
+  if (sysctl(name, 4, &res, &reslen, NULL, 0) >= 0) {
+#ifdef __APPLE__
+    return sexp_c_string(ctx, res.kp_proc.p_comm, -1);
+#else
+    return sexp_c_string(ctx, res.ki_comm, -1);
+#endif
+  } else {
+    return SEXP_FALSE;
+  }
+}
+
+#else
+
+/* #include <sys/syscall.h> */
+/* #include <linux/sysctl.h> */
+
+/* #define CMDLINE_LENGTH 512 */
+
+/* static sexp sexp_pid_cmdline (sexp ctx, int pid) { */
+/*   struct __sysctl_args args; */
+/*   char cmdline[CMDLINE_LENGTH]; */
+/*   size_t cmdline_length; */
+/*   int name[] = { CTL_KERN, KERN_OSTYPE }; */
+
+/*   memset(&args, 0, sizeof(struct __sysctl_args)); */
+/*   args.name = name; */
+/*   args.nlen = sizeof(name)/sizeof(name[0]); */
+/*   args.oldval = cmdline; */
+/*   args.oldlenp = &cmdline_length; */
+/*   cmdline_length = sizeof(cmdline); */
+
+/*   if (syscall(SYS__sysctl, &args) == -1) { */
+/*     return SEXP_FALSE; */
+/*   } else { */
+/*     return sexp_c_string(ctx, cmdline, -1); */
+/*   } */
+/* } */
+
+#endif
+
+static void sexp_init_signals (sexp ctx, sexp env) {
+  call_sigaction.sa_sigaction  = sexp_call_sigaction;
+#if SEXP_USE_GREEN_THREADS
+  call_sigaction.sa_flags      = SA_SIGINFO | SA_RESTART /* | SA_NODEFER */;
+  sigfillset(&call_sigaction.sa_mask);
+#else
+  call_sigaction.sa_flags      = SA_SIGINFO | SA_RESTART | SA_NODEFER;
+#endif
+  call_sigdefault.sa_handler   = SIG_DFL;
+  call_sigignore.sa_handler    = SIG_IGN;
+  memset(sexp_signal_contexts, 0, sizeof(sexp_signal_contexts));
+}

lib/chibi/strings.scm

@@ -0,0 +1,154 @@
+;; strings.scm -- cursor-oriented string library
+;; Copyright (c) 2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (string-null? str)
+  (equal? str ""))
+
+;; TODO: support character sets
+(define (make-char-predicate x)
+  (cond ((procedure? x) x)
+        ((char? x) (lambda (ch) (eq? ch x)))
+        (else (error "invalid character predicate" x))))
+
+(define (complement pred) (lambda (x) (not (pred x))))
+
+(define (string-any x str)
+  (let ((pred (make-char-predicate x))
+        (end (string-cursor-end str)))
+    (and (string-cursor>? end (string-cursor-start str))
+         (let lp ((i (string-cursor-start str)))
+           (let ((i2 (string-cursor-next str i))
+                 (ch (string-cursor-ref str i)))
+             (if (string-cursor>=? i2 end)
+                 (pred ch)  ;; tail call
+                 (or (pred ch) (lp i2))))))))
+
+(define (string-every x str)
+  (not (string-any (complement (make-char-predicate x)) str)))
+
+(define (string-find str x . o)
+  (let ((pred (make-char-predicate x))
+        (end (string-cursor-end str)))
+    (let lp ((i (if (pair? o) (car o) (string-cursor-start str))))
+      (cond ((string-cursor>=? i end) end)
+            ((pred (string-ref str i)) i)
+            (else (lp (string-cursor-next str i)))))))
+
+(define (string-find-right str x . o)
+  (let ((pred (make-char-predicate x))
+        (end (string-cursor-start str)))
+    (let lp ((i (if (pair? o) (car o) (string-cursor-end str))))
+      (let ((i2 (string-cursor-prev str i)))
+        (cond ((string-cursor<? i2 end) end)
+              ((pred (string-ref str i2)) i)
+              (else (lp i2)))))))
+
+(define (string-skip str x . o)
+  (apply string-find str (complement (make-char-predicate x)) o))
+
+(define (string-skip-right str x . o)
+  (apply string-find-right str (complement (make-char-predicate x)) o))
+
+(define string-join string-concatenate)
+
+(define (string-split str . o)
+  (let ((pred (make-char-predicate (if (pair? o) (car o) #\space)))
+        (limit (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-size str)))
+        (start (string-cursor-start str))
+        (end (string-cursor-end str)))
+    (if (string-cursor>=? start end)
+        (list "")
+        (let lp ((i start) (n 1) (res '()))
+          (cond
+           ((>= n limit)
+            (reverse (cons (substring-cursor str i) res)))
+           (else
+            (let* ((j (string-find str pred i))
+                   (res (cons (substring-cursor str i j) res)))
+              (if (string-cursor>=? j end)
+                  (reverse res)
+                  (lp (string-cursor-next str j) (+ n 1) res)))))))))
+
+(define (string-trim-left str . o)
+  (let ((pred (make-char-predicate (if (pair? o) (car o) #\space))))
+    (substring-cursor str (string-skip str pred))))
+
+(define (string-trim-right str . o)
+  (let ((pred (make-char-predicate (if (pair? o) (car o) #\space))))
+    (substring-cursor str
+                      (string-cursor-start str)
+                      (string-skip-right str pred))))
+
+(define (string-trim str . o)
+  (let ((pred (make-char-predicate (if (pair? o) (car o) #\space))))
+    (substring-cursor str
+                      (string-skip str pred)
+                      (string-skip-right str pred))))
+
+(define (string-mismatch prefix str)
+  (let ((end1 (string-cursor-end prefix))
+        (end2 (string-cursor-end str)))
+    (let lp ((i (string-cursor-start prefix))
+             (j (string-cursor-start str)))
+      (if (or (string-cursor>=? i end1)
+              (string-cursor>=? j end2)
+              (not (eq? (string-ref prefix i) (string-ref str j))))
+          j
+          (lp (string-cursor-next prefix i) (string-cursor-next str j))))))
+
+(define (string-mismatch-right suffix str)
+  (let ((end1 (string-cursor-start suffix))
+        (end2 (string-cursor-start str)))
+    (let lp ((i (string-cursor-prev suffix (string-cursor-end suffix)))
+             (j (string-cursor-prev str (string-cursor-end str))))
+      (if (or (string-cursor<? i end1)
+              (string-cursor<? j end2)
+              (not (eq? (string-ref suffix i) (string-ref str j))))
+          j
+          (lp (string-cursor-prev suffix i) (string-cursor-prev str j))))))
+
+;; TODO: These definitions are specific to the Chibi implementation of
+;; cursors.  Possibly the mismatch API should be modified to allow an
+;; efficient portable definition.
+(define (string-prefix? prefix str)
+  (= (string-cursor-end prefix) (string-mismatch prefix str)))
+
+(define (string-suffix? suffix str)
+  (= (string-cursor-prev suffix (string-cursor-start suffix))
+     (- (string-mismatch-right suffix str)
+        (- (string-cursor-end str) (string-cursor-end suffix)))))
+
+(define (string-fold kons knil str)
+  (let ((end (string-cursor-end str)))
+    (let lp ((i (string-cursor-start str)) (acc knil))
+      (if (string-cursor>=? i end)
+          acc
+          (lp (string-cursor-next str i)
+              (kons (string-cursor-ref str i) acc))))))
+
+(define (string-fold-right kons knil str)
+  (let ((end (string-cursor-end str)))
+    (let lp ((i (string-cursor-start str)))
+      (if (string-cursor>=? i end)
+          knil
+          (kons (string-cursor-ref str i) (lp (string-cursor-next str i)))))))
+
+(define (string-count str x)
+  (let ((pred (make-char-predicate x)))
+    (string-fold (lambda (ch count) (if (pred ch) (+ count 1) count)) 0 str)))
+
+(define (string-for-each proc str)
+  (let ((end (string-cursor-end str)))
+    (let lp ((i (string-cursor-start str)))
+      (cond ((string-cursor<? i end)
+             (proc (string-cursor-ref str i))
+             (lp (string-cursor-next str i)))))))
+
+(define (string-map proc str)
+  (call-with-output-string
+    (lambda (out)
+      (string-for-each (lambda (ch) (write-char (proc ch) out)) str))))
+
+(define (make-string-searcher needle)
+  (lambda (haystack) (string-contains haystack needle)))

lib/chibi/strings.sld

@@ -0,0 +1,15 @@
+
+(define-library (chibi strings)
+  (export
+   string-cursor-start string-cursor-end string-cursor-ref
+   string-cursor<? string-cursor<=? string-cursor>? string-cursor>=?
+   string-cursor=? string-null? string-every string-any
+   string-join string-split string-count
+   string-trim string-trim-left string-trim-right
+   string-mismatch string-mismatch-right
+   string-prefix? string-suffix?
+   string-find string-find-right string-skip string-skip-right
+   string-fold string-fold-right string-map string-for-each
+   string-contains make-string-searcher)
+  (import (scheme) (chibi ast))
+  (include "strings.scm"))

lib/chibi/stty.scm

@@ -0,0 +1,263 @@
+;; Copyright (c) 2011 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> A high-level interface to stty and ioctl.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; symbolic representation of attributes
+
+(define stty-lookup (make-hash-table eq?))
+
+(for-each
+ (lambda (c)
+   (let ((type (cadr c))
+         (value (caddr c)))
+     (hash-table-set! stty-lookup (car c) (cdr c))))
+
+ ;; ripped from the stty man page, then trimmed down to what seemed
+ ;; available on most systems
+
+ `(;; characters
+   ;;(dsusp    char     ,VDSUSP)   ; CHAR will send a terminal stop signal
+   (eof      char     ,VEOF)     ; CHAR will send an EOF (terminate input)
+   (eol      char     ,VEOL)     ; CHAR will end the line
+   (eol2     char     ,VEOL2)    ; alternate CHAR for ending the line
+   (erase    char     ,VERASE)   ; CHAR will erase the last character typed
+   (intr     char     ,VINTR)    ; CHAR will send an interrupt signal
+   (kill     char     ,VKILL)    ; CHAR will erase the current line
+   (lnext    char     ,VLNEXT)   ; CHAR will enter the next character quoted
+   (quit     char     ,VQUIT)    ; CHAR will send a quit signal
+   (rprnt    char     ,VREPRINT) ; CHAR will redraw the current line
+   (start    char     ,VSTART)   ; CHAR will restart output after stopping it
+   (stop     char     ,VSTOP)    ; CHAR will stop the output
+   (susp     char     ,VSUSP)    ; CHAR will send a terminal stop signal
+   (werase   char     ,VWERASE)  ; CHAR will erase the last word typed
+
+   ;; special settings
+   (cols     special  #f) ; tell the kernel that the terminal has N columns
+   (columns  special  #f) ; same as cols N
+   (ispeed   special  #f) ; set the input speed to N
+   (line     special  #f) ; use line discipline N
+   (min      special  #f) ; with -icanon, set N characters minimum for a completed read
+   (ospeed   special  #f) ; set the output speed to N
+   (rows     special  #f) ; tell the kernel that the terminal has N rows
+   (size     special  #f) ; print the number of rows and columns according to the kernel
+   (speed    special  #f) ; print the terminal speed
+   (time     special  #f) ; with -icanon, set read timeout of N tenths of a second
+
+   ;; control settings
+   (clocal   control  ,CLOCAL)  ; disable modem control signals
+   (cread    control  ,CREAD)   ; allow input to be received
+   (crtscts  control  ,CRTSCTS) ; enable RTS/CTS handshaking
+   (cs5      control  ,CS5)     ; set character size to 5 bits
+   (cs6      control  ,CS6)     ; set character size to 6 bits
+   (cs7      control  ,CS7)     ; set character size to 7 bits
+   (cs8      control  ,CS8)     ; set character size to 8 bits
+   (cstopb   control  ,CSTOPB)  ; use two stop bits per character (one with `-')
+   (hup      control  ,HUPCL)   ; send a hangup signal when the last process closes the tty
+   (hupcl    control  ,HUPCL)   ; same as [-]hup
+   (parenb   control  ,PARENB)  ; generate parity bit in output and expect parity bit in input
+   (parodd   control  ,PARODD)  ; set odd parity (even with `-')
+
+   ;; input settings
+   (brkint   input    ,BRKINT)  ; breaks cause an interrupt signal
+   (icrnl    input    ,ICRNL)   ; translate carriage return to newline
+   (ignbrk   input    ,IGNBRK)  ; ignore break characters
+   (igncr    input    ,IGNCR)   ; ignore carriage return
+   (ignpar   input    ,IGNPAR)  ; ignore characters with parity errors
+   (imaxbel  input    ,IMAXBEL) ; * beep and do not flush a full input buffer on a character
+   (inlcr    input    ,INLCR)   ; translate newline to carriage return
+   (inpck    input    ,INPCK)   ; enable input parity checking
+   (istrip   input    ,ISTRIP)  ; clear high (8th) bit of input characters
+   ;;(iuclc    input    ,IUCLC)   ; * translate uppercase characters to lowercase
+   (ixany    input    ,IXANY)   ; * let any character restart output, not only start character
+   (ixoff    input    ,IXOFF)   ; enable sending of start/stop characters
+   (ixon     input    ,IXON)    ; enable XON/XOFF flow control
+   (parmrk   input    ,PARMRK)  ; mark parity errors (with a 255-0-character sequence)
+   (tandem   input    ,IXOFF)   ; same as [-]ixoff
+
+   ;; output settings
+   ;;(bs0      output   ,BS0) ; backspace delay style, N in [0..1]
+   ;;(bs1      output   ,BS1) ; backspace delay style, N in [0..1]
+   ;;(cr0      output   ,CR0) ; carriage return delay style, N in [0..3]
+   ;;(cr1      output   ,CR1) ; carriage return delay style, N in [0..3]
+   ;;(cr2      output   ,CR2) ; carriage return delay style, N in [0..3]
+   ;;(cr3      output   ,CR3) ; carriage return delay style, N in [0..3]
+   ;;(ff0      output   ,FF0) ; form feed delay style, N in [0..1]
+   ;;(ff1      output   ,FF1) ; form feed delay style, N in [0..1]
+   ;;(nl0      output   ,NL0) ; newline delay style, N in [0..1]
+   ;;(nl1      output   ,NL1) ; newline delay style, N in [0..1]
+   (ocrnl    output   ,OCRNL) ; translate carriage return to newline
+   ;;(ofdel    output   ,OFDEL) ; use delete characters for fill instead of null characters
+   ;;(ofill    output   ,OFILL) ; use fill (padding) characters instead of timing for delays
+   ;;(olcuc    output   ,OLCUC) ; translate lowercase characters to uppercase
+   (onlcr    output   ,ONLCR) ; translate newline to carriage return-newline
+   (onlret   output   ,ONLRET) ; newline performs a carriage return
+   (onocr    output   ,ONOCR) ; do not print carriage returns in the first column
+   (opost    output   ,OPOST) ; postprocess output
+   (tab0     output   #f) ; horizontal tab delay style, N in [0..3]
+   (tab1     output   #f) ; horizontal tab delay style, N in [0..3]
+   (tab2     output   #f) ; horizontal tab delay style, N in [0..3]
+   (tab3     output   #f) ; horizontal tab delay style, N in [0..3]
+   (tabs     output   #f) ; same as tab0
+   ;;(-tabs    output   #f) ; same as tab3
+   ;;(vt0      output   ,VT0) ; vertical tab delay style, N in [0..1]
+   ;;(vt1      output   ,VT1) ; vertical tab delay style, N in [0..1]
+
+   ;; local settings
+   (crterase local    ,ECHOE)   ; echo erase characters as backspace-space-backspace
+   (crtkill  local    ,ECHOKE)  ; kill all line by obeying the echoprt and echoe settings
+   ;;(-crtkill local    #f) ; kill all line by obeying the echoctl and echok settings
+   (ctlecho  local    ,ECHOCTL) ; echo control characters in hat notation (`^c')
+   (echo     local    ,ECHO)    ; echo input characters
+   (echoctl  local    ,ECHOCTL) ; same as [-]ctlecho
+   (echoe    local    ,ECHOE)   ; same as [-]crterase
+   ;;(echok    local    ,ECHOK)   ; echo a newline after a kill character
+   (echoke   local    ,ECHOKE)  ; same as [-]crtkill
+   (echonl   local    ,ECHONL)  ; echo newline even if not echoing other characters
+   ;;(echoprt  local    ,ECHOPRT) ; echo erased characters backward, between `\' and '/'
+   (icanon   local    ,ICANON)  ; enable erase, kill, werase, and rprnt special characters
+   ;;(iexten   local    ,IEXTEN)  ; enable non-POSIX special characters
+   (isig     local    ,ISIG)    ; enable interrupt, quit, and suspend special characters
+   (noflsh   local    ,NOFLSH)  ; disable flushing after interrupt and quit special characters
+   ;;(prterase local    ,ECHOPRT) ; same as [-]echoprt
+   (tostop   local    ,TOSTOP)  ; stop background jobs that try to write to the terminal
+   ;;(xcase    local    ,XCASE)   ; with icanon, escape with `\' for uppercase characters
+
+   ;; combination settings
+   (LCASE    combine  (lcase))
+   (cbreak   combine  (not icanon))
+   (cooked   combine  (brkint ignpar istrip icrnl ixon opost isig icanon))
+                                        ; also eof and eol characters
+                                        ; to their default values
+   (crt      combine  (echoe echoctl echoke))
+   (dec      combine  (echoe echoctl echoke (not ixany)))
+                                        ; also intr ^c erase 0177 kill ^u
+   (decctlq  combine  (ixany))
+   (ek       combine  ()) ; erase and kill characters to their default values
+   (evenp    combine  (parenb (not parodd) cs7))
+   ;;(-evenp combine  #f) ; same as -parenb cs8
+   (lcase    combine  (xcase iuclc olcuc))
+   (litout   combine  (cs8 (not parenb istrip opost)))
+   ;;(-litout  combine  #f) ; same as parenb istrip opost cs7
+   (nl       combine  (not icrnl onlcr))
+   ;;(-nl      combine  #f) ; same as icrnl -inlcr -igncr onlcr -ocrnl -onlret
+   (oddp     combine  (parenb parodd cs7))
+   (parity   combine  (evenp)) ; same as [-]evenp
+   (pass8    combine  (cs8 (not parenb istrip)))
+   ;;(-pass8   combine  #f) ; same as parenb istrip cs7
+   (raw      combine  (not ignbrk brkint ignpar parmrk
+                           inpck istrip inlcr igncr icrnl))
+   (ixon     combine  (ixoff ixany imaxbel opost isig icanon)) ;; xcase iuclc
+   ;;(time     combine  #f) ; 0
+   ;;(-raw     combine  #f) ; same as cooked
+   (sane     combine  (cread brkint icrnl imaxbel opost onlcr
+                       isig icanon ;; nl0 cr0 bs0 vt0 ff0 ; tab0
+                       echo echoe echoctl echoke ;; iexten echok
+                       (not ignbrk igncr ixoff ixany inlcr ;; iuclc
+                            ocrnl onocr onlret ;; olcuc ofill ofdel
+                            echonl noflsh tostop echoprt))) ;; xcase
+                                        ; plus all special characters to
+                                        ; their default values
+   ))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; high-level interface
+
+;;> @subsubsubsection{@scheme{(stty [port] args ...)}}
+
+;;> Set the terminal attributes for @var{port} (default
+;;> @scheme{(current-output-port)}) to @var{attrs}.
+;;> Attributes are specified symbolically using the
+;;> names from the @rawcode{stty(1)} command.  In addition,
+;;> (not args ...) may be used to negate the listed symbols.
+
+(define (stty . args)
+  (let* ((port (if (and (pair? args) (port? (car args)))
+                   (car args)
+                   (current-output-port)))
+         (attr (get-terminal-attributes port)))
+    ;; parse change requests
+    (let lp ((lst (if (and (pair? args) (port? (car args))) (cdr args) args))
+             (iflag (term-attrs-iflag attr))
+             (oflag (term-attrs-oflag attr))
+             (cflag (term-attrs-cflag attr))
+             (lflag (term-attrs-lflag attr))
+             (invert? #f)
+             (return (lambda (iflag oflag cflag lflag)
+                       (term-attrs-iflag-set! attr iflag)
+                       (term-attrs-oflag-set! attr oflag)
+                       (term-attrs-cflag-set! attr cflag)
+                       (term-attrs-lflag-set! attr lflag)
+                       (set-terminal-attributes! port TCSANOW attr))))
+      (define (join old new)
+        (if invert? (bitwise-and old (bitwise-not new)) (bitwise-ior old new)))
+      (cond
+       ((pair? lst)
+        (let ((command (car lst)))
+          (cond
+           ((pair? command) ;; recurse on sub-expr
+            (lp command iflag oflag cflag lflag invert?
+                (lambda (i o c l) (lp (cdr lst) i o c l invert? return))))
+           ((eq? command 'not) ;; toggle current setting
+            (lp (cdr lst) iflag oflag cflag lflag (not invert?) return))
+           (else
+            (let ((x (hash-table-ref/default stty-lookup command #f)))
+              (case (and x (car x))
+                ((input)
+                 (lp (cdr lst) (join iflag (cadr x)) oflag cflag lflag invert? return))
+                ((output)
+                 (lp (cdr lst) iflag (join oflag (cadr x)) cflag lflag invert? return))
+                ((control)
+                 (lp (cdr lst) iflag oflag (join cflag (cadr x)) lflag invert? return))
+                ((local)
+                 (lp (cdr lst) iflag oflag cflag (join lflag (cadr x)) invert? return))
+                ((char)
+                 ;;(term-attrs-cc-set! attr (cadr x) (or (cadr lst) 0))
+                 (lp (cddr lst) iflag oflag cflag lflag invert? return))
+                ((combine)
+                 (lp (cadr x) iflag oflag cflag lflag invert?
+                     (lambda (i o c l) (lp (cdr lst) i o c l invert? return))))
+                ((special)
+                 (error "special settings not yet supported" command))
+                (else
+                 (error "unknown stty command" command))))))))
+       (else
+        (return iflag oflag cflag lflag))))))
+
+;;> Run @var{thunk} with the @scheme{stty} @var{setting}s in effect
+;;> during its dynamic extent, resetting the original settings
+;;> when it returns.
+
+(define (with-stty setting thunk . o)
+  (let* ((port (if (pair? o) (car o) (current-input-port)))
+         (orig-attrs (get-terminal-attributes port)))
+    (cond
+     (orig-attrs
+      (dynamic-wind
+        (lambda () (stty port setting))
+        thunk
+        (lambda () (set-terminal-attributes! port TCSANOW orig-attrs))))
+     (else
+      ;; No terminal attributes means this isn't a tty.
+      (thunk)))))
+
+;;> Run @var{thunk} with the "raw" (no canonical or echo) options
+;;> needed for a terminal application.
+
+(define (with-raw-io port thunk)
+  (with-stty '(not icanon isig echo) thunk port))
+
+;;> Returns the current terminal width in characters of @var{x},
+;;> which must be a port or a file descriptor.
+
+(define (get-terminal-width x)
+  (let ((ws (ioctl x TIOCGWINSZ)))
+    (and ws (winsize-col ws))))
+
+;;> Returns the current terminal dimensions, as a list of character width
+;;> and height, of @var{x}, which must be a port or a file descriptor.
+
+(define (get-terminal-dimensions x)
+  (let ((ws (ioctl x TIOCGWINSZ)))
+    (and ws (list (winsize-col ws) (winsize-row ws)))))

lib/chibi/stty.sld

@@ -0,0 +1,8 @@
+
+(define-library (chibi stty)
+  (export stty with-stty with-raw-io
+          get-terminal-width get-terminal-dimensions
+          TCSANOW TCSADRAIN TCSAFLUSH)
+  (import (scheme) (srfi 33) (srfi 69))
+  (include-shared "stty")
+  (include "stty.scm"))

lib/chibi/stty.stub

@@ -0,0 +1,106 @@
+
+(c-system-include "termios.h")
+(c-system-include "sys/ioctl.h")
+
+(define-c-struct termios
+  predicate: term-attrs?
+  constructor: (make-term-attrs)
+  (unsigned-long c_iflag term-attrs-iflag term-attrs-iflag-set!)
+  (unsigned-long c_oflag term-attrs-oflag term-attrs-oflag-set!)
+  (unsigned-long c_cflag term-attrs-cflag term-attrs-cflag-set!)
+  (unsigned-long c_lflag term-attrs-lflag term-attrs-lflag-set!)
+  ;;(unsigned-char (c_cc 22) term-attrs-cc term-attrs-cc-set!)
+  (unsigned-long c_ispeed term-attrs-ispeed term-attrs-ispeed-set!)
+  (unsigned-long c_ospeed term-attrs-ospeed term-attrs-ospeed-set!))
+
+(define-c-struct winsize
+  predicate: winsize?
+  (unsigned-short ws_row winsize-row)
+  (unsigned-short ws_col winsize-col))
+
+(define-c errno ioctl (port-or-fileno unsigned-long (result winsize)))
+
+(define-c-const int TIOCGWINSZ)
+
+(define-c-const int TCSANOW)
+(define-c-const int TCSADRAIN)
+(define-c-const int TCSAFLUSH)
+
+(define-c-const unsigned-long IGNBRK)
+(define-c-const unsigned-long BRKINT)
+(define-c-const unsigned-long IGNPAR)
+(define-c-const unsigned-long PARMRK)
+(define-c-const unsigned-long INPCK)
+(define-c-const unsigned-long ISTRIP)
+(define-c-const unsigned-long INLCR)
+(define-c-const unsigned-long IGNCR)
+(define-c-const unsigned-long ICRNL)
+(define-c-const unsigned-long IXON)
+(define-c-const unsigned-long IXOFF)
+(define-c-const unsigned-long IXANY)
+(define-c-const unsigned-long IMAXBEL)
+;; (define-c-const unsigned-long IUCLC)
+
+(define-c-const unsigned-long OPOST)
+(define-c-const unsigned-long ONLCR)
+;; (define-c-const unsigned-long OXTABS)
+;; (define-c-const unsigned-long ONOEOT)
+(define-c-const unsigned-long OCRNL)
+;; (define-c-const unsigned-long OLCUC)
+(define-c-const unsigned-long ONOCR)
+(define-c-const unsigned-long ONLRET)
+
+(define-c-const unsigned-long CSIZE)
+(define-c-const unsigned-long CS5)
+(define-c-const unsigned-long CS6)
+(define-c-const unsigned-long CS7)
+(define-c-const unsigned-long CS8)
+(define-c-const unsigned-long CSTOPB)
+(define-c-const unsigned-long CREAD)
+(define-c-const unsigned-long PARENB)
+(define-c-const unsigned-long PARODD)
+(define-c-const unsigned-long HUPCL)
+(define-c-const unsigned-long CLOCAL)
+;; (define-c-const unsigned-long CCTS_OFLOW)
+(define-c-const unsigned-long CRTSCTS)
+;; (define-c-const unsigned-long CRTS_IFLOW)
+;; (define-c-const unsigned-long MDMBUF)
+
+(define-c-const unsigned-long ECHOKE)
+(define-c-const unsigned-long ECHOE)
+(define-c-const unsigned-long ECHO)
+(define-c-const unsigned-long ECHONL)
+;; (define-c-const unsigned-long ECHOPRT)
+(define-c-const unsigned-long ECHOCTL)
+(define-c-const unsigned-long ISIG)
+(define-c-const unsigned-long ICANON)
+;; (define-c-const unsigned-long ALTWERASE)
+(define-c-const unsigned-long IEXTEN)
+;; (define-c-const unsigned-long EXTPROC)
+(define-c-const unsigned-long TOSTOP)
+(define-c-const unsigned-long FLUSHO)
+;; (define-c-const unsigned-long NOKERNINFO)
+;; (define-c-const unsigned-long PENDIN)
+(define-c-const unsigned-long NOFLSH)
+
+(define-c-const unsigned-long VEOF)
+(define-c-const unsigned-long VEOL)
+(define-c-const unsigned-long VEOL2)
+(define-c-const unsigned-long VERASE)
+;; (define-c-const unsigned-long VERASE2)
+(define-c-const unsigned-long VWERASE)
+(define-c-const unsigned-long VINTR)
+(define-c-const unsigned-long VKILL)
+(define-c-const unsigned-long VQUIT)
+(define-c-const unsigned-long VSUSP)
+(define-c-const unsigned-long VSTART)
+(define-c-const unsigned-long VSTOP)
+;; (define-c-const unsigned-long VDSUSP)
+(define-c-const unsigned-long VLNEXT)
+(define-c-const unsigned-long VREPRINT)
+;; (define-c-const unsigned-long VSTATUS)
+
+(define-c errno (get-terminal-attributes "tcgetattr")
+  (port-or-fileno (result termios)))
+(define-c errno (set-terminal-attributes! "tcsetattr")
+  (port-or-fileno int termios))

lib/chibi/system.sld

@@ -0,0 +1,15 @@
+
+(define-library (chibi system)
+  (export user-information user? user-name user-password
+          user-id user-group-id user-gecos user-home user-shell
+          current-user-id current-group-id
+          current-effective-user-id current-effective-group-id
+          set-current-user-id! set-current-effective-user-id!
+          set-current-group-id! set-current-effective-group-id!
+          current-session-id create-session
+          set-root-directory!)
+  (import (scheme))
+  (include-shared "system")
+  (body
+   (define (user-information user)
+     (car (if (string? user) (getpwnam_r user) (getpwuid_r user))))))

lib/chibi/system.stub

@@ -0,0 +1,60 @@
+
+(c-system-include "unistd.h")
+(c-system-include "pwd.h")
+(c-system-include "sys/types.h")
+
+;;> @subsubsubsection{@scheme{(user-information name-or-id)}}
+
+;;> Returns the password entry for the given user.  @var{name-or-id}
+;;> should be a string indicating the user name, or an integer
+;;> for the user id.
+
+(define-c-struct passwd
+  predicate: user?
+  (string  pw_name     user-name)
+  (string  pw_passwd   user-password)
+  (uid_t   pw_uid      user-id)
+  (gid_t   pw_gid      user-group-id)
+  (string  pw_gecos    user-gecos)
+  (string  pw_dir      user-home)
+  (string  pw_shell    user-shell))
+
+;;> Accessors for the password entry structure returned by
+;;> @scheme{user-information}.
+;;/
+
+(define-c uid_t (current-user-id "getuid") ())
+(define-c gid_t (current-group-id "getgid") ())
+(define-c uid_t (current-effective-user-id "geteuid") ())
+(define-c gid_t (current-effective-group-id "getegid") ())
+
+(define-c errno (set-current-user-id! "setuid") (uid_t))
+(define-c errno (set-current-effective-user-id! "seteuid") (uid_t))
+(define-c errno (set-current-group-id! "setgid") (gid_t))
+(define-c errno (set-current-effective-group-id! "setegid") (gid_t))
+
+;;> Accessors for the current user credentials.
+;;/
+
+;;> Returns the session id of the specified process,
+;;> defaulting to the current process.
+
+(define-c pid_t (current-session-id "getsid") ((default 0 pid_t)))
+
+;;> Creates a new session.
+
+(define-c pid_t (create-session "setsid") ())
+
+;;> Set @var{string} to be the new root directory, so that
+;;> paths beginning with "/" are resolved relative to the
+;;> new root.
+
+(define-c errno (set-root-directory! "chroot") (string))
+
+(define-c errno getpwuid_r
+  (uid_t (result passwd) (result (array char arg3))
+         (value 1024 int) (result pointer passwd)))
+
+(define-c errno getpwnam_r
+  (string (result passwd) (result (array char arg3))
+          (value 1024 int) (result pointer passwd)))

lib/chibi/term/edit-line.scm

@@ -0,0 +1,666 @@
+;;;; edit-line.scm - pure scheme line editor
+;;
+;; Copyright (c) 2011-2012 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; vt100 terminal utilities
+
+(define (terminal-escape out ch arg)
+  (write-char (integer->char 27) out)
+  (write-char #\[ out)
+  (if arg (display arg out))
+  (write-char ch out))
+
+;; we use zero-based columns
+(define (terminal-goto-col out n)  (terminal-escape out #\G (+ n 1)))
+(define (terminal-up out n)        (terminal-escape out #\A n))
+(define (terminal-down out n)      (terminal-escape out #\B n))
+(define (terminal-clear-below out) (terminal-escape out #\J #f))
+(define (terminal-clear-right out) (terminal-escape out #\K #f))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; history
+
+(define maximum-history-size 128)
+
+(define-record-type History
+  (%make-history remaining past future)
+  history?
+  (remaining history-remaining history-remaining-set!)
+  (past history-past history-past-set!)
+  (future history-future history-future-set!))
+
+(define (make-history . o)
+  (%make-history (if (pair? o) (car o) maximum-history-size) '() '()))
+
+(define (history-current h)
+  (let ((p (history-past h)))
+    (and (pair? p) (car p))))
+
+(define (history->list h)
+  (let ((past (history-past h)) (future (history-future h)))
+    (if (pair? past) (cons (car past) (append future (cdr past))) future)))
+
+(define (list->history ls)
+  (%make-history (max maximum-history-size (length ls)) ls '()))
+
+(define (history-flatten! h)
+  (history-past-set! h (history->list h))
+  (history-future-set! h '()))
+
+(define (drop-last ls) (reverse (cdr (reverse ls))))
+
+(define (history-past-push! h x)
+  (if (positive? (history-remaining h))
+      (history-remaining-set! h (- (history-remaining h) 1))
+      (if (pair? (history-past h))
+          (history-past-set! h (drop-last (history-past h)))
+          (history-future-set! h (drop-last (history-future h)))))
+  (history-past-set! h (cons x (history-past h))))
+
+(define (history-insert! h x)
+  (history-flatten! h)
+  (history-past-push! h x))
+
+(define (history-commit! h x)
+  (cond
+   ((pair? (history-future h))
+    (history-past-set!
+     h (cons x (append (drop-last (history-future h)) (history-past h))))
+    (history-future-set! h '()))
+   (else
+    (history-insert! h x))))
+
+(define (history-prev! h)
+  (let ((past (history-past h)))
+    (and (pair? past)
+         (pair? (cdr past))
+         (begin
+           (history-future-set! h (cons (car past) (history-future h)))
+           (history-past-set! h (cdr past))
+           (cadr past)))))
+
+(define (history-next! h)
+  (let ((future (history-future h)))
+    (and (pair? future)
+         (begin
+           (history-past-set! h (cons (car future) (history-past h)))
+           (history-future-set! h (cdr future))
+           (car future)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; char and string utils
+
+(define (char-word-constituent? ch)
+  (or (char-alphabetic? ch) (char-numeric? ch)
+      (memv ch '(#\_ #\- #\+ #\:))))
+
+(define (char-non-word-constituent? ch) (not (char-word-constituent? ch)))
+
+(define (string-copy! dst dstart src start end)
+  (if (>= start dstart)
+      (do ((i start (+ i 1)) (j dstart (+ j 1)))
+          ((= i end))
+        (string-set! dst j (string-ref src i)))
+      (do ((i (- end 1) (- i 1)) (j (+ dstart (- end start 1)) (- j 1)))
+          ((< i start))
+        (string-set! dst j (string-ref src i)))))
+
+(define (string-index ch x)
+  (let ((len (string-length x)))
+    (let lp ((i 0))
+      (cond ((>= i len) #f)
+            ((eqv? ch (string-ref x i)))
+            (else (lp (+ i 1)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; buffers
+
+(define-record-type Buffer
+  (%make-buffer refresh? min pos row max-row col gap start width string
+                history complete? single-line?)
+  buffer?
+  (refresh? buffer-refresh? buffer-refresh?-set!)
+  (min buffer-min buffer-min-set!)
+  (pos buffer-pos buffer-pos-set!)
+  (row buffer-row buffer-row-set!)
+  (max-row buffer-max-row buffer-max-row-set!)
+  (col buffer-col buffer-col-set!)
+  (gap buffer-gap buffer-gap-set!)
+  (start buffer-start buffer-start-set!)
+  (width buffer-width buffer-width-set!)
+  (string buffer-string buffer-string-set!)
+  (kill-ring buffer-kill-ring buffer-kill-ring-set!)
+  (history buffer-history buffer-history-set!)
+  (complete? buffer-complete? buffer-complete?-set!)
+  (single-line? buffer-single-line? buffer-single-line?-set!))
+
+(define default-buffer-size 256)
+(define default-buffer-width 80)
+
+(define (make-buffer)
+  (%make-buffer #f 0 0 0 0 0 default-buffer-size 0 default-buffer-width
+                (make-string default-buffer-size) '() #f #f))
+
+(define (buffer->string buf)
+  (let ((str (buffer-string buf)))
+    (string-append (substring str (buffer-min buf) (buffer-pos buf))
+                   (substring str (buffer-gap buf) (string-length str)))))
+
+(define (buffer-right-length buf)
+  (- (string-length (buffer-string buf)) (buffer-gap buf)))
+(define (buffer-length buf)
+  (+ (buffer-pos buf) (buffer-right-length buf)))
+(define (buffer-free-space buf)
+  (- (buffer-gap buf) (buffer-pos buf)))
+
+(define (buffer-clamp buf n)
+  (max (buffer-min buf) (min n (buffer-length buf))))
+
+(define (buffer-resize buf n)
+  (cond ((<= (buffer-free-space buf) n)
+         (let* ((right-len (buffer-right-length buf))
+                (new-len (* 2 (max n (buffer-length buf))))
+                (new-gap (- new-len right-len))
+                (new (make-string new-len))
+                (old (buffer-string buf)))
+           (string-copy! new 0 old 0 (buffer-pos buf))
+           (string-copy! new new-gap old (buffer-gap buf) (string-length old))
+           (buffer-string-set! buf new)
+           (buffer-gap-set! buf new-gap)))))
+
+(define (buffer-update-position! buf)
+  (let ((pos (buffer-pos buf))
+        (gap (buffer-gap buf))
+        (str (buffer-string buf))
+        (end (string-length (buffer-string buf)))
+        (width (buffer-width buf)))
+    ;; TODO: Support double and zero-width chars and ANSI escapes.
+    (cond
+     ((buffer-single-line? buf)
+      ;; The "start" is the last left-most column of the buffer when
+      ;; we overflow and need to scroll horizontally.  This defaults
+      ;; to 0 and increments as we move past the last column.  We
+      ;; update it when we find that (via movement or insertion) the
+      ;; point would no longer be visible from "start" to the end of
+      ;; the line, by shifting the start to the rightmost column that
+      ;; would show the point.  Thus, after scrolling off the
+      ;; beginning of the buffer, successive movements left will first
+      ;; go to the 0th column, then scroll to the start one character
+      ;; at a time.  A beginning-of-line command will restore the
+      ;; "start" to 0 immediately.
+      ;; We assume no embedded newlines in this case.
+      (let ((start (buffer-start buf)))
+        (cond
+         ((> start pos)
+          (buffer-start-set! buf pos))
+         ((> (+ 1 (buffer-min buf) (- pos start)) (buffer-width buf))
+          (buffer-start-set! buf (max 0 (- (+ 1 (buffer-min buf) pos)
+                                           (buffer-width buf))))))
+        (buffer-col-set! buf (+ (buffer-min buf) (- pos (buffer-start buf))))))
+     (else
+      ;; Otherwise, in a multi-line editor we need to scan for
+      ;; newlines to determine the current (relative) row and column.
+      (let lp ((i 0) (row 0) (col 0)) ;; update row/col
+        (cond ((= i pos)
+               (buffer-row-set! buf row)
+               (buffer-col-set! buf col)
+               (lp gap row col))      ;; skip from pos->gap
+              ((>= i end)
+               (buffer-max-row-set!
+                buf (if (and (zero? col) (> row 0)) (- row 1) row)))
+              ((eqv? #\newline (string-ref str i))
+               (lp (+ i 1) (+ row 1) 0))
+              ((= (+ col 1) width)
+               (lp (+ i 1) (+ row 1) 0))
+              (else
+               (lp (+ i 1) row (+ col 1)))))))))
+
+(define (buffer-clear buf out)
+  ;; goto start of input
+  (terminal-goto-col out 0)
+  (if (positive? (buffer-row buf))
+      (terminal-up out (buffer-row buf)))
+  ;; clear below
+  (terminal-clear-below out))
+
+(define (buffer-draw buf out)
+  (let* ((gap (buffer-gap buf))
+         (str (buffer-string buf))
+         (end (string-length str))
+         (old-row (buffer-row buf))
+         (old-col (buffer-col buf)))
+    ;; update position and clear the current input
+    (buffer-clear buf out)
+    (buffer-update-position! buf)
+    (let ((left (if (buffer-single-line? buf)
+                    (buffer-start buf)
+                    (buffer-min buf)))
+          (right
+           (if (buffer-single-line? buf)
+               (min end (+ (buffer-gap buf)
+                           (- (buffer-width buf) (buffer-col buf))))
+               end)))
+      (display (substring str 0 (buffer-min buf)) out)
+      (display (substring str left (buffer-pos buf)) out)
+      (display (substring str (buffer-gap buf) right) out))
+    (cond
+     ((not (buffer-single-line? buf))
+      ;; move to next line if point at eol
+      (if (and (zero? (buffer-col buf)) (positive? (buffer-row buf)))
+          (write-char #\space out))
+      ;; move to correct row then col
+      (if (< (buffer-row buf) (buffer-max-row buf))
+          (terminal-up out (- (buffer-max-row buf) (buffer-row buf))))))
+    (terminal-goto-col out (buffer-col buf))
+    (flush-output out)))
+
+(define (buffer-refresh buf out)
+  (cond ((buffer-refresh? buf)
+         (buffer-draw buf out)
+         (buffer-refresh?-set! buf #f))))
+
+(define (buffer-goto! buf out n)
+  (let ((pos (buffer-pos buf))
+        (gap (buffer-gap buf))
+        (str (buffer-string buf))
+        (n (buffer-clamp buf n)))
+    (cond ((not (= n pos))
+           (buffer-update-position! buf) ;; necesary?
+           (if (< n pos)
+               (string-copy! str (- gap (- pos n)) str n pos)
+               (string-copy! str pos str gap (+ gap (- n pos))))
+           (buffer-pos-set! buf n)
+           (buffer-gap-set! buf (+ gap (- n pos)))
+           (cond
+            ((not (buffer-refresh? buf))
+             (let ((old-row (buffer-row buf))
+                   (old-start (buffer-start buf)))
+               (buffer-update-position! buf)
+               (cond
+                ((not (= old-start (buffer-start buf)))
+                 (buffer-refresh?-set! buf #t))
+                (else
+                 (let ((row-diff (- old-row (buffer-row buf))))
+                   (cond ((> row-diff 0) (terminal-up out row-diff))
+                         ((< row-diff 0) (terminal-down out (- row-diff)))))
+                 (terminal-goto-col out (buffer-col buf)))))))))))
+
+(define (buffer-insert! buf out x)
+  (let ((len (if (char? x) 1 (string-length x)))
+        (pos (buffer-pos buf)))
+    (buffer-resize buf len)
+    (if (char? x)
+        (string-set! (buffer-string buf) pos x)
+        (string-copy! (buffer-string buf) pos x 0 len))
+    (buffer-pos-set! buf (+ (buffer-pos buf) len))
+    (cond
+     ((buffer-refresh? buf))
+     ((and (= (buffer-gap buf) (string-length (buffer-string buf)))
+           (< (+ (buffer-col buf) len) (buffer-width buf))
+           (if (char? x)
+               (not (eqv? x #\newline))
+               (not (string-index #\newline x))))
+      ;; fast path - append to end of buffer w/o wrapping to next line
+      (display x out)
+      (flush-output out)
+      (buffer-col-set! buf (+ (buffer-col buf) len)))
+     (else
+      (buffer-refresh?-set! buf #t)))))
+
+(define (buffer-delete! buf out start end)
+  (let ((pos (buffer-pos buf))
+        (gap (buffer-gap buf))
+        (str (buffer-string buf))
+        (start (buffer-clamp buf start))
+        (end (buffer-clamp buf end)))
+    (if (not (buffer-refresh? buf))
+        (if (and (= start pos) (>= end (buffer-length buf)))
+            (terminal-clear-below out)
+            (buffer-refresh?-set! buf #t)))
+    (cond ((< end pos)
+           (string-copy! str start str end pos)
+           (buffer-pos-set! buf (+ start (- pos end))))
+          ((> start gap)
+           (string-copy! str start str gap (+ gap (- end start)))
+           (buffer-gap-set! buf (+ gap (- end start))))
+          (else
+           (buffer-pos-set! buf (min pos start))
+           (buffer-gap-set! buf (max gap (+ pos (- gap pos) (- end pos))))))))
+
+(define (buffer-skip buf pred)
+  (let* ((str (buffer-string buf)) (end (string-length str)))
+    (let lp ((i (buffer-gap buf)))
+      (if (or (>= i end) (not (pred (string-ref str i))))
+          (+ (- i (buffer-gap buf)) (buffer-pos buf))
+          (lp (+ i 1))))))
+
+(define (buffer-skip-reverse buf pred)
+  (let ((str (buffer-string buf)))
+    (let lp ((i (- (buffer-pos buf) 1)))
+      (if (or (< i 0) (not (pred (string-ref str i)))) i (lp (- i 1))))))
+
+(define (buffer-previous-word buf)
+  (let ((i (buffer-skip-reverse buf char-word-constituent?)))
+    (substring (buffer-string buf) (+ i 1) (buffer-pos buf))))
+
+(define (buffer-format-list buf out words)
+  (let ((width (buffer-width buf)))
+    (define (write-rows num-cols widths)
+      (let lp ((ls words) (i 0))
+        (cond
+         ((pair? ls)
+          (let ((diff (- (vector-ref widths i) (string-length (car ls)))))
+            (display (car ls) out)
+            (if (= (+ i 1) num-cols)
+                (newline out)
+                (display (make-string (+ 1 diff) #\space) out))
+            (lp (cdr ls) (modulo (+ i 1) num-cols)))))))
+    (let try-cols ((num-cols (length words)))
+      (cond
+       ((<= num-cols 1)
+        (newline out)
+        (for-each (lambda (x) (display x out) (newline out)) words))
+       (else
+        (let ((widths (make-vector num-cols 0)))
+          (let lp ((ls words) (i 0) (avail (- num-cols 1)))
+            (cond
+             ((null? ls)
+              (write-rows num-cols widths))
+             (else
+              (let ((diff (- (string-length (car ls)) (vector-ref widths i))))
+                (if (positive? diff)
+                    (let ((avail (+ avail diff)))
+                      (cond
+                       ((> avail width)
+                        (try-cols (- num-cols 1)))
+                       (else
+                        (vector-set! widths i (string-length (car ls)))
+                        (lp (cdr ls) (modulo (+ i 1) num-cols) avail))))
+                    (lp (cdr ls) (modulo (+ i 1) num-cols) avail))))))))))))
+
+(define (buffer-make-completer generate)
+  (lambda (ch buf out return)
+    (let* ((word (buffer-previous-word buf))
+           (ls (generate buf word)))
+      (cond
+       ((null? ls)
+        (command/beep ch buf out return))
+       ((= 1 (length ls))
+        (buffer-insert! buf out (substring (car ls) (string-length word))))
+       (else
+        (newline out)
+        (buffer-format-list buf out ls)
+        (buffer-draw buf out))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; keymaps
+
+(define keymap? pair?)
+
+(define (make-keymap . o)
+  (cons (make-vector 256 #f) (and (pair? o) (car o))))
+
+(define (make-sparse-keymap . o)
+  (cons '() (and (pair? o) (car o))))
+
+(define (make-printable-keymap)
+  (let* ((keymap (make-keymap))
+         (v (car keymap)))
+    (do ((i #x20 (+ i 1))) ((= i #x7F) keymap)
+      (vector-set! v i command/self-insert))))
+
+(define (make-standard-escape-bracket-keymap)
+  (let* ((keymap (make-keymap))
+         (v (car keymap)))
+    (vector-set! v 65 command/backward-history)
+    (vector-set! v 66 command/forward-history)
+    (vector-set! v 67 command/forward-char)
+    (vector-set! v 68 command/backward-char)
+    keymap))
+
+(define (make-standard-escape-keymap)
+  (let* ((keymap (make-keymap))
+         (v (car keymap)))
+    (vector-set! v   8 command/backward-delete-word)
+    (vector-set! v  91 (make-standard-escape-bracket-keymap))
+    (vector-set! v  98 command/backward-word)
+    (vector-set! v 100 command/forward-delete-word)
+    (vector-set! v 102 command/forward-word)
+    (vector-set! v 127 command/backward-delete-word)
+    keymap))
+
+(define (make-standard-keymap)
+  (let* ((keymap (make-printable-keymap))
+         (v (car keymap)))
+    (vector-set! v   0 command/enter)   ;; for telnet
+    (vector-set! v   1 command/beginning-of-line)
+    (vector-set! v   2 command/backward-char)
+    (vector-set! v   3 command/cancel)
+    (vector-set! v   4 command/forward-delete-char)
+    (vector-set! v   5 command/end-of-line)
+    (vector-set! v   6 command/forward-char)
+    (vector-set! v   8 command/backward-delete-char)
+    (vector-set! v  10 command/enter)
+    (vector-set! v  11 command/forward-delete-line)
+    (vector-set! v  12 command/refresh)
+    (vector-set! v  13 command/skip)
+    (vector-set! v  21 command/backward-delete-line)
+    (vector-set! v  27 (make-standard-escape-keymap))
+    (vector-set! v 127 command/backward-delete-char)
+    keymap))
+
+(define (keymap-lookup keymap n)
+  (let ((table (car keymap)))
+    (or (if (vector? table)
+            (and (< -1 n (vector-length table)) (vector-ref table n))
+            (cond ((assv n table) => cdr) (else #f)))
+        (if (keymap? (cdr keymap))
+            (keymap-lookup (cdr keymap) n)
+            (cdr keymap)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; commands
+
+(define (command/self-insert ch buf out return)
+  (buffer-insert! buf out ch))
+
+(define (command/enter ch buf out return)
+  (guard (exn (else
+               (buffer-clear buf out)
+               (print-exception exn out)
+               (buffer-draw buf out)))
+    (cond
+     (((buffer-complete? buf) buf)
+      (command/end-of-line ch buf out return)
+      (display "\r\n" out)
+      (flush-output out)
+      (return))
+     (else
+      (command/self-insert ch buf out return)))))
+
+(define (command/cancel ch buf out return)
+  (command/end-of-line ch buf out return)
+  (display "^C" out)
+  (newline out)
+  (buffer-delete! buf out 0 (buffer-length buf))
+  (buffer-draw buf out))
+
+(define (command/beep ch buf out return)
+  (write-char (integer->char 7) out))
+
+(define (command/skip ch buf out return)
+  #f)
+
+(define (command/refresh ch buf out return)
+  (buffer-draw buf out))
+
+(define (command/beginning-of-line ch buf out return)
+  (buffer-goto! buf out 0))
+
+(define (command/end-of-line ch buf out return)
+  (buffer-goto! buf out (buffer-length buf)))
+
+(define (command/forward-char ch buf out return)
+  (buffer-goto! buf out (+ (buffer-pos buf) 1)))
+
+(define (command/backward-char ch buf out return)
+  (buffer-goto! buf out (- (buffer-pos buf) 1)))
+
+(define (command/forward-delete-char ch buf out return)
+  (cond
+   ((zero? (- (buffer-length buf) (buffer-min buf)))
+    (newline out)
+    (return 'eof))
+   (else
+    (buffer-delete! buf out (buffer-pos buf) (+ (buffer-pos buf) 1)))))
+
+(define (command/backward-delete-char ch buf out return)
+  (buffer-delete! buf out (- (buffer-pos buf) 1) (buffer-pos buf)))
+
+(define (command/forward-delete-line ch buf out return)
+  (buffer-delete! buf out (buffer-pos buf) (buffer-length buf)))
+
+(define (command/backward-delete-line ch buf out return)
+  (buffer-delete! buf out 0 (buffer-pos buf)))
+
+(define (command/backward-history ch buf out return)
+  (let ((history (buffer-history buf)))
+    (cond
+     ((and (history? history) (pair? (history-past history)))
+      (if (null? (history-future history))
+          (history-insert! history (buffer->string buf)))
+      (cond
+       ((pair? (cdr (history-past history)))
+        (buffer-delete! buf out 0 (buffer-length buf))
+        (buffer-insert! buf out (history-prev! history))))))))
+
+(define (command/forward-history ch buf out return)
+  (let ((history (buffer-history buf)))
+    (cond
+     ((and (history? history) (pair? (history-future history)))
+      (buffer-delete! buf out 0 (buffer-length buf))
+      (let ((res (buffer-insert! buf out (history-next! history))))
+        (if (null? (history-future history))
+            (history-past-set! history (cdr (history-past history))))
+        res)))))
+
+(define (command/forward-word ch buf out return)
+  (buffer-goto! buf out (buffer-skip buf char-non-word-constituent?))
+  (buffer-goto! buf out (buffer-skip buf char-word-constituent?)))
+
+(define (command/backward-word ch buf out return)
+  (buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?))
+  (buffer-goto! buf out (+ (buffer-skip-reverse buf char-word-constituent?) 1)))
+
+(define (command/forward-delete-word ch buf out return)
+  (let ((start (buffer-pos buf)))
+    (buffer-goto! buf out (buffer-skip buf char-non-word-constituent?))
+    (buffer-delete! buf out start (buffer-skip buf char-word-constituent?))))
+
+(define (command/backward-delete-word ch buf out return)
+  (let ((end (buffer-pos buf)))
+    (buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?))
+    (let ((start (buffer-skip-reverse buf char-word-constituent?)))
+      (buffer-delete! buf out (+ start 1) end))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; line-editing
+
+(define standard-keymap (make-standard-keymap))
+
+(define (get-key ls key . o)
+  (let ((x (memq key ls)))
+    (if (and x (pair? (cdr x))) (cadr x) (and (pair? o) (car o)))))
+
+(define (with-leading-ports ls proc)
+  (if (and (pair? ls) (input-port? (car ls)))
+      (if (and (pair? (cdr ls)) (output-port? (cadr ls)))
+          (proc (car ls) (cadr ls) (cddr ls))
+          (proc (car ls) (current-output-port) (cdr ls)))
+      (proc (current-input-port) (current-output-port) ls)))
+
+(define (make-line-editor . args)
+  (let* ((prompter (get-key args 'prompt: "> "))
+         (history (get-key args 'history:))
+         (complete? (get-key args 'complete?: (lambda (buf) #t)))
+         (completion (get-key args 'completion: #f))
+         (terminal-width (get-key args 'terminal-width:))
+         (single-line? (get-key args 'single-line?: #f))
+         (no-stty? (get-key args 'no-stty?: #f))
+         (keymap0 (get-key args 'keymap: standard-keymap))
+         (keymap (if completion
+                     (cons (list (cons 9 completion)) keymap0)
+                     keymap0))
+         (buf (or (get-key args 'buffer: #f) (make-buffer))))
+    (lambda (in out)
+      (let* ((width (or terminal-width (get-terminal-width out) 80))
+             (prompt (if (procedure? prompter) (prompter) prompter))
+             (done? #f)
+             (return (lambda o (set! done? (if (pair? o) (car o) #t)))))
+        ;; Clear buffer and reset prompt.
+        (buffer-refresh?-set! buf #t)
+        (buffer-min-set! buf 0)
+        (buffer-delete! buf out 0 (buffer-length buf))
+        (buffer-width-set! buf width)
+        (buffer-insert! buf out prompt)
+        (buffer-min-set! buf (string-length prompt))
+        (buffer-history-set! buf history)
+        (buffer-complete?-set! buf complete?)
+        (buffer-single-line?-set! buf single-line?)
+        (if single-line? (buffer-start-set! buf (buffer-min buf)))
+        (buffer-refresh buf out)
+        (flush-output out)
+        ((if no-stty? (lambda (out f) (f)) with-raw-io)
+         out
+         (lambda ()
+           (let lp ((kmap keymap))
+             (let ((ch (read-char in)))
+               (if (eof-object? ch)
+                   (let ((res (buffer->string buf)))
+                     (if (equal? res "") ch res))
+                   (let ((x (keymap-lookup kmap (char->integer ch))))
+                     (cond
+                      ((keymap? x)
+                       (lp x))
+                      ((procedure? x)
+                       (guard (exn (else
+                                    (buffer-clear buf out)
+                                    (print-exception exn out)
+                                    (buffer-draw buf out)))
+                         (x ch buf out return))
+                       (flush-output out)
+                       (buffer-refresh buf out)
+                       (if done?
+                           (and (not (eq? done? 'eof)) (buffer->string buf))
+                           (lp keymap)))
+                      (else
+                       ;;(command/beep ch buf out return)
+                       (lp keymap)))))))))))))
+
+(define (edit-line . args)
+  (with-leading-ports
+   args
+   (lambda (in out rest) ((apply make-line-editor rest) in out))))
+
+(define (edit-line-repl . args)
+  (with-leading-ports
+   args
+   (lambda (in out rest)
+     (let ((eval (get-key rest 'eval: (lambda (x) x)))
+           (print (get-key rest 'write: write))
+           (history (or (get-key rest 'history:) (make-history))))
+       (let ((edit-line
+              (apply make-line-editor 'no-stty?: #t 'history: history rest)))
+         ((if (get-key args 'no-stty?:) (lambda (out f) (f)) with-raw-io)
+          out
+          (lambda ()
+            (let lp ()
+              (let ((line (edit-line in out)))
+                (if (pair? (history-future history))
+                    (history-past-set! history (cdr (history-past history))))
+                (history-commit! history line)
+                (print (eval line) out)
+                (newline out)
+                (lp))))))))))

lib/chibi/term/edit-line.sld

@@ -0,0 +1,8 @@
+
+(define-library (chibi term edit-line)
+  (export make-line-editor edit-line edit-line-repl
+          make-history history-insert!
+          history-commit! history->list list->history buffer->string
+          make-buffer buffer-make-completer buffer-row buffer-col)
+  (import (scheme) (chibi stty) (srfi 9))
+  (include "edit-line.scm"))