emacs/mps/example/scheme/test-r5rs.scm

;;; test-r5rs.scm -- tests from R5RS
;;;
;;; This file contains test code derived directly from R5RS. It
;;; ensures that all the functions correctly evaluate the examples in
;;; R5RS.
;;;
;;; Tests that rely on features that are unimplemented in the toy
;;; Scheme interpreter distributed with the MPS are marked "UNIMPL".
;;;
;;; DOCUMENT HISTORY
;;;
;;; 2004-07-27  RB  Added document history and Perforce Id keyword.
;;; 2011-06-11  RB  Updated for Ruse/SC.
;;; 2012-11-01  GDR Updated for toy Scheme in MPS kit.

(load "test-common.scm")

;;; let, let*, letrec

(check '(let ((x 2) (y 3)) (* x y)) '6)
(check '(let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))) '35)
(check '(let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))) '70)
(check '(letrec ((even? (lambda (n) (if (zero? n) #t (odd? (- n 1))))) (odd? (lambda (n) (if (zero? n) #f (even? (- n 1)))))) (even? 88)) '#t)

;;; eqv?

(check '(eqv? 'a 'a) '#t)
(check '(eqv? 'a 'b) '#f)
(check '(eqv? 2 2) '#t)
(check '(eqv? '() '()) '#t)
(check '(eqv? 100000000 100000000) '#t)
(check '(eqv? (cons 1 2) (cons 1 2)) '#f)
(check '(eqv? (lambda () 1) (lambda () 2)) '#f)
(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))
      (lambda () (set! n (+ n 1)) n))))
(check '(let ((g (gen-counter))) (eqv? g g)) '#t)
(check '(eqv? (gen-counter) (gen-counter)) '#f)
(define gen-loser
  (lambda ()
    (let ((n 0))
      (lambda () (set! n (+ n 1)) 27))))
(check '(let ((g (gen-loser))) (eqv? g g)) '#t)

(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)
(check '(equal? '(a) '(a)) '#t)
(check '(equal? '(a (b) c) '(a (b) c)) '#t)
(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)

(check '(string->number "100") 100)
(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?

(check '(not #t) '#f)
(check '(not 3) '#f)
(check '(not (list 3)) '#f)
(check '(not #f) '#t)
(check '(not '()) '#f)
(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))))
(define x (list 'a 'b 'c))
(define y x)
(check 'y '(a b c))
(check '(list? y) '#t)
(set-cdr! x 4)
(check 'x '(a . 4))
(check '(eqv? x y) '#t)
(check 'y '(a . 4))
(check '(list? y) '#f)
(set-cdr! x x)
;; UNIMPL: (check '(list? x) '#f)

;;; pair?

(check '(pair? '(a . b)) '#t)
(check '(pair? '(a b c)) '#t)
(check '(pair? '()) '#f)
(check '(pair? '#(a b)) '#f)

;;; cons

(check '(cons 'a '()) '(a))
(check '(cons '(a) '(b c d)) '((a) b c d))
(check '(cons "a" '(b c)) '("a" b c))
(check '(cons 'a 3) '(a . 3))
(check '(cons '(a b) 'c) '((a b) . c))

;;; car

(check '(car '(a b c)) 'a)
(check '(car '((a) b c d)) '(a))
(check '(car '(1 . 2)) '1)

;;; cdr

(check '(cdr '((a) b c d)) '(b c d))
(check '(cdr '(1 . 2)) '2)

;;; list?

(check '(list? '(a b c)) '#t)
(check '(list? '()) '#t)
(check '(list? '(a . b)) '#f)
;; UNIMPL: (check '(let ((x (list 'a))) (set-cdr! x x) (list? x)) '#f)

;;; list

(check '(list 'a (+ 3 4) 'c) '(a 7 c))
(check '(list) '())

;;; length

(check '(length '(a b c)) '3)
(check '(length '(a (b) (c d e))) '3)
(check '(length '()) '0)

;;; append

(check '(append '(x) '(y)) '(x y))
(check '(append '(a) '(b c d)) '(a b c d))
(check '(append '(a (b)) '((c))) '(a (b) (c)))
(check '(append '(a b) '(c . d)) '(a b c . d))
(check '(append '() 'a) 'a)

;;; reverse

(check '(reverse '(a b c)) '(c b a))
(check '(reverse '(a (b c) d (e (f)))) '((e (f)) d (b c) a))

;;; list-tail

(check '(list-tail '(a b c d) 2) '(c d))

;;; list-ref

(check '(list-ref '(a b c d) 2) 'c)
;; UNIMPL: (check '(list-ref '(a b c d) (inexact->exact (round 1.8))) 'c)

;;; memq, memv, member

(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

(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?

(check '(symbol? 'foo) '#t)
(check '(symbol? (car '(a b))) '#t)
(check '(symbol? "bar") '#f)
(check '(symbol? 'nil) '#t)
(check '(symbol? '()) '#f)
(check '(symbol? #f) '#f)

;;; symbol->string

(check '(symbol->string 'flying-fish) '"flying-fish")
(check '(symbol->string 'Martin) '"martin")
(check '(symbol->string (string->symbol "Malvina")) '"Malvina")

;;; string->symbol

(check '(eq? 'mISSISSIppi 'mississippi) '#t)
(check '(eq? 'bitBlt (string->symbol "bitBlt")) '#f)
(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))

;;; vector-ref

(check '(vector-ref '#(1 1 2 3 5 8 13 21) 5) '8)

;(check '(vector-ref '#(1 1 2 3 5 8 13 21) (let ((i (round (* 2 (acos -1))))) (if (inexact? i) (inexact->exact i) i))) '13)

;;; vector-set!

(check '(let ((vec (vector 0 '(2 2 2 2) "Anna"))) (vector-set! vec 1 '("Sue" "Sue")) vec) '#(0 ("Sue" "Sue") "Anna"))

;;; vector->list, list->vector

(check '(vector->list '#(dah dah didah)) '(dah dah didah))
(check '(list->vector '(dididit dah)) '#(dididit dah))

;;; procedure?

(check '(procedure? car) '#t)
(check '(procedure? 'car) '#f)
(check '(procedure? (lambda (x) (* x x))) '#t)
(check '(procedure? '(lambda (x) (* x x))) '#f)
;; UNIMPL: (check '(call-with-current-continuation procedure?) '#t)

;;; apply

(check '(apply + (list 3 4)) '7)
(define compose
  (lambda (f g)
    (lambda args
      (f (apply g args)))))
;; UNIMPL: (check '((compose sqrt *) 12 75) '30)

;;; map

(check '(map cadr '((a b) (d e) (g h))) '(b e h))
;; UNIMPL: (check '(map (lambda (n) (expt n n)) '(1 2 3 4 5)) '(1 4 27 256 3125))
(check '(map + '(1 2 3) '(4 5 6)) '(5 7 9))

;;; for-each

(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)

(define list-length
  (lambda (obj)
    (call-with-current-continuation
      (lambda (return)
        (define (r obj)
          (cond ((null? obj) 0)
                ((pair? obj)
                  (+ (r (cdr obj)) 1))
                (else (return #f))))
        (r obj)))))

;; UNIMPL: (check '(list-length '(1 2 3 4)) '4)

;; UNIMPL: (check '(list-length '(a b . c)) '#f)

;;; values, call-with-values

;; UNIMPL: (check '(call-with-values (lambda () (values 4 5)) (lambda (a b) b)) 5)
;; UNIMPL: (check '(call-with-values * -) -1)

;;; quasiquote

(check '`(list ,(+ 1 2) 4) '(list 3 4))
(check '(let ((name 'a)) `(list ,name ',name)) '(list a (quote a)))
(check '`(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b) '(a 3 4 5 6 b))
;; UNIMPL: (check '`((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))) '((foo 7) . cons))
;; UNIMPL: (check '`#(10 5 ,(abs -4) ,@(map abs '(16 -9)) 8) '#(10 5 4 16 9 8))
;; UNIMPL: (check '`(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f) '(a `(b ,(+ 1 2) ,(foo 4 d) e) f))
;; UNIMPL: (check '(let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)) '(a `(b ,x ,'y d) e))

;;; do

(check '(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) (vector-set! vec i i)) '#(0 1 2 3 4))
(check '(let ((x '(1 3 5 7 9))) (do ((x x (cdr x)) (sum 0 (+ sum (car x)))) ((null? x) sum))) '25)

;;; named let

;; UNIMPL: (check '(let loop ((numbers '(3 -2 1 6 -5)) (nonneg '()) (neg '())) (cond ((null? numbers) (list nonneg neg)) ((>= (car numbers) 0) (loop (cdr numbers) (cons (car numbers) nonneg) neg)) ((< (car numbers) 0) (loop (cdr numbers) nonneg (cons (car numbers) neg))))) '((6 1 3) (-5 -2)))

(write-string "All tests pass.")
(newline)