← Back to branch summary

~peter-pearse/ubuntu/natty/guile-1.8/prop001

« back to all changes in this revision

Viewing changes to test-suite/tests/r5rs_pitfall.test

  • Committer: Bazaar Package Importer
  • Author(s): Daniel Schepler
  • Date: 2006-11-09 03:11:16 UTC
  • Revision ID: james.westby@ubuntu.com-20061109031116-hu0q1jxqg12y6yeg
Tags: upstream-1.8.1+1
Import upstream version 1.8.1+1

Show diffs side-by-side

added added

removed removed

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