diff --git a/debug.c b/debug.c index 8ab62646..a9486f2f 100644 --- a/debug.c +++ b/debug.c @@ -3,7 +3,7 @@ /* BSD-style license: http://synthcode.com/license.txt */ static const char* reverse_opcode_names[] = - {"NOOP", "CALL", "APPLY1", "CALLCC", "RESUMECC", "FCALL0", "FCALL1", + {"NOOP", "CALL", "APPLY1", "CALLCC", "RESUMECC", "ERROR", "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", "FCALL7", "FCALLN", "JUMP_UNLESS", "JUMP", "RET", "DONE", "STACK_REF", "STACK_SET", "GLOBAL_REF", "GLOBAL_SET", "CLOSURE_REF", diff --git a/eval.c b/eval.c index bccd0162..4662d054 100644 --- a/eval.c +++ b/eval.c @@ -9,7 +9,7 @@ static int scheme_initialized_p = 0; static sexp cur_input_port, cur_output_port, cur_error_port; -static sexp exception_handler; +static sexp exception_handler_cell; static sexp continuation_resumer; #ifdef USE_DEBUG @@ -206,7 +206,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, case OPC_ACCESSOR: case OPC_GENERIC: if (SEXP_NULLP(SEXP_CDR(obj))) { - errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class); + errx(1, "opcode with no arguments: %s", ((opcode)o1)->name); } else if (SEXP_NULLP(SEXP_CDDR(obj))) { if (((opcode)o1)->op_class == OPC_ARITHMETIC_INV) { analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); @@ -259,7 +259,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, } } else if (SEXP_SYMBOLP(obj)) { analyze_var_ref(obj, bc, i, e, params, fv, sv, d); - } else { + } else { /* literal */ emit_push(bc, i, obj); (*d)++; } @@ -708,6 +708,21 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { top -= 3; stack[top-1] = tmp1; break; + case OP_ERROR: + call_error_handler: + sexp_write_string("ERROR: ", cur_error_port); + sexp_write(stack[top-1], cur_error_port); + sexp_write_string("\n", cur_error_port); + tmp1 = SEXP_CDR(exception_handler_cell); + stack[top-1] = SEXP_UNDEF; + stack[top] = (sexp) 1; + stack[top+1] = sexp_make_integer(ip+4); + stack[top+2] = cp; + top+=3; + bc = sexp_procedure_code(tmp1); + ip = bc->data; + cp = sexp_procedure_vars(tmp1); + break; case OP_FCALL0: stack[top-1]=((sexp_proc0)stack[top-1])(); break; @@ -824,6 +839,7 @@ _OP(OPC_TYPE_PREDICATE, OP_OPORTP, 1, 0, 0, 0, 0, "output-port?"), _OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?"), _OP(OPC_GENERIC, OP_APPLY1, 2, SEXP_PROCEDURE, SEXP_PAIR, 0, 0, "apply1"), _OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation"), +_OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error"), _FN1(SEXP_PAIR, "reverse", sexp_reverse), _FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector), _FN2(0, SEXP_PAIR, "memq", sexp_memq), @@ -900,13 +916,24 @@ void repl (env e, sexp *stack) { } int main (int argc, char **argv) { - sexp obj, res, in, out, *stack; + sexp obj, res, in, out, *stack, err_handler, err_handler_sym; env e; - int i, quit=0; + bytecode bc; + unsigned int i, quit=0; scheme_init(); - e = make_standard_env(); stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE); + e = make_standard_env(); + bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+16); + bc->tag = SEXP_BYTECODE; + bc->len = 16; + i = 0; + emit_push(&bc, &i, (sexp_uint_t) SEXP_UNDEF); + emit(&bc, &i, OP_DONE); + err_handler = sexp_make_procedure((sexp)bc, sexp_make_vector(0, SEXP_UNDEF)); + err_handler_sym = sexp_intern("*error-handler*"); + env_define(e, err_handler_sym, err_handler); + exception_handler_cell = env_cell(e, err_handler_sym); /* parse options */ for (i=1; i < argc && argv[i][0] == '-'; i++) { @@ -927,7 +954,7 @@ int main (int argc, char **argv) { } } - repl(e, stack); + if (! quit) repl(e, stack); return 0; } diff --git a/eval.h b/eval.h index 849e4564..045e3af0 100644 --- a/eval.h +++ b/eval.h @@ -85,6 +85,7 @@ enum opcode_names { OP_APPLY1, OP_CALLCC, OP_RESUMECC, + OP_ERROR, OP_FCALL0, OP_FCALL1, OP_FCALL2, diff --git a/sexp.c b/sexp.c index 497d2cc6..2e9db9f4 100644 --- a/sexp.c +++ b/sexp.c @@ -23,6 +23,7 @@ static sexp the_quote_symbol; static sexp the_quasiquote_symbol; static sexp the_unquote_symbol; static sexp the_unquote_splicing_symbol; +static sexp the_empty_vector; static char sexp_separators[] = { /* 1 2 3 4 5 6 7 8 9 a b c d e f */ @@ -277,9 +278,11 @@ sexp sexp_intern(char *str) { sexp sexp_make_vector(unsigned int len, sexp dflt) { int i; - sexp v = SEXP_NEW(); + sexp v, *x; + if (! len) return the_empty_vector; + v = SEXP_NEW(); if (v == NULL) return SEXP_ERROR; - sexp *x = (void*) SEXP_ALLOC(len*sizeof(sexp)); + x = (void*) SEXP_ALLOC(len*sizeof(sexp)); if (x == NULL) return SEXP_ERROR; for (i=0; i", out); break; case (sexp_uint_t) SEXP_UNDEF: sexp_write_string("#", out); break; + case (sexp_uint_t) SEXP_ERROR: + sexp_write_string("#", out); break; default: sexp_printf(out, "#", obj); } @@ -776,6 +781,10 @@ void sexp_init() { the_quasiquote_symbol = sexp_intern("quasiquote"); the_unquote_symbol = sexp_intern("unquote"); the_unquote_splicing_symbol = sexp_intern("unquote-splicing"); + the_empty_vector = SEXP_NEW(); + the_empty_vector->tag = SEXP_VECTOR; + the_empty_vector->data1 = 0; + the_empty_vector->data2 = 0; } }