From d954819775cedf96ade8f625458bb76f9ad10bdd Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 31 Dec 2009 00:24:19 +0900 Subject: [PATCH] adding (chibi io) w/ interface to fgets, fread, fwrite, etc. --- .hgignore | 21 + COPYING | 24 + Makefile | 193 ++ README | 424 ++++ RELEASE | 1 + TODO | 148 ++ VERSION | 1 + doc/chibi-scheme.1 | 133 ++ eval.c | 2737 ++++++++++++++++++++++++ gc.c | 250 +++ include/chibi/bignum.h | 43 + include/chibi/eval.h | 165 ++ include/chibi/features.h | 297 +++ include/chibi/sexp.h | 862 ++++++++ lib/chibi/ast.c | 80 + lib/chibi/ast.module | 14 + lib/chibi/disasm.c | 116 + lib/chibi/disasm.module | 5 + lib/chibi/filesystem.module | 27 + lib/chibi/filesystem.scm | 43 + lib/chibi/filesystem.stub | 115 + lib/chibi/heap-stats.c | 129 ++ lib/chibi/heap-stats.module | 5 + lib/chibi/io.module | 6 + lib/chibi/io/io.scm | 6 + lib/chibi/io/io.stub | 13 + lib/chibi/loop.module | 9 + lib/chibi/loop/loop.scm | 365 ++++ lib/chibi/macroexpand.module | 6 + lib/chibi/macroexpand.scm | 85 + lib/chibi/match.module | 6 + lib/chibi/match/match.scm | 670 ++++++ lib/chibi/net.module | 10 + lib/chibi/net.scm | 23 + lib/chibi/net.stub | 25 + lib/chibi/pathname.module | 7 + lib/chibi/pathname.scm | 180 ++ lib/chibi/process.module | 17 + lib/chibi/process.stub | 72 + lib/chibi/signal.c | 62 + lib/chibi/system.module | 15 + lib/chibi/system.stub | 34 + lib/chibi/time.module | 11 + lib/chibi/time.stub | 45 + lib/chibi/uri.module | 10 + lib/chibi/uri.scm | 306 +++ lib/config.scm | 174 ++ lib/init.scm | 881 ++++++++ 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/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/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 | 82 + lib/srfi/95.module | 7 + lib/srfi/95/qsort.c | 170 ++ lib/srfi/95/sort.scm | 70 + lib/srfi/98.module | 5 + lib/srfi/98/env.c | 48 + main.c | 193 ++ mkfile | 26 + opcodes.c | 153 ++ opt/bignum.c | 751 +++++++ 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 | 135 ++ sexp.c | 1685 +++++++++++++++ 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/install/install-tests.pl | 57 + tests/install/run-install-test.sh | 12 + tests/loop-tests.scm | 202 ++ tests/match-tests.scm | 196 ++ tests/numeric-tests.scm | 150 ++ tests/r5rs-tests.scm | 483 +++++ tools/genstubs.scm | 1194 +++++++++++ 123 files changed, 17079 insertions(+) create mode 100644 .hgignore 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 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/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/loop.module create mode 100644 lib/chibi/loop/loop.scm create mode 100644 lib/chibi/macroexpand.module create mode 100644 lib/chibi/macroexpand.scm create mode 100644 lib/chibi/match.module create mode 100644 lib/chibi/match/match.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/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/signal.c create mode 100644 lib/chibi/system.module create mode 100644 lib/chibi/system.stub create mode 100644 lib/chibi/time.module create mode 100644 lib/chibi/time.stub 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/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/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/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 100755 tests/install/install-tests.pl create mode 100755 tests/install/run-install-test.sh 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 100755 tools/genstubs.scm diff --git a/.hgignore b/.hgignore new file mode 100644 index 00000000..babe41d2 --- /dev/null +++ b/.hgignore @@ -0,0 +1,21 @@ +syntax: glob +*~ +*.i +*.s +*.o +*.so +*.dylib +*.dSYM +*.orig +.hg +junk* +*.tar.gz +*.tar.bz2 +*.log +*.err +*.out +gc +gc6.8 +chibi-scheme +chibi-scheme-static +include/chibi/install.h 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..ddfc56e3 --- /dev/null +++ b/Makefile @@ -0,0 +1,193 @@ +# -*- makefile-gmake -*- + +.PHONY: all libs doc dist clean cleaner 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 + +######################################################################## +# system configuration - if not using GNU make, set PLATFORM and the +# following flags as necessary. + +ifndef PLATFORM +ifeq ($(shell uname),Darwin) +PLATFORM=macosx +else +ifeq ($(shell uname -o),Msys) +PLATFORM=mingw +SOLIBDIR = $(BINDIR) +DIFFOPTS = -b +else +PLATFORM=unix +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 -DSEXP_USE_DEBUG=0 +LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a +else +SO = .so +EXE = +CLIBFLAGS = -fPIC -shared +STATICFLAGS = -static -DSEXP_USE_DL=0 +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) -ldl -lm +XCFLAGS := -Wall -g3 $(CFLAGS) +endif + +######################################################################## + +all: chibi-scheme$(EXE) libs + +COMPILED_LIBS := 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/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/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 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-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 $@ $^ $(XLDFLAGS) + +%.c: %.stub $(GENSTUBS) + 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 + +test-basic: chibi-scheme$(EXE) + @for f in tests/basic/*.scm; do \ + ./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-numbers: chibi-scheme$(EXE) + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/numeric-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: 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)/ + mkdir -p $(DESTDIR)$(MODDIR) + cp lib/init.scm lib/config.scm $(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: cleaner + 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` diff --git a/README b/README new file mode 100644 index 00000000..172c476d --- /dev/null +++ b/README @@ -0,0 +1,424 @@ + + 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 + +------------------------------------------------------------------------ +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 the 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..93f7c837 --- /dev/null +++ b/TODO @@ -0,0 +1,148 @@ +-*- 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 +** TODO fasl/image files +** 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] +** TODO unicode +** TODO threads +** TODO virtual ports +** 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 +** TODO posix interface + 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] +*** TODO host system interface +** 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/doc/chibi-scheme.1 b/doc/chibi-scheme.1 new file mode 100644 index 00000000..f20c50e5 --- /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 +] +[-u +.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..de858f87 --- /dev/null +++ b/eval.c @@ -0,0 +1,2737 @@ +/* eval.c -- evaluator library implementation */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +/************************************************************************/ + +static int scheme_initialized_p = 0; + +#if SEXP_USE_DEBUG_VM +static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) { + int i; + if (! sexp_oport(out)) out = sexp_current_error_port(ctx); + for (i=0; i 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)))))) { + res = analyze_app(ctx, x); + } else { + res = sexp_compile_error(ctx, "invalid operand in application", 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);} + +static sexp_sint_t sexp_context_make_label (sexp ctx) { + sexp_sint_t 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; + 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)) { + 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_INV)) + ? sexp_cdr(app) : sexp_reverse(ctx, sexp_cdr(app))); + for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) + generate(ctx, sexp_car(ls)); + + /* emit the actual operator call */ + switch (sexp_opcode_class(op)) { + case SEXP_OPC_ARITHMETIC: + if (num_args > 1) + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_ARITHMETIC_INV: + emit(ctx, (num_args==1) ? sexp_opcode_inverse(op) : 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_ACCESSOR: + 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)); + } + + /* emit optional folding of operator */ + if ((num_args > 2) + && (sexp_opcode_class(op) == SEXP_OPC_ARITHMETIC + || sexp_opcode_class(op) == SEXP_OPC_ARITHMETIC_INV)) + for (i=num_args-2; i>0; i--) + 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); + 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 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; +} + +static 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 = 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 = free_vars(ctx, sexp_car(x), fv1); + } else if (sexp_cndp(x)) { + fv1 = free_vars(ctx, sexp_cnd_test(x), fv); + fv1 = free_vars(ctx, sexp_cnd_pass(x), fv1); + fv1 = 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 = free_vars(ctx, sexp_car(x), fv1); + } else if (sexp_setp(x)) { + fv1 = free_vars(ctx, sexp_set_value(x), fv); + fv1 = 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 = free_vars(ctx, sexp_synclo_expr(x), fv); + } + sexp_gc_release2(ctx); + return fv1; +} + +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 + 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: + sexp_context_top(ctx) = top; + _PUSH(((sexp_proc1)sexp_opcode_func(_WORD0))(ctx)); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL1: + sexp_context_top(ctx) = top; + _ARG1 = ((sexp_proc2)sexp_opcode_func(_WORD0))(ctx, _ARG1); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL2: + sexp_context_top(ctx) = top; + _ARG2 = ((sexp_proc3)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2); + top--; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL3: + sexp_context_top(ctx) = top; + _ARG3 = ((sexp_proc4)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3); + top -= 2; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL4: + sexp_context_top(ctx) = top; + _ARG4 = ((sexp_proc5)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3, _ARG4); + top -= 3; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL5: + sexp_context_top(ctx) = top; + _ARG5 = ((sexp_proc6)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL6: + sexp_context_top(ctx) = top; + _ARG6 = ((sexp_proc7)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6); + top -= 5; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_JUMP_UNLESS: + if (stack[--top] == SEXP_FALSE) + ip += _SWORD0; + else + ip += sizeof(sexp_sint_t); + break; + case SEXP_OP_JUMP: + ip += _SWORD0; + break; + case SEXP_OP_PUSH: + _PUSH(_WORD0); + ip += sizeof(sexp); + break; + case SEXP_OP_DROP: + top--; + break; + case SEXP_OP_GLOBAL_REF: + if (sexp_cdr(_WORD0) == SEXP_UNDEF) + sexp_raise("undefined variable", sexp_list1(ctx, sexp_car(_WORD0))); + /* ... FALLTHROUGH ... */ + case SEXP_OP_GLOBAL_KNOWN_REF: + _PUSH(sexp_cdr(_WORD0)); + ip += sizeof(sexp); + break; + case SEXP_OP_STACK_REF: /* `pick' in forth */ + stack[top] = stack[top - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case SEXP_OP_LOCAL_REF: + stack[top] = stack[fp - 1 - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case SEXP_OP_LOCAL_SET: + stack[fp - 1 - _SWORD0] = _ARG1; + _ARG1 = SEXP_VOID; + ip += sizeof(sexp); + break; + case SEXP_OP_CLOSURE_REF: + _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_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)); + _ARG2 = sexp_string_ref(_ARG1, _ARG2); + top--; + break; + 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)); + sexp_string_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case SEXP_OP_STRING_LENGTH: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-length: not a string", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_string_length(_ARG1)); + 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: + _ARG1 = sexp_make_boolean(sexp_check_tag(_ARG1, _UWORD0)); + ip += sizeof(sexp); + break; + case SEXP_OP_MAKE: + _PUSH(sexp_alloc_tagged(ctx, _UWORD1, _UWORD0)); + ip += sizeof(sexp)*2; + break; + case SEXP_OP_SLOT_REF: + 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: + 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_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: +#if SEXP_USE_BIGNUMS + tmp1 = _ARG1, tmp2 = _ARG2; + 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)) + _ARG2 = sexp_add(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG2 = sexp_make_fixnum(j); + } + else + _ARG2 = sexp_add(ctx, tmp1, tmp2); +#else + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_fx_add(_ARG1, _ARG2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_add(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) + (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) + sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("+: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_SUB: +#if SEXP_USE_BIGNUMS + tmp1 = _ARG1, tmp2 = _ARG2; + 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)) + _ARG2 = sexp_sub(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG2 = sexp_make_fixnum(j); + } + else + _ARG2 = sexp_sub(ctx, tmp1, tmp2); +#else + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_fx_sub(_ARG1, _ARG2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_sub(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) - (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) - sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("-: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_MUL: +#if SEXP_USE_BIGNUMS + tmp1 = _ARG1, tmp2 = _ARG2; + 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)) + _ARG2 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG2 = sexp_make_fixnum(prod); + } + else + _ARG2 = sexp_mul(ctx, tmp1, tmp2); +#else + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_fx_mul(_ARG1, _ARG2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_mul(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) * (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) * sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("*: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_DIV: + if (_ARG2 == SEXP_ZERO) { +#if SEXP_USE_FLONUMS + if (sexp_flonump(_ARG1) && sexp_flonum_value(_ARG1) == 0.0) + _ARG2 = sexp_make_flonum(ctx, 0.0/0.0); + else +#endif + sexp_raise("divide by zero", SEXP_NULL); + } else if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { +#if SEXP_USE_FLONUMS + _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); + _ARG2 = sexp_fixnum_to_flonum(ctx, _ARG2); + _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); + if (sexp_flonum_value(_ARG2) == trunc(sexp_flonum_value(_ARG2))) + _ARG2 = sexp_make_fixnum(sexp_flonum_value(_ARG2)); +#else + _ARG2 = sexp_fx_div(_ARG1, _ARG2); +#endif + } +#if SEXP_USE_BIGNUMS + else + _ARG2 = sexp_div(ctx, _ARG1, _ARG2); +#else +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) / (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) / sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("/: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_QUOTIENT: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + if (_ARG2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + _ARG2 = sexp_fx_div(_ARG1, _ARG2); + top--; + } +#if SEXP_USE_BIGNUMS + else { + _ARG2 = sexp_quotient(ctx, _ARG1, _ARG2); + top--; + } +#else + else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + break; + case SEXP_OP_REMAINDER: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + if (_ARG2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + tmp1 = sexp_fx_rem(_ARG1, _ARG2); + top--; + _ARG1 = tmp1; + } +#if SEXP_USE_BIGNUMS + else { + _ARG2 = sexp_remainder(ctx, _ARG1, _ARG2); + top--; + } +#else + else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + break; + case SEXP_OP_NEGATIVE: + if (sexp_fixnump(_ARG1)) + _ARG1 = sexp_make_fixnum(-sexp_unbox_fixnum(_ARG1)); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(_ARG1)) { + _ARG1 = sexp_copy_bignum(ctx, NULL, _ARG1, 0); + sexp_bignum_sign(_ARG1) = -sexp_bignum_sign(_ARG1); + } +#endif +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, -sexp_flonum_value(_ARG1)); +#endif + else sexp_raise("-: not a number", sexp_list1(ctx, _ARG1)); + break; + case SEXP_OP_INVERSE: + if (sexp_fixnump(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, 1/(double)sexp_unbox_fixnum(_ARG1)); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, 1/sexp_flonum_value(_ARG1)); +#endif + else sexp_raise("/: not a number", sexp_list1(ctx, _ARG1)); + break; + case SEXP_OP_LT: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + i = (sexp_sint_t)_ARG1 < (sexp_sint_t)_ARG2; +#if SEXP_USE_BIGNUMS + _ARG2 = sexp_make_boolean(i); + } else { + tmp1 = sexp_compare(ctx, _ARG1, _ARG2); + _ARG2 = sexp_fixnump(tmp1) + ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) < 0) : tmp1; + } +#else +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) { + i = sexp_flonum_value(_ARG1) < sexp_flonum_value(_ARG2); + } else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) { + i = sexp_flonum_value(_ARG1) < (double)sexp_unbox_fixnum(_ARG2); + } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { + i = (double)sexp_unbox_fixnum(_ARG1) < sexp_flonum_value(_ARG2); +#endif + } else sexp_raise("<: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); +#endif + top--; + break; + case SEXP_OP_LE: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + i = (sexp_sint_t)_ARG1 <= (sexp_sint_t)_ARG2; +#if SEXP_USE_BIGNUMS + _ARG2 = sexp_make_boolean(i); + } else { + tmp1 = sexp_compare(ctx, _ARG1, _ARG2); + _ARG2 = sexp_fixnump(tmp1) + ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) <= 0) : tmp1; + } +#else +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) { + i = sexp_flonum_value(_ARG1) <= sexp_flonum_value(_ARG2); + } else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) { + i = sexp_flonum_value(_ARG1) <= (double)sexp_unbox_fixnum(_ARG2); + } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { + i = (double)sexp_unbox_fixnum(_ARG1) <= sexp_flonum_value(_ARG2); +#endif + } else sexp_raise("<=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); +#endif + top--; + break; + case SEXP_OP_EQN: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + i = _ARG1 == _ARG2; +#if SEXP_USE_BIGNUMS + _ARG2 = sexp_make_boolean(i); + } else { + tmp1 = sexp_compare(ctx, _ARG1, _ARG2); + _ARG2 = sexp_fixnump(tmp1) + ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) == 0) : tmp1; + } +#else +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) { + i = sexp_flonum_value(_ARG1) == sexp_flonum_value(_ARG2); + } else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) { + i = sexp_flonum_value(_ARG1) == (double)sexp_unbox_fixnum(_ARG2); + } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { + i = (double)sexp_unbox_fixnum(_ARG1) == sexp_flonum_value(_ARG2); +#endif + } else sexp_raise("=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); +#endif + top--; + 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)); + sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + case SEXP_OP_NEWLINE: + sexp_newline(ctx, _ARG1); + _ARG1 = SEXP_VOID; + break; + case SEXP_OP_READ_CHAR: + i = sexp_read_char(ctx, _ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case SEXP_OP_PEEK_CHAR: + 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_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: + sexp_gc_release3(ctx); + sexp_context_top(ctx) = top; + return _ARG1; +} + +/************************ library procedures **************************/ + +static sexp sexp_exception_type_func (sexp ctx, sexp exn) { + if (sexp_exceptionp(exn)) + return sexp_exception_kind(exn); + else + return sexp_type_exception(ctx, "not an exception", exn); +} + +static sexp sexp_open_input_file (sexp ctx, sexp path) { + FILE *in; + if (! sexp_stringp(path)) + return sexp_type_exception(ctx, "not a string", path); + in = fopen(sexp_string_data(path), "r"); + if (! in) + return + sexp_user_exception(ctx, SEXP_FALSE, "couldn't open input file", path); + return sexp_make_input_port(ctx, in, path); +} + +static sexp sexp_open_output_file (sexp ctx, sexp path) { + FILE *out; + if (! sexp_stringp(path)) + return sexp_type_exception(ctx, "not a string", path); + out = fopen(sexp_string_data(path), "w"); + if (! out) + return + sexp_user_exception(ctx, SEXP_FALSE, "couldn't open output file", path); + return sexp_make_output_port(ctx, out, path); +} + +static sexp sexp_close_port (sexp ctx, sexp port) { + if (! sexp_portp(port)) + return sexp_type_exception(ctx, "not a port", port); + if (! sexp_port_openp(port)) + return sexp_user_exception(ctx, SEXP_FALSE, "port already closed", port); + if (sexp_port_stream(port)) + fclose(sexp_port_stream(port)); +#if ! SEXP_USE_STRING_STREAMS + if (sexp_port_buf(port) && sexp_oportp(port)) + free(sexp_port_buf(port)); +#endif + sexp_port_openp(port) = 0; + return SEXP_VOID; +} + +void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out) { + sexp x; + for (x=from; sexp_pairp(x) && x!=to; x=sexp_cdr(x)) + if (sexp_cdar(x) == SEXP_UNDEF) { + sexp_write_string(ctx, "WARNING: reference to undefined variable: ", out); + sexp_write(ctx, sexp_caar(x), out); + sexp_write_char(ctx, '\n', out); + } +} + +#if SEXP_USE_DL +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, env); +} +#endif + +sexp sexp_load (sexp ctx, sexp source, sexp env) { +#if SEXP_USE_DL + char *suffix; +#endif + sexp tmp, out=SEXP_FALSE; + sexp_gc_var4(ctx2, x, in, res); + if (! sexp_stringp(source)) + return sexp_type_exception(ctx, "not a string", source); + if (! sexp_envp(env)) + return sexp_type_exception(ctx, "not an environment", 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); + } + sexp_gc_release4(ctx); +#if SEXP_USE_DL + } +#endif +#if SEXP_USE_WARN_UNDEFS + if (sexp_oportp(out) && ! sexp_exceptionp(res)) + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, out); +#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 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, "not a 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 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, "not a 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 (sexp ctx, 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, "expt: not a number", 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, "expt: not a number", 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 (sexp ctx, sexp str1, sexp str2, sexp ci) { + sexp_sint_t len1, len2, len, diff; + if (! sexp_stringp(str1)) + return sexp_type_exception(ctx, "not a string", str1); + if (! sexp_stringp(str2)) + return sexp_type_exception(ctx, "not a string", str2); + len1 = sexp_string_length(str1); + len2 = sexp_string_length(str2); + len = ((len1= SEXP_OPC_NUM_OP_CLASSES)) + res = sexp_type_exception(ctx, "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_type_exception(ctx, "make-opcode: bad opcode", code); + else if (! sexp_fixnump(num_args)) + res = sexp_type_exception(ctx, "make-opcode: bad num_args", num_args); + else if (! sexp_fixnump(flags)) + res = sexp_type_exception(ctx, "make-opcode: bad flags", flags); + 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) = sexp_unbox_fixnum(arg1t); + sexp_opcode_arg2_type(res) = sexp_unbox_fixnum(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, char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { + sexp res; + if (num_args > 6) { + res = sexp_type_exception(ctx, "make-foreign: exceeded foreign arg limit", + sexp_make_fixnum(num_args)); + } else { + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = SEXP_OPC_FOREIGN; + 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, char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { + sexp_gc_var1(op); + sexp_gc_preserve1(ctx, op); + sexp res = SEXP_VOID; + 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), op); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_define_foreign_param (sexp ctx, sexp env, char *name, int num_args, + sexp_proc1 f, char *param) { + sexp res; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_intern(ctx, param); + 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 (sexp ctx, sexp name, sexp type) { + if (! sexp_fixnump(type)) + return sexp_type_exception(ctx, "make-type-predicate: bad type", type); + return sexp_make_opcode(ctx, 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 (sexp ctx, sexp name, sexp type) { + sexp_uint_t type_size; + if (! sexp_fixnump(type)) + return sexp_type_exception(ctx, "make-constructor: bad type", type); + type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type))); + return sexp_make_opcode(ctx, 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_accessor (sexp ctx, sexp name, sexp type, sexp index, sexp code) { + if (! sexp_fixnump(type)) + return sexp_type_exception(ctx, "make-accessor: bad type", type); + if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) + return sexp_type_exception(ctx, "make-accessor: bad index", index); + return + sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_ACCESSOR), code, + sexp_make_fixnum(sexp_unbox_fixnum(code)==SEXP_OP_SLOT_REF?1:2), + SEXP_ZERO, type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); +} + +sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index) { + return sexp_make_accessor(ctx, name, type, index, sexp_make_fixnum(SEXP_OP_SLOT_REF)); +} +sexp sexp_make_setter (sexp ctx, sexp name, sexp type, sexp index) { + return sexp_make_accessor(ctx, name, type, index, sexp_make_fixnum(SEXP_OP_SLOT_SET)); +} + +#endif + +/*********************** standard environment *************************/ + +static struct sexp_struct core_forms[] = { + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_DEFINE, "define"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_SET, "set!"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LAMBDA, "lambda"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_IF, "if"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_BEGIN, "begin"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_QUOTE, "quote"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_SYNTAX_QUOTE, "syntax-quote"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_DEFINE_SYNTAX, "define-syntax"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LET_SYNTAX, "let-syntax"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LETREC_SYNTAX, "letrec-syntax"}}}, +}; + +sexp sexp_make_env (sexp ctx) { + 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 (sexp ctx, sexp version) { + sexp_uint_t i; + sexp e = sexp_make_env(ctx); + for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_core_name(&core_forms[i])), + sexp_copy_core(ctx, &core_forms[i])); + 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)); + 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)), op); + } + sexp_gc_release3(ctx); + return e; +} + +sexp sexp_find_module_file (sexp ctx, 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, 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 +static sexp sexp_find_module_file_op (sexp ctx, sexp file) { + if (! sexp_stringp(file)) + return sexp_type_exception(ctx, "not a string", file); + else + return sexp_find_module_file(ctx, sexp_string_data(file)); +} +sexp sexp_load_module_file_op (sexp ctx, sexp file, sexp env) { + if (! sexp_stringp(file)) + return sexp_type_exception(ctx, "not a string", file); + else if (! sexp_envp(env)) + return sexp_type_exception(ctx, "not an environment", env); + return sexp_load_module_file(ctx, sexp_string_data(file), env); +} +#endif + +sexp sexp_add_module_directory (sexp ctx, sexp dir, sexp appendp) { + sexp ls; + if (! sexp_stringp(dir)) + return sexp_type_exception(ctx, "not a 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_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), + sexp_make_input_port(ctx, stdin, SEXP_FALSE)); + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), + sexp_make_output_port(ctx, stdout, SEXP_FALSE)); + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), + sexp_make_output_port(ctx, stderr, SEXP_FALSE)); + 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*"), + tmp=sexp_c_string(ctx, sexp_so_extension, -1)); +#endif + tmp = sexp_list1(ctx, sym=sexp_intern(ctx, sexp_platform)); +#if SEXP_USE_DL + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "dynamic-loading")); +#endif +#if SEXP_USE_MODULES + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "modules")); +#endif +#if SEXP_USE_BOEHM + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "boehm-gc")); +#endif + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi")); + sexp_env_define(ctx, e, sexp_intern(ctx, "*features*"), 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*"); + 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 + sexp_gc_release3(ctx); + return sexp_exceptionp(tmp) ? tmp : e; +} + +sexp sexp_make_standard_env (sexp ctx, 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 (sexp ctx, sexp to, sexp from, sexp ls, sexp immutp) { + sexp oldname, newname, value, out; + 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_cdr(ls)) + sexp_env_define(ctx, to, sexp_caar(ls), sexp_cdar(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 if (sexp_oportp(out=sexp_current_error_port(ctx))) { + sexp_write_string(ctx, "WARNING: importing undefined variable: ", out); + sexp_write(ctx, oldname, out); + sexp_write_char(ctx, '\n', out); +#endif + } + } + } + return SEXP_VOID; +} + +/************************** eval interface ****************************/ + +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, "apply: not a 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); + top++; + 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; + } + return res; +} + +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_apply_optimization(ctx, sexp_cdar(res), ast); + free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ + 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 (sexp ctx, sexp obj, sexp env) { + sexp_sint_t top; + sexp ctx2; + sexp_gc_var2(res, err_handler); + 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 ? env : sexp_context_env(ctx)), + 0); + res = sexp_compile(ctx2, obj); + if (! sexp_exceptionp(res)) + res = sexp_apply(ctx2, res, SEXP_NULL); + sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = err_handler; + sexp_context_top(ctx) = top; + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_eval_string (sexp ctx, char *str, sexp env) { + sexp res; + sexp_gc_var1(obj); + sexp_gc_preserve1(ctx, obj); + obj = sexp_read_from_string(ctx, str); + 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..5e2a4d23 --- /dev/null +++ b/gc.c @@ -0,0 +1,250 @@ +/* gc.c -- simple mark&sweep garbage collector */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/sexp.h" + +/* These settings are configurable but only recommended for */ +/* experienced users, so they're not in config.h. */ + +/* 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 512*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 + +#define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(pair)) + +#if SEXP_64_BIT +#define sexp_heap_align(n) sexp_align(n, 5) +#else +#define sexp_heap_align(n) sexp_align(n, 4) +#endif + +#if SEXP_USE_GLOBAL_HEAP +sexp_heap sexp_global_heap; +#endif + +#if SEXP_USE_DEBUG_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; +} + +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; + 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 = (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) { + 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, 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); + } + } + } + sum_freed_ptr[0] = 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; + 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)); + h = sexp_heap_last(sexp_context_heap(ctx)); + if (((max_freed < size) + || ((h->size - sum_freed) > (h->size*SEXP_GROW_HEAP_RATIO))) + && ((! SEXP_MAXIMUM_HEAP_SIZE) || (h->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; +} + +void sexp_gc_init (void) { +#if SEXP_USE_GLOBAL_HEAP || SEXP_USE_DEBUG_GC + sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE); +#endif +#if SEXP_USE_GLOBAL_HEAP + sexp_global_heap = sexp_make_heap(size); +#endif +#if SEXP_USE_DEBUG_GC + /* the +32 is a hack, but this is just for debugging anyway */ + stack_base = ((sexp*)&size) + 32; +#endif +} + diff --git a/include/chibi/bignum.h b/include/chibi/bignum.h new file mode 100644 index 00000000..580b0a7d --- /dev/null +++ b/include/chibi/bignum.h @@ -0,0 +1,43 @@ +/* bignum.h -- header for bignum utilities */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifndef SEXP_BIGNUM_H +#define SEXP_BIGNUM_H + +#if (SEXP_64_BIT) +typedef unsigned int uint128_t __attribute__((mode(TI))); +typedef int sint128_t __attribute__((mode(TI))); +typedef uint128_t sexp_luint_t; +typedef sint128_t sexp_lsint_t; +#else +typedef unsigned long long sexp_luint_t; +typedef long long sexp_lsint_t; +#endif + +sexp_sint_t sexp_bignum_compare (sexp a, sexp b); +sexp sexp_compare (sexp ctx, sexp a, sexp b); +sexp sexp_make_bignum (sexp ctx, sexp_uint_t len); +sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len); +sexp sexp_bignum_normalize (sexp a); +sexp_uint_t sexp_bignum_hi (sexp a); +sexp sexp_fixnum_to_bignum (sexp ctx, sexp a); +double sexp_bignum_to_double (sexp a); +sexp sexp_double_to_bignum (sexp ctx, double f); +sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b); +sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset); +sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset); +sexp sexp_bignum_add (sexp ctx, sexp dst, sexp a, sexp b); +sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b); +sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b); +sexp sexp_bignum_div (sexp ctx, sexp dst, sexp a, sexp b); +sexp sexp_bignum_expt (sexp ctx, sexp n, sexp e); +sexp sexp_add (sexp ctx, sexp a, sexp b); +sexp sexp_sub (sexp ctx, sexp a, sexp b); +sexp sexp_mul (sexp ctx, sexp a, sexp b); +sexp sexp_div (sexp ctx, sexp a, sexp b); +sexp sexp_quotient (sexp ctx, sexp a, sexp b); +sexp sexp_remainder (sexp ctx, sexp a, sexp b); + +#endif /* ! SEXP_BIGNUM_H */ + diff --git a/include/chibi/eval.h b/include/chibi/eval.h new file mode 100644 index 00000000..7ce70433 --- /dev/null +++ b/include/chibi/eval.h @@ -0,0 +1,165 @@ +/* eval.h -- headers for eval library */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifndef SEXP_EVAL_H +#define SEXP_EVAL_H + +#include "chibi/sexp.h" + +/************************* additional types ***************************/ + +#define SEXP_INIT_BCODE_SIZE 128 +#define SEXP_INIT_STACK_SIZE 8192 + +#define sexp_init_file "init.scm" +#define sexp_config_file "config.scm" + +enum sexp_core_form_names { + SEXP_CORE_DEFINE = 1, + SEXP_CORE_SET, + SEXP_CORE_LAMBDA, + SEXP_CORE_IF, + SEXP_CORE_BEGIN, + SEXP_CORE_QUOTE, + SEXP_CORE_SYNTAX_QUOTE, + SEXP_CORE_DEFINE_SYNTAX, + SEXP_CORE_LET_SYNTAX, + SEXP_CORE_LETREC_SYNTAX +}; + +enum sexp_opcode_classes { + SEXP_OPC_GENERIC = 1, + SEXP_OPC_TYPE_PREDICATE, + SEXP_OPC_PREDICATE, + SEXP_OPC_ARITHMETIC, + SEXP_OPC_ARITHMETIC_INV, + SEXP_OPC_ARITHMETIC_CMP, + SEXP_OPC_IO, + SEXP_OPC_CONSTRUCTOR, + SEXP_OPC_ACCESSOR, + SEXP_OPC_PARAMETER, + SEXP_OPC_FOREIGN, + SEXP_OPC_NUM_OP_CLASSES +}; + +enum sexp_opcode_names { + SEXP_OP_NOOP, + SEXP_OP_RAISE, + SEXP_OP_RESUMECC, + SEXP_OP_CALLCC, + SEXP_OP_APPLY1, + SEXP_OP_TAIL_CALL, + SEXP_OP_CALL, + SEXP_OP_FCALL0, + SEXP_OP_FCALL1, + SEXP_OP_FCALL2, + SEXP_OP_FCALL3, + SEXP_OP_FCALL4, + SEXP_OP_FCALL5, + SEXP_OP_FCALL6, + SEXP_OP_JUMP_UNLESS, + SEXP_OP_JUMP, + SEXP_OP_PUSH, + SEXP_OP_DROP, + SEXP_OP_GLOBAL_REF, + SEXP_OP_GLOBAL_KNOWN_REF, + SEXP_OP_STACK_REF, + SEXP_OP_LOCAL_REF, + SEXP_OP_LOCAL_SET, + SEXP_OP_CLOSURE_REF, + SEXP_OP_VECTOR_REF, + SEXP_OP_VECTOR_SET, + SEXP_OP_VECTOR_LENGTH, + SEXP_OP_STRING_REF, + SEXP_OP_STRING_SET, + SEXP_OP_STRING_LENGTH, + SEXP_OP_MAKE_PROCEDURE, + SEXP_OP_MAKE_VECTOR, + SEXP_OP_MAKE_EXCEPTION, + SEXP_OP_AND, + SEXP_OP_NULLP, + SEXP_OP_FIXNUMP, + SEXP_OP_SYMBOLP, + SEXP_OP_CHARP, + SEXP_OP_EOFP, + SEXP_OP_TYPEP, + SEXP_OP_MAKE, + SEXP_OP_SLOT_REF, + SEXP_OP_SLOT_SET, + SEXP_OP_CAR, + SEXP_OP_CDR, + SEXP_OP_SET_CAR, + SEXP_OP_SET_CDR, + SEXP_OP_CONS, + SEXP_OP_ADD, + SEXP_OP_SUB, + SEXP_OP_MUL, + SEXP_OP_DIV, + SEXP_OP_QUOTIENT, + SEXP_OP_REMAINDER, + SEXP_OP_NEGATIVE, + SEXP_OP_INVERSE, + SEXP_OP_LT, + SEXP_OP_LE, + SEXP_OP_EQN, + SEXP_OP_EQ, + SEXP_OP_FIX2FLO, + SEXP_OP_FLO2FIX, + SEXP_OP_CHAR2INT, + SEXP_OP_INT2CHAR, + SEXP_OP_CHAR_UPCASE, + SEXP_OP_CHAR_DOWNCASE, + SEXP_OP_WRITE_CHAR, + SEXP_OP_NEWLINE, + SEXP_OP_READ_CHAR, + SEXP_OP_PEEK_CHAR, + SEXP_OP_RET, + SEXP_OP_DONE, + SEXP_OP_NUM_OPCODES +}; + +/**************************** prototypes ******************************/ + +SEXP_API void sexp_scheme_init (void); +SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env, sexp_uint_t size); +SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda); +SEXP_API sexp sexp_analyze (sexp context, sexp x); +SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args); +SEXP_API sexp sexp_eval (sexp context, sexp obj, sexp env); +SEXP_API sexp sexp_eval_string (sexp context, char *str, sexp env); +SEXP_API sexp sexp_load (sexp context, sexp expr, sexp env); +SEXP_API sexp sexp_make_env (sexp context); +SEXP_API sexp sexp_make_null_env (sexp context, sexp version); +SEXP_API sexp sexp_make_primitive_env (sexp context, sexp version); +SEXP_API sexp sexp_make_standard_env (sexp context, sexp version); +SEXP_API sexp sexp_load_standard_parameters (sexp context, sexp env); +SEXP_API sexp sexp_load_standard_env (sexp context, sexp env, sexp version); +SEXP_API sexp sexp_find_module_file (sexp ctx, char *file); +SEXP_API sexp sexp_load_module_file (sexp ctx, char *file, sexp env); +SEXP_API sexp sexp_add_module_directory (sexp ctx, sexp dir, sexp appendp); +SEXP_API sexp sexp_extend_env (sexp context, sexp env, sexp vars, sexp value); +SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls, sexp immutp); +SEXP_API sexp sexp_env_define (sexp context, sexp env, sexp sym, sexp val); +SEXP_API sexp sexp_env_cell (sexp env, sexp sym); +SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt); +SEXP_API sexp sexp_env_global_ref (sexp env, sexp sym, sexp dflt); +SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out); +SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); +SEXP_API sexp sexp_make_foreign (sexp ctx, char *name, int num_args, int flags, sexp_proc1 f, sexp data); +SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, int flags, sexp_proc1 f, sexp data); + +#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(sexp_proc1)f,NULL) +#define sexp_define_foreign_opt(c,e,s,n,f,d) sexp_define_foreign_aux(c,e,s,n,1,(sexp_proc1)f,d) + +SEXP_API sexp sexp_define_foreign_param (sexp ctx, sexp env, char *name, int num_args, sexp_proc1 f, char *param); + +#if SEXP_USE_TYPE_DEFS +SEXP_API sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type); +SEXP_API sexp sexp_make_constructor (sexp ctx, sexp name, sexp type); +SEXP_API sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index); +SEXP_API sexp sexp_make_setter (sexp ctx, sexp name, sexp type, sexp index); +#endif + +#endif /* ! SEXP_EVAL_H */ + diff --git a/include/chibi/features.h b/include/chibi/features.h new file mode 100644 index 00000000..9143a071 --- /dev/null +++ b/include/chibi/features.h @@ -0,0 +1,297 @@ +/* features.h -- general feature configuration */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +/* uncomment this to disable most features */ +/* Most features are enabled by default, but setting this */ +/* option will disable any not explicitly enabled. */ +/* #define SEXP_USE_NO_FEATURES 1 */ + +/* uncomment this to disable the module system */ +/* Currently this just loads the config.scm from main and */ +/* sets up an (import (module name)) macro. */ +/* #define SEXP_USE_MODULES 0 */ + +/* uncomment this to disable dynamic loading */ +/* If enabled, you can LOAD .so files with a */ +/* sexp_init_library(ctx, env) function provided. */ +/* #define SEXP_USE_DL 0 */ + +/* uncomment this to disable a simplifying optimization pass */ +/* This performs some simple optimizations such as dead-code */ +/* elimination, constant-folding, and directly propagating */ +/* non-mutated let values bound to constants or non-mutated */ +/* references. More than performance, this is aimed at reducing the */ +/* size of the compiled code, especially as the result of macro */ +/* expansions, so it's a good idea to leave it enabled. */ +/* #define SEXP_USE_SIMPLIFY 0 */ + +/* uncomment this to disable dynamic type definitions */ +/* This enables register-simple-type and related */ +/* opcodes for defining types, needed by the default */ +/* implementation of (srfi 9). */ +/* #define SEXP_USE_TYPE_DEFS 0 */ + +/* uncomment this to use the Boehm conservative GC */ +/* Conservative GCs make it easier to write extensions, */ +/* since you don't have to keep track of intermediate */ +/* variables, but can leak memory. Boehm is also a */ +/* very large library to link in. You may want to */ +/* enable this when debugging your own extensions, or */ +/* if you suspect a bug in the native GC. */ +/* #define SEXP_USE_BOEHM 1 */ + +/* uncomment this to just malloc manually instead of any GC */ +/* Mostly for debugging purposes, this is the no GC option. */ +/* You can use just the read/write API and */ +/* explicitly free sexps, though. */ +/* #define SEXP_USE_MALLOC 1 */ + +/* uncomment this to add conservative checks to the native GC */ +/* Please mail the author if enabling this makes a bug */ +/* go away and you're not working on your own C extension. */ +/* #define SEXP_USE_DEBUG_GC 1 */ + +/* uncomment this to make the heap common to all contexts */ +/* By default separate contexts can have separate heaps, */ +/* and are thus thread-safe and independant. */ +/* #define SEXP_USE_GLOBAL_HEAP 1 */ + +/* uncomment this to make type definitions common to all contexts */ +/* By default types are only global if you don't allow user type */ +/* definitions, so new types will be local to a given set of */ +/* contexts sharing thei heap. */ +/* #define SEXP_USE_GLOBAL_TYPES 1 */ + +/* uncomment this to make the symbol table common to all contexts */ +/* Will still be restricted to all contexts sharing the same */ +/* heap, of course. */ +/* #define SEXP_USE_GLOBAL_SYMBOLS 1 */ + +/* uncomment this 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 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 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. */ + +/************************************************************************/ +/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ +/************************************************************************/ + +#ifndef SEXP_64_BIT +#if defined(__amd64) || defined(__x86_64) +#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 +#define _GNU_SOURCE +#endif + +#ifndef SEXP_USE_NO_FEATURES +#define SEXP_USE_NO_FEATURES 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 +#ifdef PLAN9 +#define SEXP_USE_DL 0 +#else +#define SEXP_USE_DL ! SEXP_USE_NO_FEATURES +#endif +#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_DEBUG_GC +#define SEXP_USE_DEBUG_GC 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_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_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_STRING_STREAMS +#define SEXP_USE_STRING_STREAMS ! SEXP_USE_NO_FEATURES +#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 + +#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)) +#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..369e3b65 --- /dev/null +++ b/include/chibi/sexp.h @@ -0,0 +1,862 @@ +/* sexp.h -- header for sexp library */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifndef SEXP_H +#define SEXP_H + +#define SEXP_MODULE_PATH_VAR "CHIBI_MODULE_PATH" + +#include "chibi/features.h" +#include "chibi/install.h" + +#include +#include + +#if SEXP_USE_DL +#include +#endif + +#ifdef PLAN9 +#include +#include +#include +#include +#include <9p.h> +typedef unsigned long size_t; +#else +#include +#include +#include +#include +#include +#include +#include +#endif + +/* tagging system + * bits end in 00: pointer + * 01: fixnum + * 011: immediate flonum (optional) + * 111: immediate symbol (optional) + * 0110: char + * 1110: other immediate object (NULL, TRUE, FALSE) + */ + +#define SEXP_FIXNUM_BITS 2 +#define SEXP_IMMEDIATE_BITS 3 +#define SEXP_EXTENDED_BITS 4 + +#define SEXP_FIXNUM_MASK 3 +#define SEXP_IMMEDIATE_MASK 7 +#define SEXP_EXTENDED_MASK 15 + +#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 + +#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_CHAR, + SEXP_BOOLEAN, + SEXP_PAIR, + SEXP_SYMBOL, + 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 +}; + +typedef unsigned long sexp_uint_t; +typedef long sexp_sint_t; +#if SEXP_64_BIT +typedef unsigned int sexp_tag_t; +#else +typedef unsigned short sexp_tag_t; +#endif +typedef struct sexp_struct *sexp; + +#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) + +/* procedure types */ +typedef sexp (*sexp_proc0) (void); +typedef sexp (*sexp_proc1) (sexp); +typedef sexp (*sexp_proc2) (sexp, sexp); +typedef sexp (*sexp_proc3) (sexp, sexp, sexp); +typedef sexp (*sexp_proc4) (sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc5) (sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc6) (sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc7) (sexp, sexp, sexp, sexp, sexp, sexp, sexp); + +typedef struct sexp_free_list *sexp_free_list; +struct sexp_free_list { + sexp_uint_t size; + sexp_free_list next; +}; + +typedef struct sexp_heap *sexp_heap; +struct sexp_heap { + sexp_uint_t size; + sexp_free_list free_list; + sexp_heap next; + char *data; +}; + +struct sexp_gc_var_t { + sexp *var; + /* char *name; */ + struct sexp_gc_var_t *next; +}; + +struct sexp_struct { + sexp_tag_t tag; + char gc_mark; + unsigned int immutablep:1; + unsigned int freep:1; + union { + /* basic types */ + double flonum; + 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; + } type; + struct { + sexp car, cdr; + sexp source; + } pair; + struct { + sexp_uint_t length; + sexp data[]; + } vector; + struct { + sexp_uint_t length; + char data[]; + } string; + struct { + sexp string; + } symbol; + struct { + FILE *stream; + char *buf; + char openp, sourcep; + sexp_uint_t offset, line; + size_t size; + sexp name; + sexp cookie; + } port; + struct { + sexp kind, message, irritants, procedure, source; + } exception; + struct { + 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 { + unsigned int syntacticp:1; + sexp parent, lambda, bindings; + } env; + struct { + sexp_uint_t length; + sexp name, literals; + 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 { + unsigned char op_class, code, num_args, flags, + arg1_type, arg2_type, inverse; + char *name; + sexp data, data2, proc; + sexp_proc1 func; + } opcode; + struct { + char code; + char *name; + } core; + /* ast types */ + struct { + sexp name, params, body, defs, locals, flags, fv, sv; + } lambda; + struct { + sexp test, pass, fail; + } cnd; + struct { + sexp var, value; + } set; + struct { + sexp name, cell; + } ref; + struct { + sexp ls; + } seq; + struct { + sexp value; + } lit; + /* compiler state */ + struct { + sexp_uint_t length, top; + sexp data[]; + } stack; + struct { + sexp_heap heap; + struct sexp_gc_var_t *saves; + sexp_uint_t pos, depth, tailp, tracep; + sexp bc, lambda, stack, env, fv, parent, globals; + } 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_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)) + +#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)) + +#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_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))) +#else +#define sexp_fixnum_to_flonum(ctx, x) (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_string_length(x) ((x)->value.string.length) +#define sexp_string_data(x) ((x)->value.string.data) + +#define sexp_string_ref(x, i) (sexp_make_character(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_string(x) ((x)->value.symbol.string) + +#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_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_data(x) ((x)->value.bytecode.data) + +#define sexp_env_syntactic_p(x) ((x)->value.env.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_arg1_type(x) ((x)->value.opcode.arg1_type) +#define sexp_opcode_arg2_type(x) ((x)->value.opcode.arg2_type) +#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_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_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_set_var(x) ((x)->value.set.var) +#define sexp_set_value(x) ((x)->value.set.value) + +#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_seq_ls(x) ((x)->value.seq.ls) + +#define sexp_lit_value(x) ((x)->value.lit.value) + +#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_saves(x) ((x)->value.context.saves) +#define sexp_context_tailp(x) ((x)->value.context.tailp) +#define sexp_context_tracep(x) ((x)->value.context.tailp) +#define sexp_context_globals(x) ((x)->value.context.globals) + +#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, + 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, char *str, sexp_uint_t len, sexp p); +SEXP_API sexp sexp_buffered_write_string (sexp ctx, 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)) + +SEXP_API sexp sexp_make_context(sexp ctx, sexp_uint_t size); +SEXP_API sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); +SEXP_API sexp sexp_cons(sexp ctx, sexp head, sexp tail); +SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b); +SEXP_API sexp sexp_equalp (sexp ctx, sexp a, sexp b); +SEXP_API sexp sexp_listp(sexp ctx, sexp obj); +SEXP_API sexp sexp_reverse(sexp ctx, sexp ls); +SEXP_API sexp sexp_nreverse(sexp ctx, sexp ls); +SEXP_API sexp sexp_append2(sexp ctx, sexp a, sexp b); +SEXP_API sexp sexp_memq(sexp ctx, sexp x, sexp ls); +SEXP_API sexp sexp_assq(sexp ctx, sexp x, sexp ls); +SEXP_API sexp sexp_length(sexp ctx, sexp ls); +SEXP_API sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen); +SEXP_API sexp sexp_make_string(sexp ctx, sexp len, sexp ch); +SEXP_API sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end); +SEXP_API sexp sexp_string_concatenate (sexp ctx, sexp str_ls, sexp sep); +SEXP_API sexp sexp_intern(sexp ctx, char *str); +SEXP_API sexp sexp_string_to_symbol(sexp ctx, sexp str); +SEXP_API sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt); +SEXP_API sexp sexp_list_to_vector(sexp ctx, sexp ls); +SEXP_API sexp sexp_make_cpointer(sexp ctx, sexp_uint_t typeid, void* value, sexp parent, int freep); +SEXP_API sexp sexp_write(sexp ctx, sexp obj, sexp out); +SEXP_API sexp sexp_display(sexp ctx, sexp obj, sexp out); +SEXP_API sexp sexp_flush_output(sexp ctx, 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(sexp ctx, sexp in); +SEXP_API sexp sexp_read_from_string(sexp ctx, char *str); +SEXP_API sexp sexp_write_to_string(sexp ctx, sexp obj); +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(sexp ctx, sexp str); +SEXP_API sexp sexp_make_output_string_port(sexp ctx); +SEXP_API sexp sexp_get_output_string(sexp ctx, 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, char *message, sexp obj); +SEXP_API sexp sexp_type_exception(sexp ctx, char *message, sexp obj); +SEXP_API sexp sexp_range_exception(sexp ctx, sexp obj, sexp start, sexp end); +SEXP_API sexp sexp_print_exception(sexp ctx, sexp exn, sexp out); +SEXP_API void sexp_init(void); + +#if SEXP_USE_GLOBAL_HEAP +#define sexp_destroy_context(ctx) +#else +SEXP_API void sexp_destroy_context(sexp ctx); +#endif + +#if SEXP_USE_TYPE_DEFS +SEXP_API sexp sexp_register_type (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2); +SEXP_API sexp sexp_register_simple_type (sexp ctx, 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 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, 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))) + +#endif /* ! SEXP_H */ + diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c new file mode 100644 index 00000000..19721c10 --- /dev/null +++ b/lib/chibi/ast.c @@ -0,0 +1,80 @@ +/* ast.c -- interface to the Abstract Syntax Tree */ +/* Copyright (c) 2009 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), 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), 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), op); + sexp_gc_release2(ctx); +} + +static sexp sexp_get_env_cell (sexp ctx, 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 op) { + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, "not an opcode", op); + else if (! sexp_opcode_name(op)) + return SEXP_FALSE; + else + return sexp_intern(ctx, sexp_opcode_name(op)); +} + +sexp sexp_init_library (sexp ctx, sexp env) { + 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_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_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_foreign(ctx, env, "analyze", 1, sexp_analyze); + 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); + return SEXP_VOID; +} + diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module new file mode 100644 index 00000000..57068ece --- /dev/null +++ b/lib/chibi/ast.module @@ -0,0 +1,14 @@ + +(define-module (chibi ast) + (export analyze env-cell opcode-name + syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? + syntactic-closure-expr syntactic-closure-env syntactic-closure-vars + lambda-name lambda-params lambda-body lambda-defs + lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-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!) + (include-shared "ast")) + diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c new file mode 100644 index 00000000..89fde159 --- /dev/null +++ b/lib/chibi/disasm.c @@ -0,0 +1,116 @@ +/* disasm.c -- optional debugging utilities */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#define SEXP_DISASM_MAX_DEPTH 8 +#define SEXP_DISASM_PAD_WIDTH 4 + +static const char* reverse_opcode_names[] = + {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", + "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", + "JUMP-UNLESS", "JUMP", "PUSH", "DROP", "GLOBAL-REF", "GLOBAL-KNOWN-REF", + "STACK-REF", "LOCAL-REF", "LOCAL-SET", + "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-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", "CAR", "CDR", + "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", + "MUL", "DIV", "QUOTIENT", "REMAINDER", "NEGATIVE", "INVERSE", + "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT", + "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", + "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", "RET", "DONE", + }; + +static sexp disasm (sexp ctx, 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, "not a procedure", bc); + } + if (! sexp_oportp(out)) { + return sexp_type_exception(ctx, "not an output-port", 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: + case SEXP_OP_FCALL5: + case SEXP_OP_FCALL6: + sexp_printf(ctx, out, "%ld", (sexp_sint_t) ((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, 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 bc, sexp out) { + return disasm(ctx, bc, out, 0); +} + +sexp sexp_init_library (sexp ctx, 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..38a8fab1 --- /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 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 + ) + (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..8c42466f --- /dev/null +++ b/lib/chibi/filesystem.stub @@ -0,0 +1,115 @@ + +(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 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")) diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c new file mode 100644 index 00000000..34e415c1 --- /dev/null +++ b/lib/chibi/heap-stats.c @@ -0,0 +1,129 @@ +/* heap-stats.c -- count or dump heap objects */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +#define SEXP_HEAP_VECTOR_DEPTH 1 + +#if SEXP_64_BIT +#define sexp_heap_align(n) sexp_align(n, 5) +#else +#define sexp_heap_align(n) sexp_align(n, 4) +#endif + +extern sexp sexp_gc (sexp ctx, size_t *sum_freed); +extern sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x); + +#if SEXP_USE_GLOBAL_HEAP +#endif + +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)); + 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) { + return sexp_heap_walk(ctx, 0, 0); +} + +static sexp sexp_heap_dump (sexp ctx, sexp depth) { + if (! sexp_fixnump(depth) || (sexp_unbox_fixnum(depth) < 0)) + return sexp_type_exception(ctx, "bad heap-dump depth", depth); + return sexp_heap_walk(ctx, sexp_unbox_fixnum(depth), 1); +} + +sexp sexp_init_library (sexp ctx, 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..af84ca44 --- /dev/null +++ b/lib/chibi/heap-stats.module @@ -0,0 +1,5 @@ + +(define-module (chibi heap-stats) + (export heap-stats heap-dump) + (include-shared "heap-stats")) + diff --git a/lib/chibi/io.module b/lib/chibi/io.module new file mode 100644 index 00000000..f20b5b31 --- /dev/null +++ b/lib/chibi/io.module @@ -0,0 +1,6 @@ + +(define-module (chibi io) + (export read-string read-string! write-string read-line write-line) + (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..3ffa8a98 --- /dev/null +++ b/lib/chibi/io/io.scm @@ -0,0 +1,6 @@ + +(define (write-line str . o) + (let ((out (if (pair? o) (car o) (current-output-port)))) + (display str out) + (newline out))) + diff --git a/lib/chibi/io/io.stub b/lib/chibi/io/io.stub new file mode 100644 index 00000000..665d1bb5 --- /dev/null +++ b/lib/chibi/io/io.stub @@ -0,0 +1,13 @@ + +(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 arg1)) size_t (value 1 size_t) (default (current-input-port) input-port))) + +(define-c size_t (read-string! "fread") + (string size_t (value 1 size_t) (default (current-input-port) input-port))) + +(define-c size_t (write-string "fwrite") + (string size_t (value 1 size_t) (default (current-output-port) output-port))) + 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/macroexpand.module b/lib/chibi/macroexpand.module new file mode 100644 index 00000000..47b0e7d4 --- /dev/null +++ b/lib/chibi/macroexpand.module @@ -0,0 +1,6 @@ + +(define-module (chibi macroexpand) + (import-immutable (scheme)) + (import (chibi ast)) + (export macroexpand) + (include "macroexpand.scm")) diff --git a/lib/chibi/macroexpand.scm b/lib/chibi/macroexpand.scm new file mode 100644 index 00000000..a040855a --- /dev/null +++ b/lib/chibi/macroexpand.scm @@ -0,0 +1,85 @@ +;; macroexpand.scm -- macro expansion utility +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; This actually analyzes the expression then reverse-engineers an +;; sexp from the result, generating a minimal amount of renames. + +(define (macroexpand x) + (ast->sexp (analyze 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 (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 (cadr 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/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..963b89ff --- /dev/null +++ b/lib/chibi/match/match.scm @@ -0,0 +1,670 @@ +;;;; 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 (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))))))) + +;; 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/net.module b/lib/chibi/net.module new file mode 100644 index 00000000..41cdafe4 --- /dev/null +++ b/lib/chibi/net.module @@ -0,0 +1,10 @@ + +(define-module (chibi net) + (export sockaddr? address-info? get-address-info socket connect with-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..85ed756a --- /dev/null +++ b/lib/chibi/net.scm @@ -0,0 +1,23 @@ +;; net.scm -- the high-level network interface +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (with-net-io host service proc) + (let lp ((addr (get-address-info host 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)) + (let ((in (open-input-file-descriptor sock)) + (out (open-output-file-descriptor sock))) + (let ((res (proc in out))) + (close-input-port in) + 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/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..fe03c2e5 --- /dev/null +++ b/lib/chibi/process.module @@ -0,0 +1,17 @@ + +(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)) + (include-shared "process")) + diff --git a/lib/chibi/process.stub b/lib/chibi/process.stub new file mode 100644 index 00000000..7dbca7eb --- /dev/null +++ b/lib/chibi/process.stub @@ -0,0 +1,72 @@ + +(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) sexp sexp)) + +(define-c errno (make-signal-set "sigemptyset") ((result sigset_t))) +(define-c errno (signal-set-fill! "sigfillset") (sigset_t)) +(define-c errno (signal-set-add! "sigaddset") (sigset_t int)) +(define-c errno (signal-set-delete! "sigaddset") (sigset_t int)) +(define-c boolean (signal-set-contains? "sigismember") (sigset_t int)) + +(define-c errno (signal-mask-block! "sigprocmask") + ((value SIG_BLOCK int) sigset_t (value NULL sigset_t))) +(define-c errno (signal-mask-unblock! "sigprocmask") + ((value SIG_UNBLOCK int) sigset_t (value NULL sigset_t))) +(define-c errno (signal-mask-set! "sigprocmask") + ((value SIG_SETMASK int) sigset_t (value NULL sigset_t))) +(define-c errno (current-signal-mask "sigprocmask") + ((value SIG_BLOCK int) (value NULL sigset_t) (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))) + diff --git a/lib/chibi/signal.c b/lib/chibi/signal.c new file mode 100644 index 00000000..463e481d --- /dev/null +++ b/lib/chibi/signal.c @@ -0,0 +1,62 @@ +/* signal.c -- process signals interface */ +/* Copyright (c) 2009 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 void sexp_call_sigaction (int signum, siginfo_t *info, void *uctx) { + sexp ctx, sigctx, handler; + sexp_gc_var1(args); + ctx = sexp_signal_contexts[signum]; + if (ctx) { + handler = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), + sexp_make_fixnum(signum)); + if (sexp_truep(handler)) { + sigctx = sexp_make_child_context(ctx, NULL); + sexp_gc_preserve1(sigctx, args); + args = sexp_cons(sigctx, SEXP_FALSE, SEXP_NULL); + sexp_car(args) + = sexp_make_cpointer(sigctx, sexp_siginfo_t_type_id, info, SEXP_FALSE, 0); + args = sexp_cons(sigctx, SEXP_FALSE, args); + sexp_car(args) = sexp_make_fixnum(signum); + sexp_apply(sigctx, handler, args); + sexp_gc_release1(sigctx); + } + } +} + +static struct sigaction call_sigaction = { + .sa_sigaction = sexp_call_sigaction, + .sa_flags = SA_SIGINFO | SA_NODEFER +}; + +static struct sigaction call_sigdefault = {.sa_handler = SIG_DFL}; +static struct sigaction call_sigignore = {.sa_handler = SIG_IGN}; + +static sexp sexp_set_signal_action (sexp ctx, sexp signum, sexp newaction) { + int res; + sexp oldaction; + if (! (sexp_fixnump(signum) && sexp_unbox_fixnum(signum) > 0 + && sexp_unbox_fixnum(signum) < SEXP_MAX_SIGNUM)) + return sexp_type_exception(ctx, "not a valid signal number", signum); + if (! (sexp_procedurep(newaction) || sexp_opcodep(newaction) + || sexp_booleanp(newaction))) + return sexp_type_exception(ctx, "not a 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, SEXP_FALSE, "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; +} + 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/time.module b/lib/chibi/time.module new file mode 100644 index 00000000..84f2b800 --- /dev/null +++ b/lib/chibi/time.module @@ -0,0 +1,11 @@ + +(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?) + (import-immutable (scheme)) + (include-shared "time")) + diff --git a/lib/chibi/time.stub b/lib/chibi/time.stub new file mode 100644 index 00000000..bb5cd644 --- /dev/null +++ b/lib/chibi/time.stub @@ -0,0 +1,45 @@ + +(c-system-include "time.h") +(c-system-include "sys/time.h") + +(define-c-struct 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/uri.module b/lib/chibi/uri.module new file mode 100644 index 00000000..2456dd9f --- /dev/null +++ b/lib/chibi/uri.module @@ -0,0 +1,10 @@ + +(define-module (chibi uri) + (export uri->string make-uri string->uri + uri-scheme uri-user uri-host 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..1254360d --- /dev/null +++ b/lib/config.scm @@ -0,0 +1,174 @@ +;; config.scm -- configuration module +;; Copyright (c) 2009 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)) +(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))) + (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 include-shared) + (for-each + (lambda (f) + (let ((f (string-append + dir f + (if (eq? (car x) 'include) "" *shared-object-extension*)))) + (cond + ((find-module-file f) => (lambda (x) (load x env))) + (else (error "couldn't find include" f))))) + (cdr x))) + ((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) '())) + (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..e1b7b256 --- /dev/null +++ b/lib/init.scm @@ -0,0 +1,881 @@ +;; 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 (null? (car lol)) + (reverse res) + (mapn proc + (map1 cdr lol '()) + (cons (apply1 proc (map1 car lol '())) 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) + (if (identifier? (cadr expr)) + `(,(rename 'letrec) ((,(cadr expr) + (,(rename 'lambda) ,(map car bindings) + ,@(cdddr expr)))) + ,(cons (cadr expr) (map cadr bindings))) + `((,(rename 'lambda) ,(map car bindings) ,@(cddr expr)) + ,@(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? fixnum?) +(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 n . o) + (if (if (null? o) #t (eq? 10 (car o))) + (call-with-output-string (lambda (out) (write n out))) + (let lp ((n n) (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 res)))))) + +(define (string->number str . o) + (let ((res + (if (if (null? o) #t (eq? 10 (car o))) + (call-with-input-string str (lambda (in) (read in))) + (let ((len (string-length str))) + (let lp ((i 0) (d (car o)) (acc 0)) + (if (>= i len) + acc + (let ((v (digit-value (string-ref str i)))) + (and v (lp (+ i 1) d (+ (* acc d) v)))))))))) + (and (number? 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..e205cee0 --- /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) count)) + (step (if (and (pair? o) (pair? (cdr o))) (cadr o) 1))) + (let lp ((i count) (n (- start 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..70ee5cc5 --- /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)))) + (filter (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..f2ffc4ae --- /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 (cdr b) (if (member (car b) a eq) a (cons (car b) a))))) + +(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/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..d5d3d984 --- /dev/null +++ b/lib/srfi/27/rand.c @@ -0,0 +1,204 @@ +/* rand.c -- rand_r/random_r interface */ +/* Copyright (c) 2009 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 +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 rs, sexp bound) { + sexp res; + int32_t n; +#if SEXP_USE_BIGNUMS + int32_t hi, mod, len, i, *data; +#endif + if (! sexp_random_source_p(rs)) + res = sexp_type_exception(ctx, "not a random-source", rs); + if (sexp_fixnump(bound)) { + sexp_call_random(rs, n); + res = sexp_make_fixnum(n % 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 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, y, x); +#endif + else + res = sexp_type_exception(ctx, "bitwise-and: not an integer", 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, 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, "arithmetic-shift: not an integer", 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 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 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, "integer-length: not an integer", x); + } +} + +static sexp sexp_bit_set_p (sexp ctx, sexp i, sexp x) { +#if SEXP_USE_BIGNUMS + sexp_uint_t pos; +#endif + if (! sexp_fixnump(i)) + return sexp_type_exception(ctx, "bit-set?: not an integer", i); + if (sexp_fixnump(x)) { + return sexp_make_boolean(sexp_unbox_fixnum(x) & (1<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..e38c23c0 --- /dev/null +++ b/lib/srfi/69/hash.c @@ -0,0 +1,242 @@ +/* hash.c -- type-general hashing */ +/* Copyright (c) 2009 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 str, sexp bound) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "string-hash: not a string", str); + else if (! sexp_integerp(bound)) + return sexp_type_exception(ctx, "string-hash: not an integer", 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 str, sexp bound) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "string-ci-hash: not a string", str); + else if (! sexp_integerp(bound)) + return sexp_type_exception(ctx, "string-ci-hash: not an integer", 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..0516b201 --- /dev/null +++ b/lib/srfi/9.module @@ -0,0 +1,82 @@ + +(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)) + (make (caaddr expr)) + (make-fields (cdaddr expr)) + (pred (cadddr expr)) + (fields (cddddr expr)) + (num-fields (length fields)) + (index (register-simple-type (symbol->string name) num-fields)) + (_define (rename 'define)) + (_lambda (rename 'lambda)) + (_let (rename 'let))) + (define (index-of field ls) + (let lp ((ls ls) (i 0)) + (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1))))) + `(,(rename 'begin) + (,_define ,pred (,(rename 'make-type-predicate) + ,(symbol->string pred) + ,index)) + ,@(let lp ((ls fields) (i 0) (res '())) + (if (null? ls) + res + (let ((res + (cons `(,_define ,(cadar ls) + (,(rename 'make-getter) + ,(symbol->string (cadar ls)) + ,index + ,i)) + res))) + (lp (cdr ls) + (+ i 1) + (if (pair? (cddar ls)) + (cons + `(,_define ,(caddar ls) + (,(rename 'make-setter) + ,(symbol->string (caddar ls)) + ,index + ,i)) + res) + res))))) + (,_define ,make + ,(let lp ((ls make-fields) (sets '()) (set-defs '())) + (cond + ((null? ls) + `(,_let ((%make (,(rename 'make-constructor) + ,(symbol->string make) + ,index)) + ,@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 "%" (symbol->string name) "-" + (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 + index + (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..25e0d3ff --- /dev/null +++ b/lib/srfi/95.module @@ -0,0 +1,7 @@ + +(define-module (srfi 95) + (export sorted? merge merge! sort sort!) + (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..6b304e54 --- /dev/null +++ b/lib/srfi/95/qsort.c @@ -0,0 +1,170 @@ +/* qsort.c -- quicksort implementation */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#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 2) { + sexp_qsort(ctx, vec, lo, j-1); + lo = j+1; + goto loop; + } + } +} + +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]); + sexp_car(args1) = tmp; + b = sexp_apply(ctx, key, args1); + for (i=j=lo; i < hi; i++) { + sexp_car(args1) = vec[i]; + a = sexp_apply(ctx, key, args1); + 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+1; + goto loop; + } + } + done: + sexp_gc_release3(ctx); + return res; +} + +static sexp sexp_sort_x (sexp ctx, 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, "sort: not a 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, "sort: not a procedure", less); + } else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) { + res = sexp_type_exception(ctx, "sort: not a procedure", less); + } 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 env) { + 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..38273199 --- /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) + #f) + (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..38f8b883 --- /dev/null +++ b/lib/srfi/98/env.c @@ -0,0 +1,48 @@ +/* env.c -- SRFI-98 environment interface */ +/* Copyright (c) 2009 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 str) { + char *cstr; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "get-environment-variable: not a 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) { + 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 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..6edd9185 --- /dev/null +++ b/main.c @@ -0,0 +1,193 @@ +/* main.c -- chibi-scheme command-line app */ +/* Copyright (c) 2009 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 "))" + +#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_context_env(ctx); + sexp_context_tracep(ctx) = 1; + in = sexp_eval_string(ctx, "(current-input-port)", env); + out = sexp_eval_string(ctx, "(current-output-port)", env); + err = sexp_eval_string(ctx, "(current-error-port)", env); + 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); + } else { +#if SEXP_USE_WARN_UNDEFS + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, err); +#endif + if (res != SEXP_VOID) { + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); + } + } + } + } + sexp_gc_release4(ctx); +} + +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); + 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); + res = check_exception(ctx, sexp_read_from_string(ctx, arg)); + res = check_exception(ctx, sexp_eval(ctx, res, env)); + if (print) { + if (! sexp_oportp(out)) + out = sexp_eval_string(ctx, "(current-output-port)", env); + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); + } + quit = 1; + i++; + break; + case 'l': + load_init(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_exception(ctx, sexp_load_module_file(ctx, argv[++i], env)); + break; + case 'm': + load_init(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + 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, 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); + 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); + 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); + 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': + printf("chibi-scheme 0.3\n"); + 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), args); + sexp_eval_string(ctx, sexp_argv_proc, 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"); + 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); +} + +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..fdce3e9f --- /dev/null +++ b/mkfile @@ -0,0 +1,26 @@ + include/chibi/install.h + echo '#define sexp_platform "plan9"' >> 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..85a35afc --- /dev/null +++ b/opcodes.c @@ -0,0 +1,153 @@ + +#define _OP(c,o,n,m,t,u,i,s,d,f) \ + {.tag=SEXP_OPCODE, \ + .value={.opcode={c, o, n, m, t, u, i, s, d, NULL, NULL, f}}} +#define _FN(o,n,m,t,u,s,d,f) _OP(SEXP_OPC_FOREIGN, o, n, m, t, u, 0, s, d, (sexp_proc1)f) +#define _FN0(s, d, f) _FN(SEXP_OP_FCALL0, 0, 0, 0, 0, s, d, f) +#define _FN1(t, s, d, f) _FN(SEXP_OP_FCALL1, 1, 0, t, 0, s, d, f) +#define _FN1OPT(t, s, d, f) _FN(SEXP_OP_FCALL1, 0, 1, t, u, s, d, f) +#define _FN1OPTP(t, s, d, f) _FN(SEXP_OP_FCALL1, 0, 3, t, 0, s, d, f) +#define _FN2(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 2, 0, t, u, s, d, f) +#define _FN2OPT(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 1, 1, t, u, s, d, f) +#define _FN2OPTP(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 1, 3, t, u, s, d, f) +#define _FN3(t, u, s, d, f) _FN(SEXP_OP_FCALL3, 3, 0, t, u, s, d, f) +#define _FN4(t, u, s, d, f) _FN(SEXP_OP_FCALL4, 4, 0, t, u, s, d, f) +#define _FN5(t, u, s, d, f) _FN(SEXP_OP_FCALL5, 5, 0, t, u, s, d, f) +#define _FN6(t, u, s, d, f) _FN(SEXP_OP_FCALL6, 6, 0, t, u, s, d, f) +#define _PARAM(n, a, t) _OP(SEXP_OPC_PARAMETER, SEXP_OP_NOOP, 0, 3, t, 0, 0, n, a, 0) + +static struct sexp_struct opcodes[] = { +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_INT2CHAR, 1, 0, SEXP_FIXNUM, 0, 0, "integer->char", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_DOWNCASE, 1, 0, SEXP_CHAR, 0, 0, "char-downcase", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", sexp_make_fixnum(0), NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", sexp_make_fixnum(1), NULL), +_OP(SEXP_OPC_ARITHMETIC_INV, SEXP_OP_SUB, 0, 1, SEXP_FIXNUM, 0, SEXP_OP_NEGATIVE, "-", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_INV, SEXP_OP_DIV, 0, 1, SEXP_FIXNUM, 0, SEXP_OP_INVERSE, "/", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_QUOTIENT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_REMAINDER, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "remainder", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, SEXP_FIXNUM, 0, 0, "<", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, SEXP_FIXNUM, 0, 0, "<=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, SEXP_FIXNUM, 0, 1, ">", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, SEXP_FIXNUM, 0, 1, ">=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_EQN, 2, 1, SEXP_FIXNUM, 0, 0, "=", 0, NULL), +_OP(SEXP_OPC_PREDICATE, SEXP_OP_EQ, 2, 0, 0, 0, 0, "eq?", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_CONS, 2, 0, 0, 0, 0, "cons", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_VOID, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_EXCEPTION, 5, 0, 0, 0, 0, "make-exception", 0, NULL), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_FIXNUMP, 1, 0, 0, 0, 0, "fixnum?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "pair?", sexp_make_fixnum(SEXP_PAIR), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "string?", sexp_make_fixnum(SEXP_STRING), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "vector?", sexp_make_fixnum(SEXP_VECTOR), 0), +#if SEXP_USE_IMMEDIATE_FLONUMS +_FN1(0, "flonum?", 0, sexp_flonum_predicate), +#else +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", sexp_make_fixnum(SEXP_FLONUM), 0), +#endif +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "bignum?", sexp_make_fixnum(SEXP_BIGNUM), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "closure?", sexp_make_fixnum(SEXP_PROCEDURE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", sexp_make_fixnum(SEXP_OPCODE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", sexp_make_fixnum(SEXP_IPORT), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", sexp_make_fixnum(SEXP_OPORT), 0), +_OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "%call/cc", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, SEXP_STRING, 0, 0, 0, "raise", 0, NULL), +_OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, 0, SEXP_IPORT, 0, "peek-char", (sexp)"*current-input-port*", NULL), +_FN1OPTP(SEXP_IPORT, "read", (sexp)"*current-input-port*", sexp_read), +_FN2OPTP(0, SEXP_OPORT, "write", (sexp)"*current-output-port*", sexp_write), +_FN2OPTP(0, SEXP_OPORT, "display", (sexp)"*current-output-port*", sexp_display), +_FN1OPTP(SEXP_OPORT, "flush-output", (sexp)"*current-output-port*", sexp_flush_output), +_FN2(0, 0, "equal?", 0, sexp_equalp), +_FN1(0, "list?", 0, sexp_listp), +_FN1(0, "identifier?", 0, sexp_identifierp), +_FN1(0, "identifier->symbol", 0, sexp_syntactic_closure_expr), +_FN4(0, SEXP_ENV, "identifier=?", 0, sexp_identifier_eq), +_FN1(SEXP_PAIR, "length", 0, sexp_length), +_FN1(SEXP_PAIR, "reverse", 0, sexp_reverse), +_FN1(SEXP_PAIR, "reverse!", 0, sexp_nreverse), +_FN2(SEXP_PAIR, SEXP_PAIR, "append2", 0, sexp_append2), +_FN1(SEXP_PAIR, "list->vector", 0, sexp_list_to_vector), +_FN1(SEXP_STRING, "open-input-file", 0, sexp_open_input_file), +_FN1(SEXP_STRING, "open-output-file", 0, sexp_open_output_file), +_FN1(SEXP_IPORT, "close-input-port", 0, sexp_close_port), +_FN1(SEXP_OPORT, "close-output-port", 0, sexp_close_port), +_FN0("make-environment", 0, sexp_make_env), +_FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env), +_FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env), +_FN2OPTP(0, SEXP_ENV, "eval", (sexp)"*interaction-environment*", sexp_eval), +_FN2OPTP(SEXP_STRING, SEXP_ENV, "load", (sexp)"*interaction-environment*", sexp_load), +_FN4(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy), +_FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception), +_FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_func), +_FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_make_string), +_FN3(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp), +_FN3(SEXP_STRING, SEXP_FIXNUM, "substring", 0, sexp_substring), +_FN1(SEXP_STRING, "string->symbol", 0, sexp_string_to_symbol), +_FN2OPT(SEXP_PAIR, SEXP_STRING, "string-concatenate", SEXP_FALSE, sexp_string_concatenate), +_FN2(0, SEXP_PAIR, "memq", 0, sexp_memq), +_FN2(0, SEXP_PAIR, "assq", 0, sexp_assq), +_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", 0, sexp_make_synclo), +_FN1(0, "strip-syntactic-closures", 0, sexp_strip_synclos), +_PARAM("current-input-port", (sexp)"*current-input-port*", SEXP_IPORT), +_PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT), +_PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT), +_PARAM("current-exception-handler", (sexp)"*current-exception-handler*", SEXP_PROCEDURE), +_PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV), +_FN0("open-output-string", 0, sexp_make_output_string_port), +_FN1(SEXP_STRING, "open-input-string", 0, sexp_make_input_string_port), +_FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string), +#if SEXP_USE_MATH +_FN1(0, "exp", 0, sexp_exp), +_FN1(0, "log", 0, sexp_log), +_FN1(0, "sin", 0, sexp_sin), +_FN1(0, "cos", 0, sexp_cos), +_FN1(0, "tan", 0, sexp_tan), +_FN1(0, "asin", 0, sexp_asin), +_FN1(0, "acos", 0, sexp_acos), +_FN1(0, "atan1", 0, sexp_atan), +_FN1(0, "sqrt", 0, sexp_sqrt), +_FN1(0, "round", 0, sexp_round), +_FN1(0, "truncate", 0, sexp_trunc), +_FN1(0, "floor", 0, sexp_floor), +_FN1(0, "ceiling", 0, sexp_ceiling), +#endif +_FN2(0, 0, "expt", 0, sexp_expt), +#if SEXP_USE_TYPE_DEFS +_FN2(SEXP_STRING, SEXP_FIXNUM, "register-simple-type", 0, sexp_register_simple_type), +_FN2(SEXP_STRING, SEXP_FIXNUM, "make-type-predicate", 0, sexp_make_type_predicate), +_FN2(SEXP_STRING, SEXP_FIXNUM, "make-constructor", 0, sexp_make_constructor), +_FN3(SEXP_STRING, SEXP_FIXNUM, "make-getter", 0, sexp_make_getter), +_FN3(SEXP_STRING, SEXP_FIXNUM, "make-setter", 0, sexp_make_setter), +#endif +#if PLAN9 +#include "opt/plan9-opcodes.c" +#endif +#if SEXP_USE_MODULES +_FN1(SEXP_ENV, "env-exports", 0, sexp_env_exports), +_FN1(SEXP_STRING, "find-module-file", 0, sexp_find_module_file_op), +_FN2(SEXP_STRING, SEXP_ENV, "load-module-file", 0, sexp_load_module_file_op), +_FN2(SEXP_STRING, SEXP_BOOLEAN, "add-module-directory", 0, sexp_add_module_directory), +#endif +}; + diff --git a/opt/bignum.c b/opt/bignum.c new file mode 100644 index 00000000..60215de8 --- /dev/null +++ b/opt/bignum.c @@ -0,0 +1,751 @@ +/* bignum.c -- bignum support */ +/* Copyright (c) 2009 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_make_fixnum(0)); + scale = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1)); + 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); + memcpy(dst, a, size); + sexp_bignum_length(dst) = len; + } else { + memset(dst->value.bignum.data, 0, + sexp_bignum_length(dst)*sizeof(sexp_uint_t)); + memcpy(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_uint_t i, *data=sexp_bignum_data(a); + for (i=0; i (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; + } + 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); + if (c!='.') sexp_push_char(ctx, c, in); + 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); + } + 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_make_fixnum(0)); + } + 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_make_fixnum(1)); + 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 rem; + sexp_bignum_quot_rem(ctx, &rem, a, b); /* discard quotient */ + 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_make_fixnum(1)); + 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, 2, 3, 0, 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, "+: not a 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; + 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, "-: not a number", a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, "-: not a 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: + r = sexp_bignum_sub(ctx, NULL, b, sexp_fixnum_to_bignum(ctx, a)); + 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: + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, sexp_fixnum_to_bignum(ctx, b))); + break; + case SEXP_NUM_BIG_FLO: + r = sexp_make_flonum(ctx, sexp_flonum_value(b) - sexp_bignum_to_double(a)); + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, b)); + break; + } + 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, "*: not a 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, 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, "/: not a number", a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, "/: not a 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_fixnum_to_double(b)/sexp_flonum_value(a)); + 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 = 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_make_fixnum(0)) + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) + / sexp_fixnum_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; + } + 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; + 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, "quotient: not a number", a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, "quotient: not a number", b); + break; + case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: + r = sexp_type_exception(ctx, "quotient: can't take quotient of inexact", a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: + r = sexp_type_exception(ctx, "quotient: can't take quotient of inexact", b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_div(a, b); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_fixnum(0); + break; + case SEXP_NUM_BIG_FIX: + b = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_quotient(ctx, a, b)); + break; + } + 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; + 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, "remainder: not a number", a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, "remainder: not a number", b); + break; + case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: + r = sexp_type_exception(ctx, "remainder: can't take quotient of inexact", a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: + r = sexp_type_exception(ctx, "remainder: can't take quotient of inexact", 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 = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_remainder(ctx, a, b)); + break; + } + 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, "compare: not a 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/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..b103912a --- /dev/null +++ b/opt/plan9.c @@ -0,0 +1,351 @@ +/* plan9.c -- extended Plan 9 system utils */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +sexp sexp_rand (sexp ctx) { + return sexp_make_fixnum(rand()); +} + +sexp sexp_srand (sexp ctx, sexp seed) { + srand(sexp_unbox_fixnum(seed)); + return SEXP_VOID; +} + +sexp sexp_file_exists_p (sexp ctx, 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 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 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) { + return sexp_make_fixnum(fork()); +} + +sexp sexp_exec (sexp ctx, 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 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:")) { + s->auth = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "attach:")) { + s->attach = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "walk:")) { + s->walk = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "walk1:")) { + s->walk1 = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "clone:")) { + s->clone = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "open:")) { + s->open = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "create:")) { + s->create = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "remove:")) { + s->remove = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "read:")) { + s->read = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "write:")) { + s->write = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "stat:")) { + s->stat = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "wstat:")) { + s->wstat = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "flush:")) { + s->flush = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyfid:")) { + s->destroyfid = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyreq:")) { + s->destroyreq = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "end:")) { + 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 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 req) { + return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.offset); +} + +sexp sexp_9p_req_count (sexp ctx, sexp req) { + return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.count); +} + +#if 0 +sexp sexp_9p_req_path (sexp ctx, 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 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 req) { + return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->newfid, SEXP_FALSE, 0); +} + +sexp sexp_9p_respond (sexp ctx, 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 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..d4ac576d --- /dev/null +++ b/opt/simplify.c @@ -0,0 +1,135 @@ +/* simplify.c -- basic simplification pass */ +/* Copyright (c) 2009 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); + if (sexp_opcodep(sexp_car(app))) { + 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); + app = finalize_bytecode(ctx2); + if (! sexp_exceptionp(app)) { + tmp = sexp_make_vector(ctx2, 0, SEXP_VOID); + app = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, app, tmp); + if (! sexp_exceptionp(app)) + app = sexp_apply(ctx2, app, SEXP_NULL); + } + } + } + } 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)))))) { + 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 ast) { + return simplify(ctx, ast, SEXP_NULL, NULL); +} + diff --git a/sexp.c b/sexp.c new file mode 100644 index 00000000..2a3ff0f6 --- /dev/null +++ b/sexp.c @@ -0,0 +1,1685 @@ +/* sexp.c -- standalone sexp library implementation */ +/* Copyright (c) 2009 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, sexp_uint_t whole, int negp); + +static 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, SEXP_FALSE, "register-type: exceeded maximum type limit", name); + } else if (! sexp_stringp(name)) { + res = sexp_type_exception(ctx, "register-type: not a 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; i= 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, char *msg, sexp irritants, 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(irritants) || sexp_nullp(irritants)) + ? irritants : sexp_list1(ctx, irritants)); + res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "read"), + str, irr, SEXP_FALSE, name); + sexp_gc_release4(ctx); + return res; +} + +/*************************** list utilities ***************************/ + +sexp sexp_cons (sexp ctx, 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 (sexp ctx, 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 (sexp ctx, 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 (sexp ctx, 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 (sexp ctx, 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 (sexp ctx, sexp ls) { + sexp a, b, tmp; + if (ls == SEXP_NULL) { + return ls; + } else if (! sexp_pairp(ls)) { + return sexp_type_exception(ctx, "not a list", ls); + } else { + 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_append2 (sexp ctx, 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 (sexp ctx, sexp ls) { + sexp_uint_t res=0; + for ( ; sexp_pairp(ls); res++, ls=sexp_cdr(ls)) + ; + return sexp_make_fixnum(res); +} + +sexp sexp_equalp (sexp ctx, 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_string(sexp ctx, sexp len, sexp ch) { + sexp_sint_t clen = sexp_unbox_fixnum(len); + sexp s; + if (! sexp_fixnump(len)) return sexp_type_exception(ctx, "bad length", len); + if (clen < 0) return sexp_type_exception(ctx, "negative length", len); + s = sexp_alloc_atomic(ctx, sexp_sizeof(string)+clen+1); + if (sexp_exceptionp(s)) return s; + sexp_pointer_tag(s) = SEXP_STRING; + sexp_string_length(s) = clen; + if (sexp_charp(ch)) + memset(sexp_string_data(s), sexp_unbox_character(ch), clen); + sexp_string_data(s)[clen] = '\0'; + return s; +} + +sexp sexp_c_string(sexp ctx, 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 (sexp ctx, sexp str, sexp start, sexp end) { + sexp res; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "not a string", str); + if (! sexp_fixnump(start)) + return sexp_type_exception(ctx, "not a number", start); + if (sexp_not(end)) + end = sexp_make_fixnum(sexp_string_length(str)); + if (! sexp_fixnump(end)) + return sexp_type_exception(ctx, "not a number", 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 (sexp ctx, 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, "not a 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(char *str, sexp_uint_t acc) { + while (*str) {acc *= FNV_PRIME; acc ^= *str++;} + return acc; +} + +#endif + +sexp sexp_intern(sexp ctx, char *str) { +#if SEXP_USE_HUFF_SYMS + struct sexp_huff_entry he; + sexp_uint_t space=3, newbits; + char c; +#endif + sexp_uint_t len, res=FNV_OFFSET_BASIS, bucket; + char *p=str; + sexp ls; + sexp_gc_var1(sym); + +#if SEXP_USE_HUFF_SYMS + res = 0; + for ( ; (c=*p); p++) { + 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, res) % SEXP_SYMBOL_TABLE_SIZE); +#else + bucket = 0; +#endif + len = strlen(str) + 1; /* include the trailing NULL in the comparison */ + for (ls=sexp_context_symbols(ctx)[bucket]; sexp_pairp(ls); ls=sexp_cdr(ls)) + if (! strncmp(str, sexp_string_data(sexp_symbol_string(sexp_car(ls))), len)) + return sexp_car(ls); + + /* not found, make a new symbol */ + sexp_gc_preserve1(ctx, sym); + sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL); + if (sexp_exceptionp(sym)) return sym; + sexp_symbol_string(sym) = sexp_c_string(ctx, str, len-1); + sexp_push(ctx, sexp_context_symbols(ctx)[bucket], sym); + sexp_gc_release1(ctx); + return sym; +} + +sexp sexp_string_to_symbol (sexp ctx, sexp str) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "string->symbol: not a string", str); + return sexp_intern(ctx, sexp_string_data(str)); +} + +sexp sexp_make_vector(sexp ctx, 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 (sexp ctx, 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 (sexp ctx) { + 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 (sexp ctx, 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 (sexp ctx, sexp str) { + FILE *in; + sexp res; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "open-input-string: not a string", str); + in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r"); + res = sexp_make_input_port(ctx, in, SEXP_FALSE); + sexp_port_cookie(res) = str; /* for gc preservation */ + return res; +} + +sexp sexp_make_output_string_port (sexp ctx) { + 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 (sexp ctx, 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, 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, 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, "not an output-port", p); + else 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 (sexp ctx, sexp str) { + sexp res; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "open-input-string: not a 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 (sexp ctx) { + 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 (sexp ctx, 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_sourcep(p) = 1; + 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; +} + +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[20]; + + 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_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_string_length(sexp_symbol_string(obj)); + str = sexp_string_data(sexp_symbol_string(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 + 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)) { + sprintf(numbuf, "%ld", 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 = sprintf(numbuf, "%.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); + sexp_write_char(ctx, hex_digit(sexp_unbox_character(obj)>>4), out); + sexp_write_char(ctx, hex_digit(sexp_unbox_character(obj)&0xF), out); + } + } else if (sexp_symbolp(obj)) { + +#if SEXP_USE_HUFF_SYMS + if (((sexp_uint_t)obj&7)==7) { + 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 (sexp ctx, sexp obj, sexp out) { + if (! sexp_oportp(out)) + return sexp_type_exception(ctx, "write: not an output-port", out); + else + return sexp_write_one(ctx, obj, out); +} + +sexp sexp_display (sexp ctx, sexp obj, sexp out) { + sexp res=SEXP_VOID; + if (! sexp_oportp(out)) + res = sexp_type_exception(ctx, "display: not an output-port", out); + else 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 (sexp ctx, 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; + } + } + 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) : 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, sexp_uint_t 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 = ((double)whole + res) * pow(10, e); + if (negp) res *= -1; + if ((scale == 0.1) && (exponent != SEXP_VOID) && (res == round(res))) + return sexp_make_fixnum(res); + else + 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; + else if (isdigit(c)) + res = digit_value(c); + + 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; + 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: + res = SEXP_EOF; + 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); + 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); + if (c1 == EOF || is_separator(c1)) { + res = SEXP_RAWDOT; + } else if (isdigit(c1)) { + sexp_push_char(ctx, c1, in); + res = sexp_read_float_tail(ctx, in, 0, 0); + } else { + sexp_push_char(ctx, c1, in); + 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)) + 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")) + res = sexp_make_flonum(ctx, 1.0/0.0); + else if (res == sexp_intern(ctx, "-inf.0")) + res = sexp_make_flonum(ctx, -1.0/0.0); + else if (res == sexp_intern(ctx, "+nan.0")) + res = sexp_make_flonum(ctx, 0.0/0.0); +#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 (sexp ctx, sexp in) { + sexp res; + if (sexp_iportp(in)) + res = sexp_read_raw(ctx, in); + else + res = sexp_type_exception(ctx, "read: not an input-port", 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, char *str) { + sexp res; + sexp_gc_var2(s, in); + sexp_gc_preserve2(ctx, s, in); + s = sexp_c_string(ctx, str, -1); + in = sexp_make_input_string_port(ctx, s); + res = sexp_read(ctx, in); + sexp_gc_release2(ctx); + return res; +} + +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/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/loop-tests.scm b/tests/loop-tests.scm new file mode 100644 index 00000000..1c49d48f --- /dev/null +++ b/tests/loop-tests.scm @@ -0,0 +1,202 @@ + +(import (chibi loop)) + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test name expr expect) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display name 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; run tests + +(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-report) + diff --git a/tests/match-tests.scm b/tests/match-tests.scm new file mode 100644 index 00000000..a223e729 --- /dev/null +++ b/tests/match-tests.scm @@ -0,0 +1,196 @@ + +(import (chibi match)) + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test name expr expect) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display name 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; run tests + +(test "any" (match 'any (_ 'ok)) 'ok) +(test "symbol" (match 'ok (x x)) 'ok) +(test "number" (match 28 (28 'ok)) 'ok) +(test "string" (match "good" ("bad" 'fail) ("good" 'ok)) 'ok) +(test "literal symbol" (match 'good ('bad 'fail) ('good 'ok)) 'ok) +(test "null" (match '() (() 'ok)) 'ok) +(test "pair" (match '(ok) ((x) x)) 'ok) +(test "vector" (match '#(ok) (#(x) x)) 'ok) +(test "any doubled" (match '(1 2) ((_ _) 'ok)) 'ok) +(test "and empty" (match '(o k) ((and) 'ok)) 'ok) +(test "and single" (match 'ok ((and x) x)) 'ok) +(test "and double" (match 'ok ((and (? symbol?) y) 'ok)) 'ok) +(test "or empty" (match '(o k) ((or) 'fail) (else 'ok)) 'ok) +(test "or single" (match 'ok ((or x) 'ok)) 'ok) +(test "or double" (match 'ok ((or (? symbol? y) y) y)) 'ok) +(test "not" (match 28 ((not (a . b)) 'ok)) 'ok) +(test "pred" (match 28 ((? number?) 'ok)) 'ok) +(test "named pred" (match 28 ((? number? x) (+ x 1))) 29) + +(test "duplicate symbols pass" (match '(ok . ok) ((x . x) x)) 'ok) +(test "duplicate symbols fail" (match '(ok . bad) ((x . x) 'bad) (else 'ok)) 'ok) +(test "duplicate symbols samth" (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)) 'ok) + +(test "ellipses" + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ___) (list x y))) + '((a b c) (1 2 3))) + +(test "real ellipses" + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ...) (list x y))) + '((a b c) (1 2 3))) + +(test "vector ellipses" + (match '#(1 2 3 (a . 1) (b . 2) (c . 3)) + (#(a b c (hd . tl) ...) (list a b c hd tl))) + '(1 2 3 (a b c) (1 2 3))) + +(test "pred ellipses" + (match '(1 2 3) + (((? odd? n) ___) n) + (((? number? n) ___) n)) + '(1 2 3)) + +(test "failure continuation" + (match '(1 2) + ((a . b) (=> next) (if (even? a) 'fail (next))) + ((a . b) 'ok)) + 'ok) + +(test "let" + (match-let ((x 'ok) (y '(o k))) + y) + '(o k)) + +(test "let*" + (match-let* ((x 'f) (y 'o) ((z w) (list y x))) + (list x y z w)) + '(f o o f)) + +(test "getter car" + (match '(1 . 2) (((get! a) . b) (list (a) b))) + '(1 2)) + +(test "getter cdr" + (match '(1 . 2) ((a . (get! b)) (list a (b)))) + '(1 2)) + +(test "getter vector" + (match '#(1 2 3) (#((get! a) b c) (list (a) b c))) + '(1 2 3)) + +(test "setter car" + (let ((x (cons 1 2))) + (match x (((set! a) . b) (a 3))) + x) + '(3 . 2)) + +(test "setter cdr" + (let ((x (cons 1 2))) + (match x ((a . (set! b)) (b 3))) + x) + '(1 . 3)) + +(test "setter vector" + (let ((x (vector 1 2 3))) + (match x (#(a (set! b) c) (b 0))) + x) + '#(1 0 3)) + +(test "single tail" + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ... last) (list x y last))) + '((a b) (1 2) (c . 3))) + +(test "single tail 2" + (match '((a . 1) (b . 2) 3) + (((x . y) ... last) (list x y last))) + '((a b) (1 2) 3)) + +(test "multiple tail" + (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5)) + (((x . y) ... u v w) (list x y u v w))) + '((a b) (1 2) (c . 3) (d . 4) (e . 5))) + +(test "Riastradh quasiquote" + (match '(1 2 3) (`(1 ,b ,c) (list b c))) + '(2 3)) + +(test "trivial tree search" + (match '(1 2 3) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "simple tree search" + (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "deep tree search" + (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "non-tail tree search" + (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "restricted tree search" + (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "fail restricted tree search" + (match '(x (y (x a b c (1 2 3) d e f))) + (('x *** (a b c)) (list a b c)) + (else #f)) + #f) + +(test "sxml tree search" + (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)) + '(((href . "http://synthcode.com/")) ("synthcode"))) + +(test "failed sxml tree search" + (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)) + #f) + +(test "collect tree search" + (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)) + '((p ul li) ((href . "http://synthcode.com/")) ("synthcode"))) + +(test-report) + diff --git a/tests/numeric-tests.scm b/tests/numeric-tests.scm new file mode 100644 index 00000000..76a783f0 --- /dev/null +++ b/tests/numeric-tests.scm @@ -0,0 +1,150 @@ + +;; these tests are only valid if chibi-scheme is compiled with full +;; numeric support (USE_BIGNUMS, USE_FLONUMS and USE_MATH) + +(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) (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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(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-report) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm new file mode 100644 index 00000000..1b22acd2 --- /dev/null +++ b/tests/r5rs-tests.scm @@ -0,0 +1,483 @@ + +(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)) + +;;;; these will fail when compiled either without flonums or trig funcs + +;; (test #t (= -5 (floor -4.3))) + +;; (test #t (= -4 (ceiling -4.3))) + +;; (test #t (= -4 (truncate -4.3))) + +;; (test #t (= -4 (round -4.3))) + +;; (test #t (= 3 (floor 3.5))) + +;; (test #t (= 4 (ceiling 3.5))) + +;; (test #t (= 3 (truncate 3.5))) + +;; (test #t (= 4 (round 3.5))) + +(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 (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/tools/genstubs.scm b/tools/genstubs.scm new file mode 100755 index 00000000..81b07acc --- /dev/null +++ b/tools/genstubs.scm @@ -0,0 +1,1194 @@ +#! /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 +;; +;; 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* '()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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)) + "")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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-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 (assq (type-base type) *types*))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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) + (if (>= i 6) + (error "FFI currently only supports up to 6 scheme args" func)) + (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))))) + +(define (definite-article x) + (define (vowel? c) + (memv c '(#\a #\e #\i #\o #\u #\A #\E #\I #\O #\U))) + (define (vowel-exception? str) + (member (string-downcase str) + '("european" "ewe" "unicorn" "unicycle" "university" "user"))) + (define (consonant-exception? str) + ;; not "historic" according to elements of style + (member (string-downcase str) + '("heir" "herb" "herbal" "herbivore" "honest" "honor" "hour"))) + (let* ((full-str (with-output-to-string (lambda () (cat x)))) + (i (string-scan #\space full-str)) + (str (if i (substring full-str 0 i) full-str))) + (string-append + (cond + ((equal? str "") "a ") + ((vowel? (string-ref str 0)) (if (vowel-exception? str) "a " "an ")) + (else (if (consonant-exception? str) "an " "a "))) + full-str))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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 (parse-struct-like ls) + (map (lambda (x) (if (pair? x) (cons (parse-type (car x)) (cdr x)) x)) ls)) + +(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-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) + (set! *consts* + (cons (cons (parse-type (cadr expr)) (cddr expr)) *consts*))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; C code generation + +(define (c->scheme-converter type val . o) + (let ((base (type-base type))) + (cond + ((eq? base 'void) + (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*))) + (cond + (ctype + (cat "sexp_make_cpointer(ctx, " (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 ")")) + ((memq base '(port input-port output-port)) + (cat "sexp_port_stream(" val ")")) + (else + (let ((ctype (assq base *types*))) + (cond + (ctype + (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 type-spec "*" "") + (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 ")")) + (else + (cond + ((assq base *types*) + (cat + (if (type-null? type) "(" "") + "(sexp_pointerp(" arg ")" + " && (sexp_pointer_tag(" arg ") == " (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 (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, \"not a list\", " 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_type_exception(ctx, \"not a list of " + (type-name type) "s\", " arg ");\n") + (if (not (number? array)) + (cat " if (! sexp_nullp(res))\n" + " return sexp_type_exception(ctx, \"not a list of " + (type-name type) "s\", " 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, \"not " + (definite-article (type-name type)) "\", " + arg ");\n")) + (else + (cond + ((assq base-type *types*) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, \"not " + (definite-article (type-name 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)) + (write type))))))) + +(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 (and (type-array x) (not (number? len))) + (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 (type-array 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-pointer? arg) (type-free? arg) (basic-type? 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 (type-free? a)) (not (type-pointer? a)) + (or (not (type-array a)) + (not (integer? (get-array-length func a))))) + (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" (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_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 "\");\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 x) {\n" + (lambda () (write-validator "x" name)) + " return " + (lambda () + (c->scheme-converter + (car field) + (string-append "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" + "sexp_cpointer_value(x))" + (if (type-struct? (car field)) "." "->") + (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 (car field)))))) + +(define (write-type-setter type name field) + (cat "static sexp " (type-setter-name type name field) + " (sexp ctx, sexp x, sexp v) {\n" + (lambda () (write-validator "x" name)) + (lambda () (write-validator "v" (car field))) + " " + (lambda () (c->scheme-converter + (car field) + (string-append "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" + "sexp_cpointer_value(x))" + (if (type-struct? (car field)) "." "->") + (x->string (cadr field))))) + " = v;\n" + " return SEXP_VOID;" + "}\n\n")) + +(define (write-type-funcs type) + (let ((name (car type)) + (type (cdr type))) + ;; maybe write finalizer + (cond + ((memq 'finalizer: type) + => (lambda (x) + (cat "static sexp " (generate-stub-name (cadr x)) + " (sexp ctx, 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" + (lambda () (for-each (lambda (x) (cat ", sexp " x)) args)) + ") {\n" + " struct " (type-name name) " *r;\n" + " sexp res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), " + (type-id-name name) + ");\n" + " sexp_cpointer_value(res) = sexp_cpointer_body(res);\n" + " r = sexp_cpointer_value(res);\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*))))))) + 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 "\");\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 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*) + (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 []"))))