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 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 1 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))