313 lines
11 KiB
Scheme
313 lines
11 KiB
Scheme
; 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)))
|