Commit | Line | Data |
---|---|---|
a1a5dfa8 NJ |
1 | ;;;; srfi-34.test --- test suite for SRFI-34 -*- scheme -*- |
2 | ;;;; | |
76350432 | 3 | ;;;; Copyright (C) 2003, 2004, 2006, 2008 Free Software Foundation, Inc. |
a1a5dfa8 | 4 | ;;;; |
53befeb7 NJ |
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, | |
a1a5dfa8 | 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
53befeb7 NJ |
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 | |
a1a5dfa8 NJ |
18 | |
19 | (define-module (test-suite test-srfi-34) | |
cd6f7d0b | 20 | :duplicates (last) ;; avoid warning about srfi-34 replacing `raise' |
a1a5dfa8 NJ |
21 | :use-module (test-suite lib) |
22 | :use-module (srfi srfi-13) | |
23 | :use-module (srfi srfi-34)) | |
24 | ||
25 | (define (expr-prints-and-evals-to? expr printout result) | |
26 | (let ((actual-result *unspecified*)) | |
27 | (let ((actual-printout | |
28 | (string-trim-both | |
29 | (with-output-to-string | |
30 | (lambda () | |
31 | (set! actual-result | |
32 | (eval expr (current-module)))))))) | |
33 | ;;(write (list actual-printout printout actual-result result)) | |
34 | ;;(newline) | |
35 | (and (equal? actual-printout printout) | |
36 | (equal? actual-result result))))) | |
37 | ||
38 | (with-test-prefix "SRFI 34" | |
39 | ||
68eb63f1 KR |
40 | (pass-if "cond-expand" |
41 | (cond-expand (srfi-34 #t) | |
42 | (else #f))) | |
43 | ||
a1a5dfa8 NJ |
44 | (pass-if "example 1" |
45 | (expr-prints-and-evals-to? | |
46 | '(call-with-current-continuation | |
47 | (lambda (k) | |
48 | (with-exception-handler (lambda (x) | |
49 | (display "condition: ") | |
50 | (write x) | |
51 | (newline) | |
52 | (k 'exception)) | |
53 | (lambda () | |
54 | (+ 1 (raise 'an-error)))))) | |
55 | "condition: an-error" | |
56 | 'exception)) | |
57 | ||
58 | ;; SRFI 34 specifies that the behaviour of the call/cc expression | |
59 | ;; after printing "something went wrong" is unspecified, which is | |
60 | ;; tricky to test for in a positive way ... Guile behaviour at time | |
61 | ;; of writing is to signal a "lazy-catch handler did return" error, | |
62 | ;; which feels about right to me. | |
63 | (pass-if "example 2" | |
64 | (expr-prints-and-evals-to? | |
65 | '(false-if-exception | |
66 | (call-with-current-continuation | |
67 | (lambda (k) | |
68 | (with-exception-handler (lambda (x) | |
69 | (display "something went wrong") | |
70 | (newline) | |
71 | 'dont-care) | |
72 | (lambda () | |
73 | (+ 1 (raise 'an-error))))))) | |
74 | "something went wrong" | |
75 | #f)) | |
76 | ||
77 | (pass-if "example 3" | |
78 | (expr-prints-and-evals-to? | |
79 | '(guard (condition | |
80 | (else | |
81 | (display "condition: ") | |
82 | (write condition) | |
83 | (newline) | |
84 | 'exception)) | |
85 | (+ 1 (raise 'an-error))) | |
86 | "condition: an-error" | |
87 | 'exception)) | |
88 | ||
89 | (pass-if "example 4" | |
90 | (expr-prints-and-evals-to? | |
91 | '(guard (condition | |
92 | (else | |
93 | (display "something went wrong") | |
94 | (newline) | |
95 | 'dont-care)) | |
96 | (+ 1 (raise 'an-error))) | |
97 | "something went wrong" | |
98 | 'dont-care)) | |
99 | ||
100 | (pass-if "example 5" | |
101 | (expr-prints-and-evals-to? | |
102 | '(call-with-current-continuation | |
103 | (lambda (k) | |
104 | (with-exception-handler (lambda (x) | |
105 | (display "reraised ") (write x) (newline) | |
106 | (k 'zero)) | |
107 | (lambda () | |
108 | (guard (condition | |
109 | ((positive? condition) 'positive) | |
110 | ((negative? condition) 'negative)) | |
111 | (raise 1)))))) | |
112 | "" | |
113 | 'positive)) | |
114 | ||
115 | (pass-if "example 6" | |
116 | (expr-prints-and-evals-to? | |
117 | '(call-with-current-continuation | |
118 | (lambda (k) | |
119 | (with-exception-handler (lambda (x) | |
120 | (display "reraised ") (write x) (newline) | |
121 | (k 'zero)) | |
122 | (lambda () | |
123 | (guard (condition | |
124 | ((positive? condition) 'positive) | |
125 | ((negative? condition) 'negative)) | |
126 | (raise -1)))))) | |
127 | "" | |
128 | 'negative)) | |
129 | ||
130 | (pass-if "example 7" | |
131 | (expr-prints-and-evals-to? | |
132 | '(call-with-current-continuation | |
133 | (lambda (k) | |
134 | (with-exception-handler (lambda (x) | |
135 | (display "reraised ") (write x) (newline) | |
136 | (k 'zero)) | |
137 | (lambda () | |
138 | (guard (condition | |
139 | ((positive? condition) 'positive) | |
140 | ((negative? condition) 'negative)) | |
141 | (raise 0)))))) | |
142 | "reraised 0" | |
143 | 'zero)) | |
144 | ||
145 | (pass-if "example 8" | |
146 | (expr-prints-and-evals-to? | |
147 | '(guard (condition | |
148 | ((assq 'a condition) => cdr) | |
149 | ((assq 'b condition))) | |
150 | (raise (list (cons 'a 42)))) | |
151 | "" | |
152 | 42)) | |
153 | ||
154 | (pass-if "example 9" | |
155 | (expr-prints-and-evals-to? | |
156 | '(guard (condition | |
157 | ((assq 'a condition) => cdr) | |
158 | ((assq 'b condition))) | |
159 | (raise (list (cons 'b 23)))) | |
160 | "" | |
161 | '(b . 23))) | |
162 | ||
76350432 LC |
163 | (pass-if "`with-exception-handler' invokes HANDLER in THUNK's dynamic env." |
164 | ;; In Guile 1.8.5 and earlier, unwinders would be called before | |
165 | ;; the exception handler, which reads "The handler is called in | |
166 | ;; the dynamic environment of the call to `raise'". | |
167 | (call/cc | |
168 | (lambda (return) | |
169 | (let ((inside? #f)) | |
170 | (with-exception-handler | |
171 | (lambda (c) | |
172 | ;; This handler must be called before the unwinder below. | |
173 | (return inside?)) | |
174 | (lambda () | |
175 | (dynamic-wind | |
176 | (lambda () | |
177 | (set! inside? #t)) | |
178 | (lambda () | |
179 | (raise 'some-exception)) | |
180 | (lambda () | |
181 | ;; This unwinder should not be executed before the | |
182 | ;; handler is called. | |
183 | (set! inside? #f)))))))))) |