From 3cf62f033aefaf9be6fc3522e2f29dcd379c7e90 Mon Sep 17 00:00:00 2001
From: Alex Shinn <alexshinn@gmail.com>
Date: Mon, 26 Apr 2021 21:40:39 +0900
Subject: [PATCH] store stack traces directly in top-level exceptions to more
 consistently be able to report them from C

---
 eval.c               | 11 +++++
 include/chibi/sexp.h |  5 ++-
 main.c               | 15 ++++++-
 sexp.c               |  3 +-
 vm.c                 | 97 ++++++++++++++++++++++++++++++++------------
 5 files changed, 101 insertions(+), 30 deletions(-)

diff --git a/eval.c b/eval.c
index 0ac9ca84..8efe25be 100644
--- a/eval.c
+++ b/eval.c
@@ -361,6 +361,17 @@ sexp sexp_complete_bytecode (sexp ctx) {
 #if SEXP_USE_FULL_SOURCE_INFO
   if (sexp_bytecode_source(bc) && sexp_pairp(sexp_bytecode_source(bc))) {
     sexp_bytecode_source(bc) = sexp_nreverse(ctx, sexp_bytecode_source(bc));
+    /* omit the leading -1 source marker for the bytecode if the next */
+    /* entry is in the same file */
+    if (sexp_pairp(sexp_cdr(sexp_bytecode_source(bc))) &&
+        sexp_pairp(sexp_car(sexp_bytecode_source(bc))) &&
+        sexp_pairp(sexp_cdar(sexp_bytecode_source(bc))) &&
+        sexp_pairp(sexp_cadr(sexp_bytecode_source(bc))) &&
+        sexp_pairp(sexp_cdr(sexp_cadr(sexp_bytecode_source(bc)))) &&
+        sexp_cadr(sexp_car(sexp_bytecode_source(bc)))
+        == sexp_cadr(sexp_cadr(sexp_bytecode_source(bc)))) {
+      sexp_bytecode_source(bc) = sexp_cdr(sexp_bytecode_source(bc));
+    }
     sexp_bytecode_source(bc) = sexp_list_to_vector(ctx, sexp_bytecode_source(bc));
   }
 #endif
diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h
index 07929066..dbead7c8 100644
--- a/include/chibi/sexp.h
+++ b/include/chibi/sexp.h
@@ -505,7 +505,7 @@ struct sexp_struct {
       sexp_sint_t fd, count;
     } fileno;
     struct {
-      sexp kind, message, irritants, procedure, source;
+      sexp kind, message, irritants, procedure, source, stack_trace;
     } exception;
     struct {
       signed char sign;
@@ -1244,6 +1244,7 @@ enum sexp_uniform_vector_type {
 #define sexp_exception_irritants(x) (sexp_field(x, exception, SEXP_EXCEPTION, irritants))
 #define sexp_exception_procedure(x) (sexp_field(x, exception, SEXP_EXCEPTION, procedure))
 #define sexp_exception_source(x)    (sexp_field(x, exception, SEXP_EXCEPTION, source))
+#define sexp_exception_stack_trace(x) (sexp_field(x, exception, SEXP_EXCEPTION, stack_trace))
 
 #define sexp_trampolinep(x) (sexp_exceptionp(x) && sexp_exception_kind(x) == SEXP_TRAMPOLINE)
 #define sexp_trampoline_procedure(x) sexp_exception_procedure(x)
@@ -1756,6 +1757,7 @@ SEXP_API sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp x
 SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end);
 SEXP_API sexp sexp_print_exception_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp out);
 SEXP_API sexp sexp_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp out);
+SEXP_API sexp sexp_print_exception_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp out);
 SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args);
 SEXP_API sexp sexp_apply1 (sexp ctx, sexp f, sexp x);
 SEXP_API sexp sexp_apply2 (sexp ctx, sexp f, sexp x, sexp y);
