1 ;;; r6rs-exceptions.test --- Test suite for R6RS (rnrs exceptions) -*- scheme -*-
3 ;; Copyright (C) 2010, 2013 Free Software Foundation, Inc.
5 ;; This library is free software; you can redistribute it and/or
6 ;; modify it under the terms of the GNU Lesser General Public
7 ;; License as published by the Free Software Foundation; either
8 ;; version 3 of the License, or (at your option) any later version.
10 ;; This library is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;; Lesser General Public License for more details.
15 ;; You should have received a copy of the GNU Lesser General Public
16 ;; License along with this library; if not, write to the Free Software
17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 (define-module (test-suite test-rnrs-exceptions)
21 :use-module ((rnrs conditions) :version (6))
22 :use-module ((rnrs exceptions) :version (6))
23 :use-module (system foreign)
24 :use-module (test-suite lib))
26 (with-test-prefix "with-exception-handler"
27 (pass-if "handler invoked on raise"
30 (lambda (continuation)
31 (with-exception-handler
32 (lambda (condition) (set! success #t) (continuation))
33 (lambda () (raise (make-violation))))))
36 (pass-if "handler not invoked unless raise"
39 (lambda (continuation)
40 (with-exception-handler
41 (lambda (condition) (continuation))
42 (lambda () (set! success #t)))))
45 (with-test-prefix "raise"
46 (pass-if "raise causes &non-continuable after handler"
49 (lambda (continuation)
50 (with-exception-handler
52 (set! success (non-continuable-violation? condition))
55 (with-exception-handler
56 (lambda (condition) #f)
57 (lambda () (raise (make-violation))))))))
60 (with-test-prefix "raise-continuable"
61 (pass-if "raise-continuable invokes continuation after handler"
65 (lambda (continuation)
66 (with-exception-handler
67 (lambda (condition) (set! handled #t))
69 (raise-continuable (make-violation))
70 (set! continued #t)))))
71 (and handled continued))))
73 (with-test-prefix "guard"
74 (pass-if "guard with matching cond without else"
76 (guard (condition ((error? condition) (set! success #t)))
80 (pass-if "guard without matching cond without else"
83 (lambda (continuation)
84 (with-exception-handler
85 (lambda (condition) (set! success (error? condition)) (continuation))
87 (guard (condition ((irritants-condition? condition) #f))
88 (raise (make-error)))))))
91 (pass-if "guard with else and without matching cond"
93 (guard (condition ((irritants-condition? condition) #f)
94 (else (set! success #t)))
98 (pass-if "guard with cond => syntax"
99 (guard (condition (condition => error?)) (raise (make-error)))))
101 (with-test-prefix "guile condition conversions"
103 (define-syntax-rule (pass-if-condition name expected-condition? body ...)
105 (guard (obj ((expected-condition? obj) #t)
109 (pass-if "rethrown native guile exceptions"
112 (guard (obj ((syntax-violation? obj) #f))
113 (vector-ref '#(0 1) 2)
116 (eq? key 'out-of-range))))
118 (pass-if-condition "syntax-error"
120 (eval '(let) (current-module)))
122 (pass-if-condition "unbound-variable"
124 variable-that-does-not-exist)
126 (pass-if-condition "out-of-range"
128 (vector-ref '#(0 1) 2))
130 (pass-if-condition "wrong-number-of-args"
132 ((lambda () #f) 'unwanted-argument))
134 (pass-if-condition "wrong-type-arg"
136 (vector-ref '#(0 1) 'invalid-index))
138 (pass-if-condition "keyword-argument-error"
140 ((lambda* (#:key a) #f) #:unwanted-keyword 'val))
142 (pass-if-condition "regular-expression-syntax"
144 (make-regexp "[missing-close-square-bracket"))
146 (pass-if-condition "null-pointer-error"
148 (dereference-pointer (make-pointer 0)))
150 (pass-if-condition "read-error"
152 (read (open-input-string "(missing-close-paren"))))
155 ;;; eval: (put 'pass-if-condition 'scheme-indent-function 1)