From 4d78a28d8c59de55c8cd1625cce6f9565c0aaef2 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 5 May 2009 03:16:09 +0900 Subject: [PATCH] passing context through all calls that can allocate memory in preparation for a native, thread-safe gc. --- Makefile | 4 +- defaults.h | 32 ++- eval.c | 598 +++++++++++++++++++++++++++-------------------------- eval.h | 1 + gc.c | 53 ++++- init.scm | 40 ++-- main.c | 36 ++-- opcodes.c | 7 +- sexp.c | 373 ++++++++++++++++----------------- sexp.h | 98 ++++----- 10 files changed, 658 insertions(+), 584 deletions(-) diff --git a/Makefile b/Makefile index c4166b8d..d23dd575 100644 --- a/Makefile +++ b/Makefile @@ -10,7 +10,9 @@ INCDIR=$(PREFIX)/include/chibi-scheme MODDIR=$(PREFIX)/share/chibi-scheme LDFLAGS=-lm -CFLAGS=-Wall -g -Os + +# -Oz for smaller size on darwin +CFLAGS=-Wall -g -Os -save-temps GC_OBJ=./gc/gc.a diff --git a/defaults.h b/defaults.h index add20406..2367f68f 100644 --- a/defaults.h +++ b/defaults.h @@ -20,6 +20,10 @@ #define USE_BOEHM 1 #endif +#ifndef USE_MALLOC +#define USE_MALLOC 0 +#endif + #ifndef USE_FLONUMS #define USE_FLONUMS 1 #endif @@ -58,16 +62,22 @@ #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); +#define sexp_alloc(ctx, size) GC_malloc(size) +#define sexp_alloc_atomic(ctx, size) GC_malloc_atomic(size) +#define sexp_realloc(ctx, x, size) GC_realloc(x, size) +#define sexp_free(ctx, x) +#define sexp_deep_free(ctx, x) +#elif USE_MALLOC +#define sexp_alloc(ctx, size) malloc(size) +#define sexp_alloc_atomic(ctx, size) malloc(size) +#define sexp_realloc(ctx, x, size) realloc(x, size) +#define sexp_free(ctx, x) free(x) +void sexp_deep_free(sexp ctx, sexp obj); +#else /* native gc */ +void *sexp_alloc(sexp ctx, size_t size); +#define sexp_alloc_atomic sexp_alloc +void *sexp_realloc(sexp ctx, sexp x, size_t size); +#define sexp_free(ctx, x) +#define sexp_deep_free(ctx, x) #endif diff --git a/eval.c b/eval.c index 28cc7b61..bc384d9b 100644 --- a/eval.c +++ b/eval.c @@ -23,8 +23,8 @@ static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol; 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); +static sexp sexp_make_null_env (sexp ctx, sexp version); +static sexp sexp_make_standard_env (sexp ctx, sexp version); /********************** environment utilities ***************************/ @@ -41,13 +41,13 @@ static sexp env_cell(sexp e, sexp key) { return NULL; } -static sexp env_cell_create(sexp e, sexp key, sexp value) { +static sexp env_cell_create(sexp ctx, sexp e, sexp key, sexp value) { sexp cell = env_cell(e, key); if (! cell) { - cell = sexp_cons(key, value); + cell = sexp_cons(ctx, key, value); while (sexp_env_parent(e)) e = sexp_env_parent(e); - sexp_env_bindings(e) = sexp_cons(cell, sexp_env_bindings(e)); + sexp_env_bindings(e) = sexp_cons(ctx, cell, sexp_env_bindings(e)); } return cell; } @@ -60,32 +60,32 @@ static sexp env_global_ref(sexp e, sexp key, sexp dflt) { 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)); +static void env_define(sexp ctx, sexp e, sexp key, sexp value) { + sexp cell = sexp_assq(ctx, key, sexp_env_bindings(e)); if (cell != SEXP_FALSE) sexp_cdr(cell) = value; else - sexp_push(sexp_env_bindings(e), sexp_cons(key, value)); + sexp_push(ctx, sexp_env_bindings(e), sexp_cons(ctx, key, value)); } -static sexp extend_env (sexp env, sexp vars, sexp value) { - sexp e = sexp_alloc_type(env, SEXP_ENV); +static sexp extend_env (sexp ctx, sexp env, sexp vars, sexp value) { + sexp e = sexp_alloc_type(ctx, env, SEXP_ENV); sexp_env_parent(e) = env; sexp_env_bindings(e) = SEXP_NULL; for ( ; sexp_pairp(vars); vars = sexp_cdr(vars)) - sexp_push(sexp_env_bindings(e), sexp_cons(sexp_car(vars), value)); + sexp_push(ctx, sexp_env_bindings(e), sexp_cons(ctx, sexp_car(vars), value)); return e; } -static sexp sexp_reverse_flatten_dot (sexp ls) { +static sexp sexp_reverse_flatten_dot (sexp ctx, 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)); + sexp_push(ctx, res, sexp_car(ls)); + return (sexp_nullp(ls) ? res : sexp_cons(ctx, ls, res)); } -static sexp sexp_flatten_dot (sexp ls) { - return sexp_nreverse(sexp_reverse_flatten_dot(ls)); +static sexp sexp_flatten_dot (sexp ctx, sexp ls) { + return sexp_nreverse(ctx, sexp_reverse_flatten_dot(ctx, ls)); } static int sexp_param_index (sexp lambda, sexp name) { @@ -108,7 +108,7 @@ static int sexp_param_index (sexp lambda, sexp name) { 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); + tmp = sexp_alloc_tagged(context, sexp_sizeof(bytecode) + i, SEXP_BYTECODE); sexp_bytecode_name(tmp) = SEXP_FALSE; sexp_bytecode_length(tmp) = i; sexp_bytecode_literals(tmp) @@ -124,7 +124,8 @@ 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) + tmp = sexp_alloc_tagged(context, + sexp_sizeof(bytecode) + sexp_bytecode_length(sexp_context_bc(context))*2, SEXP_BYTECODE); sexp_bytecode_name(tmp) = SEXP_FALSE; @@ -156,12 +157,12 @@ 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); + sexp_push(context, sexp_bytecode_literals(sexp_context_bc(context)), obj); } -static sexp sexp_make_procedure(sexp flags, sexp num_args, +static sexp sexp_make_procedure(sexp ctx, sexp flags, sexp num_args, sexp bc, sexp vars) { - sexp proc = sexp_alloc_type(procedure, SEXP_PROCEDURE); + sexp proc = sexp_alloc_type(ctx, procedure, SEXP_PROCEDURE); sexp_procedure_flags(proc) = (char) (sexp_uint_t) flags; sexp_procedure_num_args(proc) = (unsigned short) (sexp_uint_t) num_args; sexp_procedure_code(proc) = bc; @@ -169,18 +170,18 @@ static sexp sexp_make_procedure(sexp flags, sexp num_args, return proc; } -static sexp sexp_make_macro (sexp p, sexp e) { - sexp mac = sexp_alloc_type(macro, SEXP_MACRO); +static sexp sexp_make_macro (sexp ctx, sexp p, sexp e) { + sexp mac = sexp_alloc_type(ctx, macro, SEXP_MACRO); sexp_macro_env(mac) = e; sexp_macro_proc(mac) = p; return mac; } -static sexp sexp_make_synclo (sexp env, sexp fv, sexp expr) { +static sexp sexp_make_synclo (sexp ctx, sexp env, sexp fv, sexp expr) { sexp res; if (sexp_synclop(expr)) return expr; - res = sexp_alloc_type(synclo, SEXP_SYNCLO); + res = sexp_alloc_type(ctx, synclo, SEXP_SYNCLO); sexp_synclo_env(res) = env; sexp_synclo_free_vars(res) = fv; sexp_synclo_expr(res) = expr; @@ -189,8 +190,8 @@ static sexp sexp_make_synclo (sexp env, sexp fv, sexp expr) { /* internal AST */ -static sexp sexp_make_lambda(sexp params) { - sexp res = sexp_alloc_type(lambda, SEXP_LAMBDA); +static sexp sexp_make_lambda(sexp ctx, sexp params) { + sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA); sexp_lambda_name(res) = SEXP_FALSE; sexp_lambda_params(res) = params; sexp_lambda_fv(res) = SEXP_NULL; @@ -200,42 +201,42 @@ static sexp sexp_make_lambda(sexp params) { return res; } -static sexp sexp_make_set(sexp var, sexp value) { - sexp res = sexp_alloc_type(set, SEXP_SET); +static sexp sexp_make_set(sexp ctx, sexp var, sexp value) { + sexp res = sexp_alloc_type(ctx, set, SEXP_SET); sexp_set_var(res) = var; sexp_set_value(res) = value; return res; } -static sexp sexp_make_ref(sexp name, sexp cell) { - sexp res = sexp_alloc_type(ref, SEXP_REF); +static sexp sexp_make_ref(sexp ctx, sexp name, sexp cell) { + sexp res = sexp_alloc_type(ctx, ref, SEXP_REF); sexp_ref_name(res) = name; sexp_ref_cell(res) = cell; return res; } -static sexp sexp_make_cnd(sexp test, sexp pass, sexp fail) { - sexp res = sexp_alloc_type(cnd, SEXP_CND); +static sexp sexp_make_cnd(sexp ctx, sexp test, sexp pass, sexp fail) { + sexp res = sexp_alloc_type(ctx, cnd, SEXP_CND); sexp_cnd_test(res) = test; sexp_cnd_pass(res) = pass; sexp_cnd_fail(res) = fail; return res; } -static sexp sexp_make_lit(sexp value) { - sexp res = sexp_alloc_type(lit, SEXP_LIT); +static sexp sexp_make_lit(sexp ctx, sexp value) { + sexp res = sexp_alloc_type(ctx, lit, SEXP_LIT); sexp_lit_value(res) = value; return res; } -static sexp sexp_make_context(sexp *stack, sexp env) { - sexp res = sexp_alloc_type(context, SEXP_CONTEXT); +static sexp sexp_make_context(sexp ctx, sexp *stack, sexp env) { + sexp res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); if (! stack) - stack = (sexp*) sexp_alloc(sizeof(sexp)*INIT_STACK_SIZE); + stack = (sexp*) sexp_alloc(ctx, sizeof(sexp)*INIT_STACK_SIZE); if (! env) - env = sexp_make_standard_env(sexp_make_integer(5)); + env = sexp_make_standard_env(ctx, sexp_make_integer(5)); sexp_context_bc(res) - = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE); + = sexp_alloc_tagged(ctx, 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; @@ -252,7 +253,8 @@ static sexp sexp_make_context(sexp *stack, sexp env) { } static sexp sexp_child_context(sexp context, sexp lambda) { - sexp ctx = sexp_make_context(sexp_context_stack(context), + sexp ctx = sexp_make_context(context, + sexp_context_stack(context), sexp_context_env(context)); sexp_context_lambda(ctx) = lambda; sexp_context_env(ctx) = sexp_context_env(context); @@ -264,28 +266,29 @@ static sexp sexp_child_context(sexp context, sexp lambda) { #define sexp_idp(x) (sexp_symbolp(x) || (sexp_synclop(x) && sexp_symbolp(sexp_synclo_expr(x)))) -static sexp sexp_identifierp (sexp x) { +static sexp sexp_identifierp (sexp ctx, sexp x) { return sexp_make_boolean(sexp_idp(x)); } -static sexp sexp_syntactic_closure_expr (sexp x) { +static sexp sexp_syntactic_closure_expr (sexp ctx, sexp x) { return (sexp_synclop(x) ? sexp_synclo_expr(x) : x); } -static sexp sexp_strip_syntactic_closures (sexp x) { +static sexp sexp_strip_synclos (sexp ctx, 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))); + return sexp_cons(ctx, + sexp_strip_synclos(ctx, sexp_car(x)), + sexp_strip_synclos(ctx, sexp_cdr(x))); } else { return x; } } -static sexp sexp_identifier_eq (sexp e1, sexp id1, sexp e2, sexp id2) { +static sexp sexp_identifier_eq(sexp ctx, 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); @@ -306,10 +309,10 @@ static sexp sexp_identifier_eq (sexp e1, sexp id1, sexp e2, sexp id2) { /************************* 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); +static sexp sexp_compile_error(sexp ctx, char *message, sexp obj) { + return sexp_make_exception(ctx, the_compile_error_symbol, + sexp_c_string(ctx, message), sexp_list1(ctx, obj), + SEXP_FALSE, SEXP_FALSE, SEXP_FALSE); } #define analyze_check_exception(x) do {if (sexp_exceptionp(x)) \ @@ -324,9 +327,9 @@ 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); + sexp_push(context, res, tmp); } - return sexp_nreverse(res); + return sexp_nreverse(context, res); } static sexp analyze_seq (sexp ls, sexp context) { @@ -336,7 +339,7 @@ static sexp analyze_seq (sexp ls, sexp context) { else if (sexp_nullp(sexp_cdr(ls))) res = analyze(sexp_car(ls), context); else { - res = sexp_alloc_type(seq, SEXP_SEQ); + res = sexp_alloc_type(context, seq, SEXP_SEQ); tmp = analyze_app(ls, context); analyze_check_exception(tmp); sexp_seq_ls(res) = tmp; @@ -349,43 +352,44 @@ static sexp analyze_var_ref (sexp x, sexp context) { cell = env_cell(env, x); if (! cell) { if (sexp_synclop(x)) { - if (sexp_memq(x, sexp_context_fv(context)) != SEXP_FALSE) + if (sexp_memq(context, 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); + cell = env_cell_create(context, 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); + return sexp_compile_error(context, "invalid use of syntax as value", x); + return sexp_make_ref(context, 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)); + sexp_insert(context, 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); + return sexp_make_set(context, 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)); + return sexp_compile_error(context, "bad lambda syntax", 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)); + return sexp_compile_error(context, "non-symbol parameter", x); + else if (sexp_memq(context, sexp_car(ls), sexp_cdr(ls)) != SEXP_FALSE) + return sexp_compile_error(context, "duplicate parameter", x); /* build lambda and analyze body */ - res = sexp_make_lambda(sexp_cadr(x)); + res = sexp_make_lambda(context, 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)), + = extend_env(context, + sexp_context_env(context), + sexp_flatten_dot(context, sexp_lambda_params(res)), res); sexp_env_lambda(sexp_context_env(context)) = res; body = analyze_seq(sexp_cddr(x), context); @@ -395,23 +399,27 @@ static sexp analyze_lambda (sexp x, sexp context) { 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))), + value = analyze_lambda(sexp_cons(context, + SEXP_VOID, + sexp_cons(context, + 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)); + sexp_push(context, defs, + sexp_make_set(context, 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); + tmp = sexp_alloc_type(context, seq, SEXP_SEQ); + sexp_seq_ls(tmp) = sexp_list1(context, body); body = tmp; } - sexp_seq_ls(body) = sexp_append(defs, sexp_seq_ls(body)); + sexp_seq_ls(body) = sexp_append2(context, defs, sexp_seq_ls(body)); } sexp_lambda_body(res) = body; return res; @@ -423,32 +431,35 @@ static sexp analyze_if (sexp x, sexp 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); + return sexp_make_cnd(context, 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); + sexp_push(context, sexp_env_bindings(env), + sexp_cons(context, name, sexp_context_lambda(context))); + sexp_push(context, sexp_lambda_sv(sexp_env_lambda(env)), name); + sexp_push(context, sexp_lambda_locals(sexp_env_lambda(env)), name); + sexp_push(context, sexp_lambda_defs(sexp_env_lambda(env)), x); return SEXP_VOID; } else { - env_cell_create(env, name, SEXP_VOID); + env_cell_create(context, 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))), + value = analyze_lambda(sexp_cons(context, + SEXP_VOID, + sexp_cons(context, + 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); + return sexp_make_set(context, ref, value); } static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { @@ -457,20 +468,23 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { 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)))); + sexp_push(eval_ctx, + sexp_env_bindings(sexp_context_env(bind_ctx)), + sexp_cons(eval_ctx, + sexp_caar(ls), + sexp_make_macro(eval_ctx, 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_define_syntax (sexp x, sexp ctx) { + return analyze_bind_syntax(sexp_list1(ctx, sexp_cdr(x)), ctx, ctx); } static sexp analyze_let_syntax (sexp x, sexp context) { sexp env, ctx, tmp; - env = sexp_alloc_type(env, SEXP_ENV); + env = sexp_alloc_type(context, 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)); @@ -490,8 +504,8 @@ 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)); + if (sexp_listp(context, x) == SEXP_FALSE) { + res = sexp_compile_error(context, "dotted list in source", 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))) @@ -512,7 +526,8 @@ static sexp analyze (sexp x, sexp context) { 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))); + res + = sexp_make_lit(context, sexp_strip_synclos(context, sexp_cadr(x))); break; case CORE_DEFINE_SYNTAX: res = analyze_define_syntax(x, context); break; @@ -521,26 +536,26 @@ static sexp analyze (sexp x, sexp context) { case CORE_LETREC_SYNTAX: res = analyze_letrec_syntax(x, context); break; default: - res = sexp_compile_error("unknown core form", sexp_list1(op)); break; + res = sexp_compile_error(context, "unknown core form", 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_list3(context, 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)); + res = sexp_length(context, 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)); + res = sexp_compile_error(context, "not enough args for opcode", 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)); + res = sexp_compile_error(context, "too many args for opcode", x); } else { res = analyze_app(sexp_cdr(x), context); analyze_check_exception(res); - sexp_push(res, op); + sexp_push(context, res, op); } } else { res = analyze_app(x, context); @@ -553,8 +568,9 @@ static sexp analyze (sexp x, sexp 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)); + sexp_context_fv(context) = sexp_append2(context, + sexp_synclo_free_vars(x), + sexp_context_fv(context)); x = sexp_synclo_expr(x); goto loop; } else { @@ -633,7 +649,7 @@ static void generate_non_global_ref (sexp name, sexp cell, sexp lambda, emit(OP_CLOSURE_REF, context); emit_word(i, context); } - if (unboxp && (sexp_memq(name, sexp_lambda_sv(loc)) != SEXP_FALSE)) + if (unboxp && (sexp_memq(context, name, sexp_lambda_sv(loc)) != SEXP_FALSE)) emit(OP_CDR, context); sexp_context_depth(context)++; } @@ -669,7 +685,8 @@ static void generate_set (sexp set, sexp 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) { + if (sexp_memq(context, 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); @@ -684,7 +701,8 @@ static void generate_set (sexp set, sexp 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_sint_t i, num_args; + num_args = sexp_unbox_integer(sexp_length(context, sexp_cdr(app))); sexp_context_tailp(context) = 0; /* maybe push the default for an optional argument */ @@ -702,7 +720,7 @@ static void generate_opcode_app (sexp app, sexp context) { /* 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))); + ? sexp_cdr(app) : sexp_reverse(context, sexp_cdr(app))); for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) generate(sexp_car(ls), context); @@ -763,12 +781,13 @@ static void generate_opcode_app (sexp app, sexp context) { static void generate_general_app (sexp app, sexp context) { sexp ls; - sexp_uint_t len = sexp_unbox_integer(sexp_length(sexp_cdr(app))), + sexp_uint_t len = sexp_unbox_integer(sexp_length(context, 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)) + for (ls = sexp_reverse(context, sexp_cdr(app)); sexp_pairp(ls); + ls = sexp_cdr(ls)) generate(sexp_car(ls), context); /* push the operator onto the stack */ @@ -794,7 +813,8 @@ static void generate_lambda (sexp lambda, sexp context) { 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), + ctx = sexp_make_context(context, + sexp_context_stack(context), sexp_context_env(context)); sexp_context_lambda(ctx) = lambda; /* allocate space for local vars */ @@ -815,19 +835,19 @@ static void generate_lambda (sexp lambda, sexp context) { } 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)); + flags = sexp_make_integer((sexp_listp(context, sexp_lambda_params(lambda)) + == SEXP_FALSE) ? 1 : 0); + len = sexp_length(context, 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); + vec = sexp_make_vector(context, sexp_make_integer(0), SEXP_VOID); + generate_lit(sexp_make_procedure(context, flags, len, bc, vec), context); } else { /* push the closed vars */ emit_push(SEXP_VOID, context); - emit_push(sexp_length(fv), context); + emit_push(sexp_length(context, fv), context); emit(OP_MAKE_VECTOR, context); sexp_context_depth(context)--; for (k=0; sexp_pairp(fv); fv=sexp_cdr(fv), k++) { @@ -881,93 +901,93 @@ static void generate (sexp x, sexp context) { } } -static sexp insert_free_var (sexp x, sexp fv) { +static sexp insert_free_var (sexp ctx, sexp x, sexp fv) { sexp name=sexp_ref_name(x), loc=sexp_ref_loc(x), ls; for (ls=fv; sexp_pairp(ls); ls=sexp_cdr(ls)) if ((name == sexp_ref_name(sexp_car(ls))) && (loc == sexp_ref_loc(sexp_car(ls)))) return fv; - return sexp_cons(x, fv); + return sexp_cons(ctx, x, fv); } -static sexp union_free_vars (sexp fv1, sexp fv2) { +static sexp union_free_vars (sexp ctx, 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); + fv2 = insert_free_var(ctx, sexp_car(fv1), fv2); return fv2; } -static sexp diff_free_vars (sexp lambda, sexp fv, sexp params) { +static sexp diff_free_vars (sexp ctx, 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)); + || (sexp_memq(NULL, sexp_ref_name(sexp_car(fv)), params) + == SEXP_FALSE)) + sexp_push(ctx, res, sexp_car(fv)); return res; } -static sexp free_vars (sexp x, sexp fv) { +static sexp free_vars (sexp ctx, 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)))); + fv1 = free_vars(ctx, sexp_lambda_body(x), SEXP_NULL); + fv2 = diff_free_vars(ctx, x, fv1, + sexp_append2(ctx, + sexp_lambda_locals(x), + sexp_flatten_dot(ctx, + sexp_lambda_params(x)))); sexp_lambda_fv(x) = fv2; - fv = union_free_vars(fv2, fv); + fv = union_free_vars(ctx, fv2, fv); } else if (sexp_pairp(x)) { for ( ; sexp_pairp(x); x=sexp_cdr(x)) - fv = free_vars(sexp_car(x), fv); + fv = free_vars(ctx, 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); + fv = free_vars(ctx, sexp_cnd_test(x), fv); + fv = free_vars(ctx, sexp_cnd_pass(x), fv); + fv = free_vars(ctx, 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); + fv = free_vars(ctx, 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); + fv = free_vars(ctx, sexp_set_value(x), fv); + fv = free_vars(ctx, sexp_set_var(x), fv); } else if (sexp_refp(x) && sexp_lambdap(sexp_ref_loc(x))) { - fv = insert_free_var(x, fv); + fv = insert_free_var(ctx, x, fv); } else if (sexp_synclop(x)) { - fv = free_vars(sexp_synclo_expr(x), fv); + fv = free_vars(ctx, sexp_synclo_expr(x), fv); } return fv; } -static sexp make_param_list(sexp_uint_t i) { +static sexp make_param_list(sexp ctx, 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); + res = sexp_cons(ctx, sexp_intern(ctx, sym), res); } return res; } -static sexp make_opcode_procedure (sexp op, sexp_uint_t i, sexp env, +static sexp make_opcode_procedure (sexp ctx, 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); + params = make_param_list(ctx, i); + lambda = sexp_make_lambda(ctx, params); + env = extend_env(ctx, env, params, lambda); + context = sexp_make_context(ctx, 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); + sexp_push(context, refs, sexp_make_ref(context, sexp_car(ls), env_cell(env, sexp_car(ls)))); + generate_opcode_app(sexp_cons(context, op, sexp_reverse(context, 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); + sexp_bytecode_name(bc) = sexp_c_string(ctx, sexp_opcode_name(op)); + res = sexp_make_procedure(ctx, 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; @@ -975,10 +995,10 @@ static sexp make_opcode_procedure (sexp op, sexp_uint_t i, sexp env, /*********************** the virtual machine **************************/ -static sexp sexp_save_stack(sexp *stack, sexp_uint_t to) { +static sexp sexp_save_stack(sexp ctx, sexp *stack, sexp_uint_t to) { sexp res, *data; sexp_uint_t i; - res = sexp_make_vector(sexp_make_integer(to), SEXP_VOID); + res = sexp_make_vector(ctx, sexp_make_integer(to), SEXP_VOID); data = sexp_vector_data(res); for (i=0; i 0) { if (sexp_procedure_variadic_p(tmp1)) { - stack[top-i-1] = sexp_cons(stack[top-i-1], SEXP_NULL); + stack[top-i-1] = sexp_cons(context, stack[top-i-1], SEXP_NULL); for (k=top-i; kinexact: not a number", sexp_list1(_ARG1)); + sexp_raise("exact->inexact: not a number", sexp_list1(context, _ARG1)); break; case OP_FLO2FIX: #if USE_FLONUMS @@ -1477,7 +1497,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { else #endif if (! sexp_integerp(_ARG1)) - sexp_raise("inexact->exact: not a number", sexp_list1(_ARG1)); + sexp_raise("inexact->exact: not a number", sexp_list1(context, _ARG1)); break; case OP_CHAR2INT: _ARG1 = sexp_make_integer(sexp_unbox_character(_ARG1)); @@ -1523,7 +1543,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { _ARG1 = SEXP_VOID; break; case OP_READ: - _ARG1 = sexp_read(_ARG1); + _ARG1 = sexp_read(context, _ARG1); sexp_check_exception(); break; case OP_READ_CHAR: @@ -1548,7 +1568,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { case OP_DONE: goto end_loop; default: - sexp_raise("unknown opcode", sexp_list1(sexp_make_integer(*(ip-1)))); + sexp_raise("unknown opcode", sexp_list1(context, sexp_make_integer(*(ip-1)))); } goto loop; @@ -1558,32 +1578,33 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { /************************ library procedures **************************/ -static sexp sexp_exception_type_func (sexp exn) { +static sexp sexp_exception_type_func (sexp ctx, sexp exn) { if (sexp_exceptionp(exn)) return sexp_exception_kind(exn); else - return sexp_type_exception("not an exception", exn); + return sexp_type_exception(ctx, "not an exception", exn); } -static sexp sexp_open_input_file (sexp path) { +static sexp sexp_open_input_file (sexp ctx, sexp path) { FILE *in; - if (! sexp_stringp(path)) return sexp_type_exception("not a string", path); + if (! sexp_stringp(path)) return sexp_type_exception(ctx, "not a string", path); in = fopen(sexp_string_data(path), "r"); if (! in) - return sexp_user_exception(SEXP_FALSE, "couldn't open input file", path); - return sexp_make_input_port(in, sexp_string_data(path)); + return sexp_user_exception(ctx, SEXP_FALSE, "couldn't open input file", path); + return sexp_make_input_port(ctx, in, sexp_string_data(path)); } -static sexp sexp_open_output_file (sexp path) { +static sexp sexp_open_output_file (sexp ctx, sexp path) { FILE *out; - if (! sexp_stringp(path)) return sexp_type_exception("not a string", path); + if (! sexp_stringp(path)) + return sexp_type_exception(ctx, "not a string", path); out = fopen(sexp_string_data(path), "w"); if (! out) - return sexp_user_exception(SEXP_FALSE, "couldn't open output file", path); - return sexp_make_input_port(out, sexp_string_data(path)); + return sexp_user_exception(ctx, SEXP_FALSE, "couldn't open output file", path); + return sexp_make_input_port(ctx, out, sexp_string_data(path)); } -static sexp sexp_close_port (sexp port) { +static sexp sexp_close_port (sexp ctx, sexp port) { fclose(sexp_port_stream(port)); return SEXP_VOID; } @@ -1598,25 +1619,25 @@ static void sexp_warn_undefs (sexp from, sexp to, sexp out) { } } -sexp sexp_load (sexp source, sexp env) { - sexp x, res, in, tmp, out, context = sexp_make_context(NULL, env); +sexp sexp_load (sexp ctx, sexp source, sexp env) { + sexp x, res, in, tmp, out, context = sexp_make_context(ctx, 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); + in = sexp_open_input_file(ctx, source); if (sexp_exceptionp(in)) { - sexp_print_exception(in, out); + sexp_print_exception(ctx, in, out); return in; } - while ((x=sexp_read(in)) != (sexp) SEXP_EOF) { + while ((x=sexp_read(ctx, 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 + sexp_close_port(ctx, in); +#if USE_WARN_UNDEFS if (sexp_oportp(out)) sexp_warn_undefs(sexp_env_bindings(env), tmp, out); #endif @@ -1626,15 +1647,15 @@ sexp sexp_load (sexp source, sexp env) { #if USE_MATH #define define_math_op(name, cname) \ - static sexp name (sexp z) { \ + static sexp name (sexp ctx, 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)); \ + return sexp_type_exception(ctx, "not a number", z); \ + return sexp_make_flonum(ctx, cname(d)); \ } define_math_op(sexp_exp, exp) @@ -1653,7 +1674,7 @@ define_math_op(sexp_ceiling, ceil) #endif -static sexp sexp_expt (sexp x, sexp e) { +static sexp sexp_expt (sexp ctx, sexp x, sexp e) { double res, x1, e1; if (sexp_integerp(x)) x1 = (double)sexp_unbox_integer(x); @@ -1662,7 +1683,7 @@ static sexp sexp_expt (sexp x, sexp e) { x1 = sexp_flonum_value(x); #endif else - return sexp_type_exception("not a number", x); + return sexp_type_exception(ctx, "not a number", x); if (sexp_integerp(e)) e1 = (double)sexp_unbox_integer(e); #if USE_FLONUMS @@ -1670,25 +1691,25 @@ static sexp sexp_expt (sexp x, sexp e) { e1 = sexp_flonum_value(e); #endif else - return sexp_type_exception("not a number", e); + return sexp_type_exception(ctx, "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); + return sexp_make_flonum(ctx, res); #endif return sexp_make_integer((sexp_sint_t)round(res)); } -static sexp sexp_string_concatenate (sexp str_ls) { +static sexp sexp_string_concatenate (sexp ctx, 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)); + return sexp_type_exception(ctx, "not a string", sexp_car(ls)); else len += sexp_string_length(sexp_car(ls)); - res = sexp_make_string(sexp_make_integer(len), SEXP_VOID); + res = sexp_make_string(ctx, 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)); @@ -1698,31 +1719,19 @@ static sexp sexp_string_concatenate (sexp str_ls) { return res; } -static sexp sexp_string_cmp (sexp str1, sexp str2) { +static sexp sexp_string_cmp (sexp ctx, sexp str1, sexp str2, sexp ci) { sexp_sint_t len1, len2, len, diff; if (! sexp_stringp(str1)) - return sexp_type_exception("not a string", str1); + return sexp_type_exception(ctx, "not a string", str1); if (! sexp_stringp(str2)) - return sexp_type_exception("not a string", str2); + return sexp_type_exception(ctx, "not a string", str2); len1 = sexp_string_length(str1); len2 = sexp_string_length(str2); len = ((len1= size) { + if (sexp_unbox_integer(sexp_gc(ctx)) >= size) { goto try_alloc; } else { fprintf(stderr, "chibi: out of memory trying to allocate %ld bytes, aborting\n", size); @@ -41,7 +71,7 @@ void sexp_mark (sexp x) { loop: if ((! sexp_pointerp(x)) || sexp_mark(x)) return; - sexp_mark(x) = 1; + sexp_gc_mark(x) = 1; switch (sexp_tag(x)) { case SEXP_PAIR: sexp_mark(sexp_car(x)); @@ -56,9 +86,10 @@ void sexp_mark (sexp x) { sexp sexp_sweep () { sexp_uint_t freed=0, size; - sexp p=(sexp)sexp_heap, f=sexp_free_list; - /* XXXX make p skip over areas already in the free_list */ + sexp p=(sexp)sexp_heap, f1=sexp_free_list, f2; while (p? s1 s2) (> (string-cmp s1 s2) 0)) -(define (string>=? s1 s2) (>= (string-cmp s1 s2) 0)) +(define (string=? s1 s2) (eq? (string-cmp s1 s2 #f) 0)) +(define (string? s1 s2) (> (string-cmp s1 s2 #f) 0)) +(define (string>=? s1 s2) (>= (string-cmp s1 s2 #f) 0)) -(define (string-ci=? s1 s2) (eq? (string-cmp-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)) +(define (string-ci=? s1 s2) (eq? (string-cmp s1 s2 #t) 0)) +(define (string-ci? s1 s2) (> (string-cmp s1 s2 #t) 0)) +(define (string-ci>=? s1 s2) (>= (string-cmp s1 s2 #t) 0)) ;; list utils @@ -418,6 +422,8 @@ (define magnitude abs) (define (angle z) (if (< z 0) 3.141592653589793 0)) +(define (atan x . o) (if (null? o) (atan1 x) (atan1 (/ x (car o))))) + (define (digit-char n) (integer->char (+ n (char->integer #\0)))) (define (digit-value ch) (if (char-numeric? ch) diff --git a/main.c b/main.c index 62da5068..fd90e900 100644 --- a/main.c +++ b/main.c @@ -11,15 +11,15 @@ void repl (sexp context) { while (1) { sexp_write_string("> ", out); sexp_flush(out); - obj = sexp_read(in); + obj = sexp_read(context, in); if (obj == SEXP_EOF) break; if (sexp_exceptionp(obj)) { - sexp_print_exception(obj, err); + sexp_print_exception(context, obj, err); } else { tmp = sexp_env_bindings(env); res = eval_in_context(obj, context); -#ifdef USE_WARN_UNDEFS +#if USE_WARN_UNDEFS sexp_warn_undefs(sexp_env_bindings(env), tmp, err); #endif if (res != SEXP_VOID) { @@ -34,12 +34,13 @@ 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); + context = sexp_make_context(NULL, NULL, NULL); + env = sexp_make_standard_env(context, sexp_make_integer(5)); + env_define(context, 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); + perr_cell = env_cell(env, sexp_intern(context, "print-exception")); + sexp_context_env(context) = env; sexp_context_tailp(context) = 0; if (err_cell && perr_cell && sexp_opcodep(sexp_cdr(perr_cell))) { emit(OP_GLOBAL_KNOWN_REF, context); @@ -51,11 +52,12 @@ void run_main (int argc, char **argv) { } emit_push(SEXP_VOID, context); emit(OP_DONE, context); - err_handler = sexp_make_procedure(sexp_make_integer(0), + err_handler = sexp_make_procedure(context, + 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); + sexp_make_vector(context, 0, SEXP_VOID)); + env_define(context, env, the_err_handler_symbol, err_handler); /* parse options */ for (i=1; i < argc && argv[i][0] == '-'; i++) { @@ -64,12 +66,12 @@ void run_main (int argc, char **argv) { case 'e': case 'p': if (! init_loaded++) - sexp_load(sexp_c_string(sexp_init_file), env); - res = sexp_read_from_string(argv[i+1]); + sexp_load(context, sexp_c_string(context, sexp_init_file), env); + res = sexp_read_from_string(context, argv[i+1]); if (! sexp_exceptionp(res)) res = eval_in_context(res, context); if (sexp_exceptionp(res)) { - sexp_print_exception(res, out); + sexp_print_exception(context, res, out); } else if (argv[i][1] == 'p') { sexp_write(res, out); sexp_write_char('\n', out); @@ -80,8 +82,8 @@ void run_main (int argc, char **argv) { #endif case 'l': if (! init_loaded++) - sexp_load(sexp_c_string(sexp_init_file), env); - sexp_load(sexp_c_string(argv[++i]), env); + sexp_load(context, sexp_c_string(context, sexp_init_file), env); + sexp_load(context, sexp_c_string(context, argv[++i]), env); break; case 'q': init_loaded = 1; @@ -93,10 +95,10 @@ void run_main (int argc, char **argv) { if (! quit) { if (! init_loaded) - sexp_load(sexp_c_string(sexp_init_file), env); + sexp_load(context, sexp_c_string(context, sexp_init_file), env); if (i < argc) for ( ; i < argc; i++) - sexp_load(sexp_c_string(argv[i]), env); + sexp_load(context, sexp_c_string(context, argv[i]), env); else repl(context); } diff --git a/opcodes.c b/opcodes.c index 5bd6cc4a..0aee670c 100644 --- a/opcodes.c +++ b/opcodes.c @@ -77,6 +77,8 @@ _FN1(0, "identifier->symbol", 0, sexp_syntactic_closure_expr), _FN4(0, SEXP_ENV, "identifier=?", 0, sexp_identifier_eq), _FN1(SEXP_PAIR, "length", 0, sexp_length), _FN1(SEXP_PAIR, "reverse", 0, sexp_reverse), +_FN1(SEXP_PAIR, "reverse!", 0, sexp_nreverse), +_FN2(SEXP_PAIR, SEXP_PAIR, "append2", 0, sexp_append2), _FN1(SEXP_PAIR, "list->vector", 0, sexp_list_to_vector), _FN1(SEXP_STRING, "open-input-file", 0, sexp_open_input_file), _FN1(SEXP_STRING, "open-output-file", 0, sexp_open_output_file), @@ -89,8 +91,7 @@ _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_STRING, "string-cmp", 0, sexp_string_cmp), _FN3(SEXP_STRING, SEXP_FIXNUM, "substring", 0, sexp_substring), _FN1(SEXP_STRING, "string->symbol", 0, sexp_string_to_symbol), _FN1(SEXP_PAIR, "string-concatenate", 0, sexp_string_concatenate), @@ -110,7 +111,7 @@ _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, "atan1", 0, sexp_atan), _FN1(0, "sqrt", 0, sexp_sqrt), _FN1(0, "round", 0, sexp_round), _FN1(0, "truncate", 0, sexp_trunc), diff --git a/sexp.c b/sexp.c index f8b4a459..ee113fda 100644 --- a/sexp.c +++ b/sexp.c @@ -53,8 +53,8 @@ static int is_separator(int c) { static sexp symbol_table[SEXP_SYMBOL_TABLE_SIZE]; -sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag) { - sexp res = (sexp) sexp_alloc(size); +sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) { + sexp res = (sexp) sexp_alloc(ctx, size); if (! res) errx(EX_OSERR, "out of memory: couldn't allocate %ld bytes for %ld", size ,tag); @@ -63,7 +63,7 @@ sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag) { } #if ! USE_BOEHM -void sexp_deep_free (sexp obj) { +void sexp_deep_free (sexp ctx, sexp obj) { int len, i; sexp *elts; if (sexp_pointerp(obj)) { @@ -77,23 +77,23 @@ void sexp_deep_free (sexp obj) { elts = sexp_vector_data(obj); for (i=0; i 0; len--) - if (sexp_equalp(v1[len], v2[len]) == SEXP_FALSE) + if (sexp_equalp(ctx, v1[len], v2[len]) == SEXP_FALSE) return SEXP_FALSE; return SEXP_TRUE; case SEXP_STRING: @@ -313,18 +311,18 @@ sexp sexp_equalp (sexp a, sexp b) { /********************* strings, symbols, vectors **********************/ -sexp sexp_make_flonum(double f) { - sexp x = sexp_alloc_type(flonum, SEXP_FLONUM); +sexp sexp_make_flonum(sexp ctx, double f) { + sexp x = sexp_alloc_type(ctx, flonum, SEXP_FLONUM); sexp_flonum_value(x) = f; return x; } -sexp sexp_make_string(sexp len, sexp ch) { +sexp sexp_make_string(sexp ctx, sexp len, sexp ch) { char *cstr; - sexp s = sexp_alloc_type(string, SEXP_STRING); + sexp s = sexp_alloc_type(ctx, 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 (clen < 0) return sexp_type_exception(ctx, "negative length", len); + cstr = sexp_alloc(ctx, clen+1); if (sexp_charp(ch)) memset(cstr, sexp_unbox_character(ch), clen); cstr[clen] = '\0'; @@ -333,31 +331,30 @@ sexp sexp_make_string(sexp len, sexp ch) { return s; } -sexp sexp_c_string(char *str) { +sexp sexp_c_string(sexp ctx, char *str) { sexp_uint_t len = strlen(str); - sexp s = sexp_make_string(sexp_make_integer(len), SEXP_VOID); + sexp s = sexp_make_string(ctx, 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 sexp_substring (sexp ctx, sexp str, sexp start, sexp end) { sexp res; if (! sexp_stringp(str)) - return sexp_type_exception("not a string", str); + return sexp_type_exception(ctx, "not a string", str); if (! sexp_integerp(start)) - return sexp_type_exception("not a number", start); + return sexp_type_exception(ctx, "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); + return sexp_type_exception(ctx, "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); + return sexp_range_exception(ctx, str, start, end); + res = sexp_make_string(ctx, sexp_fx_sub(end, start), SEXP_VOID); memcpy(sexp_string_data(res), sexp_string_data(str)+sexp_unbox_integer(start), sexp_string_length(res)); @@ -372,7 +369,7 @@ sexp_uint_t sexp_string_hash(char *str, sexp_uint_t acc) { return acc; } -sexp sexp_intern(char *str) { +sexp sexp_intern(sexp ctx, char *str) { struct huff_entry he; sexp_uint_t len, res=FNV_OFFSET_BASIS, space=3, newbits, bucket; char c, *mystr, *p=str; @@ -404,26 +401,26 @@ sexp sexp_intern(char *str) { return sexp_car(ls); /* not found, make a new symbol */ - sym = sexp_alloc_type(symbol, SEXP_SYMBOL); - mystr = sexp_alloc(len+1); + sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL); + mystr = sexp_alloc(ctx, 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); + sexp_push(ctx, symbol_table[bucket], sym); return sym; } -sexp sexp_string_to_symbol (sexp str) { - return sexp_intern(sexp_string_data(str)); +sexp sexp_string_to_symbol (sexp ctx, sexp str) { + return sexp_intern(ctx, sexp_string_data(str)); } -sexp sexp_make_vector(sexp len, sexp dflt) { +sexp sexp_make_vector(sexp ctx, 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)); + v = sexp_alloc_type(ctx, vector, SEXP_VECTOR); + x = (sexp*) sexp_alloc(ctx, clen*sizeof(sexp)); for (i=0; i= len) { - newbuf = sexp_make_string(sexp_make_integer(newpos*2), SEXP_VOID); + newbuf = sexp_make_string(NULL, sexp_make_integer(newpos*2), SEXP_VOID); memcpy(sexp_string_data(newbuf), sexp_string_data(sexp_stream_buf(vec)), pos); @@ -507,54 +504,55 @@ off_t sstream_seek (void *vec, off_t offset, int whence) { return pos; } -sexp sexp_make_input_string_port (sexp str) { +sexp sexp_make_input_string_port (sexp ctx, sexp str) { FILE *in; sexp res, cookie; - cookie = sexp_vector(3, str, sexp_make_integer(sexp_string_length(str)), + cookie = sexp_vector(ctx, 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); + res = sexp_make_input_port(ctx, in, NULL); sexp_port_cookie(res) = cookie; return res; } -sexp sexp_make_output_string_port () { +sexp sexp_make_output_string_port (sexp ctx) { 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), + cookie = sexp_vector(ctx, 3, sexp_make_string(NULL, size, SEXP_VOID), size, sexp_make_integer(0)); out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL); - res = sexp_make_output_port(out, NULL); + res = sexp_make_output_port(ctx, out, NULL); sexp_port_cookie(res) = cookie; return res; } -sexp sexp_get_output_string (sexp port) { +sexp sexp_get_output_string (sexp ctx, sexp port) { sexp cookie = sexp_port_cookie(port); fflush(sexp_port_stream(port)); - return sexp_substring(sexp_stream_buf(cookie), + return sexp_substring(ctx, + sexp_stream_buf(cookie), sexp_make_integer(0), sexp_stream_pos(cookie)); } #else -sexp sexp_make_input_string_port (sexp str) { +sexp sexp_make_input_string_port (sexp ctx, 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 () { +sexp sexp_make_output_string_port (sexp ctx) { FILE *out; - sexp buf = sexp_alloc_type(string, SEXP_STRING), res; + sexp buf = sexp_alloc_type(ctx, 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 sexp_get_output_string (sexp ctx, sexp port) { sexp cookie = sexp_port_cookie(port); fflush(sexp_port_stream(port)); return sexp_substring(cookie, @@ -566,16 +564,16 @@ sexp sexp_get_output_string (sexp port) { #endif -sexp sexp_make_input_port (FILE* in, char *path) { - sexp p = sexp_alloc_type(port, SEXP_IPORT); +sexp sexp_make_input_port (sexp ctx, FILE* in, char *path) { + sexp p = sexp_alloc_type(ctx, 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 sexp_make_output_port (sexp ctx, FILE* out, char *path) { + sexp p = sexp_alloc_type(ctx, port, SEXP_OPORT); sexp_port_stream(p) = out; sexp_port_name(p) = path; sexp_port_line(p) = 0; @@ -761,15 +759,15 @@ void sexp_write (sexp obj, sexp out) { } } -char* sexp_read_string(sexp in) { +char* sexp_read_string(sexp ctx, sexp in) { char *buf, *tmp, *res; int c, i=0, size=128; - buf = sexp_alloc(size); + buf = sexp_alloc(ctx, size); for (c=sexp_read_char(in); c != '"'; c=sexp_read_char(in)) { if (c == EOF) { - sexp_free(buf); + sexp_free(ctx, buf); return NULL; } if (c == '\\') { @@ -783,25 +781,25 @@ char* sexp_read_string(sexp in) { buf[i++] = c; } if (i >= size) { - tmp = sexp_alloc(2*size); + tmp = sexp_alloc(ctx, 2*size); memcpy(tmp, buf, i); - sexp_free(buf); + sexp_free(ctx, buf); buf = tmp; } } buf[i] = '\0'; - res = sexp_alloc(i); + res = sexp_alloc(ctx, i); memcpy(res, buf, i); - sexp_free(buf); + sexp_free(ctx, buf); return res; } -char* sexp_read_symbol(sexp in, int init) { +char* sexp_read_symbol(sexp ctx, sexp in, int init) { char *buf, *tmp, *res; int c, i=0, size=128; - buf = sexp_alloc(size); + buf = sexp_alloc(ctx, size); if (init != EOF) buf[i++] = init; @@ -814,21 +812,21 @@ char* sexp_read_symbol(sexp in, int init) { } buf[i++] = c; if (i >= size) { - tmp = sexp_alloc(2*size); + tmp = sexp_alloc(ctx, 2*size); memcpy(tmp, buf, i); - sexp_free(buf); + sexp_free(ctx, buf); buf = tmp; } } buf[i] = '\0'; - res = sexp_alloc(i); + res = sexp_alloc(ctx, i); memcpy(res, buf, i); - sexp_free(buf); + sexp_free(ctx, buf); return res; } -sexp sexp_read_float_tail(sexp in, sexp_sint_t whole) { +sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_sint_t whole) { sexp exponent; double res=0.0, scale=0.1, e=0.0; int c; @@ -836,17 +834,17 @@ sexp sexp_read_float_tail(sexp in, sexp_sint_t whole) { res += digit_value(c)*scale; sexp_push_char(c, in); if (c=='e' || c=='E') { - exponent = sexp_read_number(in, 10); + exponent = sexp_read_number(ctx, 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)); + return sexp_read_error(ctx, "invalid numeric syntax", + sexp_list1(ctx, sexp_make_character(c)), in); + return sexp_make_flonum(ctx, (whole + res) * pow(10, e)); } -sexp sexp_read_number(sexp in, int base) { +sexp sexp_read_number(sexp ctx, sexp in, int base) { sexp f; sexp_sint_t res = 0, negativep = 0, c; @@ -864,10 +862,10 @@ sexp sexp_read_number(sexp in, int base) { if (c=='.' || c=='e' || c=='E') { if (base != 10) - return sexp_read_error("decimal found in non-base 10", SEXP_NULL, in); + return sexp_read_error(ctx, "decimal found in non-base 10", SEXP_NULL, in); if (c!='.') sexp_push_char(c, in); - f = sexp_read_float_tail(in, res); + f = sexp_read_float_tail(ctx, 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); @@ -878,14 +876,14 @@ sexp sexp_read_number(sexp in, int base) { } 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_read_error(ctx, "invalid numeric syntax", + sexp_list1(ctx, sexp_make_character(c)), in); } return sexp_make_integer(negativep ? -res : res); } -sexp sexp_read_raw (sexp in) { +sexp sexp_read_raw (sexp ctx, sexp in) { sexp res, tmp, tmp2; char *str; int c1, c2; @@ -909,82 +907,82 @@ sexp sexp_read_raw (sexp in) { sexp_port_line(in)++; goto scan_loop; case '\'': - res = sexp_read(in); - res = sexp_list2(the_quote_symbol, res); + res = sexp_read(ctx, in); + res = sexp_list2(ctx, the_quote_symbol, res); break; case '`': - res = sexp_read(in); - res = sexp_list2(the_quasiquote_symbol, res); + res = sexp_read(ctx, in); + res = sexp_list2(ctx, the_quasiquote_symbol, res); break; case ',': if ((c1 = sexp_read_char(in)) == '@') { - res = sexp_read(in); - res = sexp_list2(the_unquote_splicing_symbol, res); + res = sexp_read(ctx, in); + res = sexp_list2(ctx, the_unquote_splicing_symbol, res); } else { sexp_push_char(c1, in); - res = sexp_read(in); - res = sexp_list2(the_unquote_symbol, res); + res = sexp_read(ctx, in); + res = sexp_list2(ctx, the_unquote_symbol, res); } break; case '"': - str = sexp_read_string(in); + str = sexp_read_string(ctx, in); if (! str) - res = sexp_read_error("premature end of string", SEXP_NULL, in); + res = sexp_read_error(ctx, "premature end of string", SEXP_NULL, in); else - res = sexp_c_string(str); - sexp_free(str); + res = sexp_c_string(ctx, str); + sexp_free(ctx, str); break; case '(': res = SEXP_NULL; - tmp = sexp_read_raw(in); + tmp = sexp_read_raw(ctx, 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", + return sexp_read_error(ctx, "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", + tmp = sexp_read_raw(ctx, in); + if (sexp_read_raw(ctx, in) != SEXP_CLOSE) { + sexp_deep_free(ctx, res); + return sexp_read_error(ctx, "multiple tokens in dotted tail", SEXP_NULL, in); } else { tmp2 = res; - res = sexp_nreverse(res); + res = sexp_nreverse(ctx, res); sexp_cdr(tmp2) = tmp; return res; } } } else { - res = sexp_cons(tmp, res); - tmp = sexp_read_raw(in); + res = sexp_cons(ctx, tmp, res); + tmp = sexp_read_raw(ctx, in); } } if (tmp != SEXP_CLOSE) { - sexp_deep_free(res); - return sexp_read_error("missing trailing ')'", SEXP_NULL, in); + sexp_deep_free(ctx, res); + return sexp_read_error(ctx, "missing trailing ')'", SEXP_NULL, in); } - res = (sexp_pairp(res) ? sexp_nreverse(res) : res); + res = (sexp_pairp(res) ? sexp_nreverse(ctx, res) : res); break; case '#': switch (c1=sexp_read_char(in)) { case 'b': - res = sexp_read_number(in, 2); break; + res = sexp_read_number(ctx, in, 2); break; case 'o': - res = sexp_read_number(in, 8); break; + res = sexp_read_number(ctx, in, 8); break; case 'd': - res = sexp_read_number(in, 10); break; + res = sexp_read_number(ctx, in, 10); break; case 'x': - res = sexp_read_number(in, 16); break; + res = sexp_read_number(ctx, in, 16); break; case 'e': - res = sexp_read(in); + res = sexp_read(ctx, in); if (sexp_flonump(res)) res = sexp_make_integer((sexp_sint_t)sexp_flonum_value(res)); break; case 'i': - res = sexp_read(in); + res = sexp_read(ctx, in); if (sexp_integerp(res)) - res = sexp_make_flonum(sexp_unbox_integer(res)); + res = sexp_make_flonum(ctx, sexp_unbox_integer(res)); break; case 'f': case 't': @@ -993,21 +991,22 @@ sexp sexp_read_raw (sexp in) { 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), + res = sexp_read_error(ctx, "invalid syntax #%c%c", + sexp_list2(ctx, + sexp_make_character(c1), sexp_make_character(c2)), in); } break; case ';': - sexp_read_raw(in); + sexp_read_raw(ctx, in); goto scan_loop; case '\\': c1 = sexp_read_char(in); - str = sexp_read_symbol(in, c1); + str = sexp_read_symbol(ctx, in, c1); if (str[0] == '\0') res = - sexp_read_error("unexpected end of character literal", SEXP_NULL, in); + sexp_read_error(ctx, "unexpected end of character literal", SEXP_NULL, in); if (str[1] == '\0') { res = sexp_make_character(c1); } else if ((c1 == 'x' || c1 == 'X') && @@ -1023,30 +1022,30 @@ sexp sexp_read_raw (sexp in) { 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)), + res = sexp_read_error(ctx, "unknown character name", + sexp_list1(ctx, sexp_c_string(ctx, str)), in); } } - sexp_free(str); + sexp_free(ctx, str); break; case '(': sexp_push_char(c1, in); - res = sexp_read(in); - if (sexp_listp(res) == SEXP_FALSE) { + res = sexp_read(ctx, in); + if (sexp_listp(ctx, res) == SEXP_FALSE) { if (! sexp_exceptionp(res)) { - sexp_deep_free(res); - res = sexp_read_error("dotted list not allowed in vector syntax", + sexp_deep_free(ctx, res); + res = sexp_read_error(ctx, "dotted list not allowed in vector syntax", SEXP_NULL, in); } } else { - res = sexp_list_to_vector(res); + res = sexp_list_to_vector(ctx, res); } break; default: - res = sexp_read_error("invalid # syntax", - sexp_list1(sexp_make_character(c1)), in); + res = sexp_read_error(ctx, "invalid # syntax", + sexp_list1(ctx, sexp_make_character(c1)), in); } break; case '.': @@ -1055,12 +1054,12 @@ sexp sexp_read_raw (sexp in) { res = SEXP_RAWDOT; } else if (isdigit(c1)) { sexp_push_char(c1,in ); - res = sexp_read_float_tail(in, 0); + res = sexp_read_float_tail(ctx, in, 0); } else { sexp_push_char(c1, in); - str = sexp_read_symbol(in, '.'); - res = sexp_intern(str); - sexp_free(str); + str = sexp_read_symbol(ctx, in, '.'); + res = sexp_intern(ctx, str); + sexp_free(ctx, str); } break; case ')': @@ -1071,7 +1070,7 @@ sexp sexp_read_raw (sexp in) { c2 = sexp_read_char(in); if (c2 == '.' || isdigit(c2)) { sexp_push_char(c2, in); - res = sexp_read_number(in, 10); + res = sexp_read_number(ctx, in, 10); if (sexp_exceptionp(res)) return res; if (c1 == '-') { #ifdef USE_FLONUMS @@ -1083,47 +1082,48 @@ sexp sexp_read_raw (sexp in) { } } else { sexp_push_char(c2, in); - str = sexp_read_symbol(in, c1); - res = sexp_intern(str); - sexp_free(str); + str = sexp_read_symbol(ctx, in, c1); + res = sexp_intern(ctx, str); + sexp_free(ctx, 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); + res = sexp_read_number(ctx, in, 10); break; default: - str = sexp_read_symbol(in, c1); - res = sexp_intern(str); - sexp_free(str); + str = sexp_read_symbol(ctx, in, c1); + res = sexp_intern(ctx, str); + sexp_free(ctx, str); break; } return res; } -sexp sexp_read (sexp in) { - sexp res = sexp_read_raw(in); +sexp sexp_read (sexp ctx, sexp in) { + sexp res = sexp_read_raw(ctx, in); if (res == SEXP_CLOSE) - return sexp_read_error("too many ')'s", SEXP_NULL, in); + return sexp_read_error(ctx, "too many ')'s", SEXP_NULL, in); if (res == SEXP_RAWDOT) - return sexp_read_error("unexpected '.'", SEXP_NULL, in); + return sexp_read_error(ctx, "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); +sexp sexp_read_from_string(sexp ctx, char *str) { + sexp s = sexp_c_string(ctx, str); + sexp in = sexp_make_input_string_port(ctx, s); + sexp res = sexp_read(ctx, in); + sexp_free(ctx, s); + sexp_deep_free(ctx, in); return res; } #endif void sexp_init() { int i; + sexp ctx; if (! sexp_initialized_p) { sexp_initialized_p = 1; #if USE_BOEHM @@ -1133,13 +1133,14 @@ void sexp_init() { #endif for (i=0; ivalue.x)) -#define sexp_alloc_type(type, tag) sexp_alloc_tagged(sexp_sizeof(type), tag) +#define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag) #define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<value.flonum) #if USE_FLONUMS -#define sexp_integer_to_flonum(x) (sexp_make_flonum(sexp_unbox_integer(x))) +#define sexp_integer_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_integer(x))) #else -#define sexp_integer_to_flonum(x) (x) +#define sexp_integer_to_flonum(ctx, x) (x) #endif /*************************** field accessors **************************/ @@ -357,20 +357,20 @@ struct sexp_struct { #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))) +#define sexp_fp_add(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) + sexp_flonum_value(b))) +#define sexp_fp_sub(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) - sexp_flonum_value(b))) +#define sexp_fp_mul(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) * sexp_flonum_value(b))) +#define sexp_fp_div(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) / sexp_flonum_value(b))) /****************************** utilities *****************************/ -#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_list1(x,a) sexp_cons((x), (a), SEXP_NULL) +#define sexp_list2(x,a,b) sexp_cons((x), (a), sexp_cons((x), (b), SEXP_NULL)) +#define sexp_list3(x,a,b,c) sexp_cons((x), (a), sexp_cons((x), (b), sexp_cons((x), (c), SEXP_NULL))) +#define sexp_list4(x,a,b,c,d) sexp_cons((x), (a), sexp_cons((x), (b), sexp_cons((x), (c), sexp_cons((x), (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_push(ctx, ls, x) ((ls) = sexp_cons((ctx), (x), (ls))) +#define sexp_insert(ctx, ls, x) ((sexp_memq(NULL, (x), (ls)) != SEXP_FALSE) ? (ls) : sexp_push((ctx), (ls), (x))) #define sexp_car(x) ((x)->value.pair.car) #define sexp_cdr(x) ((x)->value.pair.cdr) @@ -400,43 +400,43 @@ struct sexp_struct { #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 sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); +sexp sexp_cons(sexp ctx, sexp head, sexp tail); +sexp sexp_equalp (sexp ctx, sexp a, sexp b); +sexp sexp_listp(sexp ctx, sexp obj); +sexp sexp_reverse(sexp ctx, sexp ls); +sexp sexp_nreverse(sexp ctx, sexp ls); +sexp sexp_append2(sexp ctx, sexp a, sexp b); +sexp sexp_memq(sexp ctx, sexp x, sexp ls); +sexp sexp_assq(sexp ctx, sexp x, sexp ls); +sexp sexp_length(sexp ctx, sexp ls); +sexp sexp_c_string(sexp ctx, char *str); +sexp sexp_make_string(sexp ctx, sexp len, sexp ch); +sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end); +sexp sexp_make_flonum(sexp ctx, 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, ...); +sexp sexp_intern(sexp ctx, char *str); +sexp sexp_string_to_symbol(sexp ctx, sexp str); +sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt); +sexp sexp_list_to_vector(sexp ctx, sexp ls); +sexp sexp_vector(sexp ctx, 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); +char* sexp_read_string(sexp ctx, sexp in); +char* sexp_read_symbol(sexp ctx, sexp in, int init); +sexp sexp_read_number(sexp ctx, sexp in, int base); +sexp sexp_read_raw(sexp ctx, sexp in); +sexp sexp_read(sexp ctx, sexp in); +sexp sexp_read_from_string(sexp ctx, char *str); +sexp sexp_make_input_port(sexp ctx, FILE* in, char *path); +sexp sexp_make_output_port(sexp ctx, FILE* out, char *path); +sexp sexp_make_input_string_port(sexp ctx, sexp str); +sexp sexp_make_output_string_port(sexp ctx); +sexp sexp_get_output_string(sexp ctx, sexp port); +sexp sexp_make_exception(sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp file, sexp line); +sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp obj); +sexp sexp_type_exception (sexp ctx, char *message, sexp obj); +sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); +sexp sexp_print_exception(sexp ctx, sexp exn, sexp out); void sexp_init(); #endif /* ! SEXP_H */