diff options
Diffstat (limited to 'test-suite/tests/eval.test')
-rw-r--r-- | test-suite/tests/eval.test | 188 |
1 files changed, 143 insertions, 45 deletions
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index 6ab3b8ac8..e1837fd38 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -1,5 +1,5 @@ ;;;; eval.test --- tests guile's evaluator -*- scheme -*- -;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -18,7 +18,8 @@ (define-module (test-suite test-eval) :use-module (test-suite lib) :use-module ((srfi srfi-1) :select (unfold count)) - :use-module ((system vm vm) :select (make-vm call-with-vm)) + :use-module ((system vm vm) :select (call-with-stack-overflow-handler)) + :use-module ((system vm frame) :select (frame-call-representation)) :use-module (ice-9 documentation) :use-module (ice-9 local-eval)) @@ -218,6 +219,16 @@ (map + '(1 2) '(3))) ))) +(with-test-prefix "for-each" + + (pass-if-exception "1 arg, non-list, even number of elements" + exception:not-a-list + (for-each values '(1 2 3 4 . 5))) + + (pass-if-exception "1 arg, non-list, odd number of elements" + exception:not-a-list + (for-each values '(1 2 3 . 4)))) + ;;; ;;; define with procedure-name ;;; @@ -334,50 +345,59 @@ 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 frame-call-representation (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? (car (frame-call-representation (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? (car (frame-call-representation (car frames))) + 'make-stack) + (eq? (car (frame-call-representation (car (last-pair frames)))) + 'with-throw-handler))))) ;;; ;;; letrec init evaluation @@ -418,14 +438,92 @@ ;;; stack overflow handling ;;; -(with-test-prefix "stack overflow" +(with-test-prefix "stack overflow handlers" + (define (trigger-overflow) + (trigger-overflow) + (error "not reached")) - ;; FIXME: this test does not test what it is intending to test - (pass-if-exception "exception raised" - exception:vm-error - (let ((vm (make-vm)) - (thunk (let loop () (cons 's (loop))))) - (call-with-vm vm thunk)))) + (define (dynwind-test n) + (catch 'foo + (lambda () + (call-with-stack-overflow-handler n + (lambda () + (dynamic-wind (lambda () #t) + trigger-overflow + trigger-overflow)) + (lambda () + (throw 'foo)))) + (lambda _ #t))) + + (pass-if-exception "limit should be number" + exception:wrong-type-arg + (call-with-stack-overflow-handler #t + trigger-overflow trigger-overflow)) + + (pass-if-exception "limit should be exact integer" + exception:wrong-type-arg + (call-with-stack-overflow-handler 2.0 + trigger-overflow trigger-overflow)) + + (pass-if-exception "limit should be nonnegative" + exception:out-of-range + (call-with-stack-overflow-handler -1 + trigger-overflow trigger-overflow)) + + (pass-if-exception "limit should be positive" + exception:out-of-range + (call-with-stack-overflow-handler 0 + trigger-overflow trigger-overflow)) + + (pass-if-exception "limit should be within address space" + exception:out-of-range + (call-with-stack-overflow-handler (ash 1 64) + trigger-overflow trigger-overflow)) + + (pass-if "exception on overflow" + (catch 'foo + (lambda () + (call-with-stack-overflow-handler 10000 + trigger-overflow + (lambda () + (throw 'foo)))) + (lambda _ #t))) + + (pass-if "exception on overflow with dynwind" + ;; Try all limits between 1 and 200 words. + (let lp ((n 1)) + (or (= n 200) + (and (dynwind-test n) + (lp (1+ n)))))) + + (pass-if-exception "overflow handler should return number" + exception:wrong-type-arg + (call-with-stack-overflow-handler 1000 + trigger-overflow + (lambda () #t))) + (pass-if-exception "overflow handler should return exact integer" + exception:wrong-type-arg + (call-with-stack-overflow-handler 1000 + trigger-overflow + (lambda () 2.0))) + (pass-if-exception "overflow handler should be nonnegative" + exception:out-of-range + (call-with-stack-overflow-handler 1000 + trigger-overflow + (lambda () -1))) + (pass-if-exception "overflow handler should be positive" + exception:out-of-range + (call-with-stack-overflow-handler 1000 + trigger-overflow + (lambda () 0))) + + (letrec ((fac (lambda (n) + (if (zero? n) 1 (* n (fac (1- n))))))) + (pass-if-equal "overflow handler can allow recursion to continue" + (fac 10) + (call-with-stack-overflow-handler 1 + (lambda () (fac 10)) + (lambda () 1))))) ;;; ;;; docstrings |