Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

automatically making sockets non-blocking on accept

Browse source
This commit is contained in:
Alex Shinn 2012-05-14 08:37:45 -04:00
commit 85a7efc003
263 changed files with 42854 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

39
.hgignore Normal file
View file

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

36
AUTHORS Normal file
View file

@ -0,0 +1,36 @@
Alex Shinn wrote the initial version of chibi-scheme and all
distributed modules.
The `dynamic-wind' implementation is adapted from the implementation
in the appendix to the Scheme48 reference manual, reportedly first
written by Chris Hanson and John Lamping.
Thanks to the following people for patches and bug reports:
* Alan Watson
* Alexander Shendi
* Andreas Rottman
* Bakul Shah
* Bruno Deferrari
* Doug Currie
* Derrick Eddington
* Dmitry Chestnykh
* Eduardo Cavazos
* Felix Winkelmann
* Gregor Klinke
* Jeremy Wolff
* Jeronimo Pellegrini
* John Cowan
* John Samsa
* Lars J Aas
* Lorenzo Campedelli
* Michal Kowalski (sladegen)
* Rajesh Krishnan
* Taylor Venable
* Travis Cross
* Zhang Meng
If you would prefer not to be listed, or are one of the users listed
without a full name, please contact me. If you've made a contribution
and are not listed, please accept my apologies and contact me
immediately!

24
COPYING Normal file
View file

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

306
Makefile Normal file
View file

@ -0,0 +1,306 @@
# -*- makefile-gmake -*-
.PHONY: dist mips-dist cleaner test checkdefs
.DEFAULT_GOAL := all
CHIBI_FFI ?= $(CHIBI) tools/chibi-ffi
CHIBI_FFI_DEPENDENCIES ?= $(CHIBI_DEPENDENCIES) tools/chibi-ffi
CHIBI_DOC ?= $(CHIBI) tools/chibi-doc
CHIBI_DOC_DEPENDENCIES ?= $(CHIBI_DEPENDENCIES) tools/chibi-doc
GENSTATIC ?= ./tools/chibi-genstatic
CHIBI ?= LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE)
CHIBI_DEPENDENCIES = ./chibi-scheme$(EXE)
########################################################################
CHIBI_COMPILED_LIBS = lib/chibi/filesystem$(SO) lib/chibi/process$(SO) \
lib/chibi/time$(SO) lib/chibi/system$(SO) lib/chibi/stty$(SO) \
lib/chibi/weak$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) \
lib/chibi/net$(SO)
CHIBI_IO_COMPILED_LIBS = lib/chibi/io/io$(SO)
CHIBI_OPT_COMPILED_LIBS = lib/chibi/optimize/rest$(SO) \
lib/chibi/optimize/profile$(SO)
COMPILED_LIBS = $(CHIBI_COMPILED_LIBS) $(CHIBI_IO_COMPILED_LIBS) \
$(CHIBI_OPT_COMPILED_LIBS) lib/srfi/18/threads$(SO) \
lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) lib/srfi/39/param$(SO) \
lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) lib/srfi/98/env$(SO) \
lib/scheme/time$(SO)
BASE_INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h include/chibi/bignum.h
INCLUDES = $(BASE_INCLUDES) include/chibi/eval.h
MODULE_DOCS := ast disasm equiv filesystem generic heap-stats io loop \
match mime modules net pathname process repl scribble stty \
system test time trace type-inference uri weak
HTML_LIBS = $(MODULE_DOCS:%=doc/lib/chibi/%.html)
########################################################################
include Makefile.libs
########################################################################
# Library config.
#
# This is to allow "make SEXP_USE_BOEHM=1" and "make SEXP_USE_DL=0" to
# automatically include the necessary compiler and linker flags in
# addition to setting those features. If not using GNU make just
# comment out the ifs and use the else branches for the defaults.
ifeq ($(SEXP_USE_BOEHM),1)
GCLDFLAGS := -lgc
XCPPFLAGS := $(CPPFLAGS) -Iinclude $(D:%=-DSEXP_USE_%) -DSEXP_USE_BOEHM=1
else
GCLDFLAGS :=
XCPPFLAGS := $(CPPFLAGS) -Iinclude $(D:%=-DSEXP_USE_%)
endif
ifeq ($(SEXP_USE_DL),0)
XLDFLAGS := $(LDFLAGS) $(RLDFLAGS) $(GCLDFLAGS) -lm
XCFLAGS := -Wall -DSEXP_USE_DL=0 -g -g3 -Os $(CFLAGS)
else
XLDFLAGS := $(LDFLAGS) $(RLDFLAGS) $(GCLDFLAGS) $(LIBDL) -lm
XCFLAGS := -Wall -g -g3 -Os $(CFLAGS)
endif
########################################################################
all: chibi-scheme$(EXE) all-libs lib/chibi/ast$(SO)
include/chibi/install.h: Makefile
echo '#define sexp_so_extension "'$(SO)'"' > $@
echo '#define sexp_default_module_path "'$(MODDIR):$(BINMODDIR)'"' >> $@
echo '#define sexp_platform "'$(PLATFORM)'"' >> $@
echo '#define sexp_version "'`cat VERSION`'"' >> $@
echo '#define sexp_release_name "'`cat RELEASE`'"' >> $@
sexp.o: sexp.c gc.c opt/bignum.c $(BASE_INCLUDES) Makefile
$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $<
sexp-ulimit.o: sexp.c gc.c opt/bignum.c $(BASE_INCLUDES) Makefile
$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -DSEXP_USE_LIMITED_MALLOC -o $@ $<
eval.o: eval.c opcodes.c vm.c opt/simplify.c $(INCLUDES) Makefile
$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $<
main.o: main.c $(INCLUDES) Makefile
$(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $<
libchibi-sexp$(SO): sexp.o
$(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS)
libchibi-scheme$(SO): eval.o sexp.o
$(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS)
chibi-scheme$(EXE): main.o libchibi-scheme$(SO)
$(CC) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme
chibi-scheme-static$(EXE): main.o eval.o sexp.o
$(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) -lm
chibi-scheme-ulimit$(EXE): main.o eval.o sexp-ulimit.o
$(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) -lm
clibs.c: $(GENSTATIC) chibi-scheme$(EXE)
$(FIND) lib -name \*.sld | $(CHIBI) $(GENSTATIC) > $@
# A special case, this needs to be linked with the LDFLAGS in case
# we're using Boehm.
lib/chibi/ast$(SO): lib/chibi/ast.c $(INCLUDES)
-$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< $(XLDFLAGS) -L. -lchibi-scheme
doc/lib/chibi/%.html: lib/chibi/%.sld $(CHIBI_DOC_DEPENDENCIES)
$(CHIBI_DOC) chibi.$* > $@
doc: doc/chibi.html doc-libs
%.html: %.scrbl $(CHIBI_DOC_DEPENDENCIES)
$(CHIBI_DOC) $< > $@
clean: clean-libs
-$(RM) *.o *.i *.s *.8 tests/basic/*.out tests/basic/*.err
cleaner: clean
-$(RM) chibi-scheme$(EXE) chibi-scheme-static$(EXE) chibi-scheme-ulimit$(EXE) \
libchibi-scheme$(SO) *.a include/chibi/install.h \
$(shell $(FIND) lib -name \*.o)
dist-clean: dist-clean-libs cleaner
checkdefs:
@for d in $(D); do \
if ! $(GREP) -q " SEXP_USE_$${d%%=*} " include/chibi/features.h; then \
echo "WARNING: unknown definition $$d"; \
fi; \
done
test-basic: chibi-scheme$(EXE)
@for f in tests/basic/*.scm; do \
$(CHIBI) -xscheme $$f >$${f%.scm}.out 2>$${f%.scm}.err; \
if $(DIFF) -q $(DIFFOPTS) $${f%.scm}.out $${f%.scm}.res; then \
echo "[PASS] $${f%.scm}"; \
else \
echo "[FAIL] $${f%.scm}"; \
fi; \
done
test-memory: chibi-scheme-ulimit$(EXE)
./tests/memory/memory-tests.sh
test-build:
MAKE=$(MAKE) ./tests/build/build-tests.sh
test-threads: chibi-scheme$(EXE) lib/srfi/18/threads$(SO) lib/srfi/39/param$(SO) lib/srfi/98/env$(SO) lib/chibi/ast$(SO) lib/chibi/time$(SO)
$(CHIBI) -xscheme tests/thread-tests.scm
test-numbers: chibi-scheme$(EXE)
$(CHIBI) -xscheme tests/numeric-tests.scm
test-flonums: chibi-scheme$(EXE)
$(CHIBI) -xscheme tests/flonum-tests.scm
test-hash: chibi-scheme$(EXE) lib/srfi/69/hash$(SO)
$(CHIBI) -xscheme tests/hash-tests.scm
test-io: chibi-scheme$(EXE) lib/chibi/io/io$(SO)
$(CHIBI) -xscheme tests/io-tests.scm
test-match: chibi-scheme$(EXE)
$(CHIBI) -xscheme tests/match-tests.scm
test-loop: chibi-scheme$(EXE)
$(CHIBI) -xscheme tests/loop-tests.scm
test-sort: chibi-scheme$(EXE) lib/srfi/33/bit$(SO)
$(CHIBI) -xscheme tests/sort-tests.scm
test-srfi-1: chibi-scheme$(EXE)
$(CHIBI) -xscheme tests/srfi-1-tests.scm
test-records: chibi-scheme$(EXE)
$(CHIBI) -xscheme tests/record-tests.scm
test-weak: chibi-scheme$(EXE) lib/chibi/weak$(SO)
$(CHIBI) -xscheme tests/weak-tests.scm
test-unicode: chibi-scheme$(EXE)
$(CHIBI) -xscheme tests/unicode-tests.scm
test-process: chibi-scheme$(EXE) lib/chibi/process$(SO)
$(CHIBI) -xscheme tests/process-tests.scm
test-system: chibi-scheme$(EXE) lib/chibi/system$(SO)
$(CHIBI) -xscheme tests/system-tests.scm
test-libs: chibi-scheme$(EXE)
$(CHIBI) -xscheme tests/lib-tests.scm
test: chibi-scheme$(EXE)
$(CHIBI) -xscheme tests/r5rs-tests.scm
install: all
$(MKDIR) $(DESTDIR)$(BINDIR)
$(INSTALL) chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/
$(INSTALL) tools/chibi-ffi $(DESTDIR)$(BINDIR)/
$(INSTALL) tools/chibi-doc $(DESTDIR)$(BINDIR)/
$(MKDIR) $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(MODDIR)/chibi/term
$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/char
$(MKDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(MODDIR)/srfi/33 $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(MODDIR)/srfi/99/records
$(INSTALL) lib/*.scm $(DESTDIR)$(MODDIR)/
$(INSTALL) lib/chibi/*.sld lib/chibi/*.scm $(DESTDIR)$(MODDIR)/chibi/
$(INSTALL) lib/chibi/io/*.scm $(DESTDIR)$(MODDIR)/chibi/io/
$(INSTALL) lib/chibi/loop/*.scm $(DESTDIR)$(MODDIR)/chibi/loop/
$(INSTALL) lib/chibi/match/*.scm $(DESTDIR)$(MODDIR)/chibi/match/
$(INSTALL) lib/chibi/net/*.sld lib/chibi/net/*.scm $(DESTDIR)$(MODDIR)/chibi/net/
$(INSTALL) lib/chibi/optimize/*.sld lib/chibi/optimize/*.scm $(DESTDIR)$(MODDIR)/chibi/optimize/
$(INSTALL) lib/chibi/term/*.sld lib/chibi/term/*.scm $(DESTDIR)$(MODDIR)/chibi/term/
$(INSTALL) lib/scheme/*.sld lib/scheme/*.scm $(DESTDIR)$(MODDIR)/scheme/
$(INSTALL) lib/scheme/char/*.sld $(DESTDIR)$(MODDIR)/scheme/char/
$(INSTALL) lib/srfi/*.sld lib/srfi/*.scm $(DESTDIR)$(MODDIR)/srfi/
$(INSTALL) lib/srfi/1/*.scm $(DESTDIR)$(MODDIR)/srfi/1/
$(INSTALL) lib/srfi/18/*.scm $(DESTDIR)$(MODDIR)/srfi/18/
$(INSTALL) lib/srfi/27/*.scm $(DESTDIR)$(MODDIR)/srfi/27/
$(INSTALL) lib/srfi/33/*.scm $(DESTDIR)$(MODDIR)/srfi/33/
$(INSTALL) lib/srfi/39/*.scm $(DESTDIR)$(MODDIR)/srfi/39/
$(INSTALL) lib/srfi/69/*.scm $(DESTDIR)$(MODDIR)/srfi/69/
$(INSTALL) lib/srfi/95/*.scm $(DESTDIR)$(MODDIR)/srfi/95/
$(INSTALL) lib/srfi/99/*.sld $(DESTDIR)$(MODDIR)/srfi/99/
$(INSTALL) lib/srfi/99/records/*.sld lib/srfi/99/records/*.scm $(DESTDIR)$(MODDIR)/srfi/99/records/
$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/io/
$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
$(MKDIR) $(DESTDIR)$(BINMODDIR)/scheme/
$(MKDIR) $(DESTDIR)$(BINMODDIR)/srfi/18 $(DESTDIR)$(BINMODDIR)/srfi/27 $(DESTDIR)$(BINMODDIR)/srfi/33 $(DESTDIR)$(BINMODDIR)/srfi/39 $(DESTDIR)$(BINMODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/98
$(INSTALL) $(CHIBI_COMPILED_LIBS) lib/chibi/ast$(SO) $(DESTDIR)$(BINMODDIR)/chibi/
$(INSTALL) $(CHIBI_IO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/io/
$(INSTALL) $(CHIBI_OPT_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
$(INSTALL) lib/scheme/time$(SO) $(DESTDIR)$(BINMODDIR)/scheme/
$(INSTALL) lib/srfi/18/threads$(SO) $(DESTDIR)$(BINMODDIR)/srfi/18
$(INSTALL) lib/srfi/27/rand$(SO) $(DESTDIR)$(BINMODDIR)/srfi/27
$(INSTALL) lib/srfi/33/bit$(SO) $(DESTDIR)$(BINMODDIR)/srfi/33
$(INSTALL) lib/srfi/39/param$(SO) $(DESTDIR)$(BINMODDIR)/srfi/39
$(INSTALL) lib/srfi/69/hash$(SO) $(DESTDIR)$(BINMODDIR)/srfi/69
$(INSTALL) lib/srfi/95/qsort$(SO) $(DESTDIR)$(BINMODDIR)/srfi/95
$(INSTALL) lib/srfi/98/env$(SO) $(DESTDIR)$(BINMODDIR)/srfi/98
$(MKDIR) $(DESTDIR)$(INCDIR)
$(INSTALL) $(INCLUDES) $(DESTDIR)$(INCDIR)/
$(MKDIR) $(DESTDIR)$(LIBDIR)
$(MKDIR) $(DESTDIR)$(SOLIBDIR)
$(INSTALL) libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/
-$(INSTALL) libchibi-scheme.a $(DESTDIR)$(SOLIBDIR)/
$(MKDIR) $(DESTDIR)$(MANDIR)
$(INSTALL) doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/
$(INSTALL) doc/chibi-ffi.1 $(DESTDIR)$(MANDIR)/
$(INSTALL) doc/chibi-doc.1 $(DESTDIR)$(MANDIR)/
-if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi
uninstall:
-$(RM) $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE)
-$(RM) $(DESTDIR)$(BINDIR)/chibi-scheme-static$(EXE)
-$(RM) $(DESTDIR)$(BINDIR)/chibi-ffi
-$(RM) $(DESTDIR)$(BINDIR)/chibi-doc
-$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO)
-$(RM) $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a
-$(CD) $(DESTDIR)$(INCDIR) && $(RM) $(INCLUDES)
-$(RM) $(DESTDIR)$(MODDIR)/srfi/99/records/*.{sld,scm}
-$(RM) $(DESTDIR)$(MODDIR)/*.{sld,scm} $(DESTDIR)$(MODDIR)/*/*.{sld,scm} $(DESTDIR)$(MODDIR)/*/*/*.{sld,scm}
-$(CD) $(DESTDIR)$(MODDIR) && $(RM) $(COMPILED_LIBS:lib/%=%) chibi/ast$(SO)
-$(CD) $(DESTDIR)$(BINMODDIR) && $(RM) $(COMPILED_LIBS:lib/%=%) chibi/ast$(SO)
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(BINMODDIR)/chibi/io
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(BINMODDIR)/chibi/loop
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(BINMODDIR)/chibi/match
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(BINMODDIR)/chibi/net
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(BINMODDIR)/chibi/optimize
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/term $(DESTDIR)$(BINMODDIR)/chibi/term
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi $(DESTDIR)$(BINMODDIR)/chibi
-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/char $(DESTDIR)$(BINMODDIR)/scheme/char
-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme $(DESTDIR)$(BINMODDIR)/scheme
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(BINMODDIR)/srfi/1
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(BINMODDIR)/srfi/18
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(BINMODDIR)/srfi/27
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/33 $(DESTDIR)$(BINMODDIR)/srfi/33
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(BINMODDIR)/srfi/39
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/69
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/95
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/98 $(DESTDIR)$(BINMODDIR)/srfi/98
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/99/records $(DESTDIR)$(BINMODDIR)/srfi/99/records
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(BINMODDIR)/srfi/99
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi $(DESTDIR)$(BINMODDIR)/srfi
-$(RMDIR) $(DESTDIR)$(MODDIR) $(DESTDIR)$(BINMODDIR)
-$(RM) $(DESTDIR)$(MANDIR)/chibi-scheme.1 $(DESTDIR)$(MANDIR)/chibi-ffi.1 $(DESTDIR)$(MANDIR)/chibi-doc.1
dist: dist-clean
$(RM) chibi-scheme-`cat VERSION`.tgz
$(MKDIR) chibi-scheme-`cat VERSION`
@for f in `hg manifest`; do $(MKDIR) chibi-scheme-`cat VERSION`/`dirname $$f`; $(SYMLINK) `pwd`/$$f chibi-scheme-`cat VERSION`/$$f; done
$(TAR) cphzvf chibi-scheme-`cat VERSION`.tgz chibi-scheme-`cat VERSION`
$(RM) -r chibi-scheme-`cat VERSION`
mips-dist: dist-clean
$(RM) chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz
$(MKDIR) chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`
@for f in `hg manifest`; do $(MKDIR) chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/`dirname $$f`; $(SYMLINK) `pwd`/$$f chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/$$f; done
$(TAR) cphzvf chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`
$(RM) -r chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`

