From b5f07e6da674fc3368746305706e8078ea5e2740 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 14 Apr 2009 21:28:21 +0900 Subject: [PATCH] fixing syntax-rules.scm --- .hgignore | 19 + Makefile | 71 + README | 27 + VERSION | 1 + config.h | 31 + debug.c | 73 + defaults.h | 73 + eval.c | 1854 ++++++++++++++++++++++++ eval.h | 137 ++ init.scm | 525 +++++++ main.c | 110 ++ opcodes.c | 130 ++ sexp-huff.c | 128 ++ sexp-hufftabs.c | 92 ++ sexp-unhuff.c | 71 + sexp.c | 1147 +++++++++++++++ sexp.h | 441 ++++++ syntax-rules.scm | 182 +++ tests/basic/test00-fact-3.res | 1 + tests/basic/test00-fact-3.scm | 14 + tests/basic/test01-apply.res | 8 + tests/basic/test01-apply.scm | 18 + tests/basic/test02-closure.res | 6 + tests/basic/test02-closure.scm | 16 + tests/basic/test03-nested-closure.res | 1 + tests/basic/test03-nested-closure.scm | 8 + tests/basic/test04-nested-let.res | 1 + tests/basic/test04-nested-let.scm | 9 + tests/basic/test05-internal-define.res | 1 + tests/basic/test05-internal-define.scm | 8 + tests/basic/test06-letrec.res | 4 + tests/basic/test06-letrec.scm | 15 + tests/basic/test07-mutation.res | 1 + tests/basic/test07-mutation.scm | 9 + tests/basic/test08-callcc.res | 1 + tests/basic/test08-callcc.scm | 34 + tests/basic/test09-hygiene.res | 5 + tests/basic/test09-hygiene.scm | 25 + tests/basic/test10-unhygiene.res | 6 + tests/basic/test10-unhygiene.scm | 49 + tests/r5rs-tests.scm | 373 +++++ 41 files changed, 5725 insertions(+) create mode 100644 .hgignore create mode 100644 Makefile create mode 100644 README create mode 100644 VERSION create mode 100644 config.h create mode 100644 debug.c create mode 100644 defaults.h create mode 100644 eval.c create mode 100644 eval.h create mode 100644 init.scm create mode 100644 main.c create mode 100644 opcodes.c create mode 100644 sexp-huff.c create mode 100644 sexp-hufftabs.c create mode 100644 sexp-unhuff.c create mode 100644 sexp.c create mode 100644 sexp.h create mode 100644 syntax-rules.scm create mode 100644 tests/basic/test00-fact-3.res create mode 100644 tests/basic/test00-fact-3.scm create mode 100644 tests/basic/test01-apply.res create mode 100644 tests/basic/test01-apply.scm create mode 100644 tests/basic/test02-closure.res create mode 100644 tests/basic/test02-closure.scm create mode 100644 tests/basic/test03-nested-closure.res create mode 100644 tests/basic/test03-nested-closure.scm create mode 100644 tests/basic/test04-nested-let.res create mode 100644 tests/basic/test04-nested-let.scm create mode 100644 tests/basic/test05-internal-define.res create mode 100644 tests/basic/test05-internal-define.scm create mode 100644 tests/basic/test06-letrec.res create mode 100644 tests/basic/test06-letrec.scm create mode 100644 tests/basic/test07-mutation.res create mode 100644 tests/basic/test07-mutation.scm create mode 100644 tests/basic/test08-callcc.res create mode 100644 tests/basic/test08-callcc.scm create mode 100644 tests/basic/test09-hygiene.res create mode 100644 tests/basic/test09-hygiene.scm create mode 100644 tests/basic/test10-unhygiene.res create mode 100644 tests/basic/test10-unhygiene.scm create mode 100644 tests/r5rs-tests.scm diff --git a/.hgignore b/.hgignore new file mode 100644 index 00000000..51566e20 --- /dev/null +++ b/.hgignore @@ -0,0 +1,19 @@ +syntax: glob +*~ +*.i +*.s +*.o +*.so +*.dSYM +*.orig +.hg +junk* +*.tar.gz +*.tar.bz2 +*.log +*.err +*.out +gc +gc6.8 +chibi-scheme + diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..c4166b8d --- /dev/null +++ b/Makefile @@ -0,0 +1,71 @@ + +.PHONY: all doc dist clean cleaner test install uninstall + +all: chibi-scheme + +PREFIX=/usr/local +BINDIR=$(PREFIX)/bin +LIBDIR=$(PREFIX)/lib +INCDIR=$(PREFIX)/include/chibi-scheme +MODDIR=$(PREFIX)/share/chibi-scheme + +LDFLAGS=-lm +CFLAGS=-Wall -g -Os + +GC_OBJ=./gc/gc.a + +./gc/gc.a: ./gc/alloc.c + cd gc && make + +sexp.o: sexp.c sexp.h config.h defaults.h Makefile + gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< + +eval.o: eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile + gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< + +main.o: main.c eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile + gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< + +chibi-scheme: main.o sexp.o $(GC_OBJ) + gcc $(CFLAGS) $(LDFLAGS) -o $@ $^ + +clean: + rm -f *.o *.i *.s + +cleaner: clean + rm -f chibi-scheme + rm -rf *.dSYM + +test: chibi-scheme + @for f in tests/basic/*.scm; do \ + ./chibi-scheme $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ + if diff -q $${f%.scm}.out $${f%.scm}.res; then \ + echo "[PASS] $${f%.scm}"; \ + else \ + echo "[FAIL] $${f%.scm}"; \ + fi; \ + done + ./chibi-scheme -l syntax-rules.scm tests/r5rs-tests.scm + +# install: chibi-scheme +# cp chibi-scheme $(BINDIR)/ +# mkdir -p $(MODDIR) +# cp init.scm $(MODDIR)/ +# mkdir -p $(INCDIR) +# cp *.h $(INCDIR)/ +# cp *.$(SO) $(LIBDIR)/ + +# uninstall: +# rm -f $(BINDIR)/chibi-scheme +# rm -f $(LIBDIR)/libchibischeme.$(SO) +# rm -f $(LIBDIR)/libchibisexp.$(SO) +# rm -f $(INCDIR)/*.h +# rm -f $(MODDIR)/*.scm + +dist: cleaner + rm -f chibi-scheme-`cat VERSION`.tgz + mkdir chibi-scheme-`cat VERSION` + for f in `hg manifest`; do mkdir -p chibi-scheme-`cat VERSION`/`dirname $$f`; ln -s `pwd`/$$f chibi-scheme-`cat VERSION`/$$f; done + cd chibi-scheme-`cat VERSION`; tar xzvf ../gc.tar.gz; mv gc[0-9].[0-9] gc + tar cphzvf chibi-scheme-`cat VERSION`.tgz chibi-scheme-`cat VERSION` + rm -rf chibi-scheme-`cat VERSION` diff --git a/README b/README new file mode 100644 index 00000000..e4eb9abc --- /dev/null +++ b/README @@ -0,0 +1,27 @@ + + Chibi-Scheme + -------------- + + Simple and Minimal Scheme Implementation + + http://synthcode.com/scheme/chibi-scheme-0.1.tgz + + version 0.1 + April 8, 2009 + + +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. Currently Chibi-Scheme uses the +Boehm conservative garbage collector to try to play well with C code. + +To build, just run "make". You can edit the file config.h for a +number of settings, mostly disabling features to make the executable +smaller. Documents and examples for using Chibi-Scheme as a library +for extension scripting will be provided in an upcoming release. + +syntax-rules must be loaded manually from the file syntax-rules.scm. diff --git a/VERSION b/VERSION new file mode 100644 index 00000000..49d59571 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +0.1 diff --git a/config.h b/config.h new file mode 100644 index 00000000..81f1444c --- /dev/null +++ b/config.h @@ -0,0 +1,31 @@ +/* config.h -- general configuration */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +/* uncomment this to use manual memory management */ +/* #define USE_BOEHM 0 */ + +/* uncomment this if you only want fixnum support */ +/* #define USE_FLONUMS 0 */ + +/* uncomment this if you don't need extended math operations */ +/* #define USE_MATH 0 */ + +/* uncomment this to disable warning about references to undefined variables */ +/* #define USE_WARN_UNDEFS 0 */ + +/* uncomment this to disable huffman-coded immediate symbols */ +/* #define USE_HUFF_SYMS 0 */ + +/* uncomment this to just use a single list for hash tables */ +/* #define USE_HASH_SYMS 0 */ + +/* uncomment this to disable string ports */ +/* #define USE_STRING_STREAMS 0 */ + +/* uncomment this to disable a small optimization for let */ +/* #define USE_FAST_LET 0 */ + +/* uncomment this to enable debugging utilities */ +/* #define USE_DEBUG 1 */ + diff --git a/debug.c b/debug.c new file mode 100644 index 00000000..f39ba635 --- /dev/null +++ b/debug.c @@ -0,0 +1,73 @@ +/* debug.c -- optional debugging utilities */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +static const char* reverse_opcode_names[] = + {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", + "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", + "EVAL", "JUMP-UNLESS", + "JUMP", "PUSH", "DROP", "GLOBAL-REF", "GLOBAL-KNOWN-REF", "STACK-REF", + "LOCAL-REF", "LOCAL-SET", + "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF", + "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "AND", + "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", + "EOF?", "TYPEP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", + "MUL", "DIV", "QUOTIENT", "REMAINDER", "NEGATIVE", "INVERSE", + "LT", "LE", "EQN", "EQ", + "EXACT->INEXACT", "INEXACT->EXACT", + "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", + "DISPLAY", "WRITE", "WRITE-CHAR", + "NEWLINE", "FLUSH-OUTPUT", "READ", "READ-CHAR", "PEEK-CHAR", "RET", "DONE", + }; + +static sexp sexp_disasm (sexp bc, sexp out) { + unsigned char *ip, opcode; + if (sexp_procedurep(bc)) + bc = sexp_procedure_code(bc); + ip = sexp_bytecode_data(bc); + loop: + opcode = *ip++; + if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) { + sexp_printf(out, " %s ", reverse_opcode_names[opcode]); + } else { + sexp_printf(out, " %d ", opcode); + } + switch (opcode) { + case OP_STACK_REF: + case OP_LOCAL_REF: + case OP_LOCAL_SET: + case OP_CLOSURE_REF: + case OP_JUMP: + case OP_JUMP_UNLESS: + case OP_FCALL0: + case OP_FCALL1: + case OP_FCALL2: + case OP_FCALL3: + case OP_TYPEP: + sexp_printf(out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); + ip += sizeof(sexp); + break; + case OP_GLOBAL_REF: + case OP_GLOBAL_KNOWN_REF: + case OP_TAIL_CALL: + case OP_CALL: + case OP_PUSH: + sexp_write(((sexp*)ip)[0], out); + ip += sizeof(sexp); + break; + } + sexp_write_char('\n', out); + if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) + goto loop; + return SEXP_VOID; +} + +static void sexp_print_stack (sexp *stack, int top, int fp, sexp out) { + int i; + for (i=0; i +#else +/* requires msg be a string literal, and at least one argument */ +#define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code)) +#endif + +#if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__) +#define SEXP_BSD 1 +#else +#define SEXP_BSD 0 +#define _GNU_SOURCE +#endif + +#ifndef USE_BOEHM +#define USE_BOEHM 1 +#endif + +#ifndef USE_FLONUMS +#define USE_FLONUMS 1 +#endif + +#ifndef USE_MATH +#define USE_MATH 1 +#endif + +#ifndef USE_WARN_UNDEFS +#define USE_WARN_UNDEFS 1 +#endif + +#ifndef USE_HUFF_SYMS +#define USE_HUFF_SYMS 1 +#endif + +#ifndef USE_HASH_SYMS +#define USE_HASH_SYMS 1 +#endif + +#ifndef USE_DEBUG +#define USE_DEBUG 1 +#endif + +#ifndef USE_STRING_STREAMS +#define USE_STRING_STREAMS 1 +#endif + +#ifndef USE_FAST_LET +#define USE_FAST_LET 1 +#endif + +#ifndef USE_CHECK_STACK +#define USE_CHECK_STACK 0 +#endif + +#if USE_BOEHM +#include "gc/include/gc.h" +#define sexp_alloc GC_malloc +#define sexp_alloc_atomic GC_malloc_atomic +#define sexp_realloc GC_realloc +#define sexp_free(x) +#define sexp_deep_free(x) +#else +#define sexp_alloc malloc +#define sexp_alloc_atomic sexp_alloc +#define sexp_realloc realloc +#define sexp_free free +void sexp_deep_free(sexp obj); +#endif + diff --git a/eval.c b/eval.c new file mode 100644 index 00000000..28cc7b61 --- /dev/null +++ b/eval.c @@ -0,0 +1,1854 @@ +/* eval.c -- evaluator library implementation */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "eval.h" + +/************************************************************************/ + +static int scheme_initialized_p = 0; + +static sexp continuation_resumer, final_resumer; +static sexp the_interaction_env_symbol; +static sexp the_err_handler_symbol, the_compile_error_symbol; +static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol; + +#if USE_DEBUG +#include "debug.c" +#else +#define print_stack(...) +#define print_bytecode(...) +#define sexp_disasm(...) +#endif + +static sexp analyze (sexp x, sexp context); +static void generate (sexp x, sexp context); +static sexp sexp_make_null_env (sexp version); +static sexp sexp_make_standard_env (sexp version); + +/********************** environment utilities ***************************/ + +static sexp env_cell(sexp e, sexp key) { + sexp ls; + + do { + for (ls=sexp_env_bindings(e); sexp_pairp(ls); ls=sexp_cdr(ls)) + if (sexp_caar(ls) == key) + return sexp_car(ls); + e = sexp_env_parent(e); + } while (e); + + return NULL; +} + +static sexp env_cell_create(sexp e, sexp key, sexp value) { + sexp cell = env_cell(e, key); + if (! cell) { + cell = sexp_cons(key, value); + while (sexp_env_parent(e)) + e = sexp_env_parent(e); + sexp_env_bindings(e) = sexp_cons(cell, sexp_env_bindings(e)); + } + return cell; +} + +static sexp env_global_ref(sexp e, sexp key, sexp dflt) { + sexp cell; + while (sexp_env_parent(e)) + e = sexp_env_parent(e); + cell = env_cell(e, key); + return (cell ? sexp_cdr(cell) : dflt); +} + +static void env_define(sexp e, sexp key, sexp value) { + sexp cell = sexp_assq(key, sexp_env_bindings(e)); + if (cell != SEXP_FALSE) + sexp_cdr(cell) = value; + else + sexp_push(sexp_env_bindings(e), sexp_cons(key, value)); +} + +static sexp extend_env (sexp env, sexp vars, sexp value) { + sexp e = sexp_alloc_type(env, SEXP_ENV); + sexp_env_parent(e) = env; + sexp_env_bindings(e) = SEXP_NULL; + for ( ; sexp_pairp(vars); vars = sexp_cdr(vars)) + sexp_push(sexp_env_bindings(e), sexp_cons(sexp_car(vars), value)); + return e; +} + +static sexp sexp_reverse_flatten_dot (sexp ls) { + sexp res; + for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_push(res, sexp_car(ls)); + return (sexp_nullp(ls) ? res : sexp_cons(ls, res)); +} + +static sexp sexp_flatten_dot (sexp ls) { + return sexp_nreverse(sexp_reverse_flatten_dot(ls)); +} + +static 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 context, sexp_uint_t i) { + sexp tmp; + if (sexp_bytecode_length(sexp_context_bc(context)) != i) { + tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) + i, SEXP_BYTECODE); + sexp_bytecode_name(tmp) = SEXP_FALSE; + sexp_bytecode_length(tmp) = i; + sexp_bytecode_literals(tmp) + = sexp_bytecode_literals(sexp_context_bc(context)); + memcpy(sexp_bytecode_data(tmp), + sexp_bytecode_data(sexp_context_bc(context)), + i); + sexp_context_bc(context) = tmp; + } +} + +static void expand_bcode(sexp context, sexp_uint_t size) { + sexp tmp; + if (sexp_bytecode_length(sexp_context_bc(context)) + < (sexp_context_pos(context))+size) { + tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) + + sexp_bytecode_length(sexp_context_bc(context))*2, + SEXP_BYTECODE); + sexp_bytecode_name(tmp) = SEXP_FALSE; + sexp_bytecode_length(tmp) + = sexp_bytecode_length(sexp_context_bc(context))*2; + sexp_bytecode_literals(tmp) + = sexp_bytecode_literals(sexp_context_bc(context)); + memcpy(sexp_bytecode_data(tmp), + sexp_bytecode_data(sexp_context_bc(context)), + sexp_bytecode_length(sexp_context_bc(context))); + sexp_context_bc(context) = tmp; + } +} + +static void emit(char c, sexp context) { + expand_bcode(context, 1); + sexp_bytecode_data(sexp_context_bc(context))[sexp_context_pos(context)++] = c; +} + +static void emit_word(sexp_uint_t val, sexp context) { + unsigned char *data; + expand_bcode(context, sizeof(sexp)); + data = sexp_bytecode_data(sexp_context_bc(context)); + *((sexp_uint_t*)(&(data[sexp_context_pos(context)]))) = val; + sexp_context_pos(context) += sizeof(sexp); +} + +static void emit_push(sexp obj, sexp context) { + emit(OP_PUSH, context); + emit_word((sexp_uint_t)obj, context); + if (sexp_pointerp(obj)) + sexp_push(sexp_bytecode_literals(sexp_context_bc(context)), obj); +} + +static sexp sexp_make_procedure(sexp flags, sexp num_args, + sexp bc, sexp vars) { + sexp proc = sexp_alloc_type(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 p, sexp e) { + sexp mac = sexp_alloc_type(macro, SEXP_MACRO); + sexp_macro_env(mac) = e; + sexp_macro_proc(mac) = p; + return mac; +} + +static sexp sexp_make_synclo (sexp env, sexp fv, sexp expr) { + sexp res; + if (sexp_synclop(expr)) + return expr; + res = sexp_alloc_type(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 params) { + sexp res = sexp_alloc_type(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; + return res; +} + +static sexp sexp_make_set(sexp var, sexp value) { + sexp res = sexp_alloc_type(set, SEXP_SET); + sexp_set_var(res) = var; + sexp_set_value(res) = value; + return res; +} + +static sexp sexp_make_ref(sexp name, sexp cell) { + sexp res = sexp_alloc_type(ref, SEXP_REF); + sexp_ref_name(res) = name; + sexp_ref_cell(res) = cell; + return res; +} + +static sexp sexp_make_cnd(sexp test, sexp pass, sexp fail) { + sexp res = sexp_alloc_type(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 value) { + sexp res = sexp_alloc_type(lit, SEXP_LIT); + sexp_lit_value(res) = value; + return res; +} + +static sexp sexp_make_context(sexp *stack, sexp env) { + sexp res = sexp_alloc_type(context, SEXP_CONTEXT); + if (! stack) + stack = (sexp*) sexp_alloc(sizeof(sexp)*INIT_STACK_SIZE); + if (! env) + env = sexp_make_standard_env(sexp_make_integer(5)); + sexp_context_bc(res) + = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE); + sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE; + sexp_bytecode_length(sexp_context_bc(res)) = INIT_BCODE_SIZE; + sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL; + sexp_context_lambda(res) = SEXP_FALSE; + sexp_context_stack(res) = stack; + sexp_context_env(res) = env; + sexp_context_fv(res) = SEXP_NULL; + sexp_context_depth(res) = 0; + sexp_context_pos(res) = 0; + sexp_context_top(res) = 0; + sexp_context_tailp(res) = 0; + sexp_context_tracep(res) = 0; + return res; +} + +static sexp sexp_child_context(sexp context, sexp lambda) { + sexp ctx = sexp_make_context(sexp_context_stack(context), + sexp_context_env(context)); + sexp_context_lambda(ctx) = lambda; + sexp_context_env(ctx) = sexp_context_env(context); + sexp_context_top(ctx) = sexp_context_top(context); + sexp_context_fv(ctx) = sexp_context_fv(context); + sexp_context_tracep(ctx) = sexp_context_tracep(context); + return ctx; +} + +#define sexp_idp(x) (sexp_symbolp(x) || (sexp_synclop(x) && sexp_symbolp(sexp_synclo_expr(x)))) + +static sexp sexp_identifierp (sexp x) { + return sexp_make_boolean(sexp_idp(x)); +} + +static sexp sexp_syntactic_closure_expr (sexp x) { + return (sexp_synclop(x) ? sexp_synclo_expr(x) : x); +} + +static sexp sexp_strip_syntactic_closures (sexp x) { + loop: + if (sexp_synclop(x)) { + x = sexp_synclo_expr(x); + goto loop; + } else if (sexp_pairp(x)) { + return sexp_cons(sexp_strip_syntactic_closures(sexp_car(x)), + sexp_strip_syntactic_closures(sexp_cdr(x))); + } else { + return x; + } +} + +static sexp sexp_identifier_eq (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 = env_cell(e1, id1); + if (cell && sexp_lambdap(sexp_cdr(cell))) + lam1 = sexp_cdr(cell); + cell = 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 sexp_compile_error(char *message, sexp irritants) { + return sexp_make_exception(the_compile_error_symbol, + sexp_c_string(message), + irritants, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE); +} + +#define analyze_check_exception(x) do {if (sexp_exceptionp(x)) \ + return (x); \ + } while (0) + +#define analyze_bind(var, x, context) do {(var) = analyze(x,context); \ + analyze_check_exception(var); \ + } while (0) + +static sexp analyze_app (sexp x, sexp context) { + sexp res=SEXP_NULL, tmp; + for ( ; sexp_pairp(x); x=sexp_cdr(x)) { + analyze_bind(tmp, sexp_car(x), context); + sexp_push(res, tmp); + } + return sexp_nreverse(res); +} + +static sexp analyze_seq (sexp ls, sexp context) { + sexp res, tmp; + if (sexp_nullp(ls)) + res = SEXP_VOID; + else if (sexp_nullp(sexp_cdr(ls))) + res = analyze(sexp_car(ls), context); + else { + res = sexp_alloc_type(seq, SEXP_SEQ); + tmp = analyze_app(ls, context); + analyze_check_exception(tmp); + sexp_seq_ls(res) = tmp; + } + return res; +} + +static sexp analyze_var_ref (sexp x, sexp context) { + sexp env = sexp_context_env(context), cell; + cell = env_cell(env, x); + if (! cell) { + if (sexp_synclop(x)) { + if (sexp_memq(x, sexp_context_fv(context)) != SEXP_FALSE) + env = sexp_synclo_env(x); + x = sexp_synclo_expr(x); + } + cell = env_cell_create(env, x, SEXP_UNDEF); + } + if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell))) + return sexp_compile_error("invalid use of syntax as value", sexp_list1(x)); + return sexp_make_ref(x, cell); +} + +static sexp analyze_set (sexp x, sexp context) { + sexp ref, value; + ref = analyze_var_ref(sexp_cadr(x), context); + if (sexp_lambdap(sexp_ref_loc(ref))) + sexp_insert(sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref)); + analyze_check_exception(ref); + analyze_bind(value, sexp_caddr(x), context); + return sexp_make_set(ref, value); +} + +static sexp analyze_lambda (sexp x, sexp context) { + sexp res, body, ls, tmp, name, value, defs=SEXP_NULL; + /* verify syntax */ + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) + return sexp_compile_error("bad lambda syntax", sexp_list1(x)); + for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls)) + if (! sexp_idp(sexp_car(ls))) + return sexp_compile_error("non-symbol parameter", sexp_list1(x)); + else if (sexp_memq(sexp_car(ls), sexp_cdr(ls)) != SEXP_FALSE) + return sexp_compile_error("duplicate parameter", sexp_list1(x)); + /* build lambda and analyze body */ + res = sexp_make_lambda(sexp_cadr(x)); + context = sexp_child_context(context, res); + sexp_context_env(context) + = extend_env(sexp_context_env(context), + sexp_flatten_dot(sexp_lambda_params(res)), + res); + sexp_env_lambda(sexp_context_env(context)) = res; + body = analyze_seq(sexp_cddr(x), context); + analyze_check_exception(body); + /* delayed analyze internal defines */ + for (ls=sexp_lambda_defs(res); sexp_pairp(ls); ls=sexp_cdr(ls)) { + tmp = sexp_car(ls); + if (sexp_pairp(sexp_cadr(tmp))) { + name = sexp_caadr(tmp); + value = analyze_lambda(sexp_cons(SEXP_VOID, sexp_cons(sexp_cdadr(tmp), + sexp_cddr(tmp))), + context); + } else { + name = sexp_cadr(tmp); + value = analyze(sexp_caddr(tmp), context); + } + analyze_check_exception(value); + sexp_push(defs, sexp_make_set(analyze_var_ref(name, context), value)); + } + if (sexp_pairp(defs)) { + if (! sexp_seqp(body)) { + tmp = sexp_alloc_type(seq, SEXP_SEQ); + sexp_seq_ls(tmp) = sexp_list1(body); + body = tmp; + } + sexp_seq_ls(body) = sexp_append(defs, sexp_seq_ls(body)); + } + sexp_lambda_body(res) = body; + return res; +} + +static sexp analyze_if (sexp x, sexp context) { + sexp test, pass, fail, fail_expr; + analyze_bind(test, sexp_cadr(x), context); + analyze_bind(pass, sexp_caddr(x), context); + fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID; + analyze_bind(fail, fail_expr, context); + return sexp_make_cnd(test, pass, fail); +} + +static sexp analyze_define (sexp x, sexp context) { + sexp ref, name, value, env = sexp_context_env(context); + name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x)); + if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) { + sexp_push(sexp_env_bindings(env), + sexp_cons(name, sexp_context_lambda(context))); + sexp_push(sexp_lambda_sv(sexp_env_lambda(env)), name); + sexp_push(sexp_lambda_locals(sexp_env_lambda(env)), name); + sexp_push(sexp_lambda_defs(sexp_env_lambda(env)), x); + return SEXP_VOID; + } else { + env_cell_create(env, name, SEXP_VOID); + } + if (sexp_pairp(sexp_cadr(x))) + value = analyze_lambda(sexp_cons(SEXP_VOID, + sexp_cons(sexp_cdadr(x), sexp_cddr(x))), + context); + else + value = analyze(sexp_caddr(x), context); + analyze_check_exception(value); + ref = analyze_var_ref(name, context); + analyze_check_exception(ref); + return sexp_make_set(ref, value); +} + +static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { + sexp proc; + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { + proc = eval_in_context(sexp_cadar(ls), eval_ctx); + analyze_check_exception(proc); + if (sexp_procedurep(proc)) + sexp_push(sexp_env_bindings(sexp_context_env(bind_ctx)), + sexp_cons(sexp_caar(ls), + sexp_make_macro(proc, sexp_context_env(eval_ctx)))); + } + return SEXP_VOID; +} + +static sexp analyze_define_syntax (sexp x, sexp context) { + return analyze_bind_syntax(sexp_list1(sexp_cdr(x)), context, context); +} + +static sexp analyze_let_syntax (sexp x, sexp context) { + sexp env, ctx, tmp; + env = sexp_alloc_type(env, SEXP_ENV); + sexp_env_parent(env) = sexp_env_parent(sexp_context_env(context)); + sexp_env_bindings(env) = sexp_env_bindings(sexp_context_env(context)); + ctx = sexp_child_context(context, sexp_context_lambda(context)); + sexp_context_env(ctx) = env; + tmp = analyze_bind_syntax(sexp_cadr(x), context, ctx); + analyze_check_exception(tmp); + return analyze_seq(sexp_cddr(x), ctx); +} + +static sexp analyze_letrec_syntax (sexp x, sexp context) { + sexp tmp = analyze_bind_syntax(sexp_cadr(x), context, context); + analyze_check_exception(tmp); + return analyze_seq(sexp_cddr(x), context); +} + +static sexp analyze (sexp x, sexp context) { + sexp op, cell, res; + loop: + if (sexp_pairp(x)) { + if (sexp_listp(x) == SEXP_FALSE) { + res = sexp_compile_error("dotted list in source", sexp_list1(x)); + } else if (sexp_idp(sexp_car(x))) { + cell = env_cell(sexp_context_env(context), sexp_car(x)); + if (! cell && sexp_synclop(sexp_car(x))) + cell = env_cell(sexp_synclo_env(sexp_car(x)), + sexp_synclo_expr(sexp_car(x))); + if (! cell) return analyze_app(x, context); + op = sexp_cdr(cell); + if (sexp_corep(op)) { + switch (sexp_core_code(op)) { + case CORE_DEFINE: + res = analyze_define(x, context); break; + case CORE_SET: + res = analyze_set(x, context); break; + case CORE_LAMBDA: + res = analyze_lambda(x, context); break; + case CORE_IF: + res = analyze_if(x, context); break; + case CORE_BEGIN: + res = analyze_seq(sexp_cdr(x), context); break; + case CORE_QUOTE: + res = sexp_make_lit(sexp_strip_syntactic_closures(sexp_cadr(x))); + break; + case CORE_DEFINE_SYNTAX: + res = analyze_define_syntax(x, context); break; + case CORE_LET_SYNTAX: + res = analyze_let_syntax(x, context); break; + case CORE_LETREC_SYNTAX: + res = analyze_letrec_syntax(x, context); break; + default: + res = sexp_compile_error("unknown core form", sexp_list1(op)); break; + } + } else if (sexp_macrop(op)) { + /* if (in_repl_p) sexp_debug("expand: ", x, context); */ + x = apply(sexp_macro_proc(op), + sexp_list3(x, sexp_context_env(context), sexp_macro_env(op)), + sexp_child_context(context, sexp_context_lambda(context))); + /* if (in_repl_p) sexp_debug(" => ", x, context); */ + goto loop; + } else if (sexp_opcodep(op)) { + res = sexp_length(sexp_cdr(x)); + if (sexp_unbox_integer(res) < sexp_opcode_num_args(op)) { + res = sexp_compile_error("not enough args for opcode", sexp_list1(x)); + } else if ((sexp_unbox_integer(res) > sexp_opcode_num_args(op)) + && (! sexp_opcode_variadic_p(op))) { + res = sexp_compile_error("too many args for opcode", sexp_list1(x)); + } else { + res = analyze_app(sexp_cdr(x), context); + analyze_check_exception(res); + sexp_push(res, op); + } + } else { + res = analyze_app(x, context); + } + } else { + res = analyze_app(x, context); + } + } else if (sexp_idp(x)) { + res = analyze_var_ref(x, context); + } else if (sexp_synclop(x)) { + context = sexp_child_context(context, sexp_context_lambda(context)); + sexp_context_env(context) = sexp_synclo_env(x); + sexp_context_fv(context) = sexp_append(sexp_synclo_free_vars(x), + sexp_context_fv(context)); + x = sexp_synclo_expr(x); + goto loop; + } else { + res = x; + } + return res; +} + +static sexp_sint_t sexp_context_make_label (sexp context) { + sexp_sint_t label = sexp_context_pos(context); + sexp_context_pos(context) += sizeof(sexp_uint_t); + return label; +} + +static void sexp_context_patch_label (sexp context, sexp_sint_t label) { + sexp bc = sexp_context_bc(context); + unsigned char *data = sexp_bytecode_data(bc)+label; + *((sexp_sint_t*)data) = sexp_context_pos(context)-label; +} + +static sexp finalize_bytecode (sexp context) { + emit(OP_RET, context); + shrink_bcode(context, sexp_context_pos(context)); + return sexp_context_bc(context); +} + +static void generate_lit (sexp value, sexp context) { + emit_push(value, context); +} + +static void generate_seq (sexp app, sexp context) { + sexp head=app, tail=sexp_cdr(app); + sexp_uint_t tailp = sexp_context_tailp(context); + sexp_context_tailp(context) = 0; + for ( ; sexp_pairp(tail); head=tail, tail=sexp_cdr(tail)) + if (sexp_pointerp(sexp_car(head)) && (! sexp_litp(sexp_car(head)))) { + generate(sexp_car(head), context); + emit(OP_DROP, context); + sexp_context_depth(context)--; + } + sexp_context_tailp(context) = tailp; + generate(sexp_car(head), context); +} + +static void generate_cnd (sexp cnd, sexp context) { + sexp_sint_t label1, label2, tailp=sexp_context_tailp(context); + sexp_context_tailp(context) = 0; + generate(sexp_cnd_test(cnd), context); + sexp_context_tailp(context) = tailp; + emit(OP_JUMP_UNLESS, context); + sexp_context_depth(context)--; + label1 = sexp_context_make_label(context); + generate(sexp_cnd_pass(cnd), context); + emit(OP_JUMP, context); + sexp_context_depth(context)--; + label2 = sexp_context_make_label(context); + sexp_context_patch_label(context, label1); + generate(sexp_cnd_fail(cnd), context); + sexp_context_patch_label(context, label2); +} + +static void generate_non_global_ref (sexp name, sexp cell, sexp lambda, + sexp fv, sexp context, int unboxp) { + sexp_uint_t i; + sexp loc = sexp_cdr(cell); + if (loc == lambda && sexp_lambdap(lambda)) { + /* local ref */ + emit(OP_LOCAL_REF, context); + emit_word(sexp_param_index(lambda, name), context); + } 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(OP_CLOSURE_REF, context); + emit_word(i, context); + } + if (unboxp && (sexp_memq(name, sexp_lambda_sv(loc)) != SEXP_FALSE)) + emit(OP_CDR, context); + sexp_context_depth(context)++; +} + +static void generate_ref (sexp ref, sexp context, int unboxp) { + sexp lam; + if (! sexp_lambdap(sexp_ref_loc(ref))) { + /* global ref */ + if (unboxp) { + emit((sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF) + ? OP_GLOBAL_REF : OP_GLOBAL_KNOWN_REF, + context); + emit_word((sexp_uint_t)sexp_ref_cell(ref), context); + } else + emit_push(sexp_ref_cell(ref), context); + } else { + lam = sexp_context_lambda(context); + generate_non_global_ref(sexp_ref_name(ref), sexp_ref_cell(ref), lam, + sexp_lambda_fv(lam), context, unboxp); + } +} + +static void generate_set (sexp set, sexp context) { + sexp ref = sexp_set_var(set), lambda; + /* compile the value */ + sexp_context_tailp(context) = 0; + if (sexp_lambdap(sexp_set_value(set))) + sexp_lambda_name(sexp_set_value(set)) = sexp_ref_name(ref); + generate(sexp_set_value(set), context); + if (! sexp_lambdap(sexp_ref_loc(ref))) { + /* global vars are set directly */ + emit_push(sexp_ref_cell(ref), context); + emit(OP_SET_CDR, context); + } else { + lambda = sexp_ref_loc(ref); + if (sexp_memq(sexp_ref_name(ref), sexp_lambda_sv(lambda)) != SEXP_FALSE) { + /* stack or closure mutable vars are boxed */ + generate_ref(ref, context, 0); + emit(OP_SET_CDR, context); + } else { + /* internally defined variable */ + emit(OP_LOCAL_SET, context); + emit_word(sexp_param_index(lambda, sexp_ref_name(ref)), context); + } + } + sexp_context_depth(context)--; +} + +static void generate_opcode_app (sexp app, sexp context) { + sexp ls, op = sexp_car(app); + sexp_sint_t i, num_args = sexp_unbox_integer(sexp_length(sexp_cdr(app))); + sexp_context_tailp(context) = 0; + + /* maybe push the default for an optional argument */ + if ((num_args == sexp_opcode_num_args(op)) + && sexp_opcode_variadic_p(op) + && sexp_opcode_default(op) + && (sexp_opcode_class(op) != OPC_PARAMETER)) { + emit_push(sexp_opcode_default(op), context); + if (sexp_opcode_opt_param_p(op)) + emit(OP_CDR, context); + sexp_context_depth(context)++; + num_args++; + } + + /* push the arguments onto the stack */ + ls = ((sexp_opcode_inverse(op) + && (sexp_opcode_class(op) != OPC_ARITHMETIC_INV)) + ? sexp_cdr(app) : sexp_reverse(sexp_cdr(app))); + for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) + generate(sexp_car(ls), context); + + /* emit the actual operator call */ + switch (sexp_opcode_class(op)) { + case OPC_ARITHMETIC: + if (num_args > 1) + emit(sexp_opcode_code(op), context); + break; + case OPC_ARITHMETIC_INV: + emit((num_args == 1) ? sexp_opcode_inverse(op) + : sexp_opcode_code(op), context); + break; + case OPC_ARITHMETIC_CMP: + if (num_args > 2) { + emit(OP_STACK_REF, context); + emit_word(2, context); + emit(OP_STACK_REF, context); + emit_word(2, context); + emit(sexp_opcode_code(op), context); + emit(OP_AND, context); + for (i=num_args-2; i>0; i--) { + emit(OP_STACK_REF, context); + emit_word(3, context); + emit(OP_STACK_REF, context); + emit_word(3, context); + emit(sexp_opcode_code(op), context); + emit(OP_AND, context); + emit(OP_AND, context); + } + } else + emit(sexp_opcode_code(op), context); + break; + case OPC_FOREIGN: + case OPC_TYPE_PREDICATE: + /* push the funtion pointer for foreign calls */ + emit(sexp_opcode_code(op), context); + if (sexp_opcode_data(op)) + emit_word((sexp_uint_t)sexp_opcode_data(op), context); + break; + case OPC_PARAMETER: + emit_push(sexp_opcode_default(op), context); + emit((num_args == 0 ? OP_CDR : OP_SET_CDR), context); + break; + default: + emit(sexp_opcode_code(op), context); + } + + /* emit optional folding of operator */ + if ((num_args > 2) + && (sexp_opcode_class(op) == OPC_ARITHMETIC + || sexp_opcode_class(op) == OPC_ARITHMETIC_INV)) + for (i=num_args-2; i>0; i--) + emit(sexp_opcode_code(op), context); + + sexp_context_depth(context) -= (num_args-1); +} + +static void generate_general_app (sexp app, sexp context) { + sexp ls; + sexp_uint_t len = sexp_unbox_integer(sexp_length(sexp_cdr(app))), + tailp = sexp_context_tailp(context); + + /* push the arguments onto the stack */ + sexp_context_tailp(context) = 0; + for (ls = sexp_reverse(sexp_cdr(app)); sexp_pairp(ls); ls = sexp_cdr(ls)) + generate(sexp_car(ls), context); + + /* push the operator onto the stack */ + generate(sexp_car(app), context); + + /* maybe overwrite the current frame */ + emit((tailp ? OP_TAIL_CALL : OP_CALL), context); + emit_word((sexp_uint_t)sexp_make_integer(len), context); + + sexp_context_depth(context) -= len; +} + +static void generate_app (sexp app, sexp context) { + if (sexp_opcodep(sexp_car(app))) + generate_opcode_app(app, context); + else + generate_general_app(app, context); +} + +static void generate_lambda (sexp lambda, sexp context) { + sexp fv, ls, ctx, flags, bc, len, ref, vec, prev_lambda, prev_fv; + sexp_uint_t k; + prev_lambda = sexp_context_lambda(context); + prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL; + fv = sexp_lambda_fv(lambda); + ctx = sexp_make_context(sexp_context_stack(context), + sexp_context_env(context)); + sexp_context_lambda(ctx) = lambda; + /* allocate space for local vars */ + for (ls=sexp_lambda_locals(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) + emit_push(SEXP_VOID, ctx); + /* 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(OP_LOCAL_REF, ctx); + emit_word(k, ctx); + emit_push(sexp_car(ls), ctx); + emit(OP_CONS, ctx); + emit(OP_LOCAL_SET, ctx); + emit_word(k, ctx); + emit(OP_DROP, ctx); + } + } + sexp_context_tailp(ctx) = 1; + generate(sexp_lambda_body(lambda), ctx); + flags = sexp_make_integer((sexp_listp(sexp_lambda_params(lambda))==SEXP_FALSE) + ? 1 : 0); + len = sexp_length(sexp_lambda_params(lambda)); + bc = finalize_bytecode(ctx); + sexp_bytecode_name(bc) = sexp_lambda_name(lambda); + if (sexp_nullp(fv)) { + /* shortcut, no free vars */ + vec = sexp_make_vector(sexp_make_integer(0), SEXP_VOID); + generate_lit(sexp_make_procedure(flags, len, bc, vec), context); + } else { + /* push the closed vars */ + emit_push(SEXP_VOID, context); + emit_push(sexp_length(fv), context); + emit(OP_MAKE_VECTOR, context); + sexp_context_depth(context)--; + for (k=0; sexp_pairp(fv); fv=sexp_cdr(fv), k++) { + ref = sexp_car(fv); + generate_non_global_ref(sexp_ref_name(ref), sexp_ref_cell(ref), + prev_lambda, prev_fv, context, 0); + emit_push(sexp_make_integer(k), context); + emit(OP_STACK_REF, context); + emit_word(3, context); + emit(OP_VECTOR_SET, context); + emit(OP_DROP, context); + sexp_context_depth(context)--; + } + /* push the additional procedure info and make the closure */ + emit_push(bc, context); + emit_push(len, context); + emit_push(flags, context); + emit(OP_MAKE_PROCEDURE, context); + } +} + +static void generate (sexp x, sexp context) { + if (sexp_pointerp(x)) { + switch (sexp_pointer_tag(x)) { + case SEXP_PAIR: + generate_app(x, context); + break; + case SEXP_LAMBDA: + generate_lambda(x, context); + break; + case SEXP_CND: + generate_cnd(x, context); + break; + case SEXP_REF: + generate_ref(x, context, 1); + break; + case SEXP_SET: + generate_set(x, context); + break; + case SEXP_SEQ: + generate_seq(sexp_seq_ls(x), context); + break; + case SEXP_LIT: + generate_lit(sexp_lit_value(x), context); + break; + default: + generate_lit(x, context); + } + } else { + generate_lit(x, context); + } +} + +static sexp insert_free_var (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(x, fv); +} + +static sexp union_free_vars (sexp fv1, sexp fv2) { + if (sexp_nullp(fv2)) + return fv1; + for ( ; sexp_pairp(fv1); fv1=sexp_cdr(fv1)) + fv2 = insert_free_var(sexp_car(fv1), fv2); + return fv2; +} + +static sexp diff_free_vars (sexp lambda, sexp fv, sexp params) { + sexp res = SEXP_NULL; + for ( ; sexp_pairp(fv); fv=sexp_cdr(fv)) + if ((sexp_ref_loc(sexp_car(fv)) != lambda) + || (sexp_memq(sexp_ref_name(sexp_car(fv)), params) == SEXP_FALSE)) + sexp_push(res, sexp_car(fv)); + return res; +} + +static sexp free_vars (sexp x, sexp fv) { + sexp fv1, fv2; + if (sexp_lambdap(x)) { + fv1 = free_vars(sexp_lambda_body(x), SEXP_NULL); + fv2 = diff_free_vars(x, + fv1, + sexp_append(sexp_lambda_locals(x), + sexp_flatten_dot(sexp_lambda_params(x)))); + sexp_lambda_fv(x) = fv2; + fv = union_free_vars(fv2, fv); + } else if (sexp_pairp(x)) { + for ( ; sexp_pairp(x); x=sexp_cdr(x)) + fv = free_vars(sexp_car(x), fv); + } else if (sexp_cndp(x)) { + fv = free_vars(sexp_cnd_test(x), fv); + fv = free_vars(sexp_cnd_pass(x), fv); + fv = free_vars(sexp_cnd_fail(x), fv); + } else if (sexp_seqp(x)) { + for (x=sexp_seq_ls(x); sexp_pairp(x); x=sexp_cdr(x)) + fv = free_vars(sexp_car(x), fv); + } else if (sexp_setp(x)) { + fv = free_vars(sexp_set_value(x), fv); + fv = free_vars(sexp_set_var(x), fv); + } else if (sexp_refp(x) && sexp_lambdap(sexp_ref_loc(x))) { + fv = insert_free_var(x, fv); + } else if (sexp_synclop(x)) { + fv = free_vars(sexp_synclo_expr(x), fv); + } + return fv; +} + +static sexp make_param_list(sexp_uint_t i) { + sexp res = SEXP_NULL; + char sym[2]="a"; + for (sym[0]+=i; i>0; i--) { + sym[0] = sym[0]-1; + res = sexp_cons(sexp_intern(sym), res); + } + return res; +} + +static sexp make_opcode_procedure (sexp op, sexp_uint_t i, sexp env, + sexp *stack, sexp_sint_t top) { + sexp context, lambda, params, refs, ls, bc, res; + if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) + return sexp_opcode_proc(op); + params = make_param_list(i); + lambda = sexp_make_lambda(params); + env = extend_env(env, params, lambda); + context = sexp_make_context(stack, env); + sexp_context_lambda(context) = lambda; + sexp_context_top(context) = top; + for (ls=params, refs=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_push(refs, sexp_make_ref(sexp_car(ls), env_cell(env, sexp_car(ls)))); + generate_opcode_app(sexp_cons(op, sexp_reverse(refs)), context); + bc = finalize_bytecode(context); + sexp_bytecode_name(bc) = sexp_c_string(sexp_opcode_name(op)); + res = sexp_make_procedure(sexp_make_integer(0), + sexp_make_integer(i), + bc, + SEXP_VOID); + if (i == sexp_opcode_num_args(op)) + sexp_opcode_proc(op) = res; + return res; +} + +/*********************** the virtual machine **************************/ + +static sexp sexp_save_stack(sexp *stack, sexp_uint_t to) { + sexp res, *data; + sexp_uint_t i; + res = sexp_make_vector(sexp_make_integer(to), SEXP_VOID); + data = sexp_vector_data(res); + for (i=0; i= INIT_STACK_SIZE) + sexp_raise("out of stack space", SEXP_NULL); +#endif + i = sexp_unbox_integer(_WORD0); + tmp1 = _ARG1; + make_call: + if (sexp_opcodep(tmp1)) { + /* compile non-inlined opcode applications on the fly */ + tmp1 = make_opcode_procedure(tmp1, i, env, stack, top); + if (sexp_exceptionp(tmp1)) { + _ARG1 = tmp1; + goto call_error_handler; + } + } + if (! sexp_procedurep(tmp1)) + sexp_raise("non procedure application", sexp_list1(tmp1)); + j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1)); + if (j < 0) + sexp_raise("not enough args", sexp_list2(tmp1, sexp_make_integer(i))); + if (j > 0) { + if (sexp_procedure_variadic_p(tmp1)) { + stack[top-i-1] = sexp_cons(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_integer(i); + stack[top] = sexp_make_integer(ip+sizeof(sexp)); + stack[top+1] = self; + stack[top+2] = sexp_make_integer(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 OP_FCALL0: + _PUSH(((sexp_proc0)_UWORD0)()); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL1: + _ARG1 = ((sexp_proc1)_UWORD0)(_ARG1); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL2: + _ARG2 = ((sexp_proc2)_UWORD0)(_ARG1, _ARG2); + top--; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL3: + _ARG3 =((sexp_proc3)_UWORD0)(_ARG1, _ARG2, _ARG3); + top -= 2; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL4: + _ARG4 =((sexp_proc4)_UWORD0)(_ARG1, _ARG2, _ARG3, _ARG4); + top -= 3; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL5: + _ARG5 =((sexp_proc5)_UWORD0)(_ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL6: + _ARG6 =((sexp_proc6)_UWORD0)(_ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6); + top -= 5; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_EVAL: + sexp_context_top(context) = top; + _ARG1 = eval_in_context(_ARG1, context); + sexp_check_exception(); + break; + case OP_JUMP_UNLESS: + if (stack[--top] == SEXP_FALSE) + ip += _SWORD0; + else + ip += sizeof(sexp_sint_t); + break; + case OP_JUMP: + ip += _SWORD0; + break; + case OP_PUSH: + _PUSH(_WORD0); + ip += sizeof(sexp); + break; + case OP_DROP: + top--; + break; + case OP_GLOBAL_REF: + if (sexp_cdr(_WORD0) == SEXP_UNDEF) + sexp_raise("undefined variable", sexp_list1(sexp_car(_WORD0))); + /* ... FALLTHROUGH ... */ + case OP_GLOBAL_KNOWN_REF: + _PUSH(sexp_cdr(_WORD0)); + ip += sizeof(sexp); + break; + case OP_STACK_REF: /* `pick' in forth */ + stack[top] = stack[top - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case OP_LOCAL_REF: + stack[top] = stack[fp - 1 - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case OP_LOCAL_SET: + stack[fp - 1 - _SWORD0] = _ARG1; + _ARG1 = SEXP_VOID; + ip += sizeof(sexp); + break; + case OP_CLOSURE_REF: + _PUSH(sexp_vector_ref(cp, sexp_make_integer(_WORD0))); + ip += sizeof(sexp); + break; + case OP_VECTOR_REF: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-ref: not a vector", sexp_list1(_ARG1)); + _ARG2 = sexp_vector_ref(_ARG1, _ARG2); + top--; + break; + case OP_VECTOR_SET: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-set!: not a vector", sexp_list1(_ARG1)); + sexp_vector_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case OP_VECTOR_LENGTH: + _ARG1 = sexp_make_integer(sexp_vector_length(_ARG1)); + break; + case OP_STRING_REF: + _ARG2 = sexp_string_ref(_ARG1, _ARG2); + top--; + break; + case OP_STRING_SET: + sexp_string_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case OP_STRING_LENGTH: + _ARG1 = sexp_make_integer(sexp_string_length(_ARG1)); + break; + case OP_MAKE_PROCEDURE: + _ARG4 = sexp_make_procedure(_ARG1, _ARG2, _ARG3, _ARG4); + top-=3; + break; + case OP_MAKE_VECTOR: + _ARG2 = sexp_make_vector(_ARG1, _ARG2); + top--; + break; + case OP_AND: + _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE)); + top--; + break; + case OP_EOFP: + _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; + case OP_NULLP: + _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; + case OP_INTEGERP: + _ARG1 = sexp_make_boolean(sexp_integerp(_ARG1)); break; + case OP_SYMBOLP: + _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; + case OP_CHARP: + _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; + case OP_TYPEP: + _ARG1 = sexp_make_boolean(sexp_pointerp(_ARG1) + && (sexp_pointer_tag(_ARG1) + == _UWORD0)); + ip += sizeof(sexp); + break; + case OP_CAR: + if (! sexp_pairp(_ARG1)) sexp_raise("car: not a pair", sexp_list1(_ARG1)); + _ARG1 = sexp_car(_ARG1); break; + case OP_CDR: + if (! sexp_pairp(_ARG1)) sexp_raise("cdr: not a pair", sexp_list1(_ARG1)); + _ARG1 = sexp_cdr(_ARG1); break; + case OP_SET_CAR: + if (! sexp_pairp(_ARG1)) + sexp_raise("set-car!: not a pair", sexp_list1(_ARG1)); + sexp_car(_ARG1) = _ARG2; + _ARG2 = SEXP_VOID; + top--; + break; + case OP_SET_CDR: + if (! sexp_pairp(_ARG1)) + sexp_raise("set-cdr!: not a pair", sexp_list1(_ARG1)); + sexp_cdr(_ARG1) = _ARG2; + _ARG2 = SEXP_VOID; + top--; + break; + case OP_CONS: + _ARG2 = sexp_cons(_ARG1, _ARG2); + top--; + break; + case OP_ADD: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fx_add(_ARG1, _ARG2); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_add(_ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fp_add(_ARG1, sexp_integer_to_flonum(_ARG2)); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_add(sexp_integer_to_flonum(_ARG1), _ARG2); +#endif + else sexp_raise("+: not a number", sexp_list2(_ARG1, _ARG2)); + top--; + break; + case OP_SUB: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fx_sub(_ARG1, _ARG2); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_sub(_ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fp_sub(_ARG1, sexp_integer_to_flonum(_ARG2)); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_sub(sexp_integer_to_flonum(_ARG1), _ARG2); +#endif + else sexp_raise("-: not a number", sexp_list2(_ARG1, _ARG2)); + top--; + break; + case OP_MUL: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fx_mul(_ARG1, _ARG2); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_mul(_ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fp_mul(_ARG1, sexp_integer_to_flonum(_ARG2)); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_mul(sexp_integer_to_flonum(_ARG1), _ARG2); +#endif + else sexp_raise("*: not a number", sexp_list2(_ARG1, _ARG2)); + top--; + break; + case OP_DIV: + if (_ARG2 == sexp_make_integer(0)) + sexp_raise("divide by zero", SEXP_NULL); + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fp_div(sexp_integer_to_flonum(_ARG1), + sexp_integer_to_flonum(_ARG2)); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_div(_ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fp_div(_ARG1, sexp_integer_to_flonum(_ARG2)); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_div(sexp_integer_to_flonum(_ARG1), _ARG2); +#endif + else sexp_raise("/: not a number", sexp_list2(_ARG1, _ARG2)); + top--; + break; + case OP_QUOTIENT: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { + if (_ARG2 == sexp_make_integer(0)) + sexp_raise("divide by zero", SEXP_NULL); + _ARG2 = sexp_fx_div(_ARG1, _ARG2); + top--; + } + else sexp_raise("quotient: not an integer", sexp_list2(_ARG1, _ARG2)); + break; + case OP_REMAINDER: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { + if (_ARG2 == sexp_make_integer(0)) + sexp_raise("divide by zero", SEXP_NULL); + tmp1 = sexp_fx_rem(_ARG1, _ARG2); + top--; + _ARG1 = tmp1; + } + else sexp_raise("remainder: not an integer", sexp_list2(_ARG1, _ARG2)); + break; + case OP_NEGATIVE: + if (sexp_integerp(_ARG1)) + _ARG1 = sexp_make_integer(-sexp_unbox_integer(_ARG1)); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1)) + _ARG1 = sexp_make_flonum(-sexp_flonum_value(_ARG1)); +#endif + else sexp_raise("-: not a number", sexp_list1(_ARG1)); + break; + case OP_INVERSE: + if (sexp_integerp(_ARG1)) + _ARG1 = sexp_make_flonum(1/(double)sexp_unbox_integer(_ARG1)); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1)) + _ARG1 = sexp_make_flonum(1/sexp_flonum_value(_ARG1)); +#endif + else sexp_raise("/: not a number", sexp_list1(_ARG1)); + break; + case OP_LT: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + i = (sexp_sint_t)_ARG1 < (sexp_sint_t)_ARG2; +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + i = sexp_flonum_value(_ARG1) < sexp_flonum_value(_ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + i = sexp_flonum_value(_ARG1) < (double)sexp_unbox_integer(_ARG2); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + i = (double)sexp_unbox_integer(_ARG1) < sexp_flonum_value(_ARG2); +#endif + else sexp_raise("<: not a number", sexp_list2(_ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); + top--; + break; + case OP_LE: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + i = (sexp_sint_t)_ARG1 <= (sexp_sint_t)_ARG2; +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + i = sexp_flonum_value(_ARG1) <= sexp_flonum_value(_ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + i = sexp_flonum_value(_ARG1) <= (double)sexp_unbox_integer(_ARG2); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + i = (double)sexp_unbox_integer(_ARG1) <= sexp_flonum_value(_ARG2); +#endif + else sexp_raise("<=: not a number", sexp_list2(_ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); + top--; + break; + case OP_EQN: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + i = _ARG1 == _ARG2; +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + i = sexp_flonum_value(_ARG1) == sexp_flonum_value(_ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + i = sexp_flonum_value(_ARG1) == (double)sexp_unbox_integer(_ARG2); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + i = (double)sexp_unbox_integer(_ARG1) == sexp_flonum_value(_ARG2); +#endif + else sexp_raise("=: not a number", sexp_list2(_ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); + top--; + break; + case OP_EQ: + _ARG2 = sexp_make_boolean(_ARG1 == _ARG2); + top--; + break; + case OP_FIX2FLO: + if (sexp_integerp(_ARG1)) + _ARG1 = sexp_integer_to_flonum(_ARG1); + else +#if USE_FLONUMS + if (! sexp_flonump(_ARG1)) +#endif + sexp_raise("exact->inexact: not a number", sexp_list1(_ARG1)); + break; + case OP_FLO2FIX: +#if USE_FLONUMS + if (sexp_flonump(_ARG1)) + _ARG1 = sexp_make_integer((sexp_sint_t)sexp_flonum_value(_ARG1)); + else +#endif + if (! sexp_integerp(_ARG1)) + sexp_raise("inexact->exact: not a number", sexp_list1(_ARG1)); + break; + case OP_CHAR2INT: + _ARG1 = sexp_make_integer(sexp_unbox_character(_ARG1)); + break; + case OP_INT2CHAR: + _ARG1 = sexp_make_character(sexp_unbox_integer(_ARG1)); + break; + case OP_CHAR_UPCASE: + _ARG1 = sexp_make_character(toupper(sexp_unbox_character(_ARG1))); + break; + case OP_CHAR_DOWNCASE: + _ARG1 = sexp_make_character(tolower(sexp_unbox_character(_ARG1))); + break; + case OP_DISPLAY: + if (sexp_stringp(_ARG1)) { + sexp_write_string(sexp_string_data(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + } else if (sexp_charp(_ARG1)) { + sexp_write_char(sexp_unbox_character(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + } + /* ... FALLTHROUGH ... */ + case OP_WRITE: + sexp_write(_ARG1, _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + case OP_WRITE_CHAR: + sexp_write_char(sexp_unbox_character(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + case OP_NEWLINE: + sexp_write_char('\n', _ARG1); + _ARG1 = SEXP_VOID; + break; + case OP_FLUSH_OUTPUT: + sexp_flush(_ARG1); + _ARG1 = SEXP_VOID; + break; + case OP_READ: + _ARG1 = sexp_read(_ARG1); + sexp_check_exception(); + break; + case OP_READ_CHAR: + i = sexp_read_char(_ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case OP_PEEK_CHAR: + i = sexp_read_char(_ARG1); + sexp_push_char(i, _ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case OP_RET: + i = sexp_unbox_integer(stack[fp]); + stack[fp-i] = _ARG1; + top = fp-i+1; + ip = (unsigned char*) sexp_unbox_integer(stack[fp+1]); + self = stack[fp+2]; + bc = sexp_procedure_code(self); + cp = sexp_procedure_vars(self); + fp = sexp_unbox_integer(stack[fp+3]); + break; + case OP_DONE: + goto end_loop; + default: + sexp_raise("unknown opcode", sexp_list1(sexp_make_integer(*(ip-1)))); + } + goto loop; + + end_loop: + return _ARG1; +} + +/************************ library procedures **************************/ + +static sexp sexp_exception_type_func (sexp exn) { + if (sexp_exceptionp(exn)) + return sexp_exception_kind(exn); + else + return sexp_type_exception("not an exception", exn); +} + +static sexp sexp_open_input_file (sexp path) { + FILE *in; + if (! sexp_stringp(path)) return sexp_type_exception("not a string", path); + in = fopen(sexp_string_data(path), "r"); + if (! in) + return sexp_user_exception(SEXP_FALSE, "couldn't open input file", path); + return sexp_make_input_port(in, sexp_string_data(path)); +} + +static sexp sexp_open_output_file (sexp path) { + FILE *out; + if (! sexp_stringp(path)) return sexp_type_exception("not a string", path); + out = fopen(sexp_string_data(path), "w"); + if (! out) + return sexp_user_exception(SEXP_FALSE, "couldn't open output file", path); + return sexp_make_input_port(out, sexp_string_data(path)); +} + +static sexp sexp_close_port (sexp port) { + fclose(sexp_port_stream(port)); + return SEXP_VOID; +} + +static void sexp_warn_undefs (sexp from, sexp to, sexp out) { + sexp x; + for (x=from; sexp_pairp(x) && x!=to; x=sexp_cdr(x)) + if (sexp_cdar(x) == SEXP_UNDEF) { + sexp_write_string("WARNING: reference to undefined variable: ", out); + sexp_write(sexp_caar(x), out); + sexp_write_char('\n', out); + } +} + +sexp sexp_load (sexp source, sexp env) { + sexp x, res, in, tmp, out, context = sexp_make_context(NULL, env); + out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); + tmp = sexp_env_bindings(env); + sexp_context_tailp(context) = 0; + in = sexp_open_input_file(source); + if (sexp_exceptionp(in)) { + sexp_print_exception(in, out); + return in; + } + while ((x=sexp_read(in)) != (sexp) SEXP_EOF) { + res = eval_in_context(x, context); + if (sexp_exceptionp(res)) + break; + } + if (x == SEXP_EOF) + res = SEXP_VOID; + sexp_close_port(in); +#ifdef USE_WARN_UNDEFS + if (sexp_oportp(out)) + sexp_warn_undefs(sexp_env_bindings(env), tmp, out); +#endif + return res; +} + +#if USE_MATH + +#define define_math_op(name, cname) \ + static sexp name (sexp z) { \ + double d; \ + if (sexp_flonump(z)) \ + d = sexp_flonum_value(z); \ + else if (sexp_integerp(z)) \ + d = (double)sexp_unbox_integer(z); \ + else \ + return sexp_type_exception("not a number", z); \ + return sexp_make_flonum(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_sqrt, sqrt) +define_math_op(sexp_round, round) +define_math_op(sexp_trunc, trunc) +define_math_op(sexp_floor, floor) +define_math_op(sexp_ceiling, ceil) + +#endif + +static sexp sexp_expt (sexp x, sexp e) { + double res, x1, e1; + if (sexp_integerp(x)) + x1 = (double)sexp_unbox_integer(x); +#if USE_FLONUMS + else if (sexp_flonump(x)) + x1 = sexp_flonum_value(x); +#endif + else + return sexp_type_exception("not a number", x); + if (sexp_integerp(e)) + e1 = (double)sexp_unbox_integer(e); +#if USE_FLONUMS + else if (sexp_flonump(e)) + e1 = sexp_flonum_value(e); +#endif + else + return sexp_type_exception("not a number", e); + res = pow(x1, e1); +#if USE_FLONUMS + if ((res > SEXP_MAX_INT) || sexp_flonump(x) || sexp_flonump(e)) + return sexp_make_flonum(res); +#endif + return sexp_make_integer((sexp_sint_t)round(res)); +} + +static sexp sexp_string_concatenate (sexp str_ls) { + sexp res, ls; + sexp_uint_t len=0; + char *p; + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) + if (! sexp_stringp(sexp_car(ls))) + return sexp_type_exception("not a string", sexp_car(ls)); + else + len += sexp_string_length(sexp_car(ls)); + res = sexp_make_string(sexp_make_integer(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; + } + return res; +} + +static sexp sexp_string_cmp (sexp str1, sexp str2) { + sexp_sint_t len1, len2, len, diff; + if (! sexp_stringp(str1)) + return sexp_type_exception("not a string", str1); + if (! sexp_stringp(str2)) + return sexp_type_exception("not a string", str2); + len1 = sexp_string_length(str1); + len2 = sexp_string_length(str2); + len = ((len1 (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 + ((eq? 'unquote (car x)) + (if (<= d 0) + (cadr x) + (list (rename 'list) (list (rename 'quote) 'unquote) + (qq (cadr x) (- d 1))))) + ((eq? '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))))) + ((eq? 'quasiquote (car x)) + (list (rename 'list) (list (rename 'quote) 'quasiquote) + (qq (cadr x) (+ d 1)))) + ((and (<= d 0) (pair? (car x)) (eq? '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 (identifier? (cadr expr)) + `(,(rename 'letrec) ((,(cadr expr) + (,(rename 'lambda) ,(map car (caddr expr)) + ,@(cdddr expr)))) + ,(cons (cadr expr) (map cadr (caddr expr)))) + `((,(rename 'lambda) ,(map car (cadr expr)) ,@(cddr expr)) + ,@(map cadr (cadr expr))))))) + +(define-syntax let* + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cadr expr)) + `(,(rename 'begin) ,@(cddr expr)) + `(,(rename 'let) (,(caadr expr)) + (,(rename 'let*) ,(cdadr expr) ,@(cddr expr))))))) + +(define-syntax case + (er-macro-transformer + (lambda (expr rename compare) + (define (clause ls) + (cond + ((null? ls) #f) + ((compare '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)))))) + +(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)) + +(define (error msg . args) + (raise (make-exception 'user msg args #f #f #f))) + +(define (with-exception-handler handler thunk) + (let ((orig-handler (current-exception-handler))) + (current-exception-handler handler) + (let ((res (thunk))) + (current-exception-handler orig-handler) + res))) + +;; 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) 0)) +(define (string? s1 s2) (> (string-cmp s1 s2) 0)) +(define (string>=? s1 s2) (>= (string-cmp s1 s2) 0)) + +(define (string-ci=? s1 s2) (eq? (string-cmp-ci s1 s2) 0)) +(define (string-ci? s1 s2) (> (string-cmp-ci s1 s2) 0)) +(define (string-ci>=? s1 s2) (>= (string-cmp-ci s1 s2) 0)) + +;; list utils + +(define (eqv? a b) (if (eq? a b) #t (and (flonum? a) (flonum? b) (= a b)))) + +(define (member obj ls) + (if (null? ls) + #f + (if (equal? obj (car ls)) + ls + (member obj (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 (flonum? x))) +(define complex? number?) +(define rational? number?) +(define real? number?) +(define exact? fixnum?) +(define inexact? flonum?) +(define (integer? x) (if (fixnum? 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 (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 (digit-char n) (integer->char (+ n (char->integer #\0)))) +(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)) 65)))) + +(define (number->string n . o) + (if (if (null? o) #t (eq? 10 (car o))) + (call-with-output-string (lambda (out) (write n out))) + (let lp ((n n) (d (car o)) (res '())) + (if (> n 0) + (lp (quotient n d) d (cons (digit-char (remainder n d)) res)) + (list->string res))))) + +(define (string->number str . o) + (let ((res + (if (if (null? o) #t (eq? 10 (car o))) + (call-with-input-string str (lambda (in) (read in))) + (let ((len (string-length str))) + (let lp ((i 0) (d (car o)) (acc 0)) + (if (>= i len) + acc + (let ((v (digit-value (string-ref str i)))) + (and v (lp (+ i 1) d (+ (* acc d) v)))))))))) + (and (number? res) res))) + +;; vector utils + +(define (list->vector ls) + (let ((vec (make-vector (length ls) #f))) + (let lp ((ls ls) (i 0)) + (if (pair? ls) + (begin + (vector-set! vec i (car ls)) + (lp (cdr ls) (+ i 1))))) + vec)) + +(define (vector->list vec) + (let lp ((i (- (vector-length vec) 1)) (res '())) + (if (< i 0) res (lp (- i 1) (cons (vector-ref vec i) res))))) + +(define (vector-fill! str ch) + (let lp ((i (- (vector-length str) 1))) + (if (>= i 0) (begin (vector-set! str i ch) (lp (- i 1)))))) + +(define (vector . args) (list->vector args)) + +;; I/O utils + +(define (char-ready? . o) + (not (eof-object? (peek-char (if (pair? o) (car o) (current-input-port)))))) + +(define (load file) (%load file (interaction-environment))) + +(define (call-with-input-string str proc) + (proc (open-input-string str))) + +(define (call-with-output-string proc) + (let ((out (open-output-string))) + (proc out) + (get-output-string out))) + +(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-input-port)) + (tmp-out (open-output-file file))) + (current-input-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)))) diff --git a/main.c b/main.c new file mode 100644 index 00000000..62da5068 --- /dev/null +++ b/main.c @@ -0,0 +1,110 @@ + +#include "eval.c" + +void repl (sexp context) { + sexp obj, tmp, res, env, in, out, err; + env = sexp_context_env(context); + sexp_context_tracep(context) = 1; + in = env_global_ref(env, the_cur_in_symbol, SEXP_FALSE); + out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); + err = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); + while (1) { + sexp_write_string("> ", out); + sexp_flush(out); + obj = sexp_read(in); + if (obj == SEXP_EOF) + break; + if (sexp_exceptionp(obj)) { + sexp_print_exception(obj, err); + } else { + tmp = sexp_env_bindings(env); + res = eval_in_context(obj, context); +#ifdef USE_WARN_UNDEFS + sexp_warn_undefs(sexp_env_bindings(env), tmp, err); +#endif + if (res != SEXP_VOID) { + sexp_write(res, out); + sexp_write_char('\n', out); + } + } + } +} + +void run_main (int argc, char **argv) { + sexp env, out=NULL, res, context, perr_cell, err_cell, err_handler; + sexp_uint_t i, quit=0, init_loaded=0; + + env = sexp_make_standard_env(sexp_make_integer(5)); + env_define(env, the_interaction_env_symbol, env); + out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); + err_cell = env_cell(env, the_cur_err_symbol); + perr_cell = env_cell(env, sexp_intern("print-exception")); + context = sexp_make_context(NULL, env); + sexp_context_tailp(context) = 0; + if (err_cell && perr_cell && sexp_opcodep(sexp_cdr(perr_cell))) { + emit(OP_GLOBAL_KNOWN_REF, context); + emit_word((sexp_uint_t)err_cell, context); + emit(OP_LOCAL_REF, context); + emit_word(0, context); + emit(OP_FCALL2, context); + emit_word((sexp_uint_t)sexp_opcode_data(sexp_cdr(perr_cell)), context); + } + emit_push(SEXP_VOID, context); + emit(OP_DONE, context); + err_handler = sexp_make_procedure(sexp_make_integer(0), + sexp_make_integer(0), + finalize_bytecode(context), + sexp_make_vector(0, SEXP_VOID)); + env_define(env, the_err_handler_symbol, err_handler); + + /* parse options */ + for (i=1; i < argc && argv[i][0] == '-'; i++) { + switch (argv[i][1]) { +#if USE_STRING_STREAMS + case 'e': + case 'p': + if (! init_loaded++) + sexp_load(sexp_c_string(sexp_init_file), env); + res = sexp_read_from_string(argv[i+1]); + if (! sexp_exceptionp(res)) + res = eval_in_context(res, context); + if (sexp_exceptionp(res)) { + sexp_print_exception(res, out); + } else if (argv[i][1] == 'p') { + sexp_write(res, out); + sexp_write_char('\n', out); + } + quit=1; + i++; + break; +#endif + case 'l': + if (! init_loaded++) + sexp_load(sexp_c_string(sexp_init_file), env); + sexp_load(sexp_c_string(argv[++i]), env); + break; + case 'q': + init_loaded = 1; + break; + default: + errx(1, "unknown option: %s", argv[i]); + } + } + + if (! quit) { + if (! init_loaded) + sexp_load(sexp_c_string(sexp_init_file), env); + if (i < argc) + for ( ; i < argc; i++) + sexp_load(sexp_c_string(argv[i]), env); + else + repl(context); + } +} + +int main (int argc, char **argv) { + scheme_init(); + run_main(argc, argv); + return 0; +} + diff --git a/opcodes.c b/opcodes.c new file mode 100644 index 00000000..5bd6cc4a --- /dev/null +++ b/opcodes.c @@ -0,0 +1,130 @@ + +#define _OP(c,o,n,m,t,u,i,s,f,d) \ + {.tag=SEXP_OPCODE, \ + .value={.opcode={c, o, n, m, t, u, i, s, f, d, NULL}}} +#define _FN(o,n,m,t,u,s,f,d) _OP(OPC_FOREIGN, o, n, m, t, u, 0, s, f, (sexp)d) +#define _FN0(s, f, d) _FN(OP_FCALL0, 0, 0, 0, 0, s, f, d) +#define _FN1(t, s, f, d) _FN(OP_FCALL1, 1, 0, t, 0, s, f, d) +#define _FN2(t, u, s, f, d) _FN(OP_FCALL2, 2, 0, t, u, s, f, d) +#define _FN2OPT(t, u, s, f, d) _FN(OP_FCALL2, 1, 1, t, u, s, f, d) +#define _FN3(t, u, s, f, d) _FN(OP_FCALL3, 3, 0, t, u, s, f, d) +#define _FN4(t, u, s, f, d) _FN(OP_FCALL4, 4, 0, t, u, s, f, d) +#define _FN5(t, u, s, f, d) _FN(OP_FCALL5, 5, 0, t, u, s, f, d) +#define _FN6(t, u, s, f, d) _FN(OP_FCALL6, 6, 0, t, u, s, f, d) +#define _PARAM(n, a, t) _OP(OPC_PARAMETER, OP_NOOP, 0, 3, t, 0, 0, n, a, 0) + +static struct sexp_struct opcodes[] = { +_OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", 0, NULL), +_OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", 0, NULL), +_OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", 0, NULL), +_OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", 0, NULL), +_OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", 0, NULL), +_OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", 0, NULL), +_OP(OPC_ACCESSOR, OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", 0, NULL), +_OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", 0, NULL), +_OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", 0, NULL), +_OP(OPC_ACCESSOR, OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", 0, NULL), +_OP(OPC_GENERIC, OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", 0, NULL), +_OP(OPC_GENERIC, OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", 0, NULL), +_OP(OPC_GENERIC, OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", 0, NULL), +_OP(OPC_GENERIC, OP_INT2CHAR, 1, 0, SEXP_FIXNUM, 0, 0, "integer->char", 0, NULL), +_OP(OPC_GENERIC, OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", 0, NULL), +_OP(OPC_GENERIC, OP_CHAR_DOWNCASE, 1, 0, SEXP_CHAR, 0, 0, "char-downcase", 0, NULL), +_OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", sexp_make_integer(0), NULL), +_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", sexp_make_integer(1), NULL), +_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEGATIVE, "-", 0, NULL), +_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INVERSE, "/", 0, NULL), +_OP(OPC_ARITHMETIC, OP_QUOTIENT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", 0, NULL), +_OP(OPC_ARITHMETIC, OP_REMAINDER, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "remainder", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<=", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 1, ">", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 1, ">=", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_EQN, 0, 1, SEXP_FIXNUM, 0, 0, "=", 0, NULL), +_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?", 0, NULL), +_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", 0, NULL), +_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_VOID, NULL), +_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_INTEGERP, 1, 0, 0, 0, 0, "fixnum?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", 0, (sexp)SEXP_PAIR), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", 0, (sexp)SEXP_STRING), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", 0, (sexp)SEXP_VECTOR), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", 0, (sexp)SEXP_FLONUM), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "closure?", 0, (sexp)SEXP_PROCEDURE), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", 0, (sexp)SEXP_OPCODE), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", 0, (sexp)SEXP_IPORT), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", 0, (sexp)SEXP_OPORT), +_OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", 0, NULL), +_OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", 0, NULL), +_OP(OPC_GENERIC, OP_RAISE, 1, SEXP_STRING, 0, 0, 0, "raise", 0, NULL), +_OP(OPC_IO, OP_WRITE, 1, 3, 0, SEXP_OPORT, 0, "write", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_DISPLAY, 1, 3, 0, SEXP_OPORT, 0, "display", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 3, 0, SEXP_OPORT, 0, "flush-output", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_READ, 0, 3, 0, SEXP_IPORT, 0, "read", (sexp)"*current-input-port*", NULL), +_OP(OPC_IO, OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), +_OP(OPC_IO, OP_PEEK_CHAR, 0, 3, 0, SEXP_IPORT, 0, "peek-char", (sexp)"*current-input-port*", NULL), +_OP(OPC_GENERIC, OP_EVAL, 1, 3, 0, 0, 0, "eval", (sexp)"*interaction-environment*", NULL), +_FN2(0, 0, "equal?", 0, sexp_equalp), +_FN1(0, "list?", 0, sexp_listp), +_FN1(0, "identifier?", 0, sexp_identifierp), +_FN1(0, "identifier->symbol", 0, sexp_syntactic_closure_expr), +_FN4(0, SEXP_ENV, "identifier=?", 0, sexp_identifier_eq), +_FN1(SEXP_PAIR, "length", 0, sexp_length), +_FN1(SEXP_PAIR, "reverse", 0, sexp_reverse), +_FN1(SEXP_PAIR, "list->vector", 0, sexp_list_to_vector), +_FN1(SEXP_STRING, "open-input-file", 0, sexp_open_input_file), +_FN1(SEXP_STRING, "open-output-file", 0, sexp_open_output_file), +_FN1(SEXP_IPORT, "close-input-port", 0, sexp_close_port), +_FN1(SEXP_OPORT, "close-output-port", 0, sexp_close_port), +_FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env), +_FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env), +_FN2(SEXP_STRING, SEXP_ENV, "%load", 0, sexp_load), +_FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception), +_FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_func), +_FN6(SEXP_SYMBOL, SEXP_STRING, "make-exception", 0, sexp_make_exception), +_FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_make_string), +_FN2(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp), +_FN2(SEXP_STRING, SEXP_STRING, "string-cmp-ci", 0, sexp_string_cmp_ci), +_FN3(SEXP_STRING, SEXP_FIXNUM, "substring", 0, sexp_substring), +_FN1(SEXP_STRING, "string->symbol", 0, sexp_string_to_symbol), +_FN1(SEXP_PAIR, "string-concatenate", 0, sexp_string_concatenate), +_FN2(0, SEXP_PAIR, "memq", 0, sexp_memq), +_FN2(0, SEXP_PAIR, "assq", 0, sexp_assq), +_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", 0, sexp_make_synclo), +_PARAM("current-input-port", (sexp)"*current-input-port*", SEXP_IPORT), +_PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT), +_PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT), +_PARAM("current-exception-handler", (sexp)"*current-exception-handler*", SEXP_PROCEDURE), +_PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV), +#if USE_MATH +_FN1(0, "exp", 0, sexp_exp), +_FN1(0, "log", 0, sexp_log), +_FN1(0, "sin", 0, sexp_sin), +_FN1(0, "cos", 0, sexp_cos), +_FN1(0, "tan", 0, sexp_tan), +_FN1(0, "asin", 0, sexp_asin), +_FN1(0, "acos", 0, sexp_acos), +_FN1(0, "atan", 0, sexp_atan), +_FN1(0, "sqrt", 0, sexp_sqrt), +_FN1(0, "round", 0, sexp_round), +_FN1(0, "truncate", 0, sexp_trunc), +_FN1(0, "floor", 0, sexp_floor), +_FN1(0, "ceiling", 0, sexp_ceiling), +_FN2(0, 0, "expt", 0, sexp_expt), +#endif +#if USE_STRING_STREAMS +_FN0("open-output-string", 0, sexp_make_output_string_port), +_FN1(SEXP_STRING, "open-input-string", 0, sexp_make_input_string_port), +_FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string), +#endif +#if USE_DEBUG +_FN2(SEXP_PROCEDURE, SEXP_OPORT, "disasm", 0, sexp_disasm), +#endif +}; + diff --git a/sexp-huff.c b/sexp-huff.c new file mode 100644 index 00000000..abf6bc9f --- /dev/null +++ b/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/sexp-hufftabs.c b/sexp-hufftabs.c new file mode 100644 index 00000000..7704184f --- /dev/null +++ b/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/sexp-unhuff.c b/sexp-unhuff.c new file mode 100644 index 00000000..fa142e16 --- /dev/null +++ b/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/sexp.c b/sexp.c new file mode 100644 index 00000000..f8b4a459 --- /dev/null +++ b/sexp.c @@ -0,0 +1,1147 @@ +/* sexp.c -- standalone sexp library implementation */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "sexp.h" + +/* optional huffman-compressed immediate symbols */ +#ifdef USE_HUFF_SYMS +struct huff_entry { + unsigned char len; + unsigned short bits; +}; +#include "sexp-hufftabs.c" +static struct huff_entry huff_table[] = { +#include "sexp-huff.c" +}; +#endif + +static int sexp_initialized_p = 0; + +static sexp the_dot_symbol; +static sexp the_quote_symbol; +static sexp the_quasiquote_symbol; +static sexp the_unquote_symbol; +static sexp the_unquote_splicing_symbol; +static sexp the_read_error_symbol; +static sexp the_empty_vector; + +static char sexp_separators[] = { + /* 1 2 3 4 5 6 7 8 9 a b c d e f */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 0, 0, /* x0_ */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x1_ */ + 1, 0, 1, 0, 0, 0, 0, 1, 1, 1, 0, 0, 1, 0, 0, 0, /* x2_ */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, /* x3_ */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x4_ */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, /* x5_ */ +}; + +static int digit_value (c) { + return (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10)); +} + +static int is_separator(int c) { + /* return (!((c-9)&(~3))) | (~(c^4)); */ + return 0 sexp_make_integer(0))) { + sexp_write_string(" on line ", out); + sexp_write(sexp_exception_line(exn), out); + } + if (sexp_stringp(sexp_exception_file(exn))) { + sexp_write_string(" of file ", out); + sexp_write_string(sexp_string_data(sexp_exception_file(exn)), out); + } + sexp_write_string(": ", out); + sexp_write_string(sexp_string_data(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(": ", out); + sexp_write(sexp_car(sexp_exception_irritants(exn)), out); + sexp_write_string("\n", out); + } else { + sexp_write_string("\n", out); + for (ls=sexp_exception_irritants(exn); + sexp_pairp(ls); ls=sexp_cdr(ls)) { + sexp_write_string(" ", out); + sexp_write(sexp_car(ls), out); + sexp_write_char('\n', out); + } + } + } else { + sexp_write_char('\n', out); + } + } else { + sexp_write_string(": ", out); + if (sexp_stringp(exn)) + sexp_write_string(sexp_string_data(exn), out); + else + sexp_write(exn, out); + sexp_write_char('\n', out); + } + return SEXP_VOID; +} + +static sexp sexp_read_error (char *message, sexp irritants, sexp port) { + sexp name = (sexp_port_name(port) + ? sexp_c_string(sexp_port_name(port)) : SEXP_FALSE); + return sexp_make_exception(the_read_error_symbol, + sexp_c_string(message), + irritants, + SEXP_FALSE, + name, + sexp_make_integer(sexp_port_line(port))); +} + +/*************************** list utilities ***************************/ + +sexp sexp_cons (sexp head, sexp tail) { + sexp pair = sexp_alloc_type(pair, SEXP_PAIR); + sexp_car(pair) = head; + sexp_cdr(pair) = tail; + return pair; +} + +sexp sexp_listp (sexp hare) { + sexp turtle; + if (! sexp_pairp(hare)) + return sexp_make_boolean(hare == SEXP_NULL); + 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(hare == SEXP_NULL); +} + +sexp sexp_memq (sexp x, sexp ls) { + while (sexp_pairp(ls)) + if (x == sexp_car(ls)) + return ls; + else + ls = sexp_cdr(ls); + return SEXP_FALSE; +} + +sexp sexp_assq (sexp x, sexp ls) { + while (sexp_pairp(ls)) + if (sexp_pairp(sexp_car(ls)) && (x == sexp_caar(ls))) + return sexp_car(ls); + else + ls = sexp_cdr(ls); + return SEXP_FALSE; +} + +sexp sexp_reverse (sexp ls) { + sexp res = SEXP_NULL; + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) + res = sexp_cons(sexp_car(ls), res); + return res; +} + +sexp sexp_nreverse (sexp ls) { + sexp a, b, tmp; + if (ls == SEXP_NULL) { + return ls; + } else if (! sexp_pairp(ls)) { + return SEXP_ERROR; + } else { + b = ls; + a = sexp_cdr(ls); + sexp_cdr(b) = SEXP_NULL; + for ( ; sexp_pairp(a); b=a, a=tmp) { + tmp = sexp_cdr(a); + sexp_cdr(a) = b; + } + return b; + } +} + +sexp sexp_append (sexp a, sexp b) { + for (a=sexp_reverse(a); sexp_pairp(a); a=sexp_cdr(a)) + b = sexp_cons(sexp_car(a), b); + return b; +} + +sexp sexp_length (sexp ls) { + sexp_uint_t res=0; + for ( ; sexp_pairp(ls); res++, ls=sexp_cdr(ls)) + ; + return sexp_make_integer(res); +} + +sexp sexp_equalp (sexp a, sexp b) { + sexp_uint_t len; + sexp *v1, *v2; + loop: + if (a == b) + return SEXP_TRUE; + if (! sexp_pointerp(a)) + return sexp_make_boolean(sexp_integerp(a) && sexp_pointerp(b) + && (sexp_unbox_integer(a) + == sexp_flonum_value(b))); + else if (! sexp_pointerp(b)) + return sexp_make_boolean(sexp_integerp(b) && sexp_pointerp(a) + && (sexp_unbox_integer(b) + == sexp_flonum_value(a))); + if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) + return SEXP_FALSE; + switch (sexp_pointer_tag(a)) { + case SEXP_PAIR: + if (sexp_equalp(sexp_car(a), sexp_car(b)) == SEXP_FALSE) + return SEXP_FALSE; + a = sexp_cdr(a); + b = sexp_cdr(b); + goto loop; + case SEXP_VECTOR: + len = sexp_vector_length(a); + if (len != sexp_vector_length(b)) + return SEXP_FALSE; + v1 = sexp_vector_data(a); + v2 = sexp_vector_data(b); + for (len--; len > 0; len--) + if (sexp_equalp(v1[len], v2[len]) == SEXP_FALSE) + return SEXP_FALSE; + return SEXP_TRUE; + case SEXP_STRING: + return sexp_make_boolean((sexp_string_length(a) == sexp_string_length(b)) + && (! strncmp(sexp_string_data(a), + sexp_string_data(b), + sexp_string_length(a)))); + case SEXP_FLONUM: + return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b)); + default: + return SEXP_FALSE; + } +} + +/********************* strings, symbols, vectors **********************/ + +sexp sexp_make_flonum(double f) { + sexp x = sexp_alloc_type(flonum, SEXP_FLONUM); + sexp_flonum_value(x) = f; + return x; +} + +sexp sexp_make_string(sexp len, sexp ch) { + char *cstr; + sexp s = sexp_alloc_type(string, SEXP_STRING); + sexp_sint_t clen = sexp_unbox_integer(len); + if (clen < 0) return sexp_type_exception("negative length", len); + cstr = sexp_alloc(clen+1); + if (sexp_charp(ch)) + memset(cstr, sexp_unbox_character(ch), clen); + cstr[clen] = '\0'; + sexp_string_length(s) = clen; + sexp_string_data(s) = cstr; + return s; +} + +sexp sexp_c_string(char *str) { + sexp_uint_t len = strlen(str); + sexp s = sexp_make_string(sexp_make_integer(len), SEXP_VOID); + memcpy(sexp_string_data(s), str, len); + return s; +} + +sexp sexp_substring (sexp str, sexp start, sexp end) { + sexp res; + if (! sexp_stringp(str)) + return sexp_type_exception("not a string", str); + if (! sexp_integerp(start)) + return sexp_type_exception("not a number", start); + if (end == SEXP_FALSE) + end = sexp_make_integer(sexp_string_length(str)); + if (! sexp_integerp(end)) + return sexp_type_exception("not a number", end); + if ((sexp_unbox_integer(start) < 0) + || (sexp_unbox_integer(start) > sexp_string_length(str)) + || (sexp_unbox_integer(end) < 0) + || (sexp_unbox_integer(end) > sexp_string_length(str)) + || (end < start)) + return sexp_range_exception(str, start, end); + res = sexp_make_string(sexp_fx_sub(end, start), + SEXP_VOID); + memcpy(sexp_string_data(res), + sexp_string_data(str)+sexp_unbox_integer(start), + sexp_string_length(res)); + return res; +} + +#define FNV_PRIME 16777619 +#define FNV_OFFSET_BASIS 2166136261uL + +sexp_uint_t sexp_string_hash(char *str, sexp_uint_t acc) { + while (*str) {acc *= FNV_PRIME; acc ^= *str++;} + return acc; +} + +sexp sexp_intern(char *str) { + struct huff_entry he; + sexp_uint_t len, res=FNV_OFFSET_BASIS, space=3, newbits, bucket; + char c, *mystr, *p=str; + sexp sym, ls; + +#if USE_HUFF_SYMS + res = 0; + for ( ; (c=*p); p++) { + he = huff_table[(unsigned char)c]; + newbits = he.len; + if ((space+newbits) > (sizeof(sexp)*8)) { + goto normal_intern; + } + res |= (((sexp_uint_t) he.bits) << space); + space += newbits; + } + return (sexp) (res + SEXP_ISYMBOL_TAG); +#endif + + normal_intern: +#if USE_HASH_SYMS + bucket = (sexp_string_hash(p, res) % SEXP_SYMBOL_TABLE_SIZE); +#else + bucket = 0; +#endif + len = strlen(str); + for (ls=symbol_table[bucket]; sexp_pairp(ls); ls=sexp_cdr(ls)) + if (strncmp(str, sexp_symbol_data(sexp_car(ls)), len) == 0) + return sexp_car(ls); + + /* not found, make a new symbol */ + sym = sexp_alloc_type(symbol, SEXP_SYMBOL); + mystr = sexp_alloc(len+1); + memcpy(mystr, str, len+1); + mystr[len]=0; + sexp_symbol_length(sym) = len; + sexp_symbol_data(sym) = mystr; + sexp_push(symbol_table[bucket], sym); + return sym; +} + +sexp sexp_string_to_symbol (sexp str) { + return sexp_intern(sexp_string_data(str)); +} + +sexp sexp_make_vector(sexp len, sexp dflt) { + sexp v, *x; + int i, clen = sexp_unbox_integer(len); + if (! clen) return the_empty_vector; + v = sexp_alloc_type(vector, SEXP_VECTOR); + x = (sexp*) sexp_alloc(clen*sizeof(sexp)); + 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_integer(n); + return n; +} + +int sstream_write (void *vec, const char *src, int n) { + sexp_uint_t len, pos, newpos; + sexp newbuf; + len = sexp_unbox_integer(sexp_stream_size(vec)); + pos = sexp_unbox_integer(sexp_stream_pos(vec)); + newpos = pos+n; + if (newpos >= len) { + newbuf = sexp_make_string(sexp_make_integer(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_integer(newpos*2); + } + memcpy(sexp_string_data(sexp_stream_buf(vec))+pos, src, n); + sexp_stream_pos(vec) = sexp_make_integer(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_integer(sexp_stream_pos(vec)) + offset; + } else { /* SEEK_END */ + pos = sexp_unbox_integer(sexp_stream_size(vec)) + offset; + } + sexp_stream_pos(vec) = sexp_make_integer(pos); + return pos; +} + +sexp sexp_make_input_string_port (sexp str) { + FILE *in; + sexp res, cookie; + cookie = sexp_vector(3, str, sexp_make_integer(sexp_string_length(str)), + sexp_make_integer(0)); + in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL); + res = sexp_make_input_port(in, NULL); + sexp_port_cookie(res) = cookie; + return res; +} + +sexp sexp_make_output_string_port () { + FILE *out; + sexp res, size, cookie; + size = sexp_make_integer(SEXP_INIT_STRING_PORT_SIZE); + cookie = sexp_vector(3, sexp_make_string(size, SEXP_VOID), + size, sexp_make_integer(0)); + out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL); + res = sexp_make_output_port(out, NULL); + sexp_port_cookie(res) = cookie; + return res; +} + +sexp sexp_get_output_string (sexp port) { + sexp cookie = sexp_port_cookie(port); + fflush(sexp_port_stream(port)); + return sexp_substring(sexp_stream_buf(cookie), + sexp_make_integer(0), + sexp_stream_pos(cookie)); +} + +#else + +sexp sexp_make_input_string_port (sexp str) { + FILE *in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r"); + return sexp_make_input_port(in, NULL); +} + +sexp sexp_make_output_string_port () { + FILE *out; + sexp buf = sexp_alloc_type(string, SEXP_STRING), res; + out = open_memstream(&sexp_string_data(buf), &sexp_string_length(buf)); + res = sexp_make_input_port(out, NULL); + sexp_port_cookie(res) = buf; + return res; +} + +sexp sexp_get_output_string (sexp port) { + sexp cookie = sexp_port_cookie(port); + fflush(sexp_port_stream(port)); + return sexp_substring(cookie, + sexp_make_integer(0), + sexp_make_integer(sexp_string_length(cookie))); +} + +#endif + +#endif + +sexp sexp_make_input_port (FILE* in, char *path) { + sexp p = sexp_alloc_type(port, SEXP_IPORT); + sexp_port_stream(p) = in; + sexp_port_name(p) = path; + sexp_port_line(p) = 0; + return p; +} + +sexp sexp_make_output_port (FILE* out, char *path) { + sexp p = sexp_alloc_type(port, SEXP_OPORT); + sexp_port_stream(p) = out; + sexp_port_name(p) = path; + sexp_port_line(p) = 0; + return p; +} + +void sexp_write (sexp obj, sexp out) { + unsigned long len, c, res; + long i=0; + double f; + sexp x, *elts; + char *str=NULL; + + if (! obj) { + sexp_write_string("#", out); + } else if (sexp_pointerp(obj)) { + switch (sexp_pointer_tag(obj)) { + case SEXP_PAIR: + sexp_write_char('(', out); + sexp_write(sexp_car(obj), out); + for (x=sexp_cdr(obj); sexp_pairp(x); x=sexp_cdr(x)) { + sexp_write_char(' ', out); + sexp_write(sexp_car(x), out); + } + if (! sexp_nullp(x)) { + sexp_write_string(" . ", out); + sexp_write(x, out); + } + sexp_write_char(')', out); + break; + case SEXP_VECTOR: + len = sexp_vector_length(obj); + elts = sexp_vector_data(obj); + if (len == 0) { + sexp_write_string("#()", out); + } else { + sexp_write_string("#(", out); + sexp_write(elts[0], out); + for (i=1; i", out); + break; + case SEXP_IPORT: + sexp_write_string("#", out); break; + case SEXP_OPORT: + sexp_write_string("#", out); break; + case SEXP_CORE: + sexp_write_string("#", out); break; + case SEXP_OPCODE: + sexp_write_string("#", out); break; + case SEXP_BYTECODE: + sexp_write_string("#", out); break; + case SEXP_ENV: + sexp_printf(out, "#", obj); break; + case SEXP_EXCEPTION: + sexp_write_string("#", out); break; + case SEXP_MACRO: + sexp_write_string("#", out); break; +#if USE_DEBUG + case SEXP_LAMBDA: + sexp_write_string("#', out); + break; + case SEXP_SEQ: + sexp_write_string("#', out); + break; + case SEXP_CND: + sexp_write_string("#', out); + break; + case SEXP_REF: + sexp_write_string("#", sexp_ref_loc(obj)); + break; + case SEXP_SET: + sexp_write_string("#", out); + break; + case SEXP_SYNCLO: + sexp_write_string("#", out); + break; +#endif + case SEXP_STRING: + sexp_write_char('"', out); + i = sexp_string_length(obj); + str = sexp_string_data(obj); + for ( ; i>0; str++, i--) { + switch (str[0]) { + case '\\': sexp_write_string("\\\\", out); break; + case '"': sexp_write_string("\\\"", out); break; + case '\n': sexp_write_string("\\n", out); break; + case '\r': sexp_write_string("\\r", out); break; + case '\t': sexp_write_string("\\t", out); break; + default: sexp_write_char(str[0], out); + } + } + sexp_write_char('"', 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('\\', out); + sexp_write_char(str[0], out); + } + break; + } + } else if (sexp_integerp(obj)) { + sexp_printf(out, "%ld", sexp_unbox_integer(obj)); + } else if (sexp_charp(obj)) { + if (obj == sexp_make_character(' ')) + sexp_write_string("#\\space", out); + else if (obj == sexp_make_character('\n')) + sexp_write_string("#\\newline", out); + else if (obj == sexp_make_character('\r')) + sexp_write_string("#\\return", out); + else if (obj == sexp_make_character('\t')) + sexp_write_string("#\\tab", out); + else if ((33 <= sexp_unbox_character(obj)) + && (sexp_unbox_character(obj) < 127)) + sexp_printf(out, "#\\%c", sexp_unbox_character(obj)); + else + sexp_printf(out, "#\\x%02d", sexp_unbox_character(obj)); + } else if (sexp_symbolp(obj)) { + +#if USE_HUFF_SYMS + if (((sexp_uint_t)obj&7)==7) { + c = ((sexp_uint_t)obj)>>3; + while (c) { +#include "sexp-unhuff.c" + sexp_write_char(res, out); + } + } +#endif + + } else { + switch ((sexp_uint_t) obj) { + case (sexp_uint_t) SEXP_NULL: + sexp_write_string("()", out); break; + case (sexp_uint_t) SEXP_TRUE: + sexp_write_string("#t", out); break; + case (sexp_uint_t) SEXP_FALSE: + sexp_write_string("#f", out); break; + case (sexp_uint_t) SEXP_EOF: + sexp_write_string("#", out); break; + case (sexp_uint_t) SEXP_UNDEF: + case (sexp_uint_t) SEXP_VOID: + sexp_write_string("#", out); break; + case (sexp_uint_t) SEXP_ERROR: + sexp_write_string("#", out); break; + default: + sexp_printf(out, "#", obj); + } + } +} + +char* sexp_read_string(sexp in) { + char *buf, *tmp, *res; + int c, i=0, size=128; + + buf = sexp_alloc(size); + + for (c=sexp_read_char(in); c != '"'; c=sexp_read_char(in)) { + if (c == EOF) { + sexp_free(buf); + return NULL; + } + if (c == '\\') { + c=sexp_read_char(in); + switch (c) { + case 'n': c = '\n'; break; + case 't': c = '\t'; break; + } + buf[i++] = c; + } else { + buf[i++] = c; + } + if (i >= size) { + tmp = sexp_alloc(2*size); + memcpy(tmp, buf, i); + sexp_free(buf); + buf = tmp; + } + } + + buf[i] = '\0'; + res = sexp_alloc(i); + memcpy(res, buf, i); + sexp_free(buf); + return res; +} + +char* sexp_read_symbol(sexp in, int init) { + char *buf, *tmp, *res; + int c, i=0, size=128; + + buf = sexp_alloc(size); + + if (init != EOF) + buf[i++] = init; + + while (1) { + c=sexp_read_char(in); + if (c == EOF || is_separator(c)) { + sexp_push_char(c, in); + break; + } + buf[i++] = c; + if (i >= size) { + tmp = sexp_alloc(2*size); + memcpy(tmp, buf, i); + sexp_free(buf); + buf = tmp; + } + } + + buf[i] = '\0'; + res = sexp_alloc(i); + memcpy(res, buf, i); + sexp_free(buf); + return res; +} + +sexp sexp_read_float_tail(sexp in, sexp_sint_t whole) { + sexp exponent; + double res=0.0, scale=0.1, e=0.0; + int c; + for (c=sexp_read_char(in); isdigit(c); c=sexp_read_char(in), scale*=0.1) + res += digit_value(c)*scale; + sexp_push_char(c, in); + if (c=='e' || c=='E') { + exponent = sexp_read_number(in, 10); + if (sexp_exceptionp(exponent)) return exponent; + e = (sexp_integerp(exponent) ? sexp_unbox_integer(exponent) + : sexp_flonump(exponent) ? sexp_flonum_value(exponent) : 0.0); + } else if ((c!=EOF) && ! is_separator(c)) + return sexp_read_error("invalid numeric syntax", + sexp_list1(sexp_make_character(c)), in); + return sexp_make_flonum((whole + res) * pow(10, e)); +} + +sexp sexp_read_number(sexp in, int base) { + sexp f; + sexp_sint_t res = 0, negativep = 0, c; + + c = sexp_read_char(in); + if (c == '-') + negativep = 1; + else if (isdigit(c)) + res = digit_value(c); + + if (base == 16) + for (c=sexp_read_char(in); isxdigit(c); c=sexp_read_char(in)) + res = res * base + digit_value(c); + for (c=sexp_read_char(in); isdigit(c); c=sexp_read_char(in)) + res = res * base + digit_value(c); + + if (c=='.' || c=='e' || c=='E') { + if (base != 10) + return sexp_read_error("decimal found in non-base 10", SEXP_NULL, in); + if (c!='.') + sexp_push_char(c, in); + f = sexp_read_float_tail(in, res); + if (! sexp_flonump(f)) return f; + if ((c!='.') && (sexp_flonum_value(f) == round(sexp_flonum_value(f)))) { + res = (sexp_sint_t) sexp_flonum_value(f); + } else { + if (negativep) sexp_flonum_value(f) = -sexp_flonum_value(f); + return f; + } + } else { + sexp_push_char(c, in); + if ((c!=EOF) && ! is_separator(c)) + return sexp_read_error("invalid numeric syntax", + sexp_list1(sexp_make_character(c)), in); + } + + return sexp_make_integer(negativep ? -res : res); +} + +sexp sexp_read_raw (sexp in) { + sexp res, tmp, tmp2; + char *str; + int c1, c2; + + scan_loop: + switch (c1 = sexp_read_char(in)) { + case EOF: + res = SEXP_EOF; + break; + case ';': + sexp_port_line(in)++; + while ((c1 = sexp_read_char(in)) != EOF) + if (c1 == '\n') + break; + /* ... FALLTHROUGH ... */ + case ' ': + case '\t': + case '\r': + goto scan_loop; + case '\n': + sexp_port_line(in)++; + goto scan_loop; + case '\'': + res = sexp_read(in); + res = sexp_list2(the_quote_symbol, res); + break; + case '`': + res = sexp_read(in); + res = sexp_list2(the_quasiquote_symbol, res); + break; + case ',': + if ((c1 = sexp_read_char(in)) == '@') { + res = sexp_read(in); + res = sexp_list2(the_unquote_splicing_symbol, res); + } else { + sexp_push_char(c1, in); + res = sexp_read(in); + res = sexp_list2(the_unquote_symbol, res); + } + break; + case '"': + str = sexp_read_string(in); + if (! str) + res = sexp_read_error("premature end of string", SEXP_NULL, in); + else + res = sexp_c_string(str); + sexp_free(str); + break; + case '(': + res = SEXP_NULL; + tmp = sexp_read_raw(in); + while ((tmp != SEXP_ERROR) && (tmp != SEXP_EOF) && (tmp != SEXP_CLOSE)) { + if (tmp == SEXP_RAWDOT) { + if (res == SEXP_NULL) { + return sexp_read_error("dot before any elements in list", + SEXP_NULL, in); + } else { + tmp = sexp_read_raw(in); + if (sexp_read_raw(in) != SEXP_CLOSE) { + sexp_deep_free(res); + return sexp_read_error("multiple tokens in dotted tail", + SEXP_NULL, in); + } else { + tmp2 = res; + res = sexp_nreverse(res); + sexp_cdr(tmp2) = tmp; + return res; + } + } + } else { + res = sexp_cons(tmp, res); + tmp = sexp_read_raw(in); + } + } + if (tmp != SEXP_CLOSE) { + sexp_deep_free(res); + return sexp_read_error("missing trailing ')'", SEXP_NULL, in); + } + res = (sexp_pairp(res) ? sexp_nreverse(res) : res); + break; + case '#': + switch (c1=sexp_read_char(in)) { + case 'b': + res = sexp_read_number(in, 2); break; + case 'o': + res = sexp_read_number(in, 8); break; + case 'd': + res = sexp_read_number(in, 10); break; + case 'x': + res = sexp_read_number(in, 16); break; + case 'e': + res = sexp_read(in); + if (sexp_flonump(res)) + res = sexp_make_integer((sexp_sint_t)sexp_flonum_value(res)); + break; + case 'i': + res = sexp_read(in); + if (sexp_integerp(res)) + res = sexp_make_flonum(sexp_unbox_integer(res)); + break; + case 'f': + case 't': + c2 = sexp_read_char(in); + if (c2 == EOF || is_separator(c2)) { + res = (c1 == 't' ? SEXP_TRUE : SEXP_FALSE); + sexp_push_char(c2, in); + } else { + res = sexp_read_error("invalid syntax #%c%c", + sexp_list2(sexp_make_character(c1), + sexp_make_character(c2)), + in); + } + break; + case ';': + sexp_read_raw(in); + goto scan_loop; + case '\\': + c1 = sexp_read_char(in); + str = sexp_read_symbol(in, c1); + if (str[0] == '\0') + res = + sexp_read_error("unexpected end of character literal", SEXP_NULL, in); + if (str[1] == '\0') { + res = sexp_make_character(c1); + } else if ((c1 == 'x' || c1 == 'X') && + isxdigit(str[0]) && isxdigit(str[1]) && str[2] == '\0') { + res = sexp_make_character(16 * digit_value(c1) + digit_value(str[1])); + } 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 { + res = sexp_read_error("unknown character name", + sexp_list1(sexp_c_string(str)), + in); + } + } + sexp_free(str); + break; + case '(': + sexp_push_char(c1, in); + res = sexp_read(in); + if (sexp_listp(res) == SEXP_FALSE) { + if (! sexp_exceptionp(res)) { + sexp_deep_free(res); + res = sexp_read_error("dotted list not allowed in vector syntax", + SEXP_NULL, + in); + } + } else { + res = sexp_list_to_vector(res); + } + break; + default: + res = sexp_read_error("invalid # syntax", + sexp_list1(sexp_make_character(c1)), in); + } + break; + case '.': + c1 = sexp_read_char(in); + if (c1 == EOF || is_separator(c1)) { + res = SEXP_RAWDOT; + } else if (isdigit(c1)) { + sexp_push_char(c1,in ); + res = sexp_read_float_tail(in, 0); + } else { + sexp_push_char(c1, in); + str = sexp_read_symbol(in, '.'); + res = sexp_intern(str); + sexp_free(str); + } + break; + case ')': + res = SEXP_CLOSE; + break; + case '+': + case '-': + c2 = sexp_read_char(in); + if (c2 == '.' || isdigit(c2)) { + sexp_push_char(c2, in); + res = sexp_read_number(in, 10); + if (sexp_exceptionp(res)) return res; + if (c1 == '-') { +#ifdef USE_FLONUMS + if (sexp_flonump(res)) + sexp_flonum_value(res) = -1 * sexp_flonum_value(res); + else +#endif + res = sexp_fx_mul(res, -1); + } + } else { + sexp_push_char(c2, in); + str = sexp_read_symbol(in, c1); + res = sexp_intern(str); + sexp_free(str); + } + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + sexp_push_char(c1, in); + res = sexp_read_number(in, 10); + break; + default: + str = sexp_read_symbol(in, c1); + res = sexp_intern(str); + sexp_free(str); + break; + } + return res; +} + +sexp sexp_read (sexp in) { + sexp res = sexp_read_raw(in); + if (res == SEXP_CLOSE) + return sexp_read_error("too many ')'s", SEXP_NULL, in); + if (res == SEXP_RAWDOT) + return sexp_read_error("unexpected '.'", SEXP_NULL, in); + return res; +} + +#if USE_STRING_STREAMS +sexp sexp_read_from_string(char *str) { + sexp s = sexp_c_string(str); + sexp in = sexp_make_input_string_port(s); + sexp res = sexp_read(in); + sexp_deep_free(s); + sexp_deep_free(in); + return res; +} +#endif + +void sexp_init() { + int i; + if (! sexp_initialized_p) { + sexp_initialized_p = 1; +#if USE_BOEHM + GC_init(); + GC_add_roots((char*)&symbol_table, + ((char*)&symbol_table)+sizeof(symbol_table)+1); +#endif + for (i=0; i +#include +#include +#include +#include +#include +#include +#include + +/* tagging system + * bits end in 00: pointer + * 01: fixnum + * 011: + * 111: immediate symbol + * 0110: char + * 1110: other immediate object (NULL, TRUE, FALSE) + */ + +#define SEXP_FIXNUM_BITS 2 +#define SEXP_IMMEDIATE_BITS 3 +#define SEXP_EXTENDED_BITS 4 + +#define SEXP_FIXNUM_MASK 3 +#define SEXP_IMMEDIATE_MASK 7 +#define SEXP_EXTENDED_MASK 15 + +#define SEXP_POINTER_TAG 0 +#define SEXP_FIXNUM_TAG 1 +#define SEXP_ISYMBOL_TAG 7 +#define SEXP_CHAR_TAG 6 +#define SEXP_EXTENDED_TAG 14 + +#define SEXP_MAX_INT ((1<<29)-1) +#define SEXP_MIN_INT (-(1<<29)) + +enum sexp_types { + SEXP_OBJECT, + SEXP_FIXNUM, + SEXP_CHAR, + SEXP_BOOLEAN, + SEXP_PAIR, + SEXP_SYMBOL, + SEXP_STRING, + SEXP_VECTOR, + SEXP_FLONUM, + SEXP_BIGNUM, + SEXP_IPORT, + SEXP_OPORT, + SEXP_EXCEPTION, + /* the following are used only by the evaluator */ + 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_CONTEXT, +}; + +typedef unsigned long sexp_uint_t; +typedef long sexp_sint_t; +typedef char sexp_tag_t; +typedef struct sexp_struct *sexp; + +struct sexp_struct { + sexp_tag_t tag; + union { + /* basic types */ + double flonum; + struct { + sexp car, cdr; + } pair; + struct { + sexp_uint_t length; + sexp *data; + } vector; + struct { + sexp_uint_t length; + char *data; + } string; + struct { + sexp_uint_t length; + char *data; + } symbol; + struct { + FILE *stream; + char *name; + sexp_uint_t line; + sexp cookie; + } port; + struct { + sexp kind, message, irritants, procedure, file, line; + } exception; + /* runtime types */ + struct { + char flags; + sexp parent, lambda, bindings; + } env; + struct { + sexp_uint_t length; + sexp name, literals; + unsigned char data[]; + } bytecode; + struct { + char flags; + unsigned short num_args; + sexp bc, vars; + } procedure; + struct { + sexp proc, env; + } macro; + struct { + sexp env, free_vars, expr; + } synclo; + struct { + unsigned char op_class, code, num_args, flags, + arg1_type, arg2_type, inverse; + char *name; + sexp dflt, data, proc; + } opcode; + struct { + char code; + char *name; + } core; + /* ast types */ + struct { + sexp name, params, locals, defs, flags, body, fv, sv; + } lambda; + struct { + sexp test, pass, fail; + } cnd; + struct { + sexp var, value; + } set; + struct { + sexp name, cell; + } ref; + struct { + sexp ls; + } seq; + struct { + sexp value; + } lit; + /* compiler state */ + struct { + sexp bc, lambda, *stack, env, fv; + sexp_uint_t pos, top, depth, tailp, tracep; + } context; + } value; +}; + +#define sexp_sizeof(x) (offsetof(struct sexp_struct, value) \ + + sizeof(((sexp)0)->value.x)) + +#define sexp_alloc_type(type, tag) sexp_alloc_tagged(sexp_sizeof(type), tag) + +#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<tag) + +#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) + +#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_flonump(x) (sexp_check_tag(x, SEXP_FLONUM)) +#define sexp_iportp(x) (sexp_check_tag(x, SEXP_IPORT)) +#define sexp_oportp(x) (sexp_check_tag(x, SEXP_OPORT)) +#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_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(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_integer(n) ((sexp) ((((sexp_sint_t)n)<>SEXP_FIXNUM_BITS) + +#define sexp_make_character(n) ((sexp) ((((sexp_sint_t)n)<>SEXP_EXTENDED_BITS)) + +#define sexp_flonum_value(f) ((f)->value.flonum) + +#if USE_FLONUMS +#define sexp_integer_to_flonum(x) (sexp_make_flonum(sexp_unbox_integer(x))) +#else +#define sexp_integer_to_flonum(x) (x) +#endif + +/*************************** 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_integer(i)]) +#define sexp_vector_set(x,i,v) (sexp_vector_data(x)[sexp_unbox_integer(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_integer(sexp_procedure_flags(x)) & 1) +#define sexp_procedure_code(x) ((x)->value.procedure.bc) +#define sexp_procedure_vars(x) ((x)->value.procedure.vars) + +#define sexp_string_length(x) ((x)->value.string.length) +#define sexp_string_data(x) ((x)->value.string.data) + +#define sexp_string_ref(x, i) (sexp_make_character(sexp_string_data(x)[sexp_unbox_integer(i)])) +#define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_integer(i)] = sexp_unbox_character(v)) + +#define sexp_symbol_length(x) ((x)->value.symbol.length) +#define sexp_symbol_data(x) ((x)->value.symbol.data) + +#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_cookie(p) ((p)->value.port.cookie) + +#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_file(p) ((p)->value.exception.file) +#define sexp_exception_line(p) ((p)->value.exception.line) + +#define sexp_bytecode_length(x) ((x)->value.bytecode.length) +#define sexp_bytecode_name(x) ((x)->value.bytecode.name) +#define sexp_bytecode_literals(x) ((x)->value.bytecode.literals) +#define sexp_bytecode_data(x) ((x)->value.bytecode.data) + +#define sexp_env_flags(x) ((x)->value.env.flags) +#define sexp_env_parent(x) ((x)->value.env.parent) +#define sexp_env_bindings(x) ((x)->value.env.bindings) +#define sexp_env_local_p(x) (sexp_env_parent(x)) +#define sexp_env_global_p(x) (! sexp_env_local_p(x)) +#define sexp_env_lambda(x) ((x)->value.env.lambda) + +#define sexp_macro_proc(x) ((x)->value.macro.proc) +#define sexp_macro_env(x) ((x)->value.macro.env) + +#define sexp_synclo_env(x) ((x)->value.synclo.env) +#define sexp_synclo_free_vars(x) ((x)->value.synclo.free_vars) +#define sexp_synclo_expr(x) ((x)->value.synclo.expr) + +#define sexp_core_code(x) ((x)->value.core.code) +#define sexp_core_name(x) ((x)->value.core.name) + +#define sexp_opcode_class(x) ((x)->value.opcode.op_class) +#define sexp_opcode_code(x) ((x)->value.opcode.code) +#define sexp_opcode_num_args(x) ((x)->value.opcode.num_args) +#define sexp_opcode_flags(x) ((x)->value.opcode.flags) +#define sexp_opcode_arg1_type(x) ((x)->value.opcode.arg1_type) +#define sexp_opcode_arg2_type(x) ((x)->value.opcode.arg2_type) +#define sexp_opcode_inverse(x) ((x)->value.opcode.inverse) +#define sexp_opcode_name(x) ((x)->value.opcode.name) +#define sexp_opcode_default(x) ((x)->value.opcode.dflt) +#define sexp_opcode_data(x) ((x)->value.opcode.data) +#define sexp_opcode_proc(x) ((x)->value.opcode.proc) + +#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_lambda_name(x) ((x)->value.lambda.name) +#define sexp_lambda_params(x) ((x)->value.lambda.params) +#define sexp_lambda_locals(x) ((x)->value.lambda.locals) +#define sexp_lambda_defs(x) ((x)->value.lambda.defs) +#define sexp_lambda_flags(x) ((x)->value.lambda.flags) +#define sexp_lambda_body(x) ((x)->value.lambda.body) +#define sexp_lambda_fv(x) ((x)->value.lambda.fv) +#define sexp_lambda_sv(x) ((x)->value.lambda.sv) + +#define sexp_cnd_test(x) ((x)->value.cnd.test) +#define sexp_cnd_pass(x) ((x)->value.cnd.pass) +#define sexp_cnd_fail(x) ((x)->value.cnd.fail) + +#define sexp_set_var(x) ((x)->value.set.var) +#define sexp_set_value(x) ((x)->value.set.value) + +#define sexp_ref_name(x) ((x)->value.ref.name) +#define sexp_ref_cell(x) ((x)->value.ref.cell) +#define sexp_ref_loc(x) (sexp_cdr(sexp_ref_cell(x))) + +#define sexp_seq_ls(x) ((x)->value.seq.ls) + +#define sexp_lit_value(x) ((x)->value.lit.value) + +#define sexp_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_top(x) ((x)->value.context.top) +#define sexp_context_lambda(x) ((x)->value.context.lambda) +#define sexp_context_tailp(x) ((x)->value.context.tailp) +#define sexp_context_tracep(x) ((x)->value.context.tailp) + +/****************************** 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_integer(sexp_unbox_integer(a) / sexp_unbox_integer(b))) +#define sexp_fx_rem(a, b) (sexp_make_integer(sexp_unbox_integer(a) % sexp_unbox_integer(b))) +#define sexp_fx_sign(a) (-((sexp_sint_t)(a) < 0)) /* -1 or 0 */ + +#define sexp_fp_add(a, b) (sexp_make_flonum(sexp_flonum_value(a) + sexp_flonum_value(b))) +#define sexp_fp_sub(a, b) (sexp_make_flonum(sexp_flonum_value(a) - sexp_flonum_value(b))) +#define sexp_fp_mul(a, b) (sexp_make_flonum(sexp_flonum_value(a) * sexp_flonum_value(b))) +#define sexp_fp_div(a, b) (sexp_make_flonum(sexp_flonum_value(a) / sexp_flonum_value(b))) + +/****************************** utilities *****************************/ + +#define sexp_list1(a) sexp_cons(a, SEXP_NULL) +#define sexp_list2(a, b) sexp_cons(a, sexp_cons(b, SEXP_NULL)) +#define sexp_list3(a, b, c) sexp_cons(a, sexp_cons(b, sexp_cons(c, SEXP_NULL))) +#define sexp_list4(a, b, c, d) sexp_cons(a, sexp_cons(b, sexp_cons(c, sexp_cons(d, SEXP_NULL)))) + +#define sexp_push(ls, x) ((ls) = sexp_cons((x), (ls))) +#define sexp_insert(ls, x) ((sexp_memq((x), (ls)) != SEXP_FALSE) ? (ls) : sexp_push((ls), (x))) + +#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))) +#define sexp_cddddr(x) (sexp_cddr(sexp_cddr(x))) + +/***************************** general API ****************************/ + +#define sexp_read_char(p) (getc(sexp_port_stream(p))) +#define sexp_push_char(c, p) (ungetc(c, sexp_port_stream(p))) +#define sexp_write_char(c, p) (putc(c, sexp_port_stream(p))) +#define sexp_write_string(s, p) (fputs(s, sexp_port_stream(p))) +#define sexp_printf(p, ...) (fprintf(sexp_port_stream(p), __VA_ARGS__)) +#define sexp_scanf(p, ...) (fscanf(sexp_port_stream(p), __VA_ARGS__)) +#define sexp_flush(p) (fflush(sexp_port_stream(p))) + +sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag); +sexp sexp_cons(sexp head, sexp tail); +sexp sexp_equalp (sexp a, sexp b); +sexp sexp_listp(sexp obj); +sexp sexp_reverse(sexp ls); +sexp sexp_nreverse(sexp ls); +sexp sexp_append(sexp a, sexp b); +sexp sexp_memq(sexp x, sexp ls); +sexp sexp_assq(sexp x, sexp ls); +sexp sexp_length(sexp ls); +sexp sexp_c_string(char *str); +sexp sexp_make_string(sexp len, sexp ch); +sexp sexp_substring (sexp str, sexp start, sexp end); +sexp sexp_make_flonum(double f); +sexp_uint_t sexp_string_hash(char *str, sexp_uint_t acc); +sexp sexp_intern(char *str); +sexp sexp_string_to_symbol(sexp str); +sexp sexp_make_vector(sexp len, sexp dflt); +sexp sexp_list_to_vector(sexp ls); +sexp sexp_vector(int count, ...); +void sexp_write(sexp obj, sexp out); +char* sexp_read_string(sexp in); +char* sexp_read_symbol(sexp in, int init); +sexp sexp_read_number(sexp in, int base); +sexp sexp_read_raw(sexp in); +sexp sexp_read(sexp in); +sexp sexp_read_from_string(char *str); +sexp sexp_make_input_port(FILE* in, char *path); +sexp sexp_make_output_port(FILE* out, char *path); +sexp sexp_make_input_string_port(sexp str); +sexp sexp_make_output_string_port(); +sexp sexp_get_output_string(sexp port); +sexp sexp_make_exception(sexp kind, sexp message, sexp irritants, sexp procedure, sexp file, sexp line); +sexp sexp_user_exception (sexp self, char *message, sexp obj); +sexp sexp_type_exception (char *message, sexp obj); +sexp sexp_range_exception (sexp obj, sexp start, sexp end); +sexp sexp_print_exception(sexp exn, sexp out); +void sexp_init(); + +#endif /* ! SEXP_H */ + diff --git a/syntax-rules.scm b/syntax-rules.scm new file mode 100644 index 00000000..468c4bdf --- /dev/null +++ b/syntax-rules.scm @@ -0,0 +1,182 @@ + +(define-syntax syntax-rules + (er-macro-transformer + (lambda (expr rename compare) + (let ((lits (cadr expr)) + (forms (cddr 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 'quote)) (_apply (rename 'apply)) + (_append (rename 'append)) (_map (rename 'map)) + (_vector? (rename 'vector?)) (_list? (rename 'list?)) + (_lp (rename 'lp)) (_reverse (rename 'reverse)) + (_vector->list (rename 'vector->list)) + (_list->vector (rename 'list->vector))) + (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))) + (error "non-trailing ellipse")) + ((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? x) + (and (pair? x) (pair? (cdr x)) (compare '... (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 (memq x (list _quote 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 + ((assq t vars) + => (lambda (cell) + (if (<= (cdr cell) dim) + t + (error "too few ...'s")))) + (else + (list _rename (list _quote t))))) + ((pair? t) + (if (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)))))) + (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")))))))))) + +;; Local Variables: +;; eval: (put '_lambda 'scheme-indent-function 1) +;; eval: (put '_let 'scheme-indent-function 'scheme-let-indent) +;; eval: (put '_if 'scheme-indent-function 3) +;; End: + diff --git a/tests/basic/test00-fact-3.res b/tests/basic/test00-fact-3.res new file mode 100644 index 00000000..f76d3d1e --- /dev/null +++ b/tests/basic/test00-fact-3.res @@ -0,0 +1 @@ +(fact 3) => 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..8a1218a1 --- /dev/null +++ b/tests/basic/test09-hygiene.res @@ -0,0 +1,5 @@ +1 +2 +3 +4 +5 diff --git a/tests/basic/test09-hygiene.scm b/tests/basic/test09-hygiene.scm new file mode 100644 index 00000000..c3f0bb7e --- /dev/null +++ b/tests/basic/test09-hygiene.scm @@ -0,0 +1,25 @@ + +(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) 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/r5rs-tests.scm b/tests/r5rs-tests.scm new file mode 100644 index 00000000..e11ced4c --- /dev/null +++ b/tests/r5rs-tests.scm @@ -0,0 +1,373 @@ + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test expect expr) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display 'expr out)))) + (res expr)) + (display str) + (write-char #\space) + (display (make-string (max 0 (- 72 (string-length str))) #\.)) + (flush-output) + (cond + ((equal? res expect) + (set! *tests-passed* (+ *tests-passed* 1)) + (display " [PASS]\n")) + (else + (display " [FAIL]\n") + (display " expected ") (write expect) + (display " but got ") (write res) (newline)))))))) + +(define (test-report) + (write *tests-passed*) + (display " out of ") + (write *tests-run*) + (display " passed (") + (write (* (/ *tests-passed* *tests-run*) 100)) + (display "%)") + (newline)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(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 '#(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 2 4 3 8) + `(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 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 #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 -5 (floor -4.3)) + +(test -4 (ceiling -4.3)) + +(test -4 (truncate -4.3)) + +(test -4 (round -4.3)) + +(test 3 (floor 3.5)) + +(test 4 (ceiling 3.5)) + +(test 3 (truncate 3.5)) + +(test 4 (round 3.5)) + +(test 100 (string->number "100")) + +(test 256 (string->number "100" 16)) + +(test 100 (string->number "1e2")) + +(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 (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-report)