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:
parent
fad4e3976e
commit
820c13e752
4 changed files with 81 additions and 60 deletions
70
eval.c
70
eval.c
|
@ -109,6 +109,7 @@ static void shrink_bcode(sexp context, sexp_uint_t i) {
|
||||||
sexp tmp;
|
sexp tmp;
|
||||||
if (sexp_bytecode_length(sexp_context_bc(context)) != i) {
|
if (sexp_bytecode_length(sexp_context_bc(context)) != i) {
|
||||||
tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) + i, SEXP_BYTECODE);
|
tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) + i, SEXP_BYTECODE);
|
||||||
|
sexp_bytecode_name(tmp) = SEXP_FALSE;
|
||||||
sexp_bytecode_length(tmp) = i;
|
sexp_bytecode_length(tmp) = i;
|
||||||
sexp_bytecode_literals(tmp)
|
sexp_bytecode_literals(tmp)
|
||||||
= sexp_bytecode_literals(sexp_context_bc(context));
|
= 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)
|
tmp = sexp_alloc_tagged(sexp_sizeof(bytecode)
|
||||||
+ sexp_bytecode_length(sexp_context_bc(context))*2,
|
+ sexp_bytecode_length(sexp_context_bc(context))*2,
|
||||||
SEXP_BYTECODE);
|
SEXP_BYTECODE);
|
||||||
|
sexp_bytecode_name(tmp) = SEXP_FALSE;
|
||||||
sexp_bytecode_length(tmp)
|
sexp_bytecode_length(tmp)
|
||||||
= sexp_bytecode_length(sexp_context_bc(context))*2;
|
= sexp_bytecode_length(sexp_context_bc(context))*2;
|
||||||
sexp_bytecode_literals(tmp)
|
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) {
|
static sexp sexp_make_lambda(sexp params) {
|
||||||
sexp res = sexp_alloc_type(lambda, SEXP_LAMBDA);
|
sexp res = sexp_alloc_type(lambda, SEXP_LAMBDA);
|
||||||
|
sexp_lambda_name(res) = SEXP_FALSE;
|
||||||
sexp_lambda_params(res) = params;
|
sexp_lambda_params(res) = params;
|
||||||
sexp_lambda_fv(res) = SEXP_NULL;
|
sexp_lambda_fv(res) = SEXP_NULL;
|
||||||
sexp_lambda_sv(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));
|
env = sexp_make_standard_env(sexp_make_integer(5));
|
||||||
sexp_context_bc(res)
|
sexp_context_bc(res)
|
||||||
= sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE);
|
= 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_length(sexp_context_bc(res)) = INIT_BCODE_SIZE;
|
||||||
sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL;
|
sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL;
|
||||||
sexp_context_lambda(res) = SEXP_FALSE;
|
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) {
|
static sexp sexp_compile_error(char *message, sexp irritants) {
|
||||||
return sexp_make_exception(the_compile_error_symbol,
|
return sexp_make_exception(the_compile_error_symbol,
|
||||||
sexp_c_string(message),
|
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)) \
|
#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) {
|
static sexp finalize_bytecode (sexp context) {
|
||||||
emit(OP_RET, context);
|
emit(OP_RET, context);
|
||||||
shrink_bcode(context, sexp_context_pos(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);
|
return sexp_context_bc(context);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -643,6 +643,8 @@ static void generate_set (sexp set, sexp context) {
|
||||||
sexp ref = sexp_set_var(set), lambda;
|
sexp ref = sexp_set_var(set), lambda;
|
||||||
/* compile the value */
|
/* compile the value */
|
||||||
sexp_context_tailp(context) = 0;
|
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);
|
generate(sexp_set_value(set), context);
|
||||||
if (! sexp_lambdap(sexp_ref_loc(ref))) {
|
if (! sexp_lambdap(sexp_ref_loc(ref))) {
|
||||||
/* global vars are set directly */
|
/* global vars are set directly */
|
||||||
|
@ -800,6 +802,7 @@ static void generate_lambda (sexp lambda, sexp context) {
|
||||||
? 1 : 0);
|
? 1 : 0);
|
||||||
len = sexp_length(sexp_lambda_params(lambda));
|
len = sexp_length(sexp_lambda_params(lambda));
|
||||||
bc = finalize_bytecode(ctx);
|
bc = finalize_bytecode(ctx);
|
||||||
|
sexp_bytecode_name(bc) = sexp_lambda_name(lambda);
|
||||||
if (sexp_nullp(fv)) {
|
if (sexp_nullp(fv)) {
|
||||||
/* shortcut, no free vars */
|
/* shortcut, no free vars */
|
||||||
vec = sexp_make_vector(sexp_make_integer(0), SEXP_VOID);
|
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))));
|
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);
|
generate_opcode_app(sexp_cons(op, sexp_reverse(refs)), context);
|
||||||
bc = finalize_bytecode(context);
|
bc = finalize_bytecode(context);
|
||||||
|
sexp_bytecode_name(bc) = sexp_c_string(sexp_opcode_name(op));
|
||||||
res = sexp_make_procedure(sexp_make_integer(0),
|
res = sexp_make_procedure(sexp_make_integer(0),
|
||||||
sexp_make_integer(i),
|
sexp_make_integer(i),
|
||||||
bc,
|
bc,
|
||||||
|
@ -982,16 +986,17 @@ static sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) {
|
||||||
#define _UWORD0 ((sexp_uint_t*)ip)[0]
|
#define _UWORD0 ((sexp_uint_t*)ip)[0]
|
||||||
#define _SWORD0 ((sexp_sint_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++; \
|
top++; \
|
||||||
goto call_error_handler;} \
|
goto call_error_handler;} \
|
||||||
while (0)
|
while (0)
|
||||||
|
|
||||||
#define sexp_check_exception() do {if (sexp_exceptionp(_ARG1)) \
|
#define sexp_check_exception() do {if (sexp_exceptionp(_ARG1)) \
|
||||||
goto call_error_handler;} \
|
goto call_error_handler;} \
|
||||||
while (0)
|
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);
|
unsigned char *ip=sexp_bytecode_data(bc);
|
||||||
sexp tmp1, tmp2, env=sexp_context_env(context);
|
sexp tmp1, tmp2, env=sexp_context_env(context);
|
||||||
sexp_sint_t i, j, k, fp=top-4;
|
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
|
#endif
|
||||||
switch (*ip++) {
|
switch (*ip++) {
|
||||||
case OP_NOOP:
|
case OP_NOOP:
|
||||||
fprintf(stderr, "<<<NOOP>>>\n");
|
|
||||||
break;
|
break;
|
||||||
case OP_ERROR:
|
case OP_ERROR:
|
||||||
call_error_handler:
|
call_error_handler:
|
||||||
tmp1 = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE);
|
tmp1 = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE);
|
||||||
sexp_print_exception(_ARG1, tmp1);
|
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] = (sexp) 1;
|
||||||
stack[top+1] = sexp_make_integer(ip+4);
|
stack[top+1] = sexp_make_integer(ip+4);
|
||||||
stack[top+2] = cp;
|
stack[top+2] = self;
|
||||||
top += 3;
|
top += 3;
|
||||||
bc = sexp_procedure_code(tmp1);
|
bc = sexp_procedure_code(self);
|
||||||
ip = sexp_bytecode_data(bc);
|
ip = sexp_bytecode_data(bc);
|
||||||
cp = sexp_procedure_vars(tmp1);
|
cp = sexp_procedure_vars(self);
|
||||||
break;
|
break;
|
||||||
case OP_RESUMECC:
|
case OP_RESUMECC:
|
||||||
tmp1 = stack[fp-1];
|
tmp1 = stack[fp-1];
|
||||||
top = sexp_restore_stack(sexp_vector_ref(cp, 0), stack);
|
top = sexp_restore_stack(sexp_vector_ref(cp, 0), stack);
|
||||||
fp = sexp_unbox_integer(_ARG1);
|
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);
|
ip = (unsigned char*) sexp_unbox_integer(_ARG3);
|
||||||
i = sexp_unbox_integer(_ARG4);
|
i = sexp_unbox_integer(_ARG4);
|
||||||
top -= 4;
|
top -= 4;
|
||||||
_ARG1 = tmp1;
|
_ARG1 = tmp1;
|
||||||
break;
|
break;
|
||||||
case OP_CALLCC:
|
case OP_CALLCC:
|
||||||
tmp1 = _ARG1;
|
|
||||||
i = 1;
|
|
||||||
stack[top] = sexp_make_integer(1);
|
stack[top] = sexp_make_integer(1);
|
||||||
stack[top+1] = sexp_make_integer(ip);
|
stack[top+1] = sexp_make_integer(ip);
|
||||||
stack[top+2] = cp;
|
stack[top+2] = self;
|
||||||
stack[top+3] = sexp_make_integer(fp);
|
stack[top+3] = sexp_make_integer(fp);
|
||||||
|
tmp1 = _ARG1;
|
||||||
|
i = 1;
|
||||||
tmp2 = sexp_vector(1, sexp_save_stack(stack, top+4));
|
tmp2 = sexp_vector(1, sexp_save_stack(stack, top+4));
|
||||||
_ARG1 = sexp_make_procedure(sexp_make_integer(0),
|
_ARG1 = sexp_make_procedure(sexp_make_integer(0),
|
||||||
sexp_make_integer(1),
|
sexp_make_integer(1),
|
||||||
|
@ -1046,7 +1052,6 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
|
||||||
top++;
|
top++;
|
||||||
ip -= sizeof(sexp);
|
ip -= sizeof(sexp);
|
||||||
goto make_call;
|
goto make_call;
|
||||||
break;
|
|
||||||
case OP_APPLY1:
|
case OP_APPLY1:
|
||||||
tmp1 = _ARG1;
|
tmp1 = _ARG1;
|
||||||
tmp2 = _ARG2;
|
tmp2 = _ARG2;
|
||||||
|
@ -1064,7 +1069,9 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
|
||||||
tmp2 = stack[fp+3];
|
tmp2 = stack[fp+3];
|
||||||
j = sexp_unbox_integer(stack[fp]);
|
j = sexp_unbox_integer(stack[fp]);
|
||||||
ip = ((unsigned char*) sexp_unbox_integer(stack[fp+1])) - sizeof(sexp);
|
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 */
|
/* copy new args into place */
|
||||||
for (k=0; k<i; k++)
|
for (k=0; k<i; k++)
|
||||||
stack[fp-j+k] = stack[top-1-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);
|
_ARG1 = sexp_make_integer(i);
|
||||||
stack[top] = sexp_make_integer(ip+sizeof(sexp));
|
stack[top] = sexp_make_integer(ip+sizeof(sexp));
|
||||||
stack[top+1] = cp;
|
stack[top+1] = self;
|
||||||
stack[top+2] = sexp_make_integer(fp);
|
stack[top+2] = sexp_make_integer(fp);
|
||||||
top += 3;
|
top += 3;
|
||||||
bc = sexp_procedure_code(tmp1);
|
self = tmp1;
|
||||||
|
bc = sexp_procedure_code(self);
|
||||||
ip = sexp_bytecode_data(bc);
|
ip = sexp_bytecode_data(bc);
|
||||||
cp = sexp_procedure_vars(tmp1);
|
cp = sexp_procedure_vars(self);
|
||||||
fp = top-4;
|
fp = top-4;
|
||||||
break;
|
break;
|
||||||
case OP_FCALL0:
|
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;
|
stack[fp-i] = _ARG1;
|
||||||
top = fp-i+1;
|
top = fp-i+1;
|
||||||
ip = (unsigned char*) sexp_unbox_integer(stack[fp+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]);
|
fp = sexp_unbox_integer(stack[fp+3]);
|
||||||
break;
|
break;
|
||||||
case OP_DONE:
|
case OP_DONE:
|
||||||
|
@ -1518,7 +1528,8 @@ static sexp sexp_open_input_file (sexp path) {
|
||||||
FILE *in;
|
FILE *in;
|
||||||
if (! sexp_stringp(path)) return sexp_type_exception("not a string", path);
|
if (! sexp_stringp(path)) return sexp_type_exception("not a string", path);
|
||||||
in = fopen(sexp_string_data(path), "r");
|
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));
|
return sexp_make_input_port(in, sexp_string_data(path));
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -1526,7 +1537,8 @@ static sexp sexp_open_output_file (sexp path) {
|
||||||
FILE *out;
|
FILE *out;
|
||||||
if (! sexp_stringp(path)) return sexp_type_exception("not a string", path);
|
if (! sexp_stringp(path)) return sexp_type_exception("not a string", path);
|
||||||
out = fopen(sexp_string_data(path), "w");
|
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));
|
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_integer(sexp_bytecode_data(final_resumer));
|
||||||
stack[top++] = sexp_make_vector(0, SEXP_VOID);
|
stack[top++] = sexp_make_vector(0, SEXP_VOID);
|
||||||
stack[top++] = sexp_make_integer(0);
|
stack[top++] = sexp_make_integer(0);
|
||||||
return vm(sexp_procedure_code(proc),
|
return vm(proc, context, stack, top);
|
||||||
sexp_procedure_vars(proc),
|
|
||||||
context,
|
|
||||||
stack,
|
|
||||||
top);
|
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp compile (sexp x, sexp context) {
|
sexp compile (sexp x, sexp context) {
|
||||||
|
|
22
sexp.c
22
sexp.c
|
@ -92,41 +92,50 @@ void sexp_deep_free (sexp obj) {
|
||||||
/***************************** exceptions *****************************/
|
/***************************** exceptions *****************************/
|
||||||
|
|
||||||
sexp sexp_make_exception (sexp kind, sexp message, sexp irritants,
|
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 exn = sexp_alloc_type(exception, SEXP_EXCEPTION);
|
||||||
sexp_exception_kind(exn) = kind;
|
sexp_exception_kind(exn) = kind;
|
||||||
sexp_exception_message(exn) = message;
|
sexp_exception_message(exn) = message;
|
||||||
sexp_exception_irritants(exn) = irritants;
|
sexp_exception_irritants(exn) = irritants;
|
||||||
|
sexp_exception_procedure(exn) = procedure;
|
||||||
sexp_exception_file(exn) = file;
|
sexp_exception_file(exn) = file;
|
||||||
sexp_exception_line(exn) = line;
|
sexp_exception_line(exn) = line;
|
||||||
return exn;
|
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"),
|
return sexp_make_exception(sexp_intern("user-error"),
|
||||||
sexp_c_string(message),
|
sexp_c_string(message),
|
||||||
((sexp_pairp(irritants) || sexp_nullp(irritants))
|
((sexp_pairp(irritants) || sexp_nullp(irritants))
|
||||||
? irritants : sexp_list1(irritants)),
|
? irritants : sexp_list1(irritants)),
|
||||||
SEXP_FALSE, SEXP_FALSE);
|
self, SEXP_FALSE, SEXP_FALSE);
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_type_exception (char *message, sexp obj) {
|
sexp sexp_type_exception (char *message, sexp obj) {
|
||||||
return sexp_make_exception(sexp_intern("type-error"),
|
return sexp_make_exception(sexp_intern("type-error"),
|
||||||
sexp_c_string(message),
|
sexp_c_string(message), sexp_list1(obj),
|
||||||
sexp_list1(obj), SEXP_FALSE, SEXP_FALSE);
|
SEXP_FALSE, SEXP_FALSE, SEXP_FALSE);
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_range_exception (sexp obj, sexp start, sexp end) {
|
sexp sexp_range_exception (sexp obj, sexp start, sexp end) {
|
||||||
return sexp_make_exception(sexp_intern("range-error"),
|
return sexp_make_exception(sexp_intern("range-error"),
|
||||||
sexp_c_string("bad index range"),
|
sexp_c_string("bad index range"),
|
||||||
sexp_list3(obj, start, end),
|
sexp_list3(obj, start, end),
|
||||||
SEXP_FALSE, SEXP_FALSE);
|
SEXP_FALSE, SEXP_FALSE, SEXP_FALSE);
|
||||||
}
|
}
|
||||||
|
|
||||||
sexp sexp_print_exception (sexp exn, sexp out) {
|
sexp sexp_print_exception (sexp exn, sexp out) {
|
||||||
sexp ls;
|
sexp ls;
|
||||||
sexp_write_string("ERROR", out);
|
sexp_write_string("ERROR", out);
|
||||||
if (sexp_exceptionp(exn)) {
|
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))
|
if (sexp_integerp(sexp_exception_line(exn))
|
||||||
&& (sexp_exception_line(exn) > sexp_make_integer(0))) {
|
&& (sexp_exception_line(exn) > sexp_make_integer(0))) {
|
||||||
sexp_write_string(" on line ", out);
|
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,
|
return sexp_make_exception(the_read_error_symbol,
|
||||||
sexp_c_string(message),
|
sexp_c_string(message),
|
||||||
irritants,
|
irritants,
|
||||||
|
SEXP_FALSE,
|
||||||
name,
|
name,
|
||||||
sexp_make_integer(sexp_port_line(port)));
|
sexp_make_integer(sexp_port_line(port)));
|
||||||
}
|
}
|
||||||
|
|
12
sexp.h
12
sexp.h
|
@ -105,7 +105,7 @@ struct sexp_struct {
|
||||||
sexp cookie;
|
sexp cookie;
|
||||||
} port;
|
} port;
|
||||||
struct {
|
struct {
|
||||||
sexp kind, message, irritants, file, line;
|
sexp kind, message, irritants, procedure, file, line;
|
||||||
} exception;
|
} exception;
|
||||||
/* runtime types */
|
/* runtime types */
|
||||||
struct {
|
struct {
|
||||||
|
@ -114,7 +114,7 @@ struct sexp_struct {
|
||||||
} env;
|
} env;
|
||||||
struct {
|
struct {
|
||||||
sexp_uint_t length;
|
sexp_uint_t length;
|
||||||
sexp literals;
|
sexp name, literals;
|
||||||
unsigned char data[];
|
unsigned char data[];
|
||||||
} bytecode;
|
} bytecode;
|
||||||
struct {
|
struct {
|
||||||
|
@ -269,12 +269,14 @@ struct sexp_struct {
|
||||||
#define sexp_exception_kind(p) ((p)->value.exception.kind)
|
#define sexp_exception_kind(p) ((p)->value.exception.kind)
|
||||||
#define sexp_exception_message(p) ((p)->value.exception.message)
|
#define sexp_exception_message(p) ((p)->value.exception.message)
|
||||||
#define sexp_exception_irritants(p) ((p)->value.exception.irritants)
|
#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_file(p) ((p)->value.exception.file)
|
||||||
#define sexp_exception_line(p) ((p)->value.exception.line)
|
#define sexp_exception_line(p) ((p)->value.exception.line)
|
||||||
|
|
||||||
#define sexp_bytecode_length(x) ((x)->value.bytecode.length)
|
#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_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_flags(x) ((x)->value.env.flags)
|
||||||
#define sexp_env_parent(x) ((x)->value.env.parent)
|
#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_input_string_port(sexp str);
|
||||||
sexp sexp_make_output_string_port();
|
sexp sexp_make_output_string_port();
|
||||||
sexp sexp_get_output_string(sexp port);
|
sexp sexp_get_output_string(sexp port);
|
||||||
sexp sexp_make_exception(sexp kind, sexp message, sexp irritants, sexp file, sexp line);
|
sexp sexp_make_exception(sexp kind, sexp message, sexp irritants, sexp procedure, sexp file, sexp line);
|
||||||
sexp sexp_user_exception (char *message, sexp obj);
|
sexp sexp_user_exception (sexp self, char *message, sexp obj);
|
||||||
sexp sexp_type_exception (char *message, sexp obj);
|
sexp sexp_type_exception (char *message, sexp obj);
|
||||||
sexp sexp_range_exception (sexp obj, sexp start, sexp end);
|
sexp sexp_range_exception (sexp obj, sexp start, sexp end);
|
||||||
sexp sexp_print_exception(sexp exn, sexp out);
|
sexp sexp_print_exception(sexp exn, sexp out);
|
||||||
|
|
|
@ -1,32 +1,33 @@
|
||||||
|
|
||||||
|
(define *tests-run* 0)
|
||||||
(define *tests-passed* 0)
|
(define *tests-passed* 0)
|
||||||
(define *tests-failed* 0)
|
|
||||||
|
|
||||||
(define-syntax test
|
(define-syntax test
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((test expect expr)
|
((test expect expr)
|
||||||
(let ((str (call-with-output-string (lambda (out) (display 'expr out))))
|
(begin
|
||||||
(res expr))
|
(set! *tests-run* (+ *tests-run* 1))
|
||||||
(display str)
|
(let ((str (call-with-output-string (lambda (out) (display 'expr out))))
|
||||||
(write-char #\space)
|
(res expr))
|
||||||
(display (make-string (max 0 (- 72 (string-length str))) #\.))
|
(display str)
|
||||||
(flush-output)
|
(write-char #\space)
|
||||||
(cond
|
(display (make-string (max 0 (- 72 (string-length str))) #\.))
|
||||||
((equal? res expect)
|
(flush-output)
|
||||||
(set! *tests-passed* (+ *tests-passed* 1))
|
(cond
|
||||||
(display " [PASS]\n"))
|
((equal? res expect)
|
||||||
(else
|
(set! *tests-passed* (+ *tests-passed* 1))
|
||||||
(set! *tests-failed* (+ *tests-failed* 1))
|
(display " [PASS]\n"))
|
||||||
(display " [FAIL]\n")
|
(else
|
||||||
(display " expected ") (write expect)
|
(display " [FAIL]\n")
|
||||||
(display " but got ") (write res) (newline)))))))
|
(display " expected ") (write expect)
|
||||||
|
(display " but got ") (write res) (newline))))))))
|
||||||
|
|
||||||
(define (test-report)
|
(define (test-report)
|
||||||
(write *tests-passed*)
|
(write *tests-passed*)
|
||||||
(display " out of ")
|
(display " out of ")
|
||||||
(write (+ *tests-passed* *tests-failed*))
|
(write *tests-run*)
|
||||||
(display " passed (")
|
(display " passed (")
|
||||||
(write (* (/ *tests-passed* (+ *tests-passed* *tests-failed*)) 100))
|
(write (* (/ *tests-passed* *tests-run*) 100))
|
||||||
(display "%)")
|
(display "%)")
|
||||||
(newline))
|
(newline))
|
||||||
|
|
||||||
|
|
Loading…
Add table
Reference in a new issue