removing redundant sexp_heap_align definition

.hgignore

@@ -0,0 +1,30 @@
+syntax: glob
+*~
+*.i
+*.s
+*.o
+*.so
+*.dylib
+*.class
+*.dSYM
+*.orig
+.hg
+junk*
+*.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

AUTHORS

@@ -0,0 +1,29 @@
+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:
+
+  * Alexander Shendi
+  * Andreas Rottman
+  * Bruno Deferrari
+  * Derrick Eddington
+  * Eduardo Cavazos
+  * Felix Winkelmann
+  * Gregor Klinke
+  * Jeremy Wolff
+  * Jeronimo Pellegrini
+  * John Cowan
+  * John Samsa
+  * Lars J Aas
+  * Lorenzo Campedelli
+  * Michal Kowalski (sladegen)
+  * Taylor Venable
+
+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,246 @@
+# -*- makefile-gmake -*-
+
+.PHONY: all libs doc dist clean cleaner dist-clean test install uninstall
+.PRECIOUS: %.c
+
+# install configuration
+
+CC       ?= cc
+PREFIX   ?= /usr/local
+BINDIR   ?= $(PREFIX)/bin
+LIBDIR   ?= $(PREFIX)/lib
+SOLIBDIR ?= $(PREFIX)/lib
+INCDIR   ?= $(PREFIX)/include/chibi
+MODDIR   ?= $(PREFIX)/share/chibi
+LIBDIR   ?= $(PREFIX)/lib/chibi
+MANDIR   ?= $(PREFIX)/share/man/man1
+
+DESTDIR  ?=
+
+GENSTUBS  ?= ./tools/genstubs.scm
+GENSTATIC ?= ./tools/genstatic.scm
+
+########################################################################
+# system configuration - if not using GNU make, set PLATFORM and the
+# following flags as necessary.
+
+# 
+LIBDL = -ldl
+
+ifndef PLATFORM
+ifeq ($(shell uname),Darwin)
+PLATFORM=macosx
+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
+PLATFORM=unix
+endif
+endif
+endif
+endif
+
+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
+endif
+endif
+endif
+
+ifeq ($(USE_BOEHM),1)
+SEXP_USE_BOEHM = 1
+endif
+
+ifeq ($(SEXP_USE_BOEHM),1)
+GCLDFLAGS := -lgc
+XCPPFLAGS := $(CPPFLAGS) -Iinclude -DSEXP_USE_BOEHM=1
+else
+GCLDFLAGS :=
+XCPPFLAGS := $(CPPFLAGS) -Iinclude
+endif
+
+ifeq ($(SEXP_USE_DL),0)
+XLDFLAGS  := $(LDFLAGS) $(GCLDFLAGS) -lm
+XCFLAGS   := -Wall -DSEXP_USE_DL=0 -g3 $(CFLAGS)
+else
+XLDFLAGS  := $(LDFLAGS) $(GCLDFLAGS) $(LIBDL) -lm
+XCFLAGS   := -Wall -g3 $(CFLAGS)
+endif
+
+########################################################################
+
+all: chibi-scheme$(EXE) libs
+
+COMPILED_LIBS := lib/srfi/18/threads$(SO) lib/srfi/27/rand$(SO) \
+	lib/srfi/33/bit$(SO) lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) \
+	lib/srfi/98/env$(SO) lib/chibi/ast$(SO) lib/chibi/net$(SO) \
+	lib/chibi/filesystem$(SO) lib/chibi/process$(SO) lib/chibi/time$(SO) \
+	lib/chibi/system$(SO) lib/chibi/io/io$(SO) lib/chibi/stty$(SO) \
+	lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO)
+
+libs: $(COMPILED_LIBS)
+
+INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h include/chibi/bignum.h
+
+include/chibi/install.h: Makefile
+	echo '#define sexp_so_extension "'$(SO)'"' > $@
+	echo '#define sexp_default_module_dir "'$(MODDIR)'"' >> $@
+	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 $(INCLUDES) Makefile
+	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $<
+
+eval.o: eval.c opcodes.c vm.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile
+	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $<
+
+main.o: main.c $(INCLUDES) include/chibi/eval.h 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
+
+clibs.c: $(GENSTATIC) lib lib/chibi lib/srfi
+	make chibi-scheme$(EXE)
+	make libs
+	LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" PATH=".:$(PATH)" $(GENSTATIC) $< > $@
+
+%.c: %.stub $(GENSTUBS)
+	make chibi-scheme$(EXE)
+	-LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" PATH=".:$(PATH)" $(GENSTUBS) $<
+
+lib/%$(SO): lib/%.c $(INCLUDES)
+	-$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme
+
+clean:
+	rm -f *.o *.i *.s *.8
+	find lib -name \*$(SO) -exec rm -f '{}' \;
+	rm -f tests/basic/*.out tests/basic/*.err
+
+cleaner: clean
+	rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) $(COMPILED_LIBS) *$(SO) *.a include/chibi/install.h
+	rm -rf *.dSYM
+
+dist-clean: cleaner
+	for f in `find lib -name \*.stub`; do rm -f $${f%.stub}.c; done
+
+test-basic: chibi-scheme$(EXE)
+	@for f in tests/basic/*.scm; do \
+	    LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) $$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-build:
+	./tests/build/build-tests.sh
+
+test-threads: chibi-scheme$(EXE)
+	LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/thread-tests.scm
+
+test-numbers: chibi-scheme$(EXE)
+	LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/numeric-tests.scm
+
+test-flonums: chibi-scheme$(EXE)
+	LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/flonum-tests.scm
+
+test-hash: chibi-scheme$(EXE)
+	LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/hash-tests.scm
+
+test-match: chibi-scheme$(EXE)
+	LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/match-tests.scm
+
+test-loop: chibi-scheme$(EXE)
+	LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/loop-tests.scm
+
+test-sort: chibi-scheme$(EXE)
+	LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/sort-tests.scm
+
+test-libs: chibi-scheme$(EXE)
+	LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/lib-tests.scm
+
+test: chibi-scheme$(EXE)
+	LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/r5rs-tests.scm
+
+install: chibi-scheme$(EXE)
+	mkdir -p $(DESTDIR)$(BINDIR)
+	cp chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/
+	cp tools/genstubs.scm $(DESTDIR)$(BINDIR)/
+	mkdir -p $(DESTDIR)$(MODDIR)
+	cp -r lib/* $(DESTDIR)$(MODDIR)/
+	mkdir -p $(DESTDIR)$(INCDIR)
+	cp $(INCLUDES) include/chibi/eval.h $(DESTDIR)$(INCDIR)/
+	mkdir -p $(DESTDIR)$(LIBDIR)
+	mkdir -p $(DESTDIR)$(SOLIBDIR)
+	cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/
+	cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/
+	-cp libchibi-scheme.a $(DESTDIR)$(LIBDIR)/
+	mkdir -p $(DESTDIR)$(MANDIR)
+	cp doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/
+	-if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi
+
+uninstall:
+	rm -f $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE)
+	rm -f $(DESTDIR)$(BINDIR)/chibi-scheme-static$(EXE)
+	rm -f $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO)
+	rm -f $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a
+	cd $(DESTDIR)$(INCDIR) && rm -f $(INCLUDES) include/chibi/eval.h
+	rm -rf $(DESTDIR)$(MODDIR)
+
+dist: dist-clean
+	rm -f chibi-scheme-`cat VERSION`.tgz
+	mkdir chibi-scheme-`cat VERSION`
+	for f in `hg manifest`; do mkdir -p chibi-scheme-`cat VERSION`/`dirname $$f`; ln -s `pwd`/$$f chibi-scheme-`cat VERSION`/$$f; done
+	tar cphzvf chibi-scheme-`cat VERSION`.tgz chibi-scheme-`cat VERSION`
+	rm -rf chibi-scheme-`cat VERSION`
+
+mips-dist: dist-clean
+	rm -f 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 -p chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/`dirname $$f`; ln -s `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 -rf chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`

README

@@ -0,0 +1,440 @@
+
+                             Chibi-Scheme
+                            --------------
+                                   
+    Minimal Scheme Implementation for use as an Extension Language
+
+              http://synthcode.com/wiki/chibi-scheme/
+
+
+Chibi-Scheme is a very small but mostly complete R5RS Scheme
+implementation using a reasonably fast custom VM.  Chibi-Scheme tries
+as much as possible not to trade its small size by cutting corners,
+and provides full continuations, both low and high-level hygienic
+macros based on syntactic-closures, string ports and exceptions.
+Chibi-Scheme is written in highly portable C and supports multiple
+simultaneous VM instances to run.
+
+------------------------------------------------------------------------
+INSTALLING
+
+To build, just run "make".  This will provide a shared library
+"libchibi-scheme", as well as a sample "chibi-scheme" command-line
+repl.  The "chibi-scheme-static" make target builds an equivalent
+static executable.
+
+You can edit the file chibi/features.h for a number of settings,
+mostly disabling features to make the executable smaller.  You can
+specify standard options directly as arguments to make, for example
+
+  make CFLAGS=-Os CPPFLAGS=-DSEXP_USE_NO_FEATURES=1
+
+to optimize for size, or
+
+  make LDFLAGS=-L/usr/local/lib CPPFLAGS=-I/usr/local/include
+
+to compile against a library installed in /usr/local.
+
+By default Chibi uses a custom, precise, non-moving GC.  You can link
+against the Boehm conservative GC by editing the features.h file, or
+directly from make with:
+
+  make SEXP_USE_BOEHM=1
+
+To compile a static executable, use
+
+  make chibi-scheme-static SEXP_USE_DL=0
+
+To compile a static executable with all C libraries statically
+included, first you need to create a clibs.c file, which can be done
+with:
+
+  make clibs.c
+
+or edited manually.  Be sure to run this with a non-static
+chibi-scheme.  Then you can make the static executable with:
+
+  make cleaner
+  make chibi-scheme-static SEXP_USE_DL=0 CPPFLAGS=-DSEXP_USE_STATIC_LIBS
+
+------------------------------------------------------------------------
+CHIBI-SCHEME LANGUAGE
+
+The default language is mostly compatible with the R5RS, with all
+differences made by design, not through difficulty of implementation.
+The following procedures are omitted:
+
+  transcript-on and transcript-off (because they're silly)
+  rationalize (pending the addition of rational numbers)
+
+Apart from this, chibi-scheme is case-sensitive, unlike the R5RS.
+The default configuration includes fixnums, flonums and bignums
+but no exact rationals or complex numbers.
+
+Full continuations are supported, but currently continuations don't
+take C code into account.  The only higher-order C functions in the
+standard environment are LOAD and EVAL.
+
+LOAD is extended to accept an optional environment argument, like
+EVAL.  You can also LOAD shared libraries in addition to Scheme source
+files - in this case the function sexp_init_library is automatically
+called with the following signature:
+
+  sexp_init_library(sexp context, sexp environment)
+
+SYNTAX-RULES macros are provided by default, with the extensions from
+SRFI-46.  In addition, low-level hygienic macros are provided with
+a syntactic-closures interface, including SC-MACRO-TRANSFORMER,
+RSC-MACRO-TRANSFORMER, and ER-MACRO-TRANSFORMER.  A good introduction
+to syntactic-closures can be found at:
+
+  http://community.schemewiki.org/?syntactic-closures
+
+IDENTIFIER?, IDENTIFIER->SYMBOL, IDENTIFIER=?, and
+MAKE-SYNTACTIC-CLOSURE and STRIP-SYNTACTIC-CLOSURES are provided.
+
+SRFI-0's COND-EXPAND is provided, with the feature `chibi'.
+
+STRING-CONCATENATE concatenates a list of strings.
+
+------------------------------------------------------------------------
+TYPES
+
+You can define new data types with SRFI-9.  This is just syntactic
+sugar for the following more primitive type constructors:
+
+(register-simple-type <name-string> <num-fields>)
+ => <type-id> ; a fixnum
+
+(make-type-predicate <opcode-name-string> <type-id>)
+ => <opcode>  ; takes 1 arg, returns #t iff that arg is of the type
+
+(make-constructor <constructor-name-string> <type-id>)
+ => <opcode>  ; takes 0 args, returns a newly allocated instance of type
+
+(make-getter <getter-name-string> <type-id> <field-index>)
+ => <opcode>  ; takes 1 args, retrieves the field located at the index
+
+(make-setter <setter-name-string> <type-id> <field-index>)
+ => <opcode>  ; takes 2 args, sets the field located at the index
+
+------------------------------------------------------------------------
+MODULE SYSTEM
+
+A configurable module system, in the style of the Scheme48 module
+system, is provided by default.
+
+Modules names are hierarchical lists of symbols or numbers.  The
+definition of the module (foo bar baz) is searched for in the file
+foo/bar/baz.module.  This file should contain an expression of the
+form:
+
+  (define-module (foo bar baz)
+    <module-declarations> ...)
+
+where <module-declarations> can be any of
+
+  (export <id> ...)                    - specify an export list
+  (import <import-spec> ...)           - specify one or more imports
+  (import-immutable <import-spec> ...) - specify an immutable import
+  (body <expr> ...)                    - inline Scheme code
+  (include <file> ...)                 - load one or more files
+  (include-shared <file> ...)          - dynamic load a library
+
+<import-spec> can either be a module name or any of
+
+  (only <import-spec> <id> ...)
+  (except <import-spec> <id> ...)
+  (rename <import-spec> (<from-id> <to-id>) ...)
+  (prefix <prefix-id> <import-spec>)
+
+The can be composed and perform basic selection and renaming of
+individual identifiers from the given module.
+
+Files are loaded relative to the .module file, and are written with
+their extension (so you can use whatever suffix you prefer - .scm,
+.ss, .sls, etc.).
+
+Shared modules, on the other hand, should be specified _without_ the
+extension - the correct suffix will be added portably (e.g. .so for
+Unix and .dylib for OS X).
+
+You may also use COND-EXPAND and arbitrary macro expansions in a
+module definition to generate <module-declarations>.
+
+------------------------------------------------------------------------
+MODULES
+
+The default environment is (scheme) - you almost always want to import
+this.
+
+Currently you can load the following SRFIs with (import (srfi N)):
+
+  (srfi 0)  - cond-expand
+  (srfi 1)  - list library
+  (srfi 2)  - and-let*
+  (srfi 6)  - basic string ports
+  (srfi 8)  - receive
+  (srfi 9)  - define-record-type
+  (srfi 11) - let-values/let*-values
+  (srfi 16) - case-lambda
+  (srfi 22) - running scheme scripts on Unix
+  (srfi 23) - error reporting mechanism
+  (srfi 26) - cut/cute partial application
+  (srfi 27) - sources of random bits
+  (srfi 33) - bitwise operators
+  (srfi 39) - prameter objects
+  (srfi 46) - basic syntax-rules extensions
+  (srfi 62) - s-expression comments
+  (srfi 69) - basic hash tables
+  (srfi 95) - sorting and merging
+  (srfi 98) - environment access
+
+although 0, 22, 23, 46 and 62 are built into the default environment
+so there's no need to import them.
+
+Included non-standard modules are put in the (chibi) module namespace.
+The following additional modules are available:
+
+  (chibi net)         - networking interface
+  (chibi filesystem)  - local filesystem and file descriptor interface
+  (chibi process)     - processes and signals
+  (chibi system)      - host system and user information
+  (chibi time)        - time and date library
+  (chibi match)       - pattern-matching library
+  (chibi loop)        - extensible loop syntax
+  (chibi pathname)    - pathname manipulation utilities
+  (chibi uri)         - URI parsing and construction utilities
+  (chibi macroexpand) - macro expansion utility
+  (chibi ast)         - interface to the internal Abstract Syntax Tree
+  (chibi disasm)      - disassembly utility for the chibi VM
+  (chibi heap-stats)  - debugging tool to analyze or dump the heap
+
+------------------------------------------------------------------------
+C INTERFACE
+
+See the file main.c for an example of using chibi-scheme as a library.
+
+The basic usage involves creating a context for evaluation and loading
+or evaluating Scheme source with it.  Begin by including the eval.h
+header file:
+
+  #include <chibi/eval.h>
+
+then call
+
+  sexp_scheme_init();
+
+with no parameters to initialize any globals (this actually does
+nothing in the standard configuration but is a good idea to call
+anyway).
+
+Then you can use the following to create and manipulate contexts:
+
+  sexp_make_eval_context(context, stack, environment, heap_size)
+    Creates a new context with the given stack and environment.
+    If context is non-NULL, this will be the "parent" context and
+    the two contexts will share a heap.  Otherwise, a new heap
+    will be allocated with heap_size, or a default size if heap_size
+    is zero.  stack and environment may both also be NULL (and _must_
+    be NULL if context is NULL) and will be given standard defaults.
+
+    Thus to create your first context you generally call:
+
+      sexp_make_eval_context(NULL, NULL, NULL, 0)
+
+    You can create as many contexts as you want, and other than those
+    sharing a heap they are all independent and thread-safe.
+
+  sexp_load_standard_env(context, env, version)
+    Loads the init.scm file in the environment env.  Version refers
+    to the RnRS version number and should always be SEXP_FIVE.  The
+    environment created with sexp_make_eval_context only contains
+    core syntactic forms and C primitives (thus for example it has
+    CAR but not CADR or LIST), so to get a full featured
+    environment, plus a module system with which to load additional
+    modules, you want to use this.
+
+  sexp_destroy_context(context)
+    Signals that you no longer need context, or any other context
+    sharing the heap.  It will thus free() the context and heap and
+    all associated memory.  Does nothing if using the Boehm GC.
+
+Environments can be handled with the following:
+
+  sexp_context_env(context)
+    A macro returning the default environment associated with context.
+
+  sexp_env_define(context, env, symbol, value)
+    Define a variable in an environment.
+
+  sexp_env_ref(env, symbol, dflt)
+    Fetch the binding for symbol from the environment env,
+    returning the default dflt if the symbol is unbound.
+
+You can evaluate code with the following utility:
+
+  sexp_eval(context, expr, env)
+    Evaluates an s-expression in an environment.
+    env can be NULL to use the context's default env.
+
+  sexp_eval_string(context, str, env)
+    Reads an s-expression from str and evaluates it in env.
+
+  sexp_load(context, file, env)
+    Read and eval all top-level forms from file in environment env.
+    As described in LOAD above, file may be a shared library.
+
+To define new primitive functions from C, use sexp_define_foreign,
+which takes a Scheme environment, a name, a number of arguments the C
+function takes (not counting the context argument), and a C function.
+
+  /* sexp_define_foreign(context, env, name, num_args, f) */
+
+  sexp add (sexp context, sexp x, sexp y) {
+    return sexp_fx_add(x, y);
+  }
+
+  sexp_define_foreign(context, env, "add", 2, add);
+
+You can also define functions with a single optional argument:
+
+  sexp_define_foreign_opt(context, env, "add", 2, add, sexp_make_fixnum(1));
+
+See the SRFI-69 implementation for more detailed examples of this.
+
+------------------------------------------------------------------------
+FFI
+
+Simple C FFI.  "genstubs.scm file.stub" will read in the C function
+FFI definitions from file.stub and output the appropriate C
+wrappers into file.c.  You can then compile that file with:
+
+  cc -fPIC -shared file.c -lchibi-scheme
+
+(or using whatever flags are appropriate to generate shared libs on
+your platform) and then the generated .so file can be loaded
+directly with LOAD, or portably using (include-shared "file") in a
+module definition (note that include-shared uses no suffix).
+
+The goal of this interface is to make access to C types and
+functions easy, without requiring the user to write any C code.
+That means the stubber needs to be intelligent about various C
+calling conventions and idioms, such as return values passed in
+actual parameters.  Writing C by hand is still possible, and
+several of the core modules provide C interfaces directly without
+using the stubber.
+
+================================
+
+Struct Interface
+
+(define-c-struct struct-name
+  [predicate: predicate-name]
+  [constructor: constructor-name]
+  [finalizer: c_finalizer_name]
+  (type c_field_name getter-name setter-name) ...)
+
+
+================================
+
+
+Function Interface
+
+(define-c return-type name-spec (arg-type ...))
+
+where name-space is either a symbol name, or a list of
+(scheme-name c_name).  If just a symbol, the C name is taken
+to be the same with -'s replaced by _'s.
+
+arg-type is a type suitable for input validation and conversion.
+
+================================
+
+
+Types
+
+Types
+
+Basic Types
+  void
+  boolean
+  char
+  sexp (no conversions)
+
+Integer Types:
+  signed-char short int long
+  unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t
+  time_t (in seconds, but using the chibi epoch of 2010/01/01)
+  errno (as a return type returns #f on error)
+
+Float Types:
+  float double long-double
+
+String Types:
+  string - a null-terminated char*
+  env-string - a VAR=VALUE string represented as a (VAR . VALUE) pair inScheme
+  in addition you can use (array char) as a string
+
+Port Types:
+  input-port output-port
+
+Struct Types:
+
+Struct types are by default just referred to by the bare
+struct-name from define-c-struct, and it is assumed you want a
+pointer to that type.  To refer to the full struct, use the struct
+modifier, as in (struct struct-name).
+
+Type modifiers
+
+Any type may also be written as a list of modifiers followed by the
+type itself.  The supported modifiers are:
+
+const: prepends the "const" C type modifier
+       * as a return or result parameter, makes non-immediates immutable
+
+free:  it's Scheme's responsibility to "free" this resource
+       * as a return or result parameter, registers the freep flag
+         this causes the type finalizer to be run when GCed
+
+maybe-null: this pointer type may be NULL
+       * as a result parameter, NULL is translated to #f
+         normally this would just return a wrapped NULL pointer
+       * as an input parameter, #f is translated to NULL
+         normally this would be a type error
+
+pointer: create a pointer to this type
+       * as a return parameter, wraps the result in a vanilla cpointer
+       * as a result parameter, boxes then unboxes the value
+
+struct: treat this struct type as a struct, not a pointer
+       * as an input parameter, dereferences the pointer
+       * as a type field, indicates a nested struct
+
+link:  add a gc link
+       * as a field getter, link to the parent object, so the
+         parent won't be GCed so long as we have a reference
+         to the child.  this behavior is automatic for nested
+         structs.
+
+result: return a result in this parameter
+       * if there are multiple results (including the return type),
+         they are all returned in a list
+       * if there are any result parameters, a return type
+         of errno returns #f on failure, and as eliminated
+         from the list of results otherwise
+
+(value <expr>): specify a fixed value
+       * as an input parameter, this parameter is not provided
+         in the Scheme API but always passed as <expr>
+
+(default <expr>): specify a default value
+       * as the final input parameter, makes the Scheme parameter
+         optional, defaulting to <expr>
+
+(array <type> [<length>])  an array type
+       * length must be specified for return and result parameters
+       * if specified, length can be any of
+       ** an integer, for a fixed size
+       ** the symbol null, indicating a NULL-terminated array

RELEASE

@@ -0,0 +1 @@
+lithium

TODO

@@ -0,0 +1,165 @@
+-*- 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 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
+** TODO type inference with warnings
+
+* 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]
+** TODO support weak 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 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]
+** TODO network interface
+** 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]
+** TODO iPhone support
+** TODO bare-metal support
+
+* miscellaneous
+** TODO overall cleanup
+** TODO user documentation
+** TODO thorough source documentation
+** TODO full test suite for libraries
+
+* distribution
+** TODO packaging format
+** TODO code repository with fetch+install tool
+** TODO translator to/from other implementations
+

VERSION

@@ -0,0 +1 @@
+0.3

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>

doc/chibi-scheme.1

@@ -0,0 +1,133 @@
+.TH "chibi-scheme" "1" "" ""
+.UC 4
+.SH NAME
+.PP
+chibi-scheme \- a tiny Scheme interpreter
+
+.SH SYNOPSIS
+.B chibi-scheme
+[-qV]
+[-I
+.I path
+]
+[-A
+.I path
+]
+[-m
+.I module
+]
+[-l
+.I file
+]
+[-e
+.I expr
+]
+[-p
+.I expr
+]
+[--]
+[
+.I script argument ...
+]
+.br
+.sp 0.3
+
+.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.
+
+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.
+
+.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 -h size
+Specifies the initial size of the heap, in bytes.
+.I size
+can be any integer value, optionally suffixed by
+"K" for kilobytes, or "M" for megabytes.
+.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
+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
+.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.
+
+.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/

gc.c

