| 1 | ;;;; r5rs_pitfall.test --- tests some pitfalls in R5RS -*- scheme -*- |
| 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 |
| 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 | ;; Test 1.1 fails, but we expect that. |
| 23 | |
| 24 | (define-module (test-suite test-r5rs-pitfall) |
| 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 |
| 50 | |
| 51 | ;; See eval.c for how to make this test succeed. Look for "r5rs pitfall". |
| 52 | |
| 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 |
| 94 | (should-be 2.1 1 |
| 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)) |