[PATCH 3/3] Implement Guile exceptions with C++ exceptions.

[Taahir Ahmed <ahmed.taahir@gmail.com>]

eh-jmp.{h,cc} contain setjmp/longjmp analogues that use C++ exceptions
to unwind the stack.  This means that C++ destructors will be called
properly in when a guile exception passes through a user code frame.

Flow control to resume a continuation remains implemented with
setjmp/longjmp, since it appears that in some places the jump travels
down the stack.
---
 libguile/Makefile.am                          |  1 +
 libguile/control.c                            |  6 ++-
 libguile/eh-jmp.cc                            | 39 ++++++++++++++
 libguile/eh-jmp.h                             | 23 ++++++++
 libguile/eval.c                               | 35 +++++++++---
 libguile/threads.h                            |  5 --
 libguile/throw.c                              | 34 +++++++++---
 libguile/vm-engine.c                          |  5 +-
 libguile/vm.c                                 | 57 ++++++++++++++++----
 test-suite/standalone/Makefile.am             |  7 +++
 test-suite/standalone/test-cpp-destructors.cc | 77 
+++++++++++++++++++++++++++
 11 files changed, 259 insertions(+), 30 deletions(-)
 create mode 100644 libguile/eh-jmp.cc
 create mode 100644 libguile/eh-jmp.h
 create mode 100644 test-suite/standalone/test-cpp-destructors.cc

diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index cc88215..f5e746f 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -140,6 +140,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES =			
	\
 	deprecation.c				\
 	dynstack.c				\
 	dynwind.c				\
+	eh-jmp.cc				\
 	eq.c					\
 	error.c					\
 	eval.c					\
diff --git a/libguile/control.c b/libguile/control.c
index 347d697..53e3241 100644
--- a/libguile/control.c
+++ b/libguile/control.c
@@ -24,6 +24,7 @@
 
 #include "libguile/_scm.h"
 #include "libguile/control.h"
+#include "libguile/eh-jmp.h"
 #include "libguile/programs.h"
 #include "libguile/instructions.h"
 #include "libguile/vm.h"
@@ -37,7 +38,8 @@
 \f
 
 
-/* Only to be called if the SCM_I_SETJMP returns 1 */
+/* Only to be called if we are returning to a prompt via nonlocal
+   jump. */
 SCM
 scm_i_prompt_pop_abort_args_x (struct scm_vm *vp)
 {
@@ -177,7 +179,7 @@ scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM 
*argv,
     *(++(vp->sp)) = scm_from_size_t (n+1); /* +1 for continuation */
 
   /* Jump! */
-  SCM_I_LONGJMP (*registers, 1);
+  eh_throw (tag);
 
   /* Shouldn't get here */
   abort ();
diff --git a/libguile/eh-jmp.cc b/libguile/eh-jmp.cc
new file mode 100644
index 0000000..f5b7b80
--- /dev/null
+++ b/libguile/eh-jmp.cc
@@ -0,0 +1,39 @@
+#include "libguile/eh-jmp.h"
+
+struct prompt_exception
+{
+  SCM tag;
+};
+
+int eh_catch (SCM *taglist, tryfn_scm fn, SCM *result, ...)
+{
+  va_list ap;
+  va_start (ap, result);
+
+  try
+    {
+      *result = fn (ap);
+      va_end (ap);
+      return 0;
+    }
+  catch (prompt_exception e)
+    {
+      va_end(ap);
+
+      for (SCM rest = *taglist; rest != SCM_EOL; rest = scm_cdr (rest))
+        {
+          SCM cur_key = scm_car (rest);
+
+          if (scm_is_eq (cur_key, e.tag))
+            return 1;
+        }
+
+      throw e;
+    }
+}
+
+void eh_throw(SCM tag)
+{
+  prompt_exception e = {tag};
+  throw e;
+}
diff --git a/libguile/eh-jmp.h b/libguile/eh-jmp.h
new file mode 100644
index 0000000..6730895
--- /dev/null
+++ b/libguile/eh-jmp.h
@@ -0,0 +1,23 @@
+#ifndef LIBGUILE_EH_JMP_H
+#define LIBGUILE_EH_JMP_H
+
+#include <stdarg.h>
+
+#include "libguile/__scm.h"
+#include "libguile/_scm.h"
+#include "libguile/pairs.h"
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+typedef SCM (* tryfn_scm) (va_list);
+
+int  eh_catch (SCM *taglist, tryfn_scm fn, SCM *result, ...);
+void eh_throw (SCM taglist) SCM_NORETURN;
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
diff --git a/libguile/eval.c b/libguile/eval.c
index 735e6c0..c83b7e7 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -37,6 +37,7 @@
 #include "libguile/debug.h"
 #include "libguile/deprecation.h"
 #include "libguile/dynwind.h"
+#include "libguile/eh-jmp.h"
 #include "libguile/eq.h"
 #include "libguile/expand.h"
 #include "libguile/feature.h"
@@ -238,6 +239,8 @@ truncate_values (SCM x)
 }
 #define EVAL1(x, env) (truncate_values (eval ((x), (env))))
 
