~ chicken-core (chicken-5) /tests/r5rs_pitfalls.scm

  1;; r5rs_pitfalls.scm
  2;; 
  3;; This program attempts to test a Scheme implementation's conformance
  4;; to various subtle edge-cases and consequences of the R5RS Scheme standard.
  5;; Code was collected from public forums, and is hereby placed in the public domain.
  6;;
  7;; 
  8(define-syntax should-be
  9  (syntax-rules ()
 10    ((_ test-id value expression)
 11     (let ((return-value expression))
 12         (if (not (equal? return-value value))
 13           (for-each (lambda (v) (display v))
 14                     `("Failure: " test-id ", expected '"
 15                     value "', got '" ,return-value "'." #\newline))
 16           (for-each (lambda (v) (display v))
 17                     '("Passed: " test-id #\newline)))))))
 18
 19(define call/cc call-with-current-continuation)
 20
 21;; Section 1: Proper letrec implementation
 22
 23;;Credits to Al Petrofsky
 24;; In thread:
 25;; defines in letrec body 
 26;; http://groups.google.com/groups?selm=87bsoq0wfk.fsf%40app.dial.idiom.com
 27(should-be 1.1 0
 28 (let ((cont #f))
 29   (letrec ((x (call-with-current-continuation (lambda (c) (set! cont c) 0)))
 30            (y (call-with-current-continuation (lambda (c) (set! cont c) 0))))
 31     (if cont
 32         (let ((c cont))
 33           (set! cont #f)
 34           (set! x 1)
 35           (set! y 1)
 36           (c 0))
 37         (+ x y)))))
 38
 39;;Credits to Al Petrofsky
 40;; In thread:
 41;; Widespread bug (arguably) in letrec when an initializer returns twice
 42;; http://groups.google.com/groups?selm=87d793aacz.fsf_-_%40app.dial.idiom.com
 43(should-be 1.2 #t
 44  (letrec ((x (call/cc list)) (y (call/cc list)))
 45    (cond ((procedure? x) (x (pair? y)))
 46	  ((procedure? y) (y (pair? x))))
 47    (let ((x (car x)) (y (car y)))
 48      (and (call/cc x) (call/cc y) (call/cc x)))))
 49
 50;;Credits to Alan Bawden
 51;; In thread:
 52;; LETREC + CALL/CC = SET! even in a limited setting 
 53;; http://groups.google.com/groups?selm=19890302162742.4.ALAN%40PIGPEN.AI.MIT.EDU
 54(should-be 1.3 #t
 55  (letrec ((x (call-with-current-continuation
 56		  (lambda (c)
 57		    (list #T c)))))
 58      (if (car x)
 59	  ((cadr x) (list #F (lambda () x)))
 60	  (eq? x ((cadr x))))))
 61
 62;; Section 2: Proper call/cc and procedure application
 63
 64;;Credits to Al Petrofsky, (and a wink to Matthias Blume)
 65;; In thread:
 66;; Widespread bug in handling (call/cc (lambda (c) (0 (c 1)))) => 1 
 67;; http://groups.google.com/groups?selm=87g00y4b6l.fsf%40radish.petrofsky.org
 68(should-be 2.1 1
 69 (call/cc (lambda (c) (0 (c 1)))))
 70
 71;; Section 3: Hygienic macros
 72
 73;; Eli Barzilay 
 74;; In thread:
 75;; R5RS macros...
 76;; http://groups.google.com/groups?selm=skitsdqjq3.fsf%40tulare.cs.cornell.edu
 77(should-be 3.1 4
 78  (let-syntax ((foo
 79                (syntax-rules ()
 80                  ((_ expr) (+ expr 1)))))
 81    (let ((+ *))
 82      (foo 3))))
 83
 84
 85;; Al Petrofsky again
 86;; In thread:
 87;; Buggy use of begin in r5rs cond and case macros. 
 88;; http://groups.google.com/groups?selm=87bse3bznr.fsf%40radish.petrofsky.org
 89(should-be 3.2 2
 90 (let-syntax ((foo (syntax-rules ()
 91                       ((_ var) (define var 1)))))
 92     (let ((x 2))
 93       (begin (define foo +))
 94       (cond (else (foo x))) 
 95       x)))
 96
 97;;Al Petrofsky
 98;; In thread:
 99;; An Advanced syntax-rules Primer for the Mildly Insane
100;; http://groups.google.com/groups?selm=87it8db0um.fsf@radish.petrofsky.org
101
102(should-be 3.3 1
103  (let ((x 1))
104    (let-syntax
105        ((foo (syntax-rules ()
106                ((_ y) (let-syntax
107                             ((bar (syntax-rules ()
108                                   ((_) (let ((x 2)) y)))))
109                         (bar))))))
110      (foo x))))
111
112;; Al Petrofsky
113;; Contributed directly
114(should-be 3.4 1
115  (let-syntax ((x (syntax-rules ()))) 1))
116
117;; Setion 4: No identifiers are reserved
118
119;;(Brian M. Moore)
120;; In thread:
121;; shadowing syntatic keywords, bug in MIT Scheme?
122;; http://groups.google.com/groups?selm=6e6n88%248qf%241%40news.cc.ukans.edu
123(should-be 4.1 '(x)
124 ((lambda lambda lambda) 'x))
125
126(should-be 4.2 '(1 2 3)
127 ((lambda (begin) (begin 1 2 3)) (lambda lambda lambda)))
128
129(should-be 4.3 #f
130 (let ((quote -)) (eqv? '1 1)))
131;; Section 5: #f/() distinctness
132
133;; Scott Miller
134(should-be 5.1 #f
135  (eq? #f '()))
136(should-be 5.2 #f
137  (eqv? #f '()))
138(should-be 5.3 #f
139  (equal? #f '()))
140
141;; Section 6: string->symbol case sensitivity
142
143;; Jens Axel S?gaard
144;; In thread:
145;; Symbols in DrScheme - bug? 
146;; http://groups.google.com/groups?selm=3be55b4f%240%24358%24edfadb0f%40dspool01.news.tele.dk
147(should-be 6.1 #f
148  (eq? (string->symbol "f") (string->symbol "F")))
149
150;; Section 7: First class continuations
151
152;; Scott Miller
153;; No newsgroup posting associated.  The gist of this test and 7.2
154;; is that once captured, a continuation should be unmodified by the 
155;; invocation of other continuations.  This test determines that this is 
156;; the case by capturing a continuation and setting it aside in a temporary
157;; variable while it invokes that and another continuation, trying to 
158;; side effect the first continuation.  This test case was developed when
159;; testing SISC 1.7's lazy CallFrame unzipping code.
160(define r #f)
161(define a #f)
162(define b #f)
163(define c #f)
164(define i 0)
165(should-be 7.1 28
166  (let () 
167    (set! r (+ 1 (+ 2 (+ 3 (call/cc (lambda (k) (set! a k) 4))))
168               (+ 5 (+ 6 (call/cc (lambda (k) (set! b k) 7))))))
169    (if (not c) 
170        (set! c a))
171    (set! i (+ i 1))
172    (case i
173      ((1) (a 5))
174      ((2) (b 8))
175      ((3) (a 6))
176      ((4) (c 4)))
177    r))
178
179;; Same test, but in reverse order
180(define r #f)
181(define a #f)
182(define b #f)
183(define c #f)
184(define i 0)
185(should-be 7.2 28
186  (let () 
187    (set! r (+ 1 (+ 2 (+ 3 (call/cc (lambda (k) (set! a k) 4))))
188               (+ 5 (+ 6 (call/cc (lambda (k) (set! b k) 7))))))
189    (if (not c) 
190        (set! c a))
191    (set! i (+ i 1))
192    (case i
193      ((1) (b 8))
194      ((2) (a 5))
195      ((3) (b 7))
196      ((4) (c 4)))
197    r))
198
199;; Credits to Matthias Radestock
200;; Another test case used to test SISC's lazy CallFrame routines.
201(should-be 7.3 '((-1 4 5 3)
202                 (4 -1 5 3)
203                 (-1 5 4 3)
204                 (5 -1 4 3)
205                 (4 5 -1 3)
206                 (5 4 -1 3))
207  (let ((k1 #f)
208        (k2 #f)
209        (k3 #f)
210        (state 0))
211    (define (identity x) x)
212    (define (fn)
213      ((identity (if (= state 0)
214                     (call/cc (lambda (k) (set! k1 k) +))
215                     +))
216       (identity (if (= state 0)
217                     (call/cc (lambda (k) (set! k2 k) 1))
218                     1))
219       (identity (if (= state 0)
220                     (call/cc (lambda (k) (set! k3 k) 2))
221                     2))))
222    (define (check states)
223      (set! state 0)
224      (let* ((res '())
225             (r (fn)))
226        (set! res (cons r res))
227        (if (null? states)
228            res
229            (begin (set! state (car states))
230                   (set! states (cdr states))
231                   (case state
232                     ((1) (k3 4))
233                     ((2) (k2 2))
234                     ((3) (k1 -)))))))
235    (map check '((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1)))))
236
237;; Modification of the yin-yang puzzle so that it terminates and produces
238;; a value as a result. (Scott G. Miller)
239(should-be 7.4 '(10 9 8 7 6 5 4 3 2 1 0)
240  (let ((x '())
241        (y 0))
242    (call/cc 
243     (lambda (escape)
244       (let* ((yin ((lambda (foo) 
245                      (set! x (cons y x))
246                      (if (= y 10)
247                          (escape x)
248                          (begin
249                            (set! y 0)
250                            foo)))
251                    (call/cc (lambda (bar) bar))))
252              (yang ((lambda (foo) 
253                       (set! y (+ y 1))
254                       foo)
255                     (call/cc (lambda (baz) baz)))))
256         (yin yang))))))
257
258;; Miscellaneous 
259
260;;Al Petrofsky
261;; In thread:
262;; R5RS Implementors Pitfalls
263;; http://groups.google.com/groups?selm=871zemtmd4.fsf@app.dial.idiom.com
264(should-be 8.1 -1
265  (let - ((n (- 1))) n))
266
267(should-be 8.2 '(1 2 3 4 1 2 3 4 5)
268  (let ((ls (list 1 2 3 4)))
269    (append ls ls '(5))))
270
271;; This example actually illustrates a bug in R5RS.  If a Scheme system
272;; follows the letter of the standard, 1 should be returned, but
273;; the general agreement is that 2 should instead be returned.
274;; The reason is that in R5RS, let-syntax always introduces new scope, thus 
275;; in the following test, the let-syntax breaks the definition section
276;; and begins the expression section of the let. 
277;;
278;; The general agreement by the implementors in 1998 was that the following 
279;; should be possible, but isn't:
280;;
281;;   (define ---)
282;;   (let-syntax (---)
283;;     (define ---)
284;;     (define ---))
285;;   (define ---)
286;;
287;; Scheme systems based on the Portable syntax-case expander by Dybvig
288;; and Waddell do allow the above, and thus often violate the letter of
289;; R5RS.  In such systems, the following will produce a local scope:
290;;
291;;   (define ---)
292;;   (let-syntax ((a ---))
293;;     (let ()
294;;       (define ---)
295;;       (define ---)))
296;;   (define ---)
297;;
298;; Credits to Matthias Radestock and thanks to R. Kent Dybvig for the
299;; explanation and background
300(should-be 8.3 1
301  (let ((x 1))
302    (let-syntax ((foo (syntax-rules () ((_) 2))))
303      (define x (foo))
304      3)
305    x))
306
307;;Not really an error to fail this (Matthias Radestock)
308;;If this returns (0 1 0), your map isn't call/cc safe, but is probably
309;;tail-recursive.  If its (0 0 0), the opposite is true.
310(let ((result 
311       (let ()
312         (define executed-k #f)
313         (define cont #f)
314         (define res1 #f)
315         (define res2 #f)
316         (set! res1 (map (lambda (x)
317                           (if (= x 0)
318                               (call/cc (lambda (k) (set! cont k) 0))
319                               0))
320                         '(1 0 2)))
321         (if (not executed-k)           
322             (begin (set! executed-k #t) 
323                    (set! res2 res1)
324                    (cont 1)))
325         res2)))
326  (if (equal? result '(0 0 0))
327      (display "Map is call/cc safe, but probably not tail recursive or inefficient.")
328      (display "Map is not call/cc safe, but probably tail recursive and efficient."))
329  (newline))
330