diff --git a/eval.c b/eval.c index b9c7ad62..862a6062 100644 --- a/eval.c +++ b/eval.c @@ -20,6 +20,34 @@ static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) } #endif +void sexp_stack_trace (sexp ctx, sexp out) { + int i, fp=sexp_context_last_fp(ctx); + sexp self, bc, ls, *stack=sexp_stack_data(sexp_context_stack(ctx)); + if (! sexp_oportp(out)) out = sexp_current_error_port(ctx); + for (i=fp; i>4; i=sexp_unbox_fixnum(stack[i+3])) { + self = stack[i+2]; + if (sexp_procedurep(self)) { + sexp_write_string(ctx, " called from ", out); + bc = sexp_procedure_code(self); + if (sexp_truep(sexp_bytecode_name(bc))) + sexp_write(ctx, sexp_bytecode_name(bc), out); + else + sexp_printf(ctx, out, "anon: %p", bc); + if ((ls=sexp_bytecode_source(bc))) { + if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) { + sexp_write_string(ctx, " on line ", out); + sexp_write(ctx, sexp_cdr(ls), out); + } + if (sexp_stringp(sexp_car(ls))) { + sexp_write_string(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_car(ls)), out); + } + } + sexp_write_char(ctx, '\n', out); + } + } +} + static sexp analyze (sexp ctx, sexp x); static void generate (sexp ctx, sexp x); @@ -1558,6 +1586,7 @@ sexp sexp_eval_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp env) { res = sexp_apply(ctx2, res, SEXP_NULL); sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = err_handler; sexp_context_top(ctx) = top; + sexp_context_last_fp(ctx) = sexp_context_last_fp(ctx2); sexp_gc_release2(ctx); return res; } diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 66ce173e..54110607 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -128,6 +128,7 @@ SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env, sexp_u SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda); SEXP_API sexp sexp_compile_error (sexp ctx, const char *message, sexp obj); SEXP_API sexp sexp_analyze (sexp context, sexp x); +SEXP_API void sexp_stack_trace (sexp ctx, sexp out); SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args); SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv); SEXP_API int sexp_param_index (sexp lambda, sexp name); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index e2dc3e8c..6a0d44d2 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -296,7 +296,7 @@ struct sexp_struct { struct { sexp_heap heap; struct sexp_gc_var_t *saves; - sexp_uint_t pos, depth, tailp, tracep; + sexp_uint_t pos, depth, tailp, tracep, last_fp; sexp bc, lambda, stack, env, fv, parent, globals; } context; } value; @@ -687,6 +687,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #define sexp_context_tailp(x) ((x)->value.context.tailp) #define sexp_context_tracep(x) ((x)->value.context.tailp) #define sexp_context_globals(x) ((x)->value.context.globals) +#define sexp_context_last_fp(x) ((x)->value.context.last_fp) #if SEXP_USE_ALIGNED_BYTECODE #define sexp_context_align_pos(ctx) sexp_context_pos(ctx) = sexp_word_align(sexp_context_pos(ctx)) diff --git a/main.c b/main.c index 7ecc913f..08a55662 100644 --- a/main.c +++ b/main.c @@ -45,6 +45,7 @@ static void repl (sexp ctx) { res = sexp_eval(ctx, obj, env); if (sexp_exceptionp(res)) { sexp_print_exception(ctx, res, err); + sexp_stack_trace(ctx, err); } else { #if SEXP_USE_WARN_UNDEFS sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp); diff --git a/vm.c b/vm.c index 8e96d597..aa60cf3a 100644 --- a/vm.c +++ b/vm.c @@ -476,6 +476,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { case SEXP_OP_RAISE: call_error_handler: tmp1 = sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)); + sexp_context_last_fp(ctx) = fp; if (! sexp_procedurep(tmp1)) goto end_loop; stack[top] = (sexp) 1; stack[top+1] = sexp_make_fixnum(ip-sexp_bytecode_data(bc));