From f4d7511316539b7acdf4cdc321cf7ec92a94150d Mon Sep 17 00:00:00 2001
From: Gareth Rees <gdr@ravenbrook.com>
Date: Tue, 6 Nov 2012 12:16:59 +0000
Subject: [PATCH] More r4rs, r5rs.

Copied from Perforce
 Change: 180365
 ServerID: perforce.ravenbrook.com
---
 mps/example/scheme/r4rs.scm        | 190 +++++++++++++++++++++++++++++
 mps/example/scheme/test-common.scm |   1 -
 mps/example/scheme/test-r5rs.scm   | 167 +++++++++++++++++++------
 3 files changed, 319 insertions(+), 39 deletions(-)
 create mode 100644 mps/example/scheme/r4rs.scm

diff --git a/mps/example/scheme/r4rs.scm b/mps/example/scheme/r4rs.scm
new file mode 100644
index 00000000000..8dc5c72ab5d
--- /dev/null
+++ b/mps/example/scheme/r4rs.scm
@@ -0,0 +1,190 @@
+;;; r4rs.scm -- essential procedures from R4RS
+
+;; (caar pair)
+;; (cadr pair)
+;; ...
+;; (cdddar pair)
+;; (cddddr pair)
+;; These procedures are compositions of car and cdr. Arbitrary
+;; compositions, up to four deep, are provided. There are twenty-eight
+;; of these procedures in all.
+;; See R4RS 6.3.
+
+(define (caar x) (car (car x)))
+(define (cadr x) (car (cdr x)))
+(define (cdar x) (cdr (car x)))
+(define (cddr x) (cdr (cdr x)))
+
+(define (caaar x) (car (car (car x))))
+(define (caadr x) (car (car (cdr x))))
+(define (cadar x) (car (cdr (car x))))
+(define (caddr x) (car (cdr (cdr x))))
+(define (cdaar x) (cdr (car (car x))))
+(define (cdadr x) (cdr (car (cdr x))))
+(define (cddar x) (cdr (cdr (car x))))
+(define (cdddr x) (cdr (cdr (cdr x))))
+
+(define (caaaar x) (car (car (car (car x)))))
+(define (caaadr x) (car (car (car (cdr x)))))
+(define (caadar x) (car (car (cdr (car x)))))
+(define (caaddr x) (car (car (cdr (cdr x)))))
+(define (cadaar x) (car (cdr (car (car x)))))
+(define (cadadr x) (car (cdr (car (cdr x)))))
+(define (caddar x) (car (cdr (cdr (car x)))))
+(define (cadddr x) (car (cdr (cdr (cdr x)))))
+(define (cdaaar x) (cdr (car (car (car x)))))
+(define (cdaadr x) (cdr (car (car (cdr x)))))
+(define (cdadar x) (cdr (car (cdr (car x)))))
+(define (cdaddr x) (cdr (car (cdr (cdr x)))))
+(define (cddaar x) (cdr (cdr (car (car x)))))
+(define (cddadr x) (cdr (cdr (car (cdr x)))))
+(define (cdddar x) (cdr (cdr (cdr (car x)))))
+(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
+
+
+;; (memq obj list)
+;; (memv obj list)
+;; (member obj list)
+;; These procedures return the first sublist of list whose car is obj,
+;; where the sublists of list are the non-empty lists returned by
+;; (list-tail list k) for k less than the length of list. If obj does
+;; not occur in list, then #f (not the empty list) is returned. Memq
+;; uses eq? to compare obj with the elements of list, while memv uses
+;; eqv? and member uses equal?.
+;; See R4RS 6.3.
+
+(define (memq obj list)
+  (cond ((null? list) #f)
+        ((eq? obj (car list)) list)
+        (else (memq obj (cdr list)))))
+
+(define (memv obj list)
+  (cond ((null? list) #f)
+        ((eqv? obj (car list)) list)
+        (else (memv obj (cdr list)))))
+
+(define (member obj list)
+  (cond ((null? list) #f)
+        ((equal? obj (car list)) list)
+        (else (member obj (cdr list)))))
+
+
+;; (assq obj alist)
+;; (assv obj alist)
+;; (assoc obj alist)
+;; Alist (for "association list") must be a list of pairs. These
+;; procedures find the first pair in alist whose car field is obj, and
+;; returns that pair. If no pair in alist has obj as its car, then #f
+;; (not the empty list) is returned. Assq uses eq? to compare obj with
+;; the car fields of the pairs in alist, while assv uses eqv? and
+;; assoc uses equal?.
+;; See R4RS 6.3.
+
+(define (assq obj list)
+  (cond ((null? list) #f)
+        ((eq? obj (caar list)) (car list))
+        (else (assq obj (cdr list)))))
+
+(define (assv obj list)
+  (cond ((null? list) #f)
+        ((eqv? obj (caar list)) (car list))
+        (else (assv obj (cdr list)))))
+
+(define (assoc obj list)
+  (cond ((null? list) #f)
+        ((equal? obj (caar list)) (car list))
+        (else (assoc obj (cdr list)))))
+
+
+;; (<= x1 x2 x3 ...)
+;; (>= x1 x2 x3 ...)
+;; These procedures return #t if their arguments are (respectively):
+;; monotonically nondecreasing, or monotonically nonincreasing.
+;; These predicates are required to be transitive.
+;; See R4RS 6.5.5.
+
+(define (no-fold op list)
+  (cond ((null? list) #t)
+        ((null? (cdr list)) #t)
+        ((op (car list) (cadr list)) #f)
+        (else (no-fold op (cdr list)))))
+
+(define (<= . rest) (no-fold > rest))
+(define (>= . rest) (no-fold < rest))
+
+
+;; (odd? n)
+;; (even? n)
+;; These numerical predicates test a number for a particular property,
+;; returning #t or #f.
+;; See R4RS 6.5.5.
+
+(define (odd? n) (eqv? (remainder n 2) 1))
+(define (even? n) (eqv? (remainder n 2) 0))
+
+
+;; (max x1 x2 ...)
+;; (min x1 x2 ...)
+;; These procedures return the maximum or minimum of their arguments.
+;; See R4RS 6.5.5.
+
+(define (extremum op x list)
+  (if (null? list) x
+      (extremum op (if (op x (car list)) x (car list)) (cdr list))))
+
+(define (max x1 . rest) (extremum > x1 rest))
+(define (min x1 . rest) (extremum < x1 rest))
+
+
+;; (abs x)
+;; Abs returns the magnitude of its argument.
+;; See R4RS 6.5.5.
+
+(define (abs x) (if (< x 0) (- x) x))
+
+
+;; (quotient n1 n2)
+;; (remainder n1 n2)
+;; These procedures implement number-theoretic (integer) division: For
+;; positive integers n1 and n2, if n3 and n4 are integers such that
+;; n1=n2n3+n4 and 0<= n4<n2, then
+;;
+;; (quotient n1 n2)                       ==>  n3
+;; (remainder n1 n2)                      ==>  n4
+;; 
+;; For integers n1 and n2 with n2 not equal to 0,
+;; 
+;; (= n1 (+ (* n2 (quotient n1 n2))
+;;               (remainder n1 n2)))
+;;                                        ==>  #t
+;; 
+;; provided all numbers involved in that computation are exact.
+;; See R4RS 6.5.5.
+
+(define quotient /)
+(define (remainder n1 n2) (- n1 (* n2 (quotient n1 n2))))
+
+
+;; (number->string number)
+;; (number->string number radix)
+;; Radix must be an exact integer, either 2, 8, 10, or 16. If omitted,
+;; radix defaults to 10. The procedure number->string takes a number
+;; and a radix and returns as a string an external representation of
+;; the given number in the given radix.
+;; See R4RS 6.5.6.
+
+(define (number->string . args)
+  (letrec ((number (car args))
+           (radix (if (null? (cdr args)) 10 (cadr args)))
+           (digits "0123456789ABCDEF")
+           (n->s (lambda (n list) 
+                   (if (zero? n) list
+                       (n->s (quotient n radix)
+                             (cons (string-ref digits (remainder n radix))
+                                   list))))))
+    (cond ((or (< radix 2) (> radix 16))
+           (error "radix must be in the range 2-16"))
+          ((negative? number) 
+           (string-append "-" (number->string (abs number) radix)))
+          ((zero? number) "0")
+          (else (list->string (n->s number '()))))))
diff --git a/mps/example/scheme/test-common.scm b/mps/example/scheme/test-common.scm
index e9d1c8bdc8b..603875cdf8f 100644
--- a/mps/example/scheme/test-common.scm
+++ b/mps/example/scheme/test-common.scm
@@ -21,4 +21,3 @@
 (define (for-each f l) (if (null? l) #f (begin (f (car l)) (for-each f (cdr l)))))
 (define (reduce f l a) (if (null? l) a (f (car l) (reduce f (cdr l) a))))
 (define (sum l) (reduce + l 0))
-(define (abs x) (if (< x 0) (- x) x))
diff --git a/mps/example/scheme/test-r5rs.scm b/mps/example/scheme/test-r5rs.scm
index 5f214581b39..7ecc43c3c8c 100644
--- a/mps/example/scheme/test-r5rs.scm
+++ b/mps/example/scheme/test-r5rs.scm
@@ -14,6 +14,7 @@
 ;;; 2012-11-01  GDR Updated for toy Scheme in MPS kit.
 
 (load "test-common.scm")
+(load "r4rs.scm")
 
 ;;; let, let*, letrec
 
@@ -34,6 +35,11 @@
 (check '(eqv? #f 'nil) '#f)
 (check '(let ((p (lambda (x) x))) (eqv? p p)) '#t)
 
+(check '(boolean? (eqv? "" "")) #t)
+(check '(boolean? (eqv? '#() '#())) #t)
+(check '(boolean? (eqv? (lambda (x) x) (lambda (x) x))) #t)
+(check '(boolean? (eqv? (lambda (x) x) (lambda (y) y))) #t)
+
 (define gen-counter
   (lambda ()
     (let ((n 0))
@@ -48,20 +54,27 @@
 
 (check '(letrec ((f (lambda () (if (eqv? f g) 'f 'both))) (g (lambda () (if (eqv? f g) 'g 'both)))) (eqv? f g)) '#f)
 
+(check '(boolean? (eqv? '(a) '(a))) #t)
+(check '(boolean? (eqv? "a" "a")) #t)
+(check '(boolean? (eqv? '(b) (cdr '(a b)))) #t)
 (check '(let ((x '(a))) (eqv? x x)) '#t)
 
-
 ;;; eq?
 
 (check '(eq? 'a 'a) '#t)
+(check '(boolean? (eq? '(a) '(a))) #t)
 (check '(eq? (list 'a) (list 'a)) '#f)
+(check '(boolean? (eq? "a" "a")) #t)
+(check '(boolean? (eq? "" "")) #t)
 (check '(eq? '() '()) '#t)
+(check '(boolean? (eq? 2 2)) #t)
+(check '(boolean? (eq? #\A #\A)) #t)
 (check '(eq? car car) '#t)
+(check '(boolean? (let ((n (+ 2 3))) (eq? n n))) #t) 
 (check '(let ((x '(a))) (eq? x x)) '#t)
 (check '(let ((x '#())) (eq? x x)) '#t)
 (check '(let ((p (lambda (x) x))) (eq? p p)) '#t)
 
-
 ;;; equal?
 
 (check '(equal? 'a 'a) '#t)
@@ -70,7 +83,84 @@
 (check '(equal? "abc" "abc") '#t)
 (check '(equal? 2 2) '#t)
 (check '(equal? (make-vector 5 'a) (make-vector 5 'a)) '#t)
+(check '(boolean? (equal? (lambda (x) x) (lambda (y) y))) #t)
 
+;;; Numerical operations
+
+;; UNIMPL: (check '(complex? 3+4i) #t)
+;; UNIMPL: (check '(complex? 3) #t)
+;; UNIMPL: (check '(real? 3) #t)
+;; UNIMPL: (check '(real? -2.5+0.0i) #t)
+;; UNIMPL: (check '(real? #e1e10) #t)
+;; UNIMPL: (check '(rational? 6/10) #t)
+;; UNIMPL: (check '(rational? 6/3) #t)
+;; UNIMPL: (check '(integer? 3+0i) #t)
+;; UNIMPL: (check '(integer? 3.0) #t)
+;; UNIMPL: (check '(integer? 8/4) #t)
+
+(check '(max 3 4) 4)
+;; UNIMPL: (check '(max 3.9 4) 4.0)
+
+(check '(+ 3 4) 7)
+(check '(+ 3) 3)
+(check '(+) 0)
+(check '(* 4) 4)
+(check '(*) 1)
+
+(check '(- 3 4) -1)
+(check '(- 3 4 5) -6)
+(check '(- 3) -3)
+;; UNIMPL: (check '(/ 3 4 5) 3/20)
+;; UNIMPL: (check '(/ 3) 1/3)
+
+(check '(abs -7) 7)
+
+;; UNIMPL: (check '(modulo 13 4) 1)
+(check '(remainder 13 4) 1)
+;; UNIMPL: (check '(modulo -13 4) 3)
+(check '(remainder -13 4) -1)
+;; UNIMPL: (check '(modulo 13 -4) -3)
+(check '(remainder 13 -4) 1)
+;; UNIMPL: (check '(modulo -13 -4) -1)
+(check '(remainder -13 -4) -1)
+;; UNIMPL: (check '(remainder -13 -4.0) -1.0)
+
+;; UNIMPL: (check '(gcd 32 -36) 4)
+;; UNIMPL: (check '(gcd) 0)
+;; UNIMPL: (check '(lcm 32 -36) 288)
+;; UNIMPL: (check '(lcm 32.0 -36) 288.0)
+;; UNIMPL: (check '(lcm) 1)
+
+;; UNIMPL: (check '(numerator (/ 6 4)) 3)
+;; UNIMPL: (check '(denominator (/ 6 4)) 2)
+;; UNIMPL: (check '(denominator (exact->inexact (/ 6 4))) 2.0)
+
+;; UNIMPL: (check '(floor -4.3) -5.0)
+;; UNIMPL: (check '(ceiling -4.3) -4.0)
+;; UNIMPL: (check '(truncate -4.3) -4.0)
+;; UNIMPL: (check '(round -4.3) -4.0)
+
+;; UNIMPL: (check '(floor 3.5) 3.0)
+;; UNIMPL: (check '(ceiling 3.5) 4.0)
+;; UNIMPL: (check '(truncate 3.5) 3.0)
+;; UNIMPL: (check '(round 3.5) 4.0)
+
+;; UNIMPL: (check '(round 7/2) 4)
+;; UNIMPL: (check '(round 7) 7)
+
+;; UNIMPL: (check '(rationalize (inexact->exact .3) 1/10) 1/3)
+;; UNIMPL: (check '(rationalize .3 1/10) #i1/3)
+
+;; UNIMPL: (check '(string->number "100") 100)
+;; UNIMPL: (check '(string->number "100" 16) 256)
+;; UNIMPL: (check '(string->number "1e2") 100.0)
+;; UNIMPL: (check '(string->number "15##") 1500.0)
+
+;;; Booleans
+
+(check '#t #t)
+(check '#f #f)
+(check ''#f #f)
 
 ;;; not?
 
@@ -82,14 +172,12 @@
 (check '(not (list)) '#f)
 (check '(not 'nil) '#f)
 
-
 ;;; boolean?
 
 (check '(boolean? #f) '#t)
 (check '(boolean? 0) '#f)
 (check '(boolean? '()) '#f)
 
-
 ;;; Lists
 
 (check ''(a b c . d) '(a . (b . (c . d))))
@@ -105,7 +193,6 @@
 (set-cdr! x x)
 ;; UNIMPL: (check '(list? x) '#f)
 
-
 ;;; pair?
 
 (check '(pair? '(a . b)) '#t)
@@ -174,22 +261,22 @@
 
 ;;; memq, memv, member
 
-;; UNIMPL: (check '(memq 'a '(a b c)) '(a b c))
-;; UNIMPL: (check '(memq 'b '(a b c)) '(b c))
-;; UNIMPL: (check '(memq 'a '(b c d)) #f)
-;; UNIMPL: (check '(memq (list 'a) '(b (a) c)) #f)
-;; UNIMPL: (check '(member (list 'a) '(b (a) c)) '((a) c))
-;; UNIMPL: (check '(memv 101 '(100 101 102)) '(101 102))
+(check '(memq 'a '(a b c)) '(a b c))
+(check '(memq 'b '(a b c)) '(b c))
+(check '(memq 'a '(b c d)) #f)
+(check '(memq (list 'a) '(b (a) c)) #f)
+(check '(member (list 'a) '(b (a) c)) '((a) c))
+(check '(memv 101 '(100 101 102)) '(101 102))
 
 ;;; assq, assv, assoc
 
-;; UNIMPL: (define e '((a 1) (b 2) (c 3)))
-;; UNIMPL: (check '(assq 'a e) '(a 1))
-;; UNIMPL: (check '(assq 'b e) '(b 2))
-;; UNIMPL: (check '(assq 'd e) #f)
-;; UNIMPL: (check '(assq (list 'a) '(((a)) ((b)) ((c)))) #f)
-;; UNIMPL: (check '(assoc (list 'a) '(((a)) ((b)) ((c)))) '((a)))
-;; UNIMPL: (check '(assv 5 '((2 3) (5 7) (11 13))) '(5 7))
+(define e '((a 1) (b 2) (c 3)))
+(check '(assq 'a e) '(a 1))
+(check '(assq 'b e) '(b 2))
+(check '(assq 'd e) #f)
+(check '(assq (list 'a) '(((a)) ((b)) ((c)))) #f)
+(check '(assoc (list 'a) '(((a)) ((b)) ((c)))) '((a)))
+(check '(assv 5 '((2 3) (5 7) (11 13))) '(5 7))
 
 ;;; symbol?
 
@@ -213,6 +300,10 @@
 (check '(eq? 'JollyWog (string->symbol (symbol->string 'JollyWog))) '#t)
 (check '(string=? "K. Harper, M.D." (symbol->string (string->symbol "K. Harper, M.D."))) '#t)
 
+;;; Vectors
+
+(check ''#(0 (2 2 2 2) "Anna") '#(0 (2 2 2 2) "Anna"))
+
 ;;; vector
 
 (check '(vector 'a 'b 'c) '#(a b c))
@@ -259,6 +350,24 @@
 
 ;; UNIMPL: (check '(let ((v (make-vector 5))) (for-each (lambda (i) (vector-set! v i (* i i))) '(0 1 2 3 4)) v) '#(0 1 4 9 16))
 
+;;; delay, force
+
+(define (stream-from n) (delay (cons n (stream-from (+ n 1)))))
+(define s0 (stream-from 0))
+(define (head stream) (car (force stream)))
+(define (tail stream) (cdr (force stream)))
+(check '(head (tail (tail s0))) '2)
+
+(define count 0)
+(define p
+  (delay (begin (set! count (+ count 1))
+                (if (> count x)
+                    count
+                    (force p)))))
+(define x 5)
+(check '(force p) '6)
+;; UNIMPL: (check '(begin (set! x 10) (force p)) '6)
+
 ;;; call/cc
 
 ;; UNIMPL: (check '(call-with-current-continuation (lambda (exit) (for-each (lambda (x) (if (negative? x) (exit x))) '(54 0 37 -3 245 19)) #t)) '-3)
@@ -280,26 +389,8 @@
 
 ;;; values, call-with-values
 
-;; UNIMPL: (check '(call-with-values (lambda () (values 4 5)) (lambda (a b) b)) '5)
-;; UNIMPL: (check '(call-with-values * -) '-1)
-
-;;; delay, force
-
-(define (stream-from n) (delay (cons n (stream-from (+ n 1)))))
-(define s0 (stream-from 0))
-(define (head stream) (car (force stream)))
-(define (tail stream) (cdr (force stream)))
-(check '(head (tail (tail s0))) '2)
-
-(define count 0)
-(define p
-  (delay (begin (set! count (+ count 1))
-                (if (> count x)
-                    count
-                    (force p)))))
-(define x 5)
-(check '(force p) '6)
-;; UNIMPL: (check '(begin (set! x 10) (force p)) '6)
+;; UNIMPL: (check '(call-with-values (lambda () (values 4 5)) (lambda (a b) b)) 5)
+;; UNIMPL: (check '(call-with-values * -) -1)
 
 ;;; quasiquote