78
Makefile.detect Normal file
View file

@ -0,0 +1,78 @@
# -*- makefile-gmake -*-
########################################################################
# Detect the PLATFORM with uname.
ifndef PLATFORM
ifeq ($(shell uname),Darwin)
PLATFORM=macosx
else
ifeq ($(shell uname),FreeBSD)
PLATFORM=FreeBSD
else
ifeq ($(shell uname -o),Msys)
PLATFORM=mingw
SOLIBDIR = $(BINDIR)
DIFFOPTS = -b
else
ifeq ($(shell uname -o),Cygwin)
PLATFORM=cygwin
SOLIBDIR = $(BINDIR)
DIFFOPTS = -b
else
ifeq ($(shell uname -o),GNU/Linux)
PLATFORM=linux
else
PLATFORM=unix
endif
endif
endif
endif
endif
endif
########################################################################
# Set default variables for the platform.
LIBDL = -ldl
ifeq ($(PLATFORM),macosx)
SO = .dylib
EXE =
CLIBFLAGS = -dynamiclib
STATICFLAGS = -static-libgcc -DSEXP_USE_DL=0
else
ifeq ($(PLATFORM),mingw)
SO = .dll
EXE = .exe
CC = gcc
CLIBFLAGS = -shared
CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL
LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a
STATICFLAGS = -DSEXP_USE_DL=0
LIBDL =
else
ifeq ($(PLATFORM),cygwin)
SO = .dll
EXE = .exe
CC = gcc
CLIBFLAGS = -shared
CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0
LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a
else
SO = .so
EXE =
CLIBFLAGS = -fPIC -shared
STATICFLAGS = -static -DSEXP_USE_DL=0
ifeq ($(PLATFORM),FreeBSD)
LIBDL=
RLDFLAGS=-Wl,-R$(DESTDIR)$(LIBDIR)
endif
endif
endif
endif
ifeq ($(PLATFORM),unix)
#RLDFLAGS=-rpath $(LIBDIR)
RLDFLAGS=-Wl,-R$(LIBDIR)
endif

