From bddaed32955b7f841c3bb93ee1a1f2f2bb1bc546 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 17 Aug 2010 20:46:12 +0900 Subject: [PATCH] removing redundant sexp_heap_align definition --- .hgignore | 30 + AUTHORS | 29 + COPYING | 24 + Makefile | 246 ++++ README | 440 ++++++ RELEASE | 1 + TODO | 165 +++ VERSION | 1 + chibi-scheme.vcproj | 206 +++ doc/chibi-scheme.1 | 133 ++ eval.c | 1758 ++++++++++++++++++++++ gc.c | 346 +++++ include/chibi/bignum.h | 43 + include/chibi/eval.h | 203 +++ include/chibi/features.h | 469 ++++++ include/chibi/sexp.h | 1065 ++++++++++++++ lib/chibi/ast.c | 248 ++++ lib/chibi/ast.module | 33 + lib/chibi/ast.scm | 91 ++ lib/chibi/base64.module | 7 + lib/chibi/base64.scm | 351 +++++ lib/chibi/disasm.c | 99 ++ lib/chibi/disasm.module | 5 + lib/chibi/filesystem.module | 27 + lib/chibi/filesystem.scm | 43 + lib/chibi/filesystem.stub | 118 ++ lib/chibi/heap-stats.c | 120 ++ lib/chibi/heap-stats.module | 6 + lib/chibi/io.module | 13 + lib/chibi/io/io.scm | 170 +++ lib/chibi/io/io.stub | 27 + lib/chibi/io/port.c | 201 +++ lib/chibi/loop.module | 9 + lib/chibi/loop/loop.scm | 365 +++++ lib/chibi/match.module | 6 + lib/chibi/match/match.scm | 683 +++++++++ lib/chibi/mime.module | 7 + lib/chibi/mime.scm | 410 ++++++ lib/chibi/modules.module | 8 + lib/chibi/modules.scm | 103 ++ lib/chibi/net.module | 11 + lib/chibi/net.scm | 32 + lib/chibi/net.stub | 25 + lib/chibi/net/http.module | 7 + lib/chibi/net/http.scm | 180 +++ lib/chibi/pathname.module | 7 + lib/chibi/pathname.scm | 180 +++ lib/chibi/process.module | 18 + lib/chibi/process.stub | 73 + lib/chibi/quoted-printable.module | 7 + lib/chibi/quoted-printable.scm | 157 ++ lib/chibi/repl.module | 9 + lib/chibi/repl.scm | 41 + lib/chibi/scribble.module | 5 + lib/chibi/scribble.scm | 247 ++++ lib/chibi/signal.c | 76 + lib/chibi/stty.module | 11 + lib/chibi/stty.scm | 235 +++ lib/chibi/stty.stub | 106 ++ lib/chibi/system.module | 15 + lib/chibi/system.stub | 34 + lib/chibi/term/edit-line.module | 5 + lib/chibi/term/edit-line.scm | 505 +++++++ lib/chibi/test.module | 14 + lib/chibi/test.scm | 662 +++++++++ lib/chibi/time.module | 12 + lib/chibi/time.stub | 46 + lib/chibi/type-inference.module | 7 + lib/chibi/type-inference.scm | 272 ++++ lib/chibi/uri.module | 10 + lib/chibi/uri.scm | 306 ++++ lib/config.scm | 179 +++ lib/init.scm | 875 +++++++++++ lib/srfi/1.module | 31 + lib/srfi/1/alists.scm | 14 + lib/srfi/1/constructors.scm | 36 + lib/srfi/1/deletion.scm | 25 + lib/srfi/1/fold.scm | 115 ++ lib/srfi/1/lset.scm | 51 + lib/srfi/1/misc.scm | 54 + lib/srfi/1/predicates.scm | 42 + lib/srfi/1/search.scm | 54 + lib/srfi/1/selectors.scm | 59 + lib/srfi/11.module | 28 + lib/srfi/16.module | 24 + lib/srfi/18.module | 24 + lib/srfi/18/interface.scm | 63 + lib/srfi/18/threads.c | 421 ++++++ lib/srfi/18/types.scm | 24 + lib/srfi/2.module | 16 + lib/srfi/26.module | 24 + lib/srfi/27.module | 11 + lib/srfi/27/constructors.scm | 10 + lib/srfi/27/rand.c | 204 +++ lib/srfi/33.module | 17 + lib/srfi/33/bit.c | 303 ++++ lib/srfi/33/bitwise.scm | 61 + lib/srfi/38.module | 6 + lib/srfi/38.scm | 255 ++++ lib/srfi/39.module | 25 + lib/srfi/6.module | 5 + lib/srfi/69.module | 17 + lib/srfi/69/hash.c | 242 ++++ lib/srfi/69/interface.scm | 115 ++ lib/srfi/69/type.scm | 12 + lib/srfi/8.module | 10 + lib/srfi/9.module | 90 ++ lib/srfi/95.module | 7 + lib/srfi/95/qsort.c | 228 +++ lib/srfi/95/sort.scm | 70 + lib/srfi/98.module | 5 + lib/srfi/98/env.c | 48 + main.c | 219 +++ mkfile | 28 + opcodes.c | 178 +++ opt/bignum.c | 775 ++++++++++ opt/fcall.c | 33 + opt/opcode_names.h | 21 + opt/plan9-opcodes.c | 19 + opt/plan9.c | 351 +++++ opt/sexp-huff.c | 128 ++ opt/sexp-hufftabs.c | 92 ++ opt/sexp-unhuff.c | 71 + opt/simplify.c | 143 ++ sexp.c | 1842 ++++++++++++++++++++++++ tests/basic/test00-fact-3.res | 1 + tests/basic/test00-fact-3.scm | 14 + tests/basic/test01-apply.res | 8 + tests/basic/test01-apply.scm | 18 + tests/basic/test02-closure.res | 6 + tests/basic/test02-closure.scm | 16 + tests/basic/test03-nested-closure.res | 1 + tests/basic/test03-nested-closure.scm | 8 + tests/basic/test04-nested-let.res | 1 + tests/basic/test04-nested-let.scm | 9 + tests/basic/test05-internal-define.res | 1 + tests/basic/test05-internal-define.scm | 8 + tests/basic/test06-letrec.res | 4 + tests/basic/test06-letrec.scm | 15 + tests/basic/test07-mutation.res | 1 + tests/basic/test07-mutation.scm | 9 + tests/basic/test08-callcc.res | 1 + tests/basic/test08-callcc.scm | 34 + tests/basic/test09-hygiene.res | 7 + tests/basic/test09-hygiene.scm | 48 + tests/basic/test10-unhygiene.res | 6 + tests/basic/test10-unhygiene.scm | 49 + tests/build/build-opts.txt | 21 + tests/build/build-tests.sh | 37 + tests/flonum-tests.scm | 21 + tests/hash-tests.scm | 37 + tests/install/install-tests.pl | 57 + tests/install/run-install-test.sh | 12 + tests/lib-tests.scm | 13 + tests/loop-tests.scm | 168 +++ tests/match-tests.scm | 135 ++ tests/numeric-tests.scm | 120 ++ tests/r5rs-tests.scm | 465 ++++++ tests/sort-tests.scm | 40 + tests/thread-tests.scm | 25 + tools/genstatic.scm | 135 ++ tools/genstubs.scm | 1280 ++++++++++++++++ vm.c | 1391 ++++++++++++++++++ 163 files changed, 23646 insertions(+) create mode 100644 .hgignore create mode 100644 AUTHORS create mode 100644 COPYING create mode 100644 Makefile create mode 100644 README create mode 100644 RELEASE create mode 100644 TODO create mode 100644 VERSION create mode 100644 chibi-scheme.vcproj create mode 100644 doc/chibi-scheme.1 create mode 100644 eval.c create mode 100644 gc.c create mode 100644 include/chibi/bignum.h create mode 100644 include/chibi/eval.h create mode 100644 include/chibi/features.h create mode 100644 include/chibi/sexp.h create mode 100644 lib/chibi/ast.c create mode 100644 lib/chibi/ast.module create mode 100644 lib/chibi/ast.scm create mode 100644 lib/chibi/base64.module create mode 100644 lib/chibi/base64.scm create mode 100644 lib/chibi/disasm.c create mode 100644 lib/chibi/disasm.module create mode 100644 lib/chibi/filesystem.module create mode 100644 lib/chibi/filesystem.scm create mode 100644 lib/chibi/filesystem.stub create mode 100644 lib/chibi/heap-stats.c create mode 100644 lib/chibi/heap-stats.module create mode 100644 lib/chibi/io.module create mode 100644 lib/chibi/io/io.scm create mode 100644 lib/chibi/io/io.stub create mode 100644 lib/chibi/io/port.c create mode 100644 lib/chibi/loop.module create mode 100644 lib/chibi/loop/loop.scm create mode 100644 lib/chibi/match.module create mode 100644 lib/chibi/match/match.scm create mode 100644 lib/chibi/mime.module create mode 100644 lib/chibi/mime.scm create mode 100644 lib/chibi/modules.module create mode 100644 lib/chibi/modules.scm create mode 100644 lib/chibi/net.module create mode 100644 lib/chibi/net.scm create mode 100644 lib/chibi/net.stub create mode 100644 lib/chibi/net/http.module create mode 100644 lib/chibi/net/http.scm create mode 100644 lib/chibi/pathname.module create mode 100644 lib/chibi/pathname.scm create mode 100644 lib/chibi/process.module create mode 100644 lib/chibi/process.stub create mode 100644 lib/chibi/quoted-printable.module create mode 100644 lib/chibi/quoted-printable.scm create mode 100644 lib/chibi/repl.module create mode 100644 lib/chibi/repl.scm create mode 100644 lib/chibi/scribble.module create mode 100644 lib/chibi/scribble.scm create mode 100644 lib/chibi/signal.c create mode 100644 lib/chibi/stty.module create mode 100644 lib/chibi/stty.scm create mode 100644 lib/chibi/stty.stub create mode 100644 lib/chibi/system.module create mode 100644 lib/chibi/system.stub create mode 100644 lib/chibi/term/edit-line.module create mode 100644 lib/chibi/term/edit-line.scm create mode 100644 lib/chibi/test.module create mode 100644 lib/chibi/test.scm create mode 100644 lib/chibi/time.module create mode 100644 lib/chibi/time.stub create mode 100644 lib/chibi/type-inference.module create mode 100644 lib/chibi/type-inference.scm create mode 100644 lib/chibi/uri.module create mode 100644 lib/chibi/uri.scm create mode 100644 lib/config.scm create mode 100644 lib/init.scm create mode 100644 lib/srfi/1.module create mode 100644 lib/srfi/1/alists.scm create mode 100644 lib/srfi/1/constructors.scm create mode 100644 lib/srfi/1/deletion.scm create mode 100644 lib/srfi/1/fold.scm create mode 100644 lib/srfi/1/lset.scm create mode 100644 lib/srfi/1/misc.scm create mode 100644 lib/srfi/1/predicates.scm create mode 100644 lib/srfi/1/search.scm create mode 100644 lib/srfi/1/selectors.scm create mode 100644 lib/srfi/11.module create mode 100644 lib/srfi/16.module create mode 100644 lib/srfi/18.module create mode 100644 lib/srfi/18/interface.scm create mode 100644 lib/srfi/18/threads.c create mode 100644 lib/srfi/18/types.scm create mode 100644 lib/srfi/2.module create mode 100644 lib/srfi/26.module create mode 100644 lib/srfi/27.module create mode 100644 lib/srfi/27/constructors.scm create mode 100644 lib/srfi/27/rand.c create mode 100644 lib/srfi/33.module create mode 100644 lib/srfi/33/bit.c create mode 100644 lib/srfi/33/bitwise.scm create mode 100644 lib/srfi/38.module create mode 100644 lib/srfi/38.scm create mode 100644 lib/srfi/39.module create mode 100644 lib/srfi/6.module create mode 100644 lib/srfi/69.module create mode 100644 lib/srfi/69/hash.c create mode 100644 lib/srfi/69/interface.scm create mode 100644 lib/srfi/69/type.scm create mode 100644 lib/srfi/8.module create mode 100644 lib/srfi/9.module create mode 100644 lib/srfi/95.module create mode 100644 lib/srfi/95/qsort.c create mode 100644 lib/srfi/95/sort.scm create mode 100644 lib/srfi/98.module create mode 100644 lib/srfi/98/env.c create mode 100644 main.c create mode 100644 mkfile create mode 100644 opcodes.c create mode 100644 opt/bignum.c create mode 100644 opt/fcall.c create mode 100644 opt/opcode_names.h create mode 100644 opt/plan9-opcodes.c create mode 100644 opt/plan9.c create mode 100644 opt/sexp-huff.c create mode 100644 opt/sexp-hufftabs.c create mode 100644 opt/sexp-unhuff.c create mode 100644 opt/simplify.c create mode 100644 sexp.c create mode 100644 tests/basic/test00-fact-3.res create mode 100644 tests/basic/test00-fact-3.scm create mode 100644 tests/basic/test01-apply.res create mode 100644 tests/basic/test01-apply.scm create mode 100644 tests/basic/test02-closure.res create mode 100644 tests/basic/test02-closure.scm create mode 100644 tests/basic/test03-nested-closure.res create mode 100644 tests/basic/test03-nested-closure.scm create mode 100644 tests/basic/test04-nested-let.res create mode 100644 tests/basic/test04-nested-let.scm create mode 100644 tests/basic/test05-internal-define.res create mode 100644 tests/basic/test05-internal-define.scm create mode 100644 tests/basic/test06-letrec.res create mode 100644 tests/basic/test06-letrec.scm create mode 100644 tests/basic/test07-mutation.res create mode 100644 tests/basic/test07-mutation.scm create mode 100644 tests/basic/test08-callcc.res create mode 100644 tests/basic/test08-callcc.scm create mode 100644 tests/basic/test09-hygiene.res create mode 100644 tests/basic/test09-hygiene.scm create mode 100644 tests/basic/test10-unhygiene.res create mode 100644 tests/basic/test10-unhygiene.scm create mode 100644 tests/build/build-opts.txt create mode 100755 tests/build/build-tests.sh create mode 100644 tests/flonum-tests.scm create mode 100644 tests/hash-tests.scm create mode 100755 tests/install/install-tests.pl create mode 100755 tests/install/run-install-test.sh create mode 100644 tests/lib-tests.scm create mode 100644 tests/loop-tests.scm create mode 100644 tests/match-tests.scm create mode 100644 tests/numeric-tests.scm create mode 100644 tests/r5rs-tests.scm create mode 100644 tests/sort-tests.scm create mode 100644 tests/thread-tests.scm create mode 100755 tools/genstatic.scm create mode 100755 tools/genstubs.scm create mode 100644 vm.c diff --git a/.hgignore b/.hgignore new file mode 100644 index 00000000..e8b8b309 --- /dev/null +++ b/.hgignore @@ -0,0 +1,30 @@ +syntax: glob +*~ +*.i +*.s +*.o +*.so +*.dylib +*.class +*.dSYM +*.orig +.hg +junk* +*.tar.gz +*.tar.bz2 +*.log +*.err +*.out +gc +gc6.8 +clibs.c +chibi-scheme +chibi-scheme-static +include/chibi/install.h +lib/chibi/filesystem.c +lib/chibi/io/io.c +lib/chibi/net.c +lib/chibi/process.c +lib/chibi/system.c +lib/chibi/time.c +lib/chibi/stty.c diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 00000000..fc0b8224 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,29 @@ +Alex Shinn wrote the initial version of chibi-scheme and all +distributed modules. + +The `dynamic-wind' implementation is adapted from the implementation +in the appendix to the Scheme48 reference manual, reportedly first +written by Chris Hanson and John Lamping. + +Thanks to the following people for patches and bug reports: + + * Alexander Shendi + * Andreas Rottman + * Bruno Deferrari + * Derrick Eddington + * Eduardo Cavazos + * Felix Winkelmann + * Gregor Klinke + * Jeremy Wolff + * Jeronimo Pellegrini + * John Cowan + * John Samsa + * Lars J Aas + * Lorenzo Campedelli + * Michal Kowalski (sladegen) + * Taylor Venable + +If you would prefer not to be listed, or are one of the users listed +without a full name, please contact me. If you've made a contribution +and are not listed, please accept my apologies and contact me +immediately! diff --git a/COPYING b/COPYING new file mode 100644 index 00000000..1fcee28e --- /dev/null +++ b/COPYING @@ -0,0 +1,24 @@ +Copyright (c) 2009 Alex Shinn +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The name of the author may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..131a73d2 --- /dev/null +++ b/Makefile @@ -0,0 +1,246 @@ +# -*- makefile-gmake -*- + +.PHONY: all libs doc dist clean cleaner dist-clean test install uninstall +.PRECIOUS: %.c + +# install configuration + +CC ?= cc +PREFIX ?= /usr/local +BINDIR ?= $(PREFIX)/bin +LIBDIR ?= $(PREFIX)/lib +SOLIBDIR ?= $(PREFIX)/lib +INCDIR ?= $(PREFIX)/include/chibi +MODDIR ?= $(PREFIX)/share/chibi +LIBDIR ?= $(PREFIX)/lib/chibi +MANDIR ?= $(PREFIX)/share/man/man1 + +DESTDIR ?= + +GENSTUBS ?= ./tools/genstubs.scm +GENSTATIC ?= ./tools/genstatic.scm + +######################################################################## +# system configuration - if not using GNU make, set PLATFORM and the +# following flags as necessary. + +# +LIBDL = -ldl + +ifndef PLATFORM +ifeq ($(shell uname),Darwin) +PLATFORM=macosx +else +ifeq ($(shell uname -o),Msys) +PLATFORM=mingw +SOLIBDIR = $(BINDIR) +DIFFOPTS = -b +else +ifeq ($(shell uname -o),Cygwin) +PLATFORM=cygwin +SOLIBDIR = $(BINDIR) +DIFFOPTS = -b +else +PLATFORM=unix +endif +endif +endif +endif + +ifeq ($(PLATFORM),macosx) +SO = .dylib +EXE = +CLIBFLAGS = -dynamiclib +STATICFLAGS = -static-libgcc -DSEXP_USE_DL=0 +else +ifeq ($(PLATFORM),mingw) +SO = .dll +EXE = .exe +CC = gcc +CLIBFLAGS = -shared +CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL +LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a +STATICFLAGS = -DSEXP_USE_DL=0 +LIBDL = +else +ifeq ($(PLATFORM),cygwin) +SO = .dll +EXE = .exe +CC = gcc +CLIBFLAGS = -shared +CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 +LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a +else +SO = .so +EXE = +CLIBFLAGS = -fPIC -shared +STATICFLAGS = -static -DSEXP_USE_DL=0 +endif +endif +endif + +ifeq ($(USE_BOEHM),1) +SEXP_USE_BOEHM = 1 +endif + +ifeq ($(SEXP_USE_BOEHM),1) +GCLDFLAGS := -lgc +XCPPFLAGS := $(CPPFLAGS) -Iinclude -DSEXP_USE_BOEHM=1 +else +GCLDFLAGS := +XCPPFLAGS := $(CPPFLAGS) -Iinclude +endif + +ifeq ($(SEXP_USE_DL),0) +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm +XCFLAGS := -Wall -DSEXP_USE_DL=0 -g3 $(CFLAGS) +else +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) $(LIBDL) -lm +XCFLAGS := -Wall -g3 $(CFLAGS) +endif + +######################################################################## + +all: chibi-scheme$(EXE) libs + +COMPILED_LIBS := lib/srfi/18/threads$(SO) lib/srfi/27/rand$(SO) \ + lib/srfi/33/bit$(SO) lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) \ + lib/srfi/98/env$(SO) lib/chibi/ast$(SO) lib/chibi/net$(SO) \ + lib/chibi/filesystem$(SO) lib/chibi/process$(SO) lib/chibi/time$(SO) \ + lib/chibi/system$(SO) lib/chibi/io/io$(SO) lib/chibi/stty$(SO) \ + lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) + +libs: $(COMPILED_LIBS) + +INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h include/chibi/bignum.h + +include/chibi/install.h: Makefile + echo '#define sexp_so_extension "'$(SO)'"' > $@ + echo '#define sexp_default_module_dir "'$(MODDIR)'"' >> $@ + echo '#define sexp_platform "'$(PLATFORM)'"' >> $@ + echo '#define sexp_version "'`cat VERSION`'"' >> $@ + echo '#define sexp_release_name "'`cat RELEASE`'"' >> $@ + +sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +eval.o: eval.c opcodes.c vm.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +main.o: main.c $(INCLUDES) include/chibi/eval.h Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $< + +libchibi-sexp$(SO): sexp.o + $(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS) + +libchibi-scheme$(SO): eval.o sexp.o + $(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS) + +chibi-scheme$(EXE): main.o libchibi-scheme$(SO) + $(CC) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme + +chibi-scheme-static$(EXE): main.o eval.o sexp.o + $(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) -lm + +clibs.c: $(GENSTATIC) lib lib/chibi lib/srfi + make chibi-scheme$(EXE) + make libs + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" PATH=".:$(PATH)" $(GENSTATIC) $< > $@ + +%.c: %.stub $(GENSTUBS) + make chibi-scheme$(EXE) + -LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" PATH=".:$(PATH)" $(GENSTUBS) $< + +lib/%$(SO): lib/%.c $(INCLUDES) + -$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme + +clean: + rm -f *.o *.i *.s *.8 + find lib -name \*$(SO) -exec rm -f '{}' \; + rm -f tests/basic/*.out tests/basic/*.err + +cleaner: clean + rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) $(COMPILED_LIBS) *$(SO) *.a include/chibi/install.h + rm -rf *.dSYM + +dist-clean: cleaner + for f in `find lib -name \*.stub`; do rm -f $${f%.stub}.c; done + +test-basic: chibi-scheme$(EXE) + @for f in tests/basic/*.scm; do \ + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ + if diff -q $(DIFFOPTS) $${f%.scm}.out $${f%.scm}.res; then \ + echo "[PASS] $${f%.scm}"; \ + else \ + echo "[FAIL] $${f%.scm}"; \ + fi; \ + done + +test-build: + ./tests/build/build-tests.sh + +test-threads: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/thread-tests.scm + +test-numbers: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/numeric-tests.scm + +test-flonums: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/flonum-tests.scm + +test-hash: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/hash-tests.scm + +test-match: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/match-tests.scm + +test-loop: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/loop-tests.scm + +test-sort: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/sort-tests.scm + +test-libs: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/lib-tests.scm + +test: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/r5rs-tests.scm + +install: chibi-scheme$(EXE) + mkdir -p $(DESTDIR)$(BINDIR) + cp chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/ + cp tools/genstubs.scm $(DESTDIR)$(BINDIR)/ + mkdir -p $(DESTDIR)$(MODDIR) + cp -r lib/* $(DESTDIR)$(MODDIR)/ + mkdir -p $(DESTDIR)$(INCDIR) + cp $(INCLUDES) include/chibi/eval.h $(DESTDIR)$(INCDIR)/ + mkdir -p $(DESTDIR)$(LIBDIR) + mkdir -p $(DESTDIR)$(SOLIBDIR) + cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ + cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ + -cp libchibi-scheme.a $(DESTDIR)$(LIBDIR)/ + mkdir -p $(DESTDIR)$(MANDIR) + cp doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/ + -if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi + +uninstall: + rm -f $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE) + rm -f $(DESTDIR)$(BINDIR)/chibi-scheme-static$(EXE) + rm -f $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO) + rm -f $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a + cd $(DESTDIR)$(INCDIR) && rm -f $(INCLUDES) include/chibi/eval.h + rm -rf $(DESTDIR)$(MODDIR) + +dist: dist-clean + rm -f chibi-scheme-`cat VERSION`.tgz + mkdir chibi-scheme-`cat VERSION` + for f in `hg manifest`; do mkdir -p chibi-scheme-`cat VERSION`/`dirname $$f`; ln -s `pwd`/$$f chibi-scheme-`cat VERSION`/$$f; done + tar cphzvf chibi-scheme-`cat VERSION`.tgz chibi-scheme-`cat VERSION` + rm -rf chibi-scheme-`cat VERSION` + +mips-dist: dist-clean + rm -f chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz + mkdir chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'` + for f in `hg manifest`; do mkdir -p chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/`dirname $$f`; ln -s `pwd`/$$f chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/$$f; done + tar cphzvf chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'` + rm -rf chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'` diff --git a/README b/README new file mode 100644 index 00000000..6e5b00a6 --- /dev/null +++ b/README @@ -0,0 +1,440 @@ + + Chibi-Scheme + -------------- + + Minimal Scheme Implementation for use as an Extension Language + + http://synthcode.com/wiki/chibi-scheme/ + + +Chibi-Scheme is a very small but mostly complete R5RS Scheme +implementation using a reasonably fast custom VM. Chibi-Scheme tries +as much as possible not to trade its small size by cutting corners, +and provides full continuations, both low and high-level hygienic +macros based on syntactic-closures, string ports and exceptions. +Chibi-Scheme is written in highly portable C and supports multiple +simultaneous VM instances to run. + +------------------------------------------------------------------------ +INSTALLING + +To build, just run "make". This will provide a shared library +"libchibi-scheme", as well as a sample "chibi-scheme" command-line +repl. The "chibi-scheme-static" make target builds an equivalent +static executable. + +You can edit the file chibi/features.h for a number of settings, +mostly disabling features to make the executable smaller. You can +specify standard options directly as arguments to make, for example + + make CFLAGS=-Os CPPFLAGS=-DSEXP_USE_NO_FEATURES=1 + +to optimize for size, or + + make LDFLAGS=-L/usr/local/lib CPPFLAGS=-I/usr/local/include + +to compile against a library installed in /usr/local. + +By default Chibi uses a custom, precise, non-moving GC. You can link +against the Boehm conservative GC by editing the features.h file, or +directly from make with: + + make SEXP_USE_BOEHM=1 + +To compile a static executable, use + + make chibi-scheme-static SEXP_USE_DL=0 + +To compile a static executable with all C libraries statically +included, first you need to create a clibs.c file, which can be done +with: + + make clibs.c + +or edited manually. Be sure to run this with a non-static +chibi-scheme. Then you can make the static executable with: + + make cleaner + make chibi-scheme-static SEXP_USE_DL=0 CPPFLAGS=-DSEXP_USE_STATIC_LIBS + +------------------------------------------------------------------------ +CHIBI-SCHEME LANGUAGE + +The default language is mostly compatible with the R5RS, with all +differences made by design, not through difficulty of implementation. +The following procedures are omitted: + + transcript-on and transcript-off (because they're silly) + rationalize (pending the addition of rational numbers) + +Apart from this, chibi-scheme is case-sensitive, unlike the R5RS. +The default configuration includes fixnums, flonums and bignums +but no exact rationals or complex numbers. + +Full continuations are supported, but currently continuations don't +take C code into account. The only higher-order C functions in the +standard environment are LOAD and EVAL. + +LOAD is extended to accept an optional environment argument, like +EVAL. You can also LOAD shared libraries in addition to Scheme source +files - in this case the function sexp_init_library is automatically +called with the following signature: + + sexp_init_library(sexp context, sexp environment) + +SYNTAX-RULES macros are provided by default, with the extensions from +SRFI-46. In addition, low-level hygienic macros are provided with +a syntactic-closures interface, including SC-MACRO-TRANSFORMER, +RSC-MACRO-TRANSFORMER, and ER-MACRO-TRANSFORMER. A good introduction +to syntactic-closures can be found at: + + http://community.schemewiki.org/?syntactic-closures + +IDENTIFIER?, IDENTIFIER->SYMBOL, IDENTIFIER=?, and +MAKE-SYNTACTIC-CLOSURE and STRIP-SYNTACTIC-CLOSURES are provided. + +SRFI-0's COND-EXPAND is provided, with the feature `chibi'. + +STRING-CONCATENATE concatenates a list of strings. + +------------------------------------------------------------------------ +TYPES + +You can define new data types with SRFI-9. This is just syntactic +sugar for the following more primitive type constructors: + +(register-simple-type ) + => ; a fixnum + +(make-type-predicate ) + => ; takes 1 arg, returns #t iff that arg is of the type + +(make-constructor ) + => ; takes 0 args, returns a newly allocated instance of type + +(make-getter ) + => ; takes 1 args, retrieves the field located at the index + +(make-setter ) + => ; takes 2 args, sets the field located at the index + +------------------------------------------------------------------------ +MODULE SYSTEM + +A configurable module system, in the style of the Scheme48 module +system, is provided by default. + +Modules names are hierarchical lists of symbols or numbers. The +definition of the module (foo bar baz) is searched for in the file +foo/bar/baz.module. This file should contain an expression of the +form: + + (define-module (foo bar baz) + ...) + +where can be any of + + (export ...) - specify an export list + (import ...) - specify one or more imports + (import-immutable ...) - specify an immutable import + (body ...) - inline Scheme code + (include ...) - load one or more files + (include-shared ...) - dynamic load a library + + can either be a module name or any of + + (only ...) + (except ...) + (rename ( ) ...) + (prefix ) + +The can be composed and perform basic selection and renaming of +individual identifiers from the given module. + +Files are loaded relative to the .module file, and are written with +their extension (so you can use whatever suffix you prefer - .scm, +.ss, .sls, etc.). + +Shared modules, on the other hand, should be specified _without_ the +extension - the correct suffix will be added portably (e.g. .so for +Unix and .dylib for OS X). + +You may also use COND-EXPAND and arbitrary macro expansions in a +module definition to generate . + +------------------------------------------------------------------------ +MODULES + +The default environment is (scheme) - you almost always want to import +this. + +Currently you can load the following SRFIs with (import (srfi N)): + + (srfi 0) - cond-expand + (srfi 1) - list library + (srfi 2) - and-let* + (srfi 6) - basic string ports + (srfi 8) - receive + (srfi 9) - define-record-type + (srfi 11) - let-values/let*-values + (srfi 16) - case-lambda + (srfi 22) - running scheme scripts on Unix + (srfi 23) - error reporting mechanism + (srfi 26) - cut/cute partial application + (srfi 27) - sources of random bits + (srfi 33) - bitwise operators + (srfi 39) - prameter objects + (srfi 46) - basic syntax-rules extensions + (srfi 62) - s-expression comments + (srfi 69) - basic hash tables + (srfi 95) - sorting and merging + (srfi 98) - environment access + +although 0, 22, 23, 46 and 62 are built into the default environment +so there's no need to import them. + +Included non-standard modules are put in the (chibi) module namespace. +The following additional modules are available: + + (chibi net) - networking interface + (chibi filesystem) - local filesystem and file descriptor interface + (chibi process) - processes and signals + (chibi system) - host system and user information + (chibi time) - time and date library + (chibi match) - pattern-matching library + (chibi loop) - extensible loop syntax + (chibi pathname) - pathname manipulation utilities + (chibi uri) - URI parsing and construction utilities + (chibi macroexpand) - macro expansion utility + (chibi ast) - interface to the internal Abstract Syntax Tree + (chibi disasm) - disassembly utility for the chibi VM + (chibi heap-stats) - debugging tool to analyze or dump the heap + +------------------------------------------------------------------------ +C INTERFACE + +See the file main.c for an example of using chibi-scheme as a library. + +The basic usage involves creating a context for evaluation and loading +or evaluating Scheme source with it. Begin by including the eval.h +header file: + + #include + +then call + + sexp_scheme_init(); + +with no parameters to initialize any globals (this actually does +nothing in the standard configuration but is a good idea to call +anyway). + +Then you can use the following to create and manipulate contexts: + + sexp_make_eval_context(context, stack, environment, heap_size) + Creates a new context with the given stack and environment. + If context is non-NULL, this will be the "parent" context and + the two contexts will share a heap. Otherwise, a new heap + will be allocated with heap_size, or a default size if heap_size + is zero. stack and environment may both also be NULL (and _must_ + be NULL if context is NULL) and will be given standard defaults. + + Thus to create your first context you generally call: + + sexp_make_eval_context(NULL, NULL, NULL, 0) + + You can create as many contexts as you want, and other than those + sharing a heap they are all independent and thread-safe. + + sexp_load_standard_env(context, env, version) + Loads the init.scm file in the environment env. Version refers + to the RnRS version number and should always be SEXP_FIVE. The + environment created with sexp_make_eval_context only contains + core syntactic forms and C primitives (thus for example it has + CAR but not CADR or LIST), so to get a full featured + environment, plus a module system with which to load additional + modules, you want to use this. + + sexp_destroy_context(context) + Signals that you no longer need context, or any other context + sharing the heap. It will thus free() the context and heap and + all associated memory. Does nothing if using the Boehm GC. + +Environments can be handled with the following: + + sexp_context_env(context) + A macro returning the default environment associated with context. + + sexp_env_define(context, env, symbol, value) + Define a variable in an environment. + + sexp_env_ref(env, symbol, dflt) + Fetch the binding for symbol from the environment env, + returning the default dflt if the symbol is unbound. + +You can evaluate code with the following utility: + + sexp_eval(context, expr, env) + Evaluates an s-expression in an environment. + env can be NULL to use the context's default env. + + sexp_eval_string(context, str, env) + Reads an s-expression from str and evaluates it in env. + + sexp_load(context, file, env) + Read and eval all top-level forms from file in environment env. + As described in LOAD above, file may be a shared library. + +To define new primitive functions from C, use sexp_define_foreign, +which takes a Scheme environment, a name, a number of arguments the C +function takes (not counting the context argument), and a C function. + + /* sexp_define_foreign(context, env, name, num_args, f) */ + + sexp add (sexp context, sexp x, sexp y) { + return sexp_fx_add(x, y); + } + + sexp_define_foreign(context, env, "add", 2, add); + +You can also define functions with a single optional argument: + + sexp_define_foreign_opt(context, env, "add", 2, add, sexp_make_fixnum(1)); + +See the SRFI-69 implementation for more detailed examples of this. + +------------------------------------------------------------------------ +FFI + +Simple C FFI. "genstubs.scm file.stub" will read in the C function +FFI definitions from file.stub and output the appropriate C +wrappers into file.c. You can then compile that file with: + + cc -fPIC -shared file.c -lchibi-scheme + +(or using whatever flags are appropriate to generate shared libs on +your platform) and then the generated .so file can be loaded +directly with LOAD, or portably using (include-shared "file") in a +module definition (note that include-shared uses no suffix). + +The goal of this interface is to make access to C types and +functions easy, without requiring the user to write any C code. +That means the stubber needs to be intelligent about various C +calling conventions and idioms, such as return values passed in +actual parameters. Writing C by hand is still possible, and +several of the core modules provide C interfaces directly without +using the stubber. + +================================ + +Struct Interface + +(define-c-struct struct-name + [predicate: predicate-name] + [constructor: constructor-name] + [finalizer: c_finalizer_name] + (type c_field_name getter-name setter-name) ...) + + +================================ + + +Function Interface + +(define-c return-type name-spec (arg-type ...)) + +where name-space is either a symbol name, or a list of +(scheme-name c_name). If just a symbol, the C name is taken +to be the same with -'s replaced by _'s. + +arg-type is a type suitable for input validation and conversion. + +================================ + + +Types + +Types + +Basic Types + void + boolean + char + sexp (no conversions) + +Integer Types: + signed-char short int long + unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t + time_t (in seconds, but using the chibi epoch of 2010/01/01) + errno (as a return type returns #f on error) + +Float Types: + float double long-double + +String Types: + string - a null-terminated char* + env-string - a VAR=VALUE string represented as a (VAR . VALUE) pair inScheme + in addition you can use (array char) as a string + +Port Types: + input-port output-port + +Struct Types: + +Struct types are by default just referred to by the bare +struct-name from define-c-struct, and it is assumed you want a +pointer to that type. To refer to the full struct, use the struct +modifier, as in (struct struct-name). + +Type modifiers + +Any type may also be written as a list of modifiers followed by the +type itself. The supported modifiers are: + +const: prepends the "const" C type modifier + * as a return or result parameter, makes non-immediates immutable + +free: it's Scheme's responsibility to "free" this resource + * as a return or result parameter, registers the freep flag + this causes the type finalizer to be run when GCed + +maybe-null: this pointer type may be NULL + * as a result parameter, NULL is translated to #f + normally this would just return a wrapped NULL pointer + * as an input parameter, #f is translated to NULL + normally this would be a type error + +pointer: create a pointer to this type + * as a return parameter, wraps the result in a vanilla cpointer + * as a result parameter, boxes then unboxes the value + +struct: treat this struct type as a struct, not a pointer + * as an input parameter, dereferences the pointer + * as a type field, indicates a nested struct + +link: add a gc link + * as a field getter, link to the parent object, so the + parent won't be GCed so long as we have a reference + to the child. this behavior is automatic for nested + structs. + +result: return a result in this parameter + * if there are multiple results (including the return type), + they are all returned in a list + * if there are any result parameters, a return type + of errno returns #f on failure, and as eliminated + from the list of results otherwise + +(value ): specify a fixed value + * as an input parameter, this parameter is not provided + in the Scheme API but always passed as + +(default ): specify a default value + * as the final input parameter, makes the Scheme parameter + optional, defaulting to + +(array []) an array type + * length must be specified for return and result parameters + * if specified, length can be any of + ** an integer, for a fixed size + ** the symbol null, indicating a NULL-terminated array diff --git a/RELEASE b/RELEASE new file mode 100644 index 00000000..35f6fb33 --- /dev/null +++ b/RELEASE @@ -0,0 +1 @@ +lithium diff --git a/TODO b/TODO new file mode 100644 index 00000000..161ca82c --- /dev/null +++ b/TODO @@ -0,0 +1,165 @@ +-*- org -*- + +* compiler +** DONE ast rewrite + - State "DONE" [2009-04-09 Thu 14:32] +** DONE call/cc support + - State "DONE" [2009-04-09 Thu 14:36] +** DONE exceptions + - State "DONE" [2009-04-09 Thu 14:45] +** TODO native x86 backend + API redesign in preparation complete, initial + tests on native factorial and closures working. +** TODO fasl/image files + sexp_copy_context() can form the basis for images, + FASL for arbitrary modules will need additional + help with resolving external references. +** DONE shared stack on EVAL + - State "DONE" [2009-12-26 Sat 08:22] + +* compiler optimizations +** DONE constant folding + - State "DONE" [2009-12-16 Wed 23:25] +** DONE simplification pass, dead-code elimination + - State "DONE" [2009-12-18 Fri 14:14] + This is important in particular for the output generated by + syntax-rules. +** TODO lambda lift + The current closure representation is not very efficient, so this + would help a lot. +** TODO inlining (and disabling primitive inlining) + Being able to redefine procedures is important though. +** TODO unsafe operations + Possibly, don't want to make things too complicated or unstable. +** TODO plugin infrastructure +** TODO type inference with warnings + +* macros +** DONE hygiene + - State "DONE" [2009-04-09 Thu 14:41] +** DONE hygienic nested let-syntax + - State "DONE" [2009-12-08 Tue 14:41] +** DONE macroexpand utility + - State "DONE" [2009-12-08 Tue 14:41] +** DONE SRFI-46 basic syntax-rules extensions + - State "DONE" [2009-12-26 Sat 07:59] +** DONE (... ...) support + - State "DONE" [2009-12-26 Sat 02:06] +** TODO compiler macros +** TODO syntax-rules common pattern reduction +** TODO syntax-rules loop optimization + +* garbage collection +** DONE precise gc rewrite + - State "DONE" [2009-06-22 Mon 14:27] +** DONE fix heap growing + - State "DONE" [2009-06-22 Mon 14:29] +** DONE separate gc heaps + - State "DONE" [2009-12-08 Tue 14:29] +** DONE add finalizers + - State "DONE" [2009-12-08 Tue 14:29] +** TODO support weak references + +* runtime +** DONE bignums + - State "DONE" [2009-07-07 Tue 14:42] +** DONE unicode + - State "DONE" from "TODO" [2010-07-11 Sun 23:58] + Supported with UTF-8 strings, string-ref is O(n) and + string-set! may need to reallocate the whole string. + string-cursor-ref can be used for O(1) string access. +** DONE threads + - State "DONE" from "TODO" [2010-07-11 Sun 15:31] + VM now supports an optional hook for green threads, + and a SRFI-18 interface is provided as a separate module. + I/O operations will currently block all threads though, + this needs to be addressed. +** DONE virtual ports + - State "DONE" [2010-01-02 Sat 20:12] +** DONE dynamic-wind + - State "DONE" [2009-12-26 Sat 01:51] + Adapted a version from Scheme48. +** DONE recursive disasm + - State "DONE" [2009-12-18 Fri 14:15] + +* FFI +** DONE libdl support + - State "DONE" [2009-12-08 Tue 14:45] +** DONE opcode generation interface + - State "DONE" [2009-11-15 Sun 14:45] +** DONE stub generator + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE define-c-struct + - State "DONE" [2009-11-29 Sun 14:48] +*** DONE define-c + - State "DONE" [2009-11-29 Sun 14:48] +*** DONE array return types + - State "DONE" [2009-12-26 Sat 01:49] +*** DONE pre-buffered string types (like getcwd) + - State "DONE" [2009-12-26 Sat 01:49] + +* module system +** DONE scheme48-like config language + - State "DONE" [2009-10-13 Tue 14:38] +** DONE shared library includes + - State "DONE" [2009-12-08 Tue 14:39] +** DONE only/except/rename/prefix modifiers + - State "DONE" [2009-12-16 Wed 18:57] +** TODO scheme-complete.el support +** DONE access individual modules from repl + - State "DONE" [2009-12-26 Sat 01:49] + +* core modules +** DONE SRFI-0 cond-expand + - State "DONE" [2009-12-16 Wed 20:12] +** DONE SRFI-9 define-record-type + - State "DONE" [2009-12-08 Tue 14:50] +** DONE SRFI-69 hash-tables + - State "DONE" [2009-11-15 Sun 14:50] +** DONE match library + - State "DONE" [2009-12-08 Tue 14:54] +** DONE loop library + - State "DONE" [2009-12-08 Tue 14:54] +** TODO network interface +** DONE posix interface + - State "DONE" from "TODO" [2010-07-11 Sun 15:36] + Splitting this into several parts. +*** DONE filesystem interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE process interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE time interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE host system interface + - State "DONE" [2010-01-02 Sat 20:12] +** DONE pathname library + - State "DONE" [2009-12-16 Wed 18:58] +** DONE uri library + - State "DONE" [2009-12-16 Wed 18:58] +** TODO http library +** TODO show (formatting) library +** TODO zip library +** TODO tar library +** TODO md5sum library + +* ports +** DONE basic mingw support + - State "DONE" [2009-06-22 Mon 14:36] +** DONE Plan 9 support + - State "DONE" [2009-08-10 Mon 14:37] +** DONE 64-bit support + - State "DONE" [2009-11-01 Sun 14:37] +** TODO iPhone support +** TODO bare-metal support + +* miscellaneous +** TODO overall cleanup +** TODO user documentation +** TODO thorough source documentation +** TODO full test suite for libraries + +* distribution +** TODO packaging format +** TODO code repository with fetch+install tool +** TODO translator to/from other implementations + diff --git a/VERSION b/VERSION new file mode 100644 index 00000000..be586341 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +0.3 diff --git a/chibi-scheme.vcproj b/chibi-scheme.vcproj new file mode 100644 index 00000000..86bd69e9 --- /dev/null +++ b/chibi-scheme.vcproj @@ -0,0 +1,206 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/doc/chibi-scheme.1 b/doc/chibi-scheme.1 new file mode 100644 index 00000000..b84620d5 --- /dev/null +++ b/doc/chibi-scheme.1 @@ -0,0 +1,133 @@ +.TH "chibi-scheme" "1" "" "" +.UC 4 +.SH NAME +.PP +chibi-scheme \- a tiny Scheme interpreter + +.SH SYNOPSIS +.B chibi-scheme +[-qV] +[-I +.I path +] +[-A +.I path +] +[-m +.I module +] +[-l +.I file +] +[-e +.I expr +] +[-p +.I expr +] +[--] +[ +.I script argument ... +] +.br +.sp 0.3 + +.SH DESCRIPTION +.I chibi-scheme +is a sample interactive Scheme interpreter for the +.I chibi-scheme +library. It serves as an example of how to embed +.I chibi-scheme +in applications, and can be useful on its own for writing +scripts and interactive development. + +When +.I script +is given, the script will be loaded with SRFI-22 semantics, +calling the procedure +.I main +(if defined) with a single parameter as a list of the +command-line arguments beginning with the script name. + +Otherwise, if no script is given and no -e or -p options +are given an interactive repl is entered, reading, evaluating, +then printing expressions until EOF is reached. The repl +provided is very minimal - if you want readline +completion you may want to wrap it with the +.I rlwrap(1) +program. Signals aren't caught either - to enable handling keyboard +interrupts you can use the (chibi process) module. + +.SH OPTIONS +.TP 5 +.BI -V +Prints the version information and exits. +.TP +.BI -q +Don't load the initialization file. The resulting +environment will only contain the core syntactic forms +and primitives coded in C. +.TP +.BI -h size +Specifies the initial size of the heap, in bytes. +.I size +can be any integer value, optionally suffixed by +"K" for kilobytes, or "M" for megabytes. +.I -h +must be specified before any options which load or +evaluate Scheme code. +.TP +.BI -I path +Inserts +.I path +on front of the load path list. +.TP +.BI -A path +Appends +.I path +to the load path list. +.TP +.BI -m module +Imports +.I module +as though "(import +.I module +)" were evaluated. However, to reduce the need for shell +escapes, modules are written in a dot notation, so that the module +.I (foo bar) +is written as +.I foo.bar +.TP +.BI -l file +Loads the Scheme source from the file +.I file +searched for in the default load path. +.TP +.BI -e expr +Evaluates the Scheme expression +.I expr. +.TP +.BI -p expr +Evaluates the Scheme expression +.I expr +then prints the result to stdout. + +.SH ENVIRONMENT +.TP +.B CHIBI_MODULE_PATH +.TQ +A colon separated list of directories to search for module +files, inserted before the system default load paths. + +.SH AUTHORS +.PP +Alex Shinn (alexshinn @ gmail . com) + +.SH SEE ALSO +.PP +More detailed information can be found in the README file +included in the distribution. + +The chibi-scheme home-page: +.br +http://code.google.com/p/chibi-scheme/ diff --git a/eval.c b/eval.c new file mode 100644 index 00000000..c0c7e166 --- /dev/null +++ b/eval.c @@ -0,0 +1,1758 @@ +/* eval.c -- evaluator library implementation */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +/************************************************************************/ + +static int scheme_initialized_p = 0; + +static sexp analyze (sexp ctx, sexp x); +static void generate (sexp ctx, sexp x); + +#if SEXP_USE_MODULES +sexp sexp_load_module_file_op (sexp ctx sexp_api_params(self, n), sexp file, sexp env); +sexp sexp_find_module_file_op (sexp ctx sexp_api_params(self, n), sexp file); +sexp sexp_current_environment (sexp ctx sexp_api_params(self, n)); +#endif + +sexp sexp_compile_error (sexp ctx, const char *message, sexp o) { + sexp exn; + sexp_gc_var3(sym, irritants, msg); + sexp_gc_preserve3(ctx, sym, irritants, msg); + irritants = sexp_list1(ctx, o); + msg = sexp_c_string(ctx, message, -1); + exn = sexp_make_exception(ctx, sym = sexp_intern(ctx, "compile", -1), + msg, irritants, SEXP_FALSE, + (sexp_pairp(o)?sexp_pair_source(o):SEXP_FALSE)); + sexp_gc_release3(ctx); + return exn; +} + +static void sexp_warn (sexp ctx, char *msg, sexp x) { + sexp out = sexp_current_error_port(ctx); + if (sexp_oportp(out)) { + sexp_write_string(ctx, "WARNING: ", out); + sexp_write_string(ctx, msg, out); + sexp_write(ctx, x, out); + sexp_write_char(ctx, '\n', out); + } +} + +void sexp_warn_undefs (sexp ctx, sexp from, sexp to) { + sexp x; + for (x=from; sexp_pairp(x) && x!=to; x=sexp_env_next_cell(x)) + if (sexp_cdr(x) == SEXP_UNDEF) + sexp_warn(ctx, "reference to undefined variable: ", sexp_car(x)); +} + + +/********************** environment utilities ***************************/ + +static sexp sexp_env_cell_loc (sexp env, sexp key, sexp *varenv) { + sexp ls; + + do { + for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + if (sexp_car(ls) == key) { + if (varenv) *varenv = env; + return ls; + } + env = sexp_env_parent(env); + } while (env); + + return NULL; +} + +sexp sexp_env_cell (sexp env, sexp key) { + return sexp_env_cell_loc(env, key, NULL); +} + +static sexp sexp_env_cell_create (sexp ctx, sexp env, sexp key, + sexp value, sexp *varenv) { + sexp_gc_var1(cell); + cell = sexp_env_cell_loc(env, key, varenv); + if (! cell) { + sexp_gc_preserve1(ctx, cell); + while (sexp_env_lambda(env) || sexp_env_syntactic_p(env)) + env = sexp_env_parent(env); + sexp_env_push(ctx, env, cell, key, value); + if (varenv) *varenv = env; + sexp_gc_release1(ctx); + } + return cell; +} + +sexp sexp_env_ref (sexp env, sexp key, sexp dflt) { + sexp cell = sexp_env_cell(env, key); + return (cell ? sexp_cdr(cell) : dflt); +} + +sexp sexp_env_global_ref (sexp env, sexp key, sexp dflt) { + while (sexp_env_lambda(env) && sexp_env_parent(env)) + env = sexp_env_parent(env); + return sexp_env_ref(env, key, dflt); +} + +sexp sexp_env_define (sexp ctx, sexp env, sexp key, sexp value) { + sexp cell=SEXP_FALSE, res=SEXP_VOID; + sexp_gc_var1(tmp); + for (tmp=sexp_env_bindings(env); sexp_pairp(tmp); tmp=sexp_env_next_cell(tmp)) + if (sexp_car(tmp) == key) { + cell = tmp; + break; + } + if (sexp_immutablep(env)) { + res = sexp_user_exception(ctx, NULL, "immutable binding", key); + } else { + sexp_gc_preserve1(ctx, tmp); + if (sexp_truep(cell)) { + if (sexp_immutablep(cell)) + res = sexp_user_exception(ctx, NULL, "immutable binding", key); + else + sexp_cdr(cell) = value; + } else { + sexp_env_push(ctx, env, tmp, key, value); + } + sexp_gc_release1(ctx); + } + return res; +} + +sexp sexp_env_exports_op (sexp ctx sexp_api_params(self, n), sexp env) { + sexp ls; + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; + for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + sexp_push(ctx, res, sexp_car(ls)); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) { + sexp_gc_var2(e, tmp); + sexp_gc_preserve2(ctx, e, tmp); + e = sexp_alloc_type(ctx, env, SEXP_ENV); + sexp_env_parent(e) = env; + sexp_env_bindings(e) = SEXP_NULL; + for ( ; sexp_pairp(vars); vars = sexp_cdr(vars)) + sexp_env_push(ctx, e, tmp, sexp_car(vars), value); + sexp_gc_release2(ctx); + return e; +} + +static sexp sexp_reverse_flatten_dot (sexp ctx, sexp ls) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_push(ctx, res, sexp_car(ls)); + sexp_gc_release1(ctx); + return (sexp_nullp(ls) ? res : sexp_cons(ctx, ls, res)); +} + +static sexp sexp_flatten_dot (sexp ctx, sexp ls) { + return sexp_nreverse(ctx, sexp_reverse_flatten_dot(ctx, ls)); +} + +int sexp_param_index (sexp lambda, sexp name) { + sexp ls = sexp_lambda_params(lambda); + int i = 0; + for (i=0; sexp_pairp(ls); ls=sexp_cdr(ls), i++) + if (sexp_car(ls) == name) + return i; + if (ls == name) + return i; + ls = sexp_lambda_locals(lambda); + for (i=-1; sexp_pairp(ls); ls=sexp_cdr(ls), i--) + if (sexp_car(ls) == name) + return i-4; + return -10000; +} + +/************************* bytecode utilities ***************************/ + +static void shrink_bcode (sexp ctx, sexp_uint_t i) { + sexp tmp; + if (sexp_bytecode_length(sexp_context_bc(ctx)) != i) { + tmp = sexp_alloc_bytecode(ctx, i); + sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx)); + sexp_bytecode_length(tmp) = i; + sexp_bytecode_literals(tmp) + = sexp_bytecode_literals(sexp_context_bc(ctx)); + memcpy(sexp_bytecode_data(tmp), + sexp_bytecode_data(sexp_context_bc(ctx)), + i); + sexp_context_bc(ctx) = tmp; + } +} + +static void expand_bcode (sexp ctx, sexp_uint_t size) { + sexp tmp; + if (sexp_bytecode_length(sexp_context_bc(ctx)) + < (sexp_context_pos(ctx))+size) { + tmp=sexp_alloc_bytecode(ctx, sexp_bytecode_length(sexp_context_bc(ctx))*2); + sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx)); + sexp_bytecode_length(tmp) + = sexp_bytecode_length(sexp_context_bc(ctx))*2; + sexp_bytecode_literals(tmp) + = sexp_bytecode_literals(sexp_context_bc(ctx)); + memcpy(sexp_bytecode_data(tmp), + sexp_bytecode_data(sexp_context_bc(ctx)), + sexp_bytecode_length(sexp_context_bc(ctx))); + sexp_context_bc(ctx) = tmp; + } +} + +static void emit_enter (sexp ctx); +static void emit_return (sexp ctx); +static void bless_bytecode (sexp ctx, sexp bc); + +static sexp finalize_bytecode (sexp ctx) { + sexp bc; + emit_return(ctx); + shrink_bcode(ctx, sexp_context_pos(ctx)); + bc = sexp_context_bc(ctx); + if (sexp_pairp(sexp_bytecode_literals(bc))) { /* compress literals */ + if (sexp_nullp(sexp_cdr(sexp_bytecode_literals(bc)))) + sexp_bytecode_literals(bc) = sexp_car(sexp_bytecode_literals(bc)); + else if (sexp_nullp(sexp_cddr(sexp_bytecode_literals(bc)))) + sexp_cdr(sexp_bytecode_literals(bc)) = sexp_cadr(sexp_bytecode_literals(bc)); + else + sexp_bytecode_literals(bc) = sexp_list_to_vector(ctx, sexp_bytecode_literals(bc)); + } + bless_bytecode(ctx, bc); + return bc; +} + +static void emit (sexp ctx, unsigned char c) { + expand_bcode(ctx, 1); + sexp_bytecode_data(sexp_context_bc(ctx))[sexp_context_pos(ctx)++] = c; +} + +sexp sexp_make_procedure_op (sexp ctx sexp_api_params(self, n), sexp flags, + sexp num_args, sexp bc, sexp vars) { + sexp proc = sexp_alloc_type(ctx, procedure, SEXP_PROCEDURE); + sexp_procedure_flags(proc) = (char) (sexp_uint_t) flags; + sexp_procedure_num_args(proc) = (unsigned short) (sexp_uint_t) num_args; + sexp_procedure_code(proc) = bc; + sexp_procedure_vars(proc) = vars; + return proc; +} + +static sexp sexp_make_macro (sexp ctx, sexp p, sexp e) { + sexp mac = sexp_alloc_type(ctx, macro, SEXP_MACRO); + sexp_macro_env(mac) = e; + sexp_macro_proc(mac) = p; + return mac; +} + +static sexp sexp_make_synclo_op (sexp ctx sexp_api_params(self, n), sexp env, sexp fv, sexp expr) { + sexp res; + if (! (sexp_symbolp(expr) || sexp_pairp(expr))) + return expr; + res = sexp_alloc_type(ctx, synclo, SEXP_SYNCLO); + sexp_synclo_env(res) = env; + sexp_synclo_free_vars(res) = fv; + sexp_synclo_expr(res) = expr; + return res; +} + +/* internal AST */ + +static sexp sexp_make_lambda (sexp ctx, sexp params) { + sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA); + sexp_lambda_name(res) = SEXP_FALSE; + sexp_lambda_params(res) = params; + sexp_lambda_fv(res) = SEXP_NULL; + sexp_lambda_sv(res) = SEXP_NULL; + sexp_lambda_locals(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_make_set (sexp ctx, 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 (sexp ctx, 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 (sexp ctx, 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_lit (sexp ctx, sexp value) { + sexp res = sexp_alloc_type(ctx, lit, SEXP_LIT); + sexp_lit_value(res) = value; + return res; +} + +/****************************** contexts ******************************/ + +#define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*SEXP_INIT_STACK_SIZE) + +static void sexp_add_path (sexp ctx, const char *str) { + const char *colon; + if (str && *str) { + colon = strchr(str, ':'); + if (colon) + sexp_add_path(ctx, colon+1); + else + colon = str + strlen(str); + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), SEXP_VOID); + sexp_car(sexp_global(ctx, SEXP_G_MODULE_PATH)) + = sexp_c_string(ctx, str, colon-str); + } +} + +void sexp_init_eval_context_globals (sexp ctx) { + sexp_gc_var3(tmp, vec, ctx2); + ctx = sexp_make_child_context(ctx, NULL); + sexp_gc_preserve3(ctx, tmp, vec, ctx2); + vec = sexp_intern(ctx, "*current-exception-handler*", -1); + sexp_global(ctx, SEXP_G_ERR_HANDLER) + = sexp_env_cell_create(ctx, sexp_context_env(ctx), vec, SEXP_FALSE, NULL); +#if ! SEXP_USE_NATIVE_X86 + emit(ctx, SEXP_OP_RESUMECC); + sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE) = finalize_bytecode(ctx); + ctx2 = sexp_make_child_context(ctx, NULL); + emit(ctx2, SEXP_OP_DONE); + tmp = finalize_bytecode(ctx2); + vec = sexp_make_vector(ctx, 0, SEXP_VOID); + sexp_global(ctx, SEXP_G_FINAL_RESUMER) + = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, tmp, vec); + sexp_bytecode_name(sexp_procedure_code(sexp_global(ctx, SEXP_G_FINAL_RESUMER))) + = sexp_intern(ctx, "final-resumer", -1); +#endif + sexp_global(ctx, SEXP_G_MODULE_PATH) = SEXP_NULL; + sexp_add_path(ctx, sexp_default_module_dir); + sexp_add_path(ctx, getenv(SEXP_MODULE_PATH_VAR)); + tmp = sexp_c_string(ctx, "./lib", 5); + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), tmp); + tmp = sexp_c_string(ctx, ".", 1); + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), tmp); +#if SEXP_USE_GREEN_THREADS + sexp_global(ctx, SEXP_G_THREADS_FRONT) = SEXP_NULL; + sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL; + sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = SEXP_ZERO; + sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = SEXP_FALSE; +#endif + sexp_gc_release3(ctx); +} + +sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size) { + sexp_gc_var1(res); + if (ctx) sexp_gc_preserve1(ctx, res); + res = sexp_make_context(ctx, size); + sexp_context_bc(res) = sexp_alloc_bytecode(res, SEXP_INIT_BCODE_SIZE); + sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE; + sexp_bytecode_length(sexp_context_bc(res)) = SEXP_INIT_BCODE_SIZE; + sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL; + if ((! stack) || (stack == SEXP_FALSE)) { + stack = sexp_alloc_tagged(res, SEXP_STACK_SIZE, SEXP_STACK); + sexp_stack_length(stack) = SEXP_INIT_STACK_SIZE; + sexp_stack_top(stack) = 0; + } + sexp_context_stack(res) = stack; + sexp_context_env(res) = (env ? env : sexp_make_primitive_env(res, SEXP_FIVE)); + if (! ctx) sexp_init_eval_context_globals(res); + if (ctx) { + sexp_context_tracep(res) = sexp_context_tracep(ctx); + sexp_gc_release1(ctx); + } + return res; +} + +sexp sexp_make_child_context (sexp ctx, sexp lambda) { + sexp res = sexp_make_eval_context(ctx, + sexp_context_stack(ctx), + sexp_context_env(ctx), + 0); + if (! sexp_exceptionp(res)) { + sexp_context_lambda(res) = lambda; + sexp_context_top(res) = sexp_context_top(ctx); + sexp_context_fv(res) = sexp_context_fv(ctx); + sexp_context_tracep(res) = sexp_context_tracep(ctx); + } + return res; +} + +/**************************** identifiers *****************************/ + +static sexp sexp_identifierp_op (sexp ctx sexp_api_params(self, n), sexp x) { + return sexp_make_boolean(sexp_idp(x)); +} + +static sexp sexp_syntactic_closure_expr_op (sexp ctx sexp_api_params(self, n), sexp x) { + return (sexp_synclop(x) ? sexp_synclo_expr(x) : x); +} + +static sexp sexp_strip_synclos (sexp ctx sexp_api_params(self, n), sexp x) { + sexp res; + sexp_gc_var2(kar, kdr); + sexp_gc_preserve2(ctx, kar, kdr); + loop: + if (sexp_synclop(x)) { + x = sexp_synclo_expr(x); + goto loop; + } else if (sexp_pairp(x)) { + kar = sexp_strip_synclos(ctx sexp_api_pass(self, n), sexp_car(x)); + kdr = sexp_strip_synclos(ctx sexp_api_pass(self, n), sexp_cdr(x)); + res = sexp_cons(ctx, kar, kdr); + sexp_immutablep(res) = 1; + } else { + res = x; + } + sexp_gc_release2(ctx); + return res; +} + +static sexp sexp_identifier_eq_op (sexp ctx sexp_api_params(self, n), sexp e1, sexp id1, sexp e2, sexp id2) { + sexp cell, lam1=SEXP_FALSE, lam2=SEXP_FALSE; + if (sexp_synclop(id1)) { + e1 = sexp_synclo_env(id1); + id1 = sexp_synclo_expr(id1); + } + if (sexp_synclop(id2)) { + e2 = sexp_synclo_env(id2); + id2 = sexp_synclo_expr(id2); + } + cell = sexp_env_cell(e1, id1); + if (cell && sexp_lambdap(sexp_cdr(cell))) + lam1 = sexp_cdr(cell); + cell = sexp_env_cell(e2, id2); + if (cell && sexp_lambdap(sexp_cdr(cell))) + lam2 = sexp_cdr(cell); + return sexp_make_boolean((id1 == id2) && (lam1 == lam2)); +} + +/************************* the compiler ***************************/ + +static sexp analyze_app (sexp ctx, sexp x) { + sexp p; + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, tmp); + for (res=SEXP_NULL; sexp_pairp(x); x=sexp_cdr(x)) { + sexp_push(ctx, res, SEXP_FALSE); + tmp = analyze(ctx, sexp_car(x)); + if (sexp_exceptionp(tmp)) { + res = tmp; + break; + } else { + sexp_car(res) = tmp; + } + } + if (sexp_pairp(res)) { /* fill in lambda names */ + res = sexp_nreverse(ctx, res); + if (sexp_lambdap(sexp_car(res))) { + p=sexp_lambda_params(sexp_car(res)); + for (tmp=sexp_cdr(res); sexp_pairp(tmp)&&sexp_pairp(p); tmp=sexp_cdr(tmp), p=sexp_cdr(p)) + if (sexp_lambdap(sexp_car(tmp))) + sexp_lambda_name(sexp_car(tmp)) = sexp_car(p); + } + } + sexp_gc_release2(ctx); + return res; +} + +static sexp analyze_seq (sexp ctx, sexp ls) { + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, tmp); + if (sexp_nullp(ls)) + res = SEXP_VOID; + else if (sexp_nullp(sexp_cdr(ls))) + res = analyze(ctx, sexp_car(ls)); + else { + res = sexp_alloc_type(ctx, seq, SEXP_SEQ); + tmp = analyze_app(ctx, ls); + if (sexp_exceptionp(tmp)) + res = tmp; + else + sexp_seq_ls(res) = tmp; + } + sexp_gc_release2(ctx); + return res; +} + +static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) { + sexp env = sexp_context_env(ctx), res; + sexp_gc_var1(cell); + sexp_gc_preserve1(ctx, cell); + cell = sexp_env_cell_loc(env, x, varenv); + if (! cell) { + if (sexp_synclop(x)) { + if (sexp_not(sexp_memq(ctx, sexp_synclo_expr(x), sexp_context_fv(ctx))) + && sexp_not(sexp_memq(ctx, sexp_synclo_expr(x), sexp_synclo_free_vars(x)))) + env = sexp_synclo_env(x); + x = sexp_synclo_expr(x); + } + cell = sexp_env_cell_create(ctx, env, x, SEXP_UNDEF, varenv); + } + if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell))) + res = sexp_compile_error(ctx, "invalid use of syntax as value", x); + else + res = sexp_make_ref(ctx, x, cell); + sexp_gc_release1(ctx); + return res; +} + +static sexp analyze_set (sexp ctx, sexp x) { + sexp res, varenv; + sexp_gc_var2(ref, value); + sexp_gc_preserve2(ctx, ref, value); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)) + && sexp_nullp(sexp_cdddr(x)) && sexp_idp(sexp_cadr(x)))) { + res = sexp_compile_error(ctx, "bad set! syntax", x); + } else { + ref = analyze_var_ref(ctx, sexp_cadr(x), &varenv); + if (sexp_lambdap(sexp_ref_loc(ref))) + sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref)); + value = analyze(ctx, sexp_caddr(x)); + if (sexp_exceptionp(ref)) + res = ref; + else if (sexp_exceptionp(value)) + res = value; + else if (sexp_immutablep(sexp_ref_cell(ref)) + || (varenv && sexp_immutablep(varenv))) + res = sexp_compile_error(ctx, "immutable binding", sexp_cadr(x)); + else + res = sexp_make_set(ctx, ref, value); + } + sexp_gc_release2(ctx); + return res; +} + +#define sexp_return(res, val) do {res=val; goto cleanup;} while (0) + +static sexp analyze_lambda (sexp ctx, sexp x) { + sexp name, ls, ctx3; + sexp_gc_var6(res, body, tmp, value, defs, ctx2); + sexp_gc_preserve6(ctx, res, body, tmp, value, defs, ctx2); + /* verify syntax */ + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) + sexp_return(res, sexp_compile_error(ctx, "bad lambda syntax", x)); + for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls)) + if (! sexp_idp(sexp_car(ls))) + sexp_return(res, sexp_compile_error(ctx, "non-symbol parameter", x)); + else if (sexp_truep(sexp_memq(ctx, sexp_car(ls), sexp_cdr(ls)))) + sexp_return(res, sexp_compile_error(ctx, "duplicate parameter", x)); + /* build lambda and analyze body */ + res = sexp_make_lambda(ctx, tmp=sexp_copy_list(ctx, sexp_cadr(x))); + sexp_lambda_source(res) = sexp_pair_source(x); + if (! (sexp_lambda_source(res) && sexp_pairp(sexp_lambda_source(res)))) + sexp_lambda_source(res) = sexp_pair_source(sexp_cdr(x)); + if (! (sexp_lambda_source(res) && sexp_pairp(sexp_lambda_source(res)))) + sexp_lambda_source(res) = sexp_pair_source(sexp_cddr(x)); + ctx2 = sexp_make_child_context(ctx, res); + tmp = sexp_flatten_dot(ctx2, sexp_lambda_params(res)); + sexp_context_env(ctx2) = sexp_extend_env(ctx2, sexp_context_env(ctx2), tmp, res); + sexp_env_lambda(sexp_context_env(ctx2)) = res; + body = analyze_seq(ctx2, sexp_cddr(x)); + if (sexp_exceptionp(body)) sexp_return(res, body); + /* delayed analyze internal defines */ + defs = SEXP_NULL; + for (ls=sexp_lambda_defs(res); sexp_pairp(ls); ls=sexp_cdr(ls)) { + tmp = sexp_car(ls); + ctx3 = sexp_cdr(tmp); + if (sexp_pairp(sexp_caar(tmp))) { + name = sexp_caaar(tmp); + tmp = sexp_cons(ctx3, sexp_cdaar(tmp), sexp_cdar(tmp)); + tmp = sexp_cons(ctx3, SEXP_VOID, tmp); + sexp_pair_source(tmp) = sexp_pair_source(sexp_caar(ls)); + value = analyze_lambda(ctx3, tmp); + } else { + name = sexp_caar(tmp); + value = analyze(ctx3, sexp_cadar(tmp)); + } + if (sexp_exceptionp(value)) sexp_return(res, value); + if (sexp_lambdap(value)) sexp_lambda_name(value) = name; + sexp_push(ctx3, defs, + sexp_make_set(ctx3, analyze_var_ref(ctx3, name, NULL), value)); + } + if (sexp_pairp(defs)) { + if (! sexp_seqp(body)) { + tmp = sexp_alloc_type(ctx2, seq, SEXP_SEQ); + sexp_seq_ls(tmp) = sexp_list1(ctx2, body); + body = tmp; + } + sexp_seq_ls(body) = sexp_append2(ctx2, defs, sexp_seq_ls(body)); + } + sexp_lambda_body(res) = body; + cleanup: + sexp_gc_release6(ctx); + return res; +} + +static sexp analyze_if (sexp ctx, sexp x) { + sexp res, fail_expr; + sexp_gc_var3(test, pass, fail); + sexp_gc_preserve3(ctx, test, pass, fail); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { + res = sexp_compile_error(ctx, "bad if syntax", x); + } else { + test = analyze(ctx, sexp_cadr(x)); + pass = analyze(ctx, sexp_caddr(x)); + fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID; + fail = analyze(ctx, fail_expr); + res = (sexp_exceptionp(test) ? test : sexp_exceptionp(pass) ? pass : + sexp_exceptionp(fail) ? fail : sexp_make_cnd(ctx, test, pass, fail)); + } + sexp_gc_release3(ctx); + return res; +} + +static sexp analyze_define (sexp ctx, sexp x) { + sexp name, res, varenv; + sexp_gc_var4(ref, value, tmp, env); + sexp_gc_preserve4(ctx, ref, value, tmp, env); + env = sexp_context_env(ctx); + while (sexp_env_syntactic_p(env) && sexp_env_parent(env)) + env = sexp_env_parent(env); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { + res = sexp_compile_error(ctx, "bad define syntax", x); + } else { + name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x)); + if (! sexp_idp(name)) { + res = sexp_compile_error(ctx, "can't define a non-symbol", x); + } else if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) { + sexp_env_push(ctx, env, tmp, name, sexp_context_lambda(ctx)); + sexp_push(ctx, sexp_lambda_sv(sexp_env_lambda(env)), name); + sexp_push(ctx, sexp_lambda_locals(sexp_env_lambda(env)), name); + tmp = sexp_cons(ctx, sexp_cdr(x), ctx); + sexp_pair_source(sexp_cdr(x)) = sexp_pair_source(x); + sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), tmp); + res = SEXP_VOID; + } else { + if (sexp_synclop(name)) name = sexp_synclo_expr(name); + sexp_env_cell_create(ctx, env, name, SEXP_VOID, NULL); + if (sexp_pairp(sexp_cadr(x))) { + tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x)); + tmp = sexp_cons(ctx, SEXP_VOID, tmp); + sexp_pair_source(tmp) = sexp_pair_source(x); + value = analyze_lambda(ctx, tmp); + } else + value = analyze(ctx, sexp_caddr(x)); + ref = analyze_var_ref(ctx, name, &varenv); + if (sexp_exceptionp(ref)) { + res = ref; + } else if (sexp_exceptionp(value)) { + res = value; + } else if (varenv && sexp_immutablep(varenv)) { + res = sexp_compile_error(ctx, "immutable binding", name); + } else { + if (sexp_lambdap(value)) sexp_lambda_name(value) = name; + res = sexp_make_set(ctx, ref, value); + } + } + } + sexp_gc_release4(ctx); + return res; +} + +static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { + sexp res = SEXP_VOID, name; + sexp_gc_var2(proc, mac); + sexp_gc_preserve2(eval_ctx, proc, mac); + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { + if (! (sexp_pairp(sexp_car(ls)) && sexp_pairp(sexp_cdar(ls)) + && sexp_nullp(sexp_cddar(ls)))) { + res = sexp_compile_error(eval_ctx, "bad syntax binding", sexp_car(ls)); + } else { + proc = sexp_eval(eval_ctx, sexp_cadar(ls), NULL); + if (sexp_procedurep(proc)) { + name = sexp_caar(ls); + if (sexp_synclop(name) && sexp_env_global_p(sexp_context_env(bind_ctx))) + name = sexp_synclo_expr(name); + mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(bind_ctx)); + sexp_env_define(eval_ctx, sexp_context_env(bind_ctx), name, mac); + } else { + res = (sexp_exceptionp(proc) ? proc + : sexp_compile_error(eval_ctx, "non-procedure macro:", proc)); + break; + } + } + } + sexp_gc_release2(eval_ctx); + return res; +} + +static sexp analyze_define_syntax (sexp ctx, sexp x) { + sexp res; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_list1(ctx, sexp_cdr(x)); + res = analyze_bind_syntax(tmp, ctx, ctx); + sexp_gc_release1(ctx); + return res; +} + +static sexp analyze_let_syntax_aux (sexp ctx, sexp x, int recp) { + sexp res; + sexp_gc_var3(env, ctx2, tmp); + sexp_gc_preserve3(ctx, env, ctx2, tmp); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { + res = sexp_compile_error(ctx, "bad let(rec)-syntax", x); + } else { + env = sexp_alloc_type(ctx, env, SEXP_ENV); + sexp_env_syntactic_p(env) = 1; + sexp_env_parent(env) = sexp_context_env(ctx); + sexp_env_bindings(env) = SEXP_NULL; + ctx2 = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + sexp_context_env(ctx2) = env; + tmp = analyze_bind_syntax(sexp_cadr(x), (recp ? ctx2 : ctx), ctx2); + res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx2, sexp_cddr(x))); + } + sexp_gc_release3(ctx); + return res; +} + +static sexp analyze_let_syntax (sexp ctx, sexp x) { + return analyze_let_syntax_aux(ctx, x, 0); +} + +static sexp analyze_letrec_syntax (sexp ctx, sexp x) { + return analyze_let_syntax_aux(ctx, x, 1); +} + +static sexp analyze (sexp ctx, sexp object) { + sexp op; + sexp_gc_var4(res, tmp, x, cell); + sexp_gc_preserve4(ctx, res, tmp, x, cell); + x = object; + loop: + if (sexp_pairp(x)) { + if (sexp_not(sexp_listp(ctx, x))) { + res = sexp_compile_error(ctx, "dotted list in source", x); + } else if (sexp_idp(sexp_car(x))) { + cell = sexp_env_cell(sexp_context_env(ctx), sexp_car(x)); + if (! cell && sexp_synclop(sexp_car(x))) + cell = sexp_env_cell(sexp_synclo_env(sexp_car(x)), + sexp_synclo_expr(sexp_car(x))); + if (! cell) { + res = analyze_app(ctx, x); + } else { + op = sexp_cdr(cell); + if (sexp_corep(op)) { + switch (sexp_core_code(op)) { + case SEXP_CORE_DEFINE: + res = analyze_define(ctx, x); break; + case SEXP_CORE_SET: + res = analyze_set(ctx, x); break; + case SEXP_CORE_LAMBDA: + res = analyze_lambda(ctx, x); break; + case SEXP_CORE_IF: + res = analyze_if(ctx, x); break; + case SEXP_CORE_BEGIN: + res = analyze_seq(ctx, sexp_cdr(x)); break; + case SEXP_CORE_QUOTE: + case SEXP_CORE_SYNTAX_QUOTE: + if (! (sexp_pairp(sexp_cdr(x)) && sexp_nullp(sexp_cddr(x)))) + res = sexp_compile_error(ctx, "bad quote form", x); + else + res = sexp_make_lit(ctx, + (sexp_core_code(op) == SEXP_CORE_QUOTE) ? + sexp_strip_synclos(ctx sexp_api_pass(NULL, 1), sexp_cadr(x)) : + sexp_cadr(x)); + break; + case SEXP_CORE_DEFINE_SYNTAX: + res = analyze_define_syntax(ctx, x); break; + case SEXP_CORE_LET_SYNTAX: + res = analyze_let_syntax(ctx, x); break; + case SEXP_CORE_LETREC_SYNTAX: + res = analyze_letrec_syntax(ctx, x); break; + default: + res = sexp_compile_error(ctx, "unknown core form", op); break; + } + } else if (sexp_macrop(op)) { + tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL); + tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp); + tmp = sexp_cons(ctx, x, tmp); + x = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + x = sexp_apply(x, sexp_macro_proc(op), tmp); + if (sexp_exceptionp(x) && sexp_not(sexp_exception_source(x))) + sexp_exception_source(x) = sexp_pair_source(sexp_car(tmp)); + goto loop; + } else if (sexp_opcodep(op)) { + res = sexp_length(ctx, sexp_cdr(x)); + if (sexp_unbox_fixnum(res) < sexp_opcode_num_args(op)) { + res = sexp_compile_error(ctx, "not enough args for opcode", x); + } else if ((sexp_unbox_fixnum(res) > sexp_opcode_num_args(op)) + && (! sexp_opcode_variadic_p(op))) { + res = sexp_compile_error(ctx, "too many args for opcode", x); + } else { + res = analyze_app(ctx, sexp_cdr(x)); + if (! sexp_exceptionp(res)) + sexp_push(ctx, res, op); + } + } else { + res = analyze_app(ctx, x); + } + } + } else { + if (! (sexp_truep(sexp_listp(ctx, sexp_car(x))) + || (sexp_synclop(sexp_car(x)) + && sexp_truep(sexp_listp(ctx, + sexp_synclo_expr(sexp_car(x))))))) + sexp_warn(ctx, "invalid operand in application: ", x); + res = analyze_app(ctx, x); + } + } else if (sexp_idp(x)) { + res = analyze_var_ref(ctx, x, NULL); + } else if (sexp_synclop(x)) { + tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + sexp_context_env(tmp) = sexp_synclo_env(x); + sexp_context_fv(tmp) = sexp_append2(tmp, + sexp_synclo_free_vars(x), + sexp_context_fv(tmp)); + x = sexp_synclo_expr(x); + res = analyze(tmp, x); + } else { + res = x; + } + if (sexp_exceptionp(res) && sexp_not(sexp_exception_source(res)) + && sexp_pairp(x)) + sexp_exception_source(res) = sexp_pair_source(x); + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_analyze (sexp ctx, sexp x) {return analyze(ctx, x);} + +/********************** free varable analysis *************************/ + +static sexp insert_free_var (sexp ctx, sexp x, sexp fv) { + sexp name=sexp_ref_name(x), loc=sexp_ref_loc(x), ls; + for (ls=fv; sexp_pairp(ls); ls=sexp_cdr(ls)) + if ((name == sexp_ref_name(sexp_car(ls))) + && (loc == sexp_ref_loc(sexp_car(ls)))) + return fv; + return sexp_cons(ctx, x, fv); +} + +static sexp union_free_vars (sexp ctx, sexp fv1, sexp fv2) { + sexp_gc_var1(res); + if (sexp_nullp(fv2)) + return fv1; + sexp_gc_preserve1(ctx, res); + for (res=fv2; sexp_pairp(fv1); fv1=sexp_cdr(fv1)) + res = insert_free_var(ctx, sexp_car(fv1), res); + sexp_gc_release1(ctx); + return res; +} + +static sexp diff_free_vars (sexp ctx, sexp lambda, sexp fv, sexp params) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; + for ( ; sexp_pairp(fv); fv=sexp_cdr(fv)) + if ((sexp_ref_loc(sexp_car(fv)) != lambda) + || (sexp_memq(NULL, sexp_ref_name(sexp_car(fv)), params) + == SEXP_FALSE)) + sexp_push(ctx, res, sexp_car(fv)); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_free_vars (sexp ctx, sexp x, sexp fv) { + sexp_gc_var2(fv1, fv2); + sexp_gc_preserve2(ctx, fv1, fv2); + fv1 = fv; + if (sexp_lambdap(x)) { + fv1 = sexp_free_vars(ctx, sexp_lambda_body(x), SEXP_NULL); + fv2 = sexp_flatten_dot(ctx, sexp_lambda_params(x)); + fv2 = sexp_append2(ctx, sexp_lambda_locals(x), fv2); + fv2 = diff_free_vars(ctx, x, fv1, fv2); + sexp_lambda_fv(x) = fv2; + fv1 = union_free_vars(ctx, fv2, fv); + } else if (sexp_pairp(x)) { + for ( ; sexp_pairp(x); x=sexp_cdr(x)) + fv1 = sexp_free_vars(ctx, sexp_car(x), fv1); + } else if (sexp_cndp(x)) { + fv1 = sexp_free_vars(ctx, sexp_cnd_test(x), fv); + fv1 = sexp_free_vars(ctx, sexp_cnd_pass(x), fv1); + fv1 = sexp_free_vars(ctx, sexp_cnd_fail(x), fv1); + } else if (sexp_seqp(x)) { + for (x=sexp_seq_ls(x); sexp_pairp(x); x=sexp_cdr(x)) + fv1 = sexp_free_vars(ctx, sexp_car(x), fv1); + } else if (sexp_setp(x)) { + fv1 = sexp_free_vars(ctx, sexp_set_value(x), fv); + fv1 = sexp_free_vars(ctx, sexp_set_var(x), fv1); + } else if (sexp_refp(x) && sexp_lambdap(sexp_ref_loc(x))) { + fv1 = insert_free_var(ctx, x, fv); + } else if (sexp_synclop(x)) { + fv1 = sexp_free_vars(ctx, sexp_synclo_expr(x), fv); + } + sexp_gc_release2(ctx); + return fv1; +} + +/************************ library procedures **************************/ + +static sexp sexp_exception_type_op (sexp ctx sexp_api_params(self, n), sexp exn) { + sexp_assert_type(ctx, sexp_exceptionp, SEXP_EXCEPTION, exn); + return sexp_exception_kind(exn); +} + +static sexp sexp_open_input_file_op (sexp ctx sexp_api_params(self, n), sexp path) { + FILE *in; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path); + in = fopen(sexp_string_data(path), "r"); + if (! in) + return sexp_user_exception(ctx, self, "couldn't open input file", path); + return sexp_make_input_port(ctx, in, path); +} + +static sexp sexp_open_output_file_op (sexp ctx sexp_api_params(self, n), sexp path) { + FILE *out; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path); + out = fopen(sexp_string_data(path), "w"); + if (! out) + return sexp_user_exception(ctx, self, "couldn't open output file", path); + return sexp_make_output_port(ctx, out, path); +} + +static sexp sexp_close_port_op (sexp ctx sexp_api_params(self, n), sexp port) { + sexp_assert_type(ctx, sexp_portp, SEXP_OPORT, port); + if (! sexp_port_openp(port)) + return sexp_user_exception(ctx, self, "port already closed", port); + return sexp_finalize_port(ctx sexp_api_pass(self, n), port); +} + +#if SEXP_USE_DL +#ifdef __MINGW32__ +#include +static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { + sexp_proc2 init; + HINSTANCE handle = LoadLibraryA(sexp_string_data(file)); + if(!handle) + return sexp_compile_error(ctx, "couldn't load dynamic library", file); + init = (sexp_proc2) GetProcAddress(handle, "sexp_init_library"); + if(!init) { + FreeLibrary(handle); + return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file); + } + return init(ctx sexp_api_pass(NULL, 1), env); +} +#else +static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { + sexp_proc2 init; + void *handle = dlopen(sexp_string_data(file), RTLD_LAZY); + if (! handle) + return sexp_compile_error(ctx, "couldn't load dynamic library", file); + init = dlsym(handle, "sexp_init_library"); + if (! init) { + dlclose(handle); + return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file); + } + return init(ctx sexp_api_pass(NULL, 1), env); +} +#endif +#endif + +sexp sexp_load_op (sexp ctx sexp_api_params(self, n), sexp source, sexp env) { +#if SEXP_USE_DL + char *suffix; +#endif + sexp tmp, out=SEXP_FALSE; + sexp_gc_var4(ctx2, x, in, res); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, source); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); +#if SEXP_USE_DL + suffix = sexp_string_data(source) + + sexp_string_length(source) - strlen(sexp_so_extension); + if (strcmp(suffix, sexp_so_extension) == 0) { + res = sexp_load_dl(ctx, source, env); + } else { +#endif + sexp_gc_preserve4(ctx, ctx2, x, in, res); + res = SEXP_VOID; + in = sexp_open_input_file(ctx, source); + out = sexp_current_error_port(ctx); + ctx2 = sexp_make_eval_context(ctx, NULL, env, 0); + sexp_context_parent(ctx2) = ctx; + tmp = sexp_env_bindings(env); + sexp_context_tailp(ctx2) = 0; + if (sexp_exceptionp(in)) { + if (sexp_not(out)) out = sexp_current_error_port(ctx); + if (sexp_oportp(out)) + sexp_print_exception(ctx, in, out); + res = in; + } else { + sexp_port_sourcep(in) = 1; + while ((x=sexp_read(ctx, in)) != (sexp) SEXP_EOF) { + res = sexp_eval(ctx2, x, env); + if (sexp_exceptionp(res)) + break; + } + if (x == SEXP_EOF) + res = SEXP_VOID; + sexp_close_port(ctx, in); + } +#if SEXP_USE_WARN_UNDEFS + if (! sexp_exceptionp(res)) + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp); +#endif + sexp_gc_release4(ctx); +#if SEXP_USE_DL + } +#endif + return res; +} + +#if SEXP_USE_MATH + +#if SEXP_USE_BIGNUMS +#define maybe_convert_bignum(z) \ + else if (sexp_bignump(z)) d = sexp_bignum_to_double(z); +#else +#define maybe_convert_bignum(z) +#endif + +#define define_math_op(name, cname) \ + static sexp name (sexp ctx sexp_api_params(self, n), sexp z) { \ + double d; \ + if (sexp_flonump(z)) \ + d = sexp_flonum_value(z); \ + else if (sexp_fixnump(z)) \ + d = (double)sexp_unbox_fixnum(z); \ + maybe_convert_bignum(z) \ + else \ + return sexp_type_exception(ctx, self, SEXP_NUMBER, z); \ + return sexp_make_flonum(ctx, cname(d)); \ + } + +define_math_op(sexp_exp, exp) +define_math_op(sexp_log, log) +define_math_op(sexp_sin, sin) +define_math_op(sexp_cos, cos) +define_math_op(sexp_tan, tan) +define_math_op(sexp_asin, asin) +define_math_op(sexp_acos, acos) +define_math_op(sexp_atan, atan) +define_math_op(sexp_round, round) +define_math_op(sexp_trunc, trunc) +define_math_op(sexp_floor, floor) +define_math_op(sexp_ceiling, ceil) + +static sexp sexp_sqrt (sexp ctx sexp_api_params(self, n), sexp z) { + double d, r; + if (sexp_flonump(z)) + d = sexp_flonum_value(z); + else if (sexp_fixnump(z)) + d = (double)sexp_unbox_fixnum(z); + maybe_convert_bignum(z) /* XXXX add bignum sqrt */ + else + return sexp_type_exception(ctx, self, SEXP_NUMBER, z); + r = sqrt(d); + if (sexp_fixnump(z) && ((r*r) == (double)sexp_unbox_fixnum(z))) + return sexp_make_fixnum(round(r)); + else + return sexp_make_flonum(ctx, r); +} + +#endif + +static sexp sexp_expt_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { + long double f, x1, e1; + sexp res; +#if SEXP_USE_BIGNUMS + if (sexp_bignump(e)) { /* bignum exponent needs special handling */ + if ((x == SEXP_ZERO) || (x == SEXP_NEG_ONE)) + res = sexp_make_flonum(ctx, pow(0, 0)); /* +nan.0 */ + else if (x == SEXP_ONE) + res = SEXP_ONE; /* 1.0 */ + else if (sexp_flonump(x)) + res = sexp_make_flonum(ctx, pow(sexp_flonum_value(x), sexp_bignum_to_double(e))); + else + res = sexp_make_flonum(ctx, pow(10.0, 1e100)); /* +inf.0 */ + } else if (sexp_bignump(x)) { + res = sexp_bignum_expt(ctx, x, e); + } else { +#endif + if (sexp_fixnump(x)) + x1 = sexp_unbox_fixnum(x); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(x)) + x1 = sexp_flonum_value(x); +#endif + else + return sexp_type_exception(ctx, self, SEXP_FIXNUM, x); + if (sexp_fixnump(e)) + e1 = sexp_unbox_fixnum(e); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(e)) + e1 = sexp_flonum_value(e); +#endif + else + return sexp_type_exception(ctx, self, SEXP_FIXNUM, e); + f = pow(x1, e1); + if ((f > SEXP_MAX_FIXNUM) || (f < SEXP_MIN_FIXNUM) +#if SEXP_USE_FLONUMS + || (! sexp_fixnump(x)) || (! sexp_fixnump(e)) +#endif + ) { +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(x) && sexp_fixnump(e)) + res = sexp_bignum_expt(ctx, sexp_fixnum_to_bignum(ctx, x), e); + else +#endif +#if SEXP_USE_FLONUMS + res = sexp_make_flonum(ctx, f); +#else + res = sexp_make_fixnum((sexp_sint_t)round(f)); +#endif + } else + res = sexp_make_fixnum((sexp_sint_t)round(f)); +#if SEXP_USE_BIGNUMS + } +#endif + return res; +} + +static sexp sexp_string_cmp_op (sexp ctx sexp_api_params(self, n), sexp str1, sexp str2, sexp ci) { + sexp_sint_t len1, len2, len, diff; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str1); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str2); + len1 = sexp_string_length(str1); + len2 = sexp_string_length(str2); + len = ((len1>4)&1)+3; +} + +static int sexp_utf8_char_byte_count(int c) { + if (c < 0x80) return 1; + if (c < 0x800) return 2; + if (c < 0x10000) return 3; + return 4; +} + +static int sexp_string_utf8_length (unsigned char *p, int len) { + unsigned char *q = p+len; + int i; + for (i=0; p0 && j0) + return sexp_user_exception(ctx, self, "string-index->offset: index out of range", index); + return sexp_make_fixnum(j); +} + +sexp sexp_string_utf8_ref (sexp ctx, sexp str, sexp i) { + unsigned char *p=(unsigned char*)sexp_string_data(str) + sexp_unbox_fixnum(i); + if (*p < 0x80) + return sexp_make_character(*p); + else if ((*p < 0xC0) || (*p > 0xF7)) + return sexp_user_exception(ctx, NULL, "string-ref: invalid utf8 byte", i); + else if (*p < 0xE0) + return sexp_make_character(((p[0]&0x3F)<<6) + (p[1]&0x3F)); + else if (*p < 0xF0) + return sexp_make_character(((p[0]&0x1F)<<12) + ((p[1]&0x3F)<<6) + (p[2]&0x3F)); + else + return sexp_make_character(((p[0]&0x0F)<<16) + ((p[1]&0x3F)<<6) + ((p[2]&0x3F)<<6) + (p[2]&0x3F)); +} + +sexp sexp_string_utf8_index_ref (sexp ctx sexp_api_params(self, n), sexp str, sexp i) { + sexp off; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i); + off = sexp_string_index_to_offset(ctx sexp_api_pass(self, n), str, i); + if (sexp_exceptionp(off)) return off; + return sexp_string_utf8_ref(ctx, str, off); +} + +void sexp_utf8_encode_char (unsigned char* p, int len, int c) { + switch (len) { + case 4: *p++ = (0xF0 + ((c)>>18)); *p++ = (0x80 + ((c>>12)&0x3F)); + *p++ = (0x80 + ((c>>6)&0x3F)); *p = (0x80 + (c&0x3F)); break; + case 3: *p++ = (0xE0 + ((c)>>12)); *p++ = (0x80 + ((c>>6)&0x3F)); + *p = (0x80 + (c&0x3F)); break; + case 2: *p++ = (0xC0 + ((c)>>6)); *p = (0x80 + (c&0x3F)); break; + default: *p = c; break; + } +} + +void sexp_write_utf8_char (sexp ctx, int c, sexp out) { + unsigned char buf[8]; + int len = sexp_utf8_char_byte_count(c); + sexp_utf8_encode_char(buf, len, c); + buf[len+1] = 0; + sexp_write_string(ctx, (char*)buf, out); +} + +sexp sexp_read_utf8_char (sexp ctx, sexp port, int i) { + if (i >= 0x80) { + if ((i < 0xC0) || (i > 0xF7)) { + return sexp_user_exception(ctx, NULL, "read-char: invalid utf8 byte", sexp_make_fixnum(i)); + } else if (i < 0xE0) { + i = ((i&0x3F)<<6) + (sexp_read_char(ctx, port)&0x3F); + } else if (i < 0xF0) { + i = ((i&0x1F)<<12) + ((sexp_read_char(ctx, port)&0x3F)<<6); + i += sexp_read_char(ctx, port)&0x3F; + } else { + i = ((i&0x0F)<<16) + ((sexp_read_char(ctx, port)&0x3F)<<6); + i += (sexp_read_char(ctx, port)&0x3F)<<6; + i += sexp_read_char(ctx, port)&0x3F; + } + } + return sexp_make_character(i); +} + +#if SEXP_USE_MUTABLE_STRINGS + +void sexp_string_utf8_set (sexp ctx, sexp str, sexp index, sexp ch) { + sexp b; + unsigned char *p, *q; + int i = sexp_unbox_fixnum(index), c = sexp_unbox_character(ch), + old_len, new_len, len; + p = (unsigned char*)sexp_string_data(str) + i; + old_len = sexp_utf8_initial_byte_count(*p); + new_len = sexp_utf8_char_byte_count(c); + if (old_len != new_len) { /* resize bytes if needed */ + len = sexp_string_length(str)+(new_len-old_len); + b = sexp_make_bytes(ctx, sexp_make_fixnum(len), SEXP_VOID); + if (! sexp_exceptionp(b)) { + q = (unsigned char*)sexp_bytes_data(b); + memcpy(q, sexp_string_data(str), i); + memcpy(q+i+new_len, p+old_len, len-i-new_len+1); + sexp_string_bytes(str) = b; + p = q + i; + } + sexp_string_length(str) += new_len - old_len; + } + sexp_utf8_encode_char(p, new_len, c); +} + +sexp sexp_string_utf8_index_set (sexp ctx sexp_api_params(self, n), sexp str, sexp i, sexp ch) { + sexp off; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i); + sexp_assert_type(ctx, sexp_charp, SEXP_CHAR, ch); + off = sexp_string_index_to_offset(ctx sexp_api_pass(self, n), str, i); + if (sexp_exceptionp(off)) return off; + sexp_string_utf8_set(ctx, str, off, ch); + return SEXP_VOID; +} + +#endif +#endif + +#ifdef PLAN9 +#include "opt/plan9.c" +#endif + +/************************** optimizations *****************************/ + +#if SEXP_USE_SIMPLIFY +#include "opt/simplify.c" +#endif + +/***************************** opcodes ********************************/ + +#include "opcodes.c" + +static sexp sexp_copy_core (sexp ctx, struct sexp_core_form_struct *core) { + sexp res = sexp_alloc_type(ctx, core, SEXP_CORE); + memcpy(&(res->value), core, sizeof(core[0])); + return res; +} + +static sexp 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_make_opcode (sexp ctx, sexp self, sexp name, sexp op_class, sexp code, + sexp num_args, sexp flags, sexp arg1t, sexp arg2t, + sexp invp, sexp data, sexp data2, sexp_proc1 func) { + sexp res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, num_args); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, flags); + if ((! sexp_fixnump(op_class)) || (sexp_unbox_fixnum(op_class) <= 0) + || (sexp_unbox_fixnum(op_class) >= SEXP_OPC_NUM_OP_CLASSES)) + res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode class", op_class); + else if ((! sexp_fixnump(code)) || (sexp_unbox_fixnum(code) <= 0) + || (sexp_unbox_fixnum(code) >= SEXP_OP_NUM_OPCODES)) + res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode", code); + else { + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = sexp_unbox_fixnum(op_class); + sexp_opcode_code(res) = sexp_unbox_fixnum(code); + sexp_opcode_num_args(res) = sexp_unbox_fixnum(num_args); + sexp_opcode_flags(res) = sexp_unbox_fixnum(flags); + sexp_opcode_arg1_type(res) = arg1t; + sexp_opcode_arg2_type(res) = arg2t; + sexp_opcode_inverse(res) = sexp_unbox_fixnum(invp); + sexp_opcode_data(res) = data; + sexp_opcode_data2(res) = data2; + sexp_opcode_func(res) = func; + sexp_opcode_name(res) = strdup(sexp_string_data(name)); + } + return res; +} + +sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { + sexp res; +#if ! SEXP_USE_EXTENDED_FCALL + if (num_args > 4) + return sexp_user_exception(ctx, NULL, "make-foreign: exceeded foreign arg limit", + sexp_make_fixnum(num_args)); +#endif + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = SEXP_OPC_FOREIGN; +#if SEXP_USE_EXTENDED_FCALL + if (num_args > 4) + sexp_opcode_code(res) = SEXP_OP_FCALLN; + else +#endif + sexp_opcode_code(res) = SEXP_OP_FCALL1+num_args-1; + if (flags & 1) num_args--; + sexp_opcode_num_args(res) = num_args; + sexp_opcode_flags(res) = flags; + sexp_opcode_name(res) = name; + sexp_opcode_data(res) = data; + sexp_opcode_func(res) = f; + return res; +} + +sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { + sexp res = SEXP_VOID; + sexp_gc_var1(op); + sexp_gc_preserve1(ctx, op); + op = sexp_make_foreign(ctx, name, num_args, flags, f, data); + if (sexp_exceptionp(op)) + res = op; + else + sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), op); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_args, + sexp_proc1 f, const char *param) { + sexp res; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_intern(ctx, param, -1); + tmp = sexp_env_cell(env, tmp); + res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, f, tmp); + sexp_gc_release1(ctx); + return res; +} + +#if SEXP_USE_TYPE_DEFS + +sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) { + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type); + return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE), + sexp_make_fixnum(SEXP_OP_TYPEP), SEXP_ONE, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, NULL, NULL); +} + +sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) { + sexp_uint_t type_size; + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type); + type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type))); + return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR), + sexp_make_fixnum(SEXP_OP_MAKE), SEXP_ZERO, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, + sexp_make_fixnum(type_size), NULL); +} + +sexp sexp_make_getter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) { + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); + if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); + if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, index); + return + sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_GETTER), + sexp_make_fixnum(SEXP_OP_SLOT_REF), SEXP_ONE, SEXP_ZERO, + type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); +} + +sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) { + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); + if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); + if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, index); + return + sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_SETTER), + sexp_make_fixnum(SEXP_OP_SLOT_SET), SEXP_TWO, SEXP_ZERO, + type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); +} + +#endif + +#if SEXP_USE_STATIC_LIBS +#include "clibs.c" +#endif + +/*********************** standard environment *************************/ + +static struct sexp_core_form_struct core_forms[] = { + {SEXP_CORE_DEFINE, "define"}, + {SEXP_CORE_SET, "set!"}, + {SEXP_CORE_LAMBDA, "lambda"}, + {SEXP_CORE_IF, "if"}, + {SEXP_CORE_BEGIN, "begin"}, + {SEXP_CORE_QUOTE, "quote"}, + {SEXP_CORE_SYNTAX_QUOTE, "syntax-quote"}, + {SEXP_CORE_DEFINE_SYNTAX, "define-syntax"}, + {SEXP_CORE_LET_SYNTAX, "let-syntax"}, + {SEXP_CORE_LETREC_SYNTAX, "letrec-syntax"}, +}; + +sexp sexp_make_env_op (sexp ctx sexp_api_params(self, n)) { + sexp e = sexp_alloc_type(ctx, env, SEXP_ENV); + sexp_env_lambda(e) = NULL; + sexp_env_parent(e) = NULL; + sexp_env_bindings(e) = SEXP_NULL; + return e; +} + +sexp sexp_make_null_env_op (sexp ctx sexp_api_params(self, n), sexp version) { + sexp_uint_t i; + sexp e = sexp_make_env(ctx), core; + for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) { + core = sexp_copy_core(ctx, &core_forms[i]); + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_core_name(core), -1), core); + } + return e; +} + +sexp sexp_make_primitive_env (sexp ctx, sexp version) { + int i; + sexp_gc_var3(e, op, sym); + sexp_gc_preserve3(ctx, e, op, sym); + e = sexp_make_null_env(ctx, version); + for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { + op = sexp_copy_opcode(ctx, &opcodes[i]); + if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) { + sym = sexp_intern(ctx, (char*)sexp_opcode_data(op), -1); + sexp_opcode_data(op) = sexp_env_cell_create(ctx, e, sym, SEXP_VOID, NULL); + } + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op), -1), op); + } + sexp_gc_release3(ctx); + return e; +} + +sexp sexp_find_module_file (sexp ctx, const char *file) { + sexp res=SEXP_FALSE, ls; + char *dir, *path; + sexp_uint_t slash, dirlen, filelen, len; +#ifdef PLAN9 +#define file_exists_p(path, buf) (stat(path, buf, 128) >= 0) + unsigned char buf[128]; +#else +#define file_exists_p(path, buf) (! stat(path, buf)) + struct stat buf_str; + struct stat *buf = &buf_str; +#endif + + filelen = strlen(file); + + ls = sexp_global(ctx, SEXP_G_MODULE_PATH); + for ( ; sexp_pairp(ls) && sexp_not(res); ls=sexp_cdr(ls)) { + dir = sexp_string_data(sexp_car(ls)); + dirlen = sexp_string_length(sexp_car(ls)); + slash = dir[dirlen-1] == '/'; + len = dirlen+filelen+2-slash; + path = (char*) malloc(len); + memcpy(path, dir, dirlen); + if (! slash) path[dirlen] = '/'; + memcpy(path+len-filelen-1, file, filelen); + path[len-1] = '\0'; + if (file_exists_p(path, buf)) + res = sexp_c_string(ctx, path, len-1); + free(path); + } + + return res; +} + +#define sexp_file_not_found "couldn't find file in module path" + +sexp sexp_load_module_file (sexp ctx, const char *file, sexp env) { + sexp res; + sexp_gc_var1(path); + sexp_gc_preserve1(ctx, path); + path = sexp_find_module_file(ctx, file); + if (sexp_stringp(path)) { + res = sexp_load(ctx, path, env); + } else { + path = sexp_c_string(ctx, file, -1); + res = sexp_user_exception(ctx, SEXP_FALSE, sexp_file_not_found, path); + } + sexp_gc_release1(ctx); + return res; +} + +#if SEXP_USE_MODULES +sexp sexp_find_module_file_op (sexp ctx sexp_api_params(self, n), sexp file) { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file); + return sexp_find_module_file(ctx, sexp_string_data(file)); +} +sexp sexp_load_module_file_op (sexp ctx sexp_api_params(self, n), sexp file, sexp env) { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + return sexp_load_module_file(ctx, sexp_string_data(file), env); +} +sexp sexp_current_environment (sexp ctx sexp_api_params(self, n)) { + return sexp_context_env(ctx); +} +#endif + +sexp sexp_add_module_directory_op (sexp ctx sexp_api_params(self, n), sexp dir, sexp appendp) { + sexp ls; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, dir); + if (sexp_truep(appendp)) { + if (sexp_pairp(ls=sexp_global(ctx, SEXP_G_MODULE_PATH))) { + for ( ; sexp_pairp(sexp_cdr(ls)); ls=sexp_cdr(ls)) + ; + sexp_cdr(ls) = sexp_list1(ctx, dir); + } else { + sexp_global(ctx, SEXP_G_MODULE_PATH) = sexp_list1(ctx, dir); + } + } else { + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), dir); + } + return SEXP_VOID; +} + +sexp sexp_load_standard_parameters (sexp ctx, sexp e) { + /* add io port and interaction env parameters */ + sexp p = sexp_make_input_port(ctx, stdin, SEXP_FALSE); + sexp_port_no_closep(p) = 1; + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), p); + p = sexp_make_output_port(ctx, stdout, SEXP_FALSE); + sexp_port_no_closep(p) = 1; + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), p); + p = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_port_no_closep(p) = 1; + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), p); + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e); + return SEXP_VOID; +} + +sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { + sexp_gc_var3(op, tmp, sym); + sexp_gc_preserve3(ctx, op, tmp, sym); + sexp_load_standard_parameters(ctx, e); +#if SEXP_USE_DL + sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*shared-object-extension*", -1), + tmp=sexp_c_string(ctx, sexp_so_extension, -1)); +#endif + tmp = sexp_list1(ctx, sym=sexp_intern(ctx, sexp_platform, -1)); +#if SEXP_USE_DL + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "dynamic-loading", -1)); +#endif +#if SEXP_USE_MODULES + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "modules", -1)); +#endif +#if SEXP_USE_BOEHM + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "boehm-gc", -1)); +#endif +#if SEXP_USE_UTF8_STRINGS + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "utf-8", -1)); +#endif +#if SEXP_USE_GREEN_THREADS + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "threads", -1)); +#endif + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi", -1)); + sexp_env_define(ctx, e, sexp_intern(ctx, "*features*", -1), tmp); + sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL; +#if SEXP_USE_SIMPLIFY + op = sexp_make_foreign(ctx, "simplify", 1, 0, + (sexp_proc1)sexp_simplify, SEXP_VOID); + tmp = sexp_cons(ctx, sexp_make_fixnum(500), op); + sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp); +#endif + /* load init.scm */ + tmp = sexp_load_module_file(ctx, sexp_init_file, e); + /* load and bind config env */ +#if SEXP_USE_MODULES + if (! sexp_exceptionp(tmp)) { + sym = sexp_intern(ctx, "*config-env*", -1); + if (! sexp_envp(tmp=sexp_global(ctx, SEXP_G_CONFIG_ENV))) { + tmp = sexp_make_env(ctx); + if (! sexp_exceptionp(tmp)) { + sexp_global(ctx, SEXP_G_CONFIG_ENV) = tmp; + sexp_env_parent(tmp) = e; + op = sexp_load_module_file(ctx, sexp_config_file, tmp); + if (sexp_exceptionp(op)) + sexp_print_exception(ctx, op, sexp_current_error_port(ctx)); + sexp_env_define(ctx, tmp, sym, tmp); + } + } + sexp_env_define(ctx, e, sym, tmp); + } +#endif +#if SEXP_USE_STATIC_LIBS + sexp_init_all_libraries(ctx, e); +#endif + sexp_gc_release3(ctx); + return sexp_exceptionp(tmp) ? tmp : e; +} + +sexp sexp_make_standard_env_op (sexp ctx sexp_api_params(self, n), sexp version) { + sexp_gc_var1(env); + sexp_gc_preserve1(ctx, env); + env = sexp_make_primitive_env(ctx, version); + if (! sexp_exceptionp(env)) sexp_load_standard_env(ctx, env, version); + sexp_gc_release1(ctx); + return env; +} + +sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, sexp ls, sexp immutp) { + sexp oldname, newname, value; + if (! sexp_envp(to)) to = sexp_context_env(ctx); + if (! sexp_envp(from)) from = sexp_context_env(ctx); + if (sexp_not(ls)) { + if (sexp_truep(immutp)) { + value = sexp_make_env(ctx); + sexp_env_parent(value) = sexp_env_parent(to); + sexp_env_parent(to) = value; + sexp_immutablep(value) = 1; + sexp_env_bindings(value) = sexp_env_bindings(from); + } else { + for (ls=sexp_env_bindings(from); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + sexp_env_define(ctx, to, sexp_car(ls), sexp_cdr(ls)); + } + } else { + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { + if (sexp_pairp(sexp_car(ls))) { + newname = sexp_caar(ls); oldname = sexp_cdar(ls); + } else { + newname = oldname = sexp_car(ls); + } + value = sexp_env_ref(from, oldname, SEXP_UNDEF); + if (value != SEXP_UNDEF) { + sexp_env_define(ctx, to, newname, value); +#if SEXP_USE_WARN_UNDEFS + } else { + sexp_warn(ctx, "importing undefined variable: ", oldname); +#endif + } + } + } + return SEXP_VOID; +} + +/************************* backend ***************************/ + +#if SEXP_USE_NATIVE_X86 +#include "opt/x86.c" +#else +#include "vm.c" +#endif + +/************************** eval interface ****************************/ + +sexp sexp_compile (sexp ctx, sexp x) { + sexp_gc_var3(ast, vec, res); + sexp_gc_preserve3(ctx, ast, vec, res); + ast = sexp_analyze(ctx, x); + if (sexp_exceptionp(ast)) { + res = ast; + } else { + res = sexp_global(ctx, SEXP_G_OPTIMIZATIONS); + for ( ; sexp_pairp(res); res=sexp_cdr(res)) + ast = sexp_apply1(ctx, sexp_cdar(res), ast); + sexp_free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ + emit_enter(ctx); + generate(ctx, ast); + res = finalize_bytecode(ctx); + vec = sexp_make_vector(ctx, 0, SEXP_VOID); + res = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, res, vec); + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_eval_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp env) { + sexp_sint_t top; + sexp ctx2; + sexp_gc_var2(res, err_handler); + if (! env) env = sexp_context_env(ctx); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + sexp_gc_preserve2(ctx, res, err_handler); + top = sexp_context_top(ctx); + err_handler = sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)); + sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = SEXP_FALSE; + ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), env, 0); + sexp_context_child(ctx) = ctx2; + res = sexp_compile(ctx2, obj); + if (! sexp_exceptionp(res)) + res = sexp_apply(ctx2, res, SEXP_NULL); + sexp_context_child(ctx) = SEXP_FALSE; + sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = err_handler; + sexp_context_top(ctx) = top; + sexp_context_last_fp(ctx) = sexp_context_last_fp(ctx2); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_eval_string (sexp ctx, const char *str, sexp_sint_t len, sexp env) { + sexp res; + sexp_gc_var1(obj); + sexp_gc_preserve1(ctx, obj); + obj = sexp_read_from_string(ctx, str, len); + res = sexp_eval(ctx, obj, env); + sexp_gc_release1(ctx); + return res; +} + +void sexp_scheme_init (void) { + if (! scheme_initialized_p) { + scheme_initialized_p = 1; + sexp_init(); + } +} diff --git a/gc.c b/gc.c new file mode 100644 index 00000000..af7b3986 --- /dev/null +++ b/gc.c @@ -0,0 +1,346 @@ +/* gc.c -- simple mark&sweep garbage collector */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/sexp.h" + +#if SEXP_USE_MMAP_GC +#include +#endif + +#define SEXP_MINIMUM_OBJECT_SIZE (sexp_heap_align(sexp_sizeof(pair))) + +#if SEXP_USE_GLOBAL_HEAP +sexp_heap sexp_global_heap; +#endif + +#if SEXP_USE_CONSERVATIVE_GC +static sexp* stack_base; +#endif + +static sexp_heap sexp_heap_last (sexp_heap h) { + while (h->next) h = h->next; + return h; +} + +sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) { + sexp_uint_t res; + sexp t; + if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx))) + return sexp_heap_align(1); + t = sexp_object_type(ctx, x); + res = sexp_type_size_of_object(t, x); + return res; +} + +#if SEXP_USE_SAFE_GC_MARK +static int sexp_in_heap(sexp ctx, sexp_uint_t x) { + sexp_heap h; + if (x & (sexp_heap_align(1)-1)) { + fprintf(stderr, "invalid heap alignment: %p %d\n", (sexp)x, sexp_pointer_tag((sexp)x)); + return 0; + } + for (h=sexp_context_heap(ctx); h; h=h->next) + if (((sexp_uint_t)h < x) && (x < (sexp_uint_t)(h->data + h->size))) + return 1; + fprintf(stderr, "invalid object outside heap: %p %d\n", (sexp)x, sexp_pointer_tag((sexp)x)); + return 0; +} +#endif + +#if SEXP_USE_DEBUG_GC +#include "opt/gc_debug.c" +#endif + +void sexp_mark (sexp ctx, sexp x) { + sexp_sint_t i, len; + sexp t, *p; + struct sexp_gc_var_t *saves; + loop: + if ((! x) || (! sexp_pointerp(x)) || sexp_gc_mark(x)) + return; +#if SEXP_USE_SAFE_GC_MARK + if (! sexp_in_heap(ctx, (sexp_uint_t)x)) + return; +#endif +#if SEXP_USE_HEADER_MAGIC + if (sexp_pointer_magic(x) != SEXP_POINTER_MAGIC && sexp_pointer_tag(x) != SEXP_TYPE + && sexp_pointer_tag(x) != SEXP_OPCODE && sexp_pointer_tag(x) != SEXP_CORE + && sexp_pointer_tag(x) != SEXP_STACK) + return; +#endif + sexp_gc_mark(x) = 1; + if (sexp_contextp(x)) + for (saves=sexp_context_saves(x); saves; saves=saves->next) + if (saves->var) sexp_mark(ctx, *(saves->var)); + t = sexp_object_type(ctx, x); + p = (sexp*) (((char*)x) + sexp_type_field_base(t)); + len = sexp_type_num_slots_of_object(t, x) - 1; + if (len >= 0) { + for (i=0; inext) { + p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair))); + q = h->free_list; + end = (sexp) ((char*)h->data + h->size - sexp_heap_align(sexp_sizeof(pair))); + while (p < end) { + /* find the preceding and succeeding free list pointers */ + for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next) + ; + if ((char*)r == (char*)p) { /* this is a free block, skip it */ + p = (sexp) (((char*)p) + r->size); + continue; + } + size = sexp_heap_align(sexp_allocated_bytes(ctx, p)); + if ((! sexp_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) { + /* free p */ + finalizer = sexp_type_finalize(sexp_object_type(ctx, p)); + if (finalizer) finalizer(ctx sexp_api_pass(NULL, 1), p); + sum_freed += size; + if (((((char*)q) + q->size) == (char*)p) && (q != h->free_list)) { + /* merge q with p */ + if (r && ((((char*)p)+size) == (char*)r)) { + /* ... and with r */ + q->next = r->next; + freed = q->size + size + r->size; + p = (sexp) (((char*)p) + size + r->size); + } else { + freed = q->size + size; + p = (sexp) (((char*)p)+size); + } + q->size = freed; + } else { + s = (sexp_free_list)p; + if (r && ((((char*)p)+size) == (char*)r)) { + /* merge p with r */ + s->size = size + r->size; + s->next = r->next; + q->next = s; + freed = size + r->size; + } else { + s->size = size; + s->next = r; + q->next = s; + freed = size; + } + p = (sexp) (((char*)p)+freed); + } + if (freed > max_freed) + max_freed = freed; + } else { + sexp_gc_mark(p) = 0; + p = (sexp) (((char*)p)+size); + } + } + } + if (sum_freed_ptr) *sum_freed_ptr = sum_freed; + return sexp_make_fixnum(max_freed); +} + +sexp sexp_gc (sexp ctx, size_t *sum_freed) { + sexp res; +#if SEXP_USE_GLOBAL_SYMBOLS + int i; + for (i=0; isize = size; + h->data = (char*) sexp_heap_align((sexp_uint_t)&(h->data)); + free = h->free_list = (sexp_free_list) h->data; + h->next = NULL; + next = (sexp_free_list) (((char*)free) + sexp_heap_align(sexp_sizeof(pair))); + free->size = 0; /* actually sexp_sizeof(pair) */ + free->next = next; + next->size = size - sexp_heap_align(sexp_sizeof(pair)); + next->next = NULL; + return h; +} + +int sexp_grow_heap (sexp ctx, size_t size) { + size_t cur_size, new_size; + sexp_heap h = sexp_heap_last(sexp_context_heap(ctx)); + cur_size = h->size; + new_size = sexp_heap_align(((cur_size > size) ? cur_size : size) * 2); + h->next = sexp_make_heap(new_size); + return (h->next != NULL); +} + +void* sexp_try_alloc (sexp ctx, size_t size) { + sexp_free_list ls1, ls2, ls3; + sexp_heap h; + for (h=sexp_context_heap(ctx); h; h=h->next) + for (ls1=h->free_list, ls2=ls1->next; ls2; ls1=ls2, ls2=ls2->next) + if (ls2->size >= size) { + if (ls2->size >= (size + SEXP_MINIMUM_OBJECT_SIZE)) { + ls3 = (sexp_free_list) (((char*)ls2)+size); /* the tail after ls2 */ + ls3->size = ls2->size - size; + ls3->next = ls2->next; + ls1->next = ls3; + } else { /* take the whole chunk */ + ls1->next = ls2->next; + } + memset((void*)ls2, 0, size); + return ls2; + } + return NULL; +} + +void* sexp_alloc (sexp ctx, size_t size) { + void *res; + size_t max_freed, sum_freed, total_size; + sexp_heap h; + size = sexp_heap_align(size); + res = sexp_try_alloc(ctx, size); + if (! res) { + max_freed = sexp_unbox_fixnum(sexp_gc(ctx, &sum_freed)); + for (total_size=0, h=sexp_context_heap(ctx); h->next; h=h->next) + total_size += h->size; + total_size += h->size; + if (((max_freed < size) + || ((total_size > sum_freed) + && (total_size - sum_freed) > (total_size*SEXP_GROW_HEAP_RATIO))) + && ((!SEXP_MAXIMUM_HEAP_SIZE) || (total_size < SEXP_MAXIMUM_HEAP_SIZE))) + sexp_grow_heap(ctx, size); + res = sexp_try_alloc(ctx, size); + if (! res) + res = sexp_global(ctx, SEXP_G_OOM_ERROR); + } + return res; +} + +#if ! SEXP_USE_GLOBAL_HEAP + +sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) { + sexp_sint_t i, off, len, freep; + sexp_heap to, from = sexp_context_heap(ctx); + sexp_free_list q; + sexp p, p2, t, end, *v; + freep = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_FREEP); + + /* validate input, creating a new heap if needed */ + if (from->next) { + return sexp_user_exception(ctx, NULL, "can't copy a non-contiguous heap", ctx); + } else if (! dst || sexp_not(dst)) { + to = sexp_make_heap(from->size); + dst = (sexp) ((char*)ctx + ((char*)to - (char*)from)); + } else if (! sexp_contextp(dst)) { + return sexp_type_exception(ctx, NULL, SEXP_CONTEXT, dst); + } else if (sexp_context_heap(dst)->size < from->size) { + return sexp_user_exception(ctx, NULL, "destination context too small", dst); + } else { + to = sexp_context_heap(dst); + } + + /* copy the raw data */ + off = (char*)to - (char*)from; + memcpy(to, from, sexp_heap_pad_size(from->size)); + to->free_list = (sexp_free_list) ((char*)to->free_list + off); + to->data += off; + end = (sexp) (from->data + from->size); + + /* adjust the free list */ + for (q=to->free_list; q->next; q=q->next) + q->next = (sexp_free_list) ((char*)q->next + off); + + /* adjust if the destination is larger */ + if (from->size < to->size) { + if (((char*)q + q->size - off) >= (char*)end) { + q->size += (to->size - from->size); + } else { + q->next = (sexp_free_list) ((char*)end + off); + q->next->next = NULL; + q->next->size = (to->size - from->size); + } + } + + /* adjust data by traversing over the _original_ heap */ + p = (sexp) (from->data + sexp_heap_align(sexp_sizeof(pair))); + q = from->free_list; + while (p < end) { + /* find the next free list pointer */ + for ( ; q && ((char*)q < (char*)p); q=q->next) + ; + if ((char*)q == (char*)p) { /* this is a free block, skip it */ + p = (sexp) (((char*)p) + q->size); + } else { + t = sexp_object_type(ctx, p); + len = sexp_type_num_slots_of_object(t, p); + p2 = (sexp)((char*)p + off); + v = (sexp*) ((char*)p2 + sexp_type_field_base(t)); + /* offset any pointers in the _destination_ heap */ + for (i=0; i 6 args */ +/* #define SEXP_USE_EXTENDED_FCALL 0 */ + +/* uncomment this if you don't need flonum support */ +/* This is only for EVAL - you'll still be able to read */ +/* and write flonums directly through the sexp API. */ +/* #define SEXP_USE_FLONUMS 0 */ + +/* uncomment this to disable reading/writing IEEE infinities */ +/* By default you can read/write +inf.0, -inf.0 and +nan.0 */ +/* #define SEXP_USE_INFINITIES 0 */ + +/* uncomment this if you want immediate flonums */ +/* This is experimental, enable at your own risk. */ +/* #define SEXP_USE_IMMEDIATE_FLONUMS 1 */ + +/* uncomment this if you don't want bignum support */ +/* Bignums are implemented with a small, custom library */ +/* in opt/bignum.c. */ +/* #define SEXP_USE_BIGNUMS 0 */ + +/* uncomment this if you don't need extended math operations */ +/* This includes the trigonometric and expt functions. */ +/* Automatically disabled if you've disabled flonums. */ +/* #define SEXP_USE_MATH 0 */ + +/* uncomment this to disable the self and n parameters to primitives */ +/* This is the old style API. */ +/* #define SEXP_USE_SELF_PARAMETER 0 */ + +/* uncomment this to disable warning about references to undefined variables */ +/* This is something of a hack, but can be quite useful. */ +/* It's very fast and doesn't involve any separate analysis */ +/* passes. */ +/* #define SEXP_USE_WARN_UNDEFS 0 */ + +/* uncomment this to disable huffman-coded immediate symbols */ +/* By default (this may change) small symbols are represented */ +/* as immediates using a simple huffman encoding. This keeps */ +/* the symbol table small, and minimizes hashing when doing a */ +/* lot of reading. */ +/* #define SEXP_USE_HUFF_SYMS 0 */ + +/* uncomment this to just use a single list for hash tables */ +/* You can trade off some space in exchange for longer read */ +/* times by disabling hashing and just putting all */ +/* non-immediate symbols in a single list. */ +/* #define SEXP_USE_HASH_SYMS 0 */ + +/* uncomment this to disable UTF-8 string support */ +/* The default settings store strings in memory as UTF-8, */ +/* and assumes strings passed to/from the C FFI are UTF-8. */ +/* #define SEXP_USE_UTF8_STRINGS 0 */ + +/* uncomment this to disable the string-set! opcode */ +/* By default (non-literal) strings are mutable. */ +/* Making them immutable allows for packed UTF-8 strings. */ +/* #define SEXP_USE_MUTABLE_STRINGS 0 */ + +/* uncomment this to disable string ports */ +/* If disabled some basic functionality such as number->string */ +/* will not be available by default. */ +/* #define SEXP_USE_STRING_STREAMS 0 */ + +/* uncomment this to disable automatic closing of ports */ +/* If enabled, the underlying FILE* for file ports will be */ +/* automatically closed when they're garbage collected. Doesn't */ +/* apply to stdin/stdout/stderr. */ +/* #define SEXP_USE_AUTOCLOSE_PORTS 0 */ + +/* uncomment this to use the normal 1970 unix epoch */ +/* By default chibi uses an datetime epoch starting at */ +/* 2010/01/01 00:00:00 in order to be able to represent */ +/* more common times as fixnums. */ +/* #define SEXP_USE_2010_EPOCH 0 */ + +/* uncomment this to disable stack overflow checks */ +/* By default stacks are fairly small, so it's good to leave */ +/* this enabled. */ +/* #define SEXP_USE_CHECK_STACK 0 */ + +/* #define SEXP_USE_DEBUG_VM 0 */ +/* Experts only. */ +/* For *very* verbose output on every VM operation. */ + +/* uncomment this to make the VM adhere to alignment rules */ +/* This is required on some platforms, e.g. ARM */ +/* #define SEXP_USE_ALIGNED_BYTECODE */ + +/************************************************************************/ +/* These settings are configurable but only recommended for */ +/* experienced users, and only apply when using the native GC. */ +/************************************************************************/ + +/* the initial heap size in bytes */ +#ifndef SEXP_INITIAL_HEAP_SIZE +#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) +#endif + +/* the maximum heap size in bytes - if 0 there is no limit */ +#ifndef SEXP_MAXIMUM_HEAP_SIZE +#define SEXP_MAXIMUM_HEAP_SIZE 0 +#endif +#ifndef SEXP_MINIMUM_HEAP_SIZE +#define SEXP_MINIMUM_HEAP_SIZE 8*1024 +#endif + +/* if after GC more than this percentage of memory is still in use, */ +/* and we've not exceeded the maximum size, grow the heap */ +#ifndef SEXP_GROW_HEAP_RATIO +#define SEXP_GROW_HEAP_RATIO 0.75 +#endif + +/* the default number of opcodes to run each thread for */ +#ifndef SEXP_DEFAULT_QUANTUM +#define SEXP_DEFAULT_QUANTUM 500 +#endif + +/************************************************************************/ +/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ +/************************************************************************/ + +#ifndef SEXP_64_BIT +#if defined(__amd64) || defined(__x86_64) || defined(_WIN64) || defined(_Wp64) +#define SEXP_64_BIT 1 +#else +#define SEXP_64_BIT 0 +#endif +#endif + +#if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__) +#define SEXP_BSD 1 +#else +#define SEXP_BSD 0 +#if ! defined(_GNU_SOURCE) && ! defined(_WIN32) && ! defined(PLAN9) +#define _GNU_SOURCE +#endif +#endif + +#ifndef SEXP_USE_NO_FEATURES +#define SEXP_USE_NO_FEATURES 0 +#endif + +#ifndef SEXP_USE_GREEN_THREADS +#define SEXP_USE_GREEN_THREADS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_NATIVE_X86 +#define SEXP_USE_NATIVE_X86 0 +#endif + +#ifndef SEXP_USE_MODULES +#define SEXP_USE_MODULES ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_TYPE_DEFS +#define SEXP_USE_TYPE_DEFS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_MAXIMUM_TYPES +#define SEXP_MAXIMUM_TYPES ((sexp_tag_t)-1) +#endif + +#ifndef SEXP_USE_DL +#if defined(PLAN9) || defined(_WIN32) +#define SEXP_USE_DL 0 +#else +#define SEXP_USE_DL ! SEXP_USE_NO_FEATURES +#endif +#endif + +#ifndef SEXP_USE_STATIC_LIBS +#define SEXP_USE_STATIC_LIBS 0 +#endif + +#ifndef SEXP_USE_SIMPLIFY +#define SEXP_USE_SIMPLIFY ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_BOEHM +#define SEXP_USE_BOEHM 0 +#endif + +#ifndef SEXP_USE_MALLOC +#define SEXP_USE_MALLOC 0 +#endif + +#ifndef SEXP_USE_MMAP_GC +#define SEXP_USE_MMAP_GC 0 +#endif + +#ifndef SEXP_USE_DEBUG_GC +#define SEXP_USE_DEBUG_GC 0 +#endif + +#ifndef SEXP_USE_SAFE_GC_MARK +#define SEXP_USE_SAFE_GC_MARK 0 +#endif + +#ifndef SEXP_USE_CONSERVATIVE_GC +#define SEXP_USE_CONSERVATIVE_GC 0 +#endif + +#ifndef SEXP_USE_HEADER_MAGIC +#define SEXP_USE_HEADER_MAGIC 0 +#endif + +#ifndef SEXP_USE_GLOBAL_HEAP +#if SEXP_USE_BOEHM || SEXP_USE_MALLOC +#define SEXP_USE_GLOBAL_HEAP 1 +#else +#define SEXP_USE_GLOBAL_HEAP 0 +#endif +#endif + +#ifndef SEXP_USE_GLOBAL_TYPES +#define SEXP_USE_GLOBAL_TYPES (! SEXP_USE_TYPE_DEFS) +#endif + +#ifndef SEXP_USE_GLOBAL_SYMBOLS +#if SEXP_USE_BOEHM || SEXP_USE_MALLOC +#define SEXP_USE_GLOBAL_SYMBOLS 1 +#else +#define SEXP_USE_GLOBAL_SYMBOLS 0 +#endif +#endif + +#ifndef SEXP_USE_EXTENDED_FCALL +#define SEXP_USE_EXTENDED_FCALL ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_FLONUMS +#define SEXP_USE_FLONUMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_INFINITIES +#if defined(PLAN9) || ! SEXP_USE_FLONUMS +#define SEXP_USE_INFINITIES 0 +#else +#define SEXP_USE_INFINITIES ! SEXP_USE_NO_FEATURES +#endif +#endif + +#ifndef SEXP_USE_IMMEDIATE_FLONUMS +#define SEXP_USE_IMMEDIATE_FLONUMS 0 +#endif + +#ifndef SEXP_USE_BIGNUMS +#define SEXP_USE_BIGNUMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_MATH +#define SEXP_USE_MATH SEXP_USE_FLONUMS && ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_SELF_PARAMETER +#define SEXP_USE_SELF_PARAMETER 1 +#endif + +#ifndef SEXP_USE_WARN_UNDEFS +#define SEXP_USE_WARN_UNDEFS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_HUFF_SYMS +#define SEXP_USE_HUFF_SYMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_HASH_SYMS +#define SEXP_USE_HASH_SYMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_DEBUG_VM +#define SEXP_USE_DEBUG_VM 0 +#endif + +#ifndef SEXP_USE_UTF8_STRINGS +#define SEXP_USE_UTF8_STRINGS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_MUTABLE_STRINGS +#define SEXP_USE_MUTABLE_STRINGS 1 +#endif + +#if (SEXP_USE_UTF8_STRINGS && SEXP_USE_MUTABLE_STRINGS) +#define SEXP_USE_PACKED_STRINGS 0 +#endif +#ifndef SEXP_USE_PACKED_STRINGS +#define SEXP_USE_PACKED_STRINGS 1 +#endif + +#ifndef SEXP_USE_STRING_STREAMS +#ifdef _WIN32 +#define SEXP_USE_STRING_STREAMS 0 +#else +#define SEXP_USE_STRING_STREAMS ! SEXP_USE_NO_FEATURES +#endif +#endif + +#ifndef SEXP_USE_AUTOCLOSE_PORTS +#define SEXP_USE_AUTOCLOSE_PORTS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_2010_EPOCH +#define SEXP_USE_2010_EPOCH ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_EPOCH_OFFSET +#if SEXP_USE_2010_EPOCH +#define SEXP_EPOCH_OFFSET 1262271600 +#else +#define SEXP_EPOCH_OFFSET 0 +#endif +#endif + +#ifndef SEXP_USE_CHECK_STACK +#define SEXP_USE_CHECK_STACK ! SEXP_USE_NO_FEATURES +#endif + +#if SEXP_USE_NATIVE_X86 +#undef SEXP_USE_BOEHM +#define SEXP_USE_BOEHM 1 +#undef SEXP_USE_FLONUMS +#define SEXP_USE_FLONUMS 0 +#undef SEXP_USE_BIGNUMS +#define SEXP_USE_BIGNUMS 0 +#undef SEXP_USE_SIMPLIFY +#define SEXP_USE_SIMPLIFY 0 +#endif + +#ifndef SEXP_USE_ALIGNED_BYTECODE +#if defined(__arm__) +#define SEXP_USE_ALIGNED_BYTECODE 1 +#else +#define SEXP_USE_ALIGNED_BYTECODE 0 +#endif +#endif + +#ifdef PLAN9 +#define strcasecmp cistrcmp +#define strncasecmp cistrncmp +#define round(x) floor((x)+0.5) +#define trunc(x) floor((x)+0.5*(((x)<0)?1:0)) +#elif defined(_WIN32) +#define snprintf(buf, len, fmt, val) sprintf(buf, fmt, val) +#define strcasecmp lstrcmpi +#define strncasecmp(s1, s2, n) lstrcmpi(s1, s2) +#define round(x) floor((x)+0.5) +#define trunc(x) floor((x)+0.5*(((x)<0)?1:0)) +#define isnan(x) (x!=x) +#define isinf(x) (x > DBL_MAX || x < -DBL_MAX) +#endif + +#ifdef _WIN32 +#define sexp_pos_infinity (DBL_MAX*DBL_MAX) +#define sexp_neg_infinity -sexp_pos_infinity +#define sexp_nan log(-2) +#else +#define sexp_pos_infinity (1.0/0.0) +#define sexp_neg_infinity -sexp_pos_infinity +#define sexp_nan (0.0/0.0) +#endif + +#ifdef __MINGW32__ +#ifdef BUILDING_DLL +#define SEXP_API __declspec(dllexport) +#else +#define SEXP_API __declspec(dllimport) +#endif +#else +#define SEXP_API +#endif diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h new file mode 100644 index 00000000..7484d9c6 --- /dev/null +++ b/include/chibi/sexp.h @@ -0,0 +1,1065 @@ +/* sexp.h -- header for sexp library */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifndef SEXP_H +#define SEXP_H + +#ifdef __cplusplus +extern "C" { +#endif + +#define SEXP_MODULE_PATH_VAR "CHIBI_MODULE_PATH" + +#include "chibi/features.h" +#include "chibi/install.h" + +#if defined(_WIN32) || defined(__MINGW32__) +#include +#else +#if SEXP_USE_DL +#include +#endif +#if SEXP_USE_GREEN_THREADS +#include +#endif +#endif + +#ifdef PLAN9 +#include +#include +#include +#include +#include <9p.h> +typedef unsigned long size_t; +#else +#include +#include +#include +#include +#include +#include +#include +#if SEXP_USE_FLONUMS +#include +#include +#endif +#endif + +#include +#include + +/* tagging system + * bits end in 00: pointer + * 01: fixnum + * 011: immediate flonum (optional) + * 111: immediate symbol (optional) + * 000110: char + * 001110: unique immediate (NULL, TRUE, FALSE) + */ + +#define SEXP_FIXNUM_BITS 2 +#define SEXP_IMMEDIATE_BITS 3 +#define SEXP_EXTENDED_BITS 6 + +#define SEXP_FIXNUM_MASK 3 +#define SEXP_IMMEDIATE_MASK 7 +#define SEXP_EXTENDED_MASK 63 + +#define SEXP_POINTER_TAG 0 +#define SEXP_FIXNUM_TAG 1 +#define SEXP_ISYMBOL_TAG 7 +#define SEXP_IFLONUM_TAG 3 +#define SEXP_CHAR_TAG 6 +#define SEXP_EXTENDED_TAG 14 + +#ifndef SEXP_POINTER_MAGIC +#define SEXP_POINTER_MAGIC 0xFDCA9764uL /* arbitrary */ +#endif + +#if SEXP_USE_HASH_SYMS +#define SEXP_SYMBOL_TABLE_SIZE 389 +#else +#define SEXP_SYMBOL_TABLE_SIZE 1 +#endif + +enum sexp_types { + SEXP_OBJECT, + SEXP_TYPE, + SEXP_FIXNUM, + SEXP_NUMBER, + SEXP_CHAR, + SEXP_BOOLEAN, + SEXP_PAIR, + SEXP_SYMBOL, + SEXP_BYTES, + SEXP_STRING, + SEXP_VECTOR, + SEXP_FLONUM, + SEXP_BIGNUM, + SEXP_CPOINTER, + SEXP_IPORT, + SEXP_OPORT, + SEXP_EXCEPTION, + SEXP_PROCEDURE, + SEXP_MACRO, + SEXP_SYNCLO, + SEXP_ENV, + SEXP_BYTECODE, + SEXP_CORE, + SEXP_OPCODE, + SEXP_LAMBDA, + SEXP_CND, + SEXP_REF, + SEXP_SET, + SEXP_SEQ, + SEXP_LIT, + SEXP_STACK, + SEXP_CONTEXT, + SEXP_NUM_CORE_TYPES +}; + +#ifdef _WIN32 +typedef unsigned short sexp_tag_t; +typedef SIZE_T sexp_uint_t; +typedef SSIZE_T sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 5) +#elif SEXP_64_BIT +typedef unsigned int sexp_tag_t; +typedef unsigned long sexp_uint_t; +typedef long sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 5) +#elif defined(__CYGWIN__) +typedef unsigned short sexp_tag_t; +typedef unsigned int sexp_uint_t; +typedef int sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 5) +#else +typedef unsigned short sexp_tag_t; +typedef unsigned int sexp_uint_t; +typedef int sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 4) +#endif + +typedef struct sexp_struct *sexp; + +#define sexp_heap_pad_size(s) (sizeof(struct sexp_heap_t) + (s) + sexp_heap_align(1)) + +#define __HALF_MAX_SIGNED(type) ((type)1 << (sizeof(type)*8-2)) +#define __MAX_SIGNED(type) (__HALF_MAX_SIGNED(type) - 1 + __HALF_MAX_SIGNED(type)) +#define __MIN_SIGNED(type) (-1 - __MAX_SIGNED(type)) + +#define SEXP_UINT_T_MAX ((sexp_uint_t)-1) +#define SEXP_UINT_T_MIN (0) +#define SEXP_SINT_T_MAX __MAX_SIGNED(sexp_sint_t) +#define SEXP_SINT_T_MIN __MIN_SIGNED(sexp_sint_t) + +#define SEXP_MAX_FIXNUM ((((sexp_sint_t)1)<<(sizeof(sexp_sint_t)*8-SEXP_FIXNUM_BITS-1))-1) +#define SEXP_MIN_FIXNUM (-SEXP_MAX_FIXNUM-1) + +#if SEXP_USE_SELF_PARAMETER +#define sexp_api_params(self, n) , sexp self, long n +#define sexp_api_pass(self, n) , self, n +#else +#define sexp_api_params(self, n) +#define sexp_api_pass(self, n) +#endif + +/* procedure types */ +typedef sexp (*sexp_proc1) (sexp sexp_api_params(self, n)); +typedef sexp (*sexp_proc2) (sexp sexp_api_params(self, n), sexp); +typedef sexp (*sexp_proc3) (sexp sexp_api_params(self, n), sexp, sexp); +typedef sexp (*sexp_proc4) (sexp sexp_api_params(self, n), sexp, sexp, sexp); +typedef sexp (*sexp_proc5) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc6) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc7) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp); + +typedef struct sexp_free_list_t *sexp_free_list; +struct sexp_free_list_t { + sexp_uint_t size; + sexp_free_list next; +}; + +typedef struct sexp_heap_t *sexp_heap; +struct sexp_heap_t { + sexp_uint_t size; + sexp_free_list free_list; + sexp_heap next; + /* note this must be aligned on a proper heap boundary, */ + /* so we can't just use char data[] */ + char *data; +}; + +struct sexp_gc_var_t { + sexp *var; +#if SEXP_USE_DEBUG_GC + char *name; +#endif + struct sexp_gc_var_t *next; +}; + +struct sexp_type_struct { + sexp_tag_t tag; + short field_base, field_eq_len_base, field_len_base, field_len_off; + unsigned short field_len_scale; + short size_base, size_off; + unsigned short size_scale; + char *name; + sexp_proc2 finalize; +}; + +struct sexp_opcode_struct { + unsigned char op_class, code, num_args, flags, inverse; + const char *name; + sexp data, data2, proc, ret_type, arg1_type, arg2_type, arg3_type; + sexp_proc1 func; +}; + +struct sexp_core_form_struct { + char code; + const char *name; +}; + +struct sexp_struct { + sexp_tag_t tag; + char gc_mark; + unsigned int immutablep:1; + unsigned int freep:1; + unsigned int syntacticp:1; +#if SEXP_USE_HEADER_MAGIC + unsigned int magic; +#endif + union { + /* basic types */ + double flonum; + struct sexp_type_struct type; + struct { + sexp car, cdr; + sexp source; + } pair; + struct { + sexp_uint_t length; + sexp data[]; + } vector; + struct { + sexp_uint_t length; + char data[]; + } bytes; + struct { +#if SEXP_USE_PACKED_STRINGS + sexp_uint_t length; + char data[]; +#else + sexp_uint_t offset, length; + sexp bytes; +#endif + } string; + struct { + sexp_uint_t length; + char data[]; + } symbol; + struct { + FILE *stream; + char *buf; + char openp, no_closep, sourcep; + sexp_uint_t offset, line; + size_t size; + sexp name; + sexp cookie; + } port; + struct { + sexp kind, message, irritants, procedure, source; + } exception; + struct { + signed char sign; + sexp_uint_t length; + sexp_uint_t data[]; + } bignum; + struct { + sexp_uint_t length; + void *value; + sexp parent; + char body[]; + } cpointer; + /* runtime types */ + struct { + sexp parent, lambda, bindings; + } env; + struct { + sexp_uint_t length; + sexp name, literals, source; + unsigned char data[]; + } bytecode; + struct { + char flags; + unsigned short num_args; + sexp bc, vars; + } procedure; + struct { + sexp proc, env; + } macro; + struct { + sexp env, free_vars, expr; + } synclo; + struct sexp_opcode_struct opcode; + struct sexp_core_form_struct core; + /* ast types */ + struct { + sexp name, params, body, defs, locals, flags, fv, sv, ret, types, source; + } lambda; + struct { + sexp test, pass, fail, source; + } cnd; + struct { + sexp var, value, source; + } set; + struct { + sexp name, cell, source; + } ref; + struct { + sexp ls, source; + } seq; + struct { + sexp value, source; + } lit; + /* compiler state */ + struct { + sexp_uint_t length, top; + sexp data[]; + } stack; + struct { + sexp_heap heap; + struct sexp_gc_var_t *saves; +#if SEXP_USE_GREEN_THREADS + sexp_sint_t refuel; + unsigned char* ip; + struct timeval tval; +#endif + char tailp, tracep, timeoutp, waitp; + sexp_uint_t pos, depth, last_fp; + sexp bc, lambda, stack, env, fv, parent, child, globals, + proc, name, specific, event; + } context; + } value; +}; + +#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<value.x)) + +#define sexp_offsetof(type, f) (offsetof(struct sexp_struct, value.type.f)) + +#define sexp_offsetof_slot0 (offsetof(struct sexp_struct, value)) + +#define sexp_sizeof_header (sexp_sizeof(flonum) - sizeof(double)) + +#define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag) +#define sexp_alloc_bytecode(ctx, i) sexp_alloc_tagged(ctx, sexp_sizeof(bytecode) + i, SEXP_BYTECODE) + +#if SEXP_USE_BIGNUMS +#include "chibi/bignum.h" +#endif + +/***************************** predicates *****************************/ + +#define sexp_truep(x) ((x) != SEXP_FALSE) +#define sexp_not(x) ((x) == SEXP_FALSE) + +#define sexp_nullp(x) ((x) == SEXP_NULL) +#define sexp_pointerp(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG) +#define sexp_fixnump(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_FIXNUM_TAG) +#define sexp_isymbolp(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_ISYMBOL_TAG) +#define sexp_charp(x) (((sexp_uint_t)(x) & SEXP_EXTENDED_MASK) == SEXP_CHAR_TAG) +#define sexp_booleanp(x) (((x) == SEXP_TRUE) || ((x) == SEXP_FALSE)) + +#define sexp_pointer_tag(x) ((x)->tag) +#define sexp_gc_mark(x) ((x)->gc_mark) +#define sexp_flags(x) ((x)->flags) +#define sexp_immutablep(x) ((x)->immutablep) +#define sexp_freep(x) ((x)->freep) +#define sexp_pointer_magic(x) ((x)->magic) + +#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) + +#define sexp_slot_ref(x,i) (((sexp*)&((x)->value))[i]) +#define sexp_slot_set(x,i,v) (((sexp*)&((x)->value))[i] = (v)) + +#define sexp_isa(a, b) (sexp_pointerp(a) && sexp_typep(b) && (sexp_pointer_tag(a) == sexp_type_tag(b))) + +#if SEXP_USE_IMMEDIATE_FLONUMS +union sexp_flonum_conv { + float flonum; + unsigned int bits; +}; +#define sexp_flonump(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_IFLONUM_TAG) +SEXP_API sexp sexp_flonum_predicate (sexp ctx, sexp x); +#if SEXP_64_BIT +SEXP_API float sexp_flonum_value (sexp x); +SEXP_API sexp sexp_make_flonum(sexp ctx, float f); +#else +#define sexp_make_flonum(ctx, x) ((sexp) ((((union sexp_flonum_conv)((float)(x))).bits & ~SEXP_IMMEDIATE_MASK) + SEXP_IFLONUM_TAG)) +#define sexp_flonum_value(x) (((union sexp_flonum_conv)(((unsigned int)(x)) & ~SEXP_IMMEDIATE_MASK)).flonum) +#endif +#else +#define sexp_flonump(x) (sexp_check_tag(x, SEXP_FLONUM)) +#define sexp_flonum_value(f) ((f)->value.flonum) +sexp sexp_make_flonum(sexp ctx, double f); +#endif + +#define sexp_typep(x) (sexp_check_tag(x, SEXP_TYPE)) +#define sexp_pairp(x) (sexp_check_tag(x, SEXP_PAIR)) +#define sexp_stringp(x) (sexp_check_tag(x, SEXP_STRING)) +#define sexp_lsymbolp(x) (sexp_check_tag(x, SEXP_SYMBOL)) +#define sexp_vectorp(x) (sexp_check_tag(x, SEXP_VECTOR)) +#define sexp_iportp(x) (sexp_check_tag(x, SEXP_IPORT)) +#define sexp_oportp(x) (sexp_check_tag(x, SEXP_OPORT)) +#define sexp_bignump(x) (sexp_check_tag(x, SEXP_BIGNUM)) +#define sexp_cpointerp(x) (sexp_check_tag(x, SEXP_CPOINTER)) +#define sexp_exceptionp(x) (sexp_check_tag(x, SEXP_EXCEPTION)) +#define sexp_procedurep(x) (sexp_check_tag(x, SEXP_PROCEDURE)) +#define sexp_envp(x) (sexp_check_tag(x, SEXP_ENV)) +#define sexp_bytecodep(x) (sexp_check_tag(x, SEXP_BYTECODE)) +#define sexp_corep(x) (sexp_check_tag(x, SEXP_CORE)) +#define sexp_opcodep(x) (sexp_check_tag(x, SEXP_OPCODE)) +#define sexp_macrop(x) (sexp_check_tag(x, SEXP_MACRO)) +#define sexp_synclop(x) (sexp_check_tag(x, SEXP_SYNCLO)) +#define sexp_lambdap(x) (sexp_check_tag(x, SEXP_LAMBDA)) +#define sexp_cndp(x) (sexp_check_tag(x, SEXP_CND)) +#define sexp_refp(x) (sexp_check_tag(x, SEXP_REF)) +#define sexp_setp(x) (sexp_check_tag(x, SEXP_SET)) +#define sexp_seqp(x) (sexp_check_tag(x, SEXP_SEQ)) +#define sexp_litp(x) (sexp_check_tag(x, SEXP_LIT)) +#define sexp_contextp(x) (sexp_check_tag(x, SEXP_CONTEXT)) + +#define sexp_applicablep(x) (sexp_procedurep(x) || sexp_opcodep(x)) + +#if SEXP_USE_HUFF_SYMS +#define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) +#else +#define sexp_symbolp(x) (sexp_lsymbolp(x)) +#endif + +#define sexp_idp(x) \ + (sexp_symbolp(x) || (sexp_synclop(x) && sexp_symbolp(sexp_synclo_expr(x)))) + +#define sexp_portp(x) (sexp_iportp(x) || sexp_oportp(x)) + +/***************************** constructors ****************************/ + +#define sexp_make_boolean(x) ((x) ? SEXP_TRUE : SEXP_FALSE) +#define sexp_unbox_boolean(x) (((x) == SEXP_FALSE) ? 0 : 1) + +#define sexp_make_fixnum(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_FIXNUM_BITS) + +#define SEXP_NEG_ONE sexp_make_fixnum(-1) +#define SEXP_ZERO sexp_make_fixnum(0) +#define SEXP_ONE sexp_make_fixnum(1) +#define SEXP_TWO sexp_make_fixnum(2) +#define SEXP_THREE sexp_make_fixnum(3) +#define SEXP_FOUR sexp_make_fixnum(4) +#define SEXP_FIVE sexp_make_fixnum(5) +#define SEXP_SIX sexp_make_fixnum(6) +#define SEXP_SEVEN sexp_make_fixnum(7) +#define SEXP_EIGHT sexp_make_fixnum(8) +#define SEXP_NINE sexp_make_fixnum(9) +#define SEXP_TEN sexp_make_fixnum(10) + +#define sexp_make_character(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_EXTENDED_BITS)) + +#define sexp_fixnum_to_double(x) ((double)sexp_unbox_fixnum(x)) + +#if SEXP_USE_FLONUMS +#define sexp_fp_integerp(x) (sexp_flonum_value(x) == trunc(sexp_flonum_value(x))) +#define _or_integer_flonump(x) || (sexp_flonump(x) && sexp_fp_integerp(x)) +#else +#define _or_integer_flonump(x) +#endif + +#if SEXP_USE_BIGNUMS +SEXP_API sexp sexp_make_integer(sexp ctx, sexp_lsint_t x); +SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); +#define sexp_exact_integerp(x) (sexp_fixnump(x) || sexp_bignump(x)) +#else +#define sexp_make_integer(ctx, x) sexp_make_fixnum(x) +#define sexp_make_unsigned_integer(ctx, x) sexp_make_fixnum(x) +#define sexp_exact_integerp(x) sexp_fixnump(x) +#endif + +#define sexp_integerp(x) (sexp_exact_integerp(x) _or_integer_flonump(x)) + +#if SEXP_USE_FLONUMS +#define sexp_fixnum_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_fixnum(x))) +#define sexp_numberp(x) (sexp_exact_integerp(x) || sexp_flonump(x)) +#else +#define sexp_fixnum_to_flonum(ctx, x) (x) +#define sexp_numberp(x) sexp_exact_integerp(x) +#endif + +#if SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS +#define sexp_uint_value(x) ((sexp_uint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_data(x)[0])) +#define sexp_sint_value(x) ((sexp_sint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_sign(x)*sexp_bignum_data(x)[0])) +#else +#define sexp_uint_value(x) ((sexp_uint_t)sexp_unbox_fixnum(x)) +#define sexp_sint_value(x) ((sexp_sint_t)sexp_unbox_fixnum(x)) +#endif + +#define sexp_shift_epoch(x) ((x)-SEXP_EPOCH_OFFSET) +#define sexp_unshift_epoch(x) ((x)+SEXP_EPOCH_OFFSET) + +/*************************** field accessors **************************/ + +#define sexp_vector_length(x) ((x)->value.vector.length) +#define sexp_vector_data(x) ((x)->value.vector.data) + +#define sexp_vector_ref(x,i) (sexp_vector_data(x)[sexp_unbox_fixnum(i)]) +#define sexp_vector_set(x,i,v) (sexp_vector_data(x)[sexp_unbox_fixnum(i)]=(v)) + +#define sexp_procedure_num_args(x) ((x)->value.procedure.num_args) +#define sexp_procedure_flags(x) ((x)->value.procedure.flags) +#define sexp_procedure_variadic_p(x) (sexp_unbox_fixnum(sexp_procedure_flags(x)) & 1) +#define sexp_procedure_code(x) ((x)->value.procedure.bc) +#define sexp_procedure_vars(x) ((x)->value.procedure.vars) + +#define sexp_bytes_length(x) ((x)->value.bytes.length) +#define sexp_bytes_data(x) ((x)->value.bytes.data) + +#define sexp_string_length(x) ((x)->value.string.length) +#if SEXP_USE_PACKED_STRINGS +#define sexp_string_data(x) ((x)->value.string.data) +#else +#define sexp_string_bytes(x) ((x)->value.string.bytes) +#define sexp_string_offset(x) ((x)->value.string.offset) +#define sexp_string_data(x) (sexp_bytes_data(sexp_string_bytes(x))+sexp_string_offset(x)) +#endif + +#define sexp_bytes_ref(x, i) (sexp_make_fixnum((unsigned char)sexp_bytes_data(x)[sexp_unbox_fixnum(i)])) +#define sexp_bytes_set(x, i, v) (sexp_bytes_data(x)[sexp_unbox_fixnum(i)] = sexp_unbox_fixnum(v)) + +#define sexp_string_ref(x, i) (sexp_make_character((unsigned char)sexp_string_data(x)[sexp_unbox_fixnum(i)])) +#define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_fixnum(i)] = sexp_unbox_character(v)) + +#define sexp_symbol_data(x) ((x)->value.symbol.data) +#define sexp_symbol_length(x) ((x)->value.symbol.length) +#define sexp_symbol_string(x) (x) + +#define sexp_port_stream(p) ((p)->value.port.stream) +#define sexp_port_name(p) ((p)->value.port.name) +#define sexp_port_line(p) ((p)->value.port.line) +#define sexp_port_openp(p) ((p)->value.port.openp) +#define sexp_port_no_closep(p) ((p)->value.port.no_closep) +#define sexp_port_sourcep(p) ((p)->value.port.sourcep) +#define sexp_port_cookie(p) ((p)->value.port.cookie) +#define sexp_port_buf(p) ((p)->value.port.buf) +#define sexp_port_size(p) ((p)->value.port.size) +#define sexp_port_offset(p) ((p)->value.port.offset) + +#define sexp_exception_kind(p) ((p)->value.exception.kind) +#define sexp_exception_message(p) ((p)->value.exception.message) +#define sexp_exception_irritants(p) ((p)->value.exception.irritants) +#define sexp_exception_procedure(p) ((p)->value.exception.procedure) +#define sexp_exception_source(p) ((p)->value.exception.source) + +#define sexp_cpointer_freep(p) (sexp_freep(p)) +#define sexp_cpointer_length(p) ((p)->value.cpointer.length) +#define sexp_cpointer_body(p) ((p)->value.cpointer.body) +#define sexp_cpointer_parent(p) ((p)->value.cpointer.parent) +#define sexp_cpointer_value(p) ((p)->value.cpointer.value) +#define sexp_cpointer_maybe_null_value(p) (sexp_not(p) ? NULL : sexp_cpointer_value(p)) + +#define sexp_bytecode_length(x) ((x)->value.bytecode.length) +#define sexp_bytecode_name(x) ((x)->value.bytecode.name) +#define sexp_bytecode_literals(x) ((x)->value.bytecode.literals) +#define sexp_bytecode_source(x) ((x)->value.bytecode.source) +#define sexp_bytecode_data(x) ((x)->value.bytecode.data) + +#define sexp_env_syntactic_p(x) ((x)->syntacticp) +#define sexp_env_parent(x) ((x)->value.env.parent) +#define sexp_env_bindings(x) ((x)->value.env.bindings) +#define sexp_env_local_p(x) (sexp_env_parent(x)) +#define sexp_env_global_p(x) (! sexp_env_local_p(x)) +#define sexp_env_lambda(x) ((x)->value.env.lambda) + +#define sexp_macro_proc(x) ((x)->value.macro.proc) +#define sexp_macro_env(x) ((x)->value.macro.env) + +#define sexp_synclo_env(x) ((x)->value.synclo.env) +#define sexp_synclo_free_vars(x) ((x)->value.synclo.free_vars) +#define sexp_synclo_expr(x) ((x)->value.synclo.expr) + +#define sexp_core_code(x) ((x)->value.core.code) +#define sexp_core_name(x) ((x)->value.core.name) + +#define sexp_opcode_class(x) ((x)->value.opcode.op_class) +#define sexp_opcode_code(x) ((x)->value.opcode.code) +#define sexp_opcode_num_args(x) ((x)->value.opcode.num_args) +#define sexp_opcode_flags(x) ((x)->value.opcode.flags) +#define sexp_opcode_inverse(x) ((x)->value.opcode.inverse) +#define sexp_opcode_name(x) ((x)->value.opcode.name) +#define sexp_opcode_data(x) ((x)->value.opcode.data) +#define sexp_opcode_data2(x) ((x)->value.opcode.data2) +#define sexp_opcode_proc(x) ((x)->value.opcode.proc) +#define sexp_opcode_return_type(x) ((x)->value.opcode.ret_type) +#define sexp_opcode_arg1_type(x) ((x)->value.opcode.arg1_type) +#define sexp_opcode_arg2_type(x) ((x)->value.opcode.arg2_type) +#define sexp_opcode_arg3_type(x) ((x)->value.opcode.arg3_type) +#define sexp_opcode_func(x) ((x)->value.opcode.func) + +#define sexp_opcode_variadic_p(x) (sexp_opcode_flags(x) & 1) +#define sexp_opcode_opt_param_p(x) (sexp_opcode_flags(x) & 2) +#define sexp_opcode_ref_trans_p(x) (sexp_opcode_flags(x) & 4) + +#define sexp_lambda_name(x) ((x)->value.lambda.name) +#define sexp_lambda_params(x) ((x)->value.lambda.params) +#define sexp_lambda_locals(x) ((x)->value.lambda.locals) +#define sexp_lambda_defs(x) ((x)->value.lambda.defs) +#define sexp_lambda_flags(x) ((x)->value.lambda.flags) +#define sexp_lambda_body(x) ((x)->value.lambda.body) +#define sexp_lambda_fv(x) ((x)->value.lambda.fv) +#define sexp_lambda_sv(x) ((x)->value.lambda.sv) +#define sexp_lambda_return_type(x) ((x)->value.lambda.ret) +#define sexp_lambda_param_types(x) ((x)->value.lambda.types) +#define sexp_lambda_source(x) ((x)->value.lambda.source) + +#define sexp_cnd_test(x) ((x)->value.cnd.test) +#define sexp_cnd_pass(x) ((x)->value.cnd.pass) +#define sexp_cnd_fail(x) ((x)->value.cnd.fail) +#define sexp_cnd_source(x) ((x)->value.cnd.source) + +#define sexp_set_var(x) ((x)->value.set.var) +#define sexp_set_value(x) ((x)->value.set.value) +#define sexp_set_source(x) ((x)->value.set.source) + +#define sexp_ref_name(x) ((x)->value.ref.name) +#define sexp_ref_cell(x) ((x)->value.ref.cell) +#define sexp_ref_loc(x) (sexp_cdr(sexp_ref_cell(x))) +#define sexp_ref_source(x) ((x)->value.ref.source) + +#define sexp_seq_ls(x) ((x)->value.seq.ls) +#define sexp_seq_source(x) ((x)->value.seq.source) + +#define sexp_lit_value(x) ((x)->value.lit.value) +#define sexp_lit_source(x) ((x)->value.lit.source) + +#define sexp_stack_length(x) ((x)->value.stack.length) +#define sexp_stack_top(x) ((x)->value.stack.top) +#define sexp_stack_data(x) ((x)->value.stack.data) + +#define sexp_context_env(x) ((x)->value.context.env) +#define sexp_context_stack(x) ((x)->value.context.stack) +#define sexp_context_depth(x) ((x)->value.context.depth) +#define sexp_context_bc(x) ((x)->value.context.bc) +#define sexp_context_fv(x) ((x)->value.context.fv) +#define sexp_context_pos(x) ((x)->value.context.pos) +#define sexp_context_lambda(x) ((x)->value.context.lambda) +#define sexp_context_parent(x) ((x)->value.context.parent) +#define sexp_context_child(x) ((x)->value.context.child) +#define sexp_context_saves(x) ((x)->value.context.saves) +#define sexp_context_tailp(x) ((x)->value.context.tailp) +#define sexp_context_tracep(x) ((x)->value.context.tracep) +#define sexp_context_globals(x) ((x)->value.context.globals) +#define sexp_context_last_fp(x) ((x)->value.context.last_fp) +#define sexp_context_refuel(x) ((x)->value.context.refuel) +#define sexp_context_ip(x) ((x)->value.context.ip) +#define sexp_context_proc(x) ((x)->value.context.proc) +#define sexp_context_timeval(x) ((x)->value.context.tval) +#define sexp_context_name(x) ((x)->value.context.name) +#define sexp_context_specific(x) ((x)->value.context.specific) +#define sexp_context_event(x) ((x)->value.context.event) +#define sexp_context_timeoutp(x) ((x)->value.context.timeoutp) +#define sexp_context_waitp(x) ((x)->value.context.waitp) + +#if SEXP_USE_ALIGNED_BYTECODE +#define sexp_context_align_pos(ctx) sexp_context_pos(ctx) = sexp_word_align(sexp_context_pos(ctx)) +#else +#define sexp_context_align_pos(ctx) +#endif + +#define sexp_global(ctx,x) (sexp_vector_data(sexp_context_globals(ctx))[x]) + +#if SEXP_USE_GLOBAL_HEAP +#if ! SEXP_USE_BOEHM +SEXP_API sexp_heap sexp_global_heap; +#endif +#define sexp_context_heap(ctx) sexp_global_heap +#else +#define sexp_context_heap(ctx) ((ctx)->value.context.heap) +#endif + +#if SEXP_USE_GLOBAL_SYMBOLS +#define sexp_context_symbols(ctx) sexp_symbol_table +#else +#define sexp_context_symbols(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_SYMBOLS)) +#endif + +#if SEXP_USE_GLOBAL_TYPES +SEXP_API struct sexp_struct *sexp_type_specs; +#define sexp_context_types(ctx) sexp_type_specs +#define sexp_type_by_index(ctx,i) (&(sexp_context_types(ctx)[i])) +#define sexp_context_num_types(ctx) sexp_num_types +#define sexp_context_type_array_size(ctx) sexp_type_array_size +#else +#define sexp_context_types(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)) +#define sexp_type_by_index(ctx,i) (sexp_context_types(ctx)[i]) +#define sexp_context_num_types(ctx) \ + sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_NUM_TYPES)) +#define sexp_context_type_array_size(ctx) \ + sexp_vector_length(sexp_global(ctx, SEXP_G_TYPES)) +#endif + +#define sexp_object_type(ctx,x) (sexp_type_by_index(ctx, ((x)->tag))) +#define sexp_object_type_name(ctx,x) (sexp_type_name(sexp_object_type(ctx, x))) +#define sexp_type_name_by_index(ctx,i) (sexp_type_name(sexp_type_by_index(ctx,i))) + +#define sexp_type_size_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_size_off(t)))[0] \ + * sexp_type_size_scale(t) \ + + sexp_type_size_base(t)) +#define sexp_type_num_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ + * sexp_type_field_len_scale(t) \ + + sexp_type_field_len_base(t)) +#define sexp_type_num_eq_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ + * sexp_type_field_len_scale(t) \ + + sexp_type_field_eq_len_base(t)) + +#define sexp_context_top(x) (sexp_stack_top(sexp_context_stack(x))) + +#define sexp_type_tag(x) ((x)->value.type.tag) +#define sexp_type_field_base(x) ((x)->value.type.field_base) +#define sexp_type_field_eq_len_base(x) ((x)->value.type.field_eq_len_base) +#define sexp_type_field_len_base(x) ((x)->value.type.field_len_base) +#define sexp_type_field_len_off(x) ((x)->value.type.field_len_off) +#define sexp_type_field_len_scale(x) ((x)->value.type.field_len_scale) +#define sexp_type_size_base(x) ((x)->value.type.size_base) +#define sexp_type_size_off(x) ((x)->value.type.size_off) +#define sexp_type_size_scale(x) ((x)->value.type.size_scale) +#define sexp_type_name(x) ((x)->value.type.name) +#define sexp_type_finalize(x) ((x)->value.type.finalize) + +#define sexp_bignum_sign(x) ((x)->value.bignum.sign) +#define sexp_bignum_length(x) ((x)->value.bignum.length) +#define sexp_bignum_data(x) ((x)->value.bignum.data) + +/****************************** arithmetic ****************************/ + +#define sexp_fx_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG)) +#define sexp_fx_sub(a, b) ((sexp)(((sexp_sint_t)a)-((sexp_sint_t)b)+SEXP_FIXNUM_TAG)) +#define sexp_fx_mul(a, b) ((sexp)((((((sexp_sint_t)a)-SEXP_FIXNUM_TAG)*(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG))) +#define sexp_fx_div(a, b) (sexp_make_fixnum(sexp_unbox_fixnum(a) / sexp_unbox_fixnum(b))) +#define sexp_fx_rem(a, b) (sexp_make_fixnum(sexp_unbox_fixnum(a) % sexp_unbox_fixnum(b))) +#define sexp_fx_sign(a) (+1 | (((sexp_sint_t)(a)) >> (sizeof(sexp_sint_t)*8 - 1))) +#define sexp_fx_neg(a) (sexp_make_fixnum(-(sexp_unbox_fixnum(a)))) +#define sexp_fx_abs(a) ((((sexp_sint_t)a) < 0) ? sexp_fx_neg(a) : a) + +#define sexp_fp_add(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) + sexp_flonum_value(b))) +#define sexp_fp_sub(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) - sexp_flonum_value(b))) +#define sexp_fp_mul(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) * sexp_flonum_value(b))) +#define sexp_fp_div(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) / sexp_flonum_value(b))) + +/****************************** utilities *****************************/ + +enum sexp_context_globals { +#if ! SEXP_USE_GLOBAL_SYMBOLS + SEXP_G_SYMBOLS, +#endif +#if ! SEXP_USE_GLOBAL_TYPES + SEXP_G_TYPES, + SEXP_G_NUM_TYPES, +#endif + SEXP_G_OOM_ERROR, /* out of memory exception object */ + SEXP_G_OOS_ERROR, /* out of stack exception object */ + SEXP_G_OPTIMIZATIONS, + SEXP_G_SIGNAL_HANDLERS, + SEXP_G_CONFIG_ENV, + SEXP_G_MODULE_PATH, + SEXP_G_QUOTE_SYMBOL, + SEXP_G_QUASIQUOTE_SYMBOL, + SEXP_G_UNQUOTE_SYMBOL, + SEXP_G_UNQUOTE_SPLICING_SYMBOL, + SEXP_G_EMPTY_VECTOR, + SEXP_G_CUR_IN_SYMBOL, + SEXP_G_CUR_OUT_SYMBOL, + SEXP_G_CUR_ERR_SYMBOL, + SEXP_G_INTERACTION_ENV_SYMBOL, + SEXP_G_ERR_HANDLER, + SEXP_G_RESUMECC_BYTECODE, + SEXP_G_FINAL_RESUMER, +#if SEXP_USE_GREEN_THREADS + SEXP_G_THREADS_SCHEDULER, + SEXP_G_THREADS_FRONT, + SEXP_G_THREADS_BACK, + SEXP_G_THREADS_PAUSED, + SEXP_G_THREADS_LOCAL, + SEXP_G_THREADS_SIGNALS, + SEXP_G_THREADS_SIGNAL_RUNNER, +#endif + SEXP_G_NUM_GLOBALS +}; + +#define sexp_list1(x,a) sexp_cons((x), (a), SEXP_NULL) + +#define sexp_push(ctx, ls, x) ((ls) = sexp_cons((ctx), (x), (ls))) +#define sexp_insert(ctx, ls, x) ((sexp_memq(ctx, (x), (ls)) != SEXP_FALSE) ? (ls) : sexp_push((ctx), (ls), (x))) + +#define sexp_pair_source(x) ((x)->value.pair.source) + +#define sexp_car(x) ((x)->value.pair.car) +#define sexp_cdr(x) ((x)->value.pair.cdr) + +#define sexp_caar(x) (sexp_car(sexp_car(x))) +#define sexp_cadr(x) (sexp_car(sexp_cdr(x))) +#define sexp_cdar(x) (sexp_cdr(sexp_car(x))) +#define sexp_cddr(x) (sexp_cdr(sexp_cdr(x))) +#define sexp_caaar(x) (sexp_car(sexp_caar(x))) +#define sexp_caadr(x) (sexp_car(sexp_cadr(x))) +#define sexp_cadar(x) (sexp_car(sexp_cdar(x))) +#define sexp_caddr(x) (sexp_car(sexp_cddr(x))) +#define sexp_cdaar(x) (sexp_cdr(sexp_caar(x))) +#define sexp_cdadr(x) (sexp_cdr(sexp_cadr(x))) +#define sexp_cddar(x) (sexp_cdr(sexp_cdar(x))) +#define sexp_cdddr(x) (sexp_cdr(sexp_cddr(x))) +#define sexp_cadddr(x) (sexp_cadr(sexp_cddr(x))) /* just these two */ +#define sexp_cddddr(x) (sexp_cddr(sexp_cddr(x))) + +/***************************** general API ****************************/ + +#if SEXP_USE_STRING_STREAMS + +#define sexp_read_char(x, p) (getc(sexp_port_stream(p))) +#define sexp_push_char(x, c, p) (ungetc(c, sexp_port_stream(p))) +#define sexp_write_char(x, c, p) (putc(c, sexp_port_stream(p))) +#define sexp_write_string(x, s, p) (fputs(s, sexp_port_stream(p))) +#define sexp_printf(x, p, ...) (fprintf(sexp_port_stream(p), __VA_ARGS__)) +#define sexp_flush(x, p) (fflush(sexp_port_stream(p))) + +#else + +#define sexp_read_char(x, p) (sexp_port_buf(p) ? ((sexp_port_offset(p) < sexp_port_size(p)) ? sexp_port_buf(p)[sexp_port_offset(p)++] : sexp_buffered_read_char(x, p)) : getc(sexp_port_stream(p))) +#define sexp_push_char(x, c, p) (sexp_port_buf(p) ? (sexp_port_buf(p)[--sexp_port_offset(p)] = ((char)(c))) : ungetc(c, sexp_port_stream(p))) +#define sexp_write_char(x, c, p) (sexp_port_buf(p) ? ((sexp_port_offset(p) < sexp_port_size(p)) ? ((((sexp_port_buf(p))[sexp_port_offset(p)++]) = (char)(c)), SEXP_VOID) : sexp_buffered_write_char(x, c, p)) : (putc(c, sexp_port_stream(p)), SEXP_VOID)) +#define sexp_write_string(x, s, p) (sexp_port_buf(p) ? sexp_buffered_write_string(x, s, p) : (fputs(s, sexp_port_stream(p)), SEXP_VOID)) +#define sexp_flush(x, p) (sexp_port_buf(p) ? sexp_buffered_flush(x, p) : (fflush(sexp_port_stream(p)), SEXP_VOID)) + +SEXP_API int sexp_buffered_read_char (sexp ctx, sexp p); +SEXP_API sexp sexp_buffered_write_char (sexp ctx, int c, sexp p); +SEXP_API sexp sexp_buffered_write_string_n (sexp ctx, const char *str, sexp_uint_t len, sexp p); +SEXP_API sexp sexp_buffered_write_string (sexp ctx, const char *str, sexp p); +SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p); + +#endif + +#define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p)) +#define sexp_at_eofp(p) (feof(sexp_port_stream(p))) + +SEXP_API sexp sexp_make_context(sexp ctx, size_t size); +SEXP_API sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); +SEXP_API sexp sexp_cons_op(sexp ctx sexp_api_params(self, n), sexp head, sexp tail); +SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b); +SEXP_API sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b); +SEXP_API sexp sexp_listp_op(sexp ctx sexp_api_params(self, n), sexp obj); +SEXP_API sexp sexp_reverse_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_nreverse_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_copy_list_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_append2_op(sexp ctx sexp_api_params(self, n), sexp a, sexp b); +SEXP_API sexp sexp_memq_op(sexp ctx sexp_api_params(self, n), sexp x, sexp ls); +SEXP_API sexp sexp_assq_op(sexp ctx sexp_api_params(self, n), sexp x, sexp ls); +SEXP_API sexp sexp_length_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_c_string(sexp ctx, const char *str, sexp_sint_t slen); +SEXP_API sexp sexp_make_bytes_op(sexp ctx sexp_api_params(self, n), sexp len, sexp i); +SEXP_API sexp sexp_make_string_op(sexp ctx sexp_api_params(self, n), sexp len, sexp ch); +SEXP_API sexp sexp_substring_op (sexp ctx sexp_api_params(self, n), sexp str, sexp start, sexp end); +SEXP_API sexp sexp_string_concatenate_op (sexp ctx sexp_api_params(self, n), sexp str_ls, sexp sep); +SEXP_API sexp sexp_intern (sexp ctx, const char *str, sexp_sint_t len); +SEXP_API sexp sexp_string_to_symbol_op (sexp ctx sexp_api_params(self, n), sexp str); +SEXP_API sexp sexp_string_to_number_op (sexp ctx sexp_api_params(self, n), sexp str, sexp b); +SEXP_API sexp sexp_make_vector_op (sexp ctx sexp_api_params(self, n), sexp len, sexp dflt); +SEXP_API sexp sexp_list_to_vector_op (sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_make_cpointer (sexp ctx, sexp_uint_t type_id, void* value, sexp parent, int freep); +SEXP_API sexp sexp_write_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out); +SEXP_API sexp sexp_display_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out); +SEXP_API sexp sexp_flush_output_op (sexp ctx sexp_api_params(self, n), sexp out); +SEXP_API sexp sexp_read_string (sexp ctx, sexp in); +SEXP_API sexp sexp_read_symbol (sexp ctx, sexp in, int init, int internp); +SEXP_API sexp sexp_read_number (sexp ctx, sexp in, int base); +SEXP_API sexp sexp_read_raw (sexp ctx, sexp in); +SEXP_API sexp sexp_read_op (sexp ctx sexp_api_params(self, n), sexp in); +SEXP_API sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len); +SEXP_API sexp sexp_write_to_string (sexp ctx, sexp obj); +SEXP_API sexp sexp_finalize_port (sexp ctx sexp_api_params(self, n), sexp port); +SEXP_API sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name); +SEXP_API sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name); +SEXP_API sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str); +SEXP_API sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)); +SEXP_API sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port); +SEXP_API sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source); +SEXP_API sexp sexp_user_exception (sexp ctx, sexp self, const char *msg, sexp x); +SEXP_API sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp x); +SEXP_API sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp x); +SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); +SEXP_API sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp out); +SEXP_API void sexp_init(void); + +#define sexp_assert_type(ctx, pred, type_id, obj) if (! pred(obj)) return sexp_type_exception(ctx, self, type_id, obj) + +#define SEXP_COPY_DEFAULT SEXP_ZERO +#define SEXP_COPY_FREEP SEXP_ONE + +#if SEXP_USE_GLOBAL_HEAP +#define sexp_destroy_context(ctx) +#else +SEXP_API void sexp_destroy_context (sexp ctx); +SEXP_API sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags); +#endif + +#if SEXP_USE_TYPE_DEFS +SEXP_API sexp sexp_register_type_op (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2); +SEXP_API sexp sexp_register_simple_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp slots); +SEXP_API sexp sexp_register_c_type (sexp ctx, sexp name); +SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj); +#define sexp_register_c_type(ctx, name, finalizer) \ + sexp_register_type(ctx, name, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \ + SEXP_ZERO, sexp_make_fixnum(sexp_sizeof(cpointer)), \ + SEXP_ZERO, SEXP_ZERO, (sexp_proc2)finalizer) +#endif + +#define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL),SEXP_FALSE) +#define sexp_debug(ctx, msg, obj) (sexp_write_string(ctx, msg, sexp_current_error_port(ctx)), sexp_write(ctx, obj, sexp_current_error_port(ctx)), sexp_write_char(ctx, '\n', sexp_current_error_port(ctx))) + +/* simplify primitive API interface */ + +#define sexp_read(ctx, in) sexp_read_op(ctx sexp_api_pass(NULL, 1), in) +#define sexp_write(ctx, obj, out) sexp_write_op(ctx sexp_api_pass(NULL, 2), obj, out) +#define sexp_display(ctx, obj, out) sexp_display_op(ctx sexp_api_pass(NULL, 2), obj, out) +#define sexp_print_exception(ctx, e, out) sexp_print_exception_op(ctx sexp_api_pass(NULL, 2), e, out) +#define sexp_flush_output(ctx, obj, out) sexp_flush_output_op(ctx sexp_api_pass(NULL, 1), out) +#define sexp_equalp(ctx, a, b) sexp_equalp_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_listp(ctx, x) sexp_listp_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_length(ctx, x) sexp_length_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_reverse(ctx, x) sexp_reverse_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_nreverse(ctx, x) sexp_nreverse_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_copy_list(ctx, x) sexp_copy_list_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_cons(ctx, a, b) sexp_cons_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_append2(ctx, a, b) sexp_append2_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_vector(ctx, a, b) sexp_make_vector_op(ctx sexp_api_pass(NULL, 2), a, b); +#define sexp_list_to_vector(ctx, x) sexp_list_to_vector_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_exception_type(ctx, x) sexp_exception_type_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_string_to_number(ctx, s, b) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), s, b) +#define sexp_make_bytes(ctx, l, i) sexp_make_bytes_op(ctx sexp_api_pass(NULL, 2), l, i) +#define sexp_make_string(ctx, l, c) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), l, c) +#define sexp_string_cmp(ctx, a, b, c) sexp_string_cmp_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_substring(ctx, a, b, c) sexp_substring_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_string_concatenate(ctx, ls, s) sexp_string_concatenate_op(ctx sexp_api_pass(NULL, 2), ls, s) +#define sexp_memq(ctx, a, b) sexp_memq_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_assq(ctx, a, b) sexp_assq_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_output_string_port(ctx) sexp_make_output_string_port_op(ctx sexp_api_pass(NULL, 0)) +#define sexp_make_input_string_port(ctx, s) sexp_make_input_string_port_op(ctx sexp_api_pass(NULL, 1), s) +#define sexp_get_output_string(ctx, out) sexp_get_output_string_op(ctx sexp_api_pass(NULL, 1), out) +#define sexp_expt(ctx, a, b) sexp_expt_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_register_simple_type(ctx, a, b) sexp_register_simple_type_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_register_type(ctx, a, b, c, d, e, f, g, h, i, j) sexp_register_type_op(ctx sexp_api_pass(NULL, 10), a, b, c, d, e, f, g, h, i, j) +#define sexp_make_type_predicate(ctx, a, b) sexp_make_type_predicate_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_constructor(ctx, a, b) sexp_make_constructor_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_getter(ctx, a, b, c) sexp_make_getter_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_make_setter(ctx, a, b, c) sexp_make_setter_op(ctx sexp_api_pass(NULL, 3), a, b, c) + +#ifdef __cplusplus +} /* extern "C" */ +#endif + +#endif /* ! SEXP_H */ + diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c new file mode 100644 index 00000000..8d946273 --- /dev/null +++ b/lib/chibi/ast.c @@ -0,0 +1,248 @@ +/* ast.c -- interface to the Abstract Syntax Tree */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +static void sexp_define_type_predicate (sexp ctx, sexp env, char *cname, sexp_uint_t type) { + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + name = sexp_c_string(ctx, cname, -1); + op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type)); + sexp_env_define(ctx, env, name=sexp_intern(ctx, cname, -1), op); + sexp_gc_release2(ctx); +} + +static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype, + sexp_uint_t cindex, char* get, char *set) { + sexp type, index; + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + type = sexp_make_fixnum(ctype); + index = sexp_make_fixnum(cindex); + op = sexp_make_getter(ctx, name=sexp_c_string(ctx, get, -1), type, index); + sexp_env_define(ctx, env, name=sexp_intern(ctx, get, -1), op); + op = sexp_make_setter(ctx, name=sexp_c_string(ctx, set, -1), type, index); + sexp_env_define(ctx, env, name=sexp_intern(ctx, set, -1), op); + sexp_gc_release2(ctx); +} + +static sexp sexp_get_env_cell (sexp ctx sexp_api_params(self, n), sexp env, sexp id) { + sexp cell = sexp_env_cell(env, id); + while ((! cell) && sexp_synclop(id)) { + env = sexp_synclo_env(id); + id = sexp_synclo_expr(id); + } + return cell ? cell : SEXP_FALSE; +} + +static sexp sexp_get_opcode_name (sexp ctx sexp_api_params(self, n), sexp op) { + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + else if (! sexp_opcode_name(op)) + return SEXP_FALSE; + else + return sexp_intern(ctx, sexp_opcode_name(op), -1); +} + +static sexp sexp_translate_opcode_type (sexp ctx, sexp type) { + sexp_gc_var2(res, tmp); + res = type; + if (! res) { + res = sexp_type_by_index(ctx, SEXP_OBJECT); + } if (sexp_fixnump(res)) { + res = sexp_type_by_index(ctx, sexp_unbox_fixnum(res)); + } else if (sexp_nullp(res)) { /* opcode list types */ + sexp_gc_preserve2(ctx, res, tmp); + tmp = sexp_intern(ctx, "or", -1); + res = sexp_cons(ctx, SEXP_NULL, SEXP_NULL); + res = sexp_cons(ctx, sexp_type_by_index(ctx, SEXP_PAIR), res); + res = sexp_cons(ctx, tmp, res); + sexp_gc_release2(ctx); + } + return res; +} + +static sexp sexp_get_opcode_ret_type (sexp ctx sexp_api_params(self, n), sexp op) { + sexp res; + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + if (sexp_opcode_code(op) == SEXP_OP_RAISE) + return sexp_list1(ctx, sexp_intern(ctx, "error", -1)); + res = sexp_opcode_return_type(op); + if (sexp_fixnump(res)) + res = sexp_type_by_index(ctx, sexp_unbox_fixnum(res)); + return sexp_translate_opcode_type(ctx, res); +} + +static sexp sexp_get_opcode_param_type (sexp ctx sexp_api_params(self, n), sexp op, sexp k) { + sexp res; + int p = sexp_unbox_fixnum(k); + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + else if (! sexp_fixnump(k)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, k); + if (p > sexp_opcode_num_args(op) && sexp_opcode_variadic_p(op)) + p = sexp_opcode_num_args(op); + switch (p) { + case 0: + res = sexp_opcode_arg1_type(op); + break; + case 1: + res = sexp_opcode_arg2_type(op); + break; + default: + res = sexp_opcode_arg3_type(op); + if (sexp_vectorp(res)) { + if (sexp_vector_length(res) > (sexp_unbox_fixnum(k)-2)) + res = sexp_vector_ref(res, sexp_fx_sub(k, SEXP_TWO)); + else + res = sexp_type_by_index(ctx, SEXP_OBJECT); + } + break; + } + return sexp_translate_opcode_type(ctx, res); +} + +static sexp sexp_get_opcode_num_params (sexp ctx sexp_api_params(self, n), sexp op) { + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + return sexp_make_fixnum(sexp_opcode_num_args(op)); +} + +static sexp sexp_get_opcode_variadic_p (sexp ctx sexp_api_params(self, n), sexp op) { + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + return sexp_make_boolean(sexp_opcode_variadic_p(op)); +} + +static sexp sexp_type_of (sexp ctx sexp_api_params(self, n), sexp x) { + if (sexp_pointerp(x)) + return sexp_object_type(ctx, x); + else if (sexp_fixnump(x)) + return sexp_type_by_index(ctx, SEXP_FIXNUM); + else if (sexp_booleanp(x)) + return sexp_type_by_index(ctx, SEXP_BOOLEAN); + else if (sexp_charp(x)) + return sexp_type_by_index(ctx, SEXP_CHAR); +#if SEXP_USE_HUFF_SYMS + else if (sexp_symbolp(x)) + return sexp_type_by_index(ctx, SEXP_SYMBOL); +#endif +#if SEXP_USE_IMMEDIATE_FLONUMS + else if (sexp_flonump(x)) + return sexp_type_by_index(ctx, SEXP_FLONUM); +#endif + else + return sexp_type_by_index(ctx, SEXP_OBJECT); +} + +static sexp sexp_analyze_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { + sexp ctx2 = ctx; + if (sexp_envp(e)) { + ctx2 = sexp_make_child_context(ctx, NULL); + sexp_context_env(ctx2) = e; + } + return sexp_analyze(ctx2, x); +} + +static sexp sexp_optimize (sexp ctx sexp_api_params(self, n), sexp x) { + sexp_gc_var2(ls, res); + sexp_gc_preserve2(ctx, ls, res); + res = x; + ls = sexp_global(ctx, SEXP_G_OPTIMIZATIONS); + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) + res = sexp_apply1(ctx, sexp_cdar(ls), res); + sexp_free_vars(ctx, res, SEXP_NULL); + sexp_gc_release2(ctx); + return res; +} + +#define sexp_define_type(ctx, name, tag) \ + sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), sexp_type_by_index(ctx, tag)); + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_type(ctx, "", SEXP_OBJECT); + sexp_define_type(ctx, "", SEXP_NUMBER); + sexp_define_type(ctx, "", SEXP_BIGNUM); + sexp_define_type(ctx, "", SEXP_FLONUM); + sexp_define_type(ctx, "", SEXP_FIXNUM); + sexp_define_type(ctx, "", SEXP_SYMBOL); + sexp_define_type(ctx, "", SEXP_CHAR); + sexp_define_type(ctx, "", SEXP_BOOLEAN); + sexp_define_type(ctx, "", SEXP_STRING); + sexp_define_type(ctx, "", SEXP_BYTES); + sexp_define_type(ctx, "", SEXP_PAIR); + sexp_define_type(ctx, "", SEXP_VECTOR); + sexp_define_type(ctx, "", SEXP_OPCODE); + sexp_define_type(ctx, "", SEXP_PROCEDURE); + sexp_define_type(ctx, "", SEXP_BYTECODE); + sexp_define_type(ctx, "", SEXP_ENV); + sexp_define_type(ctx, "", SEXP_MACRO); + sexp_define_type(ctx, "", SEXP_LAMBDA); + sexp_define_type(ctx, "", SEXP_CND); + sexp_define_type(ctx, "", SEXP_SET); + sexp_define_type(ctx, "", SEXP_REF); + sexp_define_type(ctx, "", SEXP_SEQ); + sexp_define_type(ctx, "", SEXP_LIT); + sexp_define_type(ctx, "", SEXP_SYNCLO); + sexp_define_type(ctx, "", SEXP_CONTEXT); + sexp_define_type(ctx, "", SEXP_EXCEPTION); + sexp_define_type_predicate(ctx, env, "environment?", SEXP_ENV); + sexp_define_type_predicate(ctx, env, "bytecode?", SEXP_BYTECODE); + sexp_define_type_predicate(ctx, env, "exception?", SEXP_EXCEPTION); + sexp_define_type_predicate(ctx, env, "macro?", SEXP_MACRO); + sexp_define_type_predicate(ctx, env, "syntactic-closure?", SEXP_SYNCLO); + sexp_define_type_predicate(ctx, env, "lambda?", SEXP_LAMBDA); + sexp_define_type_predicate(ctx, env, "cnd?", SEXP_CND); + sexp_define_type_predicate(ctx, env, "set?", SEXP_SET); + sexp_define_type_predicate(ctx, env, "ref?", SEXP_REF); + sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ); + sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT); + sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE); + sexp_define_type_predicate(ctx, env, "type?", SEXP_TYPE); + sexp_define_type_predicate(ctx, env, "context?", SEXP_CONTEXT); + sexp_define_type_predicate(ctx, env, "exception?", SEXP_EXCEPTION); + sexp_define_accessors(ctx, env, SEXP_PAIR, 2, "pair-source", "pair-source-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 0, "syntactic-closure-env", "syntactic-closure-env-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", "syntactic-closure-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 2, "syntactic-closure-expr", "syntactic-closure-expr-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 0, "lambda-name", "lambda-name-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 1, "lambda-params", "lambda-params-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 2, "lambda-body", "lambda-body-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 3, "lambda-defs", "lambda-defs-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 4, "lambda-locals", "lambda-locals-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 5, "lambda-flags", "lambda-flags-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 6, "lambda-free-vars", "lambda-free-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 7, "lambda-set-vars", "lambda-set-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 8, "lambda-return-type", "lambda-return-type-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 9, "lambda-param-types", "lambda-param-types-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 10, "lambda-source", "lambda-source-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 0, "cnd-test", "cnd-test-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 1, "cnd-pass", "cnd-pass-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 2, "cnd-fail", "cnd-fail-set!"); + sexp_define_accessors(ctx, env, SEXP_SET, 0, "set-var", "set-var-set!"); + sexp_define_accessors(ctx, env, SEXP_SET, 1, "set-value", "set-value-set!"); + sexp_define_accessors(ctx, env, SEXP_REF, 0, "ref-name", "ref-name-set!"); + sexp_define_accessors(ctx, env, SEXP_REF, 1, "ref-cell", "ref-cell-set!"); + sexp_define_accessors(ctx, env, SEXP_SEQ, 0, "seq-ls", "seq-ls-set!"); + sexp_define_accessors(ctx, env, SEXP_LIT, 0, "lit-value", "lit-value-set!"); + sexp_define_accessors(ctx, env, SEXP_PROCEDURE, 1, "procedure-code", "procedure-code-set!"); + sexp_define_accessors(ctx, env, SEXP_PROCEDURE, 2, "procedure-vars", "procedure-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_BYTECODE, 1, "bytecode-name", "bytecode-name-set!"); + sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 0, "exception-kind", "exception-kind-set!"); + sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 1, "exception-message", "exception-message-set!"); + sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 2, "exception-irritants", "exception-irritants-set!"); + sexp_define_foreign_opt(ctx, env, "analyze", 2, sexp_analyze_op, SEXP_FALSE); + sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env); + sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell); + sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name); + sexp_define_foreign(ctx, env, "opcode-variadic?", 1, sexp_get_opcode_variadic_p); + sexp_define_foreign(ctx, env, "opcode-num-params", 1, sexp_get_opcode_num_params); + sexp_define_foreign(ctx, env, "opcode-return-type", 1, sexp_get_opcode_ret_type); + sexp_define_foreign(ctx, env, "opcode-param-type", 2, sexp_get_opcode_param_type); + sexp_define_foreign(ctx, env, "optimize", 1, sexp_optimize); + sexp_define_foreign(ctx, env, "type-of", 1, sexp_type_of); + return SEXP_VOID; +} + diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module new file mode 100644 index 00000000..a439bd57 --- /dev/null +++ b/lib/chibi/ast.module @@ -0,0 +1,33 @@ + +(define-module (chibi ast) + (export + analyze optimize env-cell ast->sexp macroexpand type-of + + + + + pair-source pair-source-set! + syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? type? + environment? bytecode? exception? macro? context? exception? + syntactic-closure-expr syntactic-closure-env syntactic-closure-vars + lambda-name lambda-params lambda-body lambda-defs lambda-locals + lambda-flags lambda-free-vars lambda-set-vars lambda-return-type + lambda-param-types lambda-source + lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-set! + lambda-locals-set! lambda-flags-set! lambda-free-vars-set! + lambda-set-vars-set! lambda-return-type-set! lambda-param-types-set! + lambda-source-set! + cnd-test cnd-pass cnd-fail + cnd-test-set! cnd-pass-set! cnd-fail-set! + set-var set-value set-var-set! set-value-set! + ref-name ref-cell ref-name-set! ref-cell-set! + seq-ls seq-ls-set! lit-value lit-value-set! + exception-kind exception-kind-set! exception-message exception-message-set! + exception-irritants exception-irritants-set! + opcode-name opcode-num-params opcode-return-type opcode-param-type + opcode-variadic? + procedure-code procedure-vars procedure-name bytecode-name) + (import-immutable (scheme)) + (include-shared "ast") + (include "ast.scm")) + diff --git a/lib/chibi/ast.scm b/lib/chibi/ast.scm new file mode 100644 index 00000000..020f257a --- /dev/null +++ b/lib/chibi/ast.scm @@ -0,0 +1,91 @@ +;; ast.scm -- ast utilities +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (macroexpand x) + (ast->sexp (analyze x))) + +(define (procedure-name x) + (bytecode-name (procedure-code x))) + +(define (ast-renames ast) + (define i 0) + (define renames '()) + (define (rename-symbol id) + (set! i (+ i 1)) + (string->symbol + (string-append (symbol->string (identifier->symbol id)) + "." (number->string i)))) + (define (rename-lambda lam) + (or (assq lam renames) + (let ((res (list lam))) + (set! renames (cons res renames)) + res))) + (define (rename! id lam) + (let ((cell (rename-lambda lam))) + (set-cdr! cell (cons (cons id (rename-symbol id)) (cdr cell))))) + (define (check-ref id lam env) + (let ((sym (identifier->symbol id))) + (let lp1 ((ls env)) + (cond + ((pair? ls) + (let lp2 ((ls2 (car ls)) (found? #f)) + (cond + ((null? ls2) + (if (not found?) (lp1 (cdr ls)))) + ((and (eq? id (caar ls2)) (eq? lam (cdar ls2))) + (lp2 (cdr ls2) #t)) + ((eq? sym (identifier->symbol (caar ls2))) + (rename! (caar ls2) (cdar ls2)) + (lp2 (cdr ls2) found?)) + (else + (lp2 (cdr ls2) found?))))))))) + (define (flatten-dot x) + (cond ((pair? x) (cons (car x) (flatten-dot (cdr x)))) + ((null? x) x) + (else (list x)))) + (define (extend-env lam env) + (cons (map (lambda (x) (cons x lam)) (flatten-dot (lambda-params lam))) env)) + (let lp ((x ast) (env '())) + (cond + ((lambda? x) (lp (lambda-body x) (extend-env x env))) + ((ref? x) (check-ref (ref-name x) (cdr (ref-cell x)) env)) + ((cnd? x) (lp (cnd-test x) env) (lp (cnd-pass x) env) (lp (cnd-fail x) env)) + ((set? x) (lp (set-var x) env) (lp (set-value x) env)) + ((seq? x) (for-each (lambda (x) (lp x env)) (seq-ls x))) + ((pair? x) (for-each (lambda (x) (lp x env)) x)))) + renames) + +(define (get-rename id lam renames) + (let ((ls (assq lam renames))) + (if (not ls) + (identifier->symbol id) + (cond ((assq id (cdr ls)) => cdr) (else (identifier->symbol id)))))) + +(define (map* f ls) + (cond ((pair? ls) (cons (f (car ls)) (map* f (cdr ls)))) + ((null? ls) '()) + (else (f ls)))) + +(define (ast->sexp ast) + (let ((renames (ast-renames ast))) + (let a2s ((x ast)) + (cond + ((lambda? x) + `(lambda ,(map* (lambda (id) (get-rename id x renames)) (lambda-params x)) + ,@(map (lambda (d) `(define ,(identifier->symbol (caar d)) #f)) + (lambda-defs x)) + ,@(if (seq? (lambda-body x)) + (map a2s (seq-ls (lambda-body x))) + (list (a2s (lambda-body x)))))) + ((cnd? x) `(if ,(a2s (cnd-test x)) ,(a2s (cnd-pass x)) ,(a2s (cnd-fail x)))) + ((set? x) `(set! ,(a2s (set-var x)) ,(a2s (set-value x)))) + ((ref? x) (get-rename (ref-name x) (cdr (ref-cell x)) renames)) + ((seq? x) `(begin ,@(map a2s (seq-ls x)))) + ((lit? x) + (let ((v (lit-value x))) + (if (or (pair? v) (null? v) (symbol? v)) `',v v))) + ((pair? x) (cons (a2s (car x)) (a2s (cdr x)))) + ((opcode? x) (or (opcode-name x) x)) + (else x))))) + diff --git a/lib/chibi/base64.module b/lib/chibi/base64.module new file mode 100644 index 00000000..12324e1d --- /dev/null +++ b/lib/chibi/base64.module @@ -0,0 +1,7 @@ + +(define-module (chibi base64) + (export base64-encode base64-encode-string + base64-decode base64-decode-string + base64-encode-header) + (import-immutable (scheme) (srfi 33) (chibi io)) + (include "base64.scm")) diff --git a/lib/chibi/base64.scm b/lib/chibi/base64.scm new file mode 100644 index 00000000..3d95ad71 --- /dev/null +++ b/lib/chibi/base64.scm @@ -0,0 +1,351 @@ +;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; Procedure: base64-encode-string str +;; Return a base64 encoded representation of string according to the +;; official base64 standard as described in RFC3548. + +;; Procedure: base64-decode-string str +;; Return a base64 decoded representation of string, also interpreting +;; the alternate 62 & 63 valued characters as described in RFC3548. +;; Other out-of-band characters are silently stripped, and = signals +;; the end of the encoded string. No errors will be raised. + +;; Procedure: base64-encode [port] +;; Procedure: base64-decode [port] +;; Variations of the above which read and write to ports. + +;; Procedure: base64-encode-header enc str [start-col max-col nl] +;; Return a base64 encoded representation of string as above, +;; wrapped in =?ENC?B?...?= as per RFC1522, split across multiple +;; MIME-header lines as needed to keep each lines length less than +;; MAX-COL. The string is encoded as is, and the encoding ENC is +;; just used for the prefix, i.e. you are responsible for ensuring +;; STR is already encoded according to ENC. The optional argument +;; NL is the newline separator, defaulting to CRLF. + +;; This API is compatible with the Gauche library rfc.base64. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils + +(define (string-chop str n) + (let ((len (string-length str))) + (let lp ((i 0) (res '())) + (let ((j (+ i n))) + (if (>= j len) + (reverse (cons (substring str i len) res)) + (lp j (cons (substring str i j) res))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; constants and tables + +(define *default-max-col* 76) + +(define *outside-char* 99) ; luft-balloons +(define *pad-char* 101) ; dalmations + +(define *base64-decode-table* + (let ((res (make-vector #x100 *outside-char*))) + (let lp ((i 0)) ; map letters + (cond + ((<= i 25) + (vector-set! res (+ i 65) i) + (vector-set! res (+ i 97) (+ i 26)) + (lp (+ i 1))))) + (let lp ((i 0)) ; map numbers + (cond + ((<= i 9) + (vector-set! res (+ i 48) (+ i 52)) + (lp (+ i 1))))) + ;; extras (be liberal for different common base64 formats) + (vector-set! res (char->integer #\+) 62) + (vector-set! res (char->integer #\-) 62) + (vector-set! res (char->integer #\/) 63) + (vector-set! res (char->integer #\_) 63) + (vector-set! res (char->integer #\~) 63) + (vector-set! res (char->integer #\=) *pad-char*) + res)) + +(define (base64-decode-char c) + (vector-ref *base64-decode-table* (char->integer c))) + +(define *base64-encode-table* + (let ((res (make-vector 64))) + (let lp ((i 0)) ; map letters + (cond + ((<= i 25) + (vector-set! res i (integer->char (+ i 65))) + (vector-set! res (+ i 26) (integer->char (+ i 97))) + (lp (+ i 1))))) + (let lp ((i 0)) ; map numbers + (cond + ((<= i 9) + (vector-set! res (+ i 52) (integer->char (+ i 48))) + (lp (+ i 1))))) + (vector-set! res 62 #\+) + (vector-set! res 63 #\/) + res)) + +(define (enc i) + (vector-ref *base64-encode-table* i)) + +;; try to match common boundaries +(define decode-src-length + (lcm 76 78)) + +(define decode-dst-length + (* 3 (arithmetic-shift (+ 3 decode-src-length) -2))) + +(define encode-src-length + (* 3 1024)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; decoding + +;; Create a result buffer with the maximum possible length for the +;; input, and pass it to the internal base64-decode-string! utility. +;; If the resulting length used is exact, we can return that buffer, +;; otherwise we return the appropriate substring. +(define (base64-decode-string src) + (let* ((len (string-length src)) + (dst-len (* 3 (arithmetic-shift (+ 3 len) -2))) + (dst (make-string dst-len))) + (base64-decode-string! + src 0 len dst + (lambda (src-offset res-len b1 b2 b3) + (let ((res-len (base64-decode-finish dst res-len b1 b2 b3))) + (if (= res-len dst-len) + dst + (substring dst 0 res-len))))))) + +;; This is a little funky. +;; +;; We want to skip over "outside" characters (e.g. newlines inside +;; base64-encoded data, as would be passed in mail clients and most +;; large base64 data). This would normally mean two nested loops - +;; one for overall processing the input, and one for looping until +;; we get to a valid character. However, many Scheme compilers are +;; really bad about optimizing nested loops of primitives, so we +;; flatten this into a single loop, using conditionals to determine +;; which character is currently being read. +(define (base64-decode-string! src start end dst kont) + (let lp ((i start) + (j 0) + (b1 *outside-char*) + (b2 *outside-char*) + (b3 *outside-char*)) + (if (>= i end) + (kont i j b1 b2 b3) + (let ((c (base64-decode-char (string-ref src i)))) + (cond + ((eqv? c *pad-char*) + (kont i j b1 b2 b3)) + ((eqv? c *outside-char*) + (lp (+ i 1) j b1 b2 b3)) + ((eqv? b1 *outside-char*) + (lp (+ i 1) j c b2 b3)) + ((eqv? b2 *outside-char*) + (lp (+ i 1) j b1 c b3)) + ((eqv? b3 *outside-char*) + (lp (+ i 1) j b1 b2 c)) + (else + (string-set! dst + j + (integer->char + (bitwise-ior (arithmetic-shift b1 2) + (extract-bit-field 2 4 b2)))) + (string-set! dst + (+ j 1) + (integer->char + (bitwise-ior + (arithmetic-shift (extract-bit-field 4 0 b2) 4) + (extract-bit-field 4 2 b3)))) + (string-set! dst + (+ j 2) + (integer->char + (bitwise-ior + (arithmetic-shift (extract-bit-field 2 0 b3) 6) + c))) + (lp (+ i 1) (+ j 3) + *outside-char* *outside-char* *outside-char*))))))) + +;; If requested, account for any "partial" results (i.e. trailing 2 or +;; 3 chars) by writing them into the destination (additional 1 or 2 +;; bytes) and returning the adjusted offset for how much data we've +;; written. +(define (base64-decode-finish dst j b1 b2 b3) + (cond + ((eqv? b1 *outside-char*) + j) + ((eqv? b2 *outside-char*) + (string-set! dst j (integer->char (arithmetic-shift b1 2))) + (+ j 1)) + (else + (string-set! dst + j + (integer->char + (bitwise-ior (arithmetic-shift b1 2) + (extract-bit-field 2 4 b2)))) + (cond + ((eqv? b3 *outside-char*) + (+ j 1)) + (else + (string-set! dst + (+ j 1) + (integer->char + (bitwise-ior + (arithmetic-shift (extract-bit-field 4 0 b2) 4) + (extract-bit-field 4 2 b3)))) + (+ j 2)))))) + +;; General port decoder: work in single blocks at a time to avoid +;; allocating memory (crucial for Scheme implementations that don't +;; allow large strings). +(define (base64-decode . o) + (let ((in (if (pair? o) (car o) (current-input-port))) + (out (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (current-output-port)))) + (let ((src (make-string decode-src-length)) + (dst (make-string decode-dst-length))) + (let lp ((offset 0)) + (let ((src-len (+ offset + (read-string! decode-src-length src in offset)))) + (cond + ((= src-len decode-src-length) + ;; read a full chunk: decode, write and loop + (base64-decode-string! + src 0 decode-src-length dst + (lambda (src-offset dst-len b1 b2 b3) + (cond + ((and (< src-offset src-len) + (eqv? #\= (string-ref src src-offset))) + ;; done + (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3))) + (write-string dst dst-len out))) + ((eqv? b1 *outside-char*) + (write-string dst dst-len out) + (lp 0)) + (else + (write-string dst dst-len out) + ;; one to three chars left in buffer + (string-set! src 0 (enc b1)) + (cond + ((eqv? b2 *outside-char*) + (lp 1)) + (else + (string-set! src 1 (enc b2)) + (cond + ((eqv? b3 *outside-char*) + (lp 2)) + (else + (string-set! src 2 (enc b3)) + (lp 3)))))))))) + (else + ;; end of source - just decode and write once + (base64-decode-string! + src 0 src-len dst + (lambda (src-offset dst-len b1 b2 b3) + (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3))) + (write-string dst dst-len out))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; encoding + +(define (base64-encode-string str) + (let* ((len (string-length str)) + (quot (quotient len 3)) + (rem (- len (* quot 3))) + (res-len (arithmetic-shift (+ quot (if (zero? rem) 0 1)) 2)) + (res (make-string res-len))) + (base64-encode-string! str 0 len res) + res)) + +(define (base64-encode-string! str start end res) + (let* ((res-len (string-length res)) + (limit (- end 2))) + (let lp ((i start) (j 0)) + (if (>= i limit) + (case (- end i) + ((1) + (let ((b1 (char->integer (string-ref str i)))) + (string-set! res j (enc (arithmetic-shift b1 -2))) + (string-set! res + (+ j 1) + (enc (arithmetic-shift (bitwise-and #b11 b1) 4))) + (string-set! res (+ j 2) #\=) + (string-set! res (+ j 3) #\=))) + ((2) + (let ((b1 (char->integer (string-ref str i))) + (b2 (char->integer (string-ref str (+ i 1))))) + (string-set! res j (enc (arithmetic-shift b1 -2))) + (string-set! res + (+ j 1) + (enc (bitwise-ior + (arithmetic-shift (bitwise-and #b11 b1) 4) + (extract-bit-field 4 4 b2)))) + (string-set! res + (+ j 2) + (enc (arithmetic-shift (extract-bit-field 4 0 b2) + 2))) + (string-set! res (+ j 3) #\=)))) + (let ((b1 (char->integer (string-ref str i))) + (b2 (char->integer (string-ref str (+ i 1)))) + (b3 (char->integer (string-ref str (+ i 2))))) + (string-set! res j (enc (arithmetic-shift b1 -2))) + (string-set! res + (+ j 1) + (enc (bitwise-ior + (arithmetic-shift (bitwise-and #b11 b1) 4) + (extract-bit-field 4 4 b2)))) + (string-set! res + (+ j 2) + (enc (bitwise-ior + (arithmetic-shift (extract-bit-field 4 0 b2) 2) + (extract-bit-field 2 6 b3)))) + (string-set! res (+ j 3) (enc (bitwise-and #b111111 b3))) + (lp (+ i 3) (+ j 4))))))) + +(define (base64-encode . o) + (let ((in (if (pair? o) (car o) (current-input-port))) + (out (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (current-output-port)))) + (let ((src (make-string encode-src-length)) + (dst (make-string + (arithmetic-shift (quotient encode-src-length 3) 2)))) + (let lp () + (let ((n (read-string! 2048 src in))) + (base64-encode-string! src 0 n dst) + (write-string dst (* 3 (quotient (+ n 3) 4)) out) + (if (= n 2048) + (lp))))))) + +(define (base64-encode-header encoding str . o) + (define (round4 i) (arithmetic-shift (arithmetic-shift i -2) 2)) + (let ((start-col (if (pair? o) (car o) 0)) + (max-col (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + *default-max-col*)) + (nl (if (and (pair? o) (pair? (cdr o)) (pair? (cdr (cdr o)))) + (car (cdr (cdr o))) + "\r\n"))) + (let* ((prefix (string-append "=?" encoding "?B?")) + (prefix-length (+ 2 (string-length prefix))) + (effective-max-col (round4 (- max-col prefix-length))) + (first-max-col (round4 (- effective-max-col start-col))) + (str (base64-encode-string str)) + (len (string-length str))) + (if (<= len first-max-col) + (string-append prefix str "?=") + (string-append + (if (positive? first-max-col) + (string-append + prefix (substring str 0 first-max-col) "?=" nl "\t" prefix) + "") + (string-concatenate (string-chop (substring str first-max-col len) + effective-max-col) + (string-append "?=" nl "\t" prefix)) + "?="))))) + diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c new file mode 100644 index 00000000..d193e3a7 --- /dev/null +++ b/lib/chibi/disasm.c @@ -0,0 +1,99 @@ +/* disasm.c -- optional debugging utilities */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" +#include "../../opt/opcode_names.h" + +#define SEXP_DISASM_MAX_DEPTH 8 +#define SEXP_DISASM_PAD_WIDTH 4 + +static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { + sexp tmp; + unsigned char *ip, opcode, i; + + if (sexp_procedurep(bc)) { + bc = sexp_procedure_code(bc); + } else if (sexp_opcodep(bc)) { + sexp_printf(ctx, out, "%s is a primitive\n", sexp_opcode_name(bc)); + return SEXP_VOID; + } else if (! sexp_bytecodep(bc)) { + return sexp_type_exception(ctx, self, SEXP_BYTECODE, bc); + } + if (! sexp_oportp(out)) { + return sexp_type_exception(ctx, self, SEXP_OPORT, out); + } + + for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) + sexp_write_char(ctx, ' ', out); + sexp_write_string(ctx, "-------------- ", out); + if (sexp_truep(sexp_bytecode_name(bc))) { + sexp_write(ctx, sexp_bytecode_name(bc), out); + sexp_write_char(ctx, ' ', out); + } + sexp_printf(ctx, out, "%p\n", bc); + + ip = sexp_bytecode_data(bc); + + loop: + for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) + sexp_write_char(ctx, ' ', out); + opcode = *ip++; + if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) { + sexp_printf(ctx, out, " %s ", reverse_opcode_names[opcode]); + } else { + sexp_printf(ctx, out, " %d ", opcode); + } + switch (opcode) { + case SEXP_OP_STACK_REF: + case SEXP_OP_LOCAL_REF: + case SEXP_OP_LOCAL_SET: + case SEXP_OP_CLOSURE_REF: + case SEXP_OP_JUMP: + case SEXP_OP_JUMP_UNLESS: + case SEXP_OP_TYPEP: + case SEXP_OP_FCALL0: + case SEXP_OP_FCALL1: + case SEXP_OP_FCALL2: + case SEXP_OP_FCALL3: + case SEXP_OP_FCALL4: + sexp_printf(ctx, out, "%ld", (long) ((sexp*)ip)[0]); + ip += sizeof(sexp); + break; + case SEXP_OP_SLOT_REF: + case SEXP_OP_SLOT_SET: + case SEXP_OP_MAKE: + ip += sizeof(sexp)*2; + break; + case SEXP_OP_GLOBAL_REF: + case SEXP_OP_GLOBAL_KNOWN_REF: + case SEXP_OP_TAIL_CALL: + case SEXP_OP_CALL: + case SEXP_OP_PUSH: + tmp = ((sexp*)ip)[0]; + if (((opcode == SEXP_OP_GLOBAL_REF) || (opcode == SEXP_OP_GLOBAL_KNOWN_REF)) + && sexp_pairp(tmp)) + tmp = sexp_car(tmp); + else if ((opcode == SEXP_OP_PUSH) && (sexp_pairp(tmp) || sexp_idp(tmp))) + sexp_write_char(ctx, '\'', out); + sexp_write(ctx, tmp, out); + ip += sizeof(sexp); + break; + } + sexp_write_char(ctx, '\n', out); + if ((opcode == SEXP_OP_PUSH) && (depth < SEXP_DISASM_MAX_DEPTH) + && (sexp_bytecodep(tmp) || sexp_procedurep(tmp))) + disasm(ctx, self, tmp, out, depth+1); + if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) + goto loop; + return SEXP_VOID; +} + +static sexp sexp_disasm (sexp ctx sexp_api_params(self, n), sexp bc, sexp out) { + return disasm(ctx, self, bc, out, 0); +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign_param(ctx, env, "disasm", 2, (sexp_proc1)sexp_disasm, "*current-output-port*"); + return SEXP_VOID; +} diff --git a/lib/chibi/disasm.module b/lib/chibi/disasm.module new file mode 100644 index 00000000..9017a4bc --- /dev/null +++ b/lib/chibi/disasm.module @@ -0,0 +1,5 @@ + +(define-module (chibi disasm) + (export disasm) + (import-immutable (scheme)) + (include-shared "disasm")) diff --git a/lib/chibi/filesystem.module b/lib/chibi/filesystem.module new file mode 100644 index 00000000..ecd4af32 --- /dev/null +++ b/lib/chibi/filesystem.module @@ -0,0 +1,27 @@ + +(define-module (chibi filesystem) + (export open-input-file-descriptor open-output-file-descriptor + duplicate-file-descriptor duplicate-file-descriptor-to + close-file-descriptor renumber-file-descriptor + delete-file link-file symbolic-link-file rename-file + directory-files directory-fold create-directory delete-directory + file-status + file-device file-inode + file-mode file-num-links + file-owner file-group + file-represented-device file-size + file-block-size file-num-blocks + file-access-time file-modification-time file-change-time + file-regular? file-directory? file-character? + file-block? file-fifo? file-link? + file-socket? file-exists? + get-file-descriptor-flags set-file-descriptor-flags! + get-file-descriptor-status set-file-descriptor-status! + open/read open/write open/read-write + open/create open/exclusive open/truncate + open/append open/non-block + is-a-tty?) + (import-immutable (scheme)) + (include-shared "filesystem") + (include "filesystem.scm")) + diff --git a/lib/chibi/filesystem.scm b/lib/chibi/filesystem.scm new file mode 100644 index 00000000..aa3fc69f --- /dev/null +++ b/lib/chibi/filesystem.scm @@ -0,0 +1,43 @@ +;; filesystem.scm -- additional filesystem utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (directory-fold dir kons knil) + (let ((dir (opendir dir))) + (let lp ((res knil)) + (let ((file (readdir dir))) + (if file (lp (kons (dirent-name file) res)) res))))) + +(define (directory-files dir) + (directory-fold dir cons '())) + +(define (renumber-file-descriptor old new) + (and (duplicate-file-descriptor-to old new) + (close-file-descriptor old))) + +(define (file-status file) + (if (string? file) (stat file) (fstat file))) + +(define (file-device x) (stat-dev (if (stat? x) x (file-status x)))) +(define (file-inode x) (stat-ino (if (stat? x) x (file-status x)))) +(define (file-mode x) (stat-mode (if (stat? x) x (file-status x)))) +(define (file-num-links x) (stat-nlinks (if (stat? x) x (file-status x)))) +(define (file-owner x) (stat-uid (if (stat? x) x (file-status x)))) +(define (file-group x) (stat-gid (if (stat? x) x (file-status x)))) +(define (file-represented-device x) (stat-rdev (if (stat? x) x (file-status x)))) +(define (file-size x) (stat-size (if (stat? x) x (file-status x)))) +(define (file-block-size x) (stat-blksize (if (stat? x) x (file-status x)))) +(define (file-num-blocks x) (stat-blocks (if (stat? x) x (file-status x)))) +(define (file-access-time x) (stat-atime (if (stat? x) x (file-status x)))) +(define (file-modification-time x) (stat-mtime (if (stat? x) x (file-status x)))) +(define (file-change-time x) (stat-ctime (if (stat? x) x (file-status x)))) + +(define (file-regular? x) (S_ISREG (file-mode x))) +(define (file-directory? x) (S_ISDIR (file-mode x))) +(define (file-character? x) (S_ISCHR (file-mode x))) +(define (file-block? x) (S_ISBLK (file-mode x))) +(define (file-fifo? x) (S_ISFIFO (file-mode x))) +(define (file-link? x) (S_ISLNK (file-mode x))) +(define (file-socket? x) (S_ISSOCK (file-mode x))) + +(define (file-exists? x) (and (file-status x) #t)) diff --git a/lib/chibi/filesystem.stub b/lib/chibi/filesystem.stub new file mode 100644 index 00000000..2aa66e50 --- /dev/null +++ b/lib/chibi/filesystem.stub @@ -0,0 +1,118 @@ + +(c-system-include "sys/types.h") +(c-system-include "unistd.h") +(c-system-include "dirent.h") +(c-system-include "fcntl.h") + +(define-c-type DIR + finalizer: closedir) + +(define-c-struct dirent + (string d_name dirent-name)) + +(define-c-struct stat + predicate: stat? + (dev_t st_dev stat-dev) + (ino_t st_ino stat-ino) + (mode_t st_mode stat-mode) + (nlink_t st_nlink stat-nlinks) + (uid_t st_uid stat-uid) + (gid_t st_gid stat-gid) + (dev_t st_rdev stat-rdev) + (off_t st_size stat-size) + (blksize_t st_blksize stat-blksize) + (blkcnt_t st_blocks stat-blocks) + (time_t st_atime stat-atime) + (time_t st_mtime stat-mtime) + (time_t st_ctime stat-ctime)) + +(define-c boolean S_ISREG (mode_t)) +(define-c boolean S_ISDIR (mode_t)) +(define-c boolean S_ISCHR (mode_t)) +(define-c boolean S_ISBLK (mode_t)) +(define-c boolean S_ISFIFO (mode_t)) +(define-c boolean S_ISLNK (mode_t)) +(define-c boolean S_ISSOCK (mode_t)) + +;;(define-c-const int ("S_IFMT")) +(define-c-const int (file/socket "S_IFSOCK")) +(define-c-const int (file/link "S_IFLNK")) +(define-c-const int (file/regular "S_IFREG")) +(define-c-const int (file/block "S_IFBLK")) +(define-c-const int (file/directory "S_IFDIR")) +(define-c-const int (file/character "S_IFCHR")) +(define-c-const int (file/fifo "S_IFIFO")) +(define-c-const int (file/suid "S_ISUID")) +(define-c-const int (file/sgid "S_ISGID")) +(define-c-const int (file/sticky "S_ISVTX")) +;;(define-c-const int ("S_IRWXU")) +(define-c-const int (perm/user-read "S_IRUSR")) +(define-c-const int (perm/user-write "S_IWUSR")) +(define-c-const int (perm/user-execute "S_IXUSR")) +;;(define-c-const int ("S_IRWXG")) +(define-c-const int (perm/group-read "S_IRGRP")) +(define-c-const int (perm/group-write "S_IWGRP")) +(define-c-const int (perm/group-execute "S_IXGRP")) +;;(define-c-const int ("S_IRWXO")) +(define-c-const int (perm/others-read "S_IROTH")) +(define-c-const int (perm/others-write "S_IWOTH")) +(define-c-const int (perm/others-execute "S_IXOTH")) + +(define-c errno stat (string (result stat))) +(define-c errno fstat (int (result stat))) +(define-c errno (file-link-status "lstat") (string (result stat))) + +(define-c input-port (open-input-file-descriptor "fdopen") + (int (value "r" string))) +(define-c output-port (open-output-file-descriptor "fdopen") + (int (value "w" string))) + +(define-c errno (delete-file "unlink") (string)) +(define-c errno (link-file "link") (string string)) +(define-c errno (symbolic-link-file "symlink") (string string)) +(define-c errno (rename-file "rename") (string string)) + +(define-c non-null-string (current-directory "getcwd") + ((result (array char (auto-expand arg1))) (value 256 int))) + +(define-c errno (create-directory "mkdir") (string int)) +(define-c errno (delete-directory "rmdir") (string)) + +(define-c (free DIR) opendir (string)) +(define-c dirent readdir ((link (pointer DIR)))) + +(define-c int (duplicate-file-descriptor "dup") (int)) +(define-c errno (duplicate-file-descriptor-to "dup2") (int int)) +(define-c errno (close-file-descriptor "close") (int)) + +(define-c errno (open-pipe "pipe") ((result (array int 2)))) +(define-c errno (make-fifo "mkfifo") (string (default #o644 int))) + +(define-c int (get-file-descriptor-flags "fcntl") + (int (value F_GETFD int))) +(define-c errno (set-file-descriptor-flags! "fcntl") + (int (value F_SETFD int) long)) + +(define-c int (get-file-descriptor-status "fcntl") + (int (value F_GETFL int))) +(define-c errno (set-file-descriptor-status! "fcntl") + (int (value F_SETFL int) long)) + +;; (define-c int (get-file-descriptor-lock "fcntl") +;; (int (value F_GETLK int) flock)) +;; (define-c errno (set-file-descriptor-lock! "fcntl") +;; (int (value F_SETLK int) flock)) +;; (define-c errno (try-set-file-descriptor-lock! "fcntl") +;; (int (value F_SETLKW int) flock)) + +(define-c-const int (open/read "O_RDONLY")) +(define-c-const int (open/write "O_WRONLY")) +(define-c-const int (open/read-write "O_RDWR")) +(define-c-const int (open/create "O_CREAT")) +(define-c-const int (open/exclusive "O_EXCL")) +(define-c-const int (open/truncate "O_TRUNC")) +(define-c-const int (open/append "O_APPEND")) +(define-c-const int (open/non-block "O_NONBLOCK")) + +(define-c boolean (is-a-tty? "isatty") (port-or-fd)) + diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c new file mode 100644 index 00000000..8b977f1a --- /dev/null +++ b/lib/chibi/heap-stats.c @@ -0,0 +1,120 @@ +/* heap-stats.c -- count or dump heap objects */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +#define SEXP_HEAP_VECTOR_DEPTH 1 + +extern sexp sexp_gc (sexp ctx, size_t *sum_freed); +extern sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x); + +static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) { + int i; + if ((!sexp_pointerp(x)) || sexp_symbolp(x) || sexp_stringp(x) + || sexp_flonump(x) || sexp_bignump(x)) { + sexp_write(ctx, x, out); + } else if (depth <= 0) { + goto print_name; + } else if (sexp_synclop(x)) { + sexp_write_string(ctx, "#", 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; i0) + sexp_write_char(ctx, ' ', out); + sexp_print_simple(ctx, sexp_vector_ref(x, i), out, depth-1); + } + if (i", out); + } +} + +static sexp sexp_heap_walk (sexp ctx, int depth, int printp) { + size_t freed; + sexp_uint_t stats[256], hi_type=0, i; + sexp_heap h = sexp_context_heap(ctx); + sexp p, out=SEXP_FALSE; + sexp_free_list q, r; + char *end; + sexp_gc_var3(res, tmp, name); + + if (printp) + out = sexp_env_global_ref(sexp_context_env(ctx), + sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), + SEXP_FALSE); + + /* run gc once to remove unused variables */ + sexp_gc(ctx, &freed); + + /* initialize stats */ + for (i=0; i<256; i++) stats[i]=0; + + /* loop over each heap chunk */ + for ( ; h; h=h->next) { + p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair))); + q = h->free_list; + end = (char*)h->data + h->size; + while (((char*)p) < end) { + /* find the preceding and succeeding free list pointers */ + for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next) + ; + if ((char*)r == (char*)p) { /* this is a free block, skip */ + p = (sexp) (((char*)p) + r->size); + continue; + } + /* otherwise maybe print, then increment the stat and continue */ + if (sexp_oportp(out)) { + sexp_print_simple(ctx, p, out, depth); + sexp_write_char(ctx, '\n', out); + } + stats[sexp_pointer_tag(p)]++; + if (sexp_pointer_tag(p) > hi_type) + hi_type = sexp_pointer_tag(p); + p = (sexp) (((char*)p) + sexp_heap_align(sexp_allocated_bytes(ctx, p))); + } + } + + /* build and return results */ + sexp_gc_preserve3(ctx, res, tmp, name); + res = SEXP_NULL; + for (i=hi_type; i>0; i--) + if (stats[i]) { + name = sexp_intern(ctx, sexp_type_name_by_index(ctx, i), -1); + tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i])); + res = sexp_cons(ctx, tmp, res); + } + sexp_gc_release3(ctx); + return res; +} + +static sexp sexp_heap_stats (sexp ctx sexp_api_params(self, n)) { + return sexp_heap_walk(ctx, 0, 0); +} + +static sexp sexp_heap_dump (sexp ctx sexp_api_params(self, n), sexp depth) { + if (! sexp_fixnump(depth) || (sexp_unbox_fixnum(depth) < 0)) + return sexp_xtype_exception(ctx, self, "bad heap-dump depth", depth); + return sexp_heap_walk(ctx, sexp_unbox_fixnum(depth), 1); +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign(ctx, env, "heap-stats", 0, sexp_heap_stats); + sexp_define_foreign_opt(ctx, env, "heap-dump", 1, sexp_heap_dump, SEXP_ONE); + return SEXP_VOID; +} + diff --git a/lib/chibi/heap-stats.module b/lib/chibi/heap-stats.module new file mode 100644 index 00000000..c1599c35 --- /dev/null +++ b/lib/chibi/heap-stats.module @@ -0,0 +1,6 @@ + +(define-module (chibi heap-stats) + (export heap-stats heap-dump) + (import-immutable (scheme)) + (include-shared "heap-stats")) + diff --git a/lib/chibi/io.module b/lib/chibi/io.module new file mode 100644 index 00000000..ec765c04 --- /dev/null +++ b/lib/chibi/io.module @@ -0,0 +1,13 @@ + +(define-module (chibi io) + (export read-string read-string! write-string read-line write-line + port-fold port-fold-right port-map + port->list port->string-list port->sexp-list port->string + file-position set-file-position! seek/set seek/cur seek/end + make-custom-input-port make-custom-output-port + make-null-output-port make-broadcast-port make-concatenated-port + make-generated-input-port make-filtered-output-port + make-filtered-input-port) + (import-immutable (scheme)) + (include-shared "io/io") + (include "io/io.scm")) diff --git a/lib/chibi/io/io.scm b/lib/chibi/io/io.scm new file mode 100644 index 00000000..2d4da555 --- /dev/null +++ b/lib/chibi/io/io.scm @@ -0,0 +1,170 @@ +;; io.scm -- various input/output utilities +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define eof + (call-with-input-string " " + (lambda (in) (read-char in) (read-char in)))) + +(define (string-copy! dst start src from to) + (do ((i from (+ i 1)) (j start (+ j 1))) + ((>= i to)) + (string-set! dst j (string-ref src i)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; reading and writing + +(define (write-line str . o) + (let ((out (if (pair? o) (car o) (current-output-port)))) + (display str out) + (newline out))) + +(define (read-line . o) + (let ((in (if (pair? o) (car o) (current-input-port))) + (n (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) 8192))) + (let ((res (%read-line n in))) + (if (not res) + eof + (let ((len (string-length res))) + (if (and (> len 0) (eqv? #\newline (string-ref res (- len 1)))) + (if (and (> len 1) (eqv? #\return (string-ref res (- len 2)))) + (substring res 0 (- len 2)) + (substring res 0 (- len 1))) + res)))))) + +(define (read-string n . o) + (let ((in (if (pair? o) (car o) (current-input-port)))) + (let ((res (%read-string n in))) + (if (if (pair? res) (= 0 (car res)) #t) + eof + (cadr res))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; higher order port operations + +(define (port-fold kons knil . o) + (let ((read (if (pair? o) (car o) read)) + (in (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + (current-input-port)))) + (let lp ((acc knil)) + (let ((x (read in))) + (if (eof-object? x) acc (lp (kons x acc))))))) + +(define (port-fold-right kons knil . o) + (let ((read (if (pair? o) (car o) read)) + (in (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + (current-input-port)))) + (let lp () + (let ((x (read in))) + (if (eof-object? x) knil (kons x (lp))))))) + +(define (port-map fn . o) + (reverse (apply port-fold (lambda (x ls) (cons (fn x) ls)) '() o))) + +(define (port->list read in) + (port-map (lambda (x) x) read in)) + +(define (port->sexp-list in) + (port->list read in)) + +(define (port->string-list in) + (port->list read-line in)) + +(define (port->string in) + (string-concatenate (port->list (lambda (in) (read-string 1024 in)) in))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; custom port utilities + +(define (make-custom-input-port read . o) + (let ((seek (and (pair? o) (car o))) + (close (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (%make-custom-input-port read seek close))) + +(define (make-custom-output-port write . o) + (let ((seek (and (pair? o) (car o))) + (close (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (%make-custom-output-port write seek close))) + +(define (make-null-output-port) + (make-custom-output-port (lambda (str n) 0))) + +(define (make-broadcast-port . ports) + (make-custom-output-port + (lambda (str n) + (for-each (lambda (p) (write-string str n p)) ports) + n))) + +(define (make-filtered-output-port filter out) + (make-custom-output-port + (lambda (str n) + (let* ((len (string-length str)) + (s1 (if (= n len) str (substring str 0 n))) + (s2 (filter s1))) + (if (string? s2) + (write-string s2 (string-length s2) out)))))) + +(define (make-concatenated-port . ports) + (make-custom-input-port + (lambda (str n) + (if (null? ports) + 0 + (let lp ((i (read-string! str n (car ports)))) + (cond + ((>= i n) + i) + (else + (set! ports (cdr ports)) + (cond + ((null? ports) + i) + (else + (let* ((s (read-string (- n i) (car ports))) + (len (if (string? s) (string-length s) 0))) + (if (and (string? str) (> len 0)) + (string-copy! str i s 0 len)) + (lp (+ i len)))))))))))) + +(define (make-generated-input-port generator) + (let ((buf "") + (len 0) + (offset 0)) + (make-custom-input-port + (lambda (str n) + (cond + ((>= (- len offset) n) + (string-copy! str 0 buf offset (+ offset n)) + (set! offset (+ offset n)) + n) + (else + (string-copy! str 0 buf offset len) + (let lp ((i (- len offset))) + (set! buf (generator)) + (cond + ((not (string? buf)) + (set! buf "") + (set! len 0) + (set! offset 0) + (- n i)) + (else + (set! len (string-length buf)) + (set! offset 0) + (cond + ((>= (- len offset) (- n i)) + (string-copy! str i buf offset (+ offset (- n i))) + (set! offset (+ offset (- n i))) + n) + (else + (string-copy! str i buf offset len) + (lp (+ i (- len offset)))))))))))))) + +(define (make-filtered-input-port filter in) + (make-generated-input-port + (lambda () + (let ((res (read-string 1024 in))) + (if (string? res) (filter res) res))))) diff --git a/lib/chibi/io/io.stub b/lib/chibi/io/io.stub new file mode 100644 index 00000000..07450dc0 --- /dev/null +++ b/lib/chibi/io/io.stub @@ -0,0 +1,27 @@ + +(define-c non-null-string (%read-line "fgets") + ((result (array char arg1)) int (default (current-input-port) input-port))) + +(define-c size_t (%read-string "fread") + ((result (array char arg2)) (value 1 size_t) size_t (default (current-input-port) input-port))) + +(define-c size_t (read-string! "fread") + (string (value 1 size_t) size_t (default (current-input-port) input-port))) + +(define-c size_t (write-string "fwrite") + (string (value 1 size_t) size_t (default (current-output-port) output-port))) + +(define-c-const int (seek/set "SEEK_SET")) +(define-c-const int (seek/cur "SEEK_CUR")) +(define-c-const int (seek/end "SEEK_END")) + +(define-c long (file-position "ftell") (port)) +(define-c long (set-file-position! "fseek") (port long int)) + +(c-include "port.c") + +(define-c sexp (%make-custom-input-port "sexp_make_custom_input_port") + ((value ctx sexp) (value self sexp) sexp sexp sexp)) + +(define-c sexp (%make-custom-output-port "sexp_make_custom_output_port") + ((value ctx sexp) (value self sexp) sexp sexp sexp)) diff --git a/lib/chibi/io/port.c b/lib/chibi/io/port.c new file mode 100644 index 00000000..6aa6403a --- /dev/null +++ b/lib/chibi/io/port.c @@ -0,0 +1,201 @@ + +#include +#include + +#define SEXP_PORT_BUFFER_SIZE 1024 +#define SEXP_LAST_CONTEXT_CHECK_LIMIT 256 + +#define sexp_cookie_ctx(vec) sexp_vector_ref((sexp)vec, SEXP_ZERO) +#define sexp_cookie_buffer(vec) sexp_vector_ref((sexp)vec, SEXP_ONE) +#define sexp_cookie_read(vec) sexp_vector_ref((sexp)vec, SEXP_TWO) +#define sexp_cookie_write(vec) sexp_vector_ref((sexp)vec, SEXP_THREE) +#define sexp_cookie_seek(vec) sexp_vector_ref((sexp)vec, SEXP_FOUR) +#define sexp_cookie_close(vec) sexp_vector_ref((sexp)vec, SEXP_FIVE) + +#if ! SEXP_USE_BOEHM +static int sexp_in_heap_p (sexp_heap h, sexp p) { + for ( ; h; h = h->next) + if (((sexp)h < p) && (p < (sexp)((char*)h + h->size))) + return 1; + return 0; +} +#endif + +static sexp sexp_last_context (sexp ctx, sexp *cstack) { + sexp res=SEXP_FALSE, p; +#if ! SEXP_USE_BOEHM + sexp_sint_t i; + sexp_heap h = sexp_context_heap(ctx); + for (i=0; i sexp_string_length(sexp_cookie_buffer(vec))) + sexp_cookie_buffer(vec) = sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID); + args = sexp_list2(ctx, sexp_cookie_buffer(vec), sexp_make_fixnum(size)); + res = sexp_apply(ctx, sexp_cookie_read(vec), args); + sexp_gc_release2(ctx); + if (sexp_fixnump(res)) { + memcpy(buffer, sexp_string_data(sexp_cookie_buffer(vec)), sexp_unbox_fixnum(res)); + return sexp_unbox_fixnum(res); + } else { + return -1; + } +} + +#if SEXP_BSD +static int sexp_cookie_writer (void *cookie, const char *buffer, int size) +#else +static ssize_t sexp_cookie_writer (void *cookie, const char *buffer, size_t size) +#endif +{ + sexp vec = (sexp)cookie, ctx, res; + if (! sexp_procedurep(sexp_cookie_write(vec))) return -1; + sexp_gc_var2(ctx2, args); + ctx = sexp_cookie_ctx(vec); + ctx2 = sexp_last_context(ctx, (sexp*)&cookie); + sexp_gc_preserve2(ctx, ctx2, args); + if (size > sexp_string_length(sexp_cookie_buffer(vec))) + sexp_cookie_buffer(vec) = sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID); + memcpy(sexp_string_data(sexp_cookie_buffer(vec)), buffer, size); + args = sexp_list2(ctx, sexp_cookie_buffer(vec), sexp_make_fixnum(size)); + res = sexp_apply(ctx, sexp_cookie_write(vec), args); + sexp_gc_release2(ctx); + return (sexp_fixnump(res) ? sexp_unbox_fixnum(res) : -1); +} + +#if ! SEXP_BSD + +#ifdef __CYGWIN__ +#define off64_t off_t +#endif + +static int sexp_cookie_seeker (void *cookie, off64_t *position, int whence) { + sexp vec = (sexp)cookie, ctx, res; + if (! sexp_procedurep(sexp_cookie_seek(vec))) return -1; + sexp_gc_var2(ctx2, args); + ctx = sexp_cookie_ctx(vec); + ctx2 = sexp_last_context(ctx, (sexp*)&cookie); + sexp_gc_preserve2(ctx, ctx2, args); + args = sexp_make_integer(ctx, *position); + args = sexp_list2(ctx, args, sexp_make_fixnum(whence)); + res = sexp_apply(ctx, sexp_cookie_seek(vec), args); + if (sexp_fixnump(res)) + *position = sexp_unbox_fixnum(res); + sexp_gc_release2(ctx); + return sexp_fixnump(res); +} +#endif + +static int sexp_cookie_cleaner (void *cookie) { + sexp vec = (sexp)cookie, ctx, res; + if (! sexp_procedurep(sexp_cookie_close(vec))) return 0; + ctx = sexp_cookie_ctx(vec); + res = sexp_apply(ctx, sexp_cookie_close(vec), SEXP_NULL); + return (sexp_exceptionp(res) ? -1 : sexp_truep(res)); +} + +#if ! SEXP_BSD + +static cookie_io_functions_t sexp_cookie = { + .read = (cookie_read_function_t*)sexp_cookie_reader, + .write = (cookie_write_function_t*)sexp_cookie_writer, + .seek = (cookie_seek_function_t*)sexp_cookie_seeker, + .close = (cookie_close_function_t*)sexp_cookie_cleaner, +}; + +static cookie_io_functions_t sexp_cookie_no_seek = { + .read = (cookie_read_function_t*)sexp_cookie_reader, + .write = (cookie_write_function_t*)sexp_cookie_writer, + .seek = NULL, + .close = (cookie_close_function_t*)sexp_cookie_cleaner, +}; + +#endif + +#if SEXP_USE_STRING_STREAMS + +static sexp sexp_make_custom_port (sexp ctx, sexp self, char *mode, + sexp read, sexp write, + sexp seek, sexp close) { + FILE *in; + sexp res; + sexp_gc_var1(vec); + if (sexp_truep(read) && ! sexp_procedurep(read)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, read); + if (sexp_truep(write) && ! sexp_procedurep(write)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, write); + if (sexp_truep(seek) && ! sexp_procedurep(seek)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, seek); + if (sexp_truep(close) && ! sexp_procedurep(close)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, close); + sexp_gc_preserve1(ctx, vec); + vec = sexp_make_vector(ctx, SEXP_SIX, SEXP_VOID); + sexp_cookie_ctx(vec) = ctx; + sexp_cookie_buffer(vec) + = sexp_make_string(ctx, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE), SEXP_VOID); + sexp_cookie_read(vec) = read; + sexp_cookie_write(vec) = write; + sexp_cookie_seek(vec) = seek; + sexp_cookie_close(vec) = close; +#if SEXP_BSD + in = funopen(vec, + (sexp_procedurep(read) ? sexp_cookie_reader : NULL), + (sexp_procedurep(write) ? sexp_cookie_writer : NULL), + NULL, /* (sexp_procedurep(seek) ? sexp_cookie_reader : NULL), */ + (sexp_procedurep(close) ? sexp_cookie_cleaner : NULL)); +#else + in = fopencookie(vec, mode, (sexp_truep(seek) ? sexp_cookie : sexp_cookie_no_seek)); +#endif + if (! in) { + res = sexp_user_exception(ctx, self, "couldn't make custom port", read); + } else { + res = sexp_make_input_port(ctx, in, SEXP_FALSE); + sexp_port_cookie(res) = vec; /* for gc preserving */ + } + sexp_gc_release1(ctx); + return res; +} + +#else + +static sexp sexp_make_custom_port (sexp ctx, sexp self, + char *mode, sexp read, sexp write, + sexp seek, sexp close) { + return sexp_user_exception(ctx, self, "custom ports not supported in this configuration", SEXP_NULL); +} + +#endif + +static sexp sexp_make_custom_input_port (sexp ctx, sexp self, + sexp read, sexp seek, sexp close) { + return sexp_make_custom_port(ctx, self, "r", read, SEXP_FALSE, seek, close); +} + +static sexp sexp_make_custom_output_port (sexp ctx, sexp self, + sexp write, sexp seek, sexp close) { + sexp res = sexp_make_custom_port(ctx, self, "w", SEXP_FALSE, write, seek, close); + sexp_pointer_tag(res) = SEXP_OPORT; + return res; +} diff --git a/lib/chibi/loop.module b/lib/chibi/loop.module new file mode 100644 index 00000000..5b76daf8 --- /dev/null +++ b/lib/chibi/loop.module @@ -0,0 +1,9 @@ + +(define-module (chibi loop) + (export loop in-list in-lists in-port in-file up-from down-from + listing listing-reverse appending appending-reverse + summing multiplying in-string in-string-reverse + in-vector in-vector-reverse) + (import-immutable (scheme)) + (include "loop/loop.scm")) + diff --git a/lib/chibi/loop/loop.scm b/lib/chibi/loop/loop.scm new file mode 100644 index 00000000..09e12856 --- /dev/null +++ b/lib/chibi/loop/loop.scm @@ -0,0 +1,365 @@ +;;;; loop.scm - the chibi loop (aka foof-loop) +;; +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; The loop API is compatible with Taylor Campbell's foof-loop, but +;; the iterator API is different and subject to change. All loop +;; variables may be implicitly destructured with MATCH semantics. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (assoc-pred equal elt ls) + (and (pair? ls) + (if (equal elt (car (car ls))) + (car ls) + (assoc-pred equal elt (cdr ls))))) + +(define-syntax let-keyword-form + (syntax-rules () + ((let-keyword-form + ((labeled-arg-macro-name (positional-name . params))) + . body) + (let-syntax + ((labeled-arg-macro-name + (er-macro-transformer + (lambda (expr rename compare) + (let lp ((ls (cdr expr)) (named '()) (posns '())) + (cond + ((pair? ls) + (if (and (list? (car ls)) (compare (caar ls) (rename '=>))) + (lp (cdr ls) (cons (cdar ls) named) posns) + (lp (cdr ls) named (cons (car ls) posns)))) + (else + (let lp ((ls (syntax-quote params)) + (posns (reverse posns)) + (args '())) + (cond + ((null? ls) + (if (pair? posns) + (error "let-keyword-form: too many args" expr) + (cons (syntax-quote positional-name) (reverse args)))) + ((assoc-pred compare (caar ls) named) + => (lambda (x) (lp (cdr ls) posns (cons (cadr x) args)))) + ((pair? posns) + (lp (cdr ls) (cdr posns) (cons (car posns) args))) + (else + (lp (cdr ls) posns (cons (cadar ls) args)))))))))))) + . body)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax loop + (syntax-rules () + ;; unnamed, implicit recursion + ((loop (vars ...) body ...) + (%loop tmp-loop () () () () () (vars ...) body ... (tmp-loop))) + ;; named, explicit recursion + ((loop name (vars ...) body ...) + (%loop name () () () () () (vars ...) body ...)))) + +;; Main LOOP macro. Separate the variables from the iterator and +;; parameters, then walk through each parameter expanding the +;; bindings, and build the final form. + +(define-syntax %loop + (syntax-rules (=> for with let while until) + ;; automatic iteration + ((_ name l v c r f ((for var1 (iterator source ...)) rest ...) . body) + (iterator ((var1) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 var3 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2 var3) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 var3 var4 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2 var3 var4) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ;; do equivalents, with optional guards + ((_ name l (vars ...) (checks ...) r f ((with var init step guard) rest ...) . body) + (%loop name l (vars ... (var init step)) (checks ... (guard var)) r f (rest ...) . body)) + ((_ name l (vars ...) c r f ((with var init step) rest ...) . body) + (%loop name l (vars ... (var init step)) c r f (rest ...) . body)) + ((_ name l (vars ...) c r f ((with var init) rest ...) . body) + (%loop name l (vars ... (var init var)) c r f (rest ...) . body)) + ;; user-specified terminators + ((_ name l vars (checks ...) r f ((until expr) rest ...) . body) + (%loop name l vars (checks ... expr) r f (rest ...) . body)) + ((_ name l vars (checks ...) r f ((while expr) rest ...) . body) + (%loop name l vars (checks ... (not expr)) r f (rest ...) . body)) + ;; specify a default done? + ((_ name l v c r f ()) + (%loop name l v c r f () (#f #f))) + ((_ name l v c r f () () . body) + (%loop name l v c r f () (#f #f) . body)) + ;; final expansion + ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + => result + . body) + (let* (lets ...) + (letrec ((tmp (lambda (var ...) + (if (or checks ...) + (let-keyword-form ((name (tmp (var step) ...))) + (let (finals ...) result)) + (let (refs ...) + (let-keyword-form ((name (tmp (var step) ...))) + (if #f #f) + . body)))))) + (tmp init ...)))) + ;; unspecified return value case + ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + . body) + (%loop name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + => (if #f #f) . body)) + )) + +(define-syntax %loop-next + (syntax-rules () + ((_ (new-lets ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...) + name (lets ...) (vars ...) (checks ...) (refs ...) (finals ...) + . rest) + (%loop name (lets ... new-lets ...) (vars ... new-vars ...) + (checks ... new-checks ...) (refs ... new-refs ...) + (finals ... new-finals ...) + . rest)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Iterators + +;; Each gets passed two lists, those items left of the <- and those to +;; the right, followed by a NEXT and REST continuation. + +;; Should finish with +;; +;; (next (outer-vars ...) (cursor-vars ...) (done?-tests ...) +;; (loop-vars ...) (final-vars ...) . rest) +;; +;; OUTER-VARS: bound once outside the loop in a LET* +;; CURSOR-VARS: DO-style bindings of the form (name init update) +;; DONE?-TESTS: possibly empty list of forms that terminate the loop on #t +;; LOOP-VARS: inner variables, updated in parallel after the cursors +;; FINAL-VARS: final variables, bound only in the => result + +(define-syntax in-list ; called just "IN" in ITER + (syntax-rules () + ((in-list ((var) source) next . rest) + (in-list ((var cursor) source) next . rest)) + ((in-list ((var cursor) source) next . rest) + (in-list ((var cursor succ) source) next . rest)) + ((in-list ((var cursor succ) (source)) next . rest) + (next () ; outer let bindings + ((cursor source succ)) ; iterator, init, step + ((not (pair? cursor))) ; finish tests for iterator vars + ;; step variables and values + ((var (car cursor)) + (succ (cdr cursor))) + () ; final result bindings + . rest)) + ((in-list ((var cursor succ) (source step)) next . rest) + (next () + ((cursor source succ)) + ((not (pair? cursor))) + ((var (car cursor)) + (succ (step cursor))) + () + . rest)))) + +;; Iterator from Taylor R. Campbell. If you know the number of lists +;; ahead of time it's much more efficient to iterate over each one +;; separately. +(define-syntax in-lists + (syntax-rules () + ((in-lists ((elts) lol) next . rest) + (in-lists ((elts pairs) lol) next . rest)) + ((in-lists ((elts pairs) lol) next . rest) + (in-lists ((elts pairs succ) lol) next . rest)) + ((in-lists ((elts pairs succ) (lol)) next . rest) + (in-lists ((elts pairs succ) (lol cdr)) next . rest)) + ((in-lists ((elts pairs succ) (lol)) next . rest) + (in-lists ((elts pairs succ) (lol cdr)) next . rest)) + ((in-lists ((elts pairs succ) (lol step)) next . rest) + (in-lists ((elts pairs succ) (lol step null?)) next . rest)) + ((in-lists ((elts pairs succ) (lol step done?)) next . rest) + (next () + ((pairs lol succ)) + ((let lp ((ls pairs)) ; an in-lined ANY + (and (pair? ls) (if (done? (car ls)) #t (lp (cdr ls)))))) + ((elts (map car pairs)) + (succ (map step pairs))) + () + . rest)) + )) + +(define-syntax define-in-indexed + (syntax-rules () + ((define-in-indexed in-type in-type-reverse length ref) + (begin + (define-syntax in-type + (syntax-rules () + ((in-type ls next . rest) + (%in-idx >= + 0 (length tmp) ref tmp ls next . rest)))) + (define-syntax in-type-reverse + (syntax-rules () + ((in-type-reverse ls next . rest) + (%in-idx < - (- (length tmp) 1) 0 ref tmp ls next . rest)))) + )))) + +(define-in-indexed in-string in-string-reverse string-length string-ref) +(define-in-indexed in-vector in-vector-reverse vector-length vector-ref) + +;; helper for the above string and vector iterators +(define-syntax %in-idx + (syntax-rules () + ;; cmp inc start end ref + ((%in-idx ge + s e r tmp-vec ((var) (vec ...)) next . rest) + (%in-idx ge + s e r tmp-vec ((var vec-index) (vec ...)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec s e 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec from e 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from to)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec from to 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from to step)) next . rest) + (next ((tmp-vec vec) (end to)) + ((index from (+ index step))) + ((ge index end)) + ((var (r tmp-vec index))) + () + . rest)) + )) + +(define-syntax in-port + (syntax-rules () + ((in-port ((var) source) next . rest) + (in-port ((var p) source) next . rest)) + ((in-port ((var p) ()) next . rest) + (in-port ((var p) ((current-input-port))) next . rest)) + ((in-port ((var p) (port)) next . rest) + (in-port ((var p) (port read-char)) next . rest)) + ((in-port ((var p) (port read-char)) next . rest) + (in-port ((var p) (port read-char eof-object?)) next . rest)) + ((in-port ((var p) (port reader eof?)) next . rest) + (next ((p port) (r reader) (e? eof?)) + ((var (r p) (r p))) + ((e? var)) + () + () + . rest)))) + +(define-syntax in-file + (syntax-rules () + ((in-file ((var) source) next . rest) + (in-file ((var p) source) next . rest)) + ((in-file ((var p) (file)) next . rest) + (in-file ((var p) (file read-char)) next . rest)) + ((in-file ((var p) (file reader)) next . rest) + (in-file ((var p) (file reader eof-object?)) next . rest)) + ((in-file ((var p) (file reader eof?)) next . rest) + (next ((p (open-input-file file)) (r reader) (e? eof?)) + ((var (r p) (r p))) + ((e? var)) + () + ((dummy (close-input-port p))) + . rest)))) + +(define-syntax up-from + (syntax-rules (to by) + ((up-from (() . args) next . rest) + (up-from ((var) . args) next . rest)) + ((up-from ((var) (start (to limit) (by step))) next . rest) + (next ((s start) (l limit) (e step)) + ((var s (+ var e))) + ((>= var l)) + () + () + . rest)) + ((up-from ((var) (start (to limit))) next . rest) + (next ((s start) (l limit)) + ((var s (+ var 1))) + ((>= var l)) + () + () + . rest)) + ((up-from ((var) (start (by step))) next . rest) + (next ((s start) (e step)) ((var s (+ var e))) () () () . rest)) + ((up-from ((var) (start)) next . rest) + (next ((s start)) ((var s (+ var 1))) () () () . rest)) + )) + +(define-syntax down-from + (syntax-rules (to by) + ((down-from (() . args) next . rest) + (down-from ((var) . args) next . rest)) + ((down-from ((var) (start (to limit) (by step))) next . rest) + (next ((s start) (l limit) (e step)) + ((var (- s e) (- var e))) + ((< var l)) + () + () + . rest)) + ((down-from ((var) (start (to limit))) next . rest) + (next ((s start) (l limit)) + ((var (- s 1) (- var 1))) + ((< var l)) + () + () + . rest)) + ((down-from ((var) (start (by step))) next . rest) + (next ((s start) (e step)) ((var (- s e) (- var e))) () () () + . rest)) + ((down-from ((var) (start)) next . rest) + (next ((s start)) ((var (- s 1) (- var 1))) () () () + . rest)) + )) + +(define-syntax accumulating + (syntax-rules (initial if) + ((accumulating (kons final init) ((var) . x) next . rest) + (accumulating (kons final init) ((var cursor) . x) next . rest)) + ((accumulating (kons final init) ((var cursor) ((initial i) . x)) n . rest) + (accumulating (kons final i) ((var cursor) x) n . rest)) + ((accumulating (kons final init) ((var cursor) (expr (if check))) n . rest) + (n ((tmp-kons kons)) + ((cursor '() (if check (tmp-kons expr cursor) cursor))) + () + () + ((var (final cursor))) + . rest)) + ((accumulating (kons final init) ((var cursor) (expr)) n . rest) + (n ((tmp-kons kons)) + ((cursor '() (tmp-kons expr cursor))) + () + () + ((var (final cursor))) + . rest)))) + +(define-syntax listing + (syntax-rules () + ((listing args next . rest) + (accumulating (cons reverse '()) args next . rest)))) + +(define-syntax listing-reverse + (syntax-rules () + ((listing-reverse args next . rest) + (accumulating (cons (lambda (x) x) '()) args next . rest)))) + +(define (append-reverse rev tail) + (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail)))) + +(define-syntax appending + (syntax-rules () + ((appending args next . rest) + (accumulating (append-reverse reverse '()) args next . rest)))) + +(define-syntax appending-reverse + (syntax-rules () + ((appending-reverse args next . rest) + (accumulating (append-reverse (lambda (x) x) '()) args next . rest)))) + +(define-syntax summing + (syntax-rules () + ((summing args next . rest) + (accumulating (+ (lambda (x) x) 0) args next . rest)))) + +(define-syntax multiplying + (syntax-rules () + ((multiplying args next . rest) + (accumulating (* (lambda (x) x) 1) args next . rest)))) diff --git a/lib/chibi/match.module b/lib/chibi/match.module new file mode 100644 index 00000000..1366176a --- /dev/null +++ b/lib/chibi/match.module @@ -0,0 +1,6 @@ + +(define-module (chibi match) + (export match match-lambda match-lambda* match-let match-letrec match-let*) + (import-immutable (scheme)) + (include "match/match.scm")) + diff --git a/lib/chibi/match/match.scm b/lib/chibi/match/match.scm new file mode 100644 index 00000000..f4eb173d --- /dev/null +++ b/lib/chibi/match/match.scm @@ -0,0 +1,683 @@ +;;;; match.scm -- portable hygienic pattern matcher +;; +;; This code is written by Alex Shinn and placed in the +;; Public Domain. All warranties are disclaimed. + +;; This is a full superset of the popular MATCH package by Andrew +;; Wright, written in fully portable SYNTAX-RULES (R5RS only, breaks +;; in R6RS SYNTAX-RULES), and thus preserving hygiene. + +;; This is a simple generative pattern matcher - each pattern is +;; expanded into the required tests, calling a failure continuation if +;; the tests fail. This makes the logic easy to follow and extend, +;; but produces sub-optimal code in cases where you have many similar +;; clauses due to repeating the same tests. Nonetheless a smart +;; compiler should be able to remove the redundant tests. For +;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance +;; hit. + +;; The original version was written on 2006/11/29 and described in the +;; following Usenet post: +;; http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd +;; and is still available at +;; http://synthcode.com/scheme/match-simple.scm +;; It's just 80 lines for the core MATCH, and an extra 40 lines for +;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar. +;; +;; A variant of this file which uses COND-EXPAND in a few places for +;; performance can be found at +;; http://synthcode.com/scheme/match-cond-expand.scm +;; +;; 2009/11/25 - adding `***' tree search patterns +;; 2008/03/20 - fixing bug where (a ...) matched non-lists +;; 2008/03/15 - removing redundant check in vector patterns +;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell) +;; 2007/09/04 - fixing quasiquote patterns +;; 2007/07/21 - allowing ellipse patterns in non-final list positions +;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse +;; (thanks to Taylor Campbell) +;; 2007/04/08 - clean up, commenting +;; 2006/12/24 - bugfixes +;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set! + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; force compile-time syntax errors with useful messages + +(define-syntax match-syntax-error + (syntax-rules () + ((_) (match-syntax-error "invalid match-syntax-error usage")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; The basic interface. MATCH just performs some basic syntax +;; validation, binds the match expression to a temporary variable `v', +;; and passes it on to MATCH-NEXT. It's a constant throughout the +;; code below that the binding `v' is a direct variable reference, not +;; an expression. + +(define-syntax match + (syntax-rules () + ((match) + (match-syntax-error "missing match expression")) + ((match atom) + (match-syntax-error "no match clauses")) + ((match (app ...) (pat . body) ...) + (let ((v (app ...))) + (match-next v ((app ...) (set! (app ...))) (pat . body) ...))) + ((match #(vec ...) (pat . body) ...) + (let ((v #(vec ...))) + (match-next v (v (set! v)) (pat . body) ...))) + ((match atom (pat . body) ...) + (match-next atom (atom (set! atom)) (pat . body) ...)) + )) + +;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure +;; thunk, which is expanded by recursing MATCH-NEXT on the remaining +;; clauses. `g+s' is a list of two elements, the get! and set! +;; expressions respectively. + +(define-syntax match-next + (syntax-rules (=>) + ;; no more clauses, the match failed + ((match-next v g+s) + (error 'match "no matching pattern")) + ;; named failure continuation + ((match-next v g+s (pat (=> failure) . body) . rest) + (let ((failure (lambda () (match-next v g+s . rest)))) + ;; match-one analyzes the pattern for us + (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ()))) + ;; anonymous failure continuation, give it a dummy name + ((match-next v g+s (pat . body) . rest) + (match-next v g+s (pat (=> failure) . body) . rest)))) + +;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to +;; MATCH-TWO. + +(define-syntax match-one + (syntax-rules () + ;; If it's a list of two or more values, check to see if the + ;; second one is an ellipse and handle accordingly, otherwise go + ;; to MATCH-TWO. + ((match-one v (p q . r) g+s sk fk i) + (match-check-ellipse + q + (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()) + (match-two v (p q . r) g+s sk fk i))) + ;; Go directly to MATCH-TWO. + ((match-one . x) + (match-two . x)))) + +;; This is the guts of the pattern matcher. We are passed a lot of +;; information in the form: +;; +;; (match-two var pattern getter setter success-k fail-k (ids ...)) +;; +;; usually abbreviated +;; +;; (match-two v p g+s sk fk i) +;; +;; where VAR is the symbol name of the current variable we are +;; matching, PATTERN is the current pattern, getter and setter are the +;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding +;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure +;; continuation (which is just a thunk call and is thus safe to expand +;; multiple times) and IDS are the list of identifiers bound in the +;; pattern so far. + +(define-syntax match-two + (syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!) + ((match-two v () g+s (sk ...) fk i) + (if (null? v) (sk ... i) fk)) + ((match-two v (quote p) g+s (sk ...) fk i) + (if (equal? v 'p) (sk ... i) fk)) + ((match-two v (quasiquote p) . x) + (match-quasiquote v p . x)) + ((match-two v (and) g+s (sk ...) fk i) (sk ... i)) + ((match-two v (and p q ...) g+s sk fk i) + (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i)) + ((match-two v (or) g+s sk fk i) fk) + ((match-two v (or p) . x) + (match-one v p . x)) + ((match-two v (or p ...) g+s sk fk i) + (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ())) + ((match-two v (not p) g+s (sk ...) fk i) + (match-one v p g+s (match-drop-ids fk) (sk ... i) i)) + ((match-two v (get! getter) (g s) (sk ...) fk i) + (let ((getter (lambda () g))) (sk ... i))) + ((match-two v (set! setter) (g (s ...)) (sk ...) fk i) + (let ((setter (lambda (x) (s ... x)))) (sk ... i))) + ((match-two v (? pred . p) g+s sk fk i) + (if (pred v) (match-one v (and . p) g+s sk fk i) fk)) + ((match-two v (= proc p) . x) + (let ((w (proc v))) (match-one w p . x))) + ((match-two v (p ___ . r) g+s sk fk i) + (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ())) + ((match-two v (p) g+s sk fk i) + (if (and (pair? v) (null? (cdr v))) + (let ((w (car v))) + (match-one w p ((car v) (set-car! v)) sk fk i)) + fk)) + ((match-two v (p *** q) g+s sk fk i) + (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ())) + ((match-two v (p *** . q) g+s sk fk i) + (match-syntax-error "invalid use of ***" (p *** . q))) + ((match-two v ($ rec p ...) g+s sk fk i) + (if (is-a? v rec) + (match-record-refs v rec 0 (p ...) g+s sk fk i) + fk)) + ((match-two v (p . q) g+s sk fk i) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-one w p ((car v) (set-car! v)) + (match-one x q ((cdr v) (set-cdr! v)) sk fk) + fk + i)) + fk)) + ((match-two v #(p ...) g+s . x) + (match-vector v 0 () (p ...) . x)) + ((match-two v _ g+s (sk ...) fk i) (sk ... i)) + ;; Not a pair or vector or special literal, test to see if it's a + ;; new symbol, in which case we just bind it, or if it's an + ;; already bound symbol or some other literal, in which case we + ;; compare it with EQUAL?. + ((match-two v x g+s (sk ...) fk (id ...)) + (let-syntax + ((new-sym? + (syntax-rules (id ...) + ((new-sym? x sk2 fk2) sk2) + ((new-sym? y sk2 fk2) fk2)))) + (new-sym? random-sym-to-match + (let ((x v)) (sk ... (id ... x))) + (if (equal? v x) (sk ... (id ...)) fk)))) + )) + +;; QUASIQUOTE patterns + +(define-syntax match-quasiquote + (syntax-rules (unquote unquote-splicing quasiquote) + ((_ v (unquote p) g+s sk fk i) + (match-one v p g+s sk fk i)) + ((_ v ((unquote-splicing p) . rest) g+s sk fk i) + (if (pair? v) + (match-one v + (p . tmp) + (match-quasiquote tmp rest g+s sk fk) + fk + i) + fk)) + ((_ v (quasiquote p) g+s sk fk i . depth) + (match-quasiquote v p g+s sk fk i #f . depth)) + ((_ v (unquote p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (unquote-splicing p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (p . q) g+s sk fk i . depth) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-quasiquote + w p g+s + (match-quasiquote-step x q g+s sk fk depth) + fk i . depth)) + fk)) + ((_ v #(elt ...) g+s sk fk i . depth) + (if (vector? v) + (let ((ls (vector->list v))) + (match-quasiquote ls (elt ...) g+s sk fk i . depth)) + fk)) + ((_ v x g+s sk fk i . depth) + (match-one v 'x g+s sk fk i)))) + +(define-syntax match-quasiquote-step + (syntax-rules () + ((match-quasiquote-step x q g+s sk fk depth i) + (match-quasiquote x q g+s sk fk i . depth)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Utilities + +;; Takes two values and just expands into the first. +(define-syntax match-drop-ids + (syntax-rules () + ((_ expr ids ...) expr))) + +(define-syntax match-drop-first-arg + (syntax-rules () + ((_ arg expr) expr))) + +;; To expand an OR group we try each clause in succession, passing the +;; first that succeeds to the success continuation. On failure for +;; any clause, we just try the next clause, finally resorting to the +;; failure continuation fk if all clauses fail. The only trick is +;; that we want to unify the identifiers, so that the success +;; continuation can refer to a variable from any of the OR clauses. + +(define-syntax match-gen-or + (syntax-rules () + ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...)) + (let ((sk2 (lambda (id ...) (sk ... (i ... id ...))))) + (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...)))))) + +(define-syntax match-gen-or-step + (syntax-rules () + ((_ v () g+s sk fk . x) + ;; no OR clauses, call the failure continuation + fk) + ((_ v (p) . x) + ;; last (or only) OR clause, just expand normally + (match-one v p . x)) + ((_ v (p . q) g+s sk fk i) + ;; match one and try the remaining on failure + (match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i)) + )) + +;; We match a pattern (p ...) by matching the pattern p in a loop on +;; each element of the variable, accumulating the bound ids into lists. + +;; Look at the body of the simple case - it's just a named let loop, +;; matching each element in turn to the same pattern. The only trick +;; is that we want to keep track of the lists of each extracted id, so +;; when the loop recurses we cons the ids onto their respective list +;; variables, and on success we bind the ids (what the user input and +;; expects to see in the success body) to the reversed accumulated +;; list IDs. + +(define-syntax match-gen-ellipses + (syntax-rules () + ((_ v p () g+s (sk ...) fk i ((id id-ls) ...)) + (match-check-identifier p + ;; simplest case equivalent to (p ...), just bind the list + (let ((p v)) + (if (list? p) + (sk ... i) + fk)) + ;; simple case, match all elements of the list + (let loop ((ls v) (id-ls '()) ...) + (cond + ((null? ls) + (let ((id (reverse id-ls)) ...) (sk ... i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids (loop (cdr ls) (cons id id-ls) ...)) + fk i))) + (else + fk))))) + ((_ v p r g+s (sk ...) fk i ((id id-ls) ...)) + ;; general case, trailing patterns to match, keep track of the + ;; remaining list length so we don't need any backtracking + (match-verify-no-ellipses + r + (let* ((tail-len (length 'r)) + (ls v) + (len (length ls))) + (if (< len tail-len) + fk + (let loop ((ls ls) (n len) (id-ls '()) ...) + (cond + ((= n tail-len) + (let ((id (reverse id-ls)) ...) + (match-one ls r (#f #f) (sk ... i) fk i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids + (loop (cdr ls) (- n 1) (cons id id-ls) ...)) + fk + i))) + (else + fk))))))))) + +;; This is just a safety check. Although unlike syntax-rules we allow +;; trailing patterns after an ellipses, we explicitly disable multiple +;; ellipses at the same level. This is because in the general case +;; such patterns are exponential in the number of ellipses, and we +;; don't want to make it easy to construct very expensive operations +;; with simple looking patterns. For example, it would be O(n^2) for +;; patterns like (a ... b ...) because we must consider every trailing +;; element for every possible break for the leading "a ...". + +(define-syntax match-verify-no-ellipses + (syntax-rules () + ((_ (x . y) sk) + (match-check-ellipse + x + (match-syntax-error + "multiple ellipse patterns not allowed at same level") + (match-verify-no-ellipses y sk))) + ((_ () sk) + sk) + ((_ x sk) + (match-syntax-error "dotted tail not allowed after ellipse" x)))) + +;; Matching a tree search pattern is only slightly more complicated. +;; Here we allow patterns of the form +;; +;; (x *** y) +;; +;; to represent the pattern y located somewhere in a tree where the +;; path from the current object to y can be seen as a list of the form +;; (X ...). Y can immediately match the current object in which case +;; the path is the empty list. In a sense it's a 2-dimensional +;; version of the ... pattern. +;; +;; As a common case the pattern (_ *** y) can be used to search for Y +;; anywhere in a tree, regardless of the path used. +;; +;; To implement the search, we use two recursive procedures. TRY +;; attempts to match Y once, and on success it calls the normal SK on +;; the accumulated list ids as in MATCH-GEN-ELLIPSES. On failure, we +;; call NEXT which first checks if the current value is a list +;; beginning with X, then calls TRY on each remaining element of the +;; list. Since TRY will recursively call NEXT again on failure, this +;; effects a full depth-first search. +;; +;; The failure continuation throughout is a jump to the next step in +;; the tree search, initialized with the original failure continuation +;; FK. + +(define-syntax match-gen-search + (syntax-rules () + ((match-gen-search v p q g+s sk fk i ((id id-ls) ...)) + (letrec ((try (lambda (w fail id-ls ...) + (match-one w q g+s + (match-drop-ids + (let ((id (reverse id-ls)) ...) + sk)) + (next w fail id-ls ...) i))) + (next (lambda (w fail id-ls ...) + (if (not (pair? w)) + (fail) + (let ((u (car w))) + (match-one + u p ((car w) (set-car! w)) + (match-drop-ids + ;; accumulate the head variables from + ;; the p pattern, and loop over the tail + (let ((id-ls (cons id id-ls)) ...) + (let lp ((ls (cdr w))) + (if (pair? ls) + (try (car ls) + (lambda () (lp (cdr ls))) + id-ls ...) + (fail))))) + (fail) i)))))) + ;; the initial id-ls binding here is a dummy to get the right + ;; number of '()s + (let ((id-ls '()) ...) + (try v (lambda () fk) id-ls ...)))))) + +;; Vector patterns are just more of the same, with the slight +;; exception that we pass around the current vector index being +;; matched. + +(define-syntax match-vector + (syntax-rules (___) + ((_ v n pats (p q) . x) + (match-check-ellipse q + (match-gen-vector-ellipses v n pats p . x) + (match-vector-two v n pats (p q) . x))) + ((_ v n pats (p ___) sk fk i) + (match-gen-vector-ellipses v n pats p sk fk i)) + ((_ . x) + (match-vector-two . x)))) + +;; Check the exact vector length, then check each element in turn. + +(define-syntax match-vector-two + (syntax-rules () + ((_ v n ((pat index) ...) () sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (= len n) + (match-vector-step v ((pat index) ...) sk fk i) + fk)) + fk)) + ((_ v n (pats ...) (p . q) . x) + (match-vector v (+ n 1) (pats ... (p n)) q . x)))) + +(define-syntax match-vector-step + (syntax-rules () + ((_ v () (sk ...) fk i) (sk ... i)) + ((_ v ((pat index) . rest) sk fk i) + (let ((w (vector-ref v index))) + (match-one w pat ((vector-ref v index) (vector-set! v index)) + (match-vector-step v rest sk fk) + fk i))))) + +;; With a vector ellipse pattern we first check to see if the vector +;; length is at least the required length. + +(define-syntax match-gen-vector-ellipses + (syntax-rules () + ((_ v n ((pat index) ...) p sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (>= len n) + (match-vector-step v ((pat index) ...) + (match-vector-tail v p n len sk fk) + fk i) + fk)) + fk)))) + +(define-syntax match-vector-tail + (syntax-rules () + ((_ v p n len sk fk i) + (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ())))) + +(define-syntax match-vector-tail-two + (syntax-rules () + ((_ v p n len (sk ...) fk i ((id id-ls) ...)) + (let loop ((j n) (id-ls '()) ...) + (if (>= j len) + (let ((id (reverse id-ls)) ...) (sk ... i)) + (let ((w (vector-ref v j))) + (match-one w p ((vector-ref v j) (vetor-set! v j)) + (match-drop-ids (loop (+ j 1) (cons id id-ls) ...)) + fk i))))))) + +(define-syntax match-record-refs + (syntax-rules () + ((_ v rec n (p . q) g+s sk fk i) + (let ((w (slot-ref rec v n))) + (match-one w p ((slot-ref rec v n) (slot-set! rec v n)) + (match-record-refs v rec (+ n 1) q g+s sk fk) fk i))) + ((_ v rec n () g+s (sk ...) fk i) + (sk ... i)))) + +;; Extract all identifiers in a pattern. A little more complicated +;; than just looking for symbols, we need to ignore special keywords +;; and non-pattern forms (such as the predicate expression in ? +;; patterns), and also ignore previously bound identifiers. +;; +;; Calls the continuation with all new vars as a list of the form +;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely +;; pair with the original variable (e.g. it's used in the ellipse +;; generation for list variables). +;; +;; (match-extract-vars pattern continuation (ids ...) (new-vars ...)) + +(define-syntax match-extract-vars + (syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!) + ((match-extract-vars (? pred . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars ($ rec . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (= proc p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (quote x) (k ...) i v) + (k ... v)) + ((match-extract-vars (quasiquote x) k i v) + (match-extract-quasiquote-vars x k i v (#t))) + ((match-extract-vars (and . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (or . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (not . p) . x) + (match-extract-vars p . x)) + ;; A non-keyword pair, expand the CAR with a continuation to + ;; expand the CDR. + ((match-extract-vars (p q . r) k i v) + (match-check-ellipse + q + (match-extract-vars (p . r) k i v) + (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ()))) + ((match-extract-vars (p . q) k i v) + (match-extract-vars p (match-extract-vars-step q k i v) i ())) + ((match-extract-vars #(p ...) . x) + (match-extract-vars (p ...) . x)) + ((match-extract-vars _ (k ...) i v) (k ... v)) + ((match-extract-vars ___ (k ...) i v) (k ... v)) + ((match-extract-vars *** (k ...) i v) (k ... v)) + ;; This is the main part, the only place where we might add a new + ;; var if it's an unbound symbol. + ((match-extract-vars p (k ...) (i ...) v) + (let-syntax + ((new-sym? + (syntax-rules (i ...) + ((new-sym? p sk fk) sk) + ((new-sym? x sk fk) fk)))) + (new-sym? random-sym-to-match + (k ... ((p p-ls) . v)) + (k ... v)))) + )) + +;; Stepper used in the above so it can expand the CAR and CDR +;; separately. + +(define-syntax match-extract-vars-step + (syntax-rules () + ((_ p k i v ((v2 v2-ls) ...)) + (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v))) + )) + +(define-syntax match-extract-quasiquote-vars + (syntax-rules (quasiquote unquote unquote-splicing) + ((match-extract-quasiquote-vars (quasiquote x) k i v d) + (match-extract-quasiquote-vars x k i v (#t . d))) + ((match-extract-quasiquote-vars (unquote-splicing x) k i v d) + (match-extract-quasiquote-vars (unquote x) k i v d)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t)) + (match-extract-vars x k i v)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t . d)) + (match-extract-quasiquote-vars x k i v d)) + ((match-extract-quasiquote-vars (x . y) k i v (#t . d)) + (match-extract-quasiquote-vars + x + (match-extract-quasiquote-vars-step y k i v d) i ())) + ((match-extract-quasiquote-vars #(x ...) k i v (#t . d)) + (match-extract-quasiquote-vars (x ...) k i v d)) + ((match-extract-quasiquote-vars x (k ...) i v (#t . d)) + (k ... v)) + )) + +(define-syntax match-extract-quasiquote-vars-step + (syntax-rules () + ((_ x k i v d ((v2 v2-ls) ...)) + (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d)) + )) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Gimme some sugar baby. + +(define-syntax match-lambda + (syntax-rules () + ((_ clause ...) (lambda (expr) (match expr clause ...))))) + +(define-syntax match-lambda* + (syntax-rules () + ((_ clause ...) (lambda expr (match expr clause ...))))) + +(define-syntax match-let + (syntax-rules () + ((_ (vars ...) . body) + (match-let/helper let () () (vars ...) . body)) + ((_ loop . rest) + (match-named-let loop () . rest)))) + +(define-syntax match-letrec + (syntax-rules () + ((_ vars . body) (match-let/helper letrec () () vars . body)))) + +(define-syntax match-let/helper + (syntax-rules () + ((_ let ((var expr) ...) () () . body) + (let ((var expr) ...) . body)) + ((_ let ((var expr) ...) ((pat tmp) ...) () . body) + (let ((var expr) ...) + (match-let* ((pat tmp) ...) + . body))) + ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((a expr) . rest) . body) + (match-let/helper let (v ... (a expr)) (p ...) rest . body)))) + +(define-syntax match-named-let + (syntax-rules () + ((_ loop ((pat expr var) ...) () . body) + (let loop ((var expr) ...) + (match-let ((pat var) ...) + . body))) + ((_ loop (v ...) ((pat expr) . rest) . body) + (match-named-let loop (v ... (pat expr tmp)) rest . body)))) + +(define-syntax match-let* + (syntax-rules () + ((_ () . body) + (begin . body)) + ((_ ((pat expr) . rest) . body) + (match expr (pat (match-let* rest . body)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Otherwise COND-EXPANDed bits. + +;; This *should* work, but doesn't :( +;; (define-syntax match-check-ellipse +;; (syntax-rules (...) +;; ((_ ... sk fk) sk) +;; ((_ x sk fk) fk))) + +;; This is a little more complicated, and introduces a new let-syntax, +;; but should work portably in any R[56]RS Scheme. Taylor Campbell +;; originally came up with the idea. +(define-syntax match-check-ellipse + (syntax-rules () + ;; these two aren't necessary but provide fast-case failures + ((match-check-ellipse (a . b) success-k failure-k) failure-k) + ((match-check-ellipse #(a ...) success-k failure-k) failure-k) + ;; matching an atom + ((match-check-ellipse id success-k failure-k) + (let-syntax ((ellipse? (syntax-rules () + ;; iff `id' is `...' here then this will + ;; match a list of any length + ((ellipse? (foo id) sk fk) sk) + ((ellipse? other sk fk) fk)))) + ;; this list of three elements will only many the (foo id) list + ;; above if `id' is `...' + (ellipse? (a b c) success-k failure-k))))) + + +;; This is portable but can be more efficient with non-portable +;; extensions. This trick was originally discovered by Oleg Kiselyov. + +(define-syntax match-check-identifier + (syntax-rules () + ;; fast-case failures, lists and vectors are not identifiers + ((_ (x . y) success-k failure-k) failure-k) + ((_ #(x ...) success-k failure-k) failure-k) + ;; x is an atom + ((_ x success-k failure-k) + (let-syntax + ((sym? + (syntax-rules () + ;; if the symbol `abracadabra' matches x, then x is a + ;; symbol + ((sym? x sk fk) sk) + ;; otherwise x is a non-symbol datum + ((sym? y sk fk) fk)))) + (sym? abracadabra success-k failure-k))))) diff --git a/lib/chibi/mime.module b/lib/chibi/mime.module new file mode 100644 index 00000000..2c10dbd1 --- /dev/null +++ b/lib/chibi/mime.module @@ -0,0 +1,7 @@ + +(define-module (chibi mime) + (export mime-ref assoc-ref mime-header-fold mime-headers->list + mime-parse-content-type mime-decode-header + mime-message-fold mime-message->sxml) + (import-immutable (scheme) (chibi base64) (chibi quoted-printable) (chibi io)) + (include "mime.scm")) diff --git a/lib/chibi/mime.scm b/lib/chibi/mime.scm new file mode 100644 index 00000000..e712d7fa --- /dev/null +++ b/lib/chibi/mime.scm @@ -0,0 +1,410 @@ +;; mime.scm -- RFC2045 MIME library +;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; RFC2822 headers + +;; Procedure: mime-header-fold kons knil [source [limit [kons-from]]] +;; +;; Performs a fold operation on the MIME headers of source which can be +;; either a string or port, and defaults to current-input-port. kons +;; is called on the three values: +;; kons header value accumulator +;; where accumulator begins with knil. Neither the header nor the +;; value are modified, except wrapped lines are handled for the value. +;; +;; The optional procedure KONS-FROM is a procedure to be called when +;; the first line of the headers is an "From
" line, to +;; enable this procedure to be used as-is on mbox files and the like. +;; It defaults to KONS, and if such a line is found the fold will begin +;; with (KONS-FROM "%from"
(KONS-FROM "%date" KNIL)). +;; +;; The optional LIMIT gives a limit on the number of headers to read. + +;; Procedure: mime-headers->list [source] +;; Return an alist of the MIME headers from source with headers all +;; downcased. + +;; Procedure: mime-parse-content-type str +;; Parses STR as a Content-Type style-value returning the list +;; (type (attr . val) ...) +;; For example: +;; (mime-parse-content-type +;; "text/html; CHARSET=US-ASCII; filename=index.html") +;; => ("text/html" ("charset" . "US-ASCII") ("filename" . "index.html")) + +;; Procedure: mime-decode-header str +;; Replace all occurrences of RFC1522 =?ENC?...?= escapes in STR with +;; the appropriate decoded and charset converted value. + +;; Procedure: mime-ref headers str [default] +;; A case-insensitive assoc-ref. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; RFC2045 MIME encoding + +;; Procedure: mime-message-fold src headers kons knil +;; Performs a fold operation on the given string or port SRC as a MIME +;; body corresponding to the headers give in HEADERS. KONS is called +;; on the successive values: +;; +;; KONS part-headers part-body accumulator +;; +;; where part-headers are the headers for the given MIME part (the +;; original headers for single-part MIME), part-body is the +;; appropriately decoded and charset-converted body of the message, +;; and the accumulator begins with KNIL. +;; +;; TODO: Extend mime-message-fold to (optionally?) pass KONS an +;; input-port instead of string for the body to handle very large bodies +;; (this is not much of an issue for SMTP since the messages are in +;; practice limited, but it could be problematic for large HTTP bodies). +;; +;; This does a depth-first search, folding in sequence. It should +;; probably be doing a tree-fold as in html-parser. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define mime-line-length-limit 4096) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; association lists + +(define (assoc* key ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls)) + (cond + ((null? ls) #f) + ((eq key (caar ls)) (car ls)) + (else (lp (cdr ls))))))) + +(define (assoc-ref ls key . o) + (let ((default (and (pair? o) (car o))) + (eq (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) equal?))) + (cond ((assoc* key ls eq) => cdr) + (else default)))) + +(define (mime-ref ls key . o) + (assoc-ref ls key (and (pair? o) (car o)) string-ci=?)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; simple matching instead of regexps + +(define (match-mbox-from-line line) + (let ((len (string-length line))) + (and (> len 5) + (string=? (substring line 0 5) "From ") + (let lp ((i 6)) + (cond + ((= i len) (list (substring line 5 len) "")) + ((memq (string-ref line i) '(#\space #\tab)) + (list (substring line 5 i) (substring line (+ i 1) len))) + (else (lp (+ i 1)))))))) + +(define (string-scan-colon-or-maybe-equal str) + (let ((len (string-length str))) + (let lp ((i 0) (best #f)) + (if (= i len) + best + (let ((c (string-ref str i))) + (cond ((or (char-alphabetic? c) + (char-numeric? c) + (memv c '(#\- #\_))) + (lp (+ i 1) best)) + ((eq? c #\:) + (if (= i 0) #f i)) + ((eqv? c #\=) + (lp (+ i 1) (or best i))) + (else + best))))))) + +(define (string-skip-white-space str i) + (let ((lim (string-length str))) + (let lp ((i i)) + (cond ((>= i lim) lim) + ((char-whitespace? (string-ref str i)) (lp (+ i 1))) + (else i))))) + +(define (match-mime-header-line line) + (let ((i (string-scan-colon-or-maybe-equal line))) + (and i + (let ((j (string-skip-white-space line (+ i 1)))) + (list (substring line 0 i) + (substring line j (string-length line))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; dummy encoder + +(define (ces-convert str . x) + str) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; some srfi-13 & string utils + +(define (string-copy! to tstart from . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length from)))) + (let lp ((i start) (j tstart)) + (cond + ((< i end) + (string-set! to j (string-ref from i)) + (lp (+ i 1) (+ j 1))))))) + +(define (string-concatenate-reverse ls) + (let lp ((ls ls) (rev '()) (len 0)) + (if (null? ls) + (let ((res (make-string len))) + (let lp ((ls rev) (i 0)) + (cond + ((null? ls) + res) + (else + (string-copy! res i (car ls)) + (lp (cdr ls) (+ i (string-length (car ls)))))))) + (lp (cdr ls) (cons (car ls) rev) (+ len (string-length (car ls))))))) + +(define (string-downcase s . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length s)))) + (let* ((len (- end start)) (s2 (make-string len))) + (let lp ((i start) (j 0)) + (cond + ((>= i end) + s2) + (else + (string-set! s2 j (char-downcase (string-ref s i))) + (lp (+ i 1) (+ j 1)))))))) + +(define (string-char-index str c . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond + ((= i end) #f) + ((eq? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-trim-white-space s) + (let ((len (string-length s))) + (let lp ((i 0)) + (cond ((= i len) "") + ((char-whitespace? (string-ref s i)) (lp (+ i 1))) + (else + (let lp ((j (- len 1))) + (cond ((<= j i) "") + ((char-whitespace? (string-ref s j)) (lp (- j 1))) + (else (substring s i (+ j 1)))))))))) + +(define (string-split str ch) + (let ((len (string-length str))) + (let lp ((i 0) (res '())) + (let ((j (string-char-index str ch i))) + (if j + (lp (+ j 1) (cons (substring str i j) res)) + (reverse (cons (substring str i len) res))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; header parsing + +(define (mime-header-fold kons knil . o) + (let ((src (and (pair? o) (car o))) + (limit (and (pair? o) (pair? (cdr o)) (car (cdr o)))) + (kons-from (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) (caddr o) kons))) + ((if (string? src) mime-header-fold-string mime-header-fold-port) + kons knil (or src (current-input-port)) limit kons-from))) + +(define (mime-header-fold-string kons knil str limit kons-from) + (call-with-input-string str + (lambda (in) (mime-header-fold-port kons knil in limit kons-from)))) + +(define (mime-header-fold-port kons knil port limit kons-from) + (define (out line acc count) + (cond + ((or (and limit (> count limit)) (eof-object? line) (string=? line "")) + acc) + ((match-mime-header-line line) + => (lambda (m) (in (car m) (list (cadr m)) acc (+ count 1)))) + (else + ;;(warn "invalid header line: ~S\n" line) + (out (read-line port mime-line-length-limit) acc (+ count 1))))) + (define (in header value acc count) + (let ((line (read-line port mime-line-length-limit))) + (cond + ((and limit (> count limit)) + acc) + ((or (eof-object? line) (string=? line "")) + (kons header (string-concatenate-reverse value) acc)) + ((char-whitespace? (string-ref line 0)) + (in header (cons line value) acc (+ count 1))) + (else + (out line + (kons header (string-concatenate-reverse value) acc) + (+ count 1)))))) + (let ((first-line (read-line port mime-line-length-limit))) + (cond + ((eof-object? first-line) + knil) + ((and kons-from (match-mbox-from-line first-line)) + => (lambda (m) ; special case check on first line for mbox files + (out (read-line port mime-line-length-limit) + (kons-from "%from" (car m) + (kons-from "%date" (cadr m) knil)) + 0))) + (else + (out first-line knil 0))))) + +(define (mime-headers->list . o) + (reverse + (apply + mime-header-fold + (lambda (h v acc) (cons (cons (string-downcase h) v) acc)) + '() + o))) + +(define (mime-split-name+value s) + (let ((i (string-char-index s #\=))) + (if i + (cons (string-downcase (string-trim-white-space (substring s 0 i))) + (if (= i (string-length s)) + "" + (if (eqv? #\" (string-ref s (+ i 1))) + (substring s (+ i 2) (- (string-length s) 1)) + (substring s (+ i 1) (string-length s))))) + (cons (string-downcase (string-trim-white-space s)) "")))) + +(define (mime-parse-content-type str) + (map mime-split-name+value (string-split str #\;))) + +(define (mime-decode-header str) + (let* ((len (string-length str)) + (limit (- len 8))) ; need at least 8 chars: "=?Q?X??=" + (let lp ((i 0) (from 0) (res '())) + (if (>= i limit) + (string-concatenate (reverse (cons (substring str from len) res))) + (if (and (eqv? #\= (string-ref str i)) + (eqv? #\? (string-ref str (+ i 1)))) + (let* ((j (string-char-index str #\? (+ i 3))) + (k (string-char-index str #\? (+ j 3)))) + (if (and j k (< (+ k 1) len) + (eqv? #\? (string-ref str (+ j 2))) + (memq (string-ref str (+ j 1)) '(#\Q #\B #\q #\b)) + (eqv? #\= (string-ref str (+ k 1)))) + (let ((decode (if (memq (string-ref str (+ j 1)) '(#\Q #\q)) + quoted-printable-decode-string + base64-decode-string)) + (cset (substring str (+ i 2) j)) + (content (substring str (+ j 3) k)) + (k2 (+ k 2))) + (lp k2 k2 (cons (ces-convert (decode content) cset) + (cons (substring str from i) res)))) + (lp (+ i 2) from res))) + (lp (+ i 1) from res)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; message parsing + +(define (mime-read-to-boundary port boundary next final) + (let ((final-boundary (and boundary (string-append boundary "--")))) + (let lp ((res '())) + (let ((line (read-line port mime-line-length-limit))) + (cond + ((or (eof-object? line) (equal? line final-boundary)) + (final (string-concatenate (reverse res) + (call-with-output-string newline)))) + ((equal? line boundary) + (next (string-concatenate (reverse res) + (call-with-output-string newline)))) + (else + (lp (cons line res)))))))) + +(define (mime-convert-part str cte enc) + (let ((str (cond + ((and (string? cte) (string-ci=? cte "quoted-printable")) + (quoted-printable-decode-string str)) + ((and (string? cte) (string-ci=? cte "base64")) + (base64-decode-string str)) + (else + str)))) + (if (string? enc) (ces-convert str enc) str))) + +(define (mime-read-part port cte enc boundary next final) + (mime-read-to-boundary + port boundary + (lambda (x) (next (mime-convert-part x cte enc))) + (lambda (x) (final (mime-convert-part x cte enc))))) + +;; (kons parent-headers part-headers part-body seed) +;; (start headers seed) +;; (end headers parent-seed seed) +(define (mime-message-fold src kons init-seed . o) + (let ((port (if (string? src) (open-input-string src) src))) + (let ((kons-start + (if (pair? o) (car o) (lambda (headers seed) '()))) + (kons-end + (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + (lambda (headers parent-seed seed) + `((mime (^ ,@headers) + ,@(if (pair? seed) (reverse seed) seed)) + ,@parent-seed)))) + (headers + (if (and (pair? o) (pair? (cdr o)) (pair? (cdr (cdr o)))) + (car (cdr (cdr o))) + (mime-headers->list port)))) + (let tfold ((parent-headers '()) + (headers headers) + (seed init-seed) + (boundary #f) + (next (lambda (x) x)) + (final (lambda (x) x))) + (let* ((ctype (mime-parse-content-type + (mime-ref headers "Content-Type" "text/plain"))) + (type (string-trim-white-space (caar ctype))) + (enc (string-trim-white-space + (or (mime-ref ctype "charset") + (mime-ref headers "charset" "ASCII")))) + (cte (string-trim-white-space + (or (mime-ref headers "Content-Transfer-Encoding") + (mime-ref headers "Encoding" "7-bit"))))) + (cond + ((and (string-ci=? type "multipart/") + (mime-ref ctype "boundary")) + => (lambda (boundary2) + (let ((boundary2 (string-append "--" boundary2))) + ;; skip preamble + (mime-read-to-boundary port boundary2 (lambda (x) x) (lambda (x) x)) + (let lp ((part-seed (kons-start headers seed))) + (let ((part-headers (mime-headers->list port))) + (tfold parent-headers part-headers + part-seed boundary2 + lp + (lambda (x) + ;; skip epilogue + (if boundary + (mime-read-to-boundary port boundary + (lambda (x) x) (lambda (x) x))) + (next (kons-end headers seed x))) + )))))) + (else + (mime-read-part + port cte enc boundary + (lambda (x) (next (kons parent-headers headers x seed))) + (lambda (x) (final (kons parent-headers headers x seed))))))))))) + +;; (mime (^ (header . value) ...) parts ...) +(define (mime-message->sxml . o) + (car + (apply + mime-message-fold + (if (pair? o) (car o) (current-input-port)) + (lambda (parent-headers headers body seed) + `((mime (^ ,@headers) ,body) ,@seed)) + '() + (lambda (headers seed) '()) + (lambda (headers parent-seed seed) + `((mime (^ ,@headers) + ,@(if (pair? seed) (reverse seed) seed)) + ,@parent-seed)) + (if (pair? o) (cdr o) '())))) + diff --git a/lib/chibi/modules.module b/lib/chibi/modules.module new file mode 100644 index 00000000..0d20861e --- /dev/null +++ b/lib/chibi/modules.module @@ -0,0 +1,8 @@ + +(define-module (chibi modules) + (export analyze-module module-ast module-ast-set! + module-ref module-contains? containing-module + procedure-analysis) + (import-immutable (scheme) (config)) + (import (chibi ast)) + (include "modules.scm")) diff --git a/lib/chibi/modules.scm b/lib/chibi/modules.scm new file mode 100644 index 00000000..b9e40e0d --- /dev/null +++ b/lib/chibi/modules.scm @@ -0,0 +1,103 @@ + +(define (file->sexp-list file) + (call-with-input-file file + (lambda (in) + (let lp ((res '())) + (let ((x (read in))) + (if (eof-object? x) + (reverse res) + (lp (cons x res)))))))) + +(define (module? x) (vector? x)) + +(define (module-ast mod) (vector-ref mod 3)) +(define (module-ast-set! mod x) (vector-set! mod 3 x)) + +(define (analyze-module-source name mod recursive?) + (let ((env (module-env mod)) + (dir (if (equal? name '(scheme)) "" (module-name-prefix name)))) + (define (include-source file) + (cond ((find-module-file (string-append dir file)) + => (lambda (x) (cons 'body (file->sexp-list x)))) + (else (error "couldn't find include" file)))) + (let lp ((ls (module-meta-data mod)) (res '())) + (cond + ((not (pair? ls)) + (reverse res)) + (else + (case (and (pair? (car ls)) (caar ls)) + ((import import-immutable) + (for-each + (lambda (m) + (let* ((mod2-name+imports (resolve-import m)) + (mod2-name (car mod2-name+imports))) + (if recursive? + (analyze-module mod2-name #t)))) + (cdar ls)) + (lp (cdr ls) res)) + ((include) + (lp (append (map include-source (cdar ls)) (cdr ls)) res)) + ((body) + (let lp2 ((ls2 (cdar ls)) (res res)) + (cond + ((pair? ls2) + (lp2 (cdr ls2) (cons (analyze (car ls2) env) res))) + (else + (lp (cdr ls) res))))) + (else + (lp (cdr ls) res)))))))) + +(define (analyze-module name . o) + (let ((recursive? (and (pair? o) (car o))) + (res (load-module name))) + (if (not (module-ast res)) + (module-ast-set! res (analyze-module-source name res recursive?))) + res)) + +(define (module-ref mod var-name . o) + (let ((cell (env-cell (module-env (if (module? mod) mod (load-module mod))) + var-name))) + (if cell + (cdr cell) + (if (pair? o) (car o) (error "no binding in module" mod var-name))))) + +(define (module-contains? mod var-name) + (and (env-cell (module-env (if (module? mod) mod (load-module mod))) var-name) + #t)) + +(define (module-defines? name mod var-name) + (if (not (module-ast mod)) + (module-ast-set! mod (analyze-module-source name mod #f))) + (let lp ((ls (module-ast mod))) + (and (pair? ls) + (or (and (set? (car ls)) + (eq? var-name (ref-name (set-var (car ls)))) + (begin + ;; (write `(found ,var-name in ,name ,(ast->sexp (car ls))) (current-error-port)) + ;; (newline (current-error-port)) + #t)) + (lp (cdr ls)))))) + +(define (containing-module x) + (let lp1 ((ls (reverse *modules*))) + (and (pair? ls) + (let ((env (module-env (cdar ls)))) + (let lp2 ((e-ls (env-exports env))) + (if (null? e-ls) + (lp1 (cdr ls)) + (let ((cell (env-cell env (car e-ls)))) + (if (and (eq? x (cdr cell)) + (module-defines? (caar ls) (cdar ls) (car cell))) + (car ls) + (lp2 (cdr e-ls)))))))))) + +(define (procedure-analysis x) + (let ((mod (containing-module x))) + (and mod + (let lp ((ls (module-ast (analyze-module (car mod))))) + (and (pair? ls) + (if (and (set? (car ls)) + (eq? (procedure-name x) (ref-name (set-var (car ls))))) + (set-value (car ls)) + (lp (cdr ls)))))))) + diff --git a/lib/chibi/net.module b/lib/chibi/net.module new file mode 100644 index 00000000..845a7aa8 --- /dev/null +++ b/lib/chibi/net.module @@ -0,0 +1,11 @@ + +(define-module (chibi net) + (export sockaddr? address-info? get-address-info socket connect + with-net-io open-net-io + address-info-family address-info-socket-type address-info-protocol + address-info-address address-info-address-length address-info-next) + (import-immutable (scheme)) + (import (chibi filesystem)) + (include-shared "net") + (include "net.scm")) + diff --git a/lib/chibi/net.scm b/lib/chibi/net.scm new file mode 100644 index 00000000..5f912cb5 --- /dev/null +++ b/lib/chibi/net.scm @@ -0,0 +1,32 @@ +;; net.scm -- the high-level network interface +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (open-net-io host service) + (let lp ((addr (get-address-info host + (if (integer? service) + (number->string service) + service) + #f))) + (if (not addr) + (error "couldn't find address" host service) + (let ((sock (socket (address-info-family addr) + (address-info-socket-type addr) + (address-info-protocol addr)))) + (if (negative? sock) + (lp (address-info-next addr)) + (if (negative? + (connect sock + (address-info-address addr) + (address-info-address-length addr))) + (lp (address-info-next addr)) + (list (open-input-file-descriptor sock) + (open-output-file-descriptor sock)))))))) + +(define (with-net-io host service proc) + (let ((io (open-net-io host service))) + (if (not (pair? io)) + (error "couldn't find address" host service) + (let ((res (proc (car io) (car (cdr io))))) + (close-input-port (car io)) + res)))) diff --git a/lib/chibi/net.stub b/lib/chibi/net.stub new file mode 100644 index 00000000..0d72bc90 --- /dev/null +++ b/lib/chibi/net.stub @@ -0,0 +1,25 @@ + +(c-system-include "sys/types.h") +(c-system-include "sys/socket.h") +(c-system-include "netdb.h") + +(define-c-struct sockaddr + predicate: sockaddr?) + +(define-c-struct addrinfo + finalizer: freeaddrinfo + predicate: address-info? + (int ai_family address-info-family) + (int ai_socktype address-info-socket-type) + (int ai_protocol address-info-protocol) + ((link sockaddr) ai_addr address-info-address) + (size_t ai_addrlen address-info-address-length) + ((link addrinfo) ai_next address-info-next)) + +(define-c errno (get-address-info getaddrinfo) + (string string (maybe-null addrinfo) (result free addrinfo))) + +(define-c int bind (int sockaddr int)) +(define-c int listen (int int)) +(define-c int socket (int int int)) +(define-c int connect (int sockaddr int)) diff --git a/lib/chibi/net/http.module b/lib/chibi/net/http.module new file mode 100644 index 00000000..352bf7b4 --- /dev/null +++ b/lib/chibi/net/http.module @@ -0,0 +1,7 @@ + +(define-module (chibi net http) + (export http-get call-with-input-url with-input-from-url + http-parse-request http-parse-form) + (import-immutable (scheme) (srfi 39) (chibi net) (chibi io) + (chibi uri) (chibi mime)) + (include "http.scm")) diff --git a/lib/chibi/net/http.scm b/lib/chibi/net/http.scm new file mode 100644 index 00000000..37cac5e6 --- /dev/null +++ b/lib/chibi/net/http.scm @@ -0,0 +1,180 @@ +;; http.scm -- http client +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils + +(define (string-char-index str c . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond + ((= i end) #f) + ((eq? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-split str ch) + (let ((len (string-length str))) + (let lp ((i 0) (res '())) + (let ((j (string-char-index str ch i))) + (if j + (lp (+ j 1) (cons (substring str i j) res)) + (reverse (cons (substring str i len) res))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; client utils + +(define http-user-agent "chibi") + +(define http-redirect-limit 10) +(define http-chunked-buffer-size 4096) +(define http-chunked-size-limit 409600) + +(define (string-scan str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (and (< i end) + (if (eqv? ch (string-ref str i)) + i + (lp (+ i 1))))))) + +(define (http-parse-response line) + (let* ((len (string-length line)) + (i (or (string-scan line #\space 0 len) len)) + (j (or (string-scan line #\space (+ i 1) len) len)) + (n (and (< i j) (string->number (substring line (+ i 1) j))))) + (if (not (integer? n)) + (error "bad response" line i j) + (list (substring line 0 i) + n + (if (>= j len) "" (substring line (+ j 1) len)))))) + +(define (http-wrap-chunked-input-port in) + (define (read-chunk in) + (let* ((line (read-line in)) + (n (and (string? line) (string->number line 16)))) + (display "read-chunk ") (write line) (newline) + (cond + ((not (and (integer? n) (<= 0 n http-chunked-size-limit))) + (error "invalid chunked size line" line)) + ((zero? n) "") + (else (read-string n in))))) + (make-generated-input-port + (lambda () (read-chunk in)))) + +(define (http-get/raw url in-headers limit) + (if (<= limit 0) + (error "http-get: redirect limit reached" url) + (let* ((uri (if (uri? url) url (string->uri url))) + (host (and uri (uri-host uri)))) + (if (not host) + (error "invalid url" url) + (let* ((io (open-net-io + host + (or (uri-port uri) + (if (eq? 'https (uri-scheme uri)) 443 80)))) + (in (car io)) + (out (car (cdr io)))) + (display "GET " out) + (display (or (uri-path uri) "/") out) + (display " HTTP/1.0\r\n" out) + (display "Host: " out) (display host out) (display "\r\n" out) + (cond + ((not (mime-ref in-headers "user-agent")) + (display "User-Agent: " out) + (display http-user-agent out) + (display "\r\n" out))) + (for-each + (lambda (x) + (display (car x) out) (display ": " out) + (display (cdr x) out) (display "\r\n" out)) + in-headers) + (display "Connection: close\r\n\r\n" out) + (flush-output out) + (let* ((resp (http-parse-response (read-line in))) + (headers (mime-headers->list in)) + (status (quotient (cadr resp) 100))) + (case status + ((2) + (let ((enc (mime-ref headers "transfer-encoding"))) + (cond + ((equal? enc "chunked") + (http-wrap-chunked-input-port in)) + (else + in)))) + ((3) + (close-input-port in) + (close-output-port out) + (let ((url2 (mime-ref headers "location"))) + (if url2 + (http-get/raw url2 in-headers (- limit 1)) + (error "redirect with no location header")))) + (else + (close-input-port in) + (close-output-port out) + (error "couldn't retrieve url" url resp))))))))) + +(define (http-get url . headers) + (http-get/raw url + (if (pair? headers) (car headers) '()) + http-redirect-limit)) + +(define (call-with-input-url url proc) + (let* ((p (http-get url)) + (res (proc p))) + (close-input-port p) + res)) + +(define (with-input-from-url url thunk) + (let ((p (http-get url))) + (let ((res (parameterize ((current-input-port p)) (thunk)))) + (close-input-port p) + res))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; server utils + +;; read and parse a request line +(define (http-parse-request . o) + (let ((line (string-split + (read-line (if (pair? o) (car o) (current-input-port)) 4096)))) + (cons (string->symbol (car line)) (cdr line)))) + +;; Parse a form body with a given URI and MIME headers (as parsed with +;; mime-headers->list). Returns an alist of (name . value) for every +;; query or form parameter. +(define (http-parse-form uri headers . o) + (let* ((in (if (pair? o) (car o) (current-input-port))) + (type (mime-ref headers + "content-type" + "application/x-www-form-urlencoded")) + (query0 (or (uri-query (if (string? uri) (string->uri uri) uri)) '())) + (query (if (string? query0) (uri-query->alist query0) query0))) + (cond + ((string-ci=? "multipart/" type) + (let ((mime (mime-message->sxml in headers))) + (append + (let lp ((ls (cddr mime)) + (res '())) + (cond + ((null? ls) + res) + ((and (pair? (car ls)) + (eq? 'mime (caar ls)) + (pair? (cdar ls)) + (pair? (cadar ls)) + (memq (caadar ls) '(^ @))) + (let* ((disp0 (mime-ref (cdadar ls) "content-disposition" "")) + (disp (mime-parse-content-type disp0)) + (name (mime-ref disp "name"))) + (if name + (lp (cdr ls) (cons (cons name (caddar ls)) res)) + (lp (cdr ls) res)))) + (else + (lp (cdr ls) res)))) + query))) + (else + query)))) + diff --git a/lib/chibi/pathname.module b/lib/chibi/pathname.module new file mode 100644 index 00000000..765ee189 --- /dev/null +++ b/lib/chibi/pathname.module @@ -0,0 +1,7 @@ + +(define-module (chibi pathname) + (export path-strip-directory path-directory path-extension-pos + path-extension path-strip-extension path-replace-extension + path-absolute? path-relative? path-normalize make-path) + (import-immutable (scheme)) + (include "pathname.scm")) diff --git a/lib/chibi/pathname.scm b/lib/chibi/pathname.scm new file mode 100644 index 00000000..de27ad61 --- /dev/null +++ b/lib/chibi/pathname.scm @@ -0,0 +1,180 @@ +;; pathname.scm -- a general, non-host-specific path lib +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-scan-right c str . o) + (let lp ((i (if (pair? o) (car o) (- (string-length str) 1)))) + (cond ((negative? i) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (- i 1)))))) + +(define (string-skip c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((not (eqv? c (string-ref str i))) i) + (else (lp (+ i 1))))))) + +(define (string-skip-right c str . o) + (let lp ((i (if (pair? o) (car o) (- (string-length str) 1)))) + (cond ((negative? i) #f) + ((not (eqv? c (string-ref str i))) i) + (else (lp (- i 1)))))) + +;; POSIX basename +;; (define (path-strip-directory path) +;; (if (string=? path "") +;; path +;; (let ((end (string-skip-right #\/ path))) +;; (if (not end) +;; "/" +;; (let ((start (string-scan-right #\/ path (- end 1)))) +;; (substring path (if start (+ start 1) 0) (+ end 1))))))) + +;; GNU basename +(define (path-strip-directory path) + (if (string=? path "") + path + (let ((len (string-length path))) + (if (eqv? #\/ (string-ref path (- len 1))) + "" + (let ((slash (string-scan-right #\/ path))) + (if (not slash) + path + (substring path (+ slash 1) len))))))) + +(define (path-directory path) + (if (string=? path "") + "." + (let ((end (string-skip-right #\/ path))) + (if (not end) + "/" + (let ((start (string-scan-right #\/ path (- end 1)))) + (if (not start) + "." + (let ((start (string-skip-right #\/ path start))) + (if (not start) "/" (substring path 0 (+ start 1)))))))))) + +(define (path-extension-pos path) (string-scan-right #\. path)) + +(define (path-extension path) + (let ((i (path-extension-pos path))) + (and i + (let ((start (+ i 1)) (end (string-length path))) + (and (< start end) (substring path start end)))))) + +(define (path-strip-extension path) + (let ((i (path-extension-pos path))) + (if (and i (< (+ i 1) (string-length path))) + (substring path 0 i) + path))) + +(define (path-replace-extension path ext) + (string-append (path-strip-extension path) "." ext)) + +(define (path-absolute? path) + (and (not (string=? "" path)) (eqv? #\/ (string-ref path 0)))) + +(define (path-relative? path) (not (path-absolute? path))) + +;; This looks big and hairy, but it's mutation-free and guarantees: +;; (string=? s (path-normalize s)) <=> (eq? s (path-normalize s)) +;; i.e. fast and simple for already normalized paths. + +(define (path-normalize path) + (let* ((len (string-length path)) (len-1 (- len 1))) + (define (collect i j res) + (if (>= i j) res (cons (substring path i j) res))) + (define (finish i res) + (if (zero? i) + path + (apply string-append (reverse (collect i len res))))) + ;; loop invariants: + ;; - res is a list such that (string-concatenate-reverse res) + ;; is always the normalized string up to j + ;; - the tail of the string from j onward can be concatenated to + ;; the above value to get a partially normalized path referring + ;; to the same location as the original path + (define (inside i j res) + (if (>= j len) + (finish i res) + (if (eqv? #\/ (string-ref path j)) + (boundary i (+ j 1) res) + (inside i (+ j 1) res)))) + (define (boundary i j res) + (if (>= j len-1) + (finish i res) + (case (string-ref path j) + ((#\.) + (case (string-ref path (+ j 1)) + ((#\.) + (if (or (>= j (- len 2)) (eqv? #\/ (string-ref path (+ j 2)))) + (if (>= i (- j 1)) + (if (null? res) + (backup j "" '()) + (backup j (car res) (cdr res))) + (backup j (substring path i j) res)) + (inside i (+ j 2) res))) + ((#\/) + (if (= i j) + (boundary (+ j 2) (+ j 2) res) + (let ((s (substring path i j))) + (boundary (+ j 2) (+ j 2) (cons s res))))) + (else (inside i (+ j 1) res)))) + ((#\/) (boundary (+ j 1) (+ j 1) (collect i j res))) + (else (inside i (+ j 1) res))))) + (define (backup j s res) + (let ((pos (+ j 3))) + (cond + ;; case 1: we're reduced to accumulating parents of the cwd + ((or (string=? s "/..") (string=? s "..")) + (boundary pos pos (cons "/.." (cons s res)))) + ;; case 2: the string isn't a component itself, skip it + ((or (string=? s "") (string=? s ".") (string=? s "/")) + (if (pair? res) + (backup j (car res) (cdr res)) + (boundary pos pos (if (string=? s "/") '("/") '(".."))))) + ;; case3: just take the directory of the string + (else + (let ((d (path-directory s))) + (cond + ((string=? d "/") + (boundary pos pos (if (null? res) '("/") res))) + ((string=? d ".") + (boundary pos pos res)) + (else (boundary pos pos (cons "/" (cons d res)))))))))) + ;; start with boundary if abs path, otherwise inside + (if (zero? len) + path + ((if (eqv? #\/ (string-ref path 0)) boundary inside) 0 1 '())))) + +(define (make-path . args) + (define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "not a valid path component" x)))) + (define (trim-trailing-slash s) + (let ((i (string-skip-right #\/ s))) + (if i (substring s 0 (+ i 1)) ""))) + (if (null? args) + "" + (let ((start (trim-trailing-slash (x->string (car args))))) + (let lp ((ls (cdr args)) + (res (if (string=? "" start) '() (list start)))) + (cond + ((null? ls) + (apply string-append (reverse res))) + ((pair? (car ls)) + (lp (append (car ls) (cdr ls)) res)) + (else + (let ((x (trim-trailing-slash (x->string (car ls))))) + (lp (cdr ls) + (if (string=? x "") res (cons x (cons "/" res))))))))))) diff --git a/lib/chibi/process.module b/lib/chibi/process.module new file mode 100644 index 00000000..372b56e4 --- /dev/null +++ b/lib/chibi/process.module @@ -0,0 +1,18 @@ + +(define-module (chibi process) + (export exit sleep alarm fork kill execute waitpid + set-signal-action! make-signal-set signal-set-contains? + signal-set-fill! signal-set-add! signal-set-delete! + current-signal-mask + signal-mask-block! signal-mask-unblock! signal-mask-set! + signal/hang-up signal/interrupt signal/quit + signal/illegal signal/abort signal/fpe + signal/kill signal/segv signal/pipe + signal/alarm signal/term signal/user1 + signal/user2 signal/child signal/continue + signal/stop signal/tty-stop signal/tty-input + signal/tty-output) + (import-immutable (scheme)) + (cond-expand (threads (import (srfi 18))) (else #f)) + (include-shared "process")) + diff --git a/lib/chibi/process.stub b/lib/chibi/process.stub new file mode 100644 index 00000000..93b08d95 --- /dev/null +++ b/lib/chibi/process.stub @@ -0,0 +1,73 @@ + +(c-system-include "sys/types.h") +(c-system-include "sys/wait.h") +(c-system-include "signal.h") +(c-system-include "unistd.h") + +(define-c-type siginfo_t + predicate: signal-info? + (int si_signo signal-number) + (int si_errno signal-error-number) + (int si_code signal-code) + (pid_t si_pid signal-pid) + (uid_t si_uid signal-uid) + (int si_status signal-status) + ;;(clock_t si_utime signal-user-time) + ;;(clock_t si_stime signal-system-time) + ) + +(define-c-type sigset_t + predicate: signal-set?) + +(define-c-const int (signal/hang-up "SIGHUP")) +(define-c-const int (signal/interrupt "SIGINT")) +(define-c-const int (signal/quit "SIGQUIT")) +(define-c-const int (signal/illegal "SIGILL")) +(define-c-const int (signal/abort "SIGABRT")) +(define-c-const int (signal/fpe "SIGFPE")) +(define-c-const int (signal/kill "SIGKILL")) +(define-c-const int (signal/segv "SIGSEGV")) +(define-c-const int (signal/pipe "SIGPIPE")) +(define-c-const int (signal/alarm "SIGALRM")) +(define-c-const int (signal/term "SIGTERM")) +(define-c-const int (signal/user1"SIGUSR1")) +(define-c-const int (signal/user2 "SIGUSR2")) +(define-c-const int (signal/child "SIGCHLD")) +(define-c-const int (signal/continue "SIGCONT")) +(define-c-const int (signal/stop "SIGSTOP")) +(define-c-const int (signal/tty-stop "SIGTSTP")) +(define-c-const int (signal/tty-input "SIGTTIN")) +(define-c-const int (signal/tty-output "SIGTTOU")) + +(c-include "signal.c") + +(define-c sexp (set-signal-action! "sexp_set_signal_action") + ((value ctx sexp) (value self sexp) sexp sexp)) + +(define-c errno (make-signal-set "sigemptyset") ((pointer result sigset_t))) +(define-c errno (signal-set-fill! "sigfillset") ((pointer sigset_t))) +(define-c errno (signal-set-add! "sigaddset") ((pointer sigset_t) int)) +(define-c errno (signal-set-delete! "sigaddset") ((pointer sigset_t) int)) +(define-c boolean (signal-set-contains? "sigismember") ((pointer sigset_t) int)) + +(define-c errno (signal-mask-block! "sigprocmask") + ((value SIG_BLOCK int) (pointer sigset_t) (pointer value NULL sigset_t))) +(define-c errno (signal-mask-unblock! "sigprocmask") + ((value SIG_UNBLOCK int) (pointer sigset_t) (pointer value NULL sigset_t))) +(define-c errno (signal-mask-set! "sigprocmask") + ((value SIG_SETMASK int) (pointer sigset_t) (pointer value NULL sigset_t))) +(define-c errno (current-signal-mask "sigprocmask") + ((value SIG_BLOCK int) (pointer value NULL sigset_t) (pointer result sigset_t))) + +(define-c unsigned-int alarm (unsigned-int)) +(define-c unsigned-int sleep (unsigned-int)) + +(define-c pid_t fork ()) +;;(define-c pid_t wait ((result int))) +(define-c pid_t waitpid (int (result int) int)) +(define-c errno kill (int int)) +;;(define-c errno raise (int)) +(define-c void exit (int)) +(define-c int (execute execvp) (string (array string))) + +(c-init "sexp_init_signals(ctx, env);") diff --git a/lib/chibi/quoted-printable.module b/lib/chibi/quoted-printable.module new file mode 100644 index 00000000..9cbec430 --- /dev/null +++ b/lib/chibi/quoted-printable.module @@ -0,0 +1,7 @@ + +(define-module (chibi quoted-printable) + (export quoted-printable-encode quoted-printable-encode-string + quoted-printable-encode-header + quoted-printable-decode quoted-printable-decode-string) + (import-immutable (scheme) (srfi 33) (chibi io)) + (include "quoted-printable.scm")) diff --git a/lib/chibi/quoted-printable.scm b/lib/chibi/quoted-printable.scm new file mode 100644 index 00000000..80709026 --- /dev/null +++ b/lib/chibi/quoted-printable.scm @@ -0,0 +1,157 @@ +;; quoted-printable.scm -- RFC2045 implementation +;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; Procedure: quoted-printable-encode-string str [start-col max-col] +;; Return a quoted-printable encoded representation of string +;; according to the official standard as described in RFC2045. +;; +;; ? and _ are always encoded for compatibility with RFC1522 encoding, +;; and soft newlines are inserted as necessary to keep each lines +;; length less than MAX-COL (default 76). The starting column may be +;; overridden with START-COL (default 0). + +;; Procedure: quoted-printable-decode-string str [mime?] +;; Return a quoted-printable decoded representation of string. If +;; MIME? is specified and true, _ will be decoded as as space in +;; accordance with RFC1522. No errors will be raised on invalid +;; input. + +;; Procedure: quoted-printable-encode [port start-col max-col] +;; Procedure: quoted-printable-decode [port start-col max-col] +;; Variations of the above which read and write to ports. + +;; Procedure: quoted-printable-encode-header enc str [start-col max-col] +;; Return a quoted-printable encoded representation of string as +;; above, wrapped in =?ENC?Q?...?= as per RFC1522, split across +;; multiple MIME-header lines as needed to keep each lines length less +;; than MAX-COL. The string is encoded as is, and the encoding ENC is +;; just used for the prefix, i.e. you are responsible for ensuring STR +;; is already encoded according to ENC. + +;; Example: + +;; (define (mime-encode-header header value charset) +;; (let ((prefix (string-append header ": ")) +;; (str (ces-convert value "UTF8" charset))) +;; (string-append +;; prefix +;; (quoted-printable-encode-header charset str (string-length prefix))))) + +;; This API is backwards compatible with the Gauche library +;; rfc.quoted-printable. + +(define *default-max-col* 76) + +;; Allow for RFC1522 quoting for headers by always escaping ? and _ +(define (qp-encode str start-col max-col separator) + (define (hex i) (integer->char (+ i (if (<= i 9) 48 55)))) + (let ((end (string-length str)) + (buf (make-string max-col))) + (let lp ((i 0) (col start-col) (res '())) + (cond + ((= i end) + (if (pair? res) + (string-concatenate (reverse (cons (substring buf 0 col) res)) + separator) + (substring buf start-col col))) + ((>= col (- max-col 3)) + (lp i 0 (cons (substring buf (if (pair? res) 0 start-col) col) res))) + (else + (let ((c (char->integer (string-ref str i)))) + (cond + ((and (<= 33 c 126) (not (memq c '(61 63 95)))) + (string-set! buf col (integer->char c)) + (lp (+ i 1) (+ col 1) res)) + (else + (string-set! buf col #\=) + (string-set! buf (+ col 1) (hex (arithmetic-shift c -4))) + (string-set! buf (+ col 2) (hex (bitwise-and c #b1111))) + (lp (+ i 1) (+ col 3) res))))))))) + +(define (quoted-printable-encode-string . o) + (let ((src (if (pair? o) (car o) (current-input-port))) + (start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0)) + (max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) + (caddr o) + *default-max-col*))) + (qp-encode (if (string? src) src (read-string #f src)) + start-col max-col "=\r\n"))) + +(define (quoted-printable-encode . o) + (display (apply (quoted-printable-encode-string o)))) + +(define (quoted-printable-encode-header encoding . o) + (let ((src (if (pair? o) (car o) (current-input-port))) + (start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0)) + (max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) + (caddr o) + *default-max-col*)) + (nl (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)) (pair? (cdddr o))) + (cadddr o) + "\r\n"))) + (let* ((prefix (string-append "=?" encoding "?Q?")) + (prefix-length (+ 2 (string-length prefix))) + (separator (string-append "?=" nl "\t" prefix)) + (effective-max-col (- max-col prefix-length))) + (string-append prefix + (qp-encode (if (string? src) src (read-string #f src)) + start-col effective-max-col separator) + "?=")))) + +(define (quoted-printable-decode-string . o) + (define (hex? c) (or (char-numeric? c) (<= 65 (char->integer c) 70))) + (define (unhex1 c) + (let ((i (char->integer c))) (if (>= i 65) (- i 55) (- i 48)))) + (define (unhex c1 c2) + (integer->char (+ (arithmetic-shift (unhex1 c1) 4) (unhex1 c2)))) + (let ((src (if (pair? o) (car o) (current-input-port))) + (mime-header? (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (let* ((str (if (string? src) src (read-string #f src))) + (end (string-length str))) + (call-with-output-string + (lambda (out) + (let lp ((i 0)) + (cond + ((< i end) + (let ((c (string-ref str i))) + (case c + ((#\=) ; = escapes + (cond + ((< (+ i 2) end) + (let ((c2 (string-ref str (+ i 1)))) + (cond + ((eq? c2 #\newline) (lp (+ i 2))) + ((eq? c2 #\return) + (lp (if (eq? (string-ref str (+ i 2)) #\newline) + (+ i 3) + (+ i 2)))) + ((hex? c2) + (let ((c3 (string-ref str (+ i 2)))) + (if (hex? c3) (write-char (unhex c2 c3) out)) + (lp (+ i 3)))) + (else (lp (+ i 3)))))))) + ((#\_) ; maybe translate _ to space + (write-char (if mime-header? #\space c) out) + (lp (+ i 1))) + ((#\space #\tab) ; strip trailing whitespace + (let lp2 ((j (+ i 1))) + (cond + ((not (= j end)) + (case (string-ref str j) + ((#\space #\tab) (lp2 (+ j 1))) + ((#\newline) + (lp (+ j 1))) + ((#\return) + (let ((k (+ j 1))) + (lp (if (and (< k end) + (eqv? #\newline (string-ref str k))) + (+ k 1) k)))) + (else (display (substring str i j) out) (lp j))))))) + (else ; a literal char + (write-char c out) + (lp (+ i 1))))))))))))) + +(define (quoted-printable-decode . o) + (display (apply quoted-printable-decode-string o))) + diff --git a/lib/chibi/repl.module b/lib/chibi/repl.module new file mode 100644 index 00000000..742b9581 --- /dev/null +++ b/lib/chibi/repl.module @@ -0,0 +1,9 @@ + +(define-module (chibi repl) + (export repl) + (import-immutable (scheme)) + (import (chibi ast) + (chibi process) + (chibi term edit-line) + (srfi 18)) + (include "repl.scm")) diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm new file mode 100644 index 00000000..b7ff79bc --- /dev/null +++ b/lib/chibi/repl.scm @@ -0,0 +1,41 @@ +;;;; repl.scm - friendlier repl with line editing and signal handling +;; +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define-syntax handle-exceptions + (syntax-rules () + ((handle-exceptions exn handler expr) + (call-with-current-continuation + (lambda (return) + (with-exception-handler (lambda (exn) (return handler)) + (lambda () expr))))))) + +(define (with-signal-handler sig handler thunk) + (let ((old-handler #f)) + (dynamic-wind + (lambda () (set! old-handler (set-signal-action! sig handler))) + thunk + (lambda () (set-signal-action! sig old-handler))))) + +(define (run-repl module env) + (let ((line (edit-line (if module (string-append (symbol->string module) "> ") "> ")))) + (cond + ((or (not line) (eof-object? line))) + ((equal? line "") (run-repl module env)) + (else + (handle-exceptions exn (print-exception exn (current-error-port)) + (let* ((expr (call-with-input-string line read)) + (thread (make-thread (lambda () + (let ((res (eval expr env))) + (if (not (eq? res (if #f #f))) + (write res))))))) + (with-signal-handler + signal/interrupt + (lambda (n) (thread-terminate! thread)) + (lambda () (thread-start! thread) (thread-join! thread))))) + (newline) + (run-repl module env))))) + +(define (repl) + (run-repl #f (interaction-environment))) diff --git a/lib/chibi/scribble.module b/lib/chibi/scribble.module new file mode 100644 index 00000000..b479eb64 --- /dev/null +++ b/lib/chibi/scribble.module @@ -0,0 +1,5 @@ + +(define-module (chibi scribble) + (export scribble-parse scribble-read) + (import-immutable (scheme)) + (include "scribble.scm")) diff --git a/lib/chibi/scribble.scm b/lib/chibi/scribble.scm new file mode 100644 index 00000000..1e4f15cd --- /dev/null +++ b/lib/chibi/scribble.scm @@ -0,0 +1,247 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; general character utils + +(define (char-mirror ch) + (case ch ((#\() #\)) ((#\[) #\]) ((#\{) #\}) ((#\<) #\>) (else ch))) + +(define (char-delimiter? ch) + (or (eof-object? ch) (char-whitespace? ch) + (memv ch '(#\( #\) #\[ #\] #\{ #\} #\" #\|)))) + +(define (char-punctuation? ch) + (memv ch '(#\- #\+ #\! #\< #\> #\[ #\] #\|))) + +(define (char-digit ch) (- (char->integer ch) (char->integer #\0))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; list utils + +(define (drop ls n) (if (<= n 0) ls (drop (cdr ls) (- n 1)))) + +(define (drop-while pred ls) + (if (or (null? ls) (not (pred (car ls)))) ls (drop-while pred (cdr ls)))) + +(define (list-prefix? prefix ls) + (cond ((null? prefix) #t) + ((null? ls) #f) + ((equal? (car prefix) (car ls)) (list-prefix? (cdr prefix) (cdr ls))) + (else #f))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; scribble reader (standalone, don't use the native reader) + +(define scribble-dot (list ".")) +(define scribble-close (list ")")) + +(define (if-peek-char ch in pass fail) + (cond ((eqv? ch (peek-char in)) (read-char in) pass) (else fail))) + +(define (skip-line in) + (do ((c #f (read-char in))) ((or (eof-object? c) (eqv? c #\newline))))) + +(define (read-float-tail in acc) + (let lp ((res acc) (k 0.1)) + (let ((ch (read-char in))) + (cond ((or (eof-object? ch) (char-delimiter? ch)) res) + ((char-numeric? ch) (lp (+ res (* k (char-digit ch))) (* k 0.1))) + (else (error "invalid numeric syntax")))))) + +(define (read-number in acc base) + (let lp ((acc acc)) + (let ((ch (peek-char in))) + (cond + ((or (eof-object? ch) (char-delimiter? ch)) acc) + ((char-numeric? ch) (read-char in) (lp (+ (* acc base) (char-digit ch)))) + ((eqv? #\. ch) + (read-char in) + (if (= base 10) + (begin (read-char in) (read-float-tail in (exact->inexact acc))) + (error "non-base-10 floating point"))) + (else (error "invalid numeric syntax")))))) + +(define (read-escaped in terminal) + (let lp ((ls '())) + (let ((ch (read-char in))) + (cond + ((or (eof-object? ch) (eqv? ch terminal)) (list->string (reverse ls))) + ((eqv? ch #\\) (lp (cons (read-char in) ls))) + (else (lp (cons ch ls))))))) + +(define (read-symbol in ls) + (do ((ls ls (cons c ls)) (c (peek-char in) (peek-char in))) + ((char-delimiter? c) (string->symbol (list->string (reverse ls)))) + (read-char in))) + +(define (scrib-read in) + (define ch (read-char in)) + (cond + ((eof-object? ch) ch) + ((char-whitespace? ch) (scrib-read in)) + (else + (case ch + ((#\( #\[ #\{) + (let lp ((res '())) + (let ((x (scrib-read in))) + (cond ((eof-object? x) (error "unterminated list" x)) + ((eq? x scribble-close) (reverse res)) + ((eq? x scribble-dot) + (let ((y (scrib-read in))) + (if (or (eof-object? y) (eq? y scribble-close)) + (error "unterminated dotted list") + (let ((z (scrib-read in))) + (if (not (eq? z scribble-close)) + (error "dot in non-terminal position in list" y z) + (append (reverse res) y)))))) + (else (lp (cons x res))))))) + ((#\} #\] #\)) scribble-close) + ((#\.) (if (char-delimiter? (peek-char in)) scribble-dot (read-float-tail in 0.0))) + ((#\') (list 'quote (scrib-read in))) + ((#\`) (list 'quasiquote (scrib-read in))) + ((#\,) (list (if-peek-char #\@ in 'unquote-splicing 'unquote) (scrib-read in))) + ((#\@) (scribble-parse-escape in #\@)) + ((#\;) (skip-line in) (scrib-read in)) + ((#\|) (string->symbol (read-escaped in #\|))) + ((#\") (read-escaped in #\")) + ((#\+ #\-) + (cond ((char-numeric? (peek-char in)) + ((if (eqv? ch #\+) + -) 0 (read-number in 0 10))) + (else (read-symbol in (list ch))))) + ((#\#) + (case (peek-char in) + ((#\t #\f) (eqv? (read-char in) #\t)) + ((#\() (list->vector (scrib-read in))) + ((#\\) + (read-char in) + (if (char-alphabetic? (peek-char in)) + (let ((name (scrib-read in))) + (case name + ((space) #\space) ((newline) #\newline) + (else (string-ref (symbol->string name) 0)))) + (read-char in))) + (else (error "unknown # syntax")))) + (else + (if (char-numeric? ch) + (read-number in (char-digit ch) 10) + (read-symbol in (list ch)))))))) + +(define (scribble-read in) + (let ((res (scrib-read in))) + (cond ((eq? res scribble-dot) (error "invalid . in source")) + ((eq? res scribble-close) (error "too many )'s")) + (else res)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; scribble parser + +(define (read-punctuation in) + (if (not (eqv? #\| (peek-char in))) + '() + (let lp ((ls '())) + (let ((c (peek-char in))) + (cond ((or (eof-object? c) (not(char-punctuation? c))) ls) + (else (lp (cons (char-mirror (read-char in)) ls)))))))) + +(define (read-prefix-wrapper in) + (let lp ((wrap (lambda (x) x))) + (case (peek-char in) + ((#\') (read-char in) (lp (lambda (x) (wrap (list 'quote x))))) + ((#\`) (read-char in) (lp (lambda (x) (wrap (list 'quasiquote x))))) + ((#\,) + (read-char in) + (cond ((eqv? #\@ (peek-char in)) + (read-char in) + (lp (lambda (x) (wrap (list 'unquote-splicing x))))) + (else (lp (lambda (x) (wrap (list 'unquote x))))))) + (else wrap)))) + +(define (scribble-parse-escape in ec) + (define bracket-char #\[) + (define brace-char #\{) + (let* ((wrap (read-prefix-wrapper in)) + (c (peek-char in)) + (cmd (if (or (eqv? c bracket-char) (eqv? c brace-char)) '() (list (scribble-read in)))) + (data? (eqv? (peek-char in) bracket-char)) + (data (if data? (scribble-read in) '())) + (punc (read-punctuation in)) + (body? (eqv? (peek-char in) brace-char)) + (body (cond (body? (read-char in) (scribble-parse in punc ec)) (else '())))) + (wrap (if (or data? body?) (append cmd data body) (car cmd))))) + +(define (scribble-parse in . o) + (define init-punc (if (pair? o) (car o) '())) + (define escape-char (if (and (pair? o) (pair? (cdr o))) (cadr o) #\@)) + (define comment-char #\;) + (define bracket-char #\[) + (define brace-char #\{) + (define close-bracket-char (char-mirror bracket-char)) + (define close-brace-char (char-mirror brace-char)) + (define (collect str res) + (if (pair? str) (cons (list->string (reverse str)) res) res)) + (define (skip-space in) + (let ((ch (peek-char in))) + (cond ((char-whitespace? ch) (read-char in) (skip-space in)) + ((eqv? ch #\;) (skip-line in) (skip-space in))))) + (define (tok str res punc depth) + (let ((c (read-char in))) + (cond + ((eof-object? c) + (if (zero? depth) + (reverse (collect str res)) + (error "unterminated expression" punc))) + ((and (eqv? c escape-char) (list-prefix? punc str)) + (let ((c (peek-char in))) + (cond + ((eof-object? c) + (tok str res punc depth)) + ((char-whitespace? c) + (tok (cons c str) res punc depth)) + ((eqv? c comment-char) + (read-char in) + (cond ((eqv? brace-char (peek-char in)) + (scribble-parse-escape in escape-char)) + (else + (skip-line in) + (let lp () + (cond ((char-whitespace? (peek-char in)) (read-char in) (lp)))))) + (tok str res punc depth)) + ((eqv? c #\|) + (read-char in) + (let lp ((ls (collect str res))) + (skip-space in) + (cond ((eqv? #\| (peek-char in)) (read-char in) (tok '() ls punc depth)) + (else (lp (cons (scribble-read in) ls)))))) + (else + (let ((str (drop str (length punc))) + (x (scribble-parse-escape in escape-char))) + (if (string? x) + (tok (append (reverse (string->list x)) str) res punc depth) + (tok '() (cons x (collect str res)) punc depth))))))) + ((eqv? c brace-char) + (tok (cons c str) res punc (+ depth 1))) + ((eqv? c close-brace-char) + (cond + ((zero? depth) + (let lp ((p punc) (ls '())) + (cond ((null? p) + (reverse (collect str res))) + ((not (eqv? (car p) (peek-char in))) + (tok (append ls (cons c str)) res punc (- depth 1))) + (else + (lp (cdr p) (cons (read-char in) ls)))))) + (else (tok (cons c str) res punc (- depth 1))))) + ((eqv? c #\newline) + (let* ((first? (and (null? res) (null? str))) + (res (collect (drop-while char-whitespace? str) res)) + (res (if (or first? (eqv? #\} (peek-char in))) + res + (cons "\n" res)))) + (let lp ((ls '())) + (let ((c (peek-char in))) + (cond + ((char-whitespace? c) (read-char in) (lp (cons c ls))) + (else (tok (if (eqv? c #\}) ls '()) res punc depth))))))) + (else + (tok (cons c str) res punc depth))))) + ;; begin + (tok '() '() init-punc 0)) diff --git a/lib/chibi/signal.c b/lib/chibi/signal.c new file mode 100644 index 00000000..7202d96e --- /dev/null +++ b/lib/chibi/signal.c @@ -0,0 +1,76 @@ +/* signal.c -- process signals interface */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define SEXP_MAX_SIGNUM 32 + +static sexp sexp_signal_contexts[SEXP_MAX_SIGNUM]; + +static struct sigaction call_sigaction, call_sigdefault, call_sigignore; + +static void sexp_call_sigaction (int signum, siginfo_t *info, void *uctx) { + sexp ctx; +#if ! SEXP_USE_GREEN_THREADS + sexp sigctx, handler; + sexp_gc_var1(args); +#endif + ctx = sexp_signal_contexts[signum]; + if (ctx) { +#if SEXP_USE_GREEN_THREADS + sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = + (sexp) ((sexp_uint_t)sexp_global(ctx, SEXP_G_THREADS_SIGNALS) + | (sexp_uint_t)sexp_make_fixnum(1UL< 0 + && sexp_unbox_fixnum(signum) < SEXP_MAX_SIGNUM)) + return sexp_xtype_exception(ctx, self, "not a valid signal number", signum); + if (! (sexp_procedurep(newaction) || sexp_opcodep(newaction) + || sexp_booleanp(newaction))) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, newaction); + if (! sexp_vectorp(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS))) + sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS) + = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_MAX_SIGNUM), SEXP_FALSE); + oldaction = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum); + res = sigaction(sexp_unbox_fixnum(signum), + (sexp_booleanp(newaction) ? + (sexp_truep(newaction) ? &call_sigdefault : &call_sigignore) + : &call_sigaction), + NULL); + if (res) + return sexp_user_exception(ctx, self, "couldn't set signal", signum); + sexp_vector_set(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum, newaction); + sexp_signal_contexts[sexp_unbox_fixnum(signum)] = ctx; + return oldaction; +} + +static void sexp_init_signals (sexp ctx, sexp env) { + call_sigaction.sa_sigaction = sexp_call_sigaction; +#if SEXP_USE_GREEN_THREADS + call_sigaction.sa_flags = SA_SIGINFO | SA_RESTART /* | SA_NODEFER */; + sigfillset(&call_sigaction.sa_mask); +#else + call_sigaction.sa_flags = SA_SIGINFO | SA_RESTART | SA_NODEFER; +#endif + call_sigdefault.sa_handler = SIG_DFL; + call_sigignore.sa_handler = SIG_IGN; + memset(sexp_signal_contexts, 0, sizeof(sexp_signal_contexts)); +} diff --git a/lib/chibi/stty.module b/lib/chibi/stty.module new file mode 100644 index 00000000..4540cb18 --- /dev/null +++ b/lib/chibi/stty.module @@ -0,0 +1,11 @@ + +(define-module (chibi stty) + (export stty with-stty with-raw-io + get-terminal-width get-terminal-dimensions + TCSANOW TCSADRAIN TCSAFLUSH) + (import-immutable (scheme) + (srfi 33) + (srfi 69)) + (include-shared "stty") + (include "stty.scm")) + diff --git a/lib/chibi/stty.scm b/lib/chibi/stty.scm new file mode 100644 index 00000000..b4aee004 --- /dev/null +++ b/lib/chibi/stty.scm @@ -0,0 +1,235 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; symbolic representation of attributes + +(define stty-lookup (make-hash-table eq?)) + +(for-each + (lambda (c) + (let ((type (cadr c)) + (value (caddr c))) + (hash-table-set! stty-lookup (car c) (cdr c)))) + + ;; ripped from the stty man page, then trimmed down to what seemed + ;; available on most systems + + `(;; characters + ;;(dsusp char ,VDSUSP) ; CHAR will send a terminal stop signal + (eof char ,VEOF) ; CHAR will send an EOF (terminate input) + (eol char ,VEOL) ; CHAR will end the line + (eol2 char ,VEOL2) ; alternate CHAR for ending the line + (erase char ,VERASE) ; CHAR will erase the last character typed + (intr char ,VINTR) ; CHAR will send an interrupt signal + (kill char ,VKILL) ; CHAR will erase the current line + (lnext char ,VLNEXT) ; CHAR will enter the next character quoted + (quit char ,VQUIT) ; CHAR will send a quit signal + (rprnt char ,VREPRINT) ; CHAR will redraw the current line + (start char ,VSTART) ; CHAR will restart output after stopping it + (stop char ,VSTOP) ; CHAR will stop the output + (susp char ,VSUSP) ; CHAR will send a terminal stop signal + (werase char ,VWERASE) ; CHAR will erase the last word typed + + ;; special settings + (cols special #f) ; tell the kernel that the terminal has N columns + (columns special #f) ; same as cols N + (ispeed special #f) ; set the input speed to N + (line special #f) ; use line discipline N + (min special #f) ; with -icanon, set N characters minimum for a completed read + (ospeed special #f) ; set the output speed to N + (rows special #f) ; tell the kernel that the terminal has N rows + (size special #f) ; print the number of rows and columns according to the kernel + (speed special #f) ; print the terminal speed + (time special #f) ; with -icanon, set read timeout of N tenths of a second + + ;; control settings + (clocal control ,CLOCAL) ; disable modem control signals + (cread control ,CREAD) ; allow input to be received + (crtscts control ,CRTSCTS) ; enable RTS/CTS handshaking + (cs5 control ,CS5) ; set character size to 5 bits + (cs6 control ,CS6) ; set character size to 6 bits + (cs7 control ,CS7) ; set character size to 7 bits + (cs8 control ,CS8) ; set character size to 8 bits + (cstopb control ,CSTOPB) ; use two stop bits per character (one with `-') + (hup control ,HUPCL) ; send a hangup signal when the last process closes the tty + (hupcl control ,HUPCL) ; same as [-]hup + (parenb control ,PARENB) ; generate parity bit in output and expect parity bit in input + (parodd control ,PARODD) ; set odd parity (even with `-') + + ;; input settings + (brkint input ,BRKINT) ; breaks cause an interrupt signal + (icrnl input ,ICRNL) ; translate carriage return to newline + (ignbrk input ,IGNBRK) ; ignore break characters + (igncr input ,IGNCR) ; ignore carriage return + (ignpar input ,IGNPAR) ; ignore characters with parity errors + (imaxbel input ,IMAXBEL) ; * beep and do not flush a full input buffer on a character + (inlcr input ,INLCR) ; translate newline to carriage return + (inpck input ,INPCK) ; enable input parity checking + (istrip input ,ISTRIP) ; clear high (8th) bit of input characters + ;;(iuclc input ,IUCLC) ; * translate uppercase characters to lowercase + (ixany input ,IXANY) ; * let any character restart output, not only start character + (ixoff input ,IXOFF) ; enable sending of start/stop characters + (ixon input ,IXON) ; enable XON/XOFF flow control + (parmrk input ,PARMRK) ; mark parity errors (with a 255-0-character sequence) + (tandem input ,IXOFF) ; same as [-]ixoff + + ;; output settings + ;;(bs0 output ,BS0) ; backspace delay style, N in [0..1] + ;;(bs1 output ,BS1) ; backspace delay style, N in [0..1] + ;;(cr0 output ,CR0) ; carriage return delay style, N in [0..3] + ;;(cr1 output ,CR1) ; carriage return delay style, N in [0..3] + ;;(cr2 output ,CR2) ; carriage return delay style, N in [0..3] + ;;(cr3 output ,CR3) ; carriage return delay style, N in [0..3] + ;;(ff0 output ,FF0) ; form feed delay style, N in [0..1] + ;;(ff1 output ,FF1) ; form feed delay style, N in [0..1] + ;;(nl0 output ,NL0) ; newline delay style, N in [0..1] + ;;(nl1 output ,NL1) ; newline delay style, N in [0..1] + (ocrnl output ,OCRNL) ; translate carriage return to newline + ;;(ofdel output ,OFDEL) ; use delete characters for fill instead of null characters + ;;(ofill output ,OFILL) ; use fill (padding) characters instead of timing for delays + ;;(olcuc output ,OLCUC) ; translate lowercase characters to uppercase + (onlcr output ,ONLCR) ; translate newline to carriage return-newline + (onlret output ,ONLRET) ; newline performs a carriage return + (onocr output ,ONOCR) ; do not print carriage returns in the first column + (opost output ,OPOST) ; postprocess output + (tab0 output #f) ; horizontal tab delay style, N in [0..3] + (tab1 output #f) ; horizontal tab delay style, N in [0..3] + (tab2 output #f) ; horizontal tab delay style, N in [0..3] + (tab3 output #f) ; horizontal tab delay style, N in [0..3] + (tabs output #f) ; same as tab0 + ;;(-tabs output #f) ; same as tab3 + ;;(vt0 output ,VT0) ; vertical tab delay style, N in [0..1] + ;;(vt1 output ,VT1) ; vertical tab delay style, N in [0..1] + + ;; local settings + (crterase local ,ECHOE) ; echo erase characters as backspace-space-backspace + (crtkill local ,ECHOKE) ; kill all line by obeying the echoprt and echoe settings + ;;(-crtkill local #f) ; kill all line by obeying the echoctl and echok settings + (ctlecho local ,ECHOCTL) ; echo control characters in hat notation (`^c') + (echo local ,ECHO) ; echo input characters + (echoctl local ,ECHOCTL) ; same as [-]ctlecho + (echoe local ,ECHOE) ; same as [-]crterase + ;;(echok local ,ECHOK) ; echo a newline after a kill character + (echoke local ,ECHOKE) ; same as [-]crtkill + (echonl local ,ECHONL) ; echo newline even if not echoing other characters + (echoprt local ,ECHOPRT) ; echo erased characters backward, between `\' and '/' + (icanon local ,ICANON) ; enable erase, kill, werase, and rprnt special characters + ;;(iexten local ,IEXTEN) ; enable non-POSIX special characters + (isig local ,ISIG) ; enable interrupt, quit, and suspend special characters + (noflsh local ,NOFLSH) ; disable flushing after interrupt and quit special characters + (prterase local ,ECHOPRT) ; same as [-]echoprt + (tostop local ,TOSTOP) ; stop background jobs that try to write to the terminal + ;;(xcase local ,XCASE) ; with icanon, escape with `\' for uppercase characters + + ;; combination settings + (LCASE combine (lcase)) + (cbreak combine (not icanon)) + (cooked combine (brkint ignpar istrip icrnl ixon opost isig icanon)) + ; also eof and eol characters + ; to their default values + (crt combine (echoe echoctl echoke)) + (dec combine (echoe echoctl echoke (not ixany))) + ; also intr ^c erase 0177 kill ^u + (decctlq combine (ixany)) + (ek combine ()) ; erase and kill characters to their default values + (evenp combine (parenb (not parodd) cs7)) + ;;(-evenp combine #f) ; same as -parenb cs8 + (lcase combine (xcase iuclc olcuc)) + (litout combine (cs8 (not parenb istrip opost))) + ;;(-litout combine #f) ; same as parenb istrip opost cs7 + (nl combine (not icrnl onlcr)) + ;;(-nl combine #f) ; same as icrnl -inlcr -igncr onlcr -ocrnl -onlret + (oddp combine (parenb parodd cs7)) + (parity combine (evenp)) ; same as [-]evenp + (pass8 combine (cs8 (not parenb istrip))) + ;;(-pass8 combine #f) ; same as parenb istrip cs7 + (raw combine (not ignbrk brkint ignpar parmrk + inpck istrip inlcr igncr icrnl)) + (ixon combine (ixoff ixany imaxbel opost isig icanon)) ;; xcase iuclc + ;;(time combine #f) ; 0 + ;;(-raw combine #f) ; same as cooked + (sane combine (cread brkint icrnl imaxbel opost onlcr + isig icanon ;; nl0 cr0 bs0 vt0 ff0 ; tab0 + echo echoe echoctl echoke ;; iexten echok + (not ignbrk igncr ixoff ixany inlcr ;; iuclc + ocrnl onocr onlret ;; olcuc ofill ofdel + echonl noflsh tostop echoprt))) ;; xcase + ; plus all special characters to + ; their default values + )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; high-level interface + +(define (port? x) (or (input-port? x) (output-port? x))) + +(define (stty . args) + (let* ((port (if (and (pair? args) (port? (car args))) + (car args) + (current-output-port))) + (attr (get-terminal-attributes port))) + ;; parse change requests + (let lp ((lst (if (and (pair? args) (port? (car args))) (cdr args) args)) + (iflag (term-attrs-iflag attr)) + (oflag (term-attrs-oflag attr)) + (cflag (term-attrs-cflag attr)) + (lflag (term-attrs-lflag attr)) + (invert? #f) + (return (lambda (iflag oflag cflag lflag) + (term-attrs-iflag-set! attr iflag) + (term-attrs-oflag-set! attr oflag) + (term-attrs-cflag-set! attr cflag) + (term-attrs-lflag-set! attr lflag) + (set-terminal-attributes! port TCSANOW attr)))) + (define (join old new) + (if invert? (bitwise-and old (bitwise-not new)) (bitwise-ior old new))) + (cond + ((pair? lst) + (let ((command (car lst))) + (cond + ((pair? command) ;; recurse on sub-expr + (lp command iflag oflag cflag lflag invert? + (lambda (i o c l) (lp (cdr lst) i o c l invert? return)))) + ((eq? command 'not) ;; toggle current setting + (lp (cdr lst) iflag oflag cflag lflag (not invert?) return)) + (else + (let ((x (hash-table-ref/default stty-lookup command #f))) + (case (and x (car x)) + ((input) + (lp (cdr lst) (join iflag (cadr x)) oflag cflag lflag invert? return)) + ((output) + (lp (cdr lst) iflag (join oflag (cadr x)) cflag lflag invert? return)) + ((control) + (lp (cdr lst) iflag oflag (join cflag (cadr x)) lflag invert? return)) + ((local) + (lp (cdr lst) iflag oflag cflag (join lflag (cadr x)) invert? return)) + ((char) + ;;(term-attrs-cc-set! attr (cadr x) (or (cadr lst) 0)) + (lp (cddr lst) iflag oflag cflag lflag invert? return)) + ((combine) + (lp (cadr x) iflag oflag cflag lflag invert? + (lambda (i o c l) (lp (cdr lst) i o c l invert? return)))) + ((special) + (error "special settings not yet supported" command)) + (else + (error "unknown stty command" command)))))))) + (else + (return iflag oflag cflag lflag)))))) + +(define (with-stty setting thunk . o) + (let* ((port (if (pair? o) (car o) (current-input-port))) + (orig-attrs (get-terminal-attributes port))) + (dynamic-wind + (lambda () (stty setting)) + thunk + (lambda () (set-terminal-attributes! port TCSANOW orig-attrs))))) + +(define (with-raw-io port thunk) + (with-stty '(not icanon echo) thunk port)) + +(define (get-terminal-width x) + (let ((ws (ioctl x TIOCGWINSZ))) + (and ws (winsize-col ws)))) + +(define (get-terminal-dimensions x) + (let ((ws (ioctl x TIOCGWINSZ))) + (and ws (list (winsize-col ws) (winsize-row ws))))) diff --git a/lib/chibi/stty.stub b/lib/chibi/stty.stub new file mode 100644 index 00000000..3c5939c5 --- /dev/null +++ b/lib/chibi/stty.stub @@ -0,0 +1,106 @@ + +(c-system-include "termios.h") +(c-system-include "sys/ioctl.h") + +(define-c-struct termios + predicate: term-attrs? + constructor: (make-term-attrs) + (unsigned-long c_iflag term-attrs-iflag term-attrs-iflag-set!) + (unsigned-long c_oflag term-attrs-oflag term-attrs-oflag-set!) + (unsigned-long c_cflag term-attrs-cflag term-attrs-cflag-set!) + (unsigned-long c_lflag term-attrs-lflag term-attrs-lflag-set!) + ;;(unsigned-char (c_cc 22) term-attrs-cc term-attrs-cc-set!) + (unsigned-long c_ispeed term-attrs-ispeed term-attrs-ispeed-set!) + (unsigned-long c_ospeed term-attrs-ospeed term-attrs-ospeed-set!)) + +(define-c-struct winsize + predicate: winsize? + (unsigned-short ws_row winsize-row) + (unsigned-short ws_col winsize-col)) + +(define-c errno ioctl (port-or-fd unsigned-long (result winsize))) + +(define-c-const int TIOCGWINSZ) + +(define-c-const int TCSANOW) +(define-c-const int TCSADRAIN) +(define-c-const int TCSAFLUSH) + +(define-c-const unsigned-long IGNBRK) +(define-c-const unsigned-long BRKINT) +(define-c-const unsigned-long IGNPAR) +(define-c-const unsigned-long PARMRK) +(define-c-const unsigned-long INPCK) +(define-c-const unsigned-long ISTRIP) +(define-c-const unsigned-long INLCR) +(define-c-const unsigned-long IGNCR) +(define-c-const unsigned-long ICRNL) +(define-c-const unsigned-long IXON) +(define-c-const unsigned-long IXOFF) +(define-c-const unsigned-long IXANY) +(define-c-const unsigned-long IMAXBEL) +;; (define-c-const unsigned-long IUCLC) + +(define-c-const unsigned-long OPOST) +(define-c-const unsigned-long ONLCR) +;; (define-c-const unsigned-long OXTABS) +;; (define-c-const unsigned-long ONOEOT) +(define-c-const unsigned-long OCRNL) +;; (define-c-const unsigned-long OLCUC) +(define-c-const unsigned-long ONOCR) +(define-c-const unsigned-long ONLRET) + +(define-c-const unsigned-long CSIZE) +(define-c-const unsigned-long CS5) +(define-c-const unsigned-long CS6) +(define-c-const unsigned-long CS7) +(define-c-const unsigned-long CS8) +(define-c-const unsigned-long CSTOPB) +(define-c-const unsigned-long CREAD) +(define-c-const unsigned-long PARENB) +(define-c-const unsigned-long PARODD) +(define-c-const unsigned-long HUPCL) +(define-c-const unsigned-long CLOCAL) +;; (define-c-const unsigned-long CCTS_OFLOW) +(define-c-const unsigned-long CRTSCTS) +;; (define-c-const unsigned-long CRTS_IFLOW) +;; (define-c-const unsigned-long MDMBUF) + +(define-c-const unsigned-long ECHOKE) +(define-c-const unsigned-long ECHOE) +(define-c-const unsigned-long ECHO) +(define-c-const unsigned-long ECHONL) +(define-c-const unsigned-long ECHOPRT) +(define-c-const unsigned-long ECHOCTL) +(define-c-const unsigned-long ISIG) +(define-c-const unsigned-long ICANON) +;; (define-c-const unsigned-long ALTWERASE) +(define-c-const unsigned-long IEXTEN) +;; (define-c-const unsigned-long EXTPROC) +(define-c-const unsigned-long TOSTOP) +(define-c-const unsigned-long FLUSHO) +;; (define-c-const unsigned-long NOKERNINFO) +(define-c-const unsigned-long PENDIN) +(define-c-const unsigned-long NOFLSH) + +(define-c-const unsigned-long VEOF) +(define-c-const unsigned-long VEOL) +(define-c-const unsigned-long VEOL2) +(define-c-const unsigned-long VERASE) +;; (define-c-const unsigned-long VERASE2) +(define-c-const unsigned-long VWERASE) +(define-c-const unsigned-long VINTR) +(define-c-const unsigned-long VKILL) +(define-c-const unsigned-long VQUIT) +(define-c-const unsigned-long VSUSP) +(define-c-const unsigned-long VSTART) +(define-c-const unsigned-long VSTOP) +;; (define-c-const unsigned-long VDSUSP) +(define-c-const unsigned-long VLNEXT) +(define-c-const unsigned-long VREPRINT) +;; (define-c-const unsigned-long VSTATUS) + +(define-c errno (get-terminal-attributes "tcgetattr") + (port-or-fd (result termios))) +(define-c errno (set-terminal-attributes! "tcsetattr") + (port-or-fd int termios)) diff --git a/lib/chibi/system.module b/lib/chibi/system.module new file mode 100644 index 00000000..adc26ddc --- /dev/null +++ b/lib/chibi/system.module @@ -0,0 +1,15 @@ + +(define-module (chibi system) + (export user-information user-name user-password + user-id user-group-id user-gecos user-home user-shell + current-user-id current-group-id + current-effective-user-id current-effective-group-id + set-current-user-id! set-current-effective-user-id! + set-current-group-id! set-current-effective-group-id! + current-session-id create-session + set-root-directory!) + (import-immutable (scheme)) + (include-shared "system") + ;;(include "system.scm") + ) + diff --git a/lib/chibi/system.stub b/lib/chibi/system.stub new file mode 100644 index 00000000..7d4a836f --- /dev/null +++ b/lib/chibi/system.stub @@ -0,0 +1,34 @@ + +(c-system-include "unistd.h") +(c-system-include "pwd.h") +(c-system-include "sys/types.h") + +(define-c-struct passwd + predicate: user? + (string pw_name user-name) + (string pw_passwd user-password) + (uid_t pw_uid user-id) + (gid_t pw_gid user-group-id) + (string pw_gecos user-gecos) + (string pw_dir user-home) + (string pw_shell user-shell)) + +(define-c uid_t (current-user-id "getuid") ()) +(define-c gid_t (current-group-id "getgid") ()) +(define-c uid_t (current-effective-user-id "geteuid") ()) +(define-c gid_t (current-effective-group-id "getegid") ()) + +(define-c errno (set-current-user-id! "setuid") (uid_t)) +(define-c errno (set-current-effective-user-id! "seteuid") (uid_t)) +(define-c errno (set-current-group-id! "setgid") (gid_t)) +(define-c errno (set-current-effective-group-id! "setegid") (gid_t)) + +(define-c pid_t (current-session-id "getsid") ((default 0 pid_t))) +(define-c pid_t (create-session "setsid") ()) + +(define-c errno (set-root-directory! "chroot") (string)) + +;; (define-c errno getpwuid_r +;; (uid_t (result passwd) (result (array char arg3)) +;; (value 256 int) (result pointer passwd))) + diff --git a/lib/chibi/term/edit-line.module b/lib/chibi/term/edit-line.module new file mode 100644 index 00000000..d8116473 --- /dev/null +++ b/lib/chibi/term/edit-line.module @@ -0,0 +1,5 @@ + +(define-module (chibi term edit-line) + (export edit-line edit-line-repl) + (import-immutable (scheme) (chibi stty) (srfi 9)) + (include "edit-line.scm")) diff --git a/lib/chibi/term/edit-line.scm b/lib/chibi/term/edit-line.scm new file mode 100644 index 00000000..1c985919 --- /dev/null +++ b/lib/chibi/term/edit-line.scm @@ -0,0 +1,505 @@ +;;;; edit-line.scm - pure scheme line editing tool +;; +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; vt100 terminal utilities + +(define (terminal-escape out ch arg) + (write-char (integer->char 27) out) + (write-char #\[ out) + (if arg (display arg out)) + (write-char ch out)) + +;; we use zero-based columns +(define (terminal-goto-col out n) (terminal-escape out #\G (+ n 1))) +(define (terminal-up out n) (terminal-escape out #\A n)) +(define (terminal-down out n) (terminal-escape out #\B n)) +(define (terminal-clear-below out) (terminal-escape out #\J #f)) +(define (terminal-clear-right out) (terminal-escape out #\K #f)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; history + +(define maximum-history-size 128) + +(define-record-type history + (%make-history remaining past future) + history? + (remaining history-remaining history-remaining-set!) + (past history-past history-past-set!) + (future history-future history-future-set!)) + +(define (make-history . o) + (%make-history (if (pair? o) (car o) maximum-history-size) '() '())) + +(define (history-current h) + (let ((p (history-past h))) + (and (pair? p) (car p)))) + +(define (history->list h) + (let ((past (history-past h)) (future (history-future h))) + (if (pair? past) (cons (car past) (append future (cdr past))) future))) + +(define (history-flatten! h) + (history-past-set! h (history->list h)) + (history-future-set! h '())) + +(define (drop-last ls) (reverse (cdr (reverse ls)))) + +(define (history-past-push! h x) + (if (positive? (history-remaining h)) + (history-remaining-set! h (- (history-remaining h) 1)) + (if (pair? (history-past h)) + (history-past-set! h (drop-last (history-past h))) + (history-future-set! h (drop-last (history-future h))))) + (history-past-set! h (cons x (history-past h)))) + +(define (history-insert! h x) + (history-flatten! h) + (history-past-push! h x)) + +(define (history-commit! h x) + (cond + ((pair? (history-future h)) + (history-past-set! + h (cons x (append (drop-last (history-future h)) (history-past h)))) + (history-future-set! h '())) + (else + (history-insert! h x)))) + +(define (history-prev! h) + (let ((past (history-past h))) + (and (pair? past) + (pair? (cdr past)) + (begin + (history-future-set! h (cons (car past) (history-future h))) + (history-past-set! h (cdr past)) + (cadr past))))) + +(define (history-next! h) + (let ((future (history-future h))) + (and (pair? future) + (begin + (history-past-set! h (cons (car future) (history-past h))) + (history-future-set! h (cdr future)) + (car future))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; char and string utils + +(define (char-word-constituent? ch) + (or (char-alphabetic? ch) (char-numeric? ch) + (memv ch '(#\_ #\- #\+ #\:)))) + +(define (char-non-word-constituent? ch) (not (char-word-constituent? ch))) + +(define (string-copy! dst dstart src start end) + (if (>= start dstart) + (do ((i start (+ i 1)) (j dstart (+ j 1))) + ((= i end)) + (string-set! dst j (string-ref src i))) + (do ((i (- end 1) (- i 1)) (j (+ dstart (- end start 1)) (- j 1))) + ((< i start)) + (string-set! dst j (string-ref src i))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; buffers + +(define-record-type buffer + (%make-buffer refresh? min pos row max-row col gap width string history) + buffer? + (refresh? buffer-refresh? buffer-refresh?-set!) + (min buffer-min buffer-min-set!) + (pos buffer-pos buffer-pos-set!) + (row buffer-row buffer-row-set!) + (max-row buffer-max-row buffer-max-row-set!) + (col buffer-col buffer-col-set!) + (gap buffer-gap buffer-gap-set!) + (width buffer-width buffer-width-set!) + (string buffer-string buffer-string-set!) + (kill-ring buffer-kill-ring buffer-kill-ring-set!) + (history buffer-history buffer-history-set!)) + +(define default-buffer-size 256) +(define default-buffer-width 80) + +(define (make-buffer) + (%make-buffer #f 0 0 0 0 0 default-buffer-size default-buffer-width + (make-string default-buffer-size) '())) + +(define (buffer->string buf) + (let ((str (buffer-string buf))) + (string-append (substring str (buffer-min buf) (buffer-pos buf)) + (substring str (buffer-gap buf) (string-length str))))) + +(define (buffer-right-length buf) + (- (string-length (buffer-string buf)) (buffer-gap buf))) +(define (buffer-length buf) + (+ (buffer-pos buf) (buffer-right-length buf))) +(define (buffer-free-space buf) + (- (buffer-gap buf) (buffer-pos buf))) + +(define (buffer-clamp buf n) + (max (buffer-min buf) (min n (buffer-length buf)))) + +(define (buffer-resize buf n) + (cond ((<= (buffer-free-space buf) n) + (let* ((right-len (buffer-right-length buf)) + (new-len (* 2 (max n (buffer-length buf)))) + (new-gap (- new-len right-len)) + (new (make-string new-len)) + (old (buffer-string buf))) + (string-copy! new 0 old 0 (buffer-pos buf)) + (string-copy! new new-gap old (buffer-gap buf) (string-length old)) + (buffer-string-set! buf new) + (buffer-gap-set! buf new-gap))))) + +(define (buffer-update-position! buf) + (let ((pos (buffer-pos buf)) + (gap (buffer-gap buf)) + (end (string-length (buffer-string buf))) + (width (buffer-width buf))) + (let lp ((i 0) (row 0) (col 0)) ;; update row/col + (cond ((= i pos) + (buffer-row-set! buf row) + (buffer-col-set! buf col) + (lp gap row col)) + ((>= i end) + (buffer-max-row-set! + buf (if (and (zero? col) (> row 0)) (- row 1) row))) + ((= (+ col 1) width) + (lp (+ i 1) (+ row 1) 0)) + (else + (lp (+ i 1) row (+ col 1))))))) + +(define (buffer-draw buf out) + (let* ((gap (buffer-gap buf)) + (str (buffer-string buf)) + (end (string-length str)) + (old-row (buffer-row buf)) + (old-col (buffer-col buf))) + (buffer-update-position! buf) + ;; goto start of input + (terminal-goto-col out 0) + (if (positive? old-row) + (terminal-up out old-row)) + ;; clear and display new buffer + (terminal-clear-below out) + (display (substring str 0 (buffer-pos buf)) out) + (display (substring str (buffer-gap buf) end) out) + ;; move to next line if point at eol + (if (and (zero? (buffer-col buf)) (positive? (buffer-row buf))) + (write-char #\space out)) + ;; move to correct row then col + (if (< (buffer-row buf) (buffer-max-row buf)) + (terminal-up out (- (buffer-max-row buf) (buffer-row buf)))) + (terminal-goto-col out (buffer-col buf)))) + +(define (buffer-refresh buf out) + (cond ((buffer-refresh? buf) + (buffer-draw buf out) + (buffer-refresh?-set! buf #f)))) + +(define (buffer-goto! buf out n) + (let ((pos (buffer-pos buf)) + (gap (buffer-gap buf)) + (str (buffer-string buf)) + (n (buffer-clamp buf n))) + (cond ((not (= n pos)) + (buffer-update-position! buf) ;; XXXX shouldn't be needed + (if (< n pos) + (string-copy! str (- gap (- pos n)) str n pos) + (string-copy! str pos str gap (+ gap (- n pos)))) + (buffer-pos-set! buf n) + (buffer-gap-set! buf (+ gap (- n pos))) + (cond + ((not (buffer-refresh? buf)) + (let ((old-row (buffer-row buf))) + (buffer-update-position! buf) + (let ((row-diff (- old-row (buffer-row buf)))) + (cond ((> row-diff 0) (terminal-up out row-diff)) + ((< row-diff 0) (terminal-down out (- row-diff))))) + (terminal-goto-col out (buffer-col buf))))))))) + +(define (buffer-insert! buf out x) + (let ((len (if (char? x) 1 (string-length x))) + (pos (buffer-pos buf))) + (buffer-resize buf len) + (if (char? x) + (string-set! (buffer-string buf) pos x) + (string-copy! (buffer-string buf) pos x 0 len)) + (buffer-pos-set! buf (+ (buffer-pos buf) len)) + (cond + ((buffer-refresh? buf)) + ((and (= (buffer-gap buf) (string-length (buffer-string buf))) + (< (+ (buffer-col buf) len) (buffer-width buf))) + ;; fast path - append to end of buffer w/o wrapping to next line + (display x out) + (buffer-col-set! buf (+ (buffer-col buf) len))) + (else + (buffer-refresh?-set! buf #t))))) + +(define (buffer-delete! buf out start end) + (let ((pos (buffer-pos buf)) + (gap (buffer-gap buf)) + (str (buffer-string buf)) + (start (buffer-clamp buf start)) + (end (buffer-clamp buf end))) + (if (not (buffer-refresh? buf)) + (if (and (= start pos) (>= end (buffer-length buf))) + (terminal-clear-below out) + (buffer-refresh?-set! buf #t))) + (cond ((< end pos) + (string-copy! str start str end pos) + (buffer-pos-set! buf (+ start (- pos end)))) + ((> start gap) + (string-copy! str start str gap (+ gap (- end start))) + (buffer-gap-set! buf (+ gap (- end start)))) + (else + (buffer-pos-set! buf (min pos start)) + (buffer-gap-set! buf (max gap (+ pos (- gap pos) (- end pos)))))))) + +(define (buffer-skip buf pred) + (let* ((str (buffer-string buf)) (end (string-length str))) + (let lp ((i (buffer-gap buf))) + (if (or (>= i end) (not (pred (string-ref str i)))) + (+ (- i (buffer-gap buf)) (buffer-pos buf)) + (lp (+ i 1)))))) + +(define (buffer-skip-reverse buf pred) + (let ((str (buffer-string buf))) + (let lp ((i (- (buffer-pos buf) 1))) + (if (or (< i 0) (not (pred (string-ref str i)))) i (lp (- i 1)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; keymaps + +(define keymap? pair?) + +(define (make-keymap . o) + (cons (make-vector 256 #f) (and (pair? o) (car o)))) + +(define (make-sparse-keymap . o) + (cons '() (and (pair? o) (car o)))) + +(define (make-printable-keymap) + (let* ((keymap (make-keymap)) + (v (car keymap))) + (do ((i #x20 (+ i 1))) ((= i #x7F) keymap) + (vector-set! v i command/self-insert)))) + +(define (make-standard-escape-bracket-keymap) + (let* ((keymap (make-keymap)) + (v (car keymap))) + (vector-set! v 65 command/backward-history) + (vector-set! v 66 command/forward-history) + (vector-set! v 67 command/forward-char) + (vector-set! v 68 command/backward-char) + keymap)) + +(define (make-standard-escape-keymap) + (let* ((keymap (make-keymap)) + (v (car keymap))) + (vector-set! v 8 command/backward-delete-word) + (vector-set! v 91 (make-standard-escape-bracket-keymap)) + (vector-set! v 98 command/backward-word) + (vector-set! v 100 command/forward-delete-word) + (vector-set! v 102 command/forward-word) + (vector-set! v 127 command/backward-delete-word) + keymap)) + +(define (make-standard-keymap) + (let* ((keymap (make-printable-keymap)) + (v (car keymap))) + (vector-set! v 1 command/beggining-of-line) + (vector-set! v 2 command/backward-char) + (vector-set! v 4 command/forward-delete-char) + (vector-set! v 5 command/end-of-line) + (vector-set! v 6 command/forward-char) + (vector-set! v 8 command/backward-delete-char) + (vector-set! v 10 command/enter) + (vector-set! v 11 command/forward-delete-line) + (vector-set! v 12 command/refresh) + (vector-set! v 13 command/enter) + (vector-set! v 21 command/backward-delete-line) + (vector-set! v 27 (make-standard-escape-keymap)) + (vector-set! v 127 command/backward-delete-char) + keymap)) + +(define (keymap-lookup keymap n) + (let ((table (car keymap))) + (or (if (vector? table) + (and (< n (vector-length table)) (vector-ref table n)) + (cond ((assv n table) => cdr) (else #f))) + (if (keymap? (cdr keymap)) + (keymap-lookup (cdr keymap) n) + (cdr keymap))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; commands + +(define (command/self-insert ch buf out return) + (buffer-insert! buf out ch)) + +(define (command/enter ch buf out return) + (command/end-of-line ch buf out return) + (newline out) + (return)) + +(define (command/beep ch buf out return) + (write-char (integer->char 7) out)) + +(define (command/refresh ch buf out return) + (buffer-draw buf out)) + +(define (command/beggining-of-line ch buf out return) + (buffer-goto! buf out 0)) + +(define (command/end-of-line ch buf out return) + (buffer-goto! buf out (buffer-length buf))) + +(define (command/forward-char ch buf out return) + (buffer-goto! buf out (+ (buffer-pos buf) 1))) + +(define (command/backward-char ch buf out return) + (buffer-goto! buf out (- (buffer-pos buf) 1))) + +(define (command/forward-delete-char ch buf out return) + (cond + ((zero? (- (buffer-length buf) (buffer-min buf))) + (newline out) + (return 'eof)) + (else + (buffer-delete! buf out (buffer-pos buf) (+ (buffer-pos buf) 1))))) + +(define (command/backward-delete-char ch buf out return) + (buffer-delete! buf out (- (buffer-pos buf) 1) (buffer-pos buf))) + +(define (command/forward-delete-line ch buf out return) + (buffer-delete! buf out (buffer-pos buf) (buffer-length buf))) + +(define (command/backward-delete-line ch buf out return) + (buffer-delete! buf out 0 (buffer-pos buf))) + +(define (command/backward-history ch buf out return) + (let ((history (buffer-history buf))) + (cond + ((and (history? history) (pair? (history-past history))) + (if (null? (history-future history)) + (history-insert! history (buffer->string buf))) + (cond + ((pair? (cdr (history-past history))) + (buffer-delete! buf out 0 (buffer-length buf)) + (buffer-insert! buf out (history-prev! history)))))))) + +(define (command/forward-history ch buf out return) + (let ((history (buffer-history buf))) + (cond + ((and (history? history) (pair? (history-future history))) + (buffer-delete! buf out 0 (buffer-length buf)) + (let ((res (buffer-insert! buf out (history-next! history)))) + (if (null? (history-future history)) + (history-past-set! history (cdr (history-past history)))) + res))))) + +(define (command/forward-word ch buf out return) + (buffer-goto! buf out (buffer-skip buf char-non-word-constituent?)) + (buffer-goto! buf out (buffer-skip buf char-word-constituent?))) + +(define (command/backward-word ch buf out return) + (buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?)) + (buffer-goto! buf out (+ (buffer-skip-reverse buf char-word-constituent?) 1))) + +(define (command/forward-delete-word ch buf out return) + (let ((start (buffer-pos buf))) + (buffer-goto! buf out (buffer-skip buf char-non-word-constituent?)) + (buffer-delete! buf out start (buffer-skip buf char-word-constituent?)))) + +(define (command/backward-delete-word ch buf out return) + (let ((end (buffer-pos buf))) + (buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?)) + (let ((start (buffer-skip-reverse buf char-word-constituent?))) + (buffer-delete! buf out (+ start 1) end)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; line-editing + +(define standard-keymap (make-standard-keymap)) + +(define (get-key ls key . o) + (let ((x (memq key ls))) + (if (and x (pair? (cdr x))) (cadr x) (and (pair? o) (car o))))) + +(define (with-leading-ports ls proc) + (if (and (pair? ls) (input-port? (car ls))) + (if (and (pair? (cdr ls)) (output-port? (cadr ls))) + (proc (car ls) (cadr ls) (cddr ls)) + (proc (car ls) (current-output-port) (cdr ls))) + (proc (current-input-port) (current-output-port) ls))) + +(define (make-line-editor . args) + (let* ((prompt (get-key args 'prompt: "> ")) + (history (get-key args 'history:)) + (terminal-width (get-key args 'terminal-width:)) + (keymap (get-key args 'keymap: standard-keymap))) + (lambda (in out) + (let* ((width (or terminal-width (get-terminal-width out))) + (buf (make-buffer)) + (done? #f) + (return (lambda o (set! done? (if (pair? o) (car o) #t))))) + (buffer-refresh?-set! buf #t) + (buffer-width-set! buf width) + (buffer-insert! buf out prompt) + (buffer-min-set! buf (string-length prompt)) + (buffer-history-set! buf history) + (buffer-refresh buf out) + (flush-output out) + ((if (get-key args 'no-stty?:) (lambda (out f) (f)) with-raw-io) + out + (lambda () + (let lp ((kmap keymap)) + (let ((ch (read-char in))) + (if (eof-object? ch) + (let ((res (buffer->string buf))) + (if (equal? res "") ch res)) + (let ((x (keymap-lookup kmap (char->integer ch)))) + (cond + ((keymap? x) + (lp x)) + ((procedure? x) + (x ch buf out return) + (buffer-refresh buf out) + (if done? + (and (not (eq? done? 'eof)) (buffer->string buf)) + (lp keymap))) + (else + ;;(command/beep ch buf out return) + (lp keymap))))))))))))) + +(define (edit-line . args) + (with-leading-ports + args + (lambda (in out rest) ((apply make-line-editor rest) in out)))) + +(define (edit-line-repl . args) + (with-leading-ports + args + (lambda (in out rest) + (let ((eval (get-key rest 'eval: (lambda (x) x))) + (print (get-key rest 'write: write)) + (history (or (get-key rest 'history:) (make-history)))) + (let ((edit-line + (apply make-line-editor 'no-stty?: #t 'history: history rest))) + ((if (get-key args 'no-stty?:) (lambda (out f) (f)) with-raw-io) + out + (lambda () + (let lp () + (let ((line (edit-line in out))) + (if (pair? (history-future history)) + (history-past-set! history (cdr (history-past history)))) + (history-commit! history line) + (print (eval line) out) + (newline out) + (lp)))))))))) diff --git a/lib/chibi/test.module b/lib/chibi/test.module new file mode 100644 index 00000000..d8b405f1 --- /dev/null +++ b/lib/chibi/test.module @@ -0,0 +1,14 @@ + +(define-module (chibi test) + (export + test test-error test-assert test-values + test-group current-test-group + test-begin test-end test-syntax-error test-info + test-vars test-run ;;test-exit + current-test-verbosity current-test-epsilon current-test-comparator + current-test-applier current-test-handler current-test-skipper + current-test-group-reporter test-failure-count) + (import-immutable (scheme)) + (import (srfi 39) (srfi 98) (chibi time) (chibi ast)) + (include "test.scm")) + diff --git a/lib/chibi/test.scm b/lib/chibi/test.scm new file mode 100644 index 00000000..bfa7429e --- /dev/null +++ b/lib/chibi/test.scm @@ -0,0 +1,662 @@ +;;;; test.scm -- testing framework +;; +;; Easy to use test suite adapted from the Chicken "test" module. +;; +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; exception utilities + +;; from SRFI-12, pending stabilization of an exception library for WG1 +(define-syntax handle-exceptions + (syntax-rules () + ((handle-exceptions exn handler body ...) + (call-with-current-continuation + (lambda (return) + (with-exception-handler + (lambda (exn) (return handler)) + (lambda () body ...))))))) + +(define (warning msg . args) + (display msg (current-error-port)) + (for-each (lambda (x) + (write-char #\space (current-error-port)) + (write x (current-error-port))) + args) + (newline (current-error-port))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utilities + +(define (string-search pat str) + (let* ((pat-len (string-length pat)) + (limit (- (string-length str) pat-len))) + (let lp1 ((i 0)) + (cond + ((>= i limit) #f) + (else + (let lp2 ((j i) (k 0)) + (cond ((>= k pat-len) #t) + ((not (eqv? (string-ref str j) (string-ref pat k))) + (lp1 (+ i 1))) + (else (lp2 (+ j 1) (+ k 1)))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; time utilities + +(define (timeval-difference tv1 tv2) + (let ((seconds (- (timeval-seconds tv1) (timeval-seconds tv2))) + (ms (- (timeval-microseconds tv1) (timeval-microseconds tv2)))) + (+ (max seconds 0.0) (/ ms 1000000.0)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; test interface + +(define-syntax test + (syntax-rules () + ((test expect expr) + (test #f expect expr)) + ((test name expect (expr ...)) + (test-info name expect (expr ...) ())) + ((test name (expect ...) expr) + (test-syntax-error + 'test + "the test expression should come last " + (test name (expect ...) expr))) + ((test name expect expr) + (test-info name expect expr ())) + ((test a ...) + (test-syntax-error 'test "2 or 3 arguments required" + (test a ...))))) + +(define-syntax test-assert + (syntax-rules () + ((_ expr) + (test-assert #f expr)) + ((_ name expr) + (test-info name #f expr ((assertion . #t)))) + ((test a ...) + (test-syntax-error 'test-assert "1 or 2 arguments required" + (test a ...))))) + +(define-syntax test-values + (syntax-rules () + ((_ expect expr) + (test-values #f expect expr)) + ((_ name expect expr) + (test name (call-with-values (lambda () expect) (lambda results results)) + (call-with-values (lambda () expr) (lambda results results)))))) + +(define-syntax test-error + (syntax-rules () + ((_ expr) + (test-error #f expr)) + ((_ name expr) + (test-info name #f expr ((expect-error . #t)))) + ((test a ...) + (test-syntax-error 'test-error "1 or 2 arguments required" + (test a ...))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; group interface + +(define-syntax test-group + (syntax-rules () + ((_ name-expr body ...) + (let ((name name-expr) + (old-group (current-test-group))) + (if (not (string? name)) + (error "a name is required, got " 'name-expr name)) + (test-begin name) + (handle-exceptions + exn + (begin + (warning "error in group outside of tests") + (print-exception e (current-error-port)) + (test-group-inc! (current-test-group) 'count) + (test-group-inc! (current-test-group) 'ERROR)) + body ...) + (test-end name) + (current-test-group old-group))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define-syntax test-syntax-error + (syntax-rules () + ((_) (syntax-error "invalid use of test-syntax-error")))) + +(define-syntax test-info + (syntax-rules () + ((test-info name expect expr info) + (test-vars () name expect expr ((source . expr) . info))))) + +(define-syntax test-vars + (syntax-rules () + ((_ (vars ...) n expect expr ((key . val) ...)) + (test-run (lambda () expect) + (lambda () expr) + (cons (cons 'name n) + '((source . expr) + ;;(var-names . (vars ...)) + ;;(var-values . ,(list vars)) + (key . val) ...)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; test-group representation + +;; (name (prop value) ...) +(define (make-test-group name) + (list name + (cons 'start-time (get-time-of-day)))) + +(define test-group-name car) + +(define (test-group-ref group field . o) + (apply assq-ref (cdr group) field o)) + +(define (test-group-set! group field value) + (cond ((assq field (cdr group)) + => (lambda (x) (set-cdr! x value))) + (else (set-cdr! group (cons (cons field value) (cdr group)))))) + +(define (test-group-inc! group field) + (cond ((assq field (cdr group)) + => (lambda (x) (set-cdr! x (+ 1 (cdr x))))) + (else (set-cdr! group (cons (cons field 1) (cdr group)))))) + +(define (test-group-push! group field value) + (cond ((assq field (cdr group)) + => (lambda (x) (set-cdr! x (cons value (cdr x))))) + (else (set-cdr! group (cons (cons field (list value)) (cdr group)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define (assq-ref ls key . o) + (cond ((assq key ls) => cdr) + ((pair? o) (car o)) + (else #f))) + +(define (approx-equal? a b epsilon) + (< (abs (- 1 (abs (if (zero? b) (+ 1 a) (/ a b))))) + epsilon)) + +;; partial pretty printing to abbreviate `quote' forms and the like +(define (write-to-string x) + (call-with-output-string + (lambda (out) + (let wr ((x x)) + (if (pair? x) + (cond + ((and (symbol? (car x)) (pair? (cdr x)) (null? (cddr x)) + (assq (car x) + '((quote . "'") (quasiquote . "`") + (unquote . ",") (unquote-splicing . ",@")))) + => (lambda (s) (display (cdr s) out) (wr (cadr x)))) + (else + (display "(" out) + (wr (car x)) + (let lp ((ls (cdr x))) + (cond ((pair? ls) + (display " " out) + (wr (car ls)) + (lp (cdr ls))) + ((not (null? ls)) + (display " . " out) + (write ls out)))) + (display ")" out))) + (write x out)))))) + +;; if we need to truncate, try first dropping let's to get at the +;; heart of the expression +(define (truncate-source x width . o) + (let* ((str (write-to-string x)) + (len (string-length str))) + (cond + ((<= len width) + str) + ((and (pair? x) (eq? 'let (car x))) + (if (and (pair? o) (car o)) + (truncate-source (car (reverse x)) width #t) + (string-append "..." + (truncate-source (car (reverse x)) (- width 3) #t)))) + ((and (pair? x) (eq? 'call-with-current-continuation (car x))) + (truncate-source (cons 'call/cc (cdr x)) width (and (pair? o) (car o)))) + ((and (pair? x) (eq? 'call-with-values (car x))) + (string-append + "..." + (truncate-source (if (and (pair? (cadr x)) (eq? 'lambda (caadr x))) + (car (reverse (cadr x))) + (cadr x)) + (- width 3) + #t))) + (else + (string-append + (substring str 0 (min (max 0 (- width 3)) (string-length str))) + "..."))))) + +(define (test-get-name! info) + (or + (assq-ref info 'name) + (assq-ref info 'gen-name) + (let ((name + (cond + ((assq-ref info 'source) + => (lambda (src) + (truncate-source src (- (current-column-width) 12)))) + ((current-test-group) + => (lambda (g) + (string-append + "test-" + (number->string (test-group-ref g 'count 0))))) + (else "")))) + (if (pair? info) + (set-cdr! info (cons (cons 'gen-name name) (cdr info)))) + name))) + +(define (test-print-name info . indent) + (let ((width (- (current-column-width) + (or (and (pair? indent) (car indent)) 0))) + (name (test-get-name! info))) + (display name) + (display " ") + (let ((diff (- width 9 (string-length name)))) + (cond + ((positive? diff) + (display (make-string diff #\.))))) + (display " ") + (flush-output))) + +(define (test-group-indent-width group) + (let ((level (max 0 (+ 1 (- (test-group-ref group 'level 0) + (test-first-indentation)))))) + (* 4 (min level (test-max-indentation))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ansi tools + +(define (display-to-string x) + (if (string? x) x (call-with-output-string (lambda (out) (display x out))))) + +(define (red x) (string-append "\x1B[31m" (display-to-string x) "\x1B[0m")) +(define (green x) (string-append "\x1B[32m" (display-to-string x) "\x1B[0m")) +(define (yellow x) (string-append "\x1B[33m" (display-to-string x) "\x1B[0m")) +;; (define (blue x) (string-append "\x1B[34m" (display-to-string x) "\x1B[0m")) +;; (define (magenta x) (string-append "\x1B[35m" (display-to-string x) "\x1B[0m")) +;; (define (cyan x) (string-append "\x1B[36m" (display-to-string x) "\x1B[0m")) +(define (bold x) (string-append "\x1B[1m" (display-to-string x) "\x1B[0m")) +(define (underline x) (string-append "\x1B[4m" (display-to-string x) "\x1B[0m")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (test-run expect expr info) + (if (and (cond ((current-test-group) + => (lambda (g) (not (test-group-ref g 'skip-group?)))) + (else #t)) + (every (lambda (f) (f info)) (current-test-filters))) + ((current-test-applier) expect expr info) + ((current-test-skipper) expect expr info))) + +(define (test-default-applier expect expr info) + (let* ((group (current-test-group)) + (indent (and group (test-group-indent-width group)))) + (cond + ((and group + (equal? 0 (test-group-ref group 'count 0)) + (zero? (test-group-ref group 'subgroups-count 0)) + (test-group-ref group 'verbosity)) + (newline) + (print-header-line + (string-append "testing " (or (test-group-name group) "")) + (or indent 0)))) + (if (and indent (positive? indent)) + (display (make-string indent #\space))) + (test-print-name info indent) + (let ((expect-val + (handle-exceptions + exn + (begin + (warning "bad expect value") + (print-exception exn (current-error-port)) + #f) + (expect)))) + (handle-exceptions + exn + (begin + ((current-test-handler) + (if (assq-ref info 'expect-error) 'PASS 'ERROR) + expect + expr + (append `((exception . ,exn)) info))) + (let ((res (expr))) + (let ((status + (if (and (not (assq-ref info 'expect-error)) + (if (assq-ref info 'assertion) + res + ((current-test-comparator) expect-val res))) + 'PASS + 'FAIL)) + (info `((result . ,res) (expected . ,expect-val) ,@info))) + ((current-test-handler) status expect expr info))))))) + +(define (test-default-skipper expect expr info) + ((current-test-handler) 'SKIP expect expr info)) + +(define (test-default-handler status expect expr info) + (define indent + (make-string + (+ 4 (cond ((current-test-group) + => (lambda (group) (or (test-group-indent-width group) 0))) + (else 0))) + #\space)) + ;; update group info + (cond ((current-test-group) + => (lambda (group) + (if (not (eq? 'SKIP status)) + (test-group-inc! group 'count)) + (test-group-inc! group status)))) + (cond + ((or (eq? status 'FAIL) (eq? status 'ERROR)) + (test-failure-count (+ 1 (test-failure-count))))) + (cond + ((not (eq? status 'SKIP)) + ;; display status + (display "[") + (if (not (eq? status 'ERROR)) (display " ")) ; pad + (display ((if (test-ansi?) + (case status + ((ERROR) (lambda (x) (underline (red x)))) + ((FAIL) red) + ((SKIP) yellow) + (else green)) + (lambda (x) x)) + status)) + (display "]") + (newline) + ;; display status explanation + (cond + ((eq? status 'ERROR) + (display indent) + (cond ((assq 'exception info) + => (lambda (e) + (print-exception (cdr e) (current-output-port)))))) + ((and (eq? status 'FAIL) (assq-ref info 'assertion)) + (display indent) + (display "assertion failed\n")) + ((and (eq? status 'FAIL) (assq-ref info 'expect-error)) + (display indent) + (display "expected an error but got ") + (write (assq-ref info 'result)) (newline)) + ((eq? status 'FAIL) + (display indent) + (display "expected ") (write (assq-ref info 'expected)) + (display " but got ") (write (assq-ref info 'result)) (newline))) + ;; display line, source and values info + (cond + ((or (not (current-test-group)) + (test-group-ref (current-test-group) 'verbosity)) + (case status + ((FAIL ERROR) + (cond + ((assq-ref info 'line-number) + => (lambda (line) + (display " in line ") + (write line) + (cond ((assq-ref info 'file-name) + => (lambda (file) (display " of file ") (write file)))) + (newline)))) + (cond + ((assq-ref info 'source) + => (lambda (s) + (cond + ((or (assq-ref info 'name) + (> (string-length (write-to-string s)) + (current-column-width))) + (display (write-to-string s)) + (newline)))))) + (cond + ((assq-ref info 'values) + => (lambda (v) + (for-each + (lambda (v) + (display " ") (display (car v)) + (display ": ") (write (cdr v)) (newline)) + v)))))))))) + status) + +(define (test-default-group-reporter group) + (define (plural word n) + (if (= n 1) word (string-append word "s"))) + (define (percent n d) + (string-append " (" (number->string (/ (round (* 1000 (/ n d))) 10)) "%)")) + (let* ((end-time (get-time-of-day)) + (start-time (test-group-ref group 'start-time)) + (duration (timeval-difference (car end-time) (car start-time))) + (count (or (test-group-ref group 'count) 0)) + (pass (or (test-group-ref group 'PASS) 0)) + (fail (or (test-group-ref group 'FAIL) 0)) + (err (or (test-group-ref group 'ERROR) 0)) + (skip (or (test-group-ref group 'SKIP) 0)) + (subgroups-count (or (test-group-ref group 'subgroups-count) 0)) + (subgroups-pass (or (test-group-ref group 'subgroups-pass) 0)) + (indent (make-string (or (test-group-indent-width group) 0) #\space))) + (cond + ((or (positive? count) (positive? subgroups-count)) + (if (not (= count (+ pass fail err))) + (warning "inconsistent count:" count pass fail err)) + (display indent) + (cond + ((positive? count) + (write count) (display (plural " test" count)))) + (if (and (positive? count) (positive? subgroups-count)) + (display " and ")) + (cond + ((positive? subgroups-count) + (write subgroups-count) + (display (plural " subgroup" subgroups-count)))) + (display " completed in ") (write duration) (display " seconds") + (cond + ((not (zero? skip)) + (display " (") (write skip) (display (plural " test" skip)) + (display " skipped)"))) + (display ".") (newline) + (cond ((positive? fail) + (display indent) + (display + ((if (test-ansi?) red (lambda (x) x)) + (string-append + (number->string fail) (plural " failure" fail) + (percent fail count) "."))) + (newline))) + (cond ((positive? err) + (display indent) + (display + ((if (test-ansi?) (lambda (x) (underline (red x))) (lambda (x) x)) + (string-append + (number->string err) (plural " error" err) + (percent err count) "."))) + (newline))) + (cond + ((positive? count) + (display indent) + (display + ((if (and (test-ansi?) (= pass count)) green (lambda (x) x)) + (string-append + (number->string pass) " out of " (number->string count) + (percent pass count) (plural " test" pass) " passed."))) + (newline))) + (cond + ((positive? subgroups-count) + (display indent) + (display + ((if (and (test-ansi?) (= subgroups-pass subgroups-count)) + green (lambda (x) x)) + (string-append + (number->string subgroups-pass) " out of " + (number->string subgroups-count) + (percent subgroups-pass subgroups-count) + (plural " subgroup" subgroups-pass) " passed."))) + (newline))) + )) + (print-header-line + (string-append "done testing " (or (test-group-name group) "")) + (or (test-group-indent-width group) 0)) + (newline) + )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (test-equal? expect res) + (or (equal? expect res) + (and (number? expect) + (inexact? expect) + (approx-equal? expect res (current-test-epsilon))))) + +(define (print-header-line str . indent) + (let* ((header (string-append + (make-string (if (pair? indent) (car indent) 0) #\space) + "-- " str " ")) + (len (string-length header))) + (display (if (test-ansi?) (bold header) header)) + (display (make-string (max 0 (- (current-column-width) len)) #\-)) + (newline))) + +(define (test-begin . o) + (let* ((name (if (pair? o) (car o) "")) + (group (make-test-group name)) + (parent (current-test-group))) + (cond + ((and parent + (equal? 0 (test-group-ref parent 'count 0)) + (zero? (test-group-ref parent 'subgroups-count 0)) + (test-group-ref parent 'verbosity)) + (newline) + (print-header-line + (string-append "testing " (test-group-name parent)) + (or (test-group-indent-width parent) 0)))) + (test-group-set! group 'parent parent) + (test-group-set! group 'verbosity + (if parent + (test-group-ref parent 'verbosity) + (current-test-verbosity))) + (test-group-set! group 'level + (if parent + (+ 1 (test-group-ref parent 'level 0)) + 0)) + (test-group-set! + group + 'skip-group? + (or (and parent (test-group-ref parent 'skip-group?)) + (not (every (lambda (f) (f group)) (current-test-group-filters))))) + (current-test-group group))) + +(define (test-end . o) + (cond + ((current-test-group) + => (lambda (group) + (if (and (pair? o) (not (equal? (car o) (test-group-name group)))) + (warning "mismatched test-end:" (car o) (test-group-name group))) + (let ((parent (test-group-ref group 'parent))) + (cond + ((not (test-group-ref group 'skip-group?)) + ;; only report if there's something to say + ((current-test-group-reporter) group) + (cond + (parent + (test-group-inc! parent 'subgroups-count) + (cond + ((and (zero? (test-group-ref group 'FAIL 0)) + (zero? (test-group-ref group 'ERROR 0)) + (= (test-group-ref group 'subgroups-pass 0) + (test-group-ref group 'subgroups-count 0))) + (test-group-inc! parent 'subgroups-pass))))))) + (current-test-group parent) + group))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; parameters + +(define current-test-group (make-parameter #f)) +(define current-test-verbosity + (make-parameter + (cond ((get-environment-variable "TEST_QUIET") + => (lambda (s) (equal? s "0"))) + (else #t)))) +(define current-test-epsilon (make-parameter 1e-5)) +(define current-test-comparator (make-parameter test-equal?)) +(define current-test-applier (make-parameter test-default-applier)) +(define current-test-handler (make-parameter test-default-handler)) +(define current-test-skipper (make-parameter test-default-skipper)) +(define current-test-group-reporter + (make-parameter test-default-group-reporter)) +(define test-failure-count (make-parameter 0)) + +(define test-first-indentation + (make-parameter + (or (cond ((get-environment-variable "TEST_FIRST_INDENTATION") + => string->number) + (else #f)) + 1))) + +(define test-max-indentation + (make-parameter + (or (cond ((get-environment-variable "TEST_MAX_INDENTATION") + => string->number) + (else #f)) + 5))) + +(define (string->info-matcher str) + (lambda (info) + (cond ((test-get-name! info) + => (lambda (n) (string-search str n))) + (else #f)))) + +(define (string->group-matcher str) + (lambda (group) (string-search str (car group)))) + +(define (getenv-filter-list proc name . o) + (cond + ((get-environment-variable name) + => (lambda (s) + (handle-exceptions + exn + (begin + (warning + (string-append "invalid filter '" s + "' from environment variable: " name)) + (print-exception exn (current-error-port)) + '()) + (let ((f (proc s))) + (list (if (and (pair? o) (car o)) + (lambda (x) (not (f x))) + f)))))) + (else '()))) + +(define current-test-filters + (make-parameter + (append (getenv-filter-list string->info-matcher "TEST_FILTER") + (getenv-filter-list string->info-matcher "TEST_REMOVE" #t)))) + +(define current-test-group-filters + (make-parameter + (append (getenv-filter-list string->group-matcher "TEST_GROUP_FILTER") + (getenv-filter-list string->group-matcher "TEST_GROUP_REMOVE" #t)))) + +(define current-column-width + (make-parameter + (or (cond ((get-environment-variable "TEST_COLUMN_WIDTH") + => string->number) + (else #f)) + 78))) + +(define test-ansi? + (make-parameter + (cond + ((get-environment-variable "TEST_USE_ANSI") + => (lambda (s) (not (equal? s "0")))) + (else + (member (get-environment-variable "TERM") + '("xterm" "xterm-color" "xterm-256color" "rxvt" "kterm" + "linux" "screen" "screen-256color" "vt100")))))) diff --git a/lib/chibi/time.module b/lib/chibi/time.module new file mode 100644 index 00000000..8d591100 --- /dev/null +++ b/lib/chibi/time.module @@ -0,0 +1,12 @@ + +(define-module (chibi time) + (export current-seconds get-time-of-day set-time-of-day! + seconds->time seconds->string time->seconds time->string + timeval-seconds timeval-microseconds + timezone-offset timezone-dst-time + time-second time-minute time-hour time-day time-month time-year + time-day-of-week time-day-of-year time-dst? + tm? timeval? timezone?) + (import-immutable (scheme)) + (include-shared "time")) + diff --git a/lib/chibi/time.stub b/lib/chibi/time.stub new file mode 100644 index 00000000..adde486e --- /dev/null +++ b/lib/chibi/time.stub @@ -0,0 +1,46 @@ + +(c-system-include "time.h") +(c-system-include "sys/time.h") + +(define-c-struct tm + predicate: tm? + (int tm_sec time-second) + (int tm_min time-minute) + (int tm_hour time-hour) + (int tm_mday time-day) + (int tm_mon time-month) + (int tm_year time-year) + (int tm_wday time-day-of-week) + (int tm_yday time-day-of-year) + (int tm_isdst time-dst?)) + +(define-c-struct timeval + predicate: timeval? + (time_t tv_sec timeval-seconds) + (int tv_usec timeval-microseconds)) + +(define-c-struct timezone + predicate: timezone? + (int tz_minuteswest timezone-offset) + (int tz_dsttime timezone-dst-time)) + +(define-c time_t (current-seconds "time") ((value NULL))) + +(define-c errno (get-time-of-day "gettimeofday") + ((result timeval) (result timezone))) + +(define-c errno (set-time-of-day! "settimeofday") + (timeval (maybe-null default NULL timezone))) + +(define-c non-null-pointer (seconds->time "localtime_r") + ((pointer time_t) (result tm))) + +(define-c time_t (time->seconds "mktime") + (tm)) + +(define-c non-null-string (seconds->string "ctime_r") + ((pointer time_t) (result (array char 64)))) + +(define-c non-null-string (time->string "asctime_r") + (tm (result (array char 64)))) + diff --git a/lib/chibi/type-inference.module b/lib/chibi/type-inference.module new file mode 100644 index 00000000..2f9534d2 --- /dev/null +++ b/lib/chibi/type-inference.module @@ -0,0 +1,7 @@ + +(define-module (chibi type-inference) + (export type-analyze-module type-analyze procedure-signature) + (import-immutable (scheme)) + (import (srfi 1) (srfi 69) (chibi modules) (chibi ast) (chibi match)) + (include "type-inference.scm")) + diff --git a/lib/chibi/type-inference.scm b/lib/chibi/type-inference.scm new file mode 100644 index 00000000..6b21a230 --- /dev/null +++ b/lib/chibi/type-inference.scm @@ -0,0 +1,272 @@ +;; type-inference.scm -- general type-inference for Scheme +;; +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (typed? x) + (and (lambda? x) + (lambda-return-type x))) + +(define (union-type? a) + (and (pair? a) (equal? (car a) 'or))) + +(define (intersection-type? a) + (and (pair? a) (equal? (car a) 'and))) + +(define (unfinalized-type? a) + (and (pair? a) + (or (memq (car a) '(return-type param-type)) + (and (memq (car a) '(and or)) + (any unfinalized-type? (cdr a)))))) + +(define (finalized-type? a) + (not (unfinalized-type? a))) + +(define (numeric-type? a) + (or (eq? a ) (eq? a ) (eq? a ))) + +(define (procedure-type? a) + (or (eq? a ) + (eq? a ) + (and (pair? a) (eq? (car a) 'lambda)))) + +(define (type-subset? a b) + (or (equal? a b) + (equal? a ) + (equal? b ) + (and (numeric-type? a) (numeric-type? b)) + (and (procedure-type? a) (procedure-type? b)) + (if (union-type? a) + (if (union-type? b) + (lset<= equal? (cdr a) (cdr b)) + (member b (cdr a))) + (and (union-type? b) (member a (cdr b)))))) + +;; XXXX check for type hierarchies +(define (type-union a b) + (cond + ((equal? a b) a) + ((or (equal? a ) (equal? b )) ) + ((union-type? a) + (if (union-type? b) + (cons (car a) (lset-union equal? (cdr a) (cdr b))) + (cons (car a) (lset-adjoin equal? (cdr a) b)))) + (else (list 'or a b)))) + +;; XXXX check for conflicts +(define (type-intersection a b) + (cond + ((equal? a b) a) + ((or (equal? a ) (unfinalized-type? a)) b) + ((or (equal? b ) (unfinalized-type? b)) a) + ((intersection-type? a) + (if (intersection-type? b) + (lset-intersection equal? (cdr a) (cdr b)) + (cons (car a) (lset-adjoin equal? (cdr a) b)))) + (else (list 'and a b)))) + +(define (lambda-param-types-initialize! f) + (lambda-param-types-set! f (map (lambda (p) (list 'param-type f p)) + (lambda-params f)))) + +(define (lambda-param-type-memq f x) + (let lp ((p (lambda-params f)) + (t (lambda-param-types f))) + (and (pair? p) + (pair? t) + (if (eq? x (car p)) + t + (lp (cdr p) (cdr t)))))) + +(define (lambda-param-type-ref f x) + (cond ((lambda-param-type-memq f x) => car) + (else #f))) + +(define (lambda-param-type-set! f x y) + (if (not (pair? (lambda-param-types f))) + (lambda-param-types-initialize! f)) + (cond ((lambda-param-type-memq f x) + => (lambda (cell) (set-car! cell y))))) + +(define (type-analyze-expr x) + (match x + (($ name params body defs) + (cond + ((not (lambda-return-type x)) + (lambda-return-type-set! x (list 'return-type x)) + (lambda-param-types-initialize! x) + (let ((ret-type (type-analyze-expr body))) + (lambda-return-type-set! x ret-type) + (cons 'lambda (cons ret-type (lambda-param-types x))))))) + (($ ref value) + (type-analyze-expr value) + (if #f #f)) + (($ name (value . loc) source) + (cond + ((lambda? loc) (lambda-param-type-ref loc name)) + ((procedure? loc) + (let ((sig (procedure-signature loc))) + (if (and (pair? sig) (car sig)) + (cons 'lambda sig) + (list 'return-type (procedure-analysis loc))))) + (else ))) + (($ test pass fail) + (let ((test-type (type-analyze-expr test)) + (pass-type (type-analyze-expr pass)) + (fail-type (type-analyze-expr fail))) + (type-union pass-type fail-type))) + (($ ls) + (let lp ((ls ls)) + (cond ((null? (cdr ls)) + (type-analyze-expr (car ls))) + (else + (type-analyze-expr (car ls)) + (lp (cdr ls)))))) + ((f args ...) + (cond + ((opcode? f) + (let lp ((p (opcode-param-types f)) + (a args)) + (cond + ((pair? a) + (cond ((or (pair? p) (opcode-variadic? f)) + (let ((p-type + (if (pair? p) + (car p) + (opcode-param-type f (opcode-num-params f))))) + (match (car a) + (($ name (_ . (and g ($ )))) + (let ((t (type-intersection (lambda-param-type-ref g name) + p-type))) + (lambda-param-type-set! g name t))) + (else + (let ((t (type-analyze-expr (car a)))) + (cond + ((and t p-type + (finalized-type? t) + (finalized-type? p-type) + (not (type-subset? t p-type))) + (display "WARNING: incompatible type: " + (current-error-port)) + (write (list x t p-type) (current-error-port)) + (newline (current-error-port)))) + t)))) + (lp (and (pair? p) (cdr p)) (cdr a))) + (else + (for-each type-analyze-expr a)))))) + (opcode-return-type f)) + (else + (let ((f-type (type-analyze-expr f))) + ;; XXXX apply f-type to params + (for-each type-analyze-expr args) + (cond + ((and (pair? f-type) (eq? (car f-type) 'lambda)) + (cadr f-type)) + ((and (pair? f-type) (memq (car f-type) '(return-type param-type))) + f-type) + (else + )))))) + (else + (type-of x)))) + +(define (resolve-delayed-type x) + (let lp ((x x) (seen '()) (default )) + (match x + (('return-type f) + (if (memq f seen) + default + (lp (lambda-return-type f) (cons f seen) default))) + (('param-type f p) + (if (member x seen) + default + (lp (lambda-param-type-ref f p) (cons x seen) default))) + (('or y ...) + (let ((z (find finalized-type? y))) + (if z + (let ((default (if (eq? default ) + (lp z seen default) + (type-union (lp z seen default) default)))) + (fold type-union + default + (map (lambda (y1) (lp y1 seen default)) (delete z y)))) + (fold type-union default (map (lambda (y1) (lp y1 seen default)) y))))) + (('and y ...) + (fold type-intersection default (map (lambda (y1) (lp y1 seen default)) y))) + (('not y) + (list 'not (lp y seen default))) + (else + x)))) + +(define (type-resolve-circularities x) + (match x + (($ name params body defs) + (if (unfinalized-type? (lambda-return-type x)) + (lambda-return-type-set! x (resolve-delayed-type + (lambda-return-type x)))) + (for-each + (lambda (p t) + (if (unfinalized-type? t) + (lambda-param-type-set! x p (resolve-delayed-type t)))) + params + (lambda-param-types x)) + (type-resolve-circularities (lambda-body x))) + (($ ref value) + (type-resolve-circularities value)) + (($ test pass fail) + (type-resolve-circularities test) + (type-resolve-circularities pass) + (type-resolve-circularities fail)) + (($ ls) + (for-each type-resolve-circularities ls)) + ((app ...) + (for-each type-resolve-circularities app)) + (else #f))) + +(define (type-analyze-module-body name ls) + (for-each type-analyze-expr ls) + (for-each type-resolve-circularities ls)) + +(define (type-analyze-module name) + (let* ((mod (analyze-module name)) + (ls (and (vector? mod) (module-ast mod)))) + (and ls + (let ((x (let lp ((ls ls)) ;; first lambda + (and (pair? ls) + (if (and (set? (car ls)) + (lambda? (set-value (car ls)))) + (set-value (car ls)) + (lp (cdr ls))))))) + (if (and x (not (typed? x))) + (type-analyze-module-body name ls)) + ls)))) + +(define (type-analyze sexp . o) + (type-analyze-expr (apply analyze sexp o))) + +(define (opcode-param-types x) + (let lp ((n (- (opcode-num-params x) 1)) (res '())) + (if (< n 0) + res + (lp (- n 1) (cons (opcode-param-type x n) res))))) + +(define (opcode-type x) + (cons 'lambda (cons (opcode-return-type x) (opcode-param-types x)))) + +(define (lambda-type x) + (cons 'lambda (cons (lambda-return-type x) (lambda-param-types x)))) + +(define (procedure-signature x) + (if (opcode? x) + (cdr (opcode-type x)) + (let lp ((count 0)) + (let ((lam (procedure-analysis x))) + (cond + ((and lam (not (typed? lam)) (zero? count) + (containing-module x)) + => (lambda (mod) + (and (type-analyze-module (car mod)) + (lp (+ count 1))))) + ((lambda? lam) + (cdr (lambda-type lam))) + (else + #f)))))) diff --git a/lib/chibi/uri.module b/lib/chibi/uri.module new file mode 100644 index 00000000..46f9e6a6 --- /dev/null +++ b/lib/chibi/uri.module @@ -0,0 +1,10 @@ + +(define-module (chibi uri) + (export uri? uri->string make-uri string->uri + uri-scheme uri-user uri-host uri-port uri-path uri-query uri-fragment + uri-with-scheme uri-with-user uri-with-host uri-with-path + uri-with-query uri-with-fragment + uri-encode uri-decode uri-query->alist uri-alist->query) + (import-immutable (scheme) + (srfi 9)) + (include "uri.scm")) diff --git a/lib/chibi/uri.scm b/lib/chibi/uri.scm new file mode 100644 index 00000000..41507961 --- /dev/null +++ b/lib/chibi/uri.scm @@ -0,0 +1,306 @@ +;; uri.scm -- URI parsing library +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; URI representation + +(define-record-type uri + (%make-uri scheme user host port path query fragment) + uri? + (scheme uri-scheme) + (user uri-user) + (host uri-host) + (port uri-port) + (path uri-path) + (query uri-query) + (fragment uri-fragment)) + +;; (make-uri scheme [user host port path query fragment]) +(define (make-uri scheme . o) + (let* ((user (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (host (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (port (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (path (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (query (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (fragment (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) #f))) + (%make-uri scheme user host port path query fragment))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils (don't feel like using SRFI-13 and these are more +;; specialised) + +(define (string-scan str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (and (< i end) + (if (eqv? ch (string-ref str i)) + i + (lp (+ i 1))))))) + +(define (string-scan-right str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i (- end 1))) + (and (>= i start) + (if (eqv? ch (string-ref str i)) + i + (lp (- i 1))))))) + +(define (string-index-of str pred . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond ((>= i end) #f) + ((pred (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-downcase->symbol str) + (let ((len (string-length str))) + (let lp ((i 0)) + (cond + ((= i len) + (string->symbol str)) + ((char-upper-case? (string-ref str i)) + (let ((res (make-string len))) + (do ((j 0 (+ j 1))) + ((= j i)) + (string-set! res j (string-ref str j))) + (string-set! res i (char-downcase (string-ref str i))) + (do ((j (+ i 1) (+ j 1))) + ((= j len)) + (string-set! res j (char-downcase (string-ref str j)))) + (string->symbol res))) + (else + (lp (+ i 1))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; functional updaters (uses as much shared state as possible) + +(define (uri-with-scheme u scheme) + (%make-uri scheme (uri-user u) (uri-host u) (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-user u user) + (%make-uri (uri-scheme u) user (uri-host u) (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-host u host) + (%make-uri (uri-scheme u) (uri-user u) host (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-port u port) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) port + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-path u path) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + path (uri-query u) (uri-fragment u))) + +(define (uri-with-query u query) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + (uri-path u) query (uri-fragment u))) + +(define (uri-with-fragment u fragment) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + (uri-path u) (uri-query u) fragment)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; parsing - without :// we just split into scheme & path + +(define (char-uri-scheme-unsafe? ch) + (not (or (char-alphabetic? ch) (char-numeric? ch) (memv ch '(#\_ #\-))))) + +(define (string->path-uri scheme str . o) + (define decode? (and (pair? o) (car o))) + (define decode (if decode? uri-decode (lambda (x) x))) + (define decode-query + (if (and (pair? o) (pair? (cdr o)) (cadr o)) + uri-query->alist + decode)) + (if (pair? str) + str + (let* ((len (string-length str)) + (colon0 (string-scan str #\:)) + (colon + (and (not (string-index-of str char-uri-scheme-unsafe? + 0 (or colon0 len))) + colon0))) + (if (or (not colon) (zero? colon)) + (and scheme + (let* ((quest (string-scan str #\? 0)) + (pound (string-scan str #\# (or quest 0)))) + (make-uri scheme #f #f #f + (decode (substring str 0 (or quest pound len))) + (and quest + (decode-query + (substring str (+ quest 1) (or pound len)))) + (and pound + (decode (substring str (+ pound 1) len)))))) + (let ((sc1 (+ colon 1)) + (scheme (string-downcase->symbol (substring str 0 colon)))) + (if (= sc1 len) + (make-uri scheme) + (if (or (>= (+ sc1 1) len) + (not (and (eqv? #\/ (string-ref str sc1)) + (eqv? #\/ (string-ref str (+ sc1 1)))))) + (make-uri scheme #f #f #f (substring str sc1 len)) + (if (>= (+ sc1 2) len) + (make-uri scheme #f "") + (let* ((sc2 (+ sc1 2)) + (slash (string-scan str #\/ sc2)) + (sc3 (or slash len)) + (at (string-scan-right str #\@ sc2 sc3)) + (colon3 (string-scan str #\: (or at sc2) sc3)) + (quest (string-scan str #\? sc3)) + (pound (string-scan str #\# (or quest sc3)))) + (%make-uri + scheme + (and at (decode (substring str sc2 at))) + (decode + (substring str + (if at (+ at 1) sc2) + (or colon3 sc3))) + (and colon3 + (string->number + (substring str (+ colon3 1) sc3))) + (and slash + (decode + (substring str slash (or quest pound len)))) + (and quest + (decode-query + (substring str (+ quest 1) + (or pound len)))) + (and pound + (decode (substring str (+ pound 1) len))) + )))))))))) + +(define (string->uri str . o) + (apply string->path-uri #f str o)) + +(define (uri->string uri . o) + (define encode? (and (pair? o) (car o))) + (define encode (if encode? uri-encode (lambda (x) x))) + (if (string? uri) + uri + (let ((fragment (uri-fragment uri)) + (query (uri-query uri)) + (path (uri-path uri)) + (port (uri-port uri)) + (host (uri-host uri)) + (user (uri-user uri))) + (string-append + (symbol->string (uri-scheme uri)) ":" + (if (or user host port) "//" "") + (if user (encode user) "") (if user "@" "") + (or host "") ; host shouldn't need encoding + (if port ":" "") (if port (number->string port) "") + (if path (encode path) "") + (if query "?" "") + (if (pair? query) (uri-alist->query query) (or query "")) + (if fragment "#" "") (if fragment (encode fragment) ""))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; query encoding and decoding + +(define (uri-safe-char? ch) + (or (char-alphabetic? ch) + (char-numeric? ch) + (case ch + ((#\- #\_ #\. #\! #\~ #\* #\' #\( #\)) #t) + (else #f)))) + +(define (collect str from to res) + (if (>= from to) + res + (cons (substring str from to) res))) + +(define (uri-encode str . o) + (define (encode-1-space ch) + (if (eqv? ch #\space) + "+" + (encode-1-normal ch))) + (define (encode-1-normal ch) + (let* ((i (char->integer ch)) + (hex (number->string i 16))) + (if (< i 16) + (string-append "%0" hex) + (string-append "%" hex)))) + (let ((start 0) + (end (string-length str)) + (encode-1 (if (and (pair? o) (car o)) + encode-1-space + encode-1-normal))) + (let lp ((from start) (to start) (res '())) + (if (>= to end) + (if (zero? from) + str + (string-concatenate (reverse (collect str from to res)))) + (let* ((ch (string-ref str to)) + (next (+ to 1))) + (if (uri-safe-char? ch) + (lp from next res) + (lp next next (cons (encode-1 ch) + (collect str from to res))))))))) + +(define (uri-decode str . o) + (let ((space-as-plus? (and (pair? o) (car o))) + (start 0) + (end (string-length str))) + (let lp ((from start) (to start) (res '())) + (if (>= to end) + (if (zero? from) + str + (string-concatenate (reverse (collect str from to res)))) + (let* ((ch (string-ref str to)) + (next (+ to 1))) + (cond + ((eqv? ch #\%) + (if (>= next end) + (lp next next (collect str from to res)) + (let ((next2 (+ next 1))) + (if (>= next2 end) + (lp next2 next2 (collect str from to res)) + (let* ((next3 (+ next2 1)) + (hex (substring str next next3)) + (i (string->number hex 16))) + (lp next3 next3 (cons (string (integer->char i)) + (collect str from to res)))))))) + ((and space-as-plus? (eqv? ch #\+)) + (lp next next (cons " " (collect str from to res)))) + (else + (lp from next res)))))))) + +(define (uri-query->alist str . o) + (define (split-char? c) (if (eqv? c #\&) #t (eqv? c #\;))) + (let ((len (string-length str)) + (plus? (and (pair? o) (car o)))) + (let lp ((i 0) (res '())) + (if (>= i len) + (reverse res) + (let* ((j (or (string-index-of str split-char? i) len)) + (k (string-scan str #\= i j)) + (cell (if k + (cons (uri-decode (substring str i k) plus?) + (uri-decode (substring str (+ k 1) j) plus?)) + (cons (uri-decode (substring str i j) plus?) #f)))) + (lp (+ j 1) (cons cell res))))))) + +(define (uri-alist->query ls . o) + (define plus? (and (pair? o) (car o))) + (define (encode key val res) + (let ((res (cons (uri-encode key plus?) res))) + (if val (cons (uri-encode val plus?) (cons "=" res)) res))) + (if (null? ls) + "" + (let lp ((x (car ls)) (ls (cdr ls)) (res '())) + (let ((res (encode (car x) (cdr x) res))) + (if (null? ls) + (string-concatenate (reverse res)) + (lp (car ls) (cdr ls) (cons "&" res))))))) diff --git a/lib/config.scm b/lib/config.scm new file mode 100644 index 00000000..55a4e1e0 --- /dev/null +++ b/lib/config.scm @@ -0,0 +1,179 @@ +;; config.scm -- configuration module +;; Copyright (c) 2009-2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; modules + +(define *this-module* '()) + +(define (make-module exports env meta) (vector exports env meta #f)) +(define (%module-exports mod) (vector-ref mod 0)) +(define (module-env mod) (vector-ref mod 1)) +(define (module-meta-data mod) (vector-ref mod 2)) +(define (module-env-set! mod env) (vector-set! mod 1 env)) + +(define (module-exports mod) + (or (%module-exports mod) (env-exports (module-env mod)))) + +(define (module-name->strings ls res) + (if (null? ls) + res + (let ((str (cond ((symbol? (car ls)) (symbol->string (car ls))) + ((number? (car ls)) (number->string (car ls))) + ((string? (car ls)) (car ls)) + (else (error "invalid module name" (car ls)))))) + (module-name->strings (cdr ls) (cons "/" (cons str res)))))) + +(define (module-name->file name) + (string-concatenate + (reverse (cons ".module" (cdr (module-name->strings name '())))))) + +(define (module-name-prefix name) + (string-concatenate (reverse (cdr (cdr (module-name->strings name '())))))) + +(define (load-module-definition name) + (let* ((file (module-name->file name)) + (path (find-module-file file))) + (if path (load path *config-env*)))) + +(define (find-module name) + (cond + ((assoc name *modules*) => cdr) + (else + (load-module-definition name) + (cond ((assoc name *modules*) => cdr) + (else #f))))) + +(define (symbol-append a b) + (string->symbol (string-append (symbol->string a) (symbol->string b)))) + +(define (to-id id) (if (pair? id) (car id) id)) +(define (from-id id) (if (pair? id) (cdr id) id)) +(define (id-filter pred ls) + (cond ((null? ls) '()) + ((pred (to-id (car ls))) (cons (car ls) (id-filter pred (cdr ls)))) + (else (id-filter pred (cdr ls))))) + +(define (resolve-import x) + (cond + ((not (and (pair? x) (list? x))) + (error "invalid module syntax" x)) + ((and (pair? (cdr x)) (pair? (cadr x))) + (if (memq (car x) '(only except rename)) + (let* ((mod-name+imports (resolve-import (cadr x))) + (imp-ids (cdr mod-name+imports)) + (imp-ids (if (and (not imp-ids) (not (eq? 'only (car x)))) + (begin + (set-cdr! mod-name+imports + (module-exports + (find-module (car mod-name+imports)))) + (cdr mod-name+imports)) + imp-ids))) + (cons (car mod-name+imports) + (case (car x) + ((only) + (if (not imp-ids) + (cddr x) + (id-filter (lambda (i) (memq i (cddr x))) imp-ids))) + ((except) + (id-filter (lambda (i) (not (memq i (cddr x)))) imp-ids)) + ((rename) + (map (lambda (i) + (let ((rename (assq (to-id i) (cddr x)))) + (if rename (cons (cdr rename) (from-id i)) i))) + imp-ids))))) + (error "invalid import modifier" x))) + ((and (eq? 'prefix (car x)) (symbol? (cadr x)) (list? (caddr x))) + (let ((mod-name+imports (resolve-import (caddr x)))) + (cons (car mod-name+imports) + (map (lambda (i) + (cons (symbol-append (cadr x) (if (pair? i) (car i) i)) + (if (pair? i) (cdr i) i))) + (cdr mod-name+imports))))) + ((find-module x) + => (lambda (mod) (cons x (%module-exports mod)))) + (else + (error "couldn't find import" x)))) + +(define (eval-module name mod) + (let ((env (make-environment)) + (dir (module-name-prefix name))) + (define (load-modules files extension) + (for-each + (lambda (f) + (let ((f (string-append dir f extension))) + (cond ((find-module-file f) => (lambda (x) (load x env))) + (else (error "couldn't find include" f))))) + files)) + (for-each + (lambda (x) + (case (and (pair? x) (car x)) + ((import import-immutable) + (for-each + (lambda (m) + (let* ((mod2-name+imports (resolve-import m)) + (mod2 (load-module (car mod2-name+imports)))) + (%env-copy! env (module-env mod2) (cdr mod2-name+imports) + (eq? (car x) 'import-immutable)))) + (cdr x))) + ((include) + (load-modules (cdr x) "")) + ((include-shared) + (cond-expand + (dynamic-loading (load-modules (cdr x) *shared-object-extension*)) + (else #f))) + ((body) + (for-each (lambda (expr) (eval expr env)) (cdr x))))) + (module-meta-data mod)) + env)) + +(define (load-module name) + (let ((mod (find-module name))) + (if (and mod (not (module-env mod))) + (module-env-set! mod (eval-module name mod))) + mod)) + +(define-syntax define-module + (er-macro-transformer + (lambda (expr rename compare) + (let ((name (cadr expr)) + (body (cddr expr))) + `(let ((tmp *this-module*)) + (set! *this-module* '()) + ,@body + (set! *this-module* (reverse *this-module*)) + (let ((exports + (cond ((assq 'export *this-module*) => cdr) + (else '())))) + (set! *modules* + (cons (cons ',name (make-module exports #f *this-module*)) + *modules*))) + (set! *this-module* tmp)))))) + +(define-syntax define-config-primitive + (er-macro-transformer + (lambda (expr rename compare) + `(define-syntax ,(cadr expr) + (er-macro-transformer + (lambda (expr rename compare) + `(set! *this-module* (cons ',expr *this-module*)))))))) + +(define-config-primitive import) +(define-config-primitive import-immutable) +(define-config-primitive export) +(define-config-primitive include) +(define-config-primitive include-shared) +(define-config-primitive body) + +(define *modules* + (list (cons '(scheme) (make-module #f (interaction-environment) + '((include "init.scm")))) + (cons '(config) (make-module #f (current-environment) '())) + (cons '(srfi 0) (make-module (list 'cond-expand) + (interaction-environment) + (list (list 'export 'cond-expand)))) + (cons '(srfi 46) (make-module (list 'syntax-rules) + (interaction-environment) + (list (list 'export 'syntax-rules)))))) + diff --git a/lib/init.scm b/lib/init.scm new file mode 100644 index 00000000..62d044ec --- /dev/null +++ b/lib/init.scm @@ -0,0 +1,875 @@ +;; init.scm -- R5RS library procedures +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; provide c[ad]{2,4}r + +(define (caar x) (car (car x))) +(define (cadr x) (car (cdr x))) +(define (cdar x) (cdr (car x))) +(define (cddr x) (cdr (cdr x))) +(define (caaar x) (car (car (car x)))) +(define (caadr x) (car (car (cdr x)))) +(define (cadar x) (car (cdr (car x)))) +(define (caddr x) (car (cdr (cdr x)))) +(define (cdaar x) (cdr (car (car x)))) +(define (cdadr x) (cdr (car (cdr x)))) +(define (cddar x) (cdr (cdr (car x)))) +(define (cdddr x) (cdr (cdr (cdr x)))) +(define (caaaar x) (car (car (car (car x))))) +(define (caaadr x) (car (car (car (cdr x))))) +(define (caadar x) (car (car (cdr (car x))))) +(define (caaddr x) (car (car (cdr (cdr x))))) +(define (cadaar x) (car (cdr (car (car x))))) +(define (cadadr x) (car (cdr (car (cdr x))))) +(define (caddar x) (car (cdr (cdr (car x))))) +(define (cadddr x) (car (cdr (cdr (cdr x))))) +(define (cdaaar x) (cdr (car (car (car x))))) +(define (cdaadr x) (cdr (car (car (cdr x))))) +(define (cdadar x) (cdr (car (cdr (car x))))) +(define (cdaddr x) (cdr (car (cdr (cdr x))))) +(define (cddaar x) (cdr (cdr (car (car x))))) +(define (cddadr x) (cdr (cdr (car (cdr x))))) +(define (cdddar x) (cdr (cdr (cdr (car x))))) +(define (cddddr x) (cdr (cdr (cdr (cdr x))))) + +;; basic utils + +(define (procedure? x) (if (closure? x) #t (opcode? x))) + +(define (list . args) args) + +(define (list-tail ls k) + (if (eq? k 0) + ls + (list-tail (cdr ls) (- k 1)))) + +(define (list-ref ls k) (car (list-tail ls k))) + +(define (append-helper ls res) + (if (null? ls) + res + (append-helper (cdr ls) (append2 (car ls) res)))) + +(define (append . o) + (if (null? o) + '() + ((lambda (lol) + (append-helper (cdr lol) (car lol))) + (reverse o)))) + +(define (apply proc . args) + (if (null? args) + (proc) + ((lambda (lol) + (apply1 proc (append2 (reverse (cdr lol)) (car lol)))) + (reverse args)))) + +;; map with a fast-path for single lists + +(define (map proc ls . lol) + (define (map1 proc ls res) + (if (pair? ls) + (map1 proc (cdr ls) (cons (proc (car ls)) res)) + (reverse res))) + (define (mapn proc lol res) + (if (pair? (car lol)) + (mapn proc + (map1 cdr lol '()) + (cons (apply1 proc (map1 car lol '())) res)) + (reverse res))) + (if (null? lol) + (map1 proc ls '()) + (mapn proc (cons ls lol) '()))) + +(define (for-each f ls . lol) + (define (for1 f ls) (if (pair? ls) (begin (f (car ls)) (for1 f (cdr ls))))) + (if (null? lol) (for1 f ls) (begin (apply map f ls lol) (if #f #f)))) + +(define (any pred ls) + (if (pair? ls) (if (pred (car ls)) (car ls) (any pred (cdr ls))) #f)) + +(define (every pred ls) + (if (pair? ls) (if (pred (car ls)) (every pred (cdr ls)) #f) #t)) + +(define (delq x ls) + (if (pair? ls) + (if (eq? x (car ls)) (delq x (cdr ls)) (cons (car ls) (delq x (cdr ls)))) + '())) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; syntax + +(define sc-macro-transformer + (lambda (f) + (lambda (expr use-env mac-env) + (make-syntactic-closure mac-env '() (f expr use-env))))) + +(define rsc-macro-transformer + (lambda (f) + (lambda (expr use-env mac-env) + (f expr mac-env)))) + +(define er-macro-transformer + (lambda (f) + (lambda (expr use-env mac-env) + ((lambda (rename compare) (f expr rename compare)) + ((lambda (renames) + (lambda (identifier) + ((lambda (cell) + (if cell + (cdr cell) + ((lambda (name) + (set! renames (cons (cons identifier name) renames)) + name) + (make-syntactic-closure mac-env '() identifier)))) + (assq identifier renames)))) + '()) + (lambda (x y) (identifier=? use-env x use-env y)))))) + +(define-syntax cond + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #f + ((lambda (cl) + (if (compare (rename 'else) (car cl)) + (if (pair? (cddr expr)) + (error "non-final else in cond" expr) + (cons (rename 'begin) (cdr cl))) + (if (if (null? (cdr cl)) #t (compare (rename '=>) (cadr cl))) + (list (list (rename 'lambda) (list (rename 'tmp)) + (list (rename 'if) (rename 'tmp) + (if (null? (cdr cl)) + (rename 'tmp) + (list (caddr cl) (rename 'tmp))) + (cons (rename 'cond) (cddr expr)))) + (car cl)) + (list (rename 'if) + (car cl) + (cons (rename 'begin) (cdr cl)) + (cons (rename 'cond) (cddr expr)))))) + (cadr expr)))))) + +(define-syntax or + (er-macro-transformer + (lambda (expr rename compare) + (cond ((null? (cdr expr)) #f) + ((null? (cddr expr)) (cadr expr)) + (else + (list (rename 'let) (list (list (rename 'tmp) (cadr expr))) + (list (rename 'if) (rename 'tmp) + (rename 'tmp) + (cons (rename 'or) (cddr expr))))))))) + +(define-syntax and + (er-macro-transformer + (lambda (expr rename compare) + (cond ((null? (cdr expr))) + ((null? (cddr expr)) (cadr expr)) + (else (list (rename 'if) (cadr expr) + (cons (rename 'and) (cddr expr)) + #f)))))) + +(define-syntax quasiquote + (er-macro-transformer + (lambda (expr rename compare) + (define (qq x d) + (cond + ((pair? x) + (cond + ((compare (rename 'unquote) (car x)) + (if (<= d 0) + (cadr x) + (list (rename 'list) (list (rename 'quote) 'unquote) + (qq (cadr x) (- d 1))))) + ((compare (rename 'unquote-splicing) (car x)) + (if (<= d 0) + (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)) + (list (rename 'list) (list (rename 'quote) 'unquote-splicing) + (qq (cadr x) (- d 1))))) + ((compare (rename 'quasiquote) (car x)) + (list (rename 'list) (list (rename 'quote) 'quasiquote) + (qq (cadr x) (+ d 1)))) + ((and (<= d 0) (pair? (car x)) (compare (rename 'unquote-splicing) (caar x))) + (if (null? (cdr x)) + (cadar x) + (list (rename 'append) (cadar x) (qq (cdr x) d)))) + (else + (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))))) + ((vector? x) (list (rename 'list->vector) (qq (vector->list x) d))) + ((symbol? x) (list (rename 'quote) x)) + (else x))) + (qq (cadr expr) 0)))) + +(define-syntax letrec + (er-macro-transformer + (lambda (expr rename compare) + ((lambda (defs) + `((,(rename 'lambda) () ,@defs ,@(cddr expr)))) + (map (lambda (x) (cons (rename 'define) x)) (cadr expr)))))) + +(define-syntax let + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) (error "empty let" expr)) + (if (null? (cddr expr)) (error "no let body" expr)) + ((lambda (bindings) + (if (list? bindings) #f (error "bad let bindings")) + (if (every (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + bindings) + ((lambda (vars vals) + (if (identifier? (cadr expr)) + `((,(rename 'lambda) ,vars + (,(rename 'letrec) ((,(cadr expr) + (,(rename 'lambda) ,vars + ,@(cdddr expr)))) + (,(cadr expr) ,@vars))) + ,@vals) + `((,(rename 'lambda) ,vars ,@(cddr expr)) ,@vals))) + (map car bindings) + (map cadr bindings)) + (error "bad let syntax" expr))) + (if (identifier? (cadr expr)) (caddr expr) (cadr expr)))))) + +(define-syntax let* + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) (error "empty let*" expr)) + (if (null? (cddr expr)) (error "no let* body" expr)) + (if (null? (cadr expr)) + `(,(rename 'let) () ,@(cddr expr)) + (if (if (list? (cadr expr)) + (every + (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + (cadr expr)) + #f) + `(,(rename 'let) (,(caadr expr)) + (,(rename 'let*) ,(cdadr expr) ,@(cddr expr))) + (error "bad let* syntax")))))) + +(define-syntax case + (er-macro-transformer + (lambda (expr rename compare) + (define (clause ls) + (cond + ((null? ls) #f) + ((compare (rename 'else) (caar ls)) + `(,(rename 'begin) ,@(cdar ls))) + (else + (if (and (pair? (caar ls)) (null? (cdaar ls))) + `(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp) ',(caaar ls)) + (,(rename 'begin) ,@(cdar ls)) + ,(clause (cdr ls))) + `(,(rename 'if) (,(rename 'memv) ,(rename 'tmp) ',(caar ls)) + (,(rename 'begin) ,@(cdar ls)) + ,(clause (cdr ls))))))) + `(let ((,(rename 'tmp) ,(cadr expr))) + ,(clause (cddr expr)))))) + +(define-syntax do + (er-macro-transformer + (lambda (expr rename compare) + (let* ((body + `(,(rename 'begin) + ,@(cdddr expr) + (,(rename 'lp) + ,@(map (lambda (x) (if (pair? (cddr x)) (caddr x) (car x))) + (cadr expr))))) + (check (caddr expr)) + (wrap + (if (null? (cdr check)) + `(,(rename 'let) ((,(rename 'tmp) ,(car check))) + (,(rename 'if) ,(rename 'tmp) + ,(rename 'tmp) + ,body)) + `(,(rename 'if) ,(car check) + (,(rename 'begin) ,@(cdr check)) + ,body)))) + `(,(rename 'let) ,(rename 'lp) + ,(map (lambda (x) (list (car x) (cadr x))) (cadr expr)) + ,wrap))))) + +(define-syntax delay + (er-macro-transformer + (lambda (expr rename compare) + `(,(rename 'make-promise) (,(rename 'lambda) () ,(cadr expr)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; promises + +(define (make-promise thunk) + (lambda () + (let ((computed? #f) (result #f)) + (if (not computed?) + (begin + (set! result (thunk)) + (set! computed? #t))) + result))) + +(define (force x) (if (procedure? x) (x) x)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; exceptions + +(define (error msg . args) + (raise (make-exception 'user msg args #f #f))) + +(define (with-exception-handler handler thunk) + (letrec ((orig-handler (current-exception-handler)) + (self (lambda (exn) + (current-exception-handler orig-handler) + (let ((res (handler exn))) + (current-exception-handler self) + res)))) + (current-exception-handler self) + (let ((res (thunk))) + (current-exception-handler orig-handler) + res))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; library functions + +;; booleans + +(define (not x) (if x #f #t)) +(define (boolean? x) (if (eq? x #t) #t (eq? x #f))) + +;; char utils + +(define (char-alphabetic? ch) (<= 65 (char->integer (char-upcase ch)) 90)) +(define (char-numeric? ch) (<= 48 (char->integer ch) 57)) +(define (char-whitespace? ch) + (if (eq? ch #\space) + #t + (if (eq? ch #\tab) #t (if (eq? ch #\newline) #t (eq? ch #\return))))) +(define (char-upper-case? ch) (<= 65 (char->integer ch) 90)) +(define (char-lower-case? ch) (<= 97 (char->integer ch) 122)) + +(define (char=? a b) (= (char->integer a) (char->integer b))) +(define (charinteger a) (char->integer b))) +(define (char>? a b) (> (char->integer a) (char->integer b))) +(define (char<=? a b) (<= (char->integer a) (char->integer b))) +(define (char>=? a b) (>= (char->integer a) (char->integer b))) + +(define (char-ci=? a b) + (= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ciinteger (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ci>? a b) + (> (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ci<=? a b) + (<= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ci>=? a b) + (>= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) + +;; string utils + +(define (symbol->string sym) + (call-with-output-string (lambda (out) (write sym out)))) + +(define (list->string ls) + (let ((str (make-string (length ls) #\space))) + (let lp ((ls ls) (i 0)) + (if (pair? ls) + (begin + (string-set! str i (car ls)) + (lp (cdr ls) (+ i 1))))) + str)) + +(define (string->list str) + (let lp ((i (- (string-length str) 1)) (res '())) + (if (< i 0) res (lp (- i 1) (cons (string-ref str i) res))))) + +(define (string-fill! str ch) + (let lp ((i (- (string-length str) 1))) + (if (>= i 0) (begin (string-set! str i ch) (lp (- i 1)))))) + +(define (string . args) (list->string args)) +(define (string-append . args) (string-concatenate args)) +(define (string-copy s) (substring s 0 (string-length s))) + +(define (string=? s1 s2) (eq? (string-cmp s1 s2 #f) 0)) +(define (string? s1 s2) (> (string-cmp s1 s2 #f) 0)) +(define (string>=? s1 s2) (>= (string-cmp s1 s2 #f) 0)) + +(define (string-ci=? s1 s2) (eq? (string-cmp s1 s2 #t) 0)) +(define (string-ci? s1 s2) (> (string-cmp s1 s2 #t) 0)) +(define (string-ci>=? s1 s2) (>= (string-cmp s1 s2 #t) 0)) + +;; list utils + +(define (eqv? a b) (if (eq? a b) #t (and (flonum? a) (flonum? b) (= a b)))) + +(define (member obj ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls)) + (and (pair? ls) (if (eq obj (car ls)) ls (lp (cdr ls))))))) + +(define memv member) + +(define (assoc obj ls) + (if (null? ls) + #f + (if (equal? obj (caar ls)) + (car ls) + (assoc obj (cdr ls))))) + +(define assv assoc) + +;; math utils + +(define (number? x) (if (fixnum? x) #t (if (bignum? x) #t (flonum? x)))) +(define complex? number?) +(define rational? number?) +(define real? number?) +(define (exact? x) (if (fixnum? x) #t (bignum? x))) +(define inexact? flonum?) +(define (integer? x) + (if (fixnum? x) #t (if (bignum? x) #t (and (flonum? x) (= x (truncate x)))))) + +(define (zero? x) (= x 0)) +(define (positive? x) (> x 0)) +(define (negative? x) (< x 0)) +(define (even? n) (= (remainder n 2) 0)) +(define (odd? n) (= (remainder n 2) 1)) + +(define (abs x) (if (< x 0) (- x) x)) + +(define (numerator x) + (if (integer? x) x (numerator (* x 10)))) +(define (denominator x) + (if (exact? x) + 1 + (let lp ((x x) (r 1.0)) (if (integer? x) r (lp (* x 10) (* r 10)))))) + +(define (modulo a b) + (let ((res (remainder a b))) + (if (< b 0) + (if (<= res 0) res (+ res b)) + (if (>= res 0) res (+ res b))))) + +(define (gcd a b) + (if (= b 0) + (abs a) + (gcd b (remainder a b)))) + +(define (lcm a b) + (abs (quotient (* a b) (gcd a b)))) + +(define (max x . rest) + (let lp ((hi x) (ls rest)) + (if (null? ls) + hi + (lp (if (> (car ls) hi) (car ls) hi) (cdr ls))))) + +(define (min x . rest) + (let lp ((lo x) (ls rest)) + (if (null? ls) + lo + (lp (if (< (car ls) lo) (car ls) lo) (cdr ls))))) + +(define (real-part z) z) +(define (imag-part z) 0.0) +(define magnitude abs) +(define (angle z) (if (< z 0) 3.141592653589793 0)) + +(define (atan x . o) (if (null? o) (atan1 x) (atan1 (/ x (car o))))) + +(define (digit-char n) + (if (<= n 9) + (integer->char (+ n (char->integer #\0))) + (integer->char (+ (- n 10) (char->integer #\A))))) +(define (digit-value ch) + (if (char-numeric? ch) + (- (char->integer ch) (char->integer #\0)) + (and (<= 65 (char->integer (char-upcase ch)) 70) + (- (char->integer (char-upcase ch)) 55)))) + +(define (number->string num . o) + (if (if (null? o) #t (eq? 10 (car o))) + (call-with-output-string (lambda (out) (write num out))) + (let lp ((n (abs num)) (d (car o)) (res '())) + (if (> n 0) + (lp (quotient n d) d (cons (digit-char (remainder n d)) res)) + (if (null? res) + "0" + (list->string (if (negative? num) (cons #\- res) res))))))) + +;; vector utils + +(define (list->vector ls) + (let ((vec (make-vector (length ls) #f))) + (let lp ((ls ls) (i 0)) + (if (pair? ls) + (begin + (vector-set! vec i (car ls)) + (lp (cdr ls) (+ i 1))))) + vec)) + +(define (vector->list vec) + (let lp ((i (- (vector-length vec) 1)) (res '())) + (if (< i 0) res (lp (- i 1) (cons (vector-ref vec i) res))))) + +(define (vector-fill! str ch) + (let lp ((i (- (vector-length str) 1))) + (if (>= i 0) (begin (vector-set! str i ch) (lp (- i 1)))))) + +(define (vector . args) (list->vector args)) + +;; I/O utils + +(define (char-ready? . o) + (not (eof-object? (peek-char (if (pair? o) (car o) (current-input-port)))))) + +(define (call-with-input-string str proc) + (let* ((in (open-input-string str)) + (res (proc in))) + (close-input-port in) + res)) + +(define (call-with-output-string proc) + (let ((out (open-output-string))) + (proc out) + (let ((res (get-output-string out))) + (close-output-port out) + res))) + +(define (call-with-input-file file proc) + (let* ((in (open-input-file file)) + (res (proc in))) + (close-input-port in) + res)) + +(define (call-with-output-file file proc) + (let* ((out (open-output-file file)) + (res (proc out))) + (close-output-port out) + res)) + +(define (with-input-from-file file thunk) + (let ((old-in (current-input-port)) + (tmp-in (open-input-file file))) + (current-input-port tmp-in) + (let ((res (thunk))) + (current-input-port old-in) + res))) + +(define (with-output-to-file file thunk) + (let ((old-out (current-output-port)) + (tmp-out (open-output-file file))) + (current-output-port tmp-out) + (let ((res (thunk))) + (current-output-port old-out) + res))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; values + +(define *values-tag* (list 'values)) + +(define (values . ls) + (if (and (pair? ls) (null? (cdr ls))) + (car ls) + (cons *values-tag* ls))) + +(define (call-with-values producer consumer) + (let ((res (producer))) + (if (and (pair? res) (eq? *values-tag* (car res))) + (apply consumer (cdr res)) + (consumer res)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; dynamic-wind + +(define *dk* (list #f)) + +(define (dynamic-wind before thunk after) + (let ((dk *dk*)) + (set-dk! (cons (cons before after) dk)) + (let ((res (thunk))) (set-dk! dk) res))) + +(define (set-dk! dk) + (if (not (eq? dk *dk*)) + (begin + (set-dk! (cdr dk)) + (let ((before (car (car dk))) (dk dk)) + (set-car! *dk* (cons (cdr (car dk)) before)) + (set-cdr! *dk* dk) + (set-car! dk #f) + (set-cdr! dk '()) + (set! *dk* dk) + (before))))) + +(define (call-with-current-continuation proc) + (let ((dk *dk*)) + (%call/cc (lambda (k) (proc (lambda (x) (set-dk! dk) (k x))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; syntax-rules + +(define-syntax syntax-rules + (er-macro-transformer + (lambda (expr rename compare) + (let ((ellipse-specified? (identifier? (cadr expr))) + (count 0) + (_er-macro-transformer (rename 'er-macro-transformer)) + (_lambda (rename 'lambda)) (_let (rename 'let)) + (_begin (rename 'begin)) (_if (rename 'if)) + (_and (rename 'and)) (_or (rename 'or)) + (_eq? (rename 'eq?)) (_equal? (rename 'equal?)) + (_car (rename 'car)) (_cdr (rename 'cdr)) + (_cons (rename 'cons)) (_pair? (rename 'pair?)) + (_null? (rename 'null?)) (_expr (rename 'expr)) + (_rename (rename 'rename)) (_compare (rename 'compare)) + (_quote (rename 'syntax-quote)) (_apply (rename 'apply)) + (_append (rename 'append)) (_map (rename 'map)) + (_vector? (rename 'vector?)) (_list? (rename 'list?)) + (_lp (rename 'lp)) (_reverse (rename 'reverse)) + (_len (rename'len)) (_length (rename 'length)) + (_- (rename '-)) (_>= (rename '>=)) (_error (rename 'error)) + (_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i)) + (_vector->list (rename 'vector->list)) + (_list->vector (rename 'list->vector))) + (define ellipse (rename (if ellipse-specified? (cadr expr) '...))) + (define lits (if ellipse-specified? (caddr expr) (cadr expr))) + (define forms (if ellipse-specified? (cdddr expr) (cddr expr))) + (define (next-v) + (set! count (+ count 1)) + (rename (string->symbol (string-append "v." (number->string count))))) + (define (expand-pattern pat tmpl) + (let lp ((p (cdr pat)) + (x (list _cdr _expr)) + (dim 0) + (vars '()) + (k (lambda (vars) + (or (expand-template tmpl vars) + (list _begin #f))))) + (let ((v (next-v))) + (list + _let (list (list v x)) + (cond + ((identifier? p) + (if (any (lambda (l) (compare p l)) lits) + (list _and (list _compare v (list _quote p)) (k vars)) + (list _let (list (list p v)) (k (cons (cons p dim) vars))))) + ((ellipse? p) + (cond + ((not (null? (cddr p))) + (cond + ((not (list? (cddr p))) + (error "dotted ellipse" p)) + ((any (lambda (x) (and (identifier? x) (compare x ellipse))) + (cddr p)) + (error "multiple ellipses" p)) + (else + (let ((len (length (cdr (cdr p))))) + `(,_let ((,_len (,_length ,v))) + (,_and (,_>= ,_len ,len) + (,_let ,_lp ((,_ls ,v) + (,_i (,_- ,_len ,len)) + (,_res (,_quote ()))) + (,_if (,_>= 0 ,_i) + ,(lp `(,@(cdr (cdr p)) ,(car p) ,(car (cdr p))) + `(,_append ,_ls (,_reverse ,_res)) + dim + vars + k) + (,_lp (,_cdr ,_ls) + (,_- ,_i 1) + (,_cons (,_car ,_ls) ,_res)))))))))) + ((identifier? (car p)) + (list _and (list _list? v) + (list _let (list (list (car p) v)) + (k (cons (cons (car p) (+ 1 dim)) vars))))) + (else + (let* ((w (next-v)) + (new-vars (all-vars (car p) (+ dim 1))) + (ls-vars (map (lambda (x) + (rename + (string->symbol + (string-append + (symbol->string + (identifier->symbol (car x))) + "-ls")))) + new-vars)) + (once + (lp (car p) (list _car w) (+ dim 1) '() + (lambda (_) + (cons + _lp + (cons + (list _cdr w) + (map (lambda (x l) + (list _cons (car x) l)) + new-vars + ls-vars))))))) + (list + _let + _lp (cons (list w v) + (map (lambda (x) (list x '())) ls-vars)) + (list _if (list _null? w) + (list _let (map (lambda (x l) + (list (car x) (list _reverse l))) + new-vars + ls-vars) + (k (append new-vars vars))) + (list _and (list _pair? w) once))))))) + ((pair? p) + (list _and (list _pair? v) + (lp (car p) + (list _car v) + dim + vars + (lambda (vars) + (lp (cdr p) (list _cdr v) dim vars k))))) + ((vector? p) + (list _and + (list _vector? v) + (lp (vector->list p) (list _vector->list v) dim vars k))) + ((null? p) (list _and (list _null? v) (k vars))) + (else (list _and (list _equal? v p) (k vars)))))))) + (define (ellipse-escape? x) (and (pair? x) (compare ellipse (car x)))) + (define (ellipse? x) + (and (pair? x) (pair? (cdr x)) (compare ellipse (cadr x)))) + (define (ellipse-depth x) + (if (ellipse? x) + (+ 1 (ellipse-depth (cdr x))) + 0)) + (define (ellipse-tail x) + (if (ellipse? x) + (ellipse-tail (cdr x)) + (cdr x))) + (define (all-vars x dim) + (let lp ((x x) (dim dim) (vars '())) + (cond ((identifier? x) + (if (any (lambda (lit) (compare x lit)) lits) + vars + (cons (cons x dim) vars))) + ((ellipse? x) (lp (car x) (+ dim 1) vars)) + ((pair? x) (lp (car x) dim (lp (cdr x) dim vars))) + ((vector? x) (lp (vector->list x) dim vars)) + (else vars)))) + (define (free-vars x vars dim) + (let lp ((x x) (free '())) + (cond + ((identifier? x) + (if (and (not (memq x free)) + (cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim))) + (else #f))) + (cons x free) + free)) + ((pair? x) (lp (car x) (lp (cdr x) free))) + ((vector? x) (lp (vector->list x) free)) + (else free)))) + (define (expand-template tmpl vars) + (let lp ((t tmpl) (dim 0)) + (cond + ((identifier? t) + (cond + ((any (lambda (v) (compare t (car v))) vars) + => (lambda (cell) + (if (<= (cdr cell) dim) + t + (error "too few ...'s")))) + (else + (list _rename (list _quote t))))) + ((pair? t) + (cond + ((ellipse-escape? t) + (if (pair? (cdr t)) + (if (pair? (cddr t)) (cddr t) (cadr t)) + (cdr t))) + ((ellipse? t) + (let* ((depth (ellipse-depth t)) + (ell-dim (+ dim depth)) + (ell-vars (free-vars (car t) vars ell-dim))) + (if (null? ell-vars) + (error "too many ...'s") + (let* ((once (lp (car t) ell-dim)) + (nest (if (and (null? (cdr ell-vars)) + (identifier? once) + (eq? once (car vars))) + once ;; shortcut + (cons _map + (cons (list _lambda ell-vars once) + ell-vars)))) + (many (do ((d depth (- d 1)) + (many nest + (list _apply _append many))) + ((= d 1) many)))) + (if (null? (ellipse-tail t)) + many ;; shortcut + (list _append many (lp (ellipse-tail t) dim))))))) + (else (list _cons (lp (car t) dim) (lp (cdr t) dim))))) + ((vector? t) (list _list->vector (lp (vector->list t) dim))) + ((null? t) (list _quote '())) + (else t)))) + (list + _er-macro-transformer + (list _lambda (list _expr _rename _compare) + (cons + _or + (append + (map + (lambda (clause) (expand-pattern (car clause) (cadr clause))) + forms) + (list (list _error "no expansion for" + (list (rename 'strip-syntactic-closures) _expr))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; modules + +(define *config-env* #f) + +(define-syntax import + (er-macro-transformer + (lambda (expr rename compare) + (let lp ((ls (cdr expr)) (res '())) + (cond + ((null? ls) + (cons 'begin (reverse res))) + (else + (let ((mod+imps (eval `(resolve-import ',(car ls)) *config-env*))) + (if (pair? mod+imps) + (lp (cdr ls) + (cons `(%env-copy! + #f + (vector-ref + (eval '(load-module ',(car mod+imps)) *config-env*) + 1) + ',(cdr mod+imps) + #f) + res)) + (error "couldn't find module" (car ls)))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; SRFI-0 + +(define-syntax cond-expand + (er-macro-transformer + (lambda (expr rename compare) + (define (check x) + (if (pair? x) + (case (car x) + ((and) (every check (cdr x))) + ((or) (any check (cdr x))) + ((not) (not (check (cadr x)))) + (else (error "cond-expand: bad feature" x))) + (memq (identifier->symbol x) *features*))) + (let expand ((ls (cdr expr))) + (cond ((null? ls) (error "cond-expand: no expansions" expr)) + ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls))) + ((eq? 'else (identifier->symbol (caar ls))) + (if (pair? (cdr ls)) + (error "cond-expand: else in non-final position") + `(,(rename 'begin) ,@(cdar ls)))) + ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls))) + (else (expand (cdr ls)))))))) + diff --git a/lib/srfi/1.module b/lib/srfi/1.module new file mode 100644 index 00000000..3d3da044 --- /dev/null +++ b/lib/srfi/1.module @@ -0,0 +1,31 @@ + +(define-module (srfi 1) + (export + xcons cons* make-list list-tabulate list-copy circular-list iota + proper-list? circular-list? dotted-list? not-pair? null-list? list= + first second third fourth fifth sixth seventh eighth ninth tenth + car+cdr take drop take-right drop-right take! drop-right! split-at split-at! + last last-pair length+ concatenate append! concatenate! reverse! + append-reverse append-reverse! + zip unzip1 unzip2 unzip3 unzip4 unzip5 count + fold unfold pair-fold reduce fold-right unfold-right + pair-fold-right reduce-right + append-map append-map! map! pair-for-each filter-map map-in-order + filter partition remove filter! partition! remove! find find-tail any every + list-index take-while drop-while take-while! span break span! break! + delete delete-duplicates delete! delete-duplicates! + alist-cons alist-copy alist-delete alist-delete! + lset<= lset= lset-adjoin lset-union lset-union! lset-intersection + lset-intersection! lset-difference lset-difference! lset-xor lset-xor! + lset-diff+intersection lset-diff+intersection!) + (import (scheme)) + (include "1/predicates.scm" + "1/selectors.scm" + "1/search.scm" + "1/misc.scm" + "1/constructors.scm" + "1/fold.scm" + "1/deletion.scm" + "1/alists.scm" + "1/lset.scm")) + diff --git a/lib/srfi/1/alists.scm b/lib/srfi/1/alists.scm new file mode 100644 index 00000000..a35db42c --- /dev/null +++ b/lib/srfi/1/alists.scm @@ -0,0 +1,14 @@ +;; alist.scm -- association list utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (alist-cons key value ls) (cons (cons key value) ls)) + +(define (alist-copy ls) (map (lambda (x) (cons (car x) (cdr x))) ls)) + +(define (alist-delete key ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (remove (lambda (x) (eq (car x) key)) ls))) + +(define alist-delete! alist-delete) + diff --git a/lib/srfi/1/constructors.scm b/lib/srfi/1/constructors.scm new file mode 100644 index 00000000..1f8a8d5e --- /dev/null +++ b/lib/srfi/1/constructors.scm @@ -0,0 +1,36 @@ +;; constructors.scm -- list construction utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (xcons a b) (cons b a)) + +(define (cons* x . args) + (let lp ((rev '()) (x x) (ls args)) + (if (null? ls) + (append-reverse rev x) + (lp (cons x rev) (car ls) (cdr ls))))) + +(define (make-list n . o) + (let ((default (if (pair? o) (car o)))) + (let lp ((n n) (res '())) + (if (<= n 0) res (lp (- n 1) (cons default res)))))) + +(define (list-tabulate n proc) + (let lp ((n n) (res '())) + (if (< n 0) res (lp (- n 1) (cons (proc n) res))))) + +(define (list-copy ls) (reverse! (reverse ls))) + +(define (circular-list x . args) + (let ((res (cons x args))) + (set-cdr! (last-pair res) res) + res)) + +(define (iota count . o) + (let ((start (if (pair? o) (car o) 0)) + (step (if (and (pair? o) (pair? (cdr o))) (cadr o) 1))) + (let lp ((i count) (n (+ start (* (- count 1) step))) (res '())) + (if (<= i 0) + res + (lp (- i 1) (- n step) (cons n res)))))) + diff --git a/lib/srfi/1/deletion.scm b/lib/srfi/1/deletion.scm new file mode 100644 index 00000000..2d44275a --- /dev/null +++ b/lib/srfi/1/deletion.scm @@ -0,0 +1,25 @@ +;; deletion.scm -- list deletion utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (delete x ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (if (eq? eq eq?) + (let lp ((ls ls) (rev '())) ;; fast path for delq + (let ((tail (memq x ls))) + (if tail + (lp (cdr tail) (take-up-to-reverse ls tail rev)) + (if (pair? rev) (append-reverse! rev ls) ls)))) + (remove (lambda (y) (eq x y)) ls)))) + +(define delete! delete) + +(define (delete-duplicates ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls) (res '())) + (if (pair? ls) + (lp (cdr ls) (if (member (car ls) res) res (cons (car ls) res))) + (reverse! res))))) + +(define delete-duplicates! delete-duplicates) + diff --git a/lib/srfi/1/fold.scm b/lib/srfi/1/fold.scm new file mode 100644 index 00000000..892b075c --- /dev/null +++ b/lib/srfi/1/fold.scm @@ -0,0 +1,115 @@ +;; fold.scm -- list fold/reduce utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (fold kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls) (acc knil)) + (if (pair? ls) (lp (cdr ls) (kons (car ls) acc)) acc)) + (let lp ((lists (cons ls lists)) (acc knil)) + (if (every pair? lists) + (lp (map cdr lists) (apply kons (map-onto car lists (list acc)))) + acc)))) + +(define (fold-right kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls)) + (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil)) + (let lp ((lists (cons ls lists))) + (if (every pair? lists) + (apply kons (map-onto car lists (lp (map cdr lists)))) + knil)))) + +(define (pair-fold kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls) (acc knil)) + (if (pair? ls) (lp (cdr ls) (kons ls acc)) acc)) + (let lp ((lists (cons ls lists)) (acc knil)) + (if (every pair? lists) + (lp (map cdr lists) (apply kons (append lists (list acc)))) + acc)))) + +(define (pair-fold-right kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls)) + (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil)) + (let lp ((lists (cons ls lists))) + (if (every pair? lists) + (apply kons (append lists (lp (map cdr lists)))) + knil)))) + +(define (reduce f identity ls) + (if (null? ls) identity (fold f (car ls) (cdr ls)))) + +(define (reduce-right f identity ls) + (if (null? ls) identity (fold-right f (car ls) (cdr ls)))) + +(define (unfold p f g seed . o) + (let lp ((seed seed)) + (if (p seed) + (if (pair? o) ((car o) seed) '()) + (cons (f seed) (lp (g seed)))))) + +(define (unfold-right p f g seed . o) + (let lp ((seed seed) (res (if (pair? o) (car o) '()))) + (if (p seed) res (lp (g seed) (cons (f seed) res))))) + +(define (append-map-helper append f ls lists) + (if (null? lists) + (if (null? ls) + '() + (let ((rev-ls (reverse ls))) + (let lp ((ls (cdr rev-ls)) (res (car rev-ls))) + (if (null? ls) res (lp (cdr ls) (append (f (car ls) res)))) + ))) + (if (and (pair? ls) (every pair? lists)) + (let lp ((lists (cons ls lists))) + (let ((vals (apply f (map car lists))) + (cdrs (map cdr lists))) + (if (every pair? cdrs) (append vals (lp cdrs)) vals))) + '()))) + +(define (append-map f ls . lists) + (append-map-helper append f ls lists)) + +(define (append-map! f ls . lists) + (append-map-helper append! f ls lists)) + +(define map! map) +(define map-in-order map) + +(define (pair-for-each f ls . lists) + (apply pair-fold (lambda (x _) (f x)) ls lists)) + +(define (filter-map f ls . lists) + (if (null? lists) + (let lp ((ls ls) (res '())) + (if (pair? ls) + (let ((x (f (car ls)))) (lp (cdr ls) (if f (cons f res) res))) + (reverse! res))) + (filter (lambda (x) x) (apply map f ls lists)))) + +(define (take-up-to-reverse from to init) + (if (eq? from to) + init + (take-up-to-reverse (cdr from) to (cons (car from) init)))) + +(define (remove pred ls) + (let lp ((ls ls) (rev '())) + (let ((tail (find-tail pred ls))) + (if tail + (lp (cdr tail) (take-up-to-reverse ls tail rev)) + (if (pair? rev) (append-reverse! rev ls) ls))))) + +(define (filter pred ls) (remove (lambda (x) (not (pred x))) ls)) + +(define (partition pred ls) + (let lp ((ls ls) (good '()) (bad '())) + (cond ((null? ls) (values (reverse! good) (reverse! bad))) + ((pred (car ls)) (lp (cdr ls) (cons (car ls) good) bad)) + (else (lp (cdr ls) good (cons (car ls) bad)))))) + +(define filter! filter) +(define remove! remove) +(define partition! partition) + diff --git a/lib/srfi/1/lset.scm b/lib/srfi/1/lset.scm new file mode 100644 index 00000000..8565fac3 --- /dev/null +++ b/lib/srfi/1/lset.scm @@ -0,0 +1,51 @@ +;; lset.scm -- list set library +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (lset<= eq . sets) + (if (null? sets) + #t + (let lp1 ((set1 (car sets)) (sets (cdr sets))) + (if (null? sets) + #t + (let ((set2 (car sets))) + (let lp2 ((ls set1)) + (if (pair? ls) + (and (member (car set1) set2 eq) (lp2 (cdr ls))) + (lp1 set2 (cdr sets))))))))) + +(define (lset= eq . sets) + (and (apply lset<= eq sets) (apply lset<= eq (reverse sets)))) + +(define (lset-adjoin eq set . elts) + (lset-union2 eq elts set)) + +(define (lset-union2 eq a b) + (if (null? b) + a + (lset-union2 eq (if (member (car b) a eq) a (cons (car b) a)) (cdr b)))) + +(define (lset-union eq . sets) + (reduce (lambda (a b) (lset-union2 eq a b)) '() sets)) + +(define (lset-intersection eq . sets) + (reduce (lambda (a b) (filter (lambda (x) (member x b eq)) a)) '() sets)) + +(define (lset-difference eq . sets) + (reduce (lambda (a b) (remove (lambda (x) (member x b eq)) a)) '() sets)) + +(define (lset-xor eq . sets) + (reduce (lambda (a b) + (append (filter (lambda (x) (member x b eq)) a) + (filter (lambda (x) (member x a eq)) b))) + '() + sets)) + +(define (lset-diff+intersection eq . sets) + (values (apply lset-difference eq sets) (apply lset-intersection eq sets))) + +(define lset-diff+intersection! lset-diff+intersection) +(define lset-xor! lset-xor) +(define lset-difference! lset-difference) +(define lset-intersection! lset-intersection) +(define lset-union! lset-union) diff --git a/lib/srfi/1/misc.scm b/lib/srfi/1/misc.scm new file mode 100644 index 00000000..1e7568df --- /dev/null +++ b/lib/srfi/1/misc.scm @@ -0,0 +1,54 @@ +;; misc.scm -- miscellaneous list utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (map-onto proc ls init) + (let lp ((ls ls) (res init)) + (if (null? ls) res (lp (cdr ls) (cons (proc (car ls)) res))))) + +(define (append! . lists) (concatenate! lists)) + +(define (concatenate lists) + (let lp ((ls (reverse lists)) (res '())) + (if (null? ls) res (lp (cdr ls) (append (car ls) res))))) + +(define (concatenate! lists) + (if (null? lists) + '() + (let lp ((ls lists)) + (cond ((not (pair? (cdr ls))) + lists) + (else + (set-cdr! (last-pair (car ls)) (cadr ls)) + (lp (cdr ls))))))) + +(define (append-reverse rev tail) + (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail)))) + +(define (append-reverse! rev tail) + (if (null? rev) + tail + (let ((head (reverse! rev))) + (set-cdr! rev tail) + head))) + +(define (zip . lists) (apply map list lists)) + +(define (unzip1 ls) (map car ls)) +(define (unzip2 ls) (values (map car ls) (map cadr ls))) +(define (unzip3 ls) (values (map car ls) (map cadr ls) (map caddr ls))) +(define (unzip4 ls) + (values (map car ls) (map cadr ls) (map caddr ls) (map cadddr ls))) +(define (unzip5 ls) + (values (map car ls) (map cadr ls) (map caddr ls) + (map cadddr ls) (map (lambda (x) (car (cddddr x))) ls))) + +(define (count pred ls . lists) + (if (null? lists) + (let lp ((ls ls) (res 0)) + (if (pair? ls) (lp (cdr ls) (if (pred (car ls)) (+ res 1) res)) res)) + (let lp ((lists (cons ls lists)) (res 0)) + (if (every pair? lists) + (lp (map cdr lists) (if (apply pred (map car lists)) (+ res 1) res)) + res)))) + diff --git a/lib/srfi/1/predicates.scm b/lib/srfi/1/predicates.scm new file mode 100644 index 00000000..be84e085 --- /dev/null +++ b/lib/srfi/1/predicates.scm @@ -0,0 +1,42 @@ +;; predicates.scm -- list prediates +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (proper-list? x) + (cond ((null? x) #t) + ((pair? x) (proper-list? (cdr x))) + (else #f))) + +(define (circular-list? x) + (and (pair? x) (pair? (cdr x)) + (let race ((hare (cdr x)) (tortoise x)) + (or (eq? hare tortoise) + (and (pair? hare) (pair? (cdr hare)) + (race (cddr hare) (cdr tortoise))))))) + +(define (dotted-list? x) + (not (proper-list? x))) + +(define (not-pair? x) (not (pair? x))) + +(define (null-list? x) (null? x)) ; no error + +(define (list= eq . lists) + (let lp1 ((lists lists)) + (or (null? lists) + (null? (cdr lists)) + (let lp2 ((ls1 (car lists)) (ls2 (cadr lists))) + (if (null? ls1) + (and (null? ls2) + (lp1 (cdr lists))) + (and (eq (car ls1) (car ls2)) + (lp2 (cdr ls1) (cdr ls2)))))))) + +(define (length+ x) + (if (not (pair? x)) + 0 + (let lp ((hare (cdr x)) (tortoise x) (res 0)) + (and (not (eq? hare tortoise)) + (if (pair? hare) + (lp (cddr hare) (cdr tortoise) (+ res 1)) + res))))) diff --git a/lib/srfi/1/search.scm b/lib/srfi/1/search.scm new file mode 100644 index 00000000..ea31d931 --- /dev/null +++ b/lib/srfi/1/search.scm @@ -0,0 +1,54 @@ +;; search.scm -- list searching and splitting +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (find pred ls) + (cond ((find-tail pred ls) => car) (else #f))) + +(define (find-tail pred ls) + (and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls))))) + +(define (take-while pred ls) + (let lp ((ls ls) (res '())) + (if (and (pair? ls) (pred (car ls))) + (lp (cdr ls) (cons (car ls) res)) + (reverse! res)))) + +(define take-while! take-while) + +(define (drop-while pred ls) + (or (find-tail (lambda (x) (not (pred x))) ls) '())) + +(define (span pred ls) + (let lp ((ls ls) (res '())) + (if (and (pair? ls) (pred (car ls))) + (lp (cdr ls) (cons (car ls) res)) + (values (reverse! res) ls)))) + +(define span! span) + +(define (break pred ls) (span (lambda (x) (not (pred x))) ls)) + +(define break! break) + +(define (any pred ls . lists) + (if (null? lists) + (let lp ((ls ls)) (and (pair? ls) (if (pred (car ls)) (car ls) (lp (cdr ls))))) + (let lp ((lists (cons ls lists))) + (and (every pair? lists) + (let ((args (map car lists))) + (if (apply pred args) args (lp (map cdr lists)))))))) + +(define (every pred ls . lists) + (if (null? lists) + (let lp ((ls ls)) (if (pair? ls) (and (pred (car ls)) (lp (cdr ls))) #t)) + (not (apply any (lambda (x) (not (pred x))) ls lists)))) + +(define (list-index pred ls . lists) + (if (null? lists) + (let lp ((ls ls) (n 0)) + (and (pair? ls) (if (pred (car ls)) n (lp (cdr ls) (+ n 1))))) + (let lp ((lists (cons ls lists)) (n 0)) + (and (every pair? lists) + (if (apply pred (map car lists)) n (lp (map cdr lists) (+ n 1))) + )))) diff --git a/lib/srfi/1/selectors.scm b/lib/srfi/1/selectors.scm new file mode 100644 index 00000000..74ef7119 --- /dev/null +++ b/lib/srfi/1/selectors.scm @@ -0,0 +1,59 @@ +;; selectors.scm -- extended list selectors +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define first car) +(define second cadr) +(define third caddr) +(define fourth cadddr) +(define (fifth ls) (car (cdr (cdr (cdr (cdr ls)))))) +(define (sixth ls) (car (cdr (cdr (cdr (cdr (cdr ls))))))) +(define (seventh ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))) +(define (eighth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))) +(define (ninth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))) +(define (tenth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))))) + +(define (car+cdr x) (values (car x) (cdr x))) + +(define (take ls i) + (let lp ((i i) (ls ls) (res '())) + (if (<= i 0) + (reverse! res) + (lp (- i 1) (cdr ls) (cons (car ls) res))))) + +(define (take! ls i) + (if (<= i 0) + '() + (let ((tail (list-tail ls (- i 1)))) + (set-cdr! tail '()) + ls))) + +(define (drop ls i) + (if (<= i 0) ls (drop (cdr ls) (- i 1)))) + +(define (take-right ls i) + (drop ls (- (length+ ls) i))) + +(define (drop-right ls i) + (take ls (- (length+ ls) i))) + +(define (drop-right! ls i) + (take! ls (- (length+ ls) i))) + +(define (split-at ls i) + (let lp ((i i) (ls ls) (res '())) + (if (<= i 0) + (values (reverse! res) ls) + (lp (- i 1) (cdr ls) (cons (car ls) res))))) + +(define (split-at! ls i) + (if (<= i 0) + (values '() ls) + (let* ((tail (list-tail ls (- i 1))) + (right (cdr tail))) + (set-cdr! tail '()) + (values ls right)))) + +(define (last ls) (if (null? (cdr ls)) (car ls) (last (cdr ls)))) +(define (last-pair ls) (if (null? (cdr ls)) ls (last-pair (cdr ls)))) + diff --git a/lib/srfi/11.module b/lib/srfi/11.module new file mode 100644 index 00000000..f3c91df8 --- /dev/null +++ b/lib/srfi/11.module @@ -0,0 +1,28 @@ + +(define-module (srfi 11) + (export let-values let*-values) + (import-immutable (scheme)) + (body + (define-syntax let*-values + (syntax-rules () + ((let*-values () . body) + (begin . body)) + ((let*-values (((a) expr) . rest) . body) + (let ((a expr)) (let*-values rest . body))) + ((let*-values ((params expr) . rest) . body) + (call-with-values (lambda () expr) + (lambda params (let*-values rest . body)))))) + (define-syntax let-values + (syntax-rules () + ((let-values ("step") (binds ...) bind expr maps () () . body) + (let*-values (binds ... (bind expr)) (let maps . body))) + ((let-values ("step") (binds ...) bind old-expr maps () ((params expr) . rest) . body) + (let-values ("step") (binds ... (bind old-expr)) () expr maps params rest . body)) + ((let-values ("step") binds (bind ...) expr (maps ...) (x . y) rest . body) + (let-values ("step") binds (bind ... tmp) expr (maps ... (x tmp)) y rest . body)) + ((let-values ("step") binds (bind ...) expr (maps ...) x rest . body) + (let-values ("step") binds (bind ... . tmp) expr (maps ... (x tmp)) () rest . body)) + ((let-values ((params expr) . rest) . body) + (let-values ("step") () () expr () params rest . body)) + )))) + diff --git a/lib/srfi/16.module b/lib/srfi/16.module new file mode 100644 index 00000000..f931a376 --- /dev/null +++ b/lib/srfi/16.module @@ -0,0 +1,24 @@ + +(define-module (srfi 16) + (export case-lambda) + (import-immutable (scheme)) + (body + (define-syntax %case + (syntax-rules () + ((%case args len n p ((params ...) . body) . rest) + (if (= len (length '(params ...))) + (apply (lambda (params ...) . body) args) + (%case args len 0 () . rest))) + ((%case args len n (p ...) ((x . y) . body) . rest) + (%case args len (+ n 1) (p ... x) (y . body) . rest)) + ((%case args len n (p ...) (y . body) . rest) + (if (>= len n) + (apply (lambda (p ... y) . body) args) + (%case args len 0 () . rest))) + ((%case args len n p) + (error "case-lambda: no cases matched")))) + (define-syntax case-lambda + (syntax-rules () + ((case-lambda . clauses) + (lambda args (let ((len (length args))) (%case args len 0 () . clauses)))))))) + diff --git a/lib/srfi/18.module b/lib/srfi/18.module new file mode 100644 index 00000000..3ed564f8 --- /dev/null +++ b/lib/srfi/18.module @@ -0,0 +1,24 @@ + +(define-module (srfi 18) + (export + current-thread thread? make-thread thread-name + thread-specific thread-specific-set! thread-start! + thread-yield! thread-sleep! thread-terminate! + thread-join! mutex? make-mutex mutex-name + mutex-specific mutex-specific-set! mutex-state + mutex-lock! mutex-unlock! condition-variable? + make-condition-variable condition-variable-name + condition-variable-specific condition-variable-specific-set! + condition-variable-signal! condition-variable-broadcast! + current-time time? time->seconds seconds->time + current-exception-handler with-exception-handler raise + join-timeout-exception? abandoned-mutex-exception? + terminated-thread-exception? uncaught-exception? + uncaught-exception-reason) + (import-immutable (scheme) + (srfi 9) + (chibi ast) + (chibi time)) + (include-shared "18/threads") + (include "18/types.scm" "18/interface.scm")) + diff --git a/lib/srfi/18/interface.scm b/lib/srfi/18/interface.scm new file mode 100644 index 00000000..f814aa6a --- /dev/null +++ b/lib/srfi/18/interface.scm @@ -0,0 +1,63 @@ + +(define (thread-join! thread . o) + (let ((timeout (if (pair? o) (car o) #f))) + (cond + ((%thread-join! thread timeout)) + (else + (thread-yield!) + (if (thread-timeout?) + (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (error "timed out waiting for thread" thread)) + #t))))) + +(define (thread-terminate! thread) + (if (%thread-terminate! thread) ;; need to yield if terminating ourself + (thread-yield!))) + +(define (thread-sleep! timeout) + (%thread-sleep! timeout) + (thread-yield!)) + +(define (mutex-lock! mutex . o) + (let ((timeout (and (pair? o) (car o))) + (thread (if (and (pair? o) (pair? (cdr o))) (cadr o) #t))) + (cond ((%mutex-lock! mutex timeout thread)) + (else + (thread-yield!) + (not (thread-timeout?)))))) + +(define (mutex-unlock! mutex . o) + (let ((condvar (and (pair? o) (car o))) + (timeout (if (and (pair? o) (pair? (cdr o))) (cadr o) #f))) + (cond ((%mutex-unlock! mutex condvar timeout)) + (else + (thread-yield!) + (not (thread-timeout?)))))) + +(define current-time get-time-of-day) +(define time? timeval?) + +(define (join-timeout-exception? x) + (and (exception? x) + (equal? (exception-message x) "timed out waiting for thread"))) + +;; XXXX flush out exception types +(define (abandoned-mutex-exception? x) #f) +(define (terminated-thread-exception? x) #f) +(define (uncaught-exception? x) #f) +(define (uncaught-exception-reason x) #f) + +;; signal runner + +(define (signal-runner) + (let lp () + (let ((n (pop-signal!))) + (cond + ((integer? n) + (let ((handler (get-signal-handler n))) + (if (procedure? handler) + (handler n)))) + (else + (thread-sleep! #t)))) + (lp))) diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c new file mode 100644 index 00000000..b84d59f4 --- /dev/null +++ b/lib/srfi/18/threads.c @@ -0,0 +1,421 @@ +/* threads.c -- SRFI-18 thread primitives */ +/* Copyright (c) 2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include +#include +#include +#include + +#define sexp_mutex_name(x) sexp_slot_ref(x, 0) +#define sexp_mutex_specific(x) sexp_slot_ref(x, 1) +#define sexp_mutex_thread(x) sexp_slot_ref(x, 2) +#define sexp_mutex_lockp(x) sexp_slot_ref(x, 3) + +#define sexp_condvar_name(x) sexp_slot_ref(x, 0) +#define sexp_condvar_specific(x) sexp_slot_ref(x, 1) +#define sexp_condvar_threads(x) sexp_slot_ref(x, 2) + +#define timeval_le(a, b) (((a).tv_sec < (b).tv_sec) || (((a).tv_sec == (b).tv_sec) && ((a).tv_usec < (b).tv_usec))) +#define sexp_context_before(c, t) (((sexp_context_timeval(c).tv_sec != 0) || (sexp_context_timeval(c).tv_usec != 0)) && timeval_le(sexp_context_timeval(c), t)) + +/* static int mutex_id, condvar_id; */ + +/**************************** threads *************************************/ + +static void sexp_define_type_predicate (sexp ctx, sexp env, char *cname, sexp_uint_t type) { + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + name = sexp_c_string(ctx, cname, -1); + op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type)); + sexp_env_define(ctx, env, name=sexp_intern(ctx, cname, -1), op); + sexp_gc_release2(ctx); +} + +sexp sexp_thread_timeoutp (sexp ctx sexp_api_params(self, n)) { + return sexp_make_boolean(sexp_context_timeoutp(ctx)); +} + +sexp sexp_thread_name (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + return sexp_context_name(thread); +} + +sexp sexp_thread_specific (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + return sexp_context_specific(thread); +} + +sexp sexp_thread_specific_set (sexp ctx sexp_api_params(self, n), sexp thread, sexp val) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + sexp_context_specific(thread) = val; + return SEXP_VOID; +} + +sexp sexp_current_thread (sexp ctx sexp_api_params(self, n)) { + return ctx; +} + +sexp sexp_make_thread (sexp ctx sexp_api_params(self, n), sexp thunk, sexp name) { + sexp res, *stack; + sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, thunk); + res = sexp_make_eval_context(ctx, SEXP_FALSE, sexp_context_env(ctx), 0); + sexp_context_proc(res) = thunk; + sexp_context_ip(res) = sexp_bytecode_data(sexp_procedure_code(thunk)); + stack = sexp_stack_data(sexp_context_stack(res)); + stack[0] = stack[1] = stack[3] = SEXP_ZERO; + stack[2] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); + sexp_context_top(res) = 4; + sexp_context_last_fp(res) = 0; + return res; +} + +sexp sexp_thread_start (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp cell; + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + cell = sexp_cons(ctx, thread, SEXP_NULL); + if (sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = cell; + sexp_global(ctx, SEXP_G_THREADS_BACK) = cell; + } else { /* init queue */ + sexp_global(ctx, SEXP_G_THREADS_BACK) = sexp_global(ctx, SEXP_G_THREADS_FRONT) = cell; + } + return SEXP_VOID; +} + +sexp sexp_thread_terminate (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp res = sexp_make_boolean(ctx == thread); + for ( ; thread && sexp_contextp(thread); thread=sexp_context_child(thread)) + sexp_context_refuel(thread) = 0; + /* return true if terminating self */ + return res; +} + +static void sexp_insert_timed (sexp ctx, sexp thread, sexp timeout) { +#if SEXP_USE_FLONUMS + double d; +#endif + sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); + if (sexp_integerp(timeout) || sexp_flonump(timeout)) + gettimeofday(&sexp_context_timeval(ctx), NULL); + if (sexp_integerp(timeout)) { + sexp_context_timeval(ctx).tv_sec += sexp_unbox_fixnum(timeout); +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(timeout)) { + d = sexp_flonum_value(timeout); + sexp_context_timeval(ctx).tv_sec += trunc(d); + sexp_context_timeval(ctx).tv_usec += (d-trunc(d))*1000000; +#endif + } else { + sexp_context_timeval(ctx).tv_sec = 0; + sexp_context_timeval(ctx).tv_usec = 0; + } + if (sexp_numberp(timeout)) + while (sexp_pairp(ls2) + && sexp_context_before(sexp_car(ls2), sexp_context_timeval(ctx))) + ls1=ls2, ls2=sexp_cdr(ls2); + else + while (sexp_pairp(ls2) && sexp_context_timeval(sexp_car(ls2)).tv_sec) + ls1=ls2, ls2=sexp_cdr(ls2); + if (ls1 == SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cons(ctx, thread, ls2); + else + sexp_cdr(ls1) = sexp_cons(ctx, thread, ls2); +} + +sexp sexp_thread_join (sexp ctx sexp_api_params(self, n), sexp thread, sexp timeout) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + if (sexp_context_refuel(thread) <= 0) /* return true if already terminated */ { + return SEXP_TRUE; + } + sexp_context_timeoutp(ctx) = 0; + sexp_context_waitp(ctx) = 1; + sexp_context_event(ctx) = thread; + sexp_insert_timed(ctx, ctx, timeout); + return SEXP_FALSE; +} + +sexp sexp_thread_sleep (sexp ctx sexp_api_params(self, n), sexp timeout) { + sexp_context_waitp(ctx) = 1; + if (timeout != SEXP_TRUE) { + sexp_assert_type(ctx, sexp_numberp, SEXP_NUMBER, timeout); + sexp_insert_timed(ctx, ctx, timeout); + } + return SEXP_FALSE; +} + +/**************************** mutexes *************************************/ + +sexp sexp_mutex_state (sexp ctx sexp_api_params(self, n), sexp mutex) { + /* sexp_assert_type(ctx, sexp_mutexp, mutex_id, timeout); */ + if (sexp_truep(sexp_mutex_lockp(mutex))) { + if (sexp_contextp(sexp_mutex_thread(mutex))) + return sexp_mutex_thread(mutex); + else + return sexp_intern(ctx, "not-owned", -1); + } else { + return sexp_intern(ctx, (sexp_mutex_thread(mutex) ? "not-abandoned" : "abandoned"), -1); + } +} + +sexp sexp_mutex_lock (sexp ctx sexp_api_params(self, n), sexp mutex, sexp timeout, sexp thread) { + if (thread == SEXP_TRUE) + thread = ctx; + if (sexp_not(sexp_mutex_lockp(mutex))) { + sexp_mutex_lockp(mutex) = SEXP_TRUE; + sexp_mutex_thread(mutex) = thread; + return SEXP_TRUE; + } else { + sexp_context_waitp(ctx) = 1; + sexp_context_event(ctx) = mutex; + sexp_insert_timed(ctx, ctx, timeout); + return SEXP_FALSE; + } +} + +sexp sexp_mutex_unlock (sexp ctx sexp_api_params(self, n), sexp mutex, sexp condvar, sexp timeout) { + sexp ls1, ls2; + if (sexp_not(condvar)) { + /* normal unlock - always succeeds, just need to unblock threads */ + if (sexp_truep(sexp_mutex_lockp(mutex))) { + sexp_mutex_lockp(mutex) = SEXP_FALSE; + sexp_mutex_thread(mutex) = ctx; + /* search for threads blocked on this mutex */ + for (ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); + sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2)) + if (sexp_context_event(sexp_car(ls2)) == mutex) { + if (ls1==SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2); + else + sexp_cdr(ls1) = sexp_cdr(ls2); + sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT); + sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2; + if (! sexp_pairp(sexp_cdr(ls2))) + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; + sexp_context_waitp(sexp_car(ls2)) + = sexp_context_timeoutp(sexp_car(ls2)) = 0; + break; + } + } + return SEXP_TRUE; + } else { + /* wait on condition var */ + sexp_context_waitp(ctx) = 1; + sexp_context_event(ctx) = condvar; + sexp_insert_timed(ctx, ctx, timeout); + return SEXP_FALSE; + } +} + +/**************************** condition variables *************************/ + +sexp sexp_condition_variable_signal (sexp ctx sexp_api_params(self, n), sexp condvar) { + sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); + for ( ; sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2)) + if (sexp_context_event(sexp_car(ls2)) == condvar) { + if (ls1==SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2); + else + sexp_cdr(ls1) = sexp_cdr(ls2); + sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT); + sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2; + if (! sexp_pairp(sexp_cdr(ls2))) + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; + sexp_context_waitp(sexp_car(ls2)) = sexp_context_timeoutp(sexp_car(ls2)) = 0; + return SEXP_TRUE; + } + return SEXP_FALSE; +} + +sexp sexp_condition_variable_broadcast (sexp ctx sexp_api_params(self, n), sexp condvar) { + sexp res = SEXP_FALSE; + while (sexp_truep(sexp_condition_variable_signal(ctx, self, n, condvar))) + res = SEXP_TRUE; + return res; +} + +/**************************** the scheduler *******************************/ + +void sexp_wait_on_single_thread (sexp ctx) { + struct timeval tval; + useconds_t usecs = 0; + gettimeofday(&tval, NULL); + if (tval.tv_sec < sexp_context_timeval(ctx).tv_sec) + usecs = (sexp_context_timeval(ctx).tv_sec - tval.tv_sec) * 1000000; + if (tval.tv_usec < sexp_context_timeval(ctx).tv_usec) + usecs += sexp_context_timeval(ctx).tv_usec - tval.tv_usec; + usleep(usecs); +} + +static const sexp_uint_t sexp_log2_lookup[32] = { + 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, + 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9 +}; + +/* only works on powers of two */ +static sexp_uint_t sexp_log2_of_pow2 (sexp_uint_t n) { + return sexp_log2_lookup[(n * 0x077CB531U) >> 27]; +} + +static sexp sexp_pop_signal (sexp ctx sexp_api_params(self, n)) { + int allsigs, restsigs, signum; + if (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) == SEXP_ZERO) { + return SEXP_FALSE; + } else { + allsigs = sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_THREADS_SIGNALS)); + restsigs = allsigs & (allsigs-1); + sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = sexp_make_fixnum(restsigs); + signum = sexp_log2_of_pow2(allsigs-restsigs); + return sexp_make_fixnum(signum); + } +} + +static sexp sexp_get_signal_handler (sexp ctx sexp_api_params(self, n), sexp signum) { + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, signum); + return sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum); +} + +sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { + struct timeval tval; + sexp res, ls1, ls2, runner, paused, front; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + + front = sexp_global(ctx, SEXP_G_THREADS_FRONT); + paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED); + + /* check for signals */ + if (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) != SEXP_ZERO) { + runner = sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER); + if (! sexp_contextp(runner)) { /* ensure the runner exists */ + if (sexp_envp(runner)) { + tmp = sexp_env_cell(runner, (tmp=sexp_intern(ctx, "signal-runner", -1))); + if (sexp_pairp(tmp) && sexp_procedurep(sexp_cdr(tmp))) { + runner = sexp_make_thread(ctx, self, 2, sexp_cdr(tmp), SEXP_FALSE); + sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = runner; + sexp_thread_start(ctx, self, 1, runner); + } + } + } else if (sexp_context_waitp(runner)) { /* wake it if it's sleeping */ + sexp_context_waitp(runner) = 0; + sexp_thread_start(ctx, self, 1, runner); + } + } + + /* if we've terminated, check threads joining us */ + if (sexp_context_refuel(ctx) <= 0) { + for (ls1=SEXP_NULL, ls2=paused; sexp_pairp(ls2); ) { + if (sexp_context_event(sexp_car(ls2)) == ctx) { + sexp_context_waitp(sexp_car(ls2)) = 0; + sexp_context_timeoutp(sexp_car(ls2)) = 0; + if (ls1==SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = sexp_cdr(ls2); + else + sexp_cdr(ls1) = sexp_cdr(ls2); + tmp = sexp_cdr(ls2); + sexp_cdr(ls2) = SEXP_NULL; + if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { + sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = ls2; + } else { + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = ls2; + } + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; + ls2 = tmp; + } else { + ls1 = ls2; + ls2 = sexp_cdr(ls2); + } + } + } + + /* check timeouts */ + if (sexp_pairp(paused)) { + if (gettimeofday(&tval, NULL) == 0) { + ls1 = SEXP_NULL; + ls2 = paused; + while (sexp_pairp(ls2) && sexp_context_before(sexp_car(ls2), tval)) { + sexp_context_timeoutp(sexp_car(ls2)) = 1; + sexp_context_waitp(ctx) = 0; + ls1 = ls2; + ls2 = sexp_cdr(ls2); + } + if (sexp_pairp(ls1)) { + sexp_cdr(ls1) = SEXP_NULL; + if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { + sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = paused; + } else { + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = paused; + } + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls1; + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = ls2; + } + } + } + + /* dequeue next thread */ + if (sexp_pairp(front)) { + res = sexp_car(front); + if ((sexp_context_refuel(ctx) <= 0) || sexp_context_waitp(ctx)) { + /* either terminated or paused */ + sexp_global(ctx, SEXP_G_THREADS_FRONT) = sexp_cdr(front); + if (! sexp_pairp(sexp_cdr(front))) + sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL; + } else { + /* swap with front of queue */ + sexp_car(sexp_global(ctx, SEXP_G_THREADS_FRONT)) = ctx; + /* rotate front of queue to back */ + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) + = sexp_global(ctx, SEXP_G_THREADS_FRONT); + sexp_global(ctx, SEXP_G_THREADS_FRONT) + = sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_FRONT)); + sexp_global(ctx, SEXP_G_THREADS_BACK) + = sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)); + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = SEXP_NULL; + } + } else { + res = ctx; + } + + if (sexp_context_waitp(res)) { + /* the only thread available was waiting */ + sexp_wait_on_single_thread(res); + sexp_context_timeoutp(res) = 1; + sexp_context_waitp(res) = 0; + } + + sexp_gc_release1(ctx); + return res; +} + +/**************************************************************************/ + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + + sexp_define_type_predicate(ctx, env, "thread?", SEXP_CONTEXT); + sexp_define_foreign(ctx, env, "thread-timeout?", 0, sexp_thread_timeoutp); + sexp_define_foreign(ctx, env, "current-thread", 0, sexp_current_thread); + sexp_define_foreign_opt(ctx, env, "make-thread", 2, sexp_make_thread, SEXP_FALSE); + sexp_define_foreign(ctx, env, "thread-start!", 1, sexp_thread_start); + sexp_define_foreign(ctx, env, "%thread-terminate!", 1, sexp_thread_terminate); + sexp_define_foreign(ctx, env, "%thread-join!", 2, sexp_thread_join); + sexp_define_foreign(ctx, env, "%thread-sleep!", 1, sexp_thread_sleep); + sexp_define_foreign(ctx, env, "thread-name", 1, sexp_thread_name); + sexp_define_foreign(ctx, env, "thread-specific", 1, sexp_thread_specific); + sexp_define_foreign(ctx, env, "thread-specific-set!", 2, sexp_thread_specific_set); + sexp_define_foreign(ctx, env, "mutex-state", 1, sexp_mutex_state); + sexp_define_foreign(ctx, env, "%mutex-lock!", 3, sexp_mutex_lock); + sexp_define_foreign(ctx, env, "%mutex-unlock!", 3, sexp_mutex_unlock); + sexp_define_foreign(ctx, env, "condition-variable-signal!", 1, sexp_condition_variable_signal); + sexp_define_foreign(ctx, env, "condition-variable-broadcast!", 1, sexp_condition_variable_broadcast); + sexp_define_foreign(ctx, env, "pop-signal!", 0, sexp_pop_signal); + sexp_define_foreign(ctx, env, "get-signal-handler", 1, sexp_get_signal_handler); + + sexp_global(ctx, SEXP_G_THREADS_SCHEDULER) + = sexp_make_foreign(ctx, "scheduler", 0, 0, (sexp_proc1)sexp_scheduler, SEXP_FALSE); + + /* remember the env to lookup the runner later */ + sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = env; + + return SEXP_VOID; +} + diff --git a/lib/srfi/18/types.scm b/lib/srfi/18/types.scm new file mode 100644 index 00000000..093c97a7 --- /dev/null +++ b/lib/srfi/18/types.scm @@ -0,0 +1,24 @@ +;; types.scm -- thread types +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define-record-type mutex + (%make-mutex name specific thread lock) + mutex? + (name mutex-name) + (specific mutex-specific mutex-specific-set!) + (thread %mutex-thread %mutex-thread-set!) + (lock %mutex-lock %mutex-lock-set!)) + +(define (make-mutex . o) + (%make-mutex (and (pair? o) (car o)) #f #f #f)) + +(define-record-type condition-variable + (%make-condition-variable name specific threads) + condition-variable? + (name condition-variable-name) + (specific condition-variable-specific condition-variable-specific-set!) + (threads %condition-variable-threads %condition-variable-threads-set!)) + +(define (make-condition-variable . o) + (%make-condition-variable (and (pair? o) (car o)) #f #f)) diff --git a/lib/srfi/2.module b/lib/srfi/2.module new file mode 100644 index 00000000..4ceb8b6b --- /dev/null +++ b/lib/srfi/2.module @@ -0,0 +1,16 @@ + +(define-module (srfi 2) + (export and-let*) + (import-immutable (scheme)) + (body + (define-syntax and-let* + (syntax-rules () + ((and-let* () . body) + (begin . body)) + ((and-let* ((var expr) . rest) . body) + (let ((var expr)) + (and var (and-let* rest . body)))) + ((and-let* ((expr) . rest) . body) + (let ((tmp expr)) + (and tmp (and-let* rest . body)))))))) + diff --git a/lib/srfi/26.module b/lib/srfi/26.module new file mode 100644 index 00000000..f97ab783 --- /dev/null +++ b/lib/srfi/26.module @@ -0,0 +1,24 @@ + +(define-module (srfi 26) + (export cut cute) + (import-immutable (scheme)) + (body + (define-syntax %cut + (syntax-rules (<> <...>) + ((%cut e? params args) + (lambda params args)) + ((%cut e? (params ...) (args ...) <> . rest) + (%cut e? (params ... tmp) (args ... tmp) . rest)) + ((%cut e? (params ...) (args ...) <...>) + (%cut e? (params ... . tmp) (apply args ... tmp))) + ((%cut e? (params ...) (args ...) <...> . rest) + (error "cut: non-terminal <...>")) + ((%cut #t (params ...) (args ...) x . rest) + (let ((tmp x)) (%cut #t (params ...) (args ... tmp) . rest))) + ((%cut #f (params ...) (args ...) x . rest) + (%cut #t (params ...) (args ... x) . rest)))) + (define-syntax cut + (syntax-rules () ((cut args ...) (%cut #f () () args ...)))) + (define-syntax cute + (syntax-rules () ((cute args ...) (%cut #t () () args ...)))))) + diff --git a/lib/srfi/27.module b/lib/srfi/27.module new file mode 100644 index 00000000..5c451629 --- /dev/null +++ b/lib/srfi/27.module @@ -0,0 +1,11 @@ + +(define-module (srfi 27) + (export random-integer random-real default-random-source + make-random-source random-source? + random-source-state-ref random-source-state-set! + random-source-randomize! random-source-pseudo-randomize! + random-source-make-integers random-source-make-reals) + (import-immutable (scheme)) + (include-shared "27/rand") + (include "27/constructors.scm")) + diff --git a/lib/srfi/27/constructors.scm b/lib/srfi/27/constructors.scm new file mode 100644 index 00000000..dbd0a8c6 --- /dev/null +++ b/lib/srfi/27/constructors.scm @@ -0,0 +1,10 @@ +;; constructors.scm -- random function constructors +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (random-source-make-integers rs) + (lambda (n) (%random-integer rs n))) + +(define (random-source-make-reals rs . o) + (lambda () (%random-real rs))) + diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c new file mode 100644 index 00000000..6e971df8 --- /dev/null +++ b/lib/srfi/27/rand.c @@ -0,0 +1,204 @@ +/* rand.c -- rand_r/random_r interface */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include +#include + +#define SEXP_RANDOM_STATE_SIZE 128 + +#define ZERO sexp_make_fixnum(0) +#define ONE sexp_make_fixnum(1) +#define STATE_SIZE sexp_make_fixnum(SEXP_RANDOM_STATE_SIZE) + +#define sexp_random_source_p(x) sexp_check_tag(x, rs_type_id) + +#define sexp_random_init(x, seed) \ + initstate_r(seed, \ + sexp_string_data(sexp_random_state(x)), \ + SEXP_RANDOM_STATE_SIZE, \ + sexp_random_data(x)) + +#if SEXP_BSD || defined(__CYGWIN__) +typedef unsigned int sexp_random_t; +#define sexp_call_random(rs, dst) ((dst) = rand_r(sexp_random_data(rs))) +#define sexp_seed_random(n, rs) *sexp_random_data(rs) = (n) +#else +typedef struct random_data sexp_random_t; +#define sexp_call_random(rs, dst) random_r(sexp_random_data(rs), &dst) +#define sexp_seed_random(n, rs) srandom_r(n, sexp_random_data(rs)) +#endif + +#define sexp_random_state(x) (sexp_slot_ref((x), 0)) +#define sexp_random_data(x) ((sexp_random_t*)(&sexp_slot_ref((x), 1))) + +#define sexp_sizeof_random (sexp_sizeof_header + sizeof(sexp_random_t) + sizeof(sexp)) + +static sexp_uint_t rs_type_id; +static sexp default_random_source; + +static sexp sexp_rs_random_integer (sexp ctx sexp_api_params(self, n), sexp rs, sexp bound) { + sexp res; + int32_t m; +#if SEXP_USE_BIGNUMS + int32_t hi, mod, len, i, *data; +#endif + if (! sexp_random_source_p(rs)) + res = sexp_type_exception(ctx, self, rs_type_id, rs); + if (sexp_fixnump(bound)) { + sexp_call_random(rs, m); + res = sexp_make_fixnum(m % sexp_unbox_fixnum(bound)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(bound)) { + hi = sexp_bignum_hi(bound); + len = hi * sizeof(sexp_uint_t) / sizeof(int32_t); + res = sexp_make_bignum(ctx, hi); + data = (int32_t*) sexp_bignum_data(res); + for (i=0; i +#include + +#if SEXP_USE_BIGNUMS +#include +#else +#define sexp_bignum_normalize(x) x +#endif + +static sexp sexp_bit_and (sexp ctx sexp_api_params(self, n), sexp x, sexp y) { + sexp res; +#if SEXP_USE_BIGNUMS + sexp_sint_t len, i; +#endif + if (sexp_fixnump(x)) { + if (sexp_fixnump(y)) + res = (sexp) ((sexp_uint_t)x & (sexp_uint_t)y); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(y)) + res = sexp_bit_and(ctx sexp_api_pass(self, n), y, x); +#endif + else + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + if (sexp_fixnump(y)) { + res = sexp_make_fixnum(sexp_unbox_fixnum(y) & sexp_bignum_data(x)[0]); + } else if (sexp_bignump(y)) { + if (sexp_bignum_length(x) < sexp_bignum_length(y)) + res = sexp_copy_bignum(ctx, NULL, x, 0); + else + res = sexp_copy_bignum(ctx, NULL, y, 0); + for (i=0, len=sexp_bignum_length(res); i= sexp_bignum_length(y)) { + res = sexp_copy_bignum(ctx, NULL, x, 0); + len = sexp_bignum_length(y); + } else { + res = sexp_copy_bignum(ctx, NULL, y, 0); + len = sexp_bignum_length(x); + } + for (i=0; i= sexp_bignum_length(y)) { + res = sexp_copy_bignum(ctx, NULL, x, 0); + len = sexp_bignum_length(y); + } else { + res = sexp_copy_bignum(ctx, NULL, y, 0); + len = sexp_bignum_length(x); + } + for (i=0; i> -c); + } else { + tmp = (sexp_uint_t)sexp_unbox_fixnum(i) << c; +#if SEXP_USE_BIGNUMS + if (((tmp >> c) == sexp_unbox_fixnum(i)) + && (tmp < SEXP_MAX_FIXNUM) && (tmp > SEXP_MIN_FIXNUM)) { +#endif + res = sexp_make_fixnum(tmp); +#if SEXP_USE_BIGNUMS + } else { + sexp_gc_preserve1(ctx, res); + res = sexp_fixnum_to_bignum(ctx, i); + res = sexp_arithmetic_shift(ctx sexp_api_pass(self, n), res, count); + sexp_gc_release1(ctx); + } +#endif + } +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(i)) { + len = sexp_bignum_hi(i); + if (c < 0) { + c = -c; + offset = c / (sizeof(sexp_uint_t)*CHAR_BIT); + bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT); + if (len < offset) { + res = sexp_make_fixnum(sexp_bignum_sign(i) > 0 ? 0 : -1); + } else { + res = sexp_make_bignum(ctx, len - offset + 1); + for (j=len-offset, tmp=0; j>=0; j--) { + sexp_bignum_data(res)[j] + = (sexp_bignum_data(i)[j+offset] >> bit_shift)+ tmp; + tmp = sexp_bignum_data(i)[j+offset] + << (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift); + } + } + } else { + offset = c / (sizeof(sexp_uint_t)*CHAR_BIT); + bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT); + res = sexp_make_bignum(ctx, len + offset + 1); + for (j=tmp=0; j> (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift); + } + sexp_bignum_data(res)[len+offset] = tmp; + } +#endif + } else { + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, i); + } + return sexp_bignum_normalize(res); +} + +/* bit-count and integer-length were adapted from: */ +/* http://graphics.stanford.edu/~seander/bithacks.html */ +static sexp_uint_t bit_count (sexp_uint_t i) { + i -= ((i >> 1) & (sexp_uint_t)~(sexp_uint_t)0/3); + i = ((i & (sexp_uint_t)~(sexp_uint_t)0/15*3) + + ((i >> 2) & (sexp_uint_t)~(sexp_uint_t)0/15*3)); + i = (i + (i >> 4)) & (sexp_uint_t)~(sexp_uint_t)0/255*15; + return ((sexp_uint_t)(i * ((sexp_uint_t)~(sexp_uint_t)0/255)) + >> (sizeof(i) - 1) * CHAR_BIT); +} + +static sexp sexp_bit_count (sexp ctx sexp_api_params(self, n), sexp x) { + sexp res; + sexp_sint_t i; +#if SEXP_USE_BIGNUMS + sexp_uint_t count; +#endif + if (sexp_fixnump(x)) { + i = sexp_unbox_fixnum(x); + res = sexp_make_fixnum(bit_count(i<0 ? ~i : i)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + for (i=count=0; i> 32)) + return integer_log2(tt) + 32; + else +#endif + if ((tt = x >> 16)) + return (t = tt >> 8) ? 24 + log_table_256[t] : 16 + log_table_256[tt]; + else + return (t = x >> 8) ? 8 + log_table_256[t] : log_table_256[x]; +} + +static sexp sexp_integer_length (sexp ctx sexp_api_params(self, n), sexp x) { + sexp_sint_t tmp; +#if SEXP_USE_BIGNUMS + sexp_sint_t hi; +#endif + if (sexp_fixnump(x)) { + tmp = sexp_unbox_fixnum(x); + return sexp_make_fixnum(integer_log2(tmp < 0 ? -tmp-1 : tmp)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + hi = sexp_bignum_hi(x); + return sexp_make_fixnum(integer_log2(sexp_bignum_data(x)[hi]) + + hi*sizeof(sexp_uint_t)); +#endif + } else { + return sexp_type_exception(ctx, self, SEXP_FIXNUM, x); + } +} + +static sexp sexp_bit_set_p (sexp ctx sexp_api_params(self, n), sexp i, sexp x) { +#if SEXP_USE_BIGNUMS + sexp_uint_t pos; +#endif + if (! sexp_fixnump(i)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, i); + if (sexp_fixnump(x)) { + return sexp_make_boolean(sexp_unbox_fixnum(x) & (1< (lambda (cell) (set-cdr! cell (+ (cdr cell) 1)))) + ((pair? x) + (set! seen (cons (cons x 1) seen)) + (find (car x)) + (find (cdr x))) + ((vector? x) + (set! seen (cons (cons x 1) seen)) + (do ((i 0 (+ i 1))) + ((= i (vector-length x))) + (find (vector-ref x i)))))) + (let extract ((ls seen) (res '())) + (cond + ((null? ls) res) + ((> (cdar ls) 1) (extract (cdr ls) (cons (cons (caar ls) #f) res))) + (else (extract (cdr ls) res)))))) + +(define (write-with-shared-structure x . o) + (let ((out (if (pair? o) (car o) (current-output-port))) + (shared (extract-shared-objects x)) + (count 0)) + (define (check-shared x prefix cont) + (let ((cell (assq x shared))) + (cond ((and cell (cdr cell)) + (display prefix out) + (display "#" out) + (write (cdr cell)) + (display "#" out)) + (else + (cond (cell + (display prefix out) + (display "#=" out) + (write count out) + (set-cdr! cell count) + (set! count (+ count 1)))) + (cont x))))) + (cond + ((null? shared) + (write x out)) + (else + (let wr ((x x)) + (check-shared + x + "" + (lambda (x) + (cond + ((pair? x) + (display "(" out) + (wr (car x)) + (let lp ((ls (cdr x))) + (check-shared + ls + " . " + (lambda (ls) + (cond ((null? ls)) + ((pair? ls) + (display " " out) + (wr (car ls)) + (lp (cdr ls))) + (else + (display " . " out) + (wr ls)))))) + (display ")" out)) + ((vector? x) + (display "#(" out) + (let ((len (vector-length x))) + (cond ((> len 0) + (wr (vector-ref x 0)) + (do ((i 1 (+ i 1))) + ((= i len)) + (display " " out) + (wr (vector-ref x i)))))) + (display ")" out)) + (else + (write x out)))))))))) + +(define write/ss write-with-shared-structure) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (skip-line in) + (let ((c (read-char in))) + (if (not (or (eof-object? c) (eqv? c #\newline))) + (skip-line in)))) + +(define (skip-whitespace in) + (case (peek-char in) + ((#\space #\tab #\newline #\return) + (read-char in) + (skip-whitespace in)) + ((#\;) + (skip-line in) + (skip-whitespace in)))) + +(define (skip-comment in depth) + (case (read-char in) + ((#\#) (skip-comment in (if (eqv? #\| (peek-char in)) (+ depth 1) depth))) + ((#\|) (if (eqv? #\# (peek-char in)) + (if (zero? depth) (read-char in) (skip-comment in (- depth 1))) + (skip-comment in depth))) + (else (if (eof-object? (peek-char in)) + (error "unterminated #| comment") + (skip-comment in depth))))) + +(define delimiters + '(#\( #\) #\[ #\] #\space #\tab #\newline #\return)) + +(define read-with-shared-structure + (let ((read read)) + (lambda o + (let ((in (if (pair? o) (car o) (current-input-port))) + (shared '())) + (define (read-label res) + (let ((c (char-downcase (peek-char in)))) + (if (if (char-numeric? c) #t (memv c '(#\a #\b #\c #\d #\e))) + (read-label (cons (read-char in) res)) + (list->string (reverse res))))) + (define (read-number base) + (let* ((str (read-label '())) + (n (string->number str base))) + (if (or (not n) (not (memv (peek-char in) delimiters))) + (error "read error: invalid number syntax" str (peek-char in)) + n))) + (define (read-float-tail in) ;; called only after a leading period + (let lp ((res 0.0) (k 0.1)) + (let ((c (peek-char in))) + (cond + ((char-numeric? c) (lp (+ res (* (read-char in) k)) (* k 0.1))) + ((memv c delimiters) res) + (else (error "invalid char in float syntax" c)))))) + (define (read-name c in) + (let lp ((ls (if (char? c) (list c) '()))) + (let ((c (peek-char in))) + (cond ((memv c delimiters) (list->string (reverse ls))) + (else (lp (cons (read-char in) ls))))))) + (define (read-named-char c in) + (let ((name (read-name c in))) + (cond ((string-ci=? name "space") #\space) + ((string-ci=? name "newline") #\newline) + (else (error "unknown char name"))))) + (define (read-one) + (skip-whitespace in) + (case (peek-char in) + ((#\#) + (read-char in) + (case (char-downcase (peek-char in)) + ((#\=) + (read-char in) + (let* ((str (read-label '())) + (n (string->number str)) + (cell (list #f)) + (thunk (lambda () (car cell)))) + (if (not n) (error "read error: invalid reference" str)) + (set! shared (cons (cons n thunk) shared)) + (let ((x (read-one))) + (set-car! cell x) + x))) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + (let ((n (string->number (read-label '())))) + (cond + ((not (eqv? #\# (peek-char in))) + (error "read error: expected # after #n" (read-char in))) + (else + (read-char in) + (cond ((assv n shared) => cdr) + (else (error "read error: unknown reference" n))))))) + ((#\;) + (read-char in) + (read-one) ;; discard + (read-one)) + ((#\|) + (skip-comment in 0)) + ((#\!) (skip-line in) (read-one in)) + ((#\() (list->vector (read-one))) + ((#\') (read-char in) (list 'syntax (read-one))) + ((#\`) (read-char in) (list 'quasisyntax (read-one))) + ((#\t) (read-char in) #t) + ((#\f) (read-char in) #t) ; support SRFI-4 f32/64 vectors + ((#\d) (read-char in) (read in)) + ((#\x) (read-char in) (read-number 16)) + ((#\o) (read-char in) (read-number 8)) + ((#\b) (read-char in) (read-number 2)) + ((#\i) (read-char in) (exact->inexact (read-one))) + ((#\e) (read-char in) (inexact->exact (read-one))) + ((#\\) + (read-char in) + (let ((c (read-char in))) + (if (memv (peek-char in) delimiters) + c + (read-named-char c in)))) + (else + (error "unknown # syntax: " (peek-char in))))) + ((#\() + (read-char in) + (let lp ((res '())) + (skip-whitespace in) + (case (peek-char in) + ((#\)) + (read-char in) + (reverse res)) + ((#\.) + (read-char in) + (cond + ((memv (peek-char in) delimiters) + (let ((tail (read-one))) + (skip-whitespace in) + (if (eqv? #\) (peek-char in)) + (begin (read-char in) (append (reverse res) tail)) + (error "expected end of list after dot")))) + ((char-numeric? (peek-char in)) (read-float-tail in)) + (else (string->symbol (read-name #\. in))))) + (else + (lp (cons (read-one) res)))))) + ((#\') (read-char in) (list 'quote (read-one))) + ((#\`) (read-char in) (list 'quasiquote (read-one))) + ((#\,) + (read-char in) + (list (if (eqv? #\@ (peek-char in)) + (begin (read-char in) 'unquote-splicing) + 'unquote) + (read-one))) + (else + (read in)))) + ;; body + (let ((res (read-one))) + (if (pair? shared) + (patch res)) + res))))) + +(define (hole? x) (procedure? x)) +(define (fill-hole x) (if (hole? x) (fill-hole (x)) x)) + +(define (patch x) + (cond + ((pair? x) + (if (hole? (car x)) (set-car! x (fill-hole (car x))) (patch (car x))) + (if (hole? (cdr x)) (set-cdr! x (fill-hole (cdr x))) (patch (cdr x)))) + ((vector? x) + (do ((i (- (vector-length x) 1) (- i 1))) + ((< i 0)) + (let ((elt (vector-ref x i))) + (if (hole? elt) + (vector-set! x i (fill-hole elt)) + (patch elt))))))) + +(define read/ss read-with-shared-structure) diff --git a/lib/srfi/39.module b/lib/srfi/39.module new file mode 100644 index 00000000..11b9ed9f --- /dev/null +++ b/lib/srfi/39.module @@ -0,0 +1,25 @@ + +(define-module (srfi 39) + (export make-parameter parameterize) + (import-immutable (scheme)) + (body + (define (make-parameter value . o) + (if (pair? o) + (let ((converter (car o))) + (lambda args + (if (null? args) + value + (set! value (converter (car args)))))) + (lambda args (if (null? args) value (set! value (car args)))))) + (define-syntax parameterize + (syntax-rules () + ((parameterize ("step") ((param value tmp1 tmp2) ...) () body) + (let ((tmp1 value) ...) + (let ((tmp2 (param)) ...) + (dynamic-wind (lambda () (param tmp1) ...) + (lambda () . body) + (lambda () (param tmp2) ...))))) + ((parameterize ("step") args ((param value) . rest) body) + (parameterize ("step") ((param value tmp1 tmp2) . args) rest body)) + ((parameterize ((param value) ...) . body) + (parameterize ("step") () ((param value) ...) body)))))) diff --git a/lib/srfi/6.module b/lib/srfi/6.module new file mode 100644 index 00000000..e589b6ff --- /dev/null +++ b/lib/srfi/6.module @@ -0,0 +1,5 @@ + +(define-module (srfi 6) + (export open-input-string open-output-string get-output-string) + (import-immutable (scheme))) + diff --git a/lib/srfi/69.module b/lib/srfi/69.module new file mode 100644 index 00000000..037b6393 --- /dev/null +++ b/lib/srfi/69.module @@ -0,0 +1,17 @@ + +(define-module (srfi 69) + (export + make-hash-table hash-table? alist->hash-table + hash-table-equivalence-function hash-table-hash-function + hash-table-ref hash-table-ref/default hash-table-set! + hash-table-delete! hash-table-exists? + hash-table-update! hash-table-update!/default + hash-table-size hash-table-keys hash-table-values + hash-table-walk hash-table-fold hash-table->alist + hash-table-copy hash-table-merge! + hash string-hash string-ci-hash hash-by-identity) + (import-immutable (scheme) + (srfi 9)) + (include-shared "69/hash") + (include "69/type.scm" "69/interface.scm")) + diff --git a/lib/srfi/69/hash.c b/lib/srfi/69/hash.c new file mode 100644 index 00000000..42d1e864 --- /dev/null +++ b/lib/srfi/69/hash.c @@ -0,0 +1,242 @@ +/* hash.c -- type-general hashing */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +#define HASH_DEPTH 5 +#define HASH_BOUND sexp_make_fixnum(SEXP_MAX_FIXNUM) + +#define FNV_PRIME 16777619 +#define FNV_OFFSET_BASIS 2166136261uL + +#define sexp_hash_table_buckets(x) sexp_slot_ref(x, 0) +#define sexp_hash_table_size(x) sexp_slot_ref(x, 1) +#define sexp_hash_table_hash_fn(x) sexp_slot_ref(x, 2) +#define sexp_hash_table_eq_fn(x) sexp_slot_ref(x, 3) + +#define sexp_hash_resize_check(n, len) (((n)*3) > ((len)>>2)) + +static sexp_uint_t string_hash (char *str, sexp_uint_t bound) { + sexp_uint_t acc = FNV_OFFSET_BASIS; + while (*str) {acc *= FNV_PRIME; acc ^= *str++;} + return acc % bound; +} + +static sexp sexp_string_hash (sexp ctx sexp_api_params(self, n), sexp str, sexp bound) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, self, SEXP_STRING, str); + else if (! sexp_fixnump(bound)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); + return sexp_make_fixnum(string_hash(sexp_string_data(str), + sexp_unbox_fixnum(bound))); +} + +static sexp_uint_t string_ci_hash (char *str, sexp_uint_t bound) { + sexp_uint_t acc = FNV_OFFSET_BASIS; + while (*str) {acc *= FNV_PRIME; acc ^= (tolower)(*str++);} + return acc % bound; +} + +static sexp sexp_string_ci_hash (sexp ctx sexp_api_params(self, n), sexp str, sexp bound) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, self, SEXP_STRING, str); + else if (! sexp_fixnump(bound)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); + return sexp_make_fixnum(string_ci_hash(sexp_string_data(str), + sexp_unbox_fixnum(bound))); +} + +static sexp_uint_t hash_one (sexp ctx, sexp obj, sexp_uint_t bound, sexp_sint_t depth) { + sexp_uint_t acc = FNV_OFFSET_BASIS, size; + sexp_sint_t i, len; + sexp t, *p; + char *p0; + loop: +#if SEXP_USE_FLONUMS + if (sexp_flonump(obj)) + acc ^= (sexp_sint_t) sexp_flonum_value(obj); + else +#endif + if (sexp_pointerp(obj)) { + if (depth) { + t = sexp_object_type(ctx, obj); + p = (sexp*) (((char*)obj) + sexp_type_field_base(t)); + p0 = ((char*)obj) + offsetof(struct sexp_struct, value); + if ((sexp)p == obj) p=(sexp*)p0; + /* hash trailing non-object data */ + size = sexp_type_size_of_object(t, obj)-offsetof(struct sexp_struct, value); + p0 = ((char*)p + sexp_type_num_slots_of_object(t,obj)*sizeof(sexp)); + if (((char*)obj + size) > p0) + for (i=0; i 0) { + depth--; + for (i=0; ialist table) + (hash-table-fold table (lambda (k v a) (cons (cons k v) a)) '())) + +(define (hash-table-keys table) + (hash-table-fold table (lambda (k v a) (cons k a)) '())) + +(define (hash-table-values table) + (hash-table-fold table (lambda (k v a) (cons v a)) '())) + +(define (alist->hash-table ls . o) + (let ((res (apply make-hash-table o))) + (for-each (lambda (x) (hash-table-set! res (car x) (cdr x))) ls) + res)) + +(define (hash-table-merge! a b) + (hash-table-walk b (lambda (k v) (hash-table-set! a k v))) + a) + +(define (hash-table-copy table) + (assert-hash-table "hash-table-copy" table) + (let ((res (make-hash-table (hash-table-equivalence-function table)))) + (hash-table-merge! res table) + res)) + diff --git a/lib/srfi/69/type.scm b/lib/srfi/69/type.scm new file mode 100644 index 00000000..1fca9953 --- /dev/null +++ b/lib/srfi/69/type.scm @@ -0,0 +1,12 @@ +;; types.scm -- the hash-table record type +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define-record-type hash-table + (%make-hash-table buckets size hash-fn eq-fn) + hash-table? + (buckets hash-table-buckets hash-table-buckets-set!) + (size hash-table-size hash-table-size-set!) + (hash-fn %hash-table-hash-function) + (eq-fn %hash-table-equivalence-function)) + diff --git a/lib/srfi/8.module b/lib/srfi/8.module new file mode 100644 index 00000000..64a3e6e2 --- /dev/null +++ b/lib/srfi/8.module @@ -0,0 +1,10 @@ + +(define-module (srfi 8) + (export receive) + (import-immutable (scheme)) + (body + (define-syntax receive + (syntax-rules () + ((receive params expr . body) + (call-with-values (lambda () expr) (lambda params . body))))))) + diff --git a/lib/srfi/9.module b/lib/srfi/9.module new file mode 100644 index 00000000..58368111 --- /dev/null +++ b/lib/srfi/9.module @@ -0,0 +1,90 @@ + +(define-module (srfi 9) + (export define-record-type) + (import-immutable (scheme)) + (body + (define-syntax define-record-type + (er-macro-transformer + (lambda (expr rename compare) + (let* ((name (cadr expr)) + (name-str (symbol->string (identifier->symbol name))) + (make (caaddr expr)) + (make-fields (cdaddr expr)) + (pred (cadddr expr)) + (fields (cddddr expr)) + (num-fields (length fields)) + (_define (rename 'define)) + (_lambda (rename 'lambda)) + (_let (rename 'let)) + (_register (rename 'register-simple-type))) + (define (index-of field ls) + (let lp ((ls ls) (i 0)) + (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1))))) + `(,(rename 'begin) + ;; type + (,_define ,name (,_register ,name-str ,num-fields)) + ;; predicate + (,_define ,pred (,(rename 'make-type-predicate) + ,(symbol->string (identifier->symbol pred)) + ,name)) + ;; fields + ,@(let lp ((ls fields) (i 0) (res '())) + (if (null? ls) + res + (let ((res + (cons `(,_define ,(cadar ls) + (,(rename 'make-getter) + ,(symbol->string + (identifier->symbol (cadar ls))) + ,name + ,i)) + res))) + (lp (cdr ls) + (+ i 1) + (if (pair? (cddar ls)) + (cons + `(,_define ,(caddar ls) + (,(rename 'make-setter) + ,(symbol->string + (identifier->symbol (caddar ls))) + ,name + ,i)) + res) + res))))) + ;; constructor + (,_define ,make + ,(let lp ((ls make-fields) (sets '()) (set-defs '())) + (cond + ((null? ls) + `(,_let ((%make (,(rename 'make-constructor) + ,(symbol->string (identifier->symbol make)) + ,name)) + ,@set-defs) + (,_lambda ,make-fields + (,_let ((res (%make))) + ,@sets + res)))) + (else + (let ((field (assq (car ls) fields))) + (cond + ((not field) + (error "unknown record field in constructor" (car ls))) + ((pair? (cddr field)) + (lp (cdr ls) + (cons (list (caddr field) 'res (car ls)) sets) + set-defs)) + (else + (let* ((setter-name + (string-append "%" name-str "-" + (symbol->string (car ls)) "-set!")) + (setter (rename (string->symbol setter-name))) + (i (index-of (car ls) fields))) + (lp (cdr ls) + (cons (list setter 'res (car ls)) sets) + (cons (list setter + (list (rename 'make-setter) + setter-name + name + (index-of (car ls) fields))) + set-defs))))))))))))))))) + diff --git a/lib/srfi/95.module b/lib/srfi/95.module new file mode 100644 index 00000000..43bab9dd --- /dev/null +++ b/lib/srfi/95.module @@ -0,0 +1,7 @@ + +(define-module (srfi 95) + (export sorted? merge merge! sort sort! object-cmp) + (import-immutable (scheme)) + (include-shared "95/qsort") + (include "95/sort.scm")) + diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c new file mode 100644 index 00000000..14329e37 --- /dev/null +++ b/lib/srfi/95/qsort.c @@ -0,0 +1,228 @@ +/* qsort.c -- quicksort implementation */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#if SEXP_USE_HUFF_SYMS +#include "../../../opt/sexp-hufftabs.c" +#endif + +#define swap(tmp_var, a, b) (tmp_var=a, a=b, b=tmp_var) + +static sexp sexp_vector_copy_to_list (sexp ctx, sexp vec, sexp seq) { + sexp_sint_t i; + sexp ls, *data=sexp_vector_data(vec); + for (i=0, ls=seq; sexp_pairp(ls); i++, ls=sexp_cdr(ls)) + sexp_car(ls) = data[i]; + return seq; +} + +static sexp sexp_vector_nreverse (sexp ctx, sexp vec) { + int i, j; + sexp tmp, *data=sexp_vector_data(vec); + for (i=0, j=sexp_vector_length(vec)-1; i>3, d = ((sexp_uint_t)b)>>3; + while (c && d) { +#include "../../../opt/sexp-unhuff.c" +#define c d +#define res res2 +#include "../../../opt/sexp-unhuff.c" +#undef c +#undef res + if ((tmp=res-res2) != 0) + return tmp; + } + return c ? 1 : d ? -1 : 0; +} +#endif + +static int sexp_object_compare (sexp ctx, sexp a, sexp b) { + int res; + if (a == b) + return 0; + if (sexp_pointerp(a)) { + if (sexp_pointerp(b)) { + if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) { + res = sexp_pointer_tag(a) - sexp_pointer_tag(b); + } else { + switch (sexp_pointer_tag(a)) { + case SEXP_FLONUM: + res = sexp_flonum_value(a) - sexp_flonum_value(b); + break; + case SEXP_BIGNUM: + res = sexp_bignum_compare(a, b); + break; + case SEXP_STRING: + res = strcmp(sexp_string_data(a), sexp_string_data(b)); + break; + case SEXP_SYMBOL: + res = strcmp(sexp_symbol_data(a), sexp_symbol_data(b)); + break; + default: + res = 0; + break; + } + } +#if SEXP_USE_HUFF_SYMS + } else if (sexp_lsymbolp(a) && sexp_isymbolp(b)) { + res = strcmp(sexp_symbol_data(a), + sexp_string_data(sexp_write_to_string(ctx, b))); +#endif + } else { + res = 1; + } + } else if (sexp_pointerp(b)) { +#if SEXP_USE_HUFF_SYMS + if (sexp_isymbolp(a) && sexp_lsymbolp(b)) + res = strcmp(sexp_string_data(sexp_write_to_string(ctx, a)), + sexp_symbol_data(b)); + else +#endif + res = -1; + } else { +#if SEXP_USE_HUFF_SYMS + if (sexp_isymbolp(a) && sexp_isymbolp(b)) + return sexp_isymbol_compare(ctx, a, b); + else +#endif + res = (sexp_sint_t)a - (sexp_sint_t)b; + } + return res; +} + +static sexp sexp_object_compare_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { + return sexp_make_fixnum(sexp_object_compare(ctx, a, b)); +} + +/* fast path when using general object-cmp comparator with no key */ +static void sexp_qsort (sexp ctx, sexp *vec, sexp_sint_t lo, sexp_sint_t hi) { + sexp_sint_t mid, i, j; + sexp tmp, tmp2; + loop: + if (lo < hi) { + mid = lo + (hi-lo)/2; + swap(tmp, vec[mid], vec[hi]); + for (i=j=lo; i < hi; i++) + if (sexp_object_compare(ctx, vec[i], tmp) < 0) + swap(tmp2, vec[i], vec[j]), j++; + swap(tmp, vec[j], vec[hi]); + if ((hi-lo) > 2) { + sexp_qsort(ctx, vec, lo, j-1); + lo = j; + goto loop; /* tail recurse on right side */ + } + } +} + +static sexp sexp_qsort_less (sexp ctx, sexp *vec, + sexp_sint_t lo, sexp_sint_t hi, + sexp less, sexp key) { + sexp_sint_t mid, i, j; + sexp tmp, res, args1; + sexp_gc_var3(a, b, args2); + sexp_gc_preserve3(ctx, a, b, args2); + args2 = sexp_list2(ctx, SEXP_VOID, SEXP_VOID); + args1 = sexp_cdr(args2); + loop: + if (lo >= hi) { + res = SEXP_VOID; + } else { + mid = lo + (hi-lo)/2; + swap(tmp, vec[mid], vec[hi]); + if (sexp_truep(key)) { + sexp_car(args1) = tmp; + b = sexp_apply(ctx, key, args1); + } else { + b = tmp; + } + for (i=j=lo; i < hi; i++) { + if (sexp_truep(key)) { + sexp_car(args1) = vec[i]; + a = sexp_apply(ctx, key, args1); + } else { + a = vec[i]; + } + sexp_car(args2) = a; + sexp_car(args1) = b; + res = sexp_apply(ctx, less, args2); + if (sexp_exceptionp(res)) + goto done; + else if (sexp_truep(res)) + swap(res, vec[i], vec[j]), j++; + } + swap(tmp, vec[j], vec[hi]); + if ((hi-lo) > 2) { + res = sexp_qsort_less(ctx, vec, lo, j-1, less, key); + if (sexp_exceptionp(res)) + goto done; + lo = j; + goto loop; /* tail recurse on right side */ + } + } + done: + sexp_gc_release3(ctx); + return res; +} + +static sexp sexp_sort_x (sexp ctx sexp_api_params(self, n), sexp seq, + sexp less, sexp key) { + sexp_sint_t len; + sexp res, *data; + sexp_gc_var1(vec); + + if (sexp_nullp(seq)) return seq; + + sexp_gc_preserve1(ctx, vec); + + vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq); + + if (! sexp_vectorp(vec)) { + res = sexp_type_exception(ctx, self, SEXP_VECTOR, vec); + } else { + data = sexp_vector_data(vec); + len = sexp_vector_length(vec); + if (sexp_not(key) && sexp_basic_comparator(less)) { + sexp_qsort(ctx, data, 0, len-1); + if (sexp_opcodep(less) && sexp_opcode_inverse(less)) + sexp_vector_nreverse(ctx, vec); + } else if (! (sexp_procedurep(less) || sexp_opcodep(less))) { + res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, less); + } else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) { + res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, key); + } else { + res = sexp_qsort_less(ctx, data, 0, len-1, less, key); + } + } + + if (sexp_pairp(seq)) + res = sexp_vector_copy_to_list(ctx, vec, seq); + else if (! sexp_exceptionp(res)) + res = vec; + + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign(ctx, env, "object-cmp", 2, sexp_object_compare_op); + sexp_define_foreign_opt(ctx, env, "sort!", 3, sexp_sort_x, SEXP_FALSE); + return SEXP_VOID; +} diff --git a/lib/srfi/95/sort.scm b/lib/srfi/95/sort.scm new file mode 100644 index 00000000..14e24517 --- /dev/null +++ b/lib/srfi/95/sort.scm @@ -0,0 +1,70 @@ +;; sort.scm -- SRFI-95 sorting utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (copy seq) + (if (vector? seq) + (let* ((len (vector-length seq)) + (res (make-vector len))) + (do ((i (- len 1) (- i 1))) + ((< i 0) res) + (vector-set! res i (vector-ref seq i)))) + (map (lambda (x) x) seq))) + +(define (sort seq . o) + (let ((less (and (pair? o) (car o))) + (key (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (sort! (copy seq) less key))) + +(define (sorted? seq less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (cond + ((vector? seq) + (let ((len (- (vector-length seq) 1))) + (let lp ((i 0)) + (cond + ((>= i len) #t) + ((less (key (vector-ref seq (+ i 1))) (key (vector-ref seq i))) #f) + (else (lp (+ i 1))))))) + ((null? seq) + #t) + (else + (let lp ((ls1 seq) (ls2 (cdr seq))) + (cond ((null? ls2) #t) + ((less (key (car ls2)) (key (car ls1))) #f) + (else (lp ls2 (cdr ls2))))))))) + +(define (merge! ls1 ls2 less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (define (lp prev ls1 ls2 a b less key) + (cond + ((less a b) + (if (null? (cdr ls1)) + (set-cdr! ls1 ls2) + (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key))) + (else + (set-cdr! prev ls2) + (if (null? (cdr ls2)) + (set-cdr! ls2 ls1) + (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key))))) + (cond + ((null? ls1) ls2) + ((null? ls2) ls1) + (else + (let ((a (key (car ls1))) + (b (key (car ls2)))) + (cond + ((less a b) + (if (null? (cdr ls1)) + (set-cdr! ls1 ls2) + (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key)) + ls1) + (else + (if (null? (cdr ls2)) + (set-cdr! ls2 ls1) + (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key)) + ls2))))))) + +(define (merge ls1 ls2 less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (merge! (copy ls1) (copy ls2) less key))) diff --git a/lib/srfi/98.module b/lib/srfi/98.module new file mode 100644 index 00000000..9d124d66 --- /dev/null +++ b/lib/srfi/98.module @@ -0,0 +1,5 @@ + +(define-module (srfi 98) + (export get-environment-variable get-environment-variables) + (include-shared "98/env")) + diff --git a/lib/srfi/98/env.c b/lib/srfi/98/env.c new file mode 100644 index 00000000..f8e519f3 --- /dev/null +++ b/lib/srfi/98/env.c @@ -0,0 +1,48 @@ +/* env.c -- SRFI-98 environment interface */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifdef __APPLE__ +#include +#define environ (*_NSGetEnviron()) +#else +extern char **environ; +#endif + +#include + +sexp sexp_get_environment_variable (sexp ctx sexp_api_params(self, n), sexp str) { + char *cstr; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, self, SEXP_STRING, str); + cstr = getenv(sexp_string_data(str)); + return cstr ? sexp_c_string(ctx, cstr, -1) : SEXP_FALSE; +} + +sexp sexp_get_environment_variables (sexp ctx sexp_api_params(self, n)) { + int i; + char **env, *cname, *cval; + sexp_gc_var3(res, name, val); + sexp_gc_preserve3(ctx, res, name, val); + res = SEXP_NULL; + env = environ; + for (i=0; env[i]; i++) { + cname = env[i]; + cval = strchr(cname, '='); + if (cval) { + name = sexp_c_string(ctx, cname, cval-cname); + val = sexp_c_string(ctx, cval+1, -1); + val = sexp_cons(ctx, name, val); + res = sexp_cons(ctx, val, res); + } + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign(ctx, env, "get-environment-variable", 1, sexp_get_environment_variable); + sexp_define_foreign(ctx, env, "get-environment-variables", 0, sexp_get_environment_variables); + return SEXP_VOID; +} + diff --git a/main.c b/main.c new file mode 100644 index 00000000..d07a9767 --- /dev/null +++ b/main.c @@ -0,0 +1,219 @@ +/* main.c -- chibi-scheme command-line app */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#define sexp_argv_symbol "*command-line-arguments*" +#define sexp_argv_proc "(define (command-line-arguments) "sexp_argv_symbol")" + +#define sexp_import_prefix "(import (" +#define sexp_import_suffix "))" + +#define sexp_version_string "chibi-scheme "sexp_version" \""sexp_release_name"\" " + +#ifdef PLAN9 +#define exit_failure() exits("ERROR") +#else +#define exit_failure() exit(70) +#endif + +static void repl (sexp ctx) { + sexp in, out, err; + sexp_gc_var4(obj, tmp, res, env); + sexp_gc_preserve4(ctx, obj, tmp, res, env); + env = sexp_make_env(ctx); + sexp_env_parent(env) = sexp_context_env(ctx); + sexp_env_define(ctx, sexp_context_env(ctx), + sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env); + sexp_context_tracep(ctx) = 1; + in = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), SEXP_FALSE); + out = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), SEXP_FALSE); + err = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), SEXP_FALSE); + sexp_port_sourcep(in) = 1; + while (1) { + sexp_write_string(ctx, "> ", out); + sexp_flush(ctx, out); + obj = sexp_read(ctx, in); + if (obj == SEXP_EOF) + break; + if (sexp_exceptionp(obj)) { + sexp_print_exception(ctx, obj, err); + } else { + tmp = sexp_env_bindings(env); + sexp_context_top(ctx) = 0; + res = sexp_eval(ctx, obj, env); + if (sexp_exceptionp(res)) { + sexp_print_exception(ctx, res, err); + sexp_stack_trace(ctx, err); + } else { +#if SEXP_USE_WARN_UNDEFS + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp); +#endif + if (res != SEXP_VOID) { + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); + } + } + } + } + sexp_gc_release4(ctx); +} + +static void check_nonull_arg (int c, char *arg) { + if (! arg) { + fprintf(stderr, "chibi-scheme: option '%c' requires an argument\n", c); + exit_failure(); + } +} + +static sexp check_exception (sexp ctx, sexp res) { + sexp err; + if (res && sexp_exceptionp(res)) { + err = sexp_current_error_port(ctx); + if (! sexp_oportp(err)) + err = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_print_exception(ctx, res, err); + sexp_stack_trace(ctx, err); + exit_failure(); + } + return res; +} + +#define init_context() if (! ctx) do { \ + ctx = sexp_make_eval_context(NULL, NULL, NULL, heap_size); \ + env = sexp_context_env(ctx); \ + sexp_gc_preserve2(ctx, tmp, args); \ + } while (0) + +#define load_init() if (! init_loaded++) do { \ + init_context(); \ + check_exception(ctx, sexp_load_standard_env(ctx, env, SEXP_FIVE)); \ + } while (0) + +void run_main (int argc, char **argv) { + char *arg, *impmod, *p; + sexp env, out=SEXP_FALSE, res=SEXP_VOID, ctx=NULL; + sexp_sint_t i, j, len, quit=0, print=0, init_loaded=0; + sexp_uint_t heap_size=0; + sexp_gc_var2(tmp, args); + args = SEXP_NULL; + + /* parse options */ + for (i=1; i < argc && argv[i][0] == '-'; i++) { + switch (argv[i][1]) { + case 'e': + case 'p': + load_init(); + print = (argv[i][1] == 'p'); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('e', arg); + res = check_exception(ctx, sexp_read_from_string(ctx, arg, -1)); + res = check_exception(ctx, sexp_eval(ctx, res, env)); + if (print) { + if (! sexp_oportp(out)) + out = sexp_eval_string(ctx, "(current-output-port)", -1, env); + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); + } + quit = 1; + break; + case 'l': + load_init(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('l', arg); + check_exception(ctx, sexp_load_module_file(ctx, arg, env)); + break; + case 'm': + load_init(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('m', arg); + len = strlen(arg)+strlen(sexp_import_prefix)+strlen(sexp_import_suffix); + impmod = (char*) malloc(len+1); + strcpy(impmod, sexp_import_prefix); + strcpy(impmod+strlen(sexp_import_prefix), arg); + strcpy(impmod+len-+strlen(sexp_import_suffix), sexp_import_suffix); + impmod[len] = '\0'; + for (p=impmod; *p; p++) + if (*p == '.') *p=' '; + check_exception(ctx, sexp_eval_string(ctx, impmod, -1, env)); + free(impmod); + break; + case 'q': + init_context(); + if (! init_loaded++) sexp_load_standard_parameters(ctx, env); + break; + case 'A': + init_context(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('A', arg); + sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_TRUE); + break; + case 'I': + init_context(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('I', arg); + sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_FALSE); + break; + case '-': + i++; + goto done_options; + case 'h': + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('h', arg); + heap_size = atol(arg); + len = strlen(arg); + if (heap_size && (isalpha)(arg[len-1])) { + switch ((tolower)(arg[len-1])) { + case 'k': heap_size *= 1024; break; + case 'm': heap_size *= (1024*1024); break; + } + } + break; + case 'V': + load_init(); + if (! sexp_oportp(out)) + out = sexp_eval_string(ctx, "(current-output-port)", -1, env); + sexp_write_string(ctx, sexp_version_string, out); + tmp = sexp_env_ref(env, sexp_intern(ctx, "*features*", -1), SEXP_NULL); + sexp_write(ctx, tmp, out); + sexp_newline(ctx, out); + return; + default: + fprintf(stderr, "unknown option: %s\n", argv[i]); + exit_failure(); + } + } + + done_options: + if (! quit) { + load_init(); + if (i < argc) + for (j=argc-1; j>i; j--) + args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args); + else + args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args); + sexp_env_define(ctx, env, sexp_intern(ctx, sexp_argv_symbol, -1), args); + sexp_eval_string(ctx, sexp_argv_proc, -1, env); + if (i < argc) { /* script usage */ + check_exception(ctx, sexp_load(ctx, tmp=sexp_c_string(ctx, argv[i], -1), env)); + tmp = sexp_intern(ctx, "main", -1); + tmp = sexp_env_ref(env, tmp, SEXP_FALSE); + if (sexp_procedurep(tmp)) { + args = sexp_list1(ctx, args); + check_exception(ctx, sexp_apply(ctx, tmp, args)); + } + } else { + repl(ctx); + } + } + + sexp_gc_release2(ctx); + sexp_destroy_context(ctx); +} + +int main (int argc, char **argv) { + sexp_scheme_init(); + run_main(argc, argv); + return 0; +} diff --git a/mkfile b/mkfile new file mode 100644 index 00000000..a193e9b6 --- /dev/null +++ b/mkfile @@ -0,0 +1,28 @@ + include/chibi/install.h + echo '#define sexp_platform "plan9"' >> include/chibi/install.h + echo '#define sexp_version "'`{cat VERSION}'"' >> include/chibi/install.h + echo '#define sexp_release_name "'`{cat RELEASE}'"' >> include/chibi/install.h + +install:V: $BIN/$TARG + test -d $MODDIR || mkdir -p $MODDIR + cp -r lib/* $MODDIR/ + +test:V: + ./$O.out tests/r5rs-tests.scm + +sexp.c:N: gc.c opt/bignum.c diff --git a/opcodes.c b/opcodes.c new file mode 100644 index 00000000..34505644 --- /dev/null +++ b/opcodes.c @@ -0,0 +1,178 @@ + +#define _I(n) sexp_make_fixnum(n) +#define _OP(c,o,n,m,rt,a1,a2,a3,i,s,d,f) {c, o, n, m, i, s, d, NULL, NULL, rt, a1, a2, a3, f} +#define _FN(o,n,m,rt,a1,a2,a3,s,d,f) _OP(SEXP_OPC_FOREIGN, o, n, m, rt, a1, a2, a3, 0, s, d, (sexp_proc1)f) +#define _FN0(rt, s, d, f) _FN(SEXP_OP_FCALL0, 0, 0, rt, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, s, d, f) +#define _FN1(rt, a1, s, d, f) _FN(SEXP_OP_FCALL1, 1, 0, rt, a1, SEXP_FALSE, SEXP_FALSE, s, d, f) +#define _FN1OPT(rt, a1, s, d, f) _FN(SEXP_OP_FCALL1, 0, 1, rt, a1, SEXP_FALSE, SEXP_FALSE, s, d, f) +#define _FN1OPTP(rt, a1, s, d, f) _FN(SEXP_OP_FCALL1, 0, 3, rt, a1, SEXP_FALSE, SEXP_FALSE, s, d, f) +#define _FN2(rt, a1, a2, s, d, f) _FN(SEXP_OP_FCALL2, 2, 0, rt, a1, a2, SEXP_FALSE, s, d, f) +#define _FN2OPT(rt, a1, a2, s, d, f) _FN(SEXP_OP_FCALL2, 1, 1, rt, a1, a2, SEXP_FALSE, s, d, f) +#define _FN2OPTP(rt, a1, a2, s, d, f) _FN(SEXP_OP_FCALL2, 1, 3, rt, a1, a2, SEXP_FALSE, s, d, f) +#define _FN3(rt, a1, a2, a3, s, d, f) _FN(SEXP_OP_FCALL3, 3, 0, rt, a1, a2, a3, s, d, f) +#define _FN4(rt, a1, a2, a3, s, d, f) _FN(SEXP_OP_FCALL4, 4, 0, rt, a1, a2, a3, s, d, f) +#define _PARAM(n, a, t) _OP(SEXP_OPC_PARAMETER, SEXP_OP_NOOP, 0, 3, t, t, SEXP_FALSE, SEXP_FALSE, 0, n, a, 0) + +static struct sexp_opcode_struct opcodes[] = { +_OP(SEXP_OPC_GETTER, SEXP_OP_CAR, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PAIR), SEXP_FALSE, SEXP_FALSE, 0, "car", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CAR, 2, 0, SEXP_VOID, _I(SEXP_PAIR), _I(SEXP_OBJECT), SEXP_FALSE, 0, "set-car!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_CDR, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PAIR), SEXP_FALSE, SEXP_FALSE, 0, "cdr", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CDR, 2, 0, SEXP_VOID, _I(SEXP_PAIR), _I(SEXP_OBJECT), SEXP_FALSE, 0, "set-cdr!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_REF, 2, 0, _I(SEXP_OBJECT), _I(SEXP_VECTOR), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"vector-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_VECTOR_SET, 3, 0, SEXP_VOID, _I(SEXP_VECTOR), _I(SEXP_FIXNUM), _I(SEXP_OBJECT), 0,"vector-set!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_VECTOR), SEXP_FALSE, SEXP_FALSE, 0,"vector-length", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_REF, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_BYTES), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"byte-vector-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_BYTES_SET, 3, 0, SEXP_VOID, _I(SEXP_BYTES), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), 0,"byte-vector-set!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_BYTES), SEXP_FALSE, SEXP_FALSE, 0,"byte-vector-length", 0, NULL), +#if SEXP_USE_UTF8_STRINGS +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF, 2, 0, _I(SEXP_CHAR), _I(SEXP_STRING), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"string-cursor-ref", 0, NULL), +#else +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF, 2, 0, _I(SEXP_CHAR), _I(SEXP_STRING), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"string-ref", 0, NULL), +#endif +#if SEXP_USE_MUTABLE_STRINGS +#if SEXP_USE_UTF8_STRINGS +_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET, 3, 0, SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), 0,"string-cursor-set!", 0, NULL), +#else +_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET, 3, 0, SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), 0,"string-set!", 0, NULL), +#endif +#endif +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_STRING), SEXP_FALSE, SEXP_FALSE, 0,"string-length", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_SLOTN_REF, 3, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0, "slot-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SLOTN_SET, 4, 0, SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0,"slot-set!", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, _I(SEXP_FLONUM), _I(SEXP_NUMBER), SEXP_FALSE, SEXP_FALSE, 0, "exact->inexact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_NUMBER), SEXP_FALSE, SEXP_FALSE, 0, "inexact->exact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char->integer", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_INT2CHAR, 1, 0, _I(SEXP_CHAR), _I(SEXP_FIXNUM), SEXP_FALSE, SEXP_FALSE, 0, "integer->char", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_UPCASE, 1, 0, _I(SEXP_CHAR), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char-upcase", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_DOWNCASE, 1, 0, _I(SEXP_CHAR), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char-downcase", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_ADD, 0, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "+", SEXP_ZERO, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_MUL, 0, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "*", SEXP_ONE, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_SUB, 1, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, "-", SEXP_ZERO, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_DIV, 1, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, "/", SEXP_ONE, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_QUOTIENT, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), SEXP_FALSE, 0, "quotient", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_REMAINDER, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), SEXP_FALSE, 0, "remainder", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "<", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "<=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, ">", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, ">=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_EQN, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "=", 0, NULL), +_OP(SEXP_OPC_PREDICATE, SEXP_OP_EQ, 2, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, 0, "eq?", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_CONS, 2, 0, _I(SEXP_PAIR), _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, 0, "cons", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_VECTOR, 1, 1, _I(SEXP_VECTOR), _I(SEXP_FIXNUM), _I(SEXP_OBJECT), SEXP_FALSE, 0, "make-vector", SEXP_VOID, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_PROCEDURE, 4, 0, _I(SEXP_PROCEDURE), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), _I(SEXP_BYTECODE), 0, "make-procedure", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_EXCEPTION, 5, 0, _I(SEXP_EXCEPTION), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), 0, "make-exception", 0, NULL), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_ISA, 2, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, 0, "is-a?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "null?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "eof-object?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "symbol?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_CHARP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "char?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_FIXNUMP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "fixnum?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "pair?", _I(SEXP_PAIR), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "string?", _I(SEXP_STRING), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "vector?", _I(SEXP_VECTOR), 0), +#if SEXP_USE_IMMEDIATE_FLONUMS +_FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "flonum?", 0, sexp_flonump_op), +#else +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "flonum?", _I(SEXP_FLONUM), 0), +#endif +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "bignum?", _I(SEXP_BIGNUM), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "closure?", _I(SEXP_PROCEDURE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "opcode?", _I(SEXP_OPCODE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "input-port?", _I(SEXP_IPORT), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "output-port?", _I(SEXP_OPORT), 0), +_OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_NULL, SEXP_FALSE, 0, "apply1", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_FALSE, SEXP_FALSE, 0, "%call/cc", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "raise", 0, NULL), +_OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, SEXP_VOID, _I(SEXP_CHAR), _I(SEXP_OPORT), SEXP_FALSE, 0, "write-char", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, SEXP_VOID, _I(SEXP_OPORT), SEXP_FALSE, SEXP_FALSE, 0, "newline", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "read-char", (sexp)"*current-input-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "peek-char", (sexp)"*current-input-port*", NULL), +_FN1OPTP(_I(SEXP_OBJECT), _I(SEXP_IPORT), "read", (sexp)"*current-input-port*", sexp_read_op), +_FN2OPTP(SEXP_VOID,_I(SEXP_OBJECT), _I(SEXP_OPORT), "write", (sexp)"*current-output-port*", sexp_write_op), +_FN2OPTP(SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OPORT), "display", (sexp)"*current-output-port*", sexp_display_op), +_FN1OPTP(SEXP_VOID, _I(SEXP_OPORT), "flush-output", (sexp)"*current-output-port*", sexp_flush_output_op), +_FN2(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), "equal?", 0, sexp_equalp_op), +_FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "list?", 0, sexp_listp_op), +_FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "identifier?", 0, sexp_identifierp_op), +_FN1(_I(SEXP_SYMBOL), _I(SEXP_OBJECT), "identifier->symbol", 0, sexp_syntactic_closure_expr_op), +_FN4(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_ENV), _I(SEXP_OBJECT), "identifier=?", 0, sexp_identifier_eq_op), +_FN1(_I(SEXP_FIXNUM), SEXP_NULL, "length", 0, sexp_length_op), +_FN1(SEXP_NULL, SEXP_NULL, "reverse", 0, sexp_reverse_op), +_FN1(SEXP_NULL, SEXP_NULL, "reverse!", 0, sexp_nreverse_op), +_FN2(SEXP_NULL, SEXP_NULL, SEXP_NULL, "append2", 0, sexp_append2_op), +_FN1(_I(SEXP_VECTOR), SEXP_NULL, "list->vector", 0, sexp_list_to_vector_op), +_FN1(_I(SEXP_IPORT), _I(SEXP_STRING), "open-input-file", 0, sexp_open_input_file_op), +_FN1(_I(SEXP_OPORT), _I(SEXP_STRING), "open-output-file", 0, sexp_open_output_file_op), +_FN1(SEXP_VOID, _I(SEXP_IPORT), "close-input-port", 0, sexp_close_port_op), +_FN1(SEXP_VOID, _I(SEXP_OPORT), "close-output-port", 0, sexp_close_port_op), +_FN0(_I(SEXP_ENV), "make-environment", 0, sexp_make_env_op), +_FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "null-environment", 0, sexp_make_null_env_op), +_FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "scheme-report-environment", 0, sexp_make_standard_env_op), +_FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_ENV), "eval", (sexp)"*interaction-environment*", sexp_eval_op), +_FN2OPTP(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_ENV), "load", (sexp)"*interaction-environment*", sexp_load_op), +_FN4(SEXP_VOID, _I(SEXP_ENV), _I(SEXP_ENV), _I(SEXP_OBJECT), "%env-copy!", 0, sexp_env_copy_op), +_FN2(SEXP_VOID, _I(SEXP_EXCEPTION), _I(SEXP_OPORT), "print-exception", 0, sexp_print_exception_op), +_FN1(_I(SEXP_OBJECT), _I(SEXP_EXCEPTION), "exception-type", 0, sexp_exception_type_op), +_FN2OPT(_I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), "make-string", sexp_make_character(' '), sexp_make_string_op), +_FN2OPT(_I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-byte-vector", SEXP_ZERO, sexp_make_bytes_op), +_FN2OPT(_I(SEXP_NUMBER), _I(SEXP_STRING), _I(SEXP_FIXNUM), "string->number", SEXP_TEN, sexp_string_to_number_op), +_FN3(_I(SEXP_FIXNUM), _I(SEXP_STRING), _I(SEXP_STRING), _I(SEXP_BOOLEAN), "string-cmp", 0, sexp_string_cmp_op), +_FN3(_I(SEXP_STRING), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "substring", 0, sexp_substring_op), +_FN1(_I(SEXP_SYMBOL), _I(SEXP_STRING), "string->symbol", 0, sexp_string_to_symbol_op), +_FN2OPT(_I(SEXP_STRING), SEXP_NULL, _I(SEXP_STRING), "string-concatenate", SEXP_FALSE, sexp_string_concatenate_op), +_FN2(_I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_NULL, "memq", 0, sexp_memq_op), +_FN2(_I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_NULL, "assq", 0, sexp_assq_op), +_FN3(_I(SEXP_SYNCLO), _I(SEXP_ENV), SEXP_NULL, _I(SEXP_OBJECT), "make-syntactic-closure", 0, sexp_make_synclo_op), +_FN1(_I(SEXP_OBJECT), _I(SEXP_OBJECT), "strip-syntactic-closures", 0, sexp_strip_synclos), +_PARAM("current-input-port", (sexp)"*current-input-port*", _I(SEXP_IPORT)), +_PARAM("current-output-port", (sexp)"*current-output-port*", _I(SEXP_OPORT)), +_PARAM("current-error-port", (sexp)"*current-error-port*", _I(SEXP_OPORT)), +_PARAM("current-exception-handler", (sexp)"*current-exception-handler*", _I(SEXP_PROCEDURE)), +_PARAM("interaction-environment", (sexp)"*interaction-environment*", _I(SEXP_ENV)), +_FN0(_I(SEXP_OPORT), "open-output-string", 0, sexp_make_output_string_port_op), +_FN1(_I(SEXP_IPORT), _I(SEXP_STRING), "open-input-string", 0, sexp_make_input_string_port_op), +_FN1(_I(SEXP_STRING), _I(SEXP_OPORT), "get-output-string", 0, sexp_get_output_string_op), +#if SEXP_USE_MATH +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "exp", 0, sexp_exp), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "log", 0, sexp_log), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "sin", 0, sexp_sin), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "cos", 0, sexp_cos), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "tan", 0, sexp_tan), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "asin", 0, sexp_asin), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "acos", 0, sexp_acos), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "atan1", 0, sexp_atan), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "sqrt", 0, sexp_sqrt), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "round", 0, sexp_round), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "truncate", 0, sexp_trunc), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "floor", 0, sexp_floor), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "ceiling", 0, sexp_ceiling), +#endif +_FN2(_I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), "expt", 0, sexp_expt_op), +#if SEXP_USE_UTF8_STRINGS +_FN2(_I(SEXP_FIXNUM), _I(SEXP_STRING), _I(SEXP_FIXNUM), "string-index->offset", 0, sexp_string_index_to_offset), +_FN2(_I(SEXP_CHAR), _I(SEXP_STRING), _I(SEXP_FIXNUM), "string-ref", 0, sexp_string_utf8_index_ref), +_FN3(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), "string-set!", 0, sexp_string_utf8_index_set), +#endif +#if SEXP_USE_TYPE_DEFS +_FN2(_I(SEXP_TYPE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "register-simple-type", 0, sexp_register_simple_type_op), +_FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-type-predicate", 0, sexp_make_type_predicate_op), +_FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-constructor", 0, sexp_make_constructor_op), +_FN3(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-getter", 0, sexp_make_getter_op), +_FN3(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-setter", 0, sexp_make_setter_op), +#endif +#if PLAN9 +#include "opt/plan9-opcodes.c" +#endif +#if SEXP_USE_MODULES +_FN0(_I(SEXP_ENV), "current-environment", 0, sexp_current_environment), +_FN1(SEXP_NULL, _I(SEXP_ENV), "env-exports", 0, sexp_env_exports_op), +_FN1(_I(SEXP_STRING), _I(SEXP_STRING), "find-module-file", 0, sexp_find_module_file_op), +_FN2(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_ENV), "load-module-file", 0, sexp_load_module_file_op), +_FN2(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_BOOLEAN), "add-module-directory", 0, sexp_add_module_directory_op), +#endif +#if SEXP_USE_GREEN_THREADS +_OP(SEXP_OPC_GENERIC, SEXP_OP_YIELD, 0, 0, SEXP_VOID, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, 0, "thread-yield!", 0, NULL), +#endif +}; + + diff --git a/opt/bignum.c b/opt/bignum.c new file mode 100644 index 00000000..767d8898 --- /dev/null +++ b/opt/bignum.c @@ -0,0 +1,775 @@ +/* bignum.c -- bignum support */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define SEXP_INIT_BIGNUM_SIZE 2 + +#define sexp_negate(x) \ + if (sexp_bignump(x)) \ + sexp_bignum_sign(x) = -sexp_bignum_sign(x); \ + else if (sexp_fixnump(x)) \ + x = sexp_fx_neg(x); + +sexp sexp_make_bignum (sexp ctx, sexp_uint_t len) { + sexp_uint_t size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); + sexp res = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM); + sexp_bignum_length(res) = len; + sexp_bignum_sign(res) = 1; + return res; +} + +sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) { + sexp res = sexp_make_bignum(ctx, 1); + sexp_bignum_data(res)[0] = sexp_unbox_fixnum(sexp_fx_abs(a)); + sexp_bignum_sign(res) = sexp_fx_sign(a); + return res; +} + +sexp sexp_make_integer (sexp ctx, sexp_lsint_t x) { + sexp res; + if ((SEXP_MIN_FIXNUM <= x) && (x <= SEXP_MAX_FIXNUM)) { + res = sexp_make_fixnum(x); + } else { + res = sexp_make_bignum(ctx, 1); + if (x < 0) { + sexp_bignum_sign(res) = -1; + sexp_bignum_data(res)[0] = -x; + } else { + sexp_bignum_sign(res) = 1; + sexp_bignum_data(res)[0] = x; + } + } + return res; +} + +sexp sexp_make_unsigned_integer (sexp ctx, sexp_luint_t x) { + sexp res; + if (x <= SEXP_MAX_FIXNUM) { + res = sexp_make_fixnum(x); + } else { + res = sexp_make_bignum(ctx, 1); + sexp_bignum_sign(res) = 1; + sexp_bignum_data(res)[0] = x; + } + return res; +} + +#define double_trunc_10s_digit(f) (trunc((f)/10.0)*10.0) +#define double_10s_digit(f) ((f)-double_trunc_10s_digit(f)) + +sexp sexp_double_to_bignum (sexp ctx, double f) { + int sign; + sexp_gc_var3(res, scale, tmp); + sexp_gc_preserve3(ctx, res, scale, tmp); + res = sexp_fixnum_to_bignum(ctx, SEXP_ZERO); + scale = sexp_fixnum_to_bignum(ctx, SEXP_ONE); + sign = (f < 0 ? -1 : 1); + for (f=fabs(f); f >= 1.0; f=trunc(f/10)) { + tmp = sexp_bignum_fxmul(ctx, NULL, scale, double_10s_digit(f), 0); + res = sexp_bignum_add(ctx, res, res, tmp); + scale = sexp_bignum_fxmul(ctx, NULL, scale, 10, 0); + } + sexp_bignum_sign(res) = sign; + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len0) { + sexp_uint_t len = (len0 > 0) ? len0 : sexp_bignum_length(a), size; + size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); + if (! dst || sexp_bignum_length(dst) < len) { + dst = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM); + memmove(dst, a, size); + sexp_bignum_length(dst) = len; + } else { + memset(dst->value.bignum.data, 0, + sexp_bignum_length(dst)*sizeof(sexp_uint_t)); + memmove(dst->value.bignum.data, a->value.bignum.data, + sexp_bignum_length(a)*sizeof(sexp_uint_t)); + } + return dst; +} + +int sexp_bignum_zerop (sexp a) { + int i; + sexp_uint_t *data = sexp_bignum_data(a); + for (i=sexp_bignum_length(a)-1; i>=0; i--) + if (data[i]) + return 0; + return 1; +} + +sexp_uint_t sexp_bignum_hi (sexp a) { + sexp_uint_t i=sexp_bignum_length(a)-1; + while ((i>0) && ! sexp_bignum_data(a)[i]) + i--; + return i+1; +} + +sexp_sint_t sexp_bignum_compare_abs (sexp a, sexp b) { + int ai=sexp_bignum_hi(a), bi=sexp_bignum_hi(b); + sexp_uint_t *adata=sexp_bignum_data(a), *bdata=sexp_bignum_data(b); + if (ai != bi) + return ai - bi; + for (--ai; ai >= 0; ai--) { + if (adata[ai] > bdata[ai]) + return 1; + else if (adata[ai] < bdata[ai]) + return -1; + } + return 0; +} + +sexp_sint_t sexp_bignum_compare (sexp a, sexp b) { + if (sexp_bignum_sign(a) != sexp_bignum_sign(b)) + return sexp_bignum_sign(a); + return sexp_bignum_compare_abs(a, b); +} + +sexp sexp_bignum_normalize (sexp a) { + sexp_uint_t *data; + if ((! sexp_bignump(a)) || (sexp_bignum_hi(a)>1)) + return a; + data = sexp_bignum_data(a); + if ((data[0] > SEXP_MAX_FIXNUM) + && ! ((sexp_bignum_sign(a) == -1) && (data[0] == SEXP_MAX_FIXNUM+1))) + return a; + return sexp_make_fixnum((sexp_sint_t)data[0] * sexp_bignum_sign(a)); +} + +double sexp_bignum_to_double (sexp a) { + double res = 0; + sexp_sint_t i; + sexp_uint_t *data=sexp_bignum_data(a); + for (i=sexp_bignum_hi(a)-1; i>=0; i--) + res = res * ((double)SEXP_UINT_T_MAX+1) + data[i]; + return res * sexp_bignum_sign(a); +} + +sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b) { + sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), + carry=b, i=0, n; + do { n = data[i]; + data[i] += carry; + carry = (n > (SEXP_UINT_T_MAX - carry)); + } while (++i> (sizeof(sexp_uint_t)*8); + } + if (carry) { + if (sexp_bignum_length(d)+offset <= len) + d = sexp_copy_bignum(ctx, NULL, d, len+offset+1); + sexp_bignum_data(d)[len+offset] = carry; + } + sexp_gc_release1(ctx); + return d; +} + +sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) { + sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, r=0; + int i; + sexp_luint_t n = 0; + for (i=len-1; i>=offset; i--) { + n = (n << sizeof(sexp_uint_t)*8) + data[i]; + q = n / b; + r = n - (sexp_luint_t)q * b; + data[i] = q; + n = r; + } + return r; +} + +sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init, + char sign, sexp_uint_t base) { + int c, digit; + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_make_bignum(ctx, SEXP_INIT_BIGNUM_SIZE); + sexp_bignum_sign(res) = sign; + sexp_bignum_data(res)[0] = init; + for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in)) { + digit = digit_value(c); + if ((digit < 0) || (digit >= base)) + break; + res = sexp_bignum_fxmul(ctx, res, res, base, 0); + res = sexp_bignum_fxadd(ctx, res, digit); + } + if (c=='.' || c=='e' || c=='E') { + if (base != 10) { + res = sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in); + } else { + if (c!='.') sexp_push_char(ctx, c, in); /* push the e back */ + res = sexp_read_float_tail(ctx, in, sexp_bignum_to_double(res), (sign==-1)); + } + } else if ((c!=EOF) && ! is_separator(c)) { + res = sexp_read_error(ctx, "invalid numeric syntax", + sexp_make_character(c), in); + } else { + sexp_push_char(ctx, c, in); + } + sexp_gc_release1(ctx); + return sexp_bignum_normalize(res); +} + +static int log2i(int v) { + int i; + for (i = 0; i < sizeof(v)*8; i++) + if ((1<<(i+1)) > v) + break; + return i; +} + +sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) { + int i, str_len, lg_base = log2i(base); + char *data; + sexp_gc_var2(b, str); + sexp_gc_preserve2(ctx, b, str); + b = sexp_copy_bignum(ctx, NULL, a, 0); + sexp_bignum_sign(b) = 1; + i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1) + / lg_base + 1; + str = sexp_make_string(ctx, sexp_make_fixnum(str_len), + sexp_make_character(' ')); + data = sexp_string_data(str); + while (! sexp_bignum_zerop(b)) + data[--i] = hex_digit(sexp_bignum_fxdiv(ctx, b, base, 0)); + if (i == str_len) + data[--i] = '0'; + else if (sexp_bignum_sign(a) == -1) + data[--i] = '-'; + sexp_write_string(ctx, data + i, out); + sexp_gc_release2(ctx); + return SEXP_VOID; +} + +/****************** bignum arithmetic *************************/ + +sexp sexp_bignum_add_fixnum (sexp ctx, sexp a, sexp b) { + sexp_gc_var1(c); + sexp_gc_preserve1(ctx, c); + c = sexp_copy_bignum(ctx, NULL, a, 0); + if (sexp_bignum_sign(c) == sexp_fx_sign(b)) + c = sexp_bignum_fxadd(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b))); + else + c = sexp_bignum_fxsub(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b))); + sexp_gc_release1(ctx); + return c; +} + +sexp sexp_bignum_sub_digits (sexp ctx, sexp dst, sexp a, sexp b) { + sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), + borrow=0, i, *adata, *bdata, *cdata; + sexp_gc_var1(c); + if ((alen < blen) || ((alen == blen) && (sexp_bignum_compare_abs(a, b) < 0))) + return sexp_bignum_sub_digits(ctx, dst, b, a); + sexp_gc_preserve1(ctx, c); + c = ((dst && sexp_bignum_hi(dst) >= alen) + ? dst : sexp_copy_bignum(ctx, NULL, a, 0)); + adata = sexp_bignum_data(a); + bdata = sexp_bignum_data(b); + cdata = sexp_bignum_data(c); + for (i=0; i= alen) + ? dst : sexp_copy_bignum(ctx, NULL, a, 0)); + adata = sexp_bignum_data(a); + bdata = sexp_bignum_data(b); + cdata = sexp_bignum_data(c); + for (i=0; i (SEXP_UINT_T_MAX - bdata[i]) ? 1 : 0); + } + for ( ; carry && (i= 0 ? a : b); + } + return res; +} + +sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b) { + sexp res; + if (sexp_bignum_sign(a) == sexp_bignum_sign(b)) { + res = sexp_bignum_sub_digits(ctx, dst, a, b); + sexp_bignum_sign(res) + = (sexp_bignum_compare_abs(a, b) >= 0 ? sexp_bignum_sign(a) + : -sexp_bignum_sign(a)); + } else { + res = sexp_bignum_add_digits(ctx, dst, a, b); + sexp_bignum_sign(res) = sexp_bignum_sign(a); + } + return res; +} + +sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b) { + sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), i, + *bdata=sexp_bignum_data(b); + sexp_gc_var2(c, d); + if (alen < blen) return sexp_bignum_mul(ctx, dst, b, a); + sexp_gc_preserve2(ctx, c, d); + c = (dst ? dst : sexp_make_bignum(ctx, alen+blen+1)); + d = sexp_make_bignum(ctx, alen+blen+1); + for (i=0; i 0) { + *rem = a; + return sexp_fixnum_to_bignum(ctx, SEXP_ZERO); + } + sexp_gc_preserve5(ctx, x, prod, diff, k2, i2); + k2 = sexp_bignum_double(ctx, k); + i2 = sexp_bignum_double(ctx, i); + x = quot_step(ctx, rem, a, b, k2, i2); + prod = sexp_bignum_mul(ctx, NULL, x, b); + diff = sexp_bignum_sub_digits(ctx, NULL, a, prod); + if (sexp_bignum_compare(diff, k) >= 0) { + *rem = sexp_bignum_sub_digits(ctx, NULL, diff, k); + res = sexp_bignum_add_digits(ctx, NULL, x, i); + } else { + *rem = diff; + res = x; + } + sexp_gc_release5(ctx); + return res; +} + +sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) { + sexp res; + sexp_gc_var4(k, i, a1, b1); + sexp_gc_preserve4(ctx, k, i, a1, b1); + a1 = sexp_copy_bignum(ctx, NULL, a, 0); + sexp_bignum_sign(a1) = 1; + b1 = sexp_copy_bignum(ctx, NULL, b, 0); + sexp_bignum_sign(b1) = 1; + k = sexp_copy_bignum(ctx, NULL, b1, 0); + i = sexp_fixnum_to_bignum(ctx, SEXP_ONE); + res = quot_step(ctx, rem, a1, b1, k, i); + sexp_bignum_sign(res) = sexp_bignum_sign(a) * sexp_bignum_sign(b); + if (sexp_bignum_sign(a) < 0) { + sexp_negate(*rem); + } + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_bignum_quotient (sexp ctx, sexp a, sexp b) { + sexp res; + sexp_gc_var1(rem); + sexp_gc_preserve1(ctx, rem); + res = sexp_bignum_quot_rem(ctx, &rem, a, b); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_bignum_remainder (sexp ctx, sexp a, sexp b) { + sexp_gc_var1(rem); + sexp_gc_preserve1(ctx, rem); + sexp_bignum_quot_rem(ctx, &rem, a, b); /* discard quotient */ + sexp_gc_release1(ctx); + return rem; +} + +sexp sexp_bignum_expt (sexp ctx, sexp a, sexp b) { + sexp_sint_t e = sexp_unbox_fixnum(sexp_fx_abs(b)); + sexp_gc_var2(res, acc); + sexp_gc_preserve2(ctx, res, acc); + res = sexp_fixnum_to_bignum(ctx, SEXP_ONE); + acc = sexp_copy_bignum(ctx, NULL, a, 0); + for (; e; e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc)) + if (e & 1) + res = sexp_bignum_mul(ctx, NULL, res, acc); + sexp_gc_release2(ctx); + return res; +} + +/****************** generic arithmetic ************************/ + +enum sexp_number_types { + SEXP_NUM_NOT = 0, + SEXP_NUM_FIX, + SEXP_NUM_FLO, + SEXP_NUM_BIG +}; + +enum sexp_number_combs { + SEXP_NUM_NOT_NOT = 0, + SEXP_NUM_NOT_FIX, + SEXP_NUM_NOT_FLO, + SEXP_NUM_NOT_BIG, + SEXP_NUM_FIX_NOT, + SEXP_NUM_FIX_FIX, + SEXP_NUM_FIX_FLO, + SEXP_NUM_FIX_BIG, + SEXP_NUM_FLO_NOT, + SEXP_NUM_FLO_FIX, + SEXP_NUM_FLO_FLO, + SEXP_NUM_FLO_BIG, + SEXP_NUM_BIG_NOT, + SEXP_NUM_BIG_FIX, + SEXP_NUM_BIG_FLO, + SEXP_NUM_BIG_BIG +}; + +static int sexp_number_types[] = + {0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0}; + +static int sexp_number_type (sexp a) { + return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)&15] +#if SEXP_USE_IMMEDIATE_FLONUMS + : sexp_flonump(a) ? 2 +#endif + : sexp_fixnump(a); +} + +sexp sexp_add (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b), t; + sexp r=SEXP_VOID; + if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_add(a, b); /* VM catches this case */ + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)+sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_normalize(sexp_bignum_add_fixnum(ctx, b, a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_add(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_add(ctx, NULL, b, a)); + break; + } + return r; +} + +sexp sexp_sub (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_sub(a, b); /* VM catches this case */ + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)-sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + tmp = sexp_fixnum_to_bignum(ctx, a); + r = sexp_bignum_sub(ctx, NULL, b, tmp); + sexp_negate(r); + r = sexp_bignum_normalize(r); + break; + case SEXP_NUM_FLO_FIX: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(b)+sexp_flonum_value(a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_sub(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) - sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_FIX: + tmp = sexp_fixnum_to_bignum(ctx, b); + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, tmp)); + break; + case SEXP_NUM_BIG_FLO: + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) - sexp_flonum_value(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, b)); + break; + } + sexp_gc_release1(ctx); + return r; +} + +sexp sexp_mul (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b), t; + sexp r=SEXP_VOID; + if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_mul(a, b); + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)*sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_fxmul(ctx, NULL, b, sexp_unbox_fixnum(sexp_fx_abs(a)), 0); + sexp_bignum_sign(r) = sexp_fx_sign(a) * sexp_bignum_sign(b); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_mul(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) * sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_mul(ctx, NULL, a, b); + break; + } + return r; +} + +sexp sexp_div (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + double f; + sexp r=SEXP_VOID; + sexp_gc_var2(tmp, rem); + sexp_gc_preserve2(ctx, tmp, rem); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, b); + break; + case SEXP_NUM_FIX_FIX: + f = sexp_fixnum_to_double(a) / sexp_fixnum_to_double(b); + r = ((f == trunc(f)) ? sexp_make_fixnum((sexp_sint_t)f) + : sexp_make_flonum(ctx, f)); + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_bignum_to_double(b)); + break; + case SEXP_NUM_FLO_FIX: + r = sexp_make_flonum(ctx, sexp_flonum_value(a)/sexp_fixnum_to_double(b)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_div(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) / sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_FIX: + b = tmp = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_quot_rem(ctx, &rem, a, b); + if (sexp_bignum_normalize(rem) != SEXP_ZERO) + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) + / sexp_bignum_to_double(b)); + else + r = sexp_bignum_normalize(r); + break; + case SEXP_NUM_BIG_FLO: + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) / sexp_flonum_value(b)); + break; + } + sexp_gc_release2(ctx); + return r; +} + +sexp sexp_quotient (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_div(a, b); + break; + case SEXP_NUM_FIX_BIG: + r = SEXP_ZERO; + break; + case SEXP_NUM_BIG_FIX: + b = tmp = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_quotient(ctx, a, b)); + break; + } + sexp_gc_release1(ctx); + return r; +} + +sexp sexp_remainder (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_rem(a, b); + break; + case SEXP_NUM_FIX_BIG: + r = a; + break; + case SEXP_NUM_BIG_FIX: + b = tmp = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_remainder(ctx, a, b)); + break; + } + sexp_gc_release1(ctx); + return r; +} + +sexp sexp_compare (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + double f; + if (at > bt) { + r = sexp_compare(ctx, b, a); + sexp_negate(r); + } else { + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_make_fixnum(sexp_unbox_fixnum(a) - sexp_unbox_fixnum(b)); + break; + case SEXP_NUM_FIX_FLO: + f = sexp_fixnum_to_double(a) - sexp_flonum_value(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_fixnum(-1); + break; + case SEXP_NUM_FLO_FLO: + f = sexp_flonum_value(a) - sexp_flonum_value(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_FLO_BIG: + f = sexp_flonum_value(a) - sexp_bignum_to_double(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_make_fixnum(sexp_bignum_compare(a, b)); + break; + } + } + return r; +} + diff --git a/opt/fcall.c b/opt/fcall.c new file mode 100644 index 00000000..c38cc3fe --- /dev/null +++ b/opt/fcall.c @@ -0,0 +1,33 @@ + +typedef sexp (*sexp_proc8) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc9) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc10) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc11) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc12) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc13) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc14) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc15) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc16) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc17) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); + +#define _A(i) stack[top-i] + +sexp sexp_fcall (sexp ctx, sexp self, sexp_sint_t n, sexp f) { + sexp *stack = sexp_stack_data(sexp_context_stack(ctx)); + sexp_sint_t top = sexp_context_top(ctx); + switch (n) { + case 5: return ((sexp_proc6)sexp_opcode_func(f))(ctx, f, 5, _A(1), _A(2), _A(3), _A(4), _A(5)); + case 6: return ((sexp_proc7)sexp_opcode_func(f))(ctx, f, 6, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6)); + case 7: return ((sexp_proc8)sexp_opcode_func(f))(ctx, f, 7, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7)); + case 8: return ((sexp_proc9)sexp_opcode_func(f))(ctx, f, 8, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8)); + case 9: return ((sexp_proc10)sexp_opcode_func(f))(ctx, f, 9, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9)); + case 10: return ((sexp_proc11)sexp_opcode_func(f))(ctx, f, 10, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10)); + case 11: return ((sexp_proc12)sexp_opcode_func(f))(ctx, f, 11, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11)); + case 12: return ((sexp_proc13)sexp_opcode_func(f))(ctx, f, 12, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12)); + case 13: return ((sexp_proc14)sexp_opcode_func(f))(ctx, f, 13, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13)); + case 14: return ((sexp_proc15)sexp_opcode_func(f))(ctx, f, 14, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14)); + case 15: return ((sexp_proc16)sexp_opcode_func(f))(ctx, f, 15, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15)); + case 16: return ((sexp_proc17)sexp_opcode_func(f))(ctx, f, 16, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15), _A(16)); + default: return sexp_user_exception(ctx, self, "too many FFI arguments", f); + } +} diff --git a/opt/opcode_names.h b/opt/opcode_names.h new file mode 100644 index 00000000..a87aeb1c --- /dev/null +++ b/opt/opcode_names.h @@ -0,0 +1,21 @@ + +static const char* reverse_opcode_names[] = + {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", + "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALLN", + "JUMP-UNLESS", "JUMP", "PUSH", "DROP", + "GLOBAL-REF", "GLOBAL-KNOWN-REF", "STACK-REF", + "LOCAL-REF", "LOCAL-SET", "CLOSURE-REF", + "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", + "BYTES-REF", "BYTES-SET", "BYTES-LENGTH", + "STRING-REF", "STRING-SET", "STRING-LENGTH", + "MAKE-PROCEDURE", "MAKE-VECTOR", + "MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", + "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", + "ISA?", "SLOTN-REF", "SLOTN-SET", + "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", + "ADD", "SUB", "MUL", "DIV", "QUOTIENT", "REMAINDER", + "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT", + "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", + "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", + "YIELD", "RET", "DONE", + }; diff --git a/opt/plan9-opcodes.c b/opt/plan9-opcodes.c new file mode 100644 index 00000000..9f7cac33 --- /dev/null +++ b/opt/plan9-opcodes.c @@ -0,0 +1,19 @@ +_FN0("random-integer", 0, sexp_rand), +_FN1(SEXP_FIXNUM, "random-seed", 0, sexp_srand), +_FN0("current-directory", 0, sexp_getwd), +_FN0("current-user", 0, sexp_getuser), +_FN0("system-name", 0, sexp_sysname), +_FN1(SEXP_IPORT, "port-fileno", 0, sexp_fileno), +_FN2(SEXP_FIXNUM, SEXP_STRING, "fileno->port", 0, sexp_fdopen), +_FN0("fork", 0, sexp_fork), +_FN2(SEXP_STRING, SEXP_PAIR, "exec", 0, sexp_exec), +_FN1(SEXP_STRING, "exits", 0, sexp_exits), +_FN2(SEXP_FIXNUM, SEXP_FIXNUM, "dup", 0, sexp_dup), +_FN0("pipe", 0, sexp_pipe), +_FN1(SEXP_FIXNUM, "sleep", 0, sexp_sleep), +_FN1(SEXP_STRING, "getenv", 0, sexp_getenv), +_FN1(SEXP_STRING, "change-directory", 0, sexp_chdir), +_FN0("wait", 0, sexp_wait), +_FN2(SEXP_FIXNUM, SEXP_STRING, "post-note", 0, sexp_postnote), +_FN4(SEXP_PAIR, SEXP_STRING, "%postmountsrv", 0, sexp_postmountsrv), +_FN1(SEXP_STRING, "file-exists?", 0, sexp_file_exists_p), diff --git a/opt/plan9.c b/opt/plan9.c new file mode 100644 index 00000000..ca25afba --- /dev/null +++ b/opt/plan9.c @@ -0,0 +1,351 @@ +/* plan9.c -- extended Plan 9 system utils */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +sexp sexp_rand (sexp ctx sexp_api_params(self, n)) { + return sexp_make_fixnum(rand()); +} + +sexp sexp_srand (sexp ctx sexp_api_params(self, n), sexp seed) { + srand(sexp_unbox_fixnum(seed)); + return SEXP_VOID; +} + +sexp sexp_file_exists_p (sexp ctx sexp_api_params(self, n), sexp path) { + int res; + uchar statbuf[STATMAX]; + if (! sexp_stringp(path)) + return sexp_type_exception(ctx, "file-exists?: not a string", path); + res = stat(sexp_string_data(path), statbuf, sizeof(statbuf)); + return (res < 0) ? SEXP_FALSE : SEXP_TRUE; +} + +sexp sexp_fdopen (sexp ctx sexp_api_params(self, n), sexp fd, sexp mode) { + FILE *f; + if (! sexp_integerp(fd)) + return sexp_type_exception(ctx, "fdopen: not an integer", fd); + if (! sexp_stringp(mode)) + return sexp_type_exception(ctx, "fdopen: not a mode string", mode); + f = fdopen(sexp_unbox_fixnum(fd), sexp_string_data(mode)); + if (! f) + return sexp_user_exception(ctx, SEXP_FALSE, "fdopen failed", fd); + /* maybe use fd2path to get the name of the fd */ + if (sexp_string_data(mode)[0] == 'w') + return sexp_make_output_port(ctx, f, SEXP_FALSE); + else + return sexp_make_input_port(ctx, f, SEXP_FALSE); +} + +sexp sexp_fileno (sexp ctx sexp_api_params(self, n), sexp port) { + if (! sexp_portp(port)) + return sexp_type_exception(ctx, "fileno: not a port", port); + return sexp_make_fixnum(fileno(sexp_port_stream(port))); +} + +sexp sexp_fork (sexp ctx sexp_api_params(self, n)) { + return sexp_make_fixnum(fork()); +} + +sexp sexp_exec (sexp ctx sexp_api_params(self, n), sexp name, sexp args) { + int i, len = sexp_unbox_fixnum(sexp_length(ctx, args)); + char **argv = malloc((len+1)*sizeof(char*)); + for (i=0; imsg, -1); + res = sexp_list2(ctx, sexp_make_fixnum(wmsg->pid), msg); + sexp_gc_release(ctx, msg, s_msg); + return res; +} + +sexp sexp_postnote (sexp ctx sexp_api_params(self, n), sexp pid, sexp note) { + if (! sexp_integerp(pid)) + return sexp_type_exception(ctx, "postnote: not an integer", pid); + if (! sexp_stringp(note)) + return sexp_type_exception(ctx, "postnote: not a string", note); + postnote(PNPROC, sexp_unbox_fixnum(pid), sexp_string_data(note)); + return SEXP_VOID; +} + +/**********************************************************************/ +/* 9p interface */ + +typedef struct sexp_plan9_srv { + sexp context, auth, attach, walk, walk1, clone, open, create, remove, + read, write, stat, wstat, flush, destroyfid, destroyreq, end; +} *sexp_plan9_srv; + +void sexp_build_srv (sexp ctx, sexp_plan9_srv s, sexp ls) { + s->context = ctx; + s->auth = s->attach = s->walk = s->walk1 = s->clone = s->open + = s->create = s->remove = s->read = s->write = s->stat = s->wstat + = s->flush = s->destroyfid = s->destroyreq = s->end = SEXP_FALSE; + for ( ; sexp_pairp(ls) && sexp_pairp(sexp_cdr(ls)); ls=sexp_cddr(ls)) { + if (sexp_car(ls) == sexp_intern(ctx, "auth:", -1)) { + s->auth = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "attach:", -1)) { + s->attach = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "walk:", -1)) { + s->walk = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "walk1:", -1)) { + s->walk1 = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "clone:", -1)) { + s->clone = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "open:", -1)) { + s->open = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "create:", -1)) { + s->create = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "remove:", -1)) { + s->remove = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "read:", -1)) { + s->read = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "write:", -1)) { + s->write = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "stat:", -1)) { + s->stat = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "wstat:", -1)) { + s->wstat = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "flush:", -1)) { + s->flush = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyfid:", -1)) { + s->destroyfid = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyreq:", -1)) { + s->destroyreq = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "end:", -1)) { + s->end = sexp_cadr(ls); + } + } +} + +void sexp_run_9p_handler (Req *r, sexp handler) { + sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, handler, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +#define sexp_def_9p_handler(name, field) \ + void name (Req *r) { \ + sexp_run_9p_handler(r, ((sexp_plan9_srv)r->srv->aux)->field); \ + } + +sexp_def_9p_handler(sexp_9p_auth, auth) +sexp_def_9p_handler(sexp_9p_attach, attach) +sexp_def_9p_handler(sexp_9p_walk, walk) +sexp_def_9p_handler(sexp_9p_open, open) +sexp_def_9p_handler(sexp_9p_create, create) +sexp_def_9p_handler(sexp_9p_remove, remove) +sexp_def_9p_handler(sexp_9p_read, read) +sexp_def_9p_handler(sexp_9p_write, write) +sexp_def_9p_handler(sexp_9p_stat, stat) +sexp_def_9p_handler(sexp_9p_wstat, wstat) +sexp_def_9p_handler(sexp_9p_flush, flush) + +char* sexp_9p_walk1 (Fid *fid, char *name, Qid *qid) { + sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux; + sexp res, ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, qid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + ptr = sexp_c_string(ctx, name, -1); + args = sexp_cons(ctx, ptr, args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, args); + res = sexp_apply(ctx, s->walk1, args); + sexp_gc_release(ctx, ptr, s_ptr); + return sexp_stringp(res) ? sexp_string_data(res) : nil; +} + +char* sexp_9p_clone (Fid *oldfid, Fid *newfid) { + sexp_plan9_srv s = (sexp_plan9_srv)oldfid->pool->srv->aux; + sexp res, ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, oldfid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, newfid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, args); + res = sexp_apply(ctx, s->clone, args); + sexp_gc_release(ctx, ptr, s_ptr); + return sexp_stringp(res) ? sexp_string_data(res) : nil; +} + +void sexp_9p_destroyfid (Fid *fid) { + sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->destroyfid, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +void sexp_9p_destroyreq (Req *r) { + sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->destroyreq, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +void sexp_9p_end (Srv *srv) { + sexp_plan9_srv s = (sexp_plan9_srv)srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, srv, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->end, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +sexp sexp_postmountsrv (sexp ctx sexp_api_params(self, n), sexp ls, sexp name, sexp mtpt, sexp flags) { + Srv s; + struct sexp_plan9_srv p9s; + if (! sexp_listp(ctx, ls)) + return sexp_type_exception(ctx, "postmountsrv: not a list", ls); + if (! sexp_stringp(name)) + return sexp_type_exception(ctx, "postmountsrv: not a string", name); + if (! sexp_stringp(mtpt)) + return sexp_type_exception(ctx, "postmountsrv: not a string", mtpt); + if (! sexp_integerp(flags)) + return sexp_type_exception(ctx, "postmountsrv: not an integer", flags); + sexp_build_srv(ctx, &p9s, ls); + s.aux = &p9s; + s.auth = &sexp_9p_auth; + s.attach = &sexp_9p_attach; + s.walk = &sexp_9p_walk; + s.walk1 = &sexp_9p_walk1; + s.clone = &sexp_9p_clone; + s.open = &sexp_9p_open; + s.create = &sexp_9p_create; + s.remove = &sexp_9p_remove; + s.read = &sexp_9p_read; + s.write = &sexp_9p_write; + s.stat = &sexp_9p_stat; + s.wstat = &sexp_9p_wstat; + s.flush = &sexp_9p_flush; + s.destroyfid = &sexp_9p_destroyfid; + s.destroyreq = &sexp_9p_destroyreq; + s.end = &sexp_9p_end; + postmountsrv(&s, sexp_string_data(name), sexp_string_data(mtpt), + sexp_unbox_fixnum(flags)); + return SEXP_UNDEF; +} + +sexp sexp_9p_req_offset (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.offset); +} + +sexp sexp_9p_req_count (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.count); +} + +#if 0 +sexp sexp_9p_req_path (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_c_string(ctx, ((Req*)sexp_cpointer_value(req))->fid->qid.path, -1); +} +#endif + +sexp sexp_9p_req_fid (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->fid, SEXP_FALSE, 0); +} + +sexp sexp_9p_req_newfid (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->newfid, SEXP_FALSE, 0); +} + +sexp sexp_9p_respond (sexp ctx sexp_api_params(self, n), sexp req, sexp err) { + char *cerr = sexp_stringp(err) ? sexp_string_data(err) : nil; + respond(sexp_cpointer_value(req), cerr); + return SEXP_VOID; +} + +sexp sexp_9p_responderror (sexp ctx sexp_api_params(self, n), sexp req) { + responderror(sexp_cpointer_value(req)); + return SEXP_VOID; +} + diff --git a/opt/sexp-huff.c b/opt/sexp-huff.c new file mode 100644 index 00000000..abf6bc9f --- /dev/null +++ b/opt/sexp-huff.c @@ -0,0 +1,128 @@ + {12, 0x0C00}, /* '\x00' */ + {15, 0x0000}, /* '\x01' */ + {15, 0x4000}, /* '\x02' */ + {15, 0x2000}, /* '\x03' */ + {15, 0x6000}, /* '\x04' */ + {15, 0x0800}, /* '\x05' */ + {15, 0x4800}, /* '\x06' */ + {15, 0x2800}, /* '\x07' */ + {15, 0x6800}, /* '\x08' */ + {15, 0x1800}, /* '\x09' */ + {15, 0x5800}, /* '\x0a' */ + {15, 0x3800}, /* '\x0b' */ + {15, 0x7800}, /* '\x0c' */ + {15, 0x0100}, /* '\x0d' */ + {15, 0x4100}, /* '\x0e' */ + {15, 0x2100}, /* '\x0f' */ + {15, 0x6100}, /* '\x10' */ + {15, 0x1100}, /* '\x11' */ + {15, 0x5100}, /* '\x12' */ + {15, 0x3100}, /* '\x13' */ + {15, 0x7100}, /* '\x14' */ + {15, 0x0900}, /* '\x15' */ + {15, 0x4900}, /* '\x16' */ + {15, 0x2900}, /* '\x17' */ + {15, 0x6900}, /* '\x18' */ + {15, 0x1900}, /* '\x19' */ + {15, 0x5900}, /* '\x1a' */ + {15, 0x3900}, /* '\x1b' */ + {15, 0x7900}, /* '\x1c' */ + {15, 0x0500}, /* '\x1d' */ + {15, 0x4500}, /* '\x1e' */ + {15, 0x2500}, /* '\x1f' */ + {15, 0x6500}, /* '\x20' */ + { 8, 0x0040}, /* '!' */ + {15, 0x1500}, /* '"' */ + {15, 0x5500}, /* '#' */ + {15, 0x3500}, /* '$' */ + {15, 0x7500}, /* '%' */ + {15, 0x0D00}, /* '&' */ + {15, 0x4D00}, /* '\'' */ + {15, 0x2D00}, /* '(' */ + {15, 0x6D00}, /* ')' */ + {11, 0x0300}, /* '*' */ + {10, 0x0180}, /* '+' */ + {15, 0x1D00}, /* ',' */ + { 4, 0x000D}, /* '-' */ + {15, 0x5D00}, /* '.' */ + {10, 0x0380}, /* '/' */ + {15, 0x3D00}, /* '0' */ + {15, 0x7D00}, /* '1' */ + {14, 0x0080}, /* '2' */ + {14, 0x2080}, /* '3' */ + {14, 0x1080}, /* '4' */ + {14, 0x3080}, /* '5' */ + {14, 0x0880}, /* '6' */ + {14, 0x2880}, /* '7' */ + {14, 0x1880}, /* '8' */ + {14, 0x3880}, /* '9' */ + {14, 0x0480}, /* ':' */ + {14, 0x2480}, /* ';' */ + { 7, 0x0050}, /* '<' */ + { 7, 0x0042}, /* '=' */ + { 7, 0x0022}, /* '>' */ + { 5, 0x0009}, /* '?' */ + {14, 0x1480}, /* '@' */ + {14, 0x3480}, /* 'A' */ + {14, 0x0C80}, /* 'B' */ + {14, 0x2C80}, /* 'C' */ + {14, 0x1C80}, /* 'D' */ + {14, 0x3C80}, /* 'E' */ + {14, 0x0280}, /* 'F' */ + {14, 0x2280}, /* 'G' */ + {14, 0x1280}, /* 'H' */ + {14, 0x3280}, /* 'I' */ + {14, 0x0A80}, /* 'J' */ + {14, 0x2A80}, /* 'K' */ + {14, 0x1A80}, /* 'L' */ + {14, 0x3A80}, /* 'M' */ + {14, 0x0680}, /* 'N' */ + {14, 0x2680}, /* 'O' */ + {14, 0x1680}, /* 'P' */ + {14, 0x3680}, /* 'Q' */ + {14, 0x0E80}, /* 'R' */ + {14, 0x2E80}, /* 'S' */ + {14, 0x1E80}, /* 'T' */ + {14, 0x3E80}, /* 'U' */ + {14, 0x0200}, /* 'V' */ + {14, 0x2200}, /* 'W' */ + {14, 0x1200}, /* 'X' */ + {14, 0x3200}, /* 'Y' */ + {14, 0x0A00}, /* 'Z' */ + {14, 0x2A00}, /* '[' */ + {14, 0x1A00}, /* '\\' */ + {14, 0x3A00}, /* ']' */ + {14, 0x0600}, /* '^' */ + {14, 0x2600}, /* '_' */ + {14, 0x1600}, /* '`' */ + { 3, 0x0007}, /* 'a' */ + { 7, 0x0020}, /* 'b' */ + { 4, 0x0004}, /* 'c' */ + { 5, 0x001A}, /* 'd' */ + { 4, 0x0006}, /* 'e' */ + { 7, 0x0002}, /* 'f' */ + { 5, 0x0011}, /* 'g' */ + { 6, 0x0012}, /* 'h' */ + { 4, 0x000C}, /* 'i' */ + {12, 0x0400}, /* 'j' */ + { 8, 0x00C0}, /* 'k' */ + { 5, 0x0018}, /* 'l' */ + { 6, 0x0032}, /* 'm' */ + { 4, 0x0005}, /* 'n' */ + { 5, 0x000A}, /* 'o' */ + { 5, 0x0001}, /* 'p' */ + { 7, 0x0070}, /* 'q' */ + { 3, 0x0003}, /* 'r' */ + { 5, 0x0008}, /* 's' */ + { 4, 0x000E}, /* 't' */ + { 5, 0x0019}, /* 'u' */ + { 7, 0x0062}, /* 'v' */ + { 7, 0x0030}, /* 'w' */ + { 7, 0x0060}, /* 'x' */ + { 7, 0x0010}, /* 'y' */ + {11, 0x0700}, /* 'z' */ + {14, 0x3600}, /* '{' */ + {14, 0x0E00}, /* '|' */ + {14, 0x2E00}, /* '}' */ + {14, 0x1E00}, /* '~' */ + {14, 0x3E00}, /* '\x7f' */ diff --git a/opt/sexp-hufftabs.c b/opt/sexp-hufftabs.c new file mode 100644 index 00000000..7704184f --- /dev/null +++ b/opt/sexp-hufftabs.c @@ -0,0 +1,92 @@ +/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */ + +char _huff_tab21[] = { + '\x01', '\x00', '\x03', '\x00', '\x02', '\x00', '\x04', '\x00', +}; + +char _huff_tab19[] = { + '\x01', 'j', '\x01', '\x00', +}; + +char _huff_tab20[] = { + '\x05', '\x09', '\x07', '\x0b', '\x06', '\x0a', '\x08', '\x0c', +}; + +char _huff_tab18[] = { + '2', ':', '6', 'B', '4', '@', '8', 'D', + '3', ';', '7', 'C', '5', 'A', '9', 'E', +}; + +char _huff_tab17[] = { + '\x0d', '\x1d', '\x15', '&', '\x11', '"', '\x19', ',', + '\x0f', '\x1f', '\x17', '(', '\x13', '$', '\x1b', '0', + '\x0e', '\x1e', '\x16', '\'', '\x12', '#', '\x1a', '.', + '\x10', '\x20', '\x18', ')', '\x14', '%', '\x1c', '1', +}; + +char _huff_tab16[] = { + 'V', '^', 'Z', '|', 'X', '`', '\\', '~', + 'W', '_', '[', '}', 'Y', '{', ']', '\x7f', +}; + +char _huff_tab15[] = { + 'F', 'N', 'J', 'R', 'H', 'P', 'L', 'T', + 'G', 'O', 'K', 'S', 'I', 'Q', 'M', 'U', +}; + +char _huff_tab13[] = { + '\x00', '\x00', '\x00', '+', '\x00', '\x00', '\x00', '/', +}; + +char _huff_tab14[] = { + '*', 'z', +}; + +char _huff_tab11[] = { + '\x00', 'b', '\x00', 'x', +}; + +char _huff_tab12[] = { + '!', 'k', +}; + +char _huff_tab9[] = { + '\x00', 's', '\x00', 'l', +}; + +char _huff_tab10[] = { + 'y', 'w', '<', 'q', +}; + +char _huff_tab8[] = { + 'p', '?', 'g', 'u', +}; + +char _huff_tab7[] = { + 'f', '>', '=', 'v', +}; + +char _huff_tab5[] = { + '\x00', 'o', '\x00', 'd', +}; + +char _huff_tab6[] = { + 'h', 'm', +}; + +char _huff_tab4[] = { + 'c', 'i', +}; + +char _huff_tab3[] = { + 'n', '-', +}; + +char _huff_tab1[] = { + '\x00', '\x00', '\x00', 'r', '\x00', '\x00', '\x00', 'a', +}; + +char _huff_tab2[] = { + 'e', 't', +}; + diff --git a/opt/sexp-unhuff.c b/opt/sexp-unhuff.c new file mode 100644 index 00000000..fa142e16 --- /dev/null +++ b/opt/sexp-unhuff.c @@ -0,0 +1,71 @@ +/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */ + +res = c & 7; +c = c >> 3; +if (res == 0) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = c & 7; + c = c >> 3; + if (res == 0) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = _huff_tab21[c & 7]; + c = c >> 3; + } else if ((res = _huff_tab19[res]) == '\x01') { + res = _huff_tab20[c & 7]; + c = c >> 3; + } + } else if (res == 1) { + res = _huff_tab18[c & 15]; + c = c >> 4; + } else if (res == 2) { + res = _huff_tab17[c & 31]; + c = c >> 5; + } else if (res == 4) { + res = _huff_tab16[c & 15]; + c = c >> 4; + } else if (res == 5) { + res = _huff_tab15[c & 15]; + c = c >> 4; + } else if ((res = _huff_tab13[res]) == '\x00') { + res = _huff_tab14[c & 1]; + c = c >> 1; + } + } else if ((res = _huff_tab11[res]) == '\x00') { + res = _huff_tab12[c & 1]; + c = c >> 1; + } + } else if ((res = _huff_tab9[res]) == '\x00') { + res = _huff_tab10[c & 3]; + c = c >> 2; + } + } else if (res == 1) { + res = _huff_tab8[c & 3]; + c = c >> 2; + } else if (res == 2) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = _huff_tab7[c & 3]; + c = c >> 2; + } else if ((res = _huff_tab5[res]) == '\x00') { + res = _huff_tab6[c & 1]; + c = c >> 1; + } + } else if (res == 4) { + res = _huff_tab4[c & 1]; + c = c >> 1; + } else if (res == 5) { + res = _huff_tab3[c & 1]; + c = c >> 1; + } else if ((res = _huff_tab1[res]) == '\x00') { + res = _huff_tab2[c & 1]; + c = c >> 1; + } + diff --git a/opt/simplify.c b/opt/simplify.c new file mode 100644 index 00000000..4217a1bb --- /dev/null +++ b/opt/simplify.c @@ -0,0 +1,143 @@ +/* simplify.c -- basic simplification pass */ +/* Copyright (c) 2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define simplify_it(it) ((it) = simplify(ctx, it, substs, lambda)) + +static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) { + int check; + sexp ls1, ls2, p1, p2, sv, ctx2; + sexp_gc_var4(res, substs, tmp, app); + sexp_gc_preserve4(ctx, res, substs, tmp, app); + res = ast; /* return the ast as-is by default */ + substs = init_substs; + + loop: + switch (sexp_pointerp(res) ? sexp_pointer_tag(res) : 0) { + + case SEXP_PAIR: + /* don't simplify the operator if it's a lambda because we + simplify that as a special case below, with the appropriate + substs list */ + app = sexp_list1(ctx, sexp_lambdap(sexp_car(res)) ? sexp_car(res) + : (tmp=simplify(ctx, sexp_car(res), substs, lambda))); + for (ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) + sexp_push(ctx, app, tmp=simplify(ctx, sexp_car(ls1), substs, lambda)); + app = sexp_nreverse(ctx, app); + /* app now holds a copy of the list, and is the default result + (res = app below) if we don't replace it with a simplification */ + if (sexp_opcodep(sexp_car(app))) { + /* opcode app - right now we just constant fold arithmetic */ + if (sexp_opcode_class(sexp_car(app)) == SEXP_OPC_ARITHMETIC) { + for (check=1, ls1=sexp_cdr(app); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) { + if (sexp_pointerp(sexp_car(ls1)) && ! sexp_litp(sexp_car(ls1))) { + check = 0; + break; + } + } + if (check) { + ctx2 = sexp_make_eval_context(ctx, NULL, sexp_context_env(ctx), 0); + generate(ctx2, app); + res = finalize_bytecode(ctx2); + if (! sexp_exceptionp(res)) { + tmp = sexp_make_vector(ctx2, 0, SEXP_VOID); + tmp = sexp_make_procedure(ctx2, SEXP_ZERO, SEXP_ZERO, res, tmp); + if (! sexp_exceptionp(tmp)) { + tmp = sexp_apply(ctx2, tmp, SEXP_NULL); + if (! sexp_exceptionp(tmp)) + app = sexp_make_lit(ctx2, tmp); + } + } + } + } + } else if (lambda && sexp_lambdap(sexp_car(app))) { /* let */ + p1 = NULL; + p2 = sexp_lambda_params(sexp_car(app)); + ls1 = app; + ls2 = sexp_cdr(app); + sv = sexp_lambda_sv(sexp_car(app)); + for ( ; sexp_pairp(ls2); ls2=sexp_cdr(ls2), p2=sexp_cdr(p2)) { + if (sexp_not(sexp_memq(ctx, sexp_car(p2), sv)) + && (! sexp_pointerp(sexp_car(ls2)) || sexp_litp(sexp_car(ls2)) + || (sexp_refp(sexp_car(ls2)) + && sexp_lambdap(sexp_ref_loc(sexp_car(ls2))) + && sexp_not(sexp_memq(ctx, sexp_ref_name(sexp_car(ls2)), + sexp_lambda_sv(sexp_ref_loc(sexp_car(ls2)))))))) { + tmp = sexp_cons(ctx, sexp_car(app), sexp_car(ls2)); + tmp = sexp_cons(ctx, sexp_car(p2), tmp); + sexp_push(ctx, substs, tmp); + sexp_cdr(ls1) = sexp_cdr(ls2); + if (p1) + sexp_cdr(p1) = sexp_cdr(p2); + else + sexp_lambda_params(sexp_car(app)) = sexp_cdr(p2); + } else { + p1 = p2; + ls1 = ls2; + } + } + sexp_lambda_body(sexp_car(app)) + = simplify(ctx, sexp_lambda_body(sexp_car(app)), substs, sexp_car(app)); + if (sexp_nullp(sexp_cdr(app)) + && sexp_nullp(sexp_lambda_params(sexp_car(app))) + && sexp_nullp(sexp_lambda_defs(sexp_car(app)))) + app = sexp_lambda_body(sexp_car(app)); + } + res = app; + break; + + case SEXP_LAMBDA: + sexp_lambda_body(res) = simplify(ctx, sexp_lambda_body(res), substs, res); + break; + + case SEXP_CND: + tmp = simplify(ctx, sexp_cnd_test(res), substs, lambda); + if (sexp_litp(tmp) || ! sexp_pointerp(tmp)) { + res = sexp_not((sexp_litp(tmp) ? sexp_lit_value(tmp) : tmp)) + ? sexp_cnd_fail(res) : sexp_cnd_pass(res); + goto loop; + } else { + sexp_cnd_test(res) = tmp; + simplify_it(sexp_cnd_pass(res)); + simplify_it(sexp_cnd_fail(res)); + } + break; + + case SEXP_REF: + tmp = sexp_ref_name(res); + for (ls1=substs; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) + if ((sexp_caar(ls1) == tmp) && (sexp_cadar(ls1) == sexp_ref_loc(res))) { + res = sexp_cddar(ls1); + break; + } + break; + + case SEXP_SET: + simplify_it(sexp_set_value(res)); + break; + + case SEXP_SEQ: + app = SEXP_NULL; + for (ls2=sexp_seq_ls(res); sexp_pairp(ls2); ls2=sexp_cdr(ls2)) { + tmp = simplify(ctx, sexp_car(ls2), substs, lambda); + if (! (sexp_pairp(sexp_cdr(ls2)) + && (sexp_litp(tmp) || ! sexp_pointerp(tmp) || sexp_refp(tmp) + || sexp_lambdap(tmp)))) + sexp_push(ctx, app, tmp); + } + if (sexp_pairp(app) && sexp_nullp(sexp_cdr(app))) + res = sexp_car(app); + else + sexp_seq_ls(res) = sexp_nreverse(ctx, app); + break; + + } + + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_simplify (sexp ctx sexp_api_params(self, n), sexp ast) { + return simplify(ctx, ast, SEXP_NULL, NULL); +} + diff --git a/sexp.c b/sexp.c new file mode 100644 index 00000000..db4c91fe --- /dev/null +++ b/sexp.c @@ -0,0 +1,1842 @@ +/* sexp.c -- standalone sexp library implementation */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/sexp.h" + +/* optional huffman-compressed immediate symbols */ +struct sexp_huff_entry { + unsigned char len; + unsigned short bits; +}; + +#if SEXP_USE_HUFF_SYMS +#include "opt/sexp-hufftabs.c" +static struct sexp_huff_entry huff_table[] = { +#include "opt/sexp-huff.c" +}; +#endif + +static int sexp_initialized_p = 0; + +sexp sexp_read_float_tail(sexp ctx, sexp in, double whole, int negp); + +static const char sexp_separators[] = { + /* 1 2 3 4 5 6 7 8 9 a b c d e f */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 0, 0, /* x0_ */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x1_ */ + 1, 0, 1, 0, 0, 0, 0, 1, 1, 1, 0, 0, 1, 0, 0, 0, /* x2_ */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, /* x3_ */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x4_ */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, /* x5_ */ +}; + +static int digit_value (int c) { + return (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10)); +} + +static int hex_digit (int n) { + return ((n<=9) ? ('0' + n) : ('A' + n - 10)); +} + +static int is_separator(int c) { + return 0= SEXP_MAXIMUM_TYPES) { + res = sexp_user_exception(ctx, self, "register-type: exceeded maximum type limit", name); + } else if (! sexp_stringp(name)) { + res = sexp_type_exception(ctx, self, SEXP_STRING, name); + } else { + if (num_types >= type_array_size) { + len = type_array_size*2; + if (len > SEXP_MAXIMUM_TYPES) len = SEXP_MAXIMUM_TYPES; +#if SEXP_USE_GLOBAL_TYPES + new = malloc(len * sizeof(_sexp_type_specs[0])); + for (i=0; i num_types) free(tmp); + sexp_type_array_size = len; +#else + res = sexp_make_vector(ctx, sexp_make_fixnum(len), SEXP_VOID); + v1 = sexp_vector_data(res); + v2 = sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)); + for (i=0; ivalue), &(_sexp_type_specs[i]), sizeof(_sexp_type_specs[0])); + vec[i] = type; + } +#endif +} + +#if ! SEXP_USE_GLOBAL_HEAP +sexp sexp_bootstrap_context (sexp_uint_t size) { + sexp dummy_ctx, ctx; + sexp_heap heap; + if (size < SEXP_MINIMUM_HEAP_SIZE) size = SEXP_INITIAL_HEAP_SIZE; + heap = sexp_make_heap(sexp_heap_align(size)); + dummy_ctx = (sexp) malloc(sexp_sizeof(context)); + sexp_pointer_tag(dummy_ctx) = SEXP_CONTEXT; + sexp_context_saves(dummy_ctx) = NULL; + sexp_context_heap(dummy_ctx) = heap; + ctx = sexp_alloc_type(dummy_ctx, context, SEXP_CONTEXT); + sexp_context_heap(dummy_ctx) = NULL; + sexp_context_heap(ctx) = heap; + free(dummy_ctx); + return ctx; +} +#endif + +sexp sexp_make_context (sexp ctx, size_t size) { + sexp_gc_var1(res); + if (ctx) sexp_gc_preserve1(ctx, res); +#if ! SEXP_USE_GLOBAL_HEAP + if (! ctx) res = sexp_bootstrap_context(size); + else +#endif + { + res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); +#if ! SEXP_USE_BOEHM && ! SEXP_USE_MALLOC + sexp_context_heap(res) = sexp_context_heap(ctx); +#endif + } + sexp_context_parent(res) = ctx; + sexp_context_lambda(res) = SEXP_FALSE; + sexp_context_name(res) = sexp_context_specific(res) = SEXP_FALSE; + sexp_context_fv(res) = SEXP_NULL; + sexp_context_saves(res) = NULL; + sexp_context_depth(res)=sexp_context_tracep(res)=sexp_context_pos(res)=0; + sexp_context_tailp(res) = 1; +#if SEXP_USE_GREEN_THREADS + sexp_context_refuel(res) = SEXP_DEFAULT_QUANTUM; +#endif + if (ctx) { + sexp_context_globals(res) = sexp_context_globals(ctx); + sexp_gc_release1(ctx); + } else { + sexp_init_context_globals(res); + } + return res; +} + +#if ! SEXP_USE_GLOBAL_HEAP +void sexp_destroy_context (sexp ctx) { + sexp_heap heap, tmp; + size_t sum_freed; + if (sexp_context_heap(ctx)) { + heap = sexp_context_heap(ctx); + sexp_sweep(ctx, &sum_freed); /* sweep w/o mark to run finalizers */ + sexp_context_heap(ctx) = NULL; + for ( ; heap; heap=tmp) { + tmp = heap->next; +#if SEXP_USE_MMAP_GC + munmap(heap, sexp_heap_pad_size(heap->size)); +#else + free(heap); +#endif + } + } +} +#endif + +/***************************** exceptions *****************************/ + +sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, + sexp procedure, sexp source) { + sexp exn = sexp_alloc_type(ctx, exception, SEXP_EXCEPTION); + sexp_exception_kind(exn) = kind; + sexp_exception_message(exn) = message; + sexp_exception_irritants(exn) = irritants; + sexp_exception_procedure(exn) = procedure; + sexp_exception_source(exn) = source; + return exn; +} + +sexp sexp_string_cat3 (sexp ctx, char *pre, char *mid, char* suf) { + int plen=strlen(pre), mlen=strlen(mid), slen=strlen(suf); + char *s; + sexp str; + str = sexp_make_string(ctx, sexp_make_fixnum(plen+mlen+slen), SEXP_VOID); + memcpy(s=sexp_string_data(str), pre, plen); + memcpy(s+plen, mid, mlen); + memcpy(s+plen+mlen, suf, slen); + return str; +} + +sexp sexp_user_exception (sexp ctx, sexp self, const char *ms, sexp ir) { + sexp res; + sexp_gc_var3(sym, str, irr); + sexp_gc_preserve3(ctx, sym, str, irr); + res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "user", -1), + str = sexp_c_string(ctx, ms, -1), + ((sexp_pairp(ir) || sexp_nullp(ir)) + ? ir : (irr = sexp_list1(ctx, ir))), + self, SEXP_FALSE); + sexp_gc_release3(ctx); + return res; +} + +static sexp type_exception (sexp ctx, sexp self, sexp str, sexp obj, sexp src) { + sexp_gc_var2(res, sym); + sexp_gc_preserve2(ctx, res, sym); + sym = sexp_intern(ctx, "type", -1); + res = sexp_make_exception(ctx, sym, str, obj, self, src); + sexp_exception_irritants(res)=sexp_list1(ctx, sexp_exception_irritants(res)); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp obj) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_c_string(ctx, msg, -1); + res = type_exception(ctx, self, res, obj, SEXP_FALSE); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp obj) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_string_cat3(ctx, "invalid type, expected ", + sexp_type_name_by_index(ctx, type_id), ""); + res = type_exception(ctx, self, res, obj, SEXP_FALSE); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) { + sexp_gc_var2(res, msg); + sexp_gc_preserve2(ctx, res, msg); + msg = sexp_c_string(ctx, "bad index range", -1); + res = sexp_list2(ctx, start, end); + res = sexp_cons(ctx, obj, res); + res = sexp_make_exception(ctx, sexp_intern(ctx, "range", -1), msg, res, + SEXP_FALSE, SEXP_FALSE); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp out) { + sexp ls; + if (! sexp_oportp(out)) + out = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_write_string(ctx, "ERROR", out); + if (sexp_exceptionp(exn)) { + if (sexp_exception_procedure(exn)) { + if (sexp_procedurep(sexp_exception_procedure(exn))) { + ls = sexp_bytecode_name( + sexp_procedure_code(sexp_exception_procedure(exn))); + if (ls && sexp_symbolp(ls)) { + sexp_write_string(ctx, " in ", out); + sexp_write(ctx, ls, out); + } + } else if (sexp_opcodep(sexp_exception_procedure(exn))) { + sexp_write_string(ctx, " in ", out); + sexp_write_string(ctx, sexp_opcode_name(sexp_exception_procedure(exn)), out); + } + } + ls = sexp_exception_source(exn); + if ((! (ls && sexp_pairp(ls))) + && sexp_exception_procedure(exn) + && sexp_procedurep(sexp_exception_procedure(exn))) + ls = sexp_bytecode_source(sexp_procedure_code(sexp_exception_procedure(exn))); + if (ls && sexp_pairp(ls)) { + if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) { + sexp_write_string(ctx, " on line ", out); + sexp_write(ctx, sexp_cdr(ls), out); + } + if (sexp_stringp(sexp_car(ls))) { + sexp_write_string(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_car(ls)), out); + } + } + sexp_write_string(ctx, ": ", out); + if (sexp_stringp(sexp_exception_message(exn))) + sexp_write_string(ctx, sexp_string_data(sexp_exception_message(exn)), out); + else + sexp_write(ctx, sexp_exception_message(exn), out); + if (sexp_exception_irritants(exn) + && sexp_pairp(sexp_exception_irritants(exn))) { + if (sexp_nullp(sexp_cdr(sexp_exception_irritants(exn)))) { + sexp_write_string(ctx, ": ", out); + sexp_write(ctx, sexp_car(sexp_exception_irritants(exn)), out); + sexp_write_string(ctx, "\n", out); + } else { + sexp_write_string(ctx, "\n", out); + for (ls=sexp_exception_irritants(exn); + sexp_pairp(ls); ls=sexp_cdr(ls)) { + sexp_write_string(ctx, " ", out); + sexp_write(ctx, sexp_car(ls), out); + sexp_write_char(ctx, '\n', out); + } + } + } else { + sexp_write_char(ctx, '\n', out); + } + } else { + sexp_write_string(ctx, ": ", out); + if (sexp_stringp(exn)) + sexp_write_string(ctx, sexp_string_data(exn), out); + else + sexp_write(ctx, exn, out); + sexp_write_char(ctx, '\n', out); + } + return SEXP_VOID; +} + +static sexp sexp_read_error (sexp ctx, const char *msg, sexp ir, sexp port) { + sexp res; + sexp_gc_var4(sym, name, str, irr); + sexp_gc_preserve4(ctx, sym, name, str, irr); + name = (sexp_port_name(port) ? sexp_port_name(port) : SEXP_FALSE); + name = sexp_cons(ctx, name, sexp_make_fixnum(sexp_port_line(port))); + str = sexp_c_string(ctx, msg, -1); + irr = ((sexp_pairp(ir) || sexp_nullp(ir)) ? ir : sexp_list1(ctx, ir)); + res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "read", -1), + str, irr, SEXP_FALSE, name); + sexp_gc_release4(ctx); + return res; +} + +/*************************** list utilities ***************************/ + +sexp sexp_cons_op (sexp ctx sexp_api_params(self, n), sexp head, sexp tail) { + sexp pair = sexp_alloc_type(ctx, pair, SEXP_PAIR); + if (sexp_exceptionp(pair)) return pair; + sexp_car(pair) = head; + sexp_cdr(pair) = tail; + sexp_pair_source(pair) = SEXP_FALSE; + return pair; +} + +sexp sexp_list2 (sexp ctx, sexp a, sexp b) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_cons(ctx, b, SEXP_NULL); + res = sexp_cons(ctx, a, res); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_listp_op (sexp ctx sexp_api_params(self, n), sexp hare) { + sexp turtle; + if (! sexp_pairp(hare)) + return sexp_make_boolean(sexp_nullp(hare)); + turtle = hare; + hare = sexp_cdr(hare); + for ( ; sexp_pairp(hare); turtle=sexp_cdr(turtle)) { + if (hare == turtle) return SEXP_FALSE; + hare = sexp_cdr(hare); + if (sexp_pairp(hare)) hare = sexp_cdr(hare); + } + return sexp_make_boolean(sexp_nullp(hare)); +} + +sexp sexp_memq_op (sexp ctx sexp_api_params(self, n), sexp x, sexp ls) { + while (sexp_pairp(ls)) + if (x == sexp_car(ls)) + return ls; + else + ls = sexp_cdr(ls); + return SEXP_FALSE; +} + +sexp sexp_assq_op (sexp ctx sexp_api_params(self, n), sexp x, sexp ls) { + while (sexp_pairp(ls)) + if (sexp_pairp(sexp_car(ls)) && (x == sexp_caar(ls))) + return sexp_car(ls); + else + ls = sexp_cdr(ls); + return SEXP_FALSE; +} + +sexp sexp_reverse_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + res = sexp_cons(ctx, sexp_car(ls), res); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_nreverse_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp a, b, tmp; + if (ls == SEXP_NULL) return ls; + sexp_assert_type(ctx, sexp_pairp, SEXP_PAIR, ls); + b = ls; + a = sexp_cdr(ls); + sexp_cdr(b) = SEXP_NULL; + for ( ; sexp_pairp(a); b=a, a=tmp) { + tmp = sexp_cdr(a); + sexp_cdr(a) = b; + } + return b; +} + +sexp sexp_copy_list_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp tmp; + sexp_gc_var1(res); + if (! sexp_pairp(ls)) return ls; + sexp_gc_preserve1(ctx, res); + tmp = res = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls)); + for (ls=sexp_cdr(ls); sexp_pairp(ls); ls=sexp_cdr(ls), tmp=sexp_cdr(tmp)) + sexp_cdr(tmp) = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls)); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_append2_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { + sexp_gc_var2(a1, b1); + sexp_gc_preserve2(ctx, a1, b1); + b1 = b; + for (a1=sexp_reverse(ctx, a); sexp_pairp(a1); a1=sexp_cdr(a1)) + b1 = sexp_cons(ctx, sexp_car(a1), b1); + sexp_gc_release2(ctx); + return b1; +} + +sexp sexp_length_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp_uint_t res=0; + for ( ; sexp_pairp(ls); res++, ls=sexp_cdr(ls)) + ; + return sexp_make_fixnum(res); +} + +sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { + sexp_uint_t size; + sexp_sint_t i, len; + sexp t, *p, *q; + char *p0, *q0; + + loop: + if (a == b) + return SEXP_TRUE; + else if ((! sexp_pointerp(a)) || (! sexp_pointerp(b)) + || (sexp_pointer_tag(a) != sexp_pointer_tag(b))) + return SEXP_FALSE; + + /* a and b are both pointers of the same type */ +#if SEXP_USE_BIGNUMS + if (sexp_pointer_tag(a) == SEXP_BIGNUM) + return sexp_make_boolean(!sexp_bignum_compare(a, b)); +#endif +#if SEXP_USE_FLONUMS && ! SEXP_USE_IMMEDIATE_FLONUMS + if (sexp_pointer_tag(a) == SEXP_FLONUM) + return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b)); +#endif + t = sexp_object_type(ctx, a); + p0 = ((char*)a) + offsetof(struct sexp_struct, value); + p = (sexp*) (((char*)a) + sexp_type_field_base(t)); + q0 = ((char*)b) + offsetof(struct sexp_struct, value); + q = (sexp*) (((char*)b) + sexp_type_field_base(t)); + if ((sexp)p == a) {p=(sexp*)p0; q=(sexp*)q0;} + /* check preliminary non-object data */ + if ((p0 < (char*)p) && memcmp(p0, q0, ((char*)p - p0))) + return SEXP_FALSE; + /* check trailing non-object data */ + size = sexp_type_size_of_object(t, a) - offsetof(struct sexp_struct, value); + p0 = ((char*)p + sexp_type_num_slots_of_object(t,a)*sizeof(sexp)); + if (((char*)a + size) > p0) { + q0 = ((char*)q + sexp_type_num_slots_of_object(t,b)*sizeof(sexp)); + if (size != sexp_type_size_of_object(t,b)-offsetof(struct sexp_struct,value)) + return SEXP_FALSE; + if (memcmp(p0, q0, size)) + return SEXP_FALSE; + } + /* check eq-object slots */ + len = sexp_type_num_eq_slots_of_object(t, a); + if (len > 0) { + for (i=0; i> 32; + return r.flonum; +} +sexp sexp_make_flonum (sexp ctx, float f) { + union sexp_flonum_conv x; + x.flonum = f; + return (sexp)(((sexp_uint_t)(x.bits) << 32) + SEXP_IFLONUM_TAG); +} +#endif +#endif + +sexp sexp_make_bytes_op (sexp ctx sexp_api_params(self, n), sexp len, sexp i) { + sexp_sint_t clen = sexp_unbox_fixnum(len); + sexp s; + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, len); + if (clen < 0) return sexp_xtype_exception(ctx, self, "negative length", len); + s = sexp_alloc_atomic(ctx, sexp_sizeof(bytes)+clen+1); + if (sexp_exceptionp(s)) return s; + sexp_pointer_tag(s) = SEXP_BYTES; +#if SEXP_USE_HEADER_MAGIC + sexp_pointer_magic(s) = SEXP_POINTER_MAGIC; +#endif + sexp_bytes_length(s) = clen; + if (sexp_fixnump(i)) + memset(sexp_bytes_data(s), sexp_unbox_fixnum(i), clen); + sexp_bytes_data(s)[clen] = '\0'; + return s; +} + +sexp sexp_make_string_op (sexp ctx sexp_api_params(self, n), sexp len, sexp ch) +{ + sexp i = (sexp_charp(ch) ? sexp_make_fixnum(sexp_unbox_character(ch)) : ch); + sexp_gc_var2(b, s); + b = sexp_make_bytes_op(ctx sexp_api_pass(self, n), len, i); + if (sexp_exceptionp(b)) return b; +#if SEXP_USE_PACKED_STRINGS + sexp_pointer_tag(b) = SEXP_STRING; + return b; +#else + sexp_gc_preserve2(ctx, b, s); + s = sexp_alloc_type(ctx, string, SEXP_STRING); + sexp_string_bytes(s) = b; + sexp_string_offset(s) = 0; + sexp_string_length(s) = sexp_unbox_fixnum(len); + sexp_gc_release2(ctx); + return s; +#endif +} + +sexp sexp_c_string (sexp ctx, const char *str, sexp_sint_t slen) { + sexp_sint_t len = ((slen >= 0) ? slen : strlen(str)); + sexp s = sexp_make_string(ctx, sexp_make_fixnum(len), SEXP_VOID); + memcpy(sexp_string_data(s), str, len); + sexp_string_data(s)[len] = '\0'; + return s; +} + +sexp sexp_substring_op (sexp ctx sexp_api_params(self, n), sexp str, sexp start, sexp end) { + sexp res; + 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)); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, end); + if ((sexp_unbox_fixnum(start) < 0) + || (sexp_unbox_fixnum(start) > sexp_string_length(str)) + || (sexp_unbox_fixnum(end) < 0) + || (sexp_unbox_fixnum(end) > sexp_string_length(str)) + || (end < start)) + return sexp_range_exception(ctx, str, start, end); + res = sexp_make_string(ctx, sexp_fx_sub(end, start), SEXP_VOID); + memcpy(sexp_string_data(res), + sexp_string_data(str)+sexp_unbox_fixnum(start), + sexp_string_length(res)); + sexp_string_data(res)[sexp_string_length(res)] = '\0'; + return res; +} + +sexp sexp_string_concatenate_op (sexp ctx sexp_api_params(self, n), sexp str_ls, sexp sep) { + sexp res, ls; + sexp_uint_t len=0, i=0, sep_len=0; + char *p, *csep; + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls), i++) + if (! sexp_stringp(sexp_car(ls))) + return sexp_type_exception(ctx, self, SEXP_STRING, sexp_car(ls)); + else + len += sexp_string_length(sexp_car(ls)); + if (sexp_stringp(sep) && ((sep_len=sexp_string_length(sep)) > 0)) { + csep = sexp_string_data(sep); + len += sep_len*(i-1); + } + res = sexp_make_string(ctx, sexp_make_fixnum(len), SEXP_VOID); + p = sexp_string_data(res); + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) { + len = sexp_string_length(sexp_car(ls)); + memcpy(p, sexp_string_data(sexp_car(ls)), len); + p += len; + if (sep_len && sexp_pairp(sexp_cdr(ls))) { + memcpy(p, csep, sep_len); + p += sep_len; + } + } + *p = '\0'; + return res; +} + +#define FNV_PRIME 16777619 +#define FNV_OFFSET_BASIS 2166136261uL + +#if SEXP_USE_HASH_SYMS + +static sexp_uint_t sexp_string_hash(const char *str, sexp_sint_t len, + sexp_uint_t acc) { + for ( ; len; len--) {acc *= FNV_PRIME; acc ^= *str++;} + return acc; +} + +#endif + +sexp sexp_intern(sexp ctx, const char *str, sexp_sint_t len) { +#if SEXP_USE_HUFF_SYMS + struct sexp_huff_entry he; + sexp_uint_t space=3, newbits; + char c; +#endif + sexp_uint_t res=FNV_OFFSET_BASIS, bucket, i=0; + const char *p=str; + sexp ls, tmp; + sexp_gc_var1(sym); + + if (len < 0) len = strlen(str); + +#if SEXP_USE_HUFF_SYMS + res = 0; + for ( ; i 127) + goto normal_intern; + he = huff_table[(unsigned char)c]; + newbits = he.len; + if ((space+newbits) > (sizeof(sexp)*8)) + goto normal_intern; + res |= (((sexp_uint_t) he.bits) << space); + space += newbits; + } + return (sexp) (res + SEXP_ISYMBOL_TAG); + + normal_intern: +#endif +#if SEXP_USE_HASH_SYMS + bucket = (sexp_string_hash(p, len-i, res) % SEXP_SYMBOL_TABLE_SIZE); +#else + bucket = 0; +#endif + for (ls=sexp_context_symbols(ctx)[bucket]; sexp_pairp(ls); ls=sexp_cdr(ls)) + if ((sexp_symbol_length(tmp=sexp_car(ls)) == len) + && ! strncmp(str, sexp_symbol_data(tmp), len)) + return sexp_car(ls); + + /* not found, make a new symbol */ + sexp_gc_preserve1(ctx, sym); + sym = sexp_c_string(ctx, str, len); + if (sexp_exceptionp(sym)) return sym; +#if ! SEXP_USE_PACKED_STRINGS + sym = sexp_string_bytes(sym); +#endif + sexp_pointer_tag(sym) = SEXP_SYMBOL; + sexp_push(ctx, sexp_context_symbols(ctx)[bucket], sym); + sexp_gc_release1(ctx); + return sym; +} + +sexp sexp_string_to_symbol_op (sexp ctx sexp_api_params(self, n), sexp str) { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + return sexp_intern(ctx, sexp_string_data(str), sexp_string_length(str)); +} + +sexp sexp_make_vector_op (sexp ctx sexp_api_params(self, n), sexp len, sexp dflt) { + sexp vec, *x; + int i, clen = sexp_unbox_fixnum(len); + if (! clen) return sexp_global(ctx, SEXP_G_EMPTY_VECTOR); + vec = sexp_alloc_tagged(ctx, sexp_sizeof(vector) + clen*sizeof(sexp), + SEXP_VECTOR); + if (sexp_exceptionp(vec)) return vec; + x = sexp_vector_data(vec); + for (i=0; i= len) return 0; + if (n > (len - pos)) n = (len - pos); + memcpy(dst, sexp_string_data(sexp_stream_buf(vec))+pos, n); + sexp_stream_pos(vec) = sexp_make_fixnum(n); + return n; +} + +int sstream_write (void *vec, const char *src, int n) { + sexp_uint_t len, pos, newpos; + sexp newbuf; + len = sexp_unbox_fixnum(sexp_stream_size(vec)); + pos = sexp_unbox_fixnum(sexp_stream_pos(vec)); + newpos = pos+n; + if (newpos >= len) { + newbuf = sexp_make_string(sexp_stream_ctx(vec), + sexp_make_fixnum(newpos*2), + SEXP_VOID); + memcpy(sexp_string_data(newbuf), + sexp_string_data(sexp_stream_buf(vec)), + pos); + sexp_stream_buf(vec) = newbuf; + sexp_stream_size(vec) = sexp_make_fixnum(newpos*2); + } + memcpy(sexp_string_data(sexp_stream_buf(vec))+pos, src, n); + sexp_stream_pos(vec) = sexp_make_fixnum(newpos); + return n; +} + +off_t sstream_seek (void *vec, off_t offset, int whence) { + sexp_sint_t pos; + if (whence == SEEK_SET) { + pos = offset; + } else if (whence == SEEK_CUR) { + pos = sexp_unbox_fixnum(sexp_stream_pos(vec)) + offset; + } else { /* SEEK_END */ + pos = sexp_unbox_fixnum(sexp_stream_size(vec)) + offset; + } + sexp_stream_pos(vec) = sexp_make_fixnum(pos); + return pos; +} + +sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { + FILE *in; + sexp res; + sexp_gc_var1(cookie); + sexp_gc_preserve1(ctx, cookie); + cookie = sexp_make_vector(ctx, sexp_make_fixnum(4), SEXP_VOID); + sexp_stream_ctx(cookie) = ctx; + sexp_stream_buf(cookie) = str; + sexp_stream_size(cookie) = sexp_make_fixnum(sexp_string_length(str)); + sexp_stream_pos(cookie) = SEXP_ZERO; + in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL); + res = sexp_make_input_port(ctx, in, SEXP_FALSE); + sexp_port_cookie(res) = cookie; + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) { + FILE *out; + sexp res, size; + sexp_gc_var1(cookie); + sexp_gc_preserve1(ctx, cookie); + size = sexp_make_fixnum(SEXP_INIT_STRING_PORT_SIZE); + cookie = sexp_make_vector(ctx, sexp_make_fixnum(4), SEXP_VOID); + sexp_stream_ctx(cookie) = ctx; + sexp_stream_buf(cookie) = sexp_make_string(ctx, size, SEXP_VOID); + sexp_stream_size(cookie) = size; + sexp_stream_pos(cookie) = SEXP_ZERO; + out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL); + res = sexp_make_output_port(ctx, out, SEXP_FALSE); + sexp_port_cookie(res) = cookie; + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port) { + sexp cookie = sexp_port_cookie(port); + fflush(sexp_port_stream(port)); + return sexp_substring(ctx, + sexp_stream_buf(cookie), + SEXP_ZERO, + sexp_stream_pos(cookie)); +} + +#else + +sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { + FILE *in; + sexp res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + if (sexp_string_length(str) == 0) + in = fopen("/dev/null", "r"); + else + in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r"); + if (in) { + res = sexp_make_input_port(ctx, in, SEXP_FALSE); + if (sexp_string_length(str) == 0) + sexp_port_name(res) = sexp_c_string(ctx, "/dev/null", -1); + sexp_port_cookie(res) = str; /* for gc preservation */ + } else { + res = sexp_user_exception(ctx, SEXP_FALSE, "couldn't open string", str); + } + return res; +} + +sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) { + sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE); + sexp_port_stream(res) + = open_memstream(&sexp_port_buf(res), &sexp_port_size(res)); + return res; +} + +sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port) { + fflush(sexp_port_stream(port)); + return sexp_c_string(ctx, sexp_port_buf(port), sexp_port_size(port)); +} + +#endif + +#else + +#define SEXP_PORT_BUFFER_SIZE 4096 + +int sexp_buffered_read_char (sexp ctx, sexp p) { + if (sexp_port_offset(p) < sexp_port_size(p)) { + return sexp_port_buf(p)[sexp_port_offset(p)++]; + } else if (! sexp_port_stream(p)) { + return EOF; + } else { + sexp_port_size(p) + = fread(sexp_port_buf(p), 1, SEXP_PORT_BUFFER_SIZE, sexp_port_stream(p)); + sexp_port_offset(p) = 0; + return ((sexp_port_offset(p) < sexp_port_size(p)) + ? sexp_port_buf(p)[sexp_port_offset(p)++] : EOF); + } +} + +sexp sexp_buffered_write_char (sexp ctx, int c, sexp p) { + if (sexp_port_offset(p) >= sexp_port_size(p)) + sexp_buffered_flush(ctx, p); + sexp_port_buf(p)[sexp_port_offset(p)++] = c; + return SEXP_VOID; +} + +sexp sexp_buffered_write_string_n (sexp ctx, const char *str, + sexp_uint_t len, sexp p) { + if (sexp_port_offset(p) >= sexp_port_size(p)) + sexp_buffered_flush(ctx, p); + memcpy(sexp_port_buf(p)+sexp_port_offset(p), str, len); + sexp_port_offset(p) += len; + return SEXP_VOID; +} + +sexp sexp_buffered_write_string (sexp ctx, const char *str, sexp p) { + return sexp_buffered_write_string_n(ctx, str, strlen(str), p); +} + +sexp sexp_buffered_flush (sexp ctx, sexp p) { + sexp_gc_var1(tmp); + if (! sexp_oportp(p)) + return sexp_type_exception(ctx, NULL, SEXP_OPORT, p); + if (! sexp_port_openp(p)) + return sexp_user_exception(ctx, SEXP_FALSE, "port is closed", p); + else { + if (sexp_port_stream(p)) { + fwrite(sexp_port_buf(p), 1, sexp_port_offset(p), sexp_port_stream(p)); + fflush(sexp_port_stream(p)); + } else if (sexp_port_offset(p) > 0) { + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p)); + sexp_push(ctx, sexp_port_cookie(p), tmp); + sexp_gc_release1(ctx); + } + sexp_port_offset(p) = 0; + return SEXP_VOID; + } +} + +sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { + sexp res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + res = sexp_make_input_port(ctx, NULL, SEXP_FALSE); + if (sexp_exceptionp(res)) return res; + sexp_port_cookie(res) = str; + sexp_port_buf(res) = sexp_string_data(str); + sexp_port_offset(res) = 0; + sexp_port_size(res) = sexp_string_length(str); + return res; +} + +sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) { + sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE); + if (sexp_exceptionp(res)) return res; + sexp_port_buf(res) = (char*) malloc(SEXP_PORT_BUFFER_SIZE); + sexp_port_size(res) = SEXP_PORT_BUFFER_SIZE; + sexp_port_offset(res) = 0; + sexp_port_cookie(res) = SEXP_NULL; + return res; +} + +sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp out) { + sexp res; + sexp_gc_var2(ls, tmp); + sexp_gc_preserve2(ctx, ls, tmp); + if (sexp_port_offset(out) > 0) { + tmp = sexp_c_string(ctx, sexp_port_buf(out), sexp_port_offset(out)); + ls = sexp_cons(ctx, tmp, sexp_port_cookie(out)); + } else { + ls = sexp_port_cookie(out); + } + res = sexp_string_concatenate(ctx, ls, SEXP_FALSE); + sexp_gc_release2(ctx); + return res; +} + +#endif + +sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { + sexp p = sexp_alloc_type(ctx, port, SEXP_IPORT); + if (sexp_exceptionp(p)) return p; + sexp_port_stream(p) = in; + sexp_port_name(p) = name; + sexp_port_line(p) = 1; + sexp_port_buf(p) = NULL; + sexp_port_openp(p) = 1; + sexp_port_no_closep(p) = 0; + sexp_port_sourcep(p) = 0; + sexp_port_cookie(p) = SEXP_VOID; + return p; +} + +sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) { + sexp p = sexp_make_input_port(ctx, out, name); + if (sexp_exceptionp(p)) return p; + sexp_pointer_tag(p) = SEXP_OPORT; + return p; +} + +#define NUMBUF_LEN 32 + +sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { +#if SEXP_USE_HUFF_SYMS + unsigned long res, c; +#endif + unsigned long len; + long i=0; + double f; + sexp x, *elts; + char *str=NULL, numbuf[NUMBUF_LEN]; + + if (! obj) { + sexp_write_string(ctx, "#", out); /* shouldn't happen */ + } else if (sexp_pointerp(obj)) { + switch (sexp_pointer_tag(obj)) { + case SEXP_PAIR: + sexp_write_char(ctx, '(', out); + sexp_write_one(ctx, sexp_car(obj), out); + for (x=sexp_cdr(obj); sexp_pairp(x); x=sexp_cdr(x)) { + sexp_write_char(ctx, ' ', out); + sexp_write_one(ctx, sexp_car(x), out); + } + if (! sexp_nullp(x)) { + sexp_write_string(ctx, " . ", out); + sexp_write_one(ctx, x, out); + } + sexp_write_char(ctx, ')', out); + break; + case SEXP_VECTOR: + len = sexp_vector_length(obj); + elts = sexp_vector_data(obj); + if (len == 0) { + sexp_write_string(ctx, "#()", out); + } else { + sexp_write_string(ctx, "#(", out); + sexp_write_one(ctx, elts[0], out); + for (i=1; i", out); + break; + case SEXP_SYNCLO: + sexp_write_string(ctx, "#", out); + break; + case SEXP_TYPE: + sexp_write_string(ctx, "#", out); + break; + case SEXP_STRING: + sexp_write_char(ctx, '"', out); + i = sexp_string_length(obj); + str = sexp_string_data(obj); + for ( ; i>0; str++, i--) { + switch (str[0]) { + case '\\': sexp_write_string(ctx, "\\\\", out); break; + case '"': sexp_write_string(ctx, "\\\"", out); break; + case '\n': sexp_write_string(ctx, "\\n", out); break; + case '\r': sexp_write_string(ctx, "\\r", out); break; + case '\t': sexp_write_string(ctx, "\\t", out); break; + default: sexp_write_char(ctx, str[0], out); + } + } + sexp_write_char(ctx, '"', out); + break; + case SEXP_SYMBOL: + i = sexp_symbol_length(obj); + str = sexp_symbol_data(obj); + for ( ; i>0; str++, i--) { + if ((str[0] == '\\') || is_separator(str[0])) + sexp_write_char(ctx, '\\', out); + sexp_write_char(ctx, str[0], out); + } + break; +#if SEXP_USE_BIGNUMS + case SEXP_BIGNUM: + sexp_write_bignum(ctx, obj, out, 10); + break; +#endif + case SEXP_OPCODE: + sexp_write_string(ctx, "#', out); + break; + default: + i = sexp_pointer_tag(obj); + sexp_write_string(ctx, "#<", out); + sexp_write_string(ctx, + (i < sexp_context_num_types(ctx)) + ? sexp_type_name_by_index(ctx, i) : "invalid", + out); + sexp_write_char(ctx, '>', out); + break; + } + } else if (sexp_fixnump(obj)) { + snprintf(numbuf, NUMBUF_LEN, "%ld", (long)sexp_unbox_fixnum(obj)); + sexp_write_string(ctx, numbuf, out); +#if SEXP_USE_IMMEDIATE_FLONUMS + } else if (sexp_flonump(obj)) { + f = sexp_flonum_value(obj); +#if SEXP_USE_INFINITIES + if (isinf(f) || isnan(f)) { + numbuf[0] = (isinf(f) && f < 0 ? '-' : '+'); + strcpy(numbuf+1, isinf(f) ? "inf.0" : "nan.0"); + } else +#endif + { + i = snprintf(numbuf, NUMBUF_LEN, "%.8g", f); + if (f == trunc(f) && ! strchr(numbuf, '.')) { + numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0'; + } + } + sexp_write_string(ctx, numbuf, out); +#endif + } else if (sexp_charp(obj)) { + if (obj == sexp_make_character(' ')) + sexp_write_string(ctx, "#\\space", out); + else if (obj == sexp_make_character('\n')) + sexp_write_string(ctx, "#\\newline", out); + else if (obj == sexp_make_character('\r')) + sexp_write_string(ctx, "#\\return", out); + else if (obj == sexp_make_character('\t')) + sexp_write_string(ctx, "#\\tab", out); + else if ((33 <= sexp_unbox_character(obj)) + && (sexp_unbox_character(obj) < 127)) { + sexp_write_string(ctx, "#\\", out); + sexp_write_char(ctx, sexp_unbox_character(obj), out); + } else { + sexp_write_string(ctx, "#\\x", out); + c = sexp_unbox_character(obj); + if (c >= 0x100) { + if (c >= 0x10000) { + sexp_write_char(ctx, hex_digit((c>>20)&0x0F), out); + sexp_write_char(ctx, hex_digit((c>>16)&0x0F), out); + } + sexp_write_char(ctx, hex_digit((c>>12)&0x0F), out); + sexp_write_char(ctx, hex_digit((c>>8)&0x0F), out); + } + sexp_write_char(ctx, hex_digit((c>>4)&0x0F), out); + sexp_write_char(ctx, hex_digit(c&0x0F), out); + } + } else if (sexp_symbolp(obj)) { + +#if SEXP_USE_HUFF_SYMS + if (sexp_isymbolp(obj)) { + c = ((sexp_uint_t)obj)>>3; + while (c) { +#include "opt/sexp-unhuff.c" + sexp_write_char(ctx, res, out); + } + } +#endif + + } else { + switch ((sexp_uint_t) obj) { + case (sexp_uint_t) SEXP_NULL: + sexp_write_string(ctx, "()", out); break; + case (sexp_uint_t) SEXP_TRUE: + sexp_write_string(ctx, "#t", out); break; + case (sexp_uint_t) SEXP_FALSE: + sexp_write_string(ctx, "#f", out); break; + case (sexp_uint_t) SEXP_EOF: + sexp_write_string(ctx, "#", out); break; + case (sexp_uint_t) SEXP_UNDEF: + case (sexp_uint_t) SEXP_VOID: + sexp_write_string(ctx, "#", out); break; + default: + sexp_write_string(ctx, "#", out); + } + } + return SEXP_VOID; +} + +sexp sexp_write_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) { + sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out); + return sexp_write_one(ctx, obj, out); +} + +sexp sexp_display_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) { + sexp res=SEXP_VOID; + sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out); + if (sexp_stringp(obj)) + sexp_write_string(ctx, sexp_string_data(obj), out); + else if (sexp_charp(obj)) + sexp_write_char(ctx, sexp_unbox_character(obj), out); + else + res = sexp_write_one(ctx, obj, out); + return res; +} + +sexp sexp_flush_output_op (sexp ctx sexp_api_params(self, n), sexp out) { + sexp_flush(ctx, out); + return SEXP_VOID; +} + +#define INIT_STRING_BUFFER_SIZE 128 + +sexp sexp_read_string (sexp ctx, sexp in) { + int c, i=0, size=INIT_STRING_BUFFER_SIZE; + char initbuf[INIT_STRING_BUFFER_SIZE]; + char *buf=initbuf, *tmp; + sexp res; + + for (c = sexp_read_char(ctx, in); c != '"'; c = sexp_read_char(ctx, in)) { + if (c == '\\') { + c = sexp_read_char(ctx, in); + switch (c) { + case 'n': c = '\n'; break; + case 'r': c = '\r'; break; + case 't': c = '\t'; break; + case 'x': + c = sexp_read_char(ctx, in); + if (isxdigit(c)) { + c = digit_value(c)*16 + digit_value(sexp_read_char(ctx, in)); + } else { + sexp_push_char(ctx, c, in); c = 'x'; + } + } + } + if (c == EOF) { + res = sexp_read_error(ctx, "premature end of string", SEXP_NULL, in); + break; + } + buf[i++] = c; + if (i >= size) { /* expand buffer w/ malloc(), later free() it */ + tmp = (char*) malloc(size*2); + memcpy(tmp, buf, i); + if (size != INIT_STRING_BUFFER_SIZE) free(buf); + buf = tmp; + size *= 2; + } + } + + buf[i] = '\0'; + res = sexp_c_string(ctx, buf, i); + if (size != INIT_STRING_BUFFER_SIZE) free(buf); + return res; +} + +sexp sexp_read_symbol (sexp ctx, sexp in, int init, int internp) { + int c, i=0, size=INIT_STRING_BUFFER_SIZE; + char initbuf[INIT_STRING_BUFFER_SIZE]; + char *buf=initbuf, *tmp; + sexp res; + + if (init != EOF) + buf[i++] = init; + + for (c = sexp_read_char(ctx, in); c != '"'; c = sexp_read_char(ctx, in)) { + if (c == '\\') c = sexp_read_char(ctx, in); + if (c == EOF || is_separator(c)) { + sexp_push_char(ctx, c, in); + break; + } + buf[i++] = c; + if (i >= size) { /* expand buffer w/ malloc(), later free() it */ + tmp = (char*) malloc(size*2); + memcpy(tmp, buf, i); + if (size != INIT_STRING_BUFFER_SIZE) free(buf); + buf = tmp; + size *= 2; + } + } + + buf[i] = '\0'; + res = (internp ? sexp_intern(ctx, buf, i) : sexp_c_string(ctx, buf, i)); + if (size != INIT_STRING_BUFFER_SIZE) free(buf); + return res; +} + +sexp sexp_read_float_tail (sexp ctx, sexp in, double whole, int negp) { + sexp exponent=SEXP_VOID; + double res=0.0, scale=0.1, e=0.0; + int c; + for (c=sexp_read_char(ctx, in); + isdigit(c); + c=sexp_read_char(ctx, in), scale*=0.1) + res += digit_value(c)*scale; + if (c=='e' || c=='E') { + exponent = sexp_read_number(ctx, in, 10); + if (sexp_exceptionp(exponent)) return exponent; + e = (sexp_fixnump(exponent) ? sexp_unbox_fixnum(exponent) + : sexp_flonump(exponent) ? sexp_flonum_value(exponent) : 0.0); + } else if ((c!=EOF) && ! is_separator(c)) { + return sexp_read_error(ctx, "invalid numeric syntax", + sexp_make_character(c), in); + } else { + sexp_push_char(ctx, c, in); + } + res = (whole + res) * pow(10, e); + if (negp) res *= -1; + return sexp_make_flonum(ctx, res); +} + +sexp sexp_read_number (sexp ctx, sexp in, int base) { + sexp den; + sexp_uint_t res = 0, tmp; + int c, digit, negativep = 0; + + c = sexp_read_char(ctx, in); + if (c == '-') { + negativep = 1; + c = sexp_read_char(ctx, in); + } + + for ( ; isxdigit(c); c=sexp_read_char(ctx, in)) { + digit = digit_value(c); + if ((digit < 0) || (digit >= base)) + break; + tmp = res * base + digit; +#if SEXP_USE_BIGNUMS + if ((tmp < res) || (tmp > SEXP_MAX_FIXNUM)) { + sexp_push_char(ctx, c, in); + return sexp_read_bignum(ctx, in, res, (negativep ? -1 : 1), base); + } +#endif + res = tmp; + } + + if (c=='.' || c=='e' || c=='E') { + if (base != 10) + return sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in); + if (c!='.') sexp_push_char(ctx, c, in); + return sexp_read_float_tail(ctx, in, res, negativep); + } else if (c=='/') { + den = sexp_read_number(ctx, in, base); + if (! sexp_fixnump(den)) + return (sexp_exceptionp(den) + ? den : sexp_read_error(ctx, "invalid rational syntax", den, in)); + return sexp_make_flonum(ctx, (double)(negativep ? -res : res) + / (double)sexp_unbox_fixnum(den)); + } else { + if ((c!=EOF) && ! is_separator(c)) + return sexp_read_error(ctx, "invalid numeric syntax", + sexp_make_character(c), in); + sexp_push_char(ctx, c, in); + } + + return sexp_make_fixnum(negativep ? -res : res); +} + +sexp sexp_read_raw (sexp ctx, sexp in) { + char *str; + int c1, c2, line; + sexp tmp2; + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, tmp); + + scan_loop: + switch (c1 = sexp_read_char(ctx, in)) { + case EOF: + if (sexp_at_eofp(in)) + res = SEXP_EOF; + else + goto scan_loop; + break; + case ';': + while ((c1 = sexp_read_char(ctx, in)) != EOF) + if (c1 == '\n') + break; + /* ... FALLTHROUGH ... */ + case '\n': + sexp_port_line(in)++; + goto scan_loop; + case ' ': + case '\t': + case '\r': + goto scan_loop; + case '\'': + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUOTE_SYMBOL), res); + break; + case '`': + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL), res); + break; + case ',': + if ((c1 = sexp_read_char(ctx, in)) == '@') { + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL), res); + } else { + sexp_push_char(ctx, c1, in); + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_UNQUOTE_SYMBOL), res); + } + break; + case '"': + res = sexp_read_string(ctx, in); + break; + case '(': + line = (sexp_port_sourcep(in) ? sexp_port_line(in) : -1); + res = SEXP_NULL; + tmp = sexp_read_raw(ctx, in); + while ((tmp != SEXP_EOF) && (tmp != SEXP_CLOSE) && (tmp != SEXP_RAWDOT)) { + if (sexp_exceptionp(tmp)) { + res = tmp; + break; + } + res = sexp_cons(ctx, tmp, res); + if (sexp_port_sourcep(in) && (line >= 0)) + sexp_pair_source(res) + = sexp_cons(ctx, sexp_port_name(in), sexp_make_fixnum(line)); + tmp = sexp_read_raw(ctx, in); + } + if (! sexp_exceptionp(res)) { + if (tmp == SEXP_RAWDOT) { /* dotted list */ + if (res == SEXP_NULL) { + res = sexp_read_error(ctx, "dot before any elements in list", + SEXP_NULL, in); + } else { + tmp = sexp_read_raw(ctx, in); + if (sexp_exceptionp(tmp)) { + res = tmp; + } else if (tmp == SEXP_CLOSE) { + res = sexp_read_error(ctx, "no final element in list after dot", + SEXP_NULL, in); + } else if (sexp_read_raw(ctx, in) != SEXP_CLOSE) { + res = sexp_read_error(ctx, "multiple tokens in dotted tail", + SEXP_NULL, in); + } else { + tmp2 = res; + res = sexp_nreverse(ctx, res); + sexp_cdr(tmp2) = tmp; + } + } + } else if (tmp == SEXP_CLOSE) { + res = (sexp_pairp(res) ? sexp_nreverse(ctx, res) : res); + } else { + res = sexp_read_error(ctx, "missing trailing ')'", SEXP_NULL, in); + } + } + if ((line >= 0) && sexp_pairp(res)) { + sexp_pair_source(res) + = sexp_cons(ctx, sexp_port_name(in), sexp_make_fixnum(line)); + } + if (sexp_port_sourcep(in)) + for (tmp=res; sexp_pairp(tmp); tmp=sexp_cdr(tmp)) + sexp_immutablep(tmp) = 1; + break; + case '#': + switch (c1=sexp_read_char(ctx, in)) { + case 'b': + res = sexp_read_number(ctx, in, 2); break; + case 'o': + res = sexp_read_number(ctx, in, 8); break; + case 'd': + res = sexp_read_number(ctx, in, 10); break; + case 'x': + res = sexp_read_number(ctx, in, 16); break; + case 'e': + res = sexp_read(ctx, in); + if (sexp_flonump(res)) + res = sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(res)); + break; + case 'i': + res = sexp_read(ctx, in); + if (sexp_fixnump(res)) + res = sexp_make_flonum(ctx, sexp_unbox_fixnum(res)); + break; + case 'f': case 'F': + case 't': case 'T': + c2 = sexp_read_char(ctx, in); + if (c2 == EOF || is_separator(c2)) { + res = (tolower(c1) == 't' ? SEXP_TRUE : SEXP_FALSE); + sexp_push_char(ctx, c2, in); + } else { + tmp = sexp_list2(ctx, sexp_make_character(c1), sexp_make_character(c2)); + res = sexp_read_error(ctx, "invalid syntax #%c%c", tmp, in); + } + break; +/* case '0': case '1': case '2': case '3': case '4': */ +/* case '5': case '6': case '7': case '8': case '9': */ + case ';': + tmp = sexp_read_raw(ctx, in); /* discard */ + if (sexp_exceptionp(tmp)) + res = tmp; + else + goto scan_loop; + break; + case '!': + while ((c1 = sexp_read_char(ctx, in)) != EOF) + if (c1 == '\n') + break; + sexp_port_line(in)++; + goto scan_loop; + case '\\': + c1 = sexp_read_char(ctx, in); + res = sexp_read_symbol(ctx, in, c1, 0); + if (sexp_stringp(res)) { + str = sexp_string_data(res); + if (sexp_string_length(res) == 0) + res = + sexp_read_error(ctx, "unexpected end of character literal", + SEXP_NULL, in); + if (sexp_string_length(res) == 1) { + res = sexp_make_character(c1); + } else if ((c1 == 'x' || c1 == 'X') && + (isxdigit)(str[1]) && (isxdigit)(str[2]) && str[3] == '\0') { + res = sexp_make_character(16 * digit_value(str[1]) + + digit_value(str[2])); + } else { + if (strcasecmp(str, "space") == 0) + res = sexp_make_character(' '); + else if (strcasecmp(str, "newline") == 0) + res = sexp_make_character('\n'); + else if (strcasecmp(str, "return") == 0) + res = sexp_make_character('\r'); + else if (strcasecmp(str, "tab") == 0) + res = sexp_make_character('\t'); + else { + tmp = sexp_c_string(ctx, str, -1); + res = sexp_read_error(ctx, "unknown character name", tmp, in); + } + } + } + break; + case '(': + sexp_push_char(ctx, c1, in); + res = sexp_read(ctx, in); + if (sexp_not(sexp_listp(ctx, res))) { + if (! sexp_exceptionp(res)) { + res = sexp_read_error(ctx, "dotted list not allowed in vector syntax", + SEXP_NULL, + in); + } + } else { + res = sexp_list_to_vector(ctx, res); + } + break; + default: + res = sexp_read_error(ctx, "invalid # syntax", + sexp_make_character(c1), in); + } + break; + case '.': + c1 = sexp_read_char(ctx, in); + sexp_push_char(ctx, c1, in); + if (c1 == EOF || is_separator(c1)) { + res = SEXP_RAWDOT; + } else if (isdigit(c1)) { + res = sexp_read_float_tail(ctx, in, 0, 0); + } else { + res = sexp_read_symbol(ctx, in, '.', 1); + } + break; + case ')': + res = SEXP_CLOSE; + break; + case '+': + case '-': + c2 = sexp_read_char(ctx, in); + if (c2 == '.' || isdigit(c2)) { + sexp_push_char(ctx, c2, in); + res = sexp_read_number(ctx, in, 10); + if ((c1 == '-') && ! sexp_exceptionp(res)) { +#if SEXP_USE_FLONUMS + if (sexp_flonump(res)) +#if SEXP_USE_IMMEDIATE_FLONUMS + res = sexp_make_flonum(ctx, -1 * sexp_flonum_value(res)); +#else + sexp_flonum_value(res) = -1 * sexp_flonum_value(res); +#endif + else +#endif +#if SEXP_USE_BIGNUMS + if (sexp_bignump(res)) { + if ((sexp_bignum_hi(res) == 1) + && (sexp_bignum_data(res)[0] == (SEXP_MAX_FIXNUM+1))) + res = sexp_make_fixnum(-sexp_bignum_data(res)[0]); + else + sexp_bignum_sign(res) = -sexp_bignum_sign(res); + } else +#endif + res = sexp_fx_mul(res, SEXP_NEG_ONE); + } + } else { + sexp_push_char(ctx, c2, in); + res = sexp_read_symbol(ctx, in, c1, 1); +#if SEXP_USE_INFINITIES + if (res == sexp_intern(ctx, "+inf.0", -1)) + res = sexp_make_flonum(ctx, sexp_pos_infinity); + else if (res == sexp_intern(ctx, "-inf.0", -1)) + res = sexp_make_flonum(ctx, sexp_neg_infinity); + else if (res == sexp_intern(ctx, "+nan.0", -1)) + res = sexp_make_flonum(ctx, sexp_nan); +#endif + } + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + sexp_push_char(ctx, c1, in); + res = sexp_read_number(ctx, in, 10); + break; + default: + res = sexp_read_symbol(ctx, in, c1, 1); + break; + } + + if (sexp_port_sourcep(in) && sexp_pointerp(res)) + sexp_immutablep(res) = 1; + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_read_op (sexp ctx sexp_api_params(self, n), sexp in) { + sexp res; + sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in); + res = sexp_read_raw(ctx, in); + if (res == SEXP_CLOSE) + res = sexp_read_error(ctx, "too many ')'s", SEXP_NULL, in); + if (res == SEXP_RAWDOT) + res = sexp_read_error(ctx, "unexpected '.'", SEXP_NULL, in); + return res; +} + +sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len) { + sexp res; + sexp_gc_var2(s, in); + sexp_gc_preserve2(ctx, s, in); + s = sexp_c_string(ctx, str, len); + in = sexp_make_input_string_port(ctx, s); + res = sexp_read(ctx, in); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_string_to_number_op (sexp ctx sexp_api_params(self, n), sexp str, sexp b) { + int base; + sexp_gc_var1(in); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, b); + if (((base=sexp_unbox_fixnum(b)) < 2) || (base > 36)) + return sexp_user_exception(ctx, self, "invalid numeric base", b); + sexp_gc_preserve1(ctx, in); + in = sexp_make_input_string_port(ctx, str); + in = ((sexp_string_data(str)[0] == '#') ? + sexp_read(ctx, in) : sexp_read_number(ctx, in, base)); + sexp_gc_release1(ctx); + return sexp_numberp(in) ? in : SEXP_FALSE; +} + +sexp sexp_write_to_string (sexp ctx, sexp obj) { + sexp str; + sexp_gc_var1(out); + sexp_gc_preserve1(ctx, out); + out = sexp_make_output_string_port(ctx); + str = sexp_write(ctx, obj, out); + if (! sexp_exceptionp(str)) + str = sexp_get_output_string(ctx, out); + sexp_gc_release1(ctx); + return str; +} + +void sexp_init (void) { +#if SEXP_USE_GLOBAL_SYMBOLS + int i; +#endif + if (! sexp_initialized_p) { + sexp_initialized_p = 1; +#if SEXP_USE_BOEHM + GC_init(); +#if SEXP_USE_GLOBAL_SYMBOLS + GC_add_roots((char*)&sexp_symbol_table, + ((char*)&sexp_symbol_table)+sizeof(sexp_symbol_table)+1); +#endif +#elif ! SEXP_USE_MALLOC + sexp_gc_init(); +#endif +#if SEXP_USE_GLOBAL_SYMBOLS + for (i=0; i 6 diff --git a/tests/basic/test00-fact-3.scm b/tests/basic/test00-fact-3.scm new file mode 100644 index 00000000..41d9c20e --- /dev/null +++ b/tests/basic/test00-fact-3.scm @@ -0,0 +1,14 @@ + +(define (fact-helper x res) + (if (= x 0) + res + (fact-helper (- x 1) (* res x)))) + +(define (fact x) + (fact-helper x 1)) + +(display "(fact 3) => ") +(write (fact 3)) +(newline) + + diff --git a/tests/basic/test01-apply.res b/tests/basic/test01-apply.res new file mode 100644 index 00000000..c5b83af4 --- /dev/null +++ b/tests/basic/test01-apply.res @@ -0,0 +1,8 @@ +11 +(11 10 9 8 7 6 5 4 3 2 1) +(1 2 3 4) +100 +100 +100 +100 +100 diff --git a/tests/basic/test01-apply.scm b/tests/basic/test01-apply.scm new file mode 100644 index 00000000..183a591c --- /dev/null +++ b/tests/basic/test01-apply.scm @@ -0,0 +1,18 @@ + +(define foo + (lambda (a b c d e f g h) + (+ (+ (* a b) (* c d)) (+ (* e f) (* g h))))) + +(define (writeln x) + (write x) + (newline)) + +(writeln (length (reverse (list 1 2 3 4 5 6 7 8 9 10 11)))) +(writeln (reverse (list 1 2 3 4 5 6 7 8 9 10 11))) +(writeln (append (list 1 2) (list 3 4))) +(writeln (foo 1 2 3 4 5 6 7 8)) +(writeln (apply foo (list 1 2 3 4 5 6 7 8))) +(writeln (apply foo 1 (list 2 3 4 5 6 7 8))) +(writeln (apply foo 1 2 3 4 (list 5 6 7 8))) +(writeln (apply foo 1 2 3 4 5 (list 6 7 8))) + diff --git a/tests/basic/test02-closure.res b/tests/basic/test02-closure.res new file mode 100644 index 00000000..4d764d20 --- /dev/null +++ b/tests/basic/test02-closure.res @@ -0,0 +1,6 @@ +1 +2 +101 +102 +3 +103 diff --git a/tests/basic/test02-closure.scm b/tests/basic/test02-closure.scm new file mode 100644 index 00000000..6ed987fe --- /dev/null +++ b/tests/basic/test02-closure.scm @@ -0,0 +1,16 @@ + +(define (make-counter n) + (lambda () + (set! n (+ n 1)) + n)) + +(define f (make-counter 0)) +(define g (make-counter 100)) + +(write (f)) (newline) +(write (f)) (newline) +(write (g)) (newline) +(write (g)) (newline) +(write (f)) (newline) +(write (g)) (newline) + diff --git a/tests/basic/test03-nested-closure.res b/tests/basic/test03-nested-closure.res new file mode 100644 index 00000000..c97c8394 --- /dev/null +++ b/tests/basic/test03-nested-closure.res @@ -0,0 +1 @@ +11357 diff --git a/tests/basic/test03-nested-closure.scm b/tests/basic/test03-nested-closure.scm new file mode 100644 index 00000000..6656bd4e --- /dev/null +++ b/tests/basic/test03-nested-closure.scm @@ -0,0 +1,8 @@ + +((lambda (a b) + ((lambda (c d e) + (write (+ e (* c 1000) (* a 100) (* b 10) d)) + (newline)) + (- a 2) (+ b 2) 10000)) + 3 5) + diff --git a/tests/basic/test04-nested-let.res b/tests/basic/test04-nested-let.res new file mode 100644 index 00000000..c97c8394 --- /dev/null +++ b/tests/basic/test04-nested-let.res @@ -0,0 +1 @@ +11357 diff --git a/tests/basic/test04-nested-let.scm b/tests/basic/test04-nested-let.scm new file mode 100644 index 00000000..584bc6e5 --- /dev/null +++ b/tests/basic/test04-nested-let.scm @@ -0,0 +1,9 @@ + +(let ((a 3) + (b 5)) + (let ((c (- a 2)) + (d (+ b 2)) + (e 10000)) + (write (+ e (* c 1000) (* a 100) (* b 10) d)) + (newline))) + diff --git a/tests/basic/test05-internal-define.res b/tests/basic/test05-internal-define.res new file mode 100644 index 00000000..4edae4cc --- /dev/null +++ b/tests/basic/test05-internal-define.res @@ -0,0 +1 @@ +1000 1003 diff --git a/tests/basic/test05-internal-define.scm b/tests/basic/test05-internal-define.scm new file mode 100644 index 00000000..a5576a63 --- /dev/null +++ b/tests/basic/test05-internal-define.scm @@ -0,0 +1,8 @@ + +(let ((a 1000)) + (define b (+ a 3)) + (write a) + (display " ") + (write b) + (newline)) + diff --git a/tests/basic/test06-letrec.res b/tests/basic/test06-letrec.res new file mode 100644 index 00000000..83d9c566 --- /dev/null +++ b/tests/basic/test06-letrec.res @@ -0,0 +1,4 @@ +7 +#t +#f +#f diff --git a/tests/basic/test06-letrec.scm b/tests/basic/test06-letrec.scm new file mode 100644 index 00000000..a9c01b4e --- /dev/null +++ b/tests/basic/test06-letrec.scm @@ -0,0 +1,15 @@ + +(letrec ((add (lambda (a b) (+ a b)))) + (write (add 3 4)) + (newline)) + +(letrec ((even? (lambda (n) (if (zero? n) #t (odd? (- n 1))))) + (odd? (lambda (n) (if (zero? n) #f (even? (- n 1)))))) + (write (even? 1000)) + (newline) + (write (even? 1001)) + (newline) + (write (odd? 1000)) + (newline) + ) + diff --git a/tests/basic/test07-mutation.res b/tests/basic/test07-mutation.res new file mode 100644 index 00000000..c97c8394 --- /dev/null +++ b/tests/basic/test07-mutation.res @@ -0,0 +1 @@ +11357 diff --git a/tests/basic/test07-mutation.scm b/tests/basic/test07-mutation.scm new file mode 100644 index 00000000..8dacb7fb --- /dev/null +++ b/tests/basic/test07-mutation.scm @@ -0,0 +1,9 @@ + +(let ((a 3) + (b 5)) + (let ((c (- a 2)) + (d (+ b 2)) + (e #f)) + (set! e 10000) + (write (+ e (* c 1000) (* a 100) (* b 10) d)) + (newline))) diff --git a/tests/basic/test08-callcc.res b/tests/basic/test08-callcc.res new file mode 100644 index 00000000..849baeed --- /dev/null +++ b/tests/basic/test08-callcc.res @@ -0,0 +1 @@ +543 diff --git a/tests/basic/test08-callcc.scm b/tests/basic/test08-callcc.scm new file mode 100644 index 00000000..3a5c355e --- /dev/null +++ b/tests/basic/test08-callcc.scm @@ -0,0 +1,34 @@ + +(define fail + (lambda () 999999)) + +(define in-range + (lambda (a b) + (call-with-current-continuation + (lambda (cont) + (enumerate a b cont))))) + +(define enumerate + (lambda (a b cont) + (if (< b a) + (fail) + (let ((save fail)) + (begin + (set! fail + (lambda () + (begin + (set! fail save) + (enumerate (+ a 1) b cont)))) + (cont a)))))) + +(write + (let ((x (in-range 2 9)) + (y (in-range 2 9)) + (z (in-range 2 9))) + (if (= (* x x) + (+ (* y y) (* z z))) + (+ (* x 100) (+ (* y 10) z)) + (fail)))) + +(newline) + diff --git a/tests/basic/test09-hygiene.res b/tests/basic/test09-hygiene.res new file mode 100644 index 00000000..31cd4d7e --- /dev/null +++ b/tests/basic/test09-hygiene.res @@ -0,0 +1,7 @@ +1 +2 +3 +4 +5 +6 +outer diff --git a/tests/basic/test09-hygiene.scm b/tests/basic/test09-hygiene.scm new file mode 100644 index 00000000..820020c1 --- /dev/null +++ b/tests/basic/test09-hygiene.scm @@ -0,0 +1,48 @@ + +(write (or 1)) +(newline) +(write (or #f 2)) +(newline) +(write (or 3 #t)) +(newline) + +(let ((tmp 4)) + (write (or #f tmp)) + (newline)) + +(write + (letrec-syntax + ((myor + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #f + (list (rename 'let) (list (list (rename 'tmp) (cadr expr))) + (list (rename 'if) (rename 'tmp) + (rename 'tmp) + (cons (rename 'myor) (cddr expr))))))))) + (let ((tmp 5)) (myor #f tmp)))) +(newline) + +(define-syntax myor + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #f + (list (rename 'let) (list (list (rename 'tmp) (cadr expr))) + (list (rename 'if) (rename 'tmp) + (rename 'tmp) + (cons (rename 'myor) (cddr expr)))))))) + +(write (let ((tmp 6)) (myor #f tmp))) +(newline) + +(let ((x 'outer)) + (let-syntax ((with-x + (syntax-rules () + ((_ y expr) + (let-syntax ((y (syntax-rules () ((_) x)))) + expr))))) + (let ((x 'inner)) + (write (with-x z (z))) + (newline)))) diff --git a/tests/basic/test10-unhygiene.res b/tests/basic/test10-unhygiene.res new file mode 100644 index 00000000..0d174dc4 --- /dev/null +++ b/tests/basic/test10-unhygiene.res @@ -0,0 +1,6 @@ +1 +1 +1 +6 +7 +8 diff --git a/tests/basic/test10-unhygiene.scm b/tests/basic/test10-unhygiene.scm new file mode 100644 index 00000000..c60a6bca --- /dev/null +++ b/tests/basic/test10-unhygiene.scm @@ -0,0 +1,49 @@ + +(define-syntax aif + (sc-macro-transformer + (lambda (form environment) + (let ((condition + (make-syntactic-closure environment '() (cadr form))) + (consequent + (make-syntactic-closure environment '(it) (caddr form))) + (alternative + (make-syntactic-closure environment '() (cadddr form)))) + `(let ((it ,condition)) + (if it + ,consequent + ,alternative)))))) + +(write (aif 1 it 3)) +(newline) + +(write (let ((it 4)) (aif 1 it 3))) +(newline) + +(write (let ((it 4)) (aif (let ((it 5)) 1) it 3))) +(newline) + +(write (let ((it 4)) (aif (let ((it 5)) 1) (let ((it 6)) it) 3))) +(newline) + +(write + (letrec-syntax + ((myor + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #f + (list (rename 'let) (list (list (rename 'it) (cadr expr))) + (list (rename 'if) (rename 'it) + (rename 'it) + (cons (rename 'myor) (cddr expr))))))))) + (let ((it 7)) (myor #f it)))) +(newline) + +(define-syntax define-foo + (sc-macro-transformer + (lambda (form environment) + (make-syntactic-closure environment '(foo) `(define foo 8))))) + +(define-foo) +(write foo) +(newline) diff --git a/tests/build/build-opts.txt b/tests/build/build-opts.txt new file mode 100644 index 00000000..e6bcd056 --- /dev/null +++ b/tests/build/build-opts.txt @@ -0,0 +1,21 @@ +CPPFLAGS=-DSEXP_USE_MODULES=0 +CPPFLAGS=-DSEXP_USE_DL=0 +CPPFLAGS=-DSEXP_USE_SIMPLIFY=0 +CPPFLAGS=-DSEXP_USE_TYPE_DEFS=0 +SEXP_USE_BOEHM=1 +CPPFLAGS=-DSEXP_USE_DEBUG_GC=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_HEAP=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_TYPES=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_SYMBOLS=1 +CPPFLAGS=-DSEXP_USE_FLONUMS=0 +CPPFLAGS=-DSEXP_USE_IMMEDIATE_FLONUMS=1 +CPPFLAGS=-DSEXP_USE_BIGNUMS=0 +CPPFLAGS=-DSEXP_USE_MATH=0 +CPPFLAGS=-DSEXP_WARN_UNDEFS=0 +CPPFLAGS=-DSEXP_USE_HUFF_SYMS=0 +CPPFLAGS=-DSEXP_USE_HASH_SYMS=0 +CPPFLAGS=-DSEXP_USE_STRING_STREAMS=0 +CPPFLAGS=-DSEXP_USE_AUTOCLOSE_PORTS=0 +CPPFLAGS=-DSEXP_USE_2010_EPOCH=0 +CPPFLAGS=-DSEXP_USE_CHECK_STACK=0 +CPPFLAGS=-DSEXP_USE_NO_FEATURES=1 diff --git a/tests/build/build-tests.sh b/tests/build/build-tests.sh new file mode 100755 index 00000000..1d239629 --- /dev/null +++ b/tests/build/build-tests.sh @@ -0,0 +1,37 @@ +#! /bin/bash + +# test basic build options + +# for bootstrapping reasons this is a shell script, instead of a +# scheme script using (chibi process) + +# we just check each build against r5rs-tests.scm - +# some of the libraries will fail to build (notably +# if modules or user-defined types are disabled). + +BUILDDIR=tests/build +FAILURES=0 +i=0 + +for opts in `cat ${BUILDDIR}/build-opts.txt`; do + make cleaner 2>&1 >/dev/null + if make $opts chibi-scheme 2>&1 >${BUILDDIR}/build${i}-make.out; then + if make test 2>&1 | tee ${BUILDDIR}/build${i}-test.out | grep -q -E 'FAIL|ERROR'; then + echo "[FAIL] ${i}: tests failed with $opts" + FAILURES=$((FAILURES + 1)) + else + echo "[PASS] ${i}: tests passed with $opts" + fi + else + echo "[FAIL] ${i}: couldn't build with $opts" + FAILURES=$((FAILURES + 1)) + fi + i=$((i+1)) +done + +if (( FAILURES == 0 )); then + echo "build-tests: all tests passed" +else + echo "build-tests: ${FAILURES} tests failed" +fi + diff --git a/tests/flonum-tests.scm b/tests/flonum-tests.scm new file mode 100644 index 00000000..5abe4772 --- /dev/null +++ b/tests/flonum-tests.scm @@ -0,0 +1,21 @@ +;;;; these will fail when compiled either without flonums or trig funcs + +(import (chibi test)) + +(test-begin "floating point") + +(test-assert (= -5 (floor -4.3))) +(test-assert (= -4 (ceiling -4.3))) +(test-assert (= -4 (truncate -4.3))) +(test-assert (= -4 (round -4.3))) +(test-assert (= 3 (floor 3.5))) +(test-assert (= 4 (ceiling 3.5))) +(test-assert (= 3 (truncate 3.5))) +(test-assert (= 4 (round 3.5))) + +(test 1124378190243790143.0 (exact->inexact 1124378190243790143)) + +;; (test "1124378190243790143.0" +;; (number->string (exact->inexact 1124378190243790143))) + +(test-end) diff --git a/tests/hash-tests.scm b/tests/hash-tests.scm new file mode 100644 index 00000000..09792c5e --- /dev/null +++ b/tests/hash-tests.scm @@ -0,0 +1,37 @@ + +(import (srfi 69) (chibi test)) + +(test-begin "hash") + +(test + 'white + (let ((ht (make-hash-table eq?))) + (hash-table-set! ht 'cat 'black) + (hash-table-set! ht 'dog 'white) + (hash-table-set! ht 'elephant 'pink) + (hash-table-ref/default ht 'dog #f))) + +(test + 'white + (let ((ht (make-hash-table equal?))) + (hash-table-set! ht "cat" 'black) + (hash-table-set! ht "dog" 'white) + (hash-table-set! ht "elephant" 'pink) + (hash-table-ref/default ht "dog" #f))) + +(test + 'white + (let ((ht (make-hash-table string-ci=? string-ci-hash))) + (hash-table-set! ht "cat" 'black) + (hash-table-set! ht "dog" 'white) + (hash-table-set! ht "elephant" 'pink) + (hash-table-ref/default ht "DOG" #f))) + +(test 625 + (let ((ht (make-hash-table))) + (do ((i 0 (+ i 1))) ((= i 1000)) + (hash-table-set! ht i (* i i))) + (hash-table-ref/default ht 25 #f))) + +(test-end) + diff --git a/tests/install/install-tests.pl b/tests/install/install-tests.pl new file mode 100755 index 00000000..63681324 --- /dev/null +++ b/tests/install/install-tests.pl @@ -0,0 +1,57 @@ +#! /usr/bin/env perl + +use strict; +use warnings; + +my $ROOT="tests/install/root"; +my $USER=$ENV{USER}; + +my $ignore = qr!/lib\d*/modules|/X11|alsa-lib|aspell|dosemu|emacs|erlang|/perl|python|ruby|lisp|sbcl|/ghc-|ocaml|evolution|office|gimp|gtk|mysql|postgres|wordnet|xulrunner!; + +sub linkdir ($$$) { + my ($FROM, $TO, $DEPTH) = @_; + mkdir $TO; + for my $f (`ls $FROM`) { + chomp $f; + if (-d "$FROM/$f") { + if (($DEPTH > 0) && ($FROM !~ $ignore)) { + linkdir("$FROM/$f", "$TO/$f", $DEPTH-1); + } + } else { + link "$FROM/$f", "$TO/$f"; + } + } +} + +mkdir "$ROOT"; +mkdir "$ROOT/bin"; +mkdir "$ROOT/sbin"; +mkdir "$ROOT/dev"; +mkdir "$ROOT/etc"; +mkdir "$ROOT/etc/alternatives"; +mkdir "$ROOT/lib"; +mkdir "$ROOT/lib64"; +mkdir "$ROOT/usr"; +mkdir "$ROOT/usr/bin"; +mkdir "$ROOT/usr/include"; +mkdir "$ROOT/usr/lib"; +mkdir "$ROOT/usr/lib/gcc"; + +linkdir "/bin", "$ROOT/bin", 1; +linkdir "/sbin", "$ROOT/sbin", 1; +link "/etc/passwd", "$ROOT/etc/passwd"; +linkdir "/etc/alternatives", "$ROOT/etc/alternatives", 1; +linkdir "/lib", "$ROOT/lib", 3; +linkdir "/lib64", "$ROOT/lib64", 3; +linkdir "/usr/bin", "$ROOT/usr/bin", 3; +linkdir "/usr/include", "$ROOT/usr/include", 2; +linkdir "/usr/lib", "$ROOT/usr/lib", 3; +linkdir "/usr/lib/gcc", "$ROOT/usr/lib/gcc", 3; + +`make dist`; +my $VERSION=`cat VERSION`; +chomp $VERSION; +`cp chibi-scheme-$VERSION.tgz $ROOT/`; +`sed -e 's/\@VERSION\@/$VERSION/g' $ROOT/bin/run-install-test.sh`; +`chmod 755 $ROOT/bin/run-install-test.sh`; +exec "sudo chroot $ROOT run-install-test.sh"; diff --git a/tests/install/run-install-test.sh b/tests/install/run-install-test.sh new file mode 100755 index 00000000..c558e7cd --- /dev/null +++ b/tests/install/run-install-test.sh @@ -0,0 +1,12 @@ +#! /bin/bash + +export PATH=/usr/local/bin:$PATH +export LD_LIBRARY_PATH=/usr/local/lib:$LD_LIBRARY_PATH + +tar xzvf chibi-scheme-@VERSION@.tgz +cd chibi-scheme-@VERSION@ +make +make install +cp tests/r5rs-tests.scm .. +cd .. +chibi-scheme r5rs-tests.scm | tee r5rs-tests.out diff --git a/tests/lib-tests.scm b/tests/lib-tests.scm new file mode 100644 index 00000000..fbd8ae0a --- /dev/null +++ b/tests/lib-tests.scm @@ -0,0 +1,13 @@ + +(import (chibi test)) + +(test-begin "libraries") + +(load "tests/flonum-tests.scm") +(load "tests/numeric-tests.scm") +(load "tests/hash-tests.scm") +(load "tests/sort-tests.scm") +(load "tests/loop-tests.scm") +(load "tests/match-tests.scm") + +(test-end) diff --git a/tests/loop-tests.scm b/tests/loop-tests.scm new file mode 100644 index 00000000..f259245c --- /dev/null +++ b/tests/loop-tests.scm @@ -0,0 +1,168 @@ + +(import (chibi loop) (chibi test)) + +(test-begin "loops") + +(test + "stepping" + '(0 1 2) + (loop lp ((with i 0 (+ i 1)) + (with res '() (cons i res))) + (if (= i 3) + (reverse res) + (lp)))) + +(test + "basic in-list" + '(c b a) + (let ((res '())) + (loop ((for x (in-list '(a b c)))) + (set! res (cons x res))) + res)) + +(test + "in-list with result" + '(c b a) + (loop ((for x (in-list '(a b c))) + (with res '() (cons x res))) + => res)) + +(test + "in-list with listing" + '(a b c) + (loop ((for x (in-list '(a b c))) (for res (listing x))) => res)) + +(test + "in-list with listing-reverse" + '(c b a) + (loop ((for x (in-list '(a b c))) (for res (listing-reverse x))) => res)) + +(test + "uneven length in-list's" + '((a . 1) (b . 2) (c . 3)) + (loop ((for x (in-list '(a b c))) + (for y (in-list '(1 2 3 4))) + (for res (listing (cons x y)))) + => res)) + +(test + "in-lists" + '((a 1) (b 2) (c 3)) + (loop ((for ls (in-lists '((a b c) (1 2 3)))) + (for res (listing ls))) + => res)) + +(define (flatten ls) + (reverse + (loop lp ((for x ls (in-list ls)) (with res '())) + => res + (if (pair? x) + (lp (=> res (lp (=> ls x)))) + (lp (=> res (cons x res))))))) + +(test + "flatten (recursion test)" + '(1 2 3 4 5 6 7) + (flatten '(1 (2) (3 (4 (5)) 6) 7))) + +(test + "in-string" + '(#\h #\e #\l #\l #\o) + (loop ((for c (in-string "hello")) (for res (listing c))) => res)) + +(test + "in-string with start" + '(#\l #\o) + (loop ((for c (in-string "hello" 3)) (for res (listing c))) => res)) + +(test + "in-string with start and end" + '(#\h #\e #\l #\l) + (loop ((for c (in-string "hello" 0 4)) (for res (listing c))) => res)) + +(test + "in-string with start, end and step" + '(#\e #\l) + (loop ((for c (in-string "hello" 1 4 2)) (for res (listing c))) => res)) + +(test + "in-string-reverse" + '(#\o #\l #\l #\e #\h) + (loop ((for c (in-string-reverse "hello")) (for res (listing c))) => res)) + +(test + "in-vector" + '(1 2 3) + (loop ((for x (in-vector '#(1 2 3))) (for res (listing x))) => res)) + +(test "up-from" '(5 6 7) + (loop ((for i (up-from 5 (to 8))) + (for res (listing i))) + => res)) + +(test "up-from by" '(5 10 15) + (loop ((for i (up-from 5 (to 20) (by 5))) + (for res (listing i))) + => res)) + +(test "up-from listing if" '(10 12 14 16 18) + (loop ((for i (up-from 10 (to 20))) + (for res (listing i (if (even? i))))) + => res)) + +(test "down-from" '(7 6 5) + (loop ((for i (down-from 8 (to 5))) + (for res (listing i))) + => res)) + +(test "down-from by" '(15 10 5) + (loop ((for i (down-from 20 (to 5) (by 5))) + (for res (listing i))) + => res)) + +(test "down-from listing if" '(18 16 14 12 10) + (loop ((for i (down-from 20 (to 10))) + (for res (listing i (if (even? i))))) + => res)) + +(test "appending" '(1 2 3 4 5 6 7 8 9) + (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9)))) + (for res (appending ls))) + => res)) + +(test "appending-reverse" '(9 8 7 6 5 4 3 2 1) + (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9)))) + (for res (appending-reverse ls))) + => res)) + +(test "while + up-from" '(5 6 7) + (loop ((for i (up-from 5 (to 10))) + (while (< i 8)) + (for res (listing i))) + => res)) + +(test "up-from by, open-ended" '(5 7 9) + (loop ((for i (up-from 5 (by 2))) + (while (< i 10)) + (for res (listing i))) + => res)) + +(test "up-from open-ended" '(5 6 7) + (loop ((for i (up-from 5)) + (while (< i 8)) + (for res (listing i))) + => res)) + +(test "down-from by, open-ended" '(5 3 1) + (loop ((for i (down-from 7 (by 2))) + (until (< i 1)) + (for res (listing i))) + => res)) + +(test "down-from open-ended" '(4 3 2) + (loop ((for i (down-from 5)) + (until (< i 2)) + (for res (listing i))) + => res)) + +(test-end) diff --git a/tests/match-tests.scm b/tests/match-tests.scm new file mode 100644 index 00000000..911dd831 --- /dev/null +++ b/tests/match-tests.scm @@ -0,0 +1,135 @@ + +(import (chibi match) (chibi test)) + +(test-begin "match") + +(test "any" 'ok (match 'any (_ 'ok))) +(test "symbol" 'ok (match 'ok (x x))) +(test "number" 'ok (match 28 (28 'ok))) +(test "string" 'ok (match "good" ("bad" 'fail) ("good" 'ok))) +(test "literal symbol" 'ok (match 'good ('bad 'fail) ('good 'ok))) +(test "null" 'ok (match '() (() 'ok))) +(test "pair" 'ok (match '(ok) ((x) x))) +(test "vector" 'ok (match '#(ok) (#(x) x))) +(test "any doubled" 'ok (match '(1 2) ((_ _) 'ok))) +(test "and empty" 'ok (match '(o k) ((and) 'ok))) +(test "and single" 'ok (match 'ok ((and x) x))) +(test "and double" 'ok (match 'ok ((and (? symbol?) y) 'ok))) +(test "or empty" 'ok (match '(o k) ((or) 'fail) (else 'ok))) +(test "or single" 'ok (match 'ok ((or x) 'ok))) +(test "or double" 'ok (match 'ok ((or (? symbol? y) y) y))) +(test "not" 'ok (match 28 ((not (a . b)) 'ok))) +(test "pred" 'ok (match 28 ((? number?) 'ok))) +(test "named pred" 29 (match 28 ((? number? x) (+ x 1)))) + +(test "duplicate symbols pass" 'ok (match '(ok . ok) ((x . x) x))) +(test "duplicate symbols fail" 'ok (match '(ok . bad) ((x . x) 'bad) (else 'ok))) +(test "duplicate symbols samth" 'ok (match '(ok . ok) ((x . 'bad) x) (('ok . x) x))) + +(test "ellipses" '((a b c) (1 2 3)) + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ___) (list x y)))) + +(test "real ellipses" '((a b c) (1 2 3)) + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ...) (list x y)))) + +(test "vector ellipses" '(1 2 3 (a b c) (1 2 3)) + (match '#(1 2 3 (a . 1) (b . 2) (c . 3)) + (#(a b c (hd . tl) ...) (list a b c hd tl)))) + +(test "pred ellipses" '(1 2 3) + (match '(1 2 3) + (((? odd? n) ___) n) + (((? number? n) ___) n))) + +(test "failure continuation" 'ok + (match '(1 2) + ((a . b) (=> next) (if (even? a) 'fail (next))) + ((a . b) 'ok))) + +(test "let" '(o k) + (match-let ((x 'ok) (y '(o k))) y)) + +(test "let*" '(f o o f) + (match-let* ((x 'f) (y 'o) ((z w) (list y x))) (list x y z w))) + +(test "getter car" '(1 2) + (match '(1 . 2) (((get! a) . b) (list (a) b)))) + +(test "getter cdr" '(1 2) + (match '(1 . 2) ((a . (get! b)) (list a (b))))) + +(test "getter vector" '(1 2 3) + (match '#(1 2 3) (#((get! a) b c) (list (a) b c)))) + +(test "setter car" '(3 . 2) + (let ((x (cons 1 2))) + (match x (((set! a) . b) (a 3))) + x)) + +(test "setter cdr" '(1 . 3) + (let ((x (cons 1 2))) + (match x ((a . (set! b)) (b 3))) + x)) + +(test "setter vector" '#(1 0 3) + (let ((x (vector 1 2 3))) + (match x (#(a (set! b) c) (b 0))) + x)) + +(test "single tail" '((a b) (1 2) (c . 3)) + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ... last) (list x y last)))) + +(test "single tail 2" '((a b) (1 2) 3) + (match '((a . 1) (b . 2) 3) + (((x . y) ... last) (list x y last)))) + +(test "multiple tail" '((a b) (1 2) (c . 3) (d . 4) (e . 5)) + (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5)) + (((x . y) ... u v w) (list x y u v w)))) + +(test "Riastradh quasiquote" '(2 3) + (match '(1 2 3) (`(1 ,b ,c) (list b c)))) + +(test "trivial tree search" '(1 2 3) + (match '(1 2 3) ((_ *** (a b c)) (list a b c)))) + +(test "simple tree search" '(1 2 3) + (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c)))) + +(test "deep tree search" '(1 2 3) + (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c)))) + +(test "non-tail tree search" '(1 2 3) + (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c)))) + +(test "restricted tree search" '(1 2 3) + (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c)))) + +(test "fail restricted tree search" #f + (match '(x (y (x a b c (1 2 3) d e f))) + (('x *** (a b c)) (list a b c)) + (else #f))) + +(test "sxml tree search" '(((href . "http://synthcode.com/")) ("synthcode")) + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f))) + +(test "failed sxml tree search" #f + (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f))) + +(test "collect tree search" + '((p ul li) ((href . "http://synthcode.com/")) ("synthcode")) + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...)) + (list tag attrs text)) + (else #f))) + +(test-end) diff --git a/tests/numeric-tests.scm b/tests/numeric-tests.scm new file mode 100644 index 00000000..43b16cb4 --- /dev/null +++ b/tests/numeric-tests.scm @@ -0,0 +1,120 @@ + +;; these tests are only valid if chibi-scheme is compiled with full +;; numeric support (USE_BIGNUMS, USE_FLONUMS and USE_MATH) + +(import (chibi test)) + +(test-begin "numbers") + +(define (integer-neighborhoods x) + (list x (+ 1 x) (+ -1 x) (- x) (- 1 x) (- -1 x))) + +(test '(536870912 536870913 536870911 -536870912 -536870911 -536870913) + (integer-neighborhoods (expt 2 29))) + +(test '(1073741824 1073741825 1073741823 -1073741824 -1073741823 -1073741825) + (integer-neighborhoods (expt 2 30))) + +(test '(2147483648 2147483649 2147483647 -2147483648 -2147483647 -2147483649) + (integer-neighborhoods (expt 2 31))) + +(test '(4294967296 4294967297 4294967295 -4294967296 -4294967295 -4294967297) + (integer-neighborhoods (expt 2 32))) + +(test '(4611686018427387904 4611686018427387905 4611686018427387903 + -4611686018427387904 -4611686018427387903 -4611686018427387905) + (integer-neighborhoods (expt 2 62))) + +(test '(9223372036854775808 9223372036854775809 9223372036854775807 + -9223372036854775808 -9223372036854775807 -9223372036854775809) + (integer-neighborhoods (expt 2 63))) + +(test '(18446744073709551616 18446744073709551617 18446744073709551615 + -18446744073709551616 -18446744073709551615 -18446744073709551617) + (integer-neighborhoods (expt 2 64))) + +(test '(85070591730234615865843651857942052864 + 85070591730234615865843651857942052865 + 85070591730234615865843651857942052863 + -85070591730234615865843651857942052864 + -85070591730234615865843651857942052863 + -85070591730234615865843651857942052865) + (integer-neighborhoods (expt 2 126))) + +(test '(170141183460469231731687303715884105728 + 170141183460469231731687303715884105729 + 170141183460469231731687303715884105727 + -170141183460469231731687303715884105728 + -170141183460469231731687303715884105727 + -170141183460469231731687303715884105729) + (integer-neighborhoods (expt 2 127))) + +(test '(340282366920938463463374607431768211456 + 340282366920938463463374607431768211457 + 340282366920938463463374607431768211455 + -340282366920938463463374607431768211456 + -340282366920938463463374607431768211455 + -340282366920938463463374607431768211457) + (integer-neighborhoods (expt 2 128))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (integer-arithmetic-combinations a b) + (list (+ a b) (- a b) (* a b) (quotient a b) (remainder a b))) + +(define (sign-combinations a b) + (list (integer-arithmetic-combinations a b) + (integer-arithmetic-combinations (- a) b) + (integer-arithmetic-combinations a (- b)) + (integer-arithmetic-combinations (- a) (- b)))) + +;; fix x fix +(test '((1 -1 0 0 0) (1 -1 0 0 0) (-1 1 0 0 0) (-1 1 0 0 0)) + (sign-combinations 0 1)) +(test '((2 0 1 1 0) (0 -2 -1 -1 0) (0 2 -1 -1 0) (-2 0 1 1 0)) + (sign-combinations 1 1)) +(test '((59 25 714 2 8) (-25 -59 -714 -2 -8) + (25 59 -714 -2 8) (-59 -25 714 2 -8)) + (sign-combinations 42 17)) + +;; fix x big +(test '((4294967338 -4294967254 180388626432 0 42) + (4294967254 -4294967338 -180388626432 0 -42) + (-4294967254 4294967338 -180388626432 0 42) + (-4294967338 4294967254 180388626432 0 -42)) + (sign-combinations 42 (expt 2 32))) + +;; big x fix +(test '((4294967338 4294967254 180388626432 102261126 4) + (-4294967254 -4294967338 -180388626432 -102261126 -4) + (4294967254 4294967338 -180388626432 -102261126 4) + (-4294967338 -4294967254 180388626432 102261126 -4)) + (sign-combinations (expt 2 32) 42)) + +;; big x bigger +(test '((12884901889 -4294967297 36893488151714070528 0 4294967296) + (4294967297 -12884901889 -36893488151714070528 0 -4294967296) + (-4294967297 12884901889 -36893488151714070528 0 4294967296) + (-12884901889 4294967297 36893488151714070528 0 -4294967296)) + (sign-combinations (expt 2 32) (+ 1 (expt 2 33)))) + +(test '((18446744078004518913 -18446744069414584321 79228162514264337597838917632 0 4294967296) + (18446744069414584321 -18446744078004518913 -79228162514264337597838917632 0 -4294967296) + (-18446744069414584321 18446744078004518913 -79228162514264337597838917632 0 4294967296) + (-18446744078004518913 18446744069414584321 79228162514264337597838917632 0 -4294967296)) + (sign-combinations (expt 2 32) (+ 1 (expt 2 64)))) + +;; bigger x big +(test '((12884901889 4294967297 36893488151714070528 2 1) + (-4294967297 -12884901889 -36893488151714070528 -2 -1) + (4294967297 12884901889 -36893488151714070528 -2 1) + (-12884901889 -4294967297 36893488151714070528 2 -1)) + (sign-combinations (+ 1 (expt 2 33)) (expt 2 32))) + +(test '((18446744078004518913 18446744069414584321 79228162514264337597838917632 4294967296 1) + (-18446744069414584321 -18446744078004518913 -79228162514264337597838917632 -4294967296 -1) + (18446744069414584321 18446744078004518913 -79228162514264337597838917632 -4294967296 1) + (-18446744078004518913 -18446744069414584321 79228162514264337597838917632 4294967296 -1)) + (sign-combinations (+ 1 (expt 2 64)) (expt 2 32))) + +(test-end) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm new file mode 100644 index 00000000..a9197fb1 --- /dev/null +++ b/tests/r5rs-tests.scm @@ -0,0 +1,465 @@ + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test expect expr) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string + (lambda (out) + (write *tests-run*) + (display ". ") + (display 'expr out)))) + (res expr)) + (display str) + (write-char #\space) + (display (make-string (max 0 (- 72 (string-length str))) #\.)) + (flush-output) + (cond + ((equal? res expect) + (set! *tests-passed* (+ *tests-passed* 1)) + (display " [PASS]\n")) + (else + (display " [FAIL]\n") + (display " expected ") (write expect) + (display " but got ") (write res) (newline)))))))) + +(define (test-report) + (write *tests-passed*) + (display " out of ") + (write *tests-run*) + (display " passed (") + (write (* (/ *tests-passed* *tests-run*) 100)) + (display "%)") + (newline)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(test 8 ((lambda (x) (+ x x)) 4)) + +(test '(3 4 5 6) ((lambda x x) 3 4 5 6)) + +(test '(5 6) ((lambda (x y . z) z) 3 4 5 6)) + +(test 'yes (if (> 3 2) 'yes 'no)) + +(test 'no (if (> 2 3) 'yes 'no)) + +(test 1 (if (> 3 2) (- 3 2) (+ 3 2))) + +(test 'greater (cond ((> 3 2) 'greater) ((< 3 2) 'less))) + +(test 'equal (cond ((> 3 3) 'greater) ((< 3 3) 'less) (else 'equal))) + +(test 'composite (case (* 2 3) ((2 3 5 7) 'prime) ((1 4 6 8 9) 'composite))) + +(test 'consonant + (case (car '(c d)) + ((a e i o u) 'vowel) + ((w y) 'semivowel) + (else 'consonant))) + +(test #t (and (= 2 2) (> 2 1))) + +(test #f (and (= 2 2) (< 2 1))) + +(test '(f g) (and 1 2 'c '(f g))) + +(test #t (and)) + +(test #t (or (= 2 2) (> 2 1))) + +(test #t (or (= 2 2) (< 2 1))) + +(test '(b c) (or (memq 'b '(a b c)) (/ 3 0))) + +(test 6 (let ((x 2) (y 3)) (* x y))) + +(test 35 (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x)))) + +(test 70 (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x)))) + +(test -2 (let () + (define x 2) + (define f (lambda () (- x))) + (f))) + +(define let*-def 1) +(let* () (define let*-def 2) #f) +(test 1 let*-def) + +(test '#(0 1 2 3 4) + (do ((vec (make-vector 5)) + (i 0 (+ i 1))) + ((= i 5) vec) + (vector-set! vec i i))) + +(test 25 + (let ((x '(1 3 5 7 9))) + (do ((x x (cdr x)) + (sum 0 (+ sum (car x)))) + ((null? x) + sum)))) + +(test '((6 1 3) (-5 -2)) + (let loop ((numbers '(3 -2 1 6 -5)) (nonneg '()) (neg '())) + (cond + ((null? numbers) + (list nonneg neg)) + ((>= (car numbers) 0) + (loop (cdr numbers) (cons (car numbers) nonneg) neg)) + ((< (car numbers) 0) + (loop (cdr numbers) nonneg (cons (car numbers) neg)))))) + +(test '(list 3 4) `(list ,(+ 1 2) 4)) + +(test '(list a 'a) (let ((name 'a)) `(list ,name ',name))) + +(test '(a 3 4 5 6 b) + `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) + +(test '(10 5 4 16 9 8) + `(10 5 ,(expt 2 2) ,@(map (lambda (n) (expt n 2)) '(4 3)) 8)) + +(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) + `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) + +(test '(a `(b ,x ,'y d) e) + (let ((name1 'x) + (name2 'y)) + `(a `(b ,,name1 ,',name2 d) e))) + +(test '(list 3 4) + (quasiquote (list (unquote (+ 1 2)) 4))) + +(test #t (eqv? 'a 'a)) + +(test #f (eqv? 'a 'b)) + +(test #t (eqv? '() '())) + +(test #f (eqv? (cons 1 2) (cons 1 2))) + +(test #f (eqv? (lambda () 1) (lambda () 2))) + +(test #t (let ((p (lambda (x) x))) (eqv? p p))) + +(test #t (eq? 'a 'a)) + +(test #f (eq? (list 'a) (list 'a))) + +(test #t (eq? '() '())) + +(test #t (eq? car car)) + +(test #t (let ((x '(a))) (eq? x x))) + +(test #t (let ((p (lambda (x) x))) (eq? p p))) + +(test #t (equal? 'a 'a)) + +(test #t (equal? '(a) '(a))) + +(test #t (equal? '(a (b) c) '(a (b) c))) + +(test #t (equal? "abc" "abc")) + +(test #t (equal? 2 2)) + +;;(test #f (eqv? 2 2.0)) + +;;(test #f (equal? 2.0 2)) + +(test #t (equal? (make-vector 5 'a) (make-vector 5 'a))) + +(test 4 (max 3 4)) + +;;(test 4 (max 3.9 4)) + +(test 7 (+ 3 4)) + +(test 3 (+ 3)) + +(test 0 (+)) + +(test 4 (* 4)) + +(test 1 (*)) + +(test -1 (- 3 4)) + +(test -6 (- 3 4 5)) + +(test -3 (- 3)) + +(test 7 (abs -7)) + +(test 1 (modulo 13 4)) + +(test 1 (remainder 13 4)) + +(test 3 (modulo -13 4)) + +(test -1 (remainder -13 4)) + +(test -3 (modulo 13 -4)) + +(test 1 (remainder 13 -4)) + +(test -1 (modulo -13 -4)) + +(test -1 (remainder -13 -4)) + +(test 4 (gcd 32 -36)) + +(test 288 (lcm 32 -36)) + +(test 100 (string->number "100")) + +(test 256 (string->number "100" 16)) + +(test 127 (string->number "177" 8)) + +(test 5 (string->number "101" 2)) + +(test 100.0 (string->number "1e2")) + +(test "100" (number->string 100)) + +(test "100" (number->string 256 16)) + +(test "FF" (number->string 255 16)) + +(test "177" (number->string 127 8)) + +(test "101" (number->string 5 2)) + +(test #f (not 3)) + +(test #f (not (list 3))) + +(test #f (not '())) + +(test #f (not (list))) + +(test #f (not '())) + +(test #f (boolean? 0)) + +(test #f (boolean? '())) + +(test #t (pair? '(a . b))) + +(test #t (pair? '(a b c))) + +(test '(a) (cons 'a '())) + +(test '((a) b c d) (cons '(a) '(b c d))) + +(test '("a" b c) (cons "a" '(b c))) + +(test '(a . 3) (cons 'a 3)) + +(test '((a b) . c) (cons '(a b) 'c)) + +(test 'a (car '(a b c))) + +(test '(a) (car '((a) b c d))) + +(test 1 (car '(1 . 2))) + +(test '(b c d) (cdr '((a) b c d))) + +(test 2 (cdr '(1 . 2))) + +(test #t (list? '(a b c))) + +(test #t (list? '())) + +(test #f (list? '(a . b))) + +(test #f + (let ((x (list 'a))) + (set-cdr! x x) + (list? x))) + +(test '(a 7 c) (list 'a (+ 3 4) 'c)) + +(test '() (list)) + +(test 3 (length '(a b c))) + +(test 3 (length '(a (b) (c d e)))) + +(test 0 (length '())) + +(test '(x y) (append '(x) '(y))) + +(test '(a b c d) (append '(a) '(b c d))) + +(test '(a (b) (c)) (append '(a (b)) '((c)))) + +(test '(a b c . d) (append '(a b) '(c . d))) + +(test 'a (append '() 'a)) + +(test '(c b a) (reverse '(a b c))) + +(test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f))))) + +(test 'c (list-ref '(a b c d) 2)) + +(test '(a b c) (memq 'a '(a b c))) + +(test '(b c) (memq 'b '(a b c))) + +(test #f (memq 'a '(b c d))) + +(test #f (memq (list 'a) '(b (a) c))) + +(test '((a) c) (member (list 'a) '(b (a) c))) + +(test '(101 102) (memv 101 '(100 101 102))) + +(test #f (assq (list 'a) '(((a)) ((b)) ((c))))) + +(test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c))))) + +(test '(5 7) (assv 5 '((2 3) (5 7) (11 13)))) + +(test #t (symbol? 'foo)) + +(test #t (symbol? (car '(a b)))) + +(test #f (symbol? "bar")) + +(test #t (symbol? 'nil)) + +(test #f (symbol? '())) + +(test "flying-fish" (symbol->string 'flying-fish)) + +(test "Martin" (symbol->string 'Martin)) + +(test "Malvina" (symbol->string (string->symbol "Malvina"))) + +(test '#(0 ("Sue" "Sue") "Anna") + (let ((vec (vector 0 '(2 2 2 2) "Anna"))) + (vector-set! vec 1 '("Sue" "Sue")) + vec)) + +(test '(dah dah didah) (vector->list '#(dah dah didah))) + +(test '#(dididit dah) (list->vector '(dididit dah))) + +(test #t (procedure? car)) + +(test #f (procedure? 'car)) + +(test #t (procedure? (lambda (x) (* x x)))) + +(test #f (procedure? '(lambda (x) (* x x)))) + +(test #t (call-with-current-continuation procedure?)) + +(test 7 (call-with-current-continuation (lambda (k) (+ 2 5)))) + +(test 3 (call-with-current-continuation (lambda (k) (+ 2 5 (k 3))))) + +(test 7 (apply + (list 3 4))) + +(test '(b e h) (map cadr '((a b) (d e) (g h)))) + +(test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5))) + +(test '(5 7 9) (map + '(1 2 3) '(4 5 6))) + +(test '#(0 1 4 9 16) + (let ((v (make-vector 5))) + (for-each + (lambda (i) (vector-set! v i (* i i))) + '(0 1 2 3 4)) + v)) + +(test 3 (force (delay (+ 1 2)))) + +(test '(3 3) (let ((p (delay (+ 1 2)))) (list (force p) (force p)))) + +(test 'ok (let ((else 1)) (cond (else 'ok) (#t 'bad)))) + +(test 'ok (let ((=> 1)) (cond (#t => 'ok)))) + +(test '(,foo) (let ((unquote 1)) `(,foo))) + +(test '(,@foo) (let ((unquote-splicing 1)) `(,@foo))) + +(test 'ok + (let ((... 2)) + (let-syntax ((s (syntax-rules () + ((_ x ...) 'bad) + ((_ . r) 'ok)))) + (s a b c)))) + +(test 'ok (let () + (let-syntax () + (define internal-def 'ok)) + internal-def)) + +(test 'ok (let () + (letrec-syntax () + (define internal-def 'ok)) + internal-def)) + +(test '(2 1) + ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (list x y)))))) + +(test '(2 2) + ((lambda () (let ((x 1)) (set! x 2) (let ((y x)) (list x y)))))) + +(test '(1 2) + ((lambda () (let ((x 1)) (let ((y x)) (set! y 2) (list x y)))))) + +(test '(2 3) + ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (set! y 3) (list x y)))))) + +(test '(a b c) + (let* ((path '()) + (add (lambda (s) (set! path (cons s path))))) + (dynamic-wind (lambda () (add 'a)) (lambda () (add 'b)) (lambda () (add 'c))) + (reverse path))) + +(test '(connect talk1 disconnect connect talk2 disconnect) + (let ((path '()) + (c #f)) + (let ((add (lambda (s) + (set! path (cons s path))))) + (dynamic-wind + (lambda () (add 'connect)) + (lambda () + (add (call-with-current-continuation + (lambda (c0) + (set! c c0) + 'talk1)))) + (lambda () (add 'disconnect))) + (if (< (length path) 4) + (c 'talk2) + (reverse path))))) + +(test 2 (let-syntax + ((foo (syntax-rules ::: () + ((foo ... args :::) + (args ::: ...))))) + (foo 3 - 5))) + +(test '(5 4 1 2 3) + (let-syntax + ((foo (syntax-rules () + ((foo args ... penultimate ultimate) + (list ultimate penultimate args ...))))) + (foo 1 2 3 4 5))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(test-report) diff --git a/tests/sort-tests.scm b/tests/sort-tests.scm new file mode 100644 index 00000000..f506baca --- /dev/null +++ b/tests/sort-tests.scm @@ -0,0 +1,40 @@ + +(import (srfi 95) (chibi test)) + +(test-begin "sorting") + +(test "sort null" '() (sort '())) +(test "sort null <" '() (sort '() <)) +(test "sort null < car" '() (sort '() < car)) +(test "sort ordered list" '(1 2 3 4 5 6 7 8 9) (sort '(1 2 3 4 5 6 7 8 9))) +(test "sort reversed list" '(1 2 3 4 5 6 7 8 9) (sort '(9 8 7 6 5 4 3 2 1))) +(test "sort random list 1" '(1 2 3 4 5 6 7 8 9) (sort '(7 5 2 8 1 6 4 9 3))) +(test "sort random list 2" '(1 2 3 4 5 6 7 8) (sort '(5 3 4 1 7 6 8 2))) +(test "sort random list 3" '(1 2 3 4 5 6 7 8 9) (sort '(5 3 4 1 7 9 6 8 2))) +(test "sort numeric list <" '(1 2 3 4 5 6 7 8 9) + (sort '(7 5 2 8 1 6 4 9 3) <)) +(test "sort numeric list < car" '((1) (2) (3) (4) (5) (6) (7) (8) (9)) + (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) < car)) +(test "sort list (lambda (a b) (< (car a) (car b)))" + '((1) (2) (3) (4) (5) (6) (7) (8) (9)) + (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) + (lambda (a b) (< (car a) (car b))))) +(test "sort 1-char symbols" '(a b c d e f g h i j k) + (sort '(h b k d a c j i e g f))) +(test "sort short symbols" '(a aa b c d e ee f g h i j k) + (sort '(h b aa k d a ee c j i e g f))) +(test "sort long symbol" + '(a aa b bzzzzzzzzzzzzzzzzzzzzzzz c d e ee f g h i j k) + (sort '(h b aa k d a ee c j i bzzzzzzzzzzzzzzzzzzzzzzz e g f))) +(test "sort long symbols" + '(a aa b bzzzzzzzzzzzzzzzzzzzzzzz czzzzzzzzzzzzz dzzzzzzzz e ee f g h i j k) + (sort '(h b aa k dzzzzzzzz a ee czzzzzzzzzzzzz j i bzzzzzzzzzzzzzzzzzzzzzzz e g f))) +(test "sort strings" + '("ape" "bear" "cat" "dog" "elephant" "fox" "goat" "hawk") + (sort '("elephant" "cat" "dog" "ape" "goat" "fox" "hawk" "bear"))) +(test "sort strings string-cistring x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "non-stringable object" x)))) + +(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-replace str c r) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate (reverse (collect)))) + ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect)))) + (else (lp from (+ i 1) res)))))) + +(define (c-char? c) + (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?)))) + +(define (c-escape str) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate (reverse (collect)))) + ((not (c-char? (string-ref str i))) (lp (+ i 1) (+ i 1) (cons "_" (cons (number->string (char->integer (string-ref str i)) 16) (collect))))) + (else (lp from (+ i 1) res)))))) + +(define (mangle x) + (string-replace + (string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p") + #\! "_x")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (path-relative path dir) + (let ((p-len (string-length path)) + (d-len (string-length dir))) + (and (> p-len d-len) + (string=? dir (substring path 0 d-len)) + (cond + ((eqv? #\/ (string-ref path d-len)) + (substring path (+ d-len 1) p-len)) + ((eqv? #\/ (string-ref path (- d-len 1))) + (substring path d-len p-len)) + (else #f))))) + +(define (path-split file) + (let ((len (string-length file))) + (let lp ((i 0) (res '())) + (let ((j (string-scan #\/ file i))) + (cond + (j (lp (+ j 1) (cons (substring file i j) res))) + (else (reverse (if (= i len) + res + (cons (substring file i len) res))))))))) + +(define (init-name mod) + (string-append "sexp_init_lib_" + (string-concatenate (map mangle mod) "_"))) + +(define (find-c-libs basedir) + (define (process-dir dir) + (directory-fold + dir + (lambda (f x) + (if (and (not (equal? "" f)) (not (eqv? #\. (string-ref f 0)))) + (process (string-append dir "/" f)))) + #f)) + (define (process file) + (cond + ((file-directory? file) + (process-dir file)) + ((equal? "module" (path-extension file)) + (let* ((mod-path (path-strip-extension (path-relative file basedir))) + (mod-name (map (lambda (x) (or (string->number x) (string->symbol x))) + (path-split mod-path)))) + (cond + ((eval `(find-module ',mod-name) *config-env*) + => (lambda (mod) + (cond + ((assq 'include-shared (vector-ref mod 2)) + => (lambda (x) + (set! c-libs + (cons (cons (string-append + (path-directory file) + "/" + (cadr x) + ".c") + (init-name mod-name)) + c-libs)))))))))))) + (process-dir basedir)) + +(define (include-c-lib lib) + (display "#define sexp_init_library ") + (display (cdr lib)) + (newline) + (display "#include \"") + (display (car lib)) + (display "\"") + (newline) + (display "#undef sexp_init_library") + (newline) + (newline)) + +(define (init-c-lib lib) + (display " ") + (display (cdr lib)) + (display "(ctx, env);\n")) + +(define (main args) + (find-c-libs (if (pair? (cdr args)) (cadr args) "lib")) + (newline) + (for-each include-c-lib c-libs) + (newline) + (display "static sexp sexp_init_all_libraries (sexp ctx, sexp env) {\n") + (for-each init-c-lib c-libs) + (display " return SEXP_VOID;\n") + (display "}\n\n")) + diff --git a/tools/genstubs.scm b/tools/genstubs.scm new file mode 100755 index 00000000..e75d9a92 --- /dev/null +++ b/tools/genstubs.scm @@ -0,0 +1,1280 @@ +#! /usr/bin/env chibi-scheme + +;; Note: this evolved as a throw-away script to provide certain core +;; modules, and so is a mess. Tread carefully. + +;; Simple C FFI. "genstubs.scm file.stub" will read in the C function +;; FFI definitions from file.stub and output the appropriate C +;; wrappers into file.c. You can then compile that file with: +;; +;; cc -fPIC -shared file.c -lchibi-scheme +;; +;; (or using whatever flags are appropriate to generate shared libs on +;; your platform) and then the generated .so file can be loaded +;; directly with load, or portably using (include-shared "file") in a +;; module definition (note that include-shared uses no suffix). + +;; The goal of this interface is to make access to C types and +;; functions easy, without requiring the user to write any C code. +;; That means the stubber needs to be intelligent about various C +;; calling conventions and idioms, such as return values passed in +;; actual parameters. Writing C by hand is still possible, and +;; several of the core modules provide C interfaces directly without +;; using the stubber. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Struct Interface +;; +;; (define-c-struct struct-name +;; [predicate: predicate-name] +;; [constructor: constructor-name] +;; [finalizer: c_finalizer_name] +;; (type c_field_name getter-name setter-name) ...) +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Function Interface +;; +;; (define-c return-type name-spec (arg-type ...)) +;; +;; where name-space is either a symbol name, or a list of +;; (scheme-name c_name). If just a symbol, the C name is taken +;; to be the same with -'s replaced by _'s. +;; +;; arg-type is a type suitable for input validation and conversion. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Types +;; +;; Types +;; +;; Basic Types +;; void +;; boolean +;; char +;; sexp (no conversions) +;; +;; Integer Types: +;; signed-char short int long +;; unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t +;; time_t (in seconds, but using the chibi epoch of 2010/01/01) +;; errno (as a return type returns #f on error) +;; +;; Float Types: +;; float double long-double +;; +;; String Types: +;; string - a null-terminated char* +;; env-string - a VAR=VALUE string represented as a (VAR . VALUE) pair inScheme +;; in addition you can use (array char) as a string +;; +;; Port Types: +;; input-port output-port +;; port-or-fd - an fd-backed port or a fixnum +;; +;; Struct Types: +;; +;; Struct types are by default just referred to by the bare +;; struct-name from define-c-struct, and it is assumed you want a +;; pointer to that type. To refer to the full struct, use the struct +;; modifier, as in (struct struct-name). + +;; Type modifiers +;; +;; Any type may also be written as a list of modifiers followed by the +;; type itself. The supported modifiers are: +;; +;; const: prepends the "const" C type modifier +;; * as a return or result parameter, makes non-immediates immutable +;; +;; free: it's Scheme's responsibility to "free" this resource +;; * as a return or result parameter, registers the freep flag +;; this causes the type finalizer to be run when GCed +;; +;; maybe-null: this pointer type may be NULL +;; * as a result parameter, NULL is translated to #f +;; normally this would just return a wrapped NULL pointer +;; * as an input parameter, #f is translated to NULL +;; normally this would be a type error +;; +;; pointer: create a pointer to this type +;; * as a return parameter, wraps the result in a vanilla cpointer +;; * as a result parameter, boxes then unboxes the value +;; +;; struct: treat this struct type as a struct, not a pointer +;; * as an input parameter, dereferences the pointer +;; * as a type field, indicates a nested struct +;; +;; link: add a gc link +;; * as a field getter, link to the parent object, so the +;; parent won't be GCed so long as we have a reference +;; to the child. this behavior is automatic for nested +;; structs. +;; +;; result: return a result in this parameter +;; * if there are multiple results (including the return type), +;; they are all returned in a list +;; * if there are any result parameters, a return type +;; of errno returns #f on failure, and as eliminated +;; from the list of results otherwise +;; +;; (value ): specify a fixed value +;; * as an input parameter, this parameter is not provided +;; in the Scheme API but always passed as +;; +;; (default ): specify a default value +;; * as the final input parameter, makes the Scheme parameter +;; optional, defaulting to +;; +;; (array []) an array type +;; * length must be specified for return and result parameters +;; * if specified, length can be any of +;; ** an integer, for a fixed size +;; ** the symbol null, indicating a NULL-terminated array + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; globals + +(define *types* '()) +(define *funcs* '()) +(define *consts* '()) +(define *inits* '()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; type objects + +(define (parse-type type . o) + (cond + ((vector? type) + type) + (else + (let lp ((type type) (free? #f) (const? #f) (null-ptr? #f) + (ptr? #f) (struct? #f) (link? #f) (result? #f) (array #f) + (value #f) (default? #f)) + (define (next) (if (null? (cddr type)) (cadr type) (cdr type))) + (case (and (pair? type) (car type)) + ((free) + (lp (next) #t const? null-ptr? ptr? struct? link? result? array value default?)) + ((const) + (lp (next) free? #t null-ptr? ptr? struct? link? result? array value default?)) + ((maybe-null) + (lp (next) free? const? #t ptr? struct? link? result? array value default?)) + ((pointer) + (lp (next) free? const? null-ptr? #t struct? link? result? array value default?)) + ((struct) + (lp (next) free? const? null-ptr? ptr? #t link? result? array value default?)) + ((link) + (lp (next) free? const? null-ptr? ptr? struct? #t result? array value default?)) + ((result) + (lp (next) free? const? null-ptr? ptr? struct? link? #t array value default?)) + ((array) + (lp (cadr type) free? const? null-ptr? ptr? struct? link? result? (if (pair? (cddr type)) (caddr type) #t) value default?)) + ((value) + (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) default?)) + ((default) + (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) #t)) + (else + (vector (if (and (pair? type) (null? (cdr type))) (car type) type) free? const? null-ptr? ptr? struct? link? result? array value default? (and (pair? o) (car o))))))))) + +(define (type-base type) (vector-ref type 0)) +(define (type-free? type) (vector-ref type 1)) +(define (type-const? type) (vector-ref type 2)) +(define (type-null? type) (vector-ref type 3)) +(define (type-pointer? type) (vector-ref type 4)) +(define (type-struct? type) (vector-ref type 5)) +(define (type-link? type) (vector-ref type 6)) +(define (type-result? type) (vector-ref type 7)) +(define (type-array type) (vector-ref type 8)) +(define (type-value type) (vector-ref type 9)) +(define (type-default? type) (vector-ref type 10)) +(define (type-index type) (vector-ref type 11)) + +(define (type-auto-expand? type) + (and (pair? (type-array type)) + (memq 'auto-expand (type-array type)))) + +(define (type-index-string type) + (if (integer? (type-index type)) + (number->string (type-index type)) + "")) + +(define (struct-fields ls) + (let lp ((ls ls) (res '())) + (cond ((null? ls) (reverse res)) + ((symbol? (car ls)) (lp (cddr ls) res)) + (else (lp (cdr ls) (cons (car ls) res)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; type predicates + +(define (signed-int-type? type) + (memq type '(signed-char short int long boolean))) + +(define (unsigned-int-type? type) + (memq type '(unsigned-char unsigned-short unsigned unsigned-int unsigned-long + size_t off_t time_t clock_t dev_t ino_t mode_t nlink_t + uid_t gid_t pid_t blksize_t blkcnt_t sigval_t))) + +(define (int-type? type) + (or (signed-int-type? type) (unsigned-int-type? type))) + +(define (float-type? type) + (memq type '(float double long-double long-long-double))) + +(define (string-type? type) + (or (memq type '(char* string env-string non-null-string)) + (and (vector? type) + (type-array type) + (not (type-pointer? type)) + (eq? 'char (type-base type))))) + +(define (port-type? type) + (memq type '(port input-port output-port))) + +(define (error-type? type) + (memq type '(errno non-null-string non-null-pointer))) + +(define (array-type? type) + (and (type-array type) (not (eq? 'char (type-base type))))) + +(define (basic-type? type) + (let ((type (parse-type type))) + (and (not (type-array type)) + (not (void-pointer-type? type)) + (not (assq (type-base type) *types*))))) + +(define (void-pointer-type? type) + (or (and (eq? 'void (type-base type)) (type-pointer? type)) + (eq? 'void* (type-base type)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; function objects + +(define (parse-func func) + (if (not (and (= 3 (length func)) + (or (identifier? (cadr func)) (list (cadr func))) + (list (caddr func)))) + (error "bad function definition" func)) + (let* ((ret-type (parse-type (car func))) + (scheme-name (if (pair? (cadr func)) (caadr func) (cadr func))) + (c-name (if (pair? (cadr func)) + (cadadr func) + (mangle scheme-name))) + (stub-name (if (and (pair? (cadr func)) (pair? (cddadr func))) + (car (cddadr func)) + (generate-stub-name scheme-name)))) + (let lp ((ls (caddr func)) + (i 0) + (results '()) + (c-args '()) + (s-args '())) + (cond + ((null? ls) + (vector scheme-name c-name stub-name ret-type + (reverse results) (reverse c-args) (reverse s-args))) + (else + (let ((type (parse-type (car ls) i))) + (cond + ((type-result? type) + (lp (cdr ls) (+ i 1) (cons type results) (cons type c-args) s-args)) + ((and (type-value type) (not (type-default? type))) + (lp (cdr ls) (+ i 1) results (cons type c-args) s-args)) + (else + (lp (cdr ls) (+ i 1) results (cons type c-args) (cons type s-args))) + ))))))) + +(define (func-scheme-name func) (vector-ref func 0)) +(define (func-c-name func) (vector-ref func 1)) +(define (func-stub-name func) (vector-ref func 2)) +(define (func-ret-type func) (vector-ref func 3)) +(define (func-results func) (vector-ref func 4)) +(define (func-c-args func) (vector-ref func 5)) +(define (func-scheme-args func) (vector-ref func 6)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define (cat . args) + (for-each (lambda (x) (if (procedure? x) (x) (display x))) args)) + +(define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "non-stringable object" x)))) + +(define (filter pred ls) + (cond ((null? ls) '()) + ((pred (car ls)) (cons (car ls) (filter pred (cdr ls)))) + (else (filter pred (cdr ls))))) + +(define (remove pred ls) + (cond ((null? ls) '()) + ((pred (car ls)) (filter pred (cdr ls))) + (else (cons (car ls) (filter pred (cdr ls)))))) + +(define (strip-extension path) + (let lp ((i (- (string-length path) 1))) + (cond ((<= i 0) path) + ((eq? #\. (string-ref path i)) (substring path 0 i)) + (else (lp (- i 1)))))) + +(define (string-concatenate-reverse ls) + (cond ((null? ls) "") + ((null? (cdr ls)) (car ls)) + (else (string-concatenate (reverse ls))))) + +(define (string-replace str c r) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate-reverse (collect))) + ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect)))) + (else (lp from (+ i 1) res)))))) + +(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-downcase str) + (list->string (map char-downcase (string->list str)))) + +(define (with-output-to-string thunk) + (call-with-output-string + (lambda (out) + (let ((old-out (current-output-port))) + (current-output-port out) + (thunk) + (current-output-port old-out))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; naming + +(define (c-char? c) + (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?)))) + +(define (c-escape str) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate-reverse (collect))) + ((not (c-char? (string-ref str i))) (lp (+ i 1) (+ i 1) (cons "_" (cons (number->string (char->integer (string-ref str i)) 16) (collect))))) + (else (lp from (+ i 1) res)))))) + +(define (mangle x) + (string-replace + (string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p") + #\! "_x")) + +(define (generate-stub-name sym) + (string-append "sexp_" (mangle sym) "_stub")) + +(define (type-id-name sym) + (string-append "sexp_" (mangle sym) "_type_id")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; .stub file interface + +(define (c-declare . args) + (apply cat args) + (newline)) + +(define (c-include header) + (cat "\n#include \"" header "\"\n")) + +(define (c-system-include header) + (cat "\n#include <" header ">\n")) + +(define (c-init x) + (set! *inits* (cons x *inits*))) + +(define (parse-struct-like ls) + (let lp ((ls ls) (res '())) + (cond + ((null? ls) + (reverse res)) + ((symbol? (car ls)) + (lp (cddr ls) (cons (cadr ls) (cons (car ls) res)))) + ((pair? (car ls)) + (lp (cdr ls) (cons (cons (parse-type (caar ls)) (cdar ls)) res))) + (else + (lp (cdr ls) (cons (car ls) res)))))) + +(define-syntax define-struct-like + (er-macro-transformer + (lambda (expr rename compare) + (set! *types* + `((,(cadr expr) + ,@(parse-struct-like (cddr expr))) + ,@*types*)) + `(cat "\nstatic sexp_uint_t " ,(type-id-name (cadr expr)) ";\n")))) + +(define-syntax define-c-struct + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: struct ,@(cddr expr))))) + +(define-syntax define-c-class + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: class ,@(cddr expr))))) + +(define-syntax define-c-union + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: union ,@(cddr expr))))) + +(define-syntax define-c-type + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) ,@(cddr expr))))) + +(define-syntax define-c + (er-macro-transformer + (lambda (expr rename compare) + (set! *funcs* (cons (parse-func (cdr expr)) *funcs*)) + #f))) + +(define-syntax define-c-const + (er-macro-transformer + (lambda (expr rename compare) + (let ((type (parse-type (cadr expr)))) + (for-each (lambda (x) (set! *consts* (cons (list type x) *consts*))) + (cddr expr)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; C code generation + +(define (c->scheme-converter type val . o) + (let ((base (type-base type))) + (cond + ((and (eq? base 'void) (not (type-pointer? type))) + (cat "((" val "), SEXP_VOID)")) + ((or (eq? base 'sexp) (error-type? base)) + (cat val)) + ((eq? base 'boolean) + (cat "sexp_make_boolean(" val ")")) + ((eq? base 'time_t) + (cat "sexp_make_integer(ctx, sexp_shift_epoch(" val "))")) + ((unsigned-int-type? base) + (cat "sexp_make_unsigned_integer(ctx, " val ")")) + ((signed-int-type? base) + (cat "sexp_make_integer(ctx, " val ")")) + ((eq? base 'char) + (if (type-array type) + (cat "sexp_c_string(ctx, " val ", -1)") + (cat "sexp_make_character(ctx, " val ")"))) + ((eq? 'env-string base) + (cat "(p=strchr(" val ", '=') ? " + "sexp_cons(ctx, str=sexp_c_string(ctx, " val ", p - " val "), str=sexp_c_string(ctx, p, -1))" + " : sexp_cons(ctx, str=" val ", SEXP_FALSE)")) + ((string-type? base) + (cat "sexp_c_string(ctx, " val ", -1)")) + ((eq? 'input-port base) + (cat "sexp_make_input_port(ctx, " val ", SEXP_FALSE)")) + ((eq? 'output-port base) + (cat "sexp_make_output_port(ctx, " val ", SEXP_FALSE)")) + (else + (let ((ctype (assq base *types*)) + (void*? (void-pointer-type? type))) + (cond + ((or ctype void*?) + (cat "sexp_make_cpointer(ctx, " + (if void*? "SEXP_CPOINTER" (type-id-name base)) ", " + val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", " + (if (or (type-free? type) + (and (type-result? type) (not (basic-type? type)))) + 1 + 0) + ")")) + (else + (error "unknown type" base)))))))) + +(define (scheme->c-converter type val) + (let* ((type (parse-type type)) + (base (type-base type))) + (cond + ((eq? base 'sexp) + (cat val)) + ((eq? base 'boolean) + (cat "sexp_truep(" val ")")) + ((eq? base 'time_t) + (cat "sexp_unshift_epoch(sexp_uint_value(" val "))")) + ((signed-int-type? base) + (cat "sexp_sint_value(" val ")")) + ((unsigned-int-type? base) + (cat "sexp_uint_value(" val ")")) + ((eq? base 'char) + (cat "sexp_unbox_character(" val ")")) + ((eq? base 'env-string) + (cat "sexp_concat_env_string(" val ")")) + ((string-type? base) + (cat "sexp_string_data(" val ")")) + ((eq? base 'port-or-fd) + (cat "(sexp_portp(" val ") ? fileno(sexp_port_stream(" val "))" + " : sexp_unbox_fixnum(" val "))")) + ((port-type? base) + (cat "sexp_port_stream(" val ")")) + (else + (let ((ctype (assq base *types*)) + (void*? (void-pointer-type? type))) + (cond + ((or ctype void*?) + (cat "(" (type-c-name type) ")" + (if (type-null? type) + "sexp_cpointer_maybe_null_value" + "sexp_cpointer_value") + "(" val ")")) + (else + (error "unknown type" base)))))))) + +(define (type-predicate type) + (let ((base (type-base (parse-type type)))) + (cond + ((int-type? base) "sexp_exact_integerp") + ((float-type? base) "sexp_flonump") + ((string-type? base) "sexp_stringp") + ((eq? base 'char) "sexp_charp") + ((eq? base 'boolean) "sexp_booleanp") + ((eq? base 'port) "sexp_portp") + ((eq? base 'input-port) "sexp_iportp") + ((eq? base 'output-port) "sexp_oportp") + (else #f)))) + +(define (type-name type) + (let ((base (type-base (parse-type type)))) + (cond + ((int-type? base) "integer") + ((float-type? base) "flonum") + ((eq? 'boolean base) "int") + (else base)))) + +(define (base-type-c-name base) + (case base + ((string env-string non-null-string) "char*") + (else (symbol->string base)))) + +(define (type-struct-type type) + (let ((type-spec (assq (if (vector? type) (type-base type) type) *types*))) + (cond ((and type-spec (memq 'type: type-spec)) => cadr) + (else #f)))) + +(define (type-c-name type) + (let* ((type (parse-type type)) + (base (type-base type)) + (type-spec (assq base *types*)) + (struct-type (type-struct-type type))) + (string-append + (if (type-const? type) "const " "") + (if struct-type (string-append (symbol->string struct-type) " ") "") + (string-replace (base-type-c-name base) #\- " ") + (if struct-type "*" "") + (if (type-pointer? type) "*" "")))) + +(define (check-type arg type) + (let* ((type (parse-type type)) + (base (type-base type))) + (cond + ((eq? base 'env-string) + (cat "(sexp_pairp(" arg ") && sexp_stringp(sexp_car(" arg + ")) && sexp_stringp(sexp_cdr(" arg ")))")) + ((or (int-type? base) (float-type? base) + (string-type? base) (port-type? base)) + (cat (type-predicate type) "(" arg ")")) + ((or (assq base *types*) (void-pointer-type? type)) + (cat + (if (type-null? type) "(" "") + "(sexp_pointerp(" arg ")" + " && (sexp_pointer_tag(" arg ") == " + (if (void-pointer-type? type) "SEXP_CPOINTER" (type-id-name base)) "))" + (lambda () (if (type-null? type) (cat " || sexp_not(" arg "))"))))) + (else + (display "WARNING: don't know how to check: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)) + (cat "1"))))) + +(define (type-id-number type) + (let ((base (type-base type))) + (cond + ((int-type? base) "SEXP_FIXNUM") + ((float-type? base) "SEXP_FLONUM") + ((string-type? base) "SEXP_STRING") + ((eq? base 'char) "SEXP_CHAR") + ((eq? base 'boolean) "SEXP_BOOLEAN") + ((eq? base 'port) "SEXP_IPORT") + ((eq? base 'input-port) "SEXP_IPORT") + ((eq? base 'output-port) "SEXP_OPORT") + ((void-pointer-type? type) "SEXP_CPOINTER") + (else (type-id-name base))))) + +(define (write-validator arg type) + (let* ((type (parse-type type)) + (array (type-array type)) + (base-type (type-base type))) + (cond + ((and array (not (string-type? type))) + (cond + ((number? array) + (cat " if (!sexp_listp(ctx, " arg ")" + " || sexp_unbox_fixnum(sexp_length(" arg ")) != " array ")\n" + " return sexp_type_exception(ctx, self, SEXP_PAIR, " arg ");\n"))) + (cat " for (res=" arg "; sexp_pairp(res); res=sexp_cdr(res))\n" + " if (! " (lambda () (check-type "sexp_car(res)" type)) ")\n" + " return sexp_xtype_exception(ctx, self, \"not a list of " + (type-name type) "s\", " arg ");\n") + (if (not (number? array)) + (cat " if (! sexp_nullp(res))\n" + " return sexp_xtype_exception(ctx, self, \"not a list of " + (type-name type) "s\", " arg ");\n"))) + ((eq? base-type 'port-or-fd) + (cat " if (! (sexp_portp(" arg ") || sexp_fixnump(" arg ")))\n" + " return sexp_xtype_exception(ctx, self, \"not a port or file descriptor\"," arg ");\n")) + ((or (int-type? base-type) + (float-type? base-type) + (string-type? base-type) + (port-type? base-type)) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, self, " + (type-id-number type) ", " arg ");\n")) + ((or (assq base-type *types*) (void-pointer-type? type)) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, self, " + (type-id-number type) ", " arg ");\n")) + ((eq? 'sexp base-type)) + ((string-type? type) + (write-validator arg 'string)) + (else + (display "WARNING: don't know how to validate: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)))))) + +(define (write-parameters args) + (lambda () (for-each (lambda (a) (cat ", sexp arg" (type-index a))) args))) + +(define (get-array-length func x) + (let ((len (if (pair? (type-array x)) + (car (reverse (type-array x))) + (type-array x)))) + (if (number? len) + len + (and (symbol? len) + (let* ((str (symbol->string len)) + (len2 (string-length str))) + (and (> len2 3) + (string=? "arg" (substring str 0 3)) + (let ((i (string->number (substring str 3 len2)))) + (if i + (let ((y (list-ref (func-c-args func) i))) + (or (type-value y) len)))))))))) + +(define (write-locals func) + (define (arg-res x) + (string-append "res" (type-index-string x))) + (let* ((ret-type (func-ret-type func)) + (results (func-results func)) + (scheme-args (func-scheme-args func)) + (return-res? (not (error-type? (type-base ret-type)))) + (preserve-res? (> (+ (length results)) (if return-res? 0 1))) + (single-res? (and (= 1 (length results)) (not return-res?))) + (tmp-string? (any (lambda (a) + (and (type-array a) + (string-type? (type-base a)))) + (cons ret-type results))) + (gc-vars (map arg-res results)) + (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) + (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) + (sexps (if preserve-res? '() '("res"))) + (num-gc-vars (length gc-vars)) + (ints (if (or return-res? + (memq (type-base ret-type) + '(non-null-string non-null-pointer))) + '() + '("err"))) + (ints (if (or (array-type? ret-type) + (any array-type? results) + (any array-type? scheme-args)) + (cons "i" ints) + ints))) + (case (type-base ret-type) + ((non-null-string) (cat " char *err;\n")) + ((non-null-pointer) (cat " void *err;\n"))) + (cond + ((pair? ints) + (cat " int " (car ints)) + (for-each (lambda (x) (display ", ") (display x)) (cdr ints)) + (cat ";\n"))) + (if (any (lambda (a) (eq? 'env-string (type-base a))) + (cons ret-type results)) + (cat " char *p;\n")) + (for-each + (lambda (x) + (let ((len (get-array-length func x))) + (cat " " (type-c-name (type-base x)) " ") + (if (or (and (type-array x) (not (number? len))) (type-pointer? x)) + (cat "*")) + (cat (if (type-auto-expand? x) "buf" "tmp") (type-index-string x)) + (if (number? len) + (cat "[" len "]")) + (cat ";\n") + (if (or (vector? len) (type-auto-expand? x)) + (cat " int len" (type-index x) ";\n")) + (if (type-auto-expand? x) + (cat " " (type-c-name (type-base x)) + " *tmp" (type-index-string x) ";\n")))) + (append (if (or (type-array ret-type) (type-pointer? ret-type)) + (list ret-type) + '()) + results + (remove type-result? (filter type-array scheme-args)))) + (for-each + (lambda (arg) + (cond + ((and (type-pointer? arg) (basic-type? arg)) + (cat " " (type-c-name (type-base arg)) + " tmp" (type-index arg) ";\n")))) + scheme-args) + (cond + ((pair? sexps) + (cat " sexp " (car sexps)) + (for-each (lambda (x) (display ", ") (display x)) (cdr sexps)) + (cat ";\n"))) + (cond + ((pair? gc-vars) + (cat " sexp_gc_var" num-gc-vars "(") + (display (car gc-vars)) + (for-each (lambda (x) (display ", ") (display x)) (cdr gc-vars)) + (cat ");\n") + (cat " sexp_gc_preserve" num-gc-vars "(ctx") + (for-each (lambda (x) (display ", ") (display x)) gc-vars) + (cat ");\n"))))) + +(define (write-validators args) + (for-each + (lambda (a) + (write-validator (string-append "arg" (type-index-string a)) a)) + args)) + +(define (write-temporaries func) + (for-each + (lambda (a) + (let ((len (and (type-array a) (get-array-length func a)))) + (cond + ((and (type-array a) (or (vector? len) (type-auto-expand? a))) + (cat " len" (type-index a) " = " + (lambda () + (if (number? len) (cat len) (scheme->c-converter 'int len))) + ";\n" + " tmp" (type-index a) " = buf" (type-index a) ";\n"))) + (cond + ((and (not (type-result? a)) (type-array a) (not (string-type? a))) + (if (not (number? (type-array a))) + (cat " tmp" (type-index a) + " = (" (type-c-name (type-base a)) "*) malloc(" + "(sexp_unbox_fixnum(sexp_length(ctx, arg" (type-index a) + "))+1) * sizeof(tmp" (type-index a) "[0]));\n")) + (cat " for (i=0, res=arg" (type-index a) + "; sexp_pairp(res); res=sexp_cdr(res), i++) {\n" + " tmp" (type-index a) "[i] = " + (lambda () (scheme->c-converter (type-base a) "sexp_car(res)")) + ";\n" + " }\n") + (if (not (number? (type-array a))) + (cat " tmp" (type-index a) "[i] = NULL;\n"))) + ((and (type-result? a) (not (basic-type? a)) + (not (type-free? a)) ;;(not (type-pointer? a)) + (not (type-auto-expand? a)) + (or (not (type-array a)) + (not (integer? len)))) + (cat " tmp" (type-index a) " = malloc(" + (if (and (symbol? len) (not (eq? len 'null))) + (lambda () (cat (lambda () (scheme->c-converter 'unsigned-int len)) + "*sizeof(tmp" (type-index a) "[0])")) + (lambda () (cat "sizeof(tmp" (type-index a) "[0])"))) + ");\n")) + ((and (type-pointer? a) (basic-type? a)) + (cat " tmp" (type-index a) " = " + (lambda () + (scheme->c-converter + a + (string-append "arg" (type-index-string a)))) + ";\n"))))) + (func-c-args func))) + +(define (write-actual-parameter func arg) + (cond + ((and (not (type-default? arg)) (type-value arg)) + => (lambda (x) + (cond + ((any (lambda (y) + (and (type-array y) + (type-auto-expand? y) + (eq? x (get-array-length func y)))) + (func-c-args func)) + => (lambda (y) (cat "len" (type-index y)))) + (else (write x))))) + ((or (type-result? arg) (type-array arg)) + (cat (if (or (type-free? arg) (basic-type? arg)) ;; (type-pointer? arg) + "&" + "") + "tmp" (type-index arg))) + ((and (type-pointer? arg) (basic-type? arg)) + (cat "&tmp" (type-index arg))) + (else + (scheme->c-converter + arg + (string-append "arg" (type-index-string arg)))))) + +(define (write-call func) + (let ((ret-type (func-ret-type func)) + (c-name (func-c-name func)) + (c-args (func-c-args func))) + (if (any type-auto-expand? (func-c-args func)) + (cat " loop:\n")) + (cat (cond ((error-type? (type-base ret-type)) " err = ") + ((type-array ret-type) " tmp = ") + (else " res = "))) + ((if (type-array ret-type) + (lambda (t f x) (f)) + c->scheme-converter) + ret-type + (lambda () + (cat c-name "(") + (for-each + (lambda (arg) + (if (> (type-index arg) 0) (cat ", ")) + (write-actual-parameter func arg)) + c-args) + (cat ")")) + (cond + ((any type-link? (func-c-args func)) + => (lambda (a) (string-append "arg" (type-index-string a)))) + (else #f))) + (cat ";\n") + (if (type-array ret-type) + (write-result ret-type)))) + +(define (write-result result) + (let ((res (string-append "res" (type-index-string result))) + (tmp (string-append "tmp" (type-index-string result)))) + (cond + ((and (type-array result) (eq? 'char (type-base result))) + (cat " " res " = " (lambda () (c->scheme-converter result tmp)) ";\n")) + ((type-array result) + (cat " " res " = SEXP_NULL;\n") + (let ((auto-expand? + (and (pair? (type-array result)) + (memq 'auto-expand (type-array result)))) + (len (if (pair? (type-array result)) + (car (reverse (type-array result))) + (type-array result)))) + (cond + ((eq? 'null len) + (cat " for (i=0; " tmp "[i]; i++) {\n" + " sexp_push(ctx, " res ", " + (if (eq? 'string (type-base result)) + "str=" + (lambda () (cat "SEXP_VOID);\n sexp_car(" res ") = "))) + (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]")))) + ");\n" + " }\n" + " " res " = sexp_nreverse(ctx, " res ");\n")) + (else + (cat " for (i=" len "-1; i>=0; i--) {\n" + " sexp_push(ctx, " res ", SEXP_VOID);\n" + " sexp_car(" res ") = " + (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]")))) + ";\n" + " }\n"))))) + (else + (cat " " res " = ") + (c->scheme-converter + result + (string-append "tmp" (type-index-string result))) + (cat ";\n"))))) + +(define (write-results func) + (let ((error-res? (error-type? (type-base (func-ret-type func)))) + (results (func-results func))) + (if error-res? + (cat " if (" + (if (memq (type-base (func-ret-type func)) + '(non-null-string non-null-pointer)) + "!" + "") + "err) {\n" + (cond + ((any type-auto-expand? (func-c-args func)) + => (lambda (a) + (lambda () + (let ((len (get-array-length func a)) + (i (type-index a))) + (if (number? len) + (cat " if (len" i " != " len ")\n" + " free(tmp" i ");\n")) + (cat " len" i " *= 2;\n" + " tmp" i + " = malloc(len" i "*sizeof(tmp" i "[0]));\n" + " goto loop;\n"))))) + (else + " res = SEXP_FALSE;\n")) + " } else {\n")) + (if (null? results) + (if error-res? + (cat " res = SEXP_TRUE;\n")) + (for-each write-result results)) + (cond + ((> (length results) (if error-res? 1 0)) + (if error-res? + (cat " res = SEXP_NULL;\n") + (cat " res = sexp_cons(ctx, res, SEXP_NULL);\n")) + (for-each + (lambda (x) + (if error-res? + (cat " sexp_push(ctx, res, res" (type-index x) ");\n") + (cat " sexp_push(ctx, res, sexp_car(res));\n" + " sexp_cadr(res) = res" (type-index x) ";\n"))) + (reverse results))) + ((pair? results) + (cat " res = res" (type-index (car results)) ";\n"))) + (if error-res? + (cat " }\n")))) + +(define (write-free type) + (if (type-array type) + (cat " free(tmp" (type-index-string type) ");\n"))) + +(define (write-cleanup func) + (for-each write-free (func-scheme-args func)) + (for-each + (lambda (a) + (cond + ((type-auto-expand? a) + (let ((len (get-array-length func a)) + (i (type-index a))) + (if (number? len) + (cat " if (len" i " != " len ")\n" + " free(tmp" i ");\n")))) + ((and (type-result? a) (not (basic-type? a)) + (not (assq (type-base a) *types*)) + (not (type-free? a)) (not (type-pointer? a)) + (or (not (type-array a)) + (not (integer? (get-array-length func a))))) + ;; the above is hairy - basically this frees temporary strings + (cat " free(tmp" (type-index a) ");\n")))) + (func-c-args func)) + (let* ((results (func-results func)) + (return-res? (not (error-type? (type-base (func-ret-type func))))) + (preserve-res? (> (+ (length results)) (if return-res? 0 1))) + (single-res? (and (= 1 (length results)) (not return-res?))) + (tmp-string? (any (lambda (a) + (and (type-array a) + (string-type? (type-base a)))) + (cons (func-ret-type func) + (func-results func)))) + (gc-vars results) + (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) + (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) + (num-gc-vars (length gc-vars))) + (cond + ((pair? gc-vars) + (cat " sexp_gc_release" num-gc-vars "(ctx);\n"))))) + +(define (write-func func) + (cat "static sexp " (func-stub-name func) + " (sexp ctx sexp_api_params(self, n)" + (write-parameters (func-scheme-args func)) ") {\n") + (write-locals func) + (write-validators (func-scheme-args func)) + (write-temporaries func) + (write-call func) + (write-results func) + (write-cleanup func) + (cat " return res;\n" + "}\n\n")) + +(define (parameter-default? x) + (and (pair? x) + (member x '((current-input-port) + (current-output-port) + (current-error-port))))) + +(define (write-default x) ;; this is a hack but very convenient + (lambda () + (let ((value (type-value x))) + (cond + ((equal? value '(current-input-port)) + (cat "\"*current-input-port*\"")) + ((equal? value '(current-output-port)) + (cat "\"*current-output-port*\"")) + ((equal? value '(current-error-port)) + (cat "\"*current-error-port*\"")) + (else + (c->scheme-converter x value)))))) + +(define (write-func-binding func) + (let ((default (and (pair? (func-scheme-args func)) + (type-default? (car (reverse (func-scheme-args func)))) + (car (reverse (func-scheme-args func)))))) + (cat (if default + (if (parameter-default? (type-value default)) + " sexp_define_foreign_param(ctx, env, " + " sexp_define_foreign_opt(ctx, env, ") + " sexp_define_foreign(ctx, env, ") + (lambda () (write (symbol->string (func-scheme-name func)))) + ", " (length (func-scheme-args func)) ", " + (if default "(sexp_proc1)" "") + (func-stub-name func) + (if default ", " "") + (if default (write-default default) "") + ");\n"))) + +(define (write-type type) + (let ((name (car type)) + (type (cdr type))) + (cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n" + " " (type-id-name name) + " = sexp_unbox_fixnum(sexp_type_tag(sexp_register_c_type(ctx, name, " + (cond ((memq 'finalizer: type) + => (lambda (x) (generate-stub-name (cadr x)))) + (else "sexp_finalize_c_type")) + ")));\n") + (cond + ((memq 'predicate: type) + => (lambda (x) + (let ((pred (cadr x))) + (cat " tmp = sexp_make_type_predicate(ctx, name, " + "sexp_make_fixnum(" (type-id-name name) "));\n" + " name = sexp_intern(ctx, \"" pred "\", " + (string-length (x->string pred)) ");\n" + " sexp_env_define(ctx, env, name, tmp);\n"))))))) + +(define (type-getter-name type name field) + (string-append "sexp_" (x->string (type-name (parse-type name))) + "_get_" (x->string (type-base (parse-type (cadr field)))))) + +(define (write-type-getter type name field) + (cat "static sexp " (type-getter-name type name field) + " (sexp ctx sexp_api_params(self, n), sexp x) {\n" + (lambda () (write-validator "x" name)) + " return " + (lambda () + (c->scheme-converter + (car field) + (string-append (if (type-struct? (car field)) "&" "") + "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" + "sexp_cpointer_value(x))" "->" + (x->string (cadr field))) + (and (or (type-struct? (car field)) (type-link? (car field))) "x"))) + ";\n" + "}\n\n")) + +(define (type-setter-name type name field) + (string-append "sexp_" (x->string (type-name (parse-type name))) + "_set_" (x->string (type-base (parse-type (cadr field)))))) + +(define (write-type-setter-assignment type name field dst val) + (cond + ((type-struct? (car field)) + ;; assign to a nested struct - copy field-by-field + (let ((field-type + (cond ((assq (type-name (car field)) *types*) => cdddr) + (else (cdr field))))) + (lambda () + (for-each + (lambda (subfield) + (let ((subname (x->string (cadr subfield)))) + (cat + " " + (string-append dst "." (x->string (cadr subfield))) + " = " + (string-append + "((" (x->string (or (type-struct-type (type-name (car field))) "")) + " " (mangle (type-name (car field))) "*)" "sexp_cpointer_value(" val "))" + "->" (x->string (cadr subfield))) + ";\n"))) + (struct-fields field-type))))) + (else + (lambda () + (cat " " dst " = " (lambda () (scheme->c-converter (car field) val)) ";\n"))))) + +(define (write-type-setter type name field) + (cat "static sexp " (type-setter-name type name field) + " (sexp ctx sexp_api_params(self, n), sexp x, sexp v) {\n" + (lambda () (write-validator "x" name)) + (lambda () (write-validator "v" (car field))) + (write-type-setter-assignment + type name field + (string-append "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" "sexp_cpointer_value(x))" + "->" (x->string (cadr field))) + "v") + " return SEXP_VOID;\n" + "}\n\n")) + +(define (write-type-funcs orig-type) + (let ((name (car orig-type)) + (type (cdr orig-type))) + ;; maybe write finalizer + (cond + ((memq 'finalizer: type) + => (lambda (x) + (cat "static sexp " (generate-stub-name (cadr x)) + " (sexp ctx sexp_api_params(self, n), sexp x) {\n" + " if (sexp_cpointer_freep(x))\n" + " " (cadr x) "(sexp_cpointer_value(x));\n" + " return SEXP_VOID;\n" + "}\n\n")))) + ;; maybe write constructor + (cond + ((memq 'constructor: type) + => (lambda (x) + (let ((make (caadr x)) + (args (cdadr x))) + (cat "static sexp " (generate-stub-name make) + " (sexp ctx sexp_api_params(self, n)" + (lambda () + (let lp ((ls args) (i 0)) + (cond ((pair? ls) + (cat ", sexp arg" i) + (lp (cdr ls) (+ i 1)))))) + ") {\n" + " " (or (type-struct-type name) "") " " (type-name name) " *r;\n" + " sexp_gc_var1(res);\n" + " sexp_gc_preserve1(ctx, res);\n" + ;; " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), " + ;; (type-id-name name) + ;; ");\n" + ;; " r = sexp_cpointer_value(res) = sexp_cpointer_body(res);\n" + " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), " + (type-id-name name) + ");\n" + " r = sexp_cpointer_value(res) = malloc(sizeof(" + (or (type-struct-type name) "") " " (type-name name) "));\n" + " sexp_freep(res) = 1;\n" + (lambda () + (let lp ((ls args) (i 0)) + (cond + ((pair? ls) + (let* ((a (car ls)) + (field + (any (lambda (f) (and (pair? f) (eq? a (cadr f)))) + (cddr x)))) + (if field + (cat " r->" (cadr field) " = " + (lambda () + (scheme->c-converter + (car field) + (string-append "arg" + (number->string i)))) + ";\n")) + (lp (cdr ls) (+ i 1))))))) + " sexp_gc_release1(ctx);\n" + " return res;\n" + "}\n\n") + (set! *funcs* + (cons (parse-func `(void ,make ,args)) *funcs*)))))) + ;; write field accessors + (for-each + (lambda (field) + (cond + ((and (pair? field) (pair? (cdr field))) + (cond + ((and (pair? (cddr field)) (caddr field)) + (write-type-getter type name field) + (set! *funcs* + (cons (parse-func + `(,(car field) + (,(caddr field) + #f + ,(type-getter-name type name field)) + (,name))) + *funcs*)))) + (cond + ((and (pair? (cddr field)) + (pair? (cdddr field)) + (car (cdddr field))) + (write-type-setter type name field) + (set! *funcs* + (cons (parse-func + `(,(car field) + (,(car (cdddr field)) + #f + ,(type-setter-name type name field)) + (,name ,(car field)))) + *funcs*))))))) + (struct-fields type)))) + +(define (write-const const) + (let ((scheme-name (if (pair? (cadr const)) (caadr const) (cadr const))) + (c-name (if (pair? (cadr const)) (cadadr const) (mangle (cadr const))))) + (cat " name = sexp_intern(ctx, \"" scheme-name "\", " + (string-length (x->string scheme-name)) ");\n" + " sexp_env_define(ctx, env, name, tmp=" + (lambda () (c->scheme-converter (car const) c-name)) ");\n"))) + +(define (write-utilities) + (define (input-env-string? x) + (and (eq? 'env-string (type-base x)) (not (type-result? x)))) + (cond + ((any (lambda (f) + (or (any input-env-string? (func-results f)) + (any input-env-string? (func-scheme-args f)))) + *funcs*) + (cat "static char* sexp_concat_env_string (sexp x) {\n" + " int klen=sexp_string_length(sexp_car(x)), vlen=sexp_string_length(sexp_cdr(x));\n" + " char *res = (char*) malloc(klen+vlen+2);\n" + " strncpy(res, sexp_string_data(sexp_car(x)), klen);\n" + " res[sexp_string_length(sexp_car(x))] = '=';\n" + " strncpy(res+sexp_string_length(sexp_car(x)), sexp_string_data(sexp_cdr(x)), vlen);\n" + " res[len-1] = '\\0';\n" + " return res;\n" + "}\n\n")))) + +(define (write-init) + (newline) + (write-utilities) + (for-each write-func *funcs*) + (for-each write-type-funcs *types*) + (cat "sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {\n" + " sexp_gc_var2(name, tmp);\n" + " sexp_gc_preserve2(ctx, name, tmp);\n") + (for-each write-const *consts*) + (for-each write-type *types*) + (for-each write-func-binding *funcs*) + (for-each (lambda (x) (cat " " x "\n")) (reverse *inits*)) + (cat " sexp_gc_release2(ctx);\n" + " return SEXP_VOID;\n" + "}\n\n")) + +(define (generate file) + (display "/* automatically generated by chibi genstubs */\n") + (c-system-include "chibi/eval.h") + (load file) + (write-init)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; main + +(define (main args) + (case (length args) + ((1) + (with-output-to-file (string-append (strip-extension (car args)) ".c") + (lambda () (generate (car args))))) + ((2) + (if (equal? "-" (cadr args)) + (generate (car args)) + (with-output-to-file (cadr args) (lambda () (generate (car args)))))) + (else + (error "usage: genstubs []")))) diff --git a/vm.c b/vm.c new file mode 100644 index 00000000..acbea8b2 --- /dev/null +++ b/vm.c @@ -0,0 +1,1391 @@ +/* vm.c -- stack-based virtual machine backend */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#if SEXP_USE_DEBUG_VM > 1 +static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) { + int i; + if (! sexp_oportp(out)) out = sexp_current_error_port(ctx); + for (i=0; i4; i=sexp_unbox_fixnum(stack[i+3])) { + self = stack[i+2]; + if (sexp_procedurep(self)) { + sexp_write_string(ctx, " called from ", out); + bc = sexp_procedure_code(self); + if (sexp_truep(sexp_bytecode_name(bc))) + sexp_write(ctx, sexp_bytecode_name(bc), out); + else + sexp_write_string(ctx, "", out); + if ((ls=sexp_bytecode_source(bc)) && sexp_pairp(ls)) { + if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) { + sexp_write_string(ctx, " on line ", out); + sexp_write(ctx, sexp_cdr(ls), out); + } + if (sexp_stringp(sexp_car(ls))) { + sexp_write_string(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_car(ls)), out); + } + } + sexp_write_char(ctx, '\n', out); + } + } +} + +/************************* code generation ****************************/ + +static void emit_word (sexp ctx, sexp_uint_t val) { + unsigned char *data; + expand_bcode(ctx, sizeof(sexp)); + data = sexp_bytecode_data(sexp_context_bc(ctx)); + sexp_context_align_pos(ctx); + *((sexp_uint_t*)(&(data[sexp_context_pos(ctx)]))) = val; + sexp_context_pos(ctx) += sizeof(sexp); +} + +static void emit_push (sexp ctx, sexp obj) { + emit(ctx, SEXP_OP_PUSH); + emit_word(ctx, (sexp_uint_t)obj); + if (sexp_pointerp(obj) && ! sexp_symbolp(obj)) + sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), obj); +} + +static void emit_enter (sexp ctx) {return;} +static void bless_bytecode (sexp ctx, sexp bc) {return;} + +static void emit_return (sexp ctx) { + emit(ctx, SEXP_OP_RET); +} + +static sexp_sint_t sexp_context_make_label (sexp ctx) { + sexp_sint_t label; + sexp_context_align_pos(ctx); + label = sexp_context_pos(ctx); + sexp_context_pos(ctx) += sizeof(sexp_uint_t); + return label; +} + +static void sexp_context_patch_label (sexp ctx, sexp_sint_t label) { + sexp bc = sexp_context_bc(ctx); + unsigned char *data = sexp_bytecode_data(bc)+label; + *((sexp_sint_t*)data) = sexp_context_pos(ctx)-label; +} + +static void generate_lit (sexp ctx, sexp value) { + emit_push(ctx, value); +} + +static void generate_seq (sexp ctx, sexp app) { + sexp head=app, tail=sexp_cdr(app); + sexp_uint_t tailp = sexp_context_tailp(ctx); + sexp_context_tailp(ctx) = 0; + for ( ; sexp_pairp(tail); head=tail, tail=sexp_cdr(tail)) + if (sexp_pointerp(sexp_car(head)) && (! sexp_litp(sexp_car(head)))) { + generate(ctx, sexp_car(head)); + emit(ctx, SEXP_OP_DROP); + sexp_context_depth(ctx)--; + } + sexp_context_tailp(ctx) = tailp; + generate(ctx, sexp_car(head)); +} + +static void generate_cnd (sexp ctx, sexp cnd) { + sexp_sint_t label1, label2, tailp=sexp_context_tailp(ctx); + sexp_context_tailp(ctx) = 0; + generate(ctx, sexp_cnd_test(cnd)); + sexp_context_tailp(ctx) = tailp; + emit(ctx, SEXP_OP_JUMP_UNLESS); + sexp_context_depth(ctx)--; + label1 = sexp_context_make_label(ctx); + generate(ctx, sexp_cnd_pass(cnd)); + sexp_context_tailp(ctx) = tailp; + emit(ctx, SEXP_OP_JUMP); + sexp_context_depth(ctx)--; + label2 = sexp_context_make_label(ctx); + sexp_context_patch_label(ctx, label1); + generate(ctx, sexp_cnd_fail(cnd)); + sexp_context_patch_label(ctx, label2); +} + +static void generate_non_global_ref (sexp ctx, sexp name, sexp cell, + sexp lambda, sexp fv, int unboxp) { + sexp_uint_t i; + sexp loc = sexp_cdr(cell); + if (loc == lambda && sexp_lambdap(lambda)) { + /* local ref */ + emit(ctx, SEXP_OP_LOCAL_REF); + emit_word(ctx, sexp_param_index(lambda, name)); + } else { + /* closure ref */ + for (i=0; sexp_pairp(fv); fv=sexp_cdr(fv), i++) + if ((name == sexp_ref_name(sexp_car(fv))) + && (loc == sexp_ref_loc(sexp_car(fv)))) + break; + emit(ctx, SEXP_OP_CLOSURE_REF); + emit_word(ctx, i); + } + if (unboxp && (sexp_memq(ctx, name, sexp_lambda_sv(loc)) != SEXP_FALSE)) + emit(ctx, SEXP_OP_CDR); + sexp_context_depth(ctx)++; +} + +static void generate_ref (sexp ctx, sexp ref, int unboxp) { + sexp lam; + if (! sexp_lambdap(sexp_ref_loc(ref))) { + /* global ref */ + if (unboxp) { + emit(ctx, + (sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF) + ? SEXP_OP_GLOBAL_REF : SEXP_OP_GLOBAL_KNOWN_REF); + emit_word(ctx, (sexp_uint_t)sexp_ref_cell(ref)); + } else + emit_push(ctx, sexp_ref_cell(ref)); + } else { + lam = sexp_context_lambda(ctx); + generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref), + lam, sexp_lambda_fv(lam), unboxp); + } +} + +static void generate_set (sexp ctx, sexp set) { + sexp ref = sexp_set_var(set), lambda; + /* compile the value */ + sexp_context_tailp(ctx) = 0; + if (sexp_lambdap(sexp_set_value(set))) + sexp_lambda_name(sexp_set_value(set)) = sexp_ref_name(ref); + generate(ctx, sexp_set_value(set)); + if (! sexp_lambdap(sexp_ref_loc(ref))) { + /* global vars are set directly */ + emit_push(ctx, sexp_ref_cell(ref)); + emit(ctx, SEXP_OP_SET_CDR); + } else { + lambda = sexp_ref_loc(ref); + if (sexp_truep(sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)))) { + /* stack or closure mutable vars are boxed */ + generate_ref(ctx, ref, 0); + emit(ctx, SEXP_OP_SET_CDR); + } else { + /* internally defined variable */ + emit(ctx, SEXP_OP_LOCAL_SET); + emit_word(ctx, sexp_param_index(lambda, sexp_ref_name(ref))); + } + } + sexp_context_depth(ctx)--; +} + +static void generate_opcode_app (sexp ctx, sexp app) { + sexp op = sexp_car(app); + sexp_sint_t i, num_args, inv_default=0; + sexp_gc_var1(ls); + sexp_gc_preserve1(ctx, ls); + + num_args = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))); + sexp_context_tailp(ctx) = 0; + + /* maybe push the default for an optional argument */ + if ((num_args == sexp_opcode_num_args(op)) + && sexp_opcode_variadic_p(op) + && sexp_opcode_data(op) + && (sexp_opcode_class(op) != SEXP_OPC_PARAMETER)) { + if (sexp_opcode_inverse(op)) { + inv_default = 1; + } else { + emit_push(ctx, sexp_opcode_data(op)); + if (sexp_opcode_opt_param_p(op)) emit(ctx, SEXP_OP_CDR); + sexp_context_depth(ctx)++; + num_args++; + } + } + + /* push the arguments onto the stack in reverse order */ + ls = ((sexp_opcode_inverse(op) + && (sexp_opcode_class(op) != SEXP_OPC_ARITHMETIC)) + ? sexp_cdr(app) : sexp_reverse(ctx, sexp_cdr(app))); + for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) + generate(ctx, sexp_car(ls)); + + /* push the default for inverse opcodes */ + if (inv_default) { + emit_push(ctx, sexp_opcode_data(op)); + if (sexp_opcode_opt_param_p(op)) emit(ctx, SEXP_OP_CDR); + sexp_context_depth(ctx)++; + num_args++; + } + + /* emit the actual operator call */ + switch (sexp_opcode_class(op)) { + case SEXP_OPC_ARITHMETIC: + /* fold variadic arithmetic operators */ + for (i=num_args-1; i>0; i--) + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_ARITHMETIC_CMP: + if (num_args > 2) { + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, SEXP_OP_AND); + for (i=num_args-2; i>0; i--) { + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, SEXP_OP_AND); + emit(ctx, SEXP_OP_AND); + } + } else + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_FOREIGN: + emit(ctx, sexp_opcode_code(op)); + emit_word(ctx, (sexp_uint_t)op); + break; + case SEXP_OPC_TYPE_PREDICATE: + case SEXP_OPC_GETTER: + case SEXP_OPC_SETTER: + case SEXP_OPC_CONSTRUCTOR: + emit(ctx, sexp_opcode_code(op)); + if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR) + || sexp_opcode_code(op) == SEXP_OP_MAKE) { + if (sexp_opcode_data(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op))); + if (sexp_opcode_data2(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op))); + } + break; + case SEXP_OPC_PARAMETER: + emit_push(ctx, sexp_opcode_data(op)); + emit(ctx, ((num_args == 0) ? SEXP_OP_CDR : SEXP_OP_SET_CDR)); + break; + default: + emit(ctx, sexp_opcode_code(op)); + } + + sexp_context_depth(ctx) -= (num_args-1); + sexp_gc_release1(ctx); +} + +static void generate_general_app (sexp ctx, sexp app) { + sexp_uint_t len = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))), + tailp = sexp_context_tailp(ctx); + sexp_gc_var1(ls); + sexp_gc_preserve1(ctx, ls); + + /* push the arguments onto the stack */ + sexp_context_tailp(ctx) = 0; + for (ls=sexp_reverse(ctx, sexp_cdr(app)); sexp_pairp(ls); ls=sexp_cdr(ls)) + generate(ctx, sexp_car(ls)); + + /* push the operator onto the stack */ + generate(ctx, sexp_car(app)); + + /* maybe overwrite the current frame */ + emit(ctx, (tailp ? SEXP_OP_TAIL_CALL : SEXP_OP_CALL)); + emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len)); + + sexp_context_tailp(ctx) = tailp; + sexp_context_depth(ctx) -= len; + sexp_gc_release1(ctx); +} + +static void generate_app (sexp ctx, sexp app) { + if (sexp_opcodep(sexp_car(app))) + generate_opcode_app(ctx, app); + else + generate_general_app(ctx, app); +} + +static void generate_lambda (sexp ctx, sexp lambda) { + sexp ctx2, fv, ls, flags, len, ref, prev_lambda, prev_fv; + sexp_uint_t k; + sexp_gc_var2(tmp, bc); + sexp_gc_preserve2(ctx, tmp, bc); + prev_lambda = sexp_context_lambda(ctx); + prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL; + fv = sexp_lambda_fv(lambda); + ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx), 0); + sexp_context_lambda(ctx2) = lambda; + /* allocate space for local vars */ + for (ls=sexp_lambda_locals(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) + emit_push(ctx2, SEXP_VOID); + /* box mutable vars */ + for (ls=sexp_lambda_sv(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) { + k = sexp_param_index(lambda, sexp_car(ls)); + if (k >= 0) { + emit(ctx2, SEXP_OP_LOCAL_REF); + emit_word(ctx2, k); + emit_push(ctx2, sexp_car(ls)); + emit(ctx2, SEXP_OP_CONS); + emit(ctx2, SEXP_OP_LOCAL_SET); + emit_word(ctx2, k); + emit(ctx2, SEXP_OP_DROP); + } + } + sexp_context_tailp(ctx2) = 1; + generate(ctx2, sexp_lambda_body(lambda)); + flags = sexp_make_fixnum((sexp_listp(ctx2, sexp_lambda_params(lambda)) + == SEXP_FALSE) ? 1uL : 0uL); + len = sexp_length(ctx2, sexp_lambda_params(lambda)); + bc = finalize_bytecode(ctx2); + sexp_bytecode_name(bc) = sexp_lambda_name(lambda); + sexp_bytecode_source(bc) = sexp_lambda_source(lambda); + if (sexp_nullp(fv)) { + /* shortcut, no free vars */ + tmp = sexp_make_vector(ctx2, SEXP_ZERO, SEXP_VOID); + tmp = sexp_make_procedure(ctx2, flags, len, bc, tmp); + sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), tmp); + generate_lit(ctx, tmp); + } else { + /* push the closed vars */ + emit_push(ctx, SEXP_VOID); + emit_push(ctx, sexp_length(ctx, fv)); + emit(ctx, SEXP_OP_MAKE_VECTOR); + sexp_context_depth(ctx)--; + for (k=0; sexp_pairp(fv); fv=sexp_cdr(fv), k++) { + ref = sexp_car(fv); + generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref), + prev_lambda, prev_fv, 0); + emit_push(ctx, sexp_make_fixnum(k)); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, SEXP_OP_VECTOR_SET); + emit(ctx, SEXP_OP_DROP); + sexp_context_depth(ctx)--; + } + /* push the additional procedure info and make the closure */ + emit_push(ctx, bc); + emit_push(ctx, len); + emit_push(ctx, flags); + emit(ctx, SEXP_OP_MAKE_PROCEDURE); + } + sexp_gc_release2(ctx); +} + +static void generate (sexp ctx, sexp x) { + if (sexp_pointerp(x)) { + switch (sexp_pointer_tag(x)) { + case SEXP_PAIR: generate_app(ctx, x); break; + case SEXP_LAMBDA: generate_lambda(ctx, x); break; + case SEXP_CND: generate_cnd(ctx, x); break; + case SEXP_REF: generate_ref(ctx, x, 1); break; + case SEXP_SET: generate_set(ctx, x); break; + case SEXP_SEQ: generate_seq(ctx, sexp_seq_ls(x)); break; + case SEXP_LIT: generate_lit(ctx, sexp_lit_value(x)); break; + default: generate_lit(ctx, x); + } + } else { + generate_lit(ctx, x); + } +} + +static sexp make_param_list (sexp ctx, sexp_uint_t i) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; + for ( ; i>0; i--) + res = sexp_cons(ctx, sexp_make_fixnum(i), res); + sexp_gc_release1(ctx); + return res; +} + +static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { + sexp ls, bc, res, env; + sexp_gc_var5(params, ref, refs, lambda, ctx2); + if (i == sexp_opcode_num_args(op)) { /* return before preserving */ + if (sexp_opcode_proc(op)) return sexp_opcode_proc(op); + } else if (i < sexp_opcode_num_args(op)) { + return sexp_compile_error(ctx, "not enough args for opcode", op); + } else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */ + return sexp_compile_error(ctx, "too many args for opcode", op); + } + sexp_gc_preserve5(ctx, params, ref, refs, lambda, ctx2); + params = make_param_list(ctx, i); + lambda = sexp_make_lambda(ctx, params); + ctx2 = sexp_make_child_context(ctx, lambda); + env = sexp_extend_env(ctx2, sexp_context_env(ctx), params, lambda); + sexp_context_env(ctx2) = env; + for (ls=params, refs=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) { + ref = sexp_make_ref(ctx2, sexp_car(ls), sexp_env_cell(env, sexp_car(ls))); + sexp_push(ctx2, refs, ref); + } + refs = sexp_reverse(ctx2, refs); + refs = sexp_cons(ctx2, op, refs); + generate_opcode_app(ctx2, refs); + bc = finalize_bytecode(ctx2); + sexp_bytecode_name(bc) = sexp_c_string(ctx2, sexp_opcode_name(op), -1); + res=sexp_make_procedure(ctx2, SEXP_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID); + if (i == sexp_opcode_num_args(op)) + sexp_opcode_proc(op) = res; + sexp_gc_release5(ctx); + return res; +} + +/*********************** the virtual machine **************************/ + +static sexp sexp_save_stack (sexp ctx, sexp *stack, sexp_uint_t to) { + sexp res, *data; + sexp_uint_t i; + res = sexp_make_vector(ctx, sexp_make_fixnum(to), SEXP_VOID); + data = sexp_vector_data(res); + for (i=0; i= SEXP_INIT_STACK_SIZE) { + _ARG1 = sexp_global(ctx, SEXP_G_OOS_ERROR); + goto end_loop; + } +#endif + _ALIGN_IP(); + i = sexp_unbox_fixnum(_WORD0); + tmp1 = _ARG1; + make_call: + if (sexp_opcodep(tmp1)) { + /* compile non-inlined opcode applications on the fly */ + sexp_context_top(ctx) = top; + tmp1 = make_opcode_procedure(ctx, tmp1, i); + if (sexp_exceptionp(tmp1)) { + _ARG1 = tmp1; + goto call_error_handler; + } + } + if (! sexp_procedurep(tmp1)) + sexp_raise("non procedure application", sexp_list1(ctx, tmp1)); + j = i - sexp_unbox_fixnum(sexp_procedure_num_args(tmp1)); + if (j < 0) + sexp_raise("not enough args", + sexp_list2(ctx, tmp1, sexp_make_fixnum(i))); + if (j > 0) { + if (sexp_procedure_variadic_p(tmp1)) { + stack[top-i-1] = sexp_cons(ctx, stack[top-i-1], SEXP_NULL); + for (k=top-i; k=top-i; k--) + stack[k] = stack[k-1]; + stack[top-i-1] = SEXP_NULL; + top++; + i++; + } + _ARG1 = sexp_make_fixnum(i); + stack[top] = sexp_make_fixnum(ip+sizeof(sexp)-sexp_bytecode_data(bc)); + stack[top+1] = self; + stack[top+2] = sexp_make_fixnum(fp); + top += 3; + self = tmp1; + bc = sexp_procedure_code(self); + ip = sexp_bytecode_data(bc); + cp = sexp_procedure_vars(self); + fp = top-4; + break; + case SEXP_OP_FCALL0: + tmp1 = _WORD0; + _ALIGN_IP(); + sexp_context_top(ctx) = top; + sexp_context_last_fp(ctx) = fp; + _PUSH(((sexp_proc1)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 0))); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL1: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG1 = ((sexp_proc2)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 1), _ARG1); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL2: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG2 = ((sexp_proc3)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 2), _ARG1, _ARG2); + top--; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL3: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG3 = ((sexp_proc4)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 3), _ARG1, _ARG2, _ARG3); + top -= 2; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL4: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG4 = ((sexp_proc5)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 4), _ARG1, _ARG2, _ARG3, _ARG4); + top -= 3; + ip += sizeof(sexp); + sexp_check_exception(); + break; +#if SEXP_USE_EXTENDED_FCALL + case SEXP_OP_FCALLN: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + i = sexp_opcode_num_args(_WORD0); + tmp1 = sexp_fcall(ctx, self, i, _WORD0); + top -= (i-1); + _ARG1 = tmp1; + ip += sizeof(sexp); + sexp_check_exception(); + break; +#endif + case SEXP_OP_JUMP_UNLESS: + _ALIGN_IP(); + if (stack[--top] == SEXP_FALSE) + ip += _SWORD0; + else + ip += sizeof(sexp_sint_t); + break; + case SEXP_OP_JUMP: + _ALIGN_IP(); + ip += _SWORD0; + break; + case SEXP_OP_PUSH: + _ALIGN_IP(); + _PUSH(_WORD0); + ip += sizeof(sexp); + break; + case SEXP_OP_DROP: + top--; + break; + case SEXP_OP_GLOBAL_REF: + _ALIGN_IP(); + if (sexp_cdr(_WORD0) == SEXP_UNDEF) + sexp_raise("undefined variable", sexp_list1(ctx, sexp_car(_WORD0))); + /* ... FALLTHROUGH ... */ + case SEXP_OP_GLOBAL_KNOWN_REF: + _ALIGN_IP(); + _PUSH(sexp_cdr(_WORD0)); + ip += sizeof(sexp); + break; + case SEXP_OP_STACK_REF: /* `pick' in forth */ + _ALIGN_IP(); + stack[top] = stack[top - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case SEXP_OP_LOCAL_REF: + _ALIGN_IP(); + stack[top] = stack[fp - 1 - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case SEXP_OP_LOCAL_SET: + _ALIGN_IP(); + stack[fp - 1 - _SWORD0] = _ARG1; + _ARG1 = SEXP_VOID; + ip += sizeof(sexp); + break; + case SEXP_OP_CLOSURE_REF: + _ALIGN_IP(); + _PUSH(sexp_vector_ref(cp, sexp_make_fixnum(_WORD0))); + ip += sizeof(sexp); + break; + case SEXP_OP_VECTOR_REF: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-ref: not a vector", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("vector-ref: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + sexp_raise("vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_vector_ref(_ARG1, _ARG2); + top--; + break; + case SEXP_OP_VECTOR_SET: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-set!: not a vector", sexp_list1(ctx, _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("vector-set!: immutable vector", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("vector-set!: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + sexp_raise("vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + sexp_vector_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case SEXP_OP_VECTOR_LENGTH: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-length: not a vector", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_vector_length(_ARG1)); + break; + case SEXP_OP_BYTES_REF: + case SEXP_OP_STRING_REF: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-ref: not a string", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("string-ref: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_string_length(_ARG1))) + sexp_raise("string-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + if (ip[-1] == SEXP_OP_BYTES_REF) + _ARG2 = sexp_bytes_ref(_ARG1, _ARG2); + else +#if SEXP_USE_UTF8_STRINGS + _ARG2 = sexp_string_utf8_ref(ctx, _ARG1, _ARG2); +#else + _ARG2 = sexp_string_ref(_ARG1, _ARG2); +#endif + top--; + break; + case SEXP_OP_BYTES_SET: + case SEXP_OP_STRING_SET: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-set!: not a string", sexp_list1(ctx, _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("string-set!: immutable string", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("string-set!: not an integer", sexp_list1(ctx, _ARG2)); + else if (! sexp_charp(_ARG3)) + sexp_raise("string-set!: not a char", sexp_list1(ctx, _ARG3)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_string_length(_ARG1))) + sexp_raise("string-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + if (ip[-1] == SEXP_OP_BYTES_SET) + sexp_bytes_set(_ARG1, _ARG2, _ARG3); + else +#if SEXP_USE_UTF8_STRINGS + sexp_string_utf8_set(ctx, _ARG1, _ARG2, _ARG3); +#else + sexp_string_set(_ARG1, _ARG2, _ARG3); +#endif + _ARG3 = SEXP_VOID; + top-=2; + break; + case SEXP_OP_BYTES_LENGTH: + if (! sexp_stringp(_ARG1)) + sexp_raise("bytes-length: not a byte-vector", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_bytes_length(_ARG1)); + break; + case SEXP_OP_STRING_LENGTH: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-length: not a string", sexp_list1(ctx, _ARG1)); +#if SEXP_USE_UTF8_STRINGS + _ARG1 = sexp_make_fixnum(sexp_string_utf8_length((unsigned char*)sexp_string_data(_ARG1), sexp_string_length(_ARG1))); +#else + _ARG1 = sexp_make_fixnum(sexp_string_length(_ARG1)); +#endif + break; + case SEXP_OP_MAKE_PROCEDURE: + sexp_context_top(ctx) = top; + _ARG4 = sexp_make_procedure(ctx, _ARG1, _ARG2, _ARG3, _ARG4); + top-=3; + break; + case SEXP_OP_MAKE_VECTOR: + sexp_context_top(ctx) = top; + if (! sexp_fixnump(_ARG1)) + sexp_raise("make-vector: not an integer", sexp_list1(ctx, _ARG1)); + _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2); + top--; + break; + case SEXP_OP_MAKE_EXCEPTION: + _ARG5 = sexp_make_exception(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + break; + case SEXP_OP_AND: + _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE)); + top--; + break; + case SEXP_OP_EOFP: + _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; + case SEXP_OP_NULLP: + _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; + case SEXP_OP_FIXNUMP: + _ARG1 = sexp_make_boolean(sexp_fixnump(_ARG1)); break; + case SEXP_OP_SYMBOLP: + _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; + case SEXP_OP_CHARP: + _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; + case SEXP_OP_TYPEP: + _ALIGN_IP(); + _ARG1 = sexp_make_boolean(sexp_check_tag(_ARG1, _UWORD0)); + ip += sizeof(sexp); + break; + case SEXP_OP_MAKE: + _ALIGN_IP(); + _PUSH(sexp_alloc_tagged(ctx, _UWORD1, _UWORD0)); + ip += sizeof(sexp)*2; + break; + case SEXP_OP_SLOT_REF: + _ALIGN_IP(); + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); + _ARG1 = sexp_slot_ref(_ARG1, _UWORD1); + ip += sizeof(sexp)*2; + break; + case SEXP_OP_SLOT_SET: + _ALIGN_IP(); + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1)); + sexp_slot_set(_ARG1, _UWORD1, _ARG2); + _ARG2 = SEXP_VOID; + ip += sizeof(sexp)*2; + top--; + break; + case SEXP_OP_ISA: + _ARG2 = sexp_make_boolean(sexp_isa(_ARG1, _ARG2)); + top--; + break; + case SEXP_OP_SLOTN_REF: + if (! sexp_typep(_ARG1)) + sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1)); + else if (! sexp_isa(_ARG2, _ARG1)) + sexp_raise("slot-ref: bad type", sexp_list1(ctx, _ARG2)); + else if (! sexp_fixnump(_ARG3)) + sexp_raise("slot-ref: not an integer", sexp_list1(ctx, _ARG3)); + _ARG3 = sexp_slot_ref(_ARG2, sexp_unbox_fixnum(_ARG3)); + top-=2; + break; + case SEXP_OP_SLOTN_SET: + if (! sexp_typep(_ARG1)) + sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1)); + else if (! sexp_isa(_ARG2, _ARG1)) + sexp_raise("slot-set!: bad type", sexp_list1(ctx, _ARG2)); + else if (sexp_immutablep(_ARG2)) + sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG2)); + else if (! sexp_fixnump(_ARG3)) + sexp_raise("slot-ref: not an integer", sexp_list1(ctx, _ARG3)); + sexp_slot_set(_ARG2, sexp_unbox_fixnum(_ARG3), _ARG4); + _ARG4 = SEXP_VOID; + top-=3; + break; + case SEXP_OP_CAR: + if (! sexp_pairp(_ARG1)) + sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_car(_ARG1); break; + case SEXP_OP_CDR: + if (! sexp_pairp(_ARG1)) + sexp_raise("cdr: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_cdr(_ARG1); break; + case SEXP_OP_SET_CAR: + if (! sexp_pairp(_ARG1)) + sexp_raise("set-car!: not a pair", sexp_list1(ctx, _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("set-car!: immutable pair", sexp_list1(ctx, _ARG1)); + sexp_car(_ARG1) = _ARG2; + _ARG2 = SEXP_VOID; + top--; + break; + case SEXP_OP_SET_CDR: + if (! sexp_pairp(_ARG1)) + sexp_raise("set-cdr!: not a pair", sexp_list1(ctx, _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("set-cdr!: immutable pair", sexp_list1(ctx, _ARG1)); + sexp_cdr(_ARG1) = _ARG2; + _ARG2 = SEXP_VOID; + top--; + break; + case SEXP_OP_CONS: + sexp_context_top(ctx) = top; + _ARG2 = sexp_cons(ctx, _ARG1, _ARG2); + top--; + break; + case SEXP_OP_ADD: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + j = sexp_unbox_fixnum(tmp1) + sexp_unbox_fixnum(tmp2); + if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) + _ARG1 = sexp_add(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG1 = sexp_make_fixnum(j); + } + else { + _ARG1 = sexp_add(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_fx_add(tmp1, tmp2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_add(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) + (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) + sexp_flonum_value(tmp2)); +#endif + else sexp_raise("+: not a number", sexp_list2(ctx, tmp1, tmp2)); +#endif + break; + case SEXP_OP_SUB: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + j = sexp_unbox_fixnum(tmp1) - sexp_unbox_fixnum(tmp2); + if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) + _ARG1 = sexp_sub(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG1 = sexp_make_fixnum(j); + } + else { + _ARG1 = sexp_sub(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_fx_sub(tmp1, tmp2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_sub(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) - (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) - sexp_flonum_value(tmp2)); +#endif + else sexp_raise("-: not a number", sexp_list2(ctx, tmp1, tmp2)); +#endif + break; + case SEXP_OP_MUL: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + prod = (sexp_lsint_t)sexp_unbox_fixnum(tmp1) * sexp_unbox_fixnum(tmp2); + if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM)) + _ARG1 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG1 = sexp_make_fixnum(prod); + } + else { + _ARG1 = sexp_mul(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_fx_mul(tmp1, tmp2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_mul(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) * (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) * sexp_flonum_value(tmp2)); +#endif + else sexp_raise("*: not a number", sexp_list2(ctx, tmp1, tmp2)); +#endif + break; + case SEXP_OP_DIV: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (tmp2 == SEXP_ZERO) { +#if SEXP_USE_FLONUMS + if (sexp_flonump(tmp1) && sexp_flonum_value(tmp1) == 0.0) + _ARG1 = sexp_make_flonum(ctx, 0.0); + else +#endif + sexp_raise("divide by zero", SEXP_NULL); + } else if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { +#if SEXP_USE_FLONUMS + tmp1 = sexp_fixnum_to_flonum(ctx, tmp1); + tmp2 = sexp_fixnum_to_flonum(ctx, tmp2); + _ARG1 = sexp_fp_div(ctx, tmp1, tmp2); + if (sexp_flonum_value(_ARG1) == trunc(sexp_flonum_value(_ARG1))) + _ARG1 = sexp_make_fixnum(sexp_flonum_value(_ARG1)); +#else + _ARG1 = sexp_fx_div(tmp1, tmp2); +#endif + } +#if SEXP_USE_BIGNUMS + else { + _ARG1 = sexp_div(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else +#if SEXP_USE_FLONUMS + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_div(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) / (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) / sexp_flonum_value(tmp2)); +#endif + else sexp_raise("/: not a number", sexp_list2(ctx, tmp1, tmp2)); +#endif + break; + case SEXP_OP_QUOTIENT: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + if (tmp2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + _ARG1 = sexp_fx_div(tmp1, tmp2); + } +#if SEXP_USE_BIGNUMS + else { + _ARG1 = sexp_quotient(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, tmp2)); +#endif + break; + case SEXP_OP_REMAINDER: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + if (tmp2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + _ARG1 = sexp_fx_rem(tmp1, tmp2); + } +#if SEXP_USE_BIGNUMS + else { + _ARG1 = sexp_remainder(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, tmp2)); +#endif + break; + case SEXP_OP_LT: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + i = (sexp_sint_t)tmp1 < (sexp_sint_t)tmp2; +#if SEXP_USE_BIGNUMS + _ARG1 = sexp_make_boolean(i); + } else { + _ARG1 = sexp_compare(ctx, tmp1, tmp2); + sexp_check_exception(); + _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) < 0); + } +#else +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) { + i = sexp_flonum_value(tmp1) < sexp_flonum_value(tmp2); + } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) { + i = sexp_flonum_value(tmp1) < (double)sexp_unbox_fixnum(tmp2); + } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) { + i = (double)sexp_unbox_fixnum(tmp1) < sexp_flonum_value(tmp2); +#endif + } else sexp_raise("<: not a number", sexp_list2(ctx, tmp1, tmp2)); + _ARG1 = sexp_make_boolean(i); +#endif + break; + case SEXP_OP_LE: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + i = (sexp_sint_t)tmp1 <= (sexp_sint_t)tmp2; +#if SEXP_USE_BIGNUMS + _ARG1 = sexp_make_boolean(i); + } else { + _ARG1 = sexp_compare(ctx, tmp1, tmp2); + sexp_check_exception(); + _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) <= 0); + } +#else +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) { + i = sexp_flonum_value(tmp1) <= sexp_flonum_value(tmp2); + } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) { + i = sexp_flonum_value(tmp1) <= (double)sexp_unbox_fixnum(tmp2); + } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) { + i = (double)sexp_unbox_fixnum(tmp1) <= sexp_flonum_value(tmp2); +#endif + } else sexp_raise("<=: not a number", sexp_list2(ctx, tmp1, tmp2)); + _ARG1 = sexp_make_boolean(i); +#endif + break; + case SEXP_OP_EQN: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + i = tmp1 == tmp2; +#if SEXP_USE_BIGNUMS + _ARG1 = sexp_make_boolean(i); + } else { + _ARG1 = sexp_compare(ctx, tmp1, tmp2); + sexp_check_exception(); + _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) == 0); + } +#else +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) { + i = sexp_flonum_value(tmp1) == sexp_flonum_value(tmp2); + } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) { + i = sexp_flonum_value(tmp1) == (double)sexp_unbox_fixnum(tmp2); + } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) { + i = (double)sexp_unbox_fixnum(tmp1) == sexp_flonum_value(tmp2); +#endif + } else sexp_raise("=: not a number", sexp_list2(ctx, tmp1, tmp2)); + _ARG1 = sexp_make_boolean(i); +#endif + break; + case SEXP_OP_EQ: + _ARG2 = sexp_make_boolean(_ARG1 == _ARG2); + top--; + break; + case SEXP_OP_FIX2FLO: + if (sexp_fixnump(_ARG1)) + _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, sexp_bignum_to_double(_ARG1)); +#endif + else if (! sexp_flonump(_ARG1)) + sexp_raise("exact->inexact: not a number", sexp_list1(ctx, _ARG1)); + break; + case SEXP_OP_FLO2FIX: + if (sexp_flonump(_ARG1)) { + if (sexp_flonum_value(_ARG1) != trunc(sexp_flonum_value(_ARG1))) { + sexp_raise("inexact->exact: not an integer", sexp_list1(ctx, _ARG1)); +#if SEXP_USE_BIGNUMS + } else if ((sexp_flonum_value(_ARG1) > SEXP_MAX_FIXNUM) + || sexp_flonum_value(_ARG1) < SEXP_MIN_FIXNUM) { + _ARG1 = sexp_double_to_bignum(ctx, sexp_flonum_value(_ARG1)); +#endif + } else { + _ARG1 = sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(_ARG1)); + } + } else if (! sexp_fixnump(_ARG1) && ! sexp_bignump(_ARG1)) { + sexp_raise("inexact->exact: not a number", sexp_list1(ctx, _ARG1)); + } + break; + case SEXP_OP_CHAR2INT: + if (! sexp_charp(_ARG1)) + sexp_raise("char->integer: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_unbox_character(_ARG1)); + break; + case SEXP_OP_INT2CHAR: + if (! sexp_fixnump(_ARG1)) + sexp_raise("integer->char: not an integer", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(sexp_unbox_fixnum(_ARG1)); + break; + case SEXP_OP_CHAR_UPCASE: + if (! sexp_charp(_ARG1)) + sexp_raise("char-upcase: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(toupper(sexp_unbox_character(_ARG1))); + break; + case SEXP_OP_CHAR_DOWNCASE: + if (! sexp_charp(_ARG1)) + sexp_raise("char-downcase: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(tolower(sexp_unbox_character(_ARG1))); + break; + case SEXP_OP_WRITE_CHAR: + if (! sexp_charp(_ARG1)) + sexp_raise("write-char: not a character", sexp_list1(ctx, _ARG1)); + if (! sexp_oportp(_ARG2)) + sexp_raise("write-char: not an output-port", sexp_list1(ctx, _ARG2)); +#if SEXP_USE_UTF8_STRINGS + if (sexp_unbox_character(_ARG1) >= 0x80) + sexp_write_utf8_char(ctx, sexp_unbox_character(_ARG1), _ARG2); + else +#endif + sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + case SEXP_OP_NEWLINE: + if (! sexp_oportp(_ARG1)) + sexp_raise("newline: not an output-port", sexp_list1(ctx, _ARG1)); + sexp_newline(ctx, _ARG1); + _ARG1 = SEXP_VOID; + break; + case SEXP_OP_READ_CHAR: + if (! sexp_iportp(_ARG1)) + sexp_raise("read-char: not an input-port", sexp_list1(ctx, _ARG1)); + i = sexp_read_char(ctx, _ARG1); +#if SEXP_USE_UTF8_STRINGS + if (i >= 0x80) + _ARG1 = sexp_read_utf8_char(ctx, _ARG1, i); + else +#endif + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case SEXP_OP_PEEK_CHAR: + if (! sexp_iportp(_ARG1)) + sexp_raise("peek-char: not an input-port", sexp_list1(ctx, _ARG1)); + i = sexp_read_char(ctx, _ARG1); + sexp_push_char(ctx, i, _ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case SEXP_OP_YIELD: + fuel = 0; + _PUSH(SEXP_VOID); + break; + case SEXP_OP_RET: + i = sexp_unbox_fixnum(stack[fp]); + stack[fp-i] = _ARG1; + top = fp-i+1; + self = stack[fp+2]; + bc = sexp_procedure_code(self); + ip = sexp_bytecode_data(bc) + sexp_unbox_fixnum(stack[fp+1]); + cp = sexp_procedure_vars(self); + fp = sexp_unbox_fixnum(stack[fp+3]); + break; + case SEXP_OP_DONE: + goto end_loop; + default: + sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_fixnum(*(ip-1)))); + } + goto loop; + + end_loop: +#if SEXP_USE_GREEN_THREADS + if (ctx != root_thread) { + if (sexp_context_refuel(root_thread) <= 0) { + /* the root already terminated */ + _ARG1 = SEXP_VOID; + } else { + /* don't return from child threads */ + sexp_context_refuel(ctx) = fuel = 0; + goto loop; + } + } +#endif + sexp_gc_release3(ctx); + sexp_context_top(ctx) = top; + return _ARG1; +} + +/******************************* apply ********************************/ + +sexp sexp_apply1 (sexp ctx, sexp f, sexp x) { + sexp res; + sexp_gc_var1(args); + if (sexp_opcodep(f)) { + res = ((sexp_proc2)sexp_opcode_func(f))(ctx sexp_api_pass(f, 1), x); + } else { + sexp_gc_preserve1(ctx, args); + res = sexp_apply(ctx, f, args=sexp_list1(ctx, x)); + sexp_gc_release1(ctx); + } + return res; +} + +sexp sexp_apply (sexp ctx, sexp proc, sexp args) { + sexp res, ls, *stack = sexp_stack_data(sexp_context_stack(ctx)); + sexp_sint_t top = sexp_context_top(ctx), len, offset; + len = sexp_unbox_fixnum(sexp_length(ctx, args)); + if (sexp_opcodep(proc)) + proc = make_opcode_procedure(ctx, proc, len); + if (! sexp_procedurep(proc)) { + res = sexp_exceptionp(proc) ? proc : + sexp_type_exception(ctx, NULL, SEXP_PROCEDURE, proc); + } else { + offset = top + len; + for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++) + stack[--offset] = sexp_car(ls); + stack[top++] = sexp_make_fixnum(len); + stack[top++] = SEXP_ZERO; + stack[top++] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); + stack[top++] = SEXP_ZERO; + sexp_context_top(ctx) = top; + res = sexp_vm(ctx, proc); + if (! res) res = SEXP_VOID; /* shouldn't happen */ + } + return res; +}