From 7eae77d0f93340c760e636aeda4f8dad3d19c88f Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 26 Dec 2009 16:21:37 +0900 Subject: [PATCH] converting make-exception to a primitive opcode instead of a foreign function, since foreign functions will always raise any exception they return (hence the double catch in issue #15). also restoring the original exception handler when an exception is raised in with-exception-handler, so that exceptions within the handler itself don't cause an infinite loop. this may change, as with-exception-handler is meant to be a low-level tool on which to build either guard or condition-case, but until then the restoring is necessary. --- eval.c | 4 ++++ include/chibi/eval.h | 1 + lib/init.scm | 5 ++++- opcodes.c | 2 +- opt/debug.c | 4 ++-- 5 files changed, 12 insertions(+), 4 deletions(-) diff --git a/eval.c b/eval.c index 7b7305fc..26f212a3 100644 --- a/eval.c +++ b/eval.c @@ -1581,6 +1581,10 @@ sexp sexp_vm (sexp ctx, sexp proc) { _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2); top--; break; + case SEXP_OP_MAKE_EXCEPTION: + _ARG5 = sexp_make_exception(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + break; case SEXP_OP_AND: _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE)); top--; diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 22b5f340..8ba7b442 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -76,6 +76,7 @@ enum sexp_opcode_names { SEXP_OP_STRING_LENGTH, SEXP_OP_MAKE_PROCEDURE, SEXP_OP_MAKE_VECTOR, + SEXP_OP_MAKE_EXCEPTION, SEXP_OP_AND, SEXP_OP_NULLP, SEXP_OP_FIXNUMP, diff --git a/lib/init.scm b/lib/init.scm index 8bcc7491..aed24843 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -312,7 +312,10 @@ (define (with-exception-handler handler thunk) (let ((orig-handler (current-exception-handler))) - (current-exception-handler handler) + (current-exception-handler + (lambda (exn) + (current-exception-handler orig-handler) + (handler exn))) (let ((res (thunk))) (current-exception-handler orig-handler) res))) diff --git a/opcodes.c b/opcodes.c index 5d3a36cc..8f9825d9 100644 --- a/opcodes.c +++ b/opcodes.c @@ -48,6 +48,7 @@ _OP(SEXP_OPC_PREDICATE, SEXP_OP_EQ, 2, 0, 0, 0, 0, "eq?", 0, NULL), _OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_CONS, 2, 0, 0, 0, 0, "cons", 0, NULL), _OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_VOID, NULL), _OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_EXCEPTION, 5, 0, 0, 0, 0, "make-exception", 0, NULL), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, 0), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, 0), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, 0), @@ -95,7 +96,6 @@ _FN2OPTP(SEXP_STRING, SEXP_ENV, "load", (sexp)"*interaction-environment*", sexp_ _FN4(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy), _FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception), _FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_func), -_FN5(SEXP_SYMBOL, SEXP_STRING, "make-exception", 0, sexp_make_exception), _FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_make_string), _FN3(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp), _FN3(SEXP_STRING, SEXP_FIXNUM, "substring", 0, sexp_substring), diff --git a/opt/debug.c b/opt/debug.c index 16419d3a..561cd52f 100644 --- a/opt/debug.c +++ b/opt/debug.c @@ -11,8 +11,8 @@ static const char* reverse_opcode_names[] = "JUMP-UNLESS", "JUMP", "PUSH", "DROP", "GLOBAL-REF", "GLOBAL-KNOWN-REF", "STACK-REF", "LOCAL-REF", "LOCAL-SET", "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF", - "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "AND", - "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", + "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", + "MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", "MUL", "DIV", "QUOTIENT", "REMAINDER", "NEGATIVE", "INVERSE",