89
Makefile.libs Normal file
View file

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

33
README Normal file
View file

@ -0,0 +1,33 @@
Chibi-Scheme
--------------
Minimal Scheme Implementation for use as an Extension Language
http://synthcode.com/wiki/chibi-scheme/
Chibi-Scheme is a very small library intended for use as an extension
and scripting language in C programs. In addition to support for
lightweight VM-based threads, each VM itself runs in an isolated heap
allowing multiple VMs to run simultaneously in different OS threads.
The default language is an extended subset of the current draft R7RS
Scheme, with support for all libraries. Support for additional
languages such as JavaScript, Go, Lua and Bash are planned for future
releases. Scheme is chosen as a substrate because its first class
continuations and guaranteed tail-call optimization makes implementing
other languages easy.
To build on most platforms just run "make && make test". This will
provide a shared library "libchibi-scheme", as well as a sample
"chibi-scheme" command-line repl. You can then run
sudo make PREFIX=/usr/local install
to install the binaries, leaving out the PREFIX for the default
/usr/local or specifying an alternate install location. If you want
to try out chibi-scheme without installing, be sure to set
LD_LIBRARY_PATH so it can find the shared libraries.
For more detailed documentation, run "make doc" and see the generated
"doc/chibi.html".

108
README.libs Normal file
View file

