make-stack handles prompt tags better

* libguile/stacks.c: update make-stack and narrow_stack to handle
  prompt tags that are not symbols.
* test-suite/tests/eval.test: add tests for trimming a stack with
  a prompt tag.

diff --git a/libguile/stacks.c b/libguile/stacks.c
index 13d347a..3f3f132 100644 (file)
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -109,7 +109,7 @@ find_prompt (SCM key)
 }
 
 static void
-narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
+narrow_stack (SCM stack, SCM inner_cut, SCM outer_cut)
 {
   unsigned long int len;
   SCM frame;
@@ -118,57 +118,67 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
   frame = SCM_STACK_FRAME (stack);
 
   /* Cut inner part. */
-  if (scm_is_true (scm_procedure_p (inner_key)))
+  if (scm_is_true (scm_procedure_p (inner_cut)))
     {
       /* Cut until the given procedure is seen. */
-      for (; inner && len ; --inner)
+      for (; len ;)
         {
           SCM proc = scm_frame_procedure (frame);
           len--;
           frame = scm_frame_previous (frame);
-          if (scm_is_eq (proc, inner_key))
+          if (scm_is_eq (proc, inner_cut))
             break;
         }
     }
-  else if (scm_is_symbol (inner_key))
-    {
-      /* Cut until the given prompt tag is seen. FIXME, assumes prompt tags are
-         symbols. */
-      SCM *fp = find_prompt (inner_key);
-      for (; len; len--, frame = scm_frame_previous (frame))
-        if (fp == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
-          break;
-    }
-  else
+  else if (scm_is_integer (inner_cut))
     {
       /* Cut specified number of frames. */
+      long inner = scm_to_int (inner_cut);
+      
       for (; inner && len; --inner)
         {
           len--;
           frame = scm_frame_previous (frame);
         }
     }
+  else
+    {
+      /* Cut until the given prompt tag is seen. */
+      SCM *fp = find_prompt (inner_cut);
+      for (; len; len--, frame = scm_frame_previous (frame))
+        if (fp == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
+          break;
+    }
 
   SCM_SET_STACK_LENGTH (stack, len);
   SCM_SET_STACK_FRAME (stack, frame);
 
   /* Cut outer part. */
-  if (scm_is_true (scm_procedure_p (outer_key)))
+  if (scm_is_true (scm_procedure_p (outer_cut)))
     {
       /* Cut until the given procedure is seen. */
-      for (; outer && len ; --outer)
+      for (; len ;)
         {
           frame = scm_stack_ref (stack, scm_from_long (len - 1));
           len--;
-          if (scm_is_eq (scm_frame_procedure (frame), outer_key))
+          if (scm_is_eq (scm_frame_procedure (frame), outer_cut))
             break;
         }
     }
-  else if (scm_is_symbol (outer_key))
+  else if (scm_is_integer (outer_cut))
+    {
+      /* Cut specified number of frames. */
+      long outer = scm_to_int (outer_cut);
+      
+      if (outer < len)
+        len -= outer;
+      else
+        len = 0;
+    }
+  else
     {
-      /* Cut until the given prompt tag is seen. FIXME, assumes prompt tags are
-         symbols. */
-      SCM *fp = find_prompt (outer_key);
+      /* Cut until the given prompt tag is seen. */
+      SCM *fp = find_prompt (outer_cut);
       while (len)
         {
           frame = scm_stack_ref (stack, scm_from_long (len - 1));
@@ -177,14 +187,6 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
             break;
         }
     }
-  else
-    {
-      /* Cut specified number of frames. */
-      if (outer < len)
-        len -= outer;
-      else
-        len = 0;
-    }
 
   SCM_SET_STACK_LENGTH (stack, len);
 }
@@ -308,10 +310,8 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
        }
       
       narrow_stack (stack,
-                   scm_is_integer (inner_cut) ? scm_to_int (inner_cut) : n,
-                   scm_is_integer (inner_cut) ? SCM_BOOL_T : inner_cut,
-                   scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n,
-                   scm_is_integer (outer_cut) ? SCM_BOOL_T : outer_cut);
+                    inner_cut,
+                    outer_cut);
 
       n = SCM_STACK_LENGTH (stack);
     }

diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index a5fbfec..5434b76 100644 (file)
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -379,6 +379,43 @@
              (pair? (member `(,substring  wrong type arg)
                             (cdr result))))))))
 
+(define (make-tagged-trimmed-stack tag spec)
+  (catch 'result
+    (lambda ()
+      (call-with-prompt
+        tag
+        (lambda ()
+          (with-throw-handler 'wrong-type-arg
+            (lambda () (substring 'wrong 'type 'arg))
+            (lambda _ (throw 'result (apply make-stack spec)))))
+        (lambda () (throw 'make-stack-failed))))
+    (lambda (key result) result)))
+
+(define tag (make-prompt-tag "foo"))
+
+(with-test-prefix "stacks and prompt handlers"
+  (pass-if "inner trim with prompt tag"
+    (let* ((stack (make-tagged-trimmed-stack tag `(#t ,tag)))
+           (frames (stack->frames stack)))
+      ;; the top frame on the stack is the lambda inside the 'catch, and the
+      ;; next frame is the (catch 'result ...)
+      (and (eq? (frame-procedure (cadr frames))
+                catch)
+           (eq? (car (frame-arguments (cadr frames)))
+                'result))))
+
+  (pass-if "outer trim with prompt tag"
+    (let* ((stack (make-tagged-trimmed-stack tag `(#t 0 ,tag)))
+           (frames (stack->frames stack)))
+      ;; the top frame on the stack is the make-stack call, and the last
+      ;; frame is the (with-throw-handler 'wrong-type-arg ...)
+      (and (eq? (frame-procedure (car frames))
+                make-stack)
+           (eq? (frame-procedure (car (last-pair frames)))
+                with-throw-handler)
+           (eq? (car (frame-arguments (car (last-pair frames))))
+                'wrong-type-arg)))))
+
 ;;;
 ;;; letrec init evaluation
 ;;;