; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.

; Tests for many of the primitives, both inlined and close-compiled.

; This prints `Hello' three times and then the first command argument, if any,
; and finally reads a line from standard input and prints it to standard output.

(define (start arg in out error-out)
  (call-with-values
    (lambda ()
      (values "H" "e" "ll" "o" " "))
    (lambda (h e ll o sp)
      (write-string h out)
      (write-string e out)
      (write-string ll out)
      (write-string o out)
      (write-string sp out)))
  (call-with-values
    (lambda ()
      (apply values "H" "e" '("ll" "o" " ")))
    (lambda (h e ll o sp)
      (write-string h out)
      (write-string e out)
      (write-string ll out)
      (write-string o out)
      (write-string sp out)))
  (call-with-values
    (lambda ()
      (values "H" "e" "ll" "o" " "))
    (lambda (h e . more)
      (write-string h out)
      (write-string e out)
      (letrec ((loop (lambda (more)
		       (if (eq? '() more)
			   0
			   (begin
			     (write-string (car more) out)
			     (loop (cdr more)))))))
	(loop more))))
  (if (vector? arg)
      (if (< 0 (vector-length arg))
	  (write-string (vector-ref arg 0) out)))
  (newline out)

  (bool-test (= 1 1) "(= 1 1)" #t out)
  (bool-test (= 1 2) "(= 1 2)" #f out)
  (bool-test (= 1 1 1) "(= 1 1 1)" #t out)
  (bool-test (= 1 2 3) "(= 1 2 3)" #f out)
  (bool-test (= 1 1 1 3) "(= 1 1 1 3)" #f out)
  (bool-test (= 1 1 1 1) "(= 1 1 1 1)" #t out)
  (bool-test (= 1 1 2 3) "(= 1 1 2 3)" #f out)
  (bool-test (= 1 1 1 3) "(= 1 1 1 3)" #f out)
  ((lambda (=)
     (bool-test (= 1 1) "(= 1 1)" #t out)
     (bool-test (= 1 2) "(= 1 2)" #f out)
     (bool-test (= 1 1 1) "(= 1 1 1)" #t out)
     (bool-test (= 1 2 3) "(= 1 2 3)" #f out)
     (bool-test (= 1 1 3) "(= 1 1 3)" #f out)
     (bool-test (= 1 1 1 3) "(= 1 1 1 3)" #f out)
     (bool-test (= 1 1 1 1) "(= 1 1 1 1)" #t out)
     (bool-test (= 1 1 2 3) "(= 1 1 2 3)" #f out)
     (bool-test (= 1 1 1 3) "(= 1 1 1 3)" #f out))
   =)
  (bool-test (< 1 1) "(< 1 1)" #f out)
  (bool-test (< 1 2) "(< 1 2)" #t out)
  (bool-test (< 1 1 1) "(< 1 1 1)" #f out)
  (bool-test (< 1 2 3) "(< 1 2 3)" #t out)
  (bool-test (< 1 2 2) "(< 1 2 2)" #f out)
  ((lambda (<)
     (bool-test (< 1 1) "(< 1 1)" #f out)
     (bool-test (< 1 2) "(< 1 2)" #t out)
     (bool-test (< 1 1 1) "(< 1 1 1)" #f out)
     (bool-test (< 1 2 3) "(< 1 2 3)" #t out)
     (bool-test (< 1 2 2) "(< 1 2 2)" #f out))
   <)
  (bool-test (<= 1 1) "(<= 1 1)" #t out)
  (bool-test (<= 1 2) "(<= 1 2)" #t out)
  (bool-test (<= 2 1) "(<= 2 1)" #f out)
  (bool-test (<= 1 1 1) "(<= 1 1 1)" #t out)
  (bool-test (<= 1 2 3) "(<= 1 2 3)" #t out)
  (bool-test (<= 1 2 2) "(<= 1 2 2)" #t out)
  (bool-test (<= 1 2 1) "(<= 1 2 1)" #f out)
  ((lambda (<=)
     (bool-test (<= 1 1) "(<= 1 1)" #t out)
     (bool-test (<= 1 2) "(<= 1 2)" #t out)
     (bool-test (<= 2 1) "(<= 2 1)" #f out)
     (bool-test (<= 1 1 1) "(<= 1 1 1)" #t out)
     (bool-test (<= 1 2 3) "(<= 1 2 3)" #t out)
     (bool-test (<= 1 2 2) "(<= 1 2 2)" #t out)
     (bool-test (<= 1 2 1) "(<= 1 2 1)" #f out))
   <=)
  (bool-test (> 1 1) "(> 1 1)" #f out)
  (bool-test (> 2 1) "(> 2 1)" #t out)
  (bool-test (> 1 1 1) "(> 1 1 1)" #f out)
  (bool-test (> 3 2 1) "(> 3 2 1)" #t out)
  (bool-test (> 2 1 1) "(> 2 1 1)" #f out)
  ((lambda (>)
     (bool-test (> 1 1) "(> 1 1)" #f out)
     (bool-test (> 2 1) "(> 2 1)" #t out)
     (bool-test (> 1 1 1) "(> 1 1 1)" #f out)
     (bool-test (> 3 2 1) "(> 3 2 1)" #t out)
     (bool-test (> 2 1 1) "(> 2 1 1)" #f out))
   >)
  (bool-test (>= 1 1) "(>= 1 1)" #t out)
  (bool-test (>= 2 1) "(>= 2 1)" #t out)
  (bool-test (>= 1 2) "(>= 1 2)" #f out)
  (bool-test (>= 1 1 1) "(>= 1 1 1)" #t out)
  (bool-test (>= 3 2 1) "(>= 3 2 1)" #t out)
  (bool-test (>= 2 1 1) "(>= 2 1 1)" #t out)
  (bool-test (>= 2 1 2) "(>= 2 1 2)" #f out)
  ((lambda (>=)
     (bool-test (>= 1 1) "(>= 1 1)" #t out)
     (bool-test (>= 2 1) "(>= 2 1)" #t out)
     (bool-test (>= 1 2) "(>= 1 2)" #f out)
     (bool-test (>= 1 1 1) "(>= 1 1 1)" #t out)
     (bool-test (>= 3 2 1) "(>= 3 2 1)" #t out)
     (bool-test (>= 2 1 1) "(>= 2 1 1)" #t out)
     (bool-test (>= 2 1 2) "(>= 2 1 2)" #f out))
   >=)
  (arith-test (vector-length (make-vector 3)) "make-vector0" 3 out)
  (arith-test (vector-length (make-vector 3 4)) "make-vector1" 3 out)
  (arith-test (vector-ref (make-vector 3 4) 2) "make-vector2" 4 out)
  ((lambda (make-vector)
     (arith-test (vector-length (make-vector 3)) "make-vector3" 3 out)
     (arith-test (vector-length (make-vector 3 4)) "make-vector4" 3 out)
     (arith-test (vector-ref (make-vector 3 4) 2) "make-vector5" 4 out))
   make-vector)
  (arith-test (string-length (make-string 3)) "make-string0" 3 out)
  (arith-test (string-length (make-string 3 #\a)) "make-string1" 3 out)
  (arith-test (- (char->ascii (string-ref (make-string 3) 2))
		 (char->ascii #\?))
	      "make-string2" 0 out)
  (arith-test (- (char->ascii (string-ref (make-string 3 #\a) 2))
		 (char->ascii #\a))
	      "make-string3" 0 out)
  ((lambda (make-string)
     (arith-test (string-length (make-string 3)) "make-string4" 3 out)
     (arith-test (string-length (make-string 3 #\a)) "make-string5" 3 out)
     (arith-test (- (char->ascii (string-ref (make-string 3) 2))
		    (char->ascii #\?))
		 "make-string6" 0 out)
     (arith-test (- (char->ascii (string-ref (make-string 3 #\a) 2))
		    (char->ascii #\a))
		 "make-string7" 0 out))
   make-string)
  (arith-test (apply + '()) "(apply + '())" 0 out)
  (arith-test (apply + '(1)) "(apply + '(1))" 1 out)
  (arith-test (apply + 1 '()) "(apply + 1 '())" 1 out)
  (arith-test (apply + '(1 2)) "(apply + '(1 2))" 3 out)
  (arith-test (apply + 1 '(2)) "(apply + 1 '(2))" 3 out)
  (arith-test (apply + 1 2 '()) "(apply + 1 2 '())" 3 out)
  (arith-test (apply + '(1 2 3)) "(apply + '(1 2 3))" 6 out)
  (arith-test (apply + 1 2 '(3)) "(apply + 1 2 '(3))" 6 out)
  (bool-test (apply < '(1 2)) "(apply < '(1 2))" #t out)
  (bool-test (apply < 1 '(2)) "(apply < 1 '(2))" #t out)
  (bool-test (apply < 1 2 '()) "(apply < 1 2 '())" #t out)
  (bool-test (apply < '(1 2 3)) "(apply < '(1 2 3))" #t out)
  (bool-test (apply < 1 2 '(3)) "(apply < 1 2 '(3))" #t out)
  (arith-test (apply apply (list + '(1 2 3)))
	      "(apply apply (list + '(1 2 3)))" 6 out)
  (arith-test (apply apply (list + 1 2 '(3)))
	      "(apply apply (list + 1 2 '(3)))" 6 out)
  (arith-test (apply apply (list + 1 2 3 '()))
	      "(apply apply (list + 1 2 3 '()))" 6 out)
  (arith-test (apply apply + 1 '(2 3 ())) "(apply apply + 1 '(2 3 ())" 6 out)
  (arith-test (apply apply + 1 '(2 (3))) "(apply apply + 1 '(2 3 ())" 6 out)
  (arith-test (apply apply + 1 2 3 '(())) "(apply + 1 2 3 '(()))" 6 out)
  ((lambda (apply)
     (arith-test (apply + '(1 2 3)) "(apply + '(1 2 3))" 6 out)
     (arith-test (apply + 1 2 '(3)) "(apply + 1 2 '(3))" 6 out)
     (arith-test (apply apply (list + '(1 2 3)))
		 "(apply apply (list + '(1 2 3)))" 6 out)
     (arith-test (apply apply (list + 1 2 '(3)))
		 "(apply apply (list + 1 2 '(3)))" 6 out)
     (arith-test (apply apply (list + 1 2 3 '()))
		 "(apply apply (list + 1 2 3 '()))" 6 out)
     (arith-test (apply apply + 1 '(2 3 ())) "(apply apply + 1 '(2 3 ())" 6 out)
     (arith-test (apply apply + 1 '(2 (3))) "(apply apply + 1 '(2 3 ())" 6 out)
     (arith-test (apply apply + 1 2 3 '(())) "(apply + 1 2 3 '(()))" 6 out))
   apply)
  (arith-test (+) "(+)" 0 out)
  (arith-test (+ 3) "(+ 3)" 3 out)
  (arith-test (+ 3 4) "(+ 3 4)" 7 out)
  (arith-test (+ 3 4 5) "(+ 3 4 5)" 12 out)
  (arith-test (+ 1 2 3 4 5 6 7 8 9 10 -50) "(+ 1 2 3 ... 10 -50) = 5" 5 out)
  ((lambda (+)
     (arith-test (+) "(+) closed" 0 out)
     (arith-test (+ 3) "(+ 3) closed" 3 out)
     (arith-test (+ 3 4) "(+ 3 4) closed" 7 out)
     (arith-test (+ 3 4 5) "(+ 3 4 5) closed" 12 out)
     (arith-test (+ 3 4 5 6) "(+ 3 4 5 6) closed" 18 out)
     (arith-test (+ 3 4 5 6 7) "(+ 3 4 5 6 7) closed" 25 out)
     (arith-test (+ 1 2 3 4 5 6 7 8 9 10 -50) "(+ 1 2 3 ... 10 -50) = 5 closed" 5 out))
   +)
  (arith-test (*) "(*)" 1 out)
  (arith-test (* 3) "(* 3)" 3 out)
  (arith-test (* 3 4) "(* 3 4)" 12 out)
  (arith-test (* 3 4 2) "(* 3 4 2)" 24 out)
  ((lambda (*)
     (arith-test (*) "(*)" 1 out)
     (arith-test (* 3) "(* 3)" 3 out)
     (arith-test (* 3 4) "(* 3 4)" 12 out)
     (arith-test (* 3 4 2) "(* 3 4 2)" 24 out))
   *)
  (arith-test (- -3) "(- -3)" 3 out)
  (arith-test (- 3 -4) "(- 3 -4)" 7 out)
  ((lambda (-)
     (arith-test (- -3) "(- -3)" 3 out)
     (arith-test (- 3 -4) "(- 3 -4)" 7 out))
   -)
  (arith-test (/ 1) "(/ 1)" 1 out)
  (arith-test (/ 12 4) "(/ 12 4)" 3 out)
  ((lambda (/)
     (arith-test (/ 1) "(/ 1)" 1 out)
     (arith-test (/ 12 4) "(/ 12 4)" 3 out))
   /)
  (arith-test (bitwise-ior) "(bitwise-ior)" 0 out)
  (arith-test (bitwise-ior 5) "(bitwise-ior 5)" 5 out)
  (arith-test (bitwise-ior 5 3) "(bitwise-ior 5 3)" 7 out)
  (arith-test (bitwise-ior 5 3 16) "(bitwise-ior 5 3 16)" 23 out)
  (arith-test (bitwise-xor) "(bitwise-xor)" 0 out)
  (arith-test (bitwise-xor 5) "(bitwise-xor 5)" 5 out)
  (arith-test (bitwise-xor 5 3) "(bitwise-xor 5 3)" 6 out)
  (arith-test (bitwise-xor 5 3 16) "(bitwise-xor 5 3 16)" 22 out)
  (arith-test (- (bitwise-and)) "(- (bitwise-and))" 1 out)
  (arith-test (bitwise-and 5) "(bitwise-and 5)" 5 out)
  (arith-test (bitwise-and 7 3) "(bitwise-and 7 3)" 3 out)
  (arith-test (bitwise-and 7 3 17) "(bitwise-and 7 3 17)" 1 out)
  (apply write-string (read-string in) (cons out '()))
  (newline out)
  0)

(define (length l n)
  (if (eq? l '()) n (length (cdr l) (+ n 1))))

(define (list . x) x)

(define numbers
  '#("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"
     "10" "11" "12" "13" "14" "15" "16" "17" "18" "19"
     "20" "21" "22" "23" "24" "25" "26" "27" "28" "29"))

(define (number->string n)
  (vector-ref numbers n))
	 
(define (arith-test n s a out)
  (if (= n a)
      #t
      (begin
	(write-string "Failure: " out)
	(write-string s out)
	(write-string " = " out)
	(write-string (number->string n) out)
	(write-string " and not " out)
	(write-string (number->string a) out)
	(newline out))))

(define (bool-test n s a out)
  (if (eq? n a)
      #t
      (begin
	(write-string "Failure: " out)
	(write-string s out)
	(write-string " => " out)
	(write-string (if n "#t" "#f") out)
	(newline out))))

(define (write-string string . channel-option)  ; test n-ary procedures
  (channel-maybe-write string
		       0
		       (string-length string)
		       (car channel-option)))

(define (newline channel)
  (write-string "
" channel))

(define (read-string in)
  ((lambda (buffer)
     (letrec ((loop (lambda (have)
		      ((lambda (got)
			 (if (eq? got (eof-object))
			     "eof"
			     ((lambda (len)
				(if len
				    ((lambda (string)
				       (copy-string! buffer string len)
				       string)
				     (make-string len #\space))
				    (loop (+ have got))))
			      (has-newline buffer have got))))
		       (channel-maybe-read buffer have (- 80 have) #f in)))))
       (loop 0)))
   (make-string 80 #\space)))

(define (has-newline string start count)
  (letrec ((loop (lambda (i)
		   (if (= i count)
		       #f
		       (if (char=? #\newline
				   (string-ref string (+ start i)))
			   (+ start i)
			   (loop (+ i 1)))))))
    (loop 0)))

(define (copy-string! from to count)
  (letrec ((loop (lambda (i)
		   (if (< i count)
		       (begin
			 (string-set! to i (string-ref from i))
			 (loop (+ i 1)))))))
    (loop 0)))