+static SCM try_call_with_prompt(va_list ap);
+
 static SCM
 eval (SCM x, SCM env)
 {
@@ -424,13 +427,14 @@ eval (SCM x, SCM env)
     case SCM_M_CALL_WITH_PROMPT:
       {
         struct scm_vm *vp;
-        SCM k, res;
+        SCM tag, res;
+        SCM taglist;
         scm_i_jmp_buf registers;
         /* We need the handler after nonlocal return to the setjmp, so
            make sure it is volatile.  */
         volatile SCM handler;
 
-        k = EVAL1 (CAR (mx), env);
+        tag = EVAL1 (CAR (mx), env);
         handler = EVAL1 (CDDR (mx), env);
         vp = scm_the_vm ();
 
@@ -438,13 +442,15 @@ eval (SCM x, SCM env)
         scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack,
                                   SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
                                   | SCM_F_DYNSTACK_PROMPT_PUSH_NARGS,
-                                  k,
+                                  tag,
                                   vp->fp - vp->stack_base,
                                   vp->sp - vp->stack_base,
                                   vp->ip,
                                   &registers);
 
-        if (SCM_I_SETJMP (registers))
+        taglist = scm_cons (tag, SCM_EOL);
+        if (eh_catch (&taglist, try_call_with_prompt, &res, mx, env,
+                      &SCM_I_CURRENT_THREAD->dynstack))
           {
             /* The prompt exited nonlocally. */
             scm_gc_after_nonlocal_exit ();
@@ -453,9 +459,7 @@ eval (SCM x, SCM env)
             args = scm_i_prompt_pop_abort_args_x (vp);
             goto apply_proc;
           }
-        
-        res = scm_call_0 (eval (CADR (mx), env));
-        scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
+
         return res;
       }
 
@@ -464,6 +468,23 @@ eval (SCM x, SCM env)
     }
 }
 
+static SCM
+try_call_with_prompt(va_list ap)
+{
+  SCM res;
+  SCM mx;
+  SCM env;
+  scm_t_dynstack *dynstack;
+
+  mx       = va_arg (ap, SCM);
+  env      = va_arg (ap, SCM);
+  dynstack = va_arg (ap, scm_t_dynstack*);
+
+  res = scm_call_0 (eval (CADR (mx), env));
+  scm_dynstack_pop (dynstack);
+  return res;
+}
+
 \f
 
 /* Simple procedure calls
diff --git a/libguile/threads.h b/libguile/threads.h
index cb61bbc..1c1f0e3 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -115,11 +115,6 @@ typedef struct scm_i_thread {
   /* For keeping track of the stack and registers. */
   struct scm_vm *vp;
   SCM_STACKITEM *base;
-  scm_i_jmp_buf regs;
-#ifdef __ia64__
-  void *register_backing_store_base;
-  scm_t_contregs *pending_rbs_continuation;
-#endif
 
   /* Whether this thread is in a critical section. */
   int critical_section_level;
diff --git a/libguile/throw.c b/libguile/throw.c
index bbde5e0..f784df7 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -23,10 +23,12 @@
 #endif
 
 #include <alloca.h>
+#include <stdarg.h>
 #include <stdio.h>
 #include <unistdio.h>
 #include "libguile/_scm.h"
 #include "libguile/smob.h"
+#include "libguile/eh-jmp.h"
 #include "libguile/eval.h"
 #include "libguile/eq.h"
 #include "libguile/control.h"