@ -0,0 +1,108 @@
Using the Makefile.libs File To Build and Install Libraries
-----------------------------------------------------------
The Makefile.libs file distributed with the Chibi Scheme sources
can facilitate building and installing Chibi Scheme libraries written
in C or Scheme. To use it, follow these instructions:
1. Copy the Makefile.libs and Makefile.detect files from the Chibi
Scheme source directory to the library source top-level directory.
2. Place the library source in the subdirectory "lib" of the library
source top-level directory. For example,
lib/foo/bar.c
lib/foo/bar.h
lib/foo/bar.sld
lib/foo/bar.scm
3. In the Makefile in the library source top-level directory, define
the following targets:
all
doc
install
uninstall
clean
dist-clean
These should depend on the corresponding "-libs" target, but
can include additional commands. For example:
all: all-libs
install: install-libs
cp -r doc $(PREFIX)/share/chibi/
uninstall: uninstall-libs
doc: doc-libs
clean: clean-libs
dist-clean: dist-clean-libs
The all target should be the first target in the Makefile.
The all-libs target makes the shared libraries in the library.
The doc-libs target generates HTML files for the library. The
install-libs and uninstall-libs targets install and uninstall
the library under the prefix. The clean-libs target removes the
shared libraries and generated HTML files. The dist-clean-libs
removes any .c files generated from .stub files and also performs
a clean-libs.
4. In the Makefile in the library source top-level directory, define
the following variables:
COMPILED_LIBS: Any shared libraries that should be built and
installed. The shared library is build from the corresponding
.c or .stub file. The $(SO) variable should be used for the
shared-library suffix; in order for this to work COMPILED_LIBS
should be defined as a recursively-expanded variable (with
=) rather than a simply-expanded variable (with :=).
INCLUDES: Any other files on which the shared libraries depend.
SCM_LIBS: Any Scheme source files that should be installed.
HTML_LIBS: Any HTML files that should be generated. The HTML
files are generated from the corresponding .sld files using
chibi-doc.
For example,
COMPILED_LIBS = lib/foo/bar$(SO)
INCLUDES = lib/foo/bar.h
SCM_LIBS = lib/foo/bar.sld lib/foo/bar.scm
HTML_LIBS = doc/lib/foo/bar.html
5. Add additional flags as necessary to XCPPFLAGS and XCFLAGS.
These flags are passed to the compiler and linker when they
generate the shared library. These should probably include at
least:
XCPPFLAGS += -I$(PREFIX)/include
XCFLAGS += -L$(PREFIX)/lib
These additions will ensure that the compiler and linker can
find the Chibi Scheme include and library files, even if they
are installed under a non-standard prefix.
6. Include the common Makefile using:
include Makefile.libs
A complete example is:
all: all-libs
install: install-libs
uninstall: uninstall-libs
doc: doc-libs
clean: clean-libs
dist-clean: dist-clean-libs
COMPILED_LIBS = lib/foo/bar$(SO)
INCLUDES = lib/foo/bar.h
SCM_LIBS = lib/foo/bar.sld lib/foo/bar.scm
HTML_LIBS = doc/lib/foo/bar.html
XCPPFLAGS += -I$(PREFIX)/include
XCFLAGS += -L$(PREFIX)/lib
include Makefile.libs

1
RELEASE Normal file
View file

@ -0,0 +1 @@
boron

187
TODO Normal file
View file

@ -0,0 +1,187 @@
-*- org -*-
* compiler
** DONE ast rewrite
- State "DONE" [2009-04-09 Thu 14:32]
** DONE call/cc support
- State "DONE" [2009-04-09 Thu 14:36]
** DONE exceptions
- State "DONE" [2009-04-09 Thu 14:45]
** TODO native x86 backend
API redesign in preparation complete, initial
tests on native factorial and closures working.
** TODO fasl/image files
sexp_copy_context() can form the basis for images,
FASL for arbitrary modules will need additional
help with resolving external references.
*** DONE optional image loading on startup
- State "DONE" from "TODO" [2011-11-10 Thu 20:44]
*** TODO static image compiled into library
With this you'll be able to run Chibi without any filesystem.
*** TODO external tool to compact and optimize images
The current GC is mark&sweep, which can cause fragmentation,
but we can at at least compact the initial fixed image.
*** TODO fasl versions of modules
Important for large applications, and fast loading of script
with many dependencies.
** DONE shared stack on EVAL
- State "DONE" [2009-12-26 Sat 08:22]
* compiler optimizations
** DONE constant folding
- State "DONE" [2009-12-16 Wed 23:25]
** DONE simplification pass, dead-code elimination
- State "DONE" [2009-12-18 Fri 14:14]
This is important in particular for the output generated by
syntax-rules.
** TODO lambda lift
The current closure representation is not very efficient, so this
would help a lot.
** TODO inlining (and disabling primitive inlining)
Being able to redefine procedures is important though.
** TODO unsafe operations
Possibly, don't want to make things too complicated or unstable.
** TODO plugin infrastructure
** DONE type inference with warnings
- State "DONE" from "TODO" [2010-09-21 Tue 23:18]
*** TODO structured type inference
*** DONE infer error branches
CLOSED: [2011-11-14 Mon 08:17]
*** TODO elide type checks from type information
* macros
** DONE hygiene
- State "DONE" [2009-04-09 Thu 14:41]
** DONE hygienic nested let-syntax
- State "DONE" [2009-12-08 Tue 14:41]
** DONE macroexpand utility
- State "DONE" [2009-12-08 Tue 14:41]
** DONE SRFI-46 basic syntax-rules extensions
- State "DONE" [2009-12-26 Sat 07:59]
** DONE (... ...) support
- State "DONE" [2009-12-26 Sat 02:06]
** TODO compiler macros
** TODO syntax-rules common pattern reduction
** TODO syntax-rules loop optimization
* garbage collection
** DONE precise gc rewrite
- State "DONE" [2009-06-22 Mon 14:27]
** DONE fix heap growing
- State "DONE" [2009-06-22 Mon 14:29]
** DONE separate gc heaps
- State "DONE" [2009-12-08 Tue 14:29]
** DONE add finalizers
- State "DONE" [2009-12-08 Tue 14:29]
** DONE support weak references
- State "DONE" from "TODO" [2010-09-21 Tue 23:16]
*** TODO support proper weak key-value references
* runtime
** DONE bignums
- State "DONE" [2009-07-07 Tue 14:42]
** DONE unicode
- State "DONE" from "TODO" [2010-07-11 Sun 23:58]
Supported with UTF-8 strings, string-ref is O(n) and
string-set! may need to reallocate the whole string.
string-cursor-ref can be used for O(1) string access.
** DONE threads
- State "DONE" from "TODO" [2010-07-11 Sun 15:31]
VM now supports an optional hook for green threads,
and a SRFI-18 interface is provided as a separate module.
I/O operations will currently block all threads though,
this needs to be addressed.
*** DONE thread-local parameters
CLOSED: [2010-12-06 Mon 21:52]
*** TODO efficient priority queues
** DONE virtual ports
- State "DONE" [2010-01-02 Sat 20:12]
** DONE dynamic-wind
- State "DONE" [2009-12-26 Sat 01:51]
Adapted a version from Scheme48.
** DONE recursive disasm
- State "DONE" [2009-12-18 Fri 14:15]
* FFI
** DONE libdl support
- State "DONE" [2009-12-08 Tue 14:45]
** DONE opcode generation interface
- State "DONE" [2009-11-15 Sun 14:45]
** DONE stub generator
- State "DONE" [2009-12-26 Sat 01:50]
*** DONE define-c-struct
- State "DONE" [2009-11-29 Sun 14:48]
*** DONE define-c
- State "DONE" [2009-11-29 Sun 14:48]
*** DONE array return types
- State "DONE" [2009-12-26 Sat 01:49]
*** DONE pre-buffered string types (like getcwd)
- State "DONE" [2009-12-26 Sat 01:49]
* module system
** DONE scheme48-like config language
- State "DONE" [2009-10-13 Tue 14:38]
** DONE shared library includes
- State "DONE" [2009-12-08 Tue 14:39]
** DONE only/except/rename/prefix modifiers
- State "DONE" [2009-12-16 Wed 18:57]
** TODO scheme-complete.el support
** DONE access individual modules from repl
- State "DONE" [2009-12-26 Sat 01:49]
* core modules
** DONE SRFI-0 cond-expand
- State "DONE" [2009-12-16 Wed 20:12]
** DONE SRFI-9 define-record-type
- State "DONE" [2009-12-08 Tue 14:50]
** DONE SRFI-69 hash-tables
- State "DONE" [2009-11-15 Sun 14:50]
** DONE match library
- State "DONE" [2009-12-08 Tue 14:54]
** DONE loop library
- State "DONE" [2009-12-08 Tue 14:54]
** DONE network interface
- State "DONE" from "TODO" [2011-11-10 Thu 20:46]
** DONE posix interface
- State "DONE" from "TODO" [2010-07-11 Sun 15:36]
Splitting this into several parts.
*** DONE filesystem interface
- State "DONE" [2009-12-26 Sat 01:50]
*** DONE process interface
- State "DONE" [2009-12-26 Sat 01:50]
*** DONE time interface
- State "DONE" [2009-12-26 Sat 01:50]
*** DONE host system interface
- State "DONE" [2010-01-02 Sat 20:12]
** DONE pathname library
- State "DONE" [2009-12-16 Wed 18:58]
** DONE uri library
- State "DONE" [2009-12-16 Wed 18:58]
** TODO http library
** TODO show (formatting) library
** TODO zip library
** TODO tar library
** TODO md5sum library
* ports
** DONE basic mingw support
- State "DONE" [2009-06-22 Mon 14:36]
** DONE Plan 9 support
- State "DONE" [2009-08-10 Mon 14:37]
** DONE 64-bit support
- State "DONE" [2009-11-01 Sun 14:37]
** DONE iPhone support
- State "DONE" from "TODO" [2011-11-10 Thu 20:46]
** TODO bare-metal support
* miscellaneous
** DONE user documentation
- State "DONE" from "TODO" [2011-11-10 Thu 20:45]
** TODO full test suite for libraries
** TODO thorough source documentation
* distribution
** TODO packaging format (Snow2)
** TODO code repository with fetch+install tool
** TODO translator to/from other implementations

