Commit | Line | Data |
---|---|---|
2e5b157d | 1 | ;;;; r5rs_pitfall.test --- tests some pitfalls in R5RS -*- scheme -*- |
3f12a4ec MV |
2 | ;;;; Copyright (C) 2003, 2004 Free Software Foundation, Inc. |
3 | ;;;; | |
4 | ;;;; This library is free software; you can redistribute it and/or | |
5 | ;;;; modify it under the terms of the GNU Lesser General Public | |
6 | ;;;; License as published by the Free Software Foundation; either | |
7 | ;;;; version 2.1 of the License, or (at your option) any later version. | |
8 | ;;;; | |
9 | ;;;; This library is distributed in the hope that it will be useful, | |
10 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
11 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
12 | ;;;; Lesser General Public License for more details. | |
13 | ;;;; | |
14 | ;;;; You should have received a copy of the GNU Lesser General Public | |
15 | ;;;; License along with this library; if not, write to the Free Software | |
92205699 | 16 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
2e5b157d MV |
17 | |
18 | ;; These tests have been copied from | |
3f12a4ec | 19 | ;; http://sisc.sourceforge.net/r5rs_pitfall.scm and the 'should-be' |
2e5b157d MV |
20 | ;; macro has been modified to fit into our test suite machinery. |
21 | ;; | |
d6e04e7c | 22 | ;; Test 1.1 fails, but we expect that. |
2e5b157d | 23 | |
d6e04e7c | 24 | (define-module (test-suite test-r5rs-pitfall) |
2e5b157d MV |
25 | :use-syntax (ice-9 syncase) |
26 | :use-module (test-suite lib)) | |
27 | ||
28 | (define-syntax should-be | |
29 | (syntax-rules () | |
30 | ((_ test-id value expression) | |
31 | (run-test test-id #t (lambda () | |
32 | (false-if-exception | |
33 | (equal? expression value))))))) | |
34 | ||
35 | (define-syntax should-be-but-isnt | |
36 | (syntax-rules () | |
37 | ((_ test-id value expression) | |
38 | (run-test test-id #f (lambda () | |
39 | (false-if-exception | |
40 | (equal? expression value))))))) | |
41 | ||
42 | (define call/cc call-with-current-continuation) | |
43 | ||
44 | ;; Section 1: Proper letrec implementation | |
45 | ||
46 | ;;Credits to Al Petrofsky | |
47 | ;; In thread: | |
48 | ;; defines in letrec body | |
49 | ;; http://groups.google.com/groups?selm=87bsoq0wfk.fsf%40app.dial.idiom.com | |
b8ad7a21 MV |
50 | |
51 | ;; See eval.c for how to make this test succeed. Look for "r5rs pitfall". | |
52 | ||
2e5b157d MV |
53 | (should-be-but-isnt 1.1 0 |
54 | (let ((cont #f)) | |
55 | (letrec ((x (call-with-current-continuation (lambda (c) (set! cont c) 0))) | |
56 | (y (call-with-current-continuation (lambda (c) (set! cont c) 0)))) | |
57 | (if cont | |
58 | (let ((c cont)) | |
59 | (set! cont #f) | |
60 | (set! x 1) | |
61 | (set! y 1) | |
62 | (c 0)) | |
63 | (+ x y))))) | |
64 | ||
65 | ;;Credits to Al Petrofsky | |
66 | ;; In thread: | |
67 | ;; Widespread bug (arguably) in letrec when an initializer returns twice | |
68 | ;; http://groups.google.com/groups?selm=87d793aacz.fsf_-_%40app.dial.idiom.com | |
69 | (should-be 1.2 #t | |
70 | (letrec ((x (call/cc list)) (y (call/cc list))) | |
71 | (cond ((procedure? x) (x (pair? y))) | |
72 | ((procedure? y) (y (pair? x)))) | |
73 | (let ((x (car x)) (y (car y))) | |
74 | (and (call/cc x) (call/cc y) (call/cc x))))) | |
75 | ||
76 | ;;Credits to Alan Bawden | |
77 | ;; In thread: | |
78 | ;; LETREC + CALL/CC = SET! even in a limited setting | |
79 | ;; http://groups.google.com/groups?selm=19890302162742.4.ALAN%40PIGPEN.AI.MIT.EDU | |
80 | (should-be 1.3 #t | |
81 | (letrec ((x (call-with-current-continuation | |
82 | (lambda (c) | |
83 | (list #T c))))) | |
84 | (if (car x) | |
85 | ((cadr x) (list #F (lambda () x))) | |
86 | (eq? x ((cadr x)))))) | |
87 | ||
88 | ;; Section 2: Proper call/cc and procedure application | |
89 | ||
90 | ;;Credits to Al Petrofsky, (and a wink to Matthias Blume) | |
91 | ;; In thread: | |
92 | ;; Widespread bug in handling (call/cc (lambda (c) (0 (c 1)))) => 1 | |
93 | ;; http://groups.google.com/groups?selm=87g00y4b6l.fsf%40radish.petrofsky.org | |
ddd8f927 | 94 | (should-be 2.1 1 |
2e5b157d MV |
95 | (call/cc (lambda (c) (0 (c 1))))) |
96 | ||
97 | ;; Section 3: Hygienic macros | |
98 | ||
99 | ;; Eli Barzilay | |
100 | ;; In thread: | |
101 | ;; R5RS macros... | |
102 | ;; http://groups.google.com/groups?selm=skitsdqjq3.fsf%40tulare.cs.cornell.edu | |
103 | (should-be 3.1 4 | |
104 | (let-syntax ((foo | |
105 | (syntax-rules () | |
106 | ((_ expr) (+ expr 1))))) | |
107 | (let ((+ *)) | |
108 | (foo 3)))) | |
109 | ||
110 | ||
111 | ;; Al Petrofsky again | |
112 | ;; In thread: | |
113 | ;; Buggy use of begin in r5rs cond and case macros. | |
114 | ;; http://groups.google.com/groups?selm=87bse3bznr.fsf%40radish.petrofsky.org | |
115 | (should-be 3.2 2 | |
116 | (let-syntax ((foo (syntax-rules () | |
117 | ((_ var) (define var 1))))) | |
118 | (let ((x 2)) | |
119 | (begin (define foo +)) | |
120 | (cond (else (foo x))) | |
121 | x))) | |
122 | ||
123 | ;;Al Petrofsky | |
124 | ;; In thread: | |
125 | ;; An Advanced syntax-rules Primer for the Mildly Insane | |
126 | ;; http://groups.google.com/groups?selm=87it8db0um.fsf@radish.petrofsky.org | |
127 | ||
128 | (should-be 3.3 1 | |
129 | (let ((x 1)) | |
130 | (let-syntax | |
131 | ((foo (syntax-rules () | |
132 | ((_ y) (let-syntax | |
133 | ((bar (syntax-rules () | |
134 | ((_) (let ((x 2)) y))))) | |
135 | (bar)))))) | |
136 | (foo x)))) | |
137 | ||
138 | ;; Al Petrofsky | |
139 | ;; Contributed directly | |
140 | (should-be 3.4 1 | |
141 | (let-syntax ((x (syntax-rules ()))) 1)) | |
142 | ||
143 | ;; Setion 4: No identifiers are reserved | |
144 | ||
145 | ;;(Brian M. Moore) | |
146 | ;; In thread: | |
147 | ;; shadowing syntatic keywords, bug in MIT Scheme? | |
148 | ;; http://groups.google.com/groups?selm=6e6n88%248qf%241%40news.cc.ukans.edu | |
149 | (should-be 4.1 '(x) | |
150 | ((lambda lambda lambda) 'x)) | |
151 | ||
152 | (should-be 4.2 '(1 2 3) | |
153 | ((lambda (begin) (begin 1 2 3)) (lambda lambda lambda))) | |
154 | ||
155 | (should-be 4.3 #f | |
156 | (let ((quote -)) (eqv? '1 1))) | |
157 | ;; Section 5: #f/() distinctness | |
158 | ||
159 | ;; Scott Miller | |
160 | (should-be 5.1 #f | |
161 | (eq? #f '())) | |
162 | (should-be 5.2 #f | |
163 | (eqv? #f '())) | |
164 | (should-be 5.3 #f | |
165 | (equal? #f '())) | |
166 | ||
167 | ;; Section 6: string->symbol case sensitivity | |
168 | ||
169 | ;; Jens Axel S?gaard | |
170 | ;; In thread: | |
171 | ;; Symbols in DrScheme - bug? | |
172 | ;; http://groups.google.com/groups?selm=3be55b4f%240%24358%24edfadb0f%40dspool01.news.tele.dk | |
173 | (should-be 6.1 #f | |
174 | (eq? (string->symbol "f") (string->symbol "F"))) | |
175 | ||
176 | ;; Section 7: First class continuations | |
177 | ||
178 | ;; Scott Miller | |
179 | ;; No newsgroup posting associated. The jist of this test and 7.2 | |
180 | ;; is that once captured, a continuation should be unmodified by the | |
181 | ;; invocation of other continuations. This test determines that this is | |
182 | ;; the case by capturing a continuation and setting it aside in a temporary | |
183 | ;; variable while it invokes that and another continuation, trying to | |
184 | ;; side effect the first continuation. This test case was developed when | |
185 | ;; testing SISC 1.7's lazy CallFrame unzipping code. | |
186 | (define r #f) | |
187 | (define a #f) | |
188 | (define b #f) | |
189 | (define c #f) | |
190 | (define i 0) | |
191 | (should-be 7.1 28 | |
192 | (let () | |
193 | (set! r (+ 1 (+ 2 (+ 3 (call/cc (lambda (k) (set! a k) 4)))) | |
194 | (+ 5 (+ 6 (call/cc (lambda (k) (set! b k) 7)))))) | |
195 | (if (not c) | |
196 | (set! c a)) | |
197 | (set! i (+ i 1)) | |
198 | (case i | |
199 | ((1) (a 5)) | |
200 | ((2) (b 8)) | |
201 | ((3) (a 6)) | |
202 | ((4) (c 4))) | |
203 | r)) | |
204 | ||
205 | ;; Same test, but in reverse order | |
206 | (define r #f) | |
207 | (define a #f) | |
208 | (define b #f) | |
209 | (define c #f) | |
210 | (define i 0) | |
211 | (should-be 7.2 28 | |
212 | (let () | |
213 | (set! r (+ 1 (+ 2 (+ 3 (call/cc (lambda (k) (set! a k) 4)))) | |
214 | (+ 5 (+ 6 (call/cc (lambda (k) (set! b k) 7)))))) | |
215 | (if (not c) | |
216 | (set! c a)) | |
217 | (set! i (+ i 1)) | |
218 | (case i | |
219 | ((1) (b 8)) | |
220 | ((2) (a 5)) | |
221 | ((3) (b 7)) | |
222 | ((4) (c 4))) | |
223 | r)) | |
224 | ||
225 | ;; Credits to Matthias Radestock | |
226 | ;; Another test case used to test SISC's lazy CallFrame routines. | |
227 | (should-be 7.3 '((-1 4 5 3) | |
228 | (4 -1 5 3) | |
229 | (-1 5 4 3) | |
230 | (5 -1 4 3) | |
231 | (4 5 -1 3) | |
232 | (5 4 -1 3)) | |
233 | (let ((k1 #f) | |
234 | (k2 #f) | |
235 | (k3 #f) | |
236 | (state 0)) | |
237 | (define (identity x) x) | |
238 | (define (fn) | |
239 | ((identity (if (= state 0) | |
240 | (call/cc (lambda (k) (set! k1 k) +)) | |
241 | +)) | |
242 | (identity (if (= state 0) | |
243 | (call/cc (lambda (k) (set! k2 k) 1)) | |
244 | 1)) | |
245 | (identity (if (= state 0) | |
246 | (call/cc (lambda (k) (set! k3 k) 2)) | |
247 | 2)))) | |
248 | (define (check states) | |
249 | (set! state 0) | |
250 | (let* ((res '()) | |
251 | (r (fn))) | |
252 | (set! res (cons r res)) | |
253 | (if (null? states) | |
254 | res | |
255 | (begin (set! state (car states)) | |
256 | (set! states (cdr states)) | |
257 | (case state | |
258 | ((1) (k3 4)) | |
259 | ((2) (k2 2)) | |
260 | ((3) (k1 -))))))) | |
261 | (map check '((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1))))) | |
262 | ||
263 | ;; Modification of the yin-yang puzzle so that it terminates and produces | |
264 | ;; a value as a result. (Scott G. Miller) | |
265 | (should-be 7.4 '(10 9 8 7 6 5 4 3 2 1 0) | |
266 | (let ((x '()) | |
267 | (y 0)) | |
268 | (call/cc | |
269 | (lambda (escape) | |
270 | (let* ((yin ((lambda (foo) | |
271 | (set! x (cons y x)) | |
272 | (if (= y 10) | |
273 | (escape x) | |
274 | (begin | |
275 | (set! y 0) | |
276 | foo))) | |
277 | (call/cc (lambda (bar) bar)))) | |
278 | (yang ((lambda (foo) | |
279 | (set! y (+ y 1)) | |
280 | foo) | |
281 | (call/cc (lambda (baz) baz))))) | |
282 | (yin yang)))))) | |
283 | ||
284 | ;; Miscellaneous | |
285 | ||
286 | ;;Al Petrofsky | |
287 | ;; In thread: | |
288 | ;; R5RS Implementors Pitfalls | |
289 | ;; http://groups.google.com/groups?selm=871zemtmd4.fsf@app.dial.idiom.com | |
290 | (should-be 8.1 -1 | |
291 | (let - ((n (- 1))) n)) | |
292 | ||
293 | (should-be 8.2 '(1 2 3 4 1 2 3 4 5) | |
294 | (let ((ls (list 1 2 3 4))) | |
295 | (append ls ls '(5)))) | |
296 | ||
297 | ;;Not really an error to fail this (Matthias Radestock) | |
298 | ;;If this returns (0 1 0), your map isn't call/cc safe, but is probably | |
299 | ;;tail-recursive. If its (0 0 0), the opposite is true. | |
300 | (should-be 8.3 '(0 1 0) | |
301 | (let () | |
302 | (define executed-k #f) | |
303 | (define cont #f) | |
304 | (define res1 #f) | |
305 | (define res2 #f) | |
306 | (set! res1 (map (lambda (x) | |
307 | (if (= x 0) | |
308 | (call/cc (lambda (k) (set! cont k) 0)) | |
309 | 0)) | |
310 | '(1 0 2))) | |
311 | (if (not executed-k) | |
312 | (begin (set! executed-k #t) | |
313 | (set! res2 res1) | |
314 | (cont 1))) | |
315 | res2)) |