reporting calling procedure name for exceptions

This commit is contained in:
Alex Shinn 2009-04-08 11:55:38 +09:00
parent fad4e3976e
commit 820c13e752
4 changed files with 81 additions and 60 deletions

66
eval.c
View file

@ -109,6 +109,7 @@ static void shrink_bcode(sexp context, sexp_uint_t i) {
sexp tmp;
if (sexp_bytecode_length(sexp_context_bc(context)) != i) {
tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) + i, SEXP_BYTECODE);
sexp_bytecode_name(tmp) = SEXP_FALSE;
sexp_bytecode_length(tmp) = i;
sexp_bytecode_literals(tmp)
= sexp_bytecode_literals(sexp_context_bc(context));
@ -126,6 +127,7 @@ static void expand_bcode(sexp context, sexp_uint_t size) {
tmp = sexp_alloc_tagged(sexp_sizeof(bytecode)
+ sexp_bytecode_length(sexp_context_bc(context))*2,
SEXP_BYTECODE);
sexp_bytecode_name(tmp) = SEXP_FALSE;
sexp_bytecode_length(tmp)
= sexp_bytecode_length(sexp_context_bc(context))*2;
sexp_bytecode_literals(tmp)
@ -189,6 +191,7 @@ static sexp sexp_make_synclo (sexp env, sexp fv, sexp expr) {
static sexp sexp_make_lambda(sexp params) {
sexp res = sexp_alloc_type(lambda, SEXP_LAMBDA);
sexp_lambda_name(res) = SEXP_FALSE;
sexp_lambda_params(res) = params;
sexp_lambda_fv(res) = SEXP_NULL;
sexp_lambda_sv(res) = SEXP_NULL;
@ -233,6 +236,7 @@ static sexp sexp_make_context(sexp *stack, sexp env) {
env = sexp_make_standard_env(sexp_make_integer(5));
sexp_context_bc(res)
= sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE);
sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE;
sexp_bytecode_length(sexp_context_bc(res)) = INIT_BCODE_SIZE;
sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL;
sexp_context_lambda(res) = SEXP_FALSE;
@ -286,7 +290,7 @@ static sexp sexp_identifier_eq (sexp e1, sexp id1, sexp e2, sexp id2) {
static sexp sexp_compile_error(char *message, sexp irritants) {
return sexp_make_exception(the_compile_error_symbol,
sexp_c_string(message),
irritants, SEXP_FALSE, SEXP_FALSE);
irritants, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE);
}
#define analyze_check_exception(x) do {if (sexp_exceptionp(x)) \
@ -557,10 +561,6 @@ static void sexp_context_patch_label (sexp context, sexp_sint_t label) {
static sexp finalize_bytecode (sexp context) {
emit(OP_RET, context);
shrink_bcode(context, sexp_context_pos(context));
/* sexp_disasm(sexp_context_bc(context), */
/* env_global_ref(sexp_context_env(context), */
/* the_cur_err_symbol, */
/* SEXP_FALSE)); */
return sexp_context_bc(context);
}
@ -643,6 +643,8 @@ static void generate_set (sexp set, sexp context) {
sexp ref = sexp_set_var(set), lambda;
/* compile the value */
sexp_context_tailp(context) = 0;
if (sexp_lambdap(sexp_set_value(set)))
sexp_lambda_name(sexp_set_value(set)) = sexp_ref_name(ref);
generate(sexp_set_value(set), context);
if (! sexp_lambdap(sexp_ref_loc(ref))) {
/* global vars are set directly */
@ -800,6 +802,7 @@ static void generate_lambda (sexp lambda, sexp context) {
? 1 : 0);
len = sexp_length(sexp_lambda_params(lambda));
bc = finalize_bytecode(ctx);
sexp_bytecode_name(bc) = sexp_lambda_name(lambda);
if (sexp_nullp(fv)) {
/* shortcut, no free vars */
vec = sexp_make_vector(sexp_make_integer(0), SEXP_VOID);
@ -943,6 +946,7 @@ static sexp make_opcode_procedure (sexp op, sexp_uint_t i, sexp env,
sexp_push(refs, sexp_make_ref(sexp_car(ls), env_cell(env, sexp_car(ls))));
generate_opcode_app(sexp_cons(op, sexp_reverse(refs)), context);
bc = finalize_bytecode(context);
sexp_bytecode_name(bc) = sexp_c_string(sexp_opcode_name(op));
res = sexp_make_procedure(sexp_make_integer(0),
sexp_make_integer(i),
bc,
@ -982,7 +986,7 @@ static sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) {
#define _UWORD0 ((sexp_uint_t*)ip)[0]
#define _SWORD0 ((sexp_sint_t*)ip)[0]
#define sexp_raise(msg, args) do {stack[top]=sexp_compile_error(msg, args); \
#define sexp_raise(msg, args) do {stack[top]=sexp_user_exception(self, msg, args); \
top++; \
goto call_error_handler;} \
while (0)
@ -991,7 +995,8 @@ static sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) {
goto call_error_handler;} \
while (0)
sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
sexp bc = sexp_procedure_code(self), cp = sexp_procedure_vars(self);
unsigned char *ip=sexp_bytecode_data(bc);
sexp tmp1, tmp2, env=sexp_context_env(context);
sexp_sint_t i, j, k, fp=top-4;
@ -1006,38 +1011,39 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
#endif
switch (*ip++) {
case OP_NOOP:
fprintf(stderr, "<<<NOOP>>>\n");
break;
case OP_ERROR:
call_error_handler:
tmp1 = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE);
sexp_print_exception(_ARG1, tmp1);
tmp1 = env_global_ref(env, the_err_handler_symbol, SEXP_FALSE);
self = env_global_ref(env, the_err_handler_symbol, SEXP_FALSE);
stack[top] = (sexp) 1;
stack[top+1] = sexp_make_integer(ip+4);
stack[top+2] = cp;
stack[top+2] = self;
top += 3;
bc = sexp_procedure_code(tmp1);
bc = sexp_procedure_code(self);
ip = sexp_bytecode_data(bc);
cp = sexp_procedure_vars(tmp1);
cp = sexp_procedure_vars(self);
break;
case OP_RESUMECC:
tmp1 = stack[fp-1];
top = sexp_restore_stack(sexp_vector_ref(cp, 0), stack);
fp = sexp_unbox_integer(_ARG1);
cp = _ARG2;
self = _ARG2;
bc = sexp_procedure_code(self);
cp = sexp_procedure_vars(self);
ip = (unsigned char*) sexp_unbox_integer(_ARG3);
i = sexp_unbox_integer(_ARG4);
top -= 4;
_ARG1 = tmp1;
break;
case OP_CALLCC:
tmp1 = _ARG1;
i = 1;
stack[top] = sexp_make_integer(1);
stack[top+1] = sexp_make_integer(ip);
stack[top+2] = cp;
stack[top+2] = self;
stack[top+3] = sexp_make_integer(fp);
tmp1 = _ARG1;
i = 1;
tmp2 = sexp_vector(1, sexp_save_stack(stack, top+4));
_ARG1 = sexp_make_procedure(sexp_make_integer(0),
sexp_make_integer(1),
@ -1046,7 +1052,6 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
top++;
ip -= sizeof(sexp);
goto make_call;
break;
case OP_APPLY1:
tmp1 = _ARG1;
tmp2 = _ARG2;
@ -1064,7 +1069,9 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
tmp2 = stack[fp+3];
j = sexp_unbox_integer(stack[fp]);
ip = ((unsigned char*) sexp_unbox_integer(stack[fp+1])) - sizeof(sexp);
cp = stack[fp+2];
self = stack[fp+2];
cp = sexp_procedure_vars(self);
bc = sexp_procedure_vars(self);
/* copy new args into place */
for (k=0; k<i; k++)
stack[fp-j+k] = stack[top-1-i+k];
@ -1112,12 +1119,13 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
}
_ARG1 = sexp_make_integer(i);
stack[top] = sexp_make_integer(ip+sizeof(sexp));
stack[top+1] = cp;
stack[top+1] = self;
stack[top+2] = sexp_make_integer(fp);
top += 3;
bc = sexp_procedure_code(tmp1);
self = tmp1;
bc = sexp_procedure_code(self);
ip = sexp_bytecode_data(bc);
cp = sexp_procedure_vars(tmp1);
cp = sexp_procedure_vars(self);
fp = top-4;
break;
case OP_FCALL0:
@ -1498,7 +1506,9 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
stack[fp-i] = _ARG1;
top = fp-i+1;
ip = (unsigned char*) sexp_unbox_integer(stack[fp+1]);
cp = stack[fp+2];
self = stack[fp+2];
bc = sexp_procedure_code(self);
cp = sexp_procedure_vars(self);
fp = sexp_unbox_integer(stack[fp+3]);
break;
case OP_DONE:
@ -1518,7 +1528,8 @@ static sexp sexp_open_input_file (sexp path) {
FILE *in;
if (! sexp_stringp(path)) return sexp_type_exception("not a string", path);
in = fopen(sexp_string_data(path), "r");
if (! in) return sexp_user_exception("couldn't open input file", path);
if (! in)
return sexp_user_exception(SEXP_FALSE, "couldn't open input file", path);
return sexp_make_input_port(in, sexp_string_data(path));
}
@ -1526,7 +1537,8 @@ static sexp sexp_open_output_file (sexp path) {
FILE *out;
if (! sexp_stringp(path)) return sexp_type_exception("not a string", path);
out = fopen(sexp_string_data(path), "w");
if (! out) return sexp_user_exception("couldn't open output file", path);
if (! out)
return sexp_user_exception(SEXP_FALSE, "couldn't open output file", path);
return sexp_make_input_port(out, sexp_string_data(path));
}
@ -1736,11 +1748,7 @@ sexp apply(sexp proc, sexp args, sexp context) {
stack[top++] = sexp_make_integer(sexp_bytecode_data(final_resumer));
stack[top++] = sexp_make_vector(0, SEXP_VOID);
stack[top++] = sexp_make_integer(0);
return vm(sexp_procedure_code(proc),
sexp_procedure_vars(proc),
context,
stack,
top);
return vm(proc, context, stack, top);
}
sexp compile (sexp x, sexp context) {

22
sexp.c
View file

@ -92,41 +92,50 @@ void sexp_deep_free (sexp obj) {
/***************************** exceptions *****************************/
sexp sexp_make_exception (sexp kind, sexp message, sexp irritants,
sexp file, sexp line) {
sexp procedure, sexp file, sexp line) {
sexp exn = sexp_alloc_type(exception, SEXP_EXCEPTION);
sexp_exception_kind(exn) = kind;
sexp_exception_message(exn) = message;
sexp_exception_irritants(exn) = irritants;
sexp_exception_procedure(exn) = procedure;
sexp_exception_file(exn) = file;
sexp_exception_line(exn) = line;
return exn;
}
sexp sexp_user_exception (char *message, sexp irritants) {
sexp sexp_user_exception (sexp self, char *message, sexp irritants) {
return sexp_make_exception(sexp_intern("user-error"),
sexp_c_string(message),
((sexp_pairp(irritants) || sexp_nullp(irritants))
? irritants : sexp_list1(irritants)),
SEXP_FALSE, SEXP_FALSE);
self, SEXP_FALSE, SEXP_FALSE);
}
sexp sexp_type_exception (char *message, sexp obj) {
return sexp_make_exception(sexp_intern("type-error"),
sexp_c_string(message),
sexp_list1(obj), SEXP_FALSE, SEXP_FALSE);
sexp_c_string(message), sexp_list1(obj),
SEXP_FALSE, SEXP_FALSE, SEXP_FALSE);
}
sexp sexp_range_exception (sexp obj, sexp start, sexp end) {
return sexp_make_exception(sexp_intern("range-error"),
sexp_c_string("bad index range"),
sexp_list3(obj, start, end),
SEXP_FALSE, SEXP_FALSE);
SEXP_FALSE, SEXP_FALSE, SEXP_FALSE);
}
sexp sexp_print_exception (sexp exn, sexp out) {
sexp ls;
sexp_write_string("ERROR", out);
if (sexp_exceptionp(exn)) {
if (sexp_procedurep(sexp_exception_procedure(exn))) {
ls = sexp_bytecode_name(
sexp_procedure_code(sexp_exception_procedure(exn)));
if (sexp_symbolp(ls)) {
sexp_write_string(" in ", out);
sexp_write(ls, out);
}
}
if (sexp_integerp(sexp_exception_line(exn))
&& (sexp_exception_line(exn) > sexp_make_integer(0))) {
sexp_write_string(" on line ", out);
@ -173,6 +182,7 @@ static sexp sexp_read_error (char *message, sexp irritants, sexp port) {
return sexp_make_exception(the_read_error_symbol,
sexp_c_string(message),
irritants,
SEXP_FALSE,
name,
sexp_make_integer(sexp_port_line(port)));
}

12
sexp.h
View file

@ -105,7 +105,7 @@ struct sexp_struct {
sexp cookie;
} port;
struct {
sexp kind, message, irritants, file, line;
sexp kind, message, irritants, procedure, file, line;
} exception;
/* runtime types */
struct {
@ -114,7 +114,7 @@ struct sexp_struct {
} env;
struct {
sexp_uint_t length;
sexp literals;
sexp name, literals;
unsigned char data[];
} bytecode;
struct {
@ -269,12 +269,14 @@ struct sexp_struct {
#define sexp_exception_kind(p) ((p)->value.exception.kind)
#define sexp_exception_message(p) ((p)->value.exception.message)
#define sexp_exception_irritants(p) ((p)->value.exception.irritants)
#define sexp_exception_procedure(p) ((p)->value.exception.procedure)
#define sexp_exception_file(p) ((p)->value.exception.file)
#define sexp_exception_line(p) ((p)->value.exception.line)
#define sexp_bytecode_length(x) ((x)->value.bytecode.length)
#define sexp_bytecode_data(x) ((x)->value.bytecode.data)
#define sexp_bytecode_name(x) ((x)->value.bytecode.name)
#define sexp_bytecode_literals(x) ((x)->value.bytecode.literals)
#define sexp_bytecode_data(x) ((x)->value.bytecode.data)
#define sexp_env_flags(x) ((x)->value.env.flags)
#define sexp_env_parent(x) ((x)->value.env.parent)
@ -426,8 +428,8 @@ sexp sexp_make_output_port(FILE* out, char *path);
sexp sexp_make_input_string_port(sexp str);
sexp sexp_make_output_string_port();
sexp sexp_get_output_string(sexp port);
sexp sexp_make_exception(sexp kind, sexp message, sexp irritants, sexp file, sexp line);
sexp sexp_user_exception (char *message, sexp obj);
sexp sexp_make_exception(sexp kind, sexp message, sexp irritants, sexp procedure, sexp file, sexp line);
sexp sexp_user_exception (sexp self, char *message, sexp obj);
sexp sexp_type_exception (char *message, sexp obj);
sexp sexp_range_exception (sexp obj, sexp start, sexp end);
sexp sexp_print_exception(sexp exn, sexp out);

View file

@ -1,10 +1,12 @@
(define *tests-run* 0)
(define *tests-passed* 0)
(define *tests-failed* 0)
(define-syntax test
(syntax-rules ()
((test expect expr)
(begin
(set! *tests-run* (+ *tests-run* 1))
(let ((str (call-with-output-string (lambda (out) (display 'expr out))))
(res expr))
(display str)
@ -16,17 +18,16 @@
(set! *tests-passed* (+ *tests-passed* 1))
(display " [PASS]\n"))
(else
(set! *tests-failed* (+ *tests-failed* 1))
(display " [FAIL]\n")
(display " expected ") (write expect)
(display " but got ") (write res) (newline)))))))
(display " but got ") (write res) (newline))))))))
(define (test-report)
(write *tests-passed*)
(display " out of ")
(write (+ *tests-passed* *tests-failed*))
(write *tests-run*)
(display " passed (")
(write (* (/ *tests-passed* (+ *tests-passed* *tests-failed*)) 100))
(write (* (/ *tests-passed* *tests-run*) 100))
(display "%)")
(newline))