1
VERSION Normal file
View file

@ -0,0 +1 @@
0.5.3

46
benchmarks/shootout/binarytrees.chibi Executable file
View file

@ -0,0 +1,46 @@
#! /usr/bin/env chibi-scheme
;;; The Computer Language Benchmarks Game
;;; http://shootout.alioth.debian.org/
(import (scheme) (srfi 9))
(define-record-type node
(make-node value left right)
node?
(value node-value node-value-set!)
(left node-left node-left-set!)
(right node-right node-right-set!))
(define (make value depth)
(if (zero? depth)
(make-node value #f #f)
(let ((v (* value 2))
(d (- depth 1)))
(make-node value (make (- v 1) d) (make v d)))))
(define (check n)
(if n
(+ (node-value n) (- (check (node-left n)) (check (node-right n))))
0))
(define (print . args) (for-each display args) (newline))
(define (main args)
(let* ((n (string->number (cadr args)))
(min-depth 4)
(max-depth (max (+ min-depth 2) n))
(stretch-depth (+ max-depth 1)))
(print "stretch tree of depth " stretch-depth "\t check: "
(check (make 0 stretch-depth)))
(let ((long-lived-tree (make 0 max-depth)))
(do ((d min-depth (+ d 2)))
((>= d max-depth))
(let ((iterations (* 2 (+ (- max-depth d) min-depth))))
(print (* 2 iterations) "\t trees of depth " d "\t check: "
(do ((i 0 (+ i 1))
(c 0 (+ c (check (make i d)) (check (make (- i) d)))))
((>= i iterations)
c)))))
(print "long lived tree of depth " max-depth "\t check: "
(check long-lived-tree)))))

107
benchmarks/shootout/chameneos-redux.chibi Normal file
View file

@ -0,0 +1,107 @@
#! /usr/bin/env chibi-scheme
;;; The Computer Language Benchmarks Game
;;; http://shootout.alioth.debian.org/
;;; based on Racket version by Matthew Flatt
(import (scheme)
(srfi 18)
(chibi match))
(define (print . args)
(for-each display args)
(newline))
(define (change c1 c2)
(case c1
((red)
(case c2 ((blue) 'yellow) ((yellow) 'blue) (else c1)))
((yellow)
(case c2 ((blue) 'red) ((red) 'blue) (else c1)))
((blue)
(case c2 ((yellow) 'red) ((red) 'yellow) (else c1)))))
(let ((colors '(blue red yellow)))
(for-each
(lambda (a)
(for-each
(lambda (b)
(print a " + " b " -> " (change a b)))
colors))
colors))
(define (place meeting-ch n)
(thread-start!
(make-thread
(lambda ()
(let loop ((n n))
(if (<= n 0)
;; Fade all:
(let loop ()
(let ((c (channel-get meeting-ch)))
(channel-put (car c) #f)
(loop)))
;; Let two meet:
(match-let (((ch1 . v1) (channel-get meeting-ch))
((ch2 . v2) (channel-get meeting-ch)))
(channel-put ch1 v2)
(channel-put ch2 v1)
(loop (- n 1)))))))))
(define (creature color meeting-ch result-ch)
(thread-start!
(make-thread
(lambda ()
(let ((ch (make-channel))
(name (gensym)))
(let loop ((color color) (met 0) (same 0))
(channel-put meeting-ch (cons ch (cons color name)))
(match (channel-get ch)
((other-color . other-name)
;; Meet:
(sleep) ; avoid imbalance from weak fairness
(loop (change color other-color)
(add1 met)
(+ same (if (eq? name other-name)
1
0))))
(#f
;; Done:
(channel-put result-ch (cons met same))))))))))
(define (spell n)
(for-each
(lambda (i)
(display " ")
(display (vector-ref digits (- (char->integer i) (char->integer #\0)))))
(string->list (number->string n))))
(define digits
'#("zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"))
(define (go n inits)
(let ((result-ch (make-channel))
(meeting-ch (make-channel)))
(place meeting-ch n)
(newline)
(for-each
(lambda (init)
(print " " init)
(creature init meeting-ch result-ch))
inits)
(newline)
(let ((results (map (lambda (i) (channel-get result-ch)) inits)))
(for-each
(lambda (r)
(display (car r))
(spell (cdr r))
(newline))
results)
(spell (apply + (map car results)))
(newline))))
(let ((n (string->number (cadr (command-line)))))
(go n '(blue red yellow))
(go n '(blue red yellow red yellow blue red yellow red blue))
(newline))

4171
benchmarks/shootout/knucleotide-input.txt Normal file
View file

File diff suppressed because it is too large Load diff

27
benchmarks/shootout/knucleotide-output.txt Normal file
View file

@ -0,0 +1,27 @@
A 30.279
T 30.113
G 19.835
C 19.773
AA 9.161
AT 9.138
TA 9.108
TT 9.060
CA 6.014
GA 5.996
AG 5.993
AC 5.988
TG 5.987
GT 5.967
TC 5.958
CT 5.948
GG 3.944
GC 3.928
CG 3.910
CC 3.899
1474 GGT
459 GGTA
49 GGTATT
1 GGTATTTTAATT
1 GGTATTTTAATTTATAGT

86
benchmarks/shootout/knucleotide.chibi Normal file
View file

@ -0,0 +1,86 @@
#! /usr/bin/env chibi-scheme
;;; The Computer Language Benchmarks Game
;;; http://shootout.alioth.debian.org/
;;; based on Racket version by Matthew Flatt
(import (scheme)
(srfi 69)
(srfi 95)
(chibi io))
(define (print . args)
(for-each display args)
(newline))
(define (string-copy! dst dstart src start end)
(do ((i dstart (+ i 1))
(j start (+ j 1)))
((>= j end))
(string-set! dst i (string-ref src j))))
(define (string-upcase str)
(let* ((len (string-length str))
(res (make-string len)))
(do ((i 0 (+ i 1)))
((>= i len) res)
(string-set! res i (char-upcase (string-ref str i))))))
(define (all-counts len dna)
(let ((table (make-hash-table eq?))
(seq (make-string len)))
(do ((s (- (string-length dna) len) ( - s 1)))
((< s 0) table)
(string-copy! seq 0 dna s (+ s len))
(let ((key (string->symbol seq)))
(let ((cnt (hash-table-ref/default table key 0)))
(hash-table-set! table key (+ cnt 1)))))))
(define (write-freqs table)
(let* ((content (hash-table->alist table))
(total (exact->inexact (apply + (map cdr content)))))
(for-each
(lambda (a)
(print (car a) " "
(/ (round (* 100000.0 (/ (cdr a) total))) 1000.0)))
(sort content > cdr))))
(define (write-one-freq table key)
(print (hash-table-ref/default table key 0) "\t" key))
(define dna
(let ((in (current-input-port)))
;; Skip to ">THREE ..."
(let lp ()
(let ((line (read-line in)))
(cond ((eof-object? line))
((and (>= (string-length line) 6)
(eqv? #\> (string-ref line 0))
(equal? (substring line 0 6) ">THREE")))
(else (lp)))))
(let ((out (open-output-string)))
;; Copy everything but newlines to out:
(let lp ()
(let ((line (read-line in)))
(cond ((eof-object? line))
(else
(display line out)
(lp)))))
;; Extract the string from out:
(string-upcase (get-output-string out)))))
;; 1-nucleotide counts:
(write-freqs (all-counts 1 dna))
(newline)
;; 2-nucleotide counts:
(write-freqs (all-counts 2 dna))
(newline)
;; Specific sequences:
(for-each
(lambda (seq)
(write-one-freq (all-counts (string-length seq) dna)
(string->symbol seq)))
'("GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT"))

206
chibi-scheme.vcproj Normal file
View file

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

69
contrib/bash_completion Normal file
View file

@ -0,0 +1,69 @@
# bash -*- shell-script -*- completion for chibi-scheme
type chibi-scheme >/dev/null 2>/dev/null && {
_chibi-modules() {
for dir in ./lib/ /usr/local/share/chibi/ "$@" \
$(echo $CHIBI_MODULE_PATH | tr ':' ' '); do
find "$dir" -name \*.sld 2>/dev/null \
| sed 's!'"$dir"'/*!!;s!\.sld$!!;s!/!.!g'
done | sort -u
}
_chibi-scheme() {
local cur prev
# Just some likely sample sizes, you're not limited to these.
local sizes="1M 2M 4M 8M 16M 32M 64M 128M 256M 512M 1G 2G 4G"
COMPREPLY=()
# We don't require a space between single-char options and the value.
cur=`_get_cword`
case "$cur" in
-m*)
COMPREPLY=( $( compgen -W "$(_chibi-modules | sed 's!^!-m!')" -- "$cur") )
return 0;;
-x*)
COMPREPLY=( $( compgen -W "$(_chibi-modules | sed 's!^!-x!')" -- "$cur") )
return 0;;
-l*)
compopt -o nospace
_filedir
return 0;;
-A*)
compopt -o nospace
COMPREPLY=( $( compgen -d -- "${cur#-A}" | sed 's!^!-A!' ) )
return 0;;
-I*)
compopt -o nospace
COMPREPLY=( $( compgen -d -- "${cur#-I}" | sed 's!^!-I!' ) )
return 0;;
-h*)
COMPREPLY=( $( compgen -W "$(echo $sizes | tr ' ' '\n' | sed 's!^!-h!')" -- "${cur}" ) )
return 0;;
-)
COMPREPLY=( $( compgen -W '-d -e -f -h -i -l -m -p -q -x -A -I -V' \
-- "$cur") )
return 0;;
-*)
return 0;;
esac
# Not connected to the option, check the previous word.
prev=${COMP_WORDS[COMP_CWORD-1]}
case "$prev" in
-[mx])
COMPREPLY=( $( compgen -W "$(_chibi-modules)" -- "$cur") )
return 0;;
-[AIl])
_filedir
return 0;;
-h)
COMPREPLY=( $( compgen -W "$sizes" -- "$cur" ) )
return 0;;
esac
}
complete -f -F _chibi-scheme chibi-scheme
}

40
doc/chibi-doc.1 Normal file
View file

@ -0,0 +1,40 @@
.TH "chibi-doc" "1" "" ""
.UC 4
.SH NAME
.PP
chibi-doc \- generate docs from Scheme scribble syntax
.SH SYNOPSIS
.B chibi-doc
[
.I file
]
.BR
.B chibi-doc
.I dotted-name.of.module
.BR
.SP 0.4
.SH DESCRIPTION
.I chibi-doc
is a tool to generate documentation from the Scheme scribble syntax
from Racket. It works like a Unix filter, translating from the
current input or a file to standard output. You can also specify a
module name, with components separated with dots, and it will search
for the module and generate documentation from it automatically from
literate comments in the module or any of its source files. These
comments are any line beginning with the characters
.I ;;>
The scribble syntax is described in the manual.
.SH AUTHORS
.PP
Alex Shinn (alexshinn @ gmail . com)
.SH SEE ALSO
.PP
The chibi-scheme home-page:
.BR
http://code.google.com/p/chibi-scheme/

45
doc/chibi-ffi.1 Normal file
View file

@ -0,0 +1,45 @@
.TH "chibi-ffi" "1" "" ""
.UC 4
.SH NAME
.PP
chibi-ffi \- generate C from Scheme stub files
.SH SYNOPSIS
.B chibi-ffi
[-c]
[-f
.I
cflags
]
input.stub
[
.I output.c
]
.BR
.SP 0.4
.SH DESCRIPTION
.I chibi-ffi
reads in the C function FFI definitions from an input file and outputs
the appropriate C wrappers into a file with the same base name and the
".c" extension. You can then compile that C file into a shared
library:
chibi-ffi file.stub
cc -fPIC -shared file.c -lchibi-scheme
If the -c option is specified then chibi-ffi attempts to compile the
generated C code for you in one step. In this case, additional flags
for the C compiler may be given with the -f option.
The FFI syntax is described in the manual.
.SH AUTHORS
.PP
Alex Shinn (alexshinn @ gmail . com)
.SH SEE ALSO
.PP
The chibi-scheme home-page:
.BR
http://code.google.com/p/chibi-scheme/

174
doc/chibi-scheme.1 Normal file
View file

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

1149
doc/chibi.scrbl Executable file
View file

File diff suppressed because it is too large Load diff

1
doc/lib/chibi/README Normal file
View file

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

2208
eval.c Normal file
View file

File diff suppressed because it is too large Load diff

38
examples/echo-server.scm Normal file
View file

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

59
fedora.spec Normal file
View file

@ -0,0 +1,59 @@
Summary: A small-footprint Scheme for use as a C Extension Language
Name: chibi-scheme
Version: 0.4
Release: 1%{?dist}
Source0: http://chibi-scheme.googlecode.com/files/chibi-scheme-0.4.tgz
Patch1: chibi-scheme.Makefile.patch
Group: Development/Tools
License: BSD
URL: http://code.google.com/p/chibi-scheme/
BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n)
# BuildRequires:
%description
Chibi-Scheme is a very small library intended for use as an extension
and scripting language in C programs. In addition to support for
lightweight VM-based threads, each VM itself runs in an isolated heap
allowing multiple VMs to run simultaneously in different OS threads.
%prep
%setup -q -n %{name}-%{version}
%patch1
%build
%{__make} PREFIX=%{_prefix} DESTDIR=%{RPM_BUILD_ROOT} LIBDIR=%{_libdir} SOLIBDIR=%{_libdir} MODDIR=%{_datarootdir}/chibi-scheme doc all
%install
rm -rf $RPM_BUILD_ROOT
mkdir -p ${RPM_BUILD_ROOT}
%{__make} PREFIX=%{_prefix} DESTDIR=${RPM_BUILD_ROOT} LIBDIR=%{_libdir} SOLIBDIR=%{_libdir} LDFLAGS="-C ${RPM_BUILD_ROOT}%{_sysconfdir}/ld.so.conf.d" MODDIR=%{_datarootdir}/chibi-scheme install
%clean
rm -rf $RPM_BUILD_ROOT
%files
%defattr(-,root,root,-)
%{_bindir}/chibi-scheme
%{_datarootdir}/chibi-scheme
%{_datarootdir}/man
%{_libdir}/libchibi-scheme.so
%package devel
Summary: Development files for the %{name} package.
%description devel
This package contains development and include
files for %{name} package.
%files devel
%defattr(-,root,root,-)
%{_includedir}
%changelog
* Sat May 28 2011 Alex Shinn <alexshinn[AT]gmail.com> - 0.4
* Wed Apr 22 2011 Rajesh Krishnan <devel[AT]krishnan.cc> - 0.3
- Initial release

721
gc.c Normal file
View file

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

68
include/chibi/bignum.h Normal file
View file

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

155
include/chibi/eval.h Normal file
View file

@ -0,0 +1,155 @@
/* eval.h -- headers for eval library */
/* Copyright (c) 2009-2011 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#ifndef SEXP_EVAL_H
#define SEXP_EVAL_H
#ifdef __cplusplus
extern "C" {
#endif
#include "chibi/sexp.h"
/************************* additional types ***************************/
#define sexp_init_file "init-"
#define sexp_init_file_suffix ".scm"
#define sexp_meta_file "meta.scm"
#define sexp_leap_seconds_file "leap.txt"
enum sexp_core_form_names {
SEXP_CORE_DEFINE = 1,
SEXP_CORE_SET,
SEXP_CORE_LAMBDA,
SEXP_CORE_IF,
SEXP_CORE_BEGIN,
SEXP_CORE_QUOTE,
SEXP_CORE_SYNTAX_QUOTE,
SEXP_CORE_DEFINE_SYNTAX,
SEXP_CORE_LET_SYNTAX,
SEXP_CORE_LETREC_SYNTAX
};
enum sexp_opcode_classes {
SEXP_OPC_GENERIC = 1,
SEXP_OPC_TYPE_PREDICATE,
SEXP_OPC_PREDICATE,
SEXP_OPC_ARITHMETIC,
SEXP_OPC_ARITHMETIC_CMP,
SEXP_OPC_IO,
SEXP_OPC_CONSTRUCTOR,
SEXP_OPC_GETTER,
SEXP_OPC_SETTER,
SEXP_OPC_PARAMETER,
SEXP_OPC_FOREIGN,
SEXP_OPC_NUM_OP_CLASSES
};
/**************************** prototypes ******************************/
SEXP_API void sexp_scheme_init (void);
SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env, sexp_uint_t size, sexp_uint_t max_size);
SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda);
SEXP_API sexp sexp_compile_error (sexp ctx, const char *message, sexp obj);
SEXP_API sexp sexp_analyze (sexp context, sexp x);
SEXP_API void sexp_stack_trace (sexp ctx, sexp out);
SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv);
SEXP_API int sexp_param_index (sexp lambda, sexp name);
SEXP_API sexp sexp_compile_op (sexp context, sexp self, sexp_sint_t n, sexp obj, sexp env);
SEXP_API sexp sexp_eval_op (sexp context, sexp self, sexp_sint_t n, sexp obj, sexp env);
SEXP_API sexp sexp_eval_string (sexp context, const char *str, sexp_sint_t len, sexp env);
SEXP_API sexp sexp_load_op (sexp context, sexp self, sexp_sint_t n, sexp expr, sexp env);
SEXP_API sexp sexp_make_env_op (sexp context, sexp self, sexp_sint_t n);
SEXP_API sexp sexp_make_null_env_op (sexp context, sexp self, sexp_sint_t n, sexp version);
SEXP_API sexp sexp_make_primitive_env (sexp context, sexp version);
SEXP_API sexp sexp_make_standard_env_op (sexp context, sexp self, sexp_sint_t n, sexp version);
SEXP_API void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value);
SEXP_API sexp sexp_load_standard_ports (sexp context, sexp env, FILE* in, FILE* out, FILE* err, int no_close);
SEXP_API sexp sexp_load_standard_env (sexp context, sexp env, sexp version);
SEXP_API sexp sexp_find_module_file (sexp ctx, const char *file);
SEXP_API sexp sexp_load_module_file (sexp ctx, const char *file, sexp env);
SEXP_API sexp sexp_add_module_directory_op (sexp ctx, sexp self, sexp_sint_t n, sexp dir, sexp appendp);
SEXP_API sexp sexp_meta_environment (sexp ctx, sexp self, sexp_sint_t n);
SEXP_API sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value);
SEXP_API sexp sexp_env_import_op (sexp ctx, sexp self, sexp_sint_t n, sexp to, sexp from, sexp ls, sexp immutp);
SEXP_API sexp sexp_identifier_op(sexp ctx, sexp self, sexp_sint_t n, sexp x);
SEXP_API sexp sexp_syntactic_closure_expr(sexp ctx, sexp self, sexp_sint_t n, sexp x);
SEXP_API sexp sexp_identifier_eq_op(sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b, sexp c, sexp d);
SEXP_API sexp sexp_open_input_file_op(sexp ctx, sexp self, sexp_sint_t n, sexp x);
SEXP_API sexp sexp_open_output_file_op(sexp ctx, sexp self, sexp_sint_t n, sexp x);
SEXP_API sexp sexp_close_port_op(sexp ctx, sexp self, sexp_sint_t n, sexp x);
SEXP_API sexp sexp_env_define (sexp ctx, sexp env, sexp sym, sexp val);
SEXP_API sexp sexp_env_cell (sexp env, sexp sym, int localp);
SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt);
SEXP_API sexp sexp_parameter_ref (sexp ctx, sexp param);
SEXP_API sexp sexp_warn_undefs_op (sexp ctx, sexp self, sexp_sint_t n, sexp from, sexp to, sexp res);
SEXP_API sexp sexp_make_lit (sexp ctx, sexp value);
SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1);
SEXP_API sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags, sexp num_args, sexp bc, sexp vars);
SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data);
#if SEXP_USE_GREEN_THREADS
SEXP_API sexp sexp_dk (sexp ctx, sexp self, sexp_sint_t n, sexp val);
SEXP_API sexp sexp_thread_parameters (sexp ctx, sexp self, sexp_sint_t n);
SEXP_API sexp sexp_thread_parameters_set (sexp ctx, sexp self, sexp_sint_t n, sexp val);
#endif
#if SEXP_USE_UTF8_STRINGS
SEXP_API int sexp_utf8_initial_byte_count (int c);
SEXP_API int sexp_utf8_char_byte_count (int c);
SEXP_API int sexp_string_utf8_length (unsigned char *p, int len);
SEXP_API char* sexp_string_utf8_prev (unsigned char *p);
SEXP_API sexp sexp_string_utf8_ref (sexp ctx, sexp str, sexp i);
#endif
#if SEXP_USE_NATIVE_X86
SEXP_API sexp sexp_write_char_op(sexp ctx, sexp self, sexp_sint_t n, sexp ch, sexp out);
SEXP_API sexp sexp_newline_op(sexp ctx, sexp self, sexp_sint_t n, sexp out);
SEXP_API sexp sexp_read_char_op(sexp ctx, sexp self, sexp_sint_t n, sexp in);
SEXP_API sexp sexp_peek_char_op(sexp ctx, sexp self, sexp_sint_t n, sexp in);
SEXP_API sexp sexp_exact_to_inexact(sexp ctx, sexp self, sexp_sint_t n, sexp i);
SEXP_API sexp sexp_inexact_to_exact(sexp ctx, sexp self, sexp_sint_t n, sexp x);
SEXP_API sexp sexp_char_upcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch);
SEXP_API sexp sexp_char_downcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch);
#endif
#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(sexp_proc1)f,NULL)
#define sexp_define_foreign_opt(c,e,s,n,f,d) sexp_define_foreign_aux(c,e,s,n,1,(sexp_proc1)f,d)
SEXP_API sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_args, sexp_proc1 f, const char *param);
#define sexp_env_key(x) sexp_car(x)
#define sexp_env_value(x) sexp_cdr(x)
#define sexp_env_next_cell(x) sexp_pair_source(x)
#define sexp_env_push(ctx, env, tmp, name, value) (tmp=sexp_cons(ctx,name,value), sexp_env_next_cell(tmp)=sexp_env_bindings(env), sexp_env_bindings(env)=tmp)
#define sexp_env_push_rename(ctx, env, tmp, name, value) (tmp=sexp_cons(ctx,name,value), sexp_env_next_cell(tmp)=sexp_env_renames(env), sexp_env_renames(env)=tmp)
#if SEXP_USE_TYPE_DEFS
SEXP_API sexp sexp_make_type_predicate_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type);
SEXP_API sexp sexp_make_constructor_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type);
SEXP_API sexp sexp_make_getter_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type, sexp index);
SEXP_API sexp sexp_make_setter_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type, sexp index);
#endif
/* simplify primitive API interface */
#define sexp_make_synclo(ctx, a, b, c) sexp_make_synclo_op(ctx, NULL, 3, a, b, c)
#define sexp_make_procedure(ctx, f, n, b, v) sexp_make_procedure_op(ctx, NULL, 4, f, n, b, v)
#define sexp_make_env(ctx) sexp_make_env_op(ctx, NULL, 0)
#define sexp_make_null_env(ctx, v) sexp_make_null_env_op(ctx, NULL, 0, v)
#define sexp_make_standard_env(ctx) sexp_make_standard_env_op(ctx, NULL, 0)
#define sexp_add_module_directory(ctx, d, a) sexp_add_module_directory_op(ctx, NULL, 1, d, a)
#define sexp_eval(ctx, x, e) sexp_eval_op(ctx, NULL, 2, x, e)
#define sexp_load(ctx, f, e) sexp_load_op(ctx, NULL, 2, f, e)
#define sexp_env_import(ctx, a, b, c, d) sexp_env_import_op(ctx, NULL, 4, a, b, c, d)
#define sexp_identifierp(ctx, x) sexp_identifierp_op(ctx, NULL, 1, x)
#define sexp_identifier_to_symbol(ctx, x) sexp_syntactic_closure_expr(ctx, NULL, 1, x)
#define sexp_identifier_eq(ctx, a, b, c, d) sexp_identifier_eq_op(ctx, NULL, 4, a, b, c, d)
#define sexp_open_input_file(ctx, x) sexp_open_input_file_op(ctx, NULL, 1, x)
#define sexp_open_output_file(ctx, x) sexp_open_output_file_op(ctx, NULL, 1, x)
#define sexp_close_port(ctx, x) sexp_close_port_op(ctx, NULL, 1, x)
#define sexp_warn_undefs(ctx, from, to, res) sexp_warn_undefs_op(ctx, NULL, 3, from, to, res)
#ifdef __cplusplus
} /* extern "C" */
#endif
#endif /* ! SEXP_EVAL_H */

