adding simple stack traces

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;
 }

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);

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))

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);

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));