@@ -0,0 +1,346 @@
+/*  gc.c -- simple mark&sweep garbage collector               */
+/*  Copyright (c) 2009-2010 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
+
+#define SEXP_MINIMUM_OBJECT_SIZE (sexp_heap_align(sexp_sizeof(pair)))
+
+#if SEXP_USE_GLOBAL_HEAP
+sexp_heap sexp_global_heap;
+#endif
+
+#if SEXP_USE_CONSERVATIVE_GC
+static sexp* stack_base;
+#endif
+
+static sexp_heap sexp_heap_last (sexp_heap h) {
+  while (h->next) h = h->next;
+  return h;
+}
+
+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);
+  return res;
+}
+
+#if SEXP_USE_SAFE_GC_MARK
+static int sexp_in_heap(sexp ctx, sexp_uint_t x) {
+  sexp_heap h;
+  if (x & (sexp_heap_align(1)-1)) {
+    fprintf(stderr, "invalid heap alignment: %p %d\n", (sexp)x, sexp_pointer_tag((sexp)x));
+    return 0;
+  }
+  for (h=sexp_context_heap(ctx); h; h=h->next)
+    if (((sexp_uint_t)h < x) && (x < (sexp_uint_t)(h->data + h->size)))
+      return 1;
+  fprintf(stderr, "invalid object outside heap: %p %d\n", (sexp)x, sexp_pointer_tag((sexp)x));
+  return 0;
+}
+#endif
+
+#if SEXP_USE_DEBUG_GC
+#include "opt/gc_debug.c"
+#endif
+
+void sexp_mark (sexp ctx, sexp x) {
+  sexp_sint_t i, len;
+  sexp t, *p;
+  struct sexp_gc_var_t *saves;
+ loop:
+  if ((! x) || (! sexp_pointerp(x)) || sexp_gc_mark(x))
+    return;
+#if SEXP_USE_SAFE_GC_MARK
+  if (! sexp_in_heap(ctx, (sexp_uint_t)x))
+    return;
+#endif
+#if SEXP_USE_HEADER_MAGIC
+  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)
+    return;
+#endif
+  sexp_gc_mark(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);
+  p = (sexp*) (((char*)x) + sexp_type_field_base(t));
+  len = sexp_type_num_slots_of_object(t, x) - 1;
+  if (len >= 0) {
+    for (i=0; i<len; i++)
+      sexp_mark(ctx, p[i]);
+    x = p[len];
+    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;
+}
+#else
+#define stack_references_pointer_p(ctx, x) 0
+#endif
+
+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;
+  sexp_proc2 finalizer;
+  /* scan over the whole heap */
+  for ( ; h; h=h->next) {
+    p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair)));
+    q = h->free_list;
+    end = (sexp) ((char*)h->data + h->size - sexp_heap_align(sexp_sizeof(pair)));
+    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_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) {
+        /* free p */
+        finalizer = sexp_type_finalize(sexp_object_type(ctx, p));
+        if (finalizer) finalizer(ctx sexp_api_pass(NULL, 1), p);
+        sum_freed += size;
+        if (((((char*)q) + q->size) == (char*)p) && (q != h->free_list)) {
+          /* merge q with p */
+          if (r && ((((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 && ((((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_gc_mark(p) = 0;
+        p = (sexp) (((char*)p)+size);
+      }
+    }
+  }
+  if (sum_freed_ptr) *sum_freed_ptr = sum_freed;
+  return sexp_make_fixnum(max_freed);
+}
+
+sexp sexp_gc (sexp ctx, size_t *sum_freed) {
+  sexp res;
+#if SEXP_USE_GLOBAL_SYMBOLS
+  int i;
+  for (i=0; i<SEXP_SYMBOL_TABLE_SIZE; i++)
+    sexp_mark(ctx, sexp_symbol_table[i]);
+#endif
+  sexp_mark(ctx, ctx);
+#if SEXP_USE_DEBUG_GC
+  sexp_sweep_stats(ctx, 2, NULL, "* \x1B[31mFREE:\x1B[0m ");
+#endif
+  res = sexp_sweep(ctx, sum_freed);
+  return res;
+}
+
+sexp_heap sexp_make_heap (size_t 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 =  malloc(sexp_heap_pad_size(size));
+#endif
+  if (! h) return NULL;
+  h->size = size;
+  h->data = (char*) sexp_heap_align((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_sizeof(pair)));
+  free->size = 0; /* actually sexp_sizeof(pair) */
+  free->next = next;
+  next->size = size - sexp_heap_align(sexp_sizeof(pair));
+  next->next = NULL;
+  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);
+  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 (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;
+  size = sexp_heap_align(size);
+  res = sexp_try_alloc(ctx, size);
+  if (! res) {
+    max_freed = sexp_unbox_fixnum(sexp_gc(ctx, &sum_freed));
+    for (total_size=0, h=sexp_context_heap(ctx); h->next; h=h->next)
+      total_size += h->size;
+    total_size += h->size;
+    if (((max_freed < size)
+         || ((total_size > sum_freed)
+             && (total_size - sum_freed) > (total_size*SEXP_GROW_HEAP_RATIO)))
+        && ((!SEXP_MAXIMUM_HEAP_SIZE) || (total_size < SEXP_MAXIMUM_HEAP_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
+
+sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) {
+  sexp_sint_t i, off, len, freep;
+  sexp_heap to, from = sexp_context_heap(ctx);
+  sexp_free_list q;
+  sexp p, p2, t, end, *v;
+  freep = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_FREEP);
+
+  /* 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);
+    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));
+  to->free_list = (sexp_free_list) ((char*)to->free_list + off);
+  to->data += off;
+  end = (sexp) (from->data + from->size);
+
+  /* adjust the free list */
+  for (q=to->free_list; q->next; q=q->next)
+    q->next = (sexp_free_list) ((char*)q->next + off);
+
+  /* adjust if the destination is larger */
+  if (from->size < to->size) {
+    if (((char*)q + q->size - off) >= (char*)end) {
+      q->size += (to->size - from->size);
+    } else {
+      q->next = (sexp_free_list) ((char*)end + off);
+      q->next->next = NULL;
+      q->next->size = (to->size - from->size);
+    }
+  }
+
+  /* adjust data by traversing over the _original_ heap */
+  p = (sexp) (from->data + sexp_heap_align(sexp_sizeof(pair)));
+  q = from->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_object_type(ctx, p);
+      len = sexp_type_num_slots_of_object(t, p);
+      p2 = (sexp)((char*)p + off);
+      v = (sexp*) ((char*)p2 + 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(p2) = 0;
+      /* adjust context heaps, don't copy saved sexp_gc_vars */
+      if (sexp_contextp(p2)) {
+        sexp_context_saves(p2) = NULL;
+        if (sexp_context_heap(p2) == from)
+          sexp_context_heap(p2) = to;
+      }
+      p = (sexp) (((char*)p)+sexp_heap_align(sexp_allocated_bytes(ctx, p)));
+    }
+  }
+
+  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);
+#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,43 @@
+/*  bignum.h -- header for bignum utilities              */
+/*  Copyright (c) 2009 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);
+
+#endif  /* ! SEXP_BIGNUM_H */
+

include/chibi/eval.h

@@ -0,0 +1,203 @@
+/*  eval.h -- headers for eval library                        */
+/*  Copyright (c) 2009-2010 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_BCODE_SIZE 128
+#define SEXP_INIT_STACK_SIZE 8192
+
+#define sexp_init_file "init.scm"
+#define sexp_config_file "config.scm"
+
+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
+};
+
+enum sexp_opcode_names {
+  SEXP_OP_NOOP,
+  SEXP_OP_RAISE,
+  SEXP_OP_RESUMECC,
+  SEXP_OP_CALLCC,
+  SEXP_OP_APPLY1,
+  SEXP_OP_TAIL_CALL,
+  SEXP_OP_CALL,
+  SEXP_OP_FCALL0,
+  SEXP_OP_FCALL1,
+  SEXP_OP_FCALL2,
+  SEXP_OP_FCALL3,
+  SEXP_OP_FCALL4,
+  SEXP_OP_FCALLN,
+  SEXP_OP_JUMP_UNLESS,
+  SEXP_OP_JUMP,
+  SEXP_OP_PUSH,
+  SEXP_OP_DROP,
+  SEXP_OP_GLOBAL_REF,
+  SEXP_OP_GLOBAL_KNOWN_REF,
+  SEXP_OP_STACK_REF,
+  SEXP_OP_LOCAL_REF,
+  SEXP_OP_LOCAL_SET,
+  SEXP_OP_CLOSURE_REF,
+  SEXP_OP_VECTOR_REF,
+  SEXP_OP_VECTOR_SET,
+  SEXP_OP_VECTOR_LENGTH,
+  SEXP_OP_BYTES_REF,
+  SEXP_OP_BYTES_SET,
+  SEXP_OP_BYTES_LENGTH,
+  SEXP_OP_STRING_REF,
+  SEXP_OP_STRING_SET,
+  SEXP_OP_STRING_LENGTH,
+  SEXP_OP_MAKE_PROCEDURE,
+  SEXP_OP_MAKE_VECTOR,
+  SEXP_OP_MAKE_EXCEPTION,
+  SEXP_OP_AND,
+  SEXP_OP_NULLP,
+  SEXP_OP_FIXNUMP,
+  SEXP_OP_SYMBOLP,
+  SEXP_OP_CHARP,
+  SEXP_OP_EOFP,
+  SEXP_OP_TYPEP,
+  SEXP_OP_MAKE,
+  SEXP_OP_SLOT_REF,
+  SEXP_OP_SLOT_SET,
+  SEXP_OP_ISA,
+  SEXP_OP_SLOTN_REF,
+  SEXP_OP_SLOTN_SET,
+  SEXP_OP_CAR,
+  SEXP_OP_CDR,
+  SEXP_OP_SET_CAR,
+  SEXP_OP_SET_CDR,
+  SEXP_OP_CONS,
+  SEXP_OP_ADD,
+  SEXP_OP_SUB,
+  SEXP_OP_MUL,
+  SEXP_OP_DIV,
+  SEXP_OP_QUOTIENT,
+  SEXP_OP_REMAINDER,
+  SEXP_OP_LT,
+  SEXP_OP_LE,
+  SEXP_OP_EQN,
+  SEXP_OP_EQ,
+  SEXP_OP_FIX2FLO,
+  SEXP_OP_FLO2FIX,
+  SEXP_OP_CHAR2INT,
+  SEXP_OP_INT2CHAR,
+  SEXP_OP_CHAR_UPCASE,
+  SEXP_OP_CHAR_DOWNCASE,
+  SEXP_OP_WRITE_CHAR,
+  SEXP_OP_NEWLINE,
+  SEXP_OP_READ_CHAR,
+  SEXP_OP_PEEK_CHAR,
+  SEXP_OP_YIELD,
+  SEXP_OP_RET,
+  SEXP_OP_DONE,
+  SEXP_OP_NUM_OPCODES
+};
+
+/**************************** 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_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_apply (sexp context, sexp proc, sexp args);
+SEXP_API sexp sexp_apply1 (sexp ctx, sexp f, sexp x);
+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_eval_op (sexp context sexp_api_params(self, 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_api_params(self, n), sexp expr, sexp env);
+SEXP_API sexp sexp_make_env_op (sexp context sexp_api_params(self, n));
+SEXP_API sexp sexp_make_null_env_op (sexp context sexp_api_params(self, 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_api_params(self, n), sexp version);
+SEXP_API sexp sexp_load_standard_parameters (sexp context, sexp env);
+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_api_params(self, n), sexp dir, sexp appendp);
+SEXP_API sexp sexp_extend_env (sexp context, sexp env, sexp vars, sexp value);
+SEXP_API sexp sexp_env_copy_op (sexp context sexp_api_params(self, n), sexp to, sexp from, sexp ls, sexp immutp);
+SEXP_API sexp sexp_env_define (sexp context, sexp env, sexp sym, sexp val);
+SEXP_API sexp sexp_env_cell (sexp env, sexp sym);
+SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt);
+SEXP_API sexp sexp_env_global_ref (sexp env, sexp sym, sexp dflt);
+SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to);
+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_api_params(self, n), sexp flags, sexp num_args, sexp bc, sexp vars);
+SEXP_API sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, sexp_proc1 f, sexp data);
+SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data);
+
+#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_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)
+
+#if SEXP_USE_TYPE_DEFS
+SEXP_API sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type);
+SEXP_API sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type);
+SEXP_API sexp sexp_make_getter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index);
+SEXP_API sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, 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 sexp_api_pass(NULL, 3) a, b, c)
+#define sexp_make_procedure(ctx, f, n, b, v) sexp_make_procedure_op(ctx sexp_api_pass(NULL, 4), f, n, b, v)
+#define sexp_make_env(ctx) sexp_make_env_op(ctx sexp_api_pass(NULL, 0))
+#define sexp_make_null_env(ctx, v) sexp_make_null_env_op(ctx sexp_api_pass(NULL, 0), v)
+#define sexp_make_standard_env(ctx) sexp_make_standard_env_op(ctx sexp_api_pass(NULL, 0))
+#define sexp_add_module_directory(ctx, d, a) sexp_add_module_directory_op(ctx sexp_api_pass(NULL, 1), d, a)
+#define sexp_eval(ctx, x, e) sexp_eval_op(ctx sexp_api_pass(NULL, 2), x, e)
+#define sexp_load(ctx, f, e) sexp_load_op(ctx sexp_api_pass(NULL, 2), f, e)
+#define sexp_env_copy(ctx, a, b, c, d) sexp_env_copy_op(ctx sexp_api_pass(NULL, 4), a, b, c, d)
+#define sexp_identifierp(ctx, x) sexp_identifier_op(ctx sexp_api_pass(NULL, 1), x)
+#define sexp_identifier_to_symbol(ctx, x) sexp_syntactic_closure_expr(ctx sexp_api_pass(NULL, 1), x)
+#define sexp_identifier_eq(ctx, a, b, c, d) sexp_identifier_eq_op(ctx sexp_api_pass(NULL, 4), a, b, c, d)
+#define sexp_open_input_file(ctx, x) sexp_open_input_file_op(ctx sexp_api_pass(NULL, 1), x)
+#define sexp_open_output_file(ctx, x) sexp_open_output_file_op(ctx sexp_api_pass(NULL, 1), x)
+#define sexp_close_port(ctx, x) sexp_close_port_op(ctx sexp_api_pass(NULL, 1), x)
+
+#ifdef __cplusplus
+} /* extern "C" */
+#endif
+
+#endif /* ! SEXP_EVAL_H */
+

include/chibi/features.h

@@ -0,0 +1,469 @@
+/*  features.h -- general feature configuration               */
+/*  Copyright (c) 2009-2010 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 config.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 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 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 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 type definitions common to all contexts */
+/*   By default types are only global if you don't allow user type */
+/*   definitions, so new types will be local to a given set of */
+/*   contexts sharing thei heap. */
+/* #define SEXP_USE_GLOBAL_TYPES 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 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 the self and n parameters to primitives */
+/*   This is the old style API. */
+/* #define SEXP_USE_SELF_PARAMETER 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 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 disable string ports */
+/*   If disabled some basic functionality such as number->string */
+/*   will not be available by default. */
+/* #define SEXP_USE_STRING_STREAMS 0 */
+
+/* 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 */
+
+/* #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_GREEN_THREADS
+#define SEXP_USE_GREEN_THREADS ! SEXP_USE_NO_FEATURES
+#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_MALLOC
+#define SEXP_USE_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 0
+#endif
+
+#ifndef SEXP_USE_CONSERVATIVE_GC
+#define SEXP_USE_CONSERVATIVE_GC 0
+#endif
+
+#ifndef SEXP_USE_HEADER_MAGIC
+#define SEXP_USE_HEADER_MAGIC 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_TYPES
+#define SEXP_USE_GLOBAL_TYPES (! SEXP_USE_TYPE_DEFS)
+#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_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_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_BIGNUMS
+#define SEXP_USE_BIGNUMS ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_MATH
+#define SEXP_USE_MATH SEXP_USE_FLONUMS && ! 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_DEBUG_VM
+#define SEXP_USE_DEBUG_VM 0
+#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
+#ifdef _WIN32
+#define SEXP_USE_STRING_STREAMS 0
+#else
+#define SEXP_USE_STRING_STREAMS ! SEXP_USE_NO_FEATURES
+#endif
+#endif
+
+#ifndef SEXP_USE_AUTOCLOSE_PORTS
+#define SEXP_USE_AUTOCLOSE_PORTS ! SEXP_USE_NO_FEATURES
+#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
+
+#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_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 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

lib/chibi/ast.c

@@ -0,0 +1,248 @@
+/*  ast.c -- interface to the Abstract Syntax Tree            */
+/*  Copyright (c) 2009-2010 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+
+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);
+  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);
+  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_api_params(self, n), sexp env, sexp id) {
+  sexp cell = sexp_env_cell(env, id);
+  while ((! cell) && sexp_synclop(id)) {
+    env = sexp_synclo_env(id);
+    id = sexp_synclo_expr(id);
+  }
+  return cell ? cell : SEXP_FALSE;
+}
+
+static sexp sexp_get_opcode_name (sexp ctx sexp_api_params(self, 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_intern(ctx, sexp_opcode_name(op), -1);
+}
+
+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_api_params(self, n), sexp op) {
+  sexp res;
+  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_api_params(self, 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 (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_num_params (sexp ctx sexp_api_params(self, n), sexp op) {
+  if (! sexp_opcodep(op))
+    return sexp_type_exception(ctx, self, SEXP_OPCODE, op);
+  return sexp_make_fixnum(sexp_opcode_num_args(op));
+}
+
+static sexp sexp_get_opcode_variadic_p (sexp ctx sexp_api_params(self, n), sexp op) {
+  if (! sexp_opcodep(op))
+    return sexp_type_exception(ctx, self, SEXP_OPCODE, op);
+  return sexp_make_boolean(sexp_opcode_variadic_p(op));
+}
+
+static sexp sexp_type_of (sexp ctx sexp_api_params(self, 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_analyze_op (sexp ctx sexp_api_params(self, 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_api_params(self, 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;
+}
+
+#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_api_params(self, n), sexp env) {
+  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, "<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, "exception?", SEXP_EXCEPTION);
+  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", "syntactic-closure-env-set!");
+  sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", "syntactic-closure-vars-set!");
+  sexp_define_accessors(ctx, env, SEXP_SYNCLO, 2, "syntactic-closure-expr", "syntactic-closure-expr-set!");
+  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_PROCEDURE, 1, "procedure-code", "procedure-code-set!");
+  sexp_define_accessors(ctx, env, SEXP_PROCEDURE, 2, "procedure-vars", "procedure-vars-set!");
+  sexp_define_accessors(ctx, env, SEXP_BYTECODE, 1, "bytecode-name", "bytecode-name-set!");
+  sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 0, "exception-kind", "exception-kind-set!");
+  sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 1, "exception-message", "exception-message-set!");
+  sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 2, "exception-irritants", "exception-irritants-set!");
+  sexp_define_foreign_opt(ctx, env, "analyze", 2, sexp_analyze_op, SEXP_FALSE);
+  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-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, "optimize", 1, sexp_optimize);
+  sexp_define_foreign(ctx, env, "type-of", 1, sexp_type_of);
+  return SEXP_VOID;
+}
+

lib/chibi/ast.module

@@ -0,0 +1,33 @@
+
+(define-module (chibi ast)
+  (export
+   analyze optimize env-cell ast->sexp macroexpand type-of
+   <object> <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>
+   pair-source pair-source-set!
+   syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? type?
+   environment? bytecode? exception? macro? context? exception?
+   syntactic-closure-expr syntactic-closure-env syntactic-closure-vars
+   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-kind-set! exception-message exception-message-set!
+   exception-irritants exception-irritants-set!
+   opcode-name opcode-num-params opcode-return-type opcode-param-type
+   opcode-variadic?
+   procedure-code procedure-vars procedure-name bytecode-name)
+  (import-immutable (scheme))
+  (include-shared "ast")
+  (include "ast.scm"))
+

lib/chibi/ast.scm

@@ -0,0 +1,91 @@
+;; ast.scm -- ast utilities
+;; Copyright (c) 2010 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (macroexpand x)
+  (ast->sexp (analyze x)))
+
+(define (procedure-name x)
+  (bytecode-name (procedure-code x)))
+
+(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 (flatten-dot x)
+    (cond ((pair? x) (cons (car x) (flatten-dot (cdr x))))
+          ((null? x) x)
+          (else (list x))))
+  (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 (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))))
+
+(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) (or (opcode-name x) x))
+       (else x)))))
+

lib/chibi/base64.module

@@ -0,0 +1,7 @@
+
+(define-module (chibi base64)
+  (export base64-encode base64-encode-string
+          base64-decode base64-decode-string
+          base64-encode-header)
+  (import-immutable (scheme) (srfi 33) (chibi io))
+  (include "base64.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/disasm.c

@@ -0,0 +1,99 @@
+/*  disasm.c -- optional debugging utilities                  */
+/*  Copyright (c) 2009-2010 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 8
+#define SEXP_DISASM_PAD_WIDTH 4
+
+static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
+  sexp tmp;
+  unsigned char *ip, opcode, i;
+
+  if (sexp_procedurep(bc)) {
+    bc = sexp_procedure_code(bc);
+  } else if (sexp_opcodep(bc)) {
+    sexp_printf(ctx, out, "%s is a primitive\n", sexp_opcode_name(bc));
+    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_printf(ctx, out, "%p\n", bc);
+
+  ip = sexp_bytecode_data(bc);
+
+ loop:
+  for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++)
+    sexp_write_char(ctx, ' ', out);
+  opcode = *ip++;
+  if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) {
+    sexp_printf(ctx, out, "  %s ", reverse_opcode_names[opcode]);
+  } else {
+    sexp_printf(ctx, out, "  <unknown> %d ", opcode);
+  }
+  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_JUMP:
+  case SEXP_OP_JUMP_UNLESS:
+  case SEXP_OP_TYPEP:
+  case SEXP_OP_FCALL0:
+  case SEXP_OP_FCALL1:
+  case SEXP_OP_FCALL2:
+  case SEXP_OP_FCALL3:
+  case SEXP_OP_FCALL4:
+    sexp_printf(ctx, out, "%ld", (long) ((sexp*)ip)[0]);
+    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_GLOBAL_REF:
+  case SEXP_OP_GLOBAL_KNOWN_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_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) && (depth < SEXP_DISASM_MAX_DEPTH)
+      && (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;
+  return SEXP_VOID;
+}
+
+static sexp sexp_disasm (sexp ctx sexp_api_params(self, n), sexp bc, sexp out) {
+  return disasm(ctx, self, bc, out, 0);
+}
+
+sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
+  sexp_define_foreign_param(ctx, env, "disasm", 2, (sexp_proc1)sexp_disasm, "*current-output-port*");
+  return SEXP_VOID;
+}

lib/chibi/disasm.module

@@ -0,0 +1,5 @@
+
+(define-module (chibi disasm)
+  (export disasm)
+  (import-immutable (scheme))
+  (include-shared "disasm"))

lib/chibi/filesystem.module

@@ -0,0 +1,27 @@
+
+(define-module (chibi filesystem)
+  (export open-input-file-descriptor open-output-file-descriptor
+          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
+          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-immutable (scheme))
+  (include-shared "filesystem")
+  (include "filesystem.scm"))
+

lib/chibi/filesystem.scm

@@ -0,0 +1,43 @@
+;; filesystem.scm -- additional filesystem utilities
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(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)))))
+
+(define (directory-files dir)
+  (directory-fold dir cons '()))
+
+(define (renumber-file-descriptor old new)
+  (and (duplicate-file-descriptor-to old new)
+       (close-file-descriptor old)))
+
+(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))))
+
+(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))

lib/chibi/filesystem.stub

@@ -0,0 +1,118 @@
+
+(c-system-include "sys/types.h")
+(c-system-include "unistd.h")
+(c-system-include "dirent.h")
+(c-system-include "fcntl.h")
+
+(define-c-type DIR
+  finalizer: closedir)
+
+(define-c-struct dirent
+  (string d_name dirent-name))
+
+(define-c-struct stat
+  predicate: stat?
+  (dev_t      st_dev      stat-dev)
+  (ino_t      st_ino      stat-ino)
+  (mode_t     st_mode     stat-mode)
+  (nlink_t    st_nlink    stat-nlinks)
+  (uid_t      st_uid      stat-uid)
+  (gid_t      st_gid      stat-gid)
+  (dev_t      st_rdev     stat-rdev)
+  (off_t      st_size     stat-size)
+  (blksize_t  st_blksize  stat-blksize)
+  (blkcnt_t   st_blocks   stat-blocks)
+  (time_t     st_atime    stat-atime)
+  (time_t     st_mtime    stat-mtime)
+  (time_t     st_ctime    stat-ctime))
+
+(define-c boolean S_ISREG (mode_t))
+(define-c boolean S_ISDIR (mode_t))
+(define-c boolean S_ISCHR (mode_t))
+(define-c boolean S_ISBLK (mode_t))
+(define-c boolean S_ISFIFO (mode_t))
+(define-c boolean S_ISLNK (mode_t))
+(define-c boolean S_ISSOCK (mode_t))
+
+;;(define-c-const int ("S_IFMT"))
+(define-c-const int (file/socket "S_IFSOCK"))
+(define-c-const int (file/link "S_IFLNK"))
+(define-c-const int (file/regular "S_IFREG"))
+(define-c-const int (file/block "S_IFBLK"))
+(define-c-const int (file/directory "S_IFDIR"))
+(define-c-const int (file/character "S_IFCHR"))
+(define-c-const int (file/fifo "S_IFIFO"))
+(define-c-const int (file/suid "S_ISUID"))
+(define-c-const int (file/sgid "S_ISGID"))
+(define-c-const int (file/sticky "S_ISVTX"))
+;;(define-c-const int ("S_IRWXU"))
+(define-c-const int (perm/user-read "S_IRUSR"))
+(define-c-const int (perm/user-write "S_IWUSR"))
+(define-c-const int (perm/user-execute "S_IXUSR"))
+;;(define-c-const int ("S_IRWXG"))
+(define-c-const int (perm/group-read "S_IRGRP"))
+(define-c-const int (perm/group-write "S_IWGRP"))
+(define-c-const int (perm/group-execute "S_IXGRP"))
+;;(define-c-const int ("S_IRWXO"))
+(define-c-const int (perm/others-read "S_IROTH"))
+(define-c-const int (perm/others-write "S_IWOTH"))
+(define-c-const int (perm/others-execute "S_IXOTH"))
+
+(define-c errno stat (string (result stat)))
+(define-c errno fstat (int (result stat)))
+(define-c errno (file-link-status "lstat") (string (result stat)))
+
+(define-c input-port (open-input-file-descriptor "fdopen")
+  (int (value "r" string)))
+(define-c output-port (open-output-file-descriptor "fdopen")
+  (int (value "w" string)))
+
+(define-c errno (delete-file "unlink") (string))
+(define-c errno (link-file "link") (string string))
+(define-c errno (symbolic-link-file "symlink") (string string))
+(define-c errno (rename-file "rename") (string string))
+
+(define-c non-null-string (current-directory "getcwd")
+  ((result (array char (auto-expand arg1))) (value 256 int)))
+
+(define-c errno (create-directory "mkdir") (string int))
+(define-c errno (delete-directory "rmdir") (string))
+
+(define-c (free DIR) opendir (string))
+(define-c dirent readdir ((link (pointer DIR))))
+
+(define-c int (duplicate-file-descriptor "dup") (int))
+(define-c errno (duplicate-file-descriptor-to "dup2") (int int))
+(define-c errno (close-file-descriptor "close") (int))
+
+(define-c errno (open-pipe "pipe") ((result (array int 2))))
+(define-c errno (make-fifo "mkfifo") (string (default #o644 int)))
+
+(define-c int (get-file-descriptor-flags "fcntl")
+  (int (value F_GETFD int)))
+(define-c errno (set-file-descriptor-flags! "fcntl")
+  (int (value F_SETFD int) long))
+
+(define-c int (get-file-descriptor-status "fcntl")
+  (int (value F_GETFL int)))
+(define-c errno (set-file-descriptor-status! "fcntl")
+  (int (value F_SETFL int) long))
+
+;; (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"))
+
+(define-c boolean (is-a-tty? "isatty") (port-or-fd))
+

lib/chibi/heap-stats.c

@@ -0,0 +1,120 @@
+/* heap-stats.c -- count or dump heap objects                */
+/* Copyright (c) 2009-2010 Alex Shinn.  All rights reserved. */
+/* BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+
+#define SEXP_HEAP_VECTOR_DEPTH 1
+
+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_string(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_env_global_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_intern(ctx, sexp_type_name_by_index(ctx, i), -1);
+      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_api_params(self, n)) {
+  return sexp_heap_walk(ctx, 0, 0);
+}
+
+static sexp sexp_heap_dump (sexp ctx sexp_api_params(self, 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);
+}
+
+sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
+  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.module

@@ -0,0 +1,6 @@
+
+(define-module (chibi heap-stats)
+  (export heap-stats heap-dump)
+  (import-immutable (scheme))
+  (include-shared "heap-stats"))
+

lib/chibi/io.module

@@ -0,0 +1,13 @@
+
+(define-module (chibi io)
+  (export read-string read-string! write-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-broadcast-port make-concatenated-port
+          make-generated-input-port make-filtered-output-port
+          make-filtered-input-port)
+  (import-immutable (scheme))
+  (include-shared "io/io")
+  (include "io/io.scm"))

lib/chibi/io/io.scm

@@ -0,0 +1,170 @@
+;; io.scm -- various input/output utilities
+;; Copyright (c) 2010 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))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; reading and writing
+
+(define (write-line str . o)
+  (let ((out (if (pair? o) (car o) (current-output-port))))
+    (display str out)
+    (newline out)))
+
+(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)))
+      (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))))))
+
+(define (read-string n . o)
+  (let ((in (if (pair? o) (car o) (current-input-port))))
+    (let ((res (%read-string n in)))
+      (if (if (pair? res) (= 0 (car res)) #t)
+          eof
+          (cadr res)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; higher order port operations
+
+(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 n) 0)))
+
+(define (make-broadcast-port . ports)
+  (make-custom-output-port
+   (lambda (str n)
+     (for-each (lambda (p) (write-string str n p)) ports)
+     n)))
+
+(define (make-filtered-output-port filter out)
+  (make-custom-output-port
+   (lambda (str n)
+     (let* ((len (string-length str))
+            (s1 (if (= n len) str (substring str 0 n)))
+            (s2 (filter s1)))
+       (if (string? s2)
+           (write-string s2 (string-length s2) out))))))
+
+(define (make-concatenated-port . ports)
+  (make-custom-input-port
+   (lambda (str n)
+     (if (null? ports)
+         0
+         (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-generated-input-port generator)
+  (let ((buf "")
+        (len 0)
+        (offset 0))
+    (make-custom-input-port
+     (lambda (str n)
+       (cond
+        ((>= (- len offset) n)
+         (string-copy! str 0 buf offset (+ offset n))
+         (set! offset (+ offset n))
+         n)
+        (else
+         (string-copy! str 0 buf offset len)
+         (let lp ((i (- len offset)))
+           (set! buf (generator))
+           (cond
+            ((not (string? buf))
+             (set! buf "")
+             (set! len 0)
+             (set! offset 0)
+             (- n i))
+            (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,27 @@
+
+(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 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 size_t (write-string "fwrite")
+  (string (value 1 size_t) size_t (default (current-output-port) output-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))

lib/chibi/io/port.c

@@ -0,0 +1,201 @@
+
+#include <stdio.h>
+#include <chibi/eval.h>
+
+#define SEXP_PORT_BUFFER_SIZE 1024
+#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)
+
+#if ! SEXP_USE_BOEHM
+static int sexp_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, p;
+#if ! SEXP_USE_BOEHM
+  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) && sexp_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(vec) = sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID);
+  args = sexp_list2(ctx, sexp_cookie_buffer(vec), sexp_make_fixnum(size));
+  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(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_cookie_buffer(vec), sexp_make_fixnum(size));
+  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
+
+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
+
+#if SEXP_USE_STRING_STREAMS
+
+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(vec) = ctx;
+  sexp_cookie_buffer(vec)
+    = sexp_make_string(ctx, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE), SEXP_VOID);
+  sexp_cookie_read(vec) = read;
+  sexp_cookie_write(vec) = write;
+  sexp_cookie_seek(vec) = seek;
+  sexp_cookie_close(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
+
+static sexp sexp_make_custom_port (sexp ctx, sexp self,
+                                   char *mode, sexp read, sexp write,
+                                   sexp seek, sexp close) {
+  return sexp_user_exception(ctx, self, "custom ports not supported in this configuration", SEXP_NULL);
+}
+
+#endif
+
+static 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);
+}
+
+static 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);
+  sexp_pointer_tag(res) = SEXP_OPORT;
+  return res;
+}

lib/chibi/loop.module

@@ -0,0 +1,9 @@
+
+(define-module (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-immutable (scheme))
+  (include "loop/loop.scm"))
+

lib/chibi/loop/loop.scm

@@ -0,0 +1,365 @@
+;;;; loop.scm - the chibi loop (aka foof-loop)
+;;
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;; The loop API is compatible with Taylor Campbell's foof-loop, but
+;; the iterator API is different and subject to change.  All loop
+;; variables may be implicitly destructured with MATCH semantics.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(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))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(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))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Iterators
+
+;; Each gets passed two lists, those items left of the <- and those to
+;; the right, followed by a NEXT and REST continuation.
+
+;; Should finish with
+;;
+;;  (next (outer-vars ...) (cursor-vars ...) (done?-tests ...)
+;;        (loop-vars ...) (final-vars ...) . rest)
+;;
+;;  OUTER-VARS: bound once outside the loop in a LET*
+;;  CURSOR-VARS: DO-style bindings of the form (name init update)
+;;  DONE?-TESTS: possibly empty list of forms that terminate the loop on #t
+;;  LOOP-VARS: inner variables, updated in parallel after the cursors
+;;  FINAL-VARS: final variables, bound only in the => result
+
+(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))))
+
+;; 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 ls next . rest)
+            (%in-idx >= + 0 (length tmp) ref tmp ls next . rest))))
+       (define-syntax in-type-reverse
+         (syntax-rules ()
+           ((in-type-reverse ls next . rest)
+            (%in-idx < - (- (length tmp) 1) 0 ref tmp ls next . rest))))
+       ))))
+
+(define-in-indexed in-string in-string-reverse string-length string-ref)
+(define-in-indexed in-vector in-vector-reverse vector-length vector-ref)
+
+;; 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-vec ((var) (vec ...)) next . rest)
+     (%in-idx ge + s e r tmp-vec ((var vec-index) (vec ...)) next . rest))
+    ((%in-idx ge + s e r tmp-vec ((var index) (vec)) next . rest)
+     (%in-idx ge + s e r tmp-vec ((var index) (vec s e 1)) next . rest))
+    ((%in-idx ge + s e r tmp-vec ((var index) (vec from)) next . rest)
+     (%in-idx ge + s e r tmp-vec ((var index) (vec from e 1)) next . rest))
+    ((%in-idx ge + s e r tmp-vec ((var index) (vec from to)) next . rest)
+     (%in-idx ge + s e r tmp-vec ((var index) (vec from to 1)) next . rest))
+    ((%in-idx ge + s e r tmp-vec ((var index) (vec from to step)) next . rest)
+     (next ((tmp-vec vec) (end to))
+           ((index from (+ index step)))
+           ((ge index end))
+           ((var (r tmp-vec index)))
+           ()
+       . rest))
+    ))
+
+(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))))
+
+(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))))
+
+(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))
+    ))
+
+(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))))
+
+(define-syntax listing
+  (syntax-rules ()
+    ((listing args next . rest)
+     (accumulating (cons reverse '()) args next . rest))))
+
+(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))))
+
+(define-syntax appending
+  (syntax-rules ()
+    ((appending args next . rest)
+     (accumulating (append-reverse reverse '()) args next . rest))))
+
+(define-syntax appending-reverse
+  (syntax-rules ()
+    ((appending-reverse args next . rest)
+     (accumulating (append-reverse (lambda (x) x) '()) args next . rest))))
+
+(define-syntax summing
+  (syntax-rules ()
+    ((summing args next . rest)
+     (accumulating (+ (lambda (x) x) 0) args next . rest))))
+
+(define-syntax multiplying
+  (syntax-rules ()
+    ((multiplying args next . rest)
+     (accumulating (* (lambda (x) x) 1) args next . rest))))

lib/chibi/match.module

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

lib/chibi/match/match.scm

@@ -0,0 +1,683 @@
+;;;; match.scm -- portable hygienic pattern matcher
+;;
+;; This code is written by Alex Shinn and placed in the
+;; Public Domain.  All warranties are disclaimed.
+
+;; This is a full superset of the popular MATCH package by Andrew
+;; Wright, written in fully portable SYNTAX-RULES (R5RS only, breaks
+;; in R6RS SYNTAX-RULES), and thus preserving hygiene.
+
+;; This 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
+;;
+;; 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"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; 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) ...)
+     (match-next atom (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 (_ ___ *** 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 ($ 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-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 (length ls)))
+        (if (< 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 ... i) 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))))
+
+;; Matching a tree search pattern is only slightly more complicated.
+;; Here we allow patterns of the form
+;;
+;;     (x *** y)
+;;
+;; to represent the pattern y located somewhere in a tree where the
+;; path from the current object to y can be seen as a list of the form
+;; (X ...).  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 ... pattern.
+;;
+;; As a common case the pattern (_ *** y) can be used to search for Y
+;; anywhere in a tree, regardless of the path used.
+;;
+;; To implement the 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-drop-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 (_ ___ *** ? $ = 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))
+    ;; 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? x 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.
+
+(define-syntax match-lambda
+  (syntax-rules ()
+    ((_ clause ...) (lambda (expr) (match expr clause ...)))))
+
+(define-syntax match-lambda*
+  (syntax-rules ()
+    ((_ clause ...) (lambda expr (match expr clause ...)))))
+
+(define-syntax match-let
+  (syntax-rules ()
+    ((_ (vars ...) . body)
+     (match-let/helper let () () (vars ...) . body))
+    ((_ loop . rest)
+     (match-named-let loop () . rest))))
+
+(define-syntax match-letrec
+  (syntax-rules ()
+    ((_ vars . body) (match-let/helper letrec () () vars . 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))))
+
+(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.module

@@ -0,0 +1,7 @@
+
+(define-module (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-immutable (scheme) (chibi base64) (chibi quoted-printable) (chibi io))
+  (include "mime.scm"))

lib/chibi/mime.scm

@@ -0,0 +1,410 @@
+;; mime.scm -- RFC2045 MIME library
+;; Copyright (c) 2005-2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; RFC2822 headers
+
+;; Procedure: mime-header-fold kons knil [source [limit [kons-from]]]
+;;
+;;  Performs a fold operation on the MIME headers of source which can be
+;;  either a string or port, and defaults to current-input-port.  kons
+;;  is called on the three values:
+;;     kons header value accumulator
+;;  where accumulator begins with knil.  Neither the header nor the
+;;  value are modified, except wrapped lines are handled for the value.
+;;
+;;  The optional procedure 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 KONS, and if such a line is found the fold will begin
+;;  with (KONS-FROM "%from" <address> (KONS-FROM "%date" <date> KNIL)).
+;;
+;; The optional LIMIT gives a limit on the number of headers to read.
+
+;; Procedure: mime-headers->list [source]
+;;   Return an alist of the MIME headers from source with headers all
+;;   downcased.
+
+;; Procedure: mime-parse-content-type str
+;;   Parses STR as a Content-Type style-value returning the list
+;;     (type (attr . val) ...)
+;;  For example:
+;;     (mime-parse-content-type
+;;        "text/html; CHARSET=US-ASCII; filename=index.html")
+;;       => ("text/html" ("charset" . "US-ASCII") ("filename" . "index.html"))
+
+;; Procedure: mime-decode-header str
+;;   Replace all occurrences of RFC1522 =?ENC?...?= escapes in STR with
+;;   the appropriate decoded and charset converted value.
+
+;; Procedure: mime-ref headers str [default]
+;;   A case-insensitive assoc-ref.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; RFC2045 MIME encoding
+
+;; Procedure: mime-message-fold src headers kons knil
+;;   Performs a fold operation on the given string or port SRC as a MIME
+;;   body corresponding to the headers give in HEADERS.  KONS is called
+;;   on the successive values:
+;;
+;;      KONS part-headers part-body accumulator
+;;
+;;   where part-headers are the headers for the given MIME part (the
+;;   original headers for single-part MIME), part-body is the
+;;   appropriately decoded and charset-converted body of the message,
+;;   and the accumulator begins with KNIL.
+;;
+;; TODO: Extend mime-message-fold to (optionally?) pass KONS an
+;; input-port instead of string for the body to handle very large bodies
+;; (this is not much of an issue for SMTP since the messages are in
+;; practice limited, but it could be problematic for large HTTP bodies).
+;;
+;; This does a depth-first search, folding in sequence.  It should
+;; probably be doing a tree-fold as in html-parser.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(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))))
+
+(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)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; header parsing
+
+(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)))))
+
+(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)) ""))))
+
+(define (mime-parse-content-type str)
+  (map mime-split-name+value (string-split str #\;)))
+
+(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)))))
+
+;; (kons parent-headers part-headers part-body seed)
+;; (start headers seed)
+;; (end headers parent-seed seed)
+(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)))))))))))
+
+;; (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/modules.module

@@ -0,0 +1,8 @@
+
+(define-module (chibi modules)
+  (export analyze-module module-ast module-ast-set!
+          module-ref module-contains? containing-module
+          procedure-analysis)
+  (import-immutable (scheme) (config))
+  (import (chibi ast))
+  (include "modules.scm"))

lib/chibi/modules.scm

@@ -0,0 +1,103 @@
+
+(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) (vector? x))
+
+(define (module-ast mod) (vector-ref mod 3))
+(define (module-ast-set! mod x) (vector-set! mod 3 x))
+
+(define (analyze-module-source name mod recursive?)
+  (let ((env (module-env mod))
+        (dir (if (equal? name '(scheme)) "" (module-name-prefix name))))
+    (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))))
+                  (begin
+                    ;; (write `(found ,var-name in ,name ,(ast->sexp (car ls))) (current-error-port))
+                    ;; (newline (current-error-port))
+                    #t))
+             (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/net.module

@@ -0,0 +1,11 @@
+
+(define-module (chibi net)
+  (export sockaddr? address-info? get-address-info socket connect
+          with-net-io open-net-io
+          address-info-family address-info-socket-type address-info-protocol
+          address-info-address address-info-address-length address-info-next)
+  (import-immutable (scheme))
+  (import (chibi filesystem))
+  (include-shared "net")
+  (include "net.scm"))
+

lib/chibi/net.scm

@@ -0,0 +1,32 @@
+;; net.scm -- the high-level network interface
+;; Copyright (c) 2010 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (open-net-io host service)
+  (let lp ((addr (get-address-info host
+                                   (if (integer? service)
+                                       (number->string service)
+                                       service)
+                                   #f)))
+    (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))
+              (if (negative?
+                   (connect sock
+                            (address-info-address addr)
+                            (address-info-address-length addr)))
+                  (lp (address-info-next addr))
+                  (list (open-input-file-descriptor sock)
+                        (open-output-file-descriptor sock))))))))
+
+(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 (car io) (car (cdr io)))))
+          (close-input-port (car io))
+          res))))

lib/chibi/net.stub

@@ -0,0 +1,25 @@
+
+(c-system-include "sys/types.h")
+(c-system-include "sys/socket.h")
+(c-system-include "netdb.h")
+
+(define-c-struct sockaddr
+  predicate:   sockaddr?)
+
+(define-c-struct addrinfo
+  finalizer: freeaddrinfo
+  predicate: address-info?
+  (int              ai_family    address-info-family)
+  (int              ai_socktype  address-info-socket-type)
+  (int              ai_protocol  address-info-protocol)
+  ((link sockaddr)  ai_addr      address-info-address)
+  (size_t           ai_addrlen   address-info-address-length)
+  ((link addrinfo)  ai_next      address-info-next))
+
+(define-c errno (get-address-info getaddrinfo)
+  (string string (maybe-null addrinfo) (result free addrinfo)))
+
+(define-c int bind (int sockaddr int))
+(define-c int listen (int int))
+(define-c int socket (int int int))
+(define-c int connect (int sockaddr int))

lib/chibi/net/http.module

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

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/pathname.module

@@ -0,0 +1,7 @@
+
+(define-module (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-immutable (scheme))
+  (include "pathname.scm"))

lib/chibi/pathname.scm

@@ -0,0 +1,180 @@
+;; pathname.scm -- a general, non-host-specific path lib
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(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)))))))
+
+;; 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)))))))
+
+(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))
+
+(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))))))
+
+(define (path-strip-extension path)
+  (let ((i (path-extension-pos path)))
+    (if (and i (< (+ i 1) (string-length path)))
+        (substring path 0 i)
+        path)))
+
+(define (path-replace-extension path ext)
+  (string-append (path-strip-extension path) "." ext))
+
+(define (path-absolute? path)
+  (and (not (string=? "" path)) (eqv? #\/ (string-ref path 0))))
+
+(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.
+
+(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 '()))))
+
+(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/process.module

@@ -0,0 +1,18 @@
+
+(define-module (chibi process)
+  (export exit sleep alarm fork kill execute waitpid
+          set-signal-action! make-signal-set signal-set-contains?
+          signal-set-fill! signal-set-add! signal-set-delete!
+          current-signal-mask
+          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)
+  (import-immutable (scheme))
+  (cond-expand (threads (import (srfi 18))) (else #f))
+  (include-shared "process"))
+

lib/chibi/process.stub

@@ -0,0 +1,73 @@
+
+(c-system-include "sys/types.h")
+(c-system-include "sys/wait.h")
+(c-system-include "signal.h")
+(c-system-include "unistd.h")
+
+(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-type sigset_t
+  predicate: signal-set?)
+
+(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")
+
+(define-c sexp (set-signal-action! "sexp_set_signal_action")
+  ((value ctx sexp) (value self sexp) sexp  sexp))
+
+(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! "sigaddset") ((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)))
+
+(define-c unsigned-int alarm (unsigned-int))
+(define-c unsigned-int sleep (unsigned-int))
+
+(define-c pid_t fork ())
+;;(define-c pid_t wait ((result int)))
+(define-c pid_t waitpid (int (result int) int))
+(define-c errno kill (int int))
+;;(define-c errno raise (int))
+(define-c void exit (int))
+(define-c int (execute execvp) (string (array string)))
+
+(c-init "sexp_init_signals(ctx, env);")

lib/chibi/quoted-printable.module

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

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/repl.module

@@ -0,0 +1,9 @@
+
+(define-module (chibi repl)
+  (export repl)
+  (import-immutable (scheme))
+  (import (chibi ast)
+          (chibi process)
+          (chibi term edit-line)
+          (srfi 18))
+  (include "repl.scm"))

lib/chibi/repl.scm

@@ -0,0 +1,41 @@
+;;;; repl.scm - friendlier repl with line editing and signal handling
+;;
+;; Copyright (c) 2010 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define-syntax handle-exceptions
+  (syntax-rules ()
+    ((handle-exceptions exn handler expr)
+     (call-with-current-continuation
+      (lambda (return)
+        (with-exception-handler (lambda (exn) (return handler))
+                                (lambda () expr)))))))
+
+(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 (run-repl module env)
+  (let ((line (edit-line (if module (string-append (symbol->string module) "> ") "> "))))
+    (cond
+     ((or (not line) (eof-object? line)))
+     ((equal? line "") (run-repl module env))
+     (else
+      (handle-exceptions exn (print-exception exn (current-error-port))
+       (let* ((expr (call-with-input-string line read))
+              (thread (make-thread (lambda ()
+                                     (let ((res (eval expr env)))
+                                       (if (not (eq? res (if #f #f)))
+                                           (write res)))))))
+         (with-signal-handler
+          signal/interrupt
+          (lambda (n) (thread-terminate! thread))
+          (lambda () (thread-start! thread) (thread-join! thread)))))
+      (newline)
+      (run-repl module env)))))
+
+(define (repl)
+  (run-repl #f (interaction-environment)))

lib/chibi/scribble.module

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

lib/chibi/scribble.scm

@@ -0,0 +1,247 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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* ((first? (and (null? res) (null? str)))
+                (res (collect (drop-while char-whitespace? str) res))
+                (res (if (or first? (eqv? #\} (peek-char in)))
+                         res
+                         (cons "\n" res))))
+           (let lp ((ls '()))
+             (let ((c (peek-char in)))
+               (cond
+                ((char-whitespace? c) (read-char in) (lp (cons c ls)))
+                (else (tok (if (eqv? c #\}) ls '()) res punc depth)))))))
+        (else
+         (tok (cons c str) res punc depth)))))
+  ;; begin
+  (tok '() '() init-punc 0))

lib/chibi/signal.c

@@ -0,0 +1,76 @@
+/*  signal.c -- process signals interface                     */
+/*  Copyright (c) 2009-2010 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_FALSE, SEXP_NULL);
+      sexp_car(args)
+        = sexp_make_cpointer(sigctx, sexp_siginfo_t_type_id, info, SEXP_FALSE, 0);
+      args = sexp_cons(sigctx, sexp_make_fixnum(signum), args);
+      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;
+}
+
+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/stty.module

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

lib/chibi/stty.scm

@@ -0,0 +1,235 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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
+
+(define (port? x) (or (input-port? x) (output-port? x)))
+
+(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))))))
+
+(define (with-stty setting thunk . o)
+  (let* ((port (if (pair? o) (car o) (current-input-port)))
+         (orig-attrs (get-terminal-attributes port)))
+    (dynamic-wind
+        (lambda () (stty setting))
+        thunk
+        (lambda () (set-terminal-attributes! port TCSANOW orig-attrs)))))
+
+(define (with-raw-io port thunk)
+  (with-stty '(not icanon echo) thunk port))
+
+(define (get-terminal-width x)
+  (let ((ws (ioctl x TIOCGWINSZ)))
+    (and ws (winsize-col ws))))
+
+(define (get-terminal-dimensions x)
+  (let ((ws (ioctl x TIOCGWINSZ)))
+    (and ws (list (winsize-col ws) (winsize-row ws)))))

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-fd 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-fd (result termios)))
+(define-c errno (set-terminal-attributes! "tcsetattr")
+  (port-or-fd int termios))

lib/chibi/system.module

@@ -0,0 +1,15 @@
+
+(define-module (chibi system)
+  (export user-information 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-immutable (scheme))
+  (include-shared "system")
+  ;;(include "system.scm")
+  )
+

lib/chibi/system.stub

@@ -0,0 +1,34 @@
+
+(c-system-include "unistd.h")
+(c-system-include "pwd.h")
+(c-system-include "sys/types.h")
+
+(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))
+
+(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))
+
+(define-c pid_t (current-session-id "getsid") ((default 0 pid_t)))
+(define-c pid_t (create-session "setsid") ())
+
+(define-c errno (set-root-directory! "chroot") (string))
+
+;; (define-c errno getpwuid_r
+;;   (uid_t (result passwd) (result (array char arg3))
+;;          (value 256 int) (result pointer passwd)))
+

lib/chibi/term/edit-line.module

@@ -0,0 +1,5 @@
+
+(define-module (chibi term edit-line)
+  (export edit-line edit-line-repl)
+  (import-immutable (scheme) (chibi stty) (srfi 9))
+  (include "edit-line.scm"))

lib/chibi/term/edit-line.scm

@@ -0,0 +1,505 @@
+;;;; edit-line.scm - pure scheme line editing tool
+;;
+;; Copyright (c) 2010 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 (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)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; buffers
+
+(define-record-type buffer
+  (%make-buffer refresh? min pos row max-row col gap width string history)
+  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!)
+  (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!))
+
+(define default-buffer-size 256)
+(define default-buffer-width 80)
+
+(define (make-buffer)
+  (%make-buffer #f 0 0 0 0 0 default-buffer-size default-buffer-width
+                (make-string default-buffer-size) '()))
+
+(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))
+        (end (string-length (buffer-string buf)))
+        (width (buffer-width buf)))
+    (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))
+            ((>= i end)
+             (buffer-max-row-set!
+              buf (if (and (zero? col) (> row 0)) (- row 1) row)))
+            ((= (+ col 1) width)
+             (lp (+ i 1) (+ row 1) 0))
+            (else
+             (lp (+ i 1) row (+ col 1)))))))
+
+(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)))
+    (buffer-update-position! buf)
+    ;; goto start of input
+    (terminal-goto-col out 0)
+    (if (positive? old-row)
+        (terminal-up out old-row))
+    ;; clear and display new buffer
+    (terminal-clear-below out)
+    (display (substring str 0 (buffer-pos buf)) out)
+    (display (substring str (buffer-gap buf) end) out)
+    ;; 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))))
+
+(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) ;; XXXX shouldn't be needed
+           (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)))
+               (buffer-update-position! buf)
+               (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)))
+      ;; fast path - append to end of buffer w/o wrapping to next line
+      (display x 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))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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   1 command/beggining-of-line)
+    (vector-set! v   2 command/backward-char)
+    (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/enter)
+    (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 (< 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)
+  (command/end-of-line ch buf out return)
+  (newline out)
+  (return))
+
+(define (command/beep ch buf out return)
+  (write-char (integer->char 7) out))
+
+(define (command/refresh ch buf out return)
+  (buffer-draw buf out))
+
+(define (command/beggining-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* ((prompt (get-key args 'prompt: "> "))
+         (history (get-key args 'history:))
+         (terminal-width (get-key args 'terminal-width:))
+         (keymap (get-key args 'keymap: standard-keymap)))
+    (lambda (in out)
+      (let* ((width (or terminal-width (get-terminal-width out)))
+             (buf (make-buffer))
+             (done? #f)
+             (return (lambda o (set! done? (if (pair? o) (car o) #t)))))
+        (buffer-refresh?-set! buf #t)
+        (buffer-width-set! buf width)
+        (buffer-insert! buf out prompt)
+        (buffer-min-set! buf (string-length prompt))
+        (buffer-history-set! buf history)
+        (buffer-refresh buf out)
+        (flush-output out)
+        ((if (get-key args '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)
+                       (x ch buf out return)
+                       (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/test.module

@@ -0,0 +1,14 @@
+
+(define-module (chibi test)
+  (export
+   test test-error test-assert test-values
+   test-group current-test-group
+   test-begin test-end test-syntax-error test-info
+   test-vars test-run ;;test-exit
+   current-test-verbosity current-test-epsilon current-test-comparator
+   current-test-applier current-test-handler current-test-skipper
+   current-test-group-reporter test-failure-count)
+  (import-immutable (scheme))
+  (import (srfi 39) (srfi 98) (chibi time) (chibi ast))
+  (include "test.scm"))
+

lib/chibi/test.scm

@@ -0,0 +1,662 @@
+;;;; test.scm -- testing framework
+;;
+;; Easy to use test suite adapted from the Chicken "test" module.
+;;
+;; Copyright (c) 2010 Alex Shinn. All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; exception utilities
+
+;; from SRFI-12, pending stabilization of an exception library for WG1
+(define-syntax handle-exceptions
+  (syntax-rules ()
+    ((handle-exceptions exn handler body ...)
+     (call-with-current-continuation
+      (lambda (return)
+        (with-exception-handler
+         (lambda (exn) (return handler))
+         (lambda () body ...)))))))
+
+(define (warning msg . args)
+  (display msg (current-error-port))
+  (for-each (lambda (x)
+              (write-char #\space (current-error-port))
+              (write x (current-error-port)))
+            args)
+  (newline (current-error-port)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; string utilities
+
+(define (string-search pat str)
+  (let* ((pat-len (string-length pat))
+         (limit (- (string-length str) pat-len)))
+    (let lp1 ((i 0))
+      (cond
+       ((>= i limit) #f)
+       (else
+        (let lp2 ((j i) (k 0))
+          (cond ((>= k pat-len) #t)
+                ((not (eqv? (string-ref str j) (string-ref pat k)))
+                 (lp1 (+ i 1)))
+                (else (lp2 (+ j 1) (+ k 1))))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; time utilities
+
+(define (timeval-difference tv1 tv2)
+  (let ((seconds (- (timeval-seconds tv1) (timeval-seconds tv2)))
+        (ms (- (timeval-microseconds tv1) (timeval-microseconds tv2))))
+    (+ (max seconds 0.0) (/ ms 1000000.0))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; test interface
+
+(define-syntax test
+  (syntax-rules ()
+    ((test expect expr)
+     (test #f expect expr))
+    ((test name expect (expr ...))
+     (test-info name expect (expr ...) ()))
+    ((test name (expect ...) expr)
+     (test-syntax-error
+      'test
+      "the test expression should come last "
+      (test name (expect ...) expr)))
+    ((test name expect expr)
+     (test-info name expect expr ()))
+    ((test a ...)
+     (test-syntax-error 'test "2 or 3 arguments required"
+                        (test a ...)))))
+
+(define-syntax test-assert
+  (syntax-rules ()
+    ((_ expr)
+    (test-assert #f expr))
+    ((_ name expr)
+     (test-info name #f expr ((assertion . #t))))
+    ((test a ...)
+     (test-syntax-error 'test-assert "1 or 2 arguments required"
+                        (test a ...)))))
+
+(define-syntax test-values
+  (syntax-rules ()
+    ((_ expect expr)
+    (test-values #f expect expr))
+    ((_ name expect expr)
+     (test name (call-with-values (lambda () expect) (lambda results results))
+       (call-with-values (lambda () expr) (lambda results results))))))
+
+(define-syntax test-error
+  (syntax-rules ()
+    ((_ expr)
+     (test-error #f expr))
+    ((_ name expr)
+     (test-info name #f expr ((expect-error . #t))))
+    ((test a ...)
+     (test-syntax-error 'test-error "1 or 2 arguments required"
+                        (test a ...)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; group interface
+
+(define-syntax test-group
+  (syntax-rules ()
+    ((_ name-expr body ...)
+     (let ((name name-expr)
+           (old-group (current-test-group)))
+       (if (not (string? name))
+           (error "a name is required, got " 'name-expr name))
+       (test-begin name)
+       (handle-exceptions
+        exn
+        (begin
+          (warning "error in group outside of tests")
+          (print-exception e (current-error-port))
+          (test-group-inc! (current-test-group) 'count)
+          (test-group-inc! (current-test-group) 'ERROR))
+        body ...)
+       (test-end name)
+       (current-test-group old-group)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utilities
+
+(define-syntax test-syntax-error
+  (syntax-rules ()
+    ((_) (syntax-error "invalid use of test-syntax-error"))))
+
+(define-syntax test-info
+  (syntax-rules ()
+    ((test-info name expect expr info)
+     (test-vars () name expect expr ((source . expr) . info)))))
+
+(define-syntax test-vars
+  (syntax-rules ()
+    ((_ (vars ...) n expect expr ((key . val) ...))
+     (test-run (lambda () expect)
+               (lambda () expr)
+               (cons (cons 'name n)
+                     '((source . expr)
+                       ;;(var-names . (vars ...))
+                       ;;(var-values . ,(list vars))
+                       (key . val) ...))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; test-group representation
+
+;; (name (prop value) ...)
+(define (make-test-group name)
+  (list name
+        (cons 'start-time (get-time-of-day))))
+
+(define test-group-name car)
+
+(define (test-group-ref group field . o)
+  (apply assq-ref (cdr group) field o))
+
+(define (test-group-set! group field value)
+  (cond ((assq field (cdr group))
+         => (lambda (x) (set-cdr! x value)))
+        (else (set-cdr! group (cons (cons field value) (cdr group))))))
+
+(define (test-group-inc! group field)
+  (cond ((assq field (cdr group))
+         => (lambda (x) (set-cdr! x (+ 1 (cdr x)))))
+        (else (set-cdr! group (cons (cons field 1) (cdr group))))))
+
+(define (test-group-push! group field value)
+  (cond ((assq field (cdr group))
+         => (lambda (x) (set-cdr! x (cons value (cdr x)))))
+        (else (set-cdr! group (cons (cons field (list value)) (cdr group))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utilities
+
+(define (assq-ref ls key . o)
+  (cond ((assq key ls) => cdr)
+        ((pair? o) (car o))
+        (else #f)))
+
+(define (approx-equal? a b epsilon)
+  (< (abs (- 1 (abs (if (zero? b) (+ 1 a) (/ a b)))))
+     epsilon))
+
+;; partial pretty printing to abbreviate `quote' forms and the like
+(define (write-to-string x)
+  (call-with-output-string
+    (lambda (out)
+      (let wr ((x x))
+        (if (pair? x)
+            (cond
+              ((and (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))
+                    (assq (car x)
+                          '((quote . "'") (quasiquote . "`")
+                            (unquote . ",") (unquote-splicing . ",@"))))
+               => (lambda (s) (display (cdr s) out) (wr (cadr x))))
+              (else
+               (display "(" out)
+               (wr (car x))
+               (let lp ((ls (cdr x)))
+                 (cond ((pair? ls)
+                        (display " " out)
+                        (wr (car ls))
+                        (lp (cdr ls)))
+                       ((not (null? ls))
+                        (display " . " out)
+                        (write ls out))))
+               (display ")" out)))
+            (write x out))))))
+
+;; if we need to truncate, try first dropping let's to get at the
+;; heart of the expression
+(define (truncate-source x width . o)
+  (let* ((str (write-to-string x))
+         (len (string-length str)))
+    (cond
+      ((<= len width)
+       str)
+      ((and (pair? x) (eq? 'let (car x)))
+       (if (and (pair? o) (car o))
+           (truncate-source (car (reverse x)) width #t)
+           (string-append "..."
+                          (truncate-source (car (reverse x)) (- width 3) #t))))
+      ((and (pair? x) (eq? 'call-with-current-continuation (car x)))
+       (truncate-source (cons 'call/cc (cdr x)) width (and (pair? o) (car o))))
+      ((and (pair? x) (eq? 'call-with-values (car x)))
+       (string-append
+        "..."
+        (truncate-source (if (and (pair? (cadr x)) (eq? 'lambda (caadr x)))
+                             (car (reverse (cadr x)))
+                             (cadr x))
+                         (- width 3)
+                         #t)))
+      (else
+       (string-append
+        (substring str 0 (min (max 0 (- width 3)) (string-length str)))
+        "...")))))
+
+(define (test-get-name! info)
+  (or
+   (assq-ref info 'name)
+   (assq-ref info 'gen-name)
+   (let ((name
+          (cond
+            ((assq-ref info 'source)
+             => (lambda (src)
+                  (truncate-source src (- (current-column-width) 12))))
+            ((current-test-group)
+             => (lambda (g)
+                  (string-append
+                   "test-"
+                   (number->string (test-group-ref g 'count 0)))))
+            (else ""))))
+     (if (pair? info)
+         (set-cdr! info (cons (cons 'gen-name name) (cdr info))))
+     name)))
+
+(define (test-print-name info . indent)
+  (let ((width (- (current-column-width)
+                  (or (and (pair? indent) (car indent)) 0)))
+        (name (test-get-name! info)))
+    (display name)
+    (display " ")
+    (let ((diff (- width 9 (string-length name))))
+      (cond
+       ((positive? diff)
+        (display (make-string diff #\.)))))
+    (display " ")
+    (flush-output)))
+
+(define (test-group-indent-width group)
+  (let ((level (max 0 (+ 1 (- (test-group-ref group 'level 0)
+                              (test-first-indentation))))))
+    (* 4 (min level (test-max-indentation)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; ansi tools
+
+(define (display-to-string x)
+  (if (string? x) x (call-with-output-string (lambda (out) (display x out)))))
+
+(define (red x) (string-append "\x1B[31m" (display-to-string x) "\x1B[0m"))
+(define (green x) (string-append "\x1B[32m" (display-to-string x) "\x1B[0m"))
+(define (yellow x) (string-append "\x1B[33m" (display-to-string x) "\x1B[0m"))
+;; (define (blue x) (string-append "\x1B[34m" (display-to-string x) "\x1B[0m"))
+;; (define (magenta x) (string-append "\x1B[35m" (display-to-string x) "\x1B[0m"))
+;; (define (cyan x) (string-append "\x1B[36m" (display-to-string x) "\x1B[0m"))
+(define (bold x) (string-append "\x1B[1m" (display-to-string x) "\x1B[0m"))
+(define (underline x) (string-append "\x1B[4m" (display-to-string x) "\x1B[0m"))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (test-run expect expr info)
+  (if (and (cond ((current-test-group)
+                  => (lambda (g) (not (test-group-ref g 'skip-group?))))
+                 (else #t))
+           (every (lambda (f) (f info)) (current-test-filters)))
+    ((current-test-applier) expect expr info)
+    ((current-test-skipper) expect expr info)))
+
+(define (test-default-applier expect expr info)
+  (let* ((group (current-test-group))
+         (indent (and group (test-group-indent-width group))))
+    (cond
+     ((and group
+           (equal? 0 (test-group-ref group 'count 0))
+           (zero? (test-group-ref group 'subgroups-count 0))
+           (test-group-ref group 'verbosity))
+      (newline)
+      (print-header-line
+       (string-append "testing " (or (test-group-name group) ""))
+       (or indent 0))))
+    (if (and indent (positive? indent))
+        (display (make-string indent #\space)))
+    (test-print-name info indent)
+    (let ((expect-val
+           (handle-exceptions
+            exn
+            (begin
+              (warning "bad expect value")
+              (print-exception exn (current-error-port))
+              #f)
+            (expect))))
+      (handle-exceptions
+       exn
+       (begin
+         ((current-test-handler)
+          (if (assq-ref info 'expect-error) 'PASS 'ERROR)
+          expect
+          expr
+          (append `((exception . ,exn)) info)))
+       (let ((res (expr)))
+         (let ((status
+                (if (and (not (assq-ref info 'expect-error))
+                         (if (assq-ref info 'assertion)
+                             res
+                             ((current-test-comparator) expect-val res)))
+                    'PASS
+                    'FAIL))
+               (info `((result . ,res) (expected . ,expect-val) ,@info)))
+           ((current-test-handler) status expect expr info)))))))
+
+(define (test-default-skipper expect expr info)
+  ((current-test-handler) 'SKIP expect expr info))
+
+(define (test-default-handler status expect expr info)
+  (define indent
+    (make-string
+     (+ 4 (cond ((current-test-group)
+                 => (lambda (group) (or (test-group-indent-width group) 0)))
+                (else 0)))
+     #\space))
+  ;; update group info
+  (cond ((current-test-group)
+         => (lambda (group)
+              (if (not (eq? 'SKIP status))
+                  (test-group-inc! group 'count))
+              (test-group-inc! group status))))
+  (cond
+   ((or (eq? status 'FAIL) (eq? status 'ERROR))
+    (test-failure-count (+ 1 (test-failure-count)))))
+  (cond
+   ((not (eq? status 'SKIP))
+    ;; display status
+    (display "[")
+    (if (not (eq? status 'ERROR)) (display " ")) ; pad
+    (display ((if (test-ansi?)
+                  (case status
+                    ((ERROR) (lambda (x) (underline (red x))))
+                    ((FAIL) red)
+                    ((SKIP) yellow)
+                    (else green))
+                  (lambda (x) x))
+              status))
+    (display "]")
+    (newline)
+    ;; display status explanation
+    (cond
+     ((eq? status 'ERROR)
+      (display indent)
+      (cond ((assq 'exception info)
+             => (lambda (e)
+                  (print-exception (cdr e) (current-output-port))))))
+     ((and (eq? status 'FAIL) (assq-ref info 'assertion))
+      (display indent)
+      (display "assertion failed\n"))
+     ((and (eq? status 'FAIL) (assq-ref info 'expect-error))
+      (display indent)
+      (display "expected an error but got ")
+      (write (assq-ref info 'result)) (newline))
+     ((eq? status 'FAIL)
+      (display indent)
+      (display "expected ") (write (assq-ref info 'expected))
+      (display " but got ") (write (assq-ref info 'result)) (newline)))
+    ;; display line, source and values info
+    (cond
+     ((or (not (current-test-group))
+          (test-group-ref (current-test-group) 'verbosity))
+      (case status
+        ((FAIL ERROR)
+         (cond
+          ((assq-ref info 'line-number)
+           => (lambda (line)
+                (display "    in line ")
+                (write line)
+                (cond ((assq-ref info 'file-name)
+                       => (lambda (file) (display " of file ") (write file))))
+                (newline))))
+         (cond
+          ((assq-ref info 'source)
+           => (lambda (s)
+                (cond
+                 ((or (assq-ref info 'name)
+                      (> (string-length (write-to-string s))
+                         (current-column-width)))
+                  (display (write-to-string s))
+                  (newline))))))
+         (cond
+          ((assq-ref info 'values)
+           => (lambda (v)
+                (for-each
+                 (lambda (v)
+                   (display "    ") (display (car v))
+                   (display ": ") (write (cdr v)) (newline))
+                 v))))))))))
+  status)
+
+(define (test-default-group-reporter group)
+  (define (plural word n)
+    (if (= n 1) word (string-append word "s")))
+  (define (percent n d)
+    (string-append " (" (number->string (/ (round (* 1000 (/ n d))) 10)) "%)"))
+  (let* ((end-time (get-time-of-day))
+         (start-time (test-group-ref group 'start-time))
+         (duration (timeval-difference (car end-time) (car start-time)))
+         (count (or (test-group-ref group 'count) 0))
+         (pass (or (test-group-ref group 'PASS) 0))
+         (fail (or (test-group-ref group 'FAIL) 0))
+         (err (or (test-group-ref group 'ERROR) 0))
+         (skip (or (test-group-ref group 'SKIP) 0))
+         (subgroups-count (or (test-group-ref group 'subgroups-count) 0))
+         (subgroups-pass (or (test-group-ref group 'subgroups-pass) 0))
+         (indent (make-string (or (test-group-indent-width group) 0) #\space)))
+    (cond
+     ((or (positive? count) (positive? subgroups-count))
+      (if (not (= count (+ pass fail err)))
+          (warning "inconsistent count:" count pass fail err))
+      (display indent)
+      (cond
+       ((positive? count)
+        (write count) (display (plural " test" count))))
+      (if (and (positive? count) (positive? subgroups-count))
+          (display " and "))
+      (cond
+       ((positive? subgroups-count)
+        (write subgroups-count)
+        (display (plural " subgroup" subgroups-count))))
+      (display " completed in ") (write duration) (display " seconds")
+      (cond
+       ((not (zero? skip))
+        (display " (") (write skip) (display (plural " test" skip))
+        (display " skipped)")))
+      (display ".") (newline)
+      (cond ((positive? fail)
+             (display indent)
+             (display
+              ((if (test-ansi?) red (lambda (x) x))
+               (string-append
+                (number->string fail) (plural " failure" fail)
+                (percent fail count) ".")))
+             (newline)))
+      (cond ((positive? err)
+             (display indent)
+             (display
+              ((if (test-ansi?) (lambda (x) (underline (red x))) (lambda (x) x))
+               (string-append
+                (number->string err) (plural " error" err)
+                (percent err count) ".")))
+             (newline)))
+      (cond
+       ((positive? count)
+        (display indent)
+        (display
+         ((if (and (test-ansi?) (= pass count)) green (lambda (x) x))
+          (string-append
+           (number->string pass) " out of " (number->string count)
+           (percent pass count) (plural " test" pass) " passed.")))
+        (newline)))
+      (cond
+       ((positive? subgroups-count)
+        (display indent)
+        (display
+         ((if (and (test-ansi?) (= subgroups-pass subgroups-count))
+              green (lambda (x) x))
+          (string-append
+           (number->string subgroups-pass) " out of "
+           (number->string subgroups-count)
+           (percent subgroups-pass subgroups-count)
+           (plural " subgroup" subgroups-pass) " passed.")))
+        (newline)))
+      ))
+    (print-header-line
+     (string-append "done testing " (or (test-group-name group) ""))
+     (or (test-group-indent-width group) 0))
+    (newline)
+    ))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (test-equal? expect res)
+  (or (equal? expect res)
+      (and (number? expect)
+           (inexact? expect)
+           (approx-equal? expect res (current-test-epsilon)))))
+
+(define (print-header-line str . indent)
+  (let* ((header (string-append
+                  (make-string (if (pair? indent) (car indent) 0) #\space)
+                  "-- " str " "))
+         (len (string-length header)))
+      (display (if (test-ansi?) (bold header) header))
+      (display (make-string (max 0 (- (current-column-width) len)) #\-))
+      (newline)))
+
+(define (test-begin . o)
+  (let* ((name (if (pair? o) (car o) ""))
+         (group (make-test-group name))
+         (parent (current-test-group)))
+    (cond
+     ((and parent
+           (equal? 0 (test-group-ref parent 'count 0))
+           (zero? (test-group-ref parent 'subgroups-count 0))
+           (test-group-ref parent 'verbosity))
+      (newline)
+      (print-header-line
+       (string-append "testing " (test-group-name parent))
+       (or (test-group-indent-width parent) 0))))
+    (test-group-set! group 'parent parent)
+    (test-group-set! group 'verbosity
+                     (if parent
+                         (test-group-ref parent 'verbosity)
+                         (current-test-verbosity)))
+    (test-group-set! group 'level
+                     (if parent
+                         (+ 1 (test-group-ref parent 'level 0))
+                         0))
+    (test-group-set!
+     group
+     'skip-group?
+     (or (and parent (test-group-ref parent 'skip-group?))
+         (not (every (lambda (f) (f group)) (current-test-group-filters)))))
+    (current-test-group group)))
+
+(define (test-end . o)
+  (cond
+    ((current-test-group)
+     => (lambda (group)
+          (if (and (pair? o) (not (equal? (car o) (test-group-name group))))
+            (warning "mismatched test-end:" (car o) (test-group-name group)))
+          (let ((parent (test-group-ref group 'parent)))
+            (cond
+             ((not (test-group-ref group 'skip-group?))
+              ;; only report if there's something to say
+              ((current-test-group-reporter) group)
+              (cond
+               (parent
+                (test-group-inc! parent 'subgroups-count)
+                (cond
+                 ((and (zero? (test-group-ref group 'FAIL 0))
+                       (zero? (test-group-ref group 'ERROR 0))
+                       (= (test-group-ref group 'subgroups-pass 0)
+                          (test-group-ref group 'subgroups-count 0)))
+                  (test-group-inc! parent 'subgroups-pass)))))))
+            (current-test-group parent)
+            group)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; parameters
+
+(define current-test-group (make-parameter #f))
+(define current-test-verbosity
+  (make-parameter
+   (cond ((get-environment-variable "TEST_QUIET")
+          => (lambda (s) (equal? s "0")))
+         (else #t))))
+(define current-test-epsilon (make-parameter 1e-5))
+(define current-test-comparator (make-parameter test-equal?))
+(define current-test-applier (make-parameter test-default-applier))
+(define current-test-handler (make-parameter test-default-handler))
+(define current-test-skipper (make-parameter test-default-skipper))
+(define current-test-group-reporter
+  (make-parameter test-default-group-reporter))
+(define test-failure-count (make-parameter 0))
+
+(define test-first-indentation
+  (make-parameter
+   (or (cond ((get-environment-variable "TEST_FIRST_INDENTATION")
+              => string->number)
+             (else #f))
+       1)))
+
+(define test-max-indentation
+  (make-parameter
+   (or (cond ((get-environment-variable "TEST_MAX_INDENTATION")
+              => string->number)
+             (else #f))
+       5)))
+
+(define (string->info-matcher str)
+  (lambda (info)
+    (cond ((test-get-name! info)
+           => (lambda (n) (string-search str n)))
+          (else #f))))
+
+(define (string->group-matcher str)
+  (lambda (group) (string-search str (car group))))
+
+(define (getenv-filter-list proc name . o)
+  (cond
+    ((get-environment-variable name)
+     => (lambda (s)
+          (handle-exceptions
+           exn
+           (begin
+             (warning
+              (string-append "invalid filter '" s
+                             "' from environment variable: " name))
+             (print-exception exn (current-error-port))
+             '())
+           (let ((f (proc s)))
+             (list (if (and (pair? o) (car o))
+                       (lambda (x) (not (f x)))
+                       f))))))
+    (else '())))
+
+(define current-test-filters
+  (make-parameter
+   (append (getenv-filter-list string->info-matcher "TEST_FILTER")
+           (getenv-filter-list string->info-matcher "TEST_REMOVE" #t))))
+
+(define current-test-group-filters
+  (make-parameter
+   (append (getenv-filter-list string->group-matcher "TEST_GROUP_FILTER")
+           (getenv-filter-list string->group-matcher "TEST_GROUP_REMOVE" #t))))
+
+(define current-column-width
+  (make-parameter
+   (or (cond ((get-environment-variable "TEST_COLUMN_WIDTH")
+              => string->number)
+             (else #f))
+       78)))
+
+(define test-ansi?
+  (make-parameter
+   (cond
+    ((get-environment-variable "TEST_USE_ANSI")
+     => (lambda (s) (not (equal? s "0"))))
+    (else
+     (member (get-environment-variable "TERM")
+             '("xterm" "xterm-color" "xterm-256color" "rxvt" "kterm"
+               "linux" "screen" "screen-256color" "vt100"))))))

lib/chibi/time.module

@@ -0,0 +1,12 @@
+
+(define-module (chibi time)
+  (export current-seconds get-time-of-day set-time-of-day!
+          seconds->time seconds->string time->seconds time->string
+          timeval-seconds timeval-microseconds
+          timezone-offset timezone-dst-time
+          time-second time-minute time-hour time-day time-month time-year
+          time-day-of-week time-day-of-year time-dst?
+          tm? timeval? timezone?)
+  (import-immutable (scheme))
+  (include-shared "time"))
+

lib/chibi/time.stub

@@ -0,0 +1,46 @@
+
+(c-system-include "time.h")
+(c-system-include "sys/time.h")
+
+(define-c-struct tm
+  predicate: tm?
+  (int     tm_sec    time-second)
+  (int     tm_min    time-minute)
+  (int     tm_hour   time-hour)
+  (int     tm_mday   time-day)
+  (int     tm_mon    time-month)
+  (int     tm_year   time-year)
+  (int     tm_wday   time-day-of-week)
+  (int     tm_yday   time-day-of-year)
+  (int     tm_isdst  time-dst?))
+
+(define-c-struct timeval
+  predicate: timeval?
+  (time_t  tv_sec          timeval-seconds)
+  (int     tv_usec         timeval-microseconds))
+
+(define-c-struct timezone
+  predicate: timezone?
+  (int     tz_minuteswest  timezone-offset)
+  (int     tz_dsttime      timezone-dst-time))
+
+(define-c time_t (current-seconds "time") ((value NULL)))
+
+(define-c errno (get-time-of-day "gettimeofday")
+  ((result timeval) (result timezone)))
+
+(define-c errno (set-time-of-day! "settimeofday")
+  (timeval (maybe-null default NULL timezone)))
+
+(define-c non-null-pointer (seconds->time "localtime_r")
+  ((pointer time_t) (result tm)))
+
+(define-c time_t (time->seconds "mktime")
+  (tm))
+
+(define-c non-null-string (seconds->string "ctime_r")
+  ((pointer time_t) (result (array char 64))))
+
+(define-c non-null-string (time->string "asctime_r")
+  (tm (result (array char 64))))
+

lib/chibi/type-inference.module

@@ -0,0 +1,7 @@
+
+(define-module (chibi type-inference)
+  (export type-analyze-module type-analyze procedure-signature)
+  (import-immutable (scheme))
+  (import (srfi 1) (srfi 69) (chibi modules) (chibi ast) (chibi match))
+  (include "type-inference.scm"))
+

lib/chibi/type-inference.scm

@@ -0,0 +1,272 @@
+;; type-inference.scm -- general type-inference for Scheme
+;;
+;; Copyright (c) 2010 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (typed? x)
+  (and (lambda? x)
+       (lambda-return-type x)))
+
+(define (union-type? a)
+  (and (pair? a) (equal? (car a) 'or)))
+
+(define (intersection-type? a)
+  (and (pair? a) (equal? (car a) 'and)))
+
+(define (unfinalized-type? a)
+  (and (pair? a)
+       (or (memq (car a) '(return-type param-type))
+           (and (memq (car a) '(and or))
+                (any unfinalized-type? (cdr a))))))
+
+(define (finalized-type? a)
+  (not (unfinalized-type? a)))
+
+(define (numeric-type? a)
+  (or (eq? a <number>) (eq? a <flonum>) (eq? a <integer>)))
+
+(define (procedure-type? a)
+  (or (eq? a <opcode>)
+      (eq? a <procedure>)
+      (and (pair? a) (eq? (car a) 'lambda))))
+
+(define (type-subset? a b)
+  (or (equal? a b)
+      (equal? a <object>)
+      (equal? b <object>)
+      (and (numeric-type? a) (numeric-type? b))
+      (and (procedure-type? a) (procedure-type? b))
+      (if (union-type? a)
+          (if (union-type? b)
+              (lset<= equal? (cdr a) (cdr b))
+              (member b (cdr a)))
+          (and (union-type? b) (member a (cdr b))))))
+
+;; XXXX check for type hierarchies
+(define (type-union a b)
+  (cond
+   ((equal? a b) a)
+   ((or (equal? a <object>) (equal? b <object>)) <object>)
+   ((union-type? a)
+    (if (union-type? b)
+        (cons (car a) (lset-union equal? (cdr a) (cdr b)))
+        (cons (car a) (lset-adjoin equal? (cdr a) b))))
+   (else (list 'or a b))))
+
+;; XXXX check for conflicts
+(define (type-intersection a b)
+  (cond
+   ((equal? a b) a)
+   ((or (equal? a <object>) (unfinalized-type? a)) b)
+   ((or (equal? b <object>) (unfinalized-type? b)) a)
+   ((intersection-type? a)
+    (if (intersection-type? b)
+        (lset-intersection equal? (cdr a) (cdr b))
+        (cons (car a) (lset-adjoin equal? (cdr a) b))))
+   (else (list 'and a b))))
+
+(define (lambda-param-types-initialize! f)
+  (lambda-param-types-set! f (map (lambda (p) (list 'param-type f p))
+                                  (lambda-params f))))
+
+(define (lambda-param-type-memq f x)
+  (let lp ((p (lambda-params f))
+           (t (lambda-param-types f)))
+    (and (pair? p)
+         (pair? t)
+         (if (eq? x (car p))
+             t
+             (lp (cdr p) (cdr t))))))
+
+(define (lambda-param-type-ref f x)
+  (cond ((lambda-param-type-memq f x) => car)
+        (else #f)))
+
+(define (lambda-param-type-set! f x y)
+  (if (not (pair? (lambda-param-types f)))
+      (lambda-param-types-initialize! f))
+  (cond ((lambda-param-type-memq f x)
+         => (lambda (cell) (set-car! cell y)))))
+
+(define (type-analyze-expr x)
+  (match x
+    (($ <lam> name params body defs)
+     (cond
+      ((not (lambda-return-type x))
+       (lambda-return-type-set! x (list 'return-type x))
+       (lambda-param-types-initialize! x)
+       (let ((ret-type (type-analyze-expr body)))
+         (lambda-return-type-set! x ret-type)
+         (cons 'lambda (cons ret-type (lambda-param-types x)))))))
+    (($ <set> ref value)
+     (type-analyze-expr value)
+     (if #f #f))
+    (($ <ref> name (value . loc) source)
+     (cond
+      ((lambda? loc) (lambda-param-type-ref loc name))
+      ((procedure? loc)
+       (let ((sig (procedure-signature loc)))
+         (if (and (pair? sig) (car sig))
+             (cons 'lambda sig)
+             (list 'return-type (procedure-analysis loc)))))
+      (else <object>)))
+    (($ <cnd> test pass fail)
+     (let ((test-type (type-analyze-expr test))
+           (pass-type (type-analyze-expr pass))
+           (fail-type (type-analyze-expr fail)))
+       (type-union pass-type fail-type)))
+    (($ <seq> ls)
+     (let lp ((ls ls))
+       (cond ((null? (cdr ls))
+              (type-analyze-expr (car ls)))
+             (else
+              (type-analyze-expr (car ls))
+              (lp (cdr ls))))))
+    ((f args ...)
+     (cond
+      ((opcode? f)
+       (let lp ((p (opcode-param-types f))
+                (a args))
+         (cond
+          ((pair? a)
+           (cond ((or (pair? p) (opcode-variadic? f))
+                  (let ((p-type
+                         (if (pair? p)
+                             (car p)
+                             (opcode-param-type f (opcode-num-params f)))))
+                    (match (car a)
+                     (($ <ref> name (_ . (and g ($ <lam>))))
+                      (let ((t (type-intersection (lambda-param-type-ref g name)
+                                                  p-type)))
+                        (lambda-param-type-set! g name t)))
+                     (else
+                      (let ((t (type-analyze-expr (car a))))
+                        (cond
+                         ((and t p-type
+                               (finalized-type? t)
+                               (finalized-type? p-type)
+                               (not (type-subset? t p-type)))
+                          (display "WARNING: incompatible type: "
+                                   (current-error-port))
+                          (write (list x t p-type) (current-error-port))
+                          (newline (current-error-port))))
+                        t))))
+                  (lp (and (pair? p) (cdr p)) (cdr a)))
+                 (else
+                  (for-each type-analyze-expr a))))))
+       (opcode-return-type f))
+      (else
+       (let ((f-type (type-analyze-expr f)))
+         ;; XXXX apply f-type to params
+         (for-each type-analyze-expr args)
+         (cond
+          ((and (pair? f-type) (eq? (car f-type) 'lambda))
+           (cadr f-type))
+          ((and (pair? f-type) (memq (car f-type) '(return-type param-type)))
+           f-type)
+          (else
+           <object>))))))
+    (else
+     (type-of x))))
+
+(define (resolve-delayed-type x)
+  (let lp ((x x) (seen '()) (default <object>))
+    (match x
+      (('return-type f)
+       (if (memq f seen)
+           default
+           (lp (lambda-return-type f) (cons f seen) default)))
+      (('param-type f p)
+       (if (member x seen)
+           default
+           (lp (lambda-param-type-ref f p) (cons x seen) default)))
+      (('or y ...)
+       (let ((z (find finalized-type? y)))
+         (if z
+             (let ((default (if (eq? default <object>)
+                                (lp z seen default)
+                                (type-union (lp z seen default) default))))
+               (fold type-union
+                     default
+                     (map (lambda (y1) (lp y1 seen default)) (delete z y))))
+             (fold type-union default (map (lambda (y1) (lp y1 seen default)) y)))))
+      (('and y ...)
+       (fold type-intersection default (map (lambda (y1) (lp y1 seen default)) y)))
+      (('not y)
+       (list 'not (lp y seen default)))
+      (else
+       x))))
+
+(define (type-resolve-circularities x)
+  (match x
+    (($ <lam> name params body defs)
+     (if (unfinalized-type? (lambda-return-type x))
+         (lambda-return-type-set! x (resolve-delayed-type
+                                     (lambda-return-type x))))
+     (for-each
+      (lambda (p t)
+        (if (unfinalized-type? t)
+            (lambda-param-type-set! x p (resolve-delayed-type t))))
+      params
+      (lambda-param-types x))
+     (type-resolve-circularities (lambda-body x)))
+    (($ <set> ref value)
+     (type-resolve-circularities value))
+    (($ <cnd> test pass fail)
+     (type-resolve-circularities test)
+     (type-resolve-circularities pass)
+     (type-resolve-circularities fail))
+    (($ <seq> ls)
+     (for-each type-resolve-circularities ls))
+    ((app ...)
+     (for-each type-resolve-circularities app))
+    (else #f)))
+
+(define (type-analyze-module-body name ls)
+  (for-each type-analyze-expr ls)
+  (for-each type-resolve-circularities ls))
+
+(define (type-analyze-module name)
+  (let* ((mod (analyze-module name))
+         (ls (and (vector? mod) (module-ast mod))))
+    (and ls
+         (let ((x (let lp ((ls ls)) ;; first lambda
+                    (and (pair? ls)
+                         (if (and (set? (car ls))
+                                  (lambda? (set-value (car ls))))
+                             (set-value (car ls))
+                             (lp (cdr ls)))))))
+           (if (and x (not (typed? x)))
+               (type-analyze-module-body name ls))
+           ls))))
+
+(define (type-analyze sexp . o)
+  (type-analyze-expr (apply analyze sexp o)))
+
+(define (opcode-param-types x)
+  (let lp ((n (- (opcode-num-params x) 1)) (res '()))
+    (if (< n 0)
+        res
+        (lp (- n 1) (cons (opcode-param-type x n) res)))))
+
+(define (opcode-type x)
+  (cons 'lambda (cons (opcode-return-type x) (opcode-param-types x))))
+
+(define (lambda-type x)
+  (cons 'lambda (cons (lambda-return-type x) (lambda-param-types x))))
+
+(define (procedure-signature x)
+  (if (opcode? x)
+      (cdr (opcode-type x))
+      (let lp ((count 0))
+        (let ((lam (procedure-analysis x)))
+          (cond
+           ((and lam (not (typed? lam)) (zero? count)
+                 (containing-module x))
+            => (lambda (mod)
+                 (and (type-analyze-module (car mod))
+                      (lp (+ count 1)))))
+           ((lambda? lam)
+            (cdr (lambda-type lam)))
+           (else
+            #f))))))

lib/chibi/uri.module

@@ -0,0 +1,10 @@
+
+(define-module (chibi uri)
+  (export uri? uri->string make-uri string->uri
+          uri-scheme uri-user uri-host uri-port uri-path uri-query uri-fragment
+          uri-with-scheme uri-with-user uri-with-host uri-with-path
+          uri-with-query uri-with-fragment
+          uri-encode uri-decode uri-query->alist uri-alist->query)
+  (import-immutable (scheme)
+                    (srfi 9))
+  (include "uri.scm"))

lib/chibi/uri.scm

@@ -0,0 +1,306 @@
+;; uri.scm -- URI parsing library
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; URI representation
+
+(define-record-type uri
+  (%make-uri scheme user host port path query fragment)
+  uri?
+  (scheme uri-scheme)
+  (user uri-user)
+  (host uri-host)
+  (port uri-port)
+  (path uri-path)
+  (query uri-query)
+  (fragment uri-fragment))
+
+;; (make-uri scheme [user host port path query fragment])
+(define (make-uri scheme . o)
+  (let* ((user (if (pair? o) (car o) #f))
+         (o (if (pair? o) (cdr o) '()))
+         (host (if (pair? o) (car o) #f))
+         (o (if (pair? o) (cdr o) '()))
+         (port (if (pair? o) (car o) #f))
+         (o (if (pair? o) (cdr o) '()))
+         (path (if (pair? o) (car o) #f))
+         (o (if (pair? o) (cdr o) '()))
+         (query (if (pair? o) (car o) #f))
+         (o (if (pair? o) (cdr o) '()))
+         (fragment (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) #f)))
+    (%make-uri scheme user host port path query fragment)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; string utils (don't feel like using SRFI-13 and these are more
+;; specialised)
+
+(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 (string-scan-right str ch . o)
+  (let ((start (if (pair? o) (car o) 0))
+        (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str))))
+    (let lp ((i (- end 1)))
+      (and (>= i start)
+           (if (eqv? ch (string-ref str i))
+               i
+               (lp (- i 1)))))))
+
+(define (string-index-of str pred . 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)
+            ((pred (string-ref str i)) i)
+            (else (lp (+ i 1)))))))
+
+(define (string-downcase->symbol str)
+  (let ((len (string-length str)))
+    (let lp ((i 0))
+      (cond
+       ((= i len)
+        (string->symbol str))
+       ((char-upper-case? (string-ref str i))
+        (let ((res (make-string len)))
+          (do ((j 0 (+ j 1)))
+              ((= j i))
+            (string-set! res j (string-ref str j)))
+          (string-set! res i (char-downcase (string-ref str i)))
+          (do ((j (+ i 1) (+ j 1)))
+              ((= j len))
+            (string-set! res j (char-downcase (string-ref str j))))
+          (string->symbol res)))
+       (else
+        (lp (+ i 1)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; functional updaters (uses as much shared state as possible)
+
+(define (uri-with-scheme u scheme)
+  (%make-uri scheme (uri-user u) (uri-host u) (uri-port u)
+             (uri-path u) (uri-query u) (uri-fragment u)))
+
+(define (uri-with-user u user)
+  (%make-uri (uri-scheme u) user (uri-host u) (uri-port u)
+             (uri-path u) (uri-query u) (uri-fragment u)))
+
+(define (uri-with-host u host)
+  (%make-uri (uri-scheme u) (uri-user u) host (uri-port u)
+             (uri-path u) (uri-query u) (uri-fragment u)))
+
+(define (uri-with-port u port)
+  (%make-uri (uri-scheme u) (uri-user u) (uri-host u) port
+             (uri-path u) (uri-query u) (uri-fragment u)))
+
+(define (uri-with-path u path)
+  (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u)
+             path (uri-query u) (uri-fragment u)))
+
+(define (uri-with-query u query)
+  (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u)
+             (uri-path u) query (uri-fragment u)))
+
+(define (uri-with-fragment u fragment)
+  (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u)
+             (uri-path u) (uri-query u) fragment))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; parsing - without :// we just split into scheme & path
+
+(define (char-uri-scheme-unsafe? ch)
+  (not (or (char-alphabetic? ch) (char-numeric? ch) (memv ch '(#\_ #\-)))))
+
+(define (string->path-uri scheme str . o)
+  (define decode? (and (pair? o) (car o)))
+  (define decode (if decode? uri-decode (lambda (x) x)))
+  (define decode-query
+    (if (and (pair? o) (pair? (cdr o)) (cadr o))
+        uri-query->alist
+        decode))
+  (if (pair? str)
+      str
+      (let* ((len (string-length str))
+             (colon0 (string-scan str #\:))
+             (colon
+              (and (not (string-index-of str char-uri-scheme-unsafe?
+                                         0 (or colon0 len)))
+                   colon0)))
+        (if (or (not colon) (zero? colon))
+            (and scheme
+                 (let* ((quest (string-scan str #\? 0))
+                        (pound (string-scan str #\# (or quest 0))))
+                   (make-uri scheme #f #f #f
+                             (decode (substring str 0 (or quest pound len)))
+                             (and quest
+                                  (decode-query
+                                   (substring str (+ quest 1) (or pound len))))
+                             (and pound
+                                  (decode (substring str (+ pound 1) len))))))
+            (let ((sc1 (+ colon 1))
+                  (scheme (string-downcase->symbol (substring str 0 colon))))
+              (if (= sc1 len)
+                  (make-uri scheme)
+                  (if (or (>= (+ sc1 1) len)
+                          (not (and (eqv? #\/ (string-ref str sc1))
+                                    (eqv? #\/ (string-ref str (+ sc1 1))))))
+                      (make-uri scheme #f #f #f (substring str sc1 len))
+                      (if (>= (+ sc1 2) len)
+                          (make-uri scheme #f "")
+                          (let* ((sc2 (+ sc1 2))
+                                 (slash (string-scan str #\/ sc2))
+                                 (sc3 (or slash len))
+                                 (at (string-scan-right str #\@ sc2 sc3))
+                                 (colon3 (string-scan str #\: (or at sc2) sc3))
+                                 (quest (string-scan str #\? sc3))
+                                 (pound (string-scan str #\# (or quest sc3))))
+                            (%make-uri
+                             scheme
+                             (and at (decode (substring str sc2 at)))
+                             (decode
+                              (substring str
+                                         (if at (+ at 1) sc2)
+                                         (or colon3 sc3)))
+                             (and colon3
+                                  (string->number
+                                   (substring str (+ colon3 1) sc3)))
+                             (and slash
+                                  (decode
+                                   (substring str slash (or quest pound len))))
+                             (and quest
+                                  (decode-query
+                                   (substring str (+ quest 1)
+                                              (or pound len))))
+                             (and pound
+                                  (decode (substring str (+ pound 1) len)))
+                             ))))))))))
+
+(define (string->uri str . o)
+  (apply string->path-uri #f str o))
+
+(define (uri->string uri . o)
+  (define encode? (and (pair? o) (car o)))
+  (define encode (if encode? uri-encode (lambda (x) x)))
+  (if (string? uri)
+      uri
+      (let ((fragment (uri-fragment uri))
+            (query (uri-query uri))
+            (path (uri-path uri))
+            (port (uri-port uri))
+            (host (uri-host uri))
+            (user (uri-user uri)))
+        (string-append
+         (symbol->string (uri-scheme uri)) ":"
+         (if (or user host port) "//" "")
+         (if user (encode user) "") (if user "@" "")
+         (or host "")                   ; host shouldn't need encoding
+         (if port ":" "") (if port (number->string port) "")
+         (if path (encode path) "")
+         (if query "?" "")
+         (if (pair? query) (uri-alist->query query) (or query ""))
+         (if fragment "#" "") (if fragment (encode fragment) "")))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; query encoding and decoding
+
+(define (uri-safe-char? ch)
+  (or (char-alphabetic? ch)
+      (char-numeric? ch)
+      (case ch
+        ((#\- #\_ #\. #\! #\~ #\* #\' #\( #\)) #t)
+        (else #f))))
+
+(define (collect str from to res)
+  (if (>= from to)
+      res
+      (cons (substring str from to) res)))
+
+(define (uri-encode str . o)
+  (define (encode-1-space ch)
+    (if (eqv? ch #\space)
+        "+"
+        (encode-1-normal ch)))
+  (define (encode-1-normal ch)
+    (let* ((i (char->integer ch))
+           (hex (number->string i 16)))
+      (if (< i 16)
+          (string-append "%0" hex)
+          (string-append "%" hex))))
+  (let ((start 0)
+        (end (string-length str))
+        (encode-1 (if (and (pair? o) (car o))
+                      encode-1-space
+                      encode-1-normal)))
+    (let lp ((from start) (to start) (res '()))
+      (if (>= to end)
+          (if (zero? from)
+              str
+              (string-concatenate (reverse (collect str from to res))))
+          (let* ((ch (string-ref str to))
+                 (next (+ to 1)))
+            (if (uri-safe-char? ch)
+                (lp from next res)
+                (lp next next (cons (encode-1 ch)
+                                    (collect str from to res)))))))))
+
+(define (uri-decode str . o)
+  (let ((space-as-plus? (and (pair? o) (car o)))
+        (start 0)
+        (end (string-length str)))
+    (let lp ((from start) (to start) (res '()))
+      (if (>= to end)
+          (if (zero? from)
+              str
+              (string-concatenate (reverse (collect str from to res))))
+          (let* ((ch (string-ref str to))
+                 (next (+ to 1)))
+            (cond
+             ((eqv? ch #\%)
+              (if (>= next end)
+                  (lp next next (collect str from to res))
+                  (let ((next2 (+ next 1)))
+                    (if (>= next2 end)
+                        (lp next2 next2 (collect str from to res))
+                        (let* ((next3 (+ next2 1))
+                               (hex (substring str next next3))
+                               (i (string->number hex 16)))
+                          (lp next3 next3 (cons (string (integer->char i))
+                                                (collect str from to res))))))))
+             ((and space-as-plus? (eqv? ch #\+))
+              (lp next next (cons " " (collect str from to res))))
+             (else
+              (lp from next res))))))))
+
+(define (uri-query->alist str . o)
+  (define (split-char? c) (if (eqv? c #\&) #t (eqv? c #\;)))
+  (let ((len (string-length str))
+        (plus? (and (pair? o) (car o))))
+    (let lp ((i 0) (res '()))
+      (if (>= i len)
+          (reverse res)
+          (let* ((j (or (string-index-of str split-char? i) len))
+                 (k (string-scan str #\= i j))
+                 (cell (if k
+                           (cons (uri-decode (substring str i k) plus?)
+                                 (uri-decode (substring str (+ k 1) j) plus?))
+                           (cons (uri-decode (substring str i j) plus?) #f))))
+            (lp (+ j 1) (cons cell res)))))))
+
+(define (uri-alist->query ls . o)
+  (define plus? (and (pair? o) (car o)))
+  (define (encode key val res)
+    (let ((res (cons (uri-encode key plus?) res)))
+      (if val (cons (uri-encode val plus?) (cons "=" res)) res)))
+  (if (null? ls)
+      ""
+      (let lp ((x (car ls)) (ls (cdr ls)) (res '()))
+        (let ((res (encode (car x) (cdr x) res)))
+          (if (null? ls)
+              (string-concatenate (reverse res))
+              (lp (car ls) (cdr ls) (cons "&" res)))))))

lib/config.scm

@@ -0,0 +1,179 @@
+;; config.scm -- configuration module
+;; Copyright (c) 2009-2010 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; modules
+
+(define *this-module* '())
+
+(define (make-module exports env meta) (vector exports env meta #f))
+(define (%module-exports mod) (vector-ref mod 0))
+(define (module-env mod) (vector-ref mod 1))
+(define (module-meta-data mod) (vector-ref mod 2))
+(define (module-env-set! mod env) (vector-set! mod 1 env))
+
+(define (module-exports mod)
+  (or (%module-exports mod) (env-exports (module-env mod))))
+
+(define (module-name->strings ls res)
+  (if (null? ls)
+      res
+      (let ((str (cond ((symbol? (car ls)) (symbol->string (car ls)))
+                       ((number? (car ls)) (number->string (car ls)))
+                       ((string? (car ls)) (car ls))
+                       (else (error "invalid module name" (car ls))))))
+        (module-name->strings (cdr ls) (cons "/" (cons str res))))))
+
+(define (module-name->file name)
+  (string-concatenate
+   (reverse (cons ".module" (cdr (module-name->strings name '()))))))
+
+(define (module-name-prefix name)
+  (string-concatenate (reverse (cdr (cdr (module-name->strings name '()))))))
+
+(define (load-module-definition name)
+  (let* ((file (module-name->file name))
+         (path (find-module-file file)))
+    (if path (load path *config-env*))))
+
+(define (find-module name)
+  (cond
+   ((assoc name *modules*) => cdr)
+   (else
+    (load-module-definition name)
+    (cond ((assoc name *modules*) => cdr)
+          (else #f)))))
+
+(define (symbol-append a b)
+  (string->symbol (string-append (symbol->string a) (symbol->string b))))
+
+(define (to-id id) (if (pair? id) (car id) id))
+(define (from-id id) (if (pair? id) (cdr id) id))
+(define (id-filter pred ls)
+  (cond ((null? ls) '())
+        ((pred (to-id (car ls))) (cons (car ls) (id-filter pred (cdr ls))))
+        (else (id-filter pred (cdr ls)))))
+
+(define (resolve-import x)
+  (cond
+   ((not (and (pair? x) (list? x)))
+    (error "invalid module syntax" x))
+   ((and (pair? (cdr x)) (pair? (cadr x)))
+    (if (memq (car x) '(only except rename))
+        (let* ((mod-name+imports (resolve-import (cadr x)))
+               (imp-ids (cdr mod-name+imports))
+               (imp-ids (if (and (not imp-ids) (not (eq? 'only (car x))))
+                            (begin
+                              (set-cdr! mod-name+imports
+                                        (module-exports
+                                         (find-module (car mod-name+imports))))
+                              (cdr mod-name+imports))
+                            imp-ids)))
+          (cons (car mod-name+imports)
+                (case (car x)
+                  ((only)
+                   (if (not imp-ids)
+                       (cddr x)
+                       (id-filter (lambda (i) (memq i (cddr x))) imp-ids)))
+                  ((except)
+                   (id-filter (lambda (i) (not (memq i (cddr x)))) imp-ids))
+                  ((rename)
+                   (map (lambda (i)
+                          (let ((rename (assq (to-id i) (cddr x))))
+                            (if rename (cons (cdr rename) (from-id i)) i)))
+                        imp-ids)))))
+        (error "invalid import modifier" x)))
+   ((and (eq? 'prefix (car x)) (symbol? (cadr x)) (list? (caddr x)))
+    (let ((mod-name+imports (resolve-import (caddr x))))
+      (cons (car mod-name+imports)
+            (map (lambda (i)
+                   (cons (symbol-append (cadr x) (if (pair? i) (car i) i))
+                         (if (pair? i) (cdr i) i)))
+                 (cdr mod-name+imports)))))
+   ((find-module x)
+    => (lambda (mod) (cons x (%module-exports mod))))
+   (else
+    (error "couldn't find import" x))))
+
+(define (eval-module name mod)
+  (let ((env (make-environment))
+        (dir (module-name-prefix name)))
+    (define (load-modules files extension)
+      (for-each
+       (lambda (f)
+         (let ((f (string-append dir f extension)))
+           (cond ((find-module-file f) => (lambda (x) (load x env)))
+                 (else (error "couldn't find include" f)))))
+       files))
+    (for-each
+     (lambda (x)
+       (case (and (pair? x) (car x))
+         ((import import-immutable)
+          (for-each
+           (lambda (m)
+             (let* ((mod2-name+imports (resolve-import m))
+                    (mod2 (load-module (car mod2-name+imports))))
+               (%env-copy! env (module-env mod2) (cdr mod2-name+imports)
+                           (eq? (car x) 'import-immutable))))
+           (cdr x)))
+         ((include)
+          (load-modules (cdr x) ""))
+         ((include-shared)
+          (cond-expand
+           (dynamic-loading (load-modules (cdr x) *shared-object-extension*))
+           (else #f)))
+         ((body)
+          (for-each (lambda (expr) (eval expr env)) (cdr x)))))
+     (module-meta-data mod))
+    env))
+
+(define (load-module name)
+  (let ((mod (find-module name)))
+    (if (and mod (not (module-env mod)))
+        (module-env-set! mod (eval-module name mod)))
+    mod))
+
+(define-syntax define-module
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let ((name (cadr expr))
+           (body (cddr expr)))
+       `(let ((tmp *this-module*))
+          (set! *this-module* '())
+          ,@body
+          (set! *this-module* (reverse *this-module*))
+          (let ((exports
+                 (cond ((assq 'export *this-module*) => cdr)
+                       (else '()))))
+            (set! *modules*
+                  (cons (cons ',name (make-module exports #f *this-module*))
+                        *modules*)))
+          (set! *this-module* tmp))))))
+
+(define-syntax define-config-primitive
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     `(define-syntax ,(cadr expr)
+        (er-macro-transformer
+         (lambda (expr rename compare)
+           `(set! *this-module* (cons ',expr *this-module*))))))))
+
+(define-config-primitive import)
+(define-config-primitive import-immutable)
+(define-config-primitive export)
+(define-config-primitive include)
+(define-config-primitive include-shared)
+(define-config-primitive body)
+
+(define *modules*
+  (list (cons '(scheme) (make-module #f (interaction-environment)
+                                     '((include "init.scm"))))
+        (cons '(config) (make-module #f (current-environment) '()))
+        (cons '(srfi 0) (make-module (list 'cond-expand)
+                                     (interaction-environment)
+                                     (list (list 'export 'cond-expand))))
+        (cons '(srfi 46) (make-module (list 'syntax-rules)
+                                      (interaction-environment)
+                                      (list (list 'export 'syntax-rules))))))
+

lib/init.scm

@@ -0,0 +1,875 @@
+;; init.scm -- R5RS library procedures
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;; provide c[ad]{2,4}r
+
+(define (caar x) (car (car x)))
+(define (cadr x) (car (cdr x)))
+(define (cdar x) (cdr (car x)))
+(define (cddr x) (cdr (cdr x)))
+(define (caaar x) (car (car (car x))))
+(define (caadr x) (car (car (cdr x))))
+(define (cadar x) (car (cdr (car x))))
+(define (caddr x) (car (cdr (cdr x))))
+(define (cdaar x) (cdr (car (car x))))
+(define (cdadr x) (cdr (car (cdr x))))
+(define (cddar x) (cdr (cdr (car x))))
+(define (cdddr x) (cdr (cdr (cdr x))))
+(define (caaaar x) (car (car (car (car x)))))
+(define (caaadr x) (car (car (car (cdr x)))))
+(define (caadar x) (car (car (cdr (car x)))))
+(define (caaddr x) (car (car (cdr (cdr x)))))
+(define (cadaar x) (car (cdr (car (car x)))))
+(define (cadadr x) (car (cdr (car (cdr x)))))
+(define (caddar x) (car (cdr (cdr (car x)))))
+(define (cadddr x) (car (cdr (cdr (cdr x)))))
+(define (cdaaar x) (cdr (car (car (car x)))))
+(define (cdaadr x) (cdr (car (car (cdr x)))))
+(define (cdadar x) (cdr (car (cdr (car x)))))
+(define (cdaddr x) (cdr (car (cdr (cdr x)))))
+(define (cddaar x) (cdr (cdr (car (car x)))))
+(define (cddadr x) (cdr (cdr (car (cdr x)))))
+(define (cdddar x) (cdr (cdr (cdr (car x)))))
+(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
+
+;; basic utils
+
+(define (procedure? x) (if (closure? x) #t (opcode? x)))
+
+(define (list . args) args)
+
+(define (list-tail ls k)
+  (if (eq? k 0)
+      ls
+      (list-tail (cdr ls) (- k 1))))
+
+(define (list-ref ls k) (car (list-tail ls k)))
+
+(define (append-helper ls res)
+  (if (null? ls)
+      res
+      (append-helper (cdr ls) (append2 (car ls) res))))
+
+(define (append . o)
+  (if (null? o)
+      '()
+      ((lambda (lol)
+         (append-helper (cdr lol) (car lol)))
+       (reverse o))))
+
+(define (apply proc . args)
+  (if (null? args)
+      (proc)
+      ((lambda (lol)
+         (apply1 proc (append2 (reverse (cdr lol)) (car lol))))
+       (reverse args))))
+
+;; map with a fast-path for single lists
+
+(define (map proc ls . lol)
+  (define (map1 proc ls res)
+    (if (pair? ls)
+        (map1 proc (cdr ls) (cons (proc (car ls)) res))
+        (reverse res)))
+  (define (mapn proc lol res)
+    (if (pair? (car lol))
+        (mapn proc
+              (map1 cdr lol '())
+              (cons (apply1 proc (map1 car lol '())) res))
+        (reverse res)))
+  (if (null? lol)
+      (map1 proc ls '())
+      (mapn proc (cons ls lol) '())))
+
+(define (for-each f ls . lol)
+  (define (for1 f ls) (if (pair? ls) (begin (f (car ls)) (for1 f (cdr ls)))))
+  (if (null? lol) (for1 f ls) (begin (apply map f ls lol) (if #f #f))))
+
+(define (any pred ls)
+  (if (pair? ls) (if (pred (car ls)) (car ls) (any pred (cdr ls))) #f))
+
+(define (every pred ls)
+  (if (pair? ls) (if (pred (car ls)) (every pred (cdr ls)) #f) #t))
+
+(define (delq x ls)
+  (if (pair? ls)
+      (if (eq? x (car ls)) (delq x (cdr ls)) (cons (car ls) (delq x (cdr ls))))
+      '()))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; syntax
+
+(define sc-macro-transformer
+  (lambda (f)
+    (lambda (expr use-env mac-env)
+      (make-syntactic-closure mac-env '() (f expr use-env)))))
+
+(define rsc-macro-transformer
+  (lambda (f)
+    (lambda (expr use-env mac-env)
+      (f expr mac-env))))
+
+(define er-macro-transformer
+  (lambda (f)
+    (lambda (expr use-env mac-env)
+      ((lambda (rename compare) (f expr rename compare))
+       ((lambda (renames)
+          (lambda (identifier)
+            ((lambda (cell)
+               (if cell
+                   (cdr cell)
+                   ((lambda (name)
+                      (set! renames (cons (cons identifier name) renames))
+                      name)
+                    (make-syntactic-closure mac-env '() identifier))))
+             (assq identifier renames))))
+        '())
+       (lambda (x y) (identifier=? use-env x use-env y))))))
+
+(define-syntax cond
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (if (null? (cdr expr))
+         #f
+         ((lambda (cl)
+            (if (compare (rename 'else) (car cl))
+                (if (pair? (cddr expr))
+                    (error "non-final else in cond" expr)
+                    (cons (rename 'begin) (cdr cl)))
+                (if (if (null? (cdr cl)) #t (compare (rename '=>) (cadr cl)))
+                    (list (list (rename 'lambda) (list (rename 'tmp))
+                                (list (rename 'if) (rename 'tmp)
+                                      (if (null? (cdr cl))
+                                          (rename 'tmp)
+                                          (list (caddr cl) (rename 'tmp)))
+                                      (cons (rename 'cond) (cddr expr))))
+                          (car cl))
+                    (list (rename 'if)
+                          (car cl)
+                          (cons (rename 'begin) (cdr cl))
+                          (cons (rename 'cond) (cddr expr))))))
+          (cadr expr))))))
+
+(define-syntax or
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (cond ((null? (cdr expr)) #f)
+           ((null? (cddr expr)) (cadr expr))
+           (else
+            (list (rename 'let) (list (list (rename 'tmp) (cadr expr)))
+                  (list (rename 'if) (rename 'tmp)
+                        (rename 'tmp)
+                        (cons (rename 'or) (cddr expr)))))))))
+
+(define-syntax and
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (cond ((null? (cdr expr)))
+           ((null? (cddr expr)) (cadr expr))
+           (else (list (rename 'if) (cadr expr)
+                       (cons (rename 'and) (cddr expr))
+                       #f))))))
+
+(define-syntax quasiquote
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (define (qq x d)
+       (cond
+        ((pair? x)
+         (cond
+          ((compare (rename 'unquote) (car x))
+           (if (<= d 0)
+               (cadr x)
+               (list (rename 'list) (list (rename 'quote) 'unquote)
+                     (qq (cadr x) (- d 1)))))
+          ((compare (rename 'unquote-splicing) (car x))
+           (if (<= d 0)
+               (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))
+               (list (rename 'list) (list (rename 'quote) 'unquote-splicing)
+                     (qq (cadr x) (- d 1)))))
+          ((compare (rename 'quasiquote) (car x))
+           (list (rename 'list) (list (rename 'quote) 'quasiquote)
+                 (qq (cadr x) (+ d 1))))
+          ((and (<= d 0) (pair? (car x)) (compare (rename 'unquote-splicing) (caar x)))
+           (if (null? (cdr x))
+               (cadar x)
+               (list (rename 'append) (cadar x) (qq (cdr x) d))))
+          (else
+           (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)))))
+        ((vector? x) (list (rename 'list->vector) (qq (vector->list x) d)))
+        ((symbol? x) (list (rename 'quote) x))
+        (else x)))
+     (qq (cadr expr) 0))))
+
+(define-syntax letrec
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     ((lambda (defs)
+        `((,(rename 'lambda) () ,@defs ,@(cddr expr))))
+      (map (lambda (x) (cons (rename 'define) x)) (cadr expr))))))
+
+(define-syntax let
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (if (null? (cdr expr)) (error "empty let" expr))
+     (if (null? (cddr expr)) (error "no let body" expr))
+     ((lambda (bindings)
+        (if (list? bindings) #f (error "bad let bindings"))
+        (if (every (lambda (x)
+                     (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f))
+                   bindings)
+            ((lambda (vars vals)
+               (if (identifier? (cadr expr))
+                   `((,(rename 'lambda) ,vars
+                      (,(rename 'letrec) ((,(cadr expr)
+                                           (,(rename 'lambda) ,vars
+                                            ,@(cdddr expr))))
+                       (,(cadr expr) ,@vars)))
+                     ,@vals)
+                   `((,(rename 'lambda) ,vars ,@(cddr expr)) ,@vals)))
+             (map car bindings)
+             (map cadr bindings))
+            (error "bad let syntax" expr)))
+      (if (identifier? (cadr expr)) (caddr expr) (cadr expr))))))
+
+(define-syntax let*
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (if (null? (cdr expr)) (error "empty let*" expr))
+     (if (null? (cddr expr)) (error "no let* body" expr))
+     (if (null? (cadr expr))
+         `(,(rename 'let) () ,@(cddr expr))
+         (if (if (list? (cadr expr))
+                 (every
+                  (lambda (x)
+                    (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f))
+                  (cadr expr))
+                 #f)
+             `(,(rename 'let) (,(caadr expr))
+               (,(rename 'let*) ,(cdadr expr) ,@(cddr expr)))
+             (error "bad let* syntax"))))))
+
+(define-syntax case
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (define (clause ls)
+       (cond
+        ((null? ls) #f)
+        ((compare (rename 'else) (caar ls))
+         `(,(rename 'begin) ,@(cdar ls)))
+        (else
+         (if (and (pair? (caar ls)) (null? (cdaar ls)))
+             `(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp) ',(caaar ls))
+               (,(rename 'begin) ,@(cdar ls))
+               ,(clause (cdr ls)))
+             `(,(rename 'if) (,(rename 'memv) ,(rename 'tmp) ',(caar ls))
+               (,(rename 'begin) ,@(cdar ls))
+               ,(clause (cdr ls)))))))
+     `(let ((,(rename 'tmp) ,(cadr expr)))
+        ,(clause (cddr expr))))))
+
+(define-syntax do
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let* ((body
+             `(,(rename 'begin)
+               ,@(cdddr expr)
+               (,(rename 'lp)
+                ,@(map (lambda (x) (if (pair? (cddr x)) (caddr x) (car x)))
+                       (cadr expr)))))
+            (check (caddr expr))
+            (wrap
+             (if (null? (cdr check))
+                 `(,(rename 'let) ((,(rename 'tmp) ,(car check)))
+                   (,(rename 'if) ,(rename 'tmp)
+                    ,(rename 'tmp)
+                    ,body))
+                 `(,(rename 'if) ,(car check)
+                   (,(rename 'begin) ,@(cdr check))
+                   ,body))))
+       `(,(rename 'let) ,(rename 'lp)
+         ,(map (lambda (x) (list (car x) (cadr x))) (cadr expr))
+         ,wrap)))))
+
+(define-syntax delay
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     `(,(rename 'make-promise) (,(rename 'lambda) () ,(cadr expr))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; promises
+
+(define (make-promise thunk)
+  (lambda ()
+    (let ((computed? #f) (result #f))
+      (if (not computed?)
+          (begin
+            (set! result (thunk))
+            (set! computed? #t)))
+      result)))
+
+(define (force x) (if (procedure? x) (x) x))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; exceptions
+
+(define (error msg . args)
+  (raise (make-exception 'user msg args #f #f)))
+
+(define (with-exception-handler handler thunk)
+  (letrec ((orig-handler (current-exception-handler))
+           (self (lambda (exn)
+                   (current-exception-handler orig-handler)
+                   (let ((res (handler exn)))
+                     (current-exception-handler self)
+                     res))))
+    (current-exception-handler self)
+    (let ((res (thunk)))
+      (current-exception-handler orig-handler)
+      res)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; library functions
+
+;; booleans
+
+(define (not x) (if x #f #t))
+(define (boolean? x) (if (eq? x #t) #t (eq? x #f)))
+
+;; char utils
+
+(define (char-alphabetic? ch) (<= 65 (char->integer (char-upcase ch)) 90))
+(define (char-numeric? ch) (<= 48 (char->integer ch) 57))
+(define (char-whitespace? ch)
+  (if (eq? ch #\space)
+      #t
+      (if (eq? ch #\tab) #t (if (eq? ch #\newline) #t (eq? ch #\return)))))
+(define (char-upper-case? ch) (<= 65 (char->integer ch) 90))
+(define (char-lower-case? ch) (<= 97 (char->integer ch) 122))
+
+(define (char=? a b) (= (char->integer a) (char->integer b)))
+(define (char<? a b) (< (char->integer a) (char->integer b)))
+(define (char>? a b) (> (char->integer a) (char->integer b)))
+(define (char<=? a b) (<= (char->integer a) (char->integer b)))
+(define (char>=? a b) (>= (char->integer a) (char->integer b)))
+
+(define (char-ci=? a b)
+  (= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
+(define (char-ci<? a b)
+  (< (char->integer (char-downcase a)) (char->integer (char-downcase b))))
+(define (char-ci>? a b)
+  (> (char->integer (char-downcase a)) (char->integer (char-downcase b))))
+(define (char-ci<=? a b)
+  (<= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
+(define (char-ci>=? a b)
+  (>= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
+
+;; string utils
+
+(define (symbol->string sym)
+  (call-with-output-string (lambda (out) (write sym out))))
+
+(define (list->string ls)
+  (let ((str (make-string (length ls) #\space)))
+    (let lp ((ls ls) (i 0))
+      (if (pair? ls)
+          (begin
+            (string-set! str i (car ls))
+            (lp (cdr ls) (+ i 1)))))
+    str))
+
+(define (string->list str)
+  (let lp ((i (- (string-length str) 1)) (res '()))
+    (if (< i 0) res (lp (- i 1) (cons (string-ref str i) res)))))
+
+(define (string-fill! str ch)
+  (let lp ((i (- (string-length str) 1)))
+    (if (>= i 0) (begin (string-set! str i ch) (lp (- i 1))))))
+
+(define (string . args) (list->string args))
+(define (string-append . args) (string-concatenate args))
+(define (string-copy s) (substring s 0 (string-length s)))
+
+(define (string=? s1 s2) (eq? (string-cmp s1 s2 #f) 0))
+(define (string<? s1 s2) (< (string-cmp s1 s2 #f) 0))
+(define (string<=? s1 s2) (<= (string-cmp s1 s2 #f) 0))
+(define (string>? s1 s2) (> (string-cmp s1 s2 #f) 0))
+(define (string>=? s1 s2) (>= (string-cmp s1 s2 #f) 0))
+
+(define (string-ci=? s1 s2) (eq? (string-cmp s1 s2 #t) 0))
+(define (string-ci<? s1 s2) (< (string-cmp s1 s2 #t) 0))
+(define (string-ci<=? s1 s2) (<= (string-cmp s1 s2 #t) 0))
+(define (string-ci>? s1 s2) (> (string-cmp s1 s2 #t) 0))
+(define (string-ci>=? s1 s2) (>= (string-cmp s1 s2 #t) 0))
+
+;; list utils
+
+(define (eqv? a b) (if (eq? a b) #t (and (flonum? a) (flonum? b) (= a b))))
+
+(define (member obj ls . o)
+  (let ((eq (if (pair? o) (car o) equal?)))
+    (let lp ((ls ls))
+      (and (pair? ls) (if (eq obj (car ls)) ls (lp (cdr ls)))))))
+
+(define memv member)
+
+(define (assoc obj ls)
+  (if (null? ls)
+      #f
+      (if (equal? obj (caar ls))
+          (car ls)
+          (assoc obj (cdr ls)))))
+
+(define assv assoc)
+
+;; math utils
+
+(define (number? x) (if (fixnum? x) #t (if (bignum? x) #t (flonum? x))))
+(define complex? number?)
+(define rational? number?)
+(define real? number?)
+(define (exact? x) (if (fixnum? x) #t (bignum? x)))
+(define inexact? flonum?)
+(define (integer? x)
+  (if (fixnum? x) #t (if (bignum? x) #t (and (flonum? x) (= x (truncate x))))))
+
+(define (zero? x) (= x 0))
+(define (positive? x) (> x 0))
+(define (negative? x) (< x 0))
+(define (even? n) (= (remainder n 2) 0))
+(define (odd? n) (= (remainder n 2) 1))
+
+(define (abs x) (if (< x 0) (- x) x))
+
+(define (numerator x)
+  (if (integer? x) x (numerator (* x 10))))
+(define (denominator x)
+  (if (exact? x)
+      1
+      (let lp ((x x) (r 1.0)) (if (integer? x) r (lp (* x 10) (* r 10))))))
+
+(define (modulo a b)
+  (let ((res (remainder a b)))
+    (if (< b 0)
+        (if (<= res 0) res (+ res b))
+        (if (>= res 0) res (+ res b)))))
+
+(define (gcd a b)
+  (if (= b 0)
+      (abs a)
+      (gcd b (remainder a b))))
+
+(define (lcm a b)
+  (abs (quotient (* a b) (gcd a b))))
+
+(define (max x . rest)
+  (let lp ((hi x) (ls rest))
+    (if (null? ls)
+        hi
+        (lp (if (> (car ls) hi) (car ls) hi) (cdr ls)))))
+
+(define (min x . rest)
+  (let lp ((lo x) (ls rest))
+    (if (null? ls)
+        lo
+        (lp (if (< (car ls) lo) (car ls) lo) (cdr ls)))))
+
+(define (real-part z) z)
+(define (imag-part z) 0.0)
+(define magnitude abs)
+(define (angle z) (if (< z 0) 3.141592653589793 0))
+
+(define (atan x . o) (if (null? o) (atan1 x) (atan1 (/ x (car o)))))
+
+(define (digit-char n)
+  (if (<= n 9)
+      (integer->char (+ n (char->integer #\0)))
+      (integer->char (+ (- n 10) (char->integer #\A)))))
+(define (digit-value ch)
+  (if (char-numeric? ch)
+      (- (char->integer ch) (char->integer #\0))
+      (and (<= 65 (char->integer (char-upcase ch)) 70)
+           (- (char->integer (char-upcase ch)) 55))))
+
+(define (number->string num . o)
+  (if (if (null? o) #t (eq? 10 (car o)))
+      (call-with-output-string (lambda (out) (write num out)))
+      (let lp ((n (abs num)) (d (car o)) (res '()))
+        (if (> n 0)
+            (lp (quotient n d) d (cons (digit-char (remainder n d)) res))
+            (if (null? res)
+                "0"
+                (list->string (if (negative? num) (cons #\- res) res)))))))
+
+;; vector utils
+
+(define (list->vector ls)
+  (let ((vec (make-vector (length ls) #f)))
+    (let lp ((ls ls) (i 0))
+      (if (pair? ls)
+          (begin
+            (vector-set! vec i (car ls))
+            (lp (cdr ls) (+ i 1)))))
+    vec))
+
+(define (vector->list vec)
+  (let lp ((i (- (vector-length vec) 1)) (res '()))
+    (if (< i 0) res (lp (- i 1) (cons (vector-ref vec i) res)))))
+
+(define (vector-fill! str ch)
+  (let lp ((i (- (vector-length str) 1)))
+    (if (>= i 0) (begin (vector-set! str i ch) (lp (- i 1))))))
+
+(define (vector . args) (list->vector args))
+
+;; I/O utils
+
+(define (char-ready? . o)
+  (not (eof-object? (peek-char (if (pair? o) (car o) (current-input-port))))))
+
+(define (call-with-input-string str proc)
+  (let* ((in (open-input-string str))
+         (res (proc in)))
+    (close-input-port in)
+    res))
+
+(define (call-with-output-string proc)
+  (let ((out (open-output-string)))
+    (proc out)
+    (let ((res (get-output-string out)))
+      (close-output-port out)
+      res)))
+
+(define (call-with-input-file file proc)
+  (let* ((in (open-input-file file))
+         (res (proc in)))
+    (close-input-port in)
+    res))
+
+(define (call-with-output-file file proc)
+  (let* ((out (open-output-file file))
+         (res (proc out)))
+    (close-output-port out)
+    res))
+
+(define (with-input-from-file file thunk)
+  (let ((old-in (current-input-port))
+        (tmp-in (open-input-file file)))
+    (current-input-port tmp-in)
+    (let ((res (thunk)))
+      (current-input-port old-in)
+      res)))
+
+(define (with-output-to-file file thunk)
+  (let ((old-out (current-output-port))
+        (tmp-out (open-output-file file)))
+    (current-output-port tmp-out)
+    (let ((res (thunk)))
+      (current-output-port old-out)
+      res)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; values
+
+(define *values-tag* (list 'values))
+
+(define (values . ls)
+  (if (and (pair? ls) (null? (cdr ls)))
+      (car ls)
+      (cons *values-tag* ls)))
+
+(define (call-with-values producer consumer)
+  (let ((res (producer)))
+    (if (and (pair? res) (eq? *values-tag* (car res)))
+        (apply consumer (cdr res))
+        (consumer res))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; dynamic-wind
+
+(define *dk* (list #f))
+
+(define (dynamic-wind before thunk after)
+  (let ((dk *dk*))
+    (set-dk! (cons (cons before after) dk))
+    (let ((res (thunk))) (set-dk! dk) res)))
+
+(define (set-dk! dk)
+  (if (not (eq? dk *dk*))
+      (begin
+        (set-dk! (cdr dk))
+        (let ((before (car (car dk))) (dk dk))
+          (set-car! *dk* (cons (cdr (car dk)) before))
+          (set-cdr! *dk* dk)
+          (set-car! dk #f)
+          (set-cdr! dk '())
+          (set! *dk* dk)
+          (before)))))
+
+(define (call-with-current-continuation proc)
+  (let ((dk *dk*))
+    (%call/cc (lambda (k) (proc (lambda (x) (set-dk! dk) (k x)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; syntax-rules
+
+(define-syntax syntax-rules
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let ((ellipse-specified? (identifier? (cadr expr)))
+           (count 0)
+           (_er-macro-transformer (rename 'er-macro-transformer))
+           (_lambda (rename 'lambda))      (_let (rename 'let))
+           (_begin (rename 'begin))        (_if (rename 'if))
+           (_and (rename 'and))            (_or (rename 'or))
+           (_eq? (rename 'eq?))            (_equal? (rename 'equal?))
+           (_car (rename 'car))            (_cdr (rename 'cdr))
+           (_cons (rename 'cons))          (_pair? (rename 'pair?))
+           (_null? (rename 'null?))        (_expr (rename 'expr))
+           (_rename (rename 'rename))      (_compare (rename 'compare))
+           (_quote (rename 'syntax-quote)) (_apply (rename 'apply))
+           (_append (rename 'append))      (_map (rename 'map))
+           (_vector? (rename 'vector?))    (_list? (rename 'list?))
+           (_lp (rename 'lp))              (_reverse (rename 'reverse))
+           (_len (rename'len))             (_length (rename 'length))
+           (_- (rename '-))   (_>= (rename '>=))   (_error (rename 'error))
+           (_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i))
+           (_vector->list (rename 'vector->list))
+           (_list->vector (rename 'list->vector)))
+       (define ellipse (rename (if ellipse-specified? (cadr expr) '...)))
+       (define lits (if ellipse-specified? (caddr expr) (cadr expr)))
+       (define forms (if ellipse-specified? (cdddr expr) (cddr expr)))
+       (define (next-v)
+         (set! count (+ count 1))
+         (rename (string->symbol (string-append "v." (number->string count)))))
+       (define (expand-pattern pat tmpl)
+         (let lp ((p (cdr pat))
+                  (x (list _cdr _expr))
+                  (dim 0)
+                  (vars '())
+                  (k (lambda (vars)
+                       (or (expand-template tmpl vars)
+                           (list _begin #f)))))
+           (let ((v (next-v)))
+             (list
+              _let (list (list v x))
+              (cond
+               ((identifier? p)
+                (if (any (lambda (l) (compare p l)) lits)
+                    (list _and (list _compare v (list _quote p)) (k vars))
+                    (list _let (list (list p v)) (k (cons (cons p dim) vars)))))
+               ((ellipse? p)
+                (cond
+                 ((not (null? (cddr p)))
+                  (cond
+                   ((not (list? (cddr p)))
+                    (error "dotted ellipse" p))
+                   ((any (lambda (x) (and (identifier? x) (compare x ellipse)))
+                         (cddr p))
+                    (error "multiple ellipses" p))
+                   (else
+                    (let ((len (length (cdr (cdr p)))))
+                      `(,_let ((,_len (,_length ,v)))
+                         (,_and (,_>= ,_len ,len)
+                                (,_let ,_lp ((,_ls ,v)
+                                             (,_i (,_- ,_len ,len))
+                                             (,_res (,_quote ())))
+                                  (,_if (,_>= 0 ,_i)
+                                      ,(lp `(,@(cdr (cdr p)) ,(car p) ,(car (cdr p)))
+                                           `(,_append ,_ls (,_reverse ,_res))
+                                           dim
+                                           vars
+                                           k)
+                                      (,_lp (,_cdr ,_ls)
+                                            (,_- ,_i 1)
+                                            (,_cons (,_car ,_ls) ,_res))))))))))
+                 ((identifier? (car p))
+                  (list _and (list _list? v)
+                        (list _let (list (list (car p) v))
+                              (k (cons (cons (car p) (+ 1 dim)) vars)))))
+                 (else
+                  (let* ((w (next-v))
+                         (new-vars (all-vars (car p) (+ dim 1)))
+                         (ls-vars (map (lambda (x)
+                                         (rename
+                                          (string->symbol
+                                           (string-append
+                                            (symbol->string
+                                             (identifier->symbol (car x)))
+                                            "-ls"))))
+                                       new-vars))
+                         (once
+                          (lp (car p) (list _car w) (+ dim 1) '()
+                              (lambda (_)
+                                (cons
+                                 _lp
+                                 (cons
+                                  (list _cdr w)
+                                  (map (lambda (x l)
+                                         (list _cons (car x) l))
+                                       new-vars
+                                       ls-vars)))))))
+                    (list
+                     _let
+                     _lp (cons (list w v)
+                               (map (lambda (x) (list x '())) ls-vars))
+                     (list _if (list _null? w)
+                           (list _let (map (lambda (x l)
+                                             (list (car x) (list _reverse l)))
+                                           new-vars
+                                           ls-vars)
+                                 (k (append new-vars vars)))
+                           (list _and (list _pair? w) once)))))))
+               ((pair? p)
+                (list _and (list _pair? v)
+                      (lp (car p)
+                          (list _car v)
+                          dim
+                          vars
+                          (lambda (vars)
+                            (lp (cdr p) (list _cdr v) dim vars k)))))
+               ((vector? p)
+                (list _and
+                      (list _vector? v)
+                      (lp (vector->list p) (list _vector->list v) dim vars k)))
+               ((null? p) (list _and (list _null? v) (k vars)))
+               (else (list _and (list _equal? v p) (k vars))))))))
+       (define (ellipse-escape? x) (and (pair? x) (compare ellipse (car x))))
+       (define (ellipse? x)
+         (and (pair? x) (pair? (cdr x)) (compare ellipse (cadr x))))
+       (define (ellipse-depth x)
+         (if (ellipse? x)
+             (+ 1 (ellipse-depth (cdr x)))
+             0))
+       (define (ellipse-tail x)
+         (if (ellipse? x)
+             (ellipse-tail (cdr x))
+             (cdr x)))
+       (define (all-vars x dim)
+         (let lp ((x x) (dim dim) (vars '()))
+           (cond ((identifier? x)
+                  (if (any (lambda (lit) (compare x lit)) lits)
+                      vars
+                      (cons (cons x dim) vars)))
+                 ((ellipse? x) (lp (car x) (+ dim 1) vars))
+                 ((pair? x) (lp (car x) dim (lp (cdr x) dim vars)))
+                 ((vector? x) (lp (vector->list x) dim vars))
+                 (else vars))))
+       (define (free-vars x vars dim)
+         (let lp ((x x) (free '()))
+           (cond
+            ((identifier? x)
+             (if (and (not (memq x free))
+                      (cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim)))
+                            (else #f)))
+                 (cons x free)
+                 free))
+            ((pair? x) (lp (car x) (lp (cdr x) free)))
+            ((vector? x) (lp (vector->list x) free))
+            (else free))))
+       (define (expand-template tmpl vars)
+         (let lp ((t tmpl) (dim 0))
+           (cond
+            ((identifier? t)
+             (cond
+              ((any (lambda (v) (compare t (car v))) vars)
+               => (lambda (cell)
+                    (if (<= (cdr cell) dim)
+                        t
+                        (error "too few ...'s"))))
+              (else
+               (list _rename (list _quote t)))))
+            ((pair? t)
+             (cond
+              ((ellipse-escape? t)
+               (if (pair? (cdr t))
+                   (if (pair? (cddr t)) (cddr t) (cadr t))
+                   (cdr t)))
+              ((ellipse? t)
+               (let* ((depth (ellipse-depth t))
+                      (ell-dim (+ dim depth))
+                      (ell-vars (free-vars (car t) vars ell-dim)))
+                 (if (null? ell-vars)
+                     (error "too many ...'s")
+                     (let* ((once (lp (car t) ell-dim))
+                            (nest (if (and (null? (cdr ell-vars))
+                                           (identifier? once)
+                                           (eq? once (car vars)))
+                                      once ;; shortcut
+                                      (cons _map
+                                            (cons (list _lambda ell-vars once)
+                                                  ell-vars))))
+                            (many (do ((d depth (- d 1))
+                                       (many nest
+                                             (list _apply _append many)))
+                                      ((= d 1) many))))
+                       (if (null? (ellipse-tail t))
+                           many ;; shortcut
+                           (list _append many (lp (ellipse-tail t) dim)))))))
+              (else (list _cons (lp (car t) dim) (lp (cdr t) dim)))))
+            ((vector? t) (list _list->vector (lp (vector->list t) dim)))
+            ((null? t) (list _quote '()))
+            (else t))))
+       (list
+        _er-macro-transformer
+        (list _lambda (list _expr _rename _compare)
+              (cons
+               _or
+               (append
+                (map
+                 (lambda (clause) (expand-pattern (car clause) (cadr clause)))
+                 forms)
+                (list (list _error "no expansion for"
+                            (list (rename 'strip-syntactic-closures) _expr)))))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; modules
+
+(define *config-env* #f)
+
+(define-syntax import
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let lp ((ls (cdr expr)) (res '()))
+       (cond
+        ((null? ls)
+         (cons 'begin (reverse res)))
+        (else
+         (let ((mod+imps (eval `(resolve-import ',(car ls)) *config-env*)))
+           (if (pair? mod+imps)
+               (lp (cdr ls)
+                   (cons `(%env-copy!
+                           #f
+                           (vector-ref
+                            (eval '(load-module ',(car mod+imps)) *config-env*)
+                            1)
+                           ',(cdr mod+imps)
+                           #f)
+                         res))
+               (error "couldn't find module" (car ls))))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; SRFI-0
+
+(define-syntax cond-expand
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (define (check x)
+       (if (pair? x)
+           (case (car x)
+             ((and) (every check (cdr x)))
+             ((or) (any check (cdr x)))
+             ((not) (not (check (cadr x))))
+             (else (error "cond-expand: bad feature" x)))
+           (memq (identifier->symbol x) *features*)))
+     (let expand ((ls (cdr expr)))
+       (cond ((null? ls) (error "cond-expand: no expansions" expr))
+             ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls)))
+             ((eq? 'else (identifier->symbol (caar ls)))
+              (if (pair? (cdr ls))
+                  (error "cond-expand: else in non-final position")
+                  `(,(rename 'begin) ,@(cdar ls))))
+             ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls)))
+             (else (expand (cdr ls))))))))
+

lib/srfi/1.module

@@ -0,0 +1,31 @@
+
+(define-module (srfi 1)
+  (export
+   xcons cons* make-list list-tabulate list-copy circular-list iota
+   proper-list? circular-list? dotted-list? not-pair? null-list? list=
+   first second third fourth fifth sixth seventh eighth ninth tenth
+   car+cdr take drop take-right drop-right take! drop-right! split-at split-at!
+   last last-pair length+ concatenate append! concatenate! reverse!
+   append-reverse append-reverse!
+   zip unzip1 unzip2 unzip3 unzip4 unzip5 count
+   fold unfold pair-fold reduce fold-right unfold-right
+   pair-fold-right reduce-right
+   append-map append-map! map! pair-for-each filter-map map-in-order
+   filter partition remove filter! partition! remove! find find-tail any every
+   list-index take-while drop-while take-while! span break span! break!
+   delete delete-duplicates delete! delete-duplicates!
+   alist-cons alist-copy alist-delete alist-delete!
+   lset<= lset= lset-adjoin lset-union lset-union! lset-intersection
+   lset-intersection! lset-difference lset-difference! lset-xor lset-xor!
+   lset-diff+intersection lset-diff+intersection!)
+  (import (scheme))
+  (include "1/predicates.scm"
+           "1/selectors.scm"
+           "1/search.scm"
+           "1/misc.scm"
+           "1/constructors.scm"
+           "1/fold.scm"
+           "1/deletion.scm"
+           "1/alists.scm"
+           "1/lset.scm"))
+

lib/srfi/1/alists.scm

@@ -0,0 +1,14 @@
+;; alist.scm -- association list utilities
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (alist-cons key value ls) (cons (cons key value) ls))
+
+(define (alist-copy ls) (map (lambda (x) (cons (car x) (cdr x))) ls))
+
+(define (alist-delete key ls . o)
+  (let ((eq (if (pair? o) (car o) equal?)))
+    (remove (lambda (x) (eq (car x) key)) ls)))
+
+(define alist-delete! alist-delete)
+

lib/srfi/1/constructors.scm

@@ -0,0 +1,36 @@
+;; constructors.scm -- list construction utilities
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (xcons a b) (cons b a))
+
+(define (cons* x . args)
+  (let lp ((rev '()) (x x) (ls args))
+    (if (null? ls)
+        (append-reverse rev x)
+        (lp (cons x rev) (car ls) (cdr ls)))))
+
+(define (make-list n . o)
+  (let ((default (if (pair? o) (car o))))
+    (let lp ((n n) (res '()))
+      (if (<= n 0) res (lp (- n 1) (cons default res))))))
+
+(define (list-tabulate n proc)
+  (let lp ((n n) (res '()))
+    (if (< n 0) res (lp (- n 1) (cons (proc n) res)))))
+
+(define (list-copy ls) (reverse! (reverse ls)))
+
+(define (circular-list x . args)
+  (let ((res (cons x args)))
+    (set-cdr! (last-pair res) res)
+    res))
+
+(define (iota count . o)
+  (let ((start (if (pair? o) (car o) 0))
+        (step (if (and (pair? o) (pair? (cdr o))) (cadr o) 1)))
+    (let lp ((i count) (n (+ start (* (- count 1) step))) (res '()))
+      (if (<= i 0)
+          res
+          (lp (- i 1) (- n step) (cons n res))))))
+

lib/srfi/1/deletion.scm

@@ -0,0 +1,25 @@
+;; deletion.scm -- list deletion utilities
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (delete x ls . o)
+  (let ((eq (if (pair? o) (car o) equal?)))
+    (if (eq? eq eq?)
+        (let lp ((ls ls) (rev '())) ;; fast path for delq
+          (let ((tail (memq x ls)))
+            (if tail
+                (lp (cdr tail) (take-up-to-reverse ls tail rev))
+                (if (pair? rev) (append-reverse! rev ls) ls))))
+        (remove (lambda (y) (eq x y)) ls))))
+
+(define delete! delete)
+
+(define (delete-duplicates ls . o)
+  (let ((eq (if (pair? o) (car o) equal?)))
+    (let lp ((ls ls) (res '()))
+      (if (pair? ls)
+          (lp (cdr ls) (if (member (car ls) res) res (cons (car ls) res)))
+          (reverse! res)))))
+
+(define delete-duplicates! delete-duplicates)
+

lib/srfi/1/fold.scm

@@ -0,0 +1,115 @@
+;; fold.scm -- list fold/reduce utilities
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (fold kons knil ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls) (acc knil))
+        (if (pair? ls) (lp (cdr ls) (kons (car ls) acc)) acc))
+      (let lp ((lists (cons ls lists)) (acc knil))
+        (if (every pair? lists)
+            (lp (map cdr lists) (apply kons (map-onto car lists (list acc))))
+            acc))))
+
+(define (fold-right kons knil ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls))
+        (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil))
+      (let lp ((lists (cons ls lists)))
+        (if (every pair? lists)
+            (apply kons (map-onto car lists (lp (map cdr lists))))
+            knil))))
+
+(define (pair-fold kons knil ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls) (acc knil))
+        (if (pair? ls) (lp (cdr ls) (kons ls acc)) acc))
+      (let lp ((lists (cons ls lists)) (acc knil))
+        (if (every pair? lists)
+            (lp (map cdr lists) (apply kons (append lists (list acc))))
+            acc))))
+
+(define (pair-fold-right kons knil ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls))
+        (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil))
+      (let lp ((lists (cons ls lists)))
+        (if (every pair? lists)
+            (apply kons (append lists (lp (map cdr lists))))
+            knil))))
+
+(define (reduce f identity ls)
+  (if (null? ls) identity (fold f (car ls) (cdr ls))))
+
+(define (reduce-right f identity ls)
+  (if (null? ls) identity (fold-right f (car ls) (cdr ls))))
+
+(define (unfold p f g seed . o)
+  (let lp ((seed seed))
+    (if (p seed)
+        (if (pair? o) ((car o) seed) '())
+        (cons (f seed) (lp (g seed))))))
+
+(define (unfold-right p f g seed . o)
+  (let lp ((seed seed) (res (if (pair? o) (car o) '())))
+    (if (p seed) res (lp (g seed) (cons (f seed) res)))))
+
+(define (append-map-helper append f ls lists)
+  (if (null? lists)
+      (if (null? ls)
+          '()
+          (let ((rev-ls (reverse ls)))
+            (let lp ((ls (cdr rev-ls)) (res (car rev-ls)))
+              (if (null? ls) res (lp (cdr ls) (append (f (car ls) res))))
+              )))
+      (if (and (pair? ls) (every pair? lists))
+          (let lp ((lists (cons ls lists)))
+            (let ((vals (apply f (map car lists)))
+                  (cdrs (map cdr lists)))
+              (if (every pair? cdrs) (append vals (lp cdrs)) vals)))
+          '())))
+
+(define (append-map f ls . lists)
+  (append-map-helper append f ls lists))
+
+(define (append-map! f ls . lists)
+  (append-map-helper append! f ls lists))
+
+(define map! map)
+(define map-in-order map)
+
+(define (pair-for-each f ls . lists)
+  (apply pair-fold (lambda (x _) (f x)) ls lists))
+
+(define (filter-map f ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls) (res '()))
+        (if (pair? ls)
+            (let ((x (f (car ls)))) (lp (cdr ls) (if f (cons f res) res)))
+            (reverse! res)))
+      (filter (lambda (x) x) (apply map f ls lists))))
+
+(define (take-up-to-reverse from to init)
+  (if (eq? from to)
+      init
+      (take-up-to-reverse (cdr from) to (cons (car from) init))))
+
+(define (remove pred ls)
+  (let lp ((ls ls) (rev '()))
+    (let ((tail (find-tail pred ls)))
+      (if tail
+          (lp (cdr tail) (take-up-to-reverse ls tail rev))
+          (if (pair? rev) (append-reverse! rev ls) ls)))))
+
+(define (filter pred ls) (remove (lambda (x) (not (pred x))) ls))
+
+(define (partition pred ls)
+  (let lp ((ls ls) (good '()) (bad '()))
+    (cond ((null? ls) (values (reverse! good) (reverse! bad)))
+          ((pred (car ls)) (lp (cdr ls) (cons (car ls) good) bad))
+          (else (lp (cdr ls) good (cons (car ls) bad))))))
+
+(define filter! filter)
+(define remove! remove)
+(define partition! partition)
+

lib/srfi/1/lset.scm

@@ -0,0 +1,51 @@
+;; lset.scm -- list set library
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (lset<= eq . sets)
+  (if (null? sets)
+      #t
+      (let lp1 ((set1 (car sets)) (sets (cdr sets)))
+        (if (null? sets)
+            #t
+            (let ((set2 (car sets)))
+              (let lp2 ((ls set1))
+                (if (pair? ls)
+                    (and (member (car set1) set2 eq) (lp2 (cdr ls)))
+                    (lp1 set2 (cdr sets)))))))))
+
+(define (lset= eq . sets)
+  (and (apply lset<= eq sets) (apply lset<= eq (reverse sets))))
+
+(define (lset-adjoin eq set . elts)
+  (lset-union2 eq elts set))
+
+(define (lset-union2 eq a b)
+  (if (null? b)
+      a
+      (lset-union2 eq (if (member (car b) a eq) a (cons (car b) a)) (cdr b))))
+
+(define (lset-union eq . sets)
+  (reduce (lambda (a b) (lset-union2 eq a b)) '() sets))
+
+(define (lset-intersection eq . sets)
+  (reduce (lambda (a b) (filter (lambda (x) (member x b eq)) a)) '() sets))
+
+(define (lset-difference eq . sets)
+  (reduce (lambda (a b) (remove (lambda (x) (member x b eq)) a)) '() sets))
+
+(define (lset-xor eq . sets)
+  (reduce (lambda (a b)
+            (append (filter (lambda (x) (member x b eq)) a)
+                    (filter (lambda (x) (member x a eq)) b)))
+          '()
+          sets))
+
+(define (lset-diff+intersection eq . sets)
+  (values (apply lset-difference eq sets) (apply lset-intersection eq sets)))
+
+(define lset-diff+intersection! lset-diff+intersection)
+(define lset-xor! lset-xor)
+(define lset-difference! lset-difference)
+(define lset-intersection! lset-intersection)
+(define lset-union! lset-union)

lib/srfi/1/misc.scm

@@ -0,0 +1,54 @@
+;; misc.scm -- miscellaneous list utilities
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (map-onto proc ls init)
+  (let lp ((ls ls) (res init))
+    (if (null? ls) res (lp (cdr ls) (cons (proc (car ls)) res)))))
+
+(define (append! . lists) (concatenate! lists))
+
+(define (concatenate lists)
+  (let lp ((ls (reverse lists)) (res '()))
+    (if (null? ls) res (lp (cdr ls) (append (car ls) res)))))
+
+(define (concatenate! lists)
+  (if (null? lists)
+      '()
+      (let lp ((ls lists))
+        (cond ((not (pair? (cdr ls)))
+               lists)
+              (else
+               (set-cdr! (last-pair (car ls)) (cadr ls))
+               (lp (cdr ls)))))))
+
+(define (append-reverse rev tail)
+  (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail))))
+
+(define (append-reverse! rev tail)
+  (if (null? rev)
+      tail
+      (let ((head (reverse! rev)))
+        (set-cdr! rev tail)
+        head)))
+
+(define (zip . lists) (apply map list lists))
+
+(define (unzip1 ls) (map car ls))
+(define (unzip2 ls) (values (map car ls) (map cadr ls)))
+(define (unzip3 ls) (values (map car ls) (map cadr ls) (map caddr ls)))
+(define (unzip4 ls)
+  (values (map car ls) (map cadr ls) (map caddr ls) (map cadddr ls)))
+(define (unzip5 ls)
+  (values (map car ls) (map cadr ls) (map caddr ls)
+          (map cadddr ls) (map (lambda (x) (car (cddddr x))) ls)))
+
+(define (count pred ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls) (res 0))
+        (if (pair? ls) (lp (cdr ls) (if (pred (car ls)) (+ res 1) res)) res))
+      (let lp ((lists (cons ls lists)) (res 0))
+        (if (every pair? lists)
+            (lp (map cdr lists) (if (apply pred (map car lists)) (+ res 1) res))
+            res))))
+

lib/srfi/1/predicates.scm

@@ -0,0 +1,42 @@
+;; predicates.scm -- list prediates
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (proper-list? x)
+  (cond ((null? x) #t)
+        ((pair? x) (proper-list? (cdr x)))
+        (else #f)))
+
+(define (circular-list? x)
+  (and (pair? x) (pair? (cdr x))
+       (let race ((hare (cdr x)) (tortoise x))
+         (or (eq? hare tortoise)
+             (and (pair? hare) (pair? (cdr hare))
+                  (race (cddr hare) (cdr tortoise)))))))
+
+(define (dotted-list? x)
+  (not (proper-list? x)))
+
+(define (not-pair? x) (not (pair? x)))
+
+(define (null-list? x) (null? x)) ; no error
+
+(define (list= eq . lists)
+  (let lp1 ((lists lists))
+    (or (null? lists)
+        (null? (cdr lists))
+        (let lp2 ((ls1 (car lists)) (ls2 (cadr lists)))
+          (if (null? ls1)
+              (and (null? ls2)
+                   (lp1 (cdr lists)))
+              (and (eq (car ls1) (car ls2))
+                   (lp2 (cdr ls1) (cdr ls2))))))))
+
+(define (length+ x)
+  (if (not (pair? x))
+      0
+      (let lp ((hare (cdr x)) (tortoise x) (res 0))
+        (and (not (eq? hare tortoise))
+             (if (pair? hare)
+                 (lp (cddr hare) (cdr tortoise) (+ res 1))
+                 res)))))

lib/srfi/1/search.scm

@@ -0,0 +1,54 @@
+;; search.scm -- list searching and splitting
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (find pred ls)
+  (cond ((find-tail pred ls) => car) (else #f)))
+
+(define (find-tail pred ls)
+  (and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls)))))
+
+(define (take-while pred ls)
+  (let lp ((ls ls) (res '()))
+    (if (and (pair? ls) (pred (car ls)))
+        (lp (cdr ls) (cons (car ls) res))
+        (reverse! res))))
+
+(define take-while! take-while)
+
+(define (drop-while pred ls)
+  (or (find-tail (lambda (x) (not (pred x))) ls) '()))
+
+(define (span pred ls)
+  (let lp ((ls ls) (res '()))
+    (if (and (pair? ls) (pred (car ls)))
+        (lp (cdr ls) (cons (car ls) res))
+        (values (reverse! res) ls))))
+
+(define span! span)
+
+(define (break pred ls) (span (lambda (x) (not (pred x))) ls))
+
+(define break! break)
+
+(define (any pred ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls)) (and (pair? ls) (if (pred (car ls)) (car ls) (lp (cdr ls)))))
+      (let lp ((lists (cons ls lists)))
+        (and (every pair? lists)
+             (let ((args (map car lists)))
+               (if (apply pred args) args (lp (map cdr lists))))))))
+
+(define (every pred ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls)) (if (pair? ls) (and (pred (car ls)) (lp (cdr ls))) #t))
+      (not (apply any (lambda (x) (not (pred x))) ls lists))))
+
+(define (list-index pred ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls) (n 0))
+        (and (pair? ls) (if (pred (car ls)) n (lp (cdr ls) (+ n 1)))))
+      (let lp ((lists (cons ls lists)) (n 0))
+        (and (every pair? lists)
+             (if (apply pred (map car lists)) n (lp (map cdr lists) (+ n 1)))
+             ))))

lib/srfi/1/selectors.scm

@@ -0,0 +1,59 @@
+;; selectors.scm -- extended list selectors
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define first car)
+(define second cadr)
+(define third caddr)
+(define fourth cadddr)
+(define (fifth ls)   (car (cdr (cdr (cdr (cdr ls))))))
+(define (sixth ls)   (car (cdr (cdr (cdr (cdr (cdr ls)))))))
+(define (seventh ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))
+(define (eighth ls)  (car (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))
+(define (ninth ls)   (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))))
+(define (tenth ls)   (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))))
+
+(define (car+cdr x) (values (car x) (cdr x)))
+
+(define (take ls i)
+  (let lp ((i i) (ls ls) (res '()))
+    (if (<= i 0)
+        (reverse! res)
+        (lp (- i 1) (cdr ls) (cons (car ls) res)))))
+
+(define (take! ls i)
+  (if (<= i 0)
+      '()
+      (let ((tail (list-tail ls (- i 1))))
+        (set-cdr! tail '())
+        ls)))
+
+(define (drop ls i)
+  (if (<= i 0) ls (drop (cdr ls) (- i 1))))
+
+(define (take-right ls i)
+  (drop ls (- (length+ ls) i)))
+
+(define (drop-right ls i)
+  (take ls (- (length+ ls) i)))
+
+(define (drop-right! ls i)
+  (take! ls (- (length+ ls) i)))
+
+(define (split-at ls i)
+  (let lp ((i i) (ls ls) (res '()))
+    (if (<= i 0)
+        (values (reverse! res) ls)
+        (lp (- i 1) (cdr ls) (cons (car ls) res)))))
+
+(define (split-at! ls i)
+  (if (<= i 0)
+      (values '() ls)
+      (let* ((tail (list-tail ls (- i 1)))
+             (right (cdr tail)))
+        (set-cdr! tail '())
+        (values ls right))))
+
+(define (last ls) (if (null? (cdr ls)) (car ls) (last (cdr ls))))
+(define (last-pair ls) (if (null? (cdr ls)) ls (last-pair (cdr ls))))
+

lib/srfi/11.module

@@ -0,0 +1,28 @@
+
+(define-module (srfi 11)
+  (export let-values let*-values)
+  (import-immutable (scheme))
+  (body
+   (define-syntax let*-values
+     (syntax-rules ()
+       ((let*-values () . body)
+        (begin . body))
+       ((let*-values (((a) expr) . rest) . body)
+        (let ((a expr)) (let*-values rest . body)))
+       ((let*-values ((params expr) . rest) . body)
+        (call-with-values (lambda () expr)
+          (lambda params (let*-values rest . body))))))
+   (define-syntax let-values
+     (syntax-rules ()
+       ((let-values ("step") (binds ...) bind expr maps () () . body)
+        (let*-values (binds ... (bind expr)) (let maps . body)))
+       ((let-values ("step") (binds ...) bind old-expr maps () ((params expr) . rest) . body)
+        (let-values ("step") (binds ... (bind old-expr)) () expr maps params rest . body))
+       ((let-values ("step") binds (bind ...) expr (maps ...) (x . y) rest . body)
+        (let-values ("step") binds (bind ... tmp) expr (maps ... (x tmp)) y rest . body))
+       ((let-values ("step") binds (bind ...) expr (maps ...) x rest . body)
+        (let-values ("step") binds (bind ... . tmp) expr (maps ... (x tmp)) () rest . body))
+       ((let-values ((params expr) . rest) . body)
+        (let-values ("step") () () expr () params rest . body))
+       ))))
+

lib/srfi/16.module

@@ -0,0 +1,24 @@
+
+(define-module (srfi 16)
+  (export case-lambda)
+  (import-immutable (scheme))
+  (body
+   (define-syntax %case
+     (syntax-rules ()
+       ((%case args len n p ((params ...) . body) . rest)
+        (if (= len (length '(params ...)))
+            (apply (lambda (params ...) . body) args)
+            (%case args len 0 () . rest)))
+       ((%case args len n (p ...) ((x . y) . body) . rest)
+        (%case args len (+ n 1) (p ... x) (y . body) . rest))
+       ((%case args len n (p ...) (y . body) . rest)
+        (if (>= len n)
+            (apply (lambda (p ... y) . body) args)
+            (%case args len 0 () . rest)))
+       ((%case args len n p)
+        (error "case-lambda: no cases matched"))))
+   (define-syntax case-lambda
+     (syntax-rules ()
+       ((case-lambda . clauses)
+        (lambda args (let ((len (length args))) (%case args len 0 () . clauses))))))))
+

lib/srfi/18.module

@@ -0,0 +1,24 @@
+
+(define-module (srfi 18)
+  (export
+   current-thread thread? make-thread thread-name
+   thread-specific thread-specific-set! thread-start!
+   thread-yield! thread-sleep! thread-terminate!
+   thread-join! mutex? make-mutex mutex-name
+   mutex-specific mutex-specific-set! mutex-state
+   mutex-lock! mutex-unlock! condition-variable?
+   make-condition-variable condition-variable-name
+   condition-variable-specific condition-variable-specific-set!
+   condition-variable-signal! condition-variable-broadcast!
+   current-time time? time->seconds seconds->time
+   current-exception-handler with-exception-handler raise
+   join-timeout-exception? abandoned-mutex-exception?
+   terminated-thread-exception? uncaught-exception?
+   uncaught-exception-reason)
+  (import-immutable (scheme)
+                    (srfi 9)
+                    (chibi ast)
+                    (chibi time))
+  (include-shared "18/threads")
+  (include "18/types.scm" "18/interface.scm"))
+

lib/srfi/18/interface.scm

@@ -0,0 +1,63 @@
+
+(define (thread-join! thread . o)
+  (let ((timeout (if (pair? o) (car o) #f)))
+    (cond
+     ((%thread-join! thread timeout))
+     (else
+      (thread-yield!)
+      (if (thread-timeout?)
+          (if (and (pair? o) (pair? (cdr o)))
+              (cadr o)
+              (error "timed out waiting for thread" thread))
+	  #t)))))
+
+(define (thread-terminate! thread)
+  (if (%thread-terminate! thread) ;; need to yield if terminating ourself
+      (thread-yield!)))
+
+(define (thread-sleep! timeout)
+  (%thread-sleep! timeout)
+  (thread-yield!))
+
+(define (mutex-lock! mutex . o)
+  (let ((timeout (and (pair? o) (car o)))
+        (thread (if (and (pair? o) (pair? (cdr o))) (cadr o) #t)))
+    (cond ((%mutex-lock! mutex timeout thread))
+	  (else
+	   (thread-yield!)
+	   (not (thread-timeout?))))))
+
+(define (mutex-unlock! mutex . o)
+  (let ((condvar (and (pair? o) (car o)))
+        (timeout (if (and (pair? o) (pair? (cdr o))) (cadr o) #f)))
+    (cond ((%mutex-unlock! mutex condvar timeout))
+	  (else
+	   (thread-yield!)
+	   (not (thread-timeout?))))))
+
+(define current-time get-time-of-day)
+(define time? timeval?)
+
+(define (join-timeout-exception? x)
+  (and (exception? x)
+       (equal? (exception-message x) "timed out waiting for thread")))
+
+;; XXXX flush out exception types
+(define (abandoned-mutex-exception? x) #f)
+(define (terminated-thread-exception? x) #f)
+(define (uncaught-exception? x) #f)
+(define (uncaught-exception-reason x) #f)
+
+;; signal runner
+
+(define (signal-runner)
+  (let lp ()
+    (let ((n (pop-signal!)))
+      (cond
+       ((integer? n)
+        (let ((handler (get-signal-handler n)))
+          (if (procedure? handler)
+              (handler n))))
+       (else
+        (thread-sleep! #t))))
+    (lp)))

lib/srfi/18/threads.c

@@ -0,0 +1,421 @@
+/*  threads.c -- SRFI-18 thread primitives                    */
+/*  Copyright (c) 2010 Alex Shinn.  All rights reserved.      */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+#include <time.h>
+#include <sys/time.h>
+#include <unistd.h>
+
+#define sexp_mutex_name(x)       sexp_slot_ref(x, 0)
+#define sexp_mutex_specific(x)   sexp_slot_ref(x, 1)
+#define sexp_mutex_thread(x)     sexp_slot_ref(x, 2)
+#define sexp_mutex_lockp(x)       sexp_slot_ref(x, 3)
+
+#define sexp_condvar_name(x)     sexp_slot_ref(x, 0)
+#define sexp_condvar_specific(x) sexp_slot_ref(x, 1)
+#define sexp_condvar_threads(x)  sexp_slot_ref(x, 2)
+
+#define timeval_le(a, b) (((a).tv_sec < (b).tv_sec) || (((a).tv_sec == (b).tv_sec) && ((a).tv_usec < (b).tv_usec)))
+#define sexp_context_before(c, t) (((sexp_context_timeval(c).tv_sec != 0) || (sexp_context_timeval(c).tv_usec != 0)) && timeval_le(sexp_context_timeval(c), t))
+
+/* static int mutex_id, condvar_id; */
+
+/**************************** threads *************************************/
+
+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);
+}
+
+sexp sexp_thread_timeoutp (sexp ctx sexp_api_params(self, n)) {
+  return sexp_make_boolean(sexp_context_timeoutp(ctx));
+}
+
+sexp sexp_thread_name (sexp ctx sexp_api_params(self, n), sexp thread) {
+  sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
+  return sexp_context_name(thread);
+}
+
+sexp sexp_thread_specific (sexp ctx sexp_api_params(self, n), sexp thread) {
+  sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
+  return sexp_context_specific(thread);
+}
+
+sexp sexp_thread_specific_set (sexp ctx sexp_api_params(self, n), sexp thread, sexp val) {
+  sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
+  sexp_context_specific(thread) = val;
+  return SEXP_VOID;
+}
+
+sexp sexp_current_thread (sexp ctx sexp_api_params(self, n)) {
+  return ctx;
+}
+
+sexp sexp_make_thread (sexp ctx sexp_api_params(self, n), sexp thunk, sexp name) {
+  sexp res, *stack;
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, thunk);
+  res = sexp_make_eval_context(ctx, SEXP_FALSE, sexp_context_env(ctx), 0);
+  sexp_context_proc(res) = thunk;
+  sexp_context_ip(res) = sexp_bytecode_data(sexp_procedure_code(thunk));
+  stack = sexp_stack_data(sexp_context_stack(res));
+  stack[0] = stack[1] = stack[3] = SEXP_ZERO;
+  stack[2] = sexp_global(ctx, SEXP_G_FINAL_RESUMER);
+  sexp_context_top(res) = 4;
+  sexp_context_last_fp(res) = 0;
+  return res;
+}
+
+sexp sexp_thread_start (sexp ctx sexp_api_params(self, n), sexp thread) {
+  sexp cell;
+  sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
+  cell = sexp_cons(ctx, thread, SEXP_NULL);
+  if (sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) {
+    sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = cell;
+    sexp_global(ctx, SEXP_G_THREADS_BACK) = cell;
+  } else {			/* init queue */
+    sexp_global(ctx, SEXP_G_THREADS_BACK) = sexp_global(ctx, SEXP_G_THREADS_FRONT) = cell;
+  }
+  return SEXP_VOID;
+}
+
+sexp sexp_thread_terminate (sexp ctx sexp_api_params(self, n), sexp thread) {
+  sexp res = sexp_make_boolean(ctx == thread);
+  for ( ; thread && sexp_contextp(thread); thread=sexp_context_child(thread))
+    sexp_context_refuel(thread) = 0;
+  /* return true if terminating self */
+  return res;
+}
+
+static void sexp_insert_timed (sexp ctx, sexp thread, sexp timeout) {
+#if SEXP_USE_FLONUMS
+  double d;
+#endif
+  sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED);
+  if (sexp_integerp(timeout) || sexp_flonump(timeout))
+    gettimeofday(&sexp_context_timeval(ctx), NULL);
+  if (sexp_integerp(timeout)) {
+    sexp_context_timeval(ctx).tv_sec += sexp_unbox_fixnum(timeout);
+#if SEXP_USE_FLONUMS
+  } else if (sexp_flonump(timeout)) {
+    d = sexp_flonum_value(timeout);
+    sexp_context_timeval(ctx).tv_sec += trunc(d);
+    sexp_context_timeval(ctx).tv_usec += (d-trunc(d))*1000000;
+#endif
+  } else {
+    sexp_context_timeval(ctx).tv_sec = 0;
+    sexp_context_timeval(ctx).tv_usec = 0;
+  }
+  if (sexp_numberp(timeout))
+    while (sexp_pairp(ls2)
+           && sexp_context_before(sexp_car(ls2), sexp_context_timeval(ctx)))
+      ls1=ls2, ls2=sexp_cdr(ls2);
+  else
+    while (sexp_pairp(ls2) && sexp_context_timeval(sexp_car(ls2)).tv_sec)
+      ls1=ls2, ls2=sexp_cdr(ls2);
+  if (ls1 == SEXP_NULL)
+    sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cons(ctx, thread, ls2);
+  else
+    sexp_cdr(ls1) = sexp_cons(ctx, thread, ls2);
+}
+
+sexp sexp_thread_join (sexp ctx sexp_api_params(self, n), sexp thread, sexp timeout) {
+  sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
+  if (sexp_context_refuel(thread) <= 0) /* return true if already terminated */ {
+    return SEXP_TRUE;
+  }
+  sexp_context_timeoutp(ctx) = 0;
+  sexp_context_waitp(ctx) = 1;
+  sexp_context_event(ctx) = thread;
+  sexp_insert_timed(ctx, ctx, timeout);
+  return SEXP_FALSE;
+}
+
+sexp sexp_thread_sleep (sexp ctx sexp_api_params(self, n), sexp timeout) {
+  sexp_context_waitp(ctx) = 1;
+  if (timeout != SEXP_TRUE) {
+    sexp_assert_type(ctx, sexp_numberp, SEXP_NUMBER, timeout);
+    sexp_insert_timed(ctx, ctx, timeout);
+  }
+  return SEXP_FALSE;
+}
+
+/**************************** mutexes *************************************/
+
+sexp sexp_mutex_state (sexp ctx sexp_api_params(self, n), sexp mutex) {
+  /* sexp_assert_type(ctx, sexp_mutexp, mutex_id, timeout); */
+  if (sexp_truep(sexp_mutex_lockp(mutex))) {
+    if (sexp_contextp(sexp_mutex_thread(mutex)))
+      return sexp_mutex_thread(mutex);
+    else
+      return sexp_intern(ctx, "not-owned", -1);
+  } else {
+    return sexp_intern(ctx, (sexp_mutex_thread(mutex) ? "not-abandoned" : "abandoned"), -1);
+  }
+}
+
+sexp sexp_mutex_lock (sexp ctx sexp_api_params(self, n), sexp mutex, sexp timeout, sexp thread) {
+  if (thread == SEXP_TRUE)
+    thread = ctx;
+  if (sexp_not(sexp_mutex_lockp(mutex))) {
+    sexp_mutex_lockp(mutex) = SEXP_TRUE;
+    sexp_mutex_thread(mutex) = thread;
+    return SEXP_TRUE;
+  } else {
+    sexp_context_waitp(ctx) = 1;
+    sexp_context_event(ctx) = mutex;
+    sexp_insert_timed(ctx, ctx, timeout);
+    return SEXP_FALSE;
+  }
+}
+
+sexp sexp_mutex_unlock (sexp ctx sexp_api_params(self, n), sexp mutex, sexp condvar, sexp timeout) {
+  sexp ls1, ls2;
+  if (sexp_not(condvar)) {
+    /* normal unlock - always succeeds, just need to unblock threads */
+    if (sexp_truep(sexp_mutex_lockp(mutex))) {
+      sexp_mutex_lockp(mutex) = SEXP_FALSE;
+      sexp_mutex_thread(mutex) = ctx;
+      /* search for threads blocked on this mutex */
+      for (ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED);
+           sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2))
+        if (sexp_context_event(sexp_car(ls2)) == mutex) {
+          if (ls1==SEXP_NULL)
+            sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2);
+          else
+            sexp_cdr(ls1) = sexp_cdr(ls2);
+          sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT);
+          sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2;
+          if (! sexp_pairp(sexp_cdr(ls2)))
+            sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2;
+          sexp_context_waitp(sexp_car(ls2))
+            = sexp_context_timeoutp(sexp_car(ls2)) = 0;
+          break;
+        }
+    }
+    return SEXP_TRUE;
+  } else {
+    /* wait on condition var */
+    sexp_context_waitp(ctx) = 1;
+    sexp_context_event(ctx) = condvar;
+    sexp_insert_timed(ctx, ctx, timeout);
+    return SEXP_FALSE;
+  }
+}
+
+/**************************** condition variables *************************/
+
+sexp sexp_condition_variable_signal (sexp ctx sexp_api_params(self, n), sexp condvar) {
+  sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED);
+  for ( ; sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2))
+    if (sexp_context_event(sexp_car(ls2)) == condvar) {
+      if (ls1==SEXP_NULL)
+	sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2);
+      else
+	sexp_cdr(ls1) = sexp_cdr(ls2);
+      sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT);
+      sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2;
+      if (! sexp_pairp(sexp_cdr(ls2)))
+	sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2;
+      sexp_context_waitp(sexp_car(ls2)) = sexp_context_timeoutp(sexp_car(ls2)) = 0;
+      return SEXP_TRUE;
+    }
+  return SEXP_FALSE;
+}
+
+sexp sexp_condition_variable_broadcast (sexp ctx sexp_api_params(self, n), sexp condvar) {
+  sexp res = SEXP_FALSE;
+  while (sexp_truep(sexp_condition_variable_signal(ctx, self, n, condvar)))
+    res = SEXP_TRUE;
+  return res;
+}
+
+/**************************** the scheduler *******************************/
+
+void sexp_wait_on_single_thread (sexp ctx) {
+  struct timeval tval;
+  useconds_t usecs = 0;
+  gettimeofday(&tval, NULL);
+  if (tval.tv_sec < sexp_context_timeval(ctx).tv_sec)
+    usecs = (sexp_context_timeval(ctx).tv_sec - tval.tv_sec) * 1000000;
+  if (tval.tv_usec < sexp_context_timeval(ctx).tv_usec)
+    usecs += sexp_context_timeval(ctx).tv_usec - tval.tv_usec;
+  usleep(usecs);
+}
+
+static const sexp_uint_t sexp_log2_lookup[32] = {
+  0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, 
+  31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9
+};
+
+/* only works on powers of two */
+static sexp_uint_t sexp_log2_of_pow2 (sexp_uint_t n) {
+  return sexp_log2_lookup[(n * 0x077CB531U) >> 27];
+}
+
+static sexp sexp_pop_signal (sexp ctx sexp_api_params(self, n)) {
+  int allsigs, restsigs, signum;
+  if (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) == SEXP_ZERO) {
+    return SEXP_FALSE;
+  } else {
+    allsigs = sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_THREADS_SIGNALS));
+    restsigs = allsigs & (allsigs-1);
+    sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = sexp_make_fixnum(restsigs);
+    signum = sexp_log2_of_pow2(allsigs-restsigs);
+    return sexp_make_fixnum(signum);
+  }
+}
+
+static sexp sexp_get_signal_handler (sexp ctx sexp_api_params(self, n), sexp signum) {
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, signum);
+  return sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum);
+}
+
+sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) {
+  struct timeval tval;
+  sexp res, ls1, ls2, runner, paused, front;
+  sexp_gc_var1(tmp);
+  sexp_gc_preserve1(ctx, tmp);
+
+  front  = sexp_global(ctx, SEXP_G_THREADS_FRONT);
+  paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED);
+
+  /* check for signals */
+  if (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) != SEXP_ZERO) {
+    runner = sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER);
+    if (! sexp_contextp(runner)) { /* ensure the runner exists */
+      if (sexp_envp(runner)) {
+        tmp = sexp_env_cell(runner, (tmp=sexp_intern(ctx, "signal-runner", -1)));
+        if (sexp_pairp(tmp) && sexp_procedurep(sexp_cdr(tmp))) {
+          runner = sexp_make_thread(ctx, self, 2, sexp_cdr(tmp), SEXP_FALSE);
+          sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = runner;
+          sexp_thread_start(ctx, self, 1, runner);
+        }
+      }
+    } else if (sexp_context_waitp(runner)) { /* wake it if it's sleeping */
+      sexp_context_waitp(runner) = 0;
+      sexp_thread_start(ctx, self, 1, runner);
+    }
+  }
+
+  /* if we've terminated, check threads joining us */
+  if (sexp_context_refuel(ctx) <= 0) {
+    for (ls1=SEXP_NULL, ls2=paused; sexp_pairp(ls2); ) {
+      if (sexp_context_event(sexp_car(ls2)) == ctx) {
+        sexp_context_waitp(sexp_car(ls2)) = 0;
+        sexp_context_timeoutp(sexp_car(ls2)) = 0;
+        if (ls1==SEXP_NULL)
+          sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = sexp_cdr(ls2);
+        else
+          sexp_cdr(ls1) = sexp_cdr(ls2);
+        tmp = sexp_cdr(ls2);
+        sexp_cdr(ls2) = SEXP_NULL;
+	if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) {
+	  sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = ls2;
+	} else {
+	  sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = ls2;
+	}
+	sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2;
+        ls2 = tmp;
+      } else {
+        ls1 = ls2;
+        ls2 = sexp_cdr(ls2);
+      }
+    }
+  }
+
+  /* check timeouts */
+  if (sexp_pairp(paused)) {
+    if (gettimeofday(&tval, NULL) == 0) {
+      ls1 = SEXP_NULL;
+      ls2 = paused;
+      while (sexp_pairp(ls2) && sexp_context_before(sexp_car(ls2), tval)) {
+        sexp_context_timeoutp(sexp_car(ls2)) = 1;
+        sexp_context_waitp(ctx) = 0;
+        ls1 = ls2;
+        ls2 = sexp_cdr(ls2);
+      }
+      if (sexp_pairp(ls1)) {
+        sexp_cdr(ls1) = SEXP_NULL;
+	if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) {
+	  sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = paused;
+	} else {
+	  sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = paused;
+	}
+	sexp_global(ctx, SEXP_G_THREADS_BACK) = ls1;
+        sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = ls2;
+      }
+    }
+  }
+
+  /* dequeue next thread */
+  if (sexp_pairp(front)) {
+    res = sexp_car(front);
+    if ((sexp_context_refuel(ctx) <= 0) || sexp_context_waitp(ctx)) {
+      /* either terminated or paused */
+      sexp_global(ctx, SEXP_G_THREADS_FRONT) = sexp_cdr(front);
+      if (! sexp_pairp(sexp_cdr(front)))
+        sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL;
+    } else {
+      /* swap with front of queue */
+      sexp_car(sexp_global(ctx, SEXP_G_THREADS_FRONT)) = ctx;
+      /* rotate front of queue to back */
+      sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK))
+        = sexp_global(ctx, SEXP_G_THREADS_FRONT);
+      sexp_global(ctx, SEXP_G_THREADS_FRONT)
+        = sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_FRONT));
+      sexp_global(ctx, SEXP_G_THREADS_BACK)
+        = sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK));
+      sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = SEXP_NULL;
+    }
+  } else {
+    res = ctx;
+  }
+
+  if (sexp_context_waitp(res)) {
+    /* the only thread available was waiting */
+    sexp_wait_on_single_thread(res);
+    sexp_context_timeoutp(res) = 1;
+    sexp_context_waitp(res) = 0;
+  }
+
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+/**************************************************************************/
+
+sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
+
+  sexp_define_type_predicate(ctx, env, "thread?", SEXP_CONTEXT);
+  sexp_define_foreign(ctx, env, "thread-timeout?", 0, sexp_thread_timeoutp);
+  sexp_define_foreign(ctx, env, "current-thread", 0, sexp_current_thread);
+  sexp_define_foreign_opt(ctx, env, "make-thread", 2, sexp_make_thread, SEXP_FALSE);
+  sexp_define_foreign(ctx, env, "thread-start!", 1, sexp_thread_start);
+  sexp_define_foreign(ctx, env, "%thread-terminate!", 1, sexp_thread_terminate);
+  sexp_define_foreign(ctx, env, "%thread-join!", 2, sexp_thread_join);
+  sexp_define_foreign(ctx, env, "%thread-sleep!", 1, sexp_thread_sleep);
+  sexp_define_foreign(ctx, env, "thread-name", 1, sexp_thread_name);
+  sexp_define_foreign(ctx, env, "thread-specific", 1, sexp_thread_specific);
+  sexp_define_foreign(ctx, env, "thread-specific-set!", 2, sexp_thread_specific_set);
+  sexp_define_foreign(ctx, env, "mutex-state", 1, sexp_mutex_state);
+  sexp_define_foreign(ctx, env, "%mutex-lock!", 3, sexp_mutex_lock);
+  sexp_define_foreign(ctx, env, "%mutex-unlock!", 3, sexp_mutex_unlock);
+  sexp_define_foreign(ctx, env, "condition-variable-signal!", 1, sexp_condition_variable_signal);
+  sexp_define_foreign(ctx, env, "condition-variable-broadcast!", 1, sexp_condition_variable_broadcast);
+  sexp_define_foreign(ctx, env, "pop-signal!", 0, sexp_pop_signal);
+  sexp_define_foreign(ctx, env, "get-signal-handler", 1, sexp_get_signal_handler);
+
+  sexp_global(ctx, SEXP_G_THREADS_SCHEDULER)
+    = sexp_make_foreign(ctx, "scheduler", 0, 0, (sexp_proc1)sexp_scheduler, SEXP_FALSE);
+
+  /* remember the env to lookup the runner later */
+  sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = env;
+
+  return SEXP_VOID;
+}
+

