1;;;; r5rs_pitfall.test --- tests some pitfalls in R5RS -*- scheme -*- 2;;;; Copyright (C) 2003, 2004, 2006, 2014 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 3 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-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 () 29 (false-if-exception 30 (equal? expression value))))))) 31 32(define-syntax should-be-but-isnt 33 (syntax-rules () 34 ((_ test-id value expression) 35 (run-test test-id #f (lambda () 36 (false-if-exception 37 (equal? expression value))))))) 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 47 48(should-be 1.1 0 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))) 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))))) 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 77 (lambda (c) 78 (list #T c))))) 79 (if (car x) 80 ((cadr x) (list #F (lambda () x))) 81 (eq? x ((cadr x)))))) 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 89(should-be 2.1 1 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. 295(should-be 8.3 '(0 0 0) 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) 302 (if (= x 0) 303 (call/cc (lambda (k) (set! cont k) 0)) 304 0)) 305 '(1 0 2))) 306 (if (not executed-k) 307 (begin (set! executed-k #t) 308 (set! res2 res1) 309 (cont 1))) 310 res2)) 311