740
include/chibi/features.h Normal file
View file

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

1541
include/chibi/sexp.h Executable file
View file

File diff suppressed because it is too large Load diff

41
lib/chibi/accept.c Normal file
View file

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

494
lib/chibi/ast.c Normal file
View file

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

377
lib/chibi/ast.scm Normal file
View file

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

40
lib/chibi/ast.sld Normal file
View file

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

351
lib/chibi/base64.scm Normal file
View file

@ -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))
"?=")))))

7
lib/chibi/base64.sld Normal file
View file

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

44
lib/chibi/channel.scm Normal file
View file

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

6
lib/chibi/channel.sld Normal file
View file

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

202
lib/chibi/disasm.c Normal file
View file

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

10
lib/chibi/disasm.sld Normal file
View file

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

49
lib/chibi/equiv.scm Normal file
View file

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

6
lib/chibi/equiv.sld Normal file
View file

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

68
lib/chibi/filesystem.scm Normal file
View file

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

32
lib/chibi/filesystem.sld Normal file
View file

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

190
lib/chibi/filesystem.stub Normal file
View file

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

93
lib/chibi/generic.scm Normal file
View file

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

7
lib/chibi/generic.sld Normal file
View file

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

137
lib/chibi/heap-stats.c Normal file
View file

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