lib/srfi/18/types.scm

@@ -0,0 +1,24 @@
+;; types.scm -- thread types
+;; Copyright (c) 2010 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define-record-type mutex
+  (%make-mutex name specific thread lock)
+  mutex?
+  (name mutex-name)
+  (specific mutex-specific mutex-specific-set!)
+  (thread %mutex-thread %mutex-thread-set!)
+  (lock %mutex-lock %mutex-lock-set!))
+
+(define (make-mutex . o)
+  (%make-mutex (and (pair? o) (car o)) #f #f #f))
+
+(define-record-type condition-variable
+  (%make-condition-variable name specific threads)
+  condition-variable?
+  (name condition-variable-name)
+  (specific condition-variable-specific condition-variable-specific-set!)
+  (threads %condition-variable-threads %condition-variable-threads-set!))
+
+(define (make-condition-variable . o)
+  (%make-condition-variable (and (pair? o) (car o)) #f #f))

lib/srfi/2.module

@@ -0,0 +1,16 @@
+
+(define-module (srfi 2)
+  (export and-let*)
+  (import-immutable (scheme))
+  (body
+   (define-syntax and-let*
+     (syntax-rules ()
+       ((and-let* () . body)
+        (begin . body))
+       ((and-let* ((var expr) . rest) . body)
+        (let ((var expr))
+          (and var (and-let* rest . body))))
+       ((and-let* ((expr) . rest) . body)
+        (let ((tmp expr))
+          (and tmp (and-let* rest . body))))))))
+

lib/srfi/26.module

@@ -0,0 +1,24 @@
+
+(define-module (srfi 26)
+  (export cut cute)
+  (import-immutable (scheme))
+  (body
+   (define-syntax %cut
+     (syntax-rules (<> <...>)
+       ((%cut e? params args)
+        (lambda params args))
+       ((%cut e? (params ...) (args ...) <> . rest)
+        (%cut e? (params ... tmp) (args ... tmp) . rest))
+       ((%cut e? (params ...) (args ...) <...>)
+        (%cut e? (params ... . tmp) (apply args ... tmp)))
+       ((%cut e? (params ...) (args ...) <...> . rest)
+        (error "cut: non-terminal <...>"))
+       ((%cut #t (params ...) (args ...) x . rest)
+        (let ((tmp x)) (%cut #t (params ...) (args ... tmp) . rest)))
+       ((%cut #f (params ...) (args ...) x . rest)
+        (%cut #t (params ...) (args ... x) . rest))))
+   (define-syntax cut
+     (syntax-rules () ((cut args ...) (%cut #f () () args ...))))
+   (define-syntax cute
+     (syntax-rules () ((cute args ...) (%cut #t () () args ...))))))
+

lib/srfi/27.module

@@ -0,0 +1,11 @@
+
+(define-module (srfi 27)
+  (export random-integer random-real default-random-source
+          make-random-source random-source?
+          random-source-state-ref random-source-state-set!
+          random-source-randomize! random-source-pseudo-randomize!
+          random-source-make-integers random-source-make-reals)
+  (import-immutable (scheme))
+  (include-shared "27/rand")
+  (include "27/constructors.scm"))
+

lib/srfi/27/constructors.scm

@@ -0,0 +1,10 @@
+;; constructors.scm -- random function constructors
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (random-source-make-integers rs)
+  (lambda (n) (%random-integer rs n)))
+
+(define (random-source-make-reals rs . o)
+  (lambda () (%random-real rs)))
+

lib/srfi/27/rand.c

@@ -0,0 +1,204 @@
+/*  rand.c -- rand_r/random_r interface                       */
+/*  Copyright (c) 2009-2010 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include <time.h>
+#include <chibi/eval.h>
+
+#define SEXP_RANDOM_STATE_SIZE 128
+
+#define ZERO sexp_make_fixnum(0)
+#define ONE  sexp_make_fixnum(1)
+#define STATE_SIZE sexp_make_fixnum(SEXP_RANDOM_STATE_SIZE)
+
+#define sexp_random_source_p(x) sexp_check_tag(x, rs_type_id)
+
+#define sexp_random_init(x, seed)                                       \
+  initstate_r(seed,                                                     \
+              sexp_string_data(sexp_random_state(x)),                   \
+              SEXP_RANDOM_STATE_SIZE,                                   \
+              sexp_random_data(x))
+
+#if SEXP_BSD || defined(__CYGWIN__)
+typedef unsigned int sexp_random_t;
+#define sexp_call_random(rs, dst) ((dst) = rand_r(sexp_random_data(rs)))
+#define sexp_seed_random(n, rs) *sexp_random_data(rs) = (n)
+#else
+typedef struct random_data sexp_random_t;
+#define sexp_call_random(rs, dst) random_r(sexp_random_data(rs), &dst)
+#define sexp_seed_random(n, rs) srandom_r(n, sexp_random_data(rs))
+#endif
+
+#define sexp_random_state(x) (sexp_slot_ref((x), 0))
+#define sexp_random_data(x)  ((sexp_random_t*)(&sexp_slot_ref((x), 1)))
+
+#define sexp_sizeof_random (sexp_sizeof_header + sizeof(sexp_random_t) + sizeof(sexp))
+
+static sexp_uint_t rs_type_id;
+static sexp default_random_source;
+
+static sexp sexp_rs_random_integer (sexp ctx sexp_api_params(self, n), sexp rs, sexp bound) {
+  sexp res;
+  int32_t m;
+#if SEXP_USE_BIGNUMS
+  int32_t hi, mod, len, i, *data;
+#endif
+  if (! sexp_random_source_p(rs))
+    res = sexp_type_exception(ctx, self, rs_type_id, rs);
+  if (sexp_fixnump(bound)) {
+    sexp_call_random(rs, m);
+    res = sexp_make_fixnum(m % sexp_unbox_fixnum(bound));
+#if SEXP_USE_BIGNUMS
+  } else if (sexp_bignump(bound)) {
+    hi = sexp_bignum_hi(bound);
+    len = hi * sizeof(sexp_uint_t) / sizeof(int32_t);
+    res = sexp_make_bignum(ctx, hi);
+    data = (int32_t*) sexp_bignum_data(res);
+    for (i=0; i<len-1; i++) {
+      sexp_call_random(rs, m);
+      data[i] = m;
+    }
+    sexp_call_random(rs, m);
+    mod = sexp_bignum_data(bound)[hi-1] * sizeof(int32_t) / sizeof(sexp_uint_t);
+    if (mod)
+      data[i] = m % mod;
+#endif
+  } else {
+    res = sexp_type_exception(ctx, self, SEXP_FIXNUM, bound);
+  }
+  return res;
+}
+
+static sexp sexp_random_integer (sexp ctx sexp_api_params(self, n), sexp bound) {
+  return sexp_rs_random_integer(ctx sexp_api_pass(self, n), default_random_source, bound);
+}
+
+static sexp sexp_rs_random_real (sexp ctx sexp_api_params(self, n), sexp rs) {
+  int32_t res;
+  if (! sexp_random_source_p(rs))
+    return sexp_type_exception(ctx, self, rs_type_id, rs);
+  sexp_call_random(rs, res);
+  return sexp_make_flonum(ctx, (double)res / (double)RAND_MAX);
+}
+
+static sexp sexp_random_real (sexp ctx sexp_api_params(self, n)) {
+  return sexp_rs_random_real(ctx sexp_api_pass(self, n), default_random_source);
+}
+
+#if SEXP_BSD || defined(__CYGWIN__)
+
+static sexp sexp_make_random_source (sexp ctx sexp_api_params(self, n)) {
+  sexp res;
+  res = sexp_alloc_tagged(ctx, sexp_sizeof_random, rs_type_id);
+  *sexp_random_data(res) = 1;
+  return res;
+}
+
+static sexp sexp_random_source_state_ref (sexp ctx sexp_api_params(self, n), sexp rs) {
+  if (! sexp_random_source_p(rs))
+    return sexp_type_exception(ctx, self, rs_type_id, rs);
+  else
+    return sexp_make_integer(ctx, *sexp_random_data(rs));
+}
+
+static sexp sexp_random_source_state_set (sexp ctx sexp_api_params(self, n), sexp rs, sexp state) {
+  if (! sexp_random_source_p(rs))
+    return sexp_type_exception(ctx, self, rs_type_id, rs);
+  else if (sexp_fixnump(state))
+    *sexp_random_data(rs) = sexp_unbox_fixnum(state);
+#if SEXP_USE_BIGNUMS
+  else if (sexp_bignump(state))
+    *sexp_random_data(rs)
+      = sexp_bignum_data(state)[0]*sexp_bignum_sign(state);
+#endif
+  else
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, state);
+  return SEXP_VOID;
+}
+
+#else
+
+static sexp sexp_make_random_source (sexp ctx sexp_api_params(self, n)) {
+  sexp res;
+  sexp_gc_var1(state);
+  sexp_gc_preserve1(ctx, state);
+  state = sexp_make_string(ctx, STATE_SIZE, SEXP_UNDEF);
+  res = sexp_alloc_tagged(ctx, sexp_sizeof_random, rs_type_id);
+  sexp_random_state(res) = state;
+  sexp_random_init(res, 1);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+static sexp sexp_random_source_state_ref (sexp ctx sexp_api_params(self, n), sexp rs) {
+  if (! sexp_random_source_p(rs))
+    return sexp_type_exception(ctx, self, rs_type_id, rs);
+  else
+    return sexp_substring(ctx, sexp_random_state(rs), ZERO, STATE_SIZE);
+}
+
+static sexp sexp_random_source_state_set (sexp ctx sexp_api_params(self, n), sexp rs, sexp state) {
+  if (! sexp_random_source_p(rs))
+    return sexp_type_exception(ctx, self, rs_type_id, rs);
+  else if (! (sexp_stringp(state)
+              && (sexp_string_length(state) == SEXP_RANDOM_STATE_SIZE)))
+    return sexp_type_exception(ctx, self, SEXP_STRING, state);
+  sexp_random_state(rs) = state;
+  sexp_random_init(rs, 1);
+  return SEXP_VOID;
+}
+
+#endif
+
+static sexp sexp_random_source_randomize (sexp ctx sexp_api_params(self, n), sexp rs) {
+  if (! sexp_random_source_p(rs))
+    return sexp_type_exception(ctx, self, rs_type_id, rs);
+  sexp_seed_random(time(NULL), rs);
+  return SEXP_VOID;
+}
+
+static sexp sexp_random_source_pseudo_randomize (sexp ctx sexp_api_params(self, n), sexp rs, sexp seed) {
+  if (! sexp_random_source_p(rs))
+    return sexp_type_exception(ctx, self, rs_type_id, rs);
+  if (! sexp_fixnump(seed))
+    return sexp_type_exception(ctx, self, rs_type_id, seed);
+  sexp_seed_random(sexp_unbox_fixnum(seed), rs);
+  return SEXP_VOID;
+}
+
+sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
+  sexp_gc_var2(name, op);
+  sexp_gc_preserve2(ctx, name, op);
+
+  name = sexp_c_string(ctx, "random-source", -1);
+  rs_type_id
+    = sexp_unbox_fixnum(sexp_register_type(ctx, name,
+                                           sexp_make_fixnum(sexp_offsetof_slot0),
+                                           ONE, ONE, ZERO, ZERO,
+                                           sexp_make_fixnum(sexp_sizeof_random),
+                                           ZERO, ZERO, NULL));
+
+  name = sexp_c_string(ctx, "random-source?", -1);
+  op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(rs_type_id));
+  name = sexp_intern(ctx, "random-source?", -1);
+  sexp_env_define(ctx, env, name, op);
+
+  sexp_define_foreign(ctx, env, "make-random-source", 0, sexp_make_random_source);
+  sexp_define_foreign(ctx, env, "%random-integer", 2, sexp_rs_random_integer);
+  sexp_define_foreign(ctx, env, "random-integer", 1, sexp_random_integer);
+  sexp_define_foreign(ctx, env, "%random-real", 1, sexp_rs_random_real);
+  sexp_define_foreign(ctx, env, "random-real", 0, sexp_random_real);
+  sexp_define_foreign(ctx, env, "random-source-state-ref", 1, sexp_random_source_state_ref);
+  sexp_define_foreign(ctx, env, "random-source-state-set!", 2, sexp_random_source_state_set);
+  sexp_define_foreign(ctx, env, "random-source-randomize!", 1, sexp_random_source_randomize);
+  sexp_define_foreign(ctx, env, "random-source-pseudo-randomize!", 2, sexp_random_source_pseudo_randomize);
+
+  default_random_source = op = sexp_make_random_source(ctx sexp_api_pass(NULL, 0));
+  name = sexp_intern(ctx, "default-random-source", -1);
+  sexp_env_define(ctx, env, name, default_random_source);
+  sexp_random_source_randomize(ctx sexp_api_pass(NULL, 0), default_random_source);
+
+  sexp_gc_release2(ctx);
+  return SEXP_VOID;
+}
+

lib/srfi/33.module

@@ -0,0 +1,17 @@
+
+(define-module (srfi 33)
+  (export bitwise-not
+          bitwise-and   bitwise-ior 
+          bitwise-xor   bitwise-eqv
+          bitwise-nand  bitwise-nor 
+          bitwise-andc1 bitwise-andc2
+          bitwise-orc1  bitwise-orc2 
+          arithmetic-shift bit-count integer-length
+          bitwise-merge 
+          bit-set? any-bits-set? all-bits-set?
+          first-set-bit
+          extract-bit-field test-bit-field? clear-bit-field 
+          replace-bit-field  copy-bit-field)
+  (import-immutable (scheme))
+  (include-shared "33/bit")
+  (include "33/bitwise.scm"))

lib/srfi/33/bit.c

@@ -0,0 +1,303 @@
+/*  bit.c -- bitwise operators                                */
+/*  Copyright (c) 2009-2010 Alex Shinn.  All rights reserved. */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+#include <limits.h>
+
+#if SEXP_USE_BIGNUMS
+#include <chibi/bignum.h>
+#else
+#define sexp_bignum_normalize(x) x
+#endif
+
+static sexp sexp_bit_and (sexp ctx sexp_api_params(self, n), sexp x, sexp y) {
+  sexp res;
+#if SEXP_USE_BIGNUMS
+  sexp_sint_t len, i;
+#endif
+  if (sexp_fixnump(x)) {
+    if (sexp_fixnump(y))
+      res = (sexp) ((sexp_uint_t)x & (sexp_uint_t)y);
+#if SEXP_USE_BIGNUMS
+    else if (sexp_bignump(y))
+      res = sexp_bit_and(ctx sexp_api_pass(self, n), y, x);
+#endif
+    else
+      res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y);
+#if SEXP_USE_BIGNUMS
+  } else if (sexp_bignump(x)) {
+    if (sexp_fixnump(y)) {
+      res = sexp_make_fixnum(sexp_unbox_fixnum(y) & sexp_bignum_data(x)[0]);
+    } else if (sexp_bignump(y)) {
+      if (sexp_bignum_length(x) < sexp_bignum_length(y))
+        res = sexp_copy_bignum(ctx, NULL, x, 0);
+      else
+        res = sexp_copy_bignum(ctx, NULL, y, 0);
+      for (i=0, len=sexp_bignum_length(res); i<len; i++)
+        sexp_bignum_data(res)[i]
+          = sexp_bignum_data(x)[i] & sexp_bignum_data(y)[i];
+    } else {
+      res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y);
+    }
+#endif
+  } else {
+    res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
+  }
+  return sexp_bignum_normalize(res);
+}
+
+static sexp sexp_bit_ior (sexp ctx sexp_api_params(self, n), sexp x, sexp y) {
+  sexp res;
+#if SEXP_USE_BIGNUMS
+  sexp_sint_t len, i;
+#endif
+  if (sexp_fixnump(x)) {
+    if (sexp_fixnump(y))
+      res = (sexp) ((sexp_uint_t)x | (sexp_uint_t)y);
+#if SEXP_USE_BIGNUMS
+    else if (sexp_bignump(y))
+      res = sexp_bit_ior(ctx sexp_api_pass(self, n), y, x);
+#endif
+    else
+      res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y);
+#if SEXP_USE_BIGNUMS
+  } else if (sexp_bignump(x)) {
+    if (sexp_fixnump(y)) {
+      res = sexp_copy_bignum(ctx, NULL, x, 0);
+      sexp_bignum_data(x)[0] |= sexp_unbox_fixnum(y);
+    } else if (sexp_bignump(y)) {
+      if (sexp_bignum_length(x) >= sexp_bignum_length(y)) {
+        res = sexp_copy_bignum(ctx, NULL, x, 0);
+        len = sexp_bignum_length(y);
+      } else {
+        res = sexp_copy_bignum(ctx, NULL, y, 0);
+        len = sexp_bignum_length(x);
+      }
+      for (i=0; i<len; i++)
+        sexp_bignum_data(res)[i]
+          = sexp_bignum_data(x)[i] | sexp_bignum_data(y)[i];
+    } else {
+      res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y);
+    }
+#endif
+  } else {
+    res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
+  }
+  return sexp_bignum_normalize(res);
+}
+
+static sexp sexp_bit_xor (sexp ctx sexp_api_params(self, n), sexp x, sexp y) {
+  sexp res;
+#if SEXP_USE_BIGNUMS
+  sexp_sint_t len, i;
+#endif
+  if (sexp_fixnump(x)) {
+    if (sexp_fixnump(y))
+      res = sexp_make_fixnum(sexp_unbox_fixnum(x) ^ sexp_unbox_fixnum(y));
+#if SEXP_USE_BIGNUMS
+    else if (sexp_bignump(y))
+      res = sexp_bit_xor(ctx sexp_api_pass(self, n), y, x);
+#endif
+    else
+      res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y);
+#if SEXP_USE_BIGNUMS
+  } else if (sexp_bignump(x)) {
+    if (sexp_fixnump(y)) {
+      res = sexp_copy_bignum(ctx, NULL, x, 0);
+      sexp_bignum_data(x)[0] ^= sexp_unbox_fixnum(y);
+    } else if (sexp_bignump(y)) {
+      if (sexp_bignum_length(x) >= sexp_bignum_length(y)) {
+        res = sexp_copy_bignum(ctx, NULL, x, 0);
+        len = sexp_bignum_length(y);
+      } else {
+        res = sexp_copy_bignum(ctx, NULL, y, 0);
+        len = sexp_bignum_length(x);
+      }
+      for (i=0; i<len; i++)
+        sexp_bignum_data(res)[i]
+          = sexp_bignum_data(x)[i] ^ sexp_bignum_data(y)[i];
+    } else {
+      res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y);
+    }
+#endif
+  } else {
+    res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
+  }
+  return sexp_bignum_normalize(res);
+}
+
+/* should probably split into left and right shifts, that's a better */
+/* interface anyway */
+static sexp sexp_arithmetic_shift (sexp ctx sexp_api_params(self, n), sexp i, sexp count) {
+  sexp_uint_t tmp;
+  sexp_sint_t c;
+#if SEXP_USE_BIGNUMS
+  sexp_sint_t len, offset, bit_shift, j;
+  sexp_gc_var1(res);
+#else
+  sexp res;
+#endif
+  if (! sexp_fixnump(count))
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, count);
+  c = sexp_unbox_fixnum(count);
+  if (c == 0) return i;
+  if (sexp_fixnump(i)) {
+    if (c < 0) {
+      res = sexp_make_fixnum(sexp_unbox_fixnum(i) >> -c);
+    } else {
+      tmp = (sexp_uint_t)sexp_unbox_fixnum(i) << c;
+#if SEXP_USE_BIGNUMS
+      if (((tmp >> c) == sexp_unbox_fixnum(i))
+          && (tmp < SEXP_MAX_FIXNUM) && (tmp > SEXP_MIN_FIXNUM)) {
+#endif
+        res = sexp_make_fixnum(tmp);
+#if SEXP_USE_BIGNUMS
+      } else {
+        sexp_gc_preserve1(ctx, res);
+        res = sexp_fixnum_to_bignum(ctx, i);
+        res = sexp_arithmetic_shift(ctx sexp_api_pass(self, n), res, count);
+        sexp_gc_release1(ctx);
+      }
+#endif
+    }
+#if SEXP_USE_BIGNUMS
+  } else if (sexp_bignump(i)) {
+    len = sexp_bignum_hi(i);
+    if (c < 0) {
+      c = -c;
+      offset = c / (sizeof(sexp_uint_t)*CHAR_BIT);
+      bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT);
+      if (len < offset) {
+        res = sexp_make_fixnum(sexp_bignum_sign(i) > 0 ? 0 : -1);
+      } else {
+        res = sexp_make_bignum(ctx, len - offset + 1);
+        for (j=len-offset, tmp=0; j>=0; j--) {
+          sexp_bignum_data(res)[j]
+            = (sexp_bignum_data(i)[j+offset] >> bit_shift)+ tmp;
+          tmp = sexp_bignum_data(i)[j+offset]
+            << (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift);
+        }
+      }
+    } else {
+      offset = c / (sizeof(sexp_uint_t)*CHAR_BIT);
+      bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT);
+      res = sexp_make_bignum(ctx, len + offset + 1);
+      for (j=tmp=0; j<len; j++) {
+        sexp_bignum_data(res)[j+offset]
+          = (sexp_bignum_data(i)[j] << bit_shift) + tmp;
+        tmp = sexp_bignum_data(i)[j] >> (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift);
+      }
+      sexp_bignum_data(res)[len+offset] = tmp;
+    }
+#endif
+  } else {
+    res = sexp_type_exception(ctx, self, SEXP_FIXNUM, i);
+  }
+  return sexp_bignum_normalize(res);
+}
+
+/* bit-count and integer-length were adapted from: */
+/* http://graphics.stanford.edu/~seander/bithacks.html */
+static sexp_uint_t bit_count (sexp_uint_t i) {
+  i -= ((i >> 1) & (sexp_uint_t)~(sexp_uint_t)0/3);
+  i = ((i & (sexp_uint_t)~(sexp_uint_t)0/15*3)
+       + ((i >> 2) & (sexp_uint_t)~(sexp_uint_t)0/15*3));
+  i = (i + (i >> 4)) & (sexp_uint_t)~(sexp_uint_t)0/255*15;
+  return ((sexp_uint_t)(i * ((sexp_uint_t)~(sexp_uint_t)0/255))
+          >> (sizeof(i) - 1) * CHAR_BIT);
+}
+
+static sexp sexp_bit_count (sexp ctx sexp_api_params(self, n), sexp x) {
+  sexp res;
+  sexp_sint_t i;
+#if SEXP_USE_BIGNUMS
+  sexp_uint_t count;
+#endif
+  if (sexp_fixnump(x)) {
+    i = sexp_unbox_fixnum(x);
+    res = sexp_make_fixnum(bit_count(i<0 ? ~i : i));
+#if SEXP_USE_BIGNUMS
+  } else if (sexp_bignump(x)) {
+    for (i=count=0; i<sexp_bignum_length(x); i++)
+      count += bit_count(sexp_bignum_data(x)[i]);
+    res = sexp_make_fixnum(count);
+#endif
+  } else {
+    res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
+  }
+  return res;
+}
+
+static const char log_table_256[256] = 
+{
+#define LT(n) n, n, n, n, n, n, n, n, n, n, n, n, n, n, n, n
+  0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4,
+  LT(5), LT(6), LT(7), LT(7), LT(7), LT(7), LT(7),
+  LT(8), LT(8), LT(8), LT(8), LT(8), LT(8), LT(8), LT(8)
+};
+
+static sexp_uint_t integer_log2 (sexp_uint_t x) {
+  sexp_uint_t t, tt;
+#if SEXP_64_BIT
+  if ((tt = x >> 32))
+    return integer_log2(tt) + 32;
+  else
+#endif
+  if ((tt = x >> 16))
+    return (t = tt >> 8) ? 24 + log_table_256[t] : 16 + log_table_256[tt];
+  else 
+    return (t = x >> 8) ? 8 + log_table_256[t] : log_table_256[x];
+}
+
+static sexp sexp_integer_length (sexp ctx sexp_api_params(self, n), sexp x) {
+  sexp_sint_t tmp;
+#if SEXP_USE_BIGNUMS
+  sexp_sint_t hi;
+#endif
+  if (sexp_fixnump(x)) {
+    tmp = sexp_unbox_fixnum(x);
+    return sexp_make_fixnum(integer_log2(tmp < 0 ? -tmp-1 : tmp));
+#if SEXP_USE_BIGNUMS
+  } else if (sexp_bignump(x)) {
+    hi = sexp_bignum_hi(x);
+    return sexp_make_fixnum(integer_log2(sexp_bignum_data(x)[hi])
+                            + hi*sizeof(sexp_uint_t));
+#endif
+  } else {
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
+  }
+}
+
+static sexp sexp_bit_set_p (sexp ctx sexp_api_params(self, n), sexp i, sexp x) {
+#if SEXP_USE_BIGNUMS
+  sexp_uint_t pos;
+#endif
+  if (! sexp_fixnump(i))
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, i);
+  if (sexp_fixnump(x)) {
+    return sexp_make_boolean(sexp_unbox_fixnum(x) & (1<<sexp_unbox_fixnum(i)));
+#if SEXP_USE_BIGNUMS
+  } else if (sexp_bignump(x)) {
+    pos = sexp_unbox_fixnum(i) / (sizeof(sexp_uint_t)*CHAR_BIT);
+    return sexp_make_boolean((pos < sexp_bignum_length(x))
+                             && (sexp_bignum_data(x)[pos]
+                                 & (1<<(sexp_unbox_fixnum(i)
+                                        - pos*sizeof(sexp_uint_t)*CHAR_BIT))));
+#endif
+  } else {
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
+  }
+}
+
+sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
+  sexp_define_foreign(ctx, env, "bit-and",    2, sexp_bit_and);
+  sexp_define_foreign(ctx, env, "bit-ior",    2, sexp_bit_ior);
+  sexp_define_foreign(ctx, env, "bit-xor",    2, sexp_bit_xor);
+  sexp_define_foreign(ctx, env, "arithmetic-shift",  2, sexp_arithmetic_shift);
+  sexp_define_foreign(ctx, env, "bit-count",  1, sexp_bit_count);
+  sexp_define_foreign(ctx, env, "integer-length",  1, sexp_integer_length);
+  sexp_define_foreign(ctx, env, "bit-set?", 2, sexp_bit_set_p);
+  return SEXP_VOID;
+}
+

lib/srfi/33/bitwise.scm

@@ -0,0 +1,61 @@
+;; bitwise.scm -- high-level bitwise functions
+;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (bitwise-not i) (- (+ i 1)))
+
+(define (bitwise-complement f) (lambda args (bitwise-not (apply f args))))
+
+(define (make-nary proc2 default)
+  (lambda args
+    (if (null? args)
+        default
+        (let lp ((i (car args)) (ls (cdr args)))
+          (if (null? ls)
+              i
+              (lp (proc2 i (car ls)) (cdr ls)))))))
+
+(define bitwise-and  (make-nary bit-and  -1))
+(define bitwise-ior  (make-nary bit-ior   0))
+(define bitwise-xor  (make-nary bit-xor   0))
+
+(define bitwise-eqv  (bitwise-complement (make-nary bit-xor -1)))
+(define bitwise-nand (bitwise-complement (make-nary bit-and  0)))
+(define bitwise-nor  (bitwise-complement (make-nary bit-ior -1)))
+
+(define (bitwise-andc1 i j) (bit-and (bitwise-not i) j))
+(define (bitwise-andc2 i j) (bit-and i (bitwise-not j)))
+(define (bitwise-orc1 i j)  (bit-ior (bitwise-not i) j))
+(define (bitwise-orc2 i j)  (bit-ior i (bitwise-not j)))
+
+(define (any-bits-set? test-bits i)
+  (not (zero? (bitwise-and test-bits i))))
+(define (all-bits-set? test-bits i)
+  (= test-bits (bitwise-and test-bits i)))
+
+(define (first-set-bit i)
+  (if (zero? i)
+      -1
+      (integer-length (- i (bit-and i (- i 1))))))
+
+(define (mask len) (- (arithmetic-shift 1 len) 1))
+
+(define (bitwise-merge mask n m)
+  (bit-ior (bit-and mask n) (bit-and (bitwise-not mask) m)))
+
+(define (extract-bit-field size position n)
+  (bit-and (arithmetic-shift n (- position)) (mask size)))
+
+(define (test-bit-field? size position n)
+  (not (zero? (bit-and (arithmetic-shift n (- position)) (mask size)))))
+
+(define (replace-bit-field size position newfield n)
+  (bit-ior (bit-and n (bitwise-not (arithmetic-shift (mask size) position)))
+           (arithmetic-shift newfield position)))
+
+(define (clear-bit-field size position n)
+  (replace-bit-field size position 0 n))
+
+(define (copy-bit-field size position from to)
+  (bitwise-merge (arithmetic-shift (mask size) position) to from))
+

lib/srfi/38.module

@@ -0,0 +1,6 @@
+
+(define-module (srfi 38)
+  (import-immutable (scheme))
+  (export write-with-shared-structure write/ss
+          read-with-shared-structure read/ss)
+  (include "38.scm"))

lib/srfi/38.scm

@@ -0,0 +1,255 @@
+;;;; srfi-38.scm - reading and writing shared structures
+;;
+;; This code was written by Alex Shinn in 2009 and placed in the
+;; Public Domain.  All warranties are disclaimed.
+
+(define (extract-shared-objects x)
+  (let ((seen '()))
+    (let find ((x x))
+      (cond
+       ((assq x seen)
+        => (lambda (cell) (set-cdr! cell (+ (cdr cell) 1))))
+       ((pair? x)
+        (set! seen (cons (cons x 1) seen))
+        (find (car x))
+        (find (cdr x)))
+       ((vector? x)
+        (set! seen (cons (cons x 1) seen))
+        (do ((i 0 (+ i 1)))
+            ((= i (vector-length x)))
+          (find (vector-ref x i))))))
+    (let extract ((ls seen) (res '()))
+      (cond
+       ((null? ls) res)
+       ((> (cdar ls) 1) (extract (cdr ls) (cons (cons (caar ls) #f) res)))
+       (else (extract (cdr ls) res))))))
+
+(define (write-with-shared-structure x . o)
+  (let ((out (if (pair? o) (car o) (current-output-port)))
+        (shared (extract-shared-objects x))
+        (count 0))
+    (define (check-shared x prefix cont)
+      (let ((cell (assq x shared)))
+        (cond ((and cell (cdr cell))
+               (display prefix out)
+               (display "#" out)
+               (write (cdr cell))
+               (display "#" out))
+              (else
+               (cond (cell
+                      (display prefix out)
+                      (display "#=" out)
+                      (write count out)
+                      (set-cdr! cell count)
+                      (set! count (+ count 1))))
+               (cont x)))))
+    (cond
+     ((null? shared)
+      (write x out))
+     (else
+      (let wr ((x x))
+        (check-shared
+         x
+         ""
+         (lambda (x)
+           (cond
+            ((pair? x)
+             (display "(" out)
+             (wr (car x))
+             (let lp ((ls (cdr x)))
+               (check-shared
+                ls
+                " . "
+                (lambda (ls)
+                  (cond ((null? ls))
+                        ((pair? ls)
+                         (display " " out)
+                         (wr (car ls))
+                         (lp (cdr ls)))
+                        (else
+                         (display " . " out)
+                         (wr ls))))))
+             (display ")" out))
+            ((vector? x)
+             (display "#(" out)
+             (let ((len (vector-length x)))
+               (cond ((> len 0)
+                      (wr (vector-ref x 0))
+                      (do ((i 1 (+ i 1)))
+                          ((= i len))
+                        (display " " out)
+                        (wr (vector-ref x i))))))
+             (display ")" out))
+            (else
+             (write x out))))))))))
+
+(define write/ss write-with-shared-structure)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (skip-line in)
+  (let ((c (read-char in)))
+    (if (not (or (eof-object? c) (eqv? c #\newline)))
+        (skip-line in))))
+
+(define (skip-whitespace in)
+  (case (peek-char in)
+    ((#\space #\tab #\newline #\return)
+     (read-char in)
+     (skip-whitespace in))
+    ((#\;)
+     (skip-line in)
+     (skip-whitespace in))))
+
+(define (skip-comment in depth)
+  (case (read-char in)
+    ((#\#) (skip-comment in (if (eqv? #\| (peek-char in)) (+ depth 1) depth)))
+    ((#\|) (if (eqv? #\# (peek-char in))
+               (if (zero? depth) (read-char in) (skip-comment in (- depth 1)))
+               (skip-comment in depth)))
+    (else (if (eof-object? (peek-char in))
+              (error "unterminated #| comment")
+              (skip-comment in depth)))))
+
+(define delimiters
+  '(#\( #\) #\[ #\] #\space #\tab #\newline #\return))
+
+(define read-with-shared-structure
+  (let ((read read))
+    (lambda o
+      (let ((in (if (pair? o) (car o) (current-input-port)))
+            (shared '()))
+        (define (read-label res)
+          (let ((c (char-downcase (peek-char in))))
+            (if (if (char-numeric? c) #t (memv c '(#\a #\b #\c #\d #\e)))
+                (read-label (cons (read-char in) res))
+                (list->string (reverse res)))))
+        (define (read-number base)
+          (let* ((str (read-label '()))
+                 (n (string->number str base)))
+            (if (or (not n) (not (memv (peek-char in) delimiters)))
+                (error "read error: invalid number syntax" str (peek-char in))
+                n)))
+        (define (read-float-tail in) ;; called only after a leading period
+          (let lp ((res 0.0) (k 0.1))
+            (let ((c (peek-char in)))
+              (cond
+               ((char-numeric? c) (lp (+ res (* (read-char in) k)) (* k 0.1)))
+               ((memv c delimiters) res)
+               (else (error "invalid char in float syntax" c))))))
+        (define (read-name c in)
+          (let lp ((ls (if (char? c) (list c) '())))
+            (let ((c (peek-char in)))
+              (cond ((memv c delimiters) (list->string (reverse ls)))
+                    (else (lp (cons (read-char in) ls)))))))
+        (define (read-named-char c in)
+          (let ((name (read-name c in)))
+            (cond ((string-ci=? name "space") #\space)
+                  ((string-ci=? name "newline") #\newline)
+                  (else (error "unknown char name")))))
+        (define (read-one)
+          (skip-whitespace in)
+          (case (peek-char in)
+            ((#\#)
+             (read-char in)
+             (case (char-downcase (peek-char in))
+               ((#\=)
+                (read-char in)
+                (let* ((str (read-label '()))
+                       (n (string->number str))
+                       (cell (list #f))
+                       (thunk (lambda () (car cell))))
+                  (if (not n) (error "read error: invalid reference" str))
+                  (set! shared (cons (cons n thunk) shared))
+                  (let ((x (read-one)))
+                    (set-car! cell x)
+                    x)))
+               ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+                (let ((n (string->number (read-label '()))))
+                  (cond
+                   ((not (eqv? #\# (peek-char in)))
+                    (error "read error: expected # after #n" (read-char in)))
+                   (else
+                    (read-char in)
+                    (cond ((assv n shared) => cdr)
+                          (else (error "read error: unknown reference" n)))))))
+               ((#\;)
+                (read-char in)
+                (read-one) ;; discard
+                (read-one))
+               ((#\|)
+                (skip-comment in 0))
+               ((#\!) (skip-line in) (read-one in))
+               ((#\() (list->vector (read-one)))
+               ((#\') (read-char in) (list 'syntax (read-one)))
+               ((#\`) (read-char in) (list 'quasisyntax (read-one)))
+               ((#\t) (read-char in) #t)
+               ((#\f) (read-char in) #t) ; support SRFI-4 f32/64 vectors
+               ((#\d) (read-char in) (read in))
+               ((#\x) (read-char in) (read-number 16))
+               ((#\o) (read-char in) (read-number 8))
+               ((#\b) (read-char in) (read-number 2))
+               ((#\i) (read-char in) (exact->inexact (read-one)))
+               ((#\e) (read-char in) (inexact->exact (read-one)))
+               ((#\\)
+                (read-char in)
+                (let ((c (read-char in)))
+                  (if (memv (peek-char in) delimiters)
+                      c
+                      (read-named-char c in))))
+               (else
+                (error "unknown # syntax: " (peek-char in)))))
+            ((#\()
+             (read-char in)
+             (let lp ((res '()))
+               (skip-whitespace in)
+               (case (peek-char in)
+                 ((#\))
+                  (read-char in)
+                  (reverse res))
+                 ((#\.)
+                  (read-char in)
+                  (cond
+                   ((memv (peek-char in) delimiters)
+                    (let ((tail (read-one)))
+                      (skip-whitespace in)
+                      (if (eqv? #\) (peek-char in))
+                          (begin (read-char in) (append (reverse res) tail))
+                          (error "expected end of list after dot"))))
+                   ((char-numeric? (peek-char in)) (read-float-tail in))
+                   (else (string->symbol (read-name #\. in)))))
+                 (else
+                  (lp (cons (read-one) res))))))
+            ((#\') (read-char in) (list 'quote (read-one)))
+            ((#\`) (read-char in) (list 'quasiquote (read-one)))
+            ((#\,)
+             (read-char in)
+             (list (if (eqv? #\@ (peek-char in))
+                       (begin (read-char in) 'unquote-splicing)
+                       'unquote)
+                   (read-one)))
+            (else
+             (read in))))
+        ;; body
+        (let ((res (read-one)))
+          (if (pair? shared)
+              (patch res))
+          res)))))
+
+(define (hole? x) (procedure? x))
+(define (fill-hole x) (if (hole? x) (fill-hole (x)) x))
+
+(define (patch x)
+  (cond
+   ((pair? x)
+    (if (hole? (car x)) (set-car! x (fill-hole (car x))) (patch (car x)))
+    (if (hole? (cdr x)) (set-cdr! x (fill-hole (cdr x))) (patch (cdr x))))
+   ((vector? x)
+    (do ((i (- (vector-length x) 1) (- i 1)))
+        ((< i 0))
+      (let ((elt (vector-ref x i)))
+        (if (hole? elt)
+            (vector-set! x i (fill-hole elt))
+            (patch elt)))))))
+
+(define read/ss read-with-shared-structure)

lib/srfi/39.module

@@ -0,0 +1,25 @@
+
+(define-module (srfi 39)
+  (export make-parameter parameterize)
+  (import-immutable (scheme))
+  (body
+   (define (make-parameter value . o)
+     (if (pair? o)
+         (let ((converter (car o)))
+           (lambda args
+             (if (null? args)
+                 value
+                 (set! value (converter (car args))))))
+         (lambda args (if (null? args) value (set! value (car args))))))
+   (define-syntax parameterize
+     (syntax-rules ()
+       ((parameterize ("step") ((param value tmp1 tmp2) ...) () body)
+        (let ((tmp1 value) ...)
+          (let ((tmp2 (param)) ...)
+            (dynamic-wind (lambda () (param tmp1) ...)
+                          (lambda () . body)
+                          (lambda () (param tmp2) ...)))))
+       ((parameterize ("step") args ((param value) . rest) body)
+        (parameterize ("step") ((param value tmp1 tmp2) . args) rest body))
+       ((parameterize ((param value) ...) . body)
+        (parameterize ("step") () ((param value) ...) body))))))