From 21dc8c0139be466ebca3f0ba11bfec9e925cb2a8 Mon Sep 17 00:00:00 2001
From: bnewbold <bnewbold@robocracy.org>
Date: Mon, 27 Jun 2022 12:04:00 -0700
Subject: commit old tweaks to test cases and examples

---
 test/r5rs_pitfall.scm   | 332 ++++++++++++++++++++++++++++++++++++++++++++++++
 test/simple.scm         |  48 +++++++
 test/unicode.scm        |   3 +
 test/unicode_lambda.scm |   6 +
 4 files changed, 389 insertions(+)
 create mode 100644 test/r5rs_pitfall.scm
 create mode 100644 test/simple.scm
 create mode 100644 test/unicode.scm
 create mode 100644 test/unicode_lambda.scm

(limited to 'test')

diff --git a/test/r5rs_pitfall.scm b/test/r5rs_pitfall.scm
new file mode 100644
index 0000000..87ca3cf
--- /dev/null
+++ b/test/r5rs_pitfall.scm
@@ -0,0 +1,332 @@
+;; From: http://sisc-scheme.org/r5rs_pitfall.scm
+;;
+;; 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.
+;;
+;; 
+(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
+(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 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)
+(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))))
+
+;; 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
+(should-be 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.
+(let ((result 
+       (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)))
+  (if (equal? result '(0 0 0))
+      (display "Map is call/cc safe, but probably not tail recursive or inefficient.")
+      (display "Map is not call/cc safe, but probably tail recursive and efficient."))
+  (newline))
+
diff --git a/test/simple.scm b/test/simple.scm
new file mode 100644
index 0000000..41babb5
--- /dev/null
+++ b/test/simple.scm
@@ -0,0 +1,48 @@
+
+; This comment should be skipped
+
+(begin
+  (display #t)
+  (newline))
+
+; anonymous lambda
+(define add1 (lambda (x) (+ 1 x)))
+(display (eq? (add1 4) 5))
+(newline)
+
+; named/defined lambda, spread over multiple lines
+(define
+  add1
+  (lambda
+    (x)
+    (+ 1 x)))
+(display (eq? (add1 4) 5))
+(newline)
+
+; this checks that cond is a special form
+(define fact (lambda (n) (if (<= n 1) 1 (* n (fact (- n 1))))))
+(display (eq? 479001600 (fact 12)))
+(newline)
+
+(display (eq? (add1 (car (cons 4 (cons 0 ())))) 5))
+(newline)
+
+(car (car (quote (lambda (x) (+ 1 x)))))
+
+(define dummy-var 5)
+(set! dummy-var 6)
+(display (eq? dummy-var 6))
+(newline)
+
+(display (string? "short string with spaces"))
+(newline)
+
+(display (pair? (cons 1 (cons 2 ()))))
+(newline)
+
+(display (symbol? 'lambda))
+(newline)
+
+(display (procedure? add1))
+(newline)
+
diff --git a/test/unicode.scm b/test/unicode.scm
new file mode 100644
index 0000000..9ea74eb
--- /dev/null
+++ b/test/unicode.scm
@@ -0,0 +1,3 @@
+
+(display (eq? "αβγ" "αβγ"))
+(newline)
diff --git a/test/unicode_lambda.scm b/test/unicode_lambda.scm
new file mode 100644
index 0000000..6c8b17f
--- /dev/null
+++ b/test/unicode_lambda.scm
@@ -0,0 +1,6 @@
+
+(display (eq? (quote λ) 'λ))
+(newline)
+
+(display (eq? 5 ((λ (x) (+ x 4)) 1)))
+(newline)
-- 
cgit v1.2.3