summaryrefslogtreecommitdiff
path: root/test-suite/tests/eval.test
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/tests/eval.test')
-rw-r--r--test-suite/tests/eval.test188
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