1 ;;;; r5rs_pitfall.test --- tests some pitfalls in R5RS -*- scheme -*-
2 ;;;; Copyright (C) 2003, 2004, 2006 Free Software Foundation, Inc.
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 3 of the License, or (at your option) any later version.
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.
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
16 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18 ;; These tests have been copied from
19 ;; http://sisc.sourceforge.net/r5rs_pitfall.scm and the 'should-be'
20 ;; macro has been modified to fit into our test suite machinery.
22 (define-module (test-suite test-r5rs-pitfall)
23 :use-module (test-suite lib))
25 (define-syntax should-be
27 ((_ test-id value expression)
28 (run-test test-id #t (lambda ()
30 (equal? expression value)))))))
32 (define-syntax should-be-but-isnt
34 ((_ test-id value expression)
35 (run-test test-id #f (lambda ()
37 (equal? expression value)))))))
39 (define call/cc call-with-current-continuation)
41 ;; Section 1: Proper letrec implementation
43 ;;Credits to Al Petrofsky
45 ;; defines in letrec body
46 ;; http://groups.google.com/groups?selm=87bsoq0wfk.fsf%40app.dial.idiom.com
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))))
60 ;;Credits to Al Petrofsky
62 ;; Widespread bug (arguably) in letrec when an initializer returns twice
63 ;; http://groups.google.com/groups?selm=87d793aacz.fsf_-_%40app.dial.idiom.com
65 (letrec ((x (call/cc list)) (y (call/cc list)))
66 (cond ((procedure? x) (x (pair? y)))
67 ((procedure? y) (y (pair? x))))
68 (let ((x (car x)) (y (car y)))
69 (and (call/cc x) (call/cc y) (call/cc x)))))
71 ;;Credits to Alan Bawden
73 ;; LETREC + CALL/CC = SET! even in a limited setting
74 ;; http://groups.google.com/groups?selm=19890302162742.4.ALAN%40PIGPEN.AI.MIT.EDU
76 (letrec ((x (call-with-current-continuation
80 ((cadr x) (list #F (lambda () x)))
83 ;; Section 2: Proper call/cc and procedure application
85 ;;Credits to Al Petrofsky, (and a wink to Matthias Blume)
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
90 (call/cc (lambda (c) (0 (c 1)))))
92 ;; Section 3: Hygienic macros
97 ;; http://groups.google.com/groups?selm=skitsdqjq3.fsf%40tulare.cs.cornell.edu
101 ((_ expr) (+ expr 1)))))
106 ;; Al Petrofsky again
108 ;; Buggy use of begin in r5rs cond and case macros.
109 ;; http://groups.google.com/groups?selm=87bse3bznr.fsf%40radish.petrofsky.org
111 (let-syntax ((foo (syntax-rules ()
112 ((_ var) (define var 1)))))
114 (begin (define foo +))
115 (cond (else (foo x)))
120 ;; An Advanced syntax-rules Primer for the Mildly Insane
121 ;; http://groups.google.com/groups?selm=87it8db0um.fsf@radish.petrofsky.org
126 ((foo (syntax-rules ()
128 ((bar (syntax-rules ()
129 ((_) (let ((x 2)) y)))))
134 ;; Contributed directly
136 (let-syntax ((x (syntax-rules ()))) 1))
138 ;; Setion 4: No identifiers are reserved
142 ;; shadowing syntatic keywords, bug in MIT Scheme?
143 ;; http://groups.google.com/groups?selm=6e6n88%248qf%241%40news.cc.ukans.edu
145 ((lambda lambda lambda) 'x))
147 (should-be 4.2 '(1 2 3)
148 ((lambda (begin) (begin 1 2 3)) (lambda lambda lambda)))
151 (let ((quote -)) (eqv? '1 1)))
152 ;; Section 5: #f/() distinctness
162 ;; Section 6: string->symbol case sensitivity
166 ;; Symbols in DrScheme - bug?
167 ;; http://groups.google.com/groups?selm=3be55b4f%240%24358%24edfadb0f%40dspool01.news.tele.dk
169 (eq? (string->symbol "f") (string->symbol "F")))
171 ;; Section 7: First class continuations
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.
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))))))
200 ;; Same test, but in reverse order
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))))))
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)
232 (define (identity x) x)
234 ((identity (if (= state 0)
235 (call/cc (lambda (k) (set! k1 k) +))
237 (identity (if (= state 0)
238 (call/cc (lambda (k) (set! k2 k) 1))
240 (identity (if (= state 0)
241 (call/cc (lambda (k) (set! k3 k) 2))
243 (define (check states)
247 (set! res (cons r res))
250 (begin (set! state (car states))
251 (set! states (cdr states))
256 (map check '((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1)))))
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)
265 (let* ((yin ((lambda (foo)
272 (call/cc (lambda (bar) bar))))
276 (call/cc (lambda (baz) baz)))))
283 ;; R5RS Implementors Pitfalls
284 ;; http://groups.google.com/groups?selm=871zemtmd4.fsf@app.dial.idiom.com
286 (let - ((n (- 1))) n))
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))))
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.
295 (should-be 8.3 '(0 1 0)
297 (define executed-k #f)
301 (set! res1 (map (lambda (x)
303 (call/cc (lambda (k) (set! cont k) 0))
307 (begin (set! executed-k #t)