diff options
Diffstat (limited to 'test-suite/tests/eval.test')
-rw-r--r-- | test-suite/tests/eval.test | 86 |
1 files changed, 50 insertions, 36 deletions
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index a5fbfece2..f8218ad61 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 |