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