;;;;
;;;; test-r5rs-pitfall.stk	-- The SISC R5RS pitfall test
;;;;
;;;; Copyright © 2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program 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 General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@essi.fr]
;;;;    Creation date:  5-Jan-2007 12:20 (eg)
;;;;


;;; This test comes with the SISC system. It is available at the following
;;; URL: http://sisc.sourceforge.net/r5rs_pitfall.scm.


(require "test")
(unless (provided? "full-syntax")
  ;; We are probably executing this test prior installation => add
  ;; the distribution library to the current load-path.
  (load-path (cons "../lib" (load-path)))
  (require "full-syntax"))

(test-section "R5RS pitfall")


;;----------------------------------------------------------------
;; r5rs_pitfalls.scm
;;
;; This program attempts to test a Scheme implementation's conformance
;; to various subtle edge-cases and consequences of the R5RS Scheme standard.
;; Code was collected from public forums, and is hereby placed in the public domain.
;;
;;

;;[eg] All the "should-be" call have been replaced by a "test" to
;;[eg] adapt this test to STklos testing framework.

(define-syntax should-be
  (syntax-rules ()
    ((_ test-id value expression)
     (let ((return-value expression))
         (if (not (equal? return-value value))
           (for-each (lambda (v) (display v))
                     `("Failure: " test-id ", expected '"
                     value "', got '" ,return-value "'." #\newline))
           (for-each (lambda (v) (display v))
                     '("Passed: " test-id #\newline)))))))

(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
(test "Test #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
(test "Test #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
(test "Test #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
(test "Test #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
(test "Test #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
(test "Test #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

(test "Test #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
(test "Test #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
(test "Test #4.1" '(x)
 ((lambda lambda lambda) 'x))

(test "Test #4.2" '(1 2 3)
 ((lambda (begin) (begin 1 2 3)) (lambda lambda lambda)))

(test "Test #4.3" #f
 (let ((quote -)) (eqv? '1 1)))
;; Section 5: #f/() distinctness

;; Scott Miller
(test "Test #5.1" #f
  (eq? #f '()))
(test "Test #5.2" #f
  (eqv? #f '()))
(test "Test #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
(test "Test #6.1" #f
  (eq? (string->symbol "f") (string->symbol "F")))

;; Section 7: First class continuations

;; Scott Miller
;; No newsgroup posting associated.  The gist 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)
(test "Test #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)
(test "Test #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.
(test "Test #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))
		   ;;[eg] modified the case in a cond, because full-syntax
		   ;;[eg] convert clause such as ((1) (k3 4)) in
		   ;;[eg] (('1) (k3 '4)) which is (I believe) incorrect
		   ;;[eg] (tested on several systems)
                   (cond
                     ((= state 1) (k3 4))
                     ((= state 2) (k2 2))
                     ((= state 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)
#;(test "Test #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
(test "Test #8.1" -1
  (let - ((n (- 1))) n))

(test "Test #8.2" '(1 2 3 4 1 2 3 4 5)
  (let ((ls (list 1 2 3 4)))
    (append ls ls '(5))))

;; This example actually illustrates a bug in R5RS.  If a Scheme system
;; follows the letter of the standard, 1 should be returned, but
;; the general agreement is that 2 should instead be returned.
;; The reason is that in R5RS, let-syntax always introduces new scope, thus
;; in the following test, the let-syntax breaks the definition section
;; and begins the expression section of the let.
;;
;; The general agreement by the implementors in 1998 was that the following
;; should be possible, but isn't:
;;
;;   (define ---)
;;   (let-syntax (---)
;;     (define ---)
;;     (define ---))
;;   (define ---)
;;
;; Scheme systems based on the Portable syntax-case expander by Dybvig
;; and Waddell do allow the above, and thus often violate the letter of
;; R5RS.  In such systems, the following will produce a local scope:
;;
;;   (define ---)
;;   (let-syntax ((a ---))
;;     (let ()
;;       (define ---)
;;       (define ---)))
;;   (define ---)
;;
;; Credits to Matthias Radestock and thanks to R. Kent Dybvig for the
;; explanation and background
(test "Test #8.3" 1
  (let ((x 1))
    (let-syntax ((foo (syntax-rules () ((_) 2))))
      (define x (foo))
      3)
    x))

;;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.
;;[eg] (let ((result
;;[eg]        (let ()
;;[eg]          (define executed-k #f)
;;[eg]          (define cont #f)
;;[eg]          (define res1 #f)
;;[eg]          (define res2 #f)
;;[eg]          (set! res1 (map (lambda (x)
;;[eg]                            (if (= x 0)
;;[eg]                                (call/cc (lambda (k) (set! cont k) 0))
;;[eg]                                0))
;;[eg]                          '(1 0 2)))
;;[eg]          (if (not executed-k)
;;[eg]              (begin (set! executed-k #t)
;;[eg]                     (set! res2 res1)
;;[eg]                     (cont 1)))
;;[eg]          res2)))
;;[eg]   (if (equal? result '(0 0 0))
;;[eg]       (display "Map is call/cc safe, but probably not tail recursive or inefficient.")
;;[eg]       (display "Map is not call/cc safe, but probably tail recursive and efficient."))
;;[eg]   (newline))
;;[eg]
;;[eg]




;;----------------------------------------------------------------
(test-section-end)

