diff --git a/.hgignore b/.hgignore index dce70adb..51566e20 100644 --- a/.hgignore +++ b/.hgignore @@ -12,7 +12,6 @@ junk* *.tar.bz2 *.log *.err -*.res *.out gc gc6.8 diff --git a/eval.c b/eval.c index d1c6607b..601e3940 100644 --- a/eval.c +++ b/eval.c @@ -103,17 +103,19 @@ static sexp sexp_flatten_dot (sexp ls) { return sexp_nreverse(sexp_reverse_flatten_dot(ls)); } -static int sexp_param_index (sexp params, sexp name) { - int i=0; - while (sexp_pairp(params)) { - if (sexp_car(params) == name) +static int sexp_param_index (sexp lambda, sexp name) { + sexp ls = sexp_lambda_params(lambda); + int i = 0; + for (i=0; sexp_pairp(ls); ls=sexp_cdr(ls), i++) + if (sexp_car(ls) == name) return i; - params = sexp_cdr(params); - i++; - } - if (params == name) + if (ls == name) return i; - return -1; + ls = sexp_lambda_locals(lambda); + for (i=-1; sexp_pairp(ls); ls=sexp_cdr(ls), i--) + if (sexp_car(ls) == name) + return i; + return -10000; } /************************* bytecode utilities ***************************/ @@ -150,8 +152,10 @@ static void emit(char c, sexp context) { } static void emit_word(sexp_uint_t val, sexp context) { + unsigned char *data; expand_bcode(context, sizeof(sexp)); - *((sexp_uint_t*)(&(sexp_bytecode_data(sexp_context_bc(context))[sexp_context_pos(context)]))) = val; + data = sexp_bytecode_data(sexp_context_bc(context)); + *((sexp_uint_t*)(&(data[sexp_context_pos(context)]))) = val; sexp_context_pos(context) += sizeof(sexp); } @@ -324,6 +328,7 @@ static sexp analyze_lambda (sexp x, sexp context) { sexp_lambda_params(res) = sexp_cadr(x); sexp_lambda_fv(res) = SEXP_NULL; sexp_lambda_sv(res) = SEXP_NULL; + sexp_lambda_locals(res) = SEXP_NULL; context = sexp_child_context(context, res); sexp_context_env(context) = extend_env(sexp_context_env(context), @@ -514,12 +519,10 @@ static void generate_non_global_ref (sexp name, sexp cell, sexp lambda, sexp fv, sexp context, int unboxp) { sexp_uint_t i; sexp loc = sexp_cdr(cell); - sexp_debug("cell: ", cell); if (loc == lambda && sexp_lambdap(lambda)) { /* local ref */ - sexp_debug("params: ", sexp_lambda_params(lambda)); emit(OP_LOCAL_REF, context); - emit_word(sexp_param_index(sexp_lambda_params(lambda), name), context); + emit_word(sexp_param_index(lambda, name), context); } else { /* closure ref */ for (i=0; sexp_pairp(fv); fv=sexp_cdr(fv), i++) @@ -642,9 +645,12 @@ static void generate_lambda (sexp lambda, sexp context) { fv = sexp_lambda_fv(lambda); ctx = sexp_new_context(sexp_context_stack(context)); sexp_context_lambda(ctx) = lambda; + /* allocate space for local vars */ + for (ls=sexp_lambda_locals(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) + emit_push(SEXP_UNDEF, ctx); /* box mutable vars */ for (ls=sexp_lambda_sv(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) { - k = sexp_param_index(sexp_lambda_params(lambda), sexp_car(ls)); + k = sexp_param_index(lambda, sexp_car(ls)); if (k >= 0) { emit(OP_LOCAL_REF, ctx); emit_word(k, ctx); @@ -710,7 +716,7 @@ static sexp diff_free_vars (sexp fv, sexp params) { /* sexp_debug("diff-free-vars: ", fv); */ /* sexp_debug("params: ", params); */ for ( ; sexp_pairp(fv); fv=sexp_cdr(fv)) - if (sexp_param_index(params, sexp_ref_name(sexp_car(fv))) < 0) + if (sexp_memq(sexp_ref_name(sexp_car(fv)), params) == SEXP_FALSE) sexp_push(res, sexp_car(fv)); /* sexp_debug(" => ", res); */ return res; @@ -720,7 +726,7 @@ static sexp free_vars (sexp x, sexp fv) { sexp fv1, fv2; if (sexp_lambdap(x)) { fv1 = free_vars(sexp_lambda_body(x), SEXP_NULL); - fv2 = diff_free_vars(fv1, sexp_lambda_params(x)); + fv2 = diff_free_vars(fv1, sexp_flatten_dot(sexp_lambda_params(x))); sexp_lambda_fv(x) = fv2; fv = union_free_vars(fv2, fv); } else if (sexp_pairp(x)) { @@ -763,6 +769,7 @@ static sexp make_opcode_procedure (sexp op, sexp_uint_t i, sexp env, sexp_lambda_params(lambda) = params; sexp_lambda_fv(lambda) = SEXP_NULL; sexp_lambda_sv(lambda) = SEXP_NULL; + sexp_lambda_locals(lambda) = SEXP_NULL; sexp_context_lambda(context) = lambda; sexp_context_top(context) = top; env = extend_env(env, params, lambda); @@ -1396,6 +1403,10 @@ sexp compile (sexp x, sexp context) { sexp eval_in_context (sexp obj, sexp context) { sexp thunk = compile(obj, context); + if (sexp_exceptionp(thunk)) { + sexp_print_exception(obj, cur_error_port); + return SEXP_UNDEF; + } return apply(thunk, SEXP_NULL, context); } @@ -1431,10 +1442,14 @@ void repl (sexp context) { obj = sexp_read(cur_input_port); if (obj == SEXP_EOF) break; - res = eval_in_context(obj, context); - if (res != SEXP_UNDEF) { - sexp_write(res, cur_output_port); - sexp_write_char('\n', cur_output_port); + if (sexp_exceptionp(obj)) { + sexp_print_exception(obj, cur_error_port); + } else { + res = eval_in_context(obj, context); + if (res != SEXP_UNDEF) { + sexp_write(res, cur_output_port); + sexp_write_char('\n', cur_output_port); + } } } } diff --git a/sexp.c b/sexp.c index 87b4725f..bd9ef1c1 100644 --- a/sexp.c +++ b/sexp.c @@ -36,7 +36,9 @@ static char sexp_separators[] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, /* x5_ */ }; -#define digit_value(c) (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10)) +static int digit_value (c) { + return (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10)); +} static int is_separator(int c) { /* return (!((c-9)&(~3))) | (~(c^4)); */ @@ -133,9 +135,12 @@ sexp sexp_print_exception(sexp exn, sexp out) { } static sexp sexp_read_error(char *message, sexp irritants, sexp port) { - return sexp_make_exception(the_read_error_symbol, sexp_make_string(message), + sexp name = (sexp_port_name(port) + ? sexp_make_string(sexp_port_name(port)) : SEXP_FALSE); + return sexp_make_exception(the_read_error_symbol, + sexp_make_string(message), irritants, - sexp_make_string(sexp_port_name(port)), + name, sexp_make_integer(sexp_port_line(port))); } @@ -382,6 +387,7 @@ sexp sexp_get_output_string(sexp port) { sexp sexp_make_input_port(FILE* in) { sexp p = sexp_alloc_type(port, SEXP_IPORT); sexp_port_stream(p) = in; + sexp_port_name(p) = NULL; sexp_port_line(p) = 0; return p; } @@ -389,6 +395,7 @@ sexp sexp_make_input_port(FILE* in) { sexp sexp_make_output_port(FILE* out) { sexp p = sexp_alloc_type(port, SEXP_OPORT); sexp_port_stream(p) = out; + sexp_port_name(p) = NULL; sexp_port_line(p) = 0; return p; } @@ -480,7 +487,12 @@ void sexp_write (sexp obj, sexp out) { } else if (sexp_integerp(obj)) { sexp_printf(out, "%ld", sexp_unbox_integer(obj)); } else if (sexp_charp(obj)) { - if ((33 <= sexp_unbox_character(obj)) && (sexp_unbox_character(obj) < 127)) + if (obj == sexp_make_character(' ')) + sexp_write_string("#\\space", out); + else if (obj == sexp_make_character('\n')) + sexp_write_string("#\\newline", out); + else if ((33 <= sexp_unbox_character(obj)) + && (sexp_unbox_character(obj) < 127)) sexp_printf(out, "#\\%c", sexp_unbox_character(obj)); else sexp_printf(out, "#\\x%02d", sexp_unbox_character(obj)); @@ -700,49 +712,59 @@ sexp sexp_read_raw (sexp in) { res = sexp_read_number(in, 10); break; case 'x': res = sexp_read_number(in, 16); break; -/* case 'e': */ -/* case 'i': */ + case 'e': + res = sexp_read(in); + if (sexp_flonump(res)) + res = sexp_make_integer((sexp_sint_t)sexp_flonum_value(res)); + break; + case 'i': + res = sexp_read(in); + if (sexp_integerp(res)) + res = sexp_make_flonum(sexp_unbox_integer(res)); + break; case 'f': case 't': c2 = sexp_read_char(in); if (c2 == EOF || is_separator(c2)) { res = (c1 == 't' ? SEXP_TRUE : SEXP_FALSE); + sexp_push_char(c2, in); } else { - return sexp_read_error("invalid syntax #%c%c", - sexp_list2(sexp_make_character(c1), - sexp_make_character(c2)), - in); + res = sexp_read_error("invalid syntax #%c%c", + sexp_list2(sexp_make_character(c1), + sexp_make_character(c2)), + in); } - sexp_push_char(c2, in); break; case ';': sexp_read_raw(in); goto scan_loop; case '\\': c1 = sexp_read_char(in); - c2 = sexp_read_char(in); - if (c2 == EOF || is_separator(c2)) { - sexp_push_char(c2, in); + str = sexp_read_symbol(in, c1); + if (str[0] == '\0') + res = + sexp_read_error("unexpected end of character literal", SEXP_NULL, in); + if (str[1] == '\0') { res = sexp_make_character(c1); - } else if ((c1 == 'x' || c1 == 'X') && isxdigit(c2)) { - c1 = sexp_read_char(in); - res = sexp_make_character(16 * digit_value(c2) + digit_value(c1)); + } else if ((c1 == 'x' || c1 == 'X') && + isxdigit(str[0]) && isxdigit(str[1]) && str[2] == '\0') { + res = sexp_make_character(16 * digit_value(c1) + digit_value(str[1])); } else { - str = sexp_read_symbol(in, c1); if (strcasecmp(str, "space") == 0) res = sexp_make_character(' '); else if (strcasecmp(str, "newline") == 0) - res = sexp_make_character('\r'); + res = sexp_make_character('\n'); else if (strcasecmp(str, "return") == 0) res = sexp_make_character('\r'); else if (strcasecmp(str, "tab") == 0) res = sexp_make_character('\t'); else { - return sexp_read_error("unknown character name", - sexp_list1(sexp_make_string(str)), - in); + res = sexp_read_error("unknown character name", + sexp_list1(sexp_make_string(str)), + in); } } + sexp_free(str); break; case '(': sexp_push_char(c1, in); @@ -750,17 +772,17 @@ sexp sexp_read_raw (sexp in) { if (! sexp_listp(res)) { if (! sexp_exceptionp(res)) { sexp_deep_free(res); - return sexp_read_error("dotted list not allowed in vector syntax", - SEXP_NULL, - in); + res = sexp_read_error("dotted list not allowed in vector syntax", + SEXP_NULL, + in); } } else { res = sexp_list_to_vector(res); } break; default: - return sexp_read_error("invalid # syntax", - sexp_list1(sexp_make_character(c1)), in); + res = sexp_read_error("invalid # syntax", + sexp_list1(sexp_make_character(c1)), in); } break; case '.': diff --git a/tests/test06-mutation.res b/tests/test03-nested-closure.res similarity index 100% rename from tests/test06-mutation.res rename to tests/test03-nested-closure.res diff --git a/tests/test03-nested-closure.scm b/tests/test03-nested-closure.scm new file mode 100644 index 00000000..6656bd4e --- /dev/null +++ b/tests/test03-nested-closure.scm @@ -0,0 +1,8 @@ + +((lambda (a b) + ((lambda (c d e) + (write (+ e (* c 1000) (* a 100) (* b 10) d)) + (newline)) + (- a 2) (+ b 2) 10000)) + 3 5) + diff --git a/tests/test05-internal-define.res b/tests/test05-internal-define.res new file mode 100644 index 00000000..4edae4cc --- /dev/null +++ b/tests/test05-internal-define.res @@ -0,0 +1 @@ +1000 1003 diff --git a/tests/test05-internal-define.scm b/tests/test05-internal-define.scm new file mode 100644 index 00000000..a5576a63 --- /dev/null +++ b/tests/test05-internal-define.scm @@ -0,0 +1,8 @@ + +(let ((a 1000)) + (define b (+ a 3)) + (write a) + (display " ") + (write b) + (newline)) + diff --git a/tests/test05-letrec.res b/tests/test06-letrec.res similarity index 100% rename from tests/test05-letrec.res rename to tests/test06-letrec.res diff --git a/tests/test05-letrec.scm b/tests/test06-letrec.scm similarity index 100% rename from tests/test05-letrec.scm rename to tests/test06-letrec.scm diff --git a/tests/test07-mutation.res b/tests/test07-mutation.res new file mode 100644 index 00000000..c97c8394 --- /dev/null +++ b/tests/test07-mutation.res @@ -0,0 +1 @@ +11357 diff --git a/tests/test06-mutation.scm b/tests/test07-mutation.scm similarity index 100% rename from tests/test06-mutation.scm rename to tests/test07-mutation.scm diff --git a/tests/test07-callcc.res b/tests/test08-callcc.res similarity index 100% rename from tests/test07-callcc.res rename to tests/test08-callcc.res diff --git a/tests/test07-callcc.scm b/tests/test08-callcc.scm similarity index 100% rename from tests/test07-callcc.scm rename to tests/test08-callcc.scm