--- /dev/null
+;;;; r5rs_pitfall.test --- tests some pitfalls in R5RS -*- scheme -*-
+;;;; Copyright (C) 2003, 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;; These tests have been copied from
+;; http://sisc.sourceforge.net/r5rs_pitfall.scm and the 'should-be'
+;; macro has been modified to fit into our test suite machinery.
+
+(define-module (test-suite test-r5rs-pitfall)
+ :use-syntax (ice-9 syncase)
+ :use-module (test-suite lib))
+
+(define-syntax should-be
+ (syntax-rules ()
+ ((_ test-id value expression)
+ (run-test test-id #t (lambda ()
+ (false-if-exception
+ (equal? expression value)))))))
+
+(define-syntax should-be-but-isnt
+ (syntax-rules ()
+ ((_ test-id value expression)
+ (run-test test-id #f (lambda ()
+ (false-if-exception
+ (equal? expression value)))))))
+
+(define call/cc call-with-current-continuation)
+
+;; Section 1: Proper letrec implementation
+
+;;Credits to Al Petrofsky
+;; In thread:
+;; defines in letrec body
+;; http://groups.google.com/groups?selm=87bsoq0wfk.fsf%40app.dial.idiom.com
+
+(should-be 1.1 0
+ (let ((cont #f))
+ (letrec ((x (call-with-current-continuation (lambda (c) (set! cont c) 0)))
+ (y (call-with-current-continuation (lambda (c) (set! cont c) 0))))
+ (if cont
+ (let ((c cont))
+ (set! cont #f)
+ (set! x 1)
+ (set! y 1)
+ (c 0))
+ (+ x y)))))
+
+;;Credits to Al Petrofsky
+;; In thread:
+;; Widespread bug (arguably) in letrec when an initializer returns twice
+;; http://groups.google.com/groups?selm=87d793aacz.fsf_-_%40app.dial.idiom.com
+(should-be 1.2 #t
+ (letrec ((x (call/cc list)) (y (call/cc list)))
+ (cond ((procedure? x) (x (pair? y)))
+ ((procedure? y) (y (pair? x))))
+ (let ((x (car x)) (y (car y)))
+ (and (call/cc x) (call/cc y) (call/cc x)))))
+
+;;Credits to Alan Bawden
+;; In thread:
+;; LETREC + CALL/CC = SET! even in a limited setting
+;; http://groups.google.com/groups?selm=19890302162742.4.ALAN%40PIGPEN.AI.MIT.EDU
+(should-be 1.3 #t
+ (letrec ((x (call-with-current-continuation
+ (lambda (c)
+ (list #T c)))))
+ (if (car x)
+ ((cadr x) (list #F (lambda () x)))
+ (eq? x ((cadr x))))))
+
+;; Section 2: Proper call/cc and procedure application
+
+;;Credits to Al Petrofsky, (and a wink to Matthias Blume)
+;; In thread:
+;; Widespread bug in handling (call/cc (lambda (c) (0 (c 1)))) => 1
+;; http://groups.google.com/groups?selm=87g00y4b6l.fsf%40radish.petrofsky.org
+(should-be 2.1 1
+ (call/cc (lambda (c) (0 (c 1)))))
+
+;; Section 3: Hygienic macros
+
+;; Eli Barzilay
+;; In thread:
+;; R5RS macros...
+;; http://groups.google.com/groups?selm=skitsdqjq3.fsf%40tulare.cs.cornell.edu
+(should-be 3.1 4
+ (let-syntax ((foo
+ (syntax-rules ()
+ ((_ expr) (+ expr 1)))))
+ (let ((+ *))
+ (foo 3))))
+
+
+;; Al Petrofsky again
+;; In thread:
+;; Buggy use of begin in r5rs cond and case macros.
+;; http://groups.google.com/groups?selm=87bse3bznr.fsf%40radish.petrofsky.org
+(should-be 3.2 2
+ (let-syntax ((foo (syntax-rules ()
+ ((_ var) (define var 1)))))
+ (let ((x 2))
+ (begin (define foo +))
+ (cond (else (foo x)))
+ x)))
+
+;;Al Petrofsky
+;; In thread:
+;; An Advanced syntax-rules Primer for the Mildly Insane
+;; http://groups.google.com/groups?selm=87it8db0um.fsf@radish.petrofsky.org
+
+(should-be 3.3 1
+ (let ((x 1))
+ (let-syntax
+ ((foo (syntax-rules ()
+ ((_ y) (let-syntax
+ ((bar (syntax-rules ()
+ ((_) (let ((x 2)) y)))))
+ (bar))))))
+ (foo x))))
+
+;; Al Petrofsky
+;; Contributed directly
+(should-be 3.4 1
+ (let-syntax ((x (syntax-rules ()))) 1))
+
+;; Setion 4: No identifiers are reserved
+
+;;(Brian M. Moore)
+;; In thread:
+;; shadowing syntatic keywords, bug in MIT Scheme?
+;; http://groups.google.com/groups?selm=6e6n88%248qf%241%40news.cc.ukans.edu
+(should-be 4.1 '(x)
+ ((lambda lambda lambda) 'x))
+
+(should-be 4.2 '(1 2 3)
+ ((lambda (begin) (begin 1 2 3)) (lambda lambda lambda)))
+
+(should-be 4.3 #f
+ (let ((quote -)) (eqv? '1 1)))
+;; Section 5: #f/() distinctness
+
+;; Scott Miller
+(should-be 5.1 #f
+ (eq? #f '()))
+(should-be 5.2 #f
+ (eqv? #f '()))
+(should-be 5.3 #f
+ (equal? #f '()))
+
+;; Section 6: string->symbol case sensitivity
+
+;; Jens Axel S?gaard
+;; In thread:
+;; Symbols in DrScheme - bug?
+;; http://groups.google.com/groups?selm=3be55b4f%240%24358%24edfadb0f%40dspool01.news.tele.dk
+(should-be 6.1 #f
+ (eq? (string->symbol "f") (string->symbol "F")))
+
+;; Section 7: First class continuations
+
+;; Scott Miller
+;; No newsgroup posting associated. The jist of this test and 7.2
+;; is that once captured, a continuation should be unmodified by the
+;; invocation of other continuations. This test determines that this is
+;; the case by capturing a continuation and setting it aside in a temporary
+;; variable while it invokes that and another continuation, trying to
+;; side effect the first continuation. This test case was developed when
+;; testing SISC 1.7's lazy CallFrame unzipping code.
+(define r #f)
+(define a #f)
+(define b #f)
+(define c #f)
+(define i 0)
+(should-be 7.1 28
+ (let ()
+ (set! r (+ 1 (+ 2 (+ 3 (call/cc (lambda (k) (set! a k) 4))))
+ (+ 5 (+ 6 (call/cc (lambda (k) (set! b k) 7))))))
+ (if (not c)
+ (set! c a))
+ (set! i (+ i 1))
+ (case i
+ ((1) (a 5))
+ ((2) (b 8))
+ ((3) (a 6))
+ ((4) (c 4)))
+ r))
+
+;; Same test, but in reverse order
+(define r #f)
+(define a #f)
+(define b #f)
+(define c #f)
+(define i 0)
+(should-be 7.2 28
+ (let ()
+ (set! r (+ 1 (+ 2 (+ 3 (call/cc (lambda (k) (set! a k) 4))))
+ (+ 5 (+ 6 (call/cc (lambda (k) (set! b k) 7))))))
+ (if (not c)
+ (set! c a))
+ (set! i (+ i 1))
+ (case i
+ ((1) (b 8))
+ ((2) (a 5))
+ ((3) (b 7))
+ ((4) (c 4)))
+ r))
+
+;; Credits to Matthias Radestock
+;; Another test case used to test SISC's lazy CallFrame routines.
+(should-be 7.3 '((-1 4 5 3)
+ (4 -1 5 3)
+ (-1 5 4 3)
+ (5 -1 4 3)
+ (4 5 -1 3)
+ (5 4 -1 3))
+ (let ((k1 #f)
+ (k2 #f)
+ (k3 #f)
+ (state 0))
+ (define (identity x) x)
+ (define (fn)
+ ((identity (if (= state 0)
+ (call/cc (lambda (k) (set! k1 k) +))
+ +))
+ (identity (if (= state 0)
+ (call/cc (lambda (k) (set! k2 k) 1))
+ 1))
+ (identity (if (= state 0)
+ (call/cc (lambda (k) (set! k3 k) 2))
+ 2))))
+ (define (check states)
+ (set! state 0)
+ (let* ((res '())
+ (r (fn)))
+ (set! res (cons r res))
+ (if (null? states)
+ res
+ (begin (set! state (car states))
+ (set! states (cdr states))
+ (case state
+ ((1) (k3 4))
+ ((2) (k2 2))
+ ((3) (k1 -)))))))
+ (map check '((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1)))))
+
+;; Modification of the yin-yang puzzle so that it terminates and produces
+;; a value as a result. (Scott G. Miller)
+(should-be 7.4 '(10 9 8 7 6 5 4 3 2 1 0)
+ (let ((x '())
+ (y 0))
+ (call/cc
+ (lambda (escape)
+ (let* ((yin ((lambda (foo)
+ (set! x (cons y x))
+ (if (= y 10)
+ (escape x)
+ (begin
+ (set! y 0)
+ foo)))
+ (call/cc (lambda (bar) bar))))
+ (yang ((lambda (foo)
+ (set! y (+ y 1))
+ foo)
+ (call/cc (lambda (baz) baz)))))
+ (yin yang))))))
+
+;; Miscellaneous
+
+;;Al Petrofsky
+;; In thread:
+;; R5RS Implementors Pitfalls
+;; http://groups.google.com/groups?selm=871zemtmd4.fsf@app.dial.idiom.com
+(should-be 8.1 -1
+ (let - ((n (- 1))) n))
+
+(should-be 8.2 '(1 2 3 4 1 2 3 4 5)
+ (let ((ls (list 1 2 3 4)))
+ (append ls ls '(5))))
+
+;;Not really an error to fail this (Matthias Radestock)
+;;If this returns (0 1 0), your map isn't call/cc safe, but is probably
+;;tail-recursive. If its (0 0 0), the opposite is true.
+(should-be 8.3 '(0 1 0)
+ (let ()
+ (define executed-k #f)
+ (define cont #f)
+ (define res1 #f)
+ (define res2 #f)
+ (set! res1 (map (lambda (x)
+ (if (= x 0)
+ (call/cc (lambda (k) (set! cont k) 0))
+ 0))
+ '(1 0 2)))
+ (if (not executed-k)
+ (begin (set! executed-k #t)
+ (set! res2 res1)
+ (cont 1)))
+ res2))
projects / lilypond.git / blobdiff