guile18/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))