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