Avoid stacks in dynamically-bound values

* libguile/dynstack.h:
* libguile/dynstack.c (scm_dynstack_find_old_fluid_value): New
  function.
* libguile/fluids.c (saved_dynamic_state_ref): New helper.
  (scm_fluid_ref): Fix docstring.
  (scm_fluid_ref_star): New function allowing access to previous values
  for a fluid.
  (scm_dynamic_state_ref): New internal function.
* libguile/fluids.h: Add scm_fluid_ref_star and scm_dynamic_state_ref.
* libguile/stacks.c (scm_stack_id): Adapt to %stacks not being a chain.
* libguile/throw.c (catch, throw_without_pre_unwind): Adapt to
  %exception-handlers not being a chain.
* module/ice-9/boot-9.scm (catch, dispatch-exception): Instead of having
  %exception-handlers be a chain, use fluid-ref* to access the chain
  that is in place at the time the exception is thrown.  Prevents
  unintended undelimited capture of the current exception handler stack
  by a delimited "catch".
  (%start-stack): Similarly, don't be a chain.
* module/system/repl/debug.scm (frame->stack-vector):
* module/system/repl/error-handling.scm (call-with-error-handling):
* module/ice-9/save-stack.scm (save-stack): Adapt to %stacks not being a
  chain.
* test-suite/tests/exceptions.test ("delimited exception handlers"): Add
  tests.
* doc/ref/api-control.texi (Fluids and Dynamic States): Add docs.

12 files changed, 221 insertions, 67 deletions

diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi
index 73fbe3607..77d98b44e 100644
--- a/doc/ref/api-control.texi
+++ b/doc/ref/api-control.texi
@@ -1765,6 +1765,21 @@ a runtime error.
 Set the value associated with @var{fluid} in the current dynamic root.
 @end deffn
 
+@deffn {Scheme Procedure} fluid-ref* fluid depth
+@deffnx {C Function} scm_fluid_ref_star (fluid, depth)
+Return the @var{depth}th oldest value associated with @var{fluid} in the
+current thread.  If @var{depth} equals or exceeds the number of values
+that have been assigned to @var{fluid}, return the default value of the
+fluid.  @code{(fluid-ref* f 0)} is equivalent to @code{(fluid-ref f)}.
+
+@code{fluid-ref*} is useful when you want to maintain a stack-like
+structure in a fluid, such as the stack of current exception handlers.
+Using @code{fluid-ref*} instead of an explicit stack allows any partial
+continuation captured by @code{call-with-prompt} to only capture the
+bindings made within the limits of the prompt instead of the entire
+continuation.  @xref{Prompts}, for more on delimited continuations.
+@end deffn
+
 @deffn {Scheme Procedure} fluid-unset! fluid
 @deffnx {C Function} scm_fluid_unset_x (fluid)
 Disassociate the given fluid from any value, making it unbound.
diff --git a/libguile/dynstack.c b/libguile/dynstack.c
index ff57c430d..652d2b35a 100644
--- a/libguile/dynstack.c
+++ b/libguile/dynstack.c
@@ -504,6 +504,55 @@ scm_dynstack_find_prompt (scm_t_dynstack *dynstack, SCM key,
   return NULL;
 }
 
