From 68cb4d634d5065f76a03fc8f2c7b1a8012acd96c Mon Sep 17 00:00:00 2001
From: Hamayama <fkyo0985@gmail.com>
Date: Thu, 4 Jan 2024 04:05:54 +0900
Subject: [PATCH] Display additional stack trace for r7rs#import error v2

---
 src/error.c     | 19 +++++++++++++++++++
 src/gauche/vm.h |  4 ++++
 src/vm.c        | 17 +++++++++++++++++
 3 files changed, 40 insertions(+)

diff --git a/src/error.c b/src/error.c
index dac62f07f..984e1b235 100644
--- a/src/error.c
+++ b/src/error.c
@@ -1128,6 +1128,25 @@ void Scm_DumpStackTrace(ScmVM *vm, ScmPort *port)
     SCM_PUTZ("Stack Trace:\n", -1, port);
     SCM_PUTZ("_______________________________________\n", -1, port);
     Scm_ShowStackTrace(port, stack, 0, 0, 0, 0);
+
+    /* display additional stack trace */
+    if (vm->errorCont) {
+        ScmContFrame *vmcont = vm->cont;
+        ScmCompiledCode *vmbase = vm->base;
+        vm->cont = vm->errorCont;
+        vm->base = NULL;
+        ScmObj stack2 = Scm_VMGetStackLite(vm);
+        if (!Scm_EqualP(stack, stack2)) {
+            SCM_PUTZ("Stack Trace on Error:\n", -1, port);
+            SCM_PUTZ("_______________________________________\n", -1, port);
+            Scm_ShowStackTrace(port, stack2, 0, 0, 0, 0);
+        }
+        vm->cont = vmcont;
+        vm->base = vmbase;
+        /* reset information for additional stack trace */
+        vm->errorCont = NULL;
+    }
+
     if (SCM_PAIRP(calls)) {
         SCM_PUTZ("Call Trace:\n", -1, port);
         SCM_PUTZ("_______________________________________\n", -1, port);
diff --git a/src/gauche/vm.h b/src/gauche/vm.h
index ab3eeb80e..ef8fb814f 100644
--- a/src/gauche/vm.h
+++ b/src/gauche/vm.h
@@ -580,6 +580,10 @@ struct ScmVMRec {
                                    appears in 'reset' and the end marker of
                                    partial continuation is set. */
 
+    /* for additional stack trace */
+    ScmContFrame *errorCont;    /* continuation saved on error.
+                                   this is used to display stack trace
+                                   that is dropped during import. */
 };
 
 SCM_EXTERN ScmVM *Scm_NewVM(ScmVM *proto, ScmObj name);
diff --git a/src/vm.c b/src/vm.c
index dac3628db..d81d2edc9 100644
--- a/src/vm.c
+++ b/src/vm.c
@@ -345,6 +345,8 @@ ScmVM *Scm_NewVM(ScmVM *proto, ScmObj name)
     v->currentPrompt = NULL;
     v->resetChain = SCM_NIL;
 
+    v->errorCont = NULL;
+
     Scm_RegisterFinalizer(SCM_OBJ(v), vm_finalize, NULL);
     return v;
 }
@@ -452,6 +454,9 @@ ScmVM *Scm_VMTakeSnapshot(ScmVM *master)
 
     v->currentPrompt = master->currentPrompt;
     v->resetChain = master->resetChain;
+
+    v->errorCont = master->errorCont;
+
     /* NB: We don't register the finalizer vm_finalize to the snapshot,
        for we do not want the associated system resources to be cleaned
        up when the snapshot is GCed. */
@@ -2288,8 +2293,17 @@ struct eval_packet_rec {
 static ScmObj safe_eval_handler(ScmObj *args,
                                 int nargs, void *data)
 {
+    ScmVM *vm = theVM;
+
     SCM_ASSERT(nargs == 1);
     ((struct eval_packet_rec *)data)->exception = args[0];
+
+    /* save information for additional stack trace */
+    if (vm->errorCont == NULL) {
+        save_cont(vm);
+        vm->errorCont = vm->cont;
+    }
+
     return SCM_UNDEFINED;
 }
 
@@ -2342,6 +2356,9 @@ static int safe_eval_wrap(int kind, ScmObj arg0, ScmObj args,
     epak.cstr = cstr;
     epak.exception = SCM_UNBOUND;
 
+    /* reset information for additional stack trace */
+    vm->errorCont = NULL;
+
     ScmObj proc = Scm_MakeSubr(safe_eval_int, &epak, 0, 0, SCM_FALSE);
     ScmObj r = Scm_ApplyRec(proc, SCM_NIL);