From 4d55fd31803c985c044baf28717e00a45ba9d495 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 25 Mar 2009 15:24:52 +0900 Subject: [PATCH] mid-rewrite --- debug.c | 6 +- eval.c | 1659 +++++++++++++++++++++++++++++++++++-------------------- eval.h | 42 +- sexp.c | 14 +- sexp.h | 158 ++++-- 5 files changed, 1213 insertions(+), 666 deletions(-) diff --git a/debug.c b/debug.c index 21021e5c..bb80564c 100644 --- a/debug.c +++ b/debug.c @@ -7,7 +7,7 @@ static const char* reverse_opcode_names[] = "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALLN", "JUMP-UNLESS", "JUMP", "RET", "DONE", "PARAMETER", - "STACK-REF", "STACK-SET", "CLOSURE-REF", + "LOCAL-REF", "LOCAL-SET", "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "STRING-REF", "STRING-SET", "MAKE-PROCEDURE", "MAKE-VECTOR", "PUSH", "DROP", "PAIRP", "NULLP", "VECTORP", "INTEGERP", "SYMBOLP", "STRINGP", "CHARP", "EOFP", "PROCEDUREP", "IPORTP", @@ -27,8 +27,8 @@ void disasm (sexp bc) { fprintf(stderr, " %d ", opcode); } switch (opcode) { - case OP_STACK_REF: - case OP_STACK_SET: + case OP_LOCAL_REF: + case OP_LOCAL_SET: case OP_CLOSURE_REF: case OP_PARAMETER: fprintf(stderr, "%ld", (long) ((sexp*)ip)[0]); diff --git a/eval.c b/eval.c index 5b167112..b51d5034 100644 --- a/eval.c +++ b/eval.c @@ -10,7 +10,7 @@ static int scheme_initialized_p = 0; static sexp cur_input_port, cur_output_port, cur_error_port; static sexp exception_handler_cell; -static sexp continuation_resumer; +static sexp continuation_resumer, final_resumer; static sexp interaction_environment; static sexp the_compile_error_symbol; @@ -22,6 +22,32 @@ static sexp the_compile_error_symbol; #define disasm(...) #endif +/*************************** prototypes *******************************/ + +sexp analyze (sexp x, sexp env); +sexp analyze_lambda (sexp x, sexp env); +sexp analyze_seq (sexp ls, sexp env); +sexp analyze_if (sexp x, sexp env); +sexp analyze_app (sexp x, sexp env); +sexp analyze_define (sexp x, sexp env); +sexp analyze_var_ref (sexp x, sexp env); +sexp analyze_set (sexp x, sexp env); + +sexp_uint_t sexp_context_make_label (sexp context); +void sexp_context_patch_label (sexp context, sexp_uint_t label); +void compile_one (sexp x, sexp context); +void compile_lit (sexp value, sexp context); +void compile_seq (sexp app, sexp context); +void compile_cnd (sexp cnd, sexp context); +void compile_ref (sexp ref, sexp context, int unboxp); +void compile_non_global_ref (sexp name, sexp loc, sexp lambda, sexp fv, + sexp context, int unboxp); +void compile_set (sexp set, sexp context); +void compile_app (sexp app, sexp context); +void compile_opcode_app (sexp app, sexp context); +void compile_general_app (sexp app, sexp context); +void compile_lambda (sexp lambda, sexp context); + /********************** environment utilities ***************************/ static sexp env_cell(sexp e, sexp key) { @@ -37,10 +63,10 @@ static sexp env_cell(sexp e, sexp key) { return NULL; } -static sexp env_cell_create(sexp e, sexp key) { +static sexp env_cell_create(sexp e, sexp key, sexp value) { sexp cell = env_cell(e, key); if (! cell) { - cell = sexp_cons(key, SEXP_UNDEF); + 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)); @@ -59,20 +85,20 @@ static int env_global_p (sexp e, sexp id) { } static void env_define(sexp e, sexp key, sexp value) { - sexp cell = env_cell_create(e, key); - sexp_cdr(cell) = 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 e, sexp fv, int offset) { - int i; - sexp e2 = sexp_alloc_type(env, SEXP_ENV); - sexp_env_parent(e2) = e; - sexp_env_bindings(e2) = SEXP_NULL; - for (i=offset; sexp_pairp(fv); fv = sexp_cdr(fv), i--) - sexp_env_bindings(e2) - = sexp_cons(sexp_cons(sexp_car(fv), sexp_make_integer(i)), - sexp_env_bindings(e2)); - return e2; +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 int core_code (sexp e, sexp sym) { @@ -84,7 +110,7 @@ static int core_code (sexp e, sexp sym) { static sexp sexp_reverse_flatten_dot (sexp ls) { sexp res; for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) - res = sexp_cons(sexp_car(ls), res); + sexp_push(res, sexp_car(ls)); return (sexp_nullp(ls) ? res : sexp_cons(ls, res)); } @@ -94,46 +120,46 @@ static sexp sexp_flatten_dot (sexp ls) { /************************* bytecode utilities ***************************/ -static void shrink_bcode(sexp *bc, sexp_uint_t i) { +static void shrink_bcode(sexp context, sexp_uint_t i) { sexp tmp; - if (sexp_bytecode_length(*bc) != i) { + if (sexp_bytecode_length(sexp_context_bc(context)) != i) { tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) + i, SEXP_BYTECODE); sexp_bytecode_length(tmp) = i; - memcpy(sexp_bytecode_data(tmp), sexp_bytecode_data(*bc), i); - sexp_free(*bc); - *bc = tmp; + memcpy(sexp_bytecode_data(tmp), sexp_bytecode_data(sexp_context_bc(context)), i); + sexp_context_bc(context) = tmp; } } -static void expand_bcode(sexp *bc, sexp_uint_t *i, sexp_uint_t size) { +static void expand_bcode(sexp context, sexp_uint_t size) { sexp tmp; - if (sexp_bytecode_length(*bc) < (*i)+size) { + if (sexp_bytecode_length(sexp_context_bc(context)) + < (sexp_context_pos(context))+size) { tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) - + sexp_bytecode_length(*bc)*2, + + sexp_bytecode_length(sexp_context_bc(context))*2, SEXP_BYTECODE); - sexp_bytecode_length(tmp) = sexp_bytecode_length(*bc)*2; + sexp_bytecode_length(tmp) + = sexp_bytecode_length(sexp_context_bc(context))*2; memcpy(sexp_bytecode_data(tmp), - sexp_bytecode_data(*bc), - sexp_bytecode_length(*bc)); - sexp_free(*bc); - *bc = tmp; + sexp_bytecode_data(sexp_context_bc(context)), + sexp_bytecode_length(sexp_context_bc(context))); + sexp_context_bc(context) = tmp; } } -static void emit(sexp *bc, sexp_uint_t *i, char c) { - expand_bcode(bc, i, 1); - sexp_bytecode_data(*bc)[(*i)++] = c; +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 *bc, sexp_uint_t *i, sexp_uint_t val) { - expand_bcode(bc, i, sizeof(sexp)); - *((sexp_uint_t*)(&(sexp_bytecode_data(*bc)[*i]))) = val; - *i += sizeof(sexp_uint_t); +static void emit_word(sexp_uint_t val, sexp context) { + expand_bcode(context, sizeof(sexp)); + *((sexp_uint_t*)(&(sexp_bytecode_data(sexp_context_bc(context))[sexp_context_pos(context)]))) = val; + sexp_context_pos(context) += sizeof(sexp); } -static void emit_push(sexp *bc, sexp_uint_t *i, sexp obj) { - emit(bc, i, OP_PUSH); - emit_word(bc, i, (sexp_uint_t)obj); +static void emit_push(sexp obj, sexp context) { + emit(OP_PUSH, context); + emit_word((sexp_uint_t)obj, context); } static sexp sexp_make_procedure(sexp flags, sexp num_args, @@ -153,498 +179,913 @@ static sexp sexp_make_macro (sexp p, sexp e) { return mac; } +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 loc) { + sexp res = sexp_alloc_type(ref, SEXP_REF); + sexp_ref_name(res) = name; + sexp_ref_loc(res) = loc; + 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_new_context(sexp *stack) { + sexp res = sexp_alloc_type(context, SEXP_CONTEXT); + if (! stack) + stack = (sexp*) sexp_alloc(sizeof(sexp)*INIT_STACK_SIZE); + sexp_context_bc(res) + = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE); + sexp_bytecode_length(sexp_context_bc(res)) = INIT_BCODE_SIZE; + sexp_context_stack(res) = stack; + sexp_context_depth(res) = 0; + sexp_context_pos(res) = 0; + return res; +} + +static sexp sexp_extend_context(sexp context, sexp lambda) { + sexp ctx = sexp_new_context(sexp_context_stack(context)); + sexp_context_lambda(ctx) = lambda; + return ctx; +} + +static int sexp_idp (sexp x) { + while (sexp_synclop(x)) + x = sexp_synclo_expr(x); + return sexp_symbolp(x); +} + /************************* the compiler ***************************/ -sexp sexp_compile_error(char *message, sexp irritants) { +static sexp sexp_compile_error(char *message, sexp irritants) { return sexp_make_exception(the_compile_error_symbol, sexp_make_string(message), irritants, SEXP_FALSE, SEXP_FALSE); } -sexp sexp_expand_macro (sexp mac, sexp form, sexp e) { - sexp bc, res, *stack = (sexp*) sexp_alloc(sizeof(sexp)*INIT_STACK_SIZE); - sexp_uint_t i=0; -/* fprintf(stderr, "expanding: "); */ -/* sexp_write(form, cur_error_port); */ -/* fprintf(stderr, "\n => "); */ - bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+64, SEXP_BYTECODE); - sexp_bytecode_length(bc) = 32; - emit_push(&bc, &i, sexp_macro_env(mac)); - emit_push(&bc, &i, e); - emit_push(&bc, &i, form); - emit_push(&bc, &i, sexp_macro_proc(mac)); - emit(&bc, &i, OP_CALL); - emit_word(&bc, &i, (sexp_uint_t) sexp_make_integer(3)); - emit(&bc, &i, OP_DONE); - res = vm(bc, e, stack, 0); - sexp_write(res, cur_error_port); -/* fprintf(stderr, "\n"); */ - sexp_free(bc); - sexp_free(stack); +/* sexp expand_macro (sexp mac, sexp form, sexp e) { */ +/* sexp bc, res, *stack = (sexp*) sexp_alloc(sizeof(sexp)*INIT_STACK_SIZE); */ +/* sexp_uint_t i=0; */ +/* /\* fprintf(stderr, "expanding: "); *\/ */ +/* /\* sexp_write(form, cur_error_port); *\/ */ +/* /\* fprintf(stderr, "\n => "); *\/ */ +/* bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+64, SEXP_BYTECODE); */ +/* sexp_bytecode_length(bc) = 32; */ +/* emit_push(&bc, &i, sexp_macro_env(mac)); */ +/* emit_push(&bc, &i, e); */ +/* emit_push(&bc, &i, form); */ +/* emit_push(&bc, &i, sexp_macro_proc(mac)); */ +/* emit(&bc, &i, OP_CALL); */ +/* emit_word(&bc, &i, (sexp_uint_t) sexp_make_integer(3)); */ +/* emit(&bc, &i, OP_DONE); */ +/* res = vm(bc, e, stack, 0); */ +/* sexp_write(res, cur_error_port); */ +/* /\* fprintf(stderr, "\n"); *\/ */ +/* sexp_free(bc); */ +/* sexp_free(stack); */ +/* return res; */ +/* } */ + +#define analyze_check_exception(x) do {if (sexp_exceptionp(x)) \ + return (x); \ + } while (0) + +#define analyze_bind(var, x, env) do {(var) = analyze(x,env); \ + analyze_check_exception(var); \ + } while (0) + +sexp analyze (sexp x, sexp env) { + sexp op, cell, res; + loop: + if (sexp_pairp(x)) { + if (sexp_idp(sexp_car(x))) { + cell = env_cell(env, sexp_car(x)); + if (! cell) return analyze_app(x, env); + op = sexp_cdr(cell); + if (sexp_corep(op)) { + switch (sexp_core_code(op)) { + case CORE_DEFINE: + res = analyze_define(x, env); + break; + case CORE_SET: + res = analyze_set(x, env); + break; + case CORE_LAMBDA: + res = analyze_lambda(x, env); + break; + case CORE_IF: + res = analyze_if(x, env); + break; + case CORE_BEGIN: + res = analyze_seq(x, env); + break; + case CORE_QUOTE: + res = sexp_make_lit(x); + break; + default: + res = sexp_compile_error("unknown core form", sexp_list1(op)); + break; + } + } else if (sexp_macrop(op)) { + /* x = expand_macro(op, x, env); */ + /* goto loop; */ + res = sexp_compile_error("macros not yet supported", sexp_list1(x)); + } else { + res = analyze_app(x, env); + } + } else { + res = analyze_app(x, env); + } + } else if (sexp_symbolp(x)) { + res = analyze_var_ref(x, env); + } else if (sexp_synclop(x)) { + env = sexp_synclo_env(x); + x = sexp_synclo_expr(x); + goto loop; + } else { + res = x; + } return res; } -/* sexp analyze(sexp x, sexp env) { */ -/* sexp op, cell; */ -/* loop: */ -/* if (sexp_pairp(x)) { */ -/* if (sexp_idp(sexp_car(x))) { */ -/* cell = env_cell(sexp_car(x), env); */ -/* if (! cell) return analyze_app(x, env); */ -/* op = sexp_cdr(cell); */ -/* if (sexp_corep(op)) { */ -/* switch (sexp_core_code(op)) { */ -/* case CORE_DEFINE: */ -/* if (sexp_env_global_p(env)) */ -/* return sexp_make_set(sexp_make_global_ref(sexp_cadr(x), env), */ -/* analyze(sexp_caddr(x), env)); */ -/* else */ -/* return sexp_compile_error("bad define location", sexp_list1(x)); */ -/* case CORE_SET: */ -/* return sexp_make_set(sexp_make_ref(sexp_cadr(x), env), */ -/* analyze(sexp_caddr(x), env)); */ -/* case CORE_LAMBDA: */ -/* return analyze_lambda(x, env); */ -/* case CORE_IF: */ -/* return sexp_make_cnd(analyze(sexp_car(x), env), */ -/* analyze(sexp_cadr(x), env), */ -/* (sexp_pairp(sexp_cddr(x)) */ -/* ? analyze(sexp_caddr(x), env) : SEXP_UNDEF)); */ -/* case CORE_BEGIN: */ -/* return sexp_make_seq(analyze_app(x, env)); */ -/* case CORE_QUOTE: */ -/* return sexp_make_lit(x); */ -/* default: */ -/* return sexp_compile_error("unknown core form", sexp_list1(op)); */ -/* } */ -/* } else if (sexp_macrop(op)) { */ -/* x = sexp_expand_macro(op, x, env); */ -/* goto loop; */ -/* } else { */ -/* return analyze_app(x, env); */ -/* } */ -/* } else { */ -/* return analyze_app(x, env); */ -/* } */ -/* } else if (sexp_symbolp(x)) { */ -/* return analyze_var_ref(x, env); */ -/* } else if (sexp_synclop(x)) { */ -/* env = sexp_synclo_env(x); */ -/* x = sexp_synclo_expr(x); */ -/* goto loop; */ -/* } else { */ -/* return x; */ -/* } */ -/* } */ - -/* sexp analyze_lambda(sexp x, sexp env) { */ -/* } */ - -/* sexp analyze_app(sexp x, sexp env) { */ -/* sexp res=SEXP_NULL; */ -/* for ( ; sexp_pairp(x); x=sexp_cdr(x)) */ -/* res = sexp_cons(analyze(sexp_car(x), env), res); */ -/* return sexp_nreverse(res); */ -/* } */ - -/* sexp compile(sexp x, sexp res) { */ -/* if (sexp_pairp(x)) */ -/* else if (sexp_lambdap(x)) */ -/* else if (sexp_seqp(x)) */ -/* else if (sexp_cndp(x)) */ -/* else if (sexp_refp(x)) */ -/* else if (sexp_setp(x)) */ -/* else if (sexp_litp(x)) */ -/* else */ -/* } */ - -sexp analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { - int tmp1, tmp2; - sexp o1, o2, e2, cell, exn; - - loop: - if (sexp_pairp(obj)) { - if (sexp_symbolp(sexp_car(obj))) { - o1 = env_cell(e, sexp_car(obj)); - if (! o1) { - return analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); - } - o1 = sexp_cdr(o1); - if (sexp_corep(o1)) { - switch (sexp_core_code(o1)) { - case CORE_LAMBDA: - return analyze_lambda(SEXP_FALSE, sexp_cadr(obj), sexp_cddr(obj), - bc, i, e, params, fv, sv, d, tailp); - case CORE_DEFINE_SYNTAX: - o2 = eval(sexp_caddr(obj), e); - if (sexp_exceptionp(o2)) return o2; - env_define(e, sexp_cadr(obj), sexp_make_macro(o2, e)); - emit_push(bc, i, SEXP_UNDEF); - (*d)++; - break; - case CORE_DEFINE: - if ((sexp_core_code(o1) == CORE_DEFINE) - && sexp_pairp(sexp_cadr(obj))) { - o2 = sexp_car(sexp_cadr(obj)); - exn = analyze_lambda(sexp_caadr(obj), sexp_cdadr(obj), - sexp_cddr(obj), - bc, i, e, params, fv, sv, d, 0); - } else { - o2 = sexp_cadr(obj); - exn = analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, 0); - } - if (sexp_exceptionp(exn)) return exn; - if (sexp_env_global_p(e)) { - cell = env_cell_create(e, o2); - emit_push(bc, i, cell); - emit(bc, i, OP_SET_CDR); - } else { - cell = env_cell(e, o2); - if (! cell || ! sexp_integerp(sexp_cdr(cell))) { - return sexp_compile_error("define in bad position", - sexp_list1(obj)); - } else { - emit(bc, i, OP_STACK_SET); - emit_word(bc, i, (*d)+1-sexp_unbox_integer(sexp_cdr(cell))); - } - } - (*d)++; - break; - case CORE_SET: - exn = analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, 0); - if (sexp_exceptionp(exn)) return exn; - if (sexp_list_index(sv, sexp_cadr(obj)) >= 0) { - analyze_var_ref(sexp_cadr(obj), bc, i, e, params, fv, SEXP_NULL, d); - emit(bc, i, OP_SET_CAR); - (*d)--; - } else { - cell = env_cell_create(e, sexp_cadr(obj)); - emit_push(bc, i, cell); - emit(bc, i, OP_SET_CDR); - } - break; - case CORE_BEGIN: - return - analyze_sequence(sexp_cdr(obj), bc, i, e, params, fv, sv, d, tailp); - case CORE_IF: - exn = analyze(sexp_cadr(obj), bc, i, e, params, fv, sv, d, 0); - if (sexp_exceptionp(exn)) return exn; - emit(bc, i, OP_JUMP_UNLESS); /* jumps if test fails */ - (*d)--; - tmp1 = *i; - emit(bc, i, 0); - exn = analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, tailp); - if (sexp_exceptionp(exn)) return exn; - emit(bc, i, OP_JUMP); - (*d)--; - tmp2 = *i; - emit(bc, i, 0); - ((signed char*) sexp_bytecode_data(*bc))[tmp1] = (*i)-tmp1; - if (sexp_pairp(sexp_cdddr(obj))) { - exn = analyze(sexp_cadddr(obj), bc, i, e, params, fv, sv, d, tailp); - if (sexp_exceptionp(exn)) return exn; - } else { - emit_push(bc, i, SEXP_UNDEF); - (*d)++; - } - ((signed char*) sexp_bytecode_data(*bc))[tmp2] = (*i)-tmp2; - break; - case CORE_QUOTE: - emit_push(bc, i, sexp_cadr(obj)); - (*d)++; - break; - default: - return sexp_compile_error("unknown core form", sexp_list1(o1)); - } - } else if (sexp_opcodep(o1)) { - return analyze_opcode(o1, obj, bc, i, e, params, fv, sv, d, tailp); - } else if (sexp_macrop(o1)) { - obj = sexp_expand_macro(o1, obj, e); - if (sexp_exceptionp(obj)) return obj; - goto loop; - } else { - /* general procedure call */ - return analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); - } - } else if (sexp_pairp(sexp_car(obj))) { -#if USE_FAST_LET - o2 = env_cell(e, sexp_caar(obj)); - if (o2 - && sexp_corep(sexp_cdr(o2)) - && (sexp_core_code(o2) == CORE_LAMBDA) - && sexp_listp(sexp_cadr(sexp_car(obj)))) { - /* let */ - tmp1 = sexp_unbox_integer(sexp_length(sexp_cadar(obj))); - /* push params as local stack variables */ - for (o2=sexp_reverse(sexp_cdr(obj)); sexp_pairp(o2); o2=sexp_cdr(o2)) { - exn = analyze(sexp_car(o2), bc, i, e, params, fv, sv, d, 0); - if (sexp_exceptionp(exn)) return exn; - } - /* analyze the body in a new local env */ - e2 = extend_env(e, sexp_cadar(obj), (*d)+(tmp1-1)); - params = sexp_append(sexp_cadar(obj), params); - exn = - analyze_sequence(sexp_cddar(obj), bc, i, e, params, fv, sv, d, tailp); - if (sexp_exceptionp(exn)) return exn; - /* set the result and pop off the local vars */ - emit(bc, i, OP_STACK_SET); - emit_word(bc, i, tmp1+1); - (*d) -= (tmp1-1); - for ( ; tmp1>0; tmp1--) - emit(bc, i, OP_DROP); - } else -#endif - /* computed application */ - return analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); - } else { - return sexp_compile_error("invalid operator", sexp_list1(sexp_car(obj))); - } - } else if (sexp_symbolp(obj)) { - analyze_var_ref(obj, bc, i, e, params, fv, sv, d); - } else { /* literal */ - emit_push(bc, i, obj); - (*d)++; - } - return SEXP_TRUE; +sexp analyze_lambda (sexp x, sexp env) { + sexp res, body; + /* XXXX verify syntax */ + res = sexp_alloc_type(lambda, SEXP_LAMBDA); + sexp_lambda_params(res) = sexp_cadr(x); + env = extend_env(env, sexp_flatten_dot(sexp_lambda_params(res)), res); + sexp_env_lambda(env) = res; + body = analyze_seq(sexp_cddr(x), env); + analyze_check_exception(body); + sexp_lambda_body(res) = body; + return res; } -sexp analyze_sequence (sexp ls, sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) -{ - sexp exn; - for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { - if (sexp_pairp(sexp_cdr(ls))) { - exn = analyze(sexp_car(ls), bc, i, e, params, fv, sv, d, 0); - if (sexp_exceptionp(exn)) - return exn; - emit(bc, i, OP_DROP); - (*d)--; - } else { - analyze(sexp_car(ls), bc, i, e, params, fv, sv, d, tailp); - } +sexp analyze_seq (sexp ls, sexp env) { + sexp res, tmp; + if (sexp_nullp(ls)) + res = SEXP_UNDEF; + else if (sexp_nullp(sexp_cdr(ls))) + res = analyze(sexp_car(ls), env); + else { + res = sexp_alloc_type(seq, SEXP_SEQ); + tmp = analyze_app(ls, env); + analyze_check_exception(tmp); + sexp_seq_ls(res) = tmp; } - return SEXP_TRUE; + return res; } -sexp analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) -{ - sexp ls, exn; - int j, len = sexp_unbox_integer(sexp_length(sexp_cdr(obj))); +sexp analyze_if (sexp x, sexp env) { + sexp test, pass, fail; + analyze_bind(test, sexp_car(x), env); + analyze_bind(pass, sexp_cadr(x), env); + analyze_bind(fail, sexp_pairp(sexp_cddr(x))?sexp_caddr(x):SEXP_UNDEF, env); + return sexp_make_cnd(test, pass, fail); +} - /* verify parameters */ - if (len < sexp_opcode_num_args(op)) { - return sexp_compile_error("not enough arguments", sexp_list1(obj)); - } else if (len > sexp_opcode_num_args(op)) { - if (! sexp_opcode_variadic_p(op)) - return sexp_compile_error("too many arguments", sexp_list1(obj)); - } else if (sexp_opcode_variadic_p(op) && sexp_opcode_data(op)) { - emit(bc, i, OP_PARAMETER); - emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op)); +sexp analyze_app (sexp x, sexp env) { + sexp res=SEXP_NULL, tmp; + for ( ; sexp_pairp(x); x=sexp_cdr(x)) { + analyze_bind(tmp, sexp_car(x), env); + sexp_push(res, tmp); + } + return sexp_nreverse(res); +} + +sexp analyze_define (sexp x, sexp env) { + sexp ref, name, value; + name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x)); + if (sexp_lambdap(sexp_env_lambda(env))) + sexp_push(sexp_lambda_locals(sexp_env_lambda(env)), name); + if (sexp_pairp(sexp_cadr(x))) + value = analyze_lambda(sexp_cons(SEXP_UNDEF, + sexp_cons(sexp_cdadr(x), sexp_cddr(x))), + env); + else + value = analyze(sexp_caddr(x), env); + analyze_check_exception(value); + ref = analyze_var_ref(name, env); + analyze_check_exception(ref); + env_cell_create(env, name, SEXP_DEF); + return sexp_make_set(ref, value); +} + +sexp analyze_var_ref (sexp x, sexp env) { + sexp cell = env_cell_create(env, x, SEXP_UNDEF); + return sexp_make_ref(x, sexp_cdr(cell)); +} + +sexp analyze_set (sexp x, sexp env) { + sexp ref, value; + ref = analyze_var_ref(sexp_cadr(x), env); + 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), env); + return sexp_make_set(ref, value); +} + +sexp_uint_t sexp_context_make_label (sexp context) { + sexp_uint_t label = sexp_context_pos(context); + sexp_context_pos(context) += sizeof(sexp_uint_t); + return label; +} + +void sexp_context_patch_label (sexp context, sexp_uint_t label) { + sexp bc = sexp_context_bc(context); + ((sexp_uint_t*) sexp_bytecode_data(bc))[label] + = 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); +} + +void compile_one (sexp x, sexp context) { + if (sexp_pointerp(x)) { + switch (sexp_pointer_tag(x)) { + case SEXP_PAIR: + compile_app(x, context); + break; + case SEXP_LAMBDA: + compile_lambda(x, context); + break; + case SEXP_CND: + compile_cnd(x, context); + break; + case SEXP_REF: + compile_ref(x, context, 1); + break; + case SEXP_SET: + compile_set(x, context); + break; + case SEXP_SEQ: + compile_seq(sexp_seq_ls(x), context); + break; + case SEXP_LIT: + compile_lit(sexp_lit_value(x), context); + break; + default: + compile_lit(x, context); + } + } else { + compile_lit(x, context); + } +} + +void compile_lit (sexp value, sexp context) { + emit_push(value, context); +} + +void compile_seq (sexp app, sexp context) { + sexp head=app, tail=sexp_cdr(app); + for ( ; sexp_pairp(tail); head=tail, tail=sexp_cdr(tail)) { + compile_one(sexp_car(head), context); + emit(OP_DROP, context); + sexp_context_depth(context)--; + } + compile_one(sexp_car(head), context); +} + +void compile_cnd (sexp cnd, sexp context) { + sexp_uint_t label1, label2; + compile_one(sexp_cnd_test(cnd), context); + emit(OP_JUMP_UNLESS, context); + sexp_context_depth(context)--; + label1 = sexp_context_make_label(context); + compile_one(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); + compile_one(sexp_cnd_fail(cnd), context); + sexp_context_patch_label(context, label2); +} + +void compile_ref (sexp ref, sexp context, int unboxp) { + sexp lam; + if (! sexp_lambdap(sexp_ref_loc(ref))) { + /* global ref */ + emit_push(ref, context); + emit(OP_CDR, context); + } else { + lam = sexp_context_lambda(context); + compile_non_global_ref(sexp_ref_name(ref), sexp_ref_loc(ref), lam, + sexp_lambda_fv(lam), context, unboxp); + } +} + +void compile_non_global_ref (sexp name, sexp loc, sexp lambda, sexp fv, + sexp context, int unboxp) { + sexp ls; + sexp_uint_t i; + if (loc == lambda) { + /* local ref */ + emit(OP_LOCAL_REF, context); + emit_word(sexp_list_index(sexp_lambda_params(lambda), name), context); + } else { + /* closure ref */ + for (i=0; sexp_pairp(fv); ls=sexp_cdr(fv), i++) + if (name == sexp_car(fv) && loc == sexp_cdr(fv)) + break; + emit(OP_CLOSURE_REF, context); + emit_word(i, context); + } + if (unboxp && (sexp_list_index(sexp_lambda_sv(loc), name) >= 0)) + emit(OP_CDR, context); + sexp_context_depth(context)++; +} + +void compile_set (sexp set, sexp context) { + sexp ref = sexp_set_var(set); + /* compile the value */ + compile_one(sexp_set_value(set), context); + if (! sexp_lambdap(sexp_ref_loc(ref))) { + /* global vars are set directly */ + emit_push(ref, context); + } else { + /* stack or closure mutable vars are boxed */ + compile_ref(ref, context, 0); + } + emit(OP_SET_CDR, context); + sexp_context_depth(context)--; +} + +void compile_app (sexp app, sexp context) { + if (sexp_opcodep(sexp_car(app))) + compile_opcode_app(app, context); + else + compile_general_app(app, context); +} + +void compile_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))); + + /* maybe push the default for an optional argument */ + if ((num_args < sexp_opcode_num_args(op)) + && sexp_opcode_variadic_p(op) && sexp_opcode_data(op)) { + emit(OP_PARAMETER, context); + emit_word((sexp_uint_t)sexp_opcode_data(op), context); if (! sexp_opcode_opt_param_p(op)) { - emit(bc, i, OP_CALL); - emit_word(bc, i, (sexp_uint_t) sexp_make_integer(0)); + emit(OP_CALL, context); + emit_word((sexp_uint_t)sexp_make_integer(0), context); } - (*d)++; - len++; + sexp_context_depth(context)++; + num_args++; } - /* push arguments */ - for (ls=sexp_reverse(sexp_cdr(obj)); sexp_pairp(ls); ls=sexp_cdr(ls)) { - exn = analyze(sexp_car(ls), bc, i, e, params, fv, sv, d, 0); - if (sexp_exceptionp(exn)) return exn; - } + /* 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)) + compile_one(sexp_car(ls), context); - /* emit operator */ + /* emit the actual operator call */ if (sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { - emit(bc, i, (len == 1) ? sexp_opcode_inverse(op) : sexp_opcode_code(op)); + emit((num_args == 1) ? sexp_opcode_inverse(op) + : sexp_opcode_code(op), context); } else { if (sexp_opcode_class(op) == OPC_FOREIGN) - emit_push(bc, i, sexp_opcode_data(op)); - else if ((len > 2) && sexp_opcode_class(op) == OPC_ARITHMETIC_CMP) { - emit(bc, i, OP_STACK_REF); - emit_word(bc, i, 2); - } - emit(bc, i, sexp_opcode_inverse(op) ? sexp_opcode_inverse(op) - : sexp_opcode_code(op)); + /* push the funtion pointer for foreign calls */ + emit_push(sexp_opcode_data(op), context); + emit(sexp_opcode_inverse(op) ? sexp_opcode_inverse(op) + : sexp_opcode_code(op), + context); } /* emit optional folding of operator */ - if (len > 2) { + if (num_args > 2) { if (sexp_opcode_class(op) == OPC_ARITHMETIC || sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { - for (j=len-2; j>0; j--) - emit(bc, i, sexp_opcode_code(op)); + for (i=num_args-2; i>0; i--) + emit(sexp_opcode_code(op), context); } else if (sexp_opcode_class(op) == OPC_ARITHMETIC_CMP) { - for (j=len-2; j>0; j--) { - /* emit(bc, i, OP_JUMP_UNLESS); */ - emit(bc, i, sexp_opcode_code(op)); - } + /* XXXX handle folding of comparisons */ } } if (sexp_opcode_class(op) == OPC_PARAMETER) - emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op)); + emit_word((sexp_uint_t)sexp_opcode_data(op), context); - (*d) -= (len-1); - - return SEXP_TRUE; + sexp_context_depth(context) -= (num_args-1); } -void analyze_var_ref (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d) { - int tmp; - sexp cell; - if ((tmp = sexp_list_index(params, obj)) >= 0) { - cell = env_cell(e, obj); - emit(bc, i, OP_STACK_REF); - emit_word(bc, i, *d - sexp_unbox_integer(sexp_cdr(cell))); - } else if ((tmp = sexp_list_index(fv, obj)) >= 0) { - emit(bc, i, OP_CLOSURE_REF); - emit_word(bc, i, (sexp_uint_t) sexp_make_integer(tmp)); - } else { - cell = env_cell_create(e, obj); - emit_push(bc, i, cell); - emit(bc, i, OP_CDR); - } - (*d)++; - if (sexp_list_index(sv, obj) >= 0) { - emit(bc, i, OP_CAR); - } -} - -sexp analyze_app (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { - sexp o1, exn; - sexp_uint_t len = sexp_unbox_integer(sexp_length(sexp_cdr(obj))); +void compile_general_app (sexp app, sexp context) { + sexp ls; + sexp_uint_t len = sexp_unbox_integer(sexp_length(sexp_cdr(app))); /* push the arguments onto the stack */ - for (o1 = sexp_reverse(sexp_cdr(obj)); sexp_pairp(o1); o1 = sexp_cdr(o1)) { - exn = analyze(sexp_car(o1), bc, i, e, params, fv, sv, d, 0); - if (sexp_exceptionp(exn)) return exn; - } + for (ls = sexp_reverse(sexp_cdr(app)); sexp_pairp(ls); ls = sexp_cdr(ls)) + compile_one(sexp_car(ls), context); /* push the operator onto the stack */ - exn = analyze(sexp_car(obj), bc, i, e, params, fv, sv, d, 0); - if (sexp_exceptionp(exn)) return exn; + compile_one(sexp_car(app), context); /* maybe overwrite the current frame */ - if (tailp) { - emit(bc, i, OP_TAIL_CALL); - emit_word(bc, i, (sexp_uint_t) sexp_make_integer(sexp_unbox_integer(sexp_length(params))+(*d)+3)); - emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len)); + if (sexp_context_tailp(context)) { + emit(OP_TAIL_CALL, context); + emit_word(sexp_context_depth(context), context); + emit_word((sexp_uint_t)sexp_make_integer(len), context); } else { /* normal call */ - emit(bc, i, OP_CALL); - emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len)); + emit(OP_CALL, context); + emit_word((sexp_uint_t)sexp_make_integer(len), context); } - (*d) -= (len); - return SEXP_TRUE; + sexp_context_depth(context) -= len; } -sexp free_vars (sexp e, sexp formals, sexp obj, sexp fv) { - sexp o1; - if (sexp_symbolp(obj)) { - if (env_global_p(e, obj) - || (sexp_list_index(formals, obj) >= 0) - || (sexp_list_index(fv, obj) >= 0)) - return fv; - else - return sexp_cons(obj, fv); - } else if (sexp_pairp(obj)) { - if (sexp_symbolp(sexp_car(obj))) { - if ((o1 = env_cell(e, sexp_car(obj))) - && sexp_corep(o1) - && (sexp_core_code(sexp_cdr(o1)) == CORE_LAMBDA)) { - return free_vars(e, sexp_cadr(obj), sexp_caddr(obj), fv); - } - } - while (sexp_pairp(obj)) { - fv = free_vars(e, formals, sexp_car(obj), fv); - obj = sexp_cdr(obj); - } - return fv; - } else { - return fv; - } -} - -sexp set_vars (sexp e, sexp formals, sexp obj, sexp sv) { - sexp cell; - int code; - if (sexp_nullp(formals)) - return sv; - if (sexp_pairp(obj)) { - if (sexp_symbolp(sexp_car(obj))) { - if ((cell = env_cell(e, sexp_car(obj))) && sexp_corep(sexp_cdr(cell))) { - code = sexp_core_code(sexp_cdr(cell)); - if (code == CORE_LAMBDA) { - formals = sexp_lset_diff(formals, sexp_cadr(obj)); - return set_vars(e, formals, sexp_caddr(obj), sv); - } else if ((code == CORE_SET || code == CORE_DEFINE) - && (sexp_list_index(formals, sexp_cadr(obj)) >= 0) - && ! (sexp_list_index(sv, sexp_cadr(obj)) >= 0)) { - sv = sexp_cons(sexp_cadr(obj), sv); - return set_vars(e, formals, sexp_caddr(obj), sv); - } - } - } - while (sexp_pairp(obj)) { - sv = set_vars(e, formals, sexp_car(obj), sv); - obj = sexp_cdr(obj); - } - } - return sv; -} - -sexp analyze_lambda (sexp name, sexp formals, sexp body, - sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d, - int tailp) { - sexp obj, ls, flat_formals, fv2, e2; - int k; - flat_formals = sexp_flatten_dot(formals); - fv2 = free_vars(e, flat_formals, body, SEXP_NULL); - e2 = extend_env(e, flat_formals, -4); - /* compile the body with respect to the new params */ - obj = compile(flat_formals, body, e2, fv2, sv, 0); - if (sexp_exceptionp(obj)) return obj; - if (sexp_nullp(fv2)) { - /* no variables to close over, fixed procedure */ - emit_push(bc, i, - sexp_make_procedure(sexp_make_integer((sexp_listp(formals) - ? 0 : 1)), - sexp_length(formals), - obj, - sexp_make_vector(sexp_make_integer(0), - SEXP_UNDEF))); - (*d)++; +void compile_lambda (sexp lambda, sexp context) { + sexp fv, ctx, flags, bc, len, ref, vec, prev_lambda, prev_fv; + sexp_uint_t k; + prev_lambda = sexp_context_lambda(context); + prev_fv = sexp_lambda_fv(prev_lambda); + fv = sexp_lambda_fv(lambda); + ctx = sexp_new_context(sexp_context_stack(context)); + sexp_context_lambda(ctx) = lambda; + compile_one(sexp_lambda_body(lambda), ctx); + flags = sexp_make_integer(sexp_listp(sexp_lambda_params(lambda)) ? 0 : 1); + len = sexp_length(sexp_lambda_params(lambda)); + bc = finalize_bytecode(ctx); + if (sexp_nullp(fv)) { + vec = sexp_make_vector(sexp_make_integer(0), SEXP_UNDEF); + compile_lit(sexp_make_procedure(flags, len, bc, vec), context); } else { /* push the closed vars */ - emit_push(bc, i, SEXP_UNDEF); - emit_push(bc, i, sexp_length(fv2)); - emit(bc, i, OP_MAKE_VECTOR); - (*d)++; - for (ls=fv2, k=0; sexp_pairp(ls); ls=sexp_cdr(ls), k++) { - analyze_var_ref(sexp_car(ls), bc, i, e, params, fv, SEXP_NULL, d); - emit_push(bc, i, sexp_make_integer(k)); - emit(bc, i, OP_STACK_REF); - emit_word(bc, i, 3); - emit(bc, i, OP_VECTOR_SET); - emit(bc, i, OP_DROP); - (*d)--; + emit_push(SEXP_UNDEF, context); + emit_push(len, 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); + compile_non_global_ref(sexp_ref_name(ref), sexp_ref_loc(ref), + prev_lambda, prev_fv, context, 1); + emit_push(sexp_make_integer(k), context); + emit(OP_LOCAL_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, i, obj); - emit_push(bc, i, sexp_length(formals)); - emit_push(bc, i, sexp_make_integer(sexp_listp(formals) ? 0 : 1)); - emit(bc, i, OP_MAKE_PROCEDURE); + emit_push(bc, context); + emit_push(len, context); + emit_push(flags, context); + emit(OP_MAKE_PROCEDURE, context); } - return SEXP_TRUE; } +/* sexp xanalyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, */ +/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { */ +/* int tmp1, tmp2; */ +/* sexp o1, o2, e2, cell, exn; */ + +/* loop: */ +/* if (sexp_pairp(obj)) { */ +/* if (sexp_symbolp(sexp_car(obj))) { */ +/* o1 = env_cell(e, sexp_car(obj)); */ +/* if (! o1) { */ +/* return analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); */ +/* } */ +/* o1 = sexp_cdr(o1); */ +/* if (sexp_corep(o1)) { */ +/* switch (sexp_core_code(o1)) { */ +/* case CORE_LAMBDA: */ +/* return analyze_lambda(SEXP_FALSE, sexp_cadr(obj), sexp_cddr(obj), */ +/* bc, i, e, params, fv, sv, d, tailp); */ +/* case CORE_DEFINE_SYNTAX: */ +/* o2 = eval(sexp_caddr(obj), e); */ +/* if (sexp_exceptionp(o2)) return o2; */ +/* env_define(e, sexp_cadr(obj), sexp_make_macro(o2, e)); */ +/* emit_push(bc, i, SEXP_UNDEF); */ +/* (*d)++; */ +/* break; */ +/* case CORE_DEFINE: */ +/* if ((sexp_core_code(o1) == CORE_DEFINE) */ +/* && sexp_pairp(sexp_cadr(obj))) { */ +/* o2 = sexp_car(sexp_cadr(obj)); */ +/* exn = analyze_lambda(sexp_caadr(obj), sexp_cdadr(obj), */ +/* sexp_cddr(obj), */ +/* bc, i, e, params, fv, sv, d, 0); */ +/* } else { */ +/* o2 = sexp_cadr(obj); */ +/* exn = analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, 0); */ +/* } */ +/* if (sexp_exceptionp(exn)) return exn; */ +/* if (sexp_env_global_p(e)) { */ +/* cell = env_cell_create(e, o2); */ +/* emit_push(bc, i, cell); */ +/* emit(bc, i, OP_SET_CDR); */ +/* } else { */ +/* cell = env_cell(e, o2); */ +/* if (! cell || ! sexp_integerp(sexp_cdr(cell))) { */ +/* return sexp_compile_error("define in bad position", */ +/* sexp_list1(obj)); */ +/* } else { */ +/* emit(bc, i, OP_STACK_SET); */ +/* emit_word(bc, i, (*d)+1-sexp_unbox_integer(sexp_cdr(cell))); */ +/* } */ +/* } */ +/* (*d)++; */ +/* break; */ +/* case CORE_SET: */ +/* exn = analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, 0); */ +/* if (sexp_exceptionp(exn)) return exn; */ +/* if (sexp_list_index(sv, sexp_cadr(obj)) >= 0) { */ +/* analyze_var_ref(sexp_cadr(obj), bc, i, e, params, fv, SEXP_NULL, d); */ +/* emit(bc, i, OP_SET_CAR); */ +/* (*d)--; */ +/* } else { */ +/* cell = env_cell_create(e, sexp_cadr(obj)); */ +/* emit_push(bc, i, cell); */ +/* emit(bc, i, OP_SET_CDR); */ +/* } */ +/* break; */ +/* case CORE_BEGIN: */ +/* return */ +/* analyze_sequence(sexp_cdr(obj), bc, i, e, params, fv, sv, d, tailp); */ +/* case CORE_IF: */ +/* exn = analyze(sexp_cadr(obj), bc, i, e, params, fv, sv, d, 0); */ +/* if (sexp_exceptionp(exn)) return exn; */ +/* emit(bc, i, OP_JUMP_UNLESS); /\* jumps if test fails *\/ */ +/* (*d)--; */ +/* tmp1 = *i; */ +/* emit(bc, i, 0); */ +/* exn = analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, tailp); */ +/* if (sexp_exceptionp(exn)) return exn; */ +/* emit(bc, i, OP_JUMP); */ +/* (*d)--; */ +/* tmp2 = *i; */ +/* emit(bc, i, 0); */ +/* ((signed char*) sexp_bytecode_data(*bc))[tmp1] = (*i)-tmp1; */ +/* if (sexp_pairp(sexp_cdddr(obj))) { */ +/* exn = analyze(sexp_cadddr(obj), bc, i, e, params, fv, sv, d, tailp); */ +/* if (sexp_exceptionp(exn)) return exn; */ +/* } else { */ +/* emit_push(bc, i, SEXP_UNDEF); */ +/* (*d)++; */ +/* } */ +/* ((signed char*) sexp_bytecode_data(*bc))[tmp2] = (*i)-tmp2; */ +/* break; */ +/* case CORE_QUOTE: */ +/* emit_push(bc, i, sexp_cadr(obj)); */ +/* (*d)++; */ +/* break; */ +/* default: */ +/* return sexp_compile_error("unknown core form", sexp_list1(o1)); */ +/* } */ +/* } else if (sexp_opcodep(o1)) { */ +/* return analyze_opcode(o1, obj, bc, i, e, params, fv, sv, d, tailp); */ +/* } else if (sexp_macrop(o1)) { */ +/* obj = sexp_expand_macro(o1, obj, e); */ +/* if (sexp_exceptionp(obj)) return obj; */ +/* goto loop; */ +/* } else { */ +/* /\* general procedure call *\/ */ +/* return analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); */ +/* } */ +/* } else if (sexp_pairp(sexp_car(obj))) { */ +/* #if USE_FAST_LET */ +/* o2 = env_cell(e, sexp_caar(obj)); */ +/* if (o2 */ +/* && sexp_corep(sexp_cdr(o2)) */ +/* && (sexp_core_code(o2) == CORE_LAMBDA) */ +/* && sexp_listp(sexp_cadr(sexp_car(obj)))) { */ +/* /\* let *\/ */ +/* tmp1 = sexp_unbox_integer(sexp_length(sexp_cadar(obj))); */ +/* /\* push params as local stack variables *\/ */ +/* for (o2=sexp_reverse(sexp_cdr(obj)); sexp_pairp(o2); o2=sexp_cdr(o2)) { */ +/* exn = analyze(sexp_car(o2), bc, i, e, params, fv, sv, d, 0); */ +/* if (sexp_exceptionp(exn)) return exn; */ +/* } */ +/* /\* analyze the body in a new local env *\/ */ +/* e2 = extend_env(e, sexp_cadar(obj), (*d)+(tmp1-1)); */ +/* params = sexp_append(sexp_cadar(obj), params); */ +/* exn = */ +/* analyze_sequence(sexp_cddar(obj), bc, i, e, params, fv, sv, d, tailp); */ +/* if (sexp_exceptionp(exn)) return exn; */ +/* /\* set the result and pop off the local vars *\/ */ +/* emit(bc, i, OP_STACK_SET); */ +/* emit_word(bc, i, tmp1+1); */ +/* (*d) -= (tmp1-1); */ +/* for ( ; tmp1>0; tmp1--) */ +/* emit(bc, i, OP_DROP); */ +/* } else */ +/* #endif */ +/* /\* computed application *\/ */ +/* return analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); */ +/* } else { */ +/* return sexp_compile_error("invalid operator", sexp_list1(sexp_car(obj))); */ +/* } */ +/* } else if (sexp_symbolp(obj)) { */ +/* analyze_var_ref(obj, bc, i, e, params, fv, sv, d); */ +/* } else { /\* literal *\/ */ +/* emit_push(bc, i, obj); */ +/* (*d)++; */ +/* } */ +/* return SEXP_TRUE; */ +/* } */ + +/* sexp analyze_sequence (sexp ls, sexp *bc, sexp_uint_t *i, sexp e, */ +/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) */ +/* { */ +/* sexp exn; */ +/* for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { */ +/* if (sexp_pairp(sexp_cdr(ls))) { */ +/* exn = analyze(sexp_car(ls), bc, i, e, params, fv, sv, d, 0); */ +/* if (sexp_exceptionp(exn)) */ +/* return exn; */ +/* emit(bc, i, OP_DROP); */ +/* (*d)--; */ +/* } else { */ +/* analyze(sexp_car(ls), bc, i, e, params, fv, sv, d, tailp); */ +/* } */ +/* } */ +/* return SEXP_TRUE; */ +/* } */ + +/* sexp analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, */ +/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) */ +/* { */ +/* sexp ls, exn; */ +/* int j, len = sexp_unbox_integer(sexp_length(sexp_cdr(obj))); */ + +/* /\* verify parameters *\/ */ +/* if (len < sexp_opcode_num_args(op)) { */ +/* return sexp_compile_error("not enough arguments", sexp_list1(obj)); */ +/* } else if (len > sexp_opcode_num_args(op)) { */ +/* if (! sexp_opcode_variadic_p(op)) */ +/* return sexp_compile_error("too many arguments", sexp_list1(obj)); */ +/* } else if (sexp_opcode_variadic_p(op) && sexp_opcode_data(op)) { */ +/* emit(bc, i, OP_PARAMETER); */ +/* emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op)); */ +/* if (! sexp_opcode_opt_param_p(op)) { */ +/* emit(bc, i, OP_CALL); */ +/* emit_word(bc, i, (sexp_uint_t) sexp_make_integer(0)); */ +/* } */ +/* (*d)++; */ +/* len++; */ +/* } */ + +/* /\* push arguments *\/ */ +/* for (ls=sexp_reverse(sexp_cdr(obj)); sexp_pairp(ls); ls=sexp_cdr(ls)) { */ +/* exn = analyze(sexp_car(ls), bc, i, e, params, fv, sv, d, 0); */ +/* if (sexp_exceptionp(exn)) return exn; */ +/* } */ + +/* /\* emit operator *\/ */ +/* if (sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { */ +/* emit(bc, i, (len == 1) ? sexp_opcode_inverse(op) : sexp_opcode_code(op)); */ +/* } else { */ +/* if (sexp_opcode_class(op) == OPC_FOREIGN) */ +/* emit_push(bc, i, sexp_opcode_data(op)); */ +/* else if ((len > 2) && sexp_opcode_class(op) == OPC_ARITHMETIC_CMP) { */ +/* emit(bc, i, OP_STACK_REF); */ +/* emit_word(bc, i, 2); */ +/* } */ +/* emit(bc, i, sexp_opcode_inverse(op) ? sexp_opcode_inverse(op) */ +/* : sexp_opcode_code(op)); */ +/* } */ + +/* /\* emit optional folding of operator *\/ */ +/* if (len > 2) { */ +/* if (sexp_opcode_class(op) == OPC_ARITHMETIC */ +/* || sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { */ +/* for (j=len-2; j>0; j--) */ +/* emit(bc, i, sexp_opcode_code(op)); */ +/* } else if (sexp_opcode_class(op) == OPC_ARITHMETIC_CMP) { */ +/* for (j=len-2; j>0; j--) { */ +/* /\* emit(bc, i, OP_JUMP_UNLESS); *\/ */ +/* emit(bc, i, sexp_opcode_code(op)); */ +/* } */ +/* } */ +/* } */ + +/* if (sexp_opcode_class(op) == OPC_PARAMETER) */ +/* emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op)); */ + +/* (*d) -= (len-1); */ + +/* return SEXP_TRUE; */ +/* } */ + +/* void analyze_var_ref (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, */ +/* sexp params, sexp fv, sexp sv, sexp_uint_t *d) { */ +/* int tmp; */ +/* sexp cell; */ +/* if ((tmp = sexp_list_index(params, obj)) >= 0) { */ +/* cell = env_cell(e, obj); */ +/* emit(bc, i, OP_STACK_REF); */ +/* emit_word(bc, i, *d - sexp_unbox_integer(sexp_cdr(cell))); */ +/* } else if ((tmp = sexp_list_index(fv, obj)) >= 0) { */ +/* emit(bc, i, OP_CLOSURE_REF); */ +/* emit_word(bc, i, (sexp_uint_t) sexp_make_integer(tmp)); */ +/* } else { */ +/* cell = env_cell_create(e, obj); */ +/* emit_push(bc, i, cell); */ +/* emit(bc, i, OP_CDR); */ +/* } */ +/* (*d)++; */ +/* if (sexp_list_index(sv, obj) >= 0) { */ +/* emit(bc, i, OP_CAR); */ +/* } */ +/* } */ + +/* sexp analyze_app (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, */ +/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { */ +/* sexp o1, exn; */ +/* sexp_uint_t len = sexp_unbox_integer(sexp_length(sexp_cdr(obj))); */ + +/* /\* push the arguments onto the stack *\/ */ +/* for (o1 = sexp_reverse(sexp_cdr(obj)); sexp_pairp(o1); o1 = sexp_cdr(o1)) { */ +/* exn = analyze(sexp_car(o1), bc, i, e, params, fv, sv, d, 0); */ +/* if (sexp_exceptionp(exn)) return exn; */ +/* } */ + +/* /\* push the operator onto the stack *\/ */ +/* exn = analyze(sexp_car(obj), bc, i, e, params, fv, sv, d, 0); */ +/* if (sexp_exceptionp(exn)) return exn; */ + +/* /\* maybe overwrite the current frame *\/ */ +/* if (tailp) { */ +/* emit(bc, i, OP_TAIL_CALL); */ +/* emit_word(bc, i, (sexp_uint_t) sexp_make_integer(sexp_unbox_integer(sexp_length(params))+(*d)+3)); */ +/* emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len)); */ +/* } else { */ +/* /\* normal call *\/ */ +/* emit(bc, i, OP_CALL); */ +/* emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len)); */ +/* } */ + +/* (*d) -= (len); */ +/* return SEXP_TRUE; */ +/* } */ + +/* sexp free_vars (sexp e, sexp formals, sexp obj, sexp fv) { */ +/* sexp o1; */ +/* if (sexp_symbolp(obj)) { */ +/* if (env_global_p(e, obj) */ +/* || (sexp_list_index(formals, obj) >= 0) */ +/* || (sexp_list_index(fv, obj) >= 0)) */ +/* return fv; */ +/* else */ +/* return sexp_cons(obj, fv); */ +/* } else if (sexp_pairp(obj)) { */ +/* if (sexp_symbolp(sexp_car(obj))) { */ +/* if ((o1 = env_cell(e, sexp_car(obj))) */ +/* && sexp_corep(o1) */ +/* && (sexp_core_code(sexp_cdr(o1)) == CORE_LAMBDA)) { */ +/* return free_vars(e, sexp_cadr(obj), sexp_caddr(obj), fv); */ +/* } */ +/* } */ +/* while (sexp_pairp(obj)) { */ +/* fv = free_vars(e, formals, sexp_car(obj), fv); */ +/* obj = sexp_cdr(obj); */ +/* } */ +/* return fv; */ +/* } else { */ +/* return fv; */ +/* } */ +/* } */ + +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_caar(ls) && loc == sexp_cdar(ls)) + return fv; + return sexp_cons(x, fv); +} + +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; +} + +sexp free_vars (sexp x, sexp fv) { + sexp fv1, fv2; + if (sexp_lambdap(x)) { + fv1 = free_vars(sexp_lambda_body(x), SEXP_NULL); + fv2 = sexp_lset_diff(fv1, 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); + } + return fv; +} + +/* sexp set_vars (sexp e, sexp formals, sexp obj, sexp sv) { */ +/* sexp cell; */ +/* int code; */ +/* if (sexp_nullp(formals)) */ +/* return sv; */ +/* if (sexp_pairp(obj)) { */ +/* if (sexp_symbolp(sexp_car(obj))) { */ +/* if ((cell = env_cell(e, sexp_car(obj))) && sexp_corep(sexp_cdr(cell))) { */ +/* code = sexp_core_code(sexp_cdr(cell)); */ +/* if (code == CORE_LAMBDA) { */ +/* formals = sexp_lset_diff(formals, sexp_cadr(obj)); */ +/* return set_vars(e, formals, sexp_caddr(obj), sv); */ +/* } else if ((code == CORE_SET || code == CORE_DEFINE) */ +/* && (sexp_list_index(formals, sexp_cadr(obj)) >= 0) */ +/* && ! (sexp_list_index(sv, sexp_cadr(obj)) >= 0)) { */ +/* sv = sexp_cons(sexp_cadr(obj), sv); */ +/* return set_vars(e, formals, sexp_caddr(obj), sv); */ +/* } */ +/* } */ +/* } */ +/* while (sexp_pairp(obj)) { */ +/* sv = set_vars(e, formals, sexp_car(obj), sv); */ +/* obj = sexp_cdr(obj); */ +/* } */ +/* } */ +/* return sv; */ +/* } */ + +/* sexp analyze_lambda (sexp name, sexp formals, sexp body, */ +/* sexp *bc, sexp_uint_t *i, sexp e, */ +/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, */ +/* int tailp) { */ +/* sexp obj, ls, flat_formals, fv2, e2; */ +/* int k; */ +/* flat_formals = sexp_flatten_dot(formals); */ +/* fv2 = free_vars(e, flat_formals, body, SEXP_NULL); */ +/* e2 = extend_env(e, flat_formals, -4); */ +/* /\* compile the body with respect to the new params *\/ */ +/* obj = compile(flat_formals, body, e2, fv2, sv, 0); */ +/* if (sexp_exceptionp(obj)) return obj; */ +/* if (sexp_nullp(fv2)) { */ +/* /\* no variables to close over, fixed procedure *\/ */ +/* emit_push(bc, i, */ +/* sexp_make_procedure(sexp_make_integer((sexp_listp(formals) */ +/* ? 0 : 1)), */ +/* sexp_length(formals), */ +/* obj, */ +/* sexp_make_vector(sexp_make_integer(0), */ +/* SEXP_UNDEF))); */ +/* (*d)++; */ +/* } else { */ +/* /\* push the closed vars *\/ */ +/* emit_push(bc, i, SEXP_UNDEF); */ +/* emit_push(bc, i, sexp_length(fv2)); */ +/* emit(bc, i, OP_MAKE_VECTOR); */ +/* (*d)++; */ +/* for (ls=fv2, k=0; sexp_pairp(ls); ls=sexp_cdr(ls), k++) { */ +/* analyze_var_ref(sexp_car(ls), bc, i, e, params, fv, SEXP_NULL, d); */ +/* emit_push(bc, i, sexp_make_integer(k)); */ +/* emit(bc, i, OP_STACK_REF); */ +/* emit_word(bc, i, 3); */ +/* emit(bc, i, OP_VECTOR_SET); */ +/* emit(bc, i, OP_DROP); */ +/* (*d)--; */ +/* } */ +/* /\* push the additional procedure info and make the closure *\/ */ +/* emit_push(bc, i, obj); */ +/* emit_push(bc, i, sexp_length(formals)); */ +/* emit_push(bc, i, sexp_make_integer(sexp_listp(formals) ? 0 : 1)); */ +/* emit(bc, i, OP_MAKE_PROCEDURE); */ +/* } */ +/* return SEXP_TRUE; */ +/* } */ + sexp make_param_list(sexp_uint_t i) { sexp res = SEXP_NULL; char sym[2]="a"; @@ -656,92 +1097,93 @@ sexp make_param_list(sexp_uint_t i) { } sexp make_opcode_procedure(sexp op, sexp_uint_t i, sexp e) { - sexp bc, params, res; - sexp_uint_t pos=0, d=0; - if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) - return sexp_opcode_proc(op); - bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE); - params = make_param_list(i); - e = extend_env(e, params, -4); - sexp_bytecode_length(bc) = INIT_BCODE_SIZE; - analyze_opcode(op, sexp_cons(op, params), &bc, &pos, e, params, - SEXP_NULL, SEXP_NULL, &d, 0); - emit(&bc, &pos, OP_RET); - shrink_bcode(&bc, pos); - /* disasm(bc); */ - res = sexp_make_procedure(sexp_make_integer(0), sexp_make_integer(i), bc, SEXP_UNDEF); - if (i == sexp_opcode_num_args(op)) - sexp_opcode_proc(op) = res; - return res; +/* sexp bc, params, res; */ +/* sexp_uint_t pos=0, d=0; */ +/* if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) */ +/* return sexp_opcode_proc(op); */ +/* bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE); */ +/* params = make_param_list(i); */ +/* e = extend_env(e, params, SEXP_UNDEF); */ +/* sexp_bytecode_length(bc) = INIT_BCODE_SIZE; */ +/* analyze_opcode(op, sexp_cons(op, params), &bc, &pos, e, params, */ +/* SEXP_NULL, SEXP_NULL, &d, 0); */ +/* emit(&bc, &pos, OP_RET); */ +/* shrink_bcode(&bc, pos); */ +/* /\* disasm(bc); *\/ */ +/* res = sexp_make_procedure(sexp_make_integer(0), sexp_make_integer(i), bc, SEXP_UNDEF); */ +/* if (i == sexp_opcode_num_args(op)) */ +/* sexp_opcode_proc(op) = res; */ +/* return res; */ + return SEXP_UNDEF; } -sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { - sexp_uint_t i=0, j=0, d=0, define_ok=1, core; - sexp bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, - SEXP_BYTECODE); - sexp sv2 = set_vars(e, params, obj, SEXP_NULL), internals=SEXP_NULL, ls; - sexp_bytecode_length(bc) = INIT_BCODE_SIZE; - /* box mutable vars */ - for (ls=params, j=0; sexp_pairp(ls); ls=sexp_cdr(ls), j++) { - if (sexp_list_index(sv2, sexp_car(ls)) >= 0) { - emit_push(&bc, &i, SEXP_NULL); - emit(&bc, &i, OP_STACK_REF); - emit_word(&bc, &i, j+5); - emit(&bc, &i, OP_CONS); - emit(&bc, &i, OP_STACK_SET); - emit_word(&bc, &i, j+5); - emit(&bc, &i, OP_DROP); - } - } - sv = sexp_append(sv2, sv); - /* determine internal defines */ - if (sexp_env_parent(e)) { - for (ls=SEXP_NULL; sexp_pairp(obj); obj=sexp_cdr(obj)) { - core = (sexp_pairp(sexp_car(obj)) && sexp_symbolp(sexp_caar(obj)) - ? core_code(e, sexp_caar(obj)) : 0); - if (core == CORE_BEGIN) { - obj = sexp_cons(sexp_car(obj), - sexp_append(sexp_cdar(obj), sexp_cdr(obj))); - } else { - if (core == CORE_DEFINE) { - if (! define_ok) - return sexp_compile_error("definition in non-definition context", - sexp_list1(obj)); - internals = sexp_cons(sexp_pairp(sexp_cadar(obj)) - ? sexp_car(sexp_cadar(obj)) : sexp_cadar(obj), - internals); - } else { - define_ok = 0; - } - ls = sexp_cons(sexp_car(obj), ls); - } - } - obj = sexp_reverse(ls); - j = sexp_unbox_integer(sexp_length(internals)); - if (sexp_pairp(internals)) { - e = extend_env(e, internals, d+j); - /* XXXX params extended, need to recompute set-vars */ - params = sexp_append(internals, params); - for (ls=internals; sexp_pairp(ls); ls=sexp_cdr(ls)) - emit_push(&bc, &i, SEXP_UNDEF); - d+=j; - } - } - /* analyze body sequence */ - analyze_sequence(obj, &bc, &i, e, params, fv, sv, &d, - (! done_p) && (! sexp_pairp(internals))); - if (sexp_pairp(internals)) { - emit(&bc, &i, OP_STACK_SET); - emit_word(&bc, &i, j+1); - for ( ; j>0; j--) - emit(&bc, &i, OP_DROP); - } - emit(&bc, &i, done_p ? OP_DONE : OP_RET); - shrink_bcode(&bc, i); - print_bytecode(bc); - disasm(bc); - return bc; -} +/* sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { */ +/* sexp_uint_t i=0, j=0, d=0, define_ok=1, core; */ +/* sexp bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, */ +/* SEXP_BYTECODE); */ +/* sexp sv2 = set_vars(e, params, obj, SEXP_NULL), internals=SEXP_NULL, ls; */ +/* sexp_bytecode_length(bc) = INIT_BCODE_SIZE; */ +/* /\* box mutable vars *\/ */ +/* for (ls=params, j=0; sexp_pairp(ls); ls=sexp_cdr(ls), j++) { */ +/* if (sexp_list_index(sv2, sexp_car(ls)) >= 0) { */ +/* emit_push(&bc, &i, SEXP_NULL); */ +/* emit(&bc, &i, OP_STACK_REF); */ +/* emit_word(&bc, &i, j+5); */ +/* emit(&bc, &i, OP_CONS); */ +/* emit(&bc, &i, OP_STACK_SET); */ +/* emit_word(&bc, &i, j+5); */ +/* emit(&bc, &i, OP_DROP); */ +/* } */ +/* } */ +/* sv = sexp_append(sv2, sv); */ +/* /\* determine internal defines *\/ */ +/* if (sexp_env_parent(e)) { */ +/* for (ls=SEXP_NULL; sexp_pairp(obj); obj=sexp_cdr(obj)) { */ +/* core = (sexp_pairp(sexp_car(obj)) && sexp_symbolp(sexp_caar(obj)) */ +/* ? core_code(e, sexp_caar(obj)) : 0); */ +/* if (core == CORE_BEGIN) { */ +/* obj = sexp_cons(sexp_car(obj), */ +/* sexp_append(sexp_cdar(obj), sexp_cdr(obj))); */ +/* } else { */ +/* if (core == CORE_DEFINE) { */ +/* if (! define_ok) */ +/* return sexp_compile_error("definition in non-definition context", */ +/* sexp_list1(obj)); */ +/* internals = sexp_cons(sexp_pairp(sexp_cadar(obj)) */ +/* ? sexp_car(sexp_cadar(obj)) : sexp_cadar(obj), */ +/* internals); */ +/* } else { */ +/* define_ok = 0; */ +/* } */ +/* ls = sexp_cons(sexp_car(obj), ls); */ +/* } */ +/* } */ +/* obj = sexp_reverse(ls); */ +/* j = sexp_unbox_integer(sexp_length(internals)); */ +/* if (sexp_pairp(internals)) { */ +/* e = extend_env(e, internals, d+j); */ +/* /\* XXXX params extended, need to recompute set-vars *\/ */ +/* params = sexp_append(internals, params); */ +/* for (ls=internals; sexp_pairp(ls); ls=sexp_cdr(ls)) */ +/* emit_push(&bc, &i, SEXP_UNDEF); */ +/* d+=j; */ +/* } */ +/* } */ +/* /\* analyze body sequence *\/ */ +/* analyze_sequence(obj, &bc, &i, e, params, fv, sv, &d, */ +/* (! done_p) && (! sexp_pairp(internals))); */ +/* if (sexp_pairp(internals)) { */ +/* emit(&bc, &i, OP_STACK_SET); */ +/* emit_word(&bc, &i, j+1); */ +/* for ( ; j>0; j--) */ +/* emit(&bc, &i, OP_DROP); */ +/* } */ +/* emit(&bc, &i, done_p ? OP_DONE : OP_RET); */ +/* shrink_bcode(&bc, i); */ +/* print_bytecode(bc); */ +/* disasm(bc); */ +/* return bc; */ +/* } */ /*********************** the virtual machine **************************/ @@ -772,9 +1214,9 @@ sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) { #define sexp_raise(msg, args) do {stack[top]=sexp_compile_error(msg, args); top++; goto call_error_handler;} while (0) -sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { +sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { unsigned char *ip=sexp_bytecode_data(bc); - sexp cp=SEXP_UNDEF, tmp1, tmp2; + sexp tmp1, tmp2; sexp_sint_t i, j, k; loop: @@ -784,14 +1226,14 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { case OP_NOOP: fprintf(stderr, "noop\n"); break; - case OP_STACK_REF: + case OP_LOCAL_REF: /* fprintf(stderr, "STACK-REF[%ld - %ld = %ld]\n", top, */ /* (sexp_sint_t) ((sexp*)ip)[0], top - (sexp_sint_t) ((sexp*)ip)[0]); */ stack[top] = stack[top - (sexp_sint_t) ((sexp*)ip)[0]]; ip += sizeof(sexp); top++; break; - case OP_STACK_SET: + case OP_LOCAL_SET: /* fprintf(stderr, "STACK-SET[%ld - %ld = %ld]\n", top, */ /* (sexp_sint_t) ((sexp*)ip)[0], top - (sexp_sint_t) ((sexp*)ip)[0]); */ stack[top - (sexp_sint_t) ((sexp*)ip)[0]] = _ARG1; @@ -1114,13 +1556,13 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { break; case OP_JUMP_UNLESS: if (stack[--top] == SEXP_FALSE) { - ip += ((signed char*)ip)[0]; + ip += ((sexp_uint_t*)ip)[0]; } else { ip++; } break; case OP_JUMP: - ip += ((signed char*)ip)[0]; + ip += ((sexp_uint_t*)ip)[0]; break; case OP_DISPLAY: if (sexp_stringp(_ARG1)) { @@ -1187,14 +1629,14 @@ sexp sexp_close_port (sexp port) { } sexp sexp_load (sexp source) { - sexp obj, res, *stack = (sexp*) sexp_alloc(sizeof(sexp)*INIT_STACK_SIZE); + sexp obj, res, context = sexp_new_context(NULL); int closep = 0; if (sexp_stringp(source)) { source = sexp_open_input_file(source); closep = 1; } while ((obj=sexp_read(source)) != (sexp) SEXP_EOF) { - res = eval_in_stack(obj, interaction_environment, stack, 0); + res = eval_in_context(obj, interaction_environment, context); if (sexp_exceptionp(res)) goto done; } res = SEXP_UNDEF; @@ -1291,7 +1733,7 @@ _PARAM("interaction-environment", (sexp)&interaction_environment, SEXP_ENV), #undef _PARAM }; -sexp make_standard_env() { +sexp make_standard_env () { sexp_uint_t i; sexp e = sexp_alloc_type(env, SEXP_ENV); sexp_env_parent(e) = NULL; @@ -1305,22 +1747,46 @@ sexp make_standard_env() { /************************** eval interface ****************************/ -sexp eval_in_stack(sexp obj, sexp e, sexp* stack, sexp_sint_t top) { - sexp bc; - bc = compile(SEXP_NULL, sexp_cons(obj, SEXP_NULL), e, SEXP_NULL, SEXP_NULL, 1); - return vm(bc, e, stack, top); +/* args ... n ret-ip ret-cp */ +sexp apply(sexp proc, sexp args, sexp env, sexp context) { + sexp *stack = sexp_context_stack(context), ls; + sexp_sint_t top=0; + for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls)) + stack[top++] = sexp_car(ls); + stack[top] = sexp_make_integer(top); + top++; + stack[top++] + = sexp_make_integer(sexp_bytecode_data(sexp_procedure_code(final_resumer))); + stack[top++] = sexp_make_vector(0, SEXP_UNDEF); + return + vm(sexp_procedure_code(proc), sexp_procedure_vars(proc), env, stack, top); } -sexp eval(sexp obj, sexp e) { - sexp* stack = (sexp*) sexp_alloc(sizeof(sexp) * INIT_STACK_SIZE); - sexp res = eval_in_stack(obj, e, stack, 0); - sexp_free(stack); +sexp compile (sexp x, sexp env, sexp context) { + sexp ast, ctx; + analyze_bind(ast, x, env); + free_vars(ast, SEXP_NULL); /* should return SEXP_NULL */ + ctx = sexp_new_context(sexp_context_stack(context)); + compile_one(ast, ctx); + return sexp_make_procedure(sexp_make_integer(0), + sexp_make_integer(0), + finalize_bytecode(ctx), + sexp_make_vector(0, SEXP_UNDEF)); +} + +sexp eval_in_context (sexp obj, sexp env, sexp context) { + sexp thunk = compile(obj, env, context); + return apply(thunk, SEXP_NULL, env, context); +} + +sexp eval (sexp obj, sexp env) { + sexp context = sexp_new_context(NULL); + sexp res = eval_in_context(obj, env, context); return res; } -void scheme_init() { - sexp bc; - sexp_uint_t i=0; +void scheme_init () { + sexp context; if (! scheme_initialized_p) { scheme_initialized_p = 1; sexp_init(); @@ -1328,14 +1794,16 @@ void scheme_init() { cur_output_port = sexp_make_output_port(stdout); cur_error_port = sexp_make_output_port(stderr); the_compile_error_symbol = sexp_intern("compile-error"); - bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+16, SEXP_BYTECODE); - sexp_bytecode_length(bc) = 16; - emit(&bc, &i, OP_RESUMECC); - continuation_resumer = (sexp) bc; + context = sexp_new_context(NULL); + emit(OP_RESUMECC, context); + continuation_resumer = finalize_bytecode(context); + context = sexp_extend_context(context, NULL); + emit(OP_DONE, context); + final_resumer = finalize_bytecode(context); } } -void repl (sexp e, sexp *stack) { +void repl (sexp env, sexp context) { sexp obj, res; while (1) { sexp_write_string("> ", cur_output_port); @@ -1343,7 +1811,7 @@ void repl (sexp e, sexp *stack) { obj = sexp_read(cur_input_port); if (obj == SEXP_EOF) break; - res = eval_in_stack(obj, e, stack, 0); + res = eval_in_context(obj, env, context); if (res != SEXP_UNDEF) { sexp_write(res, cur_output_port); sexp_write_char('\n', cur_output_port); @@ -1352,21 +1820,22 @@ void repl (sexp e, sexp *stack) { } int main (int argc, char **argv) { - sexp bc, e, obj, res, *stack, err_handler, err_handler_sym; + sexp bc, e, obj, res, *stack, context, err_handler, err_handler_sym; sexp_uint_t i, quit=0, init_loaded=0; scheme_init(); - stack = (sexp*) sexp_alloc(sizeof(sexp) * INIT_STACK_SIZE); +/* stack = (sexp*) sexp_alloc(sizeof(sexp) * INIT_STACK_SIZE); */ e = make_standard_env(); interaction_environment = e; - bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+16, SEXP_BYTECODE); - sexp_bytecode_length(bc) = 16; - i = 0; - emit_push(&bc, &i, SEXP_UNDEF); - emit(&bc, &i, OP_DONE); +/* bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+16, SEXP_BYTECODE); */ +/* sexp_bytecode_length(bc) = 16; */ +/* i = 0; */ + context = sexp_new_context(NULL); + emit_push(SEXP_UNDEF, context); + emit(OP_DONE, context); err_handler = sexp_make_procedure(sexp_make_integer(0), sexp_make_integer(0), - bc, + finalize_bytecode(context), sexp_make_vector(0, SEXP_UNDEF)); err_handler_sym = sexp_intern("*error-handler*"); env_define(e, err_handler_sym, err_handler); @@ -1382,7 +1851,7 @@ int main (int argc, char **argv) { init_loaded = 1; } obj = sexp_read_from_string(argv[i+1]); - res = eval_in_stack(obj, e, stack, 0); + res = eval_in_context(obj, e, context); if (argv[i][1] == 'p') { sexp_write(res, cur_output_port); sexp_write_char('\n', cur_output_port); @@ -1405,7 +1874,7 @@ int main (int argc, char **argv) { for ( ; i < argc; i++) sexp_load(sexp_make_string(argv[i])); else - repl(e, stack); + repl(e, context); } return 0; } diff --git a/eval.h b/eval.h index d20794d5..3ce55f52 100644 --- a/eval.h +++ b/eval.h @@ -70,8 +70,10 @@ enum opcode_names { OP_RET, OP_DONE, OP_PARAMETER, - OP_STACK_REF, - OP_STACK_SET, +/* OP_STACK_REF, */ +/* OP_STACK_SET, */ + OP_LOCAL_REF, + OP_LOCAL_SET, OP_CLOSURE_REF, OP_VECTOR_REF, OP_VECTOR_SET, @@ -122,26 +124,26 @@ enum opcode_names { /**************************** prototypes ******************************/ -sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p); +/* sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p); */ -sexp analyze_app(sexp obj, sexp *bc, sexp_uint_t *i, - sexp e, sexp params, sexp fv, sexp sv, - sexp_uint_t *d, int tailp); -sexp analyze_lambda(sexp name, sexp formals, sexp body, - sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); -void analyze_var_ref(sexp name, sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d); -sexp analyze_opcode(sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); -sexp analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); -sexp analyze_sequence(sexp ls, sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); -sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top); +/* sexp analyze_app(sexp obj, sexp *bc, sexp_uint_t *i, */ +/* sexp e, sexp params, sexp fv, sexp sv, */ +/* sexp_uint_t *d, int tailp); */ +/* sexp analyze_lambda(sexp name, sexp formals, sexp body, */ +/* sexp *bc, sexp_uint_t *i, sexp e, */ +/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); */ +/* void analyze_var_ref(sexp name, sexp *bc, sexp_uint_t *i, sexp e, */ +/* sexp params, sexp fv, sexp sv, sexp_uint_t *d); */ +/* sexp analyze_opcode(sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, */ +/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); */ +/* sexp analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, */ +/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); */ +/* sexp analyze_sequence(sexp ls, sexp *bc, sexp_uint_t *i, sexp e, */ +/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); */ +/* sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top); */ -sexp eval_in_stack(sexp expr, sexp e, sexp* stack, sexp_sint_t top); -sexp eval(sexp expr, sexp e); +sexp eval_in_context(sexp expr, sexp env, sexp context); +sexp eval(sexp expr, sexp env); #endif /* ! SEXP_EVAL_H */ diff --git a/sexp.c b/sexp.c index d01b2d50..4c90260d 100644 --- a/sexp.c +++ b/sexp.c @@ -54,7 +54,7 @@ static int symbol_table_count = 0; sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag) { sexp res = (sexp) sexp_alloc(size); if (! res) - errx(EX_OSERR, "out of memory: couldn't allocate %d bytes for %d", + errx(EX_OSERR, "out of memory: couldn't allocate %ld bytes for %ld", size ,tag); res->tag = tag; return res; @@ -65,7 +65,7 @@ void sexp_deep_free (sexp obj) { int len, i; sexp *elts; if (sexp_pointerp(obj)) { - switch (obj->tag) { + switch (sexp_pointer_tag(obj)) { case SEXP_PAIR: sexp_deep_free(sexp_car(obj)); sexp_deep_free(sexp_cdr(obj)); @@ -191,6 +191,14 @@ sexp sexp_lset_diff(sexp a, sexp b) { return res; } +/* sexp sexp_lset_union(sexp a, sexp b) { */ +/* if (! sexp_pairp(b)) */ +/* return a; */ +/* for ( ; sexp_pairp(a); a=sexp_cdr(a)) */ +/* sexp_insert(sexp_car(a), b); */ +/* return b; */ +/* } */ + sexp sexp_reverse(sexp ls) { sexp res = SEXP_NULL; for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) @@ -421,7 +429,7 @@ void sexp_write (sexp obj, sexp out) { if (! obj) { sexp_write_string("#", out); } else if (sexp_pointerp(obj)) { - switch (sexp_tag(obj)) { + switch (sexp_pointer_tag(obj)) { case SEXP_PAIR: sexp_write_char('(', out); sexp_write(sexp_car(obj), out); diff --git a/sexp.h b/sexp.h index 9bc01269..84c83a5e 100644 --- a/sexp.h +++ b/sexp.h @@ -66,6 +66,7 @@ enum sexp_types { SEXP_SET, SEXP_SEQ, SEXP_LIT, + SEXP_CONTEXT, }; typedef unsigned long sexp_uint_t; @@ -104,7 +105,7 @@ struct sexp_struct { /* runtime types */ struct { char flags; - sexp parent, bindings; + sexp parent, lambda, bindings; } env; struct { sexp_uint_t length; @@ -133,7 +134,7 @@ struct sexp_struct { } core; /* ast types */ struct { - sexp name, params, flags, body, fv, sv; + sexp name, params, locals, flags, body, fv, sv; } lambda; struct { sexp test, pass, fail; @@ -142,14 +143,19 @@ struct sexp_struct { sexp var, value; } set; struct { - sexp var, value; + sexp name, loc; } ref; struct { sexp ls; } seq; struct { - sexp x; + sexp value; } lit; + /* compiler state */ + struct { + sexp bc, lambda, offsets, *stack; + sexp_uint_t pos, depth, tailp; + } context; } value; }; @@ -162,14 +168,18 @@ struct sexp_struct { #define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<tag) +#define sexp_pointer_tag(x) ((x)->tag) -#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_tag(x) == (t))) +#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)) @@ -196,8 +206,17 @@ struct sexp_struct { #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) @@ -211,11 +230,13 @@ struct sexp_struct { #define sexp_integer_to_flonum(x) (sexp_make_flonum(sexp_unbox_integer(x))) +/*************************** 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_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) @@ -250,10 +271,15 @@ struct sexp_struct { #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) @@ -271,6 +297,81 @@ struct sexp_struct { #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_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_loc(x) ((x)->value.ref.loc) + +#define sexp_seq_ls(x) ((x)->value.seq.ls) + +#define sexp_lit_value(x) ((x)->value.lit.value) + +#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_pos(x) ((x)->value.context.pos) +#define sexp_context_lambda(x) ((x)->value.context.lambda) +#define sexp_context_offsets(x) ((x)->value.context.offsets) +#define sexp_context_tailp(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_mod(a, b) (sexp_make_integer(sexp_unbox_integer(a) % sexp_unbox_integer(b))) + +#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_list_index((ls), (x)) >= 0) ? (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 ****************************/ + #if USE_STRING_STREAMS #if SEXP_BSD #define fmemopen(str, len, m) funopen(sexp_vector(3, (sexp)str, (sexp)len, (sexp)0), sstream_read, sstream_write, sstream_seek, sstream_close) @@ -293,47 +394,14 @@ void sexp_write_string(sexp str, sexp port); void sexp_printf(sexp port, sexp fmt, ...); #endif -#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_mod(a, b) (sexp_make_integer(sexp_unbox_integer(a) % sexp_unbox_integer(b))) - -#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_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_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 ****************************/ sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag); sexp sexp_cons(sexp head, sexp tail); int sexp_listp(sexp obj); int sexp_list_index(sexp ls, sexp elt); sexp sexp_lset_diff(sexp a, sexp b); +/* sexp sexp_lset_union(sexp a, sexp b); */ sexp sexp_reverse(sexp ls); sexp sexp_nreverse(sexp ls); sexp sexp_append(sexp a, sexp b);