mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-08 13:37:35 +02:00
reporting calling procedure name for exceptions
This commit is contained in:
Alex Shinn
parent
fad4e3976e
commit
820c13e752
4 changed files with 81 additions and 60 deletions
66
eval.c
66
eval.c
|
|
@ -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
22
sexp.c
|
|
@ -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
12
sexp.h
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue