commit b5f07e6da674fc3368746305706e8078ea5e2740 Author: Alex Shinn Date: Tue Apr 14 21:28:21 2009 +0900 fixing syntax-rules.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)