[Guile-commits] GNU Guile branch, master, updated. v2.1.0-205-g649d3ea

[Noah Lavine]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=649d3ea76639424fa5445a6f44896de1fdf1e309

The branch, master has been updated
       via  649d3ea76639424fa5445a6f44896de1fdf1e309 (commit)
       via  99d7688b6ca33f3d274fee2ad15503c4ad16bf71 (commit)
      from  ebc30e3fde43e6330b0e9290c15c212844e12675 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 649d3ea76639424fa5445a6f44896de1fdf1e309
Author: Noah Lavine <address@hidden>
Date:   Mon Apr 23 21:35:08 2012 -0400

    Clean up stack tests
    
    * test-suite/tests/eval.test: remove duplicate code.

commit 99d7688b6ca33f3d274fee2ad15503c4ad16bf71
Author: Noah Lavine <address@hidden>
Date:   Wed Apr 18 22:10:21 2012 -0400

    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.

-----------------------------------------------------------------------

Summary of changes:
 libguile/stacks.c          |   66 +++++++++++++++++-----------------
 test-suite/tests/eval.test |   86 +++++++++++++++++++++++++------------------
 2 files changed, 83 insertions(+), 69 deletions(-)

diff --git a/libguile/stacks.c b/libguile/stacks.c
index 13d347a..3f3f132 100644
--- 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..f8218ad 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -334,50 +334,64 @@
           1+
           0))
 
+(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"
   (pass-if "stack involving a primitive"
     ;; The primitive involving the error must appear exactly once on the
     ;; stack.
-    (catch 'result
-      (lambda ()
-        (start-stack 'foo
-                     (with-throw-handler 'wrong-type-arg
-                       (lambda ()
-                         ;; Trigger a `wrong-type-arg' exception.
-                         (hashq-ref 'wrong 'type 'arg))
-                       (lambda _
-                         (let* ((stack  (make-stack #t))
-                                (frames (stack->frames stack)))
-                           (throw 'result
-                                  (count (lambda (frame)
-                                           (eq? (frame-procedure frame)
-                                                hashq-ref))
-                                         frames)))))))
-      (lambda (key result)
-        (= 1 result))))
+    (let* ((stack (make-tagged-trimmed-stack tag '(#t)))
+           (frames (stack->frames stack))
+           (num (count (lambda (frame) (eq? (frame-procedure frame)
+                                       substring))
+                       frames)))
+      (= num 1)))
 
   (pass-if "arguments of a primitive stack frame"
     ;; Create a stack with two primitive frames and make sure the
     ;; arguments are correct.
-    (catch 'result
-      (lambda ()
-        (start-stack 'foo
-                     (with-throw-handler 'wrong-type-arg
-                       (lambda ()
-                         ;; Trigger a `wrong-type-arg' exception.
-                         (substring 'wrong 'type 'arg))
-                       (lambda _
-                         (let* ((stack  (make-stack #t))
-                                (frames (stack->frames stack)))
-                           (throw 'result
-                                  (map (lambda (frame)
-                                         (cons (frame-procedure frame)
-                                               (frame-arguments frame)))
-                                       frames)))))))
-      (lambda (key result)
-        (and (equal? (car result) `(,make-stack #t))
-             (pair? (member `(,substring  wrong type arg)
-                            (cdr result))))))))
+    (let* ((stack (make-tagged-trimmed-stack tag '(#t)))
+           (call-list (map (lambda (frame)
+                             (cons (frame-procedure frame)
+                                   (frame-arguments frame)))
+                           (stack->frames stack))))
+      (and (equal? (car call-list) `(,make-stack #t))
+           (pair? (member `(,substring wrong type arg)
+                          (cdr call-list))))))
+
+  (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


hooks/post-receive
-- 
GNU Guile