commit bddaed32955b7f841c3bb93ee1a1f2f2bb1bc546 Author: Alex Shinn Date: Tue Aug 17 20:46:12 2010 +0900 removing redundant sexp_heap_align definition diff --git a/.hgignore b/.hgignore new file mode 100644 index 00000000..e8b8b309 --- /dev/null +++ b/.hgignore @@ -0,0 +1,30 @@ +syntax: glob +*~ +*.i +*.s +*.o +*.so +*.dylib +*.class +*.dSYM +*.orig +.hg +junk* +*.tar.gz +*.tar.bz2 +*.log +*.err +*.out +gc +gc6.8 +clibs.c +chibi-scheme +chibi-scheme-static +include/chibi/install.h +lib/chibi/filesystem.c +lib/chibi/io/io.c +lib/chibi/net.c +lib/chibi/process.c +lib/chibi/system.c +lib/chibi/time.c +lib/chibi/stty.c diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 00000000..fc0b8224 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,29 @@ +Alex Shinn wrote the initial version of chibi-scheme and all +distributed modules. + +The `dynamic-wind' implementation is adapted from the implementation +in the appendix to the Scheme48 reference manual, reportedly first +written by Chris Hanson and John Lamping. + +Thanks to the following people for patches and bug reports: + + * Alexander Shendi + * Andreas Rottman + * Bruno Deferrari + * Derrick Eddington + * Eduardo Cavazos + * Felix Winkelmann + * Gregor Klinke + * Jeremy Wolff + * Jeronimo Pellegrini + * John Cowan + * John Samsa + * Lars J Aas + * Lorenzo Campedelli + * Michal Kowalski (sladegen) + * Taylor Venable + +If you would prefer not to be listed, or are one of the users listed +without a full name, please contact me. If you've made a contribution +and are not listed, please accept my apologies and contact me +immediately! diff --git a/COPYING b/COPYING new file mode 100644 index 00000000..1fcee28e --- /dev/null +++ b/COPYING @@ -0,0 +1,24 @@ +Copyright (c) 2009 Alex Shinn +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The name of the author may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..131a73d2 --- /dev/null +++ b/Makefile @@ -0,0 +1,246 @@ +# -*- makefile-gmake -*- + +.PHONY: all libs doc dist clean cleaner dist-clean test install uninstall +.PRECIOUS: %.c + +# install configuration + +CC ?= cc +PREFIX ?= /usr/local +BINDIR ?= $(PREFIX)/bin +LIBDIR ?= $(PREFIX)/lib +SOLIBDIR ?= $(PREFIX)/lib +INCDIR ?= $(PREFIX)/include/chibi +MODDIR ?= $(PREFIX)/share/chibi +LIBDIR ?= $(PREFIX)/lib/chibi +MANDIR ?= $(PREFIX)/share/man/man1 + +DESTDIR ?= + +GENSTUBS ?= ./tools/genstubs.scm +GENSTATIC ?= ./tools/genstatic.scm + +######################################################################## +# system configuration - if not using GNU make, set PLATFORM and the +# following flags as necessary. + +# +LIBDL = -ldl + +ifndef PLATFORM +ifeq ($(shell uname),Darwin) +PLATFORM=macosx +else +ifeq ($(shell uname -o),Msys) +PLATFORM=mingw +SOLIBDIR = $(BINDIR) +DIFFOPTS = -b +else +ifeq ($(shell uname -o),Cygwin) +PLATFORM=cygwin +SOLIBDIR = $(BINDIR) +DIFFOPTS = -b +else +PLATFORM=unix +endif +endif +endif +endif + +ifeq ($(PLATFORM),macosx) +SO = .dylib +EXE = +CLIBFLAGS = -dynamiclib +STATICFLAGS = -static-libgcc -DSEXP_USE_DL=0 +else +ifeq ($(PLATFORM),mingw) +SO = .dll +EXE = .exe +CC = gcc +CLIBFLAGS = -shared +CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL +LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a +STATICFLAGS = -DSEXP_USE_DL=0 +LIBDL = +else +ifeq ($(PLATFORM),cygwin) +SO = .dll +EXE = .exe +CC = gcc +CLIBFLAGS = -shared +CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 +LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a +else +SO = .so +EXE = +CLIBFLAGS = -fPIC -shared +STATICFLAGS = -static -DSEXP_USE_DL=0 +endif +endif +endif + +ifeq ($(USE_BOEHM),1) +SEXP_USE_BOEHM = 1 +endif + +ifeq ($(SEXP_USE_BOEHM),1) +GCLDFLAGS := -lgc +XCPPFLAGS := $(CPPFLAGS) -Iinclude -DSEXP_USE_BOEHM=1 +else +GCLDFLAGS := +XCPPFLAGS := $(CPPFLAGS) -Iinclude +endif + +ifeq ($(SEXP_USE_DL),0) +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm +XCFLAGS := -Wall -DSEXP_USE_DL=0 -g3 $(CFLAGS) +else +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) $(LIBDL) -lm +XCFLAGS := -Wall -g3 $(CFLAGS) +endif + +######################################################################## + +all: chibi-scheme$(EXE) libs + +COMPILED_LIBS := lib/srfi/18/threads$(SO) lib/srfi/27/rand$(SO) \ + lib/srfi/33/bit$(SO) lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) \ + lib/srfi/98/env$(SO) lib/chibi/ast$(SO) lib/chibi/net$(SO) \ + lib/chibi/filesystem$(SO) lib/chibi/process$(SO) lib/chibi/time$(SO) \ + lib/chibi/system$(SO) lib/chibi/io/io$(SO) lib/chibi/stty$(SO) \ + lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) + +libs: $(COMPILED_LIBS) + +INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h include/chibi/bignum.h + +include/chibi/install.h: Makefile + echo '#define sexp_so_extension "'$(SO)'"' > $@ + echo '#define sexp_default_module_dir "'$(MODDIR)'"' >> $@ + echo '#define sexp_platform "'$(PLATFORM)'"' >> $@ + echo '#define sexp_version "'`cat VERSION`'"' >> $@ + echo '#define sexp_release_name "'`cat RELEASE`'"' >> $@ + +sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +eval.o: eval.c opcodes.c vm.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +main.o: main.c $(INCLUDES) include/chibi/eval.h Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $< + +libchibi-sexp$(SO): sexp.o + $(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS) + +libchibi-scheme$(SO): eval.o sexp.o + $(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS) + +chibi-scheme$(EXE): main.o libchibi-scheme$(SO) + $(CC) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme + +chibi-scheme-static$(EXE): main.o eval.o sexp.o + $(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) -lm + +clibs.c: $(GENSTATIC) lib lib/chibi lib/srfi + make chibi-scheme$(EXE) + make libs + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" PATH=".:$(PATH)" $(GENSTATIC) $< > $@ + +%.c: %.stub $(GENSTUBS) + make chibi-scheme$(EXE) + -LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" PATH=".:$(PATH)" $(GENSTUBS) $< + +lib/%$(SO): lib/%.c $(INCLUDES) + -$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme + +clean: + rm -f *.o *.i *.s *.8 + find lib -name \*$(SO) -exec rm -f '{}' \; + rm -f tests/basic/*.out tests/basic/*.err + +cleaner: clean + rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) $(COMPILED_LIBS) *$(SO) *.a include/chibi/install.h + rm -rf *.dSYM + +dist-clean: cleaner + for f in `find lib -name \*.stub`; do rm -f $${f%.stub}.c; done + +test-basic: chibi-scheme$(EXE) + @for f in tests/basic/*.scm; do \ + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ + if diff -q $(DIFFOPTS) $${f%.scm}.out $${f%.scm}.res; then \ + echo "[PASS] $${f%.scm}"; \ + else \ + echo "[FAIL] $${f%.scm}"; \ + fi; \ + done + +test-build: + ./tests/build/build-tests.sh + +test-threads: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/thread-tests.scm + +test-numbers: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/numeric-tests.scm + +test-flonums: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/flonum-tests.scm + +test-hash: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/hash-tests.scm + +test-match: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/match-tests.scm + +test-loop: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/loop-tests.scm + +test-sort: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/sort-tests.scm + +test-libs: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/lib-tests.scm + +test: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/r5rs-tests.scm + +install: chibi-scheme$(EXE) + mkdir -p $(DESTDIR)$(BINDIR) + cp chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/ + cp tools/genstubs.scm $(DESTDIR)$(BINDIR)/ + mkdir -p $(DESTDIR)$(MODDIR) + cp -r lib/* $(DESTDIR)$(MODDIR)/ + mkdir -p $(DESTDIR)$(INCDIR) + cp $(INCLUDES) include/chibi/eval.h $(DESTDIR)$(INCDIR)/ + mkdir -p $(DESTDIR)$(LIBDIR) + mkdir -p $(DESTDIR)$(SOLIBDIR) + cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ + cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ + -cp libchibi-scheme.a $(DESTDIR)$(LIBDIR)/ + mkdir -p $(DESTDIR)$(MANDIR) + cp doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/ + -if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi + +uninstall: + rm -f $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE) + rm -f $(DESTDIR)$(BINDIR)/chibi-scheme-static$(EXE) + rm -f $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO) + rm -f $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a + cd $(DESTDIR)$(INCDIR) && rm -f $(INCLUDES) include/chibi/eval.h + rm -rf $(DESTDIR)$(MODDIR) + +dist: dist-clean + rm -f chibi-scheme-`cat VERSION`.tgz + mkdir chibi-scheme-`cat VERSION` + for f in `hg manifest`; do mkdir -p chibi-scheme-`cat VERSION`/`dirname $$f`; ln -s `pwd`/$$f chibi-scheme-`cat VERSION`/$$f; done + tar cphzvf chibi-scheme-`cat VERSION`.tgz chibi-scheme-`cat VERSION` + rm -rf chibi-scheme-`cat VERSION` + +mips-dist: dist-clean + rm -f chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz + mkdir chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'` + for f in `hg manifest`; do mkdir -p chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/`dirname $$f`; ln -s `pwd`/$$f chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/$$f; done + tar cphzvf chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'` + rm -rf chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'` diff --git a/README b/README new file mode 100644 index 00000000..6e5b00a6 --- /dev/null +++ b/README @@ -0,0 +1,440 @@ + + Chibi-Scheme + -------------- + + Minimal Scheme Implementation for use as an Extension Language + + http://synthcode.com/wiki/chibi-scheme/ + + +Chibi-Scheme is a very small but mostly complete R5RS Scheme +implementation using a reasonably fast custom VM. Chibi-Scheme tries +as much as possible not to trade its small size by cutting corners, +and provides full continuations, both low and high-level hygienic +macros based on syntactic-closures, string ports and exceptions. +Chibi-Scheme is written in highly portable C and supports multiple +simultaneous VM instances to run. + +------------------------------------------------------------------------ +INSTALLING + +To build, just run "make". This will provide a shared library +"libchibi-scheme", as well as a sample "chibi-scheme" command-line +repl. The "chibi-scheme-static" make target builds an equivalent +static executable. + +You can edit the file chibi/features.h for a number of settings, +mostly disabling features to make the executable smaller. You can +specify standard options directly as arguments to make, for example + + make CFLAGS=-Os CPPFLAGS=-DSEXP_USE_NO_FEATURES=1 + +to optimize for size, or + + make LDFLAGS=-L/usr/local/lib CPPFLAGS=-I/usr/local/include + +to compile against a library installed in /usr/local. + +By default Chibi uses a custom, precise, non-moving GC. You can link +against the Boehm conservative GC by editing the features.h file, or +directly from make with: + + make SEXP_USE_BOEHM=1 + +To compile a static executable, use + + make chibi-scheme-static SEXP_USE_DL=0 + +To compile a static executable with all C libraries statically +included, first you need to create a clibs.c file, which can be done +with: + + make clibs.c + +or edited manually. Be sure to run this with a non-static +chibi-scheme. Then you can make the static executable with: + + make cleaner + make chibi-scheme-static SEXP_USE_DL=0 CPPFLAGS=-DSEXP_USE_STATIC_LIBS + +------------------------------------------------------------------------ +CHIBI-SCHEME LANGUAGE + +The default language is mostly compatible with the R5RS, with all +differences made by design, not through difficulty of implementation. +The following procedures are omitted: + + transcript-on and transcript-off (because they're silly) + rationalize (pending the addition of rational numbers) + +Apart from this, chibi-scheme is case-sensitive, unlike the R5RS. +The default configuration includes fixnums, flonums and bignums +but no exact rationals or complex numbers. + +Full continuations are supported, but currently continuations don't +take C code into account. The only higher-order C functions in the +standard environment are LOAD and EVAL. + +LOAD is extended to accept an optional environment argument, like +EVAL. You can also LOAD shared libraries in addition to Scheme source +files - in this case the function sexp_init_library is automatically +called with the following signature: + + sexp_init_library(sexp context, sexp environment) + +SYNTAX-RULES macros are provided by default, with the extensions from +SRFI-46. In addition, low-level hygienic macros are provided with +a syntactic-closures interface, including SC-MACRO-TRANSFORMER, +RSC-MACRO-TRANSFORMER, and ER-MACRO-TRANSFORMER. A good introduction +to syntactic-closures can be found at: + + http://community.schemewiki.org/?syntactic-closures + +IDENTIFIER?, IDENTIFIER->SYMBOL, IDENTIFIER=?, and +MAKE-SYNTACTIC-CLOSURE and STRIP-SYNTACTIC-CLOSURES are provided. + +SRFI-0's COND-EXPAND is provided, with the feature `chibi'. + +STRING-CONCATENATE concatenates a list of strings. + +------------------------------------------------------------------------ +TYPES + +You can define new data types with SRFI-9. This is just syntactic +sugar for the following more primitive type constructors: + +(register-simple-type ) + => ; a fixnum + +(make-type-predicate ) + => ; takes 1 arg, returns #t iff that arg is of the type + +(make-constructor ) + => ; takes 0 args, returns a newly allocated instance of type + +(make-getter ) + => ; takes 1 args, retrieves the field located at the index + +(make-setter ) + => ; takes 2 args, sets the field located at the index + +------------------------------------------------------------------------ +MODULE SYSTEM + +A configurable module system, in the style of the Scheme48 module +system, is provided by default. + +Modules names are hierarchical lists of symbols or numbers. The +definition of the module (foo bar baz) is searched for in the file +foo/bar/baz.module. This file should contain an expression of the +form: + + (define-module (foo bar baz) + ...) + +where can be any of + + (export ...) - specify an export list + (import ...) - specify one or more imports + (import-immutable ...) - specify an immutable import + (body ...) - inline Scheme code + (include ...) - load one or more files + (include-shared ...) - dynamic load a library + + can either be a module name or any of + + (only ...) + (except ...) + (rename ( ) ...) + (prefix ) + +The can be composed and perform basic selection and renaming of +individual identifiers from the given module. + +Files are loaded relative to the .module file, and are written with +their extension (so you can use whatever suffix you prefer - .scm, +.ss, .sls, etc.). + +Shared modules, on the other hand, should be specified _without_ the +extension - the correct suffix will be added portably (e.g. .so for +Unix and .dylib for OS X). + +You may also use COND-EXPAND and arbitrary macro expansions in a +module definition to generate . + +------------------------------------------------------------------------ +MODULES + +The default environment is (scheme) - you almost always want to import +this. + +Currently you can load the following SRFIs with (import (srfi N)): + + (srfi 0) - cond-expand + (srfi 1) - list library + (srfi 2) - and-let* + (srfi 6) - basic string ports + (srfi 8) - receive + (srfi 9) - define-record-type + (srfi 11) - let-values/let*-values + (srfi 16) - case-lambda + (srfi 22) - running scheme scripts on Unix + (srfi 23) - error reporting mechanism + (srfi 26) - cut/cute partial application + (srfi 27) - sources of random bits + (srfi 33) - bitwise operators + (srfi 39) - prameter objects + (srfi 46) - basic syntax-rules extensions + (srfi 62) - s-expression comments + (srfi 69) - basic hash tables + (srfi 95) - sorting and merging + (srfi 98) - environment access + +although 0, 22, 23, 46 and 62 are built into the default environment +so there's no need to import them. + +Included non-standard modules are put in the (chibi) module namespace. +The following additional modules are available: + + (chibi net) - networking interface + (chibi filesystem) - local filesystem and file descriptor interface + (chibi process) - processes and signals + (chibi system) - host system and user information + (chibi time) - time and date library + (chibi match) - pattern-matching library + (chibi loop) - extensible loop syntax + (chibi pathname) - pathname manipulation utilities + (chibi uri) - URI parsing and construction utilities + (chibi macroexpand) - macro expansion utility + (chibi ast) - interface to the internal Abstract Syntax Tree + (chibi disasm) - disassembly utility for the chibi VM + (chibi heap-stats) - debugging tool to analyze or dump the heap + +------------------------------------------------------------------------ +C INTERFACE + +See the file main.c for an example of using chibi-scheme as a library. + +The basic usage involves creating a context for evaluation and loading +or evaluating Scheme source with it. Begin by including the eval.h +header file: + + #include + +then call + + sexp_scheme_init(); + +with no parameters to initialize any globals (this actually does +nothing in the standard configuration but is a good idea to call +anyway). + +Then you can use the following to create and manipulate contexts: + + sexp_make_eval_context(context, stack, environment, heap_size) + Creates a new context with the given stack and environment. + If context is non-NULL, this will be the "parent" context and + the two contexts will share a heap. Otherwise, a new heap + will be allocated with heap_size, or a default size if heap_size + is zero. stack and environment may both also be NULL (and _must_ + be NULL if context is NULL) and will be given standard defaults. + + Thus to create your first context you generally call: + + sexp_make_eval_context(NULL, NULL, NULL, 0) + + You can create as many contexts as you want, and other than those + sharing a heap they are all independent and thread-safe. + + sexp_load_standard_env(context, env, version) + Loads the init.scm file in the environment env. Version refers + to the RnRS version number and should always be SEXP_FIVE. The + environment created with sexp_make_eval_context only contains + core syntactic forms and C primitives (thus for example it has + CAR but not CADR or LIST), so to get a full featured + environment, plus a module system with which to load additional + modules, you want to use this. + + sexp_destroy_context(context) + Signals that you no longer need context, or any other context + sharing the heap. It will thus free() the context and heap and + all associated memory. Does nothing if using the Boehm GC. + +Environments can be handled with the following: + + sexp_context_env(context) + A macro returning the default environment associated with context. + + sexp_env_define(context, env, symbol, value) + Define a variable in an environment. + + sexp_env_ref(env, symbol, dflt) + Fetch the binding for symbol from the environment env, + returning the default dflt if the symbol is unbound. + +You can evaluate code with the following utility: + + sexp_eval(context, expr, env) + Evaluates an s-expression in an environment. + env can be NULL to use the context's default env. + + sexp_eval_string(context, str, env) + Reads an s-expression from str and evaluates it in env. + + sexp_load(context, file, env) + Read and eval all top-level forms from file in environment env. + As described in LOAD above, file may be a shared library. + +To define new primitive functions from C, use sexp_define_foreign, +which takes a Scheme environment, a name, a number of arguments the C +function takes (not counting the context argument), and a C function. + + /* sexp_define_foreign(context, env, name, num_args, f) */ + + sexp add (sexp context, sexp x, sexp y) { + return sexp_fx_add(x, y); + } + + sexp_define_foreign(context, env, "add", 2, add); + +You can also define functions with a single optional argument: + + sexp_define_foreign_opt(context, env, "add", 2, add, sexp_make_fixnum(1)); + +See the SRFI-69 implementation for more detailed examples of this. + +------------------------------------------------------------------------ +FFI + +Simple C FFI. "genstubs.scm file.stub" will read in the C function +FFI definitions from file.stub and output the appropriate C +wrappers into file.c. You can then compile that file with: + + cc -fPIC -shared file.c -lchibi-scheme + +(or using whatever flags are appropriate to generate shared libs on +your platform) and then the generated .so file can be loaded +directly with LOAD, or portably using (include-shared "file") in a +module definition (note that include-shared uses no suffix). + +The goal of this interface is to make access to C types and +functions easy, without requiring the user to write any C code. +That means the stubber needs to be intelligent about various C +calling conventions and idioms, such as return values passed in +actual parameters. Writing C by hand is still possible, and +several of the core modules provide C interfaces directly without +using the stubber. + +================================ + +Struct Interface + +(define-c-struct struct-name + [predicate: predicate-name] + [constructor: constructor-name] + [finalizer: c_finalizer_name] + (type c_field_name getter-name setter-name) ...) + + +================================ + + +Function Interface + +(define-c return-type name-spec (arg-type ...)) + +where name-space is either a symbol name, or a list of +(scheme-name c_name). If just a symbol, the C name is taken +to be the same with -'s replaced by _'s. + +arg-type is a type suitable for input validation and conversion. + +================================ + + +Types + +Types + +Basic Types + void + boolean + char + sexp (no conversions) + +Integer Types: + signed-char short int long + unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t + time_t (in seconds, but using the chibi epoch of 2010/01/01) + errno (as a return type returns #f on error) + +Float Types: + float double long-double + +String Types: + string - a null-terminated char* + env-string - a VAR=VALUE string represented as a (VAR . VALUE) pair inScheme + in addition you can use (array char) as a string + +Port Types: + input-port output-port + +Struct Types: + +Struct types are by default just referred to by the bare +struct-name from define-c-struct, and it is assumed you want a +pointer to that type. To refer to the full struct, use the struct +modifier, as in (struct struct-name). + +Type modifiers + +Any type may also be written as a list of modifiers followed by the +type itself. The supported modifiers are: + +const: prepends the "const" C type modifier + * as a return or result parameter, makes non-immediates immutable + +free: it's Scheme's responsibility to "free" this resource + * as a return or result parameter, registers the freep flag + this causes the type finalizer to be run when GCed + +maybe-null: this pointer type may be NULL + * as a result parameter, NULL is translated to #f + normally this would just return a wrapped NULL pointer + * as an input parameter, #f is translated to NULL + normally this would be a type error + +pointer: create a pointer to this type + * as a return parameter, wraps the result in a vanilla cpointer + * as a result parameter, boxes then unboxes the value + +struct: treat this struct type as a struct, not a pointer + * as an input parameter, dereferences the pointer + * as a type field, indicates a nested struct + +link: add a gc link + * as a field getter, link to the parent object, so the + parent won't be GCed so long as we have a reference + to the child. this behavior is automatic for nested + structs. + +result: return a result in this parameter + * if there are multiple results (including the return type), + they are all returned in a list + * if there are any result parameters, a return type + of errno returns #f on failure, and as eliminated + from the list of results otherwise + +(value ): specify a fixed value + * as an input parameter, this parameter is not provided + in the Scheme API but always passed as + +(default ): specify a default value + * as the final input parameter, makes the Scheme parameter + optional, defaulting to + +(array []) an array type + * length must be specified for return and result parameters + * if specified, length can be any of + ** an integer, for a fixed size + ** the symbol null, indicating a NULL-terminated array diff --git a/RELEASE b/RELEASE new file mode 100644 index 00000000..35f6fb33 --- /dev/null +++ b/RELEASE @@ -0,0 +1 @@ +lithium diff --git a/TODO b/TODO new file mode 100644 index 00000000..161ca82c --- /dev/null +++ b/TODO @@ -0,0 +1,165 @@ +-*- org -*- + +* compiler +** DONE ast rewrite + - State "DONE" [2009-04-09 Thu 14:32] +** DONE call/cc support + - State "DONE" [2009-04-09 Thu 14:36] +** DONE exceptions + - State "DONE" [2009-04-09 Thu 14:45] +** TODO native x86 backend + API redesign in preparation complete, initial + tests on native factorial and closures working. +** TODO fasl/image files + sexp_copy_context() can form the basis for images, + FASL for arbitrary modules will need additional + help with resolving external references. +** DONE shared stack on EVAL + - State "DONE" [2009-12-26 Sat 08:22] + +* compiler optimizations +** DONE constant folding + - State "DONE" [2009-12-16 Wed 23:25] +** DONE simplification pass, dead-code elimination + - State "DONE" [2009-12-18 Fri 14:14] + This is important in particular for the output generated by + syntax-rules. +** TODO lambda lift + The current closure representation is not very efficient, so this + would help a lot. +** TODO inlining (and disabling primitive inlining) + Being able to redefine procedures is important though. +** TODO unsafe operations + Possibly, don't want to make things too complicated or unstable. +** TODO plugin infrastructure +** TODO type inference with warnings + +* macros +** DONE hygiene + - State "DONE" [2009-04-09 Thu 14:41] +** DONE hygienic nested let-syntax + - State "DONE" [2009-12-08 Tue 14:41] +** DONE macroexpand utility + - State "DONE" [2009-12-08 Tue 14:41] +** DONE SRFI-46 basic syntax-rules extensions + - State "DONE" [2009-12-26 Sat 07:59] +** DONE (... ...) support + - State "DONE" [2009-12-26 Sat 02:06] +** TODO compiler macros +** TODO syntax-rules common pattern reduction +** TODO syntax-rules loop optimization + +* garbage collection +** DONE precise gc rewrite + - State "DONE" [2009-06-22 Mon 14:27] +** DONE fix heap growing + - State "DONE" [2009-06-22 Mon 14:29] +** DONE separate gc heaps + - State "DONE" [2009-12-08 Tue 14:29] +** DONE add finalizers + - State "DONE" [2009-12-08 Tue 14:29] +** TODO support weak references + +* runtime +** DONE bignums + - State "DONE" [2009-07-07 Tue 14:42] +** DONE unicode + - State "DONE" from "TODO" [2010-07-11 Sun 23:58] + Supported with UTF-8 strings, string-ref is O(n) and + string-set! may need to reallocate the whole string. + string-cursor-ref can be used for O(1) string access. +** DONE threads + - State "DONE" from "TODO" [2010-07-11 Sun 15:31] + VM now supports an optional hook for green threads, + and a SRFI-18 interface is provided as a separate module. + I/O operations will currently block all threads though, + this needs to be addressed. +** DONE virtual ports + - State "DONE" [2010-01-02 Sat 20:12] +** DONE dynamic-wind + - State "DONE" [2009-12-26 Sat 01:51] + Adapted a version from Scheme48. +** DONE recursive disasm + - State "DONE" [2009-12-18 Fri 14:15] + +* FFI +** DONE libdl support + - State "DONE" [2009-12-08 Tue 14:45] +** DONE opcode generation interface + - State "DONE" [2009-11-15 Sun 14:45] +** DONE stub generator + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE define-c-struct + - State "DONE" [2009-11-29 Sun 14:48] +*** DONE define-c + - State "DONE" [2009-11-29 Sun 14:48] +*** DONE array return types + - State "DONE" [2009-12-26 Sat 01:49] +*** DONE pre-buffered string types (like getcwd) + - State "DONE" [2009-12-26 Sat 01:49] + +* module system +** DONE scheme48-like config language + - State "DONE" [2009-10-13 Tue 14:38] +** DONE shared library includes + - State "DONE" [2009-12-08 Tue 14:39] +** DONE only/except/rename/prefix modifiers + - State "DONE" [2009-12-16 Wed 18:57] +** TODO scheme-complete.el support +** DONE access individual modules from repl + - State "DONE" [2009-12-26 Sat 01:49] + +* core modules +** DONE SRFI-0 cond-expand + - State "DONE" [2009-12-16 Wed 20:12] +** DONE SRFI-9 define-record-type + - State "DONE" [2009-12-08 Tue 14:50] +** DONE SRFI-69 hash-tables + - State "DONE" [2009-11-15 Sun 14:50] +** DONE match library + - State "DONE" [2009-12-08 Tue 14:54] +** DONE loop library + - State "DONE" [2009-12-08 Tue 14:54] +** TODO network interface +** DONE posix interface + - State "DONE" from "TODO" [2010-07-11 Sun 15:36] + Splitting this into several parts. +*** DONE filesystem interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE process interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE time interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE host system interface + - State "DONE" [2010-01-02 Sat 20:12] +** DONE pathname library + - State "DONE" [2009-12-16 Wed 18:58] +** DONE uri library + - State "DONE" [2009-12-16 Wed 18:58] +** TODO http library +** TODO show (formatting) library +** TODO zip library +** TODO tar library +** TODO md5sum library + +* ports +** DONE basic mingw support + - State "DONE" [2009-06-22 Mon 14:36] +** DONE Plan 9 support + - State "DONE" [2009-08-10 Mon 14:37] +** DONE 64-bit support + - State "DONE" [2009-11-01 Sun 14:37] +** TODO iPhone support +** TODO bare-metal support + +* miscellaneous +** TODO overall cleanup +** TODO user documentation +** TODO thorough source documentation +** TODO full test suite for libraries + +* distribution +** TODO packaging format +** TODO code repository with fetch+install tool +** TODO translator to/from other implementations + diff --git a/VERSION b/VERSION new file mode 100644 index 00000000..be586341 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +0.3 diff --git a/chibi-scheme.vcproj b/chibi-scheme.vcproj new file mode 100644 index 00000000..86bd69e9 --- /dev/null +++ b/chibi-scheme.vcproj @@ -0,0 +1,206 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/doc/chibi-scheme.1 b/doc/chibi-scheme.1 new file mode 100644 index 00000000..b84620d5 --- /dev/null +++ b/doc/chibi-scheme.1 @@ -0,0 +1,133 @@ +.TH "chibi-scheme" "1" "" "" +.UC 4 +.SH NAME +.PP +chibi-scheme \- a tiny Scheme interpreter + +.SH SYNOPSIS +.B chibi-scheme +[-qV] +[-I +.I path +] +[-A +.I path +] +[-m +.I module +] +[-l +.I file +] +[-e +.I expr +] +[-p +.I expr +] +[--] +[ +.I script argument ... +] +.br +.sp 0.3 + +.SH DESCRIPTION +.I chibi-scheme +is a sample interactive Scheme interpreter for the +.I chibi-scheme +library. It serves as an example of how to embed +.I chibi-scheme +in applications, and can be useful on its own for writing +scripts and interactive development. + +When +.I script +is given, the script will be loaded with SRFI-22 semantics, +calling the procedure +.I main +(if defined) with a single parameter as a list of the +command-line arguments beginning with the script name. + +Otherwise, if no script is given and no -e or -p options +are given an interactive repl is entered, reading, evaluating, +then printing expressions until EOF is reached. The repl +provided is very minimal - if you want readline +completion you may want to wrap it with the +.I rlwrap(1) +program. Signals aren't caught either - to enable handling keyboard +interrupts you can use the (chibi process) module. + +.SH OPTIONS +.TP 5 +.BI -V +Prints the version information and exits. +.TP +.BI -q +Don't load the initialization file. The resulting +environment will only contain the core syntactic forms +and primitives coded in C. +.TP +.BI -h size +Specifies the initial size of the heap, in bytes. +.I size +can be any integer value, optionally suffixed by +"K" for kilobytes, or "M" for megabytes. +.I -h +must be specified before any options which load or +evaluate Scheme code. +.TP +.BI -I path +Inserts +.I path +on front of the load path list. +.TP +.BI -A path +Appends +.I path +to the load path list. +.TP +.BI -m module +Imports +.I module +as though "(import +.I module +)" were evaluated. However, to reduce the need for shell +escapes, modules are written in a dot notation, so that the module +.I (foo bar) +is written as +.I foo.bar +.TP +.BI -l file +Loads the Scheme source from the file +.I file +searched for in the default load path. +.TP +.BI -e expr +Evaluates the Scheme expression +.I expr. +.TP +.BI -p expr +Evaluates the Scheme expression +.I expr +then prints the result to stdout. + +.SH ENVIRONMENT +.TP +.B CHIBI_MODULE_PATH +.TQ +A colon separated list of directories to search for module +files, inserted before the system default load paths. + +.SH AUTHORS +.PP +Alex Shinn (alexshinn @ gmail . com) + +.SH SEE ALSO +.PP +More detailed information can be found in the README file +included in the distribution. + +The chibi-scheme home-page: +.br +http://code.google.com/p/chibi-scheme/ diff --git a/eval.c b/eval.c new file mode 100644 index 00000000..c0c7e166 --- /dev/null +++ b/eval.c @@ -0,0 +1,1758 @@ +/* eval.c -- evaluator library implementation */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +/************************************************************************/ + +static int scheme_initialized_p = 0; + +static sexp analyze (sexp ctx, sexp x); +static void generate (sexp ctx, sexp x); + +#if SEXP_USE_MODULES +sexp sexp_load_module_file_op (sexp ctx sexp_api_params(self, n), sexp file, sexp env); +sexp sexp_find_module_file_op (sexp ctx sexp_api_params(self, n), sexp file); +sexp sexp_current_environment (sexp ctx sexp_api_params(self, n)); +#endif + +sexp sexp_compile_error (sexp ctx, const char *message, sexp o) { + sexp exn; + sexp_gc_var3(sym, irritants, msg); + sexp_gc_preserve3(ctx, sym, irritants, msg); + irritants = sexp_list1(ctx, o); + msg = sexp_c_string(ctx, message, -1); + exn = sexp_make_exception(ctx, sym = sexp_intern(ctx, "compile", -1), + msg, irritants, SEXP_FALSE, + (sexp_pairp(o)?sexp_pair_source(o):SEXP_FALSE)); + sexp_gc_release3(ctx); + return exn; +} + +static void sexp_warn (sexp ctx, char *msg, sexp x) { + sexp out = sexp_current_error_port(ctx); + if (sexp_oportp(out)) { + sexp_write_string(ctx, "WARNING: ", out); + sexp_write_string(ctx, msg, out); + sexp_write(ctx, x, out); + sexp_write_char(ctx, '\n', out); + } +} + +void sexp_warn_undefs (sexp ctx, sexp from, sexp to) { + sexp x; + for (x=from; sexp_pairp(x) && x!=to; x=sexp_env_next_cell(x)) + if (sexp_cdr(x) == SEXP_UNDEF) + sexp_warn(ctx, "reference to undefined variable: ", sexp_car(x)); +} + + +/********************** environment utilities ***************************/ + +static sexp sexp_env_cell_loc (sexp env, sexp key, sexp *varenv) { + sexp ls; + + do { + for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + if (sexp_car(ls) == key) { + if (varenv) *varenv = env; + return ls; + } + env = sexp_env_parent(env); + } while (env); + + return NULL; +} + +sexp sexp_env_cell (sexp env, sexp key) { + return sexp_env_cell_loc(env, key, NULL); +} + +static sexp sexp_env_cell_create (sexp ctx, sexp env, sexp key, + sexp value, sexp *varenv) { + sexp_gc_var1(cell); + cell = sexp_env_cell_loc(env, key, varenv); + if (! cell) { + sexp_gc_preserve1(ctx, cell); + while (sexp_env_lambda(env) || sexp_env_syntactic_p(env)) + env = sexp_env_parent(env); + sexp_env_push(ctx, env, cell, key, value); + if (varenv) *varenv = env; + sexp_gc_release1(ctx); + } + return cell; +} + +sexp sexp_env_ref (sexp env, sexp key, sexp dflt) { + sexp cell = sexp_env_cell(env, key); + return (cell ? sexp_cdr(cell) : dflt); +} + +sexp sexp_env_global_ref (sexp env, sexp key, sexp dflt) { + while (sexp_env_lambda(env) && sexp_env_parent(env)) + env = sexp_env_parent(env); + return sexp_env_ref(env, key, dflt); +} + +sexp sexp_env_define (sexp ctx, sexp env, sexp key, sexp value) { + sexp cell=SEXP_FALSE, res=SEXP_VOID; + sexp_gc_var1(tmp); + for (tmp=sexp_env_bindings(env); sexp_pairp(tmp); tmp=sexp_env_next_cell(tmp)) + if (sexp_car(tmp) == key) { + cell = tmp; + break; + } + if (sexp_immutablep(env)) { + res = sexp_user_exception(ctx, NULL, "immutable binding", key); + } else { + sexp_gc_preserve1(ctx, tmp); + if (sexp_truep(cell)) { + if (sexp_immutablep(cell)) + res = sexp_user_exception(ctx, NULL, "immutable binding", key); + else + sexp_cdr(cell) = value; + } else { + sexp_env_push(ctx, env, tmp, key, value); + } + sexp_gc_release1(ctx); + } + return res; +} + +sexp sexp_env_exports_op (sexp ctx sexp_api_params(self, n), sexp env) { + sexp ls; + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; + for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + sexp_push(ctx, res, sexp_car(ls)); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) { + sexp_gc_var2(e, tmp); + sexp_gc_preserve2(ctx, e, tmp); + e = sexp_alloc_type(ctx, env, SEXP_ENV); + sexp_env_parent(e) = env; + sexp_env_bindings(e) = SEXP_NULL; + for ( ; sexp_pairp(vars); vars = sexp_cdr(vars)) + sexp_env_push(ctx, e, tmp, sexp_car(vars), value); + sexp_gc_release2(ctx); + return e; +} + +static sexp sexp_reverse_flatten_dot (sexp ctx, sexp ls) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_push(ctx, res, sexp_car(ls)); + sexp_gc_release1(ctx); + return (sexp_nullp(ls) ? res : sexp_cons(ctx, ls, res)); +} + +static sexp sexp_flatten_dot (sexp ctx, sexp ls) { + return sexp_nreverse(ctx, sexp_reverse_flatten_dot(ctx, ls)); +} + +int sexp_param_index (sexp lambda, sexp name) { + sexp ls = sexp_lambda_params(lambda); + int i = 0; + for (i=0; sexp_pairp(ls); ls=sexp_cdr(ls), i++) + if (sexp_car(ls) == name) + return i; + if (ls == name) + return i; + ls = sexp_lambda_locals(lambda); + for (i=-1; sexp_pairp(ls); ls=sexp_cdr(ls), i--) + if (sexp_car(ls) == name) + return i-4; + return -10000; +} + +/************************* bytecode utilities ***************************/ + +static void shrink_bcode (sexp ctx, sexp_uint_t i) { + sexp tmp; + if (sexp_bytecode_length(sexp_context_bc(ctx)) != i) { + tmp = sexp_alloc_bytecode(ctx, i); + sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx)); + sexp_bytecode_length(tmp) = i; + sexp_bytecode_literals(tmp) + = sexp_bytecode_literals(sexp_context_bc(ctx)); + memcpy(sexp_bytecode_data(tmp), + sexp_bytecode_data(sexp_context_bc(ctx)), + i); + sexp_context_bc(ctx) = tmp; + } +} + +static void expand_bcode (sexp ctx, sexp_uint_t size) { + sexp tmp; + if (sexp_bytecode_length(sexp_context_bc(ctx)) + < (sexp_context_pos(ctx))+size) { + tmp=sexp_alloc_bytecode(ctx, sexp_bytecode_length(sexp_context_bc(ctx))*2); + sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx)); + sexp_bytecode_length(tmp) + = sexp_bytecode_length(sexp_context_bc(ctx))*2; + sexp_bytecode_literals(tmp) + = sexp_bytecode_literals(sexp_context_bc(ctx)); + memcpy(sexp_bytecode_data(tmp), + sexp_bytecode_data(sexp_context_bc(ctx)), + sexp_bytecode_length(sexp_context_bc(ctx))); + sexp_context_bc(ctx) = tmp; + } +} + +static void emit_enter (sexp ctx); +static void emit_return (sexp ctx); +static void bless_bytecode (sexp ctx, sexp bc); + +static sexp finalize_bytecode (sexp ctx) { + sexp bc; + emit_return(ctx); + shrink_bcode(ctx, sexp_context_pos(ctx)); + bc = sexp_context_bc(ctx); + if (sexp_pairp(sexp_bytecode_literals(bc))) { /* compress literals */ + if (sexp_nullp(sexp_cdr(sexp_bytecode_literals(bc)))) + sexp_bytecode_literals(bc) = sexp_car(sexp_bytecode_literals(bc)); + else if (sexp_nullp(sexp_cddr(sexp_bytecode_literals(bc)))) + sexp_cdr(sexp_bytecode_literals(bc)) = sexp_cadr(sexp_bytecode_literals(bc)); + else + sexp_bytecode_literals(bc) = sexp_list_to_vector(ctx, sexp_bytecode_literals(bc)); + } + bless_bytecode(ctx, bc); + return bc; +} + +static void emit (sexp ctx, unsigned char c) { + expand_bcode(ctx, 1); + sexp_bytecode_data(sexp_context_bc(ctx))[sexp_context_pos(ctx)++] = c; +} + +sexp sexp_make_procedure_op (sexp ctx sexp_api_params(self, n), sexp flags, + sexp num_args, sexp bc, sexp vars) { + sexp proc = sexp_alloc_type(ctx, procedure, SEXP_PROCEDURE); + sexp_procedure_flags(proc) = (char) (sexp_uint_t) flags; + sexp_procedure_num_args(proc) = (unsigned short) (sexp_uint_t) num_args; + sexp_procedure_code(proc) = bc; + sexp_procedure_vars(proc) = vars; + return proc; +} + +static sexp sexp_make_macro (sexp ctx, sexp p, sexp e) { + sexp mac = sexp_alloc_type(ctx, macro, SEXP_MACRO); + sexp_macro_env(mac) = e; + sexp_macro_proc(mac) = p; + return mac; +} + +static sexp sexp_make_synclo_op (sexp ctx sexp_api_params(self, n), sexp env, sexp fv, sexp expr) { + sexp res; + if (! (sexp_symbolp(expr) || sexp_pairp(expr))) + return expr; + res = sexp_alloc_type(ctx, synclo, SEXP_SYNCLO); + sexp_synclo_env(res) = env; + sexp_synclo_free_vars(res) = fv; + sexp_synclo_expr(res) = expr; + return res; +} + +/* internal AST */ + +static sexp sexp_make_lambda (sexp ctx, sexp params) { + sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA); + sexp_lambda_name(res) = SEXP_FALSE; + sexp_lambda_params(res) = params; + sexp_lambda_fv(res) = SEXP_NULL; + sexp_lambda_sv(res) = SEXP_NULL; + sexp_lambda_locals(res) = SEXP_NULL; + sexp_lambda_defs(res) = SEXP_NULL; + sexp_lambda_return_type(res) = SEXP_FALSE; + sexp_lambda_param_types(res) = SEXP_NULL; + return res; +} + +static sexp sexp_make_set (sexp ctx, sexp var, sexp value) { + sexp res = sexp_alloc_type(ctx, set, SEXP_SET); + sexp_set_var(res) = var; + sexp_set_value(res) = value; + return res; +} + +static sexp sexp_make_ref (sexp ctx, sexp name, sexp cell) { + sexp res = sexp_alloc_type(ctx, ref, SEXP_REF); + sexp_ref_name(res) = name; + sexp_ref_cell(res) = cell; + return res; +} + +static sexp sexp_make_cnd (sexp ctx, sexp test, sexp pass, sexp fail) { + sexp res = sexp_alloc_type(ctx, cnd, SEXP_CND); + sexp_cnd_test(res) = test; + sexp_cnd_pass(res) = pass; + sexp_cnd_fail(res) = fail; + return res; +} + +static sexp sexp_make_lit (sexp ctx, sexp value) { + sexp res = sexp_alloc_type(ctx, lit, SEXP_LIT); + sexp_lit_value(res) = value; + return res; +} + +/****************************** contexts ******************************/ + +#define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*SEXP_INIT_STACK_SIZE) + +static void sexp_add_path (sexp ctx, const char *str) { + const char *colon; + if (str && *str) { + colon = strchr(str, ':'); + if (colon) + sexp_add_path(ctx, colon+1); + else + colon = str + strlen(str); + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), SEXP_VOID); + sexp_car(sexp_global(ctx, SEXP_G_MODULE_PATH)) + = sexp_c_string(ctx, str, colon-str); + } +} + +void sexp_init_eval_context_globals (sexp ctx) { + sexp_gc_var3(tmp, vec, ctx2); + ctx = sexp_make_child_context(ctx, NULL); + sexp_gc_preserve3(ctx, tmp, vec, ctx2); + vec = sexp_intern(ctx, "*current-exception-handler*", -1); + sexp_global(ctx, SEXP_G_ERR_HANDLER) + = sexp_env_cell_create(ctx, sexp_context_env(ctx), vec, SEXP_FALSE, NULL); +#if ! SEXP_USE_NATIVE_X86 + emit(ctx, SEXP_OP_RESUMECC); + sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE) = finalize_bytecode(ctx); + ctx2 = sexp_make_child_context(ctx, NULL); + emit(ctx2, SEXP_OP_DONE); + tmp = finalize_bytecode(ctx2); + vec = sexp_make_vector(ctx, 0, SEXP_VOID); + sexp_global(ctx, SEXP_G_FINAL_RESUMER) + = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, tmp, vec); + sexp_bytecode_name(sexp_procedure_code(sexp_global(ctx, SEXP_G_FINAL_RESUMER))) + = sexp_intern(ctx, "final-resumer", -1); +#endif + sexp_global(ctx, SEXP_G_MODULE_PATH) = SEXP_NULL; + sexp_add_path(ctx, sexp_default_module_dir); + sexp_add_path(ctx, getenv(SEXP_MODULE_PATH_VAR)); + tmp = sexp_c_string(ctx, "./lib", 5); + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), tmp); + tmp = sexp_c_string(ctx, ".", 1); + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), tmp); +#if SEXP_USE_GREEN_THREADS + sexp_global(ctx, SEXP_G_THREADS_FRONT) = SEXP_NULL; + sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL; + sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = SEXP_ZERO; + sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = SEXP_FALSE; +#endif + sexp_gc_release3(ctx); +} + +sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size) { + sexp_gc_var1(res); + if (ctx) sexp_gc_preserve1(ctx, res); + res = sexp_make_context(ctx, size); + sexp_context_bc(res) = sexp_alloc_bytecode(res, SEXP_INIT_BCODE_SIZE); + sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE; + sexp_bytecode_length(sexp_context_bc(res)) = SEXP_INIT_BCODE_SIZE; + sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL; + if ((! stack) || (stack == SEXP_FALSE)) { + stack = sexp_alloc_tagged(res, SEXP_STACK_SIZE, SEXP_STACK); + sexp_stack_length(stack) = SEXP_INIT_STACK_SIZE; + sexp_stack_top(stack) = 0; + } + sexp_context_stack(res) = stack; + sexp_context_env(res) = (env ? env : sexp_make_primitive_env(res, SEXP_FIVE)); + if (! ctx) sexp_init_eval_context_globals(res); + if (ctx) { + sexp_context_tracep(res) = sexp_context_tracep(ctx); + sexp_gc_release1(ctx); + } + return res; +} + +sexp sexp_make_child_context (sexp ctx, sexp lambda) { + sexp res = sexp_make_eval_context(ctx, + sexp_context_stack(ctx), + sexp_context_env(ctx), + 0); + if (! sexp_exceptionp(res)) { + sexp_context_lambda(res) = lambda; + sexp_context_top(res) = sexp_context_top(ctx); + sexp_context_fv(res) = sexp_context_fv(ctx); + sexp_context_tracep(res) = sexp_context_tracep(ctx); + } + return res; +} + +/**************************** identifiers *****************************/ + +static sexp sexp_identifierp_op (sexp ctx sexp_api_params(self, n), sexp x) { + return sexp_make_boolean(sexp_idp(x)); +} + +static sexp sexp_syntactic_closure_expr_op (sexp ctx sexp_api_params(self, n), sexp x) { + return (sexp_synclop(x) ? sexp_synclo_expr(x) : x); +} + +static sexp sexp_strip_synclos (sexp ctx sexp_api_params(self, n), sexp x) { + sexp res; + sexp_gc_var2(kar, kdr); + sexp_gc_preserve2(ctx, kar, kdr); + loop: + if (sexp_synclop(x)) { + x = sexp_synclo_expr(x); + goto loop; + } else if (sexp_pairp(x)) { + kar = sexp_strip_synclos(ctx sexp_api_pass(self, n), sexp_car(x)); + kdr = sexp_strip_synclos(ctx sexp_api_pass(self, n), sexp_cdr(x)); + res = sexp_cons(ctx, kar, kdr); + sexp_immutablep(res) = 1; + } else { + res = x; + } + sexp_gc_release2(ctx); + return res; +} + +static sexp sexp_identifier_eq_op (sexp ctx sexp_api_params(self, n), sexp e1, sexp id1, sexp e2, sexp id2) { + sexp cell, lam1=SEXP_FALSE, lam2=SEXP_FALSE; + if (sexp_synclop(id1)) { + e1 = sexp_synclo_env(id1); + id1 = sexp_synclo_expr(id1); + } + if (sexp_synclop(id2)) { + e2 = sexp_synclo_env(id2); + id2 = sexp_synclo_expr(id2); + } + cell = sexp_env_cell(e1, id1); + if (cell && sexp_lambdap(sexp_cdr(cell))) + lam1 = sexp_cdr(cell); + cell = sexp_env_cell(e2, id2); + if (cell && sexp_lambdap(sexp_cdr(cell))) + lam2 = sexp_cdr(cell); + return sexp_make_boolean((id1 == id2) && (lam1 == lam2)); +} + +/************************* the compiler ***************************/ + +static sexp analyze_app (sexp ctx, sexp x) { + sexp p; + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, tmp); + for (res=SEXP_NULL; sexp_pairp(x); x=sexp_cdr(x)) { + sexp_push(ctx, res, SEXP_FALSE); + tmp = analyze(ctx, sexp_car(x)); + if (sexp_exceptionp(tmp)) { + res = tmp; + break; + } else { + sexp_car(res) = tmp; + } + } + if (sexp_pairp(res)) { /* fill in lambda names */ + res = sexp_nreverse(ctx, res); + if (sexp_lambdap(sexp_car(res))) { + p=sexp_lambda_params(sexp_car(res)); + for (tmp=sexp_cdr(res); sexp_pairp(tmp)&&sexp_pairp(p); tmp=sexp_cdr(tmp), p=sexp_cdr(p)) + if (sexp_lambdap(sexp_car(tmp))) + sexp_lambda_name(sexp_car(tmp)) = sexp_car(p); + } + } + sexp_gc_release2(ctx); + return res; +} + +static sexp analyze_seq (sexp ctx, sexp ls) { + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, tmp); + if (sexp_nullp(ls)) + res = SEXP_VOID; + else if (sexp_nullp(sexp_cdr(ls))) + res = analyze(ctx, sexp_car(ls)); + else { + res = sexp_alloc_type(ctx, seq, SEXP_SEQ); + tmp = analyze_app(ctx, ls); + if (sexp_exceptionp(tmp)) + res = tmp; + else + sexp_seq_ls(res) = tmp; + } + sexp_gc_release2(ctx); + return res; +} + +static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) { + sexp env = sexp_context_env(ctx), res; + sexp_gc_var1(cell); + sexp_gc_preserve1(ctx, cell); + cell = sexp_env_cell_loc(env, x, varenv); + if (! cell) { + if (sexp_synclop(x)) { + if (sexp_not(sexp_memq(ctx, sexp_synclo_expr(x), sexp_context_fv(ctx))) + && sexp_not(sexp_memq(ctx, sexp_synclo_expr(x), sexp_synclo_free_vars(x)))) + env = sexp_synclo_env(x); + x = sexp_synclo_expr(x); + } + cell = sexp_env_cell_create(ctx, env, x, SEXP_UNDEF, varenv); + } + if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell))) + res = sexp_compile_error(ctx, "invalid use of syntax as value", x); + else + res = sexp_make_ref(ctx, x, cell); + sexp_gc_release1(ctx); + return res; +} + +static sexp analyze_set (sexp ctx, sexp x) { + sexp res, varenv; + sexp_gc_var2(ref, value); + sexp_gc_preserve2(ctx, ref, value); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)) + && sexp_nullp(sexp_cdddr(x)) && sexp_idp(sexp_cadr(x)))) { + res = sexp_compile_error(ctx, "bad set! syntax", x); + } else { + ref = analyze_var_ref(ctx, sexp_cadr(x), &varenv); + if (sexp_lambdap(sexp_ref_loc(ref))) + sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref)); + value = analyze(ctx, sexp_caddr(x)); + if (sexp_exceptionp(ref)) + res = ref; + else if (sexp_exceptionp(value)) + res = value; + else if (sexp_immutablep(sexp_ref_cell(ref)) + || (varenv && sexp_immutablep(varenv))) + res = sexp_compile_error(ctx, "immutable binding", sexp_cadr(x)); + else + res = sexp_make_set(ctx, ref, value); + } + sexp_gc_release2(ctx); + return res; +} + +#define sexp_return(res, val) do {res=val; goto cleanup;} while (0) + +static sexp analyze_lambda (sexp ctx, sexp x) { + sexp name, ls, ctx3; + sexp_gc_var6(res, body, tmp, value, defs, ctx2); + sexp_gc_preserve6(ctx, res, body, tmp, value, defs, ctx2); + /* verify syntax */ + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) + sexp_return(res, sexp_compile_error(ctx, "bad lambda syntax", x)); + for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls)) + if (! sexp_idp(sexp_car(ls))) + sexp_return(res, sexp_compile_error(ctx, "non-symbol parameter", x)); + else if (sexp_truep(sexp_memq(ctx, sexp_car(ls), sexp_cdr(ls)))) + sexp_return(res, sexp_compile_error(ctx, "duplicate parameter", x)); + /* build lambda and analyze body */ + res = sexp_make_lambda(ctx, tmp=sexp_copy_list(ctx, sexp_cadr(x))); + sexp_lambda_source(res) = sexp_pair_source(x); + if (! (sexp_lambda_source(res) && sexp_pairp(sexp_lambda_source(res)))) + sexp_lambda_source(res) = sexp_pair_source(sexp_cdr(x)); + if (! (sexp_lambda_source(res) && sexp_pairp(sexp_lambda_source(res)))) + sexp_lambda_source(res) = sexp_pair_source(sexp_cddr(x)); + ctx2 = sexp_make_child_context(ctx, res); + tmp = sexp_flatten_dot(ctx2, sexp_lambda_params(res)); + sexp_context_env(ctx2) = sexp_extend_env(ctx2, sexp_context_env(ctx2), tmp, res); + sexp_env_lambda(sexp_context_env(ctx2)) = res; + body = analyze_seq(ctx2, sexp_cddr(x)); + if (sexp_exceptionp(body)) sexp_return(res, body); + /* delayed analyze internal defines */ + defs = SEXP_NULL; + for (ls=sexp_lambda_defs(res); sexp_pairp(ls); ls=sexp_cdr(ls)) { + tmp = sexp_car(ls); + ctx3 = sexp_cdr(tmp); + if (sexp_pairp(sexp_caar(tmp))) { + name = sexp_caaar(tmp); + tmp = sexp_cons(ctx3, sexp_cdaar(tmp), sexp_cdar(tmp)); + tmp = sexp_cons(ctx3, SEXP_VOID, tmp); + sexp_pair_source(tmp) = sexp_pair_source(sexp_caar(ls)); + value = analyze_lambda(ctx3, tmp); + } else { + name = sexp_caar(tmp); + value = analyze(ctx3, sexp_cadar(tmp)); + } + if (sexp_exceptionp(value)) sexp_return(res, value); + if (sexp_lambdap(value)) sexp_lambda_name(value) = name; + sexp_push(ctx3, defs, + sexp_make_set(ctx3, analyze_var_ref(ctx3, name, NULL), value)); + } + if (sexp_pairp(defs)) { + if (! sexp_seqp(body)) { + tmp = sexp_alloc_type(ctx2, seq, SEXP_SEQ); + sexp_seq_ls(tmp) = sexp_list1(ctx2, body); + body = tmp; + } + sexp_seq_ls(body) = sexp_append2(ctx2, defs, sexp_seq_ls(body)); + } + sexp_lambda_body(res) = body; + cleanup: + sexp_gc_release6(ctx); + return res; +} + +static sexp analyze_if (sexp ctx, sexp x) { + sexp res, fail_expr; + sexp_gc_var3(test, pass, fail); + sexp_gc_preserve3(ctx, test, pass, fail); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { + res = sexp_compile_error(ctx, "bad if syntax", x); + } else { + test = analyze(ctx, sexp_cadr(x)); + pass = analyze(ctx, sexp_caddr(x)); + fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID; + fail = analyze(ctx, fail_expr); + res = (sexp_exceptionp(test) ? test : sexp_exceptionp(pass) ? pass : + sexp_exceptionp(fail) ? fail : sexp_make_cnd(ctx, test, pass, fail)); + } + sexp_gc_release3(ctx); + return res; +} + +static sexp analyze_define (sexp ctx, sexp x) { + sexp name, res, varenv; + sexp_gc_var4(ref, value, tmp, env); + sexp_gc_preserve4(ctx, ref, value, tmp, env); + env = sexp_context_env(ctx); + while (sexp_env_syntactic_p(env) && sexp_env_parent(env)) + env = sexp_env_parent(env); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { + res = sexp_compile_error(ctx, "bad define syntax", x); + } else { + name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x)); + if (! sexp_idp(name)) { + res = sexp_compile_error(ctx, "can't define a non-symbol", x); + } else if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) { + sexp_env_push(ctx, env, tmp, name, sexp_context_lambda(ctx)); + sexp_push(ctx, sexp_lambda_sv(sexp_env_lambda(env)), name); + sexp_push(ctx, sexp_lambda_locals(sexp_env_lambda(env)), name); + tmp = sexp_cons(ctx, sexp_cdr(x), ctx); + sexp_pair_source(sexp_cdr(x)) = sexp_pair_source(x); + sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), tmp); + res = SEXP_VOID; + } else { + if (sexp_synclop(name)) name = sexp_synclo_expr(name); + sexp_env_cell_create(ctx, env, name, SEXP_VOID, NULL); + if (sexp_pairp(sexp_cadr(x))) { + tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x)); + tmp = sexp_cons(ctx, SEXP_VOID, tmp); + sexp_pair_source(tmp) = sexp_pair_source(x); + value = analyze_lambda(ctx, tmp); + } else + value = analyze(ctx, sexp_caddr(x)); + ref = analyze_var_ref(ctx, name, &varenv); + if (sexp_exceptionp(ref)) { + res = ref; + } else if (sexp_exceptionp(value)) { + res = value; + } else if (varenv && sexp_immutablep(varenv)) { + res = sexp_compile_error(ctx, "immutable binding", name); + } else { + if (sexp_lambdap(value)) sexp_lambda_name(value) = name; + res = sexp_make_set(ctx, ref, value); + } + } + } + sexp_gc_release4(ctx); + return res; +} + +static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { + sexp res = SEXP_VOID, name; + sexp_gc_var2(proc, mac); + sexp_gc_preserve2(eval_ctx, proc, mac); + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { + if (! (sexp_pairp(sexp_car(ls)) && sexp_pairp(sexp_cdar(ls)) + && sexp_nullp(sexp_cddar(ls)))) { + res = sexp_compile_error(eval_ctx, "bad syntax binding", sexp_car(ls)); + } else { + proc = sexp_eval(eval_ctx, sexp_cadar(ls), NULL); + if (sexp_procedurep(proc)) { + name = sexp_caar(ls); + if (sexp_synclop(name) && sexp_env_global_p(sexp_context_env(bind_ctx))) + name = sexp_synclo_expr(name); + mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(bind_ctx)); + sexp_env_define(eval_ctx, sexp_context_env(bind_ctx), name, mac); + } else { + res = (sexp_exceptionp(proc) ? proc + : sexp_compile_error(eval_ctx, "non-procedure macro:", proc)); + break; + } + } + } + sexp_gc_release2(eval_ctx); + return res; +} + +static sexp analyze_define_syntax (sexp ctx, sexp x) { + sexp res; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_list1(ctx, sexp_cdr(x)); + res = analyze_bind_syntax(tmp, ctx, ctx); + sexp_gc_release1(ctx); + return res; +} + +static sexp analyze_let_syntax_aux (sexp ctx, sexp x, int recp) { + sexp res; + sexp_gc_var3(env, ctx2, tmp); + sexp_gc_preserve3(ctx, env, ctx2, tmp); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { + res = sexp_compile_error(ctx, "bad let(rec)-syntax", x); + } else { + env = sexp_alloc_type(ctx, env, SEXP_ENV); + sexp_env_syntactic_p(env) = 1; + sexp_env_parent(env) = sexp_context_env(ctx); + sexp_env_bindings(env) = SEXP_NULL; + ctx2 = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + sexp_context_env(ctx2) = env; + tmp = analyze_bind_syntax(sexp_cadr(x), (recp ? ctx2 : ctx), ctx2); + res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx2, sexp_cddr(x))); + } + sexp_gc_release3(ctx); + return res; +} + +static sexp analyze_let_syntax (sexp ctx, sexp x) { + return analyze_let_syntax_aux(ctx, x, 0); +} + +static sexp analyze_letrec_syntax (sexp ctx, sexp x) { + return analyze_let_syntax_aux(ctx, x, 1); +} + +static sexp analyze (sexp ctx, sexp object) { + sexp op; + sexp_gc_var4(res, tmp, x, cell); + sexp_gc_preserve4(ctx, res, tmp, x, cell); + x = object; + loop: + if (sexp_pairp(x)) { + if (sexp_not(sexp_listp(ctx, x))) { + res = sexp_compile_error(ctx, "dotted list in source", x); + } else if (sexp_idp(sexp_car(x))) { + cell = sexp_env_cell(sexp_context_env(ctx), sexp_car(x)); + if (! cell && sexp_synclop(sexp_car(x))) + cell = sexp_env_cell(sexp_synclo_env(sexp_car(x)), + sexp_synclo_expr(sexp_car(x))); + if (! cell) { + res = analyze_app(ctx, x); + } else { + op = sexp_cdr(cell); + if (sexp_corep(op)) { + switch (sexp_core_code(op)) { + case SEXP_CORE_DEFINE: + res = analyze_define(ctx, x); break; + case SEXP_CORE_SET: + res = analyze_set(ctx, x); break; + case SEXP_CORE_LAMBDA: + res = analyze_lambda(ctx, x); break; + case SEXP_CORE_IF: + res = analyze_if(ctx, x); break; + case SEXP_CORE_BEGIN: + res = analyze_seq(ctx, sexp_cdr(x)); break; + case SEXP_CORE_QUOTE: + case SEXP_CORE_SYNTAX_QUOTE: + if (! (sexp_pairp(sexp_cdr(x)) && sexp_nullp(sexp_cddr(x)))) + res = sexp_compile_error(ctx, "bad quote form", x); + else + res = sexp_make_lit(ctx, + (sexp_core_code(op) == SEXP_CORE_QUOTE) ? + sexp_strip_synclos(ctx sexp_api_pass(NULL, 1), sexp_cadr(x)) : + sexp_cadr(x)); + break; + case SEXP_CORE_DEFINE_SYNTAX: + res = analyze_define_syntax(ctx, x); break; + case SEXP_CORE_LET_SYNTAX: + res = analyze_let_syntax(ctx, x); break; + case SEXP_CORE_LETREC_SYNTAX: + res = analyze_letrec_syntax(ctx, x); break; + default: + res = sexp_compile_error(ctx, "unknown core form", op); break; + } + } else if (sexp_macrop(op)) { + tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL); + tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp); + tmp = sexp_cons(ctx, x, tmp); + x = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + x = sexp_apply(x, sexp_macro_proc(op), tmp); + if (sexp_exceptionp(x) && sexp_not(sexp_exception_source(x))) + sexp_exception_source(x) = sexp_pair_source(sexp_car(tmp)); + goto loop; + } else if (sexp_opcodep(op)) { + res = sexp_length(ctx, sexp_cdr(x)); + if (sexp_unbox_fixnum(res) < sexp_opcode_num_args(op)) { + res = sexp_compile_error(ctx, "not enough args for opcode", x); + } else if ((sexp_unbox_fixnum(res) > sexp_opcode_num_args(op)) + && (! sexp_opcode_variadic_p(op))) { + res = sexp_compile_error(ctx, "too many args for opcode", x); + } else { + res = analyze_app(ctx, sexp_cdr(x)); + if (! sexp_exceptionp(res)) + sexp_push(ctx, res, op); + } + } else { + res = analyze_app(ctx, x); + } + } + } else { + if (! (sexp_truep(sexp_listp(ctx, sexp_car(x))) + || (sexp_synclop(sexp_car(x)) + && sexp_truep(sexp_listp(ctx, + sexp_synclo_expr(sexp_car(x))))))) + sexp_warn(ctx, "invalid operand in application: ", x); + res = analyze_app(ctx, x); + } + } else if (sexp_idp(x)) { + res = analyze_var_ref(ctx, x, NULL); + } else if (sexp_synclop(x)) { + tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + sexp_context_env(tmp) = sexp_synclo_env(x); + sexp_context_fv(tmp) = sexp_append2(tmp, + sexp_synclo_free_vars(x), + sexp_context_fv(tmp)); + x = sexp_synclo_expr(x); + res = analyze(tmp, x); + } else { + res = x; + } + if (sexp_exceptionp(res) && sexp_not(sexp_exception_source(res)) + && sexp_pairp(x)) + sexp_exception_source(res) = sexp_pair_source(x); + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_analyze (sexp ctx, sexp x) {return analyze(ctx, x);} + +/********************** free varable analysis *************************/ + +static sexp insert_free_var (sexp ctx, sexp x, sexp fv) { + sexp name=sexp_ref_name(x), loc=sexp_ref_loc(x), ls; + for (ls=fv; sexp_pairp(ls); ls=sexp_cdr(ls)) + if ((name == sexp_ref_name(sexp_car(ls))) + && (loc == sexp_ref_loc(sexp_car(ls)))) + return fv; + return sexp_cons(ctx, x, fv); +} + +static sexp union_free_vars (sexp ctx, sexp fv1, sexp fv2) { + sexp_gc_var1(res); + if (sexp_nullp(fv2)) + return fv1; + sexp_gc_preserve1(ctx, res); + for (res=fv2; sexp_pairp(fv1); fv1=sexp_cdr(fv1)) + res = insert_free_var(ctx, sexp_car(fv1), res); + sexp_gc_release1(ctx); + return res; +} + +static sexp diff_free_vars (sexp ctx, sexp lambda, sexp fv, sexp params) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; + for ( ; sexp_pairp(fv); fv=sexp_cdr(fv)) + if ((sexp_ref_loc(sexp_car(fv)) != lambda) + || (sexp_memq(NULL, sexp_ref_name(sexp_car(fv)), params) + == SEXP_FALSE)) + sexp_push(ctx, res, sexp_car(fv)); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_free_vars (sexp ctx, sexp x, sexp fv) { + sexp_gc_var2(fv1, fv2); + sexp_gc_preserve2(ctx, fv1, fv2); + fv1 = fv; + if (sexp_lambdap(x)) { + fv1 = sexp_free_vars(ctx, sexp_lambda_body(x), SEXP_NULL); + fv2 = sexp_flatten_dot(ctx, sexp_lambda_params(x)); + fv2 = sexp_append2(ctx, sexp_lambda_locals(x), fv2); + fv2 = diff_free_vars(ctx, x, fv1, fv2); + sexp_lambda_fv(x) = fv2; + fv1 = union_free_vars(ctx, fv2, fv); + } else if (sexp_pairp(x)) { + for ( ; sexp_pairp(x); x=sexp_cdr(x)) + fv1 = sexp_free_vars(ctx, sexp_car(x), fv1); + } else if (sexp_cndp(x)) { + fv1 = sexp_free_vars(ctx, sexp_cnd_test(x), fv); + fv1 = sexp_free_vars(ctx, sexp_cnd_pass(x), fv1); + fv1 = sexp_free_vars(ctx, sexp_cnd_fail(x), fv1); + } else if (sexp_seqp(x)) { + for (x=sexp_seq_ls(x); sexp_pairp(x); x=sexp_cdr(x)) + fv1 = sexp_free_vars(ctx, sexp_car(x), fv1); + } else if (sexp_setp(x)) { + fv1 = sexp_free_vars(ctx, sexp_set_value(x), fv); + fv1 = sexp_free_vars(ctx, sexp_set_var(x), fv1); + } else if (sexp_refp(x) && sexp_lambdap(sexp_ref_loc(x))) { + fv1 = insert_free_var(ctx, x, fv); + } else if (sexp_synclop(x)) { + fv1 = sexp_free_vars(ctx, sexp_synclo_expr(x), fv); + } + sexp_gc_release2(ctx); + return fv1; +} + +/************************ library procedures **************************/ + +static sexp sexp_exception_type_op (sexp ctx sexp_api_params(self, n), sexp exn) { + sexp_assert_type(ctx, sexp_exceptionp, SEXP_EXCEPTION, exn); + return sexp_exception_kind(exn); +} + +static sexp sexp_open_input_file_op (sexp ctx sexp_api_params(self, n), sexp path) { + FILE *in; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path); + in = fopen(sexp_string_data(path), "r"); + if (! in) + return sexp_user_exception(ctx, self, "couldn't open input file", path); + return sexp_make_input_port(ctx, in, path); +} + +static sexp sexp_open_output_file_op (sexp ctx sexp_api_params(self, n), sexp path) { + FILE *out; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path); + out = fopen(sexp_string_data(path), "w"); + if (! out) + return sexp_user_exception(ctx, self, "couldn't open output file", path); + return sexp_make_output_port(ctx, out, path); +} + +static sexp sexp_close_port_op (sexp ctx sexp_api_params(self, n), sexp port) { + sexp_assert_type(ctx, sexp_portp, SEXP_OPORT, port); + if (! sexp_port_openp(port)) + return sexp_user_exception(ctx, self, "port already closed", port); + return sexp_finalize_port(ctx sexp_api_pass(self, n), port); +} + +#if SEXP_USE_DL +#ifdef __MINGW32__ +#include +static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { + sexp_proc2 init; + HINSTANCE handle = LoadLibraryA(sexp_string_data(file)); + if(!handle) + return sexp_compile_error(ctx, "couldn't load dynamic library", file); + init = (sexp_proc2) GetProcAddress(handle, "sexp_init_library"); + if(!init) { + FreeLibrary(handle); + return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file); + } + return init(ctx sexp_api_pass(NULL, 1), env); +} +#else +static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { + sexp_proc2 init; + void *handle = dlopen(sexp_string_data(file), RTLD_LAZY); + if (! handle) + return sexp_compile_error(ctx, "couldn't load dynamic library", file); + init = dlsym(handle, "sexp_init_library"); + if (! init) { + dlclose(handle); + return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file); + } + return init(ctx sexp_api_pass(NULL, 1), env); +} +#endif +#endif + +sexp sexp_load_op (sexp ctx sexp_api_params(self, n), sexp source, sexp env) { +#if SEXP_USE_DL + char *suffix; +#endif + sexp tmp, out=SEXP_FALSE; + sexp_gc_var4(ctx2, x, in, res); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, source); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); +#if SEXP_USE_DL + suffix = sexp_string_data(source) + + sexp_string_length(source) - strlen(sexp_so_extension); + if (strcmp(suffix, sexp_so_extension) == 0) { + res = sexp_load_dl(ctx, source, env); + } else { +#endif + sexp_gc_preserve4(ctx, ctx2, x, in, res); + res = SEXP_VOID; + in = sexp_open_input_file(ctx, source); + out = sexp_current_error_port(ctx); + ctx2 = sexp_make_eval_context(ctx, NULL, env, 0); + sexp_context_parent(ctx2) = ctx; + tmp = sexp_env_bindings(env); + sexp_context_tailp(ctx2) = 0; + if (sexp_exceptionp(in)) { + if (sexp_not(out)) out = sexp_current_error_port(ctx); + if (sexp_oportp(out)) + sexp_print_exception(ctx, in, out); + res = in; + } else { + sexp_port_sourcep(in) = 1; + while ((x=sexp_read(ctx, in)) != (sexp) SEXP_EOF) { + res = sexp_eval(ctx2, x, env); + if (sexp_exceptionp(res)) + break; + } + if (x == SEXP_EOF) + res = SEXP_VOID; + sexp_close_port(ctx, in); + } +#if SEXP_USE_WARN_UNDEFS + if (! sexp_exceptionp(res)) + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp); +#endif + sexp_gc_release4(ctx); +#if SEXP_USE_DL + } +#endif + return res; +} + +#if SEXP_USE_MATH + +#if SEXP_USE_BIGNUMS +#define maybe_convert_bignum(z) \ + else if (sexp_bignump(z)) d = sexp_bignum_to_double(z); +#else +#define maybe_convert_bignum(z) +#endif + +#define define_math_op(name, cname) \ + static sexp name (sexp ctx sexp_api_params(self, n), sexp z) { \ + double d; \ + if (sexp_flonump(z)) \ + d = sexp_flonum_value(z); \ + else if (sexp_fixnump(z)) \ + d = (double)sexp_unbox_fixnum(z); \ + maybe_convert_bignum(z) \ + else \ + return sexp_type_exception(ctx, self, SEXP_NUMBER, z); \ + return sexp_make_flonum(ctx, cname(d)); \ + } + +define_math_op(sexp_exp, exp) +define_math_op(sexp_log, log) +define_math_op(sexp_sin, sin) +define_math_op(sexp_cos, cos) +define_math_op(sexp_tan, tan) +define_math_op(sexp_asin, asin) +define_math_op(sexp_acos, acos) +define_math_op(sexp_atan, atan) +define_math_op(sexp_round, round) +define_math_op(sexp_trunc, trunc) +define_math_op(sexp_floor, floor) +define_math_op(sexp_ceiling, ceil) + +static sexp sexp_sqrt (sexp ctx sexp_api_params(self, n), sexp z) { + double d, r; + if (sexp_flonump(z)) + d = sexp_flonum_value(z); + else if (sexp_fixnump(z)) + d = (double)sexp_unbox_fixnum(z); + maybe_convert_bignum(z) /* XXXX add bignum sqrt */ + else + return sexp_type_exception(ctx, self, SEXP_NUMBER, z); + r = sqrt(d); + if (sexp_fixnump(z) && ((r*r) == (double)sexp_unbox_fixnum(z))) + return sexp_make_fixnum(round(r)); + else + return sexp_make_flonum(ctx, r); +} + +#endif + +static sexp sexp_expt_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { + long double f, x1, e1; + sexp res; +#if SEXP_USE_BIGNUMS + if (sexp_bignump(e)) { /* bignum exponent needs special handling */ + if ((x == SEXP_ZERO) || (x == SEXP_NEG_ONE)) + res = sexp_make_flonum(ctx, pow(0, 0)); /* +nan.0 */ + else if (x == SEXP_ONE) + res = SEXP_ONE; /* 1.0 */ + else if (sexp_flonump(x)) + res = sexp_make_flonum(ctx, pow(sexp_flonum_value(x), sexp_bignum_to_double(e))); + else + res = sexp_make_flonum(ctx, pow(10.0, 1e100)); /* +inf.0 */ + } else if (sexp_bignump(x)) { + res = sexp_bignum_expt(ctx, x, e); + } else { +#endif + if (sexp_fixnump(x)) + x1 = sexp_unbox_fixnum(x); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(x)) + x1 = sexp_flonum_value(x); +#endif + else + return sexp_type_exception(ctx, self, SEXP_FIXNUM, x); + if (sexp_fixnump(e)) + e1 = sexp_unbox_fixnum(e); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(e)) + e1 = sexp_flonum_value(e); +#endif + else + return sexp_type_exception(ctx, self, SEXP_FIXNUM, e); + f = pow(x1, e1); + if ((f > SEXP_MAX_FIXNUM) || (f < SEXP_MIN_FIXNUM) +#if SEXP_USE_FLONUMS + || (! sexp_fixnump(x)) || (! sexp_fixnump(e)) +#endif + ) { +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(x) && sexp_fixnump(e)) + res = sexp_bignum_expt(ctx, sexp_fixnum_to_bignum(ctx, x), e); + else +#endif +#if SEXP_USE_FLONUMS + res = sexp_make_flonum(ctx, f); +#else + res = sexp_make_fixnum((sexp_sint_t)round(f)); +#endif + } else + res = sexp_make_fixnum((sexp_sint_t)round(f)); +#if SEXP_USE_BIGNUMS + } +#endif + return res; +} + +static sexp sexp_string_cmp_op (sexp ctx sexp_api_params(self, n), sexp str1, sexp str2, sexp ci) { + sexp_sint_t len1, len2, len, diff; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str1); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str2); + len1 = sexp_string_length(str1); + len2 = sexp_string_length(str2); + len = ((len1>4)&1)+3; +} + +static int sexp_utf8_char_byte_count(int c) { + if (c < 0x80) return 1; + if (c < 0x800) return 2; + if (c < 0x10000) return 3; + return 4; +} + +static int sexp_string_utf8_length (unsigned char *p, int len) { + unsigned char *q = p+len; + int i; + for (i=0; p0 && j0) + return sexp_user_exception(ctx, self, "string-index->offset: index out of range", index); + return sexp_make_fixnum(j); +} + +sexp sexp_string_utf8_ref (sexp ctx, sexp str, sexp i) { + unsigned char *p=(unsigned char*)sexp_string_data(str) + sexp_unbox_fixnum(i); + if (*p < 0x80) + return sexp_make_character(*p); + else if ((*p < 0xC0) || (*p > 0xF7)) + return sexp_user_exception(ctx, NULL, "string-ref: invalid utf8 byte", i); + else if (*p < 0xE0) + return sexp_make_character(((p[0]&0x3F)<<6) + (p[1]&0x3F)); + else if (*p < 0xF0) + return sexp_make_character(((p[0]&0x1F)<<12) + ((p[1]&0x3F)<<6) + (p[2]&0x3F)); + else + return sexp_make_character(((p[0]&0x0F)<<16) + ((p[1]&0x3F)<<6) + ((p[2]&0x3F)<<6) + (p[2]&0x3F)); +} + +sexp sexp_string_utf8_index_ref (sexp ctx sexp_api_params(self, n), sexp str, sexp i) { + sexp off; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i); + off = sexp_string_index_to_offset(ctx sexp_api_pass(self, n), str, i); + if (sexp_exceptionp(off)) return off; + return sexp_string_utf8_ref(ctx, str, off); +} + +void sexp_utf8_encode_char (unsigned char* p, int len, int c) { + switch (len) { + case 4: *p++ = (0xF0 + ((c)>>18)); *p++ = (0x80 + ((c>>12)&0x3F)); + *p++ = (0x80 + ((c>>6)&0x3F)); *p = (0x80 + (c&0x3F)); break; + case 3: *p++ = (0xE0 + ((c)>>12)); *p++ = (0x80 + ((c>>6)&0x3F)); + *p = (0x80 + (c&0x3F)); break; + case 2: *p++ = (0xC0 + ((c)>>6)); *p = (0x80 + (c&0x3F)); break; + default: *p = c; break; + } +} + +void sexp_write_utf8_char (sexp ctx, int c, sexp out) { + unsigned char buf[8]; + int len = sexp_utf8_char_byte_count(c); + sexp_utf8_encode_char(buf, len, c); + buf[len+1] = 0; + sexp_write_string(ctx, (char*)buf, out); +} + +sexp sexp_read_utf8_char (sexp ctx, sexp port, int i) { + if (i >= 0x80) { + if ((i < 0xC0) || (i > 0xF7)) { + return sexp_user_exception(ctx, NULL, "read-char: invalid utf8 byte", sexp_make_fixnum(i)); + } else if (i < 0xE0) { + i = ((i&0x3F)<<6) + (sexp_read_char(ctx, port)&0x3F); + } else if (i < 0xF0) { + i = ((i&0x1F)<<12) + ((sexp_read_char(ctx, port)&0x3F)<<6); + i += sexp_read_char(ctx, port)&0x3F; + } else { + i = ((i&0x0F)<<16) + ((sexp_read_char(ctx, port)&0x3F)<<6); + i += (sexp_read_char(ctx, port)&0x3F)<<6; + i += sexp_read_char(ctx, port)&0x3F; + } + } + return sexp_make_character(i); +} + +#if SEXP_USE_MUTABLE_STRINGS + +void sexp_string_utf8_set (sexp ctx, sexp str, sexp index, sexp ch) { + sexp b; + unsigned char *p, *q; + int i = sexp_unbox_fixnum(index), c = sexp_unbox_character(ch), + old_len, new_len, len; + p = (unsigned char*)sexp_string_data(str) + i; + old_len = sexp_utf8_initial_byte_count(*p); + new_len = sexp_utf8_char_byte_count(c); + if (old_len != new_len) { /* resize bytes if needed */ + len = sexp_string_length(str)+(new_len-old_len); + b = sexp_make_bytes(ctx, sexp_make_fixnum(len), SEXP_VOID); + if (! sexp_exceptionp(b)) { + q = (unsigned char*)sexp_bytes_data(b); + memcpy(q, sexp_string_data(str), i); + memcpy(q+i+new_len, p+old_len, len-i-new_len+1); + sexp_string_bytes(str) = b; + p = q + i; + } + sexp_string_length(str) += new_len - old_len; + } + sexp_utf8_encode_char(p, new_len, c); +} + +sexp sexp_string_utf8_index_set (sexp ctx sexp_api_params(self, n), sexp str, sexp i, sexp ch) { + sexp off; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i); + sexp_assert_type(ctx, sexp_charp, SEXP_CHAR, ch); + off = sexp_string_index_to_offset(ctx sexp_api_pass(self, n), str, i); + if (sexp_exceptionp(off)) return off; + sexp_string_utf8_set(ctx, str, off, ch); + return SEXP_VOID; +} + +#endif +#endif + +#ifdef PLAN9 +#include "opt/plan9.c" +#endif + +/************************** optimizations *****************************/ + +#if SEXP_USE_SIMPLIFY +#include "opt/simplify.c" +#endif + +/***************************** opcodes ********************************/ + +#include "opcodes.c" + +static sexp sexp_copy_core (sexp ctx, struct sexp_core_form_struct *core) { + sexp res = sexp_alloc_type(ctx, core, SEXP_CORE); + memcpy(&(res->value), core, sizeof(core[0])); + return res; +} + +static sexp sexp_copy_opcode (sexp ctx, struct sexp_opcode_struct *op) { + sexp res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + memcpy(&(res->value), op, sizeof(op[0])); + return res; +} + +sexp sexp_make_opcode (sexp ctx, sexp self, sexp name, sexp op_class, sexp code, + sexp num_args, sexp flags, sexp arg1t, sexp arg2t, + sexp invp, sexp data, sexp data2, sexp_proc1 func) { + sexp res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, num_args); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, flags); + if ((! sexp_fixnump(op_class)) || (sexp_unbox_fixnum(op_class) <= 0) + || (sexp_unbox_fixnum(op_class) >= SEXP_OPC_NUM_OP_CLASSES)) + res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode class", op_class); + else if ((! sexp_fixnump(code)) || (sexp_unbox_fixnum(code) <= 0) + || (sexp_unbox_fixnum(code) >= SEXP_OP_NUM_OPCODES)) + res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode", code); + else { + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = sexp_unbox_fixnum(op_class); + sexp_opcode_code(res) = sexp_unbox_fixnum(code); + sexp_opcode_num_args(res) = sexp_unbox_fixnum(num_args); + sexp_opcode_flags(res) = sexp_unbox_fixnum(flags); + sexp_opcode_arg1_type(res) = arg1t; + sexp_opcode_arg2_type(res) = arg2t; + sexp_opcode_inverse(res) = sexp_unbox_fixnum(invp); + sexp_opcode_data(res) = data; + sexp_opcode_data2(res) = data2; + sexp_opcode_func(res) = func; + sexp_opcode_name(res) = strdup(sexp_string_data(name)); + } + return res; +} + +sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { + sexp res; +#if ! SEXP_USE_EXTENDED_FCALL + if (num_args > 4) + return sexp_user_exception(ctx, NULL, "make-foreign: exceeded foreign arg limit", + sexp_make_fixnum(num_args)); +#endif + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = SEXP_OPC_FOREIGN; +#if SEXP_USE_EXTENDED_FCALL + if (num_args > 4) + sexp_opcode_code(res) = SEXP_OP_FCALLN; + else +#endif + sexp_opcode_code(res) = SEXP_OP_FCALL1+num_args-1; + if (flags & 1) num_args--; + sexp_opcode_num_args(res) = num_args; + sexp_opcode_flags(res) = flags; + sexp_opcode_name(res) = name; + sexp_opcode_data(res) = data; + sexp_opcode_func(res) = f; + return res; +} + +sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { + sexp res = SEXP_VOID; + sexp_gc_var1(op); + sexp_gc_preserve1(ctx, op); + op = sexp_make_foreign(ctx, name, num_args, flags, f, data); + if (sexp_exceptionp(op)) + res = op; + else + sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), op); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_args, + sexp_proc1 f, const char *param) { + sexp res; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_intern(ctx, param, -1); + tmp = sexp_env_cell(env, tmp); + res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, f, tmp); + sexp_gc_release1(ctx); + return res; +} + +#if SEXP_USE_TYPE_DEFS + +sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) { + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type); + return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE), + sexp_make_fixnum(SEXP_OP_TYPEP), SEXP_ONE, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, NULL, NULL); +} + +sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) { + sexp_uint_t type_size; + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type); + type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type))); + return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR), + sexp_make_fixnum(SEXP_OP_MAKE), SEXP_ZERO, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, + sexp_make_fixnum(type_size), NULL); +} + +sexp sexp_make_getter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) { + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); + if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); + if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, index); + return + sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_GETTER), + sexp_make_fixnum(SEXP_OP_SLOT_REF), SEXP_ONE, SEXP_ZERO, + type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); +} + +sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) { + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); + if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); + if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, index); + return + sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_SETTER), + sexp_make_fixnum(SEXP_OP_SLOT_SET), SEXP_TWO, SEXP_ZERO, + type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); +} + +#endif + +#if SEXP_USE_STATIC_LIBS +#include "clibs.c" +#endif + +/*********************** standard environment *************************/ + +static struct sexp_core_form_struct core_forms[] = { + {SEXP_CORE_DEFINE, "define"}, + {SEXP_CORE_SET, "set!"}, + {SEXP_CORE_LAMBDA, "lambda"}, + {SEXP_CORE_IF, "if"}, + {SEXP_CORE_BEGIN, "begin"}, + {SEXP_CORE_QUOTE, "quote"}, + {SEXP_CORE_SYNTAX_QUOTE, "syntax-quote"}, + {SEXP_CORE_DEFINE_SYNTAX, "define-syntax"}, + {SEXP_CORE_LET_SYNTAX, "let-syntax"}, + {SEXP_CORE_LETREC_SYNTAX, "letrec-syntax"}, +}; + +sexp sexp_make_env_op (sexp ctx sexp_api_params(self, n)) { + sexp e = sexp_alloc_type(ctx, env, SEXP_ENV); + sexp_env_lambda(e) = NULL; + sexp_env_parent(e) = NULL; + sexp_env_bindings(e) = SEXP_NULL; + return e; +} + +sexp sexp_make_null_env_op (sexp ctx sexp_api_params(self, n), sexp version) { + sexp_uint_t i; + sexp e = sexp_make_env(ctx), core; + for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) { + core = sexp_copy_core(ctx, &core_forms[i]); + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_core_name(core), -1), core); + } + return e; +} + +sexp sexp_make_primitive_env (sexp ctx, sexp version) { + int i; + sexp_gc_var3(e, op, sym); + sexp_gc_preserve3(ctx, e, op, sym); + e = sexp_make_null_env(ctx, version); + for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { + op = sexp_copy_opcode(ctx, &opcodes[i]); + if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) { + sym = sexp_intern(ctx, (char*)sexp_opcode_data(op), -1); + sexp_opcode_data(op) = sexp_env_cell_create(ctx, e, sym, SEXP_VOID, NULL); + } + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op), -1), op); + } + sexp_gc_release3(ctx); + return e; +} + +sexp sexp_find_module_file (sexp ctx, const char *file) { + sexp res=SEXP_FALSE, ls; + char *dir, *path; + sexp_uint_t slash, dirlen, filelen, len; +#ifdef PLAN9 +#define file_exists_p(path, buf) (stat(path, buf, 128) >= 0) + unsigned char buf[128]; +#else +#define file_exists_p(path, buf) (! stat(path, buf)) + struct stat buf_str; + struct stat *buf = &buf_str; +#endif + + filelen = strlen(file); + + ls = sexp_global(ctx, SEXP_G_MODULE_PATH); + for ( ; sexp_pairp(ls) && sexp_not(res); ls=sexp_cdr(ls)) { + dir = sexp_string_data(sexp_car(ls)); + dirlen = sexp_string_length(sexp_car(ls)); + slash = dir[dirlen-1] == '/'; + len = dirlen+filelen+2-slash; + path = (char*) malloc(len); + memcpy(path, dir, dirlen); + if (! slash) path[dirlen] = '/'; + memcpy(path+len-filelen-1, file, filelen); + path[len-1] = '\0'; + if (file_exists_p(path, buf)) + res = sexp_c_string(ctx, path, len-1); + free(path); + } + + return res; +} + +#define sexp_file_not_found "couldn't find file in module path" + +sexp sexp_load_module_file (sexp ctx, const char *file, sexp env) { + sexp res; + sexp_gc_var1(path); + sexp_gc_preserve1(ctx, path); + path = sexp_find_module_file(ctx, file); + if (sexp_stringp(path)) { + res = sexp_load(ctx, path, env); + } else { + path = sexp_c_string(ctx, file, -1); + res = sexp_user_exception(ctx, SEXP_FALSE, sexp_file_not_found, path); + } + sexp_gc_release1(ctx); + return res; +} + +#if SEXP_USE_MODULES +sexp sexp_find_module_file_op (sexp ctx sexp_api_params(self, n), sexp file) { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file); + return sexp_find_module_file(ctx, sexp_string_data(file)); +} +sexp sexp_load_module_file_op (sexp ctx sexp_api_params(self, n), sexp file, sexp env) { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + return sexp_load_module_file(ctx, sexp_string_data(file), env); +} +sexp sexp_current_environment (sexp ctx sexp_api_params(self, n)) { + return sexp_context_env(ctx); +} +#endif + +sexp sexp_add_module_directory_op (sexp ctx sexp_api_params(self, n), sexp dir, sexp appendp) { + sexp ls; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, dir); + if (sexp_truep(appendp)) { + if (sexp_pairp(ls=sexp_global(ctx, SEXP_G_MODULE_PATH))) { + for ( ; sexp_pairp(sexp_cdr(ls)); ls=sexp_cdr(ls)) + ; + sexp_cdr(ls) = sexp_list1(ctx, dir); + } else { + sexp_global(ctx, SEXP_G_MODULE_PATH) = sexp_list1(ctx, dir); + } + } else { + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), dir); + } + return SEXP_VOID; +} + +sexp sexp_load_standard_parameters (sexp ctx, sexp e) { + /* add io port and interaction env parameters */ + sexp p = sexp_make_input_port(ctx, stdin, SEXP_FALSE); + sexp_port_no_closep(p) = 1; + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), p); + p = sexp_make_output_port(ctx, stdout, SEXP_FALSE); + sexp_port_no_closep(p) = 1; + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), p); + p = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_port_no_closep(p) = 1; + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), p); + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e); + return SEXP_VOID; +} + +sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { + sexp_gc_var3(op, tmp, sym); + sexp_gc_preserve3(ctx, op, tmp, sym); + sexp_load_standard_parameters(ctx, e); +#if SEXP_USE_DL + sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*shared-object-extension*", -1), + tmp=sexp_c_string(ctx, sexp_so_extension, -1)); +#endif + tmp = sexp_list1(ctx, sym=sexp_intern(ctx, sexp_platform, -1)); +#if SEXP_USE_DL + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "dynamic-loading", -1)); +#endif +#if SEXP_USE_MODULES + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "modules", -1)); +#endif +#if SEXP_USE_BOEHM + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "boehm-gc", -1)); +#endif +#if SEXP_USE_UTF8_STRINGS + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "utf-8", -1)); +#endif +#if SEXP_USE_GREEN_THREADS + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "threads", -1)); +#endif + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi", -1)); + sexp_env_define(ctx, e, sexp_intern(ctx, "*features*", -1), tmp); + sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL; +#if SEXP_USE_SIMPLIFY + op = sexp_make_foreign(ctx, "simplify", 1, 0, + (sexp_proc1)sexp_simplify, SEXP_VOID); + tmp = sexp_cons(ctx, sexp_make_fixnum(500), op); + sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp); +#endif + /* load init.scm */ + tmp = sexp_load_module_file(ctx, sexp_init_file, e); + /* load and bind config env */ +#if SEXP_USE_MODULES + if (! sexp_exceptionp(tmp)) { + sym = sexp_intern(ctx, "*config-env*", -1); + if (! sexp_envp(tmp=sexp_global(ctx, SEXP_G_CONFIG_ENV))) { + tmp = sexp_make_env(ctx); + if (! sexp_exceptionp(tmp)) { + sexp_global(ctx, SEXP_G_CONFIG_ENV) = tmp; + sexp_env_parent(tmp) = e; + op = sexp_load_module_file(ctx, sexp_config_file, tmp); + if (sexp_exceptionp(op)) + sexp_print_exception(ctx, op, sexp_current_error_port(ctx)); + sexp_env_define(ctx, tmp, sym, tmp); + } + } + sexp_env_define(ctx, e, sym, tmp); + } +#endif +#if SEXP_USE_STATIC_LIBS + sexp_init_all_libraries(ctx, e); +#endif + sexp_gc_release3(ctx); + return sexp_exceptionp(tmp) ? tmp : e; +} + +sexp sexp_make_standard_env_op (sexp ctx sexp_api_params(self, n), sexp version) { + sexp_gc_var1(env); + sexp_gc_preserve1(ctx, env); + env = sexp_make_primitive_env(ctx, version); + if (! sexp_exceptionp(env)) sexp_load_standard_env(ctx, env, version); + sexp_gc_release1(ctx); + return env; +} + +sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, sexp ls, sexp immutp) { + sexp oldname, newname, value; + if (! sexp_envp(to)) to = sexp_context_env(ctx); + if (! sexp_envp(from)) from = sexp_context_env(ctx); + if (sexp_not(ls)) { + if (sexp_truep(immutp)) { + value = sexp_make_env(ctx); + sexp_env_parent(value) = sexp_env_parent(to); + sexp_env_parent(to) = value; + sexp_immutablep(value) = 1; + sexp_env_bindings(value) = sexp_env_bindings(from); + } else { + for (ls=sexp_env_bindings(from); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + sexp_env_define(ctx, to, sexp_car(ls), sexp_cdr(ls)); + } + } else { + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { + if (sexp_pairp(sexp_car(ls))) { + newname = sexp_caar(ls); oldname = sexp_cdar(ls); + } else { + newname = oldname = sexp_car(ls); + } + value = sexp_env_ref(from, oldname, SEXP_UNDEF); + if (value != SEXP_UNDEF) { + sexp_env_define(ctx, to, newname, value); +#if SEXP_USE_WARN_UNDEFS + } else { + sexp_warn(ctx, "importing undefined variable: ", oldname); +#endif + } + } + } + return SEXP_VOID; +} + +/************************* backend ***************************/ + +#if SEXP_USE_NATIVE_X86 +#include "opt/x86.c" +#else +#include "vm.c" +#endif + +/************************** eval interface ****************************/ + +sexp sexp_compile (sexp ctx, sexp x) { + sexp_gc_var3(ast, vec, res); + sexp_gc_preserve3(ctx, ast, vec, res); + ast = sexp_analyze(ctx, x); + if (sexp_exceptionp(ast)) { + res = ast; + } else { + res = sexp_global(ctx, SEXP_G_OPTIMIZATIONS); + for ( ; sexp_pairp(res); res=sexp_cdr(res)) + ast = sexp_apply1(ctx, sexp_cdar(res), ast); + sexp_free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ + emit_enter(ctx); + generate(ctx, ast); + res = finalize_bytecode(ctx); + vec = sexp_make_vector(ctx, 0, SEXP_VOID); + res = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, res, vec); + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_eval_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp env) { + sexp_sint_t top; + sexp ctx2; + sexp_gc_var2(res, err_handler); + if (! env) env = sexp_context_env(ctx); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + sexp_gc_preserve2(ctx, res, err_handler); + top = sexp_context_top(ctx); + err_handler = sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)); + sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = SEXP_FALSE; + ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), env, 0); + sexp_context_child(ctx) = ctx2; + res = sexp_compile(ctx2, obj); + if (! sexp_exceptionp(res)) + res = sexp_apply(ctx2, res, SEXP_NULL); + sexp_context_child(ctx) = SEXP_FALSE; + sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = err_handler; + sexp_context_top(ctx) = top; + sexp_context_last_fp(ctx) = sexp_context_last_fp(ctx2); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_eval_string (sexp ctx, const char *str, sexp_sint_t len, sexp env) { + sexp res; + sexp_gc_var1(obj); + sexp_gc_preserve1(ctx, obj); + obj = sexp_read_from_string(ctx, str, len); + res = sexp_eval(ctx, obj, env); + sexp_gc_release1(ctx); + return res; +} + +void sexp_scheme_init (void) { + if (! scheme_initialized_p) { + scheme_initialized_p = 1; + sexp_init(); + } +} diff --git a/gc.c b/gc.c new file mode 100644 index 00000000..af7b3986 --- /dev/null +++ b/gc.c @@ -0,0 +1,346 @@ +/* gc.c -- simple mark&sweep garbage collector */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/sexp.h" + +#if SEXP_USE_MMAP_GC +#include +#endif + +#define SEXP_MINIMUM_OBJECT_SIZE (sexp_heap_align(sexp_sizeof(pair))) + +#if SEXP_USE_GLOBAL_HEAP +sexp_heap sexp_global_heap; +#endif + +#if SEXP_USE_CONSERVATIVE_GC +static sexp* stack_base; +#endif + +static sexp_heap sexp_heap_last (sexp_heap h) { + while (h->next) h = h->next; + return h; +} + +sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) { + sexp_uint_t res; + sexp t; + if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx))) + return sexp_heap_align(1); + t = sexp_object_type(ctx, x); + res = sexp_type_size_of_object(t, x); + return res; +} + +#if SEXP_USE_SAFE_GC_MARK +static int sexp_in_heap(sexp ctx, sexp_uint_t x) { + sexp_heap h; + if (x & (sexp_heap_align(1)-1)) { + fprintf(stderr, "invalid heap alignment: %p %d\n", (sexp)x, sexp_pointer_tag((sexp)x)); + return 0; + } + for (h=sexp_context_heap(ctx); h; h=h->next) + if (((sexp_uint_t)h < x) && (x < (sexp_uint_t)(h->data + h->size))) + return 1; + fprintf(stderr, "invalid object outside heap: %p %d\n", (sexp)x, sexp_pointer_tag((sexp)x)); + return 0; +} +#endif + +#if SEXP_USE_DEBUG_GC +#include "opt/gc_debug.c" +#endif + +void sexp_mark (sexp ctx, sexp x) { + sexp_sint_t i, len; + sexp t, *p; + struct sexp_gc_var_t *saves; + loop: + if ((! x) || (! sexp_pointerp(x)) || sexp_gc_mark(x)) + return; +#if SEXP_USE_SAFE_GC_MARK + if (! sexp_in_heap(ctx, (sexp_uint_t)x)) + return; +#endif +#if SEXP_USE_HEADER_MAGIC + if (sexp_pointer_magic(x) != SEXP_POINTER_MAGIC && sexp_pointer_tag(x) != SEXP_TYPE + && sexp_pointer_tag(x) != SEXP_OPCODE && sexp_pointer_tag(x) != SEXP_CORE + && sexp_pointer_tag(x) != SEXP_STACK) + return; +#endif + sexp_gc_mark(x) = 1; + if (sexp_contextp(x)) + for (saves=sexp_context_saves(x); saves; saves=saves->next) + if (saves->var) sexp_mark(ctx, *(saves->var)); + t = sexp_object_type(ctx, x); + p = (sexp*) (((char*)x) + sexp_type_field_base(t)); + len = sexp_type_num_slots_of_object(t, x) - 1; + if (len >= 0) { + for (i=0; inext) { + p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair))); + q = h->free_list; + end = (sexp) ((char*)h->data + h->size - sexp_heap_align(sexp_sizeof(pair))); + while (p < end) { + /* find the preceding and succeeding free list pointers */ + for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next) + ; + if ((char*)r == (char*)p) { /* this is a free block, skip it */ + p = (sexp) (((char*)p) + r->size); + continue; + } + size = sexp_heap_align(sexp_allocated_bytes(ctx, p)); + if ((! sexp_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) { + /* free p */ + finalizer = sexp_type_finalize(sexp_object_type(ctx, p)); + if (finalizer) finalizer(ctx sexp_api_pass(NULL, 1), p); + sum_freed += size; + if (((((char*)q) + q->size) == (char*)p) && (q != h->free_list)) { + /* merge q with p */ + if (r && ((((char*)p)+size) == (char*)r)) { + /* ... and with r */ + q->next = r->next; + freed = q->size + size + r->size; + p = (sexp) (((char*)p) + size + r->size); + } else { + freed = q->size + size; + p = (sexp) (((char*)p)+size); + } + q->size = freed; + } else { + s = (sexp_free_list)p; + if (r && ((((char*)p)+size) == (char*)r)) { + /* merge p with r */ + s->size = size + r->size; + s->next = r->next; + q->next = s; + freed = size + r->size; + } else { + s->size = size; + s->next = r; + q->next = s; + freed = size; + } + p = (sexp) (((char*)p)+freed); + } + if (freed > max_freed) + max_freed = freed; + } else { + sexp_gc_mark(p) = 0; + p = (sexp) (((char*)p)+size); + } + } + } + if (sum_freed_ptr) *sum_freed_ptr = sum_freed; + return sexp_make_fixnum(max_freed); +} + +sexp sexp_gc (sexp ctx, size_t *sum_freed) { + sexp res; +#if SEXP_USE_GLOBAL_SYMBOLS + int i; + for (i=0; isize = size; + h->data = (char*) sexp_heap_align((sexp_uint_t)&(h->data)); + free = h->free_list = (sexp_free_list) h->data; + h->next = NULL; + next = (sexp_free_list) (((char*)free) + sexp_heap_align(sexp_sizeof(pair))); + free->size = 0; /* actually sexp_sizeof(pair) */ + free->next = next; + next->size = size - sexp_heap_align(sexp_sizeof(pair)); + next->next = NULL; + return h; +} + +int sexp_grow_heap (sexp ctx, size_t size) { + size_t cur_size, new_size; + sexp_heap h = sexp_heap_last(sexp_context_heap(ctx)); + cur_size = h->size; + new_size = sexp_heap_align(((cur_size > size) ? cur_size : size) * 2); + h->next = sexp_make_heap(new_size); + return (h->next != NULL); +} + +void* sexp_try_alloc (sexp ctx, size_t size) { + sexp_free_list ls1, ls2, ls3; + sexp_heap h; + for (h=sexp_context_heap(ctx); h; h=h->next) + for (ls1=h->free_list, ls2=ls1->next; ls2; ls1=ls2, ls2=ls2->next) + if (ls2->size >= size) { + if (ls2->size >= (size + SEXP_MINIMUM_OBJECT_SIZE)) { + ls3 = (sexp_free_list) (((char*)ls2)+size); /* the tail after ls2 */ + ls3->size = ls2->size - size; + ls3->next = ls2->next; + ls1->next = ls3; + } else { /* take the whole chunk */ + ls1->next = ls2->next; + } + memset((void*)ls2, 0, size); + return ls2; + } + return NULL; +} + +void* sexp_alloc (sexp ctx, size_t size) { + void *res; + size_t max_freed, sum_freed, total_size; + sexp_heap h; + size = sexp_heap_align(size); + res = sexp_try_alloc(ctx, size); + if (! res) { + max_freed = sexp_unbox_fixnum(sexp_gc(ctx, &sum_freed)); + for (total_size=0, h=sexp_context_heap(ctx); h->next; h=h->next) + total_size += h->size; + total_size += h->size; + if (((max_freed < size) + || ((total_size > sum_freed) + && (total_size - sum_freed) > (total_size*SEXP_GROW_HEAP_RATIO))) + && ((!SEXP_MAXIMUM_HEAP_SIZE) || (total_size < SEXP_MAXIMUM_HEAP_SIZE))) + sexp_grow_heap(ctx, size); + res = sexp_try_alloc(ctx, size); + if (! res) + res = sexp_global(ctx, SEXP_G_OOM_ERROR); + } + return res; +} + +#if ! SEXP_USE_GLOBAL_HEAP + +sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) { + sexp_sint_t i, off, len, freep; + sexp_heap to, from = sexp_context_heap(ctx); + sexp_free_list q; + sexp p, p2, t, end, *v; + freep = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_FREEP); + + /* validate input, creating a new heap if needed */ + if (from->next) { + return sexp_user_exception(ctx, NULL, "can't copy a non-contiguous heap", ctx); + } else if (! dst || sexp_not(dst)) { + to = sexp_make_heap(from->size); + dst = (sexp) ((char*)ctx + ((char*)to - (char*)from)); + } else if (! sexp_contextp(dst)) { + return sexp_type_exception(ctx, NULL, SEXP_CONTEXT, dst); + } else if (sexp_context_heap(dst)->size < from->size) { + return sexp_user_exception(ctx, NULL, "destination context too small", dst); + } else { + to = sexp_context_heap(dst); + } + + /* copy the raw data */ + off = (char*)to - (char*)from; + memcpy(to, from, sexp_heap_pad_size(from->size)); + to->free_list = (sexp_free_list) ((char*)to->free_list + off); + to->data += off; + end = (sexp) (from->data + from->size); + + /* adjust the free list */ + for (q=to->free_list; q->next; q=q->next) + q->next = (sexp_free_list) ((char*)q->next + off); + + /* adjust if the destination is larger */ + if (from->size < to->size) { + if (((char*)q + q->size - off) >= (char*)end) { + q->size += (to->size - from->size); + } else { + q->next = (sexp_free_list) ((char*)end + off); + q->next->next = NULL; + q->next->size = (to->size - from->size); + } + } + + /* adjust data by traversing over the _original_ heap */ + p = (sexp) (from->data + sexp_heap_align(sexp_sizeof(pair))); + q = from->free_list; + while (p < end) { + /* find the next free list pointer */ + for ( ; q && ((char*)q < (char*)p); q=q->next) + ; + if ((char*)q == (char*)p) { /* this is a free block, skip it */ + p = (sexp) (((char*)p) + q->size); + } else { + t = sexp_object_type(ctx, p); + len = sexp_type_num_slots_of_object(t, p); + p2 = (sexp)((char*)p + off); + v = (sexp*) ((char*)p2 + sexp_type_field_base(t)); + /* offset any pointers in the _destination_ heap */ + for (i=0; i 6 args */ +/* #define SEXP_USE_EXTENDED_FCALL 0 */ + +/* uncomment this if you don't need flonum support */ +/* This is only for EVAL - you'll still be able to read */ +/* and write flonums directly through the sexp API. */ +/* #define SEXP_USE_FLONUMS 0 */ + +/* uncomment this to disable reading/writing IEEE infinities */ +/* By default you can read/write +inf.0, -inf.0 and +nan.0 */ +/* #define SEXP_USE_INFINITIES 0 */ + +/* uncomment this if you want immediate flonums */ +/* This is experimental, enable at your own risk. */ +/* #define SEXP_USE_IMMEDIATE_FLONUMS 1 */ + +/* uncomment this if you don't want bignum support */ +/* Bignums are implemented with a small, custom library */ +/* in opt/bignum.c. */ +/* #define SEXP_USE_BIGNUMS 0 */ + +/* uncomment this if you don't need extended math operations */ +/* This includes the trigonometric and expt functions. */ +/* Automatically disabled if you've disabled flonums. */ +/* #define SEXP_USE_MATH 0 */ + +/* uncomment this to disable the self and n parameters to primitives */ +/* This is the old style API. */ +/* #define SEXP_USE_SELF_PARAMETER 0 */ + +/* uncomment this to disable warning about references to undefined variables */ +/* This is something of a hack, but can be quite useful. */ +/* It's very fast and doesn't involve any separate analysis */ +/* passes. */ +/* #define SEXP_USE_WARN_UNDEFS 0 */ + +/* uncomment this to disable huffman-coded immediate symbols */ +/* By default (this may change) small symbols are represented */ +/* as immediates using a simple huffman encoding. This keeps */ +/* the symbol table small, and minimizes hashing when doing a */ +/* lot of reading. */ +/* #define SEXP_USE_HUFF_SYMS 0 */ + +/* uncomment this to just use a single list for hash tables */ +/* You can trade off some space in exchange for longer read */ +/* times by disabling hashing and just putting all */ +/* non-immediate symbols in a single list. */ +/* #define SEXP_USE_HASH_SYMS 0 */ + +/* uncomment this to disable UTF-8 string support */ +/* The default settings store strings in memory as UTF-8, */ +/* and assumes strings passed to/from the C FFI are UTF-8. */ +/* #define SEXP_USE_UTF8_STRINGS 0 */ + +/* uncomment this to disable the string-set! opcode */ +/* By default (non-literal) strings are mutable. */ +/* Making them immutable allows for packed UTF-8 strings. */ +/* #define SEXP_USE_MUTABLE_STRINGS 0 */ + +/* uncomment this to disable string ports */ +/* If disabled some basic functionality such as number->string */ +/* will not be available by default. */ +/* #define SEXP_USE_STRING_STREAMS 0 */ + +/* uncomment this to disable automatic closing of ports */ +/* If enabled, the underlying FILE* for file ports will be */ +/* automatically closed when they're garbage collected. Doesn't */ +/* apply to stdin/stdout/stderr. */ +/* #define SEXP_USE_AUTOCLOSE_PORTS 0 */ + +/* uncomment this to use the normal 1970 unix epoch */ +/* By default chibi uses an datetime epoch starting at */ +/* 2010/01/01 00:00:00 in order to be able to represent */ +/* more common times as fixnums. */ +/* #define SEXP_USE_2010_EPOCH 0 */ + +/* uncomment this to disable stack overflow checks */ +/* By default stacks are fairly small, so it's good to leave */ +/* this enabled. */ +/* #define SEXP_USE_CHECK_STACK 0 */ + +/* #define SEXP_USE_DEBUG_VM 0 */ +/* Experts only. */ +/* For *very* verbose output on every VM operation. */ + +/* uncomment this to make the VM adhere to alignment rules */ +/* This is required on some platforms, e.g. ARM */ +/* #define SEXP_USE_ALIGNED_BYTECODE */ + +/************************************************************************/ +/* These settings are configurable but only recommended for */ +/* experienced users, and only apply when using the native GC. */ +/************************************************************************/ + +/* the initial heap size in bytes */ +#ifndef SEXP_INITIAL_HEAP_SIZE +#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) +#endif + +/* the maximum heap size in bytes - if 0 there is no limit */ +#ifndef SEXP_MAXIMUM_HEAP_SIZE +#define SEXP_MAXIMUM_HEAP_SIZE 0 +#endif +#ifndef SEXP_MINIMUM_HEAP_SIZE +#define SEXP_MINIMUM_HEAP_SIZE 8*1024 +#endif + +/* if after GC more than this percentage of memory is still in use, */ +/* and we've not exceeded the maximum size, grow the heap */ +#ifndef SEXP_GROW_HEAP_RATIO +#define SEXP_GROW_HEAP_RATIO 0.75 +#endif + +/* the default number of opcodes to run each thread for */ +#ifndef SEXP_DEFAULT_QUANTUM +#define SEXP_DEFAULT_QUANTUM 500 +#endif + +/************************************************************************/ +/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ +/************************************************************************/ + +#ifndef SEXP_64_BIT +#if defined(__amd64) || defined(__x86_64) || defined(_WIN64) || defined(_Wp64) +#define SEXP_64_BIT 1 +#else +#define SEXP_64_BIT 0 +#endif +#endif + +#if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__) +#define SEXP_BSD 1 +#else +#define SEXP_BSD 0 +#if ! defined(_GNU_SOURCE) && ! defined(_WIN32) && ! defined(PLAN9) +#define _GNU_SOURCE +#endif +#endif + +#ifndef SEXP_USE_NO_FEATURES +#define SEXP_USE_NO_FEATURES 0 +#endif + +#ifndef SEXP_USE_GREEN_THREADS +#define SEXP_USE_GREEN_THREADS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_NATIVE_X86 +#define SEXP_USE_NATIVE_X86 0 +#endif + +#ifndef SEXP_USE_MODULES +#define SEXP_USE_MODULES ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_TYPE_DEFS +#define SEXP_USE_TYPE_DEFS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_MAXIMUM_TYPES +#define SEXP_MAXIMUM_TYPES ((sexp_tag_t)-1) +#endif + +#ifndef SEXP_USE_DL +#if defined(PLAN9) || defined(_WIN32) +#define SEXP_USE_DL 0 +#else +#define SEXP_USE_DL ! SEXP_USE_NO_FEATURES +#endif +#endif + +#ifndef SEXP_USE_STATIC_LIBS +#define SEXP_USE_STATIC_LIBS 0 +#endif + +#ifndef SEXP_USE_SIMPLIFY +#define SEXP_USE_SIMPLIFY ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_BOEHM +#define SEXP_USE_BOEHM 0 +#endif + +#ifndef SEXP_USE_MALLOC +#define SEXP_USE_MALLOC 0 +#endif + +#ifndef SEXP_USE_MMAP_GC +#define SEXP_USE_MMAP_GC 0 +#endif + +#ifndef SEXP_USE_DEBUG_GC +#define SEXP_USE_DEBUG_GC 0 +#endif + +#ifndef SEXP_USE_SAFE_GC_MARK +#define SEXP_USE_SAFE_GC_MARK 0 +#endif + +#ifndef SEXP_USE_CONSERVATIVE_GC +#define SEXP_USE_CONSERVATIVE_GC 0 +#endif + +#ifndef SEXP_USE_HEADER_MAGIC +#define SEXP_USE_HEADER_MAGIC 0 +#endif + +#ifndef SEXP_USE_GLOBAL_HEAP +#if SEXP_USE_BOEHM || SEXP_USE_MALLOC +#define SEXP_USE_GLOBAL_HEAP 1 +#else +#define SEXP_USE_GLOBAL_HEAP 0 +#endif +#endif + +#ifndef SEXP_USE_GLOBAL_TYPES +#define SEXP_USE_GLOBAL_TYPES (! SEXP_USE_TYPE_DEFS) +#endif + +#ifndef SEXP_USE_GLOBAL_SYMBOLS +#if SEXP_USE_BOEHM || SEXP_USE_MALLOC +#define SEXP_USE_GLOBAL_SYMBOLS 1 +#else +#define SEXP_USE_GLOBAL_SYMBOLS 0 +#endif +#endif + +#ifndef SEXP_USE_EXTENDED_FCALL +#define SEXP_USE_EXTENDED_FCALL ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_FLONUMS +#define SEXP_USE_FLONUMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_INFINITIES +#if defined(PLAN9) || ! SEXP_USE_FLONUMS +#define SEXP_USE_INFINITIES 0 +#else +#define SEXP_USE_INFINITIES ! SEXP_USE_NO_FEATURES +#endif +#endif + +#ifndef SEXP_USE_IMMEDIATE_FLONUMS +#define SEXP_USE_IMMEDIATE_FLONUMS 0 +#endif + +#ifndef SEXP_USE_BIGNUMS +#define SEXP_USE_BIGNUMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_MATH +#define SEXP_USE_MATH SEXP_USE_FLONUMS && ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_SELF_PARAMETER +#define SEXP_USE_SELF_PARAMETER 1 +#endif + +#ifndef SEXP_USE_WARN_UNDEFS +#define SEXP_USE_WARN_UNDEFS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_HUFF_SYMS +#define SEXP_USE_HUFF_SYMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_HASH_SYMS +#define SEXP_USE_HASH_SYMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_DEBUG_VM +#define SEXP_USE_DEBUG_VM 0 +#endif + +#ifndef SEXP_USE_UTF8_STRINGS +#define SEXP_USE_UTF8_STRINGS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_MUTABLE_STRINGS +#define SEXP_USE_MUTABLE_STRINGS 1 +#endif + +#if (SEXP_USE_UTF8_STRINGS && SEXP_USE_MUTABLE_STRINGS) +#define SEXP_USE_PACKED_STRINGS 0 +#endif +#ifndef SEXP_USE_PACKED_STRINGS +#define SEXP_USE_PACKED_STRINGS 1 +#endif + +#ifndef SEXP_USE_STRING_STREAMS +#ifdef _WIN32 +#define SEXP_USE_STRING_STREAMS 0 +#else +#define SEXP_USE_STRING_STREAMS ! SEXP_USE_NO_FEATURES +#endif +#endif + +#ifndef SEXP_USE_AUTOCLOSE_PORTS +#define SEXP_USE_AUTOCLOSE_PORTS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_2010_EPOCH +#define SEXP_USE_2010_EPOCH ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_EPOCH_OFFSET +#if SEXP_USE_2010_EPOCH +#define SEXP_EPOCH_OFFSET 1262271600 +#else +#define SEXP_EPOCH_OFFSET 0 +#endif +#endif + +#ifndef SEXP_USE_CHECK_STACK +#define SEXP_USE_CHECK_STACK ! SEXP_USE_NO_FEATURES +#endif + +#if SEXP_USE_NATIVE_X86 +#undef SEXP_USE_BOEHM +#define SEXP_USE_BOEHM 1 +#undef SEXP_USE_FLONUMS +#define SEXP_USE_FLONUMS 0 +#undef SEXP_USE_BIGNUMS +#define SEXP_USE_BIGNUMS 0 +#undef SEXP_USE_SIMPLIFY +#define SEXP_USE_SIMPLIFY 0 +#endif + +#ifndef SEXP_USE_ALIGNED_BYTECODE +#if defined(__arm__) +#define SEXP_USE_ALIGNED_BYTECODE 1 +#else +#define SEXP_USE_ALIGNED_BYTECODE 0 +#endif +#endif + +#ifdef PLAN9 +#define strcasecmp cistrcmp +#define strncasecmp cistrncmp +#define round(x) floor((x)+0.5) +#define trunc(x) floor((x)+0.5*(((x)<0)?1:0)) +#elif defined(_WIN32) +#define snprintf(buf, len, fmt, val) sprintf(buf, fmt, val) +#define strcasecmp lstrcmpi +#define strncasecmp(s1, s2, n) lstrcmpi(s1, s2) +#define round(x) floor((x)+0.5) +#define trunc(x) floor((x)+0.5*(((x)<0)?1:0)) +#define isnan(x) (x!=x) +#define isinf(x) (x > DBL_MAX || x < -DBL_MAX) +#endif + +#ifdef _WIN32 +#define sexp_pos_infinity (DBL_MAX*DBL_MAX) +#define sexp_neg_infinity -sexp_pos_infinity +#define sexp_nan log(-2) +#else +#define sexp_pos_infinity (1.0/0.0) +#define sexp_neg_infinity -sexp_pos_infinity +#define sexp_nan (0.0/0.0) +#endif + +#ifdef __MINGW32__ +#ifdef BUILDING_DLL +#define SEXP_API __declspec(dllexport) +#else +#define SEXP_API __declspec(dllimport) +#endif +#else +#define SEXP_API +#endif diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h new file mode 100644 index 00000000..7484d9c6 --- /dev/null +++ b/include/chibi/sexp.h @@ -0,0 +1,1065 @@ +/* sexp.h -- header for sexp library */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifndef SEXP_H +#define SEXP_H + +#ifdef __cplusplus +extern "C" { +#endif + +#define SEXP_MODULE_PATH_VAR "CHIBI_MODULE_PATH" + +#include "chibi/features.h" +#include "chibi/install.h" + +#if defined(_WIN32) || defined(__MINGW32__) +#include +#else +#if SEXP_USE_DL +#include +#endif +#if SEXP_USE_GREEN_THREADS +#include +#endif +#endif + +#ifdef PLAN9 +#include +#include +#include +#include +#include <9p.h> +typedef unsigned long size_t; +#else +#include +#include +#include +#include +#include +#include +#include +#if SEXP_USE_FLONUMS +#include +#include +#endif +#endif + +#include +#include + +/* tagging system + * bits end in 00: pointer + * 01: fixnum + * 011: immediate flonum (optional) + * 111: immediate symbol (optional) + * 000110: char + * 001110: unique immediate (NULL, TRUE, FALSE) + */ + +#define SEXP_FIXNUM_BITS 2 +#define SEXP_IMMEDIATE_BITS 3 +#define SEXP_EXTENDED_BITS 6 + +#define SEXP_FIXNUM_MASK 3 +#define SEXP_IMMEDIATE_MASK 7 +#define SEXP_EXTENDED_MASK 63 + +#define SEXP_POINTER_TAG 0 +#define SEXP_FIXNUM_TAG 1 +#define SEXP_ISYMBOL_TAG 7 +#define SEXP_IFLONUM_TAG 3 +#define SEXP_CHAR_TAG 6 +#define SEXP_EXTENDED_TAG 14 + +#ifndef SEXP_POINTER_MAGIC +#define SEXP_POINTER_MAGIC 0xFDCA9764uL /* arbitrary */ +#endif + +#if SEXP_USE_HASH_SYMS +#define SEXP_SYMBOL_TABLE_SIZE 389 +#else +#define SEXP_SYMBOL_TABLE_SIZE 1 +#endif + +enum sexp_types { + SEXP_OBJECT, + SEXP_TYPE, + SEXP_FIXNUM, + SEXP_NUMBER, + SEXP_CHAR, + SEXP_BOOLEAN, + SEXP_PAIR, + SEXP_SYMBOL, + SEXP_BYTES, + SEXP_STRING, + SEXP_VECTOR, + SEXP_FLONUM, + SEXP_BIGNUM, + SEXP_CPOINTER, + SEXP_IPORT, + SEXP_OPORT, + SEXP_EXCEPTION, + SEXP_PROCEDURE, + SEXP_MACRO, + SEXP_SYNCLO, + SEXP_ENV, + SEXP_BYTECODE, + SEXP_CORE, + SEXP_OPCODE, + SEXP_LAMBDA, + SEXP_CND, + SEXP_REF, + SEXP_SET, + SEXP_SEQ, + SEXP_LIT, + SEXP_STACK, + SEXP_CONTEXT, + SEXP_NUM_CORE_TYPES +}; + +#ifdef _WIN32 +typedef unsigned short sexp_tag_t; +typedef SIZE_T sexp_uint_t; +typedef SSIZE_T sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 5) +#elif SEXP_64_BIT +typedef unsigned int sexp_tag_t; +typedef unsigned long sexp_uint_t; +typedef long sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 5) +#elif defined(__CYGWIN__) +typedef unsigned short sexp_tag_t; +typedef unsigned int sexp_uint_t; +typedef int sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 5) +#else +typedef unsigned short sexp_tag_t; +typedef unsigned int sexp_uint_t; +typedef int sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 4) +#endif + +typedef struct sexp_struct *sexp; + +#define sexp_heap_pad_size(s) (sizeof(struct sexp_heap_t) + (s) + sexp_heap_align(1)) + +#define __HALF_MAX_SIGNED(type) ((type)1 << (sizeof(type)*8-2)) +#define __MAX_SIGNED(type) (__HALF_MAX_SIGNED(type) - 1 + __HALF_MAX_SIGNED(type)) +#define __MIN_SIGNED(type) (-1 - __MAX_SIGNED(type)) + +#define SEXP_UINT_T_MAX ((sexp_uint_t)-1) +#define SEXP_UINT_T_MIN (0) +#define SEXP_SINT_T_MAX __MAX_SIGNED(sexp_sint_t) +#define SEXP_SINT_T_MIN __MIN_SIGNED(sexp_sint_t) + +#define SEXP_MAX_FIXNUM ((((sexp_sint_t)1)<<(sizeof(sexp_sint_t)*8-SEXP_FIXNUM_BITS-1))-1) +#define SEXP_MIN_FIXNUM (-SEXP_MAX_FIXNUM-1) + +#if SEXP_USE_SELF_PARAMETER +#define sexp_api_params(self, n) , sexp self, long n +#define sexp_api_pass(self, n) , self, n +#else +#define sexp_api_params(self, n) +#define sexp_api_pass(self, n) +#endif + +/* procedure types */ +typedef sexp (*sexp_proc1) (sexp sexp_api_params(self, n)); +typedef sexp (*sexp_proc2) (sexp sexp_api_params(self, n), sexp); +typedef sexp (*sexp_proc3) (sexp sexp_api_params(self, n), sexp, sexp); +typedef sexp (*sexp_proc4) (sexp sexp_api_params(self, n), sexp, sexp, sexp); +typedef sexp (*sexp_proc5) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc6) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc7) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp); + +typedef struct sexp_free_list_t *sexp_free_list; +struct sexp_free_list_t { + sexp_uint_t size; + sexp_free_list next; +}; + +typedef struct sexp_heap_t *sexp_heap; +struct sexp_heap_t { + sexp_uint_t size; + sexp_free_list free_list; + sexp_heap next; + /* note this must be aligned on a proper heap boundary, */ + /* so we can't just use char data[] */ + char *data; +}; + +struct sexp_gc_var_t { + sexp *var; +#if SEXP_USE_DEBUG_GC + char *name; +#endif + struct sexp_gc_var_t *next; +}; + +struct sexp_type_struct { + sexp_tag_t tag; + short field_base, field_eq_len_base, field_len_base, field_len_off; + unsigned short field_len_scale; + short size_base, size_off; + unsigned short size_scale; + char *name; + sexp_proc2 finalize; +}; + +struct sexp_opcode_struct { + unsigned char op_class, code, num_args, flags, inverse; + const char *name; + sexp data, data2, proc, ret_type, arg1_type, arg2_type, arg3_type; + sexp_proc1 func; +}; + +struct sexp_core_form_struct { + char code; + const char *name; +}; + +struct sexp_struct { + sexp_tag_t tag; + char gc_mark; + unsigned int immutablep:1; + unsigned int freep:1; + unsigned int syntacticp:1; +#if SEXP_USE_HEADER_MAGIC + unsigned int magic; +#endif + union { + /* basic types */ + double flonum; + struct sexp_type_struct type; + struct { + sexp car, cdr; + sexp source; + } pair; + struct { + sexp_uint_t length; + sexp data[]; + } vector; + struct { + sexp_uint_t length; + char data[]; + } bytes; + struct { +#if SEXP_USE_PACKED_STRINGS + sexp_uint_t length; + char data[]; +#else + sexp_uint_t offset, length; + sexp bytes; +#endif + } string; + struct { + sexp_uint_t length; + char data[]; + } symbol; + struct { + FILE *stream; + char *buf; + char openp, no_closep, sourcep; + sexp_uint_t offset, line; + size_t size; + sexp name; + sexp cookie; + } port; + struct { + sexp kind, message, irritants, procedure, source; + } exception; + struct { + signed char sign; + sexp_uint_t length; + sexp_uint_t data[]; + } bignum; + struct { + sexp_uint_t length; + void *value; + sexp parent; + char body[]; + } cpointer; + /* runtime types */ + struct { + sexp parent, lambda, bindings; + } env; + struct { + sexp_uint_t length; + sexp name, literals, source; + unsigned char data[]; + } bytecode; + struct { + char flags; + unsigned short num_args; + sexp bc, vars; + } procedure; + struct { + sexp proc, env; + } macro; + struct { + sexp env, free_vars, expr; + } synclo; + struct sexp_opcode_struct opcode; + struct sexp_core_form_struct core; + /* ast types */ + struct { + sexp name, params, body, defs, locals, flags, fv, sv, ret, types, source; + } lambda; + struct { + sexp test, pass, fail, source; + } cnd; + struct { + sexp var, value, source; + } set; + struct { + sexp name, cell, source; + } ref; + struct { + sexp ls, source; + } seq; + struct { + sexp value, source; + } lit; + /* compiler state */ + struct { + sexp_uint_t length, top; + sexp data[]; + } stack; + struct { + sexp_heap heap; + struct sexp_gc_var_t *saves; +#if SEXP_USE_GREEN_THREADS + sexp_sint_t refuel; + unsigned char* ip; + struct timeval tval; +#endif + char tailp, tracep, timeoutp, waitp; + sexp_uint_t pos, depth, last_fp; + sexp bc, lambda, stack, env, fv, parent, child, globals, + proc, name, specific, event; + } context; + } value; +}; + +#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<value.x)) + +#define sexp_offsetof(type, f) (offsetof(struct sexp_struct, value.type.f)) + +#define sexp_offsetof_slot0 (offsetof(struct sexp_struct, value)) + +#define sexp_sizeof_header (sexp_sizeof(flonum) - sizeof(double)) + +#define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag) +#define sexp_alloc_bytecode(ctx, i) sexp_alloc_tagged(ctx, sexp_sizeof(bytecode) + i, SEXP_BYTECODE) + +#if SEXP_USE_BIGNUMS +#include "chibi/bignum.h" +#endif + +/***************************** predicates *****************************/ + +#define sexp_truep(x) ((x) != SEXP_FALSE) +#define sexp_not(x) ((x) == SEXP_FALSE) + +#define sexp_nullp(x) ((x) == SEXP_NULL) +#define sexp_pointerp(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG) +#define sexp_fixnump(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_FIXNUM_TAG) +#define sexp_isymbolp(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_ISYMBOL_TAG) +#define sexp_charp(x) (((sexp_uint_t)(x) & SEXP_EXTENDED_MASK) == SEXP_CHAR_TAG) +#define sexp_booleanp(x) (((x) == SEXP_TRUE) || ((x) == SEXP_FALSE)) + +#define sexp_pointer_tag(x) ((x)->tag) +#define sexp_gc_mark(x) ((x)->gc_mark) +#define sexp_flags(x) ((x)->flags) +#define sexp_immutablep(x) ((x)->immutablep) +#define sexp_freep(x) ((x)->freep) +#define sexp_pointer_magic(x) ((x)->magic) + +#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) + +#define sexp_slot_ref(x,i) (((sexp*)&((x)->value))[i]) +#define sexp_slot_set(x,i,v) (((sexp*)&((x)->value))[i] = (v)) + +#define sexp_isa(a, b) (sexp_pointerp(a) && sexp_typep(b) && (sexp_pointer_tag(a) == sexp_type_tag(b))) + +#if SEXP_USE_IMMEDIATE_FLONUMS +union sexp_flonum_conv { + float flonum; + unsigned int bits; +}; +#define sexp_flonump(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_IFLONUM_TAG) +SEXP_API sexp sexp_flonum_predicate (sexp ctx, sexp x); +#if SEXP_64_BIT +SEXP_API float sexp_flonum_value (sexp x); +SEXP_API sexp sexp_make_flonum(sexp ctx, float f); +#else +#define sexp_make_flonum(ctx, x) ((sexp) ((((union sexp_flonum_conv)((float)(x))).bits & ~SEXP_IMMEDIATE_MASK) + SEXP_IFLONUM_TAG)) +#define sexp_flonum_value(x) (((union sexp_flonum_conv)(((unsigned int)(x)) & ~SEXP_IMMEDIATE_MASK)).flonum) +#endif +#else +#define sexp_flonump(x) (sexp_check_tag(x, SEXP_FLONUM)) +#define sexp_flonum_value(f) ((f)->value.flonum) +sexp sexp_make_flonum(sexp ctx, double f); +#endif + +#define sexp_typep(x) (sexp_check_tag(x, SEXP_TYPE)) +#define sexp_pairp(x) (sexp_check_tag(x, SEXP_PAIR)) +#define sexp_stringp(x) (sexp_check_tag(x, SEXP_STRING)) +#define sexp_lsymbolp(x) (sexp_check_tag(x, SEXP_SYMBOL)) +#define sexp_vectorp(x) (sexp_check_tag(x, SEXP_VECTOR)) +#define sexp_iportp(x) (sexp_check_tag(x, SEXP_IPORT)) +#define sexp_oportp(x) (sexp_check_tag(x, SEXP_OPORT)) +#define sexp_bignump(x) (sexp_check_tag(x, SEXP_BIGNUM)) +#define sexp_cpointerp(x) (sexp_check_tag(x, SEXP_CPOINTER)) +#define sexp_exceptionp(x) (sexp_check_tag(x, SEXP_EXCEPTION)) +#define sexp_procedurep(x) (sexp_check_tag(x, SEXP_PROCEDURE)) +#define sexp_envp(x) (sexp_check_tag(x, SEXP_ENV)) +#define sexp_bytecodep(x) (sexp_check_tag(x, SEXP_BYTECODE)) +#define sexp_corep(x) (sexp_check_tag(x, SEXP_CORE)) +#define sexp_opcodep(x) (sexp_check_tag(x, SEXP_OPCODE)) +#define sexp_macrop(x) (sexp_check_tag(x, SEXP_MACRO)) +#define sexp_synclop(x) (sexp_check_tag(x, SEXP_SYNCLO)) +#define sexp_lambdap(x) (sexp_check_tag(x, SEXP_LAMBDA)) +#define sexp_cndp(x) (sexp_check_tag(x, SEXP_CND)) +#define sexp_refp(x) (sexp_check_tag(x, SEXP_REF)) +#define sexp_setp(x) (sexp_check_tag(x, SEXP_SET)) +#define sexp_seqp(x) (sexp_check_tag(x, SEXP_SEQ)) +#define sexp_litp(x) (sexp_check_tag(x, SEXP_LIT)) +#define sexp_contextp(x) (sexp_check_tag(x, SEXP_CONTEXT)) + +#define sexp_applicablep(x) (sexp_procedurep(x) || sexp_opcodep(x)) + +#if SEXP_USE_HUFF_SYMS +#define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) +#else +#define sexp_symbolp(x) (sexp_lsymbolp(x)) +#endif + +#define sexp_idp(x) \ + (sexp_symbolp(x) || (sexp_synclop(x) && sexp_symbolp(sexp_synclo_expr(x)))) + +#define sexp_portp(x) (sexp_iportp(x) || sexp_oportp(x)) + +/***************************** constructors ****************************/ + +#define sexp_make_boolean(x) ((x) ? SEXP_TRUE : SEXP_FALSE) +#define sexp_unbox_boolean(x) (((x) == SEXP_FALSE) ? 0 : 1) + +#define sexp_make_fixnum(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_FIXNUM_BITS) + +#define SEXP_NEG_ONE sexp_make_fixnum(-1) +#define SEXP_ZERO sexp_make_fixnum(0) +#define SEXP_ONE sexp_make_fixnum(1) +#define SEXP_TWO sexp_make_fixnum(2) +#define SEXP_THREE sexp_make_fixnum(3) +#define SEXP_FOUR sexp_make_fixnum(4) +#define SEXP_FIVE sexp_make_fixnum(5) +#define SEXP_SIX sexp_make_fixnum(6) +#define SEXP_SEVEN sexp_make_fixnum(7) +#define SEXP_EIGHT sexp_make_fixnum(8) +#define SEXP_NINE sexp_make_fixnum(9) +#define SEXP_TEN sexp_make_fixnum(10) + +#define sexp_make_character(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_EXTENDED_BITS)) + +#define sexp_fixnum_to_double(x) ((double)sexp_unbox_fixnum(x)) + +#if SEXP_USE_FLONUMS +#define sexp_fp_integerp(x) (sexp_flonum_value(x) == trunc(sexp_flonum_value(x))) +#define _or_integer_flonump(x) || (sexp_flonump(x) && sexp_fp_integerp(x)) +#else +#define _or_integer_flonump(x) +#endif + +#if SEXP_USE_BIGNUMS +SEXP_API sexp sexp_make_integer(sexp ctx, sexp_lsint_t x); +SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); +#define sexp_exact_integerp(x) (sexp_fixnump(x) || sexp_bignump(x)) +#else +#define sexp_make_integer(ctx, x) sexp_make_fixnum(x) +#define sexp_make_unsigned_integer(ctx, x) sexp_make_fixnum(x) +#define sexp_exact_integerp(x) sexp_fixnump(x) +#endif + +#define sexp_integerp(x) (sexp_exact_integerp(x) _or_integer_flonump(x)) + +#if SEXP_USE_FLONUMS +#define sexp_fixnum_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_fixnum(x))) +#define sexp_numberp(x) (sexp_exact_integerp(x) || sexp_flonump(x)) +#else +#define sexp_fixnum_to_flonum(ctx, x) (x) +#define sexp_numberp(x) sexp_exact_integerp(x) +#endif + +#if SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS +#define sexp_uint_value(x) ((sexp_uint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_data(x)[0])) +#define sexp_sint_value(x) ((sexp_sint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_sign(x)*sexp_bignum_data(x)[0])) +#else +#define sexp_uint_value(x) ((sexp_uint_t)sexp_unbox_fixnum(x)) +#define sexp_sint_value(x) ((sexp_sint_t)sexp_unbox_fixnum(x)) +#endif + +#define sexp_shift_epoch(x) ((x)-SEXP_EPOCH_OFFSET) +#define sexp_unshift_epoch(x) ((x)+SEXP_EPOCH_OFFSET) + +/*************************** field accessors **************************/ + +#define sexp_vector_length(x) ((x)->value.vector.length) +#define sexp_vector_data(x) ((x)->value.vector.data) + +#define sexp_vector_ref(x,i) (sexp_vector_data(x)[sexp_unbox_fixnum(i)]) +#define sexp_vector_set(x,i,v) (sexp_vector_data(x)[sexp_unbox_fixnum(i)]=(v)) + +#define sexp_procedure_num_args(x) ((x)->value.procedure.num_args) +#define sexp_procedure_flags(x) ((x)->value.procedure.flags) +#define sexp_procedure_variadic_p(x) (sexp_unbox_fixnum(sexp_procedure_flags(x)) & 1) +#define sexp_procedure_code(x) ((x)->value.procedure.bc) +#define sexp_procedure_vars(x) ((x)->value.procedure.vars) + +#define sexp_bytes_length(x) ((x)->value.bytes.length) +#define sexp_bytes_data(x) ((x)->value.bytes.data) + +#define sexp_string_length(x) ((x)->value.string.length) +#if SEXP_USE_PACKED_STRINGS +#define sexp_string_data(x) ((x)->value.string.data) +#else +#define sexp_string_bytes(x) ((x)->value.string.bytes) +#define sexp_string_offset(x) ((x)->value.string.offset) +#define sexp_string_data(x) (sexp_bytes_data(sexp_string_bytes(x))+sexp_string_offset(x)) +#endif + +#define sexp_bytes_ref(x, i) (sexp_make_fixnum((unsigned char)sexp_bytes_data(x)[sexp_unbox_fixnum(i)])) +#define sexp_bytes_set(x, i, v) (sexp_bytes_data(x)[sexp_unbox_fixnum(i)] = sexp_unbox_fixnum(v)) + +#define sexp_string_ref(x, i) (sexp_make_character((unsigned char)sexp_string_data(x)[sexp_unbox_fixnum(i)])) +#define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_fixnum(i)] = sexp_unbox_character(v)) + +#define sexp_symbol_data(x) ((x)->value.symbol.data) +#define sexp_symbol_length(x) ((x)->value.symbol.length) +#define sexp_symbol_string(x) (x) + +#define sexp_port_stream(p) ((p)->value.port.stream) +#define sexp_port_name(p) ((p)->value.port.name) +#define sexp_port_line(p) ((p)->value.port.line) +#define sexp_port_openp(p) ((p)->value.port.openp) +#define sexp_port_no_closep(p) ((p)->value.port.no_closep) +#define sexp_port_sourcep(p) ((p)->value.port.sourcep) +#define sexp_port_cookie(p) ((p)->value.port.cookie) +#define sexp_port_buf(p) ((p)->value.port.buf) +#define sexp_port_size(p) ((p)->value.port.size) +#define sexp_port_offset(p) ((p)->value.port.offset) + +#define sexp_exception_kind(p) ((p)->value.exception.kind) +#define sexp_exception_message(p) ((p)->value.exception.message) +#define sexp_exception_irritants(p) ((p)->value.exception.irritants) +#define sexp_exception_procedure(p) ((p)->value.exception.procedure) +#define sexp_exception_source(p) ((p)->value.exception.source) + +#define sexp_cpointer_freep(p) (sexp_freep(p)) +#define sexp_cpointer_length(p) ((p)->value.cpointer.length) +#define sexp_cpointer_body(p) ((p)->value.cpointer.body) +#define sexp_cpointer_parent(p) ((p)->value.cpointer.parent) +#define sexp_cpointer_value(p) ((p)->value.cpointer.value) +#define sexp_cpointer_maybe_null_value(p) (sexp_not(p) ? NULL : sexp_cpointer_value(p)) + +#define sexp_bytecode_length(x) ((x)->value.bytecode.length) +#define sexp_bytecode_name(x) ((x)->value.bytecode.name) +#define sexp_bytecode_literals(x) ((x)->value.bytecode.literals) +#define sexp_bytecode_source(x) ((x)->value.bytecode.source) +#define sexp_bytecode_data(x) ((x)->value.bytecode.data) + +#define sexp_env_syntactic_p(x) ((x)->syntacticp) +#define sexp_env_parent(x) ((x)->value.env.parent) +#define sexp_env_bindings(x) ((x)->value.env.bindings) +#define sexp_env_local_p(x) (sexp_env_parent(x)) +#define sexp_env_global_p(x) (! sexp_env_local_p(x)) +#define sexp_env_lambda(x) ((x)->value.env.lambda) + +#define sexp_macro_proc(x) ((x)->value.macro.proc) +#define sexp_macro_env(x) ((x)->value.macro.env) + +#define sexp_synclo_env(x) ((x)->value.synclo.env) +#define sexp_synclo_free_vars(x) ((x)->value.synclo.free_vars) +#define sexp_synclo_expr(x) ((x)->value.synclo.expr) + +#define sexp_core_code(x) ((x)->value.core.code) +#define sexp_core_name(x) ((x)->value.core.name) + +#define sexp_opcode_class(x) ((x)->value.opcode.op_class) +#define sexp_opcode_code(x) ((x)->value.opcode.code) +#define sexp_opcode_num_args(x) ((x)->value.opcode.num_args) +#define sexp_opcode_flags(x) ((x)->value.opcode.flags) +#define sexp_opcode_inverse(x) ((x)->value.opcode.inverse) +#define sexp_opcode_name(x) ((x)->value.opcode.name) +#define sexp_opcode_data(x) ((x)->value.opcode.data) +#define sexp_opcode_data2(x) ((x)->value.opcode.data2) +#define sexp_opcode_proc(x) ((x)->value.opcode.proc) +#define sexp_opcode_return_type(x) ((x)->value.opcode.ret_type) +#define sexp_opcode_arg1_type(x) ((x)->value.opcode.arg1_type) +#define sexp_opcode_arg2_type(x) ((x)->value.opcode.arg2_type) +#define sexp_opcode_arg3_type(x) ((x)->value.opcode.arg3_type) +#define sexp_opcode_func(x) ((x)->value.opcode.func) + +#define sexp_opcode_variadic_p(x) (sexp_opcode_flags(x) & 1) +#define sexp_opcode_opt_param_p(x) (sexp_opcode_flags(x) & 2) +#define sexp_opcode_ref_trans_p(x) (sexp_opcode_flags(x) & 4) + +#define sexp_lambda_name(x) ((x)->value.lambda.name) +#define sexp_lambda_params(x) ((x)->value.lambda.params) +#define sexp_lambda_locals(x) ((x)->value.lambda.locals) +#define sexp_lambda_defs(x) ((x)->value.lambda.defs) +#define sexp_lambda_flags(x) ((x)->value.lambda.flags) +#define sexp_lambda_body(x) ((x)->value.lambda.body) +#define sexp_lambda_fv(x) ((x)->value.lambda.fv) +#define sexp_lambda_sv(x) ((x)->value.lambda.sv) +#define sexp_lambda_return_type(x) ((x)->value.lambda.ret) +#define sexp_lambda_param_types(x) ((x)->value.lambda.types) +#define sexp_lambda_source(x) ((x)->value.lambda.source) + +#define sexp_cnd_test(x) ((x)->value.cnd.test) +#define sexp_cnd_pass(x) ((x)->value.cnd.pass) +#define sexp_cnd_fail(x) ((x)->value.cnd.fail) +#define sexp_cnd_source(x) ((x)->value.cnd.source) + +#define sexp_set_var(x) ((x)->value.set.var) +#define sexp_set_value(x) ((x)->value.set.value) +#define sexp_set_source(x) ((x)->value.set.source) + +#define sexp_ref_name(x) ((x)->value.ref.name) +#define sexp_ref_cell(x) ((x)->value.ref.cell) +#define sexp_ref_loc(x) (sexp_cdr(sexp_ref_cell(x))) +#define sexp_ref_source(x) ((x)->value.ref.source) + +#define sexp_seq_ls(x) ((x)->value.seq.ls) +#define sexp_seq_source(x) ((x)->value.seq.source) + +#define sexp_lit_value(x) ((x)->value.lit.value) +#define sexp_lit_source(x) ((x)->value.lit.source) + +#define sexp_stack_length(x) ((x)->value.stack.length) +#define sexp_stack_top(x) ((x)->value.stack.top) +#define sexp_stack_data(x) ((x)->value.stack.data) + +#define sexp_context_env(x) ((x)->value.context.env) +#define sexp_context_stack(x) ((x)->value.context.stack) +#define sexp_context_depth(x) ((x)->value.context.depth) +#define sexp_context_bc(x) ((x)->value.context.bc) +#define sexp_context_fv(x) ((x)->value.context.fv) +#define sexp_context_pos(x) ((x)->value.context.pos) +#define sexp_context_lambda(x) ((x)->value.context.lambda) +#define sexp_context_parent(x) ((x)->value.context.parent) +#define sexp_context_child(x) ((x)->value.context.child) +#define sexp_context_saves(x) ((x)->value.context.saves) +#define sexp_context_tailp(x) ((x)->value.context.tailp) +#define sexp_context_tracep(x) ((x)->value.context.tracep) +#define sexp_context_globals(x) ((x)->value.context.globals) +#define sexp_context_last_fp(x) ((x)->value.context.last_fp) +#define sexp_context_refuel(x) ((x)->value.context.refuel) +#define sexp_context_ip(x) ((x)->value.context.ip) +#define sexp_context_proc(x) ((x)->value.context.proc) +#define sexp_context_timeval(x) ((x)->value.context.tval) +#define sexp_context_name(x) ((x)->value.context.name) +#define sexp_context_specific(x) ((x)->value.context.specific) +#define sexp_context_event(x) ((x)->value.context.event) +#define sexp_context_timeoutp(x) ((x)->value.context.timeoutp) +#define sexp_context_waitp(x) ((x)->value.context.waitp) + +#if SEXP_USE_ALIGNED_BYTECODE +#define sexp_context_align_pos(ctx) sexp_context_pos(ctx) = sexp_word_align(sexp_context_pos(ctx)) +#else +#define sexp_context_align_pos(ctx) +#endif + +#define sexp_global(ctx,x) (sexp_vector_data(sexp_context_globals(ctx))[x]) + +#if SEXP_USE_GLOBAL_HEAP +#if ! SEXP_USE_BOEHM +SEXP_API sexp_heap sexp_global_heap; +#endif +#define sexp_context_heap(ctx) sexp_global_heap +#else +#define sexp_context_heap(ctx) ((ctx)->value.context.heap) +#endif + +#if SEXP_USE_GLOBAL_SYMBOLS +#define sexp_context_symbols(ctx) sexp_symbol_table +#else +#define sexp_context_symbols(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_SYMBOLS)) +#endif + +#if SEXP_USE_GLOBAL_TYPES +SEXP_API struct sexp_struct *sexp_type_specs; +#define sexp_context_types(ctx) sexp_type_specs +#define sexp_type_by_index(ctx,i) (&(sexp_context_types(ctx)[i])) +#define sexp_context_num_types(ctx) sexp_num_types +#define sexp_context_type_array_size(ctx) sexp_type_array_size +#else +#define sexp_context_types(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)) +#define sexp_type_by_index(ctx,i) (sexp_context_types(ctx)[i]) +#define sexp_context_num_types(ctx) \ + sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_NUM_TYPES)) +#define sexp_context_type_array_size(ctx) \ + sexp_vector_length(sexp_global(ctx, SEXP_G_TYPES)) +#endif + +#define sexp_object_type(ctx,x) (sexp_type_by_index(ctx, ((x)->tag))) +#define sexp_object_type_name(ctx,x) (sexp_type_name(sexp_object_type(ctx, x))) +#define sexp_type_name_by_index(ctx,i) (sexp_type_name(sexp_type_by_index(ctx,i))) + +#define sexp_type_size_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_size_off(t)))[0] \ + * sexp_type_size_scale(t) \ + + sexp_type_size_base(t)) +#define sexp_type_num_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ + * sexp_type_field_len_scale(t) \ + + sexp_type_field_len_base(t)) +#define sexp_type_num_eq_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ + * sexp_type_field_len_scale(t) \ + + sexp_type_field_eq_len_base(t)) + +#define sexp_context_top(x) (sexp_stack_top(sexp_context_stack(x))) + +#define sexp_type_tag(x) ((x)->value.type.tag) +#define sexp_type_field_base(x) ((x)->value.type.field_base) +#define sexp_type_field_eq_len_base(x) ((x)->value.type.field_eq_len_base) +#define sexp_type_field_len_base(x) ((x)->value.type.field_len_base) +#define sexp_type_field_len_off(x) ((x)->value.type.field_len_off) +#define sexp_type_field_len_scale(x) ((x)->value.type.field_len_scale) +#define sexp_type_size_base(x) ((x)->value.type.size_base) +#define sexp_type_size_off(x) ((x)->value.type.size_off) +#define sexp_type_size_scale(x) ((x)->value.type.size_scale) +#define sexp_type_name(x) ((x)->value.type.name) +#define sexp_type_finalize(x) ((x)->value.type.finalize) + +#define sexp_bignum_sign(x) ((x)->value.bignum.sign) +#define sexp_bignum_length(x) ((x)->value.bignum.length) +#define sexp_bignum_data(x) ((x)->value.bignum.data) + +/****************************** arithmetic ****************************/ + +#define sexp_fx_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG)) +#define sexp_fx_sub(a, b) ((sexp)(((sexp_sint_t)a)-((sexp_sint_t)b)+SEXP_FIXNUM_TAG)) +#define sexp_fx_mul(a, b) ((sexp)((((((sexp_sint_t)a)-SEXP_FIXNUM_TAG)*(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG))) +#define sexp_fx_div(a, b) (sexp_make_fixnum(sexp_unbox_fixnum(a) / sexp_unbox_fixnum(b))) +#define sexp_fx_rem(a, b) (sexp_make_fixnum(sexp_unbox_fixnum(a) % sexp_unbox_fixnum(b))) +#define sexp_fx_sign(a) (+1 | (((sexp_sint_t)(a)) >> (sizeof(sexp_sint_t)*8 - 1))) +#define sexp_fx_neg(a) (sexp_make_fixnum(-(sexp_unbox_fixnum(a)))) +#define sexp_fx_abs(a) ((((sexp_sint_t)a) < 0) ? sexp_fx_neg(a) : a) + +#define sexp_fp_add(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) + sexp_flonum_value(b))) +#define sexp_fp_sub(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) - sexp_flonum_value(b))) +#define sexp_fp_mul(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) * sexp_flonum_value(b))) +#define sexp_fp_div(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) / sexp_flonum_value(b))) + +/****************************** utilities *****************************/ + +enum sexp_context_globals { +#if ! SEXP_USE_GLOBAL_SYMBOLS + SEXP_G_SYMBOLS, +#endif +#if ! SEXP_USE_GLOBAL_TYPES + SEXP_G_TYPES, + SEXP_G_NUM_TYPES, +#endif + SEXP_G_OOM_ERROR, /* out of memory exception object */ + SEXP_G_OOS_ERROR, /* out of stack exception object */ + SEXP_G_OPTIMIZATIONS, + SEXP_G_SIGNAL_HANDLERS, + SEXP_G_CONFIG_ENV, + SEXP_G_MODULE_PATH, + SEXP_G_QUOTE_SYMBOL, + SEXP_G_QUASIQUOTE_SYMBOL, + SEXP_G_UNQUOTE_SYMBOL, + SEXP_G_UNQUOTE_SPLICING_SYMBOL, + SEXP_G_EMPTY_VECTOR, + SEXP_G_CUR_IN_SYMBOL, + SEXP_G_CUR_OUT_SYMBOL, + SEXP_G_CUR_ERR_SYMBOL, + SEXP_G_INTERACTION_ENV_SYMBOL, + SEXP_G_ERR_HANDLER, + SEXP_G_RESUMECC_BYTECODE, + SEXP_G_FINAL_RESUMER, +#if SEXP_USE_GREEN_THREADS + SEXP_G_THREADS_SCHEDULER, + SEXP_G_THREADS_FRONT, + SEXP_G_THREADS_BACK, + SEXP_G_THREADS_PAUSED, + SEXP_G_THREADS_LOCAL, + SEXP_G_THREADS_SIGNALS, + SEXP_G_THREADS_SIGNAL_RUNNER, +#endif + SEXP_G_NUM_GLOBALS +}; + +#define sexp_list1(x,a) sexp_cons((x), (a), SEXP_NULL) + +#define sexp_push(ctx, ls, x) ((ls) = sexp_cons((ctx), (x), (ls))) +#define sexp_insert(ctx, ls, x) ((sexp_memq(ctx, (x), (ls)) != SEXP_FALSE) ? (ls) : sexp_push((ctx), (ls), (x))) + +#define sexp_pair_source(x) ((x)->value.pair.source) + +#define sexp_car(x) ((x)->value.pair.car) +#define sexp_cdr(x) ((x)->value.pair.cdr) + +#define sexp_caar(x) (sexp_car(sexp_car(x))) +#define sexp_cadr(x) (sexp_car(sexp_cdr(x))) +#define sexp_cdar(x) (sexp_cdr(sexp_car(x))) +#define sexp_cddr(x) (sexp_cdr(sexp_cdr(x))) +#define sexp_caaar(x) (sexp_car(sexp_caar(x))) +#define sexp_caadr(x) (sexp_car(sexp_cadr(x))) +#define sexp_cadar(x) (sexp_car(sexp_cdar(x))) +#define sexp_caddr(x) (sexp_car(sexp_cddr(x))) +#define sexp_cdaar(x) (sexp_cdr(sexp_caar(x))) +#define sexp_cdadr(x) (sexp_cdr(sexp_cadr(x))) +#define sexp_cddar(x) (sexp_cdr(sexp_cdar(x))) +#define sexp_cdddr(x) (sexp_cdr(sexp_cddr(x))) +#define sexp_cadddr(x) (sexp_cadr(sexp_cddr(x))) /* just these two */ +#define sexp_cddddr(x) (sexp_cddr(sexp_cddr(x))) + +/***************************** general API ****************************/ + +#if SEXP_USE_STRING_STREAMS + +#define sexp_read_char(x, p) (getc(sexp_port_stream(p))) +#define sexp_push_char(x, c, p) (ungetc(c, sexp_port_stream(p))) +#define sexp_write_char(x, c, p) (putc(c, sexp_port_stream(p))) +#define sexp_write_string(x, s, p) (fputs(s, sexp_port_stream(p))) +#define sexp_printf(x, p, ...) (fprintf(sexp_port_stream(p), __VA_ARGS__)) +#define sexp_flush(x, p) (fflush(sexp_port_stream(p))) + +#else + +#define sexp_read_char(x, p) (sexp_port_buf(p) ? ((sexp_port_offset(p) < sexp_port_size(p)) ? sexp_port_buf(p)[sexp_port_offset(p)++] : sexp_buffered_read_char(x, p)) : getc(sexp_port_stream(p))) +#define sexp_push_char(x, c, p) (sexp_port_buf(p) ? (sexp_port_buf(p)[--sexp_port_offset(p)] = ((char)(c))) : ungetc(c, sexp_port_stream(p))) +#define sexp_write_char(x, c, p) (sexp_port_buf(p) ? ((sexp_port_offset(p) < sexp_port_size(p)) ? ((((sexp_port_buf(p))[sexp_port_offset(p)++]) = (char)(c)), SEXP_VOID) : sexp_buffered_write_char(x, c, p)) : (putc(c, sexp_port_stream(p)), SEXP_VOID)) +#define sexp_write_string(x, s, p) (sexp_port_buf(p) ? sexp_buffered_write_string(x, s, p) : (fputs(s, sexp_port_stream(p)), SEXP_VOID)) +#define sexp_flush(x, p) (sexp_port_buf(p) ? sexp_buffered_flush(x, p) : (fflush(sexp_port_stream(p)), SEXP_VOID)) + +SEXP_API int sexp_buffered_read_char (sexp ctx, sexp p); +SEXP_API sexp sexp_buffered_write_char (sexp ctx, int c, sexp p); +SEXP_API sexp sexp_buffered_write_string_n (sexp ctx, const char *str, sexp_uint_t len, sexp p); +SEXP_API sexp sexp_buffered_write_string (sexp ctx, const char *str, sexp p); +SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p); + +#endif + +#define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p)) +#define sexp_at_eofp(p) (feof(sexp_port_stream(p))) + +SEXP_API sexp sexp_make_context(sexp ctx, size_t size); +SEXP_API sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); +SEXP_API sexp sexp_cons_op(sexp ctx sexp_api_params(self, n), sexp head, sexp tail); +SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b); +SEXP_API sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b); +SEXP_API sexp sexp_listp_op(sexp ctx sexp_api_params(self, n), sexp obj); +SEXP_API sexp sexp_reverse_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_nreverse_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_copy_list_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_append2_op(sexp ctx sexp_api_params(self, n), sexp a, sexp b); +SEXP_API sexp sexp_memq_op(sexp ctx sexp_api_params(self, n), sexp x, sexp ls); +SEXP_API sexp sexp_assq_op(sexp ctx sexp_api_params(self, n), sexp x, sexp ls); +SEXP_API sexp sexp_length_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_c_string(sexp ctx, const char *str, sexp_sint_t slen); +SEXP_API sexp sexp_make_bytes_op(sexp ctx sexp_api_params(self, n), sexp len, sexp i); +SEXP_API sexp sexp_make_string_op(sexp ctx sexp_api_params(self, n), sexp len, sexp ch); +SEXP_API sexp sexp_substring_op (sexp ctx sexp_api_params(self, n), sexp str, sexp start, sexp end); +SEXP_API sexp sexp_string_concatenate_op (sexp ctx sexp_api_params(self, n), sexp str_ls, sexp sep); +SEXP_API sexp sexp_intern (sexp ctx, const char *str, sexp_sint_t len); +SEXP_API sexp sexp_string_to_symbol_op (sexp ctx sexp_api_params(self, n), sexp str); +SEXP_API sexp sexp_string_to_number_op (sexp ctx sexp_api_params(self, n), sexp str, sexp b); +SEXP_API sexp sexp_make_vector_op (sexp ctx sexp_api_params(self, n), sexp len, sexp dflt); +SEXP_API sexp sexp_list_to_vector_op (sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_make_cpointer (sexp ctx, sexp_uint_t type_id, void* value, sexp parent, int freep); +SEXP_API sexp sexp_write_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out); +SEXP_API sexp sexp_display_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out); +SEXP_API sexp sexp_flush_output_op (sexp ctx sexp_api_params(self, n), sexp out); +SEXP_API sexp sexp_read_string (sexp ctx, sexp in); +SEXP_API sexp sexp_read_symbol (sexp ctx, sexp in, int init, int internp); +SEXP_API sexp sexp_read_number (sexp ctx, sexp in, int base); +SEXP_API sexp sexp_read_raw (sexp ctx, sexp in); +SEXP_API sexp sexp_read_op (sexp ctx sexp_api_params(self, n), sexp in); +SEXP_API sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len); +SEXP_API sexp sexp_write_to_string (sexp ctx, sexp obj); +SEXP_API sexp sexp_finalize_port (sexp ctx sexp_api_params(self, n), sexp port); +SEXP_API sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name); +SEXP_API sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name); +SEXP_API sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str); +SEXP_API sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)); +SEXP_API sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port); +SEXP_API sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source); +SEXP_API sexp sexp_user_exception (sexp ctx, sexp self, const char *msg, sexp x); +SEXP_API sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp x); +SEXP_API sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp x); +SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); +SEXP_API sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp out); +SEXP_API void sexp_init(void); + +#define sexp_assert_type(ctx, pred, type_id, obj) if (! pred(obj)) return sexp_type_exception(ctx, self, type_id, obj) + +#define SEXP_COPY_DEFAULT SEXP_ZERO +#define SEXP_COPY_FREEP SEXP_ONE + +#if SEXP_USE_GLOBAL_HEAP +#define sexp_destroy_context(ctx) +#else +SEXP_API void sexp_destroy_context (sexp ctx); +SEXP_API sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags); +#endif + +#if SEXP_USE_TYPE_DEFS +SEXP_API sexp sexp_register_type_op (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2); +SEXP_API sexp sexp_register_simple_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp slots); +SEXP_API sexp sexp_register_c_type (sexp ctx, sexp name); +SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj); +#define sexp_register_c_type(ctx, name, finalizer) \ + sexp_register_type(ctx, name, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \ + SEXP_ZERO, sexp_make_fixnum(sexp_sizeof(cpointer)), \ + SEXP_ZERO, SEXP_ZERO, (sexp_proc2)finalizer) +#endif + +#define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL),SEXP_FALSE) +#define sexp_debug(ctx, msg, obj) (sexp_write_string(ctx, msg, sexp_current_error_port(ctx)), sexp_write(ctx, obj, sexp_current_error_port(ctx)), sexp_write_char(ctx, '\n', sexp_current_error_port(ctx))) + +/* simplify primitive API interface */ + +#define sexp_read(ctx, in) sexp_read_op(ctx sexp_api_pass(NULL, 1), in) +#define sexp_write(ctx, obj, out) sexp_write_op(ctx sexp_api_pass(NULL, 2), obj, out) +#define sexp_display(ctx, obj, out) sexp_display_op(ctx sexp_api_pass(NULL, 2), obj, out) +#define sexp_print_exception(ctx, e, out) sexp_print_exception_op(ctx sexp_api_pass(NULL, 2), e, out) +#define sexp_flush_output(ctx, obj, out) sexp_flush_output_op(ctx sexp_api_pass(NULL, 1), out) +#define sexp_equalp(ctx, a, b) sexp_equalp_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_listp(ctx, x) sexp_listp_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_length(ctx, x) sexp_length_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_reverse(ctx, x) sexp_reverse_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_nreverse(ctx, x) sexp_nreverse_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_copy_list(ctx, x) sexp_copy_list_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_cons(ctx, a, b) sexp_cons_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_append2(ctx, a, b) sexp_append2_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_vector(ctx, a, b) sexp_make_vector_op(ctx sexp_api_pass(NULL, 2), a, b); +#define sexp_list_to_vector(ctx, x) sexp_list_to_vector_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_exception_type(ctx, x) sexp_exception_type_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_string_to_number(ctx, s, b) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), s, b) +#define sexp_make_bytes(ctx, l, i) sexp_make_bytes_op(ctx sexp_api_pass(NULL, 2), l, i) +#define sexp_make_string(ctx, l, c) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), l, c) +#define sexp_string_cmp(ctx, a, b, c) sexp_string_cmp_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_substring(ctx, a, b, c) sexp_substring_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_string_concatenate(ctx, ls, s) sexp_string_concatenate_op(ctx sexp_api_pass(NULL, 2), ls, s) +#define sexp_memq(ctx, a, b) sexp_memq_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_assq(ctx, a, b) sexp_assq_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_output_string_port(ctx) sexp_make_output_string_port_op(ctx sexp_api_pass(NULL, 0)) +#define sexp_make_input_string_port(ctx, s) sexp_make_input_string_port_op(ctx sexp_api_pass(NULL, 1), s) +#define sexp_get_output_string(ctx, out) sexp_get_output_string_op(ctx sexp_api_pass(NULL, 1), out) +#define sexp_expt(ctx, a, b) sexp_expt_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_register_simple_type(ctx, a, b) sexp_register_simple_type_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_register_type(ctx, a, b, c, d, e, f, g, h, i, j) sexp_register_type_op(ctx sexp_api_pass(NULL, 10), a, b, c, d, e, f, g, h, i, j) +#define sexp_make_type_predicate(ctx, a, b) sexp_make_type_predicate_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_constructor(ctx, a, b) sexp_make_constructor_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_getter(ctx, a, b, c) sexp_make_getter_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_make_setter(ctx, a, b, c) sexp_make_setter_op(ctx sexp_api_pass(NULL, 3), a, b, c) + +#ifdef __cplusplus +} /* extern "C" */ +#endif + +#endif /* ! SEXP_H */ + diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c new file mode 100644 index 00000000..8d946273 --- /dev/null +++ b/lib/chibi/ast.c @@ -0,0 +1,248 @@ +/* ast.c -- interface to the Abstract Syntax Tree */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +static void sexp_define_type_predicate (sexp ctx, sexp env, char *cname, sexp_uint_t type) { + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + name = sexp_c_string(ctx, cname, -1); + op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type)); + sexp_env_define(ctx, env, name=sexp_intern(ctx, cname, -1), op); + sexp_gc_release2(ctx); +} + +static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype, + sexp_uint_t cindex, char* get, char *set) { + sexp type, index; + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + type = sexp_make_fixnum(ctype); + index = sexp_make_fixnum(cindex); + op = sexp_make_getter(ctx, name=sexp_c_string(ctx, get, -1), type, index); + sexp_env_define(ctx, env, name=sexp_intern(ctx, get, -1), op); + op = sexp_make_setter(ctx, name=sexp_c_string(ctx, set, -1), type, index); + sexp_env_define(ctx, env, name=sexp_intern(ctx, set, -1), op); + sexp_gc_release2(ctx); +} + +static sexp sexp_get_env_cell (sexp ctx sexp_api_params(self, n), sexp env, sexp id) { + sexp cell = sexp_env_cell(env, id); + while ((! cell) && sexp_synclop(id)) { + env = sexp_synclo_env(id); + id = sexp_synclo_expr(id); + } + return cell ? cell : SEXP_FALSE; +} + +static sexp sexp_get_opcode_name (sexp ctx sexp_api_params(self, n), sexp op) { + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + else if (! sexp_opcode_name(op)) + return SEXP_FALSE; + else + return sexp_intern(ctx, sexp_opcode_name(op), -1); +} + +static sexp sexp_translate_opcode_type (sexp ctx, sexp type) { + sexp_gc_var2(res, tmp); + res = type; + if (! res) { + res = sexp_type_by_index(ctx, SEXP_OBJECT); + } if (sexp_fixnump(res)) { + res = sexp_type_by_index(ctx, sexp_unbox_fixnum(res)); + } else if (sexp_nullp(res)) { /* opcode list types */ + sexp_gc_preserve2(ctx, res, tmp); + tmp = sexp_intern(ctx, "or", -1); + res = sexp_cons(ctx, SEXP_NULL, SEXP_NULL); + res = sexp_cons(ctx, sexp_type_by_index(ctx, SEXP_PAIR), res); + res = sexp_cons(ctx, tmp, res); + sexp_gc_release2(ctx); + } + return res; +} + +static sexp sexp_get_opcode_ret_type (sexp ctx sexp_api_params(self, n), sexp op) { + sexp res; + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + if (sexp_opcode_code(op) == SEXP_OP_RAISE) + return sexp_list1(ctx, sexp_intern(ctx, "error", -1)); + res = sexp_opcode_return_type(op); + if (sexp_fixnump(res)) + res = sexp_type_by_index(ctx, sexp_unbox_fixnum(res)); + return sexp_translate_opcode_type(ctx, res); +} + +static sexp sexp_get_opcode_param_type (sexp ctx sexp_api_params(self, n), sexp op, sexp k) { + sexp res; + int p = sexp_unbox_fixnum(k); + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + else if (! sexp_fixnump(k)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, k); + if (p > sexp_opcode_num_args(op) && sexp_opcode_variadic_p(op)) + p = sexp_opcode_num_args(op); + switch (p) { + case 0: + res = sexp_opcode_arg1_type(op); + break; + case 1: + res = sexp_opcode_arg2_type(op); + break; + default: + res = sexp_opcode_arg3_type(op); + if (sexp_vectorp(res)) { + if (sexp_vector_length(res) > (sexp_unbox_fixnum(k)-2)) + res = sexp_vector_ref(res, sexp_fx_sub(k, SEXP_TWO)); + else + res = sexp_type_by_index(ctx, SEXP_OBJECT); + } + break; + } + return sexp_translate_opcode_type(ctx, res); +} + +static sexp sexp_get_opcode_num_params (sexp ctx sexp_api_params(self, n), sexp op) { + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + return sexp_make_fixnum(sexp_opcode_num_args(op)); +} + +static sexp sexp_get_opcode_variadic_p (sexp ctx sexp_api_params(self, n), sexp op) { + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + return sexp_make_boolean(sexp_opcode_variadic_p(op)); +} + +static sexp sexp_type_of (sexp ctx sexp_api_params(self, n), sexp x) { + if (sexp_pointerp(x)) + return sexp_object_type(ctx, x); + else if (sexp_fixnump(x)) + return sexp_type_by_index(ctx, SEXP_FIXNUM); + else if (sexp_booleanp(x)) + return sexp_type_by_index(ctx, SEXP_BOOLEAN); + else if (sexp_charp(x)) + return sexp_type_by_index(ctx, SEXP_CHAR); +#if SEXP_USE_HUFF_SYMS + else if (sexp_symbolp(x)) + return sexp_type_by_index(ctx, SEXP_SYMBOL); +#endif +#if SEXP_USE_IMMEDIATE_FLONUMS + else if (sexp_flonump(x)) + return sexp_type_by_index(ctx, SEXP_FLONUM); +#endif + else + return sexp_type_by_index(ctx, SEXP_OBJECT); +} + +static sexp sexp_analyze_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { + sexp ctx2 = ctx; + if (sexp_envp(e)) { + ctx2 = sexp_make_child_context(ctx, NULL); + sexp_context_env(ctx2) = e; + } + return sexp_analyze(ctx2, x); +} + +static sexp sexp_optimize (sexp ctx sexp_api_params(self, n), sexp x) { + sexp_gc_var2(ls, res); + sexp_gc_preserve2(ctx, ls, res); + res = x; + ls = sexp_global(ctx, SEXP_G_OPTIMIZATIONS); + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) + res = sexp_apply1(ctx, sexp_cdar(ls), res); + sexp_free_vars(ctx, res, SEXP_NULL); + sexp_gc_release2(ctx); + return res; +} + +#define sexp_define_type(ctx, name, tag) \ + sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), sexp_type_by_index(ctx, tag)); + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_type(ctx, "", SEXP_OBJECT); + sexp_define_type(ctx, "", SEXP_NUMBER); + sexp_define_type(ctx, "", SEXP_BIGNUM); + sexp_define_type(ctx, "", SEXP_FLONUM); + sexp_define_type(ctx, "", SEXP_FIXNUM); + sexp_define_type(ctx, "", SEXP_SYMBOL); + sexp_define_type(ctx, "", SEXP_CHAR); + sexp_define_type(ctx, "", SEXP_BOOLEAN); + sexp_define_type(ctx, "", SEXP_STRING); + sexp_define_type(ctx, "", SEXP_BYTES); + sexp_define_type(ctx, "", SEXP_PAIR); + sexp_define_type(ctx, "", SEXP_VECTOR); + sexp_define_type(ctx, "", SEXP_OPCODE); + sexp_define_type(ctx, "", SEXP_PROCEDURE); + sexp_define_type(ctx, "", SEXP_BYTECODE); + sexp_define_type(ctx, "", SEXP_ENV); + sexp_define_type(ctx, "", SEXP_MACRO); + sexp_define_type(ctx, "", SEXP_LAMBDA); + sexp_define_type(ctx, "", SEXP_CND); + sexp_define_type(ctx, "", SEXP_SET); + sexp_define_type(ctx, "", SEXP_REF); + sexp_define_type(ctx, "", SEXP_SEQ); + sexp_define_type(ctx, "", SEXP_LIT); + sexp_define_type(ctx, "", SEXP_SYNCLO); + sexp_define_type(ctx, "", SEXP_CONTEXT); + sexp_define_type(ctx, "", SEXP_EXCEPTION); + sexp_define_type_predicate(ctx, env, "environment?", SEXP_ENV); + sexp_define_type_predicate(ctx, env, "bytecode?", SEXP_BYTECODE); + sexp_define_type_predicate(ctx, env, "exception?", SEXP_EXCEPTION); + sexp_define_type_predicate(ctx, env, "macro?", SEXP_MACRO); + sexp_define_type_predicate(ctx, env, "syntactic-closure?", SEXP_SYNCLO); + sexp_define_type_predicate(ctx, env, "lambda?", SEXP_LAMBDA); + sexp_define_type_predicate(ctx, env, "cnd?", SEXP_CND); + sexp_define_type_predicate(ctx, env, "set?", SEXP_SET); + sexp_define_type_predicate(ctx, env, "ref?", SEXP_REF); + sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ); + sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT); + sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE); + sexp_define_type_predicate(ctx, env, "type?", SEXP_TYPE); + sexp_define_type_predicate(ctx, env, "context?", SEXP_CONTEXT); + sexp_define_type_predicate(ctx, env, "exception?", SEXP_EXCEPTION); + sexp_define_accessors(ctx, env, SEXP_PAIR, 2, "pair-source", "pair-source-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 0, "syntactic-closure-env", "syntactic-closure-env-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", "syntactic-closure-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 2, "syntactic-closure-expr", "syntactic-closure-expr-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 0, "lambda-name", "lambda-name-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 1, "lambda-params", "lambda-params-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 2, "lambda-body", "lambda-body-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 3, "lambda-defs", "lambda-defs-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 4, "lambda-locals", "lambda-locals-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 5, "lambda-flags", "lambda-flags-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 6, "lambda-free-vars", "lambda-free-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 7, "lambda-set-vars", "lambda-set-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 8, "lambda-return-type", "lambda-return-type-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 9, "lambda-param-types", "lambda-param-types-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 10, "lambda-source", "lambda-source-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 0, "cnd-test", "cnd-test-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 1, "cnd-pass", "cnd-pass-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 2, "cnd-fail", "cnd-fail-set!"); + sexp_define_accessors(ctx, env, SEXP_SET, 0, "set-var", "set-var-set!"); + sexp_define_accessors(ctx, env, SEXP_SET, 1, "set-value", "set-value-set!"); + sexp_define_accessors(ctx, env, SEXP_REF, 0, "ref-name", "ref-name-set!"); + sexp_define_accessors(ctx, env, SEXP_REF, 1, "ref-cell", "ref-cell-set!"); + sexp_define_accessors(ctx, env, SEXP_SEQ, 0, "seq-ls", "seq-ls-set!"); + sexp_define_accessors(ctx, env, SEXP_LIT, 0, "lit-value", "lit-value-set!"); + sexp_define_accessors(ctx, env, SEXP_PROCEDURE, 1, "procedure-code", "procedure-code-set!"); + sexp_define_accessors(ctx, env, SEXP_PROCEDURE, 2, "procedure-vars", "procedure-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_BYTECODE, 1, "bytecode-name", "bytecode-name-set!"); + sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 0, "exception-kind", "exception-kind-set!"); + sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 1, "exception-message", "exception-message-set!"); + sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 2, "exception-irritants", "exception-irritants-set!"); + sexp_define_foreign_opt(ctx, env, "analyze", 2, sexp_analyze_op, SEXP_FALSE); + sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env); + sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell); + sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name); + sexp_define_foreign(ctx, env, "opcode-variadic?", 1, sexp_get_opcode_variadic_p); + sexp_define_foreign(ctx, env, "opcode-num-params", 1, sexp_get_opcode_num_params); + sexp_define_foreign(ctx, env, "opcode-return-type", 1, sexp_get_opcode_ret_type); + sexp_define_foreign(ctx, env, "opcode-param-type", 2, sexp_get_opcode_param_type); + sexp_define_foreign(ctx, env, "optimize", 1, sexp_optimize); + sexp_define_foreign(ctx, env, "type-of", 1, sexp_type_of); + return SEXP_VOID; +} + diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module new file mode 100644 index 00000000..a439bd57 --- /dev/null +++ b/lib/chibi/ast.module @@ -0,0 +1,33 @@ + +(define-module (chibi ast) + (export + analyze optimize env-cell ast->sexp macroexpand type-of + + + + + pair-source pair-source-set! + syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? type? + environment? bytecode? exception? macro? context? exception? + syntactic-closure-expr syntactic-closure-env syntactic-closure-vars + lambda-name lambda-params lambda-body lambda-defs lambda-locals + lambda-flags lambda-free-vars lambda-set-vars lambda-return-type + lambda-param-types lambda-source + lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-set! + lambda-locals-set! lambda-flags-set! lambda-free-vars-set! + lambda-set-vars-set! lambda-return-type-set! lambda-param-types-set! + lambda-source-set! + cnd-test cnd-pass cnd-fail + cnd-test-set! cnd-pass-set! cnd-fail-set! + set-var set-value set-var-set! set-value-set! + ref-name ref-cell ref-name-set! ref-cell-set! + seq-ls seq-ls-set! lit-value lit-value-set! + exception-kind exception-kind-set! exception-message exception-message-set! + exception-irritants exception-irritants-set! + opcode-name opcode-num-params opcode-return-type opcode-param-type + opcode-variadic? + procedure-code procedure-vars procedure-name bytecode-name) + (import-immutable (scheme)) + (include-shared "ast") + (include "ast.scm")) + diff --git a/lib/chibi/ast.scm b/lib/chibi/ast.scm new file mode 100644 index 00000000..020f257a --- /dev/null +++ b/lib/chibi/ast.scm @@ -0,0 +1,91 @@ +;; ast.scm -- ast utilities +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (macroexpand x) + (ast->sexp (analyze x))) + +(define (procedure-name x) + (bytecode-name (procedure-code x))) + +(define (ast-renames ast) + (define i 0) + (define renames '()) + (define (rename-symbol id) + (set! i (+ i 1)) + (string->symbol + (string-append (symbol->string (identifier->symbol id)) + "." (number->string i)))) + (define (rename-lambda lam) + (or (assq lam renames) + (let ((res (list lam))) + (set! renames (cons res renames)) + res))) + (define (rename! id lam) + (let ((cell (rename-lambda lam))) + (set-cdr! cell (cons (cons id (rename-symbol id)) (cdr cell))))) + (define (check-ref id lam env) + (let ((sym (identifier->symbol id))) + (let lp1 ((ls env)) + (cond + ((pair? ls) + (let lp2 ((ls2 (car ls)) (found? #f)) + (cond + ((null? ls2) + (if (not found?) (lp1 (cdr ls)))) + ((and (eq? id (caar ls2)) (eq? lam (cdar ls2))) + (lp2 (cdr ls2) #t)) + ((eq? sym (identifier->symbol (caar ls2))) + (rename! (caar ls2) (cdar ls2)) + (lp2 (cdr ls2) found?)) + (else + (lp2 (cdr ls2) found?))))))))) + (define (flatten-dot x) + (cond ((pair? x) (cons (car x) (flatten-dot (cdr x)))) + ((null? x) x) + (else (list x)))) + (define (extend-env lam env) + (cons (map (lambda (x) (cons x lam)) (flatten-dot (lambda-params lam))) env)) + (let lp ((x ast) (env '())) + (cond + ((lambda? x) (lp (lambda-body x) (extend-env x env))) + ((ref? x) (check-ref (ref-name x) (cdr (ref-cell x)) env)) + ((cnd? x) (lp (cnd-test x) env) (lp (cnd-pass x) env) (lp (cnd-fail x) env)) + ((set? x) (lp (set-var x) env) (lp (set-value x) env)) + ((seq? x) (for-each (lambda (x) (lp x env)) (seq-ls x))) + ((pair? x) (for-each (lambda (x) (lp x env)) x)))) + renames) + +(define (get-rename id lam renames) + (let ((ls (assq lam renames))) + (if (not ls) + (identifier->symbol id) + (cond ((assq id (cdr ls)) => cdr) (else (identifier->symbol id)))))) + +(define (map* f ls) + (cond ((pair? ls) (cons (f (car ls)) (map* f (cdr ls)))) + ((null? ls) '()) + (else (f ls)))) + +(define (ast->sexp ast) + (let ((renames (ast-renames ast))) + (let a2s ((x ast)) + (cond + ((lambda? x) + `(lambda ,(map* (lambda (id) (get-rename id x renames)) (lambda-params x)) + ,@(map (lambda (d) `(define ,(identifier->symbol (caar d)) #f)) + (lambda-defs x)) + ,@(if (seq? (lambda-body x)) + (map a2s (seq-ls (lambda-body x))) + (list (a2s (lambda-body x)))))) + ((cnd? x) `(if ,(a2s (cnd-test x)) ,(a2s (cnd-pass x)) ,(a2s (cnd-fail x)))) + ((set? x) `(set! ,(a2s (set-var x)) ,(a2s (set-value x)))) + ((ref? x) (get-rename (ref-name x) (cdr (ref-cell x)) renames)) + ((seq? x) `(begin ,@(map a2s (seq-ls x)))) + ((lit? x) + (let ((v (lit-value x))) + (if (or (pair? v) (null? v) (symbol? v)) `',v v))) + ((pair? x) (cons (a2s (car x)) (a2s (cdr x)))) + ((opcode? x) (or (opcode-name x) x)) + (else x))))) + diff --git a/lib/chibi/base64.module b/lib/chibi/base64.module new file mode 100644 index 00000000..12324e1d --- /dev/null +++ b/lib/chibi/base64.module @@ -0,0 +1,7 @@ + +(define-module (chibi base64) + (export base64-encode base64-encode-string + base64-decode base64-decode-string + base64-encode-header) + (import-immutable (scheme) (srfi 33) (chibi io)) + (include "base64.scm")) diff --git a/lib/chibi/base64.scm b/lib/chibi/base64.scm new file mode 100644 index 00000000..3d95ad71 --- /dev/null +++ b/lib/chibi/base64.scm @@ -0,0 +1,351 @@ +;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; Procedure: base64-encode-string str +;; Return a base64 encoded representation of string according to the +;; official base64 standard as described in RFC3548. + +;; Procedure: base64-decode-string str +;; Return a base64 decoded representation of string, also interpreting +;; the alternate 62 & 63 valued characters as described in RFC3548. +;; Other out-of-band characters are silently stripped, and = signals +;; the end of the encoded string. No errors will be raised. + +;; Procedure: base64-encode [port] +;; Procedure: base64-decode [port] +;; Variations of the above which read and write to ports. + +;; Procedure: base64-encode-header enc str [start-col max-col nl] +;; Return a base64 encoded representation of string as above, +;; wrapped in =?ENC?B?...?= as per RFC1522, split across multiple +;; MIME-header lines as needed to keep each lines length less than +;; MAX-COL. The string is encoded as is, and the encoding ENC is +;; just used for the prefix, i.e. you are responsible for ensuring +;; STR is already encoded according to ENC. The optional argument +;; NL is the newline separator, defaulting to CRLF. + +;; This API is compatible with the Gauche library rfc.base64. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils + +(define (string-chop str n) + (let ((len (string-length str))) + (let lp ((i 0) (res '())) + (let ((j (+ i n))) + (if (>= j len) + (reverse (cons (substring str i len) res)) + (lp j (cons (substring str i j) res))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; constants and tables + +(define *default-max-col* 76) + +(define *outside-char* 99) ; luft-balloons +(define *pad-char* 101) ; dalmations + +(define *base64-decode-table* + (let ((res (make-vector #x100 *outside-char*))) + (let lp ((i 0)) ; map letters + (cond + ((<= i 25) + (vector-set! res (+ i 65) i) + (vector-set! res (+ i 97) (+ i 26)) + (lp (+ i 1))))) + (let lp ((i 0)) ; map numbers + (cond + ((<= i 9) + (vector-set! res (+ i 48) (+ i 52)) + (lp (+ i 1))))) + ;; extras (be liberal for different common base64 formats) + (vector-set! res (char->integer #\+) 62) + (vector-set! res (char->integer #\-) 62) + (vector-set! res (char->integer #\/) 63) + (vector-set! res (char->integer #\_) 63) + (vector-set! res (char->integer #\~) 63) + (vector-set! res (char->integer #\=) *pad-char*) + res)) + +(define (base64-decode-char c) + (vector-ref *base64-decode-table* (char->integer c))) + +(define *base64-encode-table* + (let ((res (make-vector 64))) + (let lp ((i 0)) ; map letters + (cond + ((<= i 25) + (vector-set! res i (integer->char (+ i 65))) + (vector-set! res (+ i 26) (integer->char (+ i 97))) + (lp (+ i 1))))) + (let lp ((i 0)) ; map numbers + (cond + ((<= i 9) + (vector-set! res (+ i 52) (integer->char (+ i 48))) + (lp (+ i 1))))) + (vector-set! res 62 #\+) + (vector-set! res 63 #\/) + res)) + +(define (enc i) + (vector-ref *base64-encode-table* i)) + +;; try to match common boundaries +(define decode-src-length + (lcm 76 78)) + +(define decode-dst-length + (* 3 (arithmetic-shift (+ 3 decode-src-length) -2))) + +(define encode-src-length + (* 3 1024)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; decoding + +;; Create a result buffer with the maximum possible length for the +;; input, and pass it to the internal base64-decode-string! utility. +;; If the resulting length used is exact, we can return that buffer, +;; otherwise we return the appropriate substring. +(define (base64-decode-string src) + (let* ((len (string-length src)) + (dst-len (* 3 (arithmetic-shift (+ 3 len) -2))) + (dst (make-string dst-len))) + (base64-decode-string! + src 0 len dst + (lambda (src-offset res-len b1 b2 b3) + (let ((res-len (base64-decode-finish dst res-len b1 b2 b3))) + (if (= res-len dst-len) + dst + (substring dst 0 res-len))))))) + +;; This is a little funky. +;; +;; We want to skip over "outside" characters (e.g. newlines inside +;; base64-encoded data, as would be passed in mail clients and most +;; large base64 data). This would normally mean two nested loops - +;; one for overall processing the input, and one for looping until +;; we get to a valid character. However, many Scheme compilers are +;; really bad about optimizing nested loops of primitives, so we +;; flatten this into a single loop, using conditionals to determine +;; which character is currently being read. +(define (base64-decode-string! src start end dst kont) + (let lp ((i start) + (j 0) + (b1 *outside-char*) + (b2 *outside-char*) + (b3 *outside-char*)) + (if (>= i end) + (kont i j b1 b2 b3) + (let ((c (base64-decode-char (string-ref src i)))) + (cond + ((eqv? c *pad-char*) + (kont i j b1 b2 b3)) + ((eqv? c *outside-char*) + (lp (+ i 1) j b1 b2 b3)) + ((eqv? b1 *outside-char*) + (lp (+ i 1) j c b2 b3)) + ((eqv? b2 *outside-char*) + (lp (+ i 1) j b1 c b3)) + ((eqv? b3 *outside-char*) + (lp (+ i 1) j b1 b2 c)) + (else + (string-set! dst + j + (integer->char + (bitwise-ior (arithmetic-shift b1 2) + (extract-bit-field 2 4 b2)))) + (string-set! dst + (+ j 1) + (integer->char + (bitwise-ior + (arithmetic-shift (extract-bit-field 4 0 b2) 4) + (extract-bit-field 4 2 b3)))) + (string-set! dst + (+ j 2) + (integer->char + (bitwise-ior + (arithmetic-shift (extract-bit-field 2 0 b3) 6) + c))) + (lp (+ i 1) (+ j 3) + *outside-char* *outside-char* *outside-char*))))))) + +;; If requested, account for any "partial" results (i.e. trailing 2 or +;; 3 chars) by writing them into the destination (additional 1 or 2 +;; bytes) and returning the adjusted offset for how much data we've +;; written. +(define (base64-decode-finish dst j b1 b2 b3) + (cond + ((eqv? b1 *outside-char*) + j) + ((eqv? b2 *outside-char*) + (string-set! dst j (integer->char (arithmetic-shift b1 2))) + (+ j 1)) + (else + (string-set! dst + j + (integer->char + (bitwise-ior (arithmetic-shift b1 2) + (extract-bit-field 2 4 b2)))) + (cond + ((eqv? b3 *outside-char*) + (+ j 1)) + (else + (string-set! dst + (+ j 1) + (integer->char + (bitwise-ior + (arithmetic-shift (extract-bit-field 4 0 b2) 4) + (extract-bit-field 4 2 b3)))) + (+ j 2)))))) + +;; General port decoder: work in single blocks at a time to avoid +;; allocating memory (crucial for Scheme implementations that don't +;; allow large strings). +(define (base64-decode . o) + (let ((in (if (pair? o) (car o) (current-input-port))) + (out (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (current-output-port)))) + (let ((src (make-string decode-src-length)) + (dst (make-string decode-dst-length))) + (let lp ((offset 0)) + (let ((src-len (+ offset + (read-string! decode-src-length src in offset)))) + (cond + ((= src-len decode-src-length) + ;; read a full chunk: decode, write and loop + (base64-decode-string! + src 0 decode-src-length dst + (lambda (src-offset dst-len b1 b2 b3) + (cond + ((and (< src-offset src-len) + (eqv? #\= (string-ref src src-offset))) + ;; done + (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3))) + (write-string dst dst-len out))) + ((eqv? b1 *outside-char*) + (write-string dst dst-len out) + (lp 0)) + (else + (write-string dst dst-len out) + ;; one to three chars left in buffer + (string-set! src 0 (enc b1)) + (cond + ((eqv? b2 *outside-char*) + (lp 1)) + (else + (string-set! src 1 (enc b2)) + (cond + ((eqv? b3 *outside-char*) + (lp 2)) + (else + (string-set! src 2 (enc b3)) + (lp 3)))))))))) + (else + ;; end of source - just decode and write once + (base64-decode-string! + src 0 src-len dst + (lambda (src-offset dst-len b1 b2 b3) + (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3))) + (write-string dst dst-len out))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; encoding + +(define (base64-encode-string str) + (let* ((len (string-length str)) + (quot (quotient len 3)) + (rem (- len (* quot 3))) + (res-len (arithmetic-shift (+ quot (if (zero? rem) 0 1)) 2)) + (res (make-string res-len))) + (base64-encode-string! str 0 len res) + res)) + +(define (base64-encode-string! str start end res) + (let* ((res-len (string-length res)) + (limit (- end 2))) + (let lp ((i start) (j 0)) + (if (>= i limit) + (case (- end i) + ((1) + (let ((b1 (char->integer (string-ref str i)))) + (string-set! res j (enc (arithmetic-shift b1 -2))) + (string-set! res + (+ j 1) + (enc (arithmetic-shift (bitwise-and #b11 b1) 4))) + (string-set! res (+ j 2) #\=) + (string-set! res (+ j 3) #\=))) + ((2) + (let ((b1 (char->integer (string-ref str i))) + (b2 (char->integer (string-ref str (+ i 1))))) + (string-set! res j (enc (arithmetic-shift b1 -2))) + (string-set! res + (+ j 1) + (enc (bitwise-ior + (arithmetic-shift (bitwise-and #b11 b1) 4) + (extract-bit-field 4 4 b2)))) + (string-set! res + (+ j 2) + (enc (arithmetic-shift (extract-bit-field 4 0 b2) + 2))) + (string-set! res (+ j 3) #\=)))) + (let ((b1 (char->integer (string-ref str i))) + (b2 (char->integer (string-ref str (+ i 1)))) + (b3 (char->integer (string-ref str (+ i 2))))) + (string-set! res j (enc (arithmetic-shift b1 -2))) + (string-set! res + (+ j 1) + (enc (bitwise-ior + (arithmetic-shift (bitwise-and #b11 b1) 4) + (extract-bit-field 4 4 b2)))) + (string-set! res + (+ j 2) + (enc (bitwise-ior + (arithmetic-shift (extract-bit-field 4 0 b2) 2) + (extract-bit-field 2 6 b3)))) + (string-set! res (+ j 3) (enc (bitwise-and #b111111 b3))) + (lp (+ i 3) (+ j 4))))))) + +(define (base64-encode . o) + (let ((in (if (pair? o) (car o) (current-input-port))) + (out (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (current-output-port)))) + (let ((src (make-string encode-src-length)) + (dst (make-string + (arithmetic-shift (quotient encode-src-length 3) 2)))) + (let lp () + (let ((n (read-string! 2048 src in))) + (base64-encode-string! src 0 n dst) + (write-string dst (* 3 (quotient (+ n 3) 4)) out) + (if (= n 2048) + (lp))))))) + +(define (base64-encode-header encoding str . o) + (define (round4 i) (arithmetic-shift (arithmetic-shift i -2) 2)) + (let ((start-col (if (pair? o) (car o) 0)) + (max-col (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + *default-max-col*)) + (nl (if (and (pair? o) (pair? (cdr o)) (pair? (cdr (cdr o)))) + (car (cdr (cdr o))) + "\r\n"))) + (let* ((prefix (string-append "=?" encoding "?B?")) + (prefix-length (+ 2 (string-length prefix))) + (effective-max-col (round4 (- max-col prefix-length))) + (first-max-col (round4 (- effective-max-col start-col))) + (str (base64-encode-string str)) + (len (string-length str))) + (if (<= len first-max-col) + (string-append prefix str "?=") + (string-append + (if (positive? first-max-col) + (string-append + prefix (substring str 0 first-max-col) "?=" nl "\t" prefix) + "") + (string-concatenate (string-chop (substring str first-max-col len) + effective-max-col) + (string-append "?=" nl "\t" prefix)) + "?="))))) + diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c new file mode 100644 index 00000000..d193e3a7 --- /dev/null +++ b/lib/chibi/disasm.c @@ -0,0 +1,99 @@ +/* disasm.c -- optional debugging utilities */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" +#include "../../opt/opcode_names.h" + +#define SEXP_DISASM_MAX_DEPTH 8 +#define SEXP_DISASM_PAD_WIDTH 4 + +static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { + sexp tmp; + unsigned char *ip, opcode, i; + + if (sexp_procedurep(bc)) { + bc = sexp_procedure_code(bc); + } else if (sexp_opcodep(bc)) { + sexp_printf(ctx, out, "%s is a primitive\n", sexp_opcode_name(bc)); + return SEXP_VOID; + } else if (! sexp_bytecodep(bc)) { + return sexp_type_exception(ctx, self, SEXP_BYTECODE, bc); + } + if (! sexp_oportp(out)) { + return sexp_type_exception(ctx, self, SEXP_OPORT, out); + } + + for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) + sexp_write_char(ctx, ' ', out); + sexp_write_string(ctx, "-------------- ", out); + if (sexp_truep(sexp_bytecode_name(bc))) { + sexp_write(ctx, sexp_bytecode_name(bc), out); + sexp_write_char(ctx, ' ', out); + } + sexp_printf(ctx, out, "%p\n", bc); + + ip = sexp_bytecode_data(bc); + + loop: + for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) + sexp_write_char(ctx, ' ', out); + opcode = *ip++; + if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) { + sexp_printf(ctx, out, " %s ", reverse_opcode_names[opcode]); + } else { + sexp_printf(ctx, out, " %d ", opcode); + } + switch (opcode) { + case SEXP_OP_STACK_REF: + case SEXP_OP_LOCAL_REF: + case SEXP_OP_LOCAL_SET: + case SEXP_OP_CLOSURE_REF: + case SEXP_OP_JUMP: + case SEXP_OP_JUMP_UNLESS: + case SEXP_OP_TYPEP: + case SEXP_OP_FCALL0: + case SEXP_OP_FCALL1: + case SEXP_OP_FCALL2: + case SEXP_OP_FCALL3: + case SEXP_OP_FCALL4: + sexp_printf(ctx, out, "%ld", (long) ((sexp*)ip)[0]); + ip += sizeof(sexp); + break; + case SEXP_OP_SLOT_REF: + case SEXP_OP_SLOT_SET: + case SEXP_OP_MAKE: + ip += sizeof(sexp)*2; + break; + case SEXP_OP_GLOBAL_REF: + case SEXP_OP_GLOBAL_KNOWN_REF: + case SEXP_OP_TAIL_CALL: + case SEXP_OP_CALL: + case SEXP_OP_PUSH: + tmp = ((sexp*)ip)[0]; + if (((opcode == SEXP_OP_GLOBAL_REF) || (opcode == SEXP_OP_GLOBAL_KNOWN_REF)) + && sexp_pairp(tmp)) + tmp = sexp_car(tmp); + else if ((opcode == SEXP_OP_PUSH) && (sexp_pairp(tmp) || sexp_idp(tmp))) + sexp_write_char(ctx, '\'', out); + sexp_write(ctx, tmp, out); + ip += sizeof(sexp); + break; + } + sexp_write_char(ctx, '\n', out); + if ((opcode == SEXP_OP_PUSH) && (depth < SEXP_DISASM_MAX_DEPTH) + && (sexp_bytecodep(tmp) || sexp_procedurep(tmp))) + disasm(ctx, self, tmp, out, depth+1); + if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) + goto loop; + return SEXP_VOID; +} + +static sexp sexp_disasm (sexp ctx sexp_api_params(self, n), sexp bc, sexp out) { + return disasm(ctx, self, bc, out, 0); +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign_param(ctx, env, "disasm", 2, (sexp_proc1)sexp_disasm, "*current-output-port*"); + return SEXP_VOID; +} diff --git a/lib/chibi/disasm.module b/lib/chibi/disasm.module new file mode 100644 index 00000000..9017a4bc --- /dev/null +++ b/lib/chibi/disasm.module @@ -0,0 +1,5 @@ + +(define-module (chibi disasm) + (export disasm) + (import-immutable (scheme)) + (include-shared "disasm")) diff --git a/lib/chibi/filesystem.module b/lib/chibi/filesystem.module new file mode 100644 index 00000000..ecd4af32 --- /dev/null +++ b/lib/chibi/filesystem.module @@ -0,0 +1,27 @@ + +(define-module (chibi filesystem) + (export open-input-file-descriptor open-output-file-descriptor + duplicate-file-descriptor duplicate-file-descriptor-to + close-file-descriptor renumber-file-descriptor + delete-file link-file symbolic-link-file rename-file + directory-files directory-fold create-directory delete-directory + file-status + file-device file-inode + file-mode file-num-links + file-owner file-group + file-represented-device file-size + file-block-size file-num-blocks + file-access-time file-modification-time file-change-time + file-regular? file-directory? file-character? + file-block? file-fifo? file-link? + file-socket? file-exists? + get-file-descriptor-flags set-file-descriptor-flags! + get-file-descriptor-status set-file-descriptor-status! + open/read open/write open/read-write + open/create open/exclusive open/truncate + open/append open/non-block + is-a-tty?) + (import-immutable (scheme)) + (include-shared "filesystem") + (include "filesystem.scm")) + diff --git a/lib/chibi/filesystem.scm b/lib/chibi/filesystem.scm new file mode 100644 index 00000000..aa3fc69f --- /dev/null +++ b/lib/chibi/filesystem.scm @@ -0,0 +1,43 @@ +;; filesystem.scm -- additional filesystem utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (directory-fold dir kons knil) + (let ((dir (opendir dir))) + (let lp ((res knil)) + (let ((file (readdir dir))) + (if file (lp (kons (dirent-name file) res)) res))))) + +(define (directory-files dir) + (directory-fold dir cons '())) + +(define (renumber-file-descriptor old new) + (and (duplicate-file-descriptor-to old new) + (close-file-descriptor old))) + +(define (file-status file) + (if (string? file) (stat file) (fstat file))) + +(define (file-device x) (stat-dev (if (stat? x) x (file-status x)))) +(define (file-inode x) (stat-ino (if (stat? x) x (file-status x)))) +(define (file-mode x) (stat-mode (if (stat? x) x (file-status x)))) +(define (file-num-links x) (stat-nlinks (if (stat? x) x (file-status x)))) +(define (file-owner x) (stat-uid (if (stat? x) x (file-status x)))) +(define (file-group x) (stat-gid (if (stat? x) x (file-status x)))) +(define (file-represented-device x) (stat-rdev (if (stat? x) x (file-status x)))) +(define (file-size x) (stat-size (if (stat? x) x (file-status x)))) +(define (file-block-size x) (stat-blksize (if (stat? x) x (file-status x)))) +(define (file-num-blocks x) (stat-blocks (if (stat? x) x (file-status x)))) +(define (file-access-time x) (stat-atime (if (stat? x) x (file-status x)))) +(define (file-modification-time x) (stat-mtime (if (stat? x) x (file-status x)))) +(define (file-change-time x) (stat-ctime (if (stat? x) x (file-status x)))) + +(define (file-regular? x) (S_ISREG (file-mode x))) +(define (file-directory? x) (S_ISDIR (file-mode x))) +(define (file-character? x) (S_ISCHR (file-mode x))) +(define (file-block? x) (S_ISBLK (file-mode x))) +(define (file-fifo? x) (S_ISFIFO (file-mode x))) +(define (file-link? x) (S_ISLNK (file-mode x))) +(define (file-socket? x) (S_ISSOCK (file-mode x))) + +(define (file-exists? x) (and (file-status x) #t)) diff --git a/lib/chibi/filesystem.stub b/lib/chibi/filesystem.stub new file mode 100644 index 00000000..2aa66e50 --- /dev/null +++ b/lib/chibi/filesystem.stub @@ -0,0 +1,118 @@ + +(c-system-include "sys/types.h") +(c-system-include "unistd.h") +(c-system-include "dirent.h") +(c-system-include "fcntl.h") + +(define-c-type DIR + finalizer: closedir) + +(define-c-struct dirent + (string d_name dirent-name)) + +(define-c-struct stat + predicate: stat? + (dev_t st_dev stat-dev) + (ino_t st_ino stat-ino) + (mode_t st_mode stat-mode) + (nlink_t st_nlink stat-nlinks) + (uid_t st_uid stat-uid) + (gid_t st_gid stat-gid) + (dev_t st_rdev stat-rdev) + (off_t st_size stat-size) + (blksize_t st_blksize stat-blksize) + (blkcnt_t st_blocks stat-blocks) + (time_t st_atime stat-atime) + (time_t st_mtime stat-mtime) + (time_t st_ctime stat-ctime)) + +(define-c boolean S_ISREG (mode_t)) +(define-c boolean S_ISDIR (mode_t)) +(define-c boolean S_ISCHR (mode_t)) +(define-c boolean S_ISBLK (mode_t)) +(define-c boolean S_ISFIFO (mode_t)) +(define-c boolean S_ISLNK (mode_t)) +(define-c boolean S_ISSOCK (mode_t)) + +;;(define-c-const int ("S_IFMT")) +(define-c-const int (file/socket "S_IFSOCK")) +(define-c-const int (file/link "S_IFLNK")) +(define-c-const int (file/regular "S_IFREG")) +(define-c-const int (file/block "S_IFBLK")) +(define-c-const int (file/directory "S_IFDIR")) +(define-c-const int (file/character "S_IFCHR")) +(define-c-const int (file/fifo "S_IFIFO")) +(define-c-const int (file/suid "S_ISUID")) +(define-c-const int (file/sgid "S_ISGID")) +(define-c-const int (file/sticky "S_ISVTX")) +;;(define-c-const int ("S_IRWXU")) +(define-c-const int (perm/user-read "S_IRUSR")) +(define-c-const int (perm/user-write "S_IWUSR")) +(define-c-const int (perm/user-execute "S_IXUSR")) +;;(define-c-const int ("S_IRWXG")) +(define-c-const int (perm/group-read "S_IRGRP")) +(define-c-const int (perm/group-write "S_IWGRP")) +(define-c-const int (perm/group-execute "S_IXGRP")) +;;(define-c-const int ("S_IRWXO")) +(define-c-const int (perm/others-read "S_IROTH")) +(define-c-const int (perm/others-write "S_IWOTH")) +(define-c-const int (perm/others-execute "S_IXOTH")) + +(define-c errno stat (string (result stat))) +(define-c errno fstat (int (result stat))) +(define-c errno (file-link-status "lstat") (string (result stat))) + +(define-c input-port (open-input-file-descriptor "fdopen") + (int (value "r" string))) +(define-c output-port (open-output-file-descriptor "fdopen") + (int (value "w" string))) + +(define-c errno (delete-file "unlink") (string)) +(define-c errno (link-file "link") (string string)) +(define-c errno (symbolic-link-file "symlink") (string string)) +(define-c errno (rename-file "rename") (string string)) + +(define-c non-null-string (current-directory "getcwd") + ((result (array char (auto-expand arg1))) (value 256 int))) + +(define-c errno (create-directory "mkdir") (string int)) +(define-c errno (delete-directory "rmdir") (string)) + +(define-c (free DIR) opendir (string)) +(define-c dirent readdir ((link (pointer DIR)))) + +(define-c int (duplicate-file-descriptor "dup") (int)) +(define-c errno (duplicate-file-descriptor-to "dup2") (int int)) +(define-c errno (close-file-descriptor "close") (int)) + +(define-c errno (open-pipe "pipe") ((result (array int 2)))) +(define-c errno (make-fifo "mkfifo") (string (default #o644 int))) + +(define-c int (get-file-descriptor-flags "fcntl") + (int (value F_GETFD int))) +(define-c errno (set-file-descriptor-flags! "fcntl") + (int (value F_SETFD int) long)) + +(define-c int (get-file-descriptor-status "fcntl") + (int (value F_GETFL int))) +(define-c errno (set-file-descriptor-status! "fcntl") + (int (value F_SETFL int) long)) + +;; (define-c int (get-file-descriptor-lock "fcntl") +;; (int (value F_GETLK int) flock)) +;; (define-c errno (set-file-descriptor-lock! "fcntl") +;; (int (value F_SETLK int) flock)) +;; (define-c errno (try-set-file-descriptor-lock! "fcntl") +;; (int (value F_SETLKW int) flock)) + +(define-c-const int (open/read "O_RDONLY")) +(define-c-const int (open/write "O_WRONLY")) +(define-c-const int (open/read-write "O_RDWR")) +(define-c-const int (open/create "O_CREAT")) +(define-c-const int (open/exclusive "O_EXCL")) +(define-c-const int (open/truncate "O_TRUNC")) +(define-c-const int (open/append "O_APPEND")) +(define-c-const int (open/non-block "O_NONBLOCK")) + +(define-c boolean (is-a-tty? "isatty") (port-or-fd)) + diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c new file mode 100644 index 00000000..8b977f1a --- /dev/null +++ b/lib/chibi/heap-stats.c @@ -0,0 +1,120 @@ +/* heap-stats.c -- count or dump heap objects */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +#define SEXP_HEAP_VECTOR_DEPTH 1 + +extern sexp sexp_gc (sexp ctx, size_t *sum_freed); +extern sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x); + +static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) { + int i; + if ((!sexp_pointerp(x)) || sexp_symbolp(x) || sexp_stringp(x) + || sexp_flonump(x) || sexp_bignump(x)) { + sexp_write(ctx, x, out); + } else if (depth <= 0) { + goto print_name; + } else if (sexp_synclop(x)) { + sexp_write_string(ctx, "#", out); + } else if (sexp_pairp(x)) { + sexp_write_char(ctx, '(', out); + sexp_print_simple(ctx, sexp_car(x), out, depth-1); + sexp_write_string(ctx, " . ", out); + sexp_print_simple(ctx, sexp_cdr(x), out, depth-1); + sexp_write_char(ctx, ')', out); + } else if (sexp_vectorp(x)) { + sexp_write_string(ctx, "#(", out); + for (i=0; i0) + sexp_write_char(ctx, ' ', out); + sexp_print_simple(ctx, sexp_vector_ref(x, i), out, depth-1); + } + if (i", out); + } +} + +static sexp sexp_heap_walk (sexp ctx, int depth, int printp) { + size_t freed; + sexp_uint_t stats[256], hi_type=0, i; + sexp_heap h = sexp_context_heap(ctx); + sexp p, out=SEXP_FALSE; + sexp_free_list q, r; + char *end; + sexp_gc_var3(res, tmp, name); + + if (printp) + out = sexp_env_global_ref(sexp_context_env(ctx), + sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), + SEXP_FALSE); + + /* run gc once to remove unused variables */ + sexp_gc(ctx, &freed); + + /* initialize stats */ + for (i=0; i<256; i++) stats[i]=0; + + /* loop over each heap chunk */ + for ( ; h; h=h->next) { + p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair))); + q = h->free_list; + end = (char*)h->data + h->size; + while (((char*)p) < end) { + /* find the preceding and succeeding free list pointers */ + for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next) + ; + if ((char*)r == (char*)p) { /* this is a free block, skip */ + p = (sexp) (((char*)p) + r->size); + continue; + } + /* otherwise maybe print, then increment the stat and continue */ + if (sexp_oportp(out)) { + sexp_print_simple(ctx, p, out, depth); + sexp_write_char(ctx, '\n', out); + } + stats[sexp_pointer_tag(p)]++; + if (sexp_pointer_tag(p) > hi_type) + hi_type = sexp_pointer_tag(p); + p = (sexp) (((char*)p) + sexp_heap_align(sexp_allocated_bytes(ctx, p))); + } + } + + /* build and return results */ + sexp_gc_preserve3(ctx, res, tmp, name); + res = SEXP_NULL; + for (i=hi_type; i>0; i--) + if (stats[i]) { + name = sexp_intern(ctx, sexp_type_name_by_index(ctx, i), -1); + tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i])); + res = sexp_cons(ctx, tmp, res); + } + sexp_gc_release3(ctx); + return res; +} + +static sexp sexp_heap_stats (sexp ctx sexp_api_params(self, n)) { + return sexp_heap_walk(ctx, 0, 0); +} + +static sexp sexp_heap_dump (sexp ctx sexp_api_params(self, n), sexp depth) { + if (! sexp_fixnump(depth) || (sexp_unbox_fixnum(depth) < 0)) + return sexp_xtype_exception(ctx, self, "bad heap-dump depth", depth); + return sexp_heap_walk(ctx, sexp_unbox_fixnum(depth), 1); +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign(ctx, env, "heap-stats", 0, sexp_heap_stats); + sexp_define_foreign_opt(ctx, env, "heap-dump", 1, sexp_heap_dump, SEXP_ONE); + return SEXP_VOID; +} + diff --git a/lib/chibi/heap-stats.module b/lib/chibi/heap-stats.module new file mode 100644 index 00000000..c1599c35 --- /dev/null +++ b/lib/chibi/heap-stats.module @@ -0,0 +1,6 @@ + +(define-module (chibi heap-stats) + (export heap-stats heap-dump) + (import-immutable (scheme)) + (include-shared "heap-stats")) + diff --git a/lib/chibi/io.module b/lib/chibi/io.module new file mode 100644 index 00000000..ec765c04 --- /dev/null +++ b/lib/chibi/io.module @@ -0,0 +1,13 @@ + +(define-module (chibi io) + (export read-string read-string! write-string read-line write-line + port-fold port-fold-right port-map + port->list port->string-list port->sexp-list port->string + file-position set-file-position! seek/set seek/cur seek/end + make-custom-input-port make-custom-output-port + make-null-output-port make-broadcast-port make-concatenated-port + make-generated-input-port make-filtered-output-port + make-filtered-input-port) + (import-immutable (scheme)) + (include-shared "io/io") + (include "io/io.scm")) diff --git a/lib/chibi/io/io.scm b/lib/chibi/io/io.scm new file mode 100644 index 00000000..2d4da555 --- /dev/null +++ b/lib/chibi/io/io.scm @@ -0,0 +1,170 @@ +;; io.scm -- various input/output utilities +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define eof + (call-with-input-string " " + (lambda (in) (read-char in) (read-char in)))) + +(define (string-copy! dst start src from to) + (do ((i from (+ i 1)) (j start (+ j 1))) + ((>= i to)) + (string-set! dst j (string-ref src i)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; reading and writing + +(define (write-line str . o) + (let ((out (if (pair? o) (car o) (current-output-port)))) + (display str out) + (newline out))) + +(define (read-line . o) + (let ((in (if (pair? o) (car o) (current-input-port))) + (n (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) 8192))) + (let ((res (%read-line n in))) + (if (not res) + eof + (let ((len (string-length res))) + (if (and (> len 0) (eqv? #\newline (string-ref res (- len 1)))) + (if (and (> len 1) (eqv? #\return (string-ref res (- len 2)))) + (substring res 0 (- len 2)) + (substring res 0 (- len 1))) + res)))))) + +(define (read-string n . o) + (let ((in (if (pair? o) (car o) (current-input-port)))) + (let ((res (%read-string n in))) + (if (if (pair? res) (= 0 (car res)) #t) + eof + (cadr res))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; higher order port operations + +(define (port-fold kons knil . o) + (let ((read (if (pair? o) (car o) read)) + (in (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + (current-input-port)))) + (let lp ((acc knil)) + (let ((x (read in))) + (if (eof-object? x) acc (lp (kons x acc))))))) + +(define (port-fold-right kons knil . o) + (let ((read (if (pair? o) (car o) read)) + (in (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + (current-input-port)))) + (let lp () + (let ((x (read in))) + (if (eof-object? x) knil (kons x (lp))))))) + +(define (port-map fn . o) + (reverse (apply port-fold (lambda (x ls) (cons (fn x) ls)) '() o))) + +(define (port->list read in) + (port-map (lambda (x) x) read in)) + +(define (port->sexp-list in) + (port->list read in)) + +(define (port->string-list in) + (port->list read-line in)) + +(define (port->string in) + (string-concatenate (port->list (lambda (in) (read-string 1024 in)) in))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; custom port utilities + +(define (make-custom-input-port read . o) + (let ((seek (and (pair? o) (car o))) + (close (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (%make-custom-input-port read seek close))) + +(define (make-custom-output-port write . o) + (let ((seek (and (pair? o) (car o))) + (close (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (%make-custom-output-port write seek close))) + +(define (make-null-output-port) + (make-custom-output-port (lambda (str n) 0))) + +(define (make-broadcast-port . ports) + (make-custom-output-port + (lambda (str n) + (for-each (lambda (p) (write-string str n p)) ports) + n))) + +(define (make-filtered-output-port filter out) + (make-custom-output-port + (lambda (str n) + (let* ((len (string-length str)) + (s1 (if (= n len) str (substring str 0 n))) + (s2 (filter s1))) + (if (string? s2) + (write-string s2 (string-length s2) out)))))) + +(define (make-concatenated-port . ports) + (make-custom-input-port + (lambda (str n) + (if (null? ports) + 0 + (let lp ((i (read-string! str n (car ports)))) + (cond + ((>= i n) + i) + (else + (set! ports (cdr ports)) + (cond + ((null? ports) + i) + (else + (let* ((s (read-string (- n i) (car ports))) + (len (if (string? s) (string-length s) 0))) + (if (and (string? str) (> len 0)) + (string-copy! str i s 0 len)) + (lp (+ i len)))))))))))) + +(define (make-generated-input-port generator) + (let ((buf "") + (len 0) + (offset 0)) + (make-custom-input-port + (lambda (str n) + (cond + ((>= (- len offset) n) + (string-copy! str 0 buf offset (+ offset n)) + (set! offset (+ offset n)) + n) + (else + (string-copy! str 0 buf offset len) + (let lp ((i (- len offset))) + (set! buf (generator)) + (cond + ((not (string? buf)) + (set! buf "") + (set! len 0) + (set! offset 0) + (- n i)) + (else + (set! len (string-length buf)) + (set! offset 0) + (cond + ((>= (- len offset) (- n i)) + (string-copy! str i buf offset (+ offset (- n i))) + (set! offset (+ offset (- n i))) + n) + (else + (string-copy! str i buf offset len) + (lp (+ i (- len offset)))))))))))))) + +(define (make-filtered-input-port filter in) + (make-generated-input-port + (lambda () + (let ((res (read-string 1024 in))) + (if (string? res) (filter res) res))))) diff --git a/lib/chibi/io/io.stub b/lib/chibi/io/io.stub new file mode 100644 index 00000000..07450dc0 --- /dev/null +++ b/lib/chibi/io/io.stub @@ -0,0 +1,27 @@ + +(define-c non-null-string (%read-line "fgets") + ((result (array char arg1)) int (default (current-input-port) input-port))) + +(define-c size_t (%read-string "fread") + ((result (array char arg2)) (value 1 size_t) size_t (default (current-input-port) input-port))) + +(define-c size_t (read-string! "fread") + (string (value 1 size_t) size_t (default (current-input-port) input-port))) + +(define-c size_t (write-string "fwrite") + (string (value 1 size_t) size_t (default (current-output-port) output-port))) + +(define-c-const int (seek/set "SEEK_SET")) +(define-c-const int (seek/cur "SEEK_CUR")) +(define-c-const int (seek/end "SEEK_END")) + +(define-c long (file-position "ftell") (port)) +(define-c long (set-file-position! "fseek") (port long int)) + +(c-include "port.c") + +(define-c sexp (%make-custom-input-port "sexp_make_custom_input_port") + ((value ctx sexp) (value self sexp) sexp sexp sexp)) + +(define-c sexp (%make-custom-output-port "sexp_make_custom_output_port") + ((value ctx sexp) (value self sexp) sexp sexp sexp)) diff --git a/lib/chibi/io/port.c b/lib/chibi/io/port.c new file mode 100644 index 00000000..6aa6403a --- /dev/null +++ b/lib/chibi/io/port.c @@ -0,0 +1,201 @@ + +#include +#include + +#define SEXP_PORT_BUFFER_SIZE 1024 +#define SEXP_LAST_CONTEXT_CHECK_LIMIT 256 + +#define sexp_cookie_ctx(vec) sexp_vector_ref((sexp)vec, SEXP_ZERO) +#define sexp_cookie_buffer(vec) sexp_vector_ref((sexp)vec, SEXP_ONE) +#define sexp_cookie_read(vec) sexp_vector_ref((sexp)vec, SEXP_TWO) +#define sexp_cookie_write(vec) sexp_vector_ref((sexp)vec, SEXP_THREE) +#define sexp_cookie_seek(vec) sexp_vector_ref((sexp)vec, SEXP_FOUR) +#define sexp_cookie_close(vec) sexp_vector_ref((sexp)vec, SEXP_FIVE) + +#if ! SEXP_USE_BOEHM +static int sexp_in_heap_p (sexp_heap h, sexp p) { + for ( ; h; h = h->next) + if (((sexp)h < p) && (p < (sexp)((char*)h + h->size))) + return 1; + return 0; +} +#endif + +static sexp sexp_last_context (sexp ctx, sexp *cstack) { + sexp res=SEXP_FALSE, p; +#if ! SEXP_USE_BOEHM + sexp_sint_t i; + sexp_heap h = sexp_context_heap(ctx); + for (i=0; i sexp_string_length(sexp_cookie_buffer(vec))) + sexp_cookie_buffer(vec) = sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID); + args = sexp_list2(ctx, sexp_cookie_buffer(vec), sexp_make_fixnum(size)); + res = sexp_apply(ctx, sexp_cookie_read(vec), args); + sexp_gc_release2(ctx); + if (sexp_fixnump(res)) { + memcpy(buffer, sexp_string_data(sexp_cookie_buffer(vec)), sexp_unbox_fixnum(res)); + return sexp_unbox_fixnum(res); + } else { + return -1; + } +} + +#if SEXP_BSD +static int sexp_cookie_writer (void *cookie, const char *buffer, int size) +#else +static ssize_t sexp_cookie_writer (void *cookie, const char *buffer, size_t size) +#endif +{ + sexp vec = (sexp)cookie, ctx, res; + if (! sexp_procedurep(sexp_cookie_write(vec))) return -1; + sexp_gc_var2(ctx2, args); + ctx = sexp_cookie_ctx(vec); + ctx2 = sexp_last_context(ctx, (sexp*)&cookie); + sexp_gc_preserve2(ctx, ctx2, args); + if (size > sexp_string_length(sexp_cookie_buffer(vec))) + sexp_cookie_buffer(vec) = sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID); + memcpy(sexp_string_data(sexp_cookie_buffer(vec)), buffer, size); + args = sexp_list2(ctx, sexp_cookie_buffer(vec), sexp_make_fixnum(size)); + res = sexp_apply(ctx, sexp_cookie_write(vec), args); + sexp_gc_release2(ctx); + return (sexp_fixnump(res) ? sexp_unbox_fixnum(res) : -1); +} + +#if ! SEXP_BSD + +#ifdef __CYGWIN__ +#define off64_t off_t +#endif + +static int sexp_cookie_seeker (void *cookie, off64_t *position, int whence) { + sexp vec = (sexp)cookie, ctx, res; + if (! sexp_procedurep(sexp_cookie_seek(vec))) return -1; + sexp_gc_var2(ctx2, args); + ctx = sexp_cookie_ctx(vec); + ctx2 = sexp_last_context(ctx, (sexp*)&cookie); + sexp_gc_preserve2(ctx, ctx2, args); + args = sexp_make_integer(ctx, *position); + args = sexp_list2(ctx, args, sexp_make_fixnum(whence)); + res = sexp_apply(ctx, sexp_cookie_seek(vec), args); + if (sexp_fixnump(res)) + *position = sexp_unbox_fixnum(res); + sexp_gc_release2(ctx); + return sexp_fixnump(res); +} +#endif + +static int sexp_cookie_cleaner (void *cookie) { + sexp vec = (sexp)cookie, ctx, res; + if (! sexp_procedurep(sexp_cookie_close(vec))) return 0; + ctx = sexp_cookie_ctx(vec); + res = sexp_apply(ctx, sexp_cookie_close(vec), SEXP_NULL); + return (sexp_exceptionp(res) ? -1 : sexp_truep(res)); +} + +#if ! SEXP_BSD + +static cookie_io_functions_t sexp_cookie = { + .read = (cookie_read_function_t*)sexp_cookie_reader, + .write = (cookie_write_function_t*)sexp_cookie_writer, + .seek = (cookie_seek_function_t*)sexp_cookie_seeker, + .close = (cookie_close_function_t*)sexp_cookie_cleaner, +}; + +static cookie_io_functions_t sexp_cookie_no_seek = { + .read = (cookie_read_function_t*)sexp_cookie_reader, + .write = (cookie_write_function_t*)sexp_cookie_writer, + .seek = NULL, + .close = (cookie_close_function_t*)sexp_cookie_cleaner, +}; + +#endif + +#if SEXP_USE_STRING_STREAMS + +static sexp sexp_make_custom_port (sexp ctx, sexp self, char *mode, + sexp read, sexp write, + sexp seek, sexp close) { + FILE *in; + sexp res; + sexp_gc_var1(vec); + if (sexp_truep(read) && ! sexp_procedurep(read)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, read); + if (sexp_truep(write) && ! sexp_procedurep(write)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, write); + if (sexp_truep(seek) && ! sexp_procedurep(seek)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, seek); + if (sexp_truep(close) && ! sexp_procedurep(close)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, close); + sexp_gc_preserve1(ctx, vec); + vec = sexp_make_vector(ctx, SEXP_SIX, SEXP_VOID); + sexp_cookie_ctx(vec) = ctx; + sexp_cookie_buffer(vec) + = sexp_make_string(ctx, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE), SEXP_VOID); + sexp_cookie_read(vec) = read; + sexp_cookie_write(vec) = write; + sexp_cookie_seek(vec) = seek; + sexp_cookie_close(vec) = close; +#if SEXP_BSD + in = funopen(vec, + (sexp_procedurep(read) ? sexp_cookie_reader : NULL), + (sexp_procedurep(write) ? sexp_cookie_writer : NULL), + NULL, /* (sexp_procedurep(seek) ? sexp_cookie_reader : NULL), */ + (sexp_procedurep(close) ? sexp_cookie_cleaner : NULL)); +#else + in = fopencookie(vec, mode, (sexp_truep(seek) ? sexp_cookie : sexp_cookie_no_seek)); +#endif + if (! in) { + res = sexp_user_exception(ctx, self, "couldn't make custom port", read); + } else { + res = sexp_make_input_port(ctx, in, SEXP_FALSE); + sexp_port_cookie(res) = vec; /* for gc preserving */ + } + sexp_gc_release1(ctx); + return res; +} + +#else + +static sexp sexp_make_custom_port (sexp ctx, sexp self, + char *mode, sexp read, sexp write, + sexp seek, sexp close) { + return sexp_user_exception(ctx, self, "custom ports not supported in this configuration", SEXP_NULL); +} + +#endif + +static sexp sexp_make_custom_input_port (sexp ctx, sexp self, + sexp read, sexp seek, sexp close) { + return sexp_make_custom_port(ctx, self, "r", read, SEXP_FALSE, seek, close); +} + +static sexp sexp_make_custom_output_port (sexp ctx, sexp self, + sexp write, sexp seek, sexp close) { + sexp res = sexp_make_custom_port(ctx, self, "w", SEXP_FALSE, write, seek, close); + sexp_pointer_tag(res) = SEXP_OPORT; + return res; +} diff --git a/lib/chibi/loop.module b/lib/chibi/loop.module new file mode 100644 index 00000000..5b76daf8 --- /dev/null +++ b/lib/chibi/loop.module @@ -0,0 +1,9 @@ + +(define-module (chibi loop) + (export loop in-list in-lists in-port in-file up-from down-from + listing listing-reverse appending appending-reverse + summing multiplying in-string in-string-reverse + in-vector in-vector-reverse) + (import-immutable (scheme)) + (include "loop/loop.scm")) + diff --git a/lib/chibi/loop/loop.scm b/lib/chibi/loop/loop.scm new file mode 100644 index 00000000..09e12856 --- /dev/null +++ b/lib/chibi/loop/loop.scm @@ -0,0 +1,365 @@ +;;;; loop.scm - the chibi loop (aka foof-loop) +;; +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; The loop API is compatible with Taylor Campbell's foof-loop, but +;; the iterator API is different and subject to change. All loop +;; variables may be implicitly destructured with MATCH semantics. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (assoc-pred equal elt ls) + (and (pair? ls) + (if (equal elt (car (car ls))) + (car ls) + (assoc-pred equal elt (cdr ls))))) + +(define-syntax let-keyword-form + (syntax-rules () + ((let-keyword-form + ((labeled-arg-macro-name (positional-name . params))) + . body) + (let-syntax + ((labeled-arg-macro-name + (er-macro-transformer + (lambda (expr rename compare) + (let lp ((ls (cdr expr)) (named '()) (posns '())) + (cond + ((pair? ls) + (if (and (list? (car ls)) (compare (caar ls) (rename '=>))) + (lp (cdr ls) (cons (cdar ls) named) posns) + (lp (cdr ls) named (cons (car ls) posns)))) + (else + (let lp ((ls (syntax-quote params)) + (posns (reverse posns)) + (args '())) + (cond + ((null? ls) + (if (pair? posns) + (error "let-keyword-form: too many args" expr) + (cons (syntax-quote positional-name) (reverse args)))) + ((assoc-pred compare (caar ls) named) + => (lambda (x) (lp (cdr ls) posns (cons (cadr x) args)))) + ((pair? posns) + (lp (cdr ls) (cdr posns) (cons (car posns) args))) + (else + (lp (cdr ls) posns (cons (cadar ls) args)))))))))))) + . body)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax loop + (syntax-rules () + ;; unnamed, implicit recursion + ((loop (vars ...) body ...) + (%loop tmp-loop () () () () () (vars ...) body ... (tmp-loop))) + ;; named, explicit recursion + ((loop name (vars ...) body ...) + (%loop name () () () () () (vars ...) body ...)))) + +;; Main LOOP macro. Separate the variables from the iterator and +;; parameters, then walk through each parameter expanding the +;; bindings, and build the final form. + +(define-syntax %loop + (syntax-rules (=> for with let while until) + ;; automatic iteration + ((_ name l v c r f ((for var1 (iterator source ...)) rest ...) . body) + (iterator ((var1) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 var3 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2 var3) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 var3 var4 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2 var3 var4) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ;; do equivalents, with optional guards + ((_ name l (vars ...) (checks ...) r f ((with var init step guard) rest ...) . body) + (%loop name l (vars ... (var init step)) (checks ... (guard var)) r f (rest ...) . body)) + ((_ name l (vars ...) c r f ((with var init step) rest ...) . body) + (%loop name l (vars ... (var init step)) c r f (rest ...) . body)) + ((_ name l (vars ...) c r f ((with var init) rest ...) . body) + (%loop name l (vars ... (var init var)) c r f (rest ...) . body)) + ;; user-specified terminators + ((_ name l vars (checks ...) r f ((until expr) rest ...) . body) + (%loop name l vars (checks ... expr) r f (rest ...) . body)) + ((_ name l vars (checks ...) r f ((while expr) rest ...) . body) + (%loop name l vars (checks ... (not expr)) r f (rest ...) . body)) + ;; specify a default done? + ((_ name l v c r f ()) + (%loop name l v c r f () (#f #f))) + ((_ name l v c r f () () . body) + (%loop name l v c r f () (#f #f) . body)) + ;; final expansion + ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + => result + . body) + (let* (lets ...) + (letrec ((tmp (lambda (var ...) + (if (or checks ...) + (let-keyword-form ((name (tmp (var step) ...))) + (let (finals ...) result)) + (let (refs ...) + (let-keyword-form ((name (tmp (var step) ...))) + (if #f #f) + . body)))))) + (tmp init ...)))) + ;; unspecified return value case + ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + . body) + (%loop name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + => (if #f #f) . body)) + )) + +(define-syntax %loop-next + (syntax-rules () + ((_ (new-lets ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...) + name (lets ...) (vars ...) (checks ...) (refs ...) (finals ...) + . rest) + (%loop name (lets ... new-lets ...) (vars ... new-vars ...) + (checks ... new-checks ...) (refs ... new-refs ...) + (finals ... new-finals ...) + . rest)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Iterators + +;; Each gets passed two lists, those items left of the <- and those to +;; the right, followed by a NEXT and REST continuation. + +;; Should finish with +;; +;; (next (outer-vars ...) (cursor-vars ...) (done?-tests ...) +;; (loop-vars ...) (final-vars ...) . rest) +;; +;; OUTER-VARS: bound once outside the loop in a LET* +;; CURSOR-VARS: DO-style bindings of the form (name init update) +;; DONE?-TESTS: possibly empty list of forms that terminate the loop on #t +;; LOOP-VARS: inner variables, updated in parallel after the cursors +;; FINAL-VARS: final variables, bound only in the => result + +(define-syntax in-list ; called just "IN" in ITER + (syntax-rules () + ((in-list ((var) source) next . rest) + (in-list ((var cursor) source) next . rest)) + ((in-list ((var cursor) source) next . rest) + (in-list ((var cursor succ) source) next . rest)) + ((in-list ((var cursor succ) (source)) next . rest) + (next () ; outer let bindings + ((cursor source succ)) ; iterator, init, step + ((not (pair? cursor))) ; finish tests for iterator vars + ;; step variables and values + ((var (car cursor)) + (succ (cdr cursor))) + () ; final result bindings + . rest)) + ((in-list ((var cursor succ) (source step)) next . rest) + (next () + ((cursor source succ)) + ((not (pair? cursor))) + ((var (car cursor)) + (succ (step cursor))) + () + . rest)))) + +;; Iterator from Taylor R. Campbell. If you know the number of lists +;; ahead of time it's much more efficient to iterate over each one +;; separately. +(define-syntax in-lists + (syntax-rules () + ((in-lists ((elts) lol) next . rest) + (in-lists ((elts pairs) lol) next . rest)) + ((in-lists ((elts pairs) lol) next . rest) + (in-lists ((elts pairs succ) lol) next . rest)) + ((in-lists ((elts pairs succ) (lol)) next . rest) + (in-lists ((elts pairs succ) (lol cdr)) next . rest)) + ((in-lists ((elts pairs succ) (lol)) next . rest) + (in-lists ((elts pairs succ) (lol cdr)) next . rest)) + ((in-lists ((elts pairs succ) (lol step)) next . rest) + (in-lists ((elts pairs succ) (lol step null?)) next . rest)) + ((in-lists ((elts pairs succ) (lol step done?)) next . rest) + (next () + ((pairs lol succ)) + ((let lp ((ls pairs)) ; an in-lined ANY + (and (pair? ls) (if (done? (car ls)) #t (lp (cdr ls)))))) + ((elts (map car pairs)) + (succ (map step pairs))) + () + . rest)) + )) + +(define-syntax define-in-indexed + (syntax-rules () + ((define-in-indexed in-type in-type-reverse length ref) + (begin + (define-syntax in-type + (syntax-rules () + ((in-type ls next . rest) + (%in-idx >= + 0 (length tmp) ref tmp ls next . rest)))) + (define-syntax in-type-reverse + (syntax-rules () + ((in-type-reverse ls next . rest) + (%in-idx < - (- (length tmp) 1) 0 ref tmp ls next . rest)))) + )))) + +(define-in-indexed in-string in-string-reverse string-length string-ref) +(define-in-indexed in-vector in-vector-reverse vector-length vector-ref) + +;; helper for the above string and vector iterators +(define-syntax %in-idx + (syntax-rules () + ;; cmp inc start end ref + ((%in-idx ge + s e r tmp-vec ((var) (vec ...)) next . rest) + (%in-idx ge + s e r tmp-vec ((var vec-index) (vec ...)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec s e 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec from e 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from to)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec from to 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from to step)) next . rest) + (next ((tmp-vec vec) (end to)) + ((index from (+ index step))) + ((ge index end)) + ((var (r tmp-vec index))) + () + . rest)) + )) + +(define-syntax in-port + (syntax-rules () + ((in-port ((var) source) next . rest) + (in-port ((var p) source) next . rest)) + ((in-port ((var p) ()) next . rest) + (in-port ((var p) ((current-input-port))) next . rest)) + ((in-port ((var p) (port)) next . rest) + (in-port ((var p) (port read-char)) next . rest)) + ((in-port ((var p) (port read-char)) next . rest) + (in-port ((var p) (port read-char eof-object?)) next . rest)) + ((in-port ((var p) (port reader eof?)) next . rest) + (next ((p port) (r reader) (e? eof?)) + ((var (r p) (r p))) + ((e? var)) + () + () + . rest)))) + +(define-syntax in-file + (syntax-rules () + ((in-file ((var) source) next . rest) + (in-file ((var p) source) next . rest)) + ((in-file ((var p) (file)) next . rest) + (in-file ((var p) (file read-char)) next . rest)) + ((in-file ((var p) (file reader)) next . rest) + (in-file ((var p) (file reader eof-object?)) next . rest)) + ((in-file ((var p) (file reader eof?)) next . rest) + (next ((p (open-input-file file)) (r reader) (e? eof?)) + ((var (r p) (r p))) + ((e? var)) + () + ((dummy (close-input-port p))) + . rest)))) + +(define-syntax up-from + (syntax-rules (to by) + ((up-from (() . args) next . rest) + (up-from ((var) . args) next . rest)) + ((up-from ((var) (start (to limit) (by step))) next . rest) + (next ((s start) (l limit) (e step)) + ((var s (+ var e))) + ((>= var l)) + () + () + . rest)) + ((up-from ((var) (start (to limit))) next . rest) + (next ((s start) (l limit)) + ((var s (+ var 1))) + ((>= var l)) + () + () + . rest)) + ((up-from ((var) (start (by step))) next . rest) + (next ((s start) (e step)) ((var s (+ var e))) () () () . rest)) + ((up-from ((var) (start)) next . rest) + (next ((s start)) ((var s (+ var 1))) () () () . rest)) + )) + +(define-syntax down-from + (syntax-rules (to by) + ((down-from (() . args) next . rest) + (down-from ((var) . args) next . rest)) + ((down-from ((var) (start (to limit) (by step))) next . rest) + (next ((s start) (l limit) (e step)) + ((var (- s e) (- var e))) + ((< var l)) + () + () + . rest)) + ((down-from ((var) (start (to limit))) next . rest) + (next ((s start) (l limit)) + ((var (- s 1) (- var 1))) + ((< var l)) + () + () + . rest)) + ((down-from ((var) (start (by step))) next . rest) + (next ((s start) (e step)) ((var (- s e) (- var e))) () () () + . rest)) + ((down-from ((var) (start)) next . rest) + (next ((s start)) ((var (- s 1) (- var 1))) () () () + . rest)) + )) + +(define-syntax accumulating + (syntax-rules (initial if) + ((accumulating (kons final init) ((var) . x) next . rest) + (accumulating (kons final init) ((var cursor) . x) next . rest)) + ((accumulating (kons final init) ((var cursor) ((initial i) . x)) n . rest) + (accumulating (kons final i) ((var cursor) x) n . rest)) + ((accumulating (kons final init) ((var cursor) (expr (if check))) n . rest) + (n ((tmp-kons kons)) + ((cursor '() (if check (tmp-kons expr cursor) cursor))) + () + () + ((var (final cursor))) + . rest)) + ((accumulating (kons final init) ((var cursor) (expr)) n . rest) + (n ((tmp-kons kons)) + ((cursor '() (tmp-kons expr cursor))) + () + () + ((var (final cursor))) + . rest)))) + +(define-syntax listing + (syntax-rules () + ((listing args next . rest) + (accumulating (cons reverse '()) args next . rest)))) + +(define-syntax listing-reverse + (syntax-rules () + ((listing-reverse args next . rest) + (accumulating (cons (lambda (x) x) '()) args next . rest)))) + +(define (append-reverse rev tail) + (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail)))) + +(define-syntax appending + (syntax-rules () + ((appending args next . rest) + (accumulating (append-reverse reverse '()) args next . rest)))) + +(define-syntax appending-reverse + (syntax-rules () + ((appending-reverse args next . rest) + (accumulating (append-reverse (lambda (x) x) '()) args next . rest)))) + +(define-syntax summing + (syntax-rules () + ((summing args next . rest) + (accumulating (+ (lambda (x) x) 0) args next . rest)))) + +(define-syntax multiplying + (syntax-rules () + ((multiplying args next . rest) + (accumulating (* (lambda (x) x) 1) args next . rest)))) diff --git a/lib/chibi/match.module b/lib/chibi/match.module new file mode 100644 index 00000000..1366176a --- /dev/null +++ b/lib/chibi/match.module @@ -0,0 +1,6 @@ + +(define-module (chibi match) + (export match match-lambda match-lambda* match-let match-letrec match-let*) + (import-immutable (scheme)) + (include "match/match.scm")) + diff --git a/lib/chibi/match/match.scm b/lib/chibi/match/match.scm new file mode 100644 index 00000000..f4eb173d --- /dev/null +++ b/lib/chibi/match/match.scm @@ -0,0 +1,683 @@ +;;;; match.scm -- portable hygienic pattern matcher +;; +;; This code is written by Alex Shinn and placed in the +;; Public Domain. All warranties are disclaimed. + +;; This is a full superset of the popular MATCH package by Andrew +;; Wright, written in fully portable SYNTAX-RULES (R5RS only, breaks +;; in R6RS SYNTAX-RULES), and thus preserving hygiene. + +;; This is a simple generative pattern matcher - each pattern is +;; expanded into the required tests, calling a failure continuation if +;; the tests fail. This makes the logic easy to follow and extend, +;; but produces sub-optimal code in cases where you have many similar +;; clauses due to repeating the same tests. Nonetheless a smart +;; compiler should be able to remove the redundant tests. For +;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance +;; hit. + +;; The original version was written on 2006/11/29 and described in the +;; following Usenet post: +;; http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd +;; and is still available at +;; http://synthcode.com/scheme/match-simple.scm +;; It's just 80 lines for the core MATCH, and an extra 40 lines for +;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar. +;; +;; A variant of this file which uses COND-EXPAND in a few places for +;; performance can be found at +;; http://synthcode.com/scheme/match-cond-expand.scm +;; +;; 2009/11/25 - adding `***' tree search patterns +;; 2008/03/20 - fixing bug where (a ...) matched non-lists +;; 2008/03/15 - removing redundant check in vector patterns +;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell) +;; 2007/09/04 - fixing quasiquote patterns +;; 2007/07/21 - allowing ellipse patterns in non-final list positions +;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse +;; (thanks to Taylor Campbell) +;; 2007/04/08 - clean up, commenting +;; 2006/12/24 - bugfixes +;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set! + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; force compile-time syntax errors with useful messages + +(define-syntax match-syntax-error + (syntax-rules () + ((_) (match-syntax-error "invalid match-syntax-error usage")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; The basic interface. MATCH just performs some basic syntax +;; validation, binds the match expression to a temporary variable `v', +;; and passes it on to MATCH-NEXT. It's a constant throughout the +;; code below that the binding `v' is a direct variable reference, not +;; an expression. + +(define-syntax match + (syntax-rules () + ((match) + (match-syntax-error "missing match expression")) + ((match atom) + (match-syntax-error "no match clauses")) + ((match (app ...) (pat . body) ...) + (let ((v (app ...))) + (match-next v ((app ...) (set! (app ...))) (pat . body) ...))) + ((match #(vec ...) (pat . body) ...) + (let ((v #(vec ...))) + (match-next v (v (set! v)) (pat . body) ...))) + ((match atom (pat . body) ...) + (match-next atom (atom (set! atom)) (pat . body) ...)) + )) + +;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure +;; thunk, which is expanded by recursing MATCH-NEXT on the remaining +;; clauses. `g+s' is a list of two elements, the get! and set! +;; expressions respectively. + +(define-syntax match-next + (syntax-rules (=>) + ;; no more clauses, the match failed + ((match-next v g+s) + (error 'match "no matching pattern")) + ;; named failure continuation + ((match-next v g+s (pat (=> failure) . body) . rest) + (let ((failure (lambda () (match-next v g+s . rest)))) + ;; match-one analyzes the pattern for us + (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ()))) + ;; anonymous failure continuation, give it a dummy name + ((match-next v g+s (pat . body) . rest) + (match-next v g+s (pat (=> failure) . body) . rest)))) + +;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to +;; MATCH-TWO. + +(define-syntax match-one + (syntax-rules () + ;; If it's a list of two or more values, check to see if the + ;; second one is an ellipse and handle accordingly, otherwise go + ;; to MATCH-TWO. + ((match-one v (p q . r) g+s sk fk i) + (match-check-ellipse + q + (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()) + (match-two v (p q . r) g+s sk fk i))) + ;; Go directly to MATCH-TWO. + ((match-one . x) + (match-two . x)))) + +;; This is the guts of the pattern matcher. We are passed a lot of +;; information in the form: +;; +;; (match-two var pattern getter setter success-k fail-k (ids ...)) +;; +;; usually abbreviated +;; +;; (match-two v p g+s sk fk i) +;; +;; where VAR is the symbol name of the current variable we are +;; matching, PATTERN is the current pattern, getter and setter are the +;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding +;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure +;; continuation (which is just a thunk call and is thus safe to expand +;; multiple times) and IDS are the list of identifiers bound in the +;; pattern so far. + +(define-syntax match-two + (syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!) + ((match-two v () g+s (sk ...) fk i) + (if (null? v) (sk ... i) fk)) + ((match-two v (quote p) g+s (sk ...) fk i) + (if (equal? v 'p) (sk ... i) fk)) + ((match-two v (quasiquote p) . x) + (match-quasiquote v p . x)) + ((match-two v (and) g+s (sk ...) fk i) (sk ... i)) + ((match-two v (and p q ...) g+s sk fk i) + (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i)) + ((match-two v (or) g+s sk fk i) fk) + ((match-two v (or p) . x) + (match-one v p . x)) + ((match-two v (or p ...) g+s sk fk i) + (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ())) + ((match-two v (not p) g+s (sk ...) fk i) + (match-one v p g+s (match-drop-ids fk) (sk ... i) i)) + ((match-two v (get! getter) (g s) (sk ...) fk i) + (let ((getter (lambda () g))) (sk ... i))) + ((match-two v (set! setter) (g (s ...)) (sk ...) fk i) + (let ((setter (lambda (x) (s ... x)))) (sk ... i))) + ((match-two v (? pred . p) g+s sk fk i) + (if (pred v) (match-one v (and . p) g+s sk fk i) fk)) + ((match-two v (= proc p) . x) + (let ((w (proc v))) (match-one w p . x))) + ((match-two v (p ___ . r) g+s sk fk i) + (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ())) + ((match-two v (p) g+s sk fk i) + (if (and (pair? v) (null? (cdr v))) + (let ((w (car v))) + (match-one w p ((car v) (set-car! v)) sk fk i)) + fk)) + ((match-two v (p *** q) g+s sk fk i) + (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ())) + ((match-two v (p *** . q) g+s sk fk i) + (match-syntax-error "invalid use of ***" (p *** . q))) + ((match-two v ($ rec p ...) g+s sk fk i) + (if (is-a? v rec) + (match-record-refs v rec 0 (p ...) g+s sk fk i) + fk)) + ((match-two v (p . q) g+s sk fk i) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-one w p ((car v) (set-car! v)) + (match-one x q ((cdr v) (set-cdr! v)) sk fk) + fk + i)) + fk)) + ((match-two v #(p ...) g+s . x) + (match-vector v 0 () (p ...) . x)) + ((match-two v _ g+s (sk ...) fk i) (sk ... i)) + ;; Not a pair or vector or special literal, test to see if it's a + ;; new symbol, in which case we just bind it, or if it's an + ;; already bound symbol or some other literal, in which case we + ;; compare it with EQUAL?. + ((match-two v x g+s (sk ...) fk (id ...)) + (let-syntax + ((new-sym? + (syntax-rules (id ...) + ((new-sym? x sk2 fk2) sk2) + ((new-sym? y sk2 fk2) fk2)))) + (new-sym? random-sym-to-match + (let ((x v)) (sk ... (id ... x))) + (if (equal? v x) (sk ... (id ...)) fk)))) + )) + +;; QUASIQUOTE patterns + +(define-syntax match-quasiquote + (syntax-rules (unquote unquote-splicing quasiquote) + ((_ v (unquote p) g+s sk fk i) + (match-one v p g+s sk fk i)) + ((_ v ((unquote-splicing p) . rest) g+s sk fk i) + (if (pair? v) + (match-one v + (p . tmp) + (match-quasiquote tmp rest g+s sk fk) + fk + i) + fk)) + ((_ v (quasiquote p) g+s sk fk i . depth) + (match-quasiquote v p g+s sk fk i #f . depth)) + ((_ v (unquote p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (unquote-splicing p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (p . q) g+s sk fk i . depth) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-quasiquote + w p g+s + (match-quasiquote-step x q g+s sk fk depth) + fk i . depth)) + fk)) + ((_ v #(elt ...) g+s sk fk i . depth) + (if (vector? v) + (let ((ls (vector->list v))) + (match-quasiquote ls (elt ...) g+s sk fk i . depth)) + fk)) + ((_ v x g+s sk fk i . depth) + (match-one v 'x g+s sk fk i)))) + +(define-syntax match-quasiquote-step + (syntax-rules () + ((match-quasiquote-step x q g+s sk fk depth i) + (match-quasiquote x q g+s sk fk i . depth)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Utilities + +;; Takes two values and just expands into the first. +(define-syntax match-drop-ids + (syntax-rules () + ((_ expr ids ...) expr))) + +(define-syntax match-drop-first-arg + (syntax-rules () + ((_ arg expr) expr))) + +;; To expand an OR group we try each clause in succession, passing the +;; first that succeeds to the success continuation. On failure for +;; any clause, we just try the next clause, finally resorting to the +;; failure continuation fk if all clauses fail. The only trick is +;; that we want to unify the identifiers, so that the success +;; continuation can refer to a variable from any of the OR clauses. + +(define-syntax match-gen-or + (syntax-rules () + ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...)) + (let ((sk2 (lambda (id ...) (sk ... (i ... id ...))))) + (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...)))))) + +(define-syntax match-gen-or-step + (syntax-rules () + ((_ v () g+s sk fk . x) + ;; no OR clauses, call the failure continuation + fk) + ((_ v (p) . x) + ;; last (or only) OR clause, just expand normally + (match-one v p . x)) + ((_ v (p . q) g+s sk fk i) + ;; match one and try the remaining on failure + (match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i)) + )) + +;; We match a pattern (p ...) by matching the pattern p in a loop on +;; each element of the variable, accumulating the bound ids into lists. + +;; Look at the body of the simple case - it's just a named let loop, +;; matching each element in turn to the same pattern. The only trick +;; is that we want to keep track of the lists of each extracted id, so +;; when the loop recurses we cons the ids onto their respective list +;; variables, and on success we bind the ids (what the user input and +;; expects to see in the success body) to the reversed accumulated +;; list IDs. + +(define-syntax match-gen-ellipses + (syntax-rules () + ((_ v p () g+s (sk ...) fk i ((id id-ls) ...)) + (match-check-identifier p + ;; simplest case equivalent to (p ...), just bind the list + (let ((p v)) + (if (list? p) + (sk ... i) + fk)) + ;; simple case, match all elements of the list + (let loop ((ls v) (id-ls '()) ...) + (cond + ((null? ls) + (let ((id (reverse id-ls)) ...) (sk ... i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids (loop (cdr ls) (cons id id-ls) ...)) + fk i))) + (else + fk))))) + ((_ v p r g+s (sk ...) fk i ((id id-ls) ...)) + ;; general case, trailing patterns to match, keep track of the + ;; remaining list length so we don't need any backtracking + (match-verify-no-ellipses + r + (let* ((tail-len (length 'r)) + (ls v) + (len (length ls))) + (if (< len tail-len) + fk + (let loop ((ls ls) (n len) (id-ls '()) ...) + (cond + ((= n tail-len) + (let ((id (reverse id-ls)) ...) + (match-one ls r (#f #f) (sk ... i) fk i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids + (loop (cdr ls) (- n 1) (cons id id-ls) ...)) + fk + i))) + (else + fk))))))))) + +;; This is just a safety check. Although unlike syntax-rules we allow +;; trailing patterns after an ellipses, we explicitly disable multiple +;; ellipses at the same level. This is because in the general case +;; such patterns are exponential in the number of ellipses, and we +;; don't want to make it easy to construct very expensive operations +;; with simple looking patterns. For example, it would be O(n^2) for +;; patterns like (a ... b ...) because we must consider every trailing +;; element for every possible break for the leading "a ...". + +(define-syntax match-verify-no-ellipses + (syntax-rules () + ((_ (x . y) sk) + (match-check-ellipse + x + (match-syntax-error + "multiple ellipse patterns not allowed at same level") + (match-verify-no-ellipses y sk))) + ((_ () sk) + sk) + ((_ x sk) + (match-syntax-error "dotted tail not allowed after ellipse" x)))) + +;; Matching a tree search pattern is only slightly more complicated. +;; Here we allow patterns of the form +;; +;; (x *** y) +;; +;; to represent the pattern y located somewhere in a tree where the +;; path from the current object to y can be seen as a list of the form +;; (X ...). Y can immediately match the current object in which case +;; the path is the empty list. In a sense it's a 2-dimensional +;; version of the ... pattern. +;; +;; As a common case the pattern (_ *** y) can be used to search for Y +;; anywhere in a tree, regardless of the path used. +;; +;; To implement the search, we use two recursive procedures. TRY +;; attempts to match Y once, and on success it calls the normal SK on +;; the accumulated list ids as in MATCH-GEN-ELLIPSES. On failure, we +;; call NEXT which first checks if the current value is a list +;; beginning with X, then calls TRY on each remaining element of the +;; list. Since TRY will recursively call NEXT again on failure, this +;; effects a full depth-first search. +;; +;; The failure continuation throughout is a jump to the next step in +;; the tree search, initialized with the original failure continuation +;; FK. + +(define-syntax match-gen-search + (syntax-rules () + ((match-gen-search v p q g+s sk fk i ((id id-ls) ...)) + (letrec ((try (lambda (w fail id-ls ...) + (match-one w q g+s + (match-drop-ids + (let ((id (reverse id-ls)) ...) + sk)) + (next w fail id-ls ...) i))) + (next (lambda (w fail id-ls ...) + (if (not (pair? w)) + (fail) + (let ((u (car w))) + (match-one + u p ((car w) (set-car! w)) + (match-drop-ids + ;; accumulate the head variables from + ;; the p pattern, and loop over the tail + (let ((id-ls (cons id id-ls)) ...) + (let lp ((ls (cdr w))) + (if (pair? ls) + (try (car ls) + (lambda () (lp (cdr ls))) + id-ls ...) + (fail))))) + (fail) i)))))) + ;; the initial id-ls binding here is a dummy to get the right + ;; number of '()s + (let ((id-ls '()) ...) + (try v (lambda () fk) id-ls ...)))))) + +;; Vector patterns are just more of the same, with the slight +;; exception that we pass around the current vector index being +;; matched. + +(define-syntax match-vector + (syntax-rules (___) + ((_ v n pats (p q) . x) + (match-check-ellipse q + (match-gen-vector-ellipses v n pats p . x) + (match-vector-two v n pats (p q) . x))) + ((_ v n pats (p ___) sk fk i) + (match-gen-vector-ellipses v n pats p sk fk i)) + ((_ . x) + (match-vector-two . x)))) + +;; Check the exact vector length, then check each element in turn. + +(define-syntax match-vector-two + (syntax-rules () + ((_ v n ((pat index) ...) () sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (= len n) + (match-vector-step v ((pat index) ...) sk fk i) + fk)) + fk)) + ((_ v n (pats ...) (p . q) . x) + (match-vector v (+ n 1) (pats ... (p n)) q . x)))) + +(define-syntax match-vector-step + (syntax-rules () + ((_ v () (sk ...) fk i) (sk ... i)) + ((_ v ((pat index) . rest) sk fk i) + (let ((w (vector-ref v index))) + (match-one w pat ((vector-ref v index) (vector-set! v index)) + (match-vector-step v rest sk fk) + fk i))))) + +;; With a vector ellipse pattern we first check to see if the vector +;; length is at least the required length. + +(define-syntax match-gen-vector-ellipses + (syntax-rules () + ((_ v n ((pat index) ...) p sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (>= len n) + (match-vector-step v ((pat index) ...) + (match-vector-tail v p n len sk fk) + fk i) + fk)) + fk)))) + +(define-syntax match-vector-tail + (syntax-rules () + ((_ v p n len sk fk i) + (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ())))) + +(define-syntax match-vector-tail-two + (syntax-rules () + ((_ v p n len (sk ...) fk i ((id id-ls) ...)) + (let loop ((j n) (id-ls '()) ...) + (if (>= j len) + (let ((id (reverse id-ls)) ...) (sk ... i)) + (let ((w (vector-ref v j))) + (match-one w p ((vector-ref v j) (vetor-set! v j)) + (match-drop-ids (loop (+ j 1) (cons id id-ls) ...)) + fk i))))))) + +(define-syntax match-record-refs + (syntax-rules () + ((_ v rec n (p . q) g+s sk fk i) + (let ((w (slot-ref rec v n))) + (match-one w p ((slot-ref rec v n) (slot-set! rec v n)) + (match-record-refs v rec (+ n 1) q g+s sk fk) fk i))) + ((_ v rec n () g+s (sk ...) fk i) + (sk ... i)))) + +;; Extract all identifiers in a pattern. A little more complicated +;; than just looking for symbols, we need to ignore special keywords +;; and non-pattern forms (such as the predicate expression in ? +;; patterns), and also ignore previously bound identifiers. +;; +;; Calls the continuation with all new vars as a list of the form +;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely +;; pair with the original variable (e.g. it's used in the ellipse +;; generation for list variables). +;; +;; (match-extract-vars pattern continuation (ids ...) (new-vars ...)) + +(define-syntax match-extract-vars + (syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!) + ((match-extract-vars (? pred . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars ($ rec . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (= proc p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (quote x) (k ...) i v) + (k ... v)) + ((match-extract-vars (quasiquote x) k i v) + (match-extract-quasiquote-vars x k i v (#t))) + ((match-extract-vars (and . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (or . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (not . p) . x) + (match-extract-vars p . x)) + ;; A non-keyword pair, expand the CAR with a continuation to + ;; expand the CDR. + ((match-extract-vars (p q . r) k i v) + (match-check-ellipse + q + (match-extract-vars (p . r) k i v) + (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ()))) + ((match-extract-vars (p . q) k i v) + (match-extract-vars p (match-extract-vars-step q k i v) i ())) + ((match-extract-vars #(p ...) . x) + (match-extract-vars (p ...) . x)) + ((match-extract-vars _ (k ...) i v) (k ... v)) + ((match-extract-vars ___ (k ...) i v) (k ... v)) + ((match-extract-vars *** (k ...) i v) (k ... v)) + ;; This is the main part, the only place where we might add a new + ;; var if it's an unbound symbol. + ((match-extract-vars p (k ...) (i ...) v) + (let-syntax + ((new-sym? + (syntax-rules (i ...) + ((new-sym? p sk fk) sk) + ((new-sym? x sk fk) fk)))) + (new-sym? random-sym-to-match + (k ... ((p p-ls) . v)) + (k ... v)))) + )) + +;; Stepper used in the above so it can expand the CAR and CDR +;; separately. + +(define-syntax match-extract-vars-step + (syntax-rules () + ((_ p k i v ((v2 v2-ls) ...)) + (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v))) + )) + +(define-syntax match-extract-quasiquote-vars + (syntax-rules (quasiquote unquote unquote-splicing) + ((match-extract-quasiquote-vars (quasiquote x) k i v d) + (match-extract-quasiquote-vars x k i v (#t . d))) + ((match-extract-quasiquote-vars (unquote-splicing x) k i v d) + (match-extract-quasiquote-vars (unquote x) k i v d)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t)) + (match-extract-vars x k i v)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t . d)) + (match-extract-quasiquote-vars x k i v d)) + ((match-extract-quasiquote-vars (x . y) k i v (#t . d)) + (match-extract-quasiquote-vars + x + (match-extract-quasiquote-vars-step y k i v d) i ())) + ((match-extract-quasiquote-vars #(x ...) k i v (#t . d)) + (match-extract-quasiquote-vars (x ...) k i v d)) + ((match-extract-quasiquote-vars x (k ...) i v (#t . d)) + (k ... v)) + )) + +(define-syntax match-extract-quasiquote-vars-step + (syntax-rules () + ((_ x k i v d ((v2 v2-ls) ...)) + (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d)) + )) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Gimme some sugar baby. + +(define-syntax match-lambda + (syntax-rules () + ((_ clause ...) (lambda (expr) (match expr clause ...))))) + +(define-syntax match-lambda* + (syntax-rules () + ((_ clause ...) (lambda expr (match expr clause ...))))) + +(define-syntax match-let + (syntax-rules () + ((_ (vars ...) . body) + (match-let/helper let () () (vars ...) . body)) + ((_ loop . rest) + (match-named-let loop () . rest)))) + +(define-syntax match-letrec + (syntax-rules () + ((_ vars . body) (match-let/helper letrec () () vars . body)))) + +(define-syntax match-let/helper + (syntax-rules () + ((_ let ((var expr) ...) () () . body) + (let ((var expr) ...) . body)) + ((_ let ((var expr) ...) ((pat tmp) ...) () . body) + (let ((var expr) ...) + (match-let* ((pat tmp) ...) + . body))) + ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((a expr) . rest) . body) + (match-let/helper let (v ... (a expr)) (p ...) rest . body)))) + +(define-syntax match-named-let + (syntax-rules () + ((_ loop ((pat expr var) ...) () . body) + (let loop ((var expr) ...) + (match-let ((pat var) ...) + . body))) + ((_ loop (v ...) ((pat expr) . rest) . body) + (match-named-let loop (v ... (pat expr tmp)) rest . body)))) + +(define-syntax match-let* + (syntax-rules () + ((_ () . body) + (begin . body)) + ((_ ((pat expr) . rest) . body) + (match expr (pat (match-let* rest . body)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Otherwise COND-EXPANDed bits. + +;; This *should* work, but doesn't :( +;; (define-syntax match-check-ellipse +;; (syntax-rules (...) +;; ((_ ... sk fk) sk) +;; ((_ x sk fk) fk))) + +;; This is a little more complicated, and introduces a new let-syntax, +;; but should work portably in any R[56]RS Scheme. Taylor Campbell +;; originally came up with the idea. +(define-syntax match-check-ellipse + (syntax-rules () + ;; these two aren't necessary but provide fast-case failures + ((match-check-ellipse (a . b) success-k failure-k) failure-k) + ((match-check-ellipse #(a ...) success-k failure-k) failure-k) + ;; matching an atom + ((match-check-ellipse id success-k failure-k) + (let-syntax ((ellipse? (syntax-rules () + ;; iff `id' is `...' here then this will + ;; match a list of any length + ((ellipse? (foo id) sk fk) sk) + ((ellipse? other sk fk) fk)))) + ;; this list of three elements will only many the (foo id) list + ;; above if `id' is `...' + (ellipse? (a b c) success-k failure-k))))) + + +;; This is portable but can be more efficient with non-portable +;; extensions. This trick was originally discovered by Oleg Kiselyov. + +(define-syntax match-check-identifier + (syntax-rules () + ;; fast-case failures, lists and vectors are not identifiers + ((_ (x . y) success-k failure-k) failure-k) + ((_ #(x ...) success-k failure-k) failure-k) + ;; x is an atom + ((_ x success-k failure-k) + (let-syntax + ((sym? + (syntax-rules () + ;; if the symbol `abracadabra' matches x, then x is a + ;; symbol + ((sym? x sk fk) sk) + ;; otherwise x is a non-symbol datum + ((sym? y sk fk) fk)))) + (sym? abracadabra success-k failure-k))))) diff --git a/lib/chibi/mime.module b/lib/chibi/mime.module new file mode 100644 index 00000000..2c10dbd1 --- /dev/null +++ b/lib/chibi/mime.module @@ -0,0 +1,7 @@ + +(define-module (chibi mime) + (export mime-ref assoc-ref mime-header-fold mime-headers->list + mime-parse-content-type mime-decode-header + mime-message-fold mime-message->sxml) + (import-immutable (scheme) (chibi base64) (chibi quoted-printable) (chibi io)) + (include "mime.scm")) diff --git a/lib/chibi/mime.scm b/lib/chibi/mime.scm new file mode 100644 index 00000000..e712d7fa --- /dev/null +++ b/lib/chibi/mime.scm @@ -0,0 +1,410 @@ +;; mime.scm -- RFC2045 MIME library +;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; RFC2822 headers + +;; Procedure: mime-header-fold kons knil [source [limit [kons-from]]] +;; +;; Performs a fold operation on the MIME headers of source which can be +;; either a string or port, and defaults to current-input-port. kons +;; is called on the three values: +;; kons header value accumulator +;; where accumulator begins with knil. Neither the header nor the +;; value are modified, except wrapped lines are handled for the value. +;; +;; The optional procedure KONS-FROM is a procedure to be called when +;; the first line of the headers is an "From
" line, to +;; enable this procedure to be used as-is on mbox files and the like. +;; It defaults to KONS, and if such a line is found the fold will begin +;; with (KONS-FROM "%from"
(KONS-FROM "%date" KNIL)). +;; +;; The optional LIMIT gives a limit on the number of headers to read. + +;; Procedure: mime-headers->list [source] +;; Return an alist of the MIME headers from source with headers all +;; downcased. + +;; Procedure: mime-parse-content-type str +;; Parses STR as a Content-Type style-value returning the list +;; (type (attr . val) ...) +;; For example: +;; (mime-parse-content-type +;; "text/html; CHARSET=US-ASCII; filename=index.html") +;; => ("text/html" ("charset" . "US-ASCII") ("filename" . "index.html")) + +;; Procedure: mime-decode-header str +;; Replace all occurrences of RFC1522 =?ENC?...?= escapes in STR with +;; the appropriate decoded and charset converted value. + +;; Procedure: mime-ref headers str [default] +;; A case-insensitive assoc-ref. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; RFC2045 MIME encoding + +;; Procedure: mime-message-fold src headers kons knil +;; Performs a fold operation on the given string or port SRC as a MIME +;; body corresponding to the headers give in HEADERS. KONS is called +;; on the successive values: +;; +;; KONS part-headers part-body accumulator +;; +;; where part-headers are the headers for the given MIME part (the +;; original headers for single-part MIME), part-body is the +;; appropriately decoded and charset-converted body of the message, +;; and the accumulator begins with KNIL. +;; +;; TODO: Extend mime-message-fold to (optionally?) pass KONS an +;; input-port instead of string for the body to handle very large bodies +;; (this is not much of an issue for SMTP since the messages are in +;; practice limited, but it could be problematic for large HTTP bodies). +;; +;; This does a depth-first search, folding in sequence. It should +;; probably be doing a tree-fold as in html-parser. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define mime-line-length-limit 4096) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; association lists + +(define (assoc* key ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls)) + (cond + ((null? ls) #f) + ((eq key (caar ls)) (car ls)) + (else (lp (cdr ls))))))) + +(define (assoc-ref ls key . o) + (let ((default (and (pair? o) (car o))) + (eq (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) equal?))) + (cond ((assoc* key ls eq) => cdr) + (else default)))) + +(define (mime-ref ls key . o) + (assoc-ref ls key (and (pair? o) (car o)) string-ci=?)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; simple matching instead of regexps + +(define (match-mbox-from-line line) + (let ((len (string-length line))) + (and (> len 5) + (string=? (substring line 0 5) "From ") + (let lp ((i 6)) + (cond + ((= i len) (list (substring line 5 len) "")) + ((memq (string-ref line i) '(#\space #\tab)) + (list (substring line 5 i) (substring line (+ i 1) len))) + (else (lp (+ i 1)))))))) + +(define (string-scan-colon-or-maybe-equal str) + (let ((len (string-length str))) + (let lp ((i 0) (best #f)) + (if (= i len) + best + (let ((c (string-ref str i))) + (cond ((or (char-alphabetic? c) + (char-numeric? c) + (memv c '(#\- #\_))) + (lp (+ i 1) best)) + ((eq? c #\:) + (if (= i 0) #f i)) + ((eqv? c #\=) + (lp (+ i 1) (or best i))) + (else + best))))))) + +(define (string-skip-white-space str i) + (let ((lim (string-length str))) + (let lp ((i i)) + (cond ((>= i lim) lim) + ((char-whitespace? (string-ref str i)) (lp (+ i 1))) + (else i))))) + +(define (match-mime-header-line line) + (let ((i (string-scan-colon-or-maybe-equal line))) + (and i + (let ((j (string-skip-white-space line (+ i 1)))) + (list (substring line 0 i) + (substring line j (string-length line))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; dummy encoder + +(define (ces-convert str . x) + str) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; some srfi-13 & string utils + +(define (string-copy! to tstart from . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length from)))) + (let lp ((i start) (j tstart)) + (cond + ((< i end) + (string-set! to j (string-ref from i)) + (lp (+ i 1) (+ j 1))))))) + +(define (string-concatenate-reverse ls) + (let lp ((ls ls) (rev '()) (len 0)) + (if (null? ls) + (let ((res (make-string len))) + (let lp ((ls rev) (i 0)) + (cond + ((null? ls) + res) + (else + (string-copy! res i (car ls)) + (lp (cdr ls) (+ i (string-length (car ls)))))))) + (lp (cdr ls) (cons (car ls) rev) (+ len (string-length (car ls))))))) + +(define (string-downcase s . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length s)))) + (let* ((len (- end start)) (s2 (make-string len))) + (let lp ((i start) (j 0)) + (cond + ((>= i end) + s2) + (else + (string-set! s2 j (char-downcase (string-ref s i))) + (lp (+ i 1) (+ j 1)))))))) + +(define (string-char-index str c . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond + ((= i end) #f) + ((eq? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-trim-white-space s) + (let ((len (string-length s))) + (let lp ((i 0)) + (cond ((= i len) "") + ((char-whitespace? (string-ref s i)) (lp (+ i 1))) + (else + (let lp ((j (- len 1))) + (cond ((<= j i) "") + ((char-whitespace? (string-ref s j)) (lp (- j 1))) + (else (substring s i (+ j 1)))))))))) + +(define (string-split str ch) + (let ((len (string-length str))) + (let lp ((i 0) (res '())) + (let ((j (string-char-index str ch i))) + (if j + (lp (+ j 1) (cons (substring str i j) res)) + (reverse (cons (substring str i len) res))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; header parsing + +(define (mime-header-fold kons knil . o) + (let ((src (and (pair? o) (car o))) + (limit (and (pair? o) (pair? (cdr o)) (car (cdr o)))) + (kons-from (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) (caddr o) kons))) + ((if (string? src) mime-header-fold-string mime-header-fold-port) + kons knil (or src (current-input-port)) limit kons-from))) + +(define (mime-header-fold-string kons knil str limit kons-from) + (call-with-input-string str + (lambda (in) (mime-header-fold-port kons knil in limit kons-from)))) + +(define (mime-header-fold-port kons knil port limit kons-from) + (define (out line acc count) + (cond + ((or (and limit (> count limit)) (eof-object? line) (string=? line "")) + acc) + ((match-mime-header-line line) + => (lambda (m) (in (car m) (list (cadr m)) acc (+ count 1)))) + (else + ;;(warn "invalid header line: ~S\n" line) + (out (read-line port mime-line-length-limit) acc (+ count 1))))) + (define (in header value acc count) + (let ((line (read-line port mime-line-length-limit))) + (cond + ((and limit (> count limit)) + acc) + ((or (eof-object? line) (string=? line "")) + (kons header (string-concatenate-reverse value) acc)) + ((char-whitespace? (string-ref line 0)) + (in header (cons line value) acc (+ count 1))) + (else + (out line + (kons header (string-concatenate-reverse value) acc) + (+ count 1)))))) + (let ((first-line (read-line port mime-line-length-limit))) + (cond + ((eof-object? first-line) + knil) + ((and kons-from (match-mbox-from-line first-line)) + => (lambda (m) ; special case check on first line for mbox files + (out (read-line port mime-line-length-limit) + (kons-from "%from" (car m) + (kons-from "%date" (cadr m) knil)) + 0))) + (else + (out first-line knil 0))))) + +(define (mime-headers->list . o) + (reverse + (apply + mime-header-fold + (lambda (h v acc) (cons (cons (string-downcase h) v) acc)) + '() + o))) + +(define (mime-split-name+value s) + (let ((i (string-char-index s #\=))) + (if i + (cons (string-downcase (string-trim-white-space (substring s 0 i))) + (if (= i (string-length s)) + "" + (if (eqv? #\" (string-ref s (+ i 1))) + (substring s (+ i 2) (- (string-length s) 1)) + (substring s (+ i 1) (string-length s))))) + (cons (string-downcase (string-trim-white-space s)) "")))) + +(define (mime-parse-content-type str) + (map mime-split-name+value (string-split str #\;))) + +(define (mime-decode-header str) + (let* ((len (string-length str)) + (limit (- len 8))) ; need at least 8 chars: "=?Q?X??=" + (let lp ((i 0) (from 0) (res '())) + (if (>= i limit) + (string-concatenate (reverse (cons (substring str from len) res))) + (if (and (eqv? #\= (string-ref str i)) + (eqv? #\? (string-ref str (+ i 1)))) + (let* ((j (string-char-index str #\? (+ i 3))) + (k (string-char-index str #\? (+ j 3)))) + (if (and j k (< (+ k 1) len) + (eqv? #\? (string-ref str (+ j 2))) + (memq (string-ref str (+ j 1)) '(#\Q #\B #\q #\b)) + (eqv? #\= (string-ref str (+ k 1)))) + (let ((decode (if (memq (string-ref str (+ j 1)) '(#\Q #\q)) + quoted-printable-decode-string + base64-decode-string)) + (cset (substring str (+ i 2) j)) + (content (substring str (+ j 3) k)) + (k2 (+ k 2))) + (lp k2 k2 (cons (ces-convert (decode content) cset) + (cons (substring str from i) res)))) + (lp (+ i 2) from res))) + (lp (+ i 1) from res)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; message parsing + +(define (mime-read-to-boundary port boundary next final) + (let ((final-boundary (and boundary (string-append boundary "--")))) + (let lp ((res '())) + (let ((line (read-line port mime-line-length-limit))) + (cond + ((or (eof-object? line) (equal? line final-boundary)) + (final (string-concatenate (reverse res) + (call-with-output-string newline)))) + ((equal? line boundary) + (next (string-concatenate (reverse res) + (call-with-output-string newline)))) + (else + (lp (cons line res)))))))) + +(define (mime-convert-part str cte enc) + (let ((str (cond + ((and (string? cte) (string-ci=? cte "quoted-printable")) + (quoted-printable-decode-string str)) + ((and (string? cte) (string-ci=? cte "base64")) + (base64-decode-string str)) + (else + str)))) + (if (string? enc) (ces-convert str enc) str))) + +(define (mime-read-part port cte enc boundary next final) + (mime-read-to-boundary + port boundary + (lambda (x) (next (mime-convert-part x cte enc))) + (lambda (x) (final (mime-convert-part x cte enc))))) + +;; (kons parent-headers part-headers part-body seed) +;; (start headers seed) +;; (end headers parent-seed seed) +(define (mime-message-fold src kons init-seed . o) + (let ((port (if (string? src) (open-input-string src) src))) + (let ((kons-start + (if (pair? o) (car o) (lambda (headers seed) '()))) + (kons-end + (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + (lambda (headers parent-seed seed) + `((mime (^ ,@headers) + ,@(if (pair? seed) (reverse seed) seed)) + ,@parent-seed)))) + (headers + (if (and (pair? o) (pair? (cdr o)) (pair? (cdr (cdr o)))) + (car (cdr (cdr o))) + (mime-headers->list port)))) + (let tfold ((parent-headers '()) + (headers headers) + (seed init-seed) + (boundary #f) + (next (lambda (x) x)) + (final (lambda (x) x))) + (let* ((ctype (mime-parse-content-type + (mime-ref headers "Content-Type" "text/plain"))) + (type (string-trim-white-space (caar ctype))) + (enc (string-trim-white-space + (or (mime-ref ctype "charset") + (mime-ref headers "charset" "ASCII")))) + (cte (string-trim-white-space + (or (mime-ref headers "Content-Transfer-Encoding") + (mime-ref headers "Encoding" "7-bit"))))) + (cond + ((and (string-ci=? type "multipart/") + (mime-ref ctype "boundary")) + => (lambda (boundary2) + (let ((boundary2 (string-append "--" boundary2))) + ;; skip preamble + (mime-read-to-boundary port boundary2 (lambda (x) x) (lambda (x) x)) + (let lp ((part-seed (kons-start headers seed))) + (let ((part-headers (mime-headers->list port))) + (tfold parent-headers part-headers + part-seed boundary2 + lp + (lambda (x) + ;; skip epilogue + (if boundary + (mime-read-to-boundary port boundary + (lambda (x) x) (lambda (x) x))) + (next (kons-end headers seed x))) + )))))) + (else + (mime-read-part + port cte enc boundary + (lambda (x) (next (kons parent-headers headers x seed))) + (lambda (x) (final (kons parent-headers headers x seed))))))))))) + +;; (mime (^ (header . value) ...) parts ...) +(define (mime-message->sxml . o) + (car + (apply + mime-message-fold + (if (pair? o) (car o) (current-input-port)) + (lambda (parent-headers headers body seed) + `((mime (^ ,@headers) ,body) ,@seed)) + '() + (lambda (headers seed) '()) + (lambda (headers parent-seed seed) + `((mime (^ ,@headers) + ,@(if (pair? seed) (reverse seed) seed)) + ,@parent-seed)) + (if (pair? o) (cdr o) '())))) + diff --git a/lib/chibi/modules.module b/lib/chibi/modules.module new file mode 100644 index 00000000..0d20861e --- /dev/null +++ b/lib/chibi/modules.module @@ -0,0 +1,8 @@ + +(define-module (chibi modules) + (export analyze-module module-ast module-ast-set! + module-ref module-contains? containing-module + procedure-analysis) + (import-immutable (scheme) (config)) + (import (chibi ast)) + (include "modules.scm")) diff --git a/lib/chibi/modules.scm b/lib/chibi/modules.scm new file mode 100644 index 00000000..b9e40e0d --- /dev/null +++ b/lib/chibi/modules.scm @@ -0,0 +1,103 @@ + +(define (file->sexp-list file) + (call-with-input-file file + (lambda (in) + (let lp ((res '())) + (let ((x (read in))) + (if (eof-object? x) + (reverse res) + (lp (cons x res)))))))) + +(define (module? x) (vector? x)) + +(define (module-ast mod) (vector-ref mod 3)) +(define (module-ast-set! mod x) (vector-set! mod 3 x)) + +(define (analyze-module-source name mod recursive?) + (let ((env (module-env mod)) + (dir (if (equal? name '(scheme)) "" (module-name-prefix name)))) + (define (include-source file) + (cond ((find-module-file (string-append dir file)) + => (lambda (x) (cons 'body (file->sexp-list x)))) + (else (error "couldn't find include" file)))) + (let lp ((ls (module-meta-data mod)) (res '())) + (cond + ((not (pair? ls)) + (reverse res)) + (else + (case (and (pair? (car ls)) (caar ls)) + ((import import-immutable) + (for-each + (lambda (m) + (let* ((mod2-name+imports (resolve-import m)) + (mod2-name (car mod2-name+imports))) + (if recursive? + (analyze-module mod2-name #t)))) + (cdar ls)) + (lp (cdr ls) res)) + ((include) + (lp (append (map include-source (cdar ls)) (cdr ls)) res)) + ((body) + (let lp2 ((ls2 (cdar ls)) (res res)) + (cond + ((pair? ls2) + (lp2 (cdr ls2) (cons (analyze (car ls2) env) res))) + (else + (lp (cdr ls) res))))) + (else + (lp (cdr ls) res)))))))) + +(define (analyze-module name . o) + (let ((recursive? (and (pair? o) (car o))) + (res (load-module name))) + (if (not (module-ast res)) + (module-ast-set! res (analyze-module-source name res recursive?))) + res)) + +(define (module-ref mod var-name . o) + (let ((cell (env-cell (module-env (if (module? mod) mod (load-module mod))) + var-name))) + (if cell + (cdr cell) + (if (pair? o) (car o) (error "no binding in module" mod var-name))))) + +(define (module-contains? mod var-name) + (and (env-cell (module-env (if (module? mod) mod (load-module mod))) var-name) + #t)) + +(define (module-defines? name mod var-name) + (if (not (module-ast mod)) + (module-ast-set! mod (analyze-module-source name mod #f))) + (let lp ((ls (module-ast mod))) + (and (pair? ls) + (or (and (set? (car ls)) + (eq? var-name (ref-name (set-var (car ls)))) + (begin + ;; (write `(found ,var-name in ,name ,(ast->sexp (car ls))) (current-error-port)) + ;; (newline (current-error-port)) + #t)) + (lp (cdr ls)))))) + +(define (containing-module x) + (let lp1 ((ls (reverse *modules*))) + (and (pair? ls) + (let ((env (module-env (cdar ls)))) + (let lp2 ((e-ls (env-exports env))) + (if (null? e-ls) + (lp1 (cdr ls)) + (let ((cell (env-cell env (car e-ls)))) + (if (and (eq? x (cdr cell)) + (module-defines? (caar ls) (cdar ls) (car cell))) + (car ls) + (lp2 (cdr e-ls)))))))))) + +(define (procedure-analysis x) + (let ((mod (containing-module x))) + (and mod + (let lp ((ls (module-ast (analyze-module (car mod))))) + (and (pair? ls) + (if (and (set? (car ls)) + (eq? (procedure-name x) (ref-name (set-var (car ls))))) + (set-value (car ls)) + (lp (cdr ls)))))))) + diff --git a/lib/chibi/net.module b/lib/chibi/net.module new file mode 100644 index 00000000..845a7aa8 --- /dev/null +++ b/lib/chibi/net.module @@ -0,0 +1,11 @@ + +(define-module (chibi net) + (export sockaddr? address-info? get-address-info socket connect + with-net-io open-net-io + address-info-family address-info-socket-type address-info-protocol + address-info-address address-info-address-length address-info-next) + (import-immutable (scheme)) + (import (chibi filesystem)) + (include-shared "net") + (include "net.scm")) + diff --git a/lib/chibi/net.scm b/lib/chibi/net.scm new file mode 100644 index 00000000..5f912cb5 --- /dev/null +++ b/lib/chibi/net.scm @@ -0,0 +1,32 @@ +;; net.scm -- the high-level network interface +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (open-net-io host service) + (let lp ((addr (get-address-info host + (if (integer? service) + (number->string service) + service) + #f))) + (if (not addr) + (error "couldn't find address" host service) + (let ((sock (socket (address-info-family addr) + (address-info-socket-type addr) + (address-info-protocol addr)))) + (if (negative? sock) + (lp (address-info-next addr)) + (if (negative? + (connect sock + (address-info-address addr) + (address-info-address-length addr))) + (lp (address-info-next addr)) + (list (open-input-file-descriptor sock) + (open-output-file-descriptor sock)))))))) + +(define (with-net-io host service proc) + (let ((io (open-net-io host service))) + (if (not (pair? io)) + (error "couldn't find address" host service) + (let ((res (proc (car io) (car (cdr io))))) + (close-input-port (car io)) + res)))) diff --git a/lib/chibi/net.stub b/lib/chibi/net.stub new file mode 100644 index 00000000..0d72bc90 --- /dev/null +++ b/lib/chibi/net.stub @@ -0,0 +1,25 @@ + +(c-system-include "sys/types.h") +(c-system-include "sys/socket.h") +(c-system-include "netdb.h") + +(define-c-struct sockaddr + predicate: sockaddr?) + +(define-c-struct addrinfo + finalizer: freeaddrinfo + predicate: address-info? + (int ai_family address-info-family) + (int ai_socktype address-info-socket-type) + (int ai_protocol address-info-protocol) + ((link sockaddr) ai_addr address-info-address) + (size_t ai_addrlen address-info-address-length) + ((link addrinfo) ai_next address-info-next)) + +(define-c errno (get-address-info getaddrinfo) + (string string (maybe-null addrinfo) (result free addrinfo))) + +(define-c int bind (int sockaddr int)) +(define-c int listen (int int)) +(define-c int socket (int int int)) +(define-c int connect (int sockaddr int)) diff --git a/lib/chibi/net/http.module b/lib/chibi/net/http.module new file mode 100644 index 00000000..352bf7b4 --- /dev/null +++ b/lib/chibi/net/http.module @@ -0,0 +1,7 @@ + +(define-module (chibi net http) + (export http-get call-with-input-url with-input-from-url + http-parse-request http-parse-form) + (import-immutable (scheme) (srfi 39) (chibi net) (chibi io) + (chibi uri) (chibi mime)) + (include "http.scm")) diff --git a/lib/chibi/net/http.scm b/lib/chibi/net/http.scm new file mode 100644 index 00000000..37cac5e6 --- /dev/null +++ b/lib/chibi/net/http.scm @@ -0,0 +1,180 @@ +;; http.scm -- http client +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils + +(define (string-char-index str c . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond + ((= i end) #f) + ((eq? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-split str ch) + (let ((len (string-length str))) + (let lp ((i 0) (res '())) + (let ((j (string-char-index str ch i))) + (if j + (lp (+ j 1) (cons (substring str i j) res)) + (reverse (cons (substring str i len) res))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; client utils + +(define http-user-agent "chibi") + +(define http-redirect-limit 10) +(define http-chunked-buffer-size 4096) +(define http-chunked-size-limit 409600) + +(define (string-scan str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (and (< i end) + (if (eqv? ch (string-ref str i)) + i + (lp (+ i 1))))))) + +(define (http-parse-response line) + (let* ((len (string-length line)) + (i (or (string-scan line #\space 0 len) len)) + (j (or (string-scan line #\space (+ i 1) len) len)) + (n (and (< i j) (string->number (substring line (+ i 1) j))))) + (if (not (integer? n)) + (error "bad response" line i j) + (list (substring line 0 i) + n + (if (>= j len) "" (substring line (+ j 1) len)))))) + +(define (http-wrap-chunked-input-port in) + (define (read-chunk in) + (let* ((line (read-line in)) + (n (and (string? line) (string->number line 16)))) + (display "read-chunk ") (write line) (newline) + (cond + ((not (and (integer? n) (<= 0 n http-chunked-size-limit))) + (error "invalid chunked size line" line)) + ((zero? n) "") + (else (read-string n in))))) + (make-generated-input-port + (lambda () (read-chunk in)))) + +(define (http-get/raw url in-headers limit) + (if (<= limit 0) + (error "http-get: redirect limit reached" url) + (let* ((uri (if (uri? url) url (string->uri url))) + (host (and uri (uri-host uri)))) + (if (not host) + (error "invalid url" url) + (let* ((io (open-net-io + host + (or (uri-port uri) + (if (eq? 'https (uri-scheme uri)) 443 80)))) + (in (car io)) + (out (car (cdr io)))) + (display "GET " out) + (display (or (uri-path uri) "/") out) + (display " HTTP/1.0\r\n" out) + (display "Host: " out) (display host out) (display "\r\n" out) + (cond + ((not (mime-ref in-headers "user-agent")) + (display "User-Agent: " out) + (display http-user-agent out) + (display "\r\n" out))) + (for-each + (lambda (x) + (display (car x) out) (display ": " out) + (display (cdr x) out) (display "\r\n" out)) + in-headers) + (display "Connection: close\r\n\r\n" out) + (flush-output out) + (let* ((resp (http-parse-response (read-line in))) + (headers (mime-headers->list in)) + (status (quotient (cadr resp) 100))) + (case status + ((2) + (let ((enc (mime-ref headers "transfer-encoding"))) + (cond + ((equal? enc "chunked") + (http-wrap-chunked-input-port in)) + (else + in)))) + ((3) + (close-input-port in) + (close-output-port out) + (let ((url2 (mime-ref headers "location"))) + (if url2 + (http-get/raw url2 in-headers (- limit 1)) + (error "redirect with no location header")))) + (else + (close-input-port in) + (close-output-port out) + (error "couldn't retrieve url" url resp))))))))) + +(define (http-get url . headers) + (http-get/raw url + (if (pair? headers) (car headers) '()) + http-redirect-limit)) + +(define (call-with-input-url url proc) + (let* ((p (http-get url)) + (res (proc p))) + (close-input-port p) + res)) + +(define (with-input-from-url url thunk) + (let ((p (http-get url))) + (let ((res (parameterize ((current-input-port p)) (thunk)))) + (close-input-port p) + res))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; server utils + +;; read and parse a request line +(define (http-parse-request . o) + (let ((line (string-split + (read-line (if (pair? o) (car o) (current-input-port)) 4096)))) + (cons (string->symbol (car line)) (cdr line)))) + +;; Parse a form body with a given URI and MIME headers (as parsed with +;; mime-headers->list). Returns an alist of (name . value) for every +;; query or form parameter. +(define (http-parse-form uri headers . o) + (let* ((in (if (pair? o) (car o) (current-input-port))) + (type (mime-ref headers + "content-type" + "application/x-www-form-urlencoded")) + (query0 (or (uri-query (if (string? uri) (string->uri uri) uri)) '())) + (query (if (string? query0) (uri-query->alist query0) query0))) + (cond + ((string-ci=? "multipart/" type) + (let ((mime (mime-message->sxml in headers))) + (append + (let lp ((ls (cddr mime)) + (res '())) + (cond + ((null? ls) + res) + ((and (pair? (car ls)) + (eq? 'mime (caar ls)) + (pair? (cdar ls)) + (pair? (cadar ls)) + (memq (caadar ls) '(^ @))) + (let* ((disp0 (mime-ref (cdadar ls) "content-disposition" "")) + (disp (mime-parse-content-type disp0)) + (name (mime-ref disp "name"))) + (if name + (lp (cdr ls) (cons (cons name (caddar ls)) res)) + (lp (cdr ls) res)))) + (else + (lp (cdr ls) res)))) + query))) + (else + query)))) + diff --git a/lib/chibi/pathname.module b/lib/chibi/pathname.module new file mode 100644 index 00000000..765ee189 --- /dev/null +++ b/lib/chibi/pathname.module @@ -0,0 +1,7 @@ + +(define-module (chibi pathname) + (export path-strip-directory path-directory path-extension-pos + path-extension path-strip-extension path-replace-extension + path-absolute? path-relative? path-normalize make-path) + (import-immutable (scheme)) + (include "pathname.scm")) diff --git a/lib/chibi/pathname.scm b/lib/chibi/pathname.scm new file mode 100644 index 00000000..de27ad61 --- /dev/null +++ b/lib/chibi/pathname.scm @@ -0,0 +1,180 @@ +;; pathname.scm -- a general, non-host-specific path lib +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-scan-right c str . o) + (let lp ((i (if (pair? o) (car o) (- (string-length str) 1)))) + (cond ((negative? i) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (- i 1)))))) + +(define (string-skip c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((not (eqv? c (string-ref str i))) i) + (else (lp (+ i 1))))))) + +(define (string-skip-right c str . o) + (let lp ((i (if (pair? o) (car o) (- (string-length str) 1)))) + (cond ((negative? i) #f) + ((not (eqv? c (string-ref str i))) i) + (else (lp (- i 1)))))) + +;; POSIX basename +;; (define (path-strip-directory path) +;; (if (string=? path "") +;; path +;; (let ((end (string-skip-right #\/ path))) +;; (if (not end) +;; "/" +;; (let ((start (string-scan-right #\/ path (- end 1)))) +;; (substring path (if start (+ start 1) 0) (+ end 1))))))) + +;; GNU basename +(define (path-strip-directory path) + (if (string=? path "") + path + (let ((len (string-length path))) + (if (eqv? #\/ (string-ref path (- len 1))) + "" + (let ((slash (string-scan-right #\/ path))) + (if (not slash) + path + (substring path (+ slash 1) len))))))) + +(define (path-directory path) + (if (string=? path "") + "." + (let ((end (string-skip-right #\/ path))) + (if (not end) + "/" + (let ((start (string-scan-right #\/ path (- end 1)))) + (if (not start) + "." + (let ((start (string-skip-right #\/ path start))) + (if (not start) "/" (substring path 0 (+ start 1)))))))))) + +(define (path-extension-pos path) (string-scan-right #\. path)) + +(define (path-extension path) + (let ((i (path-extension-pos path))) + (and i + (let ((start (+ i 1)) (end (string-length path))) + (and (< start end) (substring path start end)))))) + +(define (path-strip-extension path) + (let ((i (path-extension-pos path))) + (if (and i (< (+ i 1) (string-length path))) + (substring path 0 i) + path))) + +(define (path-replace-extension path ext) + (string-append (path-strip-extension path) "." ext)) + +(define (path-absolute? path) + (and (not (string=? "" path)) (eqv? #\/ (string-ref path 0)))) + +(define (path-relative? path) (not (path-absolute? path))) + +;; This looks big and hairy, but it's mutation-free and guarantees: +;; (string=? s (path-normalize s)) <=> (eq? s (path-normalize s)) +;; i.e. fast and simple for already normalized paths. + +(define (path-normalize path) + (let* ((len (string-length path)) (len-1 (- len 1))) + (define (collect i j res) + (if (>= i j) res (cons (substring path i j) res))) + (define (finish i res) + (if (zero? i) + path + (apply string-append (reverse (collect i len res))))) + ;; loop invariants: + ;; - res is a list such that (string-concatenate-reverse res) + ;; is always the normalized string up to j + ;; - the tail of the string from j onward can be concatenated to + ;; the above value to get a partially normalized path referring + ;; to the same location as the original path + (define (inside i j res) + (if (>= j len) + (finish i res) + (if (eqv? #\/ (string-ref path j)) + (boundary i (+ j 1) res) + (inside i (+ j 1) res)))) + (define (boundary i j res) + (if (>= j len-1) + (finish i res) + (case (string-ref path j) + ((#\.) + (case (string-ref path (+ j 1)) + ((#\.) + (if (or (>= j (- len 2)) (eqv? #\/ (string-ref path (+ j 2)))) + (if (>= i (- j 1)) + (if (null? res) + (backup j "" '()) + (backup j (car res) (cdr res))) + (backup j (substring path i j) res)) + (inside i (+ j 2) res))) + ((#\/) + (if (= i j) + (boundary (+ j 2) (+ j 2) res) + (let ((s (substring path i j))) + (boundary (+ j 2) (+ j 2) (cons s res))))) + (else (inside i (+ j 1) res)))) + ((#\/) (boundary (+ j 1) (+ j 1) (collect i j res))) + (else (inside i (+ j 1) res))))) + (define (backup j s res) + (let ((pos (+ j 3))) + (cond + ;; case 1: we're reduced to accumulating parents of the cwd + ((or (string=? s "/..") (string=? s "..")) + (boundary pos pos (cons "/.." (cons s res)))) + ;; case 2: the string isn't a component itself, skip it + ((or (string=? s "") (string=? s ".") (string=? s "/")) + (if (pair? res) + (backup j (car res) (cdr res)) + (boundary pos pos (if (string=? s "/") '("/") '(".."))))) + ;; case3: just take the directory of the string + (else + (let ((d (path-directory s))) + (cond + ((string=? d "/") + (boundary pos pos (if (null? res) '("/") res))) + ((string=? d ".") + (boundary pos pos res)) + (else (boundary pos pos (cons "/" (cons d res)))))))))) + ;; start with boundary if abs path, otherwise inside + (if (zero? len) + path + ((if (eqv? #\/ (string-ref path 0)) boundary inside) 0 1 '())))) + +(define (make-path . args) + (define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "not a valid path component" x)))) + (define (trim-trailing-slash s) + (let ((i (string-skip-right #\/ s))) + (if i (substring s 0 (+ i 1)) ""))) + (if (null? args) + "" + (let ((start (trim-trailing-slash (x->string (car args))))) + (let lp ((ls (cdr args)) + (res (if (string=? "" start) '() (list start)))) + (cond + ((null? ls) + (apply string-append (reverse res))) + ((pair? (car ls)) + (lp (append (car ls) (cdr ls)) res)) + (else + (let ((x (trim-trailing-slash (x->string (car ls))))) + (lp (cdr ls) + (if (string=? x "") res (cons x (cons "/" res))))))))))) diff --git a/lib/chibi/process.module b/lib/chibi/process.module new file mode 100644 index 00000000..372b56e4 --- /dev/null +++ b/lib/chibi/process.module @@ -0,0 +1,18 @@ + +(define-module (chibi process) + (export exit sleep alarm fork kill execute waitpid + set-signal-action! make-signal-set signal-set-contains? + signal-set-fill! signal-set-add! signal-set-delete! + current-signal-mask + signal-mask-block! signal-mask-unblock! signal-mask-set! + signal/hang-up signal/interrupt signal/quit + signal/illegal signal/abort signal/fpe + signal/kill signal/segv signal/pipe + signal/alarm signal/term signal/user1 + signal/user2 signal/child signal/continue + signal/stop signal/tty-stop signal/tty-input + signal/tty-output) + (import-immutable (scheme)) + (cond-expand (threads (import (srfi 18))) (else #f)) + (include-shared "process")) + diff --git a/lib/chibi/process.stub b/lib/chibi/process.stub new file mode 100644 index 00000000..93b08d95 --- /dev/null +++ b/lib/chibi/process.stub @@ -0,0 +1,73 @@ + +(c-system-include "sys/types.h") +(c-system-include "sys/wait.h") +(c-system-include "signal.h") +(c-system-include "unistd.h") + +(define-c-type siginfo_t + predicate: signal-info? + (int si_signo signal-number) + (int si_errno signal-error-number) + (int si_code signal-code) + (pid_t si_pid signal-pid) + (uid_t si_uid signal-uid) + (int si_status signal-status) + ;;(clock_t si_utime signal-user-time) + ;;(clock_t si_stime signal-system-time) + ) + +(define-c-type sigset_t + predicate: signal-set?) + +(define-c-const int (signal/hang-up "SIGHUP")) +(define-c-const int (signal/interrupt "SIGINT")) +(define-c-const int (signal/quit "SIGQUIT")) +(define-c-const int (signal/illegal "SIGILL")) +(define-c-const int (signal/abort "SIGABRT")) +(define-c-const int (signal/fpe "SIGFPE")) +(define-c-const int (signal/kill "SIGKILL")) +(define-c-const int (signal/segv "SIGSEGV")) +(define-c-const int (signal/pipe "SIGPIPE")) +(define-c-const int (signal/alarm "SIGALRM")) +(define-c-const int (signal/term "SIGTERM")) +(define-c-const int (signal/user1"SIGUSR1")) +(define-c-const int (signal/user2 "SIGUSR2")) +(define-c-const int (signal/child "SIGCHLD")) +(define-c-const int (signal/continue "SIGCONT")) +(define-c-const int (signal/stop "SIGSTOP")) +(define-c-const int (signal/tty-stop "SIGTSTP")) +(define-c-const int (signal/tty-input "SIGTTIN")) +(define-c-const int (signal/tty-output "SIGTTOU")) + +(c-include "signal.c") + +(define-c sexp (set-signal-action! "sexp_set_signal_action") + ((value ctx sexp) (value self sexp) sexp sexp)) + +(define-c errno (make-signal-set "sigemptyset") ((pointer result sigset_t))) +(define-c errno (signal-set-fill! "sigfillset") ((pointer sigset_t))) +(define-c errno (signal-set-add! "sigaddset") ((pointer sigset_t) int)) +(define-c errno (signal-set-delete! "sigaddset") ((pointer sigset_t) int)) +(define-c boolean (signal-set-contains? "sigismember") ((pointer sigset_t) int)) + +(define-c errno (signal-mask-block! "sigprocmask") + ((value SIG_BLOCK int) (pointer sigset_t) (pointer value NULL sigset_t))) +(define-c errno (signal-mask-unblock! "sigprocmask") + ((value SIG_UNBLOCK int) (pointer sigset_t) (pointer value NULL sigset_t))) +(define-c errno (signal-mask-set! "sigprocmask") + ((value SIG_SETMASK int) (pointer sigset_t) (pointer value NULL sigset_t))) +(define-c errno (current-signal-mask "sigprocmask") + ((value SIG_BLOCK int) (pointer value NULL sigset_t) (pointer result sigset_t))) + +(define-c unsigned-int alarm (unsigned-int)) +(define-c unsigned-int sleep (unsigned-int)) + +(define-c pid_t fork ()) +;;(define-c pid_t wait ((result int))) +(define-c pid_t waitpid (int (result int) int)) +(define-c errno kill (int int)) +;;(define-c errno raise (int)) +(define-c void exit (int)) +(define-c int (execute execvp) (string (array string))) + +(c-init "sexp_init_signals(ctx, env);") diff --git a/lib/chibi/quoted-printable.module b/lib/chibi/quoted-printable.module new file mode 100644 index 00000000..9cbec430 --- /dev/null +++ b/lib/chibi/quoted-printable.module @@ -0,0 +1,7 @@ + +(define-module (chibi quoted-printable) + (export quoted-printable-encode quoted-printable-encode-string + quoted-printable-encode-header + quoted-printable-decode quoted-printable-decode-string) + (import-immutable (scheme) (srfi 33) (chibi io)) + (include "quoted-printable.scm")) diff --git a/lib/chibi/quoted-printable.scm b/lib/chibi/quoted-printable.scm new file mode 100644 index 00000000..80709026 --- /dev/null +++ b/lib/chibi/quoted-printable.scm @@ -0,0 +1,157 @@ +;; quoted-printable.scm -- RFC2045 implementation +;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; Procedure: quoted-printable-encode-string str [start-col max-col] +;; Return a quoted-printable encoded representation of string +;; according to the official standard as described in RFC2045. +;; +;; ? and _ are always encoded for compatibility with RFC1522 encoding, +;; and soft newlines are inserted as necessary to keep each lines +;; length less than MAX-COL (default 76). The starting column may be +;; overridden with START-COL (default 0). + +;; Procedure: quoted-printable-decode-string str [mime?] +;; Return a quoted-printable decoded representation of string. If +;; MIME? is specified and true, _ will be decoded as as space in +;; accordance with RFC1522. No errors will be raised on invalid +;; input. + +;; Procedure: quoted-printable-encode [port start-col max-col] +;; Procedure: quoted-printable-decode [port start-col max-col] +;; Variations of the above which read and write to ports. + +;; Procedure: quoted-printable-encode-header enc str [start-col max-col] +;; Return a quoted-printable encoded representation of string as +;; above, wrapped in =?ENC?Q?...?= as per RFC1522, split across +;; multiple MIME-header lines as needed to keep each lines length less +;; than MAX-COL. The string is encoded as is, and the encoding ENC is +;; just used for the prefix, i.e. you are responsible for ensuring STR +;; is already encoded according to ENC. + +;; Example: + +;; (define (mime-encode-header header value charset) +;; (let ((prefix (string-append header ": ")) +;; (str (ces-convert value "UTF8" charset))) +;; (string-append +;; prefix +;; (quoted-printable-encode-header charset str (string-length prefix))))) + +;; This API is backwards compatible with the Gauche library +;; rfc.quoted-printable. + +(define *default-max-col* 76) + +;; Allow for RFC1522 quoting for headers by always escaping ? and _ +(define (qp-encode str start-col max-col separator) + (define (hex i) (integer->char (+ i (if (<= i 9) 48 55)))) + (let ((end (string-length str)) + (buf (make-string max-col))) + (let lp ((i 0) (col start-col) (res '())) + (cond + ((= i end) + (if (pair? res) + (string-concatenate (reverse (cons (substring buf 0 col) res)) + separator) + (substring buf start-col col))) + ((>= col (- max-col 3)) + (lp i 0 (cons (substring buf (if (pair? res) 0 start-col) col) res))) + (else + (let ((c (char->integer (string-ref str i)))) + (cond + ((and (<= 33 c 126) (not (memq c '(61 63 95)))) + (string-set! buf col (integer->char c)) + (lp (+ i 1) (+ col 1) res)) + (else + (string-set! buf col #\=) + (string-set! buf (+ col 1) (hex (arithmetic-shift c -4))) + (string-set! buf (+ col 2) (hex (bitwise-and c #b1111))) + (lp (+ i 1) (+ col 3) res))))))))) + +(define (quoted-printable-encode-string . o) + (let ((src (if (pair? o) (car o) (current-input-port))) + (start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0)) + (max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) + (caddr o) + *default-max-col*))) + (qp-encode (if (string? src) src (read-string #f src)) + start-col max-col "=\r\n"))) + +(define (quoted-printable-encode . o) + (display (apply (quoted-printable-encode-string o)))) + +(define (quoted-printable-encode-header encoding . o) + (let ((src (if (pair? o) (car o) (current-input-port))) + (start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0)) + (max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) + (caddr o) + *default-max-col*)) + (nl (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)) (pair? (cdddr o))) + (cadddr o) + "\r\n"))) + (let* ((prefix (string-append "=?" encoding "?Q?")) + (prefix-length (+ 2 (string-length prefix))) + (separator (string-append "?=" nl "\t" prefix)) + (effective-max-col (- max-col prefix-length))) + (string-append prefix + (qp-encode (if (string? src) src (read-string #f src)) + start-col effective-max-col separator) + "?=")))) + +(define (quoted-printable-decode-string . o) + (define (hex? c) (or (char-numeric? c) (<= 65 (char->integer c) 70))) + (define (unhex1 c) + (let ((i (char->integer c))) (if (>= i 65) (- i 55) (- i 48)))) + (define (unhex c1 c2) + (integer->char (+ (arithmetic-shift (unhex1 c1) 4) (unhex1 c2)))) + (let ((src (if (pair? o) (car o) (current-input-port))) + (mime-header? (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (let* ((str (if (string? src) src (read-string #f src))) + (end (string-length str))) + (call-with-output-string + (lambda (out) + (let lp ((i 0)) + (cond + ((< i end) + (let ((c (string-ref str i))) + (case c + ((#\=) ; = escapes + (cond + ((< (+ i 2) end) + (let ((c2 (string-ref str (+ i 1)))) + (cond + ((eq? c2 #\newline) (lp (+ i 2))) + ((eq? c2 #\return) + (lp (if (eq? (string-ref str (+ i 2)) #\newline) + (+ i 3) + (+ i 2)))) + ((hex? c2) + (let ((c3 (string-ref str (+ i 2)))) + (if (hex? c3) (write-char (unhex c2 c3) out)) + (lp (+ i 3)))) + (else (lp (+ i 3)))))))) + ((#\_) ; maybe translate _ to space + (write-char (if mime-header? #\space c) out) + (lp (+ i 1))) + ((#\space #\tab) ; strip trailing whitespace + (let lp2 ((j (+ i 1))) + (cond + ((not (= j end)) + (case (string-ref str j) + ((#\space #\tab) (lp2 (+ j 1))) + ((#\newline) + (lp (+ j 1))) + ((#\return) + (let ((k (+ j 1))) + (lp (if (and (< k end) + (eqv? #\newline (string-ref str k))) + (+ k 1) k)))) + (else (display (substring str i j) out) (lp j))))))) + (else ; a literal char + (write-char c out) + (lp (+ i 1))))))))))))) + +(define (quoted-printable-decode . o) + (display (apply quoted-printable-decode-string o))) + diff --git a/lib/chibi/repl.module b/lib/chibi/repl.module new file mode 100644 index 00000000..742b9581 --- /dev/null +++ b/lib/chibi/repl.module @@ -0,0 +1,9 @@ + +(define-module (chibi repl) + (export repl) + (import-immutable (scheme)) + (import (chibi ast) + (chibi process) + (chibi term edit-line) + (srfi 18)) + (include "repl.scm")) diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm new file mode 100644 index 00000000..b7ff79bc --- /dev/null +++ b/lib/chibi/repl.scm @@ -0,0 +1,41 @@ +;;;; repl.scm - friendlier repl with line editing and signal handling +;; +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define-syntax handle-exceptions + (syntax-rules () + ((handle-exceptions exn handler expr) + (call-with-current-continuation + (lambda (return) + (with-exception-handler (lambda (exn) (return handler)) + (lambda () expr))))))) + +(define (with-signal-handler sig handler thunk) + (let ((old-handler #f)) + (dynamic-wind + (lambda () (set! old-handler (set-signal-action! sig handler))) + thunk + (lambda () (set-signal-action! sig old-handler))))) + +(define (run-repl module env) + (let ((line (edit-line (if module (string-append (symbol->string module) "> ") "> ")))) + (cond + ((or (not line) (eof-object? line))) + ((equal? line "") (run-repl module env)) + (else + (handle-exceptions exn (print-exception exn (current-error-port)) + (let* ((expr (call-with-input-string line read)) + (thread (make-thread (lambda () + (let ((res (eval expr env))) + (if (not (eq? res (if #f #f))) + (write res))))))) + (with-signal-handler + signal/interrupt + (lambda (n) (thread-terminate! thread)) + (lambda () (thread-start! thread) (thread-join! thread))))) + (newline) + (run-repl module env))))) + +(define (repl) + (run-repl #f (interaction-environment))) diff --git a/lib/chibi/scribble.module b/lib/chibi/scribble.module new file mode 100644 index 00000000..b479eb64 --- /dev/null +++ b/lib/chibi/scribble.module @@ -0,0 +1,5 @@ + +(define-module (chibi scribble) + (export scribble-parse scribble-read) + (import-immutable (scheme)) + (include "scribble.scm")) diff --git a/lib/chibi/scribble.scm b/lib/chibi/scribble.scm new file mode 100644 index 00000000..1e4f15cd --- /dev/null +++ b/lib/chibi/scribble.scm @@ -0,0 +1,247 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; general character utils + +(define (char-mirror ch) + (case ch ((#\() #\)) ((#\[) #\]) ((#\{) #\}) ((#\<) #\>) (else ch))) + +(define (char-delimiter? ch) + (or (eof-object? ch) (char-whitespace? ch) + (memv ch '(#\( #\) #\[ #\] #\{ #\} #\" #\|)))) + +(define (char-punctuation? ch) + (memv ch '(#\- #\+ #\! #\< #\> #\[ #\] #\|))) + +(define (char-digit ch) (- (char->integer ch) (char->integer #\0))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; list utils + +(define (drop ls n) (if (<= n 0) ls (drop (cdr ls) (- n 1)))) + +(define (drop-while pred ls) + (if (or (null? ls) (not (pred (car ls)))) ls (drop-while pred (cdr ls)))) + +(define (list-prefix? prefix ls) + (cond ((null? prefix) #t) + ((null? ls) #f) + ((equal? (car prefix) (car ls)) (list-prefix? (cdr prefix) (cdr ls))) + (else #f))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; scribble reader (standalone, don't use the native reader) + +(define scribble-dot (list ".")) +(define scribble-close (list ")")) + +(define (if-peek-char ch in pass fail) + (cond ((eqv? ch (peek-char in)) (read-char in) pass) (else fail))) + +(define (skip-line in) + (do ((c #f (read-char in))) ((or (eof-object? c) (eqv? c #\newline))))) + +(define (read-float-tail in acc) + (let lp ((res acc) (k 0.1)) + (let ((ch (read-char in))) + (cond ((or (eof-object? ch) (char-delimiter? ch)) res) + ((char-numeric? ch) (lp (+ res (* k (char-digit ch))) (* k 0.1))) + (else (error "invalid numeric syntax")))))) + +(define (read-number in acc base) + (let lp ((acc acc)) + (let ((ch (peek-char in))) + (cond + ((or (eof-object? ch) (char-delimiter? ch)) acc) + ((char-numeric? ch) (read-char in) (lp (+ (* acc base) (char-digit ch)))) + ((eqv? #\. ch) + (read-char in) + (if (= base 10) + (begin (read-char in) (read-float-tail in (exact->inexact acc))) + (error "non-base-10 floating point"))) + (else (error "invalid numeric syntax")))))) + +(define (read-escaped in terminal) + (let lp ((ls '())) + (let ((ch (read-char in))) + (cond + ((or (eof-object? ch) (eqv? ch terminal)) (list->string (reverse ls))) + ((eqv? ch #\\) (lp (cons (read-char in) ls))) + (else (lp (cons ch ls))))))) + +(define (read-symbol in ls) + (do ((ls ls (cons c ls)) (c (peek-char in) (peek-char in))) + ((char-delimiter? c) (string->symbol (list->string (reverse ls)))) + (read-char in))) + +(define (scrib-read in) + (define ch (read-char in)) + (cond + ((eof-object? ch) ch) + ((char-whitespace? ch) (scrib-read in)) + (else + (case ch + ((#\( #\[ #\{) + (let lp ((res '())) + (let ((x (scrib-read in))) + (cond ((eof-object? x) (error "unterminated list" x)) + ((eq? x scribble-close) (reverse res)) + ((eq? x scribble-dot) + (let ((y (scrib-read in))) + (if (or (eof-object? y) (eq? y scribble-close)) + (error "unterminated dotted list") + (let ((z (scrib-read in))) + (if (not (eq? z scribble-close)) + (error "dot in non-terminal position in list" y z) + (append (reverse res) y)))))) + (else (lp (cons x res))))))) + ((#\} #\] #\)) scribble-close) + ((#\.) (if (char-delimiter? (peek-char in)) scribble-dot (read-float-tail in 0.0))) + ((#\') (list 'quote (scrib-read in))) + ((#\`) (list 'quasiquote (scrib-read in))) + ((#\,) (list (if-peek-char #\@ in 'unquote-splicing 'unquote) (scrib-read in))) + ((#\@) (scribble-parse-escape in #\@)) + ((#\;) (skip-line in) (scrib-read in)) + ((#\|) (string->symbol (read-escaped in #\|))) + ((#\") (read-escaped in #\")) + ((#\+ #\-) + (cond ((char-numeric? (peek-char in)) + ((if (eqv? ch #\+) + -) 0 (read-number in 0 10))) + (else (read-symbol in (list ch))))) + ((#\#) + (case (peek-char in) + ((#\t #\f) (eqv? (read-char in) #\t)) + ((#\() (list->vector (scrib-read in))) + ((#\\) + (read-char in) + (if (char-alphabetic? (peek-char in)) + (let ((name (scrib-read in))) + (case name + ((space) #\space) ((newline) #\newline) + (else (string-ref (symbol->string name) 0)))) + (read-char in))) + (else (error "unknown # syntax")))) + (else + (if (char-numeric? ch) + (read-number in (char-digit ch) 10) + (read-symbol in (list ch)))))))) + +(define (scribble-read in) + (let ((res (scrib-read in))) + (cond ((eq? res scribble-dot) (error "invalid . in source")) + ((eq? res scribble-close) (error "too many )'s")) + (else res)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; scribble parser + +(define (read-punctuation in) + (if (not (eqv? #\| (peek-char in))) + '() + (let lp ((ls '())) + (let ((c (peek-char in))) + (cond ((or (eof-object? c) (not(char-punctuation? c))) ls) + (else (lp (cons (char-mirror (read-char in)) ls)))))))) + +(define (read-prefix-wrapper in) + (let lp ((wrap (lambda (x) x))) + (case (peek-char in) + ((#\') (read-char in) (lp (lambda (x) (wrap (list 'quote x))))) + ((#\`) (read-char in) (lp (lambda (x) (wrap (list 'quasiquote x))))) + ((#\,) + (read-char in) + (cond ((eqv? #\@ (peek-char in)) + (read-char in) + (lp (lambda (x) (wrap (list 'unquote-splicing x))))) + (else (lp (lambda (x) (wrap (list 'unquote x))))))) + (else wrap)))) + +(define (scribble-parse-escape in ec) + (define bracket-char #\[) + (define brace-char #\{) + (let* ((wrap (read-prefix-wrapper in)) + (c (peek-char in)) + (cmd (if (or (eqv? c bracket-char) (eqv? c brace-char)) '() (list (scribble-read in)))) + (data? (eqv? (peek-char in) bracket-char)) + (data (if data? (scribble-read in) '())) + (punc (read-punctuation in)) + (body? (eqv? (peek-char in) brace-char)) + (body (cond (body? (read-char in) (scribble-parse in punc ec)) (else '())))) + (wrap (if (or data? body?) (append cmd data body) (car cmd))))) + +(define (scribble-parse in . o) + (define init-punc (if (pair? o) (car o) '())) + (define escape-char (if (and (pair? o) (pair? (cdr o))) (cadr o) #\@)) + (define comment-char #\;) + (define bracket-char #\[) + (define brace-char #\{) + (define close-bracket-char (char-mirror bracket-char)) + (define close-brace-char (char-mirror brace-char)) + (define (collect str res) + (if (pair? str) (cons (list->string (reverse str)) res) res)) + (define (skip-space in) + (let ((ch (peek-char in))) + (cond ((char-whitespace? ch) (read-char in) (skip-space in)) + ((eqv? ch #\;) (skip-line in) (skip-space in))))) + (define (tok str res punc depth) + (let ((c (read-char in))) + (cond + ((eof-object? c) + (if (zero? depth) + (reverse (collect str res)) + (error "unterminated expression" punc))) + ((and (eqv? c escape-char) (list-prefix? punc str)) + (let ((c (peek-char in))) + (cond + ((eof-object? c) + (tok str res punc depth)) + ((char-whitespace? c) + (tok (cons c str) res punc depth)) + ((eqv? c comment-char) + (read-char in) + (cond ((eqv? brace-char (peek-char in)) + (scribble-parse-escape in escape-char)) + (else + (skip-line in) + (let lp () + (cond ((char-whitespace? (peek-char in)) (read-char in) (lp)))))) + (tok str res punc depth)) + ((eqv? c #\|) + (read-char in) + (let lp ((ls (collect str res))) + (skip-space in) + (cond ((eqv? #\| (peek-char in)) (read-char in) (tok '() ls punc depth)) + (else (lp (cons (scribble-read in) ls)))))) + (else + (let ((str (drop str (length punc))) + (x (scribble-parse-escape in escape-char))) + (if (string? x) + (tok (append (reverse (string->list x)) str) res punc depth) + (tok '() (cons x (collect str res)) punc depth))))))) + ((eqv? c brace-char) + (tok (cons c str) res punc (+ depth 1))) + ((eqv? c close-brace-char) + (cond + ((zero? depth) + (let lp ((p punc) (ls '())) + (cond ((null? p) + (reverse (collect str res))) + ((not (eqv? (car p) (peek-char in))) + (tok (append ls (cons c str)) res punc (- depth 1))) + (else + (lp (cdr p) (cons (read-char in) ls)))))) + (else (tok (cons c str) res punc (- depth 1))))) + ((eqv? c #\newline) + (let* ((first? (and (null? res) (null? str))) + (res (collect (drop-while char-whitespace? str) res)) + (res (if (or first? (eqv? #\} (peek-char in))) + res + (cons "\n" res)))) + (let lp ((ls '())) + (let ((c (peek-char in))) + (cond + ((char-whitespace? c) (read-char in) (lp (cons c ls))) + (else (tok (if (eqv? c #\}) ls '()) res punc depth))))))) + (else + (tok (cons c str) res punc depth))))) + ;; begin + (tok '() '() init-punc 0)) diff --git a/lib/chibi/signal.c b/lib/chibi/signal.c new file mode 100644 index 00000000..7202d96e --- /dev/null +++ b/lib/chibi/signal.c @@ -0,0 +1,76 @@ +/* signal.c -- process signals interface */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define SEXP_MAX_SIGNUM 32 + +static sexp sexp_signal_contexts[SEXP_MAX_SIGNUM]; + +static struct sigaction call_sigaction, call_sigdefault, call_sigignore; + +static void sexp_call_sigaction (int signum, siginfo_t *info, void *uctx) { + sexp ctx; +#if ! SEXP_USE_GREEN_THREADS + sexp sigctx, handler; + sexp_gc_var1(args); +#endif + ctx = sexp_signal_contexts[signum]; + if (ctx) { +#if SEXP_USE_GREEN_THREADS + sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = + (sexp) ((sexp_uint_t)sexp_global(ctx, SEXP_G_THREADS_SIGNALS) + | (sexp_uint_t)sexp_make_fixnum(1UL< 0 + && sexp_unbox_fixnum(signum) < SEXP_MAX_SIGNUM)) + return sexp_xtype_exception(ctx, self, "not a valid signal number", signum); + if (! (sexp_procedurep(newaction) || sexp_opcodep(newaction) + || sexp_booleanp(newaction))) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, newaction); + if (! sexp_vectorp(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS))) + sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS) + = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_MAX_SIGNUM), SEXP_FALSE); + oldaction = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum); + res = sigaction(sexp_unbox_fixnum(signum), + (sexp_booleanp(newaction) ? + (sexp_truep(newaction) ? &call_sigdefault : &call_sigignore) + : &call_sigaction), + NULL); + if (res) + return sexp_user_exception(ctx, self, "couldn't set signal", signum); + sexp_vector_set(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum, newaction); + sexp_signal_contexts[sexp_unbox_fixnum(signum)] = ctx; + return oldaction; +} + +static void sexp_init_signals (sexp ctx, sexp env) { + call_sigaction.sa_sigaction = sexp_call_sigaction; +#if SEXP_USE_GREEN_THREADS + call_sigaction.sa_flags = SA_SIGINFO | SA_RESTART /* | SA_NODEFER */; + sigfillset(&call_sigaction.sa_mask); +#else + call_sigaction.sa_flags = SA_SIGINFO | SA_RESTART | SA_NODEFER; +#endif + call_sigdefault.sa_handler = SIG_DFL; + call_sigignore.sa_handler = SIG_IGN; + memset(sexp_signal_contexts, 0, sizeof(sexp_signal_contexts)); +} diff --git a/lib/chibi/stty.module b/lib/chibi/stty.module new file mode 100644 index 00000000..4540cb18 --- /dev/null +++ b/lib/chibi/stty.module @@ -0,0 +1,11 @@ + +(define-module (chibi stty) + (export stty with-stty with-raw-io + get-terminal-width get-terminal-dimensions + TCSANOW TCSADRAIN TCSAFLUSH) + (import-immutable (scheme) + (srfi 33) + (srfi 69)) + (include-shared "stty") + (include "stty.scm")) + diff --git a/lib/chibi/stty.scm b/lib/chibi/stty.scm new file mode 100644 index 00000000..b4aee004 --- /dev/null +++ b/lib/chibi/stty.scm @@ -0,0 +1,235 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; symbolic representation of attributes + +(define stty-lookup (make-hash-table eq?)) + +(for-each + (lambda (c) + (let ((type (cadr c)) + (value (caddr c))) + (hash-table-set! stty-lookup (car c) (cdr c)))) + + ;; ripped from the stty man page, then trimmed down to what seemed + ;; available on most systems + + `(;; characters + ;;(dsusp char ,VDSUSP) ; CHAR will send a terminal stop signal + (eof char ,VEOF) ; CHAR will send an EOF (terminate input) + (eol char ,VEOL) ; CHAR will end the line + (eol2 char ,VEOL2) ; alternate CHAR for ending the line + (erase char ,VERASE) ; CHAR will erase the last character typed + (intr char ,VINTR) ; CHAR will send an interrupt signal + (kill char ,VKILL) ; CHAR will erase the current line + (lnext char ,VLNEXT) ; CHAR will enter the next character quoted + (quit char ,VQUIT) ; CHAR will send a quit signal + (rprnt char ,VREPRINT) ; CHAR will redraw the current line + (start char ,VSTART) ; CHAR will restart output after stopping it + (stop char ,VSTOP) ; CHAR will stop the output + (susp char ,VSUSP) ; CHAR will send a terminal stop signal + (werase char ,VWERASE) ; CHAR will erase the last word typed + + ;; special settings + (cols special #f) ; tell the kernel that the terminal has N columns + (columns special #f) ; same as cols N + (ispeed special #f) ; set the input speed to N + (line special #f) ; use line discipline N + (min special #f) ; with -icanon, set N characters minimum for a completed read + (ospeed special #f) ; set the output speed to N + (rows special #f) ; tell the kernel that the terminal has N rows + (size special #f) ; print the number of rows and columns according to the kernel + (speed special #f) ; print the terminal speed + (time special #f) ; with -icanon, set read timeout of N tenths of a second + + ;; control settings + (clocal control ,CLOCAL) ; disable modem control signals + (cread control ,CREAD) ; allow input to be received + (crtscts control ,CRTSCTS) ; enable RTS/CTS handshaking + (cs5 control ,CS5) ; set character size to 5 bits + (cs6 control ,CS6) ; set character size to 6 bits + (cs7 control ,CS7) ; set character size to 7 bits + (cs8 control ,CS8) ; set character size to 8 bits + (cstopb control ,CSTOPB) ; use two stop bits per character (one with `-') + (hup control ,HUPCL) ; send a hangup signal when the last process closes the tty + (hupcl control ,HUPCL) ; same as [-]hup + (parenb control ,PARENB) ; generate parity bit in output and expect parity bit in input + (parodd control ,PARODD) ; set odd parity (even with `-') + + ;; input settings + (brkint input ,BRKINT) ; breaks cause an interrupt signal + (icrnl input ,ICRNL) ; translate carriage return to newline + (ignbrk input ,IGNBRK) ; ignore break characters + (igncr input ,IGNCR) ; ignore carriage return + (ignpar input ,IGNPAR) ; ignore characters with parity errors + (imaxbel input ,IMAXBEL) ; * beep and do not flush a full input buffer on a character + (inlcr input ,INLCR) ; translate newline to carriage return + (inpck input ,INPCK) ; enable input parity checking + (istrip input ,ISTRIP) ; clear high (8th) bit of input characters + ;;(iuclc input ,IUCLC) ; * translate uppercase characters to lowercase + (ixany input ,IXANY) ; * let any character restart output, not only start character + (ixoff input ,IXOFF) ; enable sending of start/stop characters + (ixon input ,IXON) ; enable XON/XOFF flow control + (parmrk input ,PARMRK) ; mark parity errors (with a 255-0-character sequence) + (tandem input ,IXOFF) ; same as [-]ixoff + + ;; output settings + ;;(bs0 output ,BS0) ; backspace delay style, N in [0..1] + ;;(bs1 output ,BS1) ; backspace delay style, N in [0..1] + ;;(cr0 output ,CR0) ; carriage return delay style, N in [0..3] + ;;(cr1 output ,CR1) ; carriage return delay style, N in [0..3] + ;;(cr2 output ,CR2) ; carriage return delay style, N in [0..3] + ;;(cr3 output ,CR3) ; carriage return delay style, N in [0..3] + ;;(ff0 output ,FF0) ; form feed delay style, N in [0..1] + ;;(ff1 output ,FF1) ; form feed delay style, N in [0..1] + ;;(nl0 output ,NL0) ; newline delay style, N in [0..1] + ;;(nl1 output ,NL1) ; newline delay style, N in [0..1] + (ocrnl output ,OCRNL) ; translate carriage return to newline + ;;(ofdel output ,OFDEL) ; use delete characters for fill instead of null characters + ;;(ofill output ,OFILL) ; use fill (padding) characters instead of timing for delays + ;;(olcuc output ,OLCUC) ; translate lowercase characters to uppercase + (onlcr output ,ONLCR) ; translate newline to carriage return-newline + (onlret output ,ONLRET) ; newline performs a carriage return + (onocr output ,ONOCR) ; do not print carriage returns in the first column + (opost output ,OPOST) ; postprocess output + (tab0 output #f) ; horizontal tab delay style, N in [0..3] + (tab1 output #f) ; horizontal tab delay style, N in [0..3] + (tab2 output #f) ; horizontal tab delay style, N in [0..3] + (tab3 output #f) ; horizontal tab delay style, N in [0..3] + (tabs output #f) ; same as tab0 + ;;(-tabs output #f) ; same as tab3 + ;;(vt0 output ,VT0) ; vertical tab delay style, N in [0..1] + ;;(vt1 output ,VT1) ; vertical tab delay style, N in [0..1] + + ;; local settings + (crterase local ,ECHOE) ; echo erase characters as backspace-space-backspace + (crtkill local ,ECHOKE) ; kill all line by obeying the echoprt and echoe settings + ;;(-crtkill local #f) ; kill all line by obeying the echoctl and echok settings + (ctlecho local ,ECHOCTL) ; echo control characters in hat notation (`^c') + (echo local ,ECHO) ; echo input characters + (echoctl local ,ECHOCTL) ; same as [-]ctlecho + (echoe local ,ECHOE) ; same as [-]crterase + ;;(echok local ,ECHOK) ; echo a newline after a kill character + (echoke local ,ECHOKE) ; same as [-]crtkill + (echonl local ,ECHONL) ; echo newline even if not echoing other characters + (echoprt local ,ECHOPRT) ; echo erased characters backward, between `\' and '/' + (icanon local ,ICANON) ; enable erase, kill, werase, and rprnt special characters + ;;(iexten local ,IEXTEN) ; enable non-POSIX special characters + (isig local ,ISIG) ; enable interrupt, quit, and suspend special characters + (noflsh local ,NOFLSH) ; disable flushing after interrupt and quit special characters + (prterase local ,ECHOPRT) ; same as [-]echoprt + (tostop local ,TOSTOP) ; stop background jobs that try to write to the terminal + ;;(xcase local ,XCASE) ; with icanon, escape with `\' for uppercase characters + + ;; combination settings + (LCASE combine (lcase)) + (cbreak combine (not icanon)) + (cooked combine (brkint ignpar istrip icrnl ixon opost isig icanon)) + ; also eof and eol characters + ; to their default values + (crt combine (echoe echoctl echoke)) + (dec combine (echoe echoctl echoke (not ixany))) + ; also intr ^c erase 0177 kill ^u + (decctlq combine (ixany)) + (ek combine ()) ; erase and kill characters to their default values + (evenp combine (parenb (not parodd) cs7)) + ;;(-evenp combine #f) ; same as -parenb cs8 + (lcase combine (xcase iuclc olcuc)) + (litout combine (cs8 (not parenb istrip opost))) + ;;(-litout combine #f) ; same as parenb istrip opost cs7 + (nl combine (not icrnl onlcr)) + ;;(-nl combine #f) ; same as icrnl -inlcr -igncr onlcr -ocrnl -onlret + (oddp combine (parenb parodd cs7)) + (parity combine (evenp)) ; same as [-]evenp + (pass8 combine (cs8 (not parenb istrip))) + ;;(-pass8 combine #f) ; same as parenb istrip cs7 + (raw combine (not ignbrk brkint ignpar parmrk + inpck istrip inlcr igncr icrnl)) + (ixon combine (ixoff ixany imaxbel opost isig icanon)) ;; xcase iuclc + ;;(time combine #f) ; 0 + ;;(-raw combine #f) ; same as cooked + (sane combine (cread brkint icrnl imaxbel opost onlcr + isig icanon ;; nl0 cr0 bs0 vt0 ff0 ; tab0 + echo echoe echoctl echoke ;; iexten echok + (not ignbrk igncr ixoff ixany inlcr ;; iuclc + ocrnl onocr onlret ;; olcuc ofill ofdel + echonl noflsh tostop echoprt))) ;; xcase + ; plus all special characters to + ; their default values + )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; high-level interface + +(define (port? x) (or (input-port? x) (output-port? x))) + +(define (stty . args) + (let* ((port (if (and (pair? args) (port? (car args))) + (car args) + (current-output-port))) + (attr (get-terminal-attributes port))) + ;; parse change requests + (let lp ((lst (if (and (pair? args) (port? (car args))) (cdr args) args)) + (iflag (term-attrs-iflag attr)) + (oflag (term-attrs-oflag attr)) + (cflag (term-attrs-cflag attr)) + (lflag (term-attrs-lflag attr)) + (invert? #f) + (return (lambda (iflag oflag cflag lflag) + (term-attrs-iflag-set! attr iflag) + (term-attrs-oflag-set! attr oflag) + (term-attrs-cflag-set! attr cflag) + (term-attrs-lflag-set! attr lflag) + (set-terminal-attributes! port TCSANOW attr)))) + (define (join old new) + (if invert? (bitwise-and old (bitwise-not new)) (bitwise-ior old new))) + (cond + ((pair? lst) + (let ((command (car lst))) + (cond + ((pair? command) ;; recurse on sub-expr + (lp command iflag oflag cflag lflag invert? + (lambda (i o c l) (lp (cdr lst) i o c l invert? return)))) + ((eq? command 'not) ;; toggle current setting + (lp (cdr lst) iflag oflag cflag lflag (not invert?) return)) + (else + (let ((x (hash-table-ref/default stty-lookup command #f))) + (case (and x (car x)) + ((input) + (lp (cdr lst) (join iflag (cadr x)) oflag cflag lflag invert? return)) + ((output) + (lp (cdr lst) iflag (join oflag (cadr x)) cflag lflag invert? return)) + ((control) + (lp (cdr lst) iflag oflag (join cflag (cadr x)) lflag invert? return)) + ((local) + (lp (cdr lst) iflag oflag cflag (join lflag (cadr x)) invert? return)) + ((char) + ;;(term-attrs-cc-set! attr (cadr x) (or (cadr lst) 0)) + (lp (cddr lst) iflag oflag cflag lflag invert? return)) + ((combine) + (lp (cadr x) iflag oflag cflag lflag invert? + (lambda (i o c l) (lp (cdr lst) i o c l invert? return)))) + ((special) + (error "special settings not yet supported" command)) + (else + (error "unknown stty command" command)))))))) + (else + (return iflag oflag cflag lflag)))))) + +(define (with-stty setting thunk . o) + (let* ((port (if (pair? o) (car o) (current-input-port))) + (orig-attrs (get-terminal-attributes port))) + (dynamic-wind + (lambda () (stty setting)) + thunk + (lambda () (set-terminal-attributes! port TCSANOW orig-attrs))))) + +(define (with-raw-io port thunk) + (with-stty '(not icanon echo) thunk port)) + +(define (get-terminal-width x) + (let ((ws (ioctl x TIOCGWINSZ))) + (and ws (winsize-col ws)))) + +(define (get-terminal-dimensions x) + (let ((ws (ioctl x TIOCGWINSZ))) + (and ws (list (winsize-col ws) (winsize-row ws))))) diff --git a/lib/chibi/stty.stub b/lib/chibi/stty.stub new file mode 100644 index 00000000..3c5939c5 --- /dev/null +++ b/lib/chibi/stty.stub @@ -0,0 +1,106 @@ + +(c-system-include "termios.h") +(c-system-include "sys/ioctl.h") + +(define-c-struct termios + predicate: term-attrs? + constructor: (make-term-attrs) + (unsigned-long c_iflag term-attrs-iflag term-attrs-iflag-set!) + (unsigned-long c_oflag term-attrs-oflag term-attrs-oflag-set!) + (unsigned-long c_cflag term-attrs-cflag term-attrs-cflag-set!) + (unsigned-long c_lflag term-attrs-lflag term-attrs-lflag-set!) + ;;(unsigned-char (c_cc 22) term-attrs-cc term-attrs-cc-set!) + (unsigned-long c_ispeed term-attrs-ispeed term-attrs-ispeed-set!) + (unsigned-long c_ospeed term-attrs-ospeed term-attrs-ospeed-set!)) + +(define-c-struct winsize + predicate: winsize? + (unsigned-short ws_row winsize-row) + (unsigned-short ws_col winsize-col)) + +(define-c errno ioctl (port-or-fd unsigned-long (result winsize))) + +(define-c-const int TIOCGWINSZ) + +(define-c-const int TCSANOW) +(define-c-const int TCSADRAIN) +(define-c-const int TCSAFLUSH) + +(define-c-const unsigned-long IGNBRK) +(define-c-const unsigned-long BRKINT) +(define-c-const unsigned-long IGNPAR) +(define-c-const unsigned-long PARMRK) +(define-c-const unsigned-long INPCK) +(define-c-const unsigned-long ISTRIP) +(define-c-const unsigned-long INLCR) +(define-c-const unsigned-long IGNCR) +(define-c-const unsigned-long ICRNL) +(define-c-const unsigned-long IXON) +(define-c-const unsigned-long IXOFF) +(define-c-const unsigned-long IXANY) +(define-c-const unsigned-long IMAXBEL) +;; (define-c-const unsigned-long IUCLC) + +(define-c-const unsigned-long OPOST) +(define-c-const unsigned-long ONLCR) +;; (define-c-const unsigned-long OXTABS) +;; (define-c-const unsigned-long ONOEOT) +(define-c-const unsigned-long OCRNL) +;; (define-c-const unsigned-long OLCUC) +(define-c-const unsigned-long ONOCR) +(define-c-const unsigned-long ONLRET) + +(define-c-const unsigned-long CSIZE) +(define-c-const unsigned-long CS5) +(define-c-const unsigned-long CS6) +(define-c-const unsigned-long CS7) +(define-c-const unsigned-long CS8) +(define-c-const unsigned-long CSTOPB) +(define-c-const unsigned-long CREAD) +(define-c-const unsigned-long PARENB) +(define-c-const unsigned-long PARODD) +(define-c-const unsigned-long HUPCL) +(define-c-const unsigned-long CLOCAL) +;; (define-c-const unsigned-long CCTS_OFLOW) +(define-c-const unsigned-long CRTSCTS) +;; (define-c-const unsigned-long CRTS_IFLOW) +;; (define-c-const unsigned-long MDMBUF) + +(define-c-const unsigned-long ECHOKE) +(define-c-const unsigned-long ECHOE) +(define-c-const unsigned-long ECHO) +(define-c-const unsigned-long ECHONL) +(define-c-const unsigned-long ECHOPRT) +(define-c-const unsigned-long ECHOCTL) +(define-c-const unsigned-long ISIG) +(define-c-const unsigned-long ICANON) +;; (define-c-const unsigned-long ALTWERASE) +(define-c-const unsigned-long IEXTEN) +;; (define-c-const unsigned-long EXTPROC) +(define-c-const unsigned-long TOSTOP) +(define-c-const unsigned-long FLUSHO) +;; (define-c-const unsigned-long NOKERNINFO) +(define-c-const unsigned-long PENDIN) +(define-c-const unsigned-long NOFLSH) + +(define-c-const unsigned-long VEOF) +(define-c-const unsigned-long VEOL) +(define-c-const unsigned-long VEOL2) +(define-c-const unsigned-long VERASE) +;; (define-c-const unsigned-long VERASE2) +(define-c-const unsigned-long VWERASE) +(define-c-const unsigned-long VINTR) +(define-c-const unsigned-long VKILL) +(define-c-const unsigned-long VQUIT) +(define-c-const unsigned-long VSUSP) +(define-c-const unsigned-long VSTART) +(define-c-const unsigned-long VSTOP) +;; (define-c-const unsigned-long VDSUSP) +(define-c-const unsigned-long VLNEXT) +(define-c-const unsigned-long VREPRINT) +;; (define-c-const unsigned-long VSTATUS) + +(define-c errno (get-terminal-attributes "tcgetattr") + (port-or-fd (result termios))) +(define-c errno (set-terminal-attributes! "tcsetattr") + (port-or-fd int termios)) diff --git a/lib/chibi/system.module b/lib/chibi/system.module new file mode 100644 index 00000000..adc26ddc --- /dev/null +++ b/lib/chibi/system.module @@ -0,0 +1,15 @@ + +(define-module (chibi system) + (export user-information user-name user-password + user-id user-group-id user-gecos user-home user-shell + current-user-id current-group-id + current-effective-user-id current-effective-group-id + set-current-user-id! set-current-effective-user-id! + set-current-group-id! set-current-effective-group-id! + current-session-id create-session + set-root-directory!) + (import-immutable (scheme)) + (include-shared "system") + ;;(include "system.scm") + ) + diff --git a/lib/chibi/system.stub b/lib/chibi/system.stub new file mode 100644 index 00000000..7d4a836f --- /dev/null +++ b/lib/chibi/system.stub @@ -0,0 +1,34 @@ + +(c-system-include "unistd.h") +(c-system-include "pwd.h") +(c-system-include "sys/types.h") + +(define-c-struct passwd + predicate: user? + (string pw_name user-name) + (string pw_passwd user-password) + (uid_t pw_uid user-id) + (gid_t pw_gid user-group-id) + (string pw_gecos user-gecos) + (string pw_dir user-home) + (string pw_shell user-shell)) + +(define-c uid_t (current-user-id "getuid") ()) +(define-c gid_t (current-group-id "getgid") ()) +(define-c uid_t (current-effective-user-id "geteuid") ()) +(define-c gid_t (current-effective-group-id "getegid") ()) + +(define-c errno (set-current-user-id! "setuid") (uid_t)) +(define-c errno (set-current-effective-user-id! "seteuid") (uid_t)) +(define-c errno (set-current-group-id! "setgid") (gid_t)) +(define-c errno (set-current-effective-group-id! "setegid") (gid_t)) + +(define-c pid_t (current-session-id "getsid") ((default 0 pid_t))) +(define-c pid_t (create-session "setsid") ()) + +(define-c errno (set-root-directory! "chroot") (string)) + +;; (define-c errno getpwuid_r +;; (uid_t (result passwd) (result (array char arg3)) +;; (value 256 int) (result pointer passwd))) + diff --git a/lib/chibi/term/edit-line.module b/lib/chibi/term/edit-line.module new file mode 100644 index 00000000..d8116473 --- /dev/null +++ b/lib/chibi/term/edit-line.module @@ -0,0 +1,5 @@ + +(define-module (chibi term edit-line) + (export edit-line edit-line-repl) + (import-immutable (scheme) (chibi stty) (srfi 9)) + (include "edit-line.scm")) diff --git a/lib/chibi/term/edit-line.scm b/lib/chibi/term/edit-line.scm new file mode 100644 index 00000000..1c985919 --- /dev/null +++ b/lib/chibi/term/edit-line.scm @@ -0,0 +1,505 @@ +;;;; edit-line.scm - pure scheme line editing tool +;; +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; vt100 terminal utilities + +(define (terminal-escape out ch arg) + (write-char (integer->char 27) out) + (write-char #\[ out) + (if arg (display arg out)) + (write-char ch out)) + +;; we use zero-based columns +(define (terminal-goto-col out n) (terminal-escape out #\G (+ n 1))) +(define (terminal-up out n) (terminal-escape out #\A n)) +(define (terminal-down out n) (terminal-escape out #\B n)) +(define (terminal-clear-below out) (terminal-escape out #\J #f)) +(define (terminal-clear-right out) (terminal-escape out #\K #f)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; history + +(define maximum-history-size 128) + +(define-record-type history + (%make-history remaining past future) + history? + (remaining history-remaining history-remaining-set!) + (past history-past history-past-set!) + (future history-future history-future-set!)) + +(define (make-history . o) + (%make-history (if (pair? o) (car o) maximum-history-size) '() '())) + +(define (history-current h) + (let ((p (history-past h))) + (and (pair? p) (car p)))) + +(define (history->list h) + (let ((past (history-past h)) (future (history-future h))) + (if (pair? past) (cons (car past) (append future (cdr past))) future))) + +(define (history-flatten! h) + (history-past-set! h (history->list h)) + (history-future-set! h '())) + +(define (drop-last ls) (reverse (cdr (reverse ls)))) + +(define (history-past-push! h x) + (if (positive? (history-remaining h)) + (history-remaining-set! h (- (history-remaining h) 1)) + (if (pair? (history-past h)) + (history-past-set! h (drop-last (history-past h))) + (history-future-set! h (drop-last (history-future h))))) + (history-past-set! h (cons x (history-past h)))) + +(define (history-insert! h x) + (history-flatten! h) + (history-past-push! h x)) + +(define (history-commit! h x) + (cond + ((pair? (history-future h)) + (history-past-set! + h (cons x (append (drop-last (history-future h)) (history-past h)))) + (history-future-set! h '())) + (else + (history-insert! h x)))) + +(define (history-prev! h) + (let ((past (history-past h))) + (and (pair? past) + (pair? (cdr past)) + (begin + (history-future-set! h (cons (car past) (history-future h))) + (history-past-set! h (cdr past)) + (cadr past))))) + +(define (history-next! h) + (let ((future (history-future h))) + (and (pair? future) + (begin + (history-past-set! h (cons (car future) (history-past h))) + (history-future-set! h (cdr future)) + (car future))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; char and string utils + +(define (char-word-constituent? ch) + (or (char-alphabetic? ch) (char-numeric? ch) + (memv ch '(#\_ #\- #\+ #\:)))) + +(define (char-non-word-constituent? ch) (not (char-word-constituent? ch))) + +(define (string-copy! dst dstart src start end) + (if (>= start dstart) + (do ((i start (+ i 1)) (j dstart (+ j 1))) + ((= i end)) + (string-set! dst j (string-ref src i))) + (do ((i (- end 1) (- i 1)) (j (+ dstart (- end start 1)) (- j 1))) + ((< i start)) + (string-set! dst j (string-ref src i))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; buffers + +(define-record-type buffer + (%make-buffer refresh? min pos row max-row col gap width string history) + buffer? + (refresh? buffer-refresh? buffer-refresh?-set!) + (min buffer-min buffer-min-set!) + (pos buffer-pos buffer-pos-set!) + (row buffer-row buffer-row-set!) + (max-row buffer-max-row buffer-max-row-set!) + (col buffer-col buffer-col-set!) + (gap buffer-gap buffer-gap-set!) + (width buffer-width buffer-width-set!) + (string buffer-string buffer-string-set!) + (kill-ring buffer-kill-ring buffer-kill-ring-set!) + (history buffer-history buffer-history-set!)) + +(define default-buffer-size 256) +(define default-buffer-width 80) + +(define (make-buffer) + (%make-buffer #f 0 0 0 0 0 default-buffer-size default-buffer-width + (make-string default-buffer-size) '())) + +(define (buffer->string buf) + (let ((str (buffer-string buf))) + (string-append (substring str (buffer-min buf) (buffer-pos buf)) + (substring str (buffer-gap buf) (string-length str))))) + +(define (buffer-right-length buf) + (- (string-length (buffer-string buf)) (buffer-gap buf))) +(define (buffer-length buf) + (+ (buffer-pos buf) (buffer-right-length buf))) +(define (buffer-free-space buf) + (- (buffer-gap buf) (buffer-pos buf))) + +(define (buffer-clamp buf n) + (max (buffer-min buf) (min n (buffer-length buf)))) + +(define (buffer-resize buf n) + (cond ((<= (buffer-free-space buf) n) + (let* ((right-len (buffer-right-length buf)) + (new-len (* 2 (max n (buffer-length buf)))) + (new-gap (- new-len right-len)) + (new (make-string new-len)) + (old (buffer-string buf))) + (string-copy! new 0 old 0 (buffer-pos buf)) + (string-copy! new new-gap old (buffer-gap buf) (string-length old)) + (buffer-string-set! buf new) + (buffer-gap-set! buf new-gap))))) + +(define (buffer-update-position! buf) + (let ((pos (buffer-pos buf)) + (gap (buffer-gap buf)) + (end (string-length (buffer-string buf))) + (width (buffer-width buf))) + (let lp ((i 0) (row 0) (col 0)) ;; update row/col + (cond ((= i pos) + (buffer-row-set! buf row) + (buffer-col-set! buf col) + (lp gap row col)) + ((>= i end) + (buffer-max-row-set! + buf (if (and (zero? col) (> row 0)) (- row 1) row))) + ((= (+ col 1) width) + (lp (+ i 1) (+ row 1) 0)) + (else + (lp (+ i 1) row (+ col 1))))))) + +(define (buffer-draw buf out) + (let* ((gap (buffer-gap buf)) + (str (buffer-string buf)) + (end (string-length str)) + (old-row (buffer-row buf)) + (old-col (buffer-col buf))) + (buffer-update-position! buf) + ;; goto start of input + (terminal-goto-col out 0) + (if (positive? old-row) + (terminal-up out old-row)) + ;; clear and display new buffer + (terminal-clear-below out) + (display (substring str 0 (buffer-pos buf)) out) + (display (substring str (buffer-gap buf) end) out) + ;; move to next line if point at eol + (if (and (zero? (buffer-col buf)) (positive? (buffer-row buf))) + (write-char #\space out)) + ;; move to correct row then col + (if (< (buffer-row buf) (buffer-max-row buf)) + (terminal-up out (- (buffer-max-row buf) (buffer-row buf)))) + (terminal-goto-col out (buffer-col buf)))) + +(define (buffer-refresh buf out) + (cond ((buffer-refresh? buf) + (buffer-draw buf out) + (buffer-refresh?-set! buf #f)))) + +(define (buffer-goto! buf out n) + (let ((pos (buffer-pos buf)) + (gap (buffer-gap buf)) + (str (buffer-string buf)) + (n (buffer-clamp buf n))) + (cond ((not (= n pos)) + (buffer-update-position! buf) ;; XXXX shouldn't be needed + (if (< n pos) + (string-copy! str (- gap (- pos n)) str n pos) + (string-copy! str pos str gap (+ gap (- n pos)))) + (buffer-pos-set! buf n) + (buffer-gap-set! buf (+ gap (- n pos))) + (cond + ((not (buffer-refresh? buf)) + (let ((old-row (buffer-row buf))) + (buffer-update-position! buf) + (let ((row-diff (- old-row (buffer-row buf)))) + (cond ((> row-diff 0) (terminal-up out row-diff)) + ((< row-diff 0) (terminal-down out (- row-diff))))) + (terminal-goto-col out (buffer-col buf))))))))) + +(define (buffer-insert! buf out x) + (let ((len (if (char? x) 1 (string-length x))) + (pos (buffer-pos buf))) + (buffer-resize buf len) + (if (char? x) + (string-set! (buffer-string buf) pos x) + (string-copy! (buffer-string buf) pos x 0 len)) + (buffer-pos-set! buf (+ (buffer-pos buf) len)) + (cond + ((buffer-refresh? buf)) + ((and (= (buffer-gap buf) (string-length (buffer-string buf))) + (< (+ (buffer-col buf) len) (buffer-width buf))) + ;; fast path - append to end of buffer w/o wrapping to next line + (display x out) + (buffer-col-set! buf (+ (buffer-col buf) len))) + (else + (buffer-refresh?-set! buf #t))))) + +(define (buffer-delete! buf out start end) + (let ((pos (buffer-pos buf)) + (gap (buffer-gap buf)) + (str (buffer-string buf)) + (start (buffer-clamp buf start)) + (end (buffer-clamp buf end))) + (if (not (buffer-refresh? buf)) + (if (and (= start pos) (>= end (buffer-length buf))) + (terminal-clear-below out) + (buffer-refresh?-set! buf #t))) + (cond ((< end pos) + (string-copy! str start str end pos) + (buffer-pos-set! buf (+ start (- pos end)))) + ((> start gap) + (string-copy! str start str gap (+ gap (- end start))) + (buffer-gap-set! buf (+ gap (- end start)))) + (else + (buffer-pos-set! buf (min pos start)) + (buffer-gap-set! buf (max gap (+ pos (- gap pos) (- end pos)))))))) + +(define (buffer-skip buf pred) + (let* ((str (buffer-string buf)) (end (string-length str))) + (let lp ((i (buffer-gap buf))) + (if (or (>= i end) (not (pred (string-ref str i)))) + (+ (- i (buffer-gap buf)) (buffer-pos buf)) + (lp (+ i 1)))))) + +(define (buffer-skip-reverse buf pred) + (let ((str (buffer-string buf))) + (let lp ((i (- (buffer-pos buf) 1))) + (if (or (< i 0) (not (pred (string-ref str i)))) i (lp (- i 1)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; keymaps + +(define keymap? pair?) + +(define (make-keymap . o) + (cons (make-vector 256 #f) (and (pair? o) (car o)))) + +(define (make-sparse-keymap . o) + (cons '() (and (pair? o) (car o)))) + +(define (make-printable-keymap) + (let* ((keymap (make-keymap)) + (v (car keymap))) + (do ((i #x20 (+ i 1))) ((= i #x7F) keymap) + (vector-set! v i command/self-insert)))) + +(define (make-standard-escape-bracket-keymap) + (let* ((keymap (make-keymap)) + (v (car keymap))) + (vector-set! v 65 command/backward-history) + (vector-set! v 66 command/forward-history) + (vector-set! v 67 command/forward-char) + (vector-set! v 68 command/backward-char) + keymap)) + +(define (make-standard-escape-keymap) + (let* ((keymap (make-keymap)) + (v (car keymap))) + (vector-set! v 8 command/backward-delete-word) + (vector-set! v 91 (make-standard-escape-bracket-keymap)) + (vector-set! v 98 command/backward-word) + (vector-set! v 100 command/forward-delete-word) + (vector-set! v 102 command/forward-word) + (vector-set! v 127 command/backward-delete-word) + keymap)) + +(define (make-standard-keymap) + (let* ((keymap (make-printable-keymap)) + (v (car keymap))) + (vector-set! v 1 command/beggining-of-line) + (vector-set! v 2 command/backward-char) + (vector-set! v 4 command/forward-delete-char) + (vector-set! v 5 command/end-of-line) + (vector-set! v 6 command/forward-char) + (vector-set! v 8 command/backward-delete-char) + (vector-set! v 10 command/enter) + (vector-set! v 11 command/forward-delete-line) + (vector-set! v 12 command/refresh) + (vector-set! v 13 command/enter) + (vector-set! v 21 command/backward-delete-line) + (vector-set! v 27 (make-standard-escape-keymap)) + (vector-set! v 127 command/backward-delete-char) + keymap)) + +(define (keymap-lookup keymap n) + (let ((table (car keymap))) + (or (if (vector? table) + (and (< n (vector-length table)) (vector-ref table n)) + (cond ((assv n table) => cdr) (else #f))) + (if (keymap? (cdr keymap)) + (keymap-lookup (cdr keymap) n) + (cdr keymap))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; commands + +(define (command/self-insert ch buf out return) + (buffer-insert! buf out ch)) + +(define (command/enter ch buf out return) + (command/end-of-line ch buf out return) + (newline out) + (return)) + +(define (command/beep ch buf out return) + (write-char (integer->char 7) out)) + +(define (command/refresh ch buf out return) + (buffer-draw buf out)) + +(define (command/beggining-of-line ch buf out return) + (buffer-goto! buf out 0)) + +(define (command/end-of-line ch buf out return) + (buffer-goto! buf out (buffer-length buf))) + +(define (command/forward-char ch buf out return) + (buffer-goto! buf out (+ (buffer-pos buf) 1))) + +(define (command/backward-char ch buf out return) + (buffer-goto! buf out (- (buffer-pos buf) 1))) + +(define (command/forward-delete-char ch buf out return) + (cond + ((zero? (- (buffer-length buf) (buffer-min buf))) + (newline out) + (return 'eof)) + (else + (buffer-delete! buf out (buffer-pos buf) (+ (buffer-pos buf) 1))))) + +(define (command/backward-delete-char ch buf out return) + (buffer-delete! buf out (- (buffer-pos buf) 1) (buffer-pos buf))) + +(define (command/forward-delete-line ch buf out return) + (buffer-delete! buf out (buffer-pos buf) (buffer-length buf))) + +(define (command/backward-delete-line ch buf out return) + (buffer-delete! buf out 0 (buffer-pos buf))) + +(define (command/backward-history ch buf out return) + (let ((history (buffer-history buf))) + (cond + ((and (history? history) (pair? (history-past history))) + (if (null? (history-future history)) + (history-insert! history (buffer->string buf))) + (cond + ((pair? (cdr (history-past history))) + (buffer-delete! buf out 0 (buffer-length buf)) + (buffer-insert! buf out (history-prev! history)))))))) + +(define (command/forward-history ch buf out return) + (let ((history (buffer-history buf))) + (cond + ((and (history? history) (pair? (history-future history))) + (buffer-delete! buf out 0 (buffer-length buf)) + (let ((res (buffer-insert! buf out (history-next! history)))) + (if (null? (history-future history)) + (history-past-set! history (cdr (history-past history)))) + res))))) + +(define (command/forward-word ch buf out return) + (buffer-goto! buf out (buffer-skip buf char-non-word-constituent?)) + (buffer-goto! buf out (buffer-skip buf char-word-constituent?))) + +(define (command/backward-word ch buf out return) + (buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?)) + (buffer-goto! buf out (+ (buffer-skip-reverse buf char-word-constituent?) 1))) + +(define (command/forward-delete-word ch buf out return) + (let ((start (buffer-pos buf))) + (buffer-goto! buf out (buffer-skip buf char-non-word-constituent?)) + (buffer-delete! buf out start (buffer-skip buf char-word-constituent?)))) + +(define (command/backward-delete-word ch buf out return) + (let ((end (buffer-pos buf))) + (buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?)) + (let ((start (buffer-skip-reverse buf char-word-constituent?))) + (buffer-delete! buf out (+ start 1) end)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; line-editing + +(define standard-keymap (make-standard-keymap)) + +(define (get-key ls key . o) + (let ((x (memq key ls))) + (if (and x (pair? (cdr x))) (cadr x) (and (pair? o) (car o))))) + +(define (with-leading-ports ls proc) + (if (and (pair? ls) (input-port? (car ls))) + (if (and (pair? (cdr ls)) (output-port? (cadr ls))) + (proc (car ls) (cadr ls) (cddr ls)) + (proc (car ls) (current-output-port) (cdr ls))) + (proc (current-input-port) (current-output-port) ls))) + +(define (make-line-editor . args) + (let* ((prompt (get-key args 'prompt: "> ")) + (history (get-key args 'history:)) + (terminal-width (get-key args 'terminal-width:)) + (keymap (get-key args 'keymap: standard-keymap))) + (lambda (in out) + (let* ((width (or terminal-width (get-terminal-width out))) + (buf (make-buffer)) + (done? #f) + (return (lambda o (set! done? (if (pair? o) (car o) #t))))) + (buffer-refresh?-set! buf #t) + (buffer-width-set! buf width) + (buffer-insert! buf out prompt) + (buffer-min-set! buf (string-length prompt)) + (buffer-history-set! buf history) + (buffer-refresh buf out) + (flush-output out) + ((if (get-key args 'no-stty?:) (lambda (out f) (f)) with-raw-io) + out + (lambda () + (let lp ((kmap keymap)) + (let ((ch (read-char in))) + (if (eof-object? ch) + (let ((res (buffer->string buf))) + (if (equal? res "") ch res)) + (let ((x (keymap-lookup kmap (char->integer ch)))) + (cond + ((keymap? x) + (lp x)) + ((procedure? x) + (x ch buf out return) + (buffer-refresh buf out) + (if done? + (and (not (eq? done? 'eof)) (buffer->string buf)) + (lp keymap))) + (else + ;;(command/beep ch buf out return) + (lp keymap))))))))))))) + +(define (edit-line . args) + (with-leading-ports + args + (lambda (in out rest) ((apply make-line-editor rest) in out)))) + +(define (edit-line-repl . args) + (with-leading-ports + args + (lambda (in out rest) + (let ((eval (get-key rest 'eval: (lambda (x) x))) + (print (get-key rest 'write: write)) + (history (or (get-key rest 'history:) (make-history)))) + (let ((edit-line + (apply make-line-editor 'no-stty?: #t 'history: history rest))) + ((if (get-key args 'no-stty?:) (lambda (out f) (f)) with-raw-io) + out + (lambda () + (let lp () + (let ((line (edit-line in out))) + (if (pair? (history-future history)) + (history-past-set! history (cdr (history-past history)))) + (history-commit! history line) + (print (eval line) out) + (newline out) + (lp)))))))))) diff --git a/lib/chibi/test.module b/lib/chibi/test.module new file mode 100644 index 00000000..d8b405f1 --- /dev/null +++ b/lib/chibi/test.module @@ -0,0 +1,14 @@ + +(define-module (chibi test) + (export + test test-error test-assert test-values + test-group current-test-group + test-begin test-end test-syntax-error test-info + test-vars test-run ;;test-exit + current-test-verbosity current-test-epsilon current-test-comparator + current-test-applier current-test-handler current-test-skipper + current-test-group-reporter test-failure-count) + (import-immutable (scheme)) + (import (srfi 39) (srfi 98) (chibi time) (chibi ast)) + (include "test.scm")) + diff --git a/lib/chibi/test.scm b/lib/chibi/test.scm new file mode 100644 index 00000000..bfa7429e --- /dev/null +++ b/lib/chibi/test.scm @@ -0,0 +1,662 @@ +;;;; test.scm -- testing framework +;; +;; Easy to use test suite adapted from the Chicken "test" module. +;; +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; exception utilities + +;; from SRFI-12, pending stabilization of an exception library for WG1 +(define-syntax handle-exceptions + (syntax-rules () + ((handle-exceptions exn handler body ...) + (call-with-current-continuation + (lambda (return) + (with-exception-handler + (lambda (exn) (return handler)) + (lambda () body ...))))))) + +(define (warning msg . args) + (display msg (current-error-port)) + (for-each (lambda (x) + (write-char #\space (current-error-port)) + (write x (current-error-port))) + args) + (newline (current-error-port))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utilities + +(define (string-search pat str) + (let* ((pat-len (string-length pat)) + (limit (- (string-length str) pat-len))) + (let lp1 ((i 0)) + (cond + ((>= i limit) #f) + (else + (let lp2 ((j i) (k 0)) + (cond ((>= k pat-len) #t) + ((not (eqv? (string-ref str j) (string-ref pat k))) + (lp1 (+ i 1))) + (else (lp2 (+ j 1) (+ k 1)))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; time utilities + +(define (timeval-difference tv1 tv2) + (let ((seconds (- (timeval-seconds tv1) (timeval-seconds tv2))) + (ms (- (timeval-microseconds tv1) (timeval-microseconds tv2)))) + (+ (max seconds 0.0) (/ ms 1000000.0)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; test interface + +(define-syntax test + (syntax-rules () + ((test expect expr) + (test #f expect expr)) + ((test name expect (expr ...)) + (test-info name expect (expr ...) ())) + ((test name (expect ...) expr) + (test-syntax-error + 'test + "the test expression should come last " + (test name (expect ...) expr))) + ((test name expect expr) + (test-info name expect expr ())) + ((test a ...) + (test-syntax-error 'test "2 or 3 arguments required" + (test a ...))))) + +(define-syntax test-assert + (syntax-rules () + ((_ expr) + (test-assert #f expr)) + ((_ name expr) + (test-info name #f expr ((assertion . #t)))) + ((test a ...) + (test-syntax-error 'test-assert "1 or 2 arguments required" + (test a ...))))) + +(define-syntax test-values + (syntax-rules () + ((_ expect expr) + (test-values #f expect expr)) + ((_ name expect expr) + (test name (call-with-values (lambda () expect) (lambda results results)) + (call-with-values (lambda () expr) (lambda results results)))))) + +(define-syntax test-error + (syntax-rules () + ((_ expr) + (test-error #f expr)) + ((_ name expr) + (test-info name #f expr ((expect-error . #t)))) + ((test a ...) + (test-syntax-error 'test-error "1 or 2 arguments required" + (test a ...))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; group interface + +(define-syntax test-group + (syntax-rules () + ((_ name-expr body ...) + (let ((name name-expr) + (old-group (current-test-group))) + (if (not (string? name)) + (error "a name is required, got " 'name-expr name)) + (test-begin name) + (handle-exceptions + exn + (begin + (warning "error in group outside of tests") + (print-exception e (current-error-port)) + (test-group-inc! (current-test-group) 'count) + (test-group-inc! (current-test-group) 'ERROR)) + body ...) + (test-end name) + (current-test-group old-group))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define-syntax test-syntax-error + (syntax-rules () + ((_) (syntax-error "invalid use of test-syntax-error")))) + +(define-syntax test-info + (syntax-rules () + ((test-info name expect expr info) + (test-vars () name expect expr ((source . expr) . info))))) + +(define-syntax test-vars + (syntax-rules () + ((_ (vars ...) n expect expr ((key . val) ...)) + (test-run (lambda () expect) + (lambda () expr) + (cons (cons 'name n) + '((source . expr) + ;;(var-names . (vars ...)) + ;;(var-values . ,(list vars)) + (key . val) ...)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; test-group representation + +;; (name (prop value) ...) +(define (make-test-group name) + (list name + (cons 'start-time (get-time-of-day)))) + +(define test-group-name car) + +(define (test-group-ref group field . o) + (apply assq-ref (cdr group) field o)) + +(define (test-group-set! group field value) + (cond ((assq field (cdr group)) + => (lambda (x) (set-cdr! x value))) + (else (set-cdr! group (cons (cons field value) (cdr group)))))) + +(define (test-group-inc! group field) + (cond ((assq field (cdr group)) + => (lambda (x) (set-cdr! x (+ 1 (cdr x))))) + (else (set-cdr! group (cons (cons field 1) (cdr group)))))) + +(define (test-group-push! group field value) + (cond ((assq field (cdr group)) + => (lambda (x) (set-cdr! x (cons value (cdr x))))) + (else (set-cdr! group (cons (cons field (list value)) (cdr group)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define (assq-ref ls key . o) + (cond ((assq key ls) => cdr) + ((pair? o) (car o)) + (else #f))) + +(define (approx-equal? a b epsilon) + (< (abs (- 1 (abs (if (zero? b) (+ 1 a) (/ a b))))) + epsilon)) + +;; partial pretty printing to abbreviate `quote' forms and the like +(define (write-to-string x) + (call-with-output-string + (lambda (out) + (let wr ((x x)) + (if (pair? x) + (cond + ((and (symbol? (car x)) (pair? (cdr x)) (null? (cddr x)) + (assq (car x) + '((quote . "'") (quasiquote . "`") + (unquote . ",") (unquote-splicing . ",@")))) + => (lambda (s) (display (cdr s) out) (wr (cadr x)))) + (else + (display "(" out) + (wr (car x)) + (let lp ((ls (cdr x))) + (cond ((pair? ls) + (display " " out) + (wr (car ls)) + (lp (cdr ls))) + ((not (null? ls)) + (display " . " out) + (write ls out)))) + (display ")" out))) + (write x out)))))) + +;; if we need to truncate, try first dropping let's to get at the +;; heart of the expression +(define (truncate-source x width . o) + (let* ((str (write-to-string x)) + (len (string-length str))) + (cond + ((<= len width) + str) + ((and (pair? x) (eq? 'let (car x))) + (if (and (pair? o) (car o)) + (truncate-source (car (reverse x)) width #t) + (string-append "..." + (truncate-source (car (reverse x)) (- width 3) #t)))) + ((and (pair? x) (eq? 'call-with-current-continuation (car x))) + (truncate-source (cons 'call/cc (cdr x)) width (and (pair? o) (car o)))) + ((and (pair? x) (eq? 'call-with-values (car x))) + (string-append + "..." + (truncate-source (if (and (pair? (cadr x)) (eq? 'lambda (caadr x))) + (car (reverse (cadr x))) + (cadr x)) + (- width 3) + #t))) + (else + (string-append + (substring str 0 (min (max 0 (- width 3)) (string-length str))) + "..."))))) + +(define (test-get-name! info) + (or + (assq-ref info 'name) + (assq-ref info 'gen-name) + (let ((name + (cond + ((assq-ref info 'source) + => (lambda (src) + (truncate-source src (- (current-column-width) 12)))) + ((current-test-group) + => (lambda (g) + (string-append + "test-" + (number->string (test-group-ref g 'count 0))))) + (else "")))) + (if (pair? info) + (set-cdr! info (cons (cons 'gen-name name) (cdr info)))) + name))) + +(define (test-print-name info . indent) + (let ((width (- (current-column-width) + (or (and (pair? indent) (car indent)) 0))) + (name (test-get-name! info))) + (display name) + (display " ") + (let ((diff (- width 9 (string-length name)))) + (cond + ((positive? diff) + (display (make-string diff #\.))))) + (display " ") + (flush-output))) + +(define (test-group-indent-width group) + (let ((level (max 0 (+ 1 (- (test-group-ref group 'level 0) + (test-first-indentation)))))) + (* 4 (min level (test-max-indentation))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ansi tools + +(define (display-to-string x) + (if (string? x) x (call-with-output-string (lambda (out) (display x out))))) + +(define (red x) (string-append "\x1B[31m" (display-to-string x) "\x1B[0m")) +(define (green x) (string-append "\x1B[32m" (display-to-string x) "\x1B[0m")) +(define (yellow x) (string-append "\x1B[33m" (display-to-string x) "\x1B[0m")) +;; (define (blue x) (string-append "\x1B[34m" (display-to-string x) "\x1B[0m")) +;; (define (magenta x) (string-append "\x1B[35m" (display-to-string x) "\x1B[0m")) +;; (define (cyan x) (string-append "\x1B[36m" (display-to-string x) "\x1B[0m")) +(define (bold x) (string-append "\x1B[1m" (display-to-string x) "\x1B[0m")) +(define (underline x) (string-append "\x1B[4m" (display-to-string x) "\x1B[0m")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (test-run expect expr info) + (if (and (cond ((current-test-group) + => (lambda (g) (not (test-group-ref g 'skip-group?)))) + (else #t)) + (every (lambda (f) (f info)) (current-test-filters))) + ((current-test-applier) expect expr info) + ((current-test-skipper) expect expr info))) + +(define (test-default-applier expect expr info) + (let* ((group (current-test-group)) + (indent (and group (test-group-indent-width group)))) + (cond + ((and group + (equal? 0 (test-group-ref group 'count 0)) + (zero? (test-group-ref group 'subgroups-count 0)) + (test-group-ref group 'verbosity)) + (newline) + (print-header-line + (string-append "testing " (or (test-group-name group) "")) + (or indent 0)))) + (if (and indent (positive? indent)) + (display (make-string indent #\space))) + (test-print-name info indent) + (let ((expect-val + (handle-exceptions + exn + (begin + (warning "bad expect value") + (print-exception exn (current-error-port)) + #f) + (expect)))) + (handle-exceptions + exn + (begin + ((current-test-handler) + (if (assq-ref info 'expect-error) 'PASS 'ERROR) + expect + expr + (append `((exception . ,exn)) info))) + (let ((res (expr))) + (let ((status + (if (and (not (assq-ref info 'expect-error)) + (if (assq-ref info 'assertion) + res + ((current-test-comparator) expect-val res))) + 'PASS + 'FAIL)) + (info `((result . ,res) (expected . ,expect-val) ,@info))) + ((current-test-handler) status expect expr info))))))) + +(define (test-default-skipper expect expr info) + ((current-test-handler) 'SKIP expect expr info)) + +(define (test-default-handler status expect expr info) + (define indent + (make-string + (+ 4 (cond ((current-test-group) + => (lambda (group) (or (test-group-indent-width group) 0))) + (else 0))) + #\space)) + ;; update group info + (cond ((current-test-group) + => (lambda (group) + (if (not (eq? 'SKIP status)) + (test-group-inc! group 'count)) + (test-group-inc! group status)))) + (cond + ((or (eq? status 'FAIL) (eq? status 'ERROR)) + (test-failure-count (+ 1 (test-failure-count))))) + (cond + ((not (eq? status 'SKIP)) + ;; display status + (display "[") + (if (not (eq? status 'ERROR)) (display " ")) ; pad + (display ((if (test-ansi?) + (case status + ((ERROR) (lambda (x) (underline (red x)))) + ((FAIL) red) + ((SKIP) yellow) + (else green)) + (lambda (x) x)) + status)) + (display "]") + (newline) + ;; display status explanation + (cond + ((eq? status 'ERROR) + (display indent) + (cond ((assq 'exception info) + => (lambda (e) + (print-exception (cdr e) (current-output-port)))))) + ((and (eq? status 'FAIL) (assq-ref info 'assertion)) + (display indent) + (display "assertion failed\n")) + ((and (eq? status 'FAIL) (assq-ref info 'expect-error)) + (display indent) + (display "expected an error but got ") + (write (assq-ref info 'result)) (newline)) + ((eq? status 'FAIL) + (display indent) + (display "expected ") (write (assq-ref info 'expected)) + (display " but got ") (write (assq-ref info 'result)) (newline))) + ;; display line, source and values info + (cond + ((or (not (current-test-group)) + (test-group-ref (current-test-group) 'verbosity)) + (case status + ((FAIL ERROR) + (cond + ((assq-ref info 'line-number) + => (lambda (line) + (display " in line ") + (write line) + (cond ((assq-ref info 'file-name) + => (lambda (file) (display " of file ") (write file)))) + (newline)))) + (cond + ((assq-ref info 'source) + => (lambda (s) + (cond + ((or (assq-ref info 'name) + (> (string-length (write-to-string s)) + (current-column-width))) + (display (write-to-string s)) + (newline)))))) + (cond + ((assq-ref info 'values) + => (lambda (v) + (for-each + (lambda (v) + (display " ") (display (car v)) + (display ": ") (write (cdr v)) (newline)) + v)))))))))) + status) + +(define (test-default-group-reporter group) + (define (plural word n) + (if (= n 1) word (string-append word "s"))) + (define (percent n d) + (string-append " (" (number->string (/ (round (* 1000 (/ n d))) 10)) "%)")) + (let* ((end-time (get-time-of-day)) + (start-time (test-group-ref group 'start-time)) + (duration (timeval-difference (car end-time) (car start-time))) + (count (or (test-group-ref group 'count) 0)) + (pass (or (test-group-ref group 'PASS) 0)) + (fail (or (test-group-ref group 'FAIL) 0)) + (err (or (test-group-ref group 'ERROR) 0)) + (skip (or (test-group-ref group 'SKIP) 0)) + (subgroups-count (or (test-group-ref group 'subgroups-count) 0)) + (subgroups-pass (or (test-group-ref group 'subgroups-pass) 0)) + (indent (make-string (or (test-group-indent-width group) 0) #\space))) + (cond + ((or (positive? count) (positive? subgroups-count)) + (if (not (= count (+ pass fail err))) + (warning "inconsistent count:" count pass fail err)) + (display indent) + (cond + ((positive? count) + (write count) (display (plural " test" count)))) + (if (and (positive? count) (positive? subgroups-count)) + (display " and ")) + (cond + ((positive? subgroups-count) + (write subgroups-count) + (display (plural " subgroup" subgroups-count)))) + (display " completed in ") (write duration) (display " seconds") + (cond + ((not (zero? skip)) + (display " (") (write skip) (display (plural " test" skip)) + (display " skipped)"))) + (display ".") (newline) + (cond ((positive? fail) + (display indent) + (display + ((if (test-ansi?) red (lambda (x) x)) + (string-append + (number->string fail) (plural " failure" fail) + (percent fail count) "."))) + (newline))) + (cond ((positive? err) + (display indent) + (display + ((if (test-ansi?) (lambda (x) (underline (red x))) (lambda (x) x)) + (string-append + (number->string err) (plural " error" err) + (percent err count) "."))) + (newline))) + (cond + ((positive? count) + (display indent) + (display + ((if (and (test-ansi?) (= pass count)) green (lambda (x) x)) + (string-append + (number->string pass) " out of " (number->string count) + (percent pass count) (plural " test" pass) " passed."))) + (newline))) + (cond + ((positive? subgroups-count) + (display indent) + (display + ((if (and (test-ansi?) (= subgroups-pass subgroups-count)) + green (lambda (x) x)) + (string-append + (number->string subgroups-pass) " out of " + (number->string subgroups-count) + (percent subgroups-pass subgroups-count) + (plural " subgroup" subgroups-pass) " passed."))) + (newline))) + )) + (print-header-line + (string-append "done testing " (or (test-group-name group) "")) + (or (test-group-indent-width group) 0)) + (newline) + )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (test-equal? expect res) + (or (equal? expect res) + (and (number? expect) + (inexact? expect) + (approx-equal? expect res (current-test-epsilon))))) + +(define (print-header-line str . indent) + (let* ((header (string-append + (make-string (if (pair? indent) (car indent) 0) #\space) + "-- " str " ")) + (len (string-length header))) + (display (if (test-ansi?) (bold header) header)) + (display (make-string (max 0 (- (current-column-width) len)) #\-)) + (newline))) + +(define (test-begin . o) + (let* ((name (if (pair? o) (car o) "")) + (group (make-test-group name)) + (parent (current-test-group))) + (cond + ((and parent + (equal? 0 (test-group-ref parent 'count 0)) + (zero? (test-group-ref parent 'subgroups-count 0)) + (test-group-ref parent 'verbosity)) + (newline) + (print-header-line + (string-append "testing " (test-group-name parent)) + (or (test-group-indent-width parent) 0)))) + (test-group-set! group 'parent parent) + (test-group-set! group 'verbosity + (if parent + (test-group-ref parent 'verbosity) + (current-test-verbosity))) + (test-group-set! group 'level + (if parent + (+ 1 (test-group-ref parent 'level 0)) + 0)) + (test-group-set! + group + 'skip-group? + (or (and parent (test-group-ref parent 'skip-group?)) + (not (every (lambda (f) (f group)) (current-test-group-filters))))) + (current-test-group group))) + +(define (test-end . o) + (cond + ((current-test-group) + => (lambda (group) + (if (and (pair? o) (not (equal? (car o) (test-group-name group)))) + (warning "mismatched test-end:" (car o) (test-group-name group))) + (let ((parent (test-group-ref group 'parent))) + (cond + ((not (test-group-ref group 'skip-group?)) + ;; only report if there's something to say + ((current-test-group-reporter) group) + (cond + (parent + (test-group-inc! parent 'subgroups-count) + (cond + ((and (zero? (test-group-ref group 'FAIL 0)) + (zero? (test-group-ref group 'ERROR 0)) + (= (test-group-ref group 'subgroups-pass 0) + (test-group-ref group 'subgroups-count 0))) + (test-group-inc! parent 'subgroups-pass))))))) + (current-test-group parent) + group))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; parameters + +(define current-test-group (make-parameter #f)) +(define current-test-verbosity + (make-parameter + (cond ((get-environment-variable "TEST_QUIET") + => (lambda (s) (equal? s "0"))) + (else #t)))) +(define current-test-epsilon (make-parameter 1e-5)) +(define current-test-comparator (make-parameter test-equal?)) +(define current-test-applier (make-parameter test-default-applier)) +(define current-test-handler (make-parameter test-default-handler)) +(define current-test-skipper (make-parameter test-default-skipper)) +(define current-test-group-reporter + (make-parameter test-default-group-reporter)) +(define test-failure-count (make-parameter 0)) + +(define test-first-indentation + (make-parameter + (or (cond ((get-environment-variable "TEST_FIRST_INDENTATION") + => string->number) + (else #f)) + 1))) + +(define test-max-indentation + (make-parameter + (or (cond ((get-environment-variable "TEST_MAX_INDENTATION") + => string->number) + (else #f)) + 5))) + +(define (string->info-matcher str) + (lambda (info) + (cond ((test-get-name! info) + => (lambda (n) (string-search str n))) + (else #f)))) + +(define (string->group-matcher str) + (lambda (group) (string-search str (car group)))) + +(define (getenv-filter-list proc name . o) + (cond + ((get-environment-variable name) + => (lambda (s) + (handle-exceptions + exn + (begin + (warning + (string-append "invalid filter '" s + "' from environment variable: " name)) + (print-exception exn (current-error-port)) + '()) + (let ((f (proc s))) + (list (if (and (pair? o) (car o)) + (lambda (x) (not (f x))) + f)))))) + (else '()))) + +(define current-test-filters + (make-parameter + (append (getenv-filter-list string->info-matcher "TEST_FILTER") + (getenv-filter-list string->info-matcher "TEST_REMOVE" #t)))) + +(define current-test-group-filters + (make-parameter + (append (getenv-filter-list string->group-matcher "TEST_GROUP_FILTER") + (getenv-filter-list string->group-matcher "TEST_GROUP_REMOVE" #t)))) + +(define current-column-width + (make-parameter + (or (cond ((get-environment-variable "TEST_COLUMN_WIDTH") + => string->number) + (else #f)) + 78))) + +(define test-ansi? + (make-parameter + (cond + ((get-environment-variable "TEST_USE_ANSI") + => (lambda (s) (not (equal? s "0")))) + (else + (member (get-environment-variable "TERM") + '("xterm" "xterm-color" "xterm-256color" "rxvt" "kterm" + "linux" "screen" "screen-256color" "vt100")))))) diff --git a/lib/chibi/time.module b/lib/chibi/time.module new file mode 100644 index 00000000..8d591100 --- /dev/null +++ b/lib/chibi/time.module @@ -0,0 +1,12 @@ + +(define-module (chibi time) + (export current-seconds get-time-of-day set-time-of-day! + seconds->time seconds->string time->seconds time->string + timeval-seconds timeval-microseconds + timezone-offset timezone-dst-time + time-second time-minute time-hour time-day time-month time-year + time-day-of-week time-day-of-year time-dst? + tm? timeval? timezone?) + (import-immutable (scheme)) + (include-shared "time")) + diff --git a/lib/chibi/time.stub b/lib/chibi/time.stub new file mode 100644 index 00000000..adde486e --- /dev/null +++ b/lib/chibi/time.stub @@ -0,0 +1,46 @@ + +(c-system-include "time.h") +(c-system-include "sys/time.h") + +(define-c-struct tm + predicate: tm? + (int tm_sec time-second) + (int tm_min time-minute) + (int tm_hour time-hour) + (int tm_mday time-day) + (int tm_mon time-month) + (int tm_year time-year) + (int tm_wday time-day-of-week) + (int tm_yday time-day-of-year) + (int tm_isdst time-dst?)) + +(define-c-struct timeval + predicate: timeval? + (time_t tv_sec timeval-seconds) + (int tv_usec timeval-microseconds)) + +(define-c-struct timezone + predicate: timezone? + (int tz_minuteswest timezone-offset) + (int tz_dsttime timezone-dst-time)) + +(define-c time_t (current-seconds "time") ((value NULL))) + +(define-c errno (get-time-of-day "gettimeofday") + ((result timeval) (result timezone))) + +(define-c errno (set-time-of-day! "settimeofday") + (timeval (maybe-null default NULL timezone))) + +(define-c non-null-pointer (seconds->time "localtime_r") + ((pointer time_t) (result tm))) + +(define-c time_t (time->seconds "mktime") + (tm)) + +(define-c non-null-string (seconds->string "ctime_r") + ((pointer time_t) (result (array char 64)))) + +(define-c non-null-string (time->string "asctime_r") + (tm (result (array char 64)))) + diff --git a/lib/chibi/type-inference.module b/lib/chibi/type-inference.module new file mode 100644 index 00000000..2f9534d2 --- /dev/null +++ b/lib/chibi/type-inference.module @@ -0,0 +1,7 @@ + +(define-module (chibi type-inference) + (export type-analyze-module type-analyze procedure-signature) + (import-immutable (scheme)) + (import (srfi 1) (srfi 69) (chibi modules) (chibi ast) (chibi match)) + (include "type-inference.scm")) + diff --git a/lib/chibi/type-inference.scm b/lib/chibi/type-inference.scm new file mode 100644 index 00000000..6b21a230 --- /dev/null +++ b/lib/chibi/type-inference.scm @@ -0,0 +1,272 @@ +;; type-inference.scm -- general type-inference for Scheme +;; +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (typed? x) + (and (lambda? x) + (lambda-return-type x))) + +(define (union-type? a) + (and (pair? a) (equal? (car a) 'or))) + +(define (intersection-type? a) + (and (pair? a) (equal? (car a) 'and))) + +(define (unfinalized-type? a) + (and (pair? a) + (or (memq (car a) '(return-type param-type)) + (and (memq (car a) '(and or)) + (any unfinalized-type? (cdr a)))))) + +(define (finalized-type? a) + (not (unfinalized-type? a))) + +(define (numeric-type? a) + (or (eq? a ) (eq? a ) (eq? a ))) + +(define (procedure-type? a) + (or (eq? a ) + (eq? a ) + (and (pair? a) (eq? (car a) 'lambda)))) + +(define (type-subset? a b) + (or (equal? a b) + (equal? a ) + (equal? b ) + (and (numeric-type? a) (numeric-type? b)) + (and (procedure-type? a) (procedure-type? b)) + (if (union-type? a) + (if (union-type? b) + (lset<= equal? (cdr a) (cdr b)) + (member b (cdr a))) + (and (union-type? b) (member a (cdr b)))))) + +;; XXXX check for type hierarchies +(define (type-union a b) + (cond + ((equal? a b) a) + ((or (equal? a ) (equal? b )) ) + ((union-type? a) + (if (union-type? b) + (cons (car a) (lset-union equal? (cdr a) (cdr b))) + (cons (car a) (lset-adjoin equal? (cdr a) b)))) + (else (list 'or a b)))) + +;; XXXX check for conflicts +(define (type-intersection a b) + (cond + ((equal? a b) a) + ((or (equal? a ) (unfinalized-type? a)) b) + ((or (equal? b ) (unfinalized-type? b)) a) + ((intersection-type? a) + (if (intersection-type? b) + (lset-intersection equal? (cdr a) (cdr b)) + (cons (car a) (lset-adjoin equal? (cdr a) b)))) + (else (list 'and a b)))) + +(define (lambda-param-types-initialize! f) + (lambda-param-types-set! f (map (lambda (p) (list 'param-type f p)) + (lambda-params f)))) + +(define (lambda-param-type-memq f x) + (let lp ((p (lambda-params f)) + (t (lambda-param-types f))) + (and (pair? p) + (pair? t) + (if (eq? x (car p)) + t + (lp (cdr p) (cdr t)))))) + +(define (lambda-param-type-ref f x) + (cond ((lambda-param-type-memq f x) => car) + (else #f))) + +(define (lambda-param-type-set! f x y) + (if (not (pair? (lambda-param-types f))) + (lambda-param-types-initialize! f)) + (cond ((lambda-param-type-memq f x) + => (lambda (cell) (set-car! cell y))))) + +(define (type-analyze-expr x) + (match x + (($ name params body defs) + (cond + ((not (lambda-return-type x)) + (lambda-return-type-set! x (list 'return-type x)) + (lambda-param-types-initialize! x) + (let ((ret-type (type-analyze-expr body))) + (lambda-return-type-set! x ret-type) + (cons 'lambda (cons ret-type (lambda-param-types x))))))) + (($ ref value) + (type-analyze-expr value) + (if #f #f)) + (($ name (value . loc) source) + (cond + ((lambda? loc) (lambda-param-type-ref loc name)) + ((procedure? loc) + (let ((sig (procedure-signature loc))) + (if (and (pair? sig) (car sig)) + (cons 'lambda sig) + (list 'return-type (procedure-analysis loc))))) + (else ))) + (($ test pass fail) + (let ((test-type (type-analyze-expr test)) + (pass-type (type-analyze-expr pass)) + (fail-type (type-analyze-expr fail))) + (type-union pass-type fail-type))) + (($ ls) + (let lp ((ls ls)) + (cond ((null? (cdr ls)) + (type-analyze-expr (car ls))) + (else + (type-analyze-expr (car ls)) + (lp (cdr ls)))))) + ((f args ...) + (cond + ((opcode? f) + (let lp ((p (opcode-param-types f)) + (a args)) + (cond + ((pair? a) + (cond ((or (pair? p) (opcode-variadic? f)) + (let ((p-type + (if (pair? p) + (car p) + (opcode-param-type f (opcode-num-params f))))) + (match (car a) + (($ name (_ . (and g ($ )))) + (let ((t (type-intersection (lambda-param-type-ref g name) + p-type))) + (lambda-param-type-set! g name t))) + (else + (let ((t (type-analyze-expr (car a)))) + (cond + ((and t p-type + (finalized-type? t) + (finalized-type? p-type) + (not (type-subset? t p-type))) + (display "WARNING: incompatible type: " + (current-error-port)) + (write (list x t p-type) (current-error-port)) + (newline (current-error-port)))) + t)))) + (lp (and (pair? p) (cdr p)) (cdr a))) + (else + (for-each type-analyze-expr a)))))) + (opcode-return-type f)) + (else + (let ((f-type (type-analyze-expr f))) + ;; XXXX apply f-type to params + (for-each type-analyze-expr args) + (cond + ((and (pair? f-type) (eq? (car f-type) 'lambda)) + (cadr f-type)) + ((and (pair? f-type) (memq (car f-type) '(return-type param-type))) + f-type) + (else + )))))) + (else + (type-of x)))) + +(define (resolve-delayed-type x) + (let lp ((x x) (seen '()) (default )) + (match x + (('return-type f) + (if (memq f seen) + default + (lp (lambda-return-type f) (cons f seen) default))) + (('param-type f p) + (if (member x seen) + default + (lp (lambda-param-type-ref f p) (cons x seen) default))) + (('or y ...) + (let ((z (find finalized-type? y))) + (if z + (let ((default (if (eq? default ) + (lp z seen default) + (type-union (lp z seen default) default)))) + (fold type-union + default + (map (lambda (y1) (lp y1 seen default)) (delete z y)))) + (fold type-union default (map (lambda (y1) (lp y1 seen default)) y))))) + (('and y ...) + (fold type-intersection default (map (lambda (y1) (lp y1 seen default)) y))) + (('not y) + (list 'not (lp y seen default))) + (else + x)))) + +(define (type-resolve-circularities x) + (match x + (($ name params body defs) + (if (unfinalized-type? (lambda-return-type x)) + (lambda-return-type-set! x (resolve-delayed-type + (lambda-return-type x)))) + (for-each + (lambda (p t) + (if (unfinalized-type? t) + (lambda-param-type-set! x p (resolve-delayed-type t)))) + params + (lambda-param-types x)) + (type-resolve-circularities (lambda-body x))) + (($ ref value) + (type-resolve-circularities value)) + (($ test pass fail) + (type-resolve-circularities test) + (type-resolve-circularities pass) + (type-resolve-circularities fail)) + (($ ls) + (for-each type-resolve-circularities ls)) + ((app ...) + (for-each type-resolve-circularities app)) + (else #f))) + +(define (type-analyze-module-body name ls) + (for-each type-analyze-expr ls) + (for-each type-resolve-circularities ls)) + +(define (type-analyze-module name) + (let* ((mod (analyze-module name)) + (ls (and (vector? mod) (module-ast mod)))) + (and ls + (let ((x (let lp ((ls ls)) ;; first lambda + (and (pair? ls) + (if (and (set? (car ls)) + (lambda? (set-value (car ls)))) + (set-value (car ls)) + (lp (cdr ls))))))) + (if (and x (not (typed? x))) + (type-analyze-module-body name ls)) + ls)))) + +(define (type-analyze sexp . o) + (type-analyze-expr (apply analyze sexp o))) + +(define (opcode-param-types x) + (let lp ((n (- (opcode-num-params x) 1)) (res '())) + (if (< n 0) + res + (lp (- n 1) (cons (opcode-param-type x n) res))))) + +(define (opcode-type x) + (cons 'lambda (cons (opcode-return-type x) (opcode-param-types x)))) + +(define (lambda-type x) + (cons 'lambda (cons (lambda-return-type x) (lambda-param-types x)))) + +(define (procedure-signature x) + (if (opcode? x) + (cdr (opcode-type x)) + (let lp ((count 0)) + (let ((lam (procedure-analysis x))) + (cond + ((and lam (not (typed? lam)) (zero? count) + (containing-module x)) + => (lambda (mod) + (and (type-analyze-module (car mod)) + (lp (+ count 1))))) + ((lambda? lam) + (cdr (lambda-type lam))) + (else + #f)))))) diff --git a/lib/chibi/uri.module b/lib/chibi/uri.module new file mode 100644 index 00000000..46f9e6a6 --- /dev/null +++ b/lib/chibi/uri.module @@ -0,0 +1,10 @@ + +(define-module (chibi uri) + (export uri? uri->string make-uri string->uri + uri-scheme uri-user uri-host uri-port uri-path uri-query uri-fragment + uri-with-scheme uri-with-user uri-with-host uri-with-path + uri-with-query uri-with-fragment + uri-encode uri-decode uri-query->alist uri-alist->query) + (import-immutable (scheme) + (srfi 9)) + (include "uri.scm")) diff --git a/lib/chibi/uri.scm b/lib/chibi/uri.scm new file mode 100644 index 00000000..41507961 --- /dev/null +++ b/lib/chibi/uri.scm @@ -0,0 +1,306 @@ +;; uri.scm -- URI parsing library +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; URI representation + +(define-record-type uri + (%make-uri scheme user host port path query fragment) + uri? + (scheme uri-scheme) + (user uri-user) + (host uri-host) + (port uri-port) + (path uri-path) + (query uri-query) + (fragment uri-fragment)) + +;; (make-uri scheme [user host port path query fragment]) +(define (make-uri scheme . o) + (let* ((user (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (host (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (port (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (path (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (query (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (fragment (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) #f))) + (%make-uri scheme user host port path query fragment))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils (don't feel like using SRFI-13 and these are more +;; specialised) + +(define (string-scan str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (and (< i end) + (if (eqv? ch (string-ref str i)) + i + (lp (+ i 1))))))) + +(define (string-scan-right str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i (- end 1))) + (and (>= i start) + (if (eqv? ch (string-ref str i)) + i + (lp (- i 1))))))) + +(define (string-index-of str pred . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond ((>= i end) #f) + ((pred (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-downcase->symbol str) + (let ((len (string-length str))) + (let lp ((i 0)) + (cond + ((= i len) + (string->symbol str)) + ((char-upper-case? (string-ref str i)) + (let ((res (make-string len))) + (do ((j 0 (+ j 1))) + ((= j i)) + (string-set! res j (string-ref str j))) + (string-set! res i (char-downcase (string-ref str i))) + (do ((j (+ i 1) (+ j 1))) + ((= j len)) + (string-set! res j (char-downcase (string-ref str j)))) + (string->symbol res))) + (else + (lp (+ i 1))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; functional updaters (uses as much shared state as possible) + +(define (uri-with-scheme u scheme) + (%make-uri scheme (uri-user u) (uri-host u) (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-user u user) + (%make-uri (uri-scheme u) user (uri-host u) (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-host u host) + (%make-uri (uri-scheme u) (uri-user u) host (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-port u port) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) port + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-path u path) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + path (uri-query u) (uri-fragment u))) + +(define (uri-with-query u query) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + (uri-path u) query (uri-fragment u))) + +(define (uri-with-fragment u fragment) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + (uri-path u) (uri-query u) fragment)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; parsing - without :// we just split into scheme & path + +(define (char-uri-scheme-unsafe? ch) + (not (or (char-alphabetic? ch) (char-numeric? ch) (memv ch '(#\_ #\-))))) + +(define (string->path-uri scheme str . o) + (define decode? (and (pair? o) (car o))) + (define decode (if decode? uri-decode (lambda (x) x))) + (define decode-query + (if (and (pair? o) (pair? (cdr o)) (cadr o)) + uri-query->alist + decode)) + (if (pair? str) + str + (let* ((len (string-length str)) + (colon0 (string-scan str #\:)) + (colon + (and (not (string-index-of str char-uri-scheme-unsafe? + 0 (or colon0 len))) + colon0))) + (if (or (not colon) (zero? colon)) + (and scheme + (let* ((quest (string-scan str #\? 0)) + (pound (string-scan str #\# (or quest 0)))) + (make-uri scheme #f #f #f + (decode (substring str 0 (or quest pound len))) + (and quest + (decode-query + (substring str (+ quest 1) (or pound len)))) + (and pound + (decode (substring str (+ pound 1) len)))))) + (let ((sc1 (+ colon 1)) + (scheme (string-downcase->symbol (substring str 0 colon)))) + (if (= sc1 len) + (make-uri scheme) + (if (or (>= (+ sc1 1) len) + (not (and (eqv? #\/ (string-ref str sc1)) + (eqv? #\/ (string-ref str (+ sc1 1)))))) + (make-uri scheme #f #f #f (substring str sc1 len)) + (if (>= (+ sc1 2) len) + (make-uri scheme #f "") + (let* ((sc2 (+ sc1 2)) + (slash (string-scan str #\/ sc2)) + (sc3 (or slash len)) + (at (string-scan-right str #\@ sc2 sc3)) + (colon3 (string-scan str #\: (or at sc2) sc3)) + (quest (string-scan str #\? sc3)) + (pound (string-scan str #\# (or quest sc3)))) + (%make-uri + scheme + (and at (decode (substring str sc2 at))) + (decode + (substring str + (if at (+ at 1) sc2) + (or colon3 sc3))) + (and colon3 + (string->number + (substring str (+ colon3 1) sc3))) + (and slash + (decode + (substring str slash (or quest pound len)))) + (and quest + (decode-query + (substring str (+ quest 1) + (or pound len)))) + (and pound + (decode (substring str (+ pound 1) len))) + )))))))))) + +(define (string->uri str . o) + (apply string->path-uri #f str o)) + +(define (uri->string uri . o) + (define encode? (and (pair? o) (car o))) + (define encode (if encode? uri-encode (lambda (x) x))) + (if (string? uri) + uri + (let ((fragment (uri-fragment uri)) + (query (uri-query uri)) + (path (uri-path uri)) + (port (uri-port uri)) + (host (uri-host uri)) + (user (uri-user uri))) + (string-append + (symbol->string (uri-scheme uri)) ":" + (if (or user host port) "//" "") + (if user (encode user) "") (if user "@" "") + (or host "") ; host shouldn't need encoding + (if port ":" "") (if port (number->string port) "") + (if path (encode path) "") + (if query "?" "") + (if (pair? query) (uri-alist->query query) (or query "")) + (if fragment "#" "") (if fragment (encode fragment) ""))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; query encoding and decoding + +(define (uri-safe-char? ch) + (or (char-alphabetic? ch) + (char-numeric? ch) + (case ch + ((#\- #\_ #\. #\! #\~ #\* #\' #\( #\)) #t) + (else #f)))) + +(define (collect str from to res) + (if (>= from to) + res + (cons (substring str from to) res))) + +(define (uri-encode str . o) + (define (encode-1-space ch) + (if (eqv? ch #\space) + "+" + (encode-1-normal ch))) + (define (encode-1-normal ch) + (let* ((i (char->integer ch)) + (hex (number->string i 16))) + (if (< i 16) + (string-append "%0" hex) + (string-append "%" hex)))) + (let ((start 0) + (end (string-length str)) + (encode-1 (if (and (pair? o) (car o)) + encode-1-space + encode-1-normal))) + (let lp ((from start) (to start) (res '())) + (if (>= to end) + (if (zero? from) + str + (string-concatenate (reverse (collect str from to res)))) + (let* ((ch (string-ref str to)) + (next (+ to 1))) + (if (uri-safe-char? ch) + (lp from next res) + (lp next next (cons (encode-1 ch) + (collect str from to res))))))))) + +(define (uri-decode str . o) + (let ((space-as-plus? (and (pair? o) (car o))) + (start 0) + (end (string-length str))) + (let lp ((from start) (to start) (res '())) + (if (>= to end) + (if (zero? from) + str + (string-concatenate (reverse (collect str from to res)))) + (let* ((ch (string-ref str to)) + (next (+ to 1))) + (cond + ((eqv? ch #\%) + (if (>= next end) + (lp next next (collect str from to res)) + (let ((next2 (+ next 1))) + (if (>= next2 end) + (lp next2 next2 (collect str from to res)) + (let* ((next3 (+ next2 1)) + (hex (substring str next next3)) + (i (string->number hex 16))) + (lp next3 next3 (cons (string (integer->char i)) + (collect str from to res)))))))) + ((and space-as-plus? (eqv? ch #\+)) + (lp next next (cons " " (collect str from to res)))) + (else + (lp from next res)))))))) + +(define (uri-query->alist str . o) + (define (split-char? c) (if (eqv? c #\&) #t (eqv? c #\;))) + (let ((len (string-length str)) + (plus? (and (pair? o) (car o)))) + (let lp ((i 0) (res '())) + (if (>= i len) + (reverse res) + (let* ((j (or (string-index-of str split-char? i) len)) + (k (string-scan str #\= i j)) + (cell (if k + (cons (uri-decode (substring str i k) plus?) + (uri-decode (substring str (+ k 1) j) plus?)) + (cons (uri-decode (substring str i j) plus?) #f)))) + (lp (+ j 1) (cons cell res))))))) + +(define (uri-alist->query ls . o) + (define plus? (and (pair? o) (car o))) + (define (encode key val res) + (let ((res (cons (uri-encode key plus?) res))) + (if val (cons (uri-encode val plus?) (cons "=" res)) res))) + (if (null? ls) + "" + (let lp ((x (car ls)) (ls (cdr ls)) (res '())) + (let ((res (encode (car x) (cdr x) res))) + (if (null? ls) + (string-concatenate (reverse res)) + (lp (car ls) (cdr ls) (cons "&" res))))))) diff --git a/lib/config.scm b/lib/config.scm new file mode 100644 index 00000000..55a4e1e0 --- /dev/null +++ b/lib/config.scm @@ -0,0 +1,179 @@ +;; config.scm -- configuration module +;; Copyright (c) 2009-2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; modules + +(define *this-module* '()) + +(define (make-module exports env meta) (vector exports env meta #f)) +(define (%module-exports mod) (vector-ref mod 0)) +(define (module-env mod) (vector-ref mod 1)) +(define (module-meta-data mod) (vector-ref mod 2)) +(define (module-env-set! mod env) (vector-set! mod 1 env)) + +(define (module-exports mod) + (or (%module-exports mod) (env-exports (module-env mod)))) + +(define (module-name->strings ls res) + (if (null? ls) + res + (let ((str (cond ((symbol? (car ls)) (symbol->string (car ls))) + ((number? (car ls)) (number->string (car ls))) + ((string? (car ls)) (car ls)) + (else (error "invalid module name" (car ls)))))) + (module-name->strings (cdr ls) (cons "/" (cons str res)))))) + +(define (module-name->file name) + (string-concatenate + (reverse (cons ".module" (cdr (module-name->strings name '())))))) + +(define (module-name-prefix name) + (string-concatenate (reverse (cdr (cdr (module-name->strings name '())))))) + +(define (load-module-definition name) + (let* ((file (module-name->file name)) + (path (find-module-file file))) + (if path (load path *config-env*)))) + +(define (find-module name) + (cond + ((assoc name *modules*) => cdr) + (else + (load-module-definition name) + (cond ((assoc name *modules*) => cdr) + (else #f))))) + +(define (symbol-append a b) + (string->symbol (string-append (symbol->string a) (symbol->string b)))) + +(define (to-id id) (if (pair? id) (car id) id)) +(define (from-id id) (if (pair? id) (cdr id) id)) +(define (id-filter pred ls) + (cond ((null? ls) '()) + ((pred (to-id (car ls))) (cons (car ls) (id-filter pred (cdr ls)))) + (else (id-filter pred (cdr ls))))) + +(define (resolve-import x) + (cond + ((not (and (pair? x) (list? x))) + (error "invalid module syntax" x)) + ((and (pair? (cdr x)) (pair? (cadr x))) + (if (memq (car x) '(only except rename)) + (let* ((mod-name+imports (resolve-import (cadr x))) + (imp-ids (cdr mod-name+imports)) + (imp-ids (if (and (not imp-ids) (not (eq? 'only (car x)))) + (begin + (set-cdr! mod-name+imports + (module-exports + (find-module (car mod-name+imports)))) + (cdr mod-name+imports)) + imp-ids))) + (cons (car mod-name+imports) + (case (car x) + ((only) + (if (not imp-ids) + (cddr x) + (id-filter (lambda (i) (memq i (cddr x))) imp-ids))) + ((except) + (id-filter (lambda (i) (not (memq i (cddr x)))) imp-ids)) + ((rename) + (map (lambda (i) + (let ((rename (assq (to-id i) (cddr x)))) + (if rename (cons (cdr rename) (from-id i)) i))) + imp-ids))))) + (error "invalid import modifier" x))) + ((and (eq? 'prefix (car x)) (symbol? (cadr x)) (list? (caddr x))) + (let ((mod-name+imports (resolve-import (caddr x)))) + (cons (car mod-name+imports) + (map (lambda (i) + (cons (symbol-append (cadr x) (if (pair? i) (car i) i)) + (if (pair? i) (cdr i) i))) + (cdr mod-name+imports))))) + ((find-module x) + => (lambda (mod) (cons x (%module-exports mod)))) + (else + (error "couldn't find import" x)))) + +(define (eval-module name mod) + (let ((env (make-environment)) + (dir (module-name-prefix name))) + (define (load-modules files extension) + (for-each + (lambda (f) + (let ((f (string-append dir f extension))) + (cond ((find-module-file f) => (lambda (x) (load x env))) + (else (error "couldn't find include" f))))) + files)) + (for-each + (lambda (x) + (case (and (pair? x) (car x)) + ((import import-immutable) + (for-each + (lambda (m) + (let* ((mod2-name+imports (resolve-import m)) + (mod2 (load-module (car mod2-name+imports)))) + (%env-copy! env (module-env mod2) (cdr mod2-name+imports) + (eq? (car x) 'import-immutable)))) + (cdr x))) + ((include) + (load-modules (cdr x) "")) + ((include-shared) + (cond-expand + (dynamic-loading (load-modules (cdr x) *shared-object-extension*)) + (else #f))) + ((body) + (for-each (lambda (expr) (eval expr env)) (cdr x))))) + (module-meta-data mod)) + env)) + +(define (load-module name) + (let ((mod (find-module name))) + (if (and mod (not (module-env mod))) + (module-env-set! mod (eval-module name mod))) + mod)) + +(define-syntax define-module + (er-macro-transformer + (lambda (expr rename compare) + (let ((name (cadr expr)) + (body (cddr expr))) + `(let ((tmp *this-module*)) + (set! *this-module* '()) + ,@body + (set! *this-module* (reverse *this-module*)) + (let ((exports + (cond ((assq 'export *this-module*) => cdr) + (else '())))) + (set! *modules* + (cons (cons ',name (make-module exports #f *this-module*)) + *modules*))) + (set! *this-module* tmp)))))) + +(define-syntax define-config-primitive + (er-macro-transformer + (lambda (expr rename compare) + `(define-syntax ,(cadr expr) + (er-macro-transformer + (lambda (expr rename compare) + `(set! *this-module* (cons ',expr *this-module*)))))))) + +(define-config-primitive import) +(define-config-primitive import-immutable) +(define-config-primitive export) +(define-config-primitive include) +(define-config-primitive include-shared) +(define-config-primitive body) + +(define *modules* + (list (cons '(scheme) (make-module #f (interaction-environment) + '((include "init.scm")))) + (cons '(config) (make-module #f (current-environment) '())) + (cons '(srfi 0) (make-module (list 'cond-expand) + (interaction-environment) + (list (list 'export 'cond-expand)))) + (cons '(srfi 46) (make-module (list 'syntax-rules) + (interaction-environment) + (list (list 'export 'syntax-rules)))))) + diff --git a/lib/init.scm b/lib/init.scm new file mode 100644 index 00000000..62d044ec --- /dev/null +++ b/lib/init.scm @@ -0,0 +1,875 @@ +;; init.scm -- R5RS library procedures +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; provide c[ad]{2,4}r + +(define (caar x) (car (car x))) +(define (cadr x) (car (cdr x))) +(define (cdar x) (cdr (car x))) +(define (cddr x) (cdr (cdr x))) +(define (caaar x) (car (car (car x)))) +(define (caadr x) (car (car (cdr x)))) +(define (cadar x) (car (cdr (car x)))) +(define (caddr x) (car (cdr (cdr x)))) +(define (cdaar x) (cdr (car (car x)))) +(define (cdadr x) (cdr (car (cdr x)))) +(define (cddar x) (cdr (cdr (car x)))) +(define (cdddr x) (cdr (cdr (cdr x)))) +(define (caaaar x) (car (car (car (car x))))) +(define (caaadr x) (car (car (car (cdr x))))) +(define (caadar x) (car (car (cdr (car x))))) +(define (caaddr x) (car (car (cdr (cdr x))))) +(define (cadaar x) (car (cdr (car (car x))))) +(define (cadadr x) (car (cdr (car (cdr x))))) +(define (caddar x) (car (cdr (cdr (car x))))) +(define (cadddr x) (car (cdr (cdr (cdr x))))) +(define (cdaaar x) (cdr (car (car (car x))))) +(define (cdaadr x) (cdr (car (car (cdr x))))) +(define (cdadar x) (cdr (car (cdr (car x))))) +(define (cdaddr x) (cdr (car (cdr (cdr x))))) +(define (cddaar x) (cdr (cdr (car (car x))))) +(define (cddadr x) (cdr (cdr (car (cdr x))))) +(define (cdddar x) (cdr (cdr (cdr (car x))))) +(define (cddddr x) (cdr (cdr (cdr (cdr x))))) + +;; basic utils + +(define (procedure? x) (if (closure? x) #t (opcode? x))) + +(define (list . args) args) + +(define (list-tail ls k) + (if (eq? k 0) + ls + (list-tail (cdr ls) (- k 1)))) + +(define (list-ref ls k) (car (list-tail ls k))) + +(define (append-helper ls res) + (if (null? ls) + res + (append-helper (cdr ls) (append2 (car ls) res)))) + +(define (append . o) + (if (null? o) + '() + ((lambda (lol) + (append-helper (cdr lol) (car lol))) + (reverse o)))) + +(define (apply proc . args) + (if (null? args) + (proc) + ((lambda (lol) + (apply1 proc (append2 (reverse (cdr lol)) (car lol)))) + (reverse args)))) + +;; map with a fast-path for single lists + +(define (map proc ls . lol) + (define (map1 proc ls res) + (if (pair? ls) + (map1 proc (cdr ls) (cons (proc (car ls)) res)) + (reverse res))) + (define (mapn proc lol res) + (if (pair? (car lol)) + (mapn proc + (map1 cdr lol '()) + (cons (apply1 proc (map1 car lol '())) res)) + (reverse res))) + (if (null? lol) + (map1 proc ls '()) + (mapn proc (cons ls lol) '()))) + +(define (for-each f ls . lol) + (define (for1 f ls) (if (pair? ls) (begin (f (car ls)) (for1 f (cdr ls))))) + (if (null? lol) (for1 f ls) (begin (apply map f ls lol) (if #f #f)))) + +(define (any pred ls) + (if (pair? ls) (if (pred (car ls)) (car ls) (any pred (cdr ls))) #f)) + +(define (every pred ls) + (if (pair? ls) (if (pred (car ls)) (every pred (cdr ls)) #f) #t)) + +(define (delq x ls) + (if (pair? ls) + (if (eq? x (car ls)) (delq x (cdr ls)) (cons (car ls) (delq x (cdr ls)))) + '())) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; syntax + +(define sc-macro-transformer + (lambda (f) + (lambda (expr use-env mac-env) + (make-syntactic-closure mac-env '() (f expr use-env))))) + +(define rsc-macro-transformer + (lambda (f) + (lambda (expr use-env mac-env) + (f expr mac-env)))) + +(define er-macro-transformer + (lambda (f) + (lambda (expr use-env mac-env) + ((lambda (rename compare) (f expr rename compare)) + ((lambda (renames) + (lambda (identifier) + ((lambda (cell) + (if cell + (cdr cell) + ((lambda (name) + (set! renames (cons (cons identifier name) renames)) + name) + (make-syntactic-closure mac-env '() identifier)))) + (assq identifier renames)))) + '()) + (lambda (x y) (identifier=? use-env x use-env y)))))) + +(define-syntax cond + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #f + ((lambda (cl) + (if (compare (rename 'else) (car cl)) + (if (pair? (cddr expr)) + (error "non-final else in cond" expr) + (cons (rename 'begin) (cdr cl))) + (if (if (null? (cdr cl)) #t (compare (rename '=>) (cadr cl))) + (list (list (rename 'lambda) (list (rename 'tmp)) + (list (rename 'if) (rename 'tmp) + (if (null? (cdr cl)) + (rename 'tmp) + (list (caddr cl) (rename 'tmp))) + (cons (rename 'cond) (cddr expr)))) + (car cl)) + (list (rename 'if) + (car cl) + (cons (rename 'begin) (cdr cl)) + (cons (rename 'cond) (cddr expr)))))) + (cadr expr)))))) + +(define-syntax or + (er-macro-transformer + (lambda (expr rename compare) + (cond ((null? (cdr expr)) #f) + ((null? (cddr expr)) (cadr expr)) + (else + (list (rename 'let) (list (list (rename 'tmp) (cadr expr))) + (list (rename 'if) (rename 'tmp) + (rename 'tmp) + (cons (rename 'or) (cddr expr))))))))) + +(define-syntax and + (er-macro-transformer + (lambda (expr rename compare) + (cond ((null? (cdr expr))) + ((null? (cddr expr)) (cadr expr)) + (else (list (rename 'if) (cadr expr) + (cons (rename 'and) (cddr expr)) + #f)))))) + +(define-syntax quasiquote + (er-macro-transformer + (lambda (expr rename compare) + (define (qq x d) + (cond + ((pair? x) + (cond + ((compare (rename 'unquote) (car x)) + (if (<= d 0) + (cadr x) + (list (rename 'list) (list (rename 'quote) 'unquote) + (qq (cadr x) (- d 1))))) + ((compare (rename 'unquote-splicing) (car x)) + (if (<= d 0) + (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)) + (list (rename 'list) (list (rename 'quote) 'unquote-splicing) + (qq (cadr x) (- d 1))))) + ((compare (rename 'quasiquote) (car x)) + (list (rename 'list) (list (rename 'quote) 'quasiquote) + (qq (cadr x) (+ d 1)))) + ((and (<= d 0) (pair? (car x)) (compare (rename 'unquote-splicing) (caar x))) + (if (null? (cdr x)) + (cadar x) + (list (rename 'append) (cadar x) (qq (cdr x) d)))) + (else + (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))))) + ((vector? x) (list (rename 'list->vector) (qq (vector->list x) d))) + ((symbol? x) (list (rename 'quote) x)) + (else x))) + (qq (cadr expr) 0)))) + +(define-syntax letrec + (er-macro-transformer + (lambda (expr rename compare) + ((lambda (defs) + `((,(rename 'lambda) () ,@defs ,@(cddr expr)))) + (map (lambda (x) (cons (rename 'define) x)) (cadr expr)))))) + +(define-syntax let + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) (error "empty let" expr)) + (if (null? (cddr expr)) (error "no let body" expr)) + ((lambda (bindings) + (if (list? bindings) #f (error "bad let bindings")) + (if (every (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + bindings) + ((lambda (vars vals) + (if (identifier? (cadr expr)) + `((,(rename 'lambda) ,vars + (,(rename 'letrec) ((,(cadr expr) + (,(rename 'lambda) ,vars + ,@(cdddr expr)))) + (,(cadr expr) ,@vars))) + ,@vals) + `((,(rename 'lambda) ,vars ,@(cddr expr)) ,@vals))) + (map car bindings) + (map cadr bindings)) + (error "bad let syntax" expr))) + (if (identifier? (cadr expr)) (caddr expr) (cadr expr)))))) + +(define-syntax let* + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) (error "empty let*" expr)) + (if (null? (cddr expr)) (error "no let* body" expr)) + (if (null? (cadr expr)) + `(,(rename 'let) () ,@(cddr expr)) + (if (if (list? (cadr expr)) + (every + (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + (cadr expr)) + #f) + `(,(rename 'let) (,(caadr expr)) + (,(rename 'let*) ,(cdadr expr) ,@(cddr expr))) + (error "bad let* syntax")))))) + +(define-syntax case + (er-macro-transformer + (lambda (expr rename compare) + (define (clause ls) + (cond + ((null? ls) #f) + ((compare (rename 'else) (caar ls)) + `(,(rename 'begin) ,@(cdar ls))) + (else + (if (and (pair? (caar ls)) (null? (cdaar ls))) + `(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp) ',(caaar ls)) + (,(rename 'begin) ,@(cdar ls)) + ,(clause (cdr ls))) + `(,(rename 'if) (,(rename 'memv) ,(rename 'tmp) ',(caar ls)) + (,(rename 'begin) ,@(cdar ls)) + ,(clause (cdr ls))))))) + `(let ((,(rename 'tmp) ,(cadr expr))) + ,(clause (cddr expr)))))) + +(define-syntax do + (er-macro-transformer + (lambda (expr rename compare) + (let* ((body + `(,(rename 'begin) + ,@(cdddr expr) + (,(rename 'lp) + ,@(map (lambda (x) (if (pair? (cddr x)) (caddr x) (car x))) + (cadr expr))))) + (check (caddr expr)) + (wrap + (if (null? (cdr check)) + `(,(rename 'let) ((,(rename 'tmp) ,(car check))) + (,(rename 'if) ,(rename 'tmp) + ,(rename 'tmp) + ,body)) + `(,(rename 'if) ,(car check) + (,(rename 'begin) ,@(cdr check)) + ,body)))) + `(,(rename 'let) ,(rename 'lp) + ,(map (lambda (x) (list (car x) (cadr x))) (cadr expr)) + ,wrap))))) + +(define-syntax delay + (er-macro-transformer + (lambda (expr rename compare) + `(,(rename 'make-promise) (,(rename 'lambda) () ,(cadr expr)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; promises + +(define (make-promise thunk) + (lambda () + (let ((computed? #f) (result #f)) + (if (not computed?) + (begin + (set! result (thunk)) + (set! computed? #t))) + result))) + +(define (force x) (if (procedure? x) (x) x)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; exceptions + +(define (error msg . args) + (raise (make-exception 'user msg args #f #f))) + +(define (with-exception-handler handler thunk) + (letrec ((orig-handler (current-exception-handler)) + (self (lambda (exn) + (current-exception-handler orig-handler) + (let ((res (handler exn))) + (current-exception-handler self) + res)))) + (current-exception-handler self) + (let ((res (thunk))) + (current-exception-handler orig-handler) + res))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; library functions + +;; booleans + +(define (not x) (if x #f #t)) +(define (boolean? x) (if (eq? x #t) #t (eq? x #f))) + +;; char utils + +(define (char-alphabetic? ch) (<= 65 (char->integer (char-upcase ch)) 90)) +(define (char-numeric? ch) (<= 48 (char->integer ch) 57)) +(define (char-whitespace? ch) + (if (eq? ch #\space) + #t + (if (eq? ch #\tab) #t (if (eq? ch #\newline) #t (eq? ch #\return))))) +(define (char-upper-case? ch) (<= 65 (char->integer ch) 90)) +(define (char-lower-case? ch) (<= 97 (char->integer ch) 122)) + +(define (char=? a b) (= (char->integer a) (char->integer b))) +(define (charinteger a) (char->integer b))) +(define (char>? a b) (> (char->integer a) (char->integer b))) +(define (char<=? a b) (<= (char->integer a) (char->integer b))) +(define (char>=? a b) (>= (char->integer a) (char->integer b))) + +(define (char-ci=? a b) + (= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ciinteger (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ci>? a b) + (> (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ci<=? a b) + (<= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ci>=? a b) + (>= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) + +;; string utils + +(define (symbol->string sym) + (call-with-output-string (lambda (out) (write sym out)))) + +(define (list->string ls) + (let ((str (make-string (length ls) #\space))) + (let lp ((ls ls) (i 0)) + (if (pair? ls) + (begin + (string-set! str i (car ls)) + (lp (cdr ls) (+ i 1))))) + str)) + +(define (string->list str) + (let lp ((i (- (string-length str) 1)) (res '())) + (if (< i 0) res (lp (- i 1) (cons (string-ref str i) res))))) + +(define (string-fill! str ch) + (let lp ((i (- (string-length str) 1))) + (if (>= i 0) (begin (string-set! str i ch) (lp (- i 1)))))) + +(define (string . args) (list->string args)) +(define (string-append . args) (string-concatenate args)) +(define (string-copy s) (substring s 0 (string-length s))) + +(define (string=? s1 s2) (eq? (string-cmp s1 s2 #f) 0)) +(define (string? s1 s2) (> (string-cmp s1 s2 #f) 0)) +(define (string>=? s1 s2) (>= (string-cmp s1 s2 #f) 0)) + +(define (string-ci=? s1 s2) (eq? (string-cmp s1 s2 #t) 0)) +(define (string-ci? s1 s2) (> (string-cmp s1 s2 #t) 0)) +(define (string-ci>=? s1 s2) (>= (string-cmp s1 s2 #t) 0)) + +;; list utils + +(define (eqv? a b) (if (eq? a b) #t (and (flonum? a) (flonum? b) (= a b)))) + +(define (member obj ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls)) + (and (pair? ls) (if (eq obj (car ls)) ls (lp (cdr ls))))))) + +(define memv member) + +(define (assoc obj ls) + (if (null? ls) + #f + (if (equal? obj (caar ls)) + (car ls) + (assoc obj (cdr ls))))) + +(define assv assoc) + +;; math utils + +(define (number? x) (if (fixnum? x) #t (if (bignum? x) #t (flonum? x)))) +(define complex? number?) +(define rational? number?) +(define real? number?) +(define (exact? x) (if (fixnum? x) #t (bignum? x))) +(define inexact? flonum?) +(define (integer? x) + (if (fixnum? x) #t (if (bignum? x) #t (and (flonum? x) (= x (truncate x)))))) + +(define (zero? x) (= x 0)) +(define (positive? x) (> x 0)) +(define (negative? x) (< x 0)) +(define (even? n) (= (remainder n 2) 0)) +(define (odd? n) (= (remainder n 2) 1)) + +(define (abs x) (if (< x 0) (- x) x)) + +(define (numerator x) + (if (integer? x) x (numerator (* x 10)))) +(define (denominator x) + (if (exact? x) + 1 + (let lp ((x x) (r 1.0)) (if (integer? x) r (lp (* x 10) (* r 10)))))) + +(define (modulo a b) + (let ((res (remainder a b))) + (if (< b 0) + (if (<= res 0) res (+ res b)) + (if (>= res 0) res (+ res b))))) + +(define (gcd a b) + (if (= b 0) + (abs a) + (gcd b (remainder a b)))) + +(define (lcm a b) + (abs (quotient (* a b) (gcd a b)))) + +(define (max x . rest) + (let lp ((hi x) (ls rest)) + (if (null? ls) + hi + (lp (if (> (car ls) hi) (car ls) hi) (cdr ls))))) + +(define (min x . rest) + (let lp ((lo x) (ls rest)) + (if (null? ls) + lo + (lp (if (< (car ls) lo) (car ls) lo) (cdr ls))))) + +(define (real-part z) z) +(define (imag-part z) 0.0) +(define magnitude abs) +(define (angle z) (if (< z 0) 3.141592653589793 0)) + +(define (atan x . o) (if (null? o) (atan1 x) (atan1 (/ x (car o))))) + +(define (digit-char n) + (if (<= n 9) + (integer->char (+ n (char->integer #\0))) + (integer->char (+ (- n 10) (char->integer #\A))))) +(define (digit-value ch) + (if (char-numeric? ch) + (- (char->integer ch) (char->integer #\0)) + (and (<= 65 (char->integer (char-upcase ch)) 70) + (- (char->integer (char-upcase ch)) 55)))) + +(define (number->string num . o) + (if (if (null? o) #t (eq? 10 (car o))) + (call-with-output-string (lambda (out) (write num out))) + (let lp ((n (abs num)) (d (car o)) (res '())) + (if (> n 0) + (lp (quotient n d) d (cons (digit-char (remainder n d)) res)) + (if (null? res) + "0" + (list->string (if (negative? num) (cons #\- res) res))))))) + +;; vector utils + +(define (list->vector ls) + (let ((vec (make-vector (length ls) #f))) + (let lp ((ls ls) (i 0)) + (if (pair? ls) + (begin + (vector-set! vec i (car ls)) + (lp (cdr ls) (+ i 1))))) + vec)) + +(define (vector->list vec) + (let lp ((i (- (vector-length vec) 1)) (res '())) + (if (< i 0) res (lp (- i 1) (cons (vector-ref vec i) res))))) + +(define (vector-fill! str ch) + (let lp ((i (- (vector-length str) 1))) + (if (>= i 0) (begin (vector-set! str i ch) (lp (- i 1)))))) + +(define (vector . args) (list->vector args)) + +;; I/O utils + +(define (char-ready? . o) + (not (eof-object? (peek-char (if (pair? o) (car o) (current-input-port)))))) + +(define (call-with-input-string str proc) + (let* ((in (open-input-string str)) + (res (proc in))) + (close-input-port in) + res)) + +(define (call-with-output-string proc) + (let ((out (open-output-string))) + (proc out) + (let ((res (get-output-string out))) + (close-output-port out) + res))) + +(define (call-with-input-file file proc) + (let* ((in (open-input-file file)) + (res (proc in))) + (close-input-port in) + res)) + +(define (call-with-output-file file proc) + (let* ((out (open-output-file file)) + (res (proc out))) + (close-output-port out) + res)) + +(define (with-input-from-file file thunk) + (let ((old-in (current-input-port)) + (tmp-in (open-input-file file))) + (current-input-port tmp-in) + (let ((res (thunk))) + (current-input-port old-in) + res))) + +(define (with-output-to-file file thunk) + (let ((old-out (current-output-port)) + (tmp-out (open-output-file file))) + (current-output-port tmp-out) + (let ((res (thunk))) + (current-output-port old-out) + res))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; values + +(define *values-tag* (list 'values)) + +(define (values . ls) + (if (and (pair? ls) (null? (cdr ls))) + (car ls) + (cons *values-tag* ls))) + +(define (call-with-values producer consumer) + (let ((res (producer))) + (if (and (pair? res) (eq? *values-tag* (car res))) + (apply consumer (cdr res)) + (consumer res)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; dynamic-wind + +(define *dk* (list #f)) + +(define (dynamic-wind before thunk after) + (let ((dk *dk*)) + (set-dk! (cons (cons before after) dk)) + (let ((res (thunk))) (set-dk! dk) res))) + +(define (set-dk! dk) + (if (not (eq? dk *dk*)) + (begin + (set-dk! (cdr dk)) + (let ((before (car (car dk))) (dk dk)) + (set-car! *dk* (cons (cdr (car dk)) before)) + (set-cdr! *dk* dk) + (set-car! dk #f) + (set-cdr! dk '()) + (set! *dk* dk) + (before))))) + +(define (call-with-current-continuation proc) + (let ((dk *dk*)) + (%call/cc (lambda (k) (proc (lambda (x) (set-dk! dk) (k x))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; syntax-rules + +(define-syntax syntax-rules + (er-macro-transformer + (lambda (expr rename compare) + (let ((ellipse-specified? (identifier? (cadr expr))) + (count 0) + (_er-macro-transformer (rename 'er-macro-transformer)) + (_lambda (rename 'lambda)) (_let (rename 'let)) + (_begin (rename 'begin)) (_if (rename 'if)) + (_and (rename 'and)) (_or (rename 'or)) + (_eq? (rename 'eq?)) (_equal? (rename 'equal?)) + (_car (rename 'car)) (_cdr (rename 'cdr)) + (_cons (rename 'cons)) (_pair? (rename 'pair?)) + (_null? (rename 'null?)) (_expr (rename 'expr)) + (_rename (rename 'rename)) (_compare (rename 'compare)) + (_quote (rename 'syntax-quote)) (_apply (rename 'apply)) + (_append (rename 'append)) (_map (rename 'map)) + (_vector? (rename 'vector?)) (_list? (rename 'list?)) + (_lp (rename 'lp)) (_reverse (rename 'reverse)) + (_len (rename'len)) (_length (rename 'length)) + (_- (rename '-)) (_>= (rename '>=)) (_error (rename 'error)) + (_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i)) + (_vector->list (rename 'vector->list)) + (_list->vector (rename 'list->vector))) + (define ellipse (rename (if ellipse-specified? (cadr expr) '...))) + (define lits (if ellipse-specified? (caddr expr) (cadr expr))) + (define forms (if ellipse-specified? (cdddr expr) (cddr expr))) + (define (next-v) + (set! count (+ count 1)) + (rename (string->symbol (string-append "v." (number->string count))))) + (define (expand-pattern pat tmpl) + (let lp ((p (cdr pat)) + (x (list _cdr _expr)) + (dim 0) + (vars '()) + (k (lambda (vars) + (or (expand-template tmpl vars) + (list _begin #f))))) + (let ((v (next-v))) + (list + _let (list (list v x)) + (cond + ((identifier? p) + (if (any (lambda (l) (compare p l)) lits) + (list _and (list _compare v (list _quote p)) (k vars)) + (list _let (list (list p v)) (k (cons (cons p dim) vars))))) + ((ellipse? p) + (cond + ((not (null? (cddr p))) + (cond + ((not (list? (cddr p))) + (error "dotted ellipse" p)) + ((any (lambda (x) (and (identifier? x) (compare x ellipse))) + (cddr p)) + (error "multiple ellipses" p)) + (else + (let ((len (length (cdr (cdr p))))) + `(,_let ((,_len (,_length ,v))) + (,_and (,_>= ,_len ,len) + (,_let ,_lp ((,_ls ,v) + (,_i (,_- ,_len ,len)) + (,_res (,_quote ()))) + (,_if (,_>= 0 ,_i) + ,(lp `(,@(cdr (cdr p)) ,(car p) ,(car (cdr p))) + `(,_append ,_ls (,_reverse ,_res)) + dim + vars + k) + (,_lp (,_cdr ,_ls) + (,_- ,_i 1) + (,_cons (,_car ,_ls) ,_res)))))))))) + ((identifier? (car p)) + (list _and (list _list? v) + (list _let (list (list (car p) v)) + (k (cons (cons (car p) (+ 1 dim)) vars))))) + (else + (let* ((w (next-v)) + (new-vars (all-vars (car p) (+ dim 1))) + (ls-vars (map (lambda (x) + (rename + (string->symbol + (string-append + (symbol->string + (identifier->symbol (car x))) + "-ls")))) + new-vars)) + (once + (lp (car p) (list _car w) (+ dim 1) '() + (lambda (_) + (cons + _lp + (cons + (list _cdr w) + (map (lambda (x l) + (list _cons (car x) l)) + new-vars + ls-vars))))))) + (list + _let + _lp (cons (list w v) + (map (lambda (x) (list x '())) ls-vars)) + (list _if (list _null? w) + (list _let (map (lambda (x l) + (list (car x) (list _reverse l))) + new-vars + ls-vars) + (k (append new-vars vars))) + (list _and (list _pair? w) once))))))) + ((pair? p) + (list _and (list _pair? v) + (lp (car p) + (list _car v) + dim + vars + (lambda (vars) + (lp (cdr p) (list _cdr v) dim vars k))))) + ((vector? p) + (list _and + (list _vector? v) + (lp (vector->list p) (list _vector->list v) dim vars k))) + ((null? p) (list _and (list _null? v) (k vars))) + (else (list _and (list _equal? v p) (k vars)))))))) + (define (ellipse-escape? x) (and (pair? x) (compare ellipse (car x)))) + (define (ellipse? x) + (and (pair? x) (pair? (cdr x)) (compare ellipse (cadr x)))) + (define (ellipse-depth x) + (if (ellipse? x) + (+ 1 (ellipse-depth (cdr x))) + 0)) + (define (ellipse-tail x) + (if (ellipse? x) + (ellipse-tail (cdr x)) + (cdr x))) + (define (all-vars x dim) + (let lp ((x x) (dim dim) (vars '())) + (cond ((identifier? x) + (if (any (lambda (lit) (compare x lit)) lits) + vars + (cons (cons x dim) vars))) + ((ellipse? x) (lp (car x) (+ dim 1) vars)) + ((pair? x) (lp (car x) dim (lp (cdr x) dim vars))) + ((vector? x) (lp (vector->list x) dim vars)) + (else vars)))) + (define (free-vars x vars dim) + (let lp ((x x) (free '())) + (cond + ((identifier? x) + (if (and (not (memq x free)) + (cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim))) + (else #f))) + (cons x free) + free)) + ((pair? x) (lp (car x) (lp (cdr x) free))) + ((vector? x) (lp (vector->list x) free)) + (else free)))) + (define (expand-template tmpl vars) + (let lp ((t tmpl) (dim 0)) + (cond + ((identifier? t) + (cond + ((any (lambda (v) (compare t (car v))) vars) + => (lambda (cell) + (if (<= (cdr cell) dim) + t + (error "too few ...'s")))) + (else + (list _rename (list _quote t))))) + ((pair? t) + (cond + ((ellipse-escape? t) + (if (pair? (cdr t)) + (if (pair? (cddr t)) (cddr t) (cadr t)) + (cdr t))) + ((ellipse? t) + (let* ((depth (ellipse-depth t)) + (ell-dim (+ dim depth)) + (ell-vars (free-vars (car t) vars ell-dim))) + (if (null? ell-vars) + (error "too many ...'s") + (let* ((once (lp (car t) ell-dim)) + (nest (if (and (null? (cdr ell-vars)) + (identifier? once) + (eq? once (car vars))) + once ;; shortcut + (cons _map + (cons (list _lambda ell-vars once) + ell-vars)))) + (many (do ((d depth (- d 1)) + (many nest + (list _apply _append many))) + ((= d 1) many)))) + (if (null? (ellipse-tail t)) + many ;; shortcut + (list _append many (lp (ellipse-tail t) dim))))))) + (else (list _cons (lp (car t) dim) (lp (cdr t) dim))))) + ((vector? t) (list _list->vector (lp (vector->list t) dim))) + ((null? t) (list _quote '())) + (else t)))) + (list + _er-macro-transformer + (list _lambda (list _expr _rename _compare) + (cons + _or + (append + (map + (lambda (clause) (expand-pattern (car clause) (cadr clause))) + forms) + (list (list _error "no expansion for" + (list (rename 'strip-syntactic-closures) _expr))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; modules + +(define *config-env* #f) + +(define-syntax import + (er-macro-transformer + (lambda (expr rename compare) + (let lp ((ls (cdr expr)) (res '())) + (cond + ((null? ls) + (cons 'begin (reverse res))) + (else + (let ((mod+imps (eval `(resolve-import ',(car ls)) *config-env*))) + (if (pair? mod+imps) + (lp (cdr ls) + (cons `(%env-copy! + #f + (vector-ref + (eval '(load-module ',(car mod+imps)) *config-env*) + 1) + ',(cdr mod+imps) + #f) + res)) + (error "couldn't find module" (car ls)))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; SRFI-0 + +(define-syntax cond-expand + (er-macro-transformer + (lambda (expr rename compare) + (define (check x) + (if (pair? x) + (case (car x) + ((and) (every check (cdr x))) + ((or) (any check (cdr x))) + ((not) (not (check (cadr x)))) + (else (error "cond-expand: bad feature" x))) + (memq (identifier->symbol x) *features*))) + (let expand ((ls (cdr expr))) + (cond ((null? ls) (error "cond-expand: no expansions" expr)) + ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls))) + ((eq? 'else (identifier->symbol (caar ls))) + (if (pair? (cdr ls)) + (error "cond-expand: else in non-final position") + `(,(rename 'begin) ,@(cdar ls)))) + ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls))) + (else (expand (cdr ls)))))))) + diff --git a/lib/srfi/1.module b/lib/srfi/1.module new file mode 100644 index 00000000..3d3da044 --- /dev/null +++ b/lib/srfi/1.module @@ -0,0 +1,31 @@ + +(define-module (srfi 1) + (export + xcons cons* make-list list-tabulate list-copy circular-list iota + proper-list? circular-list? dotted-list? not-pair? null-list? list= + first second third fourth fifth sixth seventh eighth ninth tenth + car+cdr take drop take-right drop-right take! drop-right! split-at split-at! + last last-pair length+ concatenate append! concatenate! reverse! + append-reverse append-reverse! + zip unzip1 unzip2 unzip3 unzip4 unzip5 count + fold unfold pair-fold reduce fold-right unfold-right + pair-fold-right reduce-right + append-map append-map! map! pair-for-each filter-map map-in-order + filter partition remove filter! partition! remove! find find-tail any every + list-index take-while drop-while take-while! span break span! break! + delete delete-duplicates delete! delete-duplicates! + alist-cons alist-copy alist-delete alist-delete! + lset<= lset= lset-adjoin lset-union lset-union! lset-intersection + lset-intersection! lset-difference lset-difference! lset-xor lset-xor! + lset-diff+intersection lset-diff+intersection!) + (import (scheme)) + (include "1/predicates.scm" + "1/selectors.scm" + "1/search.scm" + "1/misc.scm" + "1/constructors.scm" + "1/fold.scm" + "1/deletion.scm" + "1/alists.scm" + "1/lset.scm")) + diff --git a/lib/srfi/1/alists.scm b/lib/srfi/1/alists.scm new file mode 100644 index 00000000..a35db42c --- /dev/null +++ b/lib/srfi/1/alists.scm @@ -0,0 +1,14 @@ +;; alist.scm -- association list utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (alist-cons key value ls) (cons (cons key value) ls)) + +(define (alist-copy ls) (map (lambda (x) (cons (car x) (cdr x))) ls)) + +(define (alist-delete key ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (remove (lambda (x) (eq (car x) key)) ls))) + +(define alist-delete! alist-delete) + diff --git a/lib/srfi/1/constructors.scm b/lib/srfi/1/constructors.scm new file mode 100644 index 00000000..1f8a8d5e --- /dev/null +++ b/lib/srfi/1/constructors.scm @@ -0,0 +1,36 @@ +;; constructors.scm -- list construction utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (xcons a b) (cons b a)) + +(define (cons* x . args) + (let lp ((rev '()) (x x) (ls args)) + (if (null? ls) + (append-reverse rev x) + (lp (cons x rev) (car ls) (cdr ls))))) + +(define (make-list n . o) + (let ((default (if (pair? o) (car o)))) + (let lp ((n n) (res '())) + (if (<= n 0) res (lp (- n 1) (cons default res)))))) + +(define (list-tabulate n proc) + (let lp ((n n) (res '())) + (if (< n 0) res (lp (- n 1) (cons (proc n) res))))) + +(define (list-copy ls) (reverse! (reverse ls))) + +(define (circular-list x . args) + (let ((res (cons x args))) + (set-cdr! (last-pair res) res) + res)) + +(define (iota count . o) + (let ((start (if (pair? o) (car o) 0)) + (step (if (and (pair? o) (pair? (cdr o))) (cadr o) 1))) + (let lp ((i count) (n (+ start (* (- count 1) step))) (res '())) + (if (<= i 0) + res + (lp (- i 1) (- n step) (cons n res)))))) + diff --git a/lib/srfi/1/deletion.scm b/lib/srfi/1/deletion.scm new file mode 100644 index 00000000..2d44275a --- /dev/null +++ b/lib/srfi/1/deletion.scm @@ -0,0 +1,25 @@ +;; deletion.scm -- list deletion utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (delete x ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (if (eq? eq eq?) + (let lp ((ls ls) (rev '())) ;; fast path for delq + (let ((tail (memq x ls))) + (if tail + (lp (cdr tail) (take-up-to-reverse ls tail rev)) + (if (pair? rev) (append-reverse! rev ls) ls)))) + (remove (lambda (y) (eq x y)) ls)))) + +(define delete! delete) + +(define (delete-duplicates ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls) (res '())) + (if (pair? ls) + (lp (cdr ls) (if (member (car ls) res) res (cons (car ls) res))) + (reverse! res))))) + +(define delete-duplicates! delete-duplicates) + diff --git a/lib/srfi/1/fold.scm b/lib/srfi/1/fold.scm new file mode 100644 index 00000000..892b075c --- /dev/null +++ b/lib/srfi/1/fold.scm @@ -0,0 +1,115 @@ +;; fold.scm -- list fold/reduce utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (fold kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls) (acc knil)) + (if (pair? ls) (lp (cdr ls) (kons (car ls) acc)) acc)) + (let lp ((lists (cons ls lists)) (acc knil)) + (if (every pair? lists) + (lp (map cdr lists) (apply kons (map-onto car lists (list acc)))) + acc)))) + +(define (fold-right kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls)) + (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil)) + (let lp ((lists (cons ls lists))) + (if (every pair? lists) + (apply kons (map-onto car lists (lp (map cdr lists)))) + knil)))) + +(define (pair-fold kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls) (acc knil)) + (if (pair? ls) (lp (cdr ls) (kons ls acc)) acc)) + (let lp ((lists (cons ls lists)) (acc knil)) + (if (every pair? lists) + (lp (map cdr lists) (apply kons (append lists (list acc)))) + acc)))) + +(define (pair-fold-right kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls)) + (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil)) + (let lp ((lists (cons ls lists))) + (if (every pair? lists) + (apply kons (append lists (lp (map cdr lists)))) + knil)))) + +(define (reduce f identity ls) + (if (null? ls) identity (fold f (car ls) (cdr ls)))) + +(define (reduce-right f identity ls) + (if (null? ls) identity (fold-right f (car ls) (cdr ls)))) + +(define (unfold p f g seed . o) + (let lp ((seed seed)) + (if (p seed) + (if (pair? o) ((car o) seed) '()) + (cons (f seed) (lp (g seed)))))) + +(define (unfold-right p f g seed . o) + (let lp ((seed seed) (res (if (pair? o) (car o) '()))) + (if (p seed) res (lp (g seed) (cons (f seed) res))))) + +(define (append-map-helper append f ls lists) + (if (null? lists) + (if (null? ls) + '() + (let ((rev-ls (reverse ls))) + (let lp ((ls (cdr rev-ls)) (res (car rev-ls))) + (if (null? ls) res (lp (cdr ls) (append (f (car ls) res)))) + ))) + (if (and (pair? ls) (every pair? lists)) + (let lp ((lists (cons ls lists))) + (let ((vals (apply f (map car lists))) + (cdrs (map cdr lists))) + (if (every pair? cdrs) (append vals (lp cdrs)) vals))) + '()))) + +(define (append-map f ls . lists) + (append-map-helper append f ls lists)) + +(define (append-map! f ls . lists) + (append-map-helper append! f ls lists)) + +(define map! map) +(define map-in-order map) + +(define (pair-for-each f ls . lists) + (apply pair-fold (lambda (x _) (f x)) ls lists)) + +(define (filter-map f ls . lists) + (if (null? lists) + (let lp ((ls ls) (res '())) + (if (pair? ls) + (let ((x (f (car ls)))) (lp (cdr ls) (if f (cons f res) res))) + (reverse! res))) + (filter (lambda (x) x) (apply map f ls lists)))) + +(define (take-up-to-reverse from to init) + (if (eq? from to) + init + (take-up-to-reverse (cdr from) to (cons (car from) init)))) + +(define (remove pred ls) + (let lp ((ls ls) (rev '())) + (let ((tail (find-tail pred ls))) + (if tail + (lp (cdr tail) (take-up-to-reverse ls tail rev)) + (if (pair? rev) (append-reverse! rev ls) ls))))) + +(define (filter pred ls) (remove (lambda (x) (not (pred x))) ls)) + +(define (partition pred ls) + (let lp ((ls ls) (good '()) (bad '())) + (cond ((null? ls) (values (reverse! good) (reverse! bad))) + ((pred (car ls)) (lp (cdr ls) (cons (car ls) good) bad)) + (else (lp (cdr ls) good (cons (car ls) bad)))))) + +(define filter! filter) +(define remove! remove) +(define partition! partition) + diff --git a/lib/srfi/1/lset.scm b/lib/srfi/1/lset.scm new file mode 100644 index 00000000..8565fac3 --- /dev/null +++ b/lib/srfi/1/lset.scm @@ -0,0 +1,51 @@ +;; lset.scm -- list set library +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (lset<= eq . sets) + (if (null? sets) + #t + (let lp1 ((set1 (car sets)) (sets (cdr sets))) + (if (null? sets) + #t + (let ((set2 (car sets))) + (let lp2 ((ls set1)) + (if (pair? ls) + (and (member (car set1) set2 eq) (lp2 (cdr ls))) + (lp1 set2 (cdr sets))))))))) + +(define (lset= eq . sets) + (and (apply lset<= eq sets) (apply lset<= eq (reverse sets)))) + +(define (lset-adjoin eq set . elts) + (lset-union2 eq elts set)) + +(define (lset-union2 eq a b) + (if (null? b) + a + (lset-union2 eq (if (member (car b) a eq) a (cons (car b) a)) (cdr b)))) + +(define (lset-union eq . sets) + (reduce (lambda (a b) (lset-union2 eq a b)) '() sets)) + +(define (lset-intersection eq . sets) + (reduce (lambda (a b) (filter (lambda (x) (member x b eq)) a)) '() sets)) + +(define (lset-difference eq . sets) + (reduce (lambda (a b) (remove (lambda (x) (member x b eq)) a)) '() sets)) + +(define (lset-xor eq . sets) + (reduce (lambda (a b) + (append (filter (lambda (x) (member x b eq)) a) + (filter (lambda (x) (member x a eq)) b))) + '() + sets)) + +(define (lset-diff+intersection eq . sets) + (values (apply lset-difference eq sets) (apply lset-intersection eq sets))) + +(define lset-diff+intersection! lset-diff+intersection) +(define lset-xor! lset-xor) +(define lset-difference! lset-difference) +(define lset-intersection! lset-intersection) +(define lset-union! lset-union) diff --git a/lib/srfi/1/misc.scm b/lib/srfi/1/misc.scm new file mode 100644 index 00000000..1e7568df --- /dev/null +++ b/lib/srfi/1/misc.scm @@ -0,0 +1,54 @@ +;; misc.scm -- miscellaneous list utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (map-onto proc ls init) + (let lp ((ls ls) (res init)) + (if (null? ls) res (lp (cdr ls) (cons (proc (car ls)) res))))) + +(define (append! . lists) (concatenate! lists)) + +(define (concatenate lists) + (let lp ((ls (reverse lists)) (res '())) + (if (null? ls) res (lp (cdr ls) (append (car ls) res))))) + +(define (concatenate! lists) + (if (null? lists) + '() + (let lp ((ls lists)) + (cond ((not (pair? (cdr ls))) + lists) + (else + (set-cdr! (last-pair (car ls)) (cadr ls)) + (lp (cdr ls))))))) + +(define (append-reverse rev tail) + (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail)))) + +(define (append-reverse! rev tail) + (if (null? rev) + tail + (let ((head (reverse! rev))) + (set-cdr! rev tail) + head))) + +(define (zip . lists) (apply map list lists)) + +(define (unzip1 ls) (map car ls)) +(define (unzip2 ls) (values (map car ls) (map cadr ls))) +(define (unzip3 ls) (values (map car ls) (map cadr ls) (map caddr ls))) +(define (unzip4 ls) + (values (map car ls) (map cadr ls) (map caddr ls) (map cadddr ls))) +(define (unzip5 ls) + (values (map car ls) (map cadr ls) (map caddr ls) + (map cadddr ls) (map (lambda (x) (car (cddddr x))) ls))) + +(define (count pred ls . lists) + (if (null? lists) + (let lp ((ls ls) (res 0)) + (if (pair? ls) (lp (cdr ls) (if (pred (car ls)) (+ res 1) res)) res)) + (let lp ((lists (cons ls lists)) (res 0)) + (if (every pair? lists) + (lp (map cdr lists) (if (apply pred (map car lists)) (+ res 1) res)) + res)))) + diff --git a/lib/srfi/1/predicates.scm b/lib/srfi/1/predicates.scm new file mode 100644 index 00000000..be84e085 --- /dev/null +++ b/lib/srfi/1/predicates.scm @@ -0,0 +1,42 @@ +;; predicates.scm -- list prediates +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (proper-list? x) + (cond ((null? x) #t) + ((pair? x) (proper-list? (cdr x))) + (else #f))) + +(define (circular-list? x) + (and (pair? x) (pair? (cdr x)) + (let race ((hare (cdr x)) (tortoise x)) + (or (eq? hare tortoise) + (and (pair? hare) (pair? (cdr hare)) + (race (cddr hare) (cdr tortoise))))))) + +(define (dotted-list? x) + (not (proper-list? x))) + +(define (not-pair? x) (not (pair? x))) + +(define (null-list? x) (null? x)) ; no error + +(define (list= eq . lists) + (let lp1 ((lists lists)) + (or (null? lists) + (null? (cdr lists)) + (let lp2 ((ls1 (car lists)) (ls2 (cadr lists))) + (if (null? ls1) + (and (null? ls2) + (lp1 (cdr lists))) + (and (eq (car ls1) (car ls2)) + (lp2 (cdr ls1) (cdr ls2)))))))) + +(define (length+ x) + (if (not (pair? x)) + 0 + (let lp ((hare (cdr x)) (tortoise x) (res 0)) + (and (not (eq? hare tortoise)) + (if (pair? hare) + (lp (cddr hare) (cdr tortoise) (+ res 1)) + res))))) diff --git a/lib/srfi/1/search.scm b/lib/srfi/1/search.scm new file mode 100644 index 00000000..ea31d931 --- /dev/null +++ b/lib/srfi/1/search.scm @@ -0,0 +1,54 @@ +;; search.scm -- list searching and splitting +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (find pred ls) + (cond ((find-tail pred ls) => car) (else #f))) + +(define (find-tail pred ls) + (and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls))))) + +(define (take-while pred ls) + (let lp ((ls ls) (res '())) + (if (and (pair? ls) (pred (car ls))) + (lp (cdr ls) (cons (car ls) res)) + (reverse! res)))) + +(define take-while! take-while) + +(define (drop-while pred ls) + (or (find-tail (lambda (x) (not (pred x))) ls) '())) + +(define (span pred ls) + (let lp ((ls ls) (res '())) + (if (and (pair? ls) (pred (car ls))) + (lp (cdr ls) (cons (car ls) res)) + (values (reverse! res) ls)))) + +(define span! span) + +(define (break pred ls) (span (lambda (x) (not (pred x))) ls)) + +(define break! break) + +(define (any pred ls . lists) + (if (null? lists) + (let lp ((ls ls)) (and (pair? ls) (if (pred (car ls)) (car ls) (lp (cdr ls))))) + (let lp ((lists (cons ls lists))) + (and (every pair? lists) + (let ((args (map car lists))) + (if (apply pred args) args (lp (map cdr lists)))))))) + +(define (every pred ls . lists) + (if (null? lists) + (let lp ((ls ls)) (if (pair? ls) (and (pred (car ls)) (lp (cdr ls))) #t)) + (not (apply any (lambda (x) (not (pred x))) ls lists)))) + +(define (list-index pred ls . lists) + (if (null? lists) + (let lp ((ls ls) (n 0)) + (and (pair? ls) (if (pred (car ls)) n (lp (cdr ls) (+ n 1))))) + (let lp ((lists (cons ls lists)) (n 0)) + (and (every pair? lists) + (if (apply pred (map car lists)) n (lp (map cdr lists) (+ n 1))) + )))) diff --git a/lib/srfi/1/selectors.scm b/lib/srfi/1/selectors.scm new file mode 100644 index 00000000..74ef7119 --- /dev/null +++ b/lib/srfi/1/selectors.scm @@ -0,0 +1,59 @@ +;; selectors.scm -- extended list selectors +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define first car) +(define second cadr) +(define third caddr) +(define fourth cadddr) +(define (fifth ls) (car (cdr (cdr (cdr (cdr ls)))))) +(define (sixth ls) (car (cdr (cdr (cdr (cdr (cdr ls))))))) +(define (seventh ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))) +(define (eighth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))) +(define (ninth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))) +(define (tenth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))))) + +(define (car+cdr x) (values (car x) (cdr x))) + +(define (take ls i) + (let lp ((i i) (ls ls) (res '())) + (if (<= i 0) + (reverse! res) + (lp (- i 1) (cdr ls) (cons (car ls) res))))) + +(define (take! ls i) + (if (<= i 0) + '() + (let ((tail (list-tail ls (- i 1)))) + (set-cdr! tail '()) + ls))) + +(define (drop ls i) + (if (<= i 0) ls (drop (cdr ls) (- i 1)))) + +(define (take-right ls i) + (drop ls (- (length+ ls) i))) + +(define (drop-right ls i) + (take ls (- (length+ ls) i))) + +(define (drop-right! ls i) + (take! ls (- (length+ ls) i))) + +(define (split-at ls i) + (let lp ((i i) (ls ls) (res '())) + (if (<= i 0) + (values (reverse! res) ls) + (lp (- i 1) (cdr ls) (cons (car ls) res))))) + +(define (split-at! ls i) + (if (<= i 0) + (values '() ls) + (let* ((tail (list-tail ls (- i 1))) + (right (cdr tail))) + (set-cdr! tail '()) + (values ls right)))) + +(define (last ls) (if (null? (cdr ls)) (car ls) (last (cdr ls)))) +(define (last-pair ls) (if (null? (cdr ls)) ls (last-pair (cdr ls)))) + diff --git a/lib/srfi/11.module b/lib/srfi/11.module new file mode 100644 index 00000000..f3c91df8 --- /dev/null +++ b/lib/srfi/11.module @@ -0,0 +1,28 @@ + +(define-module (srfi 11) + (export let-values let*-values) + (import-immutable (scheme)) + (body + (define-syntax let*-values + (syntax-rules () + ((let*-values () . body) + (begin . body)) + ((let*-values (((a) expr) . rest) . body) + (let ((a expr)) (let*-values rest . body))) + ((let*-values ((params expr) . rest) . body) + (call-with-values (lambda () expr) + (lambda params (let*-values rest . body)))))) + (define-syntax let-values + (syntax-rules () + ((let-values ("step") (binds ...) bind expr maps () () . body) + (let*-values (binds ... (bind expr)) (let maps . body))) + ((let-values ("step") (binds ...) bind old-expr maps () ((params expr) . rest) . body) + (let-values ("step") (binds ... (bind old-expr)) () expr maps params rest . body)) + ((let-values ("step") binds (bind ...) expr (maps ...) (x . y) rest . body) + (let-values ("step") binds (bind ... tmp) expr (maps ... (x tmp)) y rest . body)) + ((let-values ("step") binds (bind ...) expr (maps ...) x rest . body) + (let-values ("step") binds (bind ... . tmp) expr (maps ... (x tmp)) () rest . body)) + ((let-values ((params expr) . rest) . body) + (let-values ("step") () () expr () params rest . body)) + )))) + diff --git a/lib/srfi/16.module b/lib/srfi/16.module new file mode 100644 index 00000000..f931a376 --- /dev/null +++ b/lib/srfi/16.module @@ -0,0 +1,24 @@ + +(define-module (srfi 16) + (export case-lambda) + (import-immutable (scheme)) + (body + (define-syntax %case + (syntax-rules () + ((%case args len n p ((params ...) . body) . rest) + (if (= len (length '(params ...))) + (apply (lambda (params ...) . body) args) + (%case args len 0 () . rest))) + ((%case args len n (p ...) ((x . y) . body) . rest) + (%case args len (+ n 1) (p ... x) (y . body) . rest)) + ((%case args len n (p ...) (y . body) . rest) + (if (>= len n) + (apply (lambda (p ... y) . body) args) + (%case args len 0 () . rest))) + ((%case args len n p) + (error "case-lambda: no cases matched")))) + (define-syntax case-lambda + (syntax-rules () + ((case-lambda . clauses) + (lambda args (let ((len (length args))) (%case args len 0 () . clauses)))))))) + diff --git a/lib/srfi/18.module b/lib/srfi/18.module new file mode 100644 index 00000000..3ed564f8 --- /dev/null +++ b/lib/srfi/18.module @@ -0,0 +1,24 @@ + +(define-module (srfi 18) + (export + current-thread thread? make-thread thread-name + thread-specific thread-specific-set! thread-start! + thread-yield! thread-sleep! thread-terminate! + thread-join! mutex? make-mutex mutex-name + mutex-specific mutex-specific-set! mutex-state + mutex-lock! mutex-unlock! condition-variable? + make-condition-variable condition-variable-name + condition-variable-specific condition-variable-specific-set! + condition-variable-signal! condition-variable-broadcast! + current-time time? time->seconds seconds->time + current-exception-handler with-exception-handler raise + join-timeout-exception? abandoned-mutex-exception? + terminated-thread-exception? uncaught-exception? + uncaught-exception-reason) + (import-immutable (scheme) + (srfi 9) + (chibi ast) + (chibi time)) + (include-shared "18/threads") + (include "18/types.scm" "18/interface.scm")) + diff --git a/lib/srfi/18/interface.scm b/lib/srfi/18/interface.scm new file mode 100644 index 00000000..f814aa6a --- /dev/null +++ b/lib/srfi/18/interface.scm @@ -0,0 +1,63 @@ + +(define (thread-join! thread . o) + (let ((timeout (if (pair? o) (car o) #f))) + (cond + ((%thread-join! thread timeout)) + (else + (thread-yield!) + (if (thread-timeout?) + (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (error "timed out waiting for thread" thread)) + #t))))) + +(define (thread-terminate! thread) + (if (%thread-terminate! thread) ;; need to yield if terminating ourself + (thread-yield!))) + +(define (thread-sleep! timeout) + (%thread-sleep! timeout) + (thread-yield!)) + +(define (mutex-lock! mutex . o) + (let ((timeout (and (pair? o) (car o))) + (thread (if (and (pair? o) (pair? (cdr o))) (cadr o) #t))) + (cond ((%mutex-lock! mutex timeout thread)) + (else + (thread-yield!) + (not (thread-timeout?)))))) + +(define (mutex-unlock! mutex . o) + (let ((condvar (and (pair? o) (car o))) + (timeout (if (and (pair? o) (pair? (cdr o))) (cadr o) #f))) + (cond ((%mutex-unlock! mutex condvar timeout)) + (else + (thread-yield!) + (not (thread-timeout?)))))) + +(define current-time get-time-of-day) +(define time? timeval?) + +(define (join-timeout-exception? x) + (and (exception? x) + (equal? (exception-message x) "timed out waiting for thread"))) + +;; XXXX flush out exception types +(define (abandoned-mutex-exception? x) #f) +(define (terminated-thread-exception? x) #f) +(define (uncaught-exception? x) #f) +(define (uncaught-exception-reason x) #f) + +;; signal runner + +(define (signal-runner) + (let lp () + (let ((n (pop-signal!))) + (cond + ((integer? n) + (let ((handler (get-signal-handler n))) + (if (procedure? handler) + (handler n)))) + (else + (thread-sleep! #t)))) + (lp))) diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c new file mode 100644 index 00000000..b84d59f4 --- /dev/null +++ b/lib/srfi/18/threads.c @@ -0,0 +1,421 @@ +/* threads.c -- SRFI-18 thread primitives */ +/* Copyright (c) 2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include +#include +#include +#include + +#define sexp_mutex_name(x) sexp_slot_ref(x, 0) +#define sexp_mutex_specific(x) sexp_slot_ref(x, 1) +#define sexp_mutex_thread(x) sexp_slot_ref(x, 2) +#define sexp_mutex_lockp(x) sexp_slot_ref(x, 3) + +#define sexp_condvar_name(x) sexp_slot_ref(x, 0) +#define sexp_condvar_specific(x) sexp_slot_ref(x, 1) +#define sexp_condvar_threads(x) sexp_slot_ref(x, 2) + +#define timeval_le(a, b) (((a).tv_sec < (b).tv_sec) || (((a).tv_sec == (b).tv_sec) && ((a).tv_usec < (b).tv_usec))) +#define sexp_context_before(c, t) (((sexp_context_timeval(c).tv_sec != 0) || (sexp_context_timeval(c).tv_usec != 0)) && timeval_le(sexp_context_timeval(c), t)) + +/* static int mutex_id, condvar_id; */ + +/**************************** threads *************************************/ + +static void sexp_define_type_predicate (sexp ctx, sexp env, char *cname, sexp_uint_t type) { + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + name = sexp_c_string(ctx, cname, -1); + op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type)); + sexp_env_define(ctx, env, name=sexp_intern(ctx, cname, -1), op); + sexp_gc_release2(ctx); +} + +sexp sexp_thread_timeoutp (sexp ctx sexp_api_params(self, n)) { + return sexp_make_boolean(sexp_context_timeoutp(ctx)); +} + +sexp sexp_thread_name (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + return sexp_context_name(thread); +} + +sexp sexp_thread_specific (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + return sexp_context_specific(thread); +} + +sexp sexp_thread_specific_set (sexp ctx sexp_api_params(self, n), sexp thread, sexp val) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + sexp_context_specific(thread) = val; + return SEXP_VOID; +} + +sexp sexp_current_thread (sexp ctx sexp_api_params(self, n)) { + return ctx; +} + +sexp sexp_make_thread (sexp ctx sexp_api_params(self, n), sexp thunk, sexp name) { + sexp res, *stack; + sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, thunk); + res = sexp_make_eval_context(ctx, SEXP_FALSE, sexp_context_env(ctx), 0); + sexp_context_proc(res) = thunk; + sexp_context_ip(res) = sexp_bytecode_data(sexp_procedure_code(thunk)); + stack = sexp_stack_data(sexp_context_stack(res)); + stack[0] = stack[1] = stack[3] = SEXP_ZERO; + stack[2] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); + sexp_context_top(res) = 4; + sexp_context_last_fp(res) = 0; + return res; +} + +sexp sexp_thread_start (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp cell; + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + cell = sexp_cons(ctx, thread, SEXP_NULL); + if (sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = cell; + sexp_global(ctx, SEXP_G_THREADS_BACK) = cell; + } else { /* init queue */ + sexp_global(ctx, SEXP_G_THREADS_BACK) = sexp_global(ctx, SEXP_G_THREADS_FRONT) = cell; + } + return SEXP_VOID; +} + +sexp sexp_thread_terminate (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp res = sexp_make_boolean(ctx == thread); + for ( ; thread && sexp_contextp(thread); thread=sexp_context_child(thread)) + sexp_context_refuel(thread) = 0; + /* return true if terminating self */ + return res; +} + +static void sexp_insert_timed (sexp ctx, sexp thread, sexp timeout) { +#if SEXP_USE_FLONUMS + double d; +#endif + sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); + if (sexp_integerp(timeout) || sexp_flonump(timeout)) + gettimeofday(&sexp_context_timeval(ctx), NULL); + if (sexp_integerp(timeout)) { + sexp_context_timeval(ctx).tv_sec += sexp_unbox_fixnum(timeout); +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(timeout)) { + d = sexp_flonum_value(timeout); + sexp_context_timeval(ctx).tv_sec += trunc(d); + sexp_context_timeval(ctx).tv_usec += (d-trunc(d))*1000000; +#endif + } else { + sexp_context_timeval(ctx).tv_sec = 0; + sexp_context_timeval(ctx).tv_usec = 0; + } + if (sexp_numberp(timeout)) + while (sexp_pairp(ls2) + && sexp_context_before(sexp_car(ls2), sexp_context_timeval(ctx))) + ls1=ls2, ls2=sexp_cdr(ls2); + else + while (sexp_pairp(ls2) && sexp_context_timeval(sexp_car(ls2)).tv_sec) + ls1=ls2, ls2=sexp_cdr(ls2); + if (ls1 == SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cons(ctx, thread, ls2); + else + sexp_cdr(ls1) = sexp_cons(ctx, thread, ls2); +} + +sexp sexp_thread_join (sexp ctx sexp_api_params(self, n), sexp thread, sexp timeout) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + if (sexp_context_refuel(thread) <= 0) /* return true if already terminated */ { + return SEXP_TRUE; + } + sexp_context_timeoutp(ctx) = 0; + sexp_context_waitp(ctx) = 1; + sexp_context_event(ctx) = thread; + sexp_insert_timed(ctx, ctx, timeout); + return SEXP_FALSE; +} + +sexp sexp_thread_sleep (sexp ctx sexp_api_params(self, n), sexp timeout) { + sexp_context_waitp(ctx) = 1; + if (timeout != SEXP_TRUE) { + sexp_assert_type(ctx, sexp_numberp, SEXP_NUMBER, timeout); + sexp_insert_timed(ctx, ctx, timeout); + } + return SEXP_FALSE; +} + +/**************************** mutexes *************************************/ + +sexp sexp_mutex_state (sexp ctx sexp_api_params(self, n), sexp mutex) { + /* sexp_assert_type(ctx, sexp_mutexp, mutex_id, timeout); */ + if (sexp_truep(sexp_mutex_lockp(mutex))) { + if (sexp_contextp(sexp_mutex_thread(mutex))) + return sexp_mutex_thread(mutex); + else + return sexp_intern(ctx, "not-owned", -1); + } else { + return sexp_intern(ctx, (sexp_mutex_thread(mutex) ? "not-abandoned" : "abandoned"), -1); + } +} + +sexp sexp_mutex_lock (sexp ctx sexp_api_params(self, n), sexp mutex, sexp timeout, sexp thread) { + if (thread == SEXP_TRUE) + thread = ctx; + if (sexp_not(sexp_mutex_lockp(mutex))) { + sexp_mutex_lockp(mutex) = SEXP_TRUE; + sexp_mutex_thread(mutex) = thread; + return SEXP_TRUE; + } else { + sexp_context_waitp(ctx) = 1; + sexp_context_event(ctx) = mutex; + sexp_insert_timed(ctx, ctx, timeout); + return SEXP_FALSE; + } +} + +sexp sexp_mutex_unlock (sexp ctx sexp_api_params(self, n), sexp mutex, sexp condvar, sexp timeout) { + sexp ls1, ls2; + if (sexp_not(condvar)) { + /* normal unlock - always succeeds, just need to unblock threads */ + if (sexp_truep(sexp_mutex_lockp(mutex))) { + sexp_mutex_lockp(mutex) = SEXP_FALSE; + sexp_mutex_thread(mutex) = ctx; + /* search for threads blocked on this mutex */ + for (ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); + sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2)) + if (sexp_context_event(sexp_car(ls2)) == mutex) { + if (ls1==SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2); + else + sexp_cdr(ls1) = sexp_cdr(ls2); + sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT); + sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2; + if (! sexp_pairp(sexp_cdr(ls2))) + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; + sexp_context_waitp(sexp_car(ls2)) + = sexp_context_timeoutp(sexp_car(ls2)) = 0; + break; + } + } + return SEXP_TRUE; + } else { + /* wait on condition var */ + sexp_context_waitp(ctx) = 1; + sexp_context_event(ctx) = condvar; + sexp_insert_timed(ctx, ctx, timeout); + return SEXP_FALSE; + } +} + +/**************************** condition variables *************************/ + +sexp sexp_condition_variable_signal (sexp ctx sexp_api_params(self, n), sexp condvar) { + sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); + for ( ; sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2)) + if (sexp_context_event(sexp_car(ls2)) == condvar) { + if (ls1==SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2); + else + sexp_cdr(ls1) = sexp_cdr(ls2); + sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT); + sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2; + if (! sexp_pairp(sexp_cdr(ls2))) + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; + sexp_context_waitp(sexp_car(ls2)) = sexp_context_timeoutp(sexp_car(ls2)) = 0; + return SEXP_TRUE; + } + return SEXP_FALSE; +} + +sexp sexp_condition_variable_broadcast (sexp ctx sexp_api_params(self, n), sexp condvar) { + sexp res = SEXP_FALSE; + while (sexp_truep(sexp_condition_variable_signal(ctx, self, n, condvar))) + res = SEXP_TRUE; + return res; +} + +/**************************** the scheduler *******************************/ + +void sexp_wait_on_single_thread (sexp ctx) { + struct timeval tval; + useconds_t usecs = 0; + gettimeofday(&tval, NULL); + if (tval.tv_sec < sexp_context_timeval(ctx).tv_sec) + usecs = (sexp_context_timeval(ctx).tv_sec - tval.tv_sec) * 1000000; + if (tval.tv_usec < sexp_context_timeval(ctx).tv_usec) + usecs += sexp_context_timeval(ctx).tv_usec - tval.tv_usec; + usleep(usecs); +} + +static const sexp_uint_t sexp_log2_lookup[32] = { + 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, + 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9 +}; + +/* only works on powers of two */ +static sexp_uint_t sexp_log2_of_pow2 (sexp_uint_t n) { + return sexp_log2_lookup[(n * 0x077CB531U) >> 27]; +} + +static sexp sexp_pop_signal (sexp ctx sexp_api_params(self, n)) { + int allsigs, restsigs, signum; + if (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) == SEXP_ZERO) { + return SEXP_FALSE; + } else { + allsigs = sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_THREADS_SIGNALS)); + restsigs = allsigs & (allsigs-1); + sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = sexp_make_fixnum(restsigs); + signum = sexp_log2_of_pow2(allsigs-restsigs); + return sexp_make_fixnum(signum); + } +} + +static sexp sexp_get_signal_handler (sexp ctx sexp_api_params(self, n), sexp signum) { + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, signum); + return sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum); +} + +sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { + struct timeval tval; + sexp res, ls1, ls2, runner, paused, front; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + + front = sexp_global(ctx, SEXP_G_THREADS_FRONT); + paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED); + + /* check for signals */ + if (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) != SEXP_ZERO) { + runner = sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER); + if (! sexp_contextp(runner)) { /* ensure the runner exists */ + if (sexp_envp(runner)) { + tmp = sexp_env_cell(runner, (tmp=sexp_intern(ctx, "signal-runner", -1))); + if (sexp_pairp(tmp) && sexp_procedurep(sexp_cdr(tmp))) { + runner = sexp_make_thread(ctx, self, 2, sexp_cdr(tmp), SEXP_FALSE); + sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = runner; + sexp_thread_start(ctx, self, 1, runner); + } + } + } else if (sexp_context_waitp(runner)) { /* wake it if it's sleeping */ + sexp_context_waitp(runner) = 0; + sexp_thread_start(ctx, self, 1, runner); + } + } + + /* if we've terminated, check threads joining us */ + if (sexp_context_refuel(ctx) <= 0) { + for (ls1=SEXP_NULL, ls2=paused; sexp_pairp(ls2); ) { + if (sexp_context_event(sexp_car(ls2)) == ctx) { + sexp_context_waitp(sexp_car(ls2)) = 0; + sexp_context_timeoutp(sexp_car(ls2)) = 0; + if (ls1==SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = sexp_cdr(ls2); + else + sexp_cdr(ls1) = sexp_cdr(ls2); + tmp = sexp_cdr(ls2); + sexp_cdr(ls2) = SEXP_NULL; + if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { + sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = ls2; + } else { + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = ls2; + } + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; + ls2 = tmp; + } else { + ls1 = ls2; + ls2 = sexp_cdr(ls2); + } + } + } + + /* check timeouts */ + if (sexp_pairp(paused)) { + if (gettimeofday(&tval, NULL) == 0) { + ls1 = SEXP_NULL; + ls2 = paused; + while (sexp_pairp(ls2) && sexp_context_before(sexp_car(ls2), tval)) { + sexp_context_timeoutp(sexp_car(ls2)) = 1; + sexp_context_waitp(ctx) = 0; + ls1 = ls2; + ls2 = sexp_cdr(ls2); + } + if (sexp_pairp(ls1)) { + sexp_cdr(ls1) = SEXP_NULL; + if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { + sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = paused; + } else { + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = paused; + } + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls1; + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = ls2; + } + } + } + + /* dequeue next thread */ + if (sexp_pairp(front)) { + res = sexp_car(front); + if ((sexp_context_refuel(ctx) <= 0) || sexp_context_waitp(ctx)) { + /* either terminated or paused */ + sexp_global(ctx, SEXP_G_THREADS_FRONT) = sexp_cdr(front); + if (! sexp_pairp(sexp_cdr(front))) + sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL; + } else { + /* swap with front of queue */ + sexp_car(sexp_global(ctx, SEXP_G_THREADS_FRONT)) = ctx; + /* rotate front of queue to back */ + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) + = sexp_global(ctx, SEXP_G_THREADS_FRONT); + sexp_global(ctx, SEXP_G_THREADS_FRONT) + = sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_FRONT)); + sexp_global(ctx, SEXP_G_THREADS_BACK) + = sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)); + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = SEXP_NULL; + } + } else { + res = ctx; + } + + if (sexp_context_waitp(res)) { + /* the only thread available was waiting */ + sexp_wait_on_single_thread(res); + sexp_context_timeoutp(res) = 1; + sexp_context_waitp(res) = 0; + } + + sexp_gc_release1(ctx); + return res; +} + +/**************************************************************************/ + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + + sexp_define_type_predicate(ctx, env, "thread?", SEXP_CONTEXT); + sexp_define_foreign(ctx, env, "thread-timeout?", 0, sexp_thread_timeoutp); + sexp_define_foreign(ctx, env, "current-thread", 0, sexp_current_thread); + sexp_define_foreign_opt(ctx, env, "make-thread", 2, sexp_make_thread, SEXP_FALSE); + sexp_define_foreign(ctx, env, "thread-start!", 1, sexp_thread_start); + sexp_define_foreign(ctx, env, "%thread-terminate!", 1, sexp_thread_terminate); + sexp_define_foreign(ctx, env, "%thread-join!", 2, sexp_thread_join); + sexp_define_foreign(ctx, env, "%thread-sleep!", 1, sexp_thread_sleep); + sexp_define_foreign(ctx, env, "thread-name", 1, sexp_thread_name); + sexp_define_foreign(ctx, env, "thread-specific", 1, sexp_thread_specific); + sexp_define_foreign(ctx, env, "thread-specific-set!", 2, sexp_thread_specific_set); + sexp_define_foreign(ctx, env, "mutex-state", 1, sexp_mutex_state); + sexp_define_foreign(ctx, env, "%mutex-lock!", 3, sexp_mutex_lock); + sexp_define_foreign(ctx, env, "%mutex-unlock!", 3, sexp_mutex_unlock); + sexp_define_foreign(ctx, env, "condition-variable-signal!", 1, sexp_condition_variable_signal); + sexp_define_foreign(ctx, env, "condition-variable-broadcast!", 1, sexp_condition_variable_broadcast); + sexp_define_foreign(ctx, env, "pop-signal!", 0, sexp_pop_signal); + sexp_define_foreign(ctx, env, "get-signal-handler", 1, sexp_get_signal_handler); + + sexp_global(ctx, SEXP_G_THREADS_SCHEDULER) + = sexp_make_foreign(ctx, "scheduler", 0, 0, (sexp_proc1)sexp_scheduler, SEXP_FALSE); + + /* remember the env to lookup the runner later */ + sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = env; + + return SEXP_VOID; +} + diff --git a/lib/srfi/18/types.scm b/lib/srfi/18/types.scm new file mode 100644 index 00000000..093c97a7 --- /dev/null +++ b/lib/srfi/18/types.scm @@ -0,0 +1,24 @@ +;; types.scm -- thread types +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define-record-type mutex + (%make-mutex name specific thread lock) + mutex? + (name mutex-name) + (specific mutex-specific mutex-specific-set!) + (thread %mutex-thread %mutex-thread-set!) + (lock %mutex-lock %mutex-lock-set!)) + +(define (make-mutex . o) + (%make-mutex (and (pair? o) (car o)) #f #f #f)) + +(define-record-type condition-variable + (%make-condition-variable name specific threads) + condition-variable? + (name condition-variable-name) + (specific condition-variable-specific condition-variable-specific-set!) + (threads %condition-variable-threads %condition-variable-threads-set!)) + +(define (make-condition-variable . o) + (%make-condition-variable (and (pair? o) (car o)) #f #f)) diff --git a/lib/srfi/2.module b/lib/srfi/2.module new file mode 100644 index 00000000..4ceb8b6b --- /dev/null +++ b/lib/srfi/2.module @@ -0,0 +1,16 @@ + +(define-module (srfi 2) + (export and-let*) + (import-immutable (scheme)) + (body + (define-syntax and-let* + (syntax-rules () + ((and-let* () . body) + (begin . body)) + ((and-let* ((var expr) . rest) . body) + (let ((var expr)) + (and var (and-let* rest . body)))) + ((and-let* ((expr) . rest) . body) + (let ((tmp expr)) + (and tmp (and-let* rest . body)))))))) + diff --git a/lib/srfi/26.module b/lib/srfi/26.module new file mode 100644 index 00000000..f97ab783 --- /dev/null +++ b/lib/srfi/26.module @@ -0,0 +1,24 @@ + +(define-module (srfi 26) + (export cut cute) + (import-immutable (scheme)) + (body + (define-syntax %cut + (syntax-rules (<> <...>) + ((%cut e? params args) + (lambda params args)) + ((%cut e? (params ...) (args ...) <> . rest) + (%cut e? (params ... tmp) (args ... tmp) . rest)) + ((%cut e? (params ...) (args ...) <...>) + (%cut e? (params ... . tmp) (apply args ... tmp))) + ((%cut e? (params ...) (args ...) <...> . rest) + (error "cut: non-terminal <...>")) + ((%cut #t (params ...) (args ...) x . rest) + (let ((tmp x)) (%cut #t (params ...) (args ... tmp) . rest))) + ((%cut #f (params ...) (args ...) x . rest) + (%cut #t (params ...) (args ... x) . rest)))) + (define-syntax cut + (syntax-rules () ((cut args ...) (%cut #f () () args ...)))) + (define-syntax cute + (syntax-rules () ((cute args ...) (%cut #t () () args ...)))))) + diff --git a/lib/srfi/27.module b/lib/srfi/27.module new file mode 100644 index 00000000..5c451629 --- /dev/null +++ b/lib/srfi/27.module @@ -0,0 +1,11 @@ + +(define-module (srfi 27) + (export random-integer random-real default-random-source + make-random-source random-source? + random-source-state-ref random-source-state-set! + random-source-randomize! random-source-pseudo-randomize! + random-source-make-integers random-source-make-reals) + (import-immutable (scheme)) + (include-shared "27/rand") + (include "27/constructors.scm")) + diff --git a/lib/srfi/27/constructors.scm b/lib/srfi/27/constructors.scm new file mode 100644 index 00000000..dbd0a8c6 --- /dev/null +++ b/lib/srfi/27/constructors.scm @@ -0,0 +1,10 @@ +;; constructors.scm -- random function constructors +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (random-source-make-integers rs) + (lambda (n) (%random-integer rs n))) + +(define (random-source-make-reals rs . o) + (lambda () (%random-real rs))) + diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c new file mode 100644 index 00000000..6e971df8 --- /dev/null +++ b/lib/srfi/27/rand.c @@ -0,0 +1,204 @@ +/* rand.c -- rand_r/random_r interface */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include +#include + +#define SEXP_RANDOM_STATE_SIZE 128 + +#define ZERO sexp_make_fixnum(0) +#define ONE sexp_make_fixnum(1) +#define STATE_SIZE sexp_make_fixnum(SEXP_RANDOM_STATE_SIZE) + +#define sexp_random_source_p(x) sexp_check_tag(x, rs_type_id) + +#define sexp_random_init(x, seed) \ + initstate_r(seed, \ + sexp_string_data(sexp_random_state(x)), \ + SEXP_RANDOM_STATE_SIZE, \ + sexp_random_data(x)) + +#if SEXP_BSD || defined(__CYGWIN__) +typedef unsigned int sexp_random_t; +#define sexp_call_random(rs, dst) ((dst) = rand_r(sexp_random_data(rs))) +#define sexp_seed_random(n, rs) *sexp_random_data(rs) = (n) +#else +typedef struct random_data sexp_random_t; +#define sexp_call_random(rs, dst) random_r(sexp_random_data(rs), &dst) +#define sexp_seed_random(n, rs) srandom_r(n, sexp_random_data(rs)) +#endif + +#define sexp_random_state(x) (sexp_slot_ref((x), 0)) +#define sexp_random_data(x) ((sexp_random_t*)(&sexp_slot_ref((x), 1))) + +#define sexp_sizeof_random (sexp_sizeof_header + sizeof(sexp_random_t) + sizeof(sexp)) + +static sexp_uint_t rs_type_id; +static sexp default_random_source; + +static sexp sexp_rs_random_integer (sexp ctx sexp_api_params(self, n), sexp rs, sexp bound) { + sexp res; + int32_t m; +#if SEXP_USE_BIGNUMS + int32_t hi, mod, len, i, *data; +#endif + if (! sexp_random_source_p(rs)) + res = sexp_type_exception(ctx, self, rs_type_id, rs); + if (sexp_fixnump(bound)) { + sexp_call_random(rs, m); + res = sexp_make_fixnum(m % sexp_unbox_fixnum(bound)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(bound)) { + hi = sexp_bignum_hi(bound); + len = hi * sizeof(sexp_uint_t) / sizeof(int32_t); + res = sexp_make_bignum(ctx, hi); + data = (int32_t*) sexp_bignum_data(res); + for (i=0; i +#include + +#if SEXP_USE_BIGNUMS +#include +#else +#define sexp_bignum_normalize(x) x +#endif + +static sexp sexp_bit_and (sexp ctx sexp_api_params(self, n), sexp x, sexp y) { + sexp res; +#if SEXP_USE_BIGNUMS + sexp_sint_t len, i; +#endif + if (sexp_fixnump(x)) { + if (sexp_fixnump(y)) + res = (sexp) ((sexp_uint_t)x & (sexp_uint_t)y); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(y)) + res = sexp_bit_and(ctx sexp_api_pass(self, n), y, x); +#endif + else + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + if (sexp_fixnump(y)) { + res = sexp_make_fixnum(sexp_unbox_fixnum(y) & sexp_bignum_data(x)[0]); + } else if (sexp_bignump(y)) { + if (sexp_bignum_length(x) < sexp_bignum_length(y)) + res = sexp_copy_bignum(ctx, NULL, x, 0); + else + res = sexp_copy_bignum(ctx, NULL, y, 0); + for (i=0, len=sexp_bignum_length(res); i= sexp_bignum_length(y)) { + res = sexp_copy_bignum(ctx, NULL, x, 0); + len = sexp_bignum_length(y); + } else { + res = sexp_copy_bignum(ctx, NULL, y, 0); + len = sexp_bignum_length(x); + } + for (i=0; i= sexp_bignum_length(y)) { + res = sexp_copy_bignum(ctx, NULL, x, 0); + len = sexp_bignum_length(y); + } else { + res = sexp_copy_bignum(ctx, NULL, y, 0); + len = sexp_bignum_length(x); + } + for (i=0; i> -c); + } else { + tmp = (sexp_uint_t)sexp_unbox_fixnum(i) << c; +#if SEXP_USE_BIGNUMS + if (((tmp >> c) == sexp_unbox_fixnum(i)) + && (tmp < SEXP_MAX_FIXNUM) && (tmp > SEXP_MIN_FIXNUM)) { +#endif + res = sexp_make_fixnum(tmp); +#if SEXP_USE_BIGNUMS + } else { + sexp_gc_preserve1(ctx, res); + res = sexp_fixnum_to_bignum(ctx, i); + res = sexp_arithmetic_shift(ctx sexp_api_pass(self, n), res, count); + sexp_gc_release1(ctx); + } +#endif + } +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(i)) { + len = sexp_bignum_hi(i); + if (c < 0) { + c = -c; + offset = c / (sizeof(sexp_uint_t)*CHAR_BIT); + bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT); + if (len < offset) { + res = sexp_make_fixnum(sexp_bignum_sign(i) > 0 ? 0 : -1); + } else { + res = sexp_make_bignum(ctx, len - offset + 1); + for (j=len-offset, tmp=0; j>=0; j--) { + sexp_bignum_data(res)[j] + = (sexp_bignum_data(i)[j+offset] >> bit_shift)+ tmp; + tmp = sexp_bignum_data(i)[j+offset] + << (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift); + } + } + } else { + offset = c / (sizeof(sexp_uint_t)*CHAR_BIT); + bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT); + res = sexp_make_bignum(ctx, len + offset + 1); + for (j=tmp=0; j> (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift); + } + sexp_bignum_data(res)[len+offset] = tmp; + } +#endif + } else { + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, i); + } + return sexp_bignum_normalize(res); +} + +/* bit-count and integer-length were adapted from: */ +/* http://graphics.stanford.edu/~seander/bithacks.html */ +static sexp_uint_t bit_count (sexp_uint_t i) { + i -= ((i >> 1) & (sexp_uint_t)~(sexp_uint_t)0/3); + i = ((i & (sexp_uint_t)~(sexp_uint_t)0/15*3) + + ((i >> 2) & (sexp_uint_t)~(sexp_uint_t)0/15*3)); + i = (i + (i >> 4)) & (sexp_uint_t)~(sexp_uint_t)0/255*15; + return ((sexp_uint_t)(i * ((sexp_uint_t)~(sexp_uint_t)0/255)) + >> (sizeof(i) - 1) * CHAR_BIT); +} + +static sexp sexp_bit_count (sexp ctx sexp_api_params(self, n), sexp x) { + sexp res; + sexp_sint_t i; +#if SEXP_USE_BIGNUMS + sexp_uint_t count; +#endif + if (sexp_fixnump(x)) { + i = sexp_unbox_fixnum(x); + res = sexp_make_fixnum(bit_count(i<0 ? ~i : i)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + for (i=count=0; i> 32)) + return integer_log2(tt) + 32; + else +#endif + if ((tt = x >> 16)) + return (t = tt >> 8) ? 24 + log_table_256[t] : 16 + log_table_256[tt]; + else + return (t = x >> 8) ? 8 + log_table_256[t] : log_table_256[x]; +} + +static sexp sexp_integer_length (sexp ctx sexp_api_params(self, n), sexp x) { + sexp_sint_t tmp; +#if SEXP_USE_BIGNUMS + sexp_sint_t hi; +#endif + if (sexp_fixnump(x)) { + tmp = sexp_unbox_fixnum(x); + return sexp_make_fixnum(integer_log2(tmp < 0 ? -tmp-1 : tmp)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + hi = sexp_bignum_hi(x); + return sexp_make_fixnum(integer_log2(sexp_bignum_data(x)[hi]) + + hi*sizeof(sexp_uint_t)); +#endif + } else { + return sexp_type_exception(ctx, self, SEXP_FIXNUM, x); + } +} + +static sexp sexp_bit_set_p (sexp ctx sexp_api_params(self, n), sexp i, sexp x) { +#if SEXP_USE_BIGNUMS + sexp_uint_t pos; +#endif + if (! sexp_fixnump(i)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, i); + if (sexp_fixnump(x)) { + return sexp_make_boolean(sexp_unbox_fixnum(x) & (1< (lambda (cell) (set-cdr! cell (+ (cdr cell) 1)))) + ((pair? x) + (set! seen (cons (cons x 1) seen)) + (find (car x)) + (find (cdr x))) + ((vector? x) + (set! seen (cons (cons x 1) seen)) + (do ((i 0 (+ i 1))) + ((= i (vector-length x))) + (find (vector-ref x i)))))) + (let extract ((ls seen) (res '())) + (cond + ((null? ls) res) + ((> (cdar ls) 1) (extract (cdr ls) (cons (cons (caar ls) #f) res))) + (else (extract (cdr ls) res)))))) + +(define (write-with-shared-structure x . o) + (let ((out (if (pair? o) (car o) (current-output-port))) + (shared (extract-shared-objects x)) + (count 0)) + (define (check-shared x prefix cont) + (let ((cell (assq x shared))) + (cond ((and cell (cdr cell)) + (display prefix out) + (display "#" out) + (write (cdr cell)) + (display "#" out)) + (else + (cond (cell + (display prefix out) + (display "#=" out) + (write count out) + (set-cdr! cell count) + (set! count (+ count 1)))) + (cont x))))) + (cond + ((null? shared) + (write x out)) + (else + (let wr ((x x)) + (check-shared + x + "" + (lambda (x) + (cond + ((pair? x) + (display "(" out) + (wr (car x)) + (let lp ((ls (cdr x))) + (check-shared + ls + " . " + (lambda (ls) + (cond ((null? ls)) + ((pair? ls) + (display " " out) + (wr (car ls)) + (lp (cdr ls))) + (else + (display " . " out) + (wr ls)))))) + (display ")" out)) + ((vector? x) + (display "#(" out) + (let ((len (vector-length x))) + (cond ((> len 0) + (wr (vector-ref x 0)) + (do ((i 1 (+ i 1))) + ((= i len)) + (display " " out) + (wr (vector-ref x i)))))) + (display ")" out)) + (else + (write x out)))))))))) + +(define write/ss write-with-shared-structure) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (skip-line in) + (let ((c (read-char in))) + (if (not (or (eof-object? c) (eqv? c #\newline))) + (skip-line in)))) + +(define (skip-whitespace in) + (case (peek-char in) + ((#\space #\tab #\newline #\return) + (read-char in) + (skip-whitespace in)) + ((#\;) + (skip-line in) + (skip-whitespace in)))) + +(define (skip-comment in depth) + (case (read-char in) + ((#\#) (skip-comment in (if (eqv? #\| (peek-char in)) (+ depth 1) depth))) + ((#\|) (if (eqv? #\# (peek-char in)) + (if (zero? depth) (read-char in) (skip-comment in (- depth 1))) + (skip-comment in depth))) + (else (if (eof-object? (peek-char in)) + (error "unterminated #| comment") + (skip-comment in depth))))) + +(define delimiters + '(#\( #\) #\[ #\] #\space #\tab #\newline #\return)) + +(define read-with-shared-structure + (let ((read read)) + (lambda o + (let ((in (if (pair? o) (car o) (current-input-port))) + (shared '())) + (define (read-label res) + (let ((c (char-downcase (peek-char in)))) + (if (if (char-numeric? c) #t (memv c '(#\a #\b #\c #\d #\e))) + (read-label (cons (read-char in) res)) + (list->string (reverse res))))) + (define (read-number base) + (let* ((str (read-label '())) + (n (string->number str base))) + (if (or (not n) (not (memv (peek-char in) delimiters))) + (error "read error: invalid number syntax" str (peek-char in)) + n))) + (define (read-float-tail in) ;; called only after a leading period + (let lp ((res 0.0) (k 0.1)) + (let ((c (peek-char in))) + (cond + ((char-numeric? c) (lp (+ res (* (read-char in) k)) (* k 0.1))) + ((memv c delimiters) res) + (else (error "invalid char in float syntax" c)))))) + (define (read-name c in) + (let lp ((ls (if (char? c) (list c) '()))) + (let ((c (peek-char in))) + (cond ((memv c delimiters) (list->string (reverse ls))) + (else (lp (cons (read-char in) ls))))))) + (define (read-named-char c in) + (let ((name (read-name c in))) + (cond ((string-ci=? name "space") #\space) + ((string-ci=? name "newline") #\newline) + (else (error "unknown char name"))))) + (define (read-one) + (skip-whitespace in) + (case (peek-char in) + ((#\#) + (read-char in) + (case (char-downcase (peek-char in)) + ((#\=) + (read-char in) + (let* ((str (read-label '())) + (n (string->number str)) + (cell (list #f)) + (thunk (lambda () (car cell)))) + (if (not n) (error "read error: invalid reference" str)) + (set! shared (cons (cons n thunk) shared)) + (let ((x (read-one))) + (set-car! cell x) + x))) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + (let ((n (string->number (read-label '())))) + (cond + ((not (eqv? #\# (peek-char in))) + (error "read error: expected # after #n" (read-char in))) + (else + (read-char in) + (cond ((assv n shared) => cdr) + (else (error "read error: unknown reference" n))))))) + ((#\;) + (read-char in) + (read-one) ;; discard + (read-one)) + ((#\|) + (skip-comment in 0)) + ((#\!) (skip-line in) (read-one in)) + ((#\() (list->vector (read-one))) + ((#\') (read-char in) (list 'syntax (read-one))) + ((#\`) (read-char in) (list 'quasisyntax (read-one))) + ((#\t) (read-char in) #t) + ((#\f) (read-char in) #t) ; support SRFI-4 f32/64 vectors + ((#\d) (read-char in) (read in)) + ((#\x) (read-char in) (read-number 16)) + ((#\o) (read-char in) (read-number 8)) + ((#\b) (read-char in) (read-number 2)) + ((#\i) (read-char in) (exact->inexact (read-one))) + ((#\e) (read-char in) (inexact->exact (read-one))) + ((#\\) + (read-char in) + (let ((c (read-char in))) + (if (memv (peek-char in) delimiters) + c + (read-named-char c in)))) + (else + (error "unknown # syntax: " (peek-char in))))) + ((#\() + (read-char in) + (let lp ((res '())) + (skip-whitespace in) + (case (peek-char in) + ((#\)) + (read-char in) + (reverse res)) + ((#\.) + (read-char in) + (cond + ((memv (peek-char in) delimiters) + (let ((tail (read-one))) + (skip-whitespace in) + (if (eqv? #\) (peek-char in)) + (begin (read-char in) (append (reverse res) tail)) + (error "expected end of list after dot")))) + ((char-numeric? (peek-char in)) (read-float-tail in)) + (else (string->symbol (read-name #\. in))))) + (else + (lp (cons (read-one) res)))))) + ((#\') (read-char in) (list 'quote (read-one))) + ((#\`) (read-char in) (list 'quasiquote (read-one))) + ((#\,) + (read-char in) + (list (if (eqv? #\@ (peek-char in)) + (begin (read-char in) 'unquote-splicing) + 'unquote) + (read-one))) + (else + (read in)))) + ;; body + (let ((res (read-one))) + (if (pair? shared) + (patch res)) + res))))) + +(define (hole? x) (procedure? x)) +(define (fill-hole x) (if (hole? x) (fill-hole (x)) x)) + +(define (patch x) + (cond + ((pair? x) + (if (hole? (car x)) (set-car! x (fill-hole (car x))) (patch (car x))) + (if (hole? (cdr x)) (set-cdr! x (fill-hole (cdr x))) (patch (cdr x)))) + ((vector? x) + (do ((i (- (vector-length x) 1) (- i 1))) + ((< i 0)) + (let ((elt (vector-ref x i))) + (if (hole? elt) + (vector-set! x i (fill-hole elt)) + (patch elt))))))) + +(define read/ss read-with-shared-structure) diff --git a/lib/srfi/39.module b/lib/srfi/39.module new file mode 100644 index 00000000..11b9ed9f --- /dev/null +++ b/lib/srfi/39.module @@ -0,0 +1,25 @@ + +(define-module (srfi 39) + (export make-parameter parameterize) + (import-immutable (scheme)) + (body + (define (make-parameter value . o) + (if (pair? o) + (let ((converter (car o))) + (lambda args + (if (null? args) + value + (set! value (converter (car args)))))) + (lambda args (if (null? args) value (set! value (car args)))))) + (define-syntax parameterize + (syntax-rules () + ((parameterize ("step") ((param value tmp1 tmp2) ...) () body) + (let ((tmp1 value) ...) + (let ((tmp2 (param)) ...) + (dynamic-wind (lambda () (param tmp1) ...) + (lambda () . body) + (lambda () (param tmp2) ...))))) + ((parameterize ("step") args ((param value) . rest) body) + (parameterize ("step") ((param value tmp1 tmp2) . args) rest body)) + ((parameterize ((param value) ...) . body) + (parameterize ("step") () ((param value) ...) body)))))) diff --git a/lib/srfi/6.module b/lib/srfi/6.module new file mode 100644 index 00000000..e589b6ff --- /dev/null +++ b/lib/srfi/6.module @@ -0,0 +1,5 @@ + +(define-module (srfi 6) + (export open-input-string open-output-string get-output-string) + (import-immutable (scheme))) + diff --git a/lib/srfi/69.module b/lib/srfi/69.module new file mode 100644 index 00000000..037b6393 --- /dev/null +++ b/lib/srfi/69.module @@ -0,0 +1,17 @@ + +(define-module (srfi 69) + (export + make-hash-table hash-table? alist->hash-table + hash-table-equivalence-function hash-table-hash-function + hash-table-ref hash-table-ref/default hash-table-set! + hash-table-delete! hash-table-exists? + hash-table-update! hash-table-update!/default + hash-table-size hash-table-keys hash-table-values + hash-table-walk hash-table-fold hash-table->alist + hash-table-copy hash-table-merge! + hash string-hash string-ci-hash hash-by-identity) + (import-immutable (scheme) + (srfi 9)) + (include-shared "69/hash") + (include "69/type.scm" "69/interface.scm")) + diff --git a/lib/srfi/69/hash.c b/lib/srfi/69/hash.c new file mode 100644 index 00000000..42d1e864 --- /dev/null +++ b/lib/srfi/69/hash.c @@ -0,0 +1,242 @@ +/* hash.c -- type-general hashing */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +#define HASH_DEPTH 5 +#define HASH_BOUND sexp_make_fixnum(SEXP_MAX_FIXNUM) + +#define FNV_PRIME 16777619 +#define FNV_OFFSET_BASIS 2166136261uL + +#define sexp_hash_table_buckets(x) sexp_slot_ref(x, 0) +#define sexp_hash_table_size(x) sexp_slot_ref(x, 1) +#define sexp_hash_table_hash_fn(x) sexp_slot_ref(x, 2) +#define sexp_hash_table_eq_fn(x) sexp_slot_ref(x, 3) + +#define sexp_hash_resize_check(n, len) (((n)*3) > ((len)>>2)) + +static sexp_uint_t string_hash (char *str, sexp_uint_t bound) { + sexp_uint_t acc = FNV_OFFSET_BASIS; + while (*str) {acc *= FNV_PRIME; acc ^= *str++;} + return acc % bound; +} + +static sexp sexp_string_hash (sexp ctx sexp_api_params(self, n), sexp str, sexp bound) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, self, SEXP_STRING, str); + else if (! sexp_fixnump(bound)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); + return sexp_make_fixnum(string_hash(sexp_string_data(str), + sexp_unbox_fixnum(bound))); +} + +static sexp_uint_t string_ci_hash (char *str, sexp_uint_t bound) { + sexp_uint_t acc = FNV_OFFSET_BASIS; + while (*str) {acc *= FNV_PRIME; acc ^= (tolower)(*str++);} + return acc % bound; +} + +static sexp sexp_string_ci_hash (sexp ctx sexp_api_params(self, n), sexp str, sexp bound) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, self, SEXP_STRING, str); + else if (! sexp_fixnump(bound)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); + return sexp_make_fixnum(string_ci_hash(sexp_string_data(str), + sexp_unbox_fixnum(bound))); +} + +static sexp_uint_t hash_one (sexp ctx, sexp obj, sexp_uint_t bound, sexp_sint_t depth) { + sexp_uint_t acc = FNV_OFFSET_BASIS, size; + sexp_sint_t i, len; + sexp t, *p; + char *p0; + loop: +#if SEXP_USE_FLONUMS + if (sexp_flonump(obj)) + acc ^= (sexp_sint_t) sexp_flonum_value(obj); + else +#endif + if (sexp_pointerp(obj)) { + if (depth) { + t = sexp_object_type(ctx, obj); + p = (sexp*) (((char*)obj) + sexp_type_field_base(t)); + p0 = ((char*)obj) + offsetof(struct sexp_struct, value); + if ((sexp)p == obj) p=(sexp*)p0; + /* hash trailing non-object data */ + size = sexp_type_size_of_object(t, obj)-offsetof(struct sexp_struct, value); + p0 = ((char*)p + sexp_type_num_slots_of_object(t,obj)*sizeof(sexp)); + if (((char*)obj + size) > p0) + for (i=0; i 0) { + depth--; + for (i=0; ialist table) + (hash-table-fold table (lambda (k v a) (cons (cons k v) a)) '())) + +(define (hash-table-keys table) + (hash-table-fold table (lambda (k v a) (cons k a)) '())) + +(define (hash-table-values table) + (hash-table-fold table (lambda (k v a) (cons v a)) '())) + +(define (alist->hash-table ls . o) + (let ((res (apply make-hash-table o))) + (for-each (lambda (x) (hash-table-set! res (car x) (cdr x))) ls) + res)) + +(define (hash-table-merge! a b) + (hash-table-walk b (lambda (k v) (hash-table-set! a k v))) + a) + +(define (hash-table-copy table) + (assert-hash-table "hash-table-copy" table) + (let ((res (make-hash-table (hash-table-equivalence-function table)))) + (hash-table-merge! res table) + res)) + diff --git a/lib/srfi/69/type.scm b/lib/srfi/69/type.scm new file mode 100644 index 00000000..1fca9953 --- /dev/null +++ b/lib/srfi/69/type.scm @@ -0,0 +1,12 @@ +;; types.scm -- the hash-table record type +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define-record-type hash-table + (%make-hash-table buckets size hash-fn eq-fn) + hash-table? + (buckets hash-table-buckets hash-table-buckets-set!) + (size hash-table-size hash-table-size-set!) + (hash-fn %hash-table-hash-function) + (eq-fn %hash-table-equivalence-function)) + diff --git a/lib/srfi/8.module b/lib/srfi/8.module new file mode 100644 index 00000000..64a3e6e2 --- /dev/null +++ b/lib/srfi/8.module @@ -0,0 +1,10 @@ + +(define-module (srfi 8) + (export receive) + (import-immutable (scheme)) + (body + (define-syntax receive + (syntax-rules () + ((receive params expr . body) + (call-with-values (lambda () expr) (lambda params . body))))))) + diff --git a/lib/srfi/9.module b/lib/srfi/9.module new file mode 100644 index 00000000..58368111 --- /dev/null +++ b/lib/srfi/9.module @@ -0,0 +1,90 @@ + +(define-module (srfi 9) + (export define-record-type) + (import-immutable (scheme)) + (body + (define-syntax define-record-type + (er-macro-transformer + (lambda (expr rename compare) + (let* ((name (cadr expr)) + (name-str (symbol->string (identifier->symbol name))) + (make (caaddr expr)) + (make-fields (cdaddr expr)) + (pred (cadddr expr)) + (fields (cddddr expr)) + (num-fields (length fields)) + (_define (rename 'define)) + (_lambda (rename 'lambda)) + (_let (rename 'let)) + (_register (rename 'register-simple-type))) + (define (index-of field ls) + (let lp ((ls ls) (i 0)) + (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1))))) + `(,(rename 'begin) + ;; type + (,_define ,name (,_register ,name-str ,num-fields)) + ;; predicate + (,_define ,pred (,(rename 'make-type-predicate) + ,(symbol->string (identifier->symbol pred)) + ,name)) + ;; fields + ,@(let lp ((ls fields) (i 0) (res '())) + (if (null? ls) + res + (let ((res + (cons `(,_define ,(cadar ls) + (,(rename 'make-getter) + ,(symbol->string + (identifier->symbol (cadar ls))) + ,name + ,i)) + res))) + (lp (cdr ls) + (+ i 1) + (if (pair? (cddar ls)) + (cons + `(,_define ,(caddar ls) + (,(rename 'make-setter) + ,(symbol->string + (identifier->symbol (caddar ls))) + ,name + ,i)) + res) + res))))) + ;; constructor + (,_define ,make + ,(let lp ((ls make-fields) (sets '()) (set-defs '())) + (cond + ((null? ls) + `(,_let ((%make (,(rename 'make-constructor) + ,(symbol->string (identifier->symbol make)) + ,name)) + ,@set-defs) + (,_lambda ,make-fields + (,_let ((res (%make))) + ,@sets + res)))) + (else + (let ((field (assq (car ls) fields))) + (cond + ((not field) + (error "unknown record field in constructor" (car ls))) + ((pair? (cddr field)) + (lp (cdr ls) + (cons (list (caddr field) 'res (car ls)) sets) + set-defs)) + (else + (let* ((setter-name + (string-append "%" name-str "-" + (symbol->string (car ls)) "-set!")) + (setter (rename (string->symbol setter-name))) + (i (index-of (car ls) fields))) + (lp (cdr ls) + (cons (list setter 'res (car ls)) sets) + (cons (list setter + (list (rename 'make-setter) + setter-name + name + (index-of (car ls) fields))) + set-defs))))))))))))))))) + diff --git a/lib/srfi/95.module b/lib/srfi/95.module new file mode 100644 index 00000000..43bab9dd --- /dev/null +++ b/lib/srfi/95.module @@ -0,0 +1,7 @@ + +(define-module (srfi 95) + (export sorted? merge merge! sort sort! object-cmp) + (import-immutable (scheme)) + (include-shared "95/qsort") + (include "95/sort.scm")) + diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c new file mode 100644 index 00000000..14329e37 --- /dev/null +++ b/lib/srfi/95/qsort.c @@ -0,0 +1,228 @@ +/* qsort.c -- quicksort implementation */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#if SEXP_USE_HUFF_SYMS +#include "../../../opt/sexp-hufftabs.c" +#endif + +#define swap(tmp_var, a, b) (tmp_var=a, a=b, b=tmp_var) + +static sexp sexp_vector_copy_to_list (sexp ctx, sexp vec, sexp seq) { + sexp_sint_t i; + sexp ls, *data=sexp_vector_data(vec); + for (i=0, ls=seq; sexp_pairp(ls); i++, ls=sexp_cdr(ls)) + sexp_car(ls) = data[i]; + return seq; +} + +static sexp sexp_vector_nreverse (sexp ctx, sexp vec) { + int i, j; + sexp tmp, *data=sexp_vector_data(vec); + for (i=0, j=sexp_vector_length(vec)-1; i>3, d = ((sexp_uint_t)b)>>3; + while (c && d) { +#include "../../../opt/sexp-unhuff.c" +#define c d +#define res res2 +#include "../../../opt/sexp-unhuff.c" +#undef c +#undef res + if ((tmp=res-res2) != 0) + return tmp; + } + return c ? 1 : d ? -1 : 0; +} +#endif + +static int sexp_object_compare (sexp ctx, sexp a, sexp b) { + int res; + if (a == b) + return 0; + if (sexp_pointerp(a)) { + if (sexp_pointerp(b)) { + if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) { + res = sexp_pointer_tag(a) - sexp_pointer_tag(b); + } else { + switch (sexp_pointer_tag(a)) { + case SEXP_FLONUM: + res = sexp_flonum_value(a) - sexp_flonum_value(b); + break; + case SEXP_BIGNUM: + res = sexp_bignum_compare(a, b); + break; + case SEXP_STRING: + res = strcmp(sexp_string_data(a), sexp_string_data(b)); + break; + case SEXP_SYMBOL: + res = strcmp(sexp_symbol_data(a), sexp_symbol_data(b)); + break; + default: + res = 0; + break; + } + } +#if SEXP_USE_HUFF_SYMS + } else if (sexp_lsymbolp(a) && sexp_isymbolp(b)) { + res = strcmp(sexp_symbol_data(a), + sexp_string_data(sexp_write_to_string(ctx, b))); +#endif + } else { + res = 1; + } + } else if (sexp_pointerp(b)) { +#if SEXP_USE_HUFF_SYMS + if (sexp_isymbolp(a) && sexp_lsymbolp(b)) + res = strcmp(sexp_string_data(sexp_write_to_string(ctx, a)), + sexp_symbol_data(b)); + else +#endif + res = -1; + } else { +#if SEXP_USE_HUFF_SYMS + if (sexp_isymbolp(a) && sexp_isymbolp(b)) + return sexp_isymbol_compare(ctx, a, b); + else +#endif + res = (sexp_sint_t)a - (sexp_sint_t)b; + } + return res; +} + +static sexp sexp_object_compare_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { + return sexp_make_fixnum(sexp_object_compare(ctx, a, b)); +} + +/* fast path when using general object-cmp comparator with no key */ +static void sexp_qsort (sexp ctx, sexp *vec, sexp_sint_t lo, sexp_sint_t hi) { + sexp_sint_t mid, i, j; + sexp tmp, tmp2; + loop: + if (lo < hi) { + mid = lo + (hi-lo)/2; + swap(tmp, vec[mid], vec[hi]); + for (i=j=lo; i < hi; i++) + if (sexp_object_compare(ctx, vec[i], tmp) < 0) + swap(tmp2, vec[i], vec[j]), j++; + swap(tmp, vec[j], vec[hi]); + if ((hi-lo) > 2) { + sexp_qsort(ctx, vec, lo, j-1); + lo = j; + goto loop; /* tail recurse on right side */ + } + } +} + +static sexp sexp_qsort_less (sexp ctx, sexp *vec, + sexp_sint_t lo, sexp_sint_t hi, + sexp less, sexp key) { + sexp_sint_t mid, i, j; + sexp tmp, res, args1; + sexp_gc_var3(a, b, args2); + sexp_gc_preserve3(ctx, a, b, args2); + args2 = sexp_list2(ctx, SEXP_VOID, SEXP_VOID); + args1 = sexp_cdr(args2); + loop: + if (lo >= hi) { + res = SEXP_VOID; + } else { + mid = lo + (hi-lo)/2; + swap(tmp, vec[mid], vec[hi]); + if (sexp_truep(key)) { + sexp_car(args1) = tmp; + b = sexp_apply(ctx, key, args1); + } else { + b = tmp; + } + for (i=j=lo; i < hi; i++) { + if (sexp_truep(key)) { + sexp_car(args1) = vec[i]; + a = sexp_apply(ctx, key, args1); + } else { + a = vec[i]; + } + sexp_car(args2) = a; + sexp_car(args1) = b; + res = sexp_apply(ctx, less, args2); + if (sexp_exceptionp(res)) + goto done; + else if (sexp_truep(res)) + swap(res, vec[i], vec[j]), j++; + } + swap(tmp, vec[j], vec[hi]); + if ((hi-lo) > 2) { + res = sexp_qsort_less(ctx, vec, lo, j-1, less, key); + if (sexp_exceptionp(res)) + goto done; + lo = j; + goto loop; /* tail recurse on right side */ + } + } + done: + sexp_gc_release3(ctx); + return res; +} + +static sexp sexp_sort_x (sexp ctx sexp_api_params(self, n), sexp seq, + sexp less, sexp key) { + sexp_sint_t len; + sexp res, *data; + sexp_gc_var1(vec); + + if (sexp_nullp(seq)) return seq; + + sexp_gc_preserve1(ctx, vec); + + vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq); + + if (! sexp_vectorp(vec)) { + res = sexp_type_exception(ctx, self, SEXP_VECTOR, vec); + } else { + data = sexp_vector_data(vec); + len = sexp_vector_length(vec); + if (sexp_not(key) && sexp_basic_comparator(less)) { + sexp_qsort(ctx, data, 0, len-1); + if (sexp_opcodep(less) && sexp_opcode_inverse(less)) + sexp_vector_nreverse(ctx, vec); + } else if (! (sexp_procedurep(less) || sexp_opcodep(less))) { + res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, less); + } else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) { + res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, key); + } else { + res = sexp_qsort_less(ctx, data, 0, len-1, less, key); + } + } + + if (sexp_pairp(seq)) + res = sexp_vector_copy_to_list(ctx, vec, seq); + else if (! sexp_exceptionp(res)) + res = vec; + + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign(ctx, env, "object-cmp", 2, sexp_object_compare_op); + sexp_define_foreign_opt(ctx, env, "sort!", 3, sexp_sort_x, SEXP_FALSE); + return SEXP_VOID; +} diff --git a/lib/srfi/95/sort.scm b/lib/srfi/95/sort.scm new file mode 100644 index 00000000..14e24517 --- /dev/null +++ b/lib/srfi/95/sort.scm @@ -0,0 +1,70 @@ +;; sort.scm -- SRFI-95 sorting utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (copy seq) + (if (vector? seq) + (let* ((len (vector-length seq)) + (res (make-vector len))) + (do ((i (- len 1) (- i 1))) + ((< i 0) res) + (vector-set! res i (vector-ref seq i)))) + (map (lambda (x) x) seq))) + +(define (sort seq . o) + (let ((less (and (pair? o) (car o))) + (key (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (sort! (copy seq) less key))) + +(define (sorted? seq less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (cond + ((vector? seq) + (let ((len (- (vector-length seq) 1))) + (let lp ((i 0)) + (cond + ((>= i len) #t) + ((less (key (vector-ref seq (+ i 1))) (key (vector-ref seq i))) #f) + (else (lp (+ i 1))))))) + ((null? seq) + #t) + (else + (let lp ((ls1 seq) (ls2 (cdr seq))) + (cond ((null? ls2) #t) + ((less (key (car ls2)) (key (car ls1))) #f) + (else (lp ls2 (cdr ls2))))))))) + +(define (merge! ls1 ls2 less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (define (lp prev ls1 ls2 a b less key) + (cond + ((less a b) + (if (null? (cdr ls1)) + (set-cdr! ls1 ls2) + (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key))) + (else + (set-cdr! prev ls2) + (if (null? (cdr ls2)) + (set-cdr! ls2 ls1) + (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key))))) + (cond + ((null? ls1) ls2) + ((null? ls2) ls1) + (else + (let ((a (key (car ls1))) + (b (key (car ls2)))) + (cond + ((less a b) + (if (null? (cdr ls1)) + (set-cdr! ls1 ls2) + (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key)) + ls1) + (else + (if (null? (cdr ls2)) + (set-cdr! ls2 ls1) + (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key)) + ls2))))))) + +(define (merge ls1 ls2 less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (merge! (copy ls1) (copy ls2) less key))) diff --git a/lib/srfi/98.module b/lib/srfi/98.module new file mode 100644 index 00000000..9d124d66 --- /dev/null +++ b/lib/srfi/98.module @@ -0,0 +1,5 @@ + +(define-module (srfi 98) + (export get-environment-variable get-environment-variables) + (include-shared "98/env")) + diff --git a/lib/srfi/98/env.c b/lib/srfi/98/env.c new file mode 100644 index 00000000..f8e519f3 --- /dev/null +++ b/lib/srfi/98/env.c @@ -0,0 +1,48 @@ +/* env.c -- SRFI-98 environment interface */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifdef __APPLE__ +#include +#define environ (*_NSGetEnviron()) +#else +extern char **environ; +#endif + +#include + +sexp sexp_get_environment_variable (sexp ctx sexp_api_params(self, n), sexp str) { + char *cstr; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, self, SEXP_STRING, str); + cstr = getenv(sexp_string_data(str)); + return cstr ? sexp_c_string(ctx, cstr, -1) : SEXP_FALSE; +} + +sexp sexp_get_environment_variables (sexp ctx sexp_api_params(self, n)) { + int i; + char **env, *cname, *cval; + sexp_gc_var3(res, name, val); + sexp_gc_preserve3(ctx, res, name, val); + res = SEXP_NULL; + env = environ; + for (i=0; env[i]; i++) { + cname = env[i]; + cval = strchr(cname, '='); + if (cval) { + name = sexp_c_string(ctx, cname, cval-cname); + val = sexp_c_string(ctx, cval+1, -1); + val = sexp_cons(ctx, name, val); + res = sexp_cons(ctx, val, res); + } + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign(ctx, env, "get-environment-variable", 1, sexp_get_environment_variable); + sexp_define_foreign(ctx, env, "get-environment-variables", 0, sexp_get_environment_variables); + return SEXP_VOID; +} + diff --git a/main.c b/main.c new file mode 100644 index 00000000..d07a9767 --- /dev/null +++ b/main.c @@ -0,0 +1,219 @@ +/* main.c -- chibi-scheme command-line app */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#define sexp_argv_symbol "*command-line-arguments*" +#define sexp_argv_proc "(define (command-line-arguments) "sexp_argv_symbol")" + +#define sexp_import_prefix "(import (" +#define sexp_import_suffix "))" + +#define sexp_version_string "chibi-scheme "sexp_version" \""sexp_release_name"\" " + +#ifdef PLAN9 +#define exit_failure() exits("ERROR") +#else +#define exit_failure() exit(70) +#endif + +static void repl (sexp ctx) { + sexp in, out, err; + sexp_gc_var4(obj, tmp, res, env); + sexp_gc_preserve4(ctx, obj, tmp, res, env); + env = sexp_make_env(ctx); + sexp_env_parent(env) = sexp_context_env(ctx); + sexp_env_define(ctx, sexp_context_env(ctx), + sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env); + sexp_context_tracep(ctx) = 1; + in = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), SEXP_FALSE); + out = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), SEXP_FALSE); + err = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), SEXP_FALSE); + sexp_port_sourcep(in) = 1; + while (1) { + sexp_write_string(ctx, "> ", out); + sexp_flush(ctx, out); + obj = sexp_read(ctx, in); + if (obj == SEXP_EOF) + break; + if (sexp_exceptionp(obj)) { + sexp_print_exception(ctx, obj, err); + } else { + tmp = sexp_env_bindings(env); + sexp_context_top(ctx) = 0; + res = sexp_eval(ctx, obj, env); + if (sexp_exceptionp(res)) { + sexp_print_exception(ctx, res, err); + sexp_stack_trace(ctx, err); + } else { +#if SEXP_USE_WARN_UNDEFS + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp); +#endif + if (res != SEXP_VOID) { + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); + } + } + } + } + sexp_gc_release4(ctx); +} + +static void check_nonull_arg (int c, char *arg) { + if (! arg) { + fprintf(stderr, "chibi-scheme: option '%c' requires an argument\n", c); + exit_failure(); + } +} + +static sexp check_exception (sexp ctx, sexp res) { + sexp err; + if (res && sexp_exceptionp(res)) { + err = sexp_current_error_port(ctx); + if (! sexp_oportp(err)) + err = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_print_exception(ctx, res, err); + sexp_stack_trace(ctx, err); + exit_failure(); + } + return res; +} + +#define init_context() if (! ctx) do { \ + ctx = sexp_make_eval_context(NULL, NULL, NULL, heap_size); \ + env = sexp_context_env(ctx); \ + sexp_gc_preserve2(ctx, tmp, args); \ + } while (0) + +#define load_init() if (! init_loaded++) do { \ + init_context(); \ + check_exception(ctx, sexp_load_standard_env(ctx, env, SEXP_FIVE)); \ + } while (0) + +void run_main (int argc, char **argv) { + char *arg, *impmod, *p; + sexp env, out=SEXP_FALSE, res=SEXP_VOID, ctx=NULL; + sexp_sint_t i, j, len, quit=0, print=0, init_loaded=0; + sexp_uint_t heap_size=0; + sexp_gc_var2(tmp, args); + args = SEXP_NULL; + + /* parse options */ + for (i=1; i < argc && argv[i][0] == '-'; i++) { + switch (argv[i][1]) { + case 'e': + case 'p': + load_init(); + print = (argv[i][1] == 'p'); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('e', arg); + res = check_exception(ctx, sexp_read_from_string(ctx, arg, -1)); + res = check_exception(ctx, sexp_eval(ctx, res, env)); + if (print) { + if (! sexp_oportp(out)) + out = sexp_eval_string(ctx, "(current-output-port)", -1, env); + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); + } + quit = 1; + break; + case 'l': + load_init(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('l', arg); + check_exception(ctx, sexp_load_module_file(ctx, arg, env)); + break; + case 'm': + load_init(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('m', arg); + len = strlen(arg)+strlen(sexp_import_prefix)+strlen(sexp_import_suffix); + impmod = (char*) malloc(len+1); + strcpy(impmod, sexp_import_prefix); + strcpy(impmod+strlen(sexp_import_prefix), arg); + strcpy(impmod+len-+strlen(sexp_import_suffix), sexp_import_suffix); + impmod[len] = '\0'; + for (p=impmod; *p; p++) + if (*p == '.') *p=' '; + check_exception(ctx, sexp_eval_string(ctx, impmod, -1, env)); + free(impmod); + break; + case 'q': + init_context(); + if (! init_loaded++) sexp_load_standard_parameters(ctx, env); + break; + case 'A': + init_context(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('A', arg); + sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_TRUE); + break; + case 'I': + init_context(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('I', arg); + sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_FALSE); + break; + case '-': + i++; + goto done_options; + case 'h': + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('h', arg); + heap_size = atol(arg); + len = strlen(arg); + if (heap_size && (isalpha)(arg[len-1])) { + switch ((tolower)(arg[len-1])) { + case 'k': heap_size *= 1024; break; + case 'm': heap_size *= (1024*1024); break; + } + } + break; + case 'V': + load_init(); + if (! sexp_oportp(out)) + out = sexp_eval_string(ctx, "(current-output-port)", -1, env); + sexp_write_string(ctx, sexp_version_string, out); + tmp = sexp_env_ref(env, sexp_intern(ctx, "*features*", -1), SEXP_NULL); + sexp_write(ctx, tmp, out); + sexp_newline(ctx, out); + return; + default: + fprintf(stderr, "unknown option: %s\n", argv[i]); + exit_failure(); + } + } + + done_options: + if (! quit) { + load_init(); + if (i < argc) + for (j=argc-1; j>i; j--) + args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args); + else + args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args); + sexp_env_define(ctx, env, sexp_intern(ctx, sexp_argv_symbol, -1), args); + sexp_eval_string(ctx, sexp_argv_proc, -1, env); + if (i < argc) { /* script usage */ + check_exception(ctx, sexp_load(ctx, tmp=sexp_c_string(ctx, argv[i], -1), env)); + tmp = sexp_intern(ctx, "main", -1); + tmp = sexp_env_ref(env, tmp, SEXP_FALSE); + if (sexp_procedurep(tmp)) { + args = sexp_list1(ctx, args); + check_exception(ctx, sexp_apply(ctx, tmp, args)); + } + } else { + repl(ctx); + } + } + + sexp_gc_release2(ctx); + sexp_destroy_context(ctx); +} + +int main (int argc, char **argv) { + sexp_scheme_init(); + run_main(argc, argv); + return 0; +} diff --git a/mkfile b/mkfile new file mode 100644 index 00000000..a193e9b6 --- /dev/null +++ b/mkfile @@ -0,0 +1,28 @@ + include/chibi/install.h + echo '#define sexp_platform "plan9"' >> include/chibi/install.h + echo '#define sexp_version "'`{cat VERSION}'"' >> include/chibi/install.h + echo '#define sexp_release_name "'`{cat RELEASE}'"' >> include/chibi/install.h + +install:V: $BIN/$TARG + test -d $MODDIR || mkdir -p $MODDIR + cp -r lib/* $MODDIR/ + +test:V: + ./$O.out tests/r5rs-tests.scm + +sexp.c:N: gc.c opt/bignum.c diff --git a/opcodes.c b/opcodes.c new file mode 100644 index 00000000..34505644 --- /dev/null +++ b/opcodes.c @@ -0,0 +1,178 @@ + +#define _I(n) sexp_make_fixnum(n) +#define _OP(c,o,n,m,rt,a1,a2,a3,i,s,d,f) {c, o, n, m, i, s, d, NULL, NULL, rt, a1, a2, a3, f} +#define _FN(o,n,m,rt,a1,a2,a3,s,d,f) _OP(SEXP_OPC_FOREIGN, o, n, m, rt, a1, a2, a3, 0, s, d, (sexp_proc1)f) +#define _FN0(rt, s, d, f) _FN(SEXP_OP_FCALL0, 0, 0, rt, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, s, d, f) +#define _FN1(rt, a1, s, d, f) _FN(SEXP_OP_FCALL1, 1, 0, rt, a1, SEXP_FALSE, SEXP_FALSE, s, d, f) +#define _FN1OPT(rt, a1, s, d, f) _FN(SEXP_OP_FCALL1, 0, 1, rt, a1, SEXP_FALSE, SEXP_FALSE, s, d, f) +#define _FN1OPTP(rt, a1, s, d, f) _FN(SEXP_OP_FCALL1, 0, 3, rt, a1, SEXP_FALSE, SEXP_FALSE, s, d, f) +#define _FN2(rt, a1, a2, s, d, f) _FN(SEXP_OP_FCALL2, 2, 0, rt, a1, a2, SEXP_FALSE, s, d, f) +#define _FN2OPT(rt, a1, a2, s, d, f) _FN(SEXP_OP_FCALL2, 1, 1, rt, a1, a2, SEXP_FALSE, s, d, f) +#define _FN2OPTP(rt, a1, a2, s, d, f) _FN(SEXP_OP_FCALL2, 1, 3, rt, a1, a2, SEXP_FALSE, s, d, f) +#define _FN3(rt, a1, a2, a3, s, d, f) _FN(SEXP_OP_FCALL3, 3, 0, rt, a1, a2, a3, s, d, f) +#define _FN4(rt, a1, a2, a3, s, d, f) _FN(SEXP_OP_FCALL4, 4, 0, rt, a1, a2, a3, s, d, f) +#define _PARAM(n, a, t) _OP(SEXP_OPC_PARAMETER, SEXP_OP_NOOP, 0, 3, t, t, SEXP_FALSE, SEXP_FALSE, 0, n, a, 0) + +static struct sexp_opcode_struct opcodes[] = { +_OP(SEXP_OPC_GETTER, SEXP_OP_CAR, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PAIR), SEXP_FALSE, SEXP_FALSE, 0, "car", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CAR, 2, 0, SEXP_VOID, _I(SEXP_PAIR), _I(SEXP_OBJECT), SEXP_FALSE, 0, "set-car!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_CDR, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PAIR), SEXP_FALSE, SEXP_FALSE, 0, "cdr", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CDR, 2, 0, SEXP_VOID, _I(SEXP_PAIR), _I(SEXP_OBJECT), SEXP_FALSE, 0, "set-cdr!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_REF, 2, 0, _I(SEXP_OBJECT), _I(SEXP_VECTOR), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"vector-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_VECTOR_SET, 3, 0, SEXP_VOID, _I(SEXP_VECTOR), _I(SEXP_FIXNUM), _I(SEXP_OBJECT), 0,"vector-set!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_VECTOR), SEXP_FALSE, SEXP_FALSE, 0,"vector-length", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_REF, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_BYTES), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"byte-vector-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_BYTES_SET, 3, 0, SEXP_VOID, _I(SEXP_BYTES), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), 0,"byte-vector-set!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_BYTES), SEXP_FALSE, SEXP_FALSE, 0,"byte-vector-length", 0, NULL), +#if SEXP_USE_UTF8_STRINGS +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF, 2, 0, _I(SEXP_CHAR), _I(SEXP_STRING), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"string-cursor-ref", 0, NULL), +#else +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF, 2, 0, _I(SEXP_CHAR), _I(SEXP_STRING), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"string-ref", 0, NULL), +#endif +#if SEXP_USE_MUTABLE_STRINGS +#if SEXP_USE_UTF8_STRINGS +_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET, 3, 0, SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), 0,"string-cursor-set!", 0, NULL), +#else +_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET, 3, 0, SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), 0,"string-set!", 0, NULL), +#endif +#endif +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_STRING), SEXP_FALSE, SEXP_FALSE, 0,"string-length", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_SLOTN_REF, 3, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0, "slot-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SLOTN_SET, 4, 0, SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0,"slot-set!", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, _I(SEXP_FLONUM), _I(SEXP_NUMBER), SEXP_FALSE, SEXP_FALSE, 0, "exact->inexact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_NUMBER), SEXP_FALSE, SEXP_FALSE, 0, "inexact->exact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char->integer", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_INT2CHAR, 1, 0, _I(SEXP_CHAR), _I(SEXP_FIXNUM), SEXP_FALSE, SEXP_FALSE, 0, "integer->char", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_UPCASE, 1, 0, _I(SEXP_CHAR), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char-upcase", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_DOWNCASE, 1, 0, _I(SEXP_CHAR), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char-downcase", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_ADD, 0, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "+", SEXP_ZERO, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_MUL, 0, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "*", SEXP_ONE, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_SUB, 1, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, "-", SEXP_ZERO, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_DIV, 1, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, "/", SEXP_ONE, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_QUOTIENT, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), SEXP_FALSE, 0, "quotient", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_REMAINDER, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), SEXP_FALSE, 0, "remainder", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "<", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "<=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, ">", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, ">=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_EQN, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "=", 0, NULL), +_OP(SEXP_OPC_PREDICATE, SEXP_OP_EQ, 2, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, 0, "eq?", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_CONS, 2, 0, _I(SEXP_PAIR), _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, 0, "cons", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_VECTOR, 1, 1, _I(SEXP_VECTOR), _I(SEXP_FIXNUM), _I(SEXP_OBJECT), SEXP_FALSE, 0, "make-vector", SEXP_VOID, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_PROCEDURE, 4, 0, _I(SEXP_PROCEDURE), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), _I(SEXP_BYTECODE), 0, "make-procedure", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_EXCEPTION, 5, 0, _I(SEXP_EXCEPTION), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), 0, "make-exception", 0, NULL), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_ISA, 2, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, 0, "is-a?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "null?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "eof-object?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "symbol?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_CHARP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "char?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_FIXNUMP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "fixnum?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "pair?", _I(SEXP_PAIR), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "string?", _I(SEXP_STRING), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "vector?", _I(SEXP_VECTOR), 0), +#if SEXP_USE_IMMEDIATE_FLONUMS +_FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "flonum?", 0, sexp_flonump_op), +#else +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "flonum?", _I(SEXP_FLONUM), 0), +#endif +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "bignum?", _I(SEXP_BIGNUM), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "closure?", _I(SEXP_PROCEDURE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "opcode?", _I(SEXP_OPCODE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "input-port?", _I(SEXP_IPORT), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "output-port?", _I(SEXP_OPORT), 0), +_OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_NULL, SEXP_FALSE, 0, "apply1", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_FALSE, SEXP_FALSE, 0, "%call/cc", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "raise", 0, NULL), +_OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, SEXP_VOID, _I(SEXP_CHAR), _I(SEXP_OPORT), SEXP_FALSE, 0, "write-char", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, SEXP_VOID, _I(SEXP_OPORT), SEXP_FALSE, SEXP_FALSE, 0, "newline", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "read-char", (sexp)"*current-input-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "peek-char", (sexp)"*current-input-port*", NULL), +_FN1OPTP(_I(SEXP_OBJECT), _I(SEXP_IPORT), "read", (sexp)"*current-input-port*", sexp_read_op), +_FN2OPTP(SEXP_VOID,_I(SEXP_OBJECT), _I(SEXP_OPORT), "write", (sexp)"*current-output-port*", sexp_write_op), +_FN2OPTP(SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OPORT), "display", (sexp)"*current-output-port*", sexp_display_op), +_FN1OPTP(SEXP_VOID, _I(SEXP_OPORT), "flush-output", (sexp)"*current-output-port*", sexp_flush_output_op), +_FN2(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), "equal?", 0, sexp_equalp_op), +_FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "list?", 0, sexp_listp_op), +_FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "identifier?", 0, sexp_identifierp_op), +_FN1(_I(SEXP_SYMBOL), _I(SEXP_OBJECT), "identifier->symbol", 0, sexp_syntactic_closure_expr_op), +_FN4(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_ENV), _I(SEXP_OBJECT), "identifier=?", 0, sexp_identifier_eq_op), +_FN1(_I(SEXP_FIXNUM), SEXP_NULL, "length", 0, sexp_length_op), +_FN1(SEXP_NULL, SEXP_NULL, "reverse", 0, sexp_reverse_op), +_FN1(SEXP_NULL, SEXP_NULL, "reverse!", 0, sexp_nreverse_op), +_FN2(SEXP_NULL, SEXP_NULL, SEXP_NULL, "append2", 0, sexp_append2_op), +_FN1(_I(SEXP_VECTOR), SEXP_NULL, "list->vector", 0, sexp_list_to_vector_op), +_FN1(_I(SEXP_IPORT), _I(SEXP_STRING), "open-input-file", 0, sexp_open_input_file_op), +_FN1(_I(SEXP_OPORT), _I(SEXP_STRING), "open-output-file", 0, sexp_open_output_file_op), +_FN1(SEXP_VOID, _I(SEXP_IPORT), "close-input-port", 0, sexp_close_port_op), +_FN1(SEXP_VOID, _I(SEXP_OPORT), "close-output-port", 0, sexp_close_port_op), +_FN0(_I(SEXP_ENV), "make-environment", 0, sexp_make_env_op), +_FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "null-environment", 0, sexp_make_null_env_op), +_FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "scheme-report-environment", 0, sexp_make_standard_env_op), +_FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_ENV), "eval", (sexp)"*interaction-environment*", sexp_eval_op), +_FN2OPTP(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_ENV), "load", (sexp)"*interaction-environment*", sexp_load_op), +_FN4(SEXP_VOID, _I(SEXP_ENV), _I(SEXP_ENV), _I(SEXP_OBJECT), "%env-copy!", 0, sexp_env_copy_op), +_FN2(SEXP_VOID, _I(SEXP_EXCEPTION), _I(SEXP_OPORT), "print-exception", 0, sexp_print_exception_op), +_FN1(_I(SEXP_OBJECT), _I(SEXP_EXCEPTION), "exception-type", 0, sexp_exception_type_op), +_FN2OPT(_I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), "make-string", sexp_make_character(' '), sexp_make_string_op), +_FN2OPT(_I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-byte-vector", SEXP_ZERO, sexp_make_bytes_op), +_FN2OPT(_I(SEXP_NUMBER), _I(SEXP_STRING), _I(SEXP_FIXNUM), "string->number", SEXP_TEN, sexp_string_to_number_op), +_FN3(_I(SEXP_FIXNUM), _I(SEXP_STRING), _I(SEXP_STRING), _I(SEXP_BOOLEAN), "string-cmp", 0, sexp_string_cmp_op), +_FN3(_I(SEXP_STRING), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "substring", 0, sexp_substring_op), +_FN1(_I(SEXP_SYMBOL), _I(SEXP_STRING), "string->symbol", 0, sexp_string_to_symbol_op), +_FN2OPT(_I(SEXP_STRING), SEXP_NULL, _I(SEXP_STRING), "string-concatenate", SEXP_FALSE, sexp_string_concatenate_op), +_FN2(_I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_NULL, "memq", 0, sexp_memq_op), +_FN2(_I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_NULL, "assq", 0, sexp_assq_op), +_FN3(_I(SEXP_SYNCLO), _I(SEXP_ENV), SEXP_NULL, _I(SEXP_OBJECT), "make-syntactic-closure", 0, sexp_make_synclo_op), +_FN1(_I(SEXP_OBJECT), _I(SEXP_OBJECT), "strip-syntactic-closures", 0, sexp_strip_synclos), +_PARAM("current-input-port", (sexp)"*current-input-port*", _I(SEXP_IPORT)), +_PARAM("current-output-port", (sexp)"*current-output-port*", _I(SEXP_OPORT)), +_PARAM("current-error-port", (sexp)"*current-error-port*", _I(SEXP_OPORT)), +_PARAM("current-exception-handler", (sexp)"*current-exception-handler*", _I(SEXP_PROCEDURE)), +_PARAM("interaction-environment", (sexp)"*interaction-environment*", _I(SEXP_ENV)), +_FN0(_I(SEXP_OPORT), "open-output-string", 0, sexp_make_output_string_port_op), +_FN1(_I(SEXP_IPORT), _I(SEXP_STRING), "open-input-string", 0, sexp_make_input_string_port_op), +_FN1(_I(SEXP_STRING), _I(SEXP_OPORT), "get-output-string", 0, sexp_get_output_string_op), +#if SEXP_USE_MATH +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "exp", 0, sexp_exp), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "log", 0, sexp_log), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "sin", 0, sexp_sin), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "cos", 0, sexp_cos), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "tan", 0, sexp_tan), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "asin", 0, sexp_asin), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "acos", 0, sexp_acos), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "atan1", 0, sexp_atan), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "sqrt", 0, sexp_sqrt), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "round", 0, sexp_round), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "truncate", 0, sexp_trunc), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "floor", 0, sexp_floor), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "ceiling", 0, sexp_ceiling), +#endif +_FN2(_I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), "expt", 0, sexp_expt_op), +#if SEXP_USE_UTF8_STRINGS +_FN2(_I(SEXP_FIXNUM), _I(SEXP_STRING), _I(SEXP_FIXNUM), "string-index->offset", 0, sexp_string_index_to_offset), +_FN2(_I(SEXP_CHAR), _I(SEXP_STRING), _I(SEXP_FIXNUM), "string-ref", 0, sexp_string_utf8_index_ref), +_FN3(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), "string-set!", 0, sexp_string_utf8_index_set), +#endif +#if SEXP_USE_TYPE_DEFS +_FN2(_I(SEXP_TYPE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "register-simple-type", 0, sexp_register_simple_type_op), +_FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-type-predicate", 0, sexp_make_type_predicate_op), +_FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-constructor", 0, sexp_make_constructor_op), +_FN3(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-getter", 0, sexp_make_getter_op), +_FN3(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-setter", 0, sexp_make_setter_op), +#endif +#if PLAN9 +#include "opt/plan9-opcodes.c" +#endif +#if SEXP_USE_MODULES +_FN0(_I(SEXP_ENV), "current-environment", 0, sexp_current_environment), +_FN1(SEXP_NULL, _I(SEXP_ENV), "env-exports", 0, sexp_env_exports_op), +_FN1(_I(SEXP_STRING), _I(SEXP_STRING), "find-module-file", 0, sexp_find_module_file_op), +_FN2(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_ENV), "load-module-file", 0, sexp_load_module_file_op), +_FN2(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_BOOLEAN), "add-module-directory", 0, sexp_add_module_directory_op), +#endif +#if SEXP_USE_GREEN_THREADS +_OP(SEXP_OPC_GENERIC, SEXP_OP_YIELD, 0, 0, SEXP_VOID, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, 0, "thread-yield!", 0, NULL), +#endif +}; + + diff --git a/opt/bignum.c b/opt/bignum.c new file mode 100644 index 00000000..767d8898 --- /dev/null +++ b/opt/bignum.c @@ -0,0 +1,775 @@ +/* bignum.c -- bignum support */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define SEXP_INIT_BIGNUM_SIZE 2 + +#define sexp_negate(x) \ + if (sexp_bignump(x)) \ + sexp_bignum_sign(x) = -sexp_bignum_sign(x); \ + else if (sexp_fixnump(x)) \ + x = sexp_fx_neg(x); + +sexp sexp_make_bignum (sexp ctx, sexp_uint_t len) { + sexp_uint_t size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); + sexp res = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM); + sexp_bignum_length(res) = len; + sexp_bignum_sign(res) = 1; + return res; +} + +sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) { + sexp res = sexp_make_bignum(ctx, 1); + sexp_bignum_data(res)[0] = sexp_unbox_fixnum(sexp_fx_abs(a)); + sexp_bignum_sign(res) = sexp_fx_sign(a); + return res; +} + +sexp sexp_make_integer (sexp ctx, sexp_lsint_t x) { + sexp res; + if ((SEXP_MIN_FIXNUM <= x) && (x <= SEXP_MAX_FIXNUM)) { + res = sexp_make_fixnum(x); + } else { + res = sexp_make_bignum(ctx, 1); + if (x < 0) { + sexp_bignum_sign(res) = -1; + sexp_bignum_data(res)[0] = -x; + } else { + sexp_bignum_sign(res) = 1; + sexp_bignum_data(res)[0] = x; + } + } + return res; +} + +sexp sexp_make_unsigned_integer (sexp ctx, sexp_luint_t x) { + sexp res; + if (x <= SEXP_MAX_FIXNUM) { + res = sexp_make_fixnum(x); + } else { + res = sexp_make_bignum(ctx, 1); + sexp_bignum_sign(res) = 1; + sexp_bignum_data(res)[0] = x; + } + return res; +} + +#define double_trunc_10s_digit(f) (trunc((f)/10.0)*10.0) +#define double_10s_digit(f) ((f)-double_trunc_10s_digit(f)) + +sexp sexp_double_to_bignum (sexp ctx, double f) { + int sign; + sexp_gc_var3(res, scale, tmp); + sexp_gc_preserve3(ctx, res, scale, tmp); + res = sexp_fixnum_to_bignum(ctx, SEXP_ZERO); + scale = sexp_fixnum_to_bignum(ctx, SEXP_ONE); + sign = (f < 0 ? -1 : 1); + for (f=fabs(f); f >= 1.0; f=trunc(f/10)) { + tmp = sexp_bignum_fxmul(ctx, NULL, scale, double_10s_digit(f), 0); + res = sexp_bignum_add(ctx, res, res, tmp); + scale = sexp_bignum_fxmul(ctx, NULL, scale, 10, 0); + } + sexp_bignum_sign(res) = sign; + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len0) { + sexp_uint_t len = (len0 > 0) ? len0 : sexp_bignum_length(a), size; + size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); + if (! dst || sexp_bignum_length(dst) < len) { + dst = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM); + memmove(dst, a, size); + sexp_bignum_length(dst) = len; + } else { + memset(dst->value.bignum.data, 0, + sexp_bignum_length(dst)*sizeof(sexp_uint_t)); + memmove(dst->value.bignum.data, a->value.bignum.data, + sexp_bignum_length(a)*sizeof(sexp_uint_t)); + } + return dst; +} + +int sexp_bignum_zerop (sexp a) { + int i; + sexp_uint_t *data = sexp_bignum_data(a); + for (i=sexp_bignum_length(a)-1; i>=0; i--) + if (data[i]) + return 0; + return 1; +} + +sexp_uint_t sexp_bignum_hi (sexp a) { + sexp_uint_t i=sexp_bignum_length(a)-1; + while ((i>0) && ! sexp_bignum_data(a)[i]) + i--; + return i+1; +} + +sexp_sint_t sexp_bignum_compare_abs (sexp a, sexp b) { + int ai=sexp_bignum_hi(a), bi=sexp_bignum_hi(b); + sexp_uint_t *adata=sexp_bignum_data(a), *bdata=sexp_bignum_data(b); + if (ai != bi) + return ai - bi; + for (--ai; ai >= 0; ai--) { + if (adata[ai] > bdata[ai]) + return 1; + else if (adata[ai] < bdata[ai]) + return -1; + } + return 0; +} + +sexp_sint_t sexp_bignum_compare (sexp a, sexp b) { + if (sexp_bignum_sign(a) != sexp_bignum_sign(b)) + return sexp_bignum_sign(a); + return sexp_bignum_compare_abs(a, b); +} + +sexp sexp_bignum_normalize (sexp a) { + sexp_uint_t *data; + if ((! sexp_bignump(a)) || (sexp_bignum_hi(a)>1)) + return a; + data = sexp_bignum_data(a); + if ((data[0] > SEXP_MAX_FIXNUM) + && ! ((sexp_bignum_sign(a) == -1) && (data[0] == SEXP_MAX_FIXNUM+1))) + return a; + return sexp_make_fixnum((sexp_sint_t)data[0] * sexp_bignum_sign(a)); +} + +double sexp_bignum_to_double (sexp a) { + double res = 0; + sexp_sint_t i; + sexp_uint_t *data=sexp_bignum_data(a); + for (i=sexp_bignum_hi(a)-1; i>=0; i--) + res = res * ((double)SEXP_UINT_T_MAX+1) + data[i]; + return res * sexp_bignum_sign(a); +} + +sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b) { + sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), + carry=b, i=0, n; + do { n = data[i]; + data[i] += carry; + carry = (n > (SEXP_UINT_T_MAX - carry)); + } while (++i> (sizeof(sexp_uint_t)*8); + } + if (carry) { + if (sexp_bignum_length(d)+offset <= len) + d = sexp_copy_bignum(ctx, NULL, d, len+offset+1); + sexp_bignum_data(d)[len+offset] = carry; + } + sexp_gc_release1(ctx); + return d; +} + +sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) { + sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, r=0; + int i; + sexp_luint_t n = 0; + for (i=len-1; i>=offset; i--) { + n = (n << sizeof(sexp_uint_t)*8) + data[i]; + q = n / b; + r = n - (sexp_luint_t)q * b; + data[i] = q; + n = r; + } + return r; +} + +sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init, + char sign, sexp_uint_t base) { + int c, digit; + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_make_bignum(ctx, SEXP_INIT_BIGNUM_SIZE); + sexp_bignum_sign(res) = sign; + sexp_bignum_data(res)[0] = init; + for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in)) { + digit = digit_value(c); + if ((digit < 0) || (digit >= base)) + break; + res = sexp_bignum_fxmul(ctx, res, res, base, 0); + res = sexp_bignum_fxadd(ctx, res, digit); + } + if (c=='.' || c=='e' || c=='E') { + if (base != 10) { + res = sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in); + } else { + if (c!='.') sexp_push_char(ctx, c, in); /* push the e back */ + res = sexp_read_float_tail(ctx, in, sexp_bignum_to_double(res), (sign==-1)); + } + } else if ((c!=EOF) && ! is_separator(c)) { + res = sexp_read_error(ctx, "invalid numeric syntax", + sexp_make_character(c), in); + } else { + sexp_push_char(ctx, c, in); + } + sexp_gc_release1(ctx); + return sexp_bignum_normalize(res); +} + +static int log2i(int v) { + int i; + for (i = 0; i < sizeof(v)*8; i++) + if ((1<<(i+1)) > v) + break; + return i; +} + +sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) { + int i, str_len, lg_base = log2i(base); + char *data; + sexp_gc_var2(b, str); + sexp_gc_preserve2(ctx, b, str); + b = sexp_copy_bignum(ctx, NULL, a, 0); + sexp_bignum_sign(b) = 1; + i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1) + / lg_base + 1; + str = sexp_make_string(ctx, sexp_make_fixnum(str_len), + sexp_make_character(' ')); + data = sexp_string_data(str); + while (! sexp_bignum_zerop(b)) + data[--i] = hex_digit(sexp_bignum_fxdiv(ctx, b, base, 0)); + if (i == str_len) + data[--i] = '0'; + else if (sexp_bignum_sign(a) == -1) + data[--i] = '-'; + sexp_write_string(ctx, data + i, out); + sexp_gc_release2(ctx); + return SEXP_VOID; +} + +/****************** bignum arithmetic *************************/ + +sexp sexp_bignum_add_fixnum (sexp ctx, sexp a, sexp b) { + sexp_gc_var1(c); + sexp_gc_preserve1(ctx, c); + c = sexp_copy_bignum(ctx, NULL, a, 0); + if (sexp_bignum_sign(c) == sexp_fx_sign(b)) + c = sexp_bignum_fxadd(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b))); + else + c = sexp_bignum_fxsub(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b))); + sexp_gc_release1(ctx); + return c; +} + +sexp sexp_bignum_sub_digits (sexp ctx, sexp dst, sexp a, sexp b) { + sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), + borrow=0, i, *adata, *bdata, *cdata; + sexp_gc_var1(c); + if ((alen < blen) || ((alen == blen) && (sexp_bignum_compare_abs(a, b) < 0))) + return sexp_bignum_sub_digits(ctx, dst, b, a); + sexp_gc_preserve1(ctx, c); + c = ((dst && sexp_bignum_hi(dst) >= alen) + ? dst : sexp_copy_bignum(ctx, NULL, a, 0)); + adata = sexp_bignum_data(a); + bdata = sexp_bignum_data(b); + cdata = sexp_bignum_data(c); + for (i=0; i= alen) + ? dst : sexp_copy_bignum(ctx, NULL, a, 0)); + adata = sexp_bignum_data(a); + bdata = sexp_bignum_data(b); + cdata = sexp_bignum_data(c); + for (i=0; i (SEXP_UINT_T_MAX - bdata[i]) ? 1 : 0); + } + for ( ; carry && (i= 0 ? a : b); + } + return res; +} + +sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b) { + sexp res; + if (sexp_bignum_sign(a) == sexp_bignum_sign(b)) { + res = sexp_bignum_sub_digits(ctx, dst, a, b); + sexp_bignum_sign(res) + = (sexp_bignum_compare_abs(a, b) >= 0 ? sexp_bignum_sign(a) + : -sexp_bignum_sign(a)); + } else { + res = sexp_bignum_add_digits(ctx, dst, a, b); + sexp_bignum_sign(res) = sexp_bignum_sign(a); + } + return res; +} + +sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b) { + sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), i, + *bdata=sexp_bignum_data(b); + sexp_gc_var2(c, d); + if (alen < blen) return sexp_bignum_mul(ctx, dst, b, a); + sexp_gc_preserve2(ctx, c, d); + c = (dst ? dst : sexp_make_bignum(ctx, alen+blen+1)); + d = sexp_make_bignum(ctx, alen+blen+1); + for (i=0; i 0) { + *rem = a; + return sexp_fixnum_to_bignum(ctx, SEXP_ZERO); + } + sexp_gc_preserve5(ctx, x, prod, diff, k2, i2); + k2 = sexp_bignum_double(ctx, k); + i2 = sexp_bignum_double(ctx, i); + x = quot_step(ctx, rem, a, b, k2, i2); + prod = sexp_bignum_mul(ctx, NULL, x, b); + diff = sexp_bignum_sub_digits(ctx, NULL, a, prod); + if (sexp_bignum_compare(diff, k) >= 0) { + *rem = sexp_bignum_sub_digits(ctx, NULL, diff, k); + res = sexp_bignum_add_digits(ctx, NULL, x, i); + } else { + *rem = diff; + res = x; + } + sexp_gc_release5(ctx); + return res; +} + +sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) { + sexp res; + sexp_gc_var4(k, i, a1, b1); + sexp_gc_preserve4(ctx, k, i, a1, b1); + a1 = sexp_copy_bignum(ctx, NULL, a, 0); + sexp_bignum_sign(a1) = 1; + b1 = sexp_copy_bignum(ctx, NULL, b, 0); + sexp_bignum_sign(b1) = 1; + k = sexp_copy_bignum(ctx, NULL, b1, 0); + i = sexp_fixnum_to_bignum(ctx, SEXP_ONE); + res = quot_step(ctx, rem, a1, b1, k, i); + sexp_bignum_sign(res) = sexp_bignum_sign(a) * sexp_bignum_sign(b); + if (sexp_bignum_sign(a) < 0) { + sexp_negate(*rem); + } + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_bignum_quotient (sexp ctx, sexp a, sexp b) { + sexp res; + sexp_gc_var1(rem); + sexp_gc_preserve1(ctx, rem); + res = sexp_bignum_quot_rem(ctx, &rem, a, b); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_bignum_remainder (sexp ctx, sexp a, sexp b) { + sexp_gc_var1(rem); + sexp_gc_preserve1(ctx, rem); + sexp_bignum_quot_rem(ctx, &rem, a, b); /* discard quotient */ + sexp_gc_release1(ctx); + return rem; +} + +sexp sexp_bignum_expt (sexp ctx, sexp a, sexp b) { + sexp_sint_t e = sexp_unbox_fixnum(sexp_fx_abs(b)); + sexp_gc_var2(res, acc); + sexp_gc_preserve2(ctx, res, acc); + res = sexp_fixnum_to_bignum(ctx, SEXP_ONE); + acc = sexp_copy_bignum(ctx, NULL, a, 0); + for (; e; e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc)) + if (e & 1) + res = sexp_bignum_mul(ctx, NULL, res, acc); + sexp_gc_release2(ctx); + return res; +} + +/****************** generic arithmetic ************************/ + +enum sexp_number_types { + SEXP_NUM_NOT = 0, + SEXP_NUM_FIX, + SEXP_NUM_FLO, + SEXP_NUM_BIG +}; + +enum sexp_number_combs { + SEXP_NUM_NOT_NOT = 0, + SEXP_NUM_NOT_FIX, + SEXP_NUM_NOT_FLO, + SEXP_NUM_NOT_BIG, + SEXP_NUM_FIX_NOT, + SEXP_NUM_FIX_FIX, + SEXP_NUM_FIX_FLO, + SEXP_NUM_FIX_BIG, + SEXP_NUM_FLO_NOT, + SEXP_NUM_FLO_FIX, + SEXP_NUM_FLO_FLO, + SEXP_NUM_FLO_BIG, + SEXP_NUM_BIG_NOT, + SEXP_NUM_BIG_FIX, + SEXP_NUM_BIG_FLO, + SEXP_NUM_BIG_BIG +}; + +static int sexp_number_types[] = + {0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0}; + +static int sexp_number_type (sexp a) { + return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)&15] +#if SEXP_USE_IMMEDIATE_FLONUMS + : sexp_flonump(a) ? 2 +#endif + : sexp_fixnump(a); +} + +sexp sexp_add (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b), t; + sexp r=SEXP_VOID; + if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_add(a, b); /* VM catches this case */ + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)+sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_normalize(sexp_bignum_add_fixnum(ctx, b, a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_add(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_add(ctx, NULL, b, a)); + break; + } + return r; +} + +sexp sexp_sub (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_sub(a, b); /* VM catches this case */ + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)-sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + tmp = sexp_fixnum_to_bignum(ctx, a); + r = sexp_bignum_sub(ctx, NULL, b, tmp); + sexp_negate(r); + r = sexp_bignum_normalize(r); + break; + case SEXP_NUM_FLO_FIX: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(b)+sexp_flonum_value(a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_sub(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) - sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_FIX: + tmp = sexp_fixnum_to_bignum(ctx, b); + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, tmp)); + break; + case SEXP_NUM_BIG_FLO: + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) - sexp_flonum_value(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, b)); + break; + } + sexp_gc_release1(ctx); + return r; +} + +sexp sexp_mul (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b), t; + sexp r=SEXP_VOID; + if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_mul(a, b); + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)*sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_fxmul(ctx, NULL, b, sexp_unbox_fixnum(sexp_fx_abs(a)), 0); + sexp_bignum_sign(r) = sexp_fx_sign(a) * sexp_bignum_sign(b); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_mul(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) * sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_mul(ctx, NULL, a, b); + break; + } + return r; +} + +sexp sexp_div (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + double f; + sexp r=SEXP_VOID; + sexp_gc_var2(tmp, rem); + sexp_gc_preserve2(ctx, tmp, rem); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, b); + break; + case SEXP_NUM_FIX_FIX: + f = sexp_fixnum_to_double(a) / sexp_fixnum_to_double(b); + r = ((f == trunc(f)) ? sexp_make_fixnum((sexp_sint_t)f) + : sexp_make_flonum(ctx, f)); + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_bignum_to_double(b)); + break; + case SEXP_NUM_FLO_FIX: + r = sexp_make_flonum(ctx, sexp_flonum_value(a)/sexp_fixnum_to_double(b)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_div(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) / sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_FIX: + b = tmp = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_quot_rem(ctx, &rem, a, b); + if (sexp_bignum_normalize(rem) != SEXP_ZERO) + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) + / sexp_bignum_to_double(b)); + else + r = sexp_bignum_normalize(r); + break; + case SEXP_NUM_BIG_FLO: + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) / sexp_flonum_value(b)); + break; + } + sexp_gc_release2(ctx); + return r; +} + +sexp sexp_quotient (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_div(a, b); + break; + case SEXP_NUM_FIX_BIG: + r = SEXP_ZERO; + break; + case SEXP_NUM_BIG_FIX: + b = tmp = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_quotient(ctx, a, b)); + break; + } + sexp_gc_release1(ctx); + return r; +} + +sexp sexp_remainder (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_rem(a, b); + break; + case SEXP_NUM_FIX_BIG: + r = a; + break; + case SEXP_NUM_BIG_FIX: + b = tmp = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_remainder(ctx, a, b)); + break; + } + sexp_gc_release1(ctx); + return r; +} + +sexp sexp_compare (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + double f; + if (at > bt) { + r = sexp_compare(ctx, b, a); + sexp_negate(r); + } else { + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_make_fixnum(sexp_unbox_fixnum(a) - sexp_unbox_fixnum(b)); + break; + case SEXP_NUM_FIX_FLO: + f = sexp_fixnum_to_double(a) - sexp_flonum_value(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_fixnum(-1); + break; + case SEXP_NUM_FLO_FLO: + f = sexp_flonum_value(a) - sexp_flonum_value(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_FLO_BIG: + f = sexp_flonum_value(a) - sexp_bignum_to_double(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_make_fixnum(sexp_bignum_compare(a, b)); + break; + } + } + return r; +} + diff --git a/opt/fcall.c b/opt/fcall.c new file mode 100644 index 00000000..c38cc3fe --- /dev/null +++ b/opt/fcall.c @@ -0,0 +1,33 @@ + +typedef sexp (*sexp_proc8) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc9) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc10) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc11) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc12) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc13) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc14) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc15) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc16) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc17) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); + +#define _A(i) stack[top-i] + +sexp sexp_fcall (sexp ctx, sexp self, sexp_sint_t n, sexp f) { + sexp *stack = sexp_stack_data(sexp_context_stack(ctx)); + sexp_sint_t top = sexp_context_top(ctx); + switch (n) { + case 5: return ((sexp_proc6)sexp_opcode_func(f))(ctx, f, 5, _A(1), _A(2), _A(3), _A(4), _A(5)); + case 6: return ((sexp_proc7)sexp_opcode_func(f))(ctx, f, 6, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6)); + case 7: return ((sexp_proc8)sexp_opcode_func(f))(ctx, f, 7, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7)); + case 8: return ((sexp_proc9)sexp_opcode_func(f))(ctx, f, 8, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8)); + case 9: return ((sexp_proc10)sexp_opcode_func(f))(ctx, f, 9, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9)); + case 10: return ((sexp_proc11)sexp_opcode_func(f))(ctx, f, 10, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10)); + case 11: return ((sexp_proc12)sexp_opcode_func(f))(ctx, f, 11, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11)); + case 12: return ((sexp_proc13)sexp_opcode_func(f))(ctx, f, 12, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12)); + case 13: return ((sexp_proc14)sexp_opcode_func(f))(ctx, f, 13, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13)); + case 14: return ((sexp_proc15)sexp_opcode_func(f))(ctx, f, 14, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14)); + case 15: return ((sexp_proc16)sexp_opcode_func(f))(ctx, f, 15, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15)); + case 16: return ((sexp_proc17)sexp_opcode_func(f))(ctx, f, 16, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15), _A(16)); + default: return sexp_user_exception(ctx, self, "too many FFI arguments", f); + } +} diff --git a/opt/opcode_names.h b/opt/opcode_names.h new file mode 100644 index 00000000..a87aeb1c --- /dev/null +++ b/opt/opcode_names.h @@ -0,0 +1,21 @@ + +static const char* reverse_opcode_names[] = + {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", + "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALLN", + "JUMP-UNLESS", "JUMP", "PUSH", "DROP", + "GLOBAL-REF", "GLOBAL-KNOWN-REF", "STACK-REF", + "LOCAL-REF", "LOCAL-SET", "CLOSURE-REF", + "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", + "BYTES-REF", "BYTES-SET", "BYTES-LENGTH", + "STRING-REF", "STRING-SET", "STRING-LENGTH", + "MAKE-PROCEDURE", "MAKE-VECTOR", + "MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", + "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", + "ISA?", "SLOTN-REF", "SLOTN-SET", + "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", + "ADD", "SUB", "MUL", "DIV", "QUOTIENT", "REMAINDER", + "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT", + "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", + "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", + "YIELD", "RET", "DONE", + }; diff --git a/opt/plan9-opcodes.c b/opt/plan9-opcodes.c new file mode 100644 index 00000000..9f7cac33 --- /dev/null +++ b/opt/plan9-opcodes.c @@ -0,0 +1,19 @@ +_FN0("random-integer", 0, sexp_rand), +_FN1(SEXP_FIXNUM, "random-seed", 0, sexp_srand), +_FN0("current-directory", 0, sexp_getwd), +_FN0("current-user", 0, sexp_getuser), +_FN0("system-name", 0, sexp_sysname), +_FN1(SEXP_IPORT, "port-fileno", 0, sexp_fileno), +_FN2(SEXP_FIXNUM, SEXP_STRING, "fileno->port", 0, sexp_fdopen), +_FN0("fork", 0, sexp_fork), +_FN2(SEXP_STRING, SEXP_PAIR, "exec", 0, sexp_exec), +_FN1(SEXP_STRING, "exits", 0, sexp_exits), +_FN2(SEXP_FIXNUM, SEXP_FIXNUM, "dup", 0, sexp_dup), +_FN0("pipe", 0, sexp_pipe), +_FN1(SEXP_FIXNUM, "sleep", 0, sexp_sleep), +_FN1(SEXP_STRING, "getenv", 0, sexp_getenv), +_FN1(SEXP_STRING, "change-directory", 0, sexp_chdir), +_FN0("wait", 0, sexp_wait), +_FN2(SEXP_FIXNUM, SEXP_STRING, "post-note", 0, sexp_postnote), +_FN4(SEXP_PAIR, SEXP_STRING, "%postmountsrv", 0, sexp_postmountsrv), +_FN1(SEXP_STRING, "file-exists?", 0, sexp_file_exists_p), diff --git a/opt/plan9.c b/opt/plan9.c new file mode 100644 index 00000000..ca25afba --- /dev/null +++ b/opt/plan9.c @@ -0,0 +1,351 @@ +/* plan9.c -- extended Plan 9 system utils */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +sexp sexp_rand (sexp ctx sexp_api_params(self, n)) { + return sexp_make_fixnum(rand()); +} + +sexp sexp_srand (sexp ctx sexp_api_params(self, n), sexp seed) { + srand(sexp_unbox_fixnum(seed)); + return SEXP_VOID; +} + +sexp sexp_file_exists_p (sexp ctx sexp_api_params(self, n), sexp path) { + int res; + uchar statbuf[STATMAX]; + if (! sexp_stringp(path)) + return sexp_type_exception(ctx, "file-exists?: not a string", path); + res = stat(sexp_string_data(path), statbuf, sizeof(statbuf)); + return (res < 0) ? SEXP_FALSE : SEXP_TRUE; +} + +sexp sexp_fdopen (sexp ctx sexp_api_params(self, n), sexp fd, sexp mode) { + FILE *f; + if (! sexp_integerp(fd)) + return sexp_type_exception(ctx, "fdopen: not an integer", fd); + if (! sexp_stringp(mode)) + return sexp_type_exception(ctx, "fdopen: not a mode string", mode); + f = fdopen(sexp_unbox_fixnum(fd), sexp_string_data(mode)); + if (! f) + return sexp_user_exception(ctx, SEXP_FALSE, "fdopen failed", fd); + /* maybe use fd2path to get the name of the fd */ + if (sexp_string_data(mode)[0] == 'w') + return sexp_make_output_port(ctx, f, SEXP_FALSE); + else + return sexp_make_input_port(ctx, f, SEXP_FALSE); +} + +sexp sexp_fileno (sexp ctx sexp_api_params(self, n), sexp port) { + if (! sexp_portp(port)) + return sexp_type_exception(ctx, "fileno: not a port", port); + return sexp_make_fixnum(fileno(sexp_port_stream(port))); +} + +sexp sexp_fork (sexp ctx sexp_api_params(self, n)) { + return sexp_make_fixnum(fork()); +} + +sexp sexp_exec (sexp ctx sexp_api_params(self, n), sexp name, sexp args) { + int i, len = sexp_unbox_fixnum(sexp_length(ctx, args)); + char **argv = malloc((len+1)*sizeof(char*)); + for (i=0; imsg, -1); + res = sexp_list2(ctx, sexp_make_fixnum(wmsg->pid), msg); + sexp_gc_release(ctx, msg, s_msg); + return res; +} + +sexp sexp_postnote (sexp ctx sexp_api_params(self, n), sexp pid, sexp note) { + if (! sexp_integerp(pid)) + return sexp_type_exception(ctx, "postnote: not an integer", pid); + if (! sexp_stringp(note)) + return sexp_type_exception(ctx, "postnote: not a string", note); + postnote(PNPROC, sexp_unbox_fixnum(pid), sexp_string_data(note)); + return SEXP_VOID; +} + +/**********************************************************************/ +/* 9p interface */ + +typedef struct sexp_plan9_srv { + sexp context, auth, attach, walk, walk1, clone, open, create, remove, + read, write, stat, wstat, flush, destroyfid, destroyreq, end; +} *sexp_plan9_srv; + +void sexp_build_srv (sexp ctx, sexp_plan9_srv s, sexp ls) { + s->context = ctx; + s->auth = s->attach = s->walk = s->walk1 = s->clone = s->open + = s->create = s->remove = s->read = s->write = s->stat = s->wstat + = s->flush = s->destroyfid = s->destroyreq = s->end = SEXP_FALSE; + for ( ; sexp_pairp(ls) && sexp_pairp(sexp_cdr(ls)); ls=sexp_cddr(ls)) { + if (sexp_car(ls) == sexp_intern(ctx, "auth:", -1)) { + s->auth = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "attach:", -1)) { + s->attach = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "walk:", -1)) { + s->walk = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "walk1:", -1)) { + s->walk1 = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "clone:", -1)) { + s->clone = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "open:", -1)) { + s->open = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "create:", -1)) { + s->create = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "remove:", -1)) { + s->remove = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "read:", -1)) { + s->read = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "write:", -1)) { + s->write = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "stat:", -1)) { + s->stat = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "wstat:", -1)) { + s->wstat = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "flush:", -1)) { + s->flush = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyfid:", -1)) { + s->destroyfid = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyreq:", -1)) { + s->destroyreq = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "end:", -1)) { + s->end = sexp_cadr(ls); + } + } +} + +void sexp_run_9p_handler (Req *r, sexp handler) { + sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, handler, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +#define sexp_def_9p_handler(name, field) \ + void name (Req *r) { \ + sexp_run_9p_handler(r, ((sexp_plan9_srv)r->srv->aux)->field); \ + } + +sexp_def_9p_handler(sexp_9p_auth, auth) +sexp_def_9p_handler(sexp_9p_attach, attach) +sexp_def_9p_handler(sexp_9p_walk, walk) +sexp_def_9p_handler(sexp_9p_open, open) +sexp_def_9p_handler(sexp_9p_create, create) +sexp_def_9p_handler(sexp_9p_remove, remove) +sexp_def_9p_handler(sexp_9p_read, read) +sexp_def_9p_handler(sexp_9p_write, write) +sexp_def_9p_handler(sexp_9p_stat, stat) +sexp_def_9p_handler(sexp_9p_wstat, wstat) +sexp_def_9p_handler(sexp_9p_flush, flush) + +char* sexp_9p_walk1 (Fid *fid, char *name, Qid *qid) { + sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux; + sexp res, ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, qid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + ptr = sexp_c_string(ctx, name, -1); + args = sexp_cons(ctx, ptr, args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, args); + res = sexp_apply(ctx, s->walk1, args); + sexp_gc_release(ctx, ptr, s_ptr); + return sexp_stringp(res) ? sexp_string_data(res) : nil; +} + +char* sexp_9p_clone (Fid *oldfid, Fid *newfid) { + sexp_plan9_srv s = (sexp_plan9_srv)oldfid->pool->srv->aux; + sexp res, ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, oldfid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, newfid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, args); + res = sexp_apply(ctx, s->clone, args); + sexp_gc_release(ctx, ptr, s_ptr); + return sexp_stringp(res) ? sexp_string_data(res) : nil; +} + +void sexp_9p_destroyfid (Fid *fid) { + sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->destroyfid, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +void sexp_9p_destroyreq (Req *r) { + sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->destroyreq, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +void sexp_9p_end (Srv *srv) { + sexp_plan9_srv s = (sexp_plan9_srv)srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, srv, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->end, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +sexp sexp_postmountsrv (sexp ctx sexp_api_params(self, n), sexp ls, sexp name, sexp mtpt, sexp flags) { + Srv s; + struct sexp_plan9_srv p9s; + if (! sexp_listp(ctx, ls)) + return sexp_type_exception(ctx, "postmountsrv: not a list", ls); + if (! sexp_stringp(name)) + return sexp_type_exception(ctx, "postmountsrv: not a string", name); + if (! sexp_stringp(mtpt)) + return sexp_type_exception(ctx, "postmountsrv: not a string", mtpt); + if (! sexp_integerp(flags)) + return sexp_type_exception(ctx, "postmountsrv: not an integer", flags); + sexp_build_srv(ctx, &p9s, ls); + s.aux = &p9s; + s.auth = &sexp_9p_auth; + s.attach = &sexp_9p_attach; + s.walk = &sexp_9p_walk; + s.walk1 = &sexp_9p_walk1; + s.clone = &sexp_9p_clone; + s.open = &sexp_9p_open; + s.create = &sexp_9p_create; + s.remove = &sexp_9p_remove; + s.read = &sexp_9p_read; + s.write = &sexp_9p_write; + s.stat = &sexp_9p_stat; + s.wstat = &sexp_9p_wstat; + s.flush = &sexp_9p_flush; + s.destroyfid = &sexp_9p_destroyfid; + s.destroyreq = &sexp_9p_destroyreq; + s.end = &sexp_9p_end; + postmountsrv(&s, sexp_string_data(name), sexp_string_data(mtpt), + sexp_unbox_fixnum(flags)); + return SEXP_UNDEF; +} + +sexp sexp_9p_req_offset (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.offset); +} + +sexp sexp_9p_req_count (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.count); +} + +#if 0 +sexp sexp_9p_req_path (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_c_string(ctx, ((Req*)sexp_cpointer_value(req))->fid->qid.path, -1); +} +#endif + +sexp sexp_9p_req_fid (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->fid, SEXP_FALSE, 0); +} + +sexp sexp_9p_req_newfid (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->newfid, SEXP_FALSE, 0); +} + +sexp sexp_9p_respond (sexp ctx sexp_api_params(self, n), sexp req, sexp err) { + char *cerr = sexp_stringp(err) ? sexp_string_data(err) : nil; + respond(sexp_cpointer_value(req), cerr); + return SEXP_VOID; +} + +sexp sexp_9p_responderror (sexp ctx sexp_api_params(self, n), sexp req) { + responderror(sexp_cpointer_value(req)); + return SEXP_VOID; +} + diff --git a/opt/sexp-huff.c b/opt/sexp-huff.c new file mode 100644 index 00000000..abf6bc9f --- /dev/null +++ b/opt/sexp-huff.c @@ -0,0 +1,128 @@ + {12, 0x0C00}, /* '\x00' */ + {15, 0x0000}, /* '\x01' */ + {15, 0x4000}, /* '\x02' */ + {15, 0x2000}, /* '\x03' */ + {15, 0x6000}, /* '\x04' */ + {15, 0x0800}, /* '\x05' */ + {15, 0x4800}, /* '\x06' */ + {15, 0x2800}, /* '\x07' */ + {15, 0x6800}, /* '\x08' */ + {15, 0x1800}, /* '\x09' */ + {15, 0x5800}, /* '\x0a' */ + {15, 0x3800}, /* '\x0b' */ + {15, 0x7800}, /* '\x0c' */ + {15, 0x0100}, /* '\x0d' */ + {15, 0x4100}, /* '\x0e' */ + {15, 0x2100}, /* '\x0f' */ + {15, 0x6100}, /* '\x10' */ + {15, 0x1100}, /* '\x11' */ + {15, 0x5100}, /* '\x12' */ + {15, 0x3100}, /* '\x13' */ + {15, 0x7100}, /* '\x14' */ + {15, 0x0900}, /* '\x15' */ + {15, 0x4900}, /* '\x16' */ + {15, 0x2900}, /* '\x17' */ + {15, 0x6900}, /* '\x18' */ + {15, 0x1900}, /* '\x19' */ + {15, 0x5900}, /* '\x1a' */ + {15, 0x3900}, /* '\x1b' */ + {15, 0x7900}, /* '\x1c' */ + {15, 0x0500}, /* '\x1d' */ + {15, 0x4500}, /* '\x1e' */ + {15, 0x2500}, /* '\x1f' */ + {15, 0x6500}, /* '\x20' */ + { 8, 0x0040}, /* '!' */ + {15, 0x1500}, /* '"' */ + {15, 0x5500}, /* '#' */ + {15, 0x3500}, /* '$' */ + {15, 0x7500}, /* '%' */ + {15, 0x0D00}, /* '&' */ + {15, 0x4D00}, /* '\'' */ + {15, 0x2D00}, /* '(' */ + {15, 0x6D00}, /* ')' */ + {11, 0x0300}, /* '*' */ + {10, 0x0180}, /* '+' */ + {15, 0x1D00}, /* ',' */ + { 4, 0x000D}, /* '-' */ + {15, 0x5D00}, /* '.' */ + {10, 0x0380}, /* '/' */ + {15, 0x3D00}, /* '0' */ + {15, 0x7D00}, /* '1' */ + {14, 0x0080}, /* '2' */ + {14, 0x2080}, /* '3' */ + {14, 0x1080}, /* '4' */ + {14, 0x3080}, /* '5' */ + {14, 0x0880}, /* '6' */ + {14, 0x2880}, /* '7' */ + {14, 0x1880}, /* '8' */ + {14, 0x3880}, /* '9' */ + {14, 0x0480}, /* ':' */ + {14, 0x2480}, /* ';' */ + { 7, 0x0050}, /* '<' */ + { 7, 0x0042}, /* '=' */ + { 7, 0x0022}, /* '>' */ + { 5, 0x0009}, /* '?' */ + {14, 0x1480}, /* '@' */ + {14, 0x3480}, /* 'A' */ + {14, 0x0C80}, /* 'B' */ + {14, 0x2C80}, /* 'C' */ + {14, 0x1C80}, /* 'D' */ + {14, 0x3C80}, /* 'E' */ + {14, 0x0280}, /* 'F' */ + {14, 0x2280}, /* 'G' */ + {14, 0x1280}, /* 'H' */ + {14, 0x3280}, /* 'I' */ + {14, 0x0A80}, /* 'J' */ + {14, 0x2A80}, /* 'K' */ + {14, 0x1A80}, /* 'L' */ + {14, 0x3A80}, /* 'M' */ + {14, 0x0680}, /* 'N' */ + {14, 0x2680}, /* 'O' */ + {14, 0x1680}, /* 'P' */ + {14, 0x3680}, /* 'Q' */ + {14, 0x0E80}, /* 'R' */ + {14, 0x2E80}, /* 'S' */ + {14, 0x1E80}, /* 'T' */ + {14, 0x3E80}, /* 'U' */ + {14, 0x0200}, /* 'V' */ + {14, 0x2200}, /* 'W' */ + {14, 0x1200}, /* 'X' */ + {14, 0x3200}, /* 'Y' */ + {14, 0x0A00}, /* 'Z' */ + {14, 0x2A00}, /* '[' */ + {14, 0x1A00}, /* '\\' */ + {14, 0x3A00}, /* ']' */ + {14, 0x0600}, /* '^' */ + {14, 0x2600}, /* '_' */ + {14, 0x1600}, /* '`' */ + { 3, 0x0007}, /* 'a' */ + { 7, 0x0020}, /* 'b' */ + { 4, 0x0004}, /* 'c' */ + { 5, 0x001A}, /* 'd' */ + { 4, 0x0006}, /* 'e' */ + { 7, 0x0002}, /* 'f' */ + { 5, 0x0011}, /* 'g' */ + { 6, 0x0012}, /* 'h' */ + { 4, 0x000C}, /* 'i' */ + {12, 0x0400}, /* 'j' */ + { 8, 0x00C0}, /* 'k' */ + { 5, 0x0018}, /* 'l' */ + { 6, 0x0032}, /* 'm' */ + { 4, 0x0005}, /* 'n' */ + { 5, 0x000A}, /* 'o' */ + { 5, 0x0001}, /* 'p' */ + { 7, 0x0070}, /* 'q' */ + { 3, 0x0003}, /* 'r' */ + { 5, 0x0008}, /* 's' */ + { 4, 0x000E}, /* 't' */ + { 5, 0x0019}, /* 'u' */ + { 7, 0x0062}, /* 'v' */ + { 7, 0x0030}, /* 'w' */ + { 7, 0x0060}, /* 'x' */ + { 7, 0x0010}, /* 'y' */ + {11, 0x0700}, /* 'z' */ + {14, 0x3600}, /* '{' */ + {14, 0x0E00}, /* '|' */ + {14, 0x2E00}, /* '}' */ + {14, 0x1E00}, /* '~' */ + {14, 0x3E00}, /* '\x7f' */ diff --git a/opt/sexp-hufftabs.c b/opt/sexp-hufftabs.c new file mode 100644 index 00000000..7704184f --- /dev/null +++ b/opt/sexp-hufftabs.c @@ -0,0 +1,92 @@ +/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */ + +char _huff_tab21[] = { + '\x01', '\x00', '\x03', '\x00', '\x02', '\x00', '\x04', '\x00', +}; + +char _huff_tab19[] = { + '\x01', 'j', '\x01', '\x00', +}; + +char _huff_tab20[] = { + '\x05', '\x09', '\x07', '\x0b', '\x06', '\x0a', '\x08', '\x0c', +}; + +char _huff_tab18[] = { + '2', ':', '6', 'B', '4', '@', '8', 'D', + '3', ';', '7', 'C', '5', 'A', '9', 'E', +}; + +char _huff_tab17[] = { + '\x0d', '\x1d', '\x15', '&', '\x11', '"', '\x19', ',', + '\x0f', '\x1f', '\x17', '(', '\x13', '$', '\x1b', '0', + '\x0e', '\x1e', '\x16', '\'', '\x12', '#', '\x1a', '.', + '\x10', '\x20', '\x18', ')', '\x14', '%', '\x1c', '1', +}; + +char _huff_tab16[] = { + 'V', '^', 'Z', '|', 'X', '`', '\\', '~', + 'W', '_', '[', '}', 'Y', '{', ']', '\x7f', +}; + +char _huff_tab15[] = { + 'F', 'N', 'J', 'R', 'H', 'P', 'L', 'T', + 'G', 'O', 'K', 'S', 'I', 'Q', 'M', 'U', +}; + +char _huff_tab13[] = { + '\x00', '\x00', '\x00', '+', '\x00', '\x00', '\x00', '/', +}; + +char _huff_tab14[] = { + '*', 'z', +}; + +char _huff_tab11[] = { + '\x00', 'b', '\x00', 'x', +}; + +char _huff_tab12[] = { + '!', 'k', +}; + +char _huff_tab9[] = { + '\x00', 's', '\x00', 'l', +}; + +char _huff_tab10[] = { + 'y', 'w', '<', 'q', +}; + +char _huff_tab8[] = { + 'p', '?', 'g', 'u', +}; + +char _huff_tab7[] = { + 'f', '>', '=', 'v', +}; + +char _huff_tab5[] = { + '\x00', 'o', '\x00', 'd', +}; + +char _huff_tab6[] = { + 'h', 'm', +}; + +char _huff_tab4[] = { + 'c', 'i', +}; + +char _huff_tab3[] = { + 'n', '-', +}; + +char _huff_tab1[] = { + '\x00', '\x00', '\x00', 'r', '\x00', '\x00', '\x00', 'a', +}; + +char _huff_tab2[] = { + 'e', 't', +}; + diff --git a/opt/sexp-unhuff.c b/opt/sexp-unhuff.c new file mode 100644 index 00000000..fa142e16 --- /dev/null +++ b/opt/sexp-unhuff.c @@ -0,0 +1,71 @@ +/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */ + +res = c & 7; +c = c >> 3; +if (res == 0) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = c & 7; + c = c >> 3; + if (res == 0) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = _huff_tab21[c & 7]; + c = c >> 3; + } else if ((res = _huff_tab19[res]) == '\x01') { + res = _huff_tab20[c & 7]; + c = c >> 3; + } + } else if (res == 1) { + res = _huff_tab18[c & 15]; + c = c >> 4; + } else if (res == 2) { + res = _huff_tab17[c & 31]; + c = c >> 5; + } else if (res == 4) { + res = _huff_tab16[c & 15]; + c = c >> 4; + } else if (res == 5) { + res = _huff_tab15[c & 15]; + c = c >> 4; + } else if ((res = _huff_tab13[res]) == '\x00') { + res = _huff_tab14[c & 1]; + c = c >> 1; + } + } else if ((res = _huff_tab11[res]) == '\x00') { + res = _huff_tab12[c & 1]; + c = c >> 1; + } + } else if ((res = _huff_tab9[res]) == '\x00') { + res = _huff_tab10[c & 3]; + c = c >> 2; + } + } else if (res == 1) { + res = _huff_tab8[c & 3]; + c = c >> 2; + } else if (res == 2) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = _huff_tab7[c & 3]; + c = c >> 2; + } else if ((res = _huff_tab5[res]) == '\x00') { + res = _huff_tab6[c & 1]; + c = c >> 1; + } + } else if (res == 4) { + res = _huff_tab4[c & 1]; + c = c >> 1; + } else if (res == 5) { + res = _huff_tab3[c & 1]; + c = c >> 1; + } else if ((res = _huff_tab1[res]) == '\x00') { + res = _huff_tab2[c & 1]; + c = c >> 1; + } + diff --git a/opt/simplify.c b/opt/simplify.c new file mode 100644 index 00000000..4217a1bb --- /dev/null +++ b/opt/simplify.c @@ -0,0 +1,143 @@ +/* simplify.c -- basic simplification pass */ +/* Copyright (c) 2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define simplify_it(it) ((it) = simplify(ctx, it, substs, lambda)) + +static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) { + int check; + sexp ls1, ls2, p1, p2, sv, ctx2; + sexp_gc_var4(res, substs, tmp, app); + sexp_gc_preserve4(ctx, res, substs, tmp, app); + res = ast; /* return the ast as-is by default */ + substs = init_substs; + + loop: + switch (sexp_pointerp(res) ? sexp_pointer_tag(res) : 0) { + + case SEXP_PAIR: + /* don't simplify the operator if it's a lambda because we + simplify that as a special case below, with the appropriate + substs list */ + app = sexp_list1(ctx, sexp_lambdap(sexp_car(res)) ? sexp_car(res) + : (tmp=simplify(ctx, sexp_car(res), substs, lambda))); + for (ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) + sexp_push(ctx, app, tmp=simplify(ctx, sexp_car(ls1), substs, lambda)); + app = sexp_nreverse(ctx, app); + /* app now holds a copy of the list, and is the default result + (res = app below) if we don't replace it with a simplification */ + if (sexp_opcodep(sexp_car(app))) { + /* opcode app - right now we just constant fold arithmetic */ + if (sexp_opcode_class(sexp_car(app)) == SEXP_OPC_ARITHMETIC) { + for (check=1, ls1=sexp_cdr(app); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) { + if (sexp_pointerp(sexp_car(ls1)) && ! sexp_litp(sexp_car(ls1))) { + check = 0; + break; + } + } + if (check) { + ctx2 = sexp_make_eval_context(ctx, NULL, sexp_context_env(ctx), 0); + generate(ctx2, app); + res = finalize_bytecode(ctx2); + if (! sexp_exceptionp(res)) { + tmp = sexp_make_vector(ctx2, 0, SEXP_VOID); + tmp = sexp_make_procedure(ctx2, SEXP_ZERO, SEXP_ZERO, res, tmp); + if (! sexp_exceptionp(tmp)) { + tmp = sexp_apply(ctx2, tmp, SEXP_NULL); + if (! sexp_exceptionp(tmp)) + app = sexp_make_lit(ctx2, tmp); + } + } + } + } + } else if (lambda && sexp_lambdap(sexp_car(app))) { /* let */ + p1 = NULL; + p2 = sexp_lambda_params(sexp_car(app)); + ls1 = app; + ls2 = sexp_cdr(app); + sv = sexp_lambda_sv(sexp_car(app)); + for ( ; sexp_pairp(ls2); ls2=sexp_cdr(ls2), p2=sexp_cdr(p2)) { + if (sexp_not(sexp_memq(ctx, sexp_car(p2), sv)) + && (! sexp_pointerp(sexp_car(ls2)) || sexp_litp(sexp_car(ls2)) + || (sexp_refp(sexp_car(ls2)) + && sexp_lambdap(sexp_ref_loc(sexp_car(ls2))) + && sexp_not(sexp_memq(ctx, sexp_ref_name(sexp_car(ls2)), + sexp_lambda_sv(sexp_ref_loc(sexp_car(ls2)))))))) { + tmp = sexp_cons(ctx, sexp_car(app), sexp_car(ls2)); + tmp = sexp_cons(ctx, sexp_car(p2), tmp); + sexp_push(ctx, substs, tmp); + sexp_cdr(ls1) = sexp_cdr(ls2); + if (p1) + sexp_cdr(p1) = sexp_cdr(p2); + else + sexp_lambda_params(sexp_car(app)) = sexp_cdr(p2); + } else { + p1 = p2; + ls1 = ls2; + } + } + sexp_lambda_body(sexp_car(app)) + = simplify(ctx, sexp_lambda_body(sexp_car(app)), substs, sexp_car(app)); + if (sexp_nullp(sexp_cdr(app)) + && sexp_nullp(sexp_lambda_params(sexp_car(app))) + && sexp_nullp(sexp_lambda_defs(sexp_car(app)))) + app = sexp_lambda_body(sexp_car(app)); + } + res = app; + break; + + case SEXP_LAMBDA: + sexp_lambda_body(res) = simplify(ctx, sexp_lambda_body(res), substs, res); + break; + + case SEXP_CND: + tmp = simplify(ctx, sexp_cnd_test(res), substs, lambda); + if (sexp_litp(tmp) || ! sexp_pointerp(tmp)) { + res = sexp_not((sexp_litp(tmp) ? sexp_lit_value(tmp) : tmp)) + ? sexp_cnd_fail(res) : sexp_cnd_pass(res); + goto loop; + } else { + sexp_cnd_test(res) = tmp; + simplify_it(sexp_cnd_pass(res)); + simplify_it(sexp_cnd_fail(res)); + } + break; + + case SEXP_REF: + tmp = sexp_ref_name(res); + for (ls1=substs; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) + if ((sexp_caar(ls1) == tmp) && (sexp_cadar(ls1) == sexp_ref_loc(res))) { + res = sexp_cddar(ls1); + break; + } + break; + + case SEXP_SET: + simplify_it(sexp_set_value(res)); + break; + + case SEXP_SEQ: + app = SEXP_NULL; + for (ls2=sexp_seq_ls(res); sexp_pairp(ls2); ls2=sexp_cdr(ls2)) { + tmp = simplify(ctx, sexp_car(ls2), substs, lambda); + if (! (sexp_pairp(sexp_cdr(ls2)) + && (sexp_litp(tmp) || ! sexp_pointerp(tmp) || sexp_refp(tmp) + || sexp_lambdap(tmp)))) + sexp_push(ctx, app, tmp); + } + if (sexp_pairp(app) && sexp_nullp(sexp_cdr(app))) + res = sexp_car(app); + else + sexp_seq_ls(res) = sexp_nreverse(ctx, app); + break; + + } + + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_simplify (sexp ctx sexp_api_params(self, n), sexp ast) { + return simplify(ctx, ast, SEXP_NULL, NULL); +} + diff --git a/sexp.c b/sexp.c new file mode 100644 index 00000000..db4c91fe --- /dev/null +++ b/sexp.c @@ -0,0 +1,1842 @@ +/* sexp.c -- standalone sexp library implementation */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/sexp.h" + +/* optional huffman-compressed immediate symbols */ +struct sexp_huff_entry { + unsigned char len; + unsigned short bits; +}; + +#if SEXP_USE_HUFF_SYMS +#include "opt/sexp-hufftabs.c" +static struct sexp_huff_entry huff_table[] = { +#include "opt/sexp-huff.c" +}; +#endif + +static int sexp_initialized_p = 0; + +sexp sexp_read_float_tail(sexp ctx, sexp in, double whole, int negp); + +static const char sexp_separators[] = { + /* 1 2 3 4 5 6 7 8 9 a b c d e f */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 0, 0, /* x0_ */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x1_ */ + 1, 0, 1, 0, 0, 0, 0, 1, 1, 1, 0, 0, 1, 0, 0, 0, /* x2_ */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, /* x3_ */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x4_ */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, /* x5_ */ +}; + +static int digit_value (int c) { + return (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10)); +} + +static int hex_digit (int n) { + return ((n<=9) ? ('0' + n) : ('A' + n - 10)); +} + +static int is_separator(int c) { + return 0= SEXP_MAXIMUM_TYPES) { + res = sexp_user_exception(ctx, self, "register-type: exceeded maximum type limit", name); + } else if (! sexp_stringp(name)) { + res = sexp_type_exception(ctx, self, SEXP_STRING, name); + } else { + if (num_types >= type_array_size) { + len = type_array_size*2; + if (len > SEXP_MAXIMUM_TYPES) len = SEXP_MAXIMUM_TYPES; +#if SEXP_USE_GLOBAL_TYPES + new = malloc(len * sizeof(_sexp_type_specs[0])); + for (i=0; i num_types) free(tmp); + sexp_type_array_size = len; +#else + res = sexp_make_vector(ctx, sexp_make_fixnum(len), SEXP_VOID); + v1 = sexp_vector_data(res); + v2 = sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)); + for (i=0; ivalue), &(_sexp_type_specs[i]), sizeof(_sexp_type_specs[0])); + vec[i] = type; + } +#endif +} + +#if ! SEXP_USE_GLOBAL_HEAP +sexp sexp_bootstrap_context (sexp_uint_t size) { + sexp dummy_ctx, ctx; + sexp_heap heap; + if (size < SEXP_MINIMUM_HEAP_SIZE) size = SEXP_INITIAL_HEAP_SIZE; + heap = sexp_make_heap(sexp_heap_align(size)); + dummy_ctx = (sexp) malloc(sexp_sizeof(context)); + sexp_pointer_tag(dummy_ctx) = SEXP_CONTEXT; + sexp_context_saves(dummy_ctx) = NULL; + sexp_context_heap(dummy_ctx) = heap; + ctx = sexp_alloc_type(dummy_ctx, context, SEXP_CONTEXT); + sexp_context_heap(dummy_ctx) = NULL; + sexp_context_heap(ctx) = heap; + free(dummy_ctx); + return ctx; +} +#endif + +sexp sexp_make_context (sexp ctx, size_t size) { + sexp_gc_var1(res); + if (ctx) sexp_gc_preserve1(ctx, res); +#if ! SEXP_USE_GLOBAL_HEAP + if (! ctx) res = sexp_bootstrap_context(size); + else +#endif + { + res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); +#if ! SEXP_USE_BOEHM && ! SEXP_USE_MALLOC + sexp_context_heap(res) = sexp_context_heap(ctx); +#endif + } + sexp_context_parent(res) = ctx; + sexp_context_lambda(res) = SEXP_FALSE; + sexp_context_name(res) = sexp_context_specific(res) = SEXP_FALSE; + sexp_context_fv(res) = SEXP_NULL; + sexp_context_saves(res) = NULL; + sexp_context_depth(res)=sexp_context_tracep(res)=sexp_context_pos(res)=0; + sexp_context_tailp(res) = 1; +#if SEXP_USE_GREEN_THREADS + sexp_context_refuel(res) = SEXP_DEFAULT_QUANTUM; +#endif + if (ctx) { + sexp_context_globals(res) = sexp_context_globals(ctx); + sexp_gc_release1(ctx); + } else { + sexp_init_context_globals(res); + } + return res; +} + +#if ! SEXP_USE_GLOBAL_HEAP +void sexp_destroy_context (sexp ctx) { + sexp_heap heap, tmp; + size_t sum_freed; + if (sexp_context_heap(ctx)) { + heap = sexp_context_heap(ctx); + sexp_sweep(ctx, &sum_freed); /* sweep w/o mark to run finalizers */ + sexp_context_heap(ctx) = NULL; + for ( ; heap; heap=tmp) { + tmp = heap->next; +#if SEXP_USE_MMAP_GC + munmap(heap, sexp_heap_pad_size(heap->size)); +#else + free(heap); +#endif + } + } +} +#endif + +/***************************** exceptions *****************************/ + +sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, + sexp procedure, sexp source) { + sexp exn = sexp_alloc_type(ctx, exception, SEXP_EXCEPTION); + sexp_exception_kind(exn) = kind; + sexp_exception_message(exn) = message; + sexp_exception_irritants(exn) = irritants; + sexp_exception_procedure(exn) = procedure; + sexp_exception_source(exn) = source; + return exn; +} + +sexp sexp_string_cat3 (sexp ctx, char *pre, char *mid, char* suf) { + int plen=strlen(pre), mlen=strlen(mid), slen=strlen(suf); + char *s; + sexp str; + str = sexp_make_string(ctx, sexp_make_fixnum(plen+mlen+slen), SEXP_VOID); + memcpy(s=sexp_string_data(str), pre, plen); + memcpy(s+plen, mid, mlen); + memcpy(s+plen+mlen, suf, slen); + return str; +} + +sexp sexp_user_exception (sexp ctx, sexp self, const char *ms, sexp ir) { + sexp res; + sexp_gc_var3(sym, str, irr); + sexp_gc_preserve3(ctx, sym, str, irr); + res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "user", -1), + str = sexp_c_string(ctx, ms, -1), + ((sexp_pairp(ir) || sexp_nullp(ir)) + ? ir : (irr = sexp_list1(ctx, ir))), + self, SEXP_FALSE); + sexp_gc_release3(ctx); + return res; +} + +static sexp type_exception (sexp ctx, sexp self, sexp str, sexp obj, sexp src) { + sexp_gc_var2(res, sym); + sexp_gc_preserve2(ctx, res, sym); + sym = sexp_intern(ctx, "type", -1); + res = sexp_make_exception(ctx, sym, str, obj, self, src); + sexp_exception_irritants(res)=sexp_list1(ctx, sexp_exception_irritants(res)); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp obj) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_c_string(ctx, msg, -1); + res = type_exception(ctx, self, res, obj, SEXP_FALSE); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp obj) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_string_cat3(ctx, "invalid type, expected ", + sexp_type_name_by_index(ctx, type_id), ""); + res = type_exception(ctx, self, res, obj, SEXP_FALSE); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) { + sexp_gc_var2(res, msg); + sexp_gc_preserve2(ctx, res, msg); + msg = sexp_c_string(ctx, "bad index range", -1); + res = sexp_list2(ctx, start, end); + res = sexp_cons(ctx, obj, res); + res = sexp_make_exception(ctx, sexp_intern(ctx, "range", -1), msg, res, + SEXP_FALSE, SEXP_FALSE); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp out) { + sexp ls; + if (! sexp_oportp(out)) + out = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_write_string(ctx, "ERROR", out); + if (sexp_exceptionp(exn)) { + if (sexp_exception_procedure(exn)) { + if (sexp_procedurep(sexp_exception_procedure(exn))) { + ls = sexp_bytecode_name( + sexp_procedure_code(sexp_exception_procedure(exn))); + if (ls && sexp_symbolp(ls)) { + sexp_write_string(ctx, " in ", out); + sexp_write(ctx, ls, out); + } + } else if (sexp_opcodep(sexp_exception_procedure(exn))) { + sexp_write_string(ctx, " in ", out); + sexp_write_string(ctx, sexp_opcode_name(sexp_exception_procedure(exn)), out); + } + } + ls = sexp_exception_source(exn); + if ((! (ls && sexp_pairp(ls))) + && sexp_exception_procedure(exn) + && sexp_procedurep(sexp_exception_procedure(exn))) + ls = sexp_bytecode_source(sexp_procedure_code(sexp_exception_procedure(exn))); + if (ls && sexp_pairp(ls)) { + if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) { + sexp_write_string(ctx, " on line ", out); + sexp_write(ctx, sexp_cdr(ls), out); + } + if (sexp_stringp(sexp_car(ls))) { + sexp_write_string(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_car(ls)), out); + } + } + sexp_write_string(ctx, ": ", out); + if (sexp_stringp(sexp_exception_message(exn))) + sexp_write_string(ctx, sexp_string_data(sexp_exception_message(exn)), out); + else + sexp_write(ctx, sexp_exception_message(exn), out); + if (sexp_exception_irritants(exn) + && sexp_pairp(sexp_exception_irritants(exn))) { + if (sexp_nullp(sexp_cdr(sexp_exception_irritants(exn)))) { + sexp_write_string(ctx, ": ", out); + sexp_write(ctx, sexp_car(sexp_exception_irritants(exn)), out); + sexp_write_string(ctx, "\n", out); + } else { + sexp_write_string(ctx, "\n", out); + for (ls=sexp_exception_irritants(exn); + sexp_pairp(ls); ls=sexp_cdr(ls)) { + sexp_write_string(ctx, " ", out); + sexp_write(ctx, sexp_car(ls), out); + sexp_write_char(ctx, '\n', out); + } + } + } else { + sexp_write_char(ctx, '\n', out); + } + } else { + sexp_write_string(ctx, ": ", out); + if (sexp_stringp(exn)) + sexp_write_string(ctx, sexp_string_data(exn), out); + else + sexp_write(ctx, exn, out); + sexp_write_char(ctx, '\n', out); + } + return SEXP_VOID; +} + +static sexp sexp_read_error (sexp ctx, const char *msg, sexp ir, sexp port) { + sexp res; + sexp_gc_var4(sym, name, str, irr); + sexp_gc_preserve4(ctx, sym, name, str, irr); + name = (sexp_port_name(port) ? sexp_port_name(port) : SEXP_FALSE); + name = sexp_cons(ctx, name, sexp_make_fixnum(sexp_port_line(port))); + str = sexp_c_string(ctx, msg, -1); + irr = ((sexp_pairp(ir) || sexp_nullp(ir)) ? ir : sexp_list1(ctx, ir)); + res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "read", -1), + str, irr, SEXP_FALSE, name); + sexp_gc_release4(ctx); + return res; +} + +/*************************** list utilities ***************************/ + +sexp sexp_cons_op (sexp ctx sexp_api_params(self, n), sexp head, sexp tail) { + sexp pair = sexp_alloc_type(ctx, pair, SEXP_PAIR); + if (sexp_exceptionp(pair)) return pair; + sexp_car(pair) = head; + sexp_cdr(pair) = tail; + sexp_pair_source(pair) = SEXP_FALSE; + return pair; +} + +sexp sexp_list2 (sexp ctx, sexp a, sexp b) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_cons(ctx, b, SEXP_NULL); + res = sexp_cons(ctx, a, res); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_listp_op (sexp ctx sexp_api_params(self, n), sexp hare) { + sexp turtle; + if (! sexp_pairp(hare)) + return sexp_make_boolean(sexp_nullp(hare)); + turtle = hare; + hare = sexp_cdr(hare); + for ( ; sexp_pairp(hare); turtle=sexp_cdr(turtle)) { + if (hare == turtle) return SEXP_FALSE; + hare = sexp_cdr(hare); + if (sexp_pairp(hare)) hare = sexp_cdr(hare); + } + return sexp_make_boolean(sexp_nullp(hare)); +} + +sexp sexp_memq_op (sexp ctx sexp_api_params(self, n), sexp x, sexp ls) { + while (sexp_pairp(ls)) + if (x == sexp_car(ls)) + return ls; + else + ls = sexp_cdr(ls); + return SEXP_FALSE; +} + +sexp sexp_assq_op (sexp ctx sexp_api_params(self, n), sexp x, sexp ls) { + while (sexp_pairp(ls)) + if (sexp_pairp(sexp_car(ls)) && (x == sexp_caar(ls))) + return sexp_car(ls); + else + ls = sexp_cdr(ls); + return SEXP_FALSE; +} + +sexp sexp_reverse_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + res = sexp_cons(ctx, sexp_car(ls), res); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_nreverse_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp a, b, tmp; + if (ls == SEXP_NULL) return ls; + sexp_assert_type(ctx, sexp_pairp, SEXP_PAIR, ls); + b = ls; + a = sexp_cdr(ls); + sexp_cdr(b) = SEXP_NULL; + for ( ; sexp_pairp(a); b=a, a=tmp) { + tmp = sexp_cdr(a); + sexp_cdr(a) = b; + } + return b; +} + +sexp sexp_copy_list_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp tmp; + sexp_gc_var1(res); + if (! sexp_pairp(ls)) return ls; + sexp_gc_preserve1(ctx, res); + tmp = res = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls)); + for (ls=sexp_cdr(ls); sexp_pairp(ls); ls=sexp_cdr(ls), tmp=sexp_cdr(tmp)) + sexp_cdr(tmp) = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls)); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_append2_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { + sexp_gc_var2(a1, b1); + sexp_gc_preserve2(ctx, a1, b1); + b1 = b; + for (a1=sexp_reverse(ctx, a); sexp_pairp(a1); a1=sexp_cdr(a1)) + b1 = sexp_cons(ctx, sexp_car(a1), b1); + sexp_gc_release2(ctx); + return b1; +} + +sexp sexp_length_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp_uint_t res=0; + for ( ; sexp_pairp(ls); res++, ls=sexp_cdr(ls)) + ; + return sexp_make_fixnum(res); +} + +sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { + sexp_uint_t size; + sexp_sint_t i, len; + sexp t, *p, *q; + char *p0, *q0; + + loop: + if (a == b) + return SEXP_TRUE; + else if ((! sexp_pointerp(a)) || (! sexp_pointerp(b)) + || (sexp_pointer_tag(a) != sexp_pointer_tag(b))) + return SEXP_FALSE; + + /* a and b are both pointers of the same type */ +#if SEXP_USE_BIGNUMS + if (sexp_pointer_tag(a) == SEXP_BIGNUM) + return sexp_make_boolean(!sexp_bignum_compare(a, b)); +#endif +#if SEXP_USE_FLONUMS && ! SEXP_USE_IMMEDIATE_FLONUMS + if (sexp_pointer_tag(a) == SEXP_FLONUM) + return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b)); +#endif + t = sexp_object_type(ctx, a); + p0 = ((char*)a) + offsetof(struct sexp_struct, value); + p = (sexp*) (((char*)a) + sexp_type_field_base(t)); + q0 = ((char*)b) + offsetof(struct sexp_struct, value); + q = (sexp*) (((char*)b) + sexp_type_field_base(t)); + if ((sexp)p == a) {p=(sexp*)p0; q=(sexp*)q0;} + /* check preliminary non-object data */ + if ((p0 < (char*)p) && memcmp(p0, q0, ((char*)p - p0))) + return SEXP_FALSE; + /* check trailing non-object data */ + size = sexp_type_size_of_object(t, a) - offsetof(struct sexp_struct, value); + p0 = ((char*)p + sexp_type_num_slots_of_object(t,a)*sizeof(sexp)); + if (((char*)a + size) > p0) { + q0 = ((char*)q + sexp_type_num_slots_of_object(t,b)*sizeof(sexp)); + if (size != sexp_type_size_of_object(t,b)-offsetof(struct sexp_struct,value)) + return SEXP_FALSE; + if (memcmp(p0, q0, size)) + return SEXP_FALSE; + } + /* check eq-object slots */ + len = sexp_type_num_eq_slots_of_object(t, a); + if (len > 0) { + for (i=0; i> 32; + return r.flonum; +} +sexp sexp_make_flonum (sexp ctx, float f) { + union sexp_flonum_conv x; + x.flonum = f; + return (sexp)(((sexp_uint_t)(x.bits) << 32) + SEXP_IFLONUM_TAG); +} +#endif +#endif + +sexp sexp_make_bytes_op (sexp ctx sexp_api_params(self, n), sexp len, sexp i) { + sexp_sint_t clen = sexp_unbox_fixnum(len); + sexp s; + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, len); + if (clen < 0) return sexp_xtype_exception(ctx, self, "negative length", len); + s = sexp_alloc_atomic(ctx, sexp_sizeof(bytes)+clen+1); + if (sexp_exceptionp(s)) return s; + sexp_pointer_tag(s) = SEXP_BYTES; +#if SEXP_USE_HEADER_MAGIC + sexp_pointer_magic(s) = SEXP_POINTER_MAGIC; +#endif + sexp_bytes_length(s) = clen; + if (sexp_fixnump(i)) + memset(sexp_bytes_data(s), sexp_unbox_fixnum(i), clen); + sexp_bytes_data(s)[clen] = '\0'; + return s; +} + +sexp sexp_make_string_op (sexp ctx sexp_api_params(self, n), sexp len, sexp ch) +{ + sexp i = (sexp_charp(ch) ? sexp_make_fixnum(sexp_unbox_character(ch)) : ch); + sexp_gc_var2(b, s); + b = sexp_make_bytes_op(ctx sexp_api_pass(self, n), len, i); + if (sexp_exceptionp(b)) return b; +#if SEXP_USE_PACKED_STRINGS + sexp_pointer_tag(b) = SEXP_STRING; + return b; +#else + sexp_gc_preserve2(ctx, b, s); + s = sexp_alloc_type(ctx, string, SEXP_STRING); + sexp_string_bytes(s) = b; + sexp_string_offset(s) = 0; + sexp_string_length(s) = sexp_unbox_fixnum(len); + sexp_gc_release2(ctx); + return s; +#endif +} + +sexp sexp_c_string (sexp ctx, const char *str, sexp_sint_t slen) { + sexp_sint_t len = ((slen >= 0) ? slen : strlen(str)); + sexp s = sexp_make_string(ctx, sexp_make_fixnum(len), SEXP_VOID); + memcpy(sexp_string_data(s), str, len); + sexp_string_data(s)[len] = '\0'; + return s; +} + +sexp sexp_substring_op (sexp ctx sexp_api_params(self, n), sexp str, sexp start, sexp end) { + sexp res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, start); + if (sexp_not(end)) + end = sexp_make_fixnum(sexp_string_length(str)); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, end); + if ((sexp_unbox_fixnum(start) < 0) + || (sexp_unbox_fixnum(start) > sexp_string_length(str)) + || (sexp_unbox_fixnum(end) < 0) + || (sexp_unbox_fixnum(end) > sexp_string_length(str)) + || (end < start)) + return sexp_range_exception(ctx, str, start, end); + res = sexp_make_string(ctx, sexp_fx_sub(end, start), SEXP_VOID); + memcpy(sexp_string_data(res), + sexp_string_data(str)+sexp_unbox_fixnum(start), + sexp_string_length(res)); + sexp_string_data(res)[sexp_string_length(res)] = '\0'; + return res; +} + +sexp sexp_string_concatenate_op (sexp ctx sexp_api_params(self, n), sexp str_ls, sexp sep) { + sexp res, ls; + sexp_uint_t len=0, i=0, sep_len=0; + char *p, *csep; + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls), i++) + if (! sexp_stringp(sexp_car(ls))) + return sexp_type_exception(ctx, self, SEXP_STRING, sexp_car(ls)); + else + len += sexp_string_length(sexp_car(ls)); + if (sexp_stringp(sep) && ((sep_len=sexp_string_length(sep)) > 0)) { + csep = sexp_string_data(sep); + len += sep_len*(i-1); + } + res = sexp_make_string(ctx, sexp_make_fixnum(len), SEXP_VOID); + p = sexp_string_data(res); + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) { + len = sexp_string_length(sexp_car(ls)); + memcpy(p, sexp_string_data(sexp_car(ls)), len); + p += len; + if (sep_len && sexp_pairp(sexp_cdr(ls))) { + memcpy(p, csep, sep_len); + p += sep_len; + } + } + *p = '\0'; + return res; +} + +#define FNV_PRIME 16777619 +#define FNV_OFFSET_BASIS 2166136261uL + +#if SEXP_USE_HASH_SYMS + +static sexp_uint_t sexp_string_hash(const char *str, sexp_sint_t len, + sexp_uint_t acc) { + for ( ; len; len--) {acc *= FNV_PRIME; acc ^= *str++;} + return acc; +} + +#endif + +sexp sexp_intern(sexp ctx, const char *str, sexp_sint_t len) { +#if SEXP_USE_HUFF_SYMS + struct sexp_huff_entry he; + sexp_uint_t space=3, newbits; + char c; +#endif + sexp_uint_t res=FNV_OFFSET_BASIS, bucket, i=0; + const char *p=str; + sexp ls, tmp; + sexp_gc_var1(sym); + + if (len < 0) len = strlen(str); + +#if SEXP_USE_HUFF_SYMS + res = 0; + for ( ; i 127) + goto normal_intern; + he = huff_table[(unsigned char)c]; + newbits = he.len; + if ((space+newbits) > (sizeof(sexp)*8)) + goto normal_intern; + res |= (((sexp_uint_t) he.bits) << space); + space += newbits; + } + return (sexp) (res + SEXP_ISYMBOL_TAG); + + normal_intern: +#endif +#if SEXP_USE_HASH_SYMS + bucket = (sexp_string_hash(p, len-i, res) % SEXP_SYMBOL_TABLE_SIZE); +#else + bucket = 0; +#endif + for (ls=sexp_context_symbols(ctx)[bucket]; sexp_pairp(ls); ls=sexp_cdr(ls)) + if ((sexp_symbol_length(tmp=sexp_car(ls)) == len) + && ! strncmp(str, sexp_symbol_data(tmp), len)) + return sexp_car(ls); + + /* not found, make a new symbol */ + sexp_gc_preserve1(ctx, sym); + sym = sexp_c_string(ctx, str, len); + if (sexp_exceptionp(sym)) return sym; +#if ! SEXP_USE_PACKED_STRINGS + sym = sexp_string_bytes(sym); +#endif + sexp_pointer_tag(sym) = SEXP_SYMBOL; + sexp_push(ctx, sexp_context_symbols(ctx)[bucket], sym); + sexp_gc_release1(ctx); + return sym; +} + +sexp sexp_string_to_symbol_op (sexp ctx sexp_api_params(self, n), sexp str) { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + return sexp_intern(ctx, sexp_string_data(str), sexp_string_length(str)); +} + +sexp sexp_make_vector_op (sexp ctx sexp_api_params(self, n), sexp len, sexp dflt) { + sexp vec, *x; + int i, clen = sexp_unbox_fixnum(len); + if (! clen) return sexp_global(ctx, SEXP_G_EMPTY_VECTOR); + vec = sexp_alloc_tagged(ctx, sexp_sizeof(vector) + clen*sizeof(sexp), + SEXP_VECTOR); + if (sexp_exceptionp(vec)) return vec; + x = sexp_vector_data(vec); + for (i=0; i= len) return 0; + if (n > (len - pos)) n = (len - pos); + memcpy(dst, sexp_string_data(sexp_stream_buf(vec))+pos, n); + sexp_stream_pos(vec) = sexp_make_fixnum(n); + return n; +} + +int sstream_write (void *vec, const char *src, int n) { + sexp_uint_t len, pos, newpos; + sexp newbuf; + len = sexp_unbox_fixnum(sexp_stream_size(vec)); + pos = sexp_unbox_fixnum(sexp_stream_pos(vec)); + newpos = pos+n; + if (newpos >= len) { + newbuf = sexp_make_string(sexp_stream_ctx(vec), + sexp_make_fixnum(newpos*2), + SEXP_VOID); + memcpy(sexp_string_data(newbuf), + sexp_string_data(sexp_stream_buf(vec)), + pos); + sexp_stream_buf(vec) = newbuf; + sexp_stream_size(vec) = sexp_make_fixnum(newpos*2); + } + memcpy(sexp_string_data(sexp_stream_buf(vec))+pos, src, n); + sexp_stream_pos(vec) = sexp_make_fixnum(newpos); + return n; +} + +off_t sstream_seek (void *vec, off_t offset, int whence) { + sexp_sint_t pos; + if (whence == SEEK_SET) { + pos = offset; + } else if (whence == SEEK_CUR) { + pos = sexp_unbox_fixnum(sexp_stream_pos(vec)) + offset; + } else { /* SEEK_END */ + pos = sexp_unbox_fixnum(sexp_stream_size(vec)) + offset; + } + sexp_stream_pos(vec) = sexp_make_fixnum(pos); + return pos; +} + +sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { + FILE *in; + sexp res; + sexp_gc_var1(cookie); + sexp_gc_preserve1(ctx, cookie); + cookie = sexp_make_vector(ctx, sexp_make_fixnum(4), SEXP_VOID); + sexp_stream_ctx(cookie) = ctx; + sexp_stream_buf(cookie) = str; + sexp_stream_size(cookie) = sexp_make_fixnum(sexp_string_length(str)); + sexp_stream_pos(cookie) = SEXP_ZERO; + in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL); + res = sexp_make_input_port(ctx, in, SEXP_FALSE); + sexp_port_cookie(res) = cookie; + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) { + FILE *out; + sexp res, size; + sexp_gc_var1(cookie); + sexp_gc_preserve1(ctx, cookie); + size = sexp_make_fixnum(SEXP_INIT_STRING_PORT_SIZE); + cookie = sexp_make_vector(ctx, sexp_make_fixnum(4), SEXP_VOID); + sexp_stream_ctx(cookie) = ctx; + sexp_stream_buf(cookie) = sexp_make_string(ctx, size, SEXP_VOID); + sexp_stream_size(cookie) = size; + sexp_stream_pos(cookie) = SEXP_ZERO; + out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL); + res = sexp_make_output_port(ctx, out, SEXP_FALSE); + sexp_port_cookie(res) = cookie; + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port) { + sexp cookie = sexp_port_cookie(port); + fflush(sexp_port_stream(port)); + return sexp_substring(ctx, + sexp_stream_buf(cookie), + SEXP_ZERO, + sexp_stream_pos(cookie)); +} + +#else + +sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { + FILE *in; + sexp res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + if (sexp_string_length(str) == 0) + in = fopen("/dev/null", "r"); + else + in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r"); + if (in) { + res = sexp_make_input_port(ctx, in, SEXP_FALSE); + if (sexp_string_length(str) == 0) + sexp_port_name(res) = sexp_c_string(ctx, "/dev/null", -1); + sexp_port_cookie(res) = str; /* for gc preservation */ + } else { + res = sexp_user_exception(ctx, SEXP_FALSE, "couldn't open string", str); + } + return res; +} + +sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) { + sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE); + sexp_port_stream(res) + = open_memstream(&sexp_port_buf(res), &sexp_port_size(res)); + return res; +} + +sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port) { + fflush(sexp_port_stream(port)); + return sexp_c_string(ctx, sexp_port_buf(port), sexp_port_size(port)); +} + +#endif + +#else + +#define SEXP_PORT_BUFFER_SIZE 4096 + +int sexp_buffered_read_char (sexp ctx, sexp p) { + if (sexp_port_offset(p) < sexp_port_size(p)) { + return sexp_port_buf(p)[sexp_port_offset(p)++]; + } else if (! sexp_port_stream(p)) { + return EOF; + } else { + sexp_port_size(p) + = fread(sexp_port_buf(p), 1, SEXP_PORT_BUFFER_SIZE, sexp_port_stream(p)); + sexp_port_offset(p) = 0; + return ((sexp_port_offset(p) < sexp_port_size(p)) + ? sexp_port_buf(p)[sexp_port_offset(p)++] : EOF); + } +} + +sexp sexp_buffered_write_char (sexp ctx, int c, sexp p) { + if (sexp_port_offset(p) >= sexp_port_size(p)) + sexp_buffered_flush(ctx, p); + sexp_port_buf(p)[sexp_port_offset(p)++] = c; + return SEXP_VOID; +} + +sexp sexp_buffered_write_string_n (sexp ctx, const char *str, + sexp_uint_t len, sexp p) { + if (sexp_port_offset(p) >= sexp_port_size(p)) + sexp_buffered_flush(ctx, p); + memcpy(sexp_port_buf(p)+sexp_port_offset(p), str, len); + sexp_port_offset(p) += len; + return SEXP_VOID; +} + +sexp sexp_buffered_write_string (sexp ctx, const char *str, sexp p) { + return sexp_buffered_write_string_n(ctx, str, strlen(str), p); +} + +sexp sexp_buffered_flush (sexp ctx, sexp p) { + sexp_gc_var1(tmp); + if (! sexp_oportp(p)) + return sexp_type_exception(ctx, NULL, SEXP_OPORT, p); + if (! sexp_port_openp(p)) + return sexp_user_exception(ctx, SEXP_FALSE, "port is closed", p); + else { + if (sexp_port_stream(p)) { + fwrite(sexp_port_buf(p), 1, sexp_port_offset(p), sexp_port_stream(p)); + fflush(sexp_port_stream(p)); + } else if (sexp_port_offset(p) > 0) { + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p)); + sexp_push(ctx, sexp_port_cookie(p), tmp); + sexp_gc_release1(ctx); + } + sexp_port_offset(p) = 0; + return SEXP_VOID; + } +} + +sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { + sexp res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + res = sexp_make_input_port(ctx, NULL, SEXP_FALSE); + if (sexp_exceptionp(res)) return res; + sexp_port_cookie(res) = str; + sexp_port_buf(res) = sexp_string_data(str); + sexp_port_offset(res) = 0; + sexp_port_size(res) = sexp_string_length(str); + return res; +} + +sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) { + sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE); + if (sexp_exceptionp(res)) return res; + sexp_port_buf(res) = (char*) malloc(SEXP_PORT_BUFFER_SIZE); + sexp_port_size(res) = SEXP_PORT_BUFFER_SIZE; + sexp_port_offset(res) = 0; + sexp_port_cookie(res) = SEXP_NULL; + return res; +} + +sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp out) { + sexp res; + sexp_gc_var2(ls, tmp); + sexp_gc_preserve2(ctx, ls, tmp); + if (sexp_port_offset(out) > 0) { + tmp = sexp_c_string(ctx, sexp_port_buf(out), sexp_port_offset(out)); + ls = sexp_cons(ctx, tmp, sexp_port_cookie(out)); + } else { + ls = sexp_port_cookie(out); + } + res = sexp_string_concatenate(ctx, ls, SEXP_FALSE); + sexp_gc_release2(ctx); + return res; +} + +#endif + +sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { + sexp p = sexp_alloc_type(ctx, port, SEXP_IPORT); + if (sexp_exceptionp(p)) return p; + sexp_port_stream(p) = in; + sexp_port_name(p) = name; + sexp_port_line(p) = 1; + sexp_port_buf(p) = NULL; + sexp_port_openp(p) = 1; + sexp_port_no_closep(p) = 0; + sexp_port_sourcep(p) = 0; + sexp_port_cookie(p) = SEXP_VOID; + return p; +} + +sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) { + sexp p = sexp_make_input_port(ctx, out, name); + if (sexp_exceptionp(p)) return p; + sexp_pointer_tag(p) = SEXP_OPORT; + return p; +} + +#define NUMBUF_LEN 32 + +sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { +#if SEXP_USE_HUFF_SYMS + unsigned long res, c; +#endif + unsigned long len; + long i=0; + double f; + sexp x, *elts; + char *str=NULL, numbuf[NUMBUF_LEN]; + + if (! obj) { + sexp_write_string(ctx, "#", out); /* shouldn't happen */ + } else if (sexp_pointerp(obj)) { + switch (sexp_pointer_tag(obj)) { + case SEXP_PAIR: + sexp_write_char(ctx, '(', out); + sexp_write_one(ctx, sexp_car(obj), out); + for (x=sexp_cdr(obj); sexp_pairp(x); x=sexp_cdr(x)) { + sexp_write_char(ctx, ' ', out); + sexp_write_one(ctx, sexp_car(x), out); + } + if (! sexp_nullp(x)) { + sexp_write_string(ctx, " . ", out); + sexp_write_one(ctx, x, out); + } + sexp_write_char(ctx, ')', out); + break; + case SEXP_VECTOR: + len = sexp_vector_length(obj); + elts = sexp_vector_data(obj); + if (len == 0) { + sexp_write_string(ctx, "#()", out); + } else { + sexp_write_string(ctx, "#(", out); + sexp_write_one(ctx, elts[0], out); + for (i=1; i", out); + break; + case SEXP_SYNCLO: + sexp_write_string(ctx, "#", out); + break; + case SEXP_TYPE: + sexp_write_string(ctx, "#", out); + break; + case SEXP_STRING: + sexp_write_char(ctx, '"', out); + i = sexp_string_length(obj); + str = sexp_string_data(obj); + for ( ; i>0; str++, i--) { + switch (str[0]) { + case '\\': sexp_write_string(ctx, "\\\\", out); break; + case '"': sexp_write_string(ctx, "\\\"", out); break; + case '\n': sexp_write_string(ctx, "\\n", out); break; + case '\r': sexp_write_string(ctx, "\\r", out); break; + case '\t': sexp_write_string(ctx, "\\t", out); break; + default: sexp_write_char(ctx, str[0], out); + } + } + sexp_write_char(ctx, '"', out); + break; + case SEXP_SYMBOL: + i = sexp_symbol_length(obj); + str = sexp_symbol_data(obj); + for ( ; i>0; str++, i--) { + if ((str[0] == '\\') || is_separator(str[0])) + sexp_write_char(ctx, '\\', out); + sexp_write_char(ctx, str[0], out); + } + break; +#if SEXP_USE_BIGNUMS + case SEXP_BIGNUM: + sexp_write_bignum(ctx, obj, out, 10); + break; +#endif + case SEXP_OPCODE: + sexp_write_string(ctx, "#', out); + break; + default: + i = sexp_pointer_tag(obj); + sexp_write_string(ctx, "#<", out); + sexp_write_string(ctx, + (i < sexp_context_num_types(ctx)) + ? sexp_type_name_by_index(ctx, i) : "invalid", + out); + sexp_write_char(ctx, '>', out); + break; + } + } else if (sexp_fixnump(obj)) { + snprintf(numbuf, NUMBUF_LEN, "%ld", (long)sexp_unbox_fixnum(obj)); + sexp_write_string(ctx, numbuf, out); +#if SEXP_USE_IMMEDIATE_FLONUMS + } else if (sexp_flonump(obj)) { + f = sexp_flonum_value(obj); +#if SEXP_USE_INFINITIES + if (isinf(f) || isnan(f)) { + numbuf[0] = (isinf(f) && f < 0 ? '-' : '+'); + strcpy(numbuf+1, isinf(f) ? "inf.0" : "nan.0"); + } else +#endif + { + i = snprintf(numbuf, NUMBUF_LEN, "%.8g", f); + if (f == trunc(f) && ! strchr(numbuf, '.')) { + numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0'; + } + } + sexp_write_string(ctx, numbuf, out); +#endif + } else if (sexp_charp(obj)) { + if (obj == sexp_make_character(' ')) + sexp_write_string(ctx, "#\\space", out); + else if (obj == sexp_make_character('\n')) + sexp_write_string(ctx, "#\\newline", out); + else if (obj == sexp_make_character('\r')) + sexp_write_string(ctx, "#\\return", out); + else if (obj == sexp_make_character('\t')) + sexp_write_string(ctx, "#\\tab", out); + else if ((33 <= sexp_unbox_character(obj)) + && (sexp_unbox_character(obj) < 127)) { + sexp_write_string(ctx, "#\\", out); + sexp_write_char(ctx, sexp_unbox_character(obj), out); + } else { + sexp_write_string(ctx, "#\\x", out); + c = sexp_unbox_character(obj); + if (c >= 0x100) { + if (c >= 0x10000) { + sexp_write_char(ctx, hex_digit((c>>20)&0x0F), out); + sexp_write_char(ctx, hex_digit((c>>16)&0x0F), out); + } + sexp_write_char(ctx, hex_digit((c>>12)&0x0F), out); + sexp_write_char(ctx, hex_digit((c>>8)&0x0F), out); + } + sexp_write_char(ctx, hex_digit((c>>4)&0x0F), out); + sexp_write_char(ctx, hex_digit(c&0x0F), out); + } + } else if (sexp_symbolp(obj)) { + +#if SEXP_USE_HUFF_SYMS + if (sexp_isymbolp(obj)) { + c = ((sexp_uint_t)obj)>>3; + while (c) { +#include "opt/sexp-unhuff.c" + sexp_write_char(ctx, res, out); + } + } +#endif + + } else { + switch ((sexp_uint_t) obj) { + case (sexp_uint_t) SEXP_NULL: + sexp_write_string(ctx, "()", out); break; + case (sexp_uint_t) SEXP_TRUE: + sexp_write_string(ctx, "#t", out); break; + case (sexp_uint_t) SEXP_FALSE: + sexp_write_string(ctx, "#f", out); break; + case (sexp_uint_t) SEXP_EOF: + sexp_write_string(ctx, "#", out); break; + case (sexp_uint_t) SEXP_UNDEF: + case (sexp_uint_t) SEXP_VOID: + sexp_write_string(ctx, "#", out); break; + default: + sexp_write_string(ctx, "#", out); + } + } + return SEXP_VOID; +} + +sexp sexp_write_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) { + sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out); + return sexp_write_one(ctx, obj, out); +} + +sexp sexp_display_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) { + sexp res=SEXP_VOID; + sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out); + if (sexp_stringp(obj)) + sexp_write_string(ctx, sexp_string_data(obj), out); + else if (sexp_charp(obj)) + sexp_write_char(ctx, sexp_unbox_character(obj), out); + else + res = sexp_write_one(ctx, obj, out); + return res; +} + +sexp sexp_flush_output_op (sexp ctx sexp_api_params(self, n), sexp out) { + sexp_flush(ctx, out); + return SEXP_VOID; +} + +#define INIT_STRING_BUFFER_SIZE 128 + +sexp sexp_read_string (sexp ctx, sexp in) { + int c, i=0, size=INIT_STRING_BUFFER_SIZE; + char initbuf[INIT_STRING_BUFFER_SIZE]; + char *buf=initbuf, *tmp; + sexp res; + + for (c = sexp_read_char(ctx, in); c != '"'; c = sexp_read_char(ctx, in)) { + if (c == '\\') { + c = sexp_read_char(ctx, in); + switch (c) { + case 'n': c = '\n'; break; + case 'r': c = '\r'; break; + case 't': c = '\t'; break; + case 'x': + c = sexp_read_char(ctx, in); + if (isxdigit(c)) { + c = digit_value(c)*16 + digit_value(sexp_read_char(ctx, in)); + } else { + sexp_push_char(ctx, c, in); c = 'x'; + } + } + } + if (c == EOF) { + res = sexp_read_error(ctx, "premature end of string", SEXP_NULL, in); + break; + } + buf[i++] = c; + if (i >= size) { /* expand buffer w/ malloc(), later free() it */ + tmp = (char*) malloc(size*2); + memcpy(tmp, buf, i); + if (size != INIT_STRING_BUFFER_SIZE) free(buf); + buf = tmp; + size *= 2; + } + } + + buf[i] = '\0'; + res = sexp_c_string(ctx, buf, i); + if (size != INIT_STRING_BUFFER_SIZE) free(buf); + return res; +} + +sexp sexp_read_symbol (sexp ctx, sexp in, int init, int internp) { + int c, i=0, size=INIT_STRING_BUFFER_SIZE; + char initbuf[INIT_STRING_BUFFER_SIZE]; + char *buf=initbuf, *tmp; + sexp res; + + if (init != EOF) + buf[i++] = init; + + for (c = sexp_read_char(ctx, in); c != '"'; c = sexp_read_char(ctx, in)) { + if (c == '\\') c = sexp_read_char(ctx, in); + if (c == EOF || is_separator(c)) { + sexp_push_char(ctx, c, in); + break; + } + buf[i++] = c; + if (i >= size) { /* expand buffer w/ malloc(), later free() it */ + tmp = (char*) malloc(size*2); + memcpy(tmp, buf, i); + if (size != INIT_STRING_BUFFER_SIZE) free(buf); + buf = tmp; + size *= 2; + } + } + + buf[i] = '\0'; + res = (internp ? sexp_intern(ctx, buf, i) : sexp_c_string(ctx, buf, i)); + if (size != INIT_STRING_BUFFER_SIZE) free(buf); + return res; +} + +sexp sexp_read_float_tail (sexp ctx, sexp in, double whole, int negp) { + sexp exponent=SEXP_VOID; + double res=0.0, scale=0.1, e=0.0; + int c; + for (c=sexp_read_char(ctx, in); + isdigit(c); + c=sexp_read_char(ctx, in), scale*=0.1) + res += digit_value(c)*scale; + if (c=='e' || c=='E') { + exponent = sexp_read_number(ctx, in, 10); + if (sexp_exceptionp(exponent)) return exponent; + e = (sexp_fixnump(exponent) ? sexp_unbox_fixnum(exponent) + : sexp_flonump(exponent) ? sexp_flonum_value(exponent) : 0.0); + } else if ((c!=EOF) && ! is_separator(c)) { + return sexp_read_error(ctx, "invalid numeric syntax", + sexp_make_character(c), in); + } else { + sexp_push_char(ctx, c, in); + } + res = (whole + res) * pow(10, e); + if (negp) res *= -1; + return sexp_make_flonum(ctx, res); +} + +sexp sexp_read_number (sexp ctx, sexp in, int base) { + sexp den; + sexp_uint_t res = 0, tmp; + int c, digit, negativep = 0; + + c = sexp_read_char(ctx, in); + if (c == '-') { + negativep = 1; + c = sexp_read_char(ctx, in); + } + + for ( ; isxdigit(c); c=sexp_read_char(ctx, in)) { + digit = digit_value(c); + if ((digit < 0) || (digit >= base)) + break; + tmp = res * base + digit; +#if SEXP_USE_BIGNUMS + if ((tmp < res) || (tmp > SEXP_MAX_FIXNUM)) { + sexp_push_char(ctx, c, in); + return sexp_read_bignum(ctx, in, res, (negativep ? -1 : 1), base); + } +#endif + res = tmp; + } + + if (c=='.' || c=='e' || c=='E') { + if (base != 10) + return sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in); + if (c!='.') sexp_push_char(ctx, c, in); + return sexp_read_float_tail(ctx, in, res, negativep); + } else if (c=='/') { + den = sexp_read_number(ctx, in, base); + if (! sexp_fixnump(den)) + return (sexp_exceptionp(den) + ? den : sexp_read_error(ctx, "invalid rational syntax", den, in)); + return sexp_make_flonum(ctx, (double)(negativep ? -res : res) + / (double)sexp_unbox_fixnum(den)); + } else { + if ((c!=EOF) && ! is_separator(c)) + return sexp_read_error(ctx, "invalid numeric syntax", + sexp_make_character(c), in); + sexp_push_char(ctx, c, in); + } + + return sexp_make_fixnum(negativep ? -res : res); +} + +sexp sexp_read_raw (sexp ctx, sexp in) { + char *str; + int c1, c2, line; + sexp tmp2; + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, tmp); + + scan_loop: + switch (c1 = sexp_read_char(ctx, in)) { + case EOF: + if (sexp_at_eofp(in)) + res = SEXP_EOF; + else + goto scan_loop; + break; + case ';': + while ((c1 = sexp_read_char(ctx, in)) != EOF) + if (c1 == '\n') + break; + /* ... FALLTHROUGH ... */ + case '\n': + sexp_port_line(in)++; + goto scan_loop; + case ' ': + case '\t': + case '\r': + goto scan_loop; + case '\'': + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUOTE_SYMBOL), res); + break; + case '`': + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL), res); + break; + case ',': + if ((c1 = sexp_read_char(ctx, in)) == '@') { + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL), res); + } else { + sexp_push_char(ctx, c1, in); + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_UNQUOTE_SYMBOL), res); + } + break; + case '"': + res = sexp_read_string(ctx, in); + break; + case '(': + line = (sexp_port_sourcep(in) ? sexp_port_line(in) : -1); + res = SEXP_NULL; + tmp = sexp_read_raw(ctx, in); + while ((tmp != SEXP_EOF) && (tmp != SEXP_CLOSE) && (tmp != SEXP_RAWDOT)) { + if (sexp_exceptionp(tmp)) { + res = tmp; + break; + } + res = sexp_cons(ctx, tmp, res); + if (sexp_port_sourcep(in) && (line >= 0)) + sexp_pair_source(res) + = sexp_cons(ctx, sexp_port_name(in), sexp_make_fixnum(line)); + tmp = sexp_read_raw(ctx, in); + } + if (! sexp_exceptionp(res)) { + if (tmp == SEXP_RAWDOT) { /* dotted list */ + if (res == SEXP_NULL) { + res = sexp_read_error(ctx, "dot before any elements in list", + SEXP_NULL, in); + } else { + tmp = sexp_read_raw(ctx, in); + if (sexp_exceptionp(tmp)) { + res = tmp; + } else if (tmp == SEXP_CLOSE) { + res = sexp_read_error(ctx, "no final element in list after dot", + SEXP_NULL, in); + } else if (sexp_read_raw(ctx, in) != SEXP_CLOSE) { + res = sexp_read_error(ctx, "multiple tokens in dotted tail", + SEXP_NULL, in); + } else { + tmp2 = res; + res = sexp_nreverse(ctx, res); + sexp_cdr(tmp2) = tmp; + } + } + } else if (tmp == SEXP_CLOSE) { + res = (sexp_pairp(res) ? sexp_nreverse(ctx, res) : res); + } else { + res = sexp_read_error(ctx, "missing trailing ')'", SEXP_NULL, in); + } + } + if ((line >= 0) && sexp_pairp(res)) { + sexp_pair_source(res) + = sexp_cons(ctx, sexp_port_name(in), sexp_make_fixnum(line)); + } + if (sexp_port_sourcep(in)) + for (tmp=res; sexp_pairp(tmp); tmp=sexp_cdr(tmp)) + sexp_immutablep(tmp) = 1; + break; + case '#': + switch (c1=sexp_read_char(ctx, in)) { + case 'b': + res = sexp_read_number(ctx, in, 2); break; + case 'o': + res = sexp_read_number(ctx, in, 8); break; + case 'd': + res = sexp_read_number(ctx, in, 10); break; + case 'x': + res = sexp_read_number(ctx, in, 16); break; + case 'e': + res = sexp_read(ctx, in); + if (sexp_flonump(res)) + res = sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(res)); + break; + case 'i': + res = sexp_read(ctx, in); + if (sexp_fixnump(res)) + res = sexp_make_flonum(ctx, sexp_unbox_fixnum(res)); + break; + case 'f': case 'F': + case 't': case 'T': + c2 = sexp_read_char(ctx, in); + if (c2 == EOF || is_separator(c2)) { + res = (tolower(c1) == 't' ? SEXP_TRUE : SEXP_FALSE); + sexp_push_char(ctx, c2, in); + } else { + tmp = sexp_list2(ctx, sexp_make_character(c1), sexp_make_character(c2)); + res = sexp_read_error(ctx, "invalid syntax #%c%c", tmp, in); + } + break; +/* case '0': case '1': case '2': case '3': case '4': */ +/* case '5': case '6': case '7': case '8': case '9': */ + case ';': + tmp = sexp_read_raw(ctx, in); /* discard */ + if (sexp_exceptionp(tmp)) + res = tmp; + else + goto scan_loop; + break; + case '!': + while ((c1 = sexp_read_char(ctx, in)) != EOF) + if (c1 == '\n') + break; + sexp_port_line(in)++; + goto scan_loop; + case '\\': + c1 = sexp_read_char(ctx, in); + res = sexp_read_symbol(ctx, in, c1, 0); + if (sexp_stringp(res)) { + str = sexp_string_data(res); + if (sexp_string_length(res) == 0) + res = + sexp_read_error(ctx, "unexpected end of character literal", + SEXP_NULL, in); + if (sexp_string_length(res) == 1) { + res = sexp_make_character(c1); + } else if ((c1 == 'x' || c1 == 'X') && + (isxdigit)(str[1]) && (isxdigit)(str[2]) && str[3] == '\0') { + res = sexp_make_character(16 * digit_value(str[1]) + + digit_value(str[2])); + } else { + if (strcasecmp(str, "space") == 0) + res = sexp_make_character(' '); + else if (strcasecmp(str, "newline") == 0) + res = sexp_make_character('\n'); + else if (strcasecmp(str, "return") == 0) + res = sexp_make_character('\r'); + else if (strcasecmp(str, "tab") == 0) + res = sexp_make_character('\t'); + else { + tmp = sexp_c_string(ctx, str, -1); + res = sexp_read_error(ctx, "unknown character name", tmp, in); + } + } + } + break; + case '(': + sexp_push_char(ctx, c1, in); + res = sexp_read(ctx, in); + if (sexp_not(sexp_listp(ctx, res))) { + if (! sexp_exceptionp(res)) { + res = sexp_read_error(ctx, "dotted list not allowed in vector syntax", + SEXP_NULL, + in); + } + } else { + res = sexp_list_to_vector(ctx, res); + } + break; + default: + res = sexp_read_error(ctx, "invalid # syntax", + sexp_make_character(c1), in); + } + break; + case '.': + c1 = sexp_read_char(ctx, in); + sexp_push_char(ctx, c1, in); + if (c1 == EOF || is_separator(c1)) { + res = SEXP_RAWDOT; + } else if (isdigit(c1)) { + res = sexp_read_float_tail(ctx, in, 0, 0); + } else { + res = sexp_read_symbol(ctx, in, '.', 1); + } + break; + case ')': + res = SEXP_CLOSE; + break; + case '+': + case '-': + c2 = sexp_read_char(ctx, in); + if (c2 == '.' || isdigit(c2)) { + sexp_push_char(ctx, c2, in); + res = sexp_read_number(ctx, in, 10); + if ((c1 == '-') && ! sexp_exceptionp(res)) { +#if SEXP_USE_FLONUMS + if (sexp_flonump(res)) +#if SEXP_USE_IMMEDIATE_FLONUMS + res = sexp_make_flonum(ctx, -1 * sexp_flonum_value(res)); +#else + sexp_flonum_value(res) = -1 * sexp_flonum_value(res); +#endif + else +#endif +#if SEXP_USE_BIGNUMS + if (sexp_bignump(res)) { + if ((sexp_bignum_hi(res) == 1) + && (sexp_bignum_data(res)[0] == (SEXP_MAX_FIXNUM+1))) + res = sexp_make_fixnum(-sexp_bignum_data(res)[0]); + else + sexp_bignum_sign(res) = -sexp_bignum_sign(res); + } else +#endif + res = sexp_fx_mul(res, SEXP_NEG_ONE); + } + } else { + sexp_push_char(ctx, c2, in); + res = sexp_read_symbol(ctx, in, c1, 1); +#if SEXP_USE_INFINITIES + if (res == sexp_intern(ctx, "+inf.0", -1)) + res = sexp_make_flonum(ctx, sexp_pos_infinity); + else if (res == sexp_intern(ctx, "-inf.0", -1)) + res = sexp_make_flonum(ctx, sexp_neg_infinity); + else if (res == sexp_intern(ctx, "+nan.0", -1)) + res = sexp_make_flonum(ctx, sexp_nan); +#endif + } + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + sexp_push_char(ctx, c1, in); + res = sexp_read_number(ctx, in, 10); + break; + default: + res = sexp_read_symbol(ctx, in, c1, 1); + break; + } + + if (sexp_port_sourcep(in) && sexp_pointerp(res)) + sexp_immutablep(res) = 1; + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_read_op (sexp ctx sexp_api_params(self, n), sexp in) { + sexp res; + sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in); + res = sexp_read_raw(ctx, in); + if (res == SEXP_CLOSE) + res = sexp_read_error(ctx, "too many ')'s", SEXP_NULL, in); + if (res == SEXP_RAWDOT) + res = sexp_read_error(ctx, "unexpected '.'", SEXP_NULL, in); + return res; +} + +sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len) { + sexp res; + sexp_gc_var2(s, in); + sexp_gc_preserve2(ctx, s, in); + s = sexp_c_string(ctx, str, len); + in = sexp_make_input_string_port(ctx, s); + res = sexp_read(ctx, in); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_string_to_number_op (sexp ctx sexp_api_params(self, n), sexp str, sexp b) { + int base; + sexp_gc_var1(in); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, b); + if (((base=sexp_unbox_fixnum(b)) < 2) || (base > 36)) + return sexp_user_exception(ctx, self, "invalid numeric base", b); + sexp_gc_preserve1(ctx, in); + in = sexp_make_input_string_port(ctx, str); + in = ((sexp_string_data(str)[0] == '#') ? + sexp_read(ctx, in) : sexp_read_number(ctx, in, base)); + sexp_gc_release1(ctx); + return sexp_numberp(in) ? in : SEXP_FALSE; +} + +sexp sexp_write_to_string (sexp ctx, sexp obj) { + sexp str; + sexp_gc_var1(out); + sexp_gc_preserve1(ctx, out); + out = sexp_make_output_string_port(ctx); + str = sexp_write(ctx, obj, out); + if (! sexp_exceptionp(str)) + str = sexp_get_output_string(ctx, out); + sexp_gc_release1(ctx); + return str; +} + +void sexp_init (void) { +#if SEXP_USE_GLOBAL_SYMBOLS + int i; +#endif + if (! sexp_initialized_p) { + sexp_initialized_p = 1; +#if SEXP_USE_BOEHM + GC_init(); +#if SEXP_USE_GLOBAL_SYMBOLS + GC_add_roots((char*)&sexp_symbol_table, + ((char*)&sexp_symbol_table)+sizeof(sexp_symbol_table)+1); +#endif +#elif ! SEXP_USE_MALLOC + sexp_gc_init(); +#endif +#if SEXP_USE_GLOBAL_SYMBOLS + for (i=0; i 6 diff --git a/tests/basic/test00-fact-3.scm b/tests/basic/test00-fact-3.scm new file mode 100644 index 00000000..41d9c20e --- /dev/null +++ b/tests/basic/test00-fact-3.scm @@ -0,0 +1,14 @@ + +(define (fact-helper x res) + (if (= x 0) + res + (fact-helper (- x 1) (* res x)))) + +(define (fact x) + (fact-helper x 1)) + +(display "(fact 3) => ") +(write (fact 3)) +(newline) + + diff --git a/tests/basic/test01-apply.res b/tests/basic/test01-apply.res new file mode 100644 index 00000000..c5b83af4 --- /dev/null +++ b/tests/basic/test01-apply.res @@ -0,0 +1,8 @@ +11 +(11 10 9 8 7 6 5 4 3 2 1) +(1 2 3 4) +100 +100 +100 +100 +100 diff --git a/tests/basic/test01-apply.scm b/tests/basic/test01-apply.scm new file mode 100644 index 00000000..183a591c --- /dev/null +++ b/tests/basic/test01-apply.scm @@ -0,0 +1,18 @@ + +(define foo + (lambda (a b c d e f g h) + (+ (+ (* a b) (* c d)) (+ (* e f) (* g h))))) + +(define (writeln x) + (write x) + (newline)) + +(writeln (length (reverse (list 1 2 3 4 5 6 7 8 9 10 11)))) +(writeln (reverse (list 1 2 3 4 5 6 7 8 9 10 11))) +(writeln (append (list 1 2) (list 3 4))) +(writeln (foo 1 2 3 4 5 6 7 8)) +(writeln (apply foo (list 1 2 3 4 5 6 7 8))) +(writeln (apply foo 1 (list 2 3 4 5 6 7 8))) +(writeln (apply foo 1 2 3 4 (list 5 6 7 8))) +(writeln (apply foo 1 2 3 4 5 (list 6 7 8))) + diff --git a/tests/basic/test02-closure.res b/tests/basic/test02-closure.res new file mode 100644 index 00000000..4d764d20 --- /dev/null +++ b/tests/basic/test02-closure.res @@ -0,0 +1,6 @@ +1 +2 +101 +102 +3 +103 diff --git a/tests/basic/test02-closure.scm b/tests/basic/test02-closure.scm new file mode 100644 index 00000000..6ed987fe --- /dev/null +++ b/tests/basic/test02-closure.scm @@ -0,0 +1,16 @@ + +(define (make-counter n) + (lambda () + (set! n (+ n 1)) + n)) + +(define f (make-counter 0)) +(define g (make-counter 100)) + +(write (f)) (newline) +(write (f)) (newline) +(write (g)) (newline) +(write (g)) (newline) +(write (f)) (newline) +(write (g)) (newline) + diff --git a/tests/basic/test03-nested-closure.res b/tests/basic/test03-nested-closure.res new file mode 100644 index 00000000..c97c8394 --- /dev/null +++ b/tests/basic/test03-nested-closure.res @@ -0,0 +1 @@ +11357 diff --git a/tests/basic/test03-nested-closure.scm b/tests/basic/test03-nested-closure.scm new file mode 100644 index 00000000..6656bd4e --- /dev/null +++ b/tests/basic/test03-nested-closure.scm @@ -0,0 +1,8 @@ + +((lambda (a b) + ((lambda (c d e) + (write (+ e (* c 1000) (* a 100) (* b 10) d)) + (newline)) + (- a 2) (+ b 2) 10000)) + 3 5) + diff --git a/tests/basic/test04-nested-let.res b/tests/basic/test04-nested-let.res new file mode 100644 index 00000000..c97c8394 --- /dev/null +++ b/tests/basic/test04-nested-let.res @@ -0,0 +1 @@ +11357 diff --git a/tests/basic/test04-nested-let.scm b/tests/basic/test04-nested-let.scm new file mode 100644 index 00000000..584bc6e5 --- /dev/null +++ b/tests/basic/test04-nested-let.scm @@ -0,0 +1,9 @@ + +(let ((a 3) + (b 5)) + (let ((c (- a 2)) + (d (+ b 2)) + (e 10000)) + (write (+ e (* c 1000) (* a 100) (* b 10) d)) + (newline))) + diff --git a/tests/basic/test05-internal-define.res b/tests/basic/test05-internal-define.res new file mode 100644 index 00000000..4edae4cc --- /dev/null +++ b/tests/basic/test05-internal-define.res @@ -0,0 +1 @@ +1000 1003 diff --git a/tests/basic/test05-internal-define.scm b/tests/basic/test05-internal-define.scm new file mode 100644 index 00000000..a5576a63 --- /dev/null +++ b/tests/basic/test05-internal-define.scm @@ -0,0 +1,8 @@ + +(let ((a 1000)) + (define b (+ a 3)) + (write a) + (display " ") + (write b) + (newline)) + diff --git a/tests/basic/test06-letrec.res b/tests/basic/test06-letrec.res new file mode 100644 index 00000000..83d9c566 --- /dev/null +++ b/tests/basic/test06-letrec.res @@ -0,0 +1,4 @@ +7 +#t +#f +#f diff --git a/tests/basic/test06-letrec.scm b/tests/basic/test06-letrec.scm new file mode 100644 index 00000000..a9c01b4e --- /dev/null +++ b/tests/basic/test06-letrec.scm @@ -0,0 +1,15 @@ + +(letrec ((add (lambda (a b) (+ a b)))) + (write (add 3 4)) + (newline)) + +(letrec ((even? (lambda (n) (if (zero? n) #t (odd? (- n 1))))) + (odd? (lambda (n) (if (zero? n) #f (even? (- n 1)))))) + (write (even? 1000)) + (newline) + (write (even? 1001)) + (newline) + (write (odd? 1000)) + (newline) + ) + diff --git a/tests/basic/test07-mutation.res b/tests/basic/test07-mutation.res new file mode 100644 index 00000000..c97c8394 --- /dev/null +++ b/tests/basic/test07-mutation.res @@ -0,0 +1 @@ +11357 diff --git a/tests/basic/test07-mutation.scm b/tests/basic/test07-mutation.scm new file mode 100644 index 00000000..8dacb7fb --- /dev/null +++ b/tests/basic/test07-mutation.scm @@ -0,0 +1,9 @@ + +(let ((a 3) + (b 5)) + (let ((c (- a 2)) + (d (+ b 2)) + (e #f)) + (set! e 10000) + (write (+ e (* c 1000) (* a 100) (* b 10) d)) + (newline))) diff --git a/tests/basic/test08-callcc.res b/tests/basic/test08-callcc.res new file mode 100644 index 00000000..849baeed --- /dev/null +++ b/tests/basic/test08-callcc.res @@ -0,0 +1 @@ +543 diff --git a/tests/basic/test08-callcc.scm b/tests/basic/test08-callcc.scm new file mode 100644 index 00000000..3a5c355e --- /dev/null +++ b/tests/basic/test08-callcc.scm @@ -0,0 +1,34 @@ + +(define fail + (lambda () 999999)) + +(define in-range + (lambda (a b) + (call-with-current-continuation + (lambda (cont) + (enumerate a b cont))))) + +(define enumerate + (lambda (a b cont) + (if (< b a) + (fail) + (let ((save fail)) + (begin + (set! fail + (lambda () + (begin + (set! fail save) + (enumerate (+ a 1) b cont)))) + (cont a)))))) + +(write + (let ((x (in-range 2 9)) + (y (in-range 2 9)) + (z (in-range 2 9))) + (if (= (* x x) + (+ (* y y) (* z z))) + (+ (* x 100) (+ (* y 10) z)) + (fail)))) + +(newline) + diff --git a/tests/basic/test09-hygiene.res b/tests/basic/test09-hygiene.res new file mode 100644 index 00000000..31cd4d7e --- /dev/null +++ b/tests/basic/test09-hygiene.res @@ -0,0 +1,7 @@ +1 +2 +3 +4 +5 +6 +outer diff --git a/tests/basic/test09-hygiene.scm b/tests/basic/test09-hygiene.scm new file mode 100644 index 00000000..820020c1 --- /dev/null +++ b/tests/basic/test09-hygiene.scm @@ -0,0 +1,48 @@ + +(write (or 1)) +(newline) +(write (or #f 2)) +(newline) +(write (or 3 #t)) +(newline) + +(let ((tmp 4)) + (write (or #f tmp)) + (newline)) + +(write + (letrec-syntax + ((myor + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #f + (list (rename 'let) (list (list (rename 'tmp) (cadr expr))) + (list (rename 'if) (rename 'tmp) + (rename 'tmp) + (cons (rename 'myor) (cddr expr))))))))) + (let ((tmp 5)) (myor #f tmp)))) +(newline) + +(define-syntax myor + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #f + (list (rename 'let) (list (list (rename 'tmp) (cadr expr))) + (list (rename 'if) (rename 'tmp) + (rename 'tmp) + (cons (rename 'myor) (cddr expr)))))))) + +(write (let ((tmp 6)) (myor #f tmp))) +(newline) + +(let ((x 'outer)) + (let-syntax ((with-x + (syntax-rules () + ((_ y expr) + (let-syntax ((y (syntax-rules () ((_) x)))) + expr))))) + (let ((x 'inner)) + (write (with-x z (z))) + (newline)))) diff --git a/tests/basic/test10-unhygiene.res b/tests/basic/test10-unhygiene.res new file mode 100644 index 00000000..0d174dc4 --- /dev/null +++ b/tests/basic/test10-unhygiene.res @@ -0,0 +1,6 @@ +1 +1 +1 +6 +7 +8 diff --git a/tests/basic/test10-unhygiene.scm b/tests/basic/test10-unhygiene.scm new file mode 100644 index 00000000..c60a6bca --- /dev/null +++ b/tests/basic/test10-unhygiene.scm @@ -0,0 +1,49 @@ + +(define-syntax aif + (sc-macro-transformer + (lambda (form environment) + (let ((condition + (make-syntactic-closure environment '() (cadr form))) + (consequent + (make-syntactic-closure environment '(it) (caddr form))) + (alternative + (make-syntactic-closure environment '() (cadddr form)))) + `(let ((it ,condition)) + (if it + ,consequent + ,alternative)))))) + +(write (aif 1 it 3)) +(newline) + +(write (let ((it 4)) (aif 1 it 3))) +(newline) + +(write (let ((it 4)) (aif (let ((it 5)) 1) it 3))) +(newline) + +(write (let ((it 4)) (aif (let ((it 5)) 1) (let ((it 6)) it) 3))) +(newline) + +(write + (letrec-syntax + ((myor + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #f + (list (rename 'let) (list (list (rename 'it) (cadr expr))) + (list (rename 'if) (rename 'it) + (rename 'it) + (cons (rename 'myor) (cddr expr))))))))) + (let ((it 7)) (myor #f it)))) +(newline) + +(define-syntax define-foo + (sc-macro-transformer + (lambda (form environment) + (make-syntactic-closure environment '(foo) `(define foo 8))))) + +(define-foo) +(write foo) +(newline) diff --git a/tests/build/build-opts.txt b/tests/build/build-opts.txt new file mode 100644 index 00000000..e6bcd056 --- /dev/null +++ b/tests/build/build-opts.txt @@ -0,0 +1,21 @@ +CPPFLAGS=-DSEXP_USE_MODULES=0 +CPPFLAGS=-DSEXP_USE_DL=0 +CPPFLAGS=-DSEXP_USE_SIMPLIFY=0 +CPPFLAGS=-DSEXP_USE_TYPE_DEFS=0 +SEXP_USE_BOEHM=1 +CPPFLAGS=-DSEXP_USE_DEBUG_GC=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_HEAP=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_TYPES=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_SYMBOLS=1 +CPPFLAGS=-DSEXP_USE_FLONUMS=0 +CPPFLAGS=-DSEXP_USE_IMMEDIATE_FLONUMS=1 +CPPFLAGS=-DSEXP_USE_BIGNUMS=0 +CPPFLAGS=-DSEXP_USE_MATH=0 +CPPFLAGS=-DSEXP_WARN_UNDEFS=0 +CPPFLAGS=-DSEXP_USE_HUFF_SYMS=0 +CPPFLAGS=-DSEXP_USE_HASH_SYMS=0 +CPPFLAGS=-DSEXP_USE_STRING_STREAMS=0 +CPPFLAGS=-DSEXP_USE_AUTOCLOSE_PORTS=0 +CPPFLAGS=-DSEXP_USE_2010_EPOCH=0 +CPPFLAGS=-DSEXP_USE_CHECK_STACK=0 +CPPFLAGS=-DSEXP_USE_NO_FEATURES=1 diff --git a/tests/build/build-tests.sh b/tests/build/build-tests.sh new file mode 100755 index 00000000..1d239629 --- /dev/null +++ b/tests/build/build-tests.sh @@ -0,0 +1,37 @@ +#! /bin/bash + +# test basic build options + +# for bootstrapping reasons this is a shell script, instead of a +# scheme script using (chibi process) + +# we just check each build against r5rs-tests.scm - +# some of the libraries will fail to build (notably +# if modules or user-defined types are disabled). + +BUILDDIR=tests/build +FAILURES=0 +i=0 + +for opts in `cat ${BUILDDIR}/build-opts.txt`; do + make cleaner 2>&1 >/dev/null + if make $opts chibi-scheme 2>&1 >${BUILDDIR}/build${i}-make.out; then + if make test 2>&1 | tee ${BUILDDIR}/build${i}-test.out | grep -q -E 'FAIL|ERROR'; then + echo "[FAIL] ${i}: tests failed with $opts" + FAILURES=$((FAILURES + 1)) + else + echo "[PASS] ${i}: tests passed with $opts" + fi + else + echo "[FAIL] ${i}: couldn't build with $opts" + FAILURES=$((FAILURES + 1)) + fi + i=$((i+1)) +done + +if (( FAILURES == 0 )); then + echo "build-tests: all tests passed" +else + echo "build-tests: ${FAILURES} tests failed" +fi + diff --git a/tests/flonum-tests.scm b/tests/flonum-tests.scm new file mode 100644 index 00000000..5abe4772 --- /dev/null +++ b/tests/flonum-tests.scm @@ -0,0 +1,21 @@ +;;;; these will fail when compiled either without flonums or trig funcs + +(import (chibi test)) + +(test-begin "floating point") + +(test-assert (= -5 (floor -4.3))) +(test-assert (= -4 (ceiling -4.3))) +(test-assert (= -4 (truncate -4.3))) +(test-assert (= -4 (round -4.3))) +(test-assert (= 3 (floor 3.5))) +(test-assert (= 4 (ceiling 3.5))) +(test-assert (= 3 (truncate 3.5))) +(test-assert (= 4 (round 3.5))) + +(test 1124378190243790143.0 (exact->inexact 1124378190243790143)) + +;; (test "1124378190243790143.0" +;; (number->string (exact->inexact 1124378190243790143))) + +(test-end) diff --git a/tests/hash-tests.scm b/tests/hash-tests.scm new file mode 100644 index 00000000..09792c5e --- /dev/null +++ b/tests/hash-tests.scm @@ -0,0 +1,37 @@ + +(import (srfi 69) (chibi test)) + +(test-begin "hash") + +(test + 'white + (let ((ht (make-hash-table eq?))) + (hash-table-set! ht 'cat 'black) + (hash-table-set! ht 'dog 'white) + (hash-table-set! ht 'elephant 'pink) + (hash-table-ref/default ht 'dog #f))) + +(test + 'white + (let ((ht (make-hash-table equal?))) + (hash-table-set! ht "cat" 'black) + (hash-table-set! ht "dog" 'white) + (hash-table-set! ht "elephant" 'pink) + (hash-table-ref/default ht "dog" #f))) + +(test + 'white + (let ((ht (make-hash-table string-ci=? string-ci-hash))) + (hash-table-set! ht "cat" 'black) + (hash-table-set! ht "dog" 'white) + (hash-table-set! ht "elephant" 'pink) + (hash-table-ref/default ht "DOG" #f))) + +(test 625 + (let ((ht (make-hash-table))) + (do ((i 0 (+ i 1))) ((= i 1000)) + (hash-table-set! ht i (* i i))) + (hash-table-ref/default ht 25 #f))) + +(test-end) + diff --git a/tests/install/install-tests.pl b/tests/install/install-tests.pl new file mode 100755 index 00000000..63681324 --- /dev/null +++ b/tests/install/install-tests.pl @@ -0,0 +1,57 @@ +#! /usr/bin/env perl + +use strict; +use warnings; + +my $ROOT="tests/install/root"; +my $USER=$ENV{USER}; + +my $ignore = qr!/lib\d*/modules|/X11|alsa-lib|aspell|dosemu|emacs|erlang|/perl|python|ruby|lisp|sbcl|/ghc-|ocaml|evolution|office|gimp|gtk|mysql|postgres|wordnet|xulrunner!; + +sub linkdir ($$$) { + my ($FROM, $TO, $DEPTH) = @_; + mkdir $TO; + for my $f (`ls $FROM`) { + chomp $f; + if (-d "$FROM/$f") { + if (($DEPTH > 0) && ($FROM !~ $ignore)) { + linkdir("$FROM/$f", "$TO/$f", $DEPTH-1); + } + } else { + link "$FROM/$f", "$TO/$f"; + } + } +} + +mkdir "$ROOT"; +mkdir "$ROOT/bin"; +mkdir "$ROOT/sbin"; +mkdir "$ROOT/dev"; +mkdir "$ROOT/etc"; +mkdir "$ROOT/etc/alternatives"; +mkdir "$ROOT/lib"; +mkdir "$ROOT/lib64"; +mkdir "$ROOT/usr"; +mkdir "$ROOT/usr/bin"; +mkdir "$ROOT/usr/include"; +mkdir "$ROOT/usr/lib"; +mkdir "$ROOT/usr/lib/gcc"; + +linkdir "/bin", "$ROOT/bin", 1; +linkdir "/sbin", "$ROOT/sbin", 1; +link "/etc/passwd", "$ROOT/etc/passwd"; +linkdir "/etc/alternatives", "$ROOT/etc/alternatives", 1; +linkdir "/lib", "$ROOT/lib", 3; +linkdir "/lib64", "$ROOT/lib64", 3; +linkdir "/usr/bin", "$ROOT/usr/bin", 3; +linkdir "/usr/include", "$ROOT/usr/include", 2; +linkdir "/usr/lib", "$ROOT/usr/lib", 3; +linkdir "/usr/lib/gcc", "$ROOT/usr/lib/gcc", 3; + +`make dist`; +my $VERSION=`cat VERSION`; +chomp $VERSION; +`cp chibi-scheme-$VERSION.tgz $ROOT/`; +`sed -e 's/\@VERSION\@/$VERSION/g' $ROOT/bin/run-install-test.sh`; +`chmod 755 $ROOT/bin/run-install-test.sh`; +exec "sudo chroot $ROOT run-install-test.sh"; diff --git a/tests/install/run-install-test.sh b/tests/install/run-install-test.sh new file mode 100755 index 00000000..c558e7cd --- /dev/null +++ b/tests/install/run-install-test.sh @@ -0,0 +1,12 @@ +#! /bin/bash + +export PATH=/usr/local/bin:$PATH +export LD_LIBRARY_PATH=/usr/local/lib:$LD_LIBRARY_PATH + +tar xzvf chibi-scheme-@VERSION@.tgz +cd chibi-scheme-@VERSION@ +make +make install +cp tests/r5rs-tests.scm .. +cd .. +chibi-scheme r5rs-tests.scm | tee r5rs-tests.out diff --git a/tests/lib-tests.scm b/tests/lib-tests.scm new file mode 100644 index 00000000..fbd8ae0a --- /dev/null +++ b/tests/lib-tests.scm @@ -0,0 +1,13 @@ + +(import (chibi test)) + +(test-begin "libraries") + +(load "tests/flonum-tests.scm") +(load "tests/numeric-tests.scm") +(load "tests/hash-tests.scm") +(load "tests/sort-tests.scm") +(load "tests/loop-tests.scm") +(load "tests/match-tests.scm") + +(test-end) diff --git a/tests/loop-tests.scm b/tests/loop-tests.scm new file mode 100644 index 00000000..f259245c --- /dev/null +++ b/tests/loop-tests.scm @@ -0,0 +1,168 @@ + +(import (chibi loop) (chibi test)) + +(test-begin "loops") + +(test + "stepping" + '(0 1 2) + (loop lp ((with i 0 (+ i 1)) + (with res '() (cons i res))) + (if (= i 3) + (reverse res) + (lp)))) + +(test + "basic in-list" + '(c b a) + (let ((res '())) + (loop ((for x (in-list '(a b c)))) + (set! res (cons x res))) + res)) + +(test + "in-list with result" + '(c b a) + (loop ((for x (in-list '(a b c))) + (with res '() (cons x res))) + => res)) + +(test + "in-list with listing" + '(a b c) + (loop ((for x (in-list '(a b c))) (for res (listing x))) => res)) + +(test + "in-list with listing-reverse" + '(c b a) + (loop ((for x (in-list '(a b c))) (for res (listing-reverse x))) => res)) + +(test + "uneven length in-list's" + '((a . 1) (b . 2) (c . 3)) + (loop ((for x (in-list '(a b c))) + (for y (in-list '(1 2 3 4))) + (for res (listing (cons x y)))) + => res)) + +(test + "in-lists" + '((a 1) (b 2) (c 3)) + (loop ((for ls (in-lists '((a b c) (1 2 3)))) + (for res (listing ls))) + => res)) + +(define (flatten ls) + (reverse + (loop lp ((for x ls (in-list ls)) (with res '())) + => res + (if (pair? x) + (lp (=> res (lp (=> ls x)))) + (lp (=> res (cons x res))))))) + +(test + "flatten (recursion test)" + '(1 2 3 4 5 6 7) + (flatten '(1 (2) (3 (4 (5)) 6) 7))) + +(test + "in-string" + '(#\h #\e #\l #\l #\o) + (loop ((for c (in-string "hello")) (for res (listing c))) => res)) + +(test + "in-string with start" + '(#\l #\o) + (loop ((for c (in-string "hello" 3)) (for res (listing c))) => res)) + +(test + "in-string with start and end" + '(#\h #\e #\l #\l) + (loop ((for c (in-string "hello" 0 4)) (for res (listing c))) => res)) + +(test + "in-string with start, end and step" + '(#\e #\l) + (loop ((for c (in-string "hello" 1 4 2)) (for res (listing c))) => res)) + +(test + "in-string-reverse" + '(#\o #\l #\l #\e #\h) + (loop ((for c (in-string-reverse "hello")) (for res (listing c))) => res)) + +(test + "in-vector" + '(1 2 3) + (loop ((for x (in-vector '#(1 2 3))) (for res (listing x))) => res)) + +(test "up-from" '(5 6 7) + (loop ((for i (up-from 5 (to 8))) + (for res (listing i))) + => res)) + +(test "up-from by" '(5 10 15) + (loop ((for i (up-from 5 (to 20) (by 5))) + (for res (listing i))) + => res)) + +(test "up-from listing if" '(10 12 14 16 18) + (loop ((for i (up-from 10 (to 20))) + (for res (listing i (if (even? i))))) + => res)) + +(test "down-from" '(7 6 5) + (loop ((for i (down-from 8 (to 5))) + (for res (listing i))) + => res)) + +(test "down-from by" '(15 10 5) + (loop ((for i (down-from 20 (to 5) (by 5))) + (for res (listing i))) + => res)) + +(test "down-from listing if" '(18 16 14 12 10) + (loop ((for i (down-from 20 (to 10))) + (for res (listing i (if (even? i))))) + => res)) + +(test "appending" '(1 2 3 4 5 6 7 8 9) + (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9)))) + (for res (appending ls))) + => res)) + +(test "appending-reverse" '(9 8 7 6 5 4 3 2 1) + (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9)))) + (for res (appending-reverse ls))) + => res)) + +(test "while + up-from" '(5 6 7) + (loop ((for i (up-from 5 (to 10))) + (while (< i 8)) + (for res (listing i))) + => res)) + +(test "up-from by, open-ended" '(5 7 9) + (loop ((for i (up-from 5 (by 2))) + (while (< i 10)) + (for res (listing i))) + => res)) + +(test "up-from open-ended" '(5 6 7) + (loop ((for i (up-from 5)) + (while (< i 8)) + (for res (listing i))) + => res)) + +(test "down-from by, open-ended" '(5 3 1) + (loop ((for i (down-from 7 (by 2))) + (until (< i 1)) + (for res (listing i))) + => res)) + +(test "down-from open-ended" '(4 3 2) + (loop ((for i (down-from 5)) + (until (< i 2)) + (for res (listing i))) + => res)) + +(test-end) diff --git a/tests/match-tests.scm b/tests/match-tests.scm new file mode 100644 index 00000000..911dd831 --- /dev/null +++ b/tests/match-tests.scm @@ -0,0 +1,135 @@ + +(import (chibi match) (chibi test)) + +(test-begin "match") + +(test "any" 'ok (match 'any (_ 'ok))) +(test "symbol" 'ok (match 'ok (x x))) +(test "number" 'ok (match 28 (28 'ok))) +(test "string" 'ok (match "good" ("bad" 'fail) ("good" 'ok))) +(test "literal symbol" 'ok (match 'good ('bad 'fail) ('good 'ok))) +(test "null" 'ok (match '() (() 'ok))) +(test "pair" 'ok (match '(ok) ((x) x))) +(test "vector" 'ok (match '#(ok) (#(x) x))) +(test "any doubled" 'ok (match '(1 2) ((_ _) 'ok))) +(test "and empty" 'ok (match '(o k) ((and) 'ok))) +(test "and single" 'ok (match 'ok ((and x) x))) +(test "and double" 'ok (match 'ok ((and (? symbol?) y) 'ok))) +(test "or empty" 'ok (match '(o k) ((or) 'fail) (else 'ok))) +(test "or single" 'ok (match 'ok ((or x) 'ok))) +(test "or double" 'ok (match 'ok ((or (? symbol? y) y) y))) +(test "not" 'ok (match 28 ((not (a . b)) 'ok))) +(test "pred" 'ok (match 28 ((? number?) 'ok))) +(test "named pred" 29 (match 28 ((? number? x) (+ x 1)))) + +(test "duplicate symbols pass" 'ok (match '(ok . ok) ((x . x) x))) +(test "duplicate symbols fail" 'ok (match '(ok . bad) ((x . x) 'bad) (else 'ok))) +(test "duplicate symbols samth" 'ok (match '(ok . ok) ((x . 'bad) x) (('ok . x) x))) + +(test "ellipses" '((a b c) (1 2 3)) + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ___) (list x y)))) + +(test "real ellipses" '((a b c) (1 2 3)) + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ...) (list x y)))) + +(test "vector ellipses" '(1 2 3 (a b c) (1 2 3)) + (match '#(1 2 3 (a . 1) (b . 2) (c . 3)) + (#(a b c (hd . tl) ...) (list a b c hd tl)))) + +(test "pred ellipses" '(1 2 3) + (match '(1 2 3) + (((? odd? n) ___) n) + (((? number? n) ___) n))) + +(test "failure continuation" 'ok + (match '(1 2) + ((a . b) (=> next) (if (even? a) 'fail (next))) + ((a . b) 'ok))) + +(test "let" '(o k) + (match-let ((x 'ok) (y '(o k))) y)) + +(test "let*" '(f o o f) + (match-let* ((x 'f) (y 'o) ((z w) (list y x))) (list x y z w))) + +(test "getter car" '(1 2) + (match '(1 . 2) (((get! a) . b) (list (a) b)))) + +(test "getter cdr" '(1 2) + (match '(1 . 2) ((a . (get! b)) (list a (b))))) + +(test "getter vector" '(1 2 3) + (match '#(1 2 3) (#((get! a) b c) (list (a) b c)))) + +(test "setter car" '(3 . 2) + (let ((x (cons 1 2))) + (match x (((set! a) . b) (a 3))) + x)) + +(test "setter cdr" '(1 . 3) + (let ((x (cons 1 2))) + (match x ((a . (set! b)) (b 3))) + x)) + +(test "setter vector" '#(1 0 3) + (let ((x (vector 1 2 3))) + (match x (#(a (set! b) c) (b 0))) + x)) + +(test "single tail" '((a b) (1 2) (c . 3)) + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ... last) (list x y last)))) + +(test "single tail 2" '((a b) (1 2) 3) + (match '((a . 1) (b . 2) 3) + (((x . y) ... last) (list x y last)))) + +(test "multiple tail" '((a b) (1 2) (c . 3) (d . 4) (e . 5)) + (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5)) + (((x . y) ... u v w) (list x y u v w)))) + +(test "Riastradh quasiquote" '(2 3) + (match '(1 2 3) (`(1 ,b ,c) (list b c)))) + +(test "trivial tree search" '(1 2 3) + (match '(1 2 3) ((_ *** (a b c)) (list a b c)))) + +(test "simple tree search" '(1 2 3) + (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c)))) + +(test "deep tree search" '(1 2 3) + (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c)))) + +(test "non-tail tree search" '(1 2 3) + (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c)))) + +(test "restricted tree search" '(1 2 3) + (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c)))) + +(test "fail restricted tree search" #f + (match '(x (y (x a b c (1 2 3) d e f))) + (('x *** (a b c)) (list a b c)) + (else #f))) + +(test "sxml tree search" '(((href . "http://synthcode.com/")) ("synthcode")) + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f))) + +(test "failed sxml tree search" #f + (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f))) + +(test "collect tree search" + '((p ul li) ((href . "http://synthcode.com/")) ("synthcode")) + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...)) + (list tag attrs text)) + (else #f))) + +(test-end) diff --git a/tests/numeric-tests.scm b/tests/numeric-tests.scm new file mode 100644 index 00000000..43b16cb4 --- /dev/null +++ b/tests/numeric-tests.scm @@ -0,0 +1,120 @@ + +;; these tests are only valid if chibi-scheme is compiled with full +;; numeric support (USE_BIGNUMS, USE_FLONUMS and USE_MATH) + +(import (chibi test)) + +(test-begin "numbers") + +(define (integer-neighborhoods x) + (list x (+ 1 x) (+ -1 x) (- x) (- 1 x) (- -1 x))) + +(test '(536870912 536870913 536870911 -536870912 -536870911 -536870913) + (integer-neighborhoods (expt 2 29))) + +(test '(1073741824 1073741825 1073741823 -1073741824 -1073741823 -1073741825) + (integer-neighborhoods (expt 2 30))) + +(test '(2147483648 2147483649 2147483647 -2147483648 -2147483647 -2147483649) + (integer-neighborhoods (expt 2 31))) + +(test '(4294967296 4294967297 4294967295 -4294967296 -4294967295 -4294967297) + (integer-neighborhoods (expt 2 32))) + +(test '(4611686018427387904 4611686018427387905 4611686018427387903 + -4611686018427387904 -4611686018427387903 -4611686018427387905) + (integer-neighborhoods (expt 2 62))) + +(test '(9223372036854775808 9223372036854775809 9223372036854775807 + -9223372036854775808 -9223372036854775807 -9223372036854775809) + (integer-neighborhoods (expt 2 63))) + +(test '(18446744073709551616 18446744073709551617 18446744073709551615 + -18446744073709551616 -18446744073709551615 -18446744073709551617) + (integer-neighborhoods (expt 2 64))) + +(test '(85070591730234615865843651857942052864 + 85070591730234615865843651857942052865 + 85070591730234615865843651857942052863 + -85070591730234615865843651857942052864 + -85070591730234615865843651857942052863 + -85070591730234615865843651857942052865) + (integer-neighborhoods (expt 2 126))) + +(test '(170141183460469231731687303715884105728 + 170141183460469231731687303715884105729 + 170141183460469231731687303715884105727 + -170141183460469231731687303715884105728 + -170141183460469231731687303715884105727 + -170141183460469231731687303715884105729) + (integer-neighborhoods (expt 2 127))) + +(test '(340282366920938463463374607431768211456 + 340282366920938463463374607431768211457 + 340282366920938463463374607431768211455 + -340282366920938463463374607431768211456 + -340282366920938463463374607431768211455 + -340282366920938463463374607431768211457) + (integer-neighborhoods (expt 2 128))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (integer-arithmetic-combinations a b) + (list (+ a b) (- a b) (* a b) (quotient a b) (remainder a b))) + +(define (sign-combinations a b) + (list (integer-arithmetic-combinations a b) + (integer-arithmetic-combinations (- a) b) + (integer-arithmetic-combinations a (- b)) + (integer-arithmetic-combinations (- a) (- b)))) + +;; fix x fix +(test '((1 -1 0 0 0) (1 -1 0 0 0) (-1 1 0 0 0) (-1 1 0 0 0)) + (sign-combinations 0 1)) +(test '((2 0 1 1 0) (0 -2 -1 -1 0) (0 2 -1 -1 0) (-2 0 1 1 0)) + (sign-combinations 1 1)) +(test '((59 25 714 2 8) (-25 -59 -714 -2 -8) + (25 59 -714 -2 8) (-59 -25 714 2 -8)) + (sign-combinations 42 17)) + +;; fix x big +(test '((4294967338 -4294967254 180388626432 0 42) + (4294967254 -4294967338 -180388626432 0 -42) + (-4294967254 4294967338 -180388626432 0 42) + (-4294967338 4294967254 180388626432 0 -42)) + (sign-combinations 42 (expt 2 32))) + +;; big x fix +(test '((4294967338 4294967254 180388626432 102261126 4) + (-4294967254 -4294967338 -180388626432 -102261126 -4) + (4294967254 4294967338 -180388626432 -102261126 4) + (-4294967338 -4294967254 180388626432 102261126 -4)) + (sign-combinations (expt 2 32) 42)) + +;; big x bigger +(test '((12884901889 -4294967297 36893488151714070528 0 4294967296) + (4294967297 -12884901889 -36893488151714070528 0 -4294967296) + (-4294967297 12884901889 -36893488151714070528 0 4294967296) + (-12884901889 4294967297 36893488151714070528 0 -4294967296)) + (sign-combinations (expt 2 32) (+ 1 (expt 2 33)))) + +(test '((18446744078004518913 -18446744069414584321 79228162514264337597838917632 0 4294967296) + (18446744069414584321 -18446744078004518913 -79228162514264337597838917632 0 -4294967296) + (-18446744069414584321 18446744078004518913 -79228162514264337597838917632 0 4294967296) + (-18446744078004518913 18446744069414584321 79228162514264337597838917632 0 -4294967296)) + (sign-combinations (expt 2 32) (+ 1 (expt 2 64)))) + +;; bigger x big +(test '((12884901889 4294967297 36893488151714070528 2 1) + (-4294967297 -12884901889 -36893488151714070528 -2 -1) + (4294967297 12884901889 -36893488151714070528 -2 1) + (-12884901889 -4294967297 36893488151714070528 2 -1)) + (sign-combinations (+ 1 (expt 2 33)) (expt 2 32))) + +(test '((18446744078004518913 18446744069414584321 79228162514264337597838917632 4294967296 1) + (-18446744069414584321 -18446744078004518913 -79228162514264337597838917632 -4294967296 -1) + (18446744069414584321 18446744078004518913 -79228162514264337597838917632 -4294967296 1) + (-18446744078004518913 -18446744069414584321 79228162514264337597838917632 4294967296 -1)) + (sign-combinations (+ 1 (expt 2 64)) (expt 2 32))) + +(test-end) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm new file mode 100644 index 00000000..a9197fb1 --- /dev/null +++ b/tests/r5rs-tests.scm @@ -0,0 +1,465 @@ + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test expect expr) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string + (lambda (out) + (write *tests-run*) + (display ". ") + (display 'expr out)))) + (res expr)) + (display str) + (write-char #\space) + (display (make-string (max 0 (- 72 (string-length str))) #\.)) + (flush-output) + (cond + ((equal? res expect) + (set! *tests-passed* (+ *tests-passed* 1)) + (display " [PASS]\n")) + (else + (display " [FAIL]\n") + (display " expected ") (write expect) + (display " but got ") (write res) (newline)))))))) + +(define (test-report) + (write *tests-passed*) + (display " out of ") + (write *tests-run*) + (display " passed (") + (write (* (/ *tests-passed* *tests-run*) 100)) + (display "%)") + (newline)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(test 8 ((lambda (x) (+ x x)) 4)) + +(test '(3 4 5 6) ((lambda x x) 3 4 5 6)) + +(test '(5 6) ((lambda (x y . z) z) 3 4 5 6)) + +(test 'yes (if (> 3 2) 'yes 'no)) + +(test 'no (if (> 2 3) 'yes 'no)) + +(test 1 (if (> 3 2) (- 3 2) (+ 3 2))) + +(test 'greater (cond ((> 3 2) 'greater) ((< 3 2) 'less))) + +(test 'equal (cond ((> 3 3) 'greater) ((< 3 3) 'less) (else 'equal))) + +(test 'composite (case (* 2 3) ((2 3 5 7) 'prime) ((1 4 6 8 9) 'composite))) + +(test 'consonant + (case (car '(c d)) + ((a e i o u) 'vowel) + ((w y) 'semivowel) + (else 'consonant))) + +(test #t (and (= 2 2) (> 2 1))) + +(test #f (and (= 2 2) (< 2 1))) + +(test '(f g) (and 1 2 'c '(f g))) + +(test #t (and)) + +(test #t (or (= 2 2) (> 2 1))) + +(test #t (or (= 2 2) (< 2 1))) + +(test '(b c) (or (memq 'b '(a b c)) (/ 3 0))) + +(test 6 (let ((x 2) (y 3)) (* x y))) + +(test 35 (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x)))) + +(test 70 (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x)))) + +(test -2 (let () + (define x 2) + (define f (lambda () (- x))) + (f))) + +(define let*-def 1) +(let* () (define let*-def 2) #f) +(test 1 let*-def) + +(test '#(0 1 2 3 4) + (do ((vec (make-vector 5)) + (i 0 (+ i 1))) + ((= i 5) vec) + (vector-set! vec i i))) + +(test 25 + (let ((x '(1 3 5 7 9))) + (do ((x x (cdr x)) + (sum 0 (+ sum (car x)))) + ((null? x) + sum)))) + +(test '((6 1 3) (-5 -2)) + (let loop ((numbers '(3 -2 1 6 -5)) (nonneg '()) (neg '())) + (cond + ((null? numbers) + (list nonneg neg)) + ((>= (car numbers) 0) + (loop (cdr numbers) (cons (car numbers) nonneg) neg)) + ((< (car numbers) 0) + (loop (cdr numbers) nonneg (cons (car numbers) neg)))))) + +(test '(list 3 4) `(list ,(+ 1 2) 4)) + +(test '(list a 'a) (let ((name 'a)) `(list ,name ',name))) + +(test '(a 3 4 5 6 b) + `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) + +(test '(10 5 4 16 9 8) + `(10 5 ,(expt 2 2) ,@(map (lambda (n) (expt n 2)) '(4 3)) 8)) + +(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) + `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) + +(test '(a `(b ,x ,'y d) e) + (let ((name1 'x) + (name2 'y)) + `(a `(b ,,name1 ,',name2 d) e))) + +(test '(list 3 4) + (quasiquote (list (unquote (+ 1 2)) 4))) + +(test #t (eqv? 'a 'a)) + +(test #f (eqv? 'a 'b)) + +(test #t (eqv? '() '())) + +(test #f (eqv? (cons 1 2) (cons 1 2))) + +(test #f (eqv? (lambda () 1) (lambda () 2))) + +(test #t (let ((p (lambda (x) x))) (eqv? p p))) + +(test #t (eq? 'a 'a)) + +(test #f (eq? (list 'a) (list 'a))) + +(test #t (eq? '() '())) + +(test #t (eq? car car)) + +(test #t (let ((x '(a))) (eq? x x))) + +(test #t (let ((p (lambda (x) x))) (eq? p p))) + +(test #t (equal? 'a 'a)) + +(test #t (equal? '(a) '(a))) + +(test #t (equal? '(a (b) c) '(a (b) c))) + +(test #t (equal? "abc" "abc")) + +(test #t (equal? 2 2)) + +;;(test #f (eqv? 2 2.0)) + +;;(test #f (equal? 2.0 2)) + +(test #t (equal? (make-vector 5 'a) (make-vector 5 'a))) + +(test 4 (max 3 4)) + +;;(test 4 (max 3.9 4)) + +(test 7 (+ 3 4)) + +(test 3 (+ 3)) + +(test 0 (+)) + +(test 4 (* 4)) + +(test 1 (*)) + +(test -1 (- 3 4)) + +(test -6 (- 3 4 5)) + +(test -3 (- 3)) + +(test 7 (abs -7)) + +(test 1 (modulo 13 4)) + +(test 1 (remainder 13 4)) + +(test 3 (modulo -13 4)) + +(test -1 (remainder -13 4)) + +(test -3 (modulo 13 -4)) + +(test 1 (remainder 13 -4)) + +(test -1 (modulo -13 -4)) + +(test -1 (remainder -13 -4)) + +(test 4 (gcd 32 -36)) + +(test 288 (lcm 32 -36)) + +(test 100 (string->number "100")) + +(test 256 (string->number "100" 16)) + +(test 127 (string->number "177" 8)) + +(test 5 (string->number "101" 2)) + +(test 100.0 (string->number "1e2")) + +(test "100" (number->string 100)) + +(test "100" (number->string 256 16)) + +(test "FF" (number->string 255 16)) + +(test "177" (number->string 127 8)) + +(test "101" (number->string 5 2)) + +(test #f (not 3)) + +(test #f (not (list 3))) + +(test #f (not '())) + +(test #f (not (list))) + +(test #f (not '())) + +(test #f (boolean? 0)) + +(test #f (boolean? '())) + +(test #t (pair? '(a . b))) + +(test #t (pair? '(a b c))) + +(test '(a) (cons 'a '())) + +(test '((a) b c d) (cons '(a) '(b c d))) + +(test '("a" b c) (cons "a" '(b c))) + +(test '(a . 3) (cons 'a 3)) + +(test '((a b) . c) (cons '(a b) 'c)) + +(test 'a (car '(a b c))) + +(test '(a) (car '((a) b c d))) + +(test 1 (car '(1 . 2))) + +(test '(b c d) (cdr '((a) b c d))) + +(test 2 (cdr '(1 . 2))) + +(test #t (list? '(a b c))) + +(test #t (list? '())) + +(test #f (list? '(a . b))) + +(test #f + (let ((x (list 'a))) + (set-cdr! x x) + (list? x))) + +(test '(a 7 c) (list 'a (+ 3 4) 'c)) + +(test '() (list)) + +(test 3 (length '(a b c))) + +(test 3 (length '(a (b) (c d e)))) + +(test 0 (length '())) + +(test '(x y) (append '(x) '(y))) + +(test '(a b c d) (append '(a) '(b c d))) + +(test '(a (b) (c)) (append '(a (b)) '((c)))) + +(test '(a b c . d) (append '(a b) '(c . d))) + +(test 'a (append '() 'a)) + +(test '(c b a) (reverse '(a b c))) + +(test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f))))) + +(test 'c (list-ref '(a b c d) 2)) + +(test '(a b c) (memq 'a '(a b c))) + +(test '(b c) (memq 'b '(a b c))) + +(test #f (memq 'a '(b c d))) + +(test #f (memq (list 'a) '(b (a) c))) + +(test '((a) c) (member (list 'a) '(b (a) c))) + +(test '(101 102) (memv 101 '(100 101 102))) + +(test #f (assq (list 'a) '(((a)) ((b)) ((c))))) + +(test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c))))) + +(test '(5 7) (assv 5 '((2 3) (5 7) (11 13)))) + +(test #t (symbol? 'foo)) + +(test #t (symbol? (car '(a b)))) + +(test #f (symbol? "bar")) + +(test #t (symbol? 'nil)) + +(test #f (symbol? '())) + +(test "flying-fish" (symbol->string 'flying-fish)) + +(test "Martin" (symbol->string 'Martin)) + +(test "Malvina" (symbol->string (string->symbol "Malvina"))) + +(test '#(0 ("Sue" "Sue") "Anna") + (let ((vec (vector 0 '(2 2 2 2) "Anna"))) + (vector-set! vec 1 '("Sue" "Sue")) + vec)) + +(test '(dah dah didah) (vector->list '#(dah dah didah))) + +(test '#(dididit dah) (list->vector '(dididit dah))) + +(test #t (procedure? car)) + +(test #f (procedure? 'car)) + +(test #t (procedure? (lambda (x) (* x x)))) + +(test #f (procedure? '(lambda (x) (* x x)))) + +(test #t (call-with-current-continuation procedure?)) + +(test 7 (call-with-current-continuation (lambda (k) (+ 2 5)))) + +(test 3 (call-with-current-continuation (lambda (k) (+ 2 5 (k 3))))) + +(test 7 (apply + (list 3 4))) + +(test '(b e h) (map cadr '((a b) (d e) (g h)))) + +(test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5))) + +(test '(5 7 9) (map + '(1 2 3) '(4 5 6))) + +(test '#(0 1 4 9 16) + (let ((v (make-vector 5))) + (for-each + (lambda (i) (vector-set! v i (* i i))) + '(0 1 2 3 4)) + v)) + +(test 3 (force (delay (+ 1 2)))) + +(test '(3 3) (let ((p (delay (+ 1 2)))) (list (force p) (force p)))) + +(test 'ok (let ((else 1)) (cond (else 'ok) (#t 'bad)))) + +(test 'ok (let ((=> 1)) (cond (#t => 'ok)))) + +(test '(,foo) (let ((unquote 1)) `(,foo))) + +(test '(,@foo) (let ((unquote-splicing 1)) `(,@foo))) + +(test 'ok + (let ((... 2)) + (let-syntax ((s (syntax-rules () + ((_ x ...) 'bad) + ((_ . r) 'ok)))) + (s a b c)))) + +(test 'ok (let () + (let-syntax () + (define internal-def 'ok)) + internal-def)) + +(test 'ok (let () + (letrec-syntax () + (define internal-def 'ok)) + internal-def)) + +(test '(2 1) + ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (list x y)))))) + +(test '(2 2) + ((lambda () (let ((x 1)) (set! x 2) (let ((y x)) (list x y)))))) + +(test '(1 2) + ((lambda () (let ((x 1)) (let ((y x)) (set! y 2) (list x y)))))) + +(test '(2 3) + ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (set! y 3) (list x y)))))) + +(test '(a b c) + (let* ((path '()) + (add (lambda (s) (set! path (cons s path))))) + (dynamic-wind (lambda () (add 'a)) (lambda () (add 'b)) (lambda () (add 'c))) + (reverse path))) + +(test '(connect talk1 disconnect connect talk2 disconnect) + (let ((path '()) + (c #f)) + (let ((add (lambda (s) + (set! path (cons s path))))) + (dynamic-wind + (lambda () (add 'connect)) + (lambda () + (add (call-with-current-continuation + (lambda (c0) + (set! c c0) + 'talk1)))) + (lambda () (add 'disconnect))) + (if (< (length path) 4) + (c 'talk2) + (reverse path))))) + +(test 2 (let-syntax + ((foo (syntax-rules ::: () + ((foo ... args :::) + (args ::: ...))))) + (foo 3 - 5))) + +(test '(5 4 1 2 3) + (let-syntax + ((foo (syntax-rules () + ((foo args ... penultimate ultimate) + (list ultimate penultimate args ...))))) + (foo 1 2 3 4 5))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(test-report) diff --git a/tests/sort-tests.scm b/tests/sort-tests.scm new file mode 100644 index 00000000..f506baca --- /dev/null +++ b/tests/sort-tests.scm @@ -0,0 +1,40 @@ + +(import (srfi 95) (chibi test)) + +(test-begin "sorting") + +(test "sort null" '() (sort '())) +(test "sort null <" '() (sort '() <)) +(test "sort null < car" '() (sort '() < car)) +(test "sort ordered list" '(1 2 3 4 5 6 7 8 9) (sort '(1 2 3 4 5 6 7 8 9))) +(test "sort reversed list" '(1 2 3 4 5 6 7 8 9) (sort '(9 8 7 6 5 4 3 2 1))) +(test "sort random list 1" '(1 2 3 4 5 6 7 8 9) (sort '(7 5 2 8 1 6 4 9 3))) +(test "sort random list 2" '(1 2 3 4 5 6 7 8) (sort '(5 3 4 1 7 6 8 2))) +(test "sort random list 3" '(1 2 3 4 5 6 7 8 9) (sort '(5 3 4 1 7 9 6 8 2))) +(test "sort numeric list <" '(1 2 3 4 5 6 7 8 9) + (sort '(7 5 2 8 1 6 4 9 3) <)) +(test "sort numeric list < car" '((1) (2) (3) (4) (5) (6) (7) (8) (9)) + (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) < car)) +(test "sort list (lambda (a b) (< (car a) (car b)))" + '((1) (2) (3) (4) (5) (6) (7) (8) (9)) + (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) + (lambda (a b) (< (car a) (car b))))) +(test "sort 1-char symbols" '(a b c d e f g h i j k) + (sort '(h b k d a c j i e g f))) +(test "sort short symbols" '(a aa b c d e ee f g h i j k) + (sort '(h b aa k d a ee c j i e g f))) +(test "sort long symbol" + '(a aa b bzzzzzzzzzzzzzzzzzzzzzzz c d e ee f g h i j k) + (sort '(h b aa k d a ee c j i bzzzzzzzzzzzzzzzzzzzzzzz e g f))) +(test "sort long symbols" + '(a aa b bzzzzzzzzzzzzzzzzzzzzzzz czzzzzzzzzzzzz dzzzzzzzz e ee f g h i j k) + (sort '(h b aa k dzzzzzzzz a ee czzzzzzzzzzzzz j i bzzzzzzzzzzzzzzzzzzzzzzz e g f))) +(test "sort strings" + '("ape" "bear" "cat" "dog" "elephant" "fox" "goat" "hawk") + (sort '("elephant" "cat" "dog" "ape" "goat" "fox" "hawk" "bear"))) +(test "sort strings string-cistring x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "non-stringable object" x)))) + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-replace str c r) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate (reverse (collect)))) + ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect)))) + (else (lp from (+ i 1) res)))))) + +(define (c-char? c) + (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?)))) + +(define (c-escape str) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate (reverse (collect)))) + ((not (c-char? (string-ref str i))) (lp (+ i 1) (+ i 1) (cons "_" (cons (number->string (char->integer (string-ref str i)) 16) (collect))))) + (else (lp from (+ i 1) res)))))) + +(define (mangle x) + (string-replace + (string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p") + #\! "_x")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (path-relative path dir) + (let ((p-len (string-length path)) + (d-len (string-length dir))) + (and (> p-len d-len) + (string=? dir (substring path 0 d-len)) + (cond + ((eqv? #\/ (string-ref path d-len)) + (substring path (+ d-len 1) p-len)) + ((eqv? #\/ (string-ref path (- d-len 1))) + (substring path d-len p-len)) + (else #f))))) + +(define (path-split file) + (let ((len (string-length file))) + (let lp ((i 0) (res '())) + (let ((j (string-scan #\/ file i))) + (cond + (j (lp (+ j 1) (cons (substring file i j) res))) + (else (reverse (if (= i len) + res + (cons (substring file i len) res))))))))) + +(define (init-name mod) + (string-append "sexp_init_lib_" + (string-concatenate (map mangle mod) "_"))) + +(define (find-c-libs basedir) + (define (process-dir dir) + (directory-fold + dir + (lambda (f x) + (if (and (not (equal? "" f)) (not (eqv? #\. (string-ref f 0)))) + (process (string-append dir "/" f)))) + #f)) + (define (process file) + (cond + ((file-directory? file) + (process-dir file)) + ((equal? "module" (path-extension file)) + (let* ((mod-path (path-strip-extension (path-relative file basedir))) + (mod-name (map (lambda (x) (or (string->number x) (string->symbol x))) + (path-split mod-path)))) + (cond + ((eval `(find-module ',mod-name) *config-env*) + => (lambda (mod) + (cond + ((assq 'include-shared (vector-ref mod 2)) + => (lambda (x) + (set! c-libs + (cons (cons (string-append + (path-directory file) + "/" + (cadr x) + ".c") + (init-name mod-name)) + c-libs)))))))))))) + (process-dir basedir)) + +(define (include-c-lib lib) + (display "#define sexp_init_library ") + (display (cdr lib)) + (newline) + (display "#include \"") + (display (car lib)) + (display "\"") + (newline) + (display "#undef sexp_init_library") + (newline) + (newline)) + +(define (init-c-lib lib) + (display " ") + (display (cdr lib)) + (display "(ctx, env);\n")) + +(define (main args) + (find-c-libs (if (pair? (cdr args)) (cadr args) "lib")) + (newline) + (for-each include-c-lib c-libs) + (newline) + (display "static sexp sexp_init_all_libraries (sexp ctx, sexp env) {\n") + (for-each init-c-lib c-libs) + (display " return SEXP_VOID;\n") + (display "}\n\n")) + diff --git a/tools/genstubs.scm b/tools/genstubs.scm new file mode 100755 index 00000000..e75d9a92 --- /dev/null +++ b/tools/genstubs.scm @@ -0,0 +1,1280 @@ +#! /usr/bin/env chibi-scheme + +;; Note: this evolved as a throw-away script to provide certain core +;; modules, and so is a mess. Tread carefully. + +;; Simple C FFI. "genstubs.scm file.stub" will read in the C function +;; FFI definitions from file.stub and output the appropriate C +;; wrappers into file.c. You can then compile that file with: +;; +;; cc -fPIC -shared file.c -lchibi-scheme +;; +;; (or using whatever flags are appropriate to generate shared libs on +;; your platform) and then the generated .so file can be loaded +;; directly with load, or portably using (include-shared "file") in a +;; module definition (note that include-shared uses no suffix). + +;; The goal of this interface is to make access to C types and +;; functions easy, without requiring the user to write any C code. +;; That means the stubber needs to be intelligent about various C +;; calling conventions and idioms, such as return values passed in +;; actual parameters. Writing C by hand is still possible, and +;; several of the core modules provide C interfaces directly without +;; using the stubber. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Struct Interface +;; +;; (define-c-struct struct-name +;; [predicate: predicate-name] +;; [constructor: constructor-name] +;; [finalizer: c_finalizer_name] +;; (type c_field_name getter-name setter-name) ...) +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Function Interface +;; +;; (define-c return-type name-spec (arg-type ...)) +;; +;; where name-space is either a symbol name, or a list of +;; (scheme-name c_name). If just a symbol, the C name is taken +;; to be the same with -'s replaced by _'s. +;; +;; arg-type is a type suitable for input validation and conversion. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Types +;; +;; Types +;; +;; Basic Types +;; void +;; boolean +;; char +;; sexp (no conversions) +;; +;; Integer Types: +;; signed-char short int long +;; unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t +;; time_t (in seconds, but using the chibi epoch of 2010/01/01) +;; errno (as a return type returns #f on error) +;; +;; Float Types: +;; float double long-double +;; +;; String Types: +;; string - a null-terminated char* +;; env-string - a VAR=VALUE string represented as a (VAR . VALUE) pair inScheme +;; in addition you can use (array char) as a string +;; +;; Port Types: +;; input-port output-port +;; port-or-fd - an fd-backed port or a fixnum +;; +;; Struct Types: +;; +;; Struct types are by default just referred to by the bare +;; struct-name from define-c-struct, and it is assumed you want a +;; pointer to that type. To refer to the full struct, use the struct +;; modifier, as in (struct struct-name). + +;; Type modifiers +;; +;; Any type may also be written as a list of modifiers followed by the +;; type itself. The supported modifiers are: +;; +;; const: prepends the "const" C type modifier +;; * as a return or result parameter, makes non-immediates immutable +;; +;; free: it's Scheme's responsibility to "free" this resource +;; * as a return or result parameter, registers the freep flag +;; this causes the type finalizer to be run when GCed +;; +;; maybe-null: this pointer type may be NULL +;; * as a result parameter, NULL is translated to #f +;; normally this would just return a wrapped NULL pointer +;; * as an input parameter, #f is translated to NULL +;; normally this would be a type error +;; +;; pointer: create a pointer to this type +;; * as a return parameter, wraps the result in a vanilla cpointer +;; * as a result parameter, boxes then unboxes the value +;; +;; struct: treat this struct type as a struct, not a pointer +;; * as an input parameter, dereferences the pointer +;; * as a type field, indicates a nested struct +;; +;; link: add a gc link +;; * as a field getter, link to the parent object, so the +;; parent won't be GCed so long as we have a reference +;; to the child. this behavior is automatic for nested +;; structs. +;; +;; result: return a result in this parameter +;; * if there are multiple results (including the return type), +;; they are all returned in a list +;; * if there are any result parameters, a return type +;; of errno returns #f on failure, and as eliminated +;; from the list of results otherwise +;; +;; (value ): specify a fixed value +;; * as an input parameter, this parameter is not provided +;; in the Scheme API but always passed as +;; +;; (default ): specify a default value +;; * as the final input parameter, makes the Scheme parameter +;; optional, defaulting to +;; +;; (array []) an array type +;; * length must be specified for return and result parameters +;; * if specified, length can be any of +;; ** an integer, for a fixed size +;; ** the symbol null, indicating a NULL-terminated array + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; globals + +(define *types* '()) +(define *funcs* '()) +(define *consts* '()) +(define *inits* '()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; type objects + +(define (parse-type type . o) + (cond + ((vector? type) + type) + (else + (let lp ((type type) (free? #f) (const? #f) (null-ptr? #f) + (ptr? #f) (struct? #f) (link? #f) (result? #f) (array #f) + (value #f) (default? #f)) + (define (next) (if (null? (cddr type)) (cadr type) (cdr type))) + (case (and (pair? type) (car type)) + ((free) + (lp (next) #t const? null-ptr? ptr? struct? link? result? array value default?)) + ((const) + (lp (next) free? #t null-ptr? ptr? struct? link? result? array value default?)) + ((maybe-null) + (lp (next) free? const? #t ptr? struct? link? result? array value default?)) + ((pointer) + (lp (next) free? const? null-ptr? #t struct? link? result? array value default?)) + ((struct) + (lp (next) free? const? null-ptr? ptr? #t link? result? array value default?)) + ((link) + (lp (next) free? const? null-ptr? ptr? struct? #t result? array value default?)) + ((result) + (lp (next) free? const? null-ptr? ptr? struct? link? #t array value default?)) + ((array) + (lp (cadr type) free? const? null-ptr? ptr? struct? link? result? (if (pair? (cddr type)) (caddr type) #t) value default?)) + ((value) + (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) default?)) + ((default) + (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) #t)) + (else + (vector (if (and (pair? type) (null? (cdr type))) (car type) type) free? const? null-ptr? ptr? struct? link? result? array value default? (and (pair? o) (car o))))))))) + +(define (type-base type) (vector-ref type 0)) +(define (type-free? type) (vector-ref type 1)) +(define (type-const? type) (vector-ref type 2)) +(define (type-null? type) (vector-ref type 3)) +(define (type-pointer? type) (vector-ref type 4)) +(define (type-struct? type) (vector-ref type 5)) +(define (type-link? type) (vector-ref type 6)) +(define (type-result? type) (vector-ref type 7)) +(define (type-array type) (vector-ref type 8)) +(define (type-value type) (vector-ref type 9)) +(define (type-default? type) (vector-ref type 10)) +(define (type-index type) (vector-ref type 11)) + +(define (type-auto-expand? type) + (and (pair? (type-array type)) + (memq 'auto-expand (type-array type)))) + +(define (type-index-string type) + (if (integer? (type-index type)) + (number->string (type-index type)) + "")) + +(define (struct-fields ls) + (let lp ((ls ls) (res '())) + (cond ((null? ls) (reverse res)) + ((symbol? (car ls)) (lp (cddr ls) res)) + (else (lp (cdr ls) (cons (car ls) res)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; type predicates + +(define (signed-int-type? type) + (memq type '(signed-char short int long boolean))) + +(define (unsigned-int-type? type) + (memq type '(unsigned-char unsigned-short unsigned unsigned-int unsigned-long + size_t off_t time_t clock_t dev_t ino_t mode_t nlink_t + uid_t gid_t pid_t blksize_t blkcnt_t sigval_t))) + +(define (int-type? type) + (or (signed-int-type? type) (unsigned-int-type? type))) + +(define (float-type? type) + (memq type '(float double long-double long-long-double))) + +(define (string-type? type) + (or (memq type '(char* string env-string non-null-string)) + (and (vector? type) + (type-array type) + (not (type-pointer? type)) + (eq? 'char (type-base type))))) + +(define (port-type? type) + (memq type '(port input-port output-port))) + +(define (error-type? type) + (memq type '(errno non-null-string non-null-pointer))) + +(define (array-type? type) + (and (type-array type) (not (eq? 'char (type-base type))))) + +(define (basic-type? type) + (let ((type (parse-type type))) + (and (not (type-array type)) + (not (void-pointer-type? type)) + (not (assq (type-base type) *types*))))) + +(define (void-pointer-type? type) + (or (and (eq? 'void (type-base type)) (type-pointer? type)) + (eq? 'void* (type-base type)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; function objects + +(define (parse-func func) + (if (not (and (= 3 (length func)) + (or (identifier? (cadr func)) (list (cadr func))) + (list (caddr func)))) + (error "bad function definition" func)) + (let* ((ret-type (parse-type (car func))) + (scheme-name (if (pair? (cadr func)) (caadr func) (cadr func))) + (c-name (if (pair? (cadr func)) + (cadadr func) + (mangle scheme-name))) + (stub-name (if (and (pair? (cadr func)) (pair? (cddadr func))) + (car (cddadr func)) + (generate-stub-name scheme-name)))) + (let lp ((ls (caddr func)) + (i 0) + (results '()) + (c-args '()) + (s-args '())) + (cond + ((null? ls) + (vector scheme-name c-name stub-name ret-type + (reverse results) (reverse c-args) (reverse s-args))) + (else + (let ((type (parse-type (car ls) i))) + (cond + ((type-result? type) + (lp (cdr ls) (+ i 1) (cons type results) (cons type c-args) s-args)) + ((and (type-value type) (not (type-default? type))) + (lp (cdr ls) (+ i 1) results (cons type c-args) s-args)) + (else + (lp (cdr ls) (+ i 1) results (cons type c-args) (cons type s-args))) + ))))))) + +(define (func-scheme-name func) (vector-ref func 0)) +(define (func-c-name func) (vector-ref func 1)) +(define (func-stub-name func) (vector-ref func 2)) +(define (func-ret-type func) (vector-ref func 3)) +(define (func-results func) (vector-ref func 4)) +(define (func-c-args func) (vector-ref func 5)) +(define (func-scheme-args func) (vector-ref func 6)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define (cat . args) + (for-each (lambda (x) (if (procedure? x) (x) (display x))) args)) + +(define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "non-stringable object" x)))) + +(define (filter pred ls) + (cond ((null? ls) '()) + ((pred (car ls)) (cons (car ls) (filter pred (cdr ls)))) + (else (filter pred (cdr ls))))) + +(define (remove pred ls) + (cond ((null? ls) '()) + ((pred (car ls)) (filter pred (cdr ls))) + (else (cons (car ls) (filter pred (cdr ls)))))) + +(define (strip-extension path) + (let lp ((i (- (string-length path) 1))) + (cond ((<= i 0) path) + ((eq? #\. (string-ref path i)) (substring path 0 i)) + (else (lp (- i 1)))))) + +(define (string-concatenate-reverse ls) + (cond ((null? ls) "") + ((null? (cdr ls)) (car ls)) + (else (string-concatenate (reverse ls))))) + +(define (string-replace str c r) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate-reverse (collect))) + ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect)))) + (else (lp from (+ i 1) res)))))) + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-downcase str) + (list->string (map char-downcase (string->list str)))) + +(define (with-output-to-string thunk) + (call-with-output-string + (lambda (out) + (let ((old-out (current-output-port))) + (current-output-port out) + (thunk) + (current-output-port old-out))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; naming + +(define (c-char? c) + (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?)))) + +(define (c-escape str) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate-reverse (collect))) + ((not (c-char? (string-ref str i))) (lp (+ i 1) (+ i 1) (cons "_" (cons (number->string (char->integer (string-ref str i)) 16) (collect))))) + (else (lp from (+ i 1) res)))))) + +(define (mangle x) + (string-replace + (string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p") + #\! "_x")) + +(define (generate-stub-name sym) + (string-append "sexp_" (mangle sym) "_stub")) + +(define (type-id-name sym) + (string-append "sexp_" (mangle sym) "_type_id")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; .stub file interface + +(define (c-declare . args) + (apply cat args) + (newline)) + +(define (c-include header) + (cat "\n#include \"" header "\"\n")) + +(define (c-system-include header) + (cat "\n#include <" header ">\n")) + +(define (c-init x) + (set! *inits* (cons x *inits*))) + +(define (parse-struct-like ls) + (let lp ((ls ls) (res '())) + (cond + ((null? ls) + (reverse res)) + ((symbol? (car ls)) + (lp (cddr ls) (cons (cadr ls) (cons (car ls) res)))) + ((pair? (car ls)) + (lp (cdr ls) (cons (cons (parse-type (caar ls)) (cdar ls)) res))) + (else + (lp (cdr ls) (cons (car ls) res)))))) + +(define-syntax define-struct-like + (er-macro-transformer + (lambda (expr rename compare) + (set! *types* + `((,(cadr expr) + ,@(parse-struct-like (cddr expr))) + ,@*types*)) + `(cat "\nstatic sexp_uint_t " ,(type-id-name (cadr expr)) ";\n")))) + +(define-syntax define-c-struct + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: struct ,@(cddr expr))))) + +(define-syntax define-c-class + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: class ,@(cddr expr))))) + +(define-syntax define-c-union + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: union ,@(cddr expr))))) + +(define-syntax define-c-type + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) ,@(cddr expr))))) + +(define-syntax define-c + (er-macro-transformer + (lambda (expr rename compare) + (set! *funcs* (cons (parse-func (cdr expr)) *funcs*)) + #f))) + +(define-syntax define-c-const + (er-macro-transformer + (lambda (expr rename compare) + (let ((type (parse-type (cadr expr)))) + (for-each (lambda (x) (set! *consts* (cons (list type x) *consts*))) + (cddr expr)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; C code generation + +(define (c->scheme-converter type val . o) + (let ((base (type-base type))) + (cond + ((and (eq? base 'void) (not (type-pointer? type))) + (cat "((" val "), SEXP_VOID)")) + ((or (eq? base 'sexp) (error-type? base)) + (cat val)) + ((eq? base 'boolean) + (cat "sexp_make_boolean(" val ")")) + ((eq? base 'time_t) + (cat "sexp_make_integer(ctx, sexp_shift_epoch(" val "))")) + ((unsigned-int-type? base) + (cat "sexp_make_unsigned_integer(ctx, " val ")")) + ((signed-int-type? base) + (cat "sexp_make_integer(ctx, " val ")")) + ((eq? base 'char) + (if (type-array type) + (cat "sexp_c_string(ctx, " val ", -1)") + (cat "sexp_make_character(ctx, " val ")"))) + ((eq? 'env-string base) + (cat "(p=strchr(" val ", '=') ? " + "sexp_cons(ctx, str=sexp_c_string(ctx, " val ", p - " val "), str=sexp_c_string(ctx, p, -1))" + " : sexp_cons(ctx, str=" val ", SEXP_FALSE)")) + ((string-type? base) + (cat "sexp_c_string(ctx, " val ", -1)")) + ((eq? 'input-port base) + (cat "sexp_make_input_port(ctx, " val ", SEXP_FALSE)")) + ((eq? 'output-port base) + (cat "sexp_make_output_port(ctx, " val ", SEXP_FALSE)")) + (else + (let ((ctype (assq base *types*)) + (void*? (void-pointer-type? type))) + (cond + ((or ctype void*?) + (cat "sexp_make_cpointer(ctx, " + (if void*? "SEXP_CPOINTER" (type-id-name base)) ", " + val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", " + (if (or (type-free? type) + (and (type-result? type) (not (basic-type? type)))) + 1 + 0) + ")")) + (else + (error "unknown type" base)))))))) + +(define (scheme->c-converter type val) + (let* ((type (parse-type type)) + (base (type-base type))) + (cond + ((eq? base 'sexp) + (cat val)) + ((eq? base 'boolean) + (cat "sexp_truep(" val ")")) + ((eq? base 'time_t) + (cat "sexp_unshift_epoch(sexp_uint_value(" val "))")) + ((signed-int-type? base) + (cat "sexp_sint_value(" val ")")) + ((unsigned-int-type? base) + (cat "sexp_uint_value(" val ")")) + ((eq? base 'char) + (cat "sexp_unbox_character(" val ")")) + ((eq? base 'env-string) + (cat "sexp_concat_env_string(" val ")")) + ((string-type? base) + (cat "sexp_string_data(" val ")")) + ((eq? base 'port-or-fd) + (cat "(sexp_portp(" val ") ? fileno(sexp_port_stream(" val "))" + " : sexp_unbox_fixnum(" val "))")) + ((port-type? base) + (cat "sexp_port_stream(" val ")")) + (else + (let ((ctype (assq base *types*)) + (void*? (void-pointer-type? type))) + (cond + ((or ctype void*?) + (cat "(" (type-c-name type) ")" + (if (type-null? type) + "sexp_cpointer_maybe_null_value" + "sexp_cpointer_value") + "(" val ")")) + (else + (error "unknown type" base)))))))) + +(define (type-predicate type) + (let ((base (type-base (parse-type type)))) + (cond + ((int-type? base) "sexp_exact_integerp") + ((float-type? base) "sexp_flonump") + ((string-type? base) "sexp_stringp") + ((eq? base 'char) "sexp_charp") + ((eq? base 'boolean) "sexp_booleanp") + ((eq? base 'port) "sexp_portp") + ((eq? base 'input-port) "sexp_iportp") + ((eq? base 'output-port) "sexp_oportp") + (else #f)))) + +(define (type-name type) + (let ((base (type-base (parse-type type)))) + (cond + ((int-type? base) "integer") + ((float-type? base) "flonum") + ((eq? 'boolean base) "int") + (else base)))) + +(define (base-type-c-name base) + (case base + ((string env-string non-null-string) "char*") + (else (symbol->string base)))) + +(define (type-struct-type type) + (let ((type-spec (assq (if (vector? type) (type-base type) type) *types*))) + (cond ((and type-spec (memq 'type: type-spec)) => cadr) + (else #f)))) + +(define (type-c-name type) + (let* ((type (parse-type type)) + (base (type-base type)) + (type-spec (assq base *types*)) + (struct-type (type-struct-type type))) + (string-append + (if (type-const? type) "const " "") + (if struct-type (string-append (symbol->string struct-type) " ") "") + (string-replace (base-type-c-name base) #\- " ") + (if struct-type "*" "") + (if (type-pointer? type) "*" "")))) + +(define (check-type arg type) + (let* ((type (parse-type type)) + (base (type-base type))) + (cond + ((eq? base 'env-string) + (cat "(sexp_pairp(" arg ") && sexp_stringp(sexp_car(" arg + ")) && sexp_stringp(sexp_cdr(" arg ")))")) + ((or (int-type? base) (float-type? base) + (string-type? base) (port-type? base)) + (cat (type-predicate type) "(" arg ")")) + ((or (assq base *types*) (void-pointer-type? type)) + (cat + (if (type-null? type) "(" "") + "(sexp_pointerp(" arg ")" + " && (sexp_pointer_tag(" arg ") == " + (if (void-pointer-type? type) "SEXP_CPOINTER" (type-id-name base)) "))" + (lambda () (if (type-null? type) (cat " || sexp_not(" arg "))"))))) + (else + (display "WARNING: don't know how to check: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)) + (cat "1"))))) + +(define (type-id-number type) + (let ((base (type-base type))) + (cond + ((int-type? base) "SEXP_FIXNUM") + ((float-type? base) "SEXP_FLONUM") + ((string-type? base) "SEXP_STRING") + ((eq? base 'char) "SEXP_CHAR") + ((eq? base 'boolean) "SEXP_BOOLEAN") + ((eq? base 'port) "SEXP_IPORT") + ((eq? base 'input-port) "SEXP_IPORT") + ((eq? base 'output-port) "SEXP_OPORT") + ((void-pointer-type? type) "SEXP_CPOINTER") + (else (type-id-name base))))) + +(define (write-validator arg type) + (let* ((type (parse-type type)) + (array (type-array type)) + (base-type (type-base type))) + (cond + ((and array (not (string-type? type))) + (cond + ((number? array) + (cat " if (!sexp_listp(ctx, " arg ")" + " || sexp_unbox_fixnum(sexp_length(" arg ")) != " array ")\n" + " return sexp_type_exception(ctx, self, SEXP_PAIR, " arg ");\n"))) + (cat " for (res=" arg "; sexp_pairp(res); res=sexp_cdr(res))\n" + " if (! " (lambda () (check-type "sexp_car(res)" type)) ")\n" + " return sexp_xtype_exception(ctx, self, \"not a list of " + (type-name type) "s\", " arg ");\n") + (if (not (number? array)) + (cat " if (! sexp_nullp(res))\n" + " return sexp_xtype_exception(ctx, self, \"not a list of " + (type-name type) "s\", " arg ");\n"))) + ((eq? base-type 'port-or-fd) + (cat " if (! (sexp_portp(" arg ") || sexp_fixnump(" arg ")))\n" + " return sexp_xtype_exception(ctx, self, \"not a port or file descriptor\"," arg ");\n")) + ((or (int-type? base-type) + (float-type? base-type) + (string-type? base-type) + (port-type? base-type)) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, self, " + (type-id-number type) ", " arg ");\n")) + ((or (assq base-type *types*) (void-pointer-type? type)) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, self, " + (type-id-number type) ", " arg ");\n")) + ((eq? 'sexp base-type)) + ((string-type? type) + (write-validator arg 'string)) + (else + (display "WARNING: don't know how to validate: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)))))) + +(define (write-parameters args) + (lambda () (for-each (lambda (a) (cat ", sexp arg" (type-index a))) args))) + +(define (get-array-length func x) + (let ((len (if (pair? (type-array x)) + (car (reverse (type-array x))) + (type-array x)))) + (if (number? len) + len + (and (symbol? len) + (let* ((str (symbol->string len)) + (len2 (string-length str))) + (and (> len2 3) + (string=? "arg" (substring str 0 3)) + (let ((i (string->number (substring str 3 len2)))) + (if i + (let ((y (list-ref (func-c-args func) i))) + (or (type-value y) len)))))))))) + +(define (write-locals func) + (define (arg-res x) + (string-append "res" (type-index-string x))) + (let* ((ret-type (func-ret-type func)) + (results (func-results func)) + (scheme-args (func-scheme-args func)) + (return-res? (not (error-type? (type-base ret-type)))) + (preserve-res? (> (+ (length results)) (if return-res? 0 1))) + (single-res? (and (= 1 (length results)) (not return-res?))) + (tmp-string? (any (lambda (a) + (and (type-array a) + (string-type? (type-base a)))) + (cons ret-type results))) + (gc-vars (map arg-res results)) + (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) + (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) + (sexps (if preserve-res? '() '("res"))) + (num-gc-vars (length gc-vars)) + (ints (if (or return-res? + (memq (type-base ret-type) + '(non-null-string non-null-pointer))) + '() + '("err"))) + (ints (if (or (array-type? ret-type) + (any array-type? results) + (any array-type? scheme-args)) + (cons "i" ints) + ints))) + (case (type-base ret-type) + ((non-null-string) (cat " char *err;\n")) + ((non-null-pointer) (cat " void *err;\n"))) + (cond + ((pair? ints) + (cat " int " (car ints)) + (for-each (lambda (x) (display ", ") (display x)) (cdr ints)) + (cat ";\n"))) + (if (any (lambda (a) (eq? 'env-string (type-base a))) + (cons ret-type results)) + (cat " char *p;\n")) + (for-each + (lambda (x) + (let ((len (get-array-length func x))) + (cat " " (type-c-name (type-base x)) " ") + (if (or (and (type-array x) (not (number? len))) (type-pointer? x)) + (cat "*")) + (cat (if (type-auto-expand? x) "buf" "tmp") (type-index-string x)) + (if (number? len) + (cat "[" len "]")) + (cat ";\n") + (if (or (vector? len) (type-auto-expand? x)) + (cat " int len" (type-index x) ";\n")) + (if (type-auto-expand? x) + (cat " " (type-c-name (type-base x)) + " *tmp" (type-index-string x) ";\n")))) + (append (if (or (type-array ret-type) (type-pointer? ret-type)) + (list ret-type) + '()) + results + (remove type-result? (filter type-array scheme-args)))) + (for-each + (lambda (arg) + (cond + ((and (type-pointer? arg) (basic-type? arg)) + (cat " " (type-c-name (type-base arg)) + " tmp" (type-index arg) ";\n")))) + scheme-args) + (cond + ((pair? sexps) + (cat " sexp " (car sexps)) + (for-each (lambda (x) (display ", ") (display x)) (cdr sexps)) + (cat ";\n"))) + (cond + ((pair? gc-vars) + (cat " sexp_gc_var" num-gc-vars "(") + (display (car gc-vars)) + (for-each (lambda (x) (display ", ") (display x)) (cdr gc-vars)) + (cat ");\n") + (cat " sexp_gc_preserve" num-gc-vars "(ctx") + (for-each (lambda (x) (display ", ") (display x)) gc-vars) + (cat ");\n"))))) + +(define (write-validators args) + (for-each + (lambda (a) + (write-validator (string-append "arg" (type-index-string a)) a)) + args)) + +(define (write-temporaries func) + (for-each + (lambda (a) + (let ((len (and (type-array a) (get-array-length func a)))) + (cond + ((and (type-array a) (or (vector? len) (type-auto-expand? a))) + (cat " len" (type-index a) " = " + (lambda () + (if (number? len) (cat len) (scheme->c-converter 'int len))) + ";\n" + " tmp" (type-index a) " = buf" (type-index a) ";\n"))) + (cond + ((and (not (type-result? a)) (type-array a) (not (string-type? a))) + (if (not (number? (type-array a))) + (cat " tmp" (type-index a) + " = (" (type-c-name (type-base a)) "*) malloc(" + "(sexp_unbox_fixnum(sexp_length(ctx, arg" (type-index a) + "))+1) * sizeof(tmp" (type-index a) "[0]));\n")) + (cat " for (i=0, res=arg" (type-index a) + "; sexp_pairp(res); res=sexp_cdr(res), i++) {\n" + " tmp" (type-index a) "[i] = " + (lambda () (scheme->c-converter (type-base a) "sexp_car(res)")) + ";\n" + " }\n") + (if (not (number? (type-array a))) + (cat " tmp" (type-index a) "[i] = NULL;\n"))) + ((and (type-result? a) (not (basic-type? a)) + (not (type-free? a)) ;;(not (type-pointer? a)) + (not (type-auto-expand? a)) + (or (not (type-array a)) + (not (integer? len)))) + (cat " tmp" (type-index a) " = malloc(" + (if (and (symbol? len) (not (eq? len 'null))) + (lambda () (cat (lambda () (scheme->c-converter 'unsigned-int len)) + "*sizeof(tmp" (type-index a) "[0])")) + (lambda () (cat "sizeof(tmp" (type-index a) "[0])"))) + ");\n")) + ((and (type-pointer? a) (basic-type? a)) + (cat " tmp" (type-index a) " = " + (lambda () + (scheme->c-converter + a + (string-append "arg" (type-index-string a)))) + ";\n"))))) + (func-c-args func))) + +(define (write-actual-parameter func arg) + (cond + ((and (not (type-default? arg)) (type-value arg)) + => (lambda (x) + (cond + ((any (lambda (y) + (and (type-array y) + (type-auto-expand? y) + (eq? x (get-array-length func y)))) + (func-c-args func)) + => (lambda (y) (cat "len" (type-index y)))) + (else (write x))))) + ((or (type-result? arg) (type-array arg)) + (cat (if (or (type-free? arg) (basic-type? arg)) ;; (type-pointer? arg) + "&" + "") + "tmp" (type-index arg))) + ((and (type-pointer? arg) (basic-type? arg)) + (cat "&tmp" (type-index arg))) + (else + (scheme->c-converter + arg + (string-append "arg" (type-index-string arg)))))) + +(define (write-call func) + (let ((ret-type (func-ret-type func)) + (c-name (func-c-name func)) + (c-args (func-c-args func))) + (if (any type-auto-expand? (func-c-args func)) + (cat " loop:\n")) + (cat (cond ((error-type? (type-base ret-type)) " err = ") + ((type-array ret-type) " tmp = ") + (else " res = "))) + ((if (type-array ret-type) + (lambda (t f x) (f)) + c->scheme-converter) + ret-type + (lambda () + (cat c-name "(") + (for-each + (lambda (arg) + (if (> (type-index arg) 0) (cat ", ")) + (write-actual-parameter func arg)) + c-args) + (cat ")")) + (cond + ((any type-link? (func-c-args func)) + => (lambda (a) (string-append "arg" (type-index-string a)))) + (else #f))) + (cat ";\n") + (if (type-array ret-type) + (write-result ret-type)))) + +(define (write-result result) + (let ((res (string-append "res" (type-index-string result))) + (tmp (string-append "tmp" (type-index-string result)))) + (cond + ((and (type-array result) (eq? 'char (type-base result))) + (cat " " res " = " (lambda () (c->scheme-converter result tmp)) ";\n")) + ((type-array result) + (cat " " res " = SEXP_NULL;\n") + (let ((auto-expand? + (and (pair? (type-array result)) + (memq 'auto-expand (type-array result)))) + (len (if (pair? (type-array result)) + (car (reverse (type-array result))) + (type-array result)))) + (cond + ((eq? 'null len) + (cat " for (i=0; " tmp "[i]; i++) {\n" + " sexp_push(ctx, " res ", " + (if (eq? 'string (type-base result)) + "str=" + (lambda () (cat "SEXP_VOID);\n sexp_car(" res ") = "))) + (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]")))) + ");\n" + " }\n" + " " res " = sexp_nreverse(ctx, " res ");\n")) + (else + (cat " for (i=" len "-1; i>=0; i--) {\n" + " sexp_push(ctx, " res ", SEXP_VOID);\n" + " sexp_car(" res ") = " + (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]")))) + ";\n" + " }\n"))))) + (else + (cat " " res " = ") + (c->scheme-converter + result + (string-append "tmp" (type-index-string result))) + (cat ";\n"))))) + +(define (write-results func) + (let ((error-res? (error-type? (type-base (func-ret-type func)))) + (results (func-results func))) + (if error-res? + (cat " if (" + (if (memq (type-base (func-ret-type func)) + '(non-null-string non-null-pointer)) + "!" + "") + "err) {\n" + (cond + ((any type-auto-expand? (func-c-args func)) + => (lambda (a) + (lambda () + (let ((len (get-array-length func a)) + (i (type-index a))) + (if (number? len) + (cat " if (len" i " != " len ")\n" + " free(tmp" i ");\n")) + (cat " len" i " *= 2;\n" + " tmp" i + " = malloc(len" i "*sizeof(tmp" i "[0]));\n" + " goto loop;\n"))))) + (else + " res = SEXP_FALSE;\n")) + " } else {\n")) + (if (null? results) + (if error-res? + (cat " res = SEXP_TRUE;\n")) + (for-each write-result results)) + (cond + ((> (length results) (if error-res? 1 0)) + (if error-res? + (cat " res = SEXP_NULL;\n") + (cat " res = sexp_cons(ctx, res, SEXP_NULL);\n")) + (for-each + (lambda (x) + (if error-res? + (cat " sexp_push(ctx, res, res" (type-index x) ");\n") + (cat " sexp_push(ctx, res, sexp_car(res));\n" + " sexp_cadr(res) = res" (type-index x) ";\n"))) + (reverse results))) + ((pair? results) + (cat " res = res" (type-index (car results)) ";\n"))) + (if error-res? + (cat " }\n")))) + +(define (write-free type) + (if (type-array type) + (cat " free(tmp" (type-index-string type) ");\n"))) + +(define (write-cleanup func) + (for-each write-free (func-scheme-args func)) + (for-each + (lambda (a) + (cond + ((type-auto-expand? a) + (let ((len (get-array-length func a)) + (i (type-index a))) + (if (number? len) + (cat " if (len" i " != " len ")\n" + " free(tmp" i ");\n")))) + ((and (type-result? a) (not (basic-type? a)) + (not (assq (type-base a) *types*)) + (not (type-free? a)) (not (type-pointer? a)) + (or (not (type-array a)) + (not (integer? (get-array-length func a))))) + ;; the above is hairy - basically this frees temporary strings + (cat " free(tmp" (type-index a) ");\n")))) + (func-c-args func)) + (let* ((results (func-results func)) + (return-res? (not (error-type? (type-base (func-ret-type func))))) + (preserve-res? (> (+ (length results)) (if return-res? 0 1))) + (single-res? (and (= 1 (length results)) (not return-res?))) + (tmp-string? (any (lambda (a) + (and (type-array a) + (string-type? (type-base a)))) + (cons (func-ret-type func) + (func-results func)))) + (gc-vars results) + (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) + (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) + (num-gc-vars (length gc-vars))) + (cond + ((pair? gc-vars) + (cat " sexp_gc_release" num-gc-vars "(ctx);\n"))))) + +(define (write-func func) + (cat "static sexp " (func-stub-name func) + " (sexp ctx sexp_api_params(self, n)" + (write-parameters (func-scheme-args func)) ") {\n") + (write-locals func) + (write-validators (func-scheme-args func)) + (write-temporaries func) + (write-call func) + (write-results func) + (write-cleanup func) + (cat " return res;\n" + "}\n\n")) + +(define (parameter-default? x) + (and (pair? x) + (member x '((current-input-port) + (current-output-port) + (current-error-port))))) + +(define (write-default x) ;; this is a hack but very convenient + (lambda () + (let ((value (type-value x))) + (cond + ((equal? value '(current-input-port)) + (cat "\"*current-input-port*\"")) + ((equal? value '(current-output-port)) + (cat "\"*current-output-port*\"")) + ((equal? value '(current-error-port)) + (cat "\"*current-error-port*\"")) + (else + (c->scheme-converter x value)))))) + +(define (write-func-binding func) + (let ((default (and (pair? (func-scheme-args func)) + (type-default? (car (reverse (func-scheme-args func)))) + (car (reverse (func-scheme-args func)))))) + (cat (if default + (if (parameter-default? (type-value default)) + " sexp_define_foreign_param(ctx, env, " + " sexp_define_foreign_opt(ctx, env, ") + " sexp_define_foreign(ctx, env, ") + (lambda () (write (symbol->string (func-scheme-name func)))) + ", " (length (func-scheme-args func)) ", " + (if default "(sexp_proc1)" "") + (func-stub-name func) + (if default ", " "") + (if default (write-default default) "") + ");\n"))) + +(define (write-type type) + (let ((name (car type)) + (type (cdr type))) + (cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n" + " " (type-id-name name) + " = sexp_unbox_fixnum(sexp_type_tag(sexp_register_c_type(ctx, name, " + (cond ((memq 'finalizer: type) + => (lambda (x) (generate-stub-name (cadr x)))) + (else "sexp_finalize_c_type")) + ")));\n") + (cond + ((memq 'predicate: type) + => (lambda (x) + (let ((pred (cadr x))) + (cat " tmp = sexp_make_type_predicate(ctx, name, " + "sexp_make_fixnum(" (type-id-name name) "));\n" + " name = sexp_intern(ctx, \"" pred "\", " + (string-length (x->string pred)) ");\n" + " sexp_env_define(ctx, env, name, tmp);\n"))))))) + +(define (type-getter-name type name field) + (string-append "sexp_" (x->string (type-name (parse-type name))) + "_get_" (x->string (type-base (parse-type (cadr field)))))) + +(define (write-type-getter type name field) + (cat "static sexp " (type-getter-name type name field) + " (sexp ctx sexp_api_params(self, n), sexp x) {\n" + (lambda () (write-validator "x" name)) + " return " + (lambda () + (c->scheme-converter + (car field) + (string-append (if (type-struct? (car field)) "&" "") + "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" + "sexp_cpointer_value(x))" "->" + (x->string (cadr field))) + (and (or (type-struct? (car field)) (type-link? (car field))) "x"))) + ";\n" + "}\n\n")) + +(define (type-setter-name type name field) + (string-append "sexp_" (x->string (type-name (parse-type name))) + "_set_" (x->string (type-base (parse-type (cadr field)))))) + +(define (write-type-setter-assignment type name field dst val) + (cond + ((type-struct? (car field)) + ;; assign to a nested struct - copy field-by-field + (let ((field-type + (cond ((assq (type-name (car field)) *types*) => cdddr) + (else (cdr field))))) + (lambda () + (for-each + (lambda (subfield) + (let ((subname (x->string (cadr subfield)))) + (cat + " " + (string-append dst "." (x->string (cadr subfield))) + " = " + (string-append + "((" (x->string (or (type-struct-type (type-name (car field))) "")) + " " (mangle (type-name (car field))) "*)" "sexp_cpointer_value(" val "))" + "->" (x->string (cadr subfield))) + ";\n"))) + (struct-fields field-type))))) + (else + (lambda () + (cat " " dst " = " (lambda () (scheme->c-converter (car field) val)) ";\n"))))) + +(define (write-type-setter type name field) + (cat "static sexp " (type-setter-name type name field) + " (sexp ctx sexp_api_params(self, n), sexp x, sexp v) {\n" + (lambda () (write-validator "x" name)) + (lambda () (write-validator "v" (car field))) + (write-type-setter-assignment + type name field + (string-append "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" "sexp_cpointer_value(x))" + "->" (x->string (cadr field))) + "v") + " return SEXP_VOID;\n" + "}\n\n")) + +(define (write-type-funcs orig-type) + (let ((name (car orig-type)) + (type (cdr orig-type))) + ;; maybe write finalizer + (cond + ((memq 'finalizer: type) + => (lambda (x) + (cat "static sexp " (generate-stub-name (cadr x)) + " (sexp ctx sexp_api_params(self, n), sexp x) {\n" + " if (sexp_cpointer_freep(x))\n" + " " (cadr x) "(sexp_cpointer_value(x));\n" + " return SEXP_VOID;\n" + "}\n\n")))) + ;; maybe write constructor + (cond + ((memq 'constructor: type) + => (lambda (x) + (let ((make (caadr x)) + (args (cdadr x))) + (cat "static sexp " (generate-stub-name make) + " (sexp ctx sexp_api_params(self, n)" + (lambda () + (let lp ((ls args) (i 0)) + (cond ((pair? ls) + (cat ", sexp arg" i) + (lp (cdr ls) (+ i 1)))))) + ") {\n" + " " (or (type-struct-type name) "") " " (type-name name) " *r;\n" + " sexp_gc_var1(res);\n" + " sexp_gc_preserve1(ctx, res);\n" + ;; " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), " + ;; (type-id-name name) + ;; ");\n" + ;; " r = sexp_cpointer_value(res) = sexp_cpointer_body(res);\n" + " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), " + (type-id-name name) + ");\n" + " r = sexp_cpointer_value(res) = malloc(sizeof(" + (or (type-struct-type name) "") " " (type-name name) "));\n" + " sexp_freep(res) = 1;\n" + (lambda () + (let lp ((ls args) (i 0)) + (cond + ((pair? ls) + (let* ((a (car ls)) + (field + (any (lambda (f) (and (pair? f) (eq? a (cadr f)))) + (cddr x)))) + (if field + (cat " r->" (cadr field) " = " + (lambda () + (scheme->c-converter + (car field) + (string-append "arg" + (number->string i)))) + ";\n")) + (lp (cdr ls) (+ i 1))))))) + " sexp_gc_release1(ctx);\n" + " return res;\n" + "}\n\n") + (set! *funcs* + (cons (parse-func `(void ,make ,args)) *funcs*)))))) + ;; write field accessors + (for-each + (lambda (field) + (cond + ((and (pair? field) (pair? (cdr field))) + (cond + ((and (pair? (cddr field)) (caddr field)) + (write-type-getter type name field) + (set! *funcs* + (cons (parse-func + `(,(car field) + (,(caddr field) + #f + ,(type-getter-name type name field)) + (,name))) + *funcs*)))) + (cond + ((and (pair? (cddr field)) + (pair? (cdddr field)) + (car (cdddr field))) + (write-type-setter type name field) + (set! *funcs* + (cons (parse-func + `(,(car field) + (,(car (cdddr field)) + #f + ,(type-setter-name type name field)) + (,name ,(car field)))) + *funcs*))))))) + (struct-fields type)))) + +(define (write-const const) + (let ((scheme-name (if (pair? (cadr const)) (caadr const) (cadr const))) + (c-name (if (pair? (cadr const)) (cadadr const) (mangle (cadr const))))) + (cat " name = sexp_intern(ctx, \"" scheme-name "\", " + (string-length (x->string scheme-name)) ");\n" + " sexp_env_define(ctx, env, name, tmp=" + (lambda () (c->scheme-converter (car const) c-name)) ");\n"))) + +(define (write-utilities) + (define (input-env-string? x) + (and (eq? 'env-string (type-base x)) (not (type-result? x)))) + (cond + ((any (lambda (f) + (or (any input-env-string? (func-results f)) + (any input-env-string? (func-scheme-args f)))) + *funcs*) + (cat "static char* sexp_concat_env_string (sexp x) {\n" + " int klen=sexp_string_length(sexp_car(x)), vlen=sexp_string_length(sexp_cdr(x));\n" + " char *res = (char*) malloc(klen+vlen+2);\n" + " strncpy(res, sexp_string_data(sexp_car(x)), klen);\n" + " res[sexp_string_length(sexp_car(x))] = '=';\n" + " strncpy(res+sexp_string_length(sexp_car(x)), sexp_string_data(sexp_cdr(x)), vlen);\n" + " res[len-1] = '\\0';\n" + " return res;\n" + "}\n\n")))) + +(define (write-init) + (newline) + (write-utilities) + (for-each write-func *funcs*) + (for-each write-type-funcs *types*) + (cat "sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {\n" + " sexp_gc_var2(name, tmp);\n" + " sexp_gc_preserve2(ctx, name, tmp);\n") + (for-each write-const *consts*) + (for-each write-type *types*) + (for-each write-func-binding *funcs*) + (for-each (lambda (x) (cat " " x "\n")) (reverse *inits*)) + (cat " sexp_gc_release2(ctx);\n" + " return SEXP_VOID;\n" + "}\n\n")) + +(define (generate file) + (display "/* automatically generated by chibi genstubs */\n") + (c-system-include "chibi/eval.h") + (load file) + (write-init)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; main + +(define (main args) + (case (length args) + ((1) + (with-output-to-file (string-append (strip-extension (car args)) ".c") + (lambda () (generate (car args))))) + ((2) + (if (equal? "-" (cadr args)) + (generate (car args)) + (with-output-to-file (cadr args) (lambda () (generate (car args)))))) + (else + (error "usage: genstubs []")))) diff --git a/vm.c b/vm.c new file mode 100644 index 00000000..acbea8b2 --- /dev/null +++ b/vm.c @@ -0,0 +1,1391 @@ +/* vm.c -- stack-based virtual machine backend */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#if SEXP_USE_DEBUG_VM > 1 +static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) { + int i; + if (! sexp_oportp(out)) out = sexp_current_error_port(ctx); + for (i=0; i4; i=sexp_unbox_fixnum(stack[i+3])) { + self = stack[i+2]; + if (sexp_procedurep(self)) { + sexp_write_string(ctx, " called from ", out); + bc = sexp_procedure_code(self); + if (sexp_truep(sexp_bytecode_name(bc))) + sexp_write(ctx, sexp_bytecode_name(bc), out); + else + sexp_write_string(ctx, "", out); + if ((ls=sexp_bytecode_source(bc)) && sexp_pairp(ls)) { + if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) { + sexp_write_string(ctx, " on line ", out); + sexp_write(ctx, sexp_cdr(ls), out); + } + if (sexp_stringp(sexp_car(ls))) { + sexp_write_string(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_car(ls)), out); + } + } + sexp_write_char(ctx, '\n', out); + } + } +} + +/************************* code generation ****************************/ + +static void emit_word (sexp ctx, sexp_uint_t val) { + unsigned char *data; + expand_bcode(ctx, sizeof(sexp)); + data = sexp_bytecode_data(sexp_context_bc(ctx)); + sexp_context_align_pos(ctx); + *((sexp_uint_t*)(&(data[sexp_context_pos(ctx)]))) = val; + sexp_context_pos(ctx) += sizeof(sexp); +} + +static void emit_push (sexp ctx, sexp obj) { + emit(ctx, SEXP_OP_PUSH); + emit_word(ctx, (sexp_uint_t)obj); + if (sexp_pointerp(obj) && ! sexp_symbolp(obj)) + sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), obj); +} + +static void emit_enter (sexp ctx) {return;} +static void bless_bytecode (sexp ctx, sexp bc) {return;} + +static void emit_return (sexp ctx) { + emit(ctx, SEXP_OP_RET); +} + +static sexp_sint_t sexp_context_make_label (sexp ctx) { + sexp_sint_t label; + sexp_context_align_pos(ctx); + label = sexp_context_pos(ctx); + sexp_context_pos(ctx) += sizeof(sexp_uint_t); + return label; +} + +static void sexp_context_patch_label (sexp ctx, sexp_sint_t label) { + sexp bc = sexp_context_bc(ctx); + unsigned char *data = sexp_bytecode_data(bc)+label; + *((sexp_sint_t*)data) = sexp_context_pos(ctx)-label; +} + +static void generate_lit (sexp ctx, sexp value) { + emit_push(ctx, value); +} + +static void generate_seq (sexp ctx, sexp app) { + sexp head=app, tail=sexp_cdr(app); + sexp_uint_t tailp = sexp_context_tailp(ctx); + sexp_context_tailp(ctx) = 0; + for ( ; sexp_pairp(tail); head=tail, tail=sexp_cdr(tail)) + if (sexp_pointerp(sexp_car(head)) && (! sexp_litp(sexp_car(head)))) { + generate(ctx, sexp_car(head)); + emit(ctx, SEXP_OP_DROP); + sexp_context_depth(ctx)--; + } + sexp_context_tailp(ctx) = tailp; + generate(ctx, sexp_car(head)); +} + +static void generate_cnd (sexp ctx, sexp cnd) { + sexp_sint_t label1, label2, tailp=sexp_context_tailp(ctx); + sexp_context_tailp(ctx) = 0; + generate(ctx, sexp_cnd_test(cnd)); + sexp_context_tailp(ctx) = tailp; + emit(ctx, SEXP_OP_JUMP_UNLESS); + sexp_context_depth(ctx)--; + label1 = sexp_context_make_label(ctx); + generate(ctx, sexp_cnd_pass(cnd)); + sexp_context_tailp(ctx) = tailp; + emit(ctx, SEXP_OP_JUMP); + sexp_context_depth(ctx)--; + label2 = sexp_context_make_label(ctx); + sexp_context_patch_label(ctx, label1); + generate(ctx, sexp_cnd_fail(cnd)); + sexp_context_patch_label(ctx, label2); +} + +static void generate_non_global_ref (sexp ctx, sexp name, sexp cell, + sexp lambda, sexp fv, int unboxp) { + sexp_uint_t i; + sexp loc = sexp_cdr(cell); + if (loc == lambda && sexp_lambdap(lambda)) { + /* local ref */ + emit(ctx, SEXP_OP_LOCAL_REF); + emit_word(ctx, sexp_param_index(lambda, name)); + } else { + /* closure ref */ + for (i=0; sexp_pairp(fv); fv=sexp_cdr(fv), i++) + if ((name == sexp_ref_name(sexp_car(fv))) + && (loc == sexp_ref_loc(sexp_car(fv)))) + break; + emit(ctx, SEXP_OP_CLOSURE_REF); + emit_word(ctx, i); + } + if (unboxp && (sexp_memq(ctx, name, sexp_lambda_sv(loc)) != SEXP_FALSE)) + emit(ctx, SEXP_OP_CDR); + sexp_context_depth(ctx)++; +} + +static void generate_ref (sexp ctx, sexp ref, int unboxp) { + sexp lam; + if (! sexp_lambdap(sexp_ref_loc(ref))) { + /* global ref */ + if (unboxp) { + emit(ctx, + (sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF) + ? SEXP_OP_GLOBAL_REF : SEXP_OP_GLOBAL_KNOWN_REF); + emit_word(ctx, (sexp_uint_t)sexp_ref_cell(ref)); + } else + emit_push(ctx, sexp_ref_cell(ref)); + } else { + lam = sexp_context_lambda(ctx); + generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref), + lam, sexp_lambda_fv(lam), unboxp); + } +} + +static void generate_set (sexp ctx, sexp set) { + sexp ref = sexp_set_var(set), lambda; + /* compile the value */ + sexp_context_tailp(ctx) = 0; + if (sexp_lambdap(sexp_set_value(set))) + sexp_lambda_name(sexp_set_value(set)) = sexp_ref_name(ref); + generate(ctx, sexp_set_value(set)); + if (! sexp_lambdap(sexp_ref_loc(ref))) { + /* global vars are set directly */ + emit_push(ctx, sexp_ref_cell(ref)); + emit(ctx, SEXP_OP_SET_CDR); + } else { + lambda = sexp_ref_loc(ref); + if (sexp_truep(sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)))) { + /* stack or closure mutable vars are boxed */ + generate_ref(ctx, ref, 0); + emit(ctx, SEXP_OP_SET_CDR); + } else { + /* internally defined variable */ + emit(ctx, SEXP_OP_LOCAL_SET); + emit_word(ctx, sexp_param_index(lambda, sexp_ref_name(ref))); + } + } + sexp_context_depth(ctx)--; +} + +static void generate_opcode_app (sexp ctx, sexp app) { + sexp op = sexp_car(app); + sexp_sint_t i, num_args, inv_default=0; + sexp_gc_var1(ls); + sexp_gc_preserve1(ctx, ls); + + num_args = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))); + sexp_context_tailp(ctx) = 0; + + /* maybe push the default for an optional argument */ + if ((num_args == sexp_opcode_num_args(op)) + && sexp_opcode_variadic_p(op) + && sexp_opcode_data(op) + && (sexp_opcode_class(op) != SEXP_OPC_PARAMETER)) { + if (sexp_opcode_inverse(op)) { + inv_default = 1; + } else { + emit_push(ctx, sexp_opcode_data(op)); + if (sexp_opcode_opt_param_p(op)) emit(ctx, SEXP_OP_CDR); + sexp_context_depth(ctx)++; + num_args++; + } + } + + /* push the arguments onto the stack in reverse order */ + ls = ((sexp_opcode_inverse(op) + && (sexp_opcode_class(op) != SEXP_OPC_ARITHMETIC)) + ? sexp_cdr(app) : sexp_reverse(ctx, sexp_cdr(app))); + for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) + generate(ctx, sexp_car(ls)); + + /* push the default for inverse opcodes */ + if (inv_default) { + emit_push(ctx, sexp_opcode_data(op)); + if (sexp_opcode_opt_param_p(op)) emit(ctx, SEXP_OP_CDR); + sexp_context_depth(ctx)++; + num_args++; + } + + /* emit the actual operator call */ + switch (sexp_opcode_class(op)) { + case SEXP_OPC_ARITHMETIC: + /* fold variadic arithmetic operators */ + for (i=num_args-1; i>0; i--) + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_ARITHMETIC_CMP: + if (num_args > 2) { + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, SEXP_OP_AND); + for (i=num_args-2; i>0; i--) { + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, SEXP_OP_AND); + emit(ctx, SEXP_OP_AND); + } + } else + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_FOREIGN: + emit(ctx, sexp_opcode_code(op)); + emit_word(ctx, (sexp_uint_t)op); + break; + case SEXP_OPC_TYPE_PREDICATE: + case SEXP_OPC_GETTER: + case SEXP_OPC_SETTER: + case SEXP_OPC_CONSTRUCTOR: + emit(ctx, sexp_opcode_code(op)); + if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR) + || sexp_opcode_code(op) == SEXP_OP_MAKE) { + if (sexp_opcode_data(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op))); + if (sexp_opcode_data2(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op))); + } + break; + case SEXP_OPC_PARAMETER: + emit_push(ctx, sexp_opcode_data(op)); + emit(ctx, ((num_args == 0) ? SEXP_OP_CDR : SEXP_OP_SET_CDR)); + break; + default: + emit(ctx, sexp_opcode_code(op)); + } + + sexp_context_depth(ctx) -= (num_args-1); + sexp_gc_release1(ctx); +} + +static void generate_general_app (sexp ctx, sexp app) { + sexp_uint_t len = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))), + tailp = sexp_context_tailp(ctx); + sexp_gc_var1(ls); + sexp_gc_preserve1(ctx, ls); + + /* push the arguments onto the stack */ + sexp_context_tailp(ctx) = 0; + for (ls=sexp_reverse(ctx, sexp_cdr(app)); sexp_pairp(ls); ls=sexp_cdr(ls)) + generate(ctx, sexp_car(ls)); + + /* push the operator onto the stack */ + generate(ctx, sexp_car(app)); + + /* maybe overwrite the current frame */ + emit(ctx, (tailp ? SEXP_OP_TAIL_CALL : SEXP_OP_CALL)); + emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len)); + + sexp_context_tailp(ctx) = tailp; + sexp_context_depth(ctx) -= len; + sexp_gc_release1(ctx); +} + +static void generate_app (sexp ctx, sexp app) { + if (sexp_opcodep(sexp_car(app))) + generate_opcode_app(ctx, app); + else + generate_general_app(ctx, app); +} + +static void generate_lambda (sexp ctx, sexp lambda) { + sexp ctx2, fv, ls, flags, len, ref, prev_lambda, prev_fv; + sexp_uint_t k; + sexp_gc_var2(tmp, bc); + sexp_gc_preserve2(ctx, tmp, bc); + prev_lambda = sexp_context_lambda(ctx); + prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL; + fv = sexp_lambda_fv(lambda); + ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx), 0); + sexp_context_lambda(ctx2) = lambda; + /* allocate space for local vars */ + for (ls=sexp_lambda_locals(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) + emit_push(ctx2, SEXP_VOID); + /* box mutable vars */ + for (ls=sexp_lambda_sv(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) { + k = sexp_param_index(lambda, sexp_car(ls)); + if (k >= 0) { + emit(ctx2, SEXP_OP_LOCAL_REF); + emit_word(ctx2, k); + emit_push(ctx2, sexp_car(ls)); + emit(ctx2, SEXP_OP_CONS); + emit(ctx2, SEXP_OP_LOCAL_SET); + emit_word(ctx2, k); + emit(ctx2, SEXP_OP_DROP); + } + } + sexp_context_tailp(ctx2) = 1; + generate(ctx2, sexp_lambda_body(lambda)); + flags = sexp_make_fixnum((sexp_listp(ctx2, sexp_lambda_params(lambda)) + == SEXP_FALSE) ? 1uL : 0uL); + len = sexp_length(ctx2, sexp_lambda_params(lambda)); + bc = finalize_bytecode(ctx2); + sexp_bytecode_name(bc) = sexp_lambda_name(lambda); + sexp_bytecode_source(bc) = sexp_lambda_source(lambda); + if (sexp_nullp(fv)) { + /* shortcut, no free vars */ + tmp = sexp_make_vector(ctx2, SEXP_ZERO, SEXP_VOID); + tmp = sexp_make_procedure(ctx2, flags, len, bc, tmp); + sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), tmp); + generate_lit(ctx, tmp); + } else { + /* push the closed vars */ + emit_push(ctx, SEXP_VOID); + emit_push(ctx, sexp_length(ctx, fv)); + emit(ctx, SEXP_OP_MAKE_VECTOR); + sexp_context_depth(ctx)--; + for (k=0; sexp_pairp(fv); fv=sexp_cdr(fv), k++) { + ref = sexp_car(fv); + generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref), + prev_lambda, prev_fv, 0); + emit_push(ctx, sexp_make_fixnum(k)); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, SEXP_OP_VECTOR_SET); + emit(ctx, SEXP_OP_DROP); + sexp_context_depth(ctx)--; + } + /* push the additional procedure info and make the closure */ + emit_push(ctx, bc); + emit_push(ctx, len); + emit_push(ctx, flags); + emit(ctx, SEXP_OP_MAKE_PROCEDURE); + } + sexp_gc_release2(ctx); +} + +static void generate (sexp ctx, sexp x) { + if (sexp_pointerp(x)) { + switch (sexp_pointer_tag(x)) { + case SEXP_PAIR: generate_app(ctx, x); break; + case SEXP_LAMBDA: generate_lambda(ctx, x); break; + case SEXP_CND: generate_cnd(ctx, x); break; + case SEXP_REF: generate_ref(ctx, x, 1); break; + case SEXP_SET: generate_set(ctx, x); break; + case SEXP_SEQ: generate_seq(ctx, sexp_seq_ls(x)); break; + case SEXP_LIT: generate_lit(ctx, sexp_lit_value(x)); break; + default: generate_lit(ctx, x); + } + } else { + generate_lit(ctx, x); + } +} + +static sexp make_param_list (sexp ctx, sexp_uint_t i) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; + for ( ; i>0; i--) + res = sexp_cons(ctx, sexp_make_fixnum(i), res); + sexp_gc_release1(ctx); + return res; +} + +static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { + sexp ls, bc, res, env; + sexp_gc_var5(params, ref, refs, lambda, ctx2); + if (i == sexp_opcode_num_args(op)) { /* return before preserving */ + if (sexp_opcode_proc(op)) return sexp_opcode_proc(op); + } else if (i < sexp_opcode_num_args(op)) { + return sexp_compile_error(ctx, "not enough args for opcode", op); + } else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */ + return sexp_compile_error(ctx, "too many args for opcode", op); + } + sexp_gc_preserve5(ctx, params, ref, refs, lambda, ctx2); + params = make_param_list(ctx, i); + lambda = sexp_make_lambda(ctx, params); + ctx2 = sexp_make_child_context(ctx, lambda); + env = sexp_extend_env(ctx2, sexp_context_env(ctx), params, lambda); + sexp_context_env(ctx2) = env; + for (ls=params, refs=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) { + ref = sexp_make_ref(ctx2, sexp_car(ls), sexp_env_cell(env, sexp_car(ls))); + sexp_push(ctx2, refs, ref); + } + refs = sexp_reverse(ctx2, refs); + refs = sexp_cons(ctx2, op, refs); + generate_opcode_app(ctx2, refs); + bc = finalize_bytecode(ctx2); + sexp_bytecode_name(bc) = sexp_c_string(ctx2, sexp_opcode_name(op), -1); + res=sexp_make_procedure(ctx2, SEXP_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID); + if (i == sexp_opcode_num_args(op)) + sexp_opcode_proc(op) = res; + sexp_gc_release5(ctx); + return res; +} + +/*********************** the virtual machine **************************/ + +static sexp sexp_save_stack (sexp ctx, sexp *stack, sexp_uint_t to) { + sexp res, *data; + sexp_uint_t i; + res = sexp_make_vector(ctx, sexp_make_fixnum(to), SEXP_VOID); + data = sexp_vector_data(res); + for (i=0; i= SEXP_INIT_STACK_SIZE) { + _ARG1 = sexp_global(ctx, SEXP_G_OOS_ERROR); + goto end_loop; + } +#endif + _ALIGN_IP(); + i = sexp_unbox_fixnum(_WORD0); + tmp1 = _ARG1; + make_call: + if (sexp_opcodep(tmp1)) { + /* compile non-inlined opcode applications on the fly */ + sexp_context_top(ctx) = top; + tmp1 = make_opcode_procedure(ctx, tmp1, i); + if (sexp_exceptionp(tmp1)) { + _ARG1 = tmp1; + goto call_error_handler; + } + } + if (! sexp_procedurep(tmp1)) + sexp_raise("non procedure application", sexp_list1(ctx, tmp1)); + j = i - sexp_unbox_fixnum(sexp_procedure_num_args(tmp1)); + if (j < 0) + sexp_raise("not enough args", + sexp_list2(ctx, tmp1, sexp_make_fixnum(i))); + if (j > 0) { + if (sexp_procedure_variadic_p(tmp1)) { + stack[top-i-1] = sexp_cons(ctx, stack[top-i-1], SEXP_NULL); + for (k=top-i; k=top-i; k--) + stack[k] = stack[k-1]; + stack[top-i-1] = SEXP_NULL; + top++; + i++; + } + _ARG1 = sexp_make_fixnum(i); + stack[top] = sexp_make_fixnum(ip+sizeof(sexp)-sexp_bytecode_data(bc)); + stack[top+1] = self; + stack[top+2] = sexp_make_fixnum(fp); + top += 3; + self = tmp1; + bc = sexp_procedure_code(self); + ip = sexp_bytecode_data(bc); + cp = sexp_procedure_vars(self); + fp = top-4; + break; + case SEXP_OP_FCALL0: + tmp1 = _WORD0; + _ALIGN_IP(); + sexp_context_top(ctx) = top; + sexp_context_last_fp(ctx) = fp; + _PUSH(((sexp_proc1)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 0))); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL1: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG1 = ((sexp_proc2)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 1), _ARG1); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL2: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG2 = ((sexp_proc3)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 2), _ARG1, _ARG2); + top--; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL3: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG3 = ((sexp_proc4)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 3), _ARG1, _ARG2, _ARG3); + top -= 2; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL4: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG4 = ((sexp_proc5)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 4), _ARG1, _ARG2, _ARG3, _ARG4); + top -= 3; + ip += sizeof(sexp); + sexp_check_exception(); + break; +#if SEXP_USE_EXTENDED_FCALL + case SEXP_OP_FCALLN: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + i = sexp_opcode_num_args(_WORD0); + tmp1 = sexp_fcall(ctx, self, i, _WORD0); + top -= (i-1); + _ARG1 = tmp1; + ip += sizeof(sexp); + sexp_check_exception(); + break; +#endif + case SEXP_OP_JUMP_UNLESS: + _ALIGN_IP(); + if (stack[--top] == SEXP_FALSE) + ip += _SWORD0; + else + ip += sizeof(sexp_sint_t); + break; + case SEXP_OP_JUMP: + _ALIGN_IP(); + ip += _SWORD0; + break; + case SEXP_OP_PUSH: + _ALIGN_IP(); + _PUSH(_WORD0); + ip += sizeof(sexp); + break; + case SEXP_OP_DROP: + top--; + break; + case SEXP_OP_GLOBAL_REF: + _ALIGN_IP(); + if (sexp_cdr(_WORD0) == SEXP_UNDEF) + sexp_raise("undefined variable", sexp_list1(ctx, sexp_car(_WORD0))); + /* ... FALLTHROUGH ... */ + case SEXP_OP_GLOBAL_KNOWN_REF: + _ALIGN_IP(); + _PUSH(sexp_cdr(_WORD0)); + ip += sizeof(sexp); + break; + case SEXP_OP_STACK_REF: /* `pick' in forth */ + _ALIGN_IP(); + stack[top] = stack[top - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case SEXP_OP_LOCAL_REF: + _ALIGN_IP(); + stack[top] = stack[fp - 1 - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case SEXP_OP_LOCAL_SET: + _ALIGN_IP(); + stack[fp - 1 - _SWORD0] = _ARG1; + _ARG1 = SEXP_VOID; + ip += sizeof(sexp); + break; + case SEXP_OP_CLOSURE_REF: + _ALIGN_IP(); + _PUSH(sexp_vector_ref(cp, sexp_make_fixnum(_WORD0))); + ip += sizeof(sexp); + break; + case SEXP_OP_VECTOR_REF: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-ref: not a vector", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("vector-ref: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + sexp_raise("vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_vector_ref(_ARG1, _ARG2); + top--; + break; + case SEXP_OP_VECTOR_SET: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-set!: not a vector", sexp_list1(ctx, _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("vector-set!: immutable vector", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("vector-set!: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + sexp_raise("vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + sexp_vector_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case SEXP_OP_VECTOR_LENGTH: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-length: not a vector", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_vector_length(_ARG1)); + break; + case SEXP_OP_BYTES_REF: + case SEXP_OP_STRING_REF: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-ref: not a string", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("string-ref: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_string_length(_ARG1))) + sexp_raise("string-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + if (ip[-1] == SEXP_OP_BYTES_REF) + _ARG2 = sexp_bytes_ref(_ARG1, _ARG2); + else +#if SEXP_USE_UTF8_STRINGS + _ARG2 = sexp_string_utf8_ref(ctx, _ARG1, _ARG2); +#else + _ARG2 = sexp_string_ref(_ARG1, _ARG2); +#endif + top--; + break; + case SEXP_OP_BYTES_SET: + case SEXP_OP_STRING_SET: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-set!: not a string", sexp_list1(ctx, _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("string-set!: immutable string", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("string-set!: not an integer", sexp_list1(ctx, _ARG2)); + else if (! sexp_charp(_ARG3)) + sexp_raise("string-set!: not a char", sexp_list1(ctx, _ARG3)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_string_length(_ARG1))) + sexp_raise("string-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + if (ip[-1] == SEXP_OP_BYTES_SET) + sexp_bytes_set(_ARG1, _ARG2, _ARG3); + else +#if SEXP_USE_UTF8_STRINGS + sexp_string_utf8_set(ctx, _ARG1, _ARG2, _ARG3); +#else + sexp_string_set(_ARG1, _ARG2, _ARG3); +#endif + _ARG3 = SEXP_VOID; + top-=2; + break; + case SEXP_OP_BYTES_LENGTH: + if (! sexp_stringp(_ARG1)) + sexp_raise("bytes-length: not a byte-vector", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_bytes_length(_ARG1)); + break; + case SEXP_OP_STRING_LENGTH: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-length: not a string", sexp_list1(ctx, _ARG1)); +#if SEXP_USE_UTF8_STRINGS + _ARG1 = sexp_make_fixnum(sexp_string_utf8_length((unsigned char*)sexp_string_data(_ARG1), sexp_string_length(_ARG1))); +#else + _ARG1 = sexp_make_fixnum(sexp_string_length(_ARG1)); +#endif + break; + case SEXP_OP_MAKE_PROCEDURE: + sexp_context_top(ctx) = top; + _ARG4 = sexp_make_procedure(ctx, _ARG1, _ARG2, _ARG3, _ARG4); + top-=3; + break; + case SEXP_OP_MAKE_VECTOR: + sexp_context_top(ctx) = top; + if (! sexp_fixnump(_ARG1)) + sexp_raise("make-vector: not an integer", sexp_list1(ctx, _ARG1)); + _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2); + top--; + break; + case SEXP_OP_MAKE_EXCEPTION: + _ARG5 = sexp_make_exception(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + break; + case SEXP_OP_AND: + _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE)); + top--; + break; + case SEXP_OP_EOFP: + _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; + case SEXP_OP_NULLP: + _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; + case SEXP_OP_FIXNUMP: + _ARG1 = sexp_make_boolean(sexp_fixnump(_ARG1)); break; + case SEXP_OP_SYMBOLP: + _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; + case SEXP_OP_CHARP: + _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; + case SEXP_OP_TYPEP: + _ALIGN_IP(); + _ARG1 = sexp_make_boolean(sexp_check_tag(_ARG1, _UWORD0)); + ip += sizeof(sexp); + break; + case SEXP_OP_MAKE: + _ALIGN_IP(); + _PUSH(sexp_alloc_tagged(ctx, _UWORD1, _UWORD0)); + ip += sizeof(sexp)*2; + break; + case SEXP_OP_SLOT_REF: + _ALIGN_IP(); + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); + _ARG1 = sexp_slot_ref(_ARG1, _UWORD1); + ip += sizeof(sexp)*2; + break; + case SEXP_OP_SLOT_SET: + _ALIGN_IP(); + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1)); + sexp_slot_set(_ARG1, _UWORD1, _ARG2); + _ARG2 = SEXP_VOID; + ip += sizeof(sexp)*2; + top--; + break; + case SEXP_OP_ISA: + _ARG2 = sexp_make_boolean(sexp_isa(_ARG1, _ARG2)); + top--; + break; + case SEXP_OP_SLOTN_REF: + if (! sexp_typep(_ARG1)) + sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1)); + else if (! sexp_isa(_ARG2, _ARG1)) + sexp_raise("slot-ref: bad type", sexp_list1(ctx, _ARG2)); + else if (! sexp_fixnump(_ARG3)) + sexp_raise("slot-ref: not an integer", sexp_list1(ctx, _ARG3)); + _ARG3 = sexp_slot_ref(_ARG2, sexp_unbox_fixnum(_ARG3)); + top-=2; + break; + case SEXP_OP_SLOTN_SET: + if (! sexp_typep(_ARG1)) + sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1)); + else if (! sexp_isa(_ARG2, _ARG1)) + sexp_raise("slot-set!: bad type", sexp_list1(ctx, _ARG2)); + else if (sexp_immutablep(_ARG2)) + sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG2)); + else if (! sexp_fixnump(_ARG3)) + sexp_raise("slot-ref: not an integer", sexp_list1(ctx, _ARG3)); + sexp_slot_set(_ARG2, sexp_unbox_fixnum(_ARG3), _ARG4); + _ARG4 = SEXP_VOID; + top-=3; + break; + case SEXP_OP_CAR: + if (! sexp_pairp(_ARG1)) + sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_car(_ARG1); break; + case SEXP_OP_CDR: + if (! sexp_pairp(_ARG1)) + sexp_raise("cdr: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_cdr(_ARG1); break; + case SEXP_OP_SET_CAR: + if (! sexp_pairp(_ARG1)) + sexp_raise("set-car!: not a pair", sexp_list1(ctx, _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("set-car!: immutable pair", sexp_list1(ctx, _ARG1)); + sexp_car(_ARG1) = _ARG2; + _ARG2 = SEXP_VOID; + top--; + break; + case SEXP_OP_SET_CDR: + if (! sexp_pairp(_ARG1)) + sexp_raise("set-cdr!: not a pair", sexp_list1(ctx, _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("set-cdr!: immutable pair", sexp_list1(ctx, _ARG1)); + sexp_cdr(_ARG1) = _ARG2; + _ARG2 = SEXP_VOID; + top--; + break; + case SEXP_OP_CONS: + sexp_context_top(ctx) = top; + _ARG2 = sexp_cons(ctx, _ARG1, _ARG2); + top--; + break; + case SEXP_OP_ADD: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + j = sexp_unbox_fixnum(tmp1) + sexp_unbox_fixnum(tmp2); + if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) + _ARG1 = sexp_add(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG1 = sexp_make_fixnum(j); + } + else { + _ARG1 = sexp_add(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_fx_add(tmp1, tmp2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_add(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) + (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) + sexp_flonum_value(tmp2)); +#endif + else sexp_raise("+: not a number", sexp_list2(ctx, tmp1, tmp2)); +#endif + break; + case SEXP_OP_SUB: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + j = sexp_unbox_fixnum(tmp1) - sexp_unbox_fixnum(tmp2); + if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) + _ARG1 = sexp_sub(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG1 = sexp_make_fixnum(j); + } + else { + _ARG1 = sexp_sub(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_fx_sub(tmp1, tmp2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_sub(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) - (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) - sexp_flonum_value(tmp2)); +#endif + else sexp_raise("-: not a number", sexp_list2(ctx, tmp1, tmp2)); +#endif + break; + case SEXP_OP_MUL: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + prod = (sexp_lsint_t)sexp_unbox_fixnum(tmp1) * sexp_unbox_fixnum(tmp2); + if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM)) + _ARG1 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG1 = sexp_make_fixnum(prod); + } + else { + _ARG1 = sexp_mul(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_fx_mul(tmp1, tmp2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_mul(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) * (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) * sexp_flonum_value(tmp2)); +#endif + else sexp_raise("*: not a number", sexp_list2(ctx, tmp1, tmp2)); +#endif + break; + case SEXP_OP_DIV: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (tmp2 == SEXP_ZERO) { +#if SEXP_USE_FLONUMS + if (sexp_flonump(tmp1) && sexp_flonum_value(tmp1) == 0.0) + _ARG1 = sexp_make_flonum(ctx, 0.0); + else +#endif + sexp_raise("divide by zero", SEXP_NULL); + } else if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { +#if SEXP_USE_FLONUMS + tmp1 = sexp_fixnum_to_flonum(ctx, tmp1); + tmp2 = sexp_fixnum_to_flonum(ctx, tmp2); + _ARG1 = sexp_fp_div(ctx, tmp1, tmp2); + if (sexp_flonum_value(_ARG1) == trunc(sexp_flonum_value(_ARG1))) + _ARG1 = sexp_make_fixnum(sexp_flonum_value(_ARG1)); +#else + _ARG1 = sexp_fx_div(tmp1, tmp2); +#endif + } +#if SEXP_USE_BIGNUMS + else { + _ARG1 = sexp_div(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else +#if SEXP_USE_FLONUMS + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_div(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) / (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) / sexp_flonum_value(tmp2)); +#endif + else sexp_raise("/: not a number", sexp_list2(ctx, tmp1, tmp2)); +#endif + break; + case SEXP_OP_QUOTIENT: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + if (tmp2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + _ARG1 = sexp_fx_div(tmp1, tmp2); + } +#if SEXP_USE_BIGNUMS + else { + _ARG1 = sexp_quotient(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, tmp2)); +#endif + break; + case SEXP_OP_REMAINDER: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + if (tmp2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + _ARG1 = sexp_fx_rem(tmp1, tmp2); + } +#if SEXP_USE_BIGNUMS + else { + _ARG1 = sexp_remainder(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, tmp2)); +#endif + break; + case SEXP_OP_LT: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + i = (sexp_sint_t)tmp1 < (sexp_sint_t)tmp2; +#if SEXP_USE_BIGNUMS + _ARG1 = sexp_make_boolean(i); + } else { + _ARG1 = sexp_compare(ctx, tmp1, tmp2); + sexp_check_exception(); + _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) < 0); + } +#else +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) { + i = sexp_flonum_value(tmp1) < sexp_flonum_value(tmp2); + } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) { + i = sexp_flonum_value(tmp1) < (double)sexp_unbox_fixnum(tmp2); + } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) { + i = (double)sexp_unbox_fixnum(tmp1) < sexp_flonum_value(tmp2); +#endif + } else sexp_raise("<: not a number", sexp_list2(ctx, tmp1, tmp2)); + _ARG1 = sexp_make_boolean(i); +#endif + break; + case SEXP_OP_LE: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + i = (sexp_sint_t)tmp1 <= (sexp_sint_t)tmp2; +#if SEXP_USE_BIGNUMS + _ARG1 = sexp_make_boolean(i); + } else { + _ARG1 = sexp_compare(ctx, tmp1, tmp2); + sexp_check_exception(); + _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) <= 0); + } +#else +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) { + i = sexp_flonum_value(tmp1) <= sexp_flonum_value(tmp2); + } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) { + i = sexp_flonum_value(tmp1) <= (double)sexp_unbox_fixnum(tmp2); + } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) { + i = (double)sexp_unbox_fixnum(tmp1) <= sexp_flonum_value(tmp2); +#endif + } else sexp_raise("<=: not a number", sexp_list2(ctx, tmp1, tmp2)); + _ARG1 = sexp_make_boolean(i); +#endif + break; + case SEXP_OP_EQN: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + i = tmp1 == tmp2; +#if SEXP_USE_BIGNUMS + _ARG1 = sexp_make_boolean(i); + } else { + _ARG1 = sexp_compare(ctx, tmp1, tmp2); + sexp_check_exception(); + _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) == 0); + } +#else +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) { + i = sexp_flonum_value(tmp1) == sexp_flonum_value(tmp2); + } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) { + i = sexp_flonum_value(tmp1) == (double)sexp_unbox_fixnum(tmp2); + } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) { + i = (double)sexp_unbox_fixnum(tmp1) == sexp_flonum_value(tmp2); +#endif + } else sexp_raise("=: not a number", sexp_list2(ctx, tmp1, tmp2)); + _ARG1 = sexp_make_boolean(i); +#endif + break; + case SEXP_OP_EQ: + _ARG2 = sexp_make_boolean(_ARG1 == _ARG2); + top--; + break; + case SEXP_OP_FIX2FLO: + if (sexp_fixnump(_ARG1)) + _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, sexp_bignum_to_double(_ARG1)); +#endif + else if (! sexp_flonump(_ARG1)) + sexp_raise("exact->inexact: not a number", sexp_list1(ctx, _ARG1)); + break; + case SEXP_OP_FLO2FIX: + if (sexp_flonump(_ARG1)) { + if (sexp_flonum_value(_ARG1) != trunc(sexp_flonum_value(_ARG1))) { + sexp_raise("inexact->exact: not an integer", sexp_list1(ctx, _ARG1)); +#if SEXP_USE_BIGNUMS + } else if ((sexp_flonum_value(_ARG1) > SEXP_MAX_FIXNUM) + || sexp_flonum_value(_ARG1) < SEXP_MIN_FIXNUM) { + _ARG1 = sexp_double_to_bignum(ctx, sexp_flonum_value(_ARG1)); +#endif + } else { + _ARG1 = sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(_ARG1)); + } + } else if (! sexp_fixnump(_ARG1) && ! sexp_bignump(_ARG1)) { + sexp_raise("inexact->exact: not a number", sexp_list1(ctx, _ARG1)); + } + break; + case SEXP_OP_CHAR2INT: + if (! sexp_charp(_ARG1)) + sexp_raise("char->integer: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_unbox_character(_ARG1)); + break; + case SEXP_OP_INT2CHAR: + if (! sexp_fixnump(_ARG1)) + sexp_raise("integer->char: not an integer", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(sexp_unbox_fixnum(_ARG1)); + break; + case SEXP_OP_CHAR_UPCASE: + if (! sexp_charp(_ARG1)) + sexp_raise("char-upcase: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(toupper(sexp_unbox_character(_ARG1))); + break; + case SEXP_OP_CHAR_DOWNCASE: + if (! sexp_charp(_ARG1)) + sexp_raise("char-downcase: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(tolower(sexp_unbox_character(_ARG1))); + break; + case SEXP_OP_WRITE_CHAR: + if (! sexp_charp(_ARG1)) + sexp_raise("write-char: not a character", sexp_list1(ctx, _ARG1)); + if (! sexp_oportp(_ARG2)) + sexp_raise("write-char: not an output-port", sexp_list1(ctx, _ARG2)); +#if SEXP_USE_UTF8_STRINGS + if (sexp_unbox_character(_ARG1) >= 0x80) + sexp_write_utf8_char(ctx, sexp_unbox_character(_ARG1), _ARG2); + else +#endif + sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + case SEXP_OP_NEWLINE: + if (! sexp_oportp(_ARG1)) + sexp_raise("newline: not an output-port", sexp_list1(ctx, _ARG1)); + sexp_newline(ctx, _ARG1); + _ARG1 = SEXP_VOID; + break; + case SEXP_OP_READ_CHAR: + if (! sexp_iportp(_ARG1)) + sexp_raise("read-char: not an input-port", sexp_list1(ctx, _ARG1)); + i = sexp_read_char(ctx, _ARG1); +#if SEXP_USE_UTF8_STRINGS + if (i >= 0x80) + _ARG1 = sexp_read_utf8_char(ctx, _ARG1, i); + else +#endif + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case SEXP_OP_PEEK_CHAR: + if (! sexp_iportp(_ARG1)) + sexp_raise("peek-char: not an input-port", sexp_list1(ctx, _ARG1)); + i = sexp_read_char(ctx, _ARG1); + sexp_push_char(ctx, i, _ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case SEXP_OP_YIELD: + fuel = 0; + _PUSH(SEXP_VOID); + break; + case SEXP_OP_RET: + i = sexp_unbox_fixnum(stack[fp]); + stack[fp-i] = _ARG1; + top = fp-i+1; + self = stack[fp+2]; + bc = sexp_procedure_code(self); + ip = sexp_bytecode_data(bc) + sexp_unbox_fixnum(stack[fp+1]); + cp = sexp_procedure_vars(self); + fp = sexp_unbox_fixnum(stack[fp+3]); + break; + case SEXP_OP_DONE: + goto end_loop; + default: + sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_fixnum(*(ip-1)))); + } + goto loop; + + end_loop: +#if SEXP_USE_GREEN_THREADS + if (ctx != root_thread) { + if (sexp_context_refuel(root_thread) <= 0) { + /* the root already terminated */ + _ARG1 = SEXP_VOID; + } else { + /* don't return from child threads */ + sexp_context_refuel(ctx) = fuel = 0; + goto loop; + } + } +#endif + sexp_gc_release3(ctx); + sexp_context_top(ctx) = top; + return _ARG1; +} + +/******************************* apply ********************************/ + +sexp sexp_apply1 (sexp ctx, sexp f, sexp x) { + sexp res; + sexp_gc_var1(args); + if (sexp_opcodep(f)) { + res = ((sexp_proc2)sexp_opcode_func(f))(ctx sexp_api_pass(f, 1), x); + } else { + sexp_gc_preserve1(ctx, args); + res = sexp_apply(ctx, f, args=sexp_list1(ctx, x)); + sexp_gc_release1(ctx); + } + return res; +} + +sexp sexp_apply (sexp ctx, sexp proc, sexp args) { + sexp res, ls, *stack = sexp_stack_data(sexp_context_stack(ctx)); + sexp_sint_t top = sexp_context_top(ctx), len, offset; + len = sexp_unbox_fixnum(sexp_length(ctx, args)); + if (sexp_opcodep(proc)) + proc = make_opcode_procedure(ctx, proc, len); + if (! sexp_procedurep(proc)) { + res = sexp_exceptionp(proc) ? proc : + sexp_type_exception(ctx, NULL, SEXP_PROCEDURE, proc); + } else { + offset = top + len; + for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++) + stack[--offset] = sexp_car(ls); + stack[top++] = sexp_make_fixnum(len); + stack[top++] = SEXP_ZERO; + stack[top++] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); + stack[top++] = SEXP_ZERO; + sexp_context_top(ctx) = top; + res = sexp_vm(ctx, proc); + if (! res) res = SEXP_VOID; /* shouldn't happen */ + } + return res; +}