@@ -69,11 +71,34 @@ static SCM throw_var;
 
 static SCM exception_handler_fluid;
 
+/* A helper function for eh_tryfn_prompt.  Indirectly invoked below in
+   catch. */
+static SCM
+call_helper (va_list ap)
+{
+  SCM res;
+  SCM thunk;
+  scm_t_dynstack *dynstack;
+  SCM dynamic_state;
+
+  thunk         = va_arg (ap, SCM);
+  dynstack      = va_arg (ap, scm_t_dynstack*);
+  dynamic_state = va_arg (ap, SCM);
+
+  res = scm_call_0 (thunk);
+
+  scm_dynstack_unwind_fluid (dynstack, dynamic_state);
+  scm_dynstack_pop (dynstack);
+
+  return res;
+}
+
 static SCM
 catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
 {
   struct scm_vm *vp;
   SCM eh, prompt_tag;
+  SCM taglist;
   SCM res;
   scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
   SCM dynamic_state = SCM_I_CURRENT_THREAD->dynamic_state;
@@ -116,7 +141,9 @@ catch (SCM tag, SCM thunk, SCM handler, SCM 
pre_unwind_handler)
   scm_dynstack_push_fluid (dynstack, exception_handler_fluid, eh,
                            dynamic_state);
 
-  if (SCM_I_SETJMP (registers))
+  taglist = scm_cons (prompt_tag, SCM_EOL);
+  if (eh_catch (&taglist, call_helper, &res, thunk, dynstack,
+               dynamic_state))
     {
       /* A non-local return.  */
       SCM args;
@@ -133,11 +160,6 @@ catch (SCM tag, SCM thunk, SCM handler, SCM 
pre_unwind_handler)
       return scm_apply_0 (handler, args);
     }
 
-  res = scm_call_0 (thunk);
-
-  scm_dynstack_unwind_fluid (dynstack, dynamic_state);
-  scm_dynstack_pop (dynstack);
-
   return res;
 }
 
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 7e752dd..628b951 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -419,7 +419,7 @@
   ((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
 
 static SCM
-VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
+VM_NAME (SCM *catch_taglist, scm_i_thread *thread, struct scm_vm *vp,
          scm_i_jmp_buf *registers, int resume)
 {
   /* Instruction pointer: A pointer to the opcode that is currently
@@ -2069,6 +2069,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
                                 LOCAL_ADDRESS (proc_slot) - vp->stack_base,
                                 ip + offset,
                                 registers);
+
+      *catch_taglist = scm_cons (LOCAL_REF (tag), *catch_taglist);
+
       NEXT (3);
     }
 
diff --git a/libguile/vm.c b/libguile/vm.c
index 0e59835..7ac6523 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -39,6 +39,7 @@
 
 #include "_scm.h"
 #include "control.h"
+#include "eh-jmp.h"
 #include "frames.h"
 #include "gc-inline.h"
 #include "instructions.h"
@@ -783,7 +784,7 @@ scm_i_call_with_current_continuation (SCM proc)
 #undef VM_USE_HOOKS
 #undef VM_NAME
 
-typedef SCM (*scm_t_vm_engine) (scm_i_thread *current_thread, struct scm_vm 
*vp,
+typedef SCM (*scm_t_vm_engine) (SCM *taglist, scm_i_thread *current_thread, 
struct scm_vm *vp,
                                 scm_i_jmp_buf *registers, int resume);
 
 static const scm_t_vm_engine vm_engines[SCM_VM_NUM_ENGINES] =
@@ -1204,6 +1205,26 @@ scm_the_vm (void)
   return thread_vm (SCM_I_CURRENT_THREAD);
 }
 
+static SCM
+try_call_engine (va_list ap)
+{
+  scm_t_vm_engine engine;
+  SCM *taglist;
+  scm_i_thread *thread;
+  struct scm_vm *vp;
+  scm_i_jmp_buf *registers;
+  int resume;
+
+  engine    = va_arg (ap, scm_t_vm_engine);
+  taglist   = va_arg (ap, SCM*);
+  thread    = va_arg (ap, scm_i_thread*);
+  vp        = va_arg (ap, struct scm_vm*);
+  registers = va_arg (ap, scm_i_jmp_buf*);
+  resume    = va_arg (ap, int);
+
+  return engine (taglist, thread, vp, registers, resume);
+}
+
 SCM
 scm_call_n (SCM proc, SCM *argv, size_t nargs)
 {
@@ -1246,16 +1267,34 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs)
   vp->fp = &base[5];
 
   {
-    int resume = SCM_I_SETJMP (registers);
-      
-    if (SCM_UNLIKELY (resume))
+    int resume = 0;
+    SCM res;
+    scm_t_vm_engine engine;
+    SCM taglist;
+
+    engine = vm_engines[vp->engine];
+
+    taglist = SCM_EOL;
+
+    while (1)
       {
-        scm_gc_after_nonlocal_exit ();
-        /* Non-local return.  */
-        vm_dispatch_abort_hook (vp);
+        resume = eh_catch(/* Arguments used by eh_catch. */
+                          &taglist, try_call_engine, &res,
+                          /* Arguments consumed by try_call_engine. */
+                          engine,
+                          /* Arguments sent to the engine. */
+                          &taglist, thread, vp, &registers, resume);
+        if (resume)
+          {
+            scm_gc_after_nonlocal_exit ();
+            /* Non-local return.  */
+            vm_dispatch_abort_hook (vp);
+          }
+        else
+          {
+            return res;
+          }
       }
-
-    return vm_engines[vp->engine](thread, vp, &registers, resume);
   }
 }
 