+SCM
+scm_dynstack_find_old_fluid_value (scm_t_dynstack *dynstack, SCM fluid,
+                                   size_t depth, SCM dflt)
+{
+  scm_t_bits *walk;
+
+  for (walk = SCM_DYNSTACK_PREV (dynstack->top); walk;
+       walk = SCM_DYNSTACK_PREV (walk))
+    {
+      scm_t_bits tag = SCM_DYNSTACK_TAG (walk);
+
+      switch (SCM_DYNSTACK_TAG_TYPE (tag))
+        {
+        case SCM_DYNSTACK_TYPE_WITH_FLUID:
+          {
+            if (scm_is_eq (WITH_FLUID_FLUID (walk), fluid))
+              {
+                if (depth == 0)
+                  return SCM_VARIABLE_REF (WITH_FLUID_VALUE_BOX (walk));
+                else
+                  depth--;
+              }
+            break;
+          }
+        case SCM_DYNSTACK_TYPE_DYNAMIC_STATE:
+          {
+            SCM state, val;
+
+            /* The previous dynamic state may or may not have
+               established a binding for this fluid.  */
+            state = scm_variable_ref (DYNAMIC_STATE_STATE_BOX (walk));
+            val = scm_dynamic_state_ref (state, fluid, SCM_UNDEFINED);
+            if (!SCM_UNBNDP (val))
+              {
+                if (depth == 0)
+                  return val;
+                else
+                  depth--;
+              }
+            break;
+          }
+        default:
+          break;
+        }
+    }
+
+  return dflt;
+}
+
 void
 scm_dynstack_wind_prompt (scm_t_dynstack *dynstack, scm_t_bits *item,
                           scm_t_ptrdiff reloc, scm_i_jmp_buf *registers)
diff --git a/libguile/dynstack.h b/libguile/dynstack.h
index 9d91fb667..7e191fc27 100644
--- a/libguile/dynstack.h
+++ b/libguile/dynstack.h
@@ -201,6 +201,9 @@ SCM_INTERNAL scm_t_bits* scm_dynstack_find_prompt (scm_t_dynstack *, SCM,
                                                    scm_t_uint32 **,
                                                    scm_i_jmp_buf **);
 
+SCM_INTERNAL SCM scm_dynstack_find_old_fluid_value (scm_t_dynstack *,
+                                                    SCM, size_t, SCM);
+
 SCM_INTERNAL void scm_dynstack_wind_prompt (scm_t_dynstack *, scm_t_bits *,
                                             scm_t_ptrdiff, scm_i_jmp_buf *);
 
diff --git a/libguile/fluids.c b/libguile/fluids.c
index 72c75952d..7daad7781 100644
--- a/libguile/fluids.c
+++ b/libguile/fluids.c
@@ -148,6 +148,16 @@ save_dynamic_state (scm_t_dynamic_state *state)
 }
 
 static SCM
+saved_dynamic_state_ref (SCM saved, SCM fluid, SCM dflt)
+{
+  for (; scm_is_pair (saved); saved = SCM_CDR (saved))
+    if (scm_is_eq (SCM_CAAR (saved), fluid))
+      return SCM_CDAR (saved);
+
+  return scm_weak_table_refq (saved, fluid, dflt);
+}
+
+static SCM
 add_entry (void *data, SCM k, SCM v, SCM result)
 {
   scm_weak_table_putq_x (result, k, v);
@@ -300,7 +310,7 @@ SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0,
 	    (SCM fluid),
 	    "Return the value associated with @var{fluid} in the current\n"
 	    "dynamic root.  If @var{fluid} has not been set, then return\n"
-	    "@code{#f}.")
+	    "its default value.")
 #define FUNC_NAME s_scm_fluid_ref
 {
   SCM ret;
@@ -312,6 +322,33 @@ SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_fluid_ref_star, "fluid-ref*", 2, 0, 0,
+	    (SCM fluid, SCM depth),
+	    "Return the @var{depth}th oldest value associated with\n"
+            "@var{fluid} in the current thread.  If @var{depth} equals\n"
+            "or exceeds the number of values that have been assigned to\n"
+            "@var{fluid}, return the default value of the fluid.")
+#define FUNC_NAME s_scm_fluid_ref_star
+{
+  SCM ret;
+  size_t c_depth;
+
+  SCM_VALIDATE_FLUID (1, fluid);
+  c_depth = SCM_NUM2SIZE (2, depth);
+
+  if (c_depth == 0)
+    ret = fluid_ref (SCM_I_CURRENT_THREAD->dynamic_state, fluid);
+  else
+    ret = scm_dynstack_find_old_fluid_value (&SCM_I_CURRENT_THREAD->dynstack,
+                                             fluid, c_depth - 1,
+                                             SCM_I_FLUID_DEFAULT (fluid));
+
+  if (SCM_UNBNDP (ret))
+    scm_misc_error ("fluid-ref*", "unbound fluid: ~S", scm_list_1 (fluid));
+  return ret;
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0,
 	    (SCM fluid, SCM value),
 	    "Set the value associated with @var{fluid} in the current dynamic root.")