24
lib/chibi/heap-stats.sld Normal file
View file

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

453
lib/chibi/highlight.scm Normal file
View file

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

6
lib/chibi/highlight.sld Normal file
View file

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

17
lib/chibi/io.sld Normal file
View file

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

269
lib/chibi/io/io.scm Normal file
View file

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

48
lib/chibi/io/io.stub Normal file
View file

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

358
lib/chibi/io/port.c Normal file
View file

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

9
lib/chibi/loop.sld Normal file
View file

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

417
lib/chibi/loop/loop.scm Normal file
View file

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

6
lib/chibi/match.sld Normal file
View file

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

906
lib/chibi/match/match.scm Normal file
View file

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

401
lib/chibi/mime.scm Normal file
View file

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

7
lib/chibi/mime.sld Normal file
View file

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

143
lib/chibi/modules.scm Normal file
View file

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

8
lib/chibi/modules.sld Normal file
View file

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

101
lib/chibi/net.scm Normal file
View file

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

18
lib/chibi/net.sld Normal file
View file

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

89
lib/chibi/net.stub Normal file
View file

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

180
lib/chibi/net/http.scm Normal file
View file

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

7
lib/chibi/net/http.sld Normal file
View file

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

62
lib/chibi/net/server.scm Normal file
View file

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