@@ -1890,6 +1892,7 @@ SEXP_API int sexp_poll_port(sexp ctx, sexp port, int inputp);
 #define sexp_read(ctx, in) sexp_read_op(ctx, NULL, 1, in)
 #define sexp_write(ctx, obj, out) sexp_write_op(ctx, NULL, 2, obj, out)
 #define sexp_print_exception(ctx, e, out) sexp_print_exception_op(ctx, NULL, 2, e, out)
+#define sexp_print_exception_stack_trace(ctx, e, out) sexp_print_exception_stack_trace_op(ctx, NULL, 2, e, out)
 #define sexp_flush_output(ctx, out) sexp_flush_output_op(ctx, NULL, 1, out)
 #define sexp_equalp(ctx, a, b) sexp_equalp_op(ctx, NULL, 2, a, b)
 #define sexp_listp(ctx, x) sexp_listp_op(ctx, NULL, 1, x)
diff --git a/main.c b/main.c
index 53b5976d..f7a64b97 100644
--- a/main.c
+++ b/main.c
@@ -126,6 +126,19 @@ static sexp sexp_load_standard_params (sexp ctx, sexp e, int nonblocking) {
   return res;
 }
 
+static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) {
+  int i;
+  if (! sexp_oportp(out)) out = sexp_current_error_port(ctx);
+  for (i=0; i<top; i++) {
+    sexp_write_char(ctx, ((i==fp) ? '*' : ' '), out);
+    if (i < 10) sexp_write_char(ctx, '0', out);
+    sexp_write(ctx, sexp_make_fixnum(i), out);
+    sexp_write_string(ctx, ": ", out);
+    sexp_write(ctx, stack[i], out);
+    sexp_newline(ctx, out);
+  }
+}
+
 static void repl (sexp ctx, sexp env) {
   sexp_gc_var6(obj, tmp, res, in, out, err);
   sexp_gc_preserve6(ctx, obj, tmp, res, in, out, err);
@@ -212,7 +225,7 @@ static sexp check_exception (sexp ctx, sexp res) {
     if (! sexp_oportp(err))
       err = sexp_make_output_port(ctx, stderr, SEXP_FALSE);
     sexp_print_exception(ctx, res, err);
-    sexp_stack_trace(ctx, err);
+    sexp_print_exception_stack_trace(ctx, res, err);
 #if SEXP_USE_MAIN_ERROR_ADVISE
     if (sexp_envp(sexp_global(ctx, SEXP_G_META_ENV))) {
       advise = sexp_eval_string(ctx, sexp_advice_environment, -1, sexp_global(ctx, SEXP_G_META_ENV));
diff --git a/sexp.c b/sexp.c
index a3464dc1..9b83c5ba 100644
--- a/sexp.c
+++ b/sexp.c
@@ -279,7 +279,7 @@ static struct sexp_type_struct _sexp_type_specs[] = {
   {(sexp)"Input-Port", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_PORTN, SEXP_IPORT, sexp_offsetof(port, name), 3, 3, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, SEXP_FINALIZE_PORT},
   {(sexp)"Output-Port", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_PORTN, SEXP_OPORT, sexp_offsetof(port, name), 3, 3, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, SEXP_FINALIZE_PORT},
   {(sexp)"File-Descriptor", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_FILENON, SEXP_FILENO, 0, 0, 0, 0, 0, sexp_sizeof(fileno), 0, 0, 0, 0, 0, 0, 0, 0, SEXP_FINALIZE_FILENO},
-  {(sexp)"Exception", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, SEXP_EXCEPTION, sexp_offsetof(exception, kind), 5, 5, 0, 0, sexp_sizeof(exception), 0, 0, 0, 0, 0, 0, 0, 0, NULL},
+  {(sexp)"Exception", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, 0, 0, 0, 0, 0, 0, NULL},
   {(sexp)"Procedure", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, 0, 0, 0, 0, 0, 0, NULL},
   {(sexp)"Macro", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, SEXP_MACRO, sexp_offsetof(macro, proc), 4, 4, 0, 0, sexp_sizeof(macro), 0, 0, 0, 0, 0, 0, 0, 0, NULL},
   {(sexp)"Sc", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, SEXP_SYNCLO, sexp_offsetof(synclo, env), 4, 4, 0, 0, sexp_sizeof(synclo), 0, 0, 0, 0, 0, 0, 0, 0, NULL},
@@ -731,6 +731,7 @@ sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants,
   sexp_exception_irritants(exn) = irritants;
   sexp_exception_procedure(exn) = procedure;
   sexp_exception_source(exn) = source;
+  sexp_exception_stack_trace(exn) = SEXP_FALSE;
   return exn;
 }
 
diff --git a/vm.c b/vm.c
index 332ce08e..23f8c2f3 100644
--- a/vm.c
+++ b/vm.c
@@ -41,38 +41,78 @@ static sexp sexp_lookup_source_info (sexp src, int ip) {
 }
 #endif
 
-void sexp_stack_trace (sexp ctx, sexp out) {
-  int i, fp=sexp_context_last_fp(ctx);
-  sexp self, bc, src, *stack=sexp_stack_data(sexp_context_stack(ctx));
-  if (! sexp_oportp(out))
-    out = sexp_current_error_port(ctx);
+sexp sexp_get_stack_trace (sexp ctx) {
+  sexp_sint_t i, fp=sexp_context_last_fp(ctx);
+  sexp self, bc, src, *stack = sexp_stack_data(sexp_context_stack(ctx));
+  sexp_gc_var2(res, cell);
+  sexp_gc_preserve2(ctx, res, cell);
+  res = SEXP_NULL;
   for (i=fp; i>4; i=sexp_unbox_fixnum(stack[i+3])) {
     self = stack[i+2];
     if (self && sexp_procedurep(self)) {
-      sexp_write_string(ctx, "  called from ", out);
       bc = sexp_procedure_code(self);
-      if (sexp_symbolp(sexp_bytecode_name(bc)))
-        sexp_write(ctx, sexp_bytecode_name(bc), out);
-      else
-        sexp_write_string(ctx, "<anonymous>", out);
       src = sexp_bytecode_source(bc);
 #if SEXP_USE_FULL_SOURCE_INFO
       if (src && sexp_vectorp(src))
         src = sexp_lookup_source_info(src, sexp_unbox_fixnum(stack[i+3]));
 #endif
-      if (src && sexp_pairp(src)) {
-        if (sexp_fixnump(sexp_cdr(src)) && (sexp_cdr(src) >= SEXP_ZERO)) {
-          sexp_write_string(ctx, " on line ", out);
-          sexp_write(ctx, sexp_cdr(src), out);
-        }
-        if (sexp_stringp(sexp_car(src))) {
-          sexp_write_string(ctx, " of file ", out);
-          sexp_write_string(ctx, sexp_string_data(sexp_car(src)), out);
-        }
-      }
-      sexp_write_char(ctx, '\n', out);
+      cell = sexp_cons(ctx, self, src ? src : SEXP_FALSE);
+      res = sexp_cons(ctx, cell, res);
     }
   }
+  res = sexp_nreverse(ctx, res);
+  sexp_gc_release2(ctx);
+  return res;
+}
+
+void sexp_print_extracted_stack_trace (sexp ctx, sexp trace, sexp out) {
+  sexp self, bc, src, ls;
+  if (! sexp_oportp(out))
+    out = sexp_current_error_port(ctx);
+  for (ls = trace; sexp_pairp(ls); ls = sexp_cdr(ls)) {
+    self = sexp_caar(ls);
+    bc = sexp_procedure_code(self);
+    src = sexp_cdar(ls);
+    sexp_write_string(ctx, "  called from ", out);
+    if (sexp_symbolp(sexp_bytecode_name(bc)))
+      sexp_write(ctx, sexp_bytecode_name(bc), out);
+    else
+      sexp_write_string(ctx, "<anonymous>", out);
+    if (sexp_pairp(src)) {
+      if (sexp_fixnump(sexp_cdr(src)) && (sexp_cdr(src) >= SEXP_ZERO)) {
+        sexp_write_string(ctx, " on line ", out);
+        sexp_write(ctx, sexp_cdr(src), out);
+      } else {
+        sexp_write_string(ctx, " bad source line: ", out);
+        sexp_write(ctx, src, out);
+      }
+      if (sexp_stringp(sexp_car(src))) {
+        sexp_write_string(ctx, " of file ", out);
+        sexp_write_string(ctx, sexp_string_data(sexp_car(src)), out);
+      } else {
+        sexp_write_string(ctx, " bad source file: ", out);
+        sexp_write(ctx, src, out);
+      }
+    }
+    sexp_write_char(ctx, '\n', out);
+  }
+}
+
+sexp sexp_print_exception_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp out) {
+  sexp_assert_type(ctx, sexp_exceptionp, SEXP_EXCEPTION, exn);
+  sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out);
+  if (sexp_pairp(sexp_exception_stack_trace(exn))) {
+    sexp_print_extracted_stack_trace(ctx, sexp_exception_stack_trace(exn), out);
+  }
+  return SEXP_VOID;
+}
+
+void sexp_stack_trace (sexp ctx, sexp out) {
+  sexp_gc_var1(trace);
+  sexp_gc_preserve1(ctx, trace);
+  trace = sexp_get_stack_trace(ctx);
+  sexp_print_extracted_stack_trace(ctx, trace, out);
+  sexp_gc_release1(ctx);
 }
 
 sexp sexp_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp out) {
@@ -637,6 +677,13 @@ static void generate_lambda (sexp ctx, sexp name, sexp loc, sexp lam, sexp lambd
   }
   sexp_context_lambda(ctx2) = lambda;
   sexp_gc_preserve2(ctx, tmp, bc);
+#if SEXP_USE_FULL_SOURCE_INFO
+  tmp = sexp_cons(ctx, SEXP_NEG_ONE, sexp_lambda_source(lambda));
+  tmp = sexp_cons(ctx, tmp, SEXP_NULL);
+#else
+  tmp = sexp_lambda_source(lambda);
+#endif
+  sexp_bytecode_source(sexp_context_bc(ctx2)) = tmp;
   tmp = sexp_cons(ctx2, SEXP_ZERO, sexp_lambda_source(lambda));
   /* allocate space for local vars */
   k = sexp_unbox_fixnum(sexp_length(ctx, sexp_lambda_locals(lambda)));
@@ -678,12 +725,6 @@ static void generate_lambda (sexp ctx, sexp name, sexp loc, sexp lam, sexp lambd
     sexp_context_exception(ctx) = bc;
   } else {
   sexp_bytecode_name(bc) = sexp_lambda_name(lambda);
-#if SEXP_USE_FULL_SOURCE_INFO
-  sexp_bytecode_source(bc) = sexp_cons(ctx, SEXP_NEG_ONE, sexp_lambda_source(lambda));
-  sexp_bytecode_source(bc) = sexp_cons(ctx, sexp_bytecode_source(bc), SEXP_NULL);
-#else
-  sexp_bytecode_source(bc) = sexp_lambda_source(lambda);
-#endif
   if (sexp_nullp(fv)) {
     /* shortcut, no free vars */
     tmp = sexp_make_vector(ctx2, SEXP_ZERO, SEXP_VOID);
@@ -1133,6 +1174,8 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
       if (!sexp_exceptionp(_ARG1)) {
         _ARG1 = sexp_make_exception(ctx, SEXP_UNCAUGHT, SEXP_FALSE, _ARG1, self, SEXP_FALSE);
       }
+      sexp_context_top(ctx) = top;
+      sexp_exception_stack_trace(_ARG1) = sexp_get_stack_trace(ctx);
       goto end_loop;
     }
     stack[top] = SEXP_ONE;