@@ -499,6 +536,14 @@ SCM_DEFINE (scm_set_current_dynamic_state, "set-current-dynamic-state", 1,0,0,
 }
 #undef FUNC_NAME
 
+SCM
+scm_dynamic_state_ref (SCM state, SCM fluid, SCM dflt)
+{
+  SCM_ASSERT (is_dynamic_state (state), state, SCM_ARG1,
+              "dynamic-state-ref");
+  return saved_dynamic_state_ref (get_dynamic_state (state), fluid, dflt);
+}
+
 static void
 swap_dynamic_state (SCM loc)
 {
diff --git a/libguile/fluids.h b/libguile/fluids.h
index 8031c0d48..6d7969e15 100644
--- a/libguile/fluids.h
+++ b/libguile/fluids.h
@@ -56,6 +56,7 @@ SCM_API SCM scm_make_unbound_fluid (void);
 SCM_API int scm_is_fluid (SCM obj);
 SCM_API SCM scm_fluid_p (SCM fl);
 SCM_API SCM scm_fluid_ref (SCM fluid);
+SCM_API SCM scm_fluid_ref_star (SCM fluid, SCM depth);
 SCM_API SCM scm_fluid_set_x (SCM fluid, SCM value);
 SCM_API SCM scm_fluid_unset_x (SCM fluid);
 SCM_API SCM scm_fluid_bound_p (SCM fluid);
@@ -80,6 +81,7 @@ SCM_API void scm_dynwind_current_dynamic_state (SCM state);
 SCM_API void *scm_c_with_dynamic_state (SCM state, 
 					void *(*func)(void *), void *data);
 SCM_API SCM scm_with_dynamic_state (SCM state, SCM proc);
+SCM_INTERNAL SCM scm_dynamic_state_ref (SCM state, SCM fluid, SCM dflt);
 
 SCM_INTERNAL SCM scm_i_make_initial_dynamic_state (void);
 
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 3d02d81f6..99ee233e3 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -414,7 +414,7 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
     {
       /* Fetch most recent start-stack tag. */
       SCM stacks = scm_fluid_ref (scm_sys_stacks);
-      return scm_is_pair (stacks) ? scm_caar (stacks) : SCM_BOOL_F;
+      return scm_is_pair (stacks) ? scm_car (stacks) : SCM_BOOL_F;
     }
   else if (SCM_CONTINUATIONP (stack))
     /* FIXME: implement me */
diff --git a/libguile/throw.c b/libguile/throw.c
index c3a46161b..5f6dcfa90 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -96,11 +96,10 @@ catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
 
   prompt_tag = scm_cons (SCM_INUM0, SCM_EOL);
 
-  eh = scm_c_make_vector (4, SCM_BOOL_F);
-  scm_c_vector_set_x (eh, 0, scm_fluid_ref (exception_handler_fluid));
-  scm_c_vector_set_x (eh, 1, tag);
-  scm_c_vector_set_x (eh, 2, prompt_tag);
-  scm_c_vector_set_x (eh, 3, pre_unwind_handler);
+  eh = scm_c_make_vector (3, SCM_BOOL_F);
+  scm_c_vector_set_x (eh, 0, tag);
+  scm_c_vector_set_x (eh, 1, prompt_tag);
+  scm_c_vector_set_x (eh, 2, pre_unwind_handler);
 
   vp = scm_the_vm ();
   prev_cookie = vp->resumable_prompt_cookie;
@@ -201,23 +200,26 @@ abort_to_prompt (SCM prompt_tag, SCM tag, SCM args)
 static SCM
 throw_without_pre_unwind (SCM tag, SCM args)
 {
-  SCM eh;
+  size_t depth = 0;
 
   /* This function is not only the boot implementation of "throw", it is
      also called in response to resource allocation failures such as
      stack-overflow or out-of-memory.  For that reason we need to be
      careful to avoid allocating memory.  */
-  for (eh = scm_fluid_ref (exception_handler_fluid);
-       scm_is_true (eh);
-       eh = scm_c_vector_ref (eh, 0))
+  while (1)
     {
-      SCM catch_key, prompt_tag;
+      SCM eh, catch_key, prompt_tag;
 
-      catch_key = scm_c_vector_ref (eh, 1);
+      eh = scm_fluid_ref_star (exception_handler_fluid,
+                               scm_from_size_t (depth++));
+      if (scm_is_false (eh))
+        break;
+
+      catch_key = scm_c_vector_ref (eh, 0);
       if (!scm_is_eq (catch_key, SCM_BOOL_T) && !scm_is_eq (catch_key, tag))
         continue;
 
-      if (scm_is_true (scm_c_vector_ref (eh, 3)))
+      if (scm_is_true (scm_c_vector_ref (eh, 2)))
         {
           const char *key_chars;
 
@@ -230,7 +232,7 @@ throw_without_pre_unwind (SCM tag, SCM args)
                    "skipping pre-unwind handler.\n", key_chars);
         }
 
-      prompt_tag = scm_c_vector_ref (eh, 2);
+      prompt_tag = scm_c_vector_ref (eh, 1);
       if (scm_is_true (prompt_tag))
         abort_to_prompt (prompt_tag, tag, args);
     }
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 802ca7735..229d91734 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -720,48 +720,59 @@ information is unavailable."
 (define with-throw-handler #f)
 (let ((%eh (module-ref (current-module) '%exception-handler)))
   (define (make-exception-handler catch-key prompt-tag pre-unwind)
-    (vector (fluid-ref %eh) catch-key prompt-tag pre-unwind))
-  (define (exception-handler-prev handler) (vector-ref handler 0))
-  (define (exception-handler-catch-key handler) (vector-ref handler 1))
-  (define (exception-handler-prompt-tag handler) (vector-ref handler 2))
-  (define (exception-handler-pre-unwind handler) (vector-ref handler 3))
-
-  (define %running-pre-unwind (make-fluid '()))
-
-  (define (dispatch-exception handler key args)
-    (unless handler
-      (when (eq? key 'quit)
-        (primitive-exit (cond
-                         ((not (pair? args)) 0)
-                         ((integer? (car args)) (car args))
-                         ((not (car args)) 1)
-                         (else 0))))
-      (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" key args)
-      (primitive-exit 1))
-
-    (let ((catch-key (exception-handler-catch-key handler))
-          (prev (exception-handler-prev handler)))
-      (if (or (eqv? catch-key #t) (eq? catch-key key))
-          (let ((prompt-tag (exception-handler-prompt-tag handler))
-                (pre-unwind (exception-handler-pre-unwind handler)))
-            (if pre-unwind
-                ;; Instead of using a "running" set, it would be a lot
-                ;; cleaner semantically to roll back the exception
-                ;; handler binding to the one that was in place when the
-                ;; pre-unwind handler was installed, and keep it like
-                ;; that for the rest of the dispatch.  Unfortunately
-                ;; that is incompatible with existing semantics.  We'll
-                ;; see if we can change that later on.
-                (let ((running (fluid-ref %running-pre-unwind)))
-                  (with-fluid* %running-pre-unwind (cons handler running)
-                    (lambda ()
-                      (unless (memq handler running)
-                        (apply pre-unwind key args))
-                      (if prompt-tag
-                          (apply abort-to-prompt prompt-tag key args)
-                          (dispatch-exception prev key args)))))
-                (apply abort-to-prompt prompt-tag key args)))
-          (dispatch-exception prev key args))))
+    (vector catch-key prompt-tag pre-unwind))
+  (define (exception-handler-catch-key handler) (vector-ref handler 0))
+  (define (exception-handler-prompt-tag handler) (vector-ref handler 1))
+  (define (exception-handler-pre-unwind handler) (vector-ref handler 2))
+
+  (define %running-pre-unwind (make-fluid #f))
+  (define (pre-unwind-handler-running? handler)
+    (let lp ((depth 0))
+      (let ((running (fluid-ref* %running-pre-unwind depth)))
+        (and running
+             (or (eq? running handler) (lp (1+ depth)))))))
+
+  (define (dispatch-exception depth key args)
+    (cond
+     ((fluid-ref* %eh depth)
+      => (lambda (handler)
+           (let ((catch-key (exception-handler-catch-key handler)))
+             (if (or (eqv? catch-key #t) (eq? catch-key key))
+                 (let ((prompt-tag (exception-handler-prompt-tag handler))
+                       (pre-unwind (exception-handler-pre-unwind handler)))
+                   (cond
+                    ((and pre-unwind
+                          (not (pre-unwind-handler-running? handler)))
+                     ;; Prevent errors from within the pre-unwind
+                     ;; handler's invocation from being handled by this
+                     ;; handler.
+                     (with-fluid* %running-pre-unwind handler
+                       (lambda ()
+                         ;; FIXME: Currently the "running" flag only
+                         ;; applies to the pre-unwind handler; the
+                         ;; post-unwind handler is still called if the
+                         ;; error is explicitly rethrown.  Instead it
+                         ;; would be better to cause a recursive throw to
+                         ;; skip all parts of this handler.  Unfortunately
+                         ;; that is incompatible with existing semantics.
+                         ;; We'll see if we can change that later on.
+                         (apply pre-unwind key args)
+                         (dispatch-exception depth key args))))
+                    (prompt-tag
+                     (apply abort-to-prompt prompt-tag key args))
+                    (else
+                     (dispatch-exception (1+ depth) key args))))
+                 (dispatch-exception (1+ depth) key args)))))
+     ((eq? key 'quit)
+      (primitive-exit (cond
+                       ((not (pair? args)) 0)
+                       ((integer? (car args)) (car args))
+                       ((not (car args)) 1)
+                       (else 0))))
+     (else
+      (format (current-error-port) "guile: uncaught throw to ~a: ~a\n"
+              key args)
+      (primitive-exit 1))))
 
   (define (throw key . args)
     "Invoke the catch form matching @var{key}, passing @var{args} to the
@@ -773,7 +784,7 @@ If there is no handler at all, Guile prints an error and then exits."
     (unless (symbol? key)
       (throw 'wrong-type-arg "throw" "Wrong type argument in position ~a: ~a"
              (list 1 key) (list key)))
-    (dispatch-exception (fluid-ref %eh) key args))
+    (dispatch-exception 0 key args))
 
   (define* (catch k thunk handler #:optional pre-unwind-handler)
     "Invoke @var{thunk} in the dynamic context of @var{handler} for
@@ -1681,8 +1692,7 @@ written into the port is returned."
     (call-with-prompt
      prompt-tag
      (lambda ()
-       (with-fluids ((%stacks (acons tag prompt-tag
-                                     (or (fluid-ref %stacks) '()))))
+       (with-fluids ((%stacks (cons tag prompt-tag)))
          (thunk)))
      (lambda (k . args)
        (%start-stack tag (lambda () (apply k args)))))))
diff --git a/module/ice-9/save-stack.scm b/module/ice-9/save-stack.scm
index 8ba006788..5abd1d82a 100644
--- a/module/ice-9/save-stack.scm
+++ b/module/ice-9/save-stack.scm
@@ -53,6 +53,6 @@
                       ;; if any.
                       (apply make-stack #t
                              2
-                             (if (pair? stacks) (cdar stacks) 0)
+                             (if (pair? stacks) (cdr stacks) 0)
                              narrowing)))
         (set! stack-saved? #t))))
diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm
index 55062d783..383d37921 100644
--- a/module/system/repl/debug.scm
+++ b/module/system/repl/debug.scm
@@ -184,7 +184,7 @@
 (define (frame->stack-vector frame)
   (let ((stack (make-stack frame)))
     (match (fluid-ref %stacks)
-      (((stack-tag . prompt-tag) . _)
+      ((stack-tag . prompt-tag)
        (narrow-stack->vector
         stack
         ;; Take the stack from the given frame, cutting 0 frames.
@@ -206,5 +206,5 @@
 ;;     2
 ;;     ;; Narrow the end of the stack to the most recent start-stack.
 ;;     (and (pair? (fluid-ref %stacks))
-;;          (cdar (fluid-ref %stacks))))))
+;;          (cdr (fluid-ref %stacks))))))
 
diff --git a/module/system/repl/error-handling.scm b/module/system/repl/error-handling.scm
index 94a9f2a66..8d5a8a5f0 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -57,7 +57,7 @@
 
     (define (debug-trap-handler frame trap-idx trap-name)
       (let* ((tag (and (pair? (fluid-ref %stacks))
-                       (cdar (fluid-ref %stacks))))
+                       (cdr (fluid-ref %stacks))))
              (stack (narrow-stack->vector
                      (make-stack frame)
                      ;; Take the stack from the given frame, cutting 0
@@ -132,7 +132,7 @@
          (lambda (key . args)
            (if (not (memq key pass-keys))
                (let* ((tag (and (pair? (fluid-ref %stacks))
-                                (cdar (fluid-ref %stacks))))
+                                (cdr (fluid-ref %stacks))))
                       (stack (narrow-stack->vector
                               (make-stack #t)
                               ;; Cut three frames from the top of the stack:
@@ -161,7 +161,7 @@
          (lambda (key . args)
            (if (not (memq key pass-keys))
                (let* ((tag (and (pair? (fluid-ref %stacks))
-                                (cdar (fluid-ref %stacks))))
+                                (cdr (fluid-ref %stacks))))
                       (frames (narrow-stack->vector
                                (make-stack #t)
                                ;; Narrow as above, for the debugging case.
diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test
index a839b68de..391a19dca 100644
--- a/test-suite/tests/exceptions.test
+++ b/test-suite/tests/exceptions.test
@@ -16,7 +16,8 @@
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
 
-(use-modules (test-suite lib))
+(define-module (test-suite exceptions)
+  #:use-module (test-suite lib))
 
 (define-syntax-parameter push
   (lambda (stx)
@@ -365,3 +366,30 @@
   ;;     (not (eval `(,false-if-exception (,error "xxx"))
   ;;                empty-environment))))
   )
+
+(with-test-prefix "delimited exception handlers"
+  (define (catch* key thunk)
+    (let ((tag (make-prompt-tag)))
+      (call-with-prompt tag
+        (lambda ()
+          (catch key
+            (lambda ()
+              (abort-to-prompt tag)
+              (thunk))
+            (lambda args args)))
+        (lambda (k) k))))
+  (pass-if-equal '(foo)
+      (let ((thunk (catch* 'foo (lambda () (throw 'foo)))))
+        (thunk)))
+  (pass-if-equal '(foo)
+      (let* ((thunk1 (catch* 'foo (lambda () (throw 'foo))))
+             (thunk2 (catch* 'bar (lambda () (thunk1)))))
+        (thunk1)))
+  (pass-if-equal '(foo)
+      (let* ((thunk1 (catch* 'foo (lambda () (throw 'foo))))
+             (thunk2 (catch* 'bar (lambda () (thunk1)))))
+        (thunk2)))
+  (pass-if-equal '(bar)
+      (let* ((thunk1 (catch* 'foo (lambda () (throw 'bar))))
+             (thunk2 (catch* 'bar (lambda () (thunk1)))))
+        (thunk2))))