diff --git a/test-suite/standalone/Makefile.am b/test-
suite/standalone/Makefile.am
index 5138b15..01270f9 100644
--- a/test-suite/standalone/Makefile.am
+++ b/test-suite/standalone/Makefile.am
@@ -96,6 +96,13 @@ EXTRA_DIST += test-language.el test-language.js
 check_SCRIPTS += test-guild-compile
 TESTS += test-guild-compile
 
+# test-cpp-destructors
+test_cpp_destructors_SOURCES = test-cpp-destructors.cc
+test_cpp_destructors_CFLAGS = ${test_cflags}
+test_cpp_destructors_LDADD = ${LIBGUILE_LDADD}
+check_PROGRAMS += test-cpp-destructors
+TESTS += test-cpp-destructors
+
 # test-num2integral
 test_num2integral_SOURCES = test-num2integral.c
 test_num2integral_CFLAGS = ${test_cflags}
diff --git a/test-suite/standalone/test-cpp-destructors.cc b/test-
suite/standalone/test-cpp-destructors.cc
new file mode 100644
index 0000000..99fbf32
--- /dev/null
+++ b/test-suite/standalone/test-cpp-destructors.cc
@@ -0,0 +1,77 @@
+// test-cpp-destructors.c
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <cstdlib>
+
+#include <iostream>
+
+#include <libguile.h>
+
+// Canary value to track constructor/destructor execution.
+//
+//   0: constructor has not yet run
+//
+//   1: constructor has run
+//
+//   2: destructor has run
+static int canary = 0;
+
+struct miner
+{
+    miner()
+    {
+        canary = 1;
+    }
+
+    ~miner()
+    {
+        canary = 2;
+    }
+};
+
+static SCM test_miner(void *data)
+{
+    miner bob;
+
+    SCM should_be_int = static_cast<SCM>(data);
+    int dummy = scm_to_int(should_be_int);
+
+    return SCM_BOOL_T;
+}
+
+static SCM test_miner_handler(void *data, SCM key, SCM args)
+{
+    // Do nothing.
+
+    return SCM_BOOL_T;
+}
+
+static void tests(void *data, int argc, char **argv)
+{
+    SCM test_data = scm_from_utf8_string("Ceci n'est pas un int.");
+    scm_internal_catch(
+        SCM_BOOL_T,
+        test_miner,
+        static_cast<void*>(&test_data),
+        test_miner_handler,
+        NULL
+    );
+
+    // Check if destructor ran.
+    if(canary != 2)
+    {
+        std::cerr << "Destructor was not run by guile exception." << 
std::endl;
+        std::exit(1);
+    }
+
+    std::exit(0);
+}
+
+int main(int argc,  char **argv)
+{
+    scm_boot_guile(argc, argv, tests, NULL);
+    return 0;
+}
-- 
2.3.6