Have `@abort' honor VM changes by winds.

* libguile/control.c (scm_c_abort): Update VM after the `scm_dowinds'
  call.

* test-suite/tests/control.test ("the-vm"): New test prefix.

diff --git a/libguile/control.c b/libguile/control.c
index 99bc846..a696895 100644 (file)
--- a/libguile/control.c
+++ b/libguile/control.c
@@ -211,10 +211,14 @@ scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv, scm_t_int64 cookie)
 
   /* Unwind once more, beyond the prompt. */
   winds = SCM_CDR (winds), delta++;
-  
+
   /* Unwind */
   scm_dowinds (winds, delta);
 
+  /* Unwinding may have changed the current thread's VM, so use the
+     new one.  */
+  vm = scm_the_vm ();
+
   /* Restore VM regs */
   SCM_VM_DATA (vm)->fp = SCM_PROMPT_REGISTERS (prompt)->fp;
   SCM_VM_DATA (vm)->sp = SCM_PROMPT_REGISTERS (prompt)->sp;

diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test
index b3ab707..a4173ff 100644 (file)
--- a/test-suite/tests/control.test
+++ b/test-suite/tests/control.test
@@ -19,6 +19,7 @@
 
 (define-module (test-suite test-control)
   #:use-module (ice-9 control)
+  #:use-module (system vm vm)
   #:use-module (srfi srfi-11)
   #:use-module (test-suite lib))
 
@@ -225,3 +226,28 @@
 (with-test-prefix "abort to unknown prompt"
   (pass-if-exception "foo" '(misc-error . "^Abort to unknown prompt")
                      (abort-to-prompt 'does-not-exist)))
+
+(with-test-prefix "the-vm"
+
+  (pass-if "unwind changes VMs"
+    (let ((new-vm  (make-vm))
+          (prev-vm (the-vm))
+          (proc    (lambda (x y)
+                     (expt x y)))
+          (call    (lambda (p x y)
+                     (p x y))))
+      (catch 'foo
+        (lambda ()
+          (dynamic-wind
+            (lambda ()
+              (set-thread-vm! (current-thread) new-vm))
+            (lambda ()
+              (vm-apply new-vm
+                        (lambda () (throw 'foo (the-vm)))
+                        '()))
+            (lambda ()
+              (set-thread-vm! (current-thread) prev-vm))))
+        (lambda (key vm)
+          (and (eq? key 'foo)
+               (eq? vm new-vm)
+               (eq? (the-vm) prev-vm)))))))