summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--test-suite/tests/eval.test69
1 files changed, 23 insertions, 46 deletions
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index 5434b769f..f8218ad61 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -334,51 +334,6 @@
1+
0))
-(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))))
-
- (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))))))))
-
(define (make-tagged-trimmed-stack tag spec)
(catch 'result
(lambda ()
@@ -393,7 +348,29 @@
(define tag (make-prompt-tag "foo"))
-(with-test-prefix "stacks and prompt handlers"
+(with-test-prefix "stacks"
+ (pass-if "stack involving a primitive"
+ ;; The primitive involving the error must appear exactly once on the
+ ;; stack.
+ (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.
+ (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)))