Commit | Line | Data |
---|---|---|
02500d44 | 1 | ;;; r6rs-exceptions.test --- Test suite for R6RS (rnrs exceptions) -*- scheme -*- |
d1c83d38 | 2 | |
02500d44 | 3 | ;; Copyright (C) 2010, 2013 Free Software Foundation, Inc. |
d1c83d38 JG |
4 | ;; |
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. | |
9 | ;; | |
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. | |
14 | ;; | |
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 | |
18 | \f | |
19 | ||
20 | (define-module (test-suite test-rnrs-exceptions) | |
21 | :use-module ((rnrs conditions) :version (6)) | |
22 | :use-module ((rnrs exceptions) :version (6)) | |
02500d44 | 23 | :use-module (system foreign) |
d1c83d38 JG |
24 | :use-module (test-suite lib)) |
25 | ||
26 | (with-test-prefix "with-exception-handler" | |
27 | (pass-if "handler invoked on raise" | |
28 | (let ((success #f)) | |
29 | (call/cc | |
30 | (lambda (continuation) | |
31 | (with-exception-handler | |
32 | (lambda (condition) (set! success #t) (continuation)) | |
33 | (lambda () (raise (make-violation)))))) | |
34 | success)) | |
35 | ||
36 | (pass-if "handler not invoked unless raise" | |
37 | (let ((success #f)) | |
38 | (call/cc | |
39 | (lambda (continuation) | |
40 | (with-exception-handler | |
41 | (lambda (condition) (continuation)) | |
42 | (lambda () (set! success #t))))) | |
43 | success))) | |
44 | ||
45 | (with-test-prefix "raise" | |
46 | (pass-if "raise causes &non-continuable after handler" | |
47 | (let ((success #f)) | |
48 | (call/cc | |
49 | (lambda (continuation) | |
50 | (with-exception-handler | |
51 | (lambda (condition) | |
52 | (set! success (non-continuable-violation? condition)) | |
53 | (continuation)) | |
54 | (lambda () | |
55 | (with-exception-handler | |
56 | (lambda (condition) #f) | |
57 | (lambda () (raise (make-violation)))))))) | |
58 | success))) | |
59 | ||
60 | (with-test-prefix "raise-continuable" | |
61 | (pass-if "raise-continuable invokes continuation after handler" | |
62 | (let ((handled #f) | |
63 | (continued #f)) | |
64 | (call/cc | |
65 | (lambda (continuation) | |
66 | (with-exception-handler | |
67 | (lambda (condition) (set! handled #t)) | |
68 | (lambda () | |
69 | (raise-continuable (make-violation)) | |
70 | (set! continued #t))))) | |
71 | (and handled continued)))) | |
72 | ||
73 | (with-test-prefix "guard" | |
74 | (pass-if "guard with matching cond without else" | |
75 | (let ((success #f)) | |
76 | (guard (condition ((error? condition) (set! success #t))) | |
77 | (raise (make-error))) | |
78 | success)) | |
79 | ||
80 | (pass-if "guard without matching cond without else" | |
81 | (let ((success #f)) | |
82 | (call/cc | |
83 | (lambda (continuation) | |
84 | (with-exception-handler | |
85 | (lambda (condition) (set! success (error? condition)) (continuation)) | |
86 | (lambda () | |
87 | (guard (condition ((irritants-condition? condition) #f)) | |
88 | (raise (make-error))))))) | |
89 | success)) | |
90 | ||
91 | (pass-if "guard with else and without matching cond" | |
92 | (let ((success #f)) | |
93 | (guard (condition ((irritants-condition? condition) #f) | |
94 | (else (set! success #t))) | |
95 | (raise (make-error))) | |
96 | success)) | |
97 | ||
98 | (pass-if "guard with cond => syntax" | |
99 | (guard (condition (condition => error?)) (raise (make-error))))) | |
02500d44 MW |
100 | |
101 | (with-test-prefix "guile condition conversions" | |
102 | ||
103 | (define-syntax-rule (pass-if-condition name expected-condition? body ...) | |
104 | (pass-if name | |
105 | (guard (obj ((expected-condition? obj) #t) | |
106 | (else #f)) | |
107 | body ... #f))) | |
108 | ||
109 | (pass-if "rethrown native guile exceptions" | |
110 | (catch #t | |
111 | (lambda () | |
112 | (guard (obj ((syntax-violation? obj) #f)) | |
113 | (vector-ref '#(0 1) 2) | |
114 | #f)) | |
115 | (lambda (key . args) | |
116 | (eq? key 'out-of-range)))) | |
117 | ||
118 | (pass-if-condition "syntax-error" | |
119 | syntax-violation? | |
120 | (eval '(let) (current-module))) | |
121 | ||
122 | (pass-if-condition "unbound-variable" | |
123 | undefined-violation? | |
124 | variable-that-does-not-exist) | |
125 | ||
126 | (pass-if-condition "out-of-range" | |
127 | assertion-violation? | |
128 | (vector-ref '#(0 1) 2)) | |
129 | ||
130 | (pass-if-condition "wrong-number-of-args" | |
131 | assertion-violation? | |
132 | ((lambda () #f) 'unwanted-argument)) | |
133 | ||
134 | (pass-if-condition "wrong-type-arg" | |
135 | assertion-violation? | |
136 | (vector-ref '#(0 1) 'invalid-index)) | |
137 | ||
138 | (pass-if-condition "keyword-argument-error" | |
139 | assertion-violation? | |
140 | ((lambda* (#:key a) #f) #:unwanted-keyword 'val)) | |
141 | ||
142 | (pass-if-condition "regular-expression-syntax" | |
143 | assertion-violation? | |
144 | (make-regexp "[missing-close-square-bracket")) | |
145 | ||
146 | (pass-if-condition "null-pointer-error" | |
147 | assertion-violation? | |
148 | (dereference-pointer (make-pointer 0))) | |
149 | ||
150 | (pass-if-condition "read-error" | |
151 | lexical-violation? | |
152 | (read (open-input-string "(missing-close-paren")))) | |
153 | ||
154 | ;;; Local Variables: | |
155 | ;;; eval: (put 'pass-if-condition 'scheme-indent-function 1) | |
156 | ;;; End: |