5
lib/chibi/net/server.sld Normal file
View file

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

52
lib/chibi/optimize.scm Normal file
View file

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

7
lib/chibi/optimize.sld Normal file
View file

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

19
lib/chibi/optimize/profile.c Normal file
View file

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

65
lib/chibi/optimize/profile.scm Normal file
View file

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

7
lib/chibi/optimize/profile.sld Normal file
View file

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

35
lib/chibi/optimize/rest.c Normal file
View file

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

126
lib/chibi/optimize/rest.scm Normal file
View file

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

6
lib/chibi/optimize/rest.sld Normal file
View file

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

212
lib/chibi/pathname.scm Normal file
View file

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

7
lib/chibi/pathname.sld Normal file
View file

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

108
lib/chibi/process.scm Normal file
View file

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

22
lib/chibi/process.sld Normal file
View file

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

141
lib/chibi/process.stub Normal file
View file

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

157
lib/chibi/quoted-printable.scm Normal file
View file

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

7
lib/chibi/quoted-printable.sld Normal file
View file

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

237
lib/chibi/repl.scm Normal file
View file

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

7
lib/chibi/repl.sld Normal file
View file

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

250
lib/chibi/scribble.scm Normal file
View file

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

5
lib/chibi/scribble.sld Normal file
View file

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

124
lib/chibi/signal.c Normal file
View file

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

154
lib/chibi/strings.scm Normal file
View file

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

15
lib/chibi/strings.sld Normal file
View file

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

263
lib/chibi/stty.scm Normal file
View file

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

8
lib/chibi/stty.sld Normal file
View file

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

106
lib/chibi/stty.stub Normal file
View file

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

15
lib/chibi/system.sld Normal file
View file

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

60
lib/chibi/system.stub Normal file
View file

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

666
lib/chibi/term/edit-line.scm Normal file
View file

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

8
lib/chibi/term/edit-line.sld Normal file
View file

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

Some files were not shown because too many files have changed in this diff Show more