123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356 |
- ; Part of Scheme 48 1.9. See file COPYING for notices and license.
- ; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber, Martin Gasbichler
- ; 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 in-encoding out out-encoding error-out error-out-encoding resumer-records)
- (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-byte-vector (vector-ref arg 0) out)))
- (newline out)
- (write-string "=" 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)
- (write-string "==" out) (newline 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))
- =)
- (write-string "<" out) (newline 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)
- (write-string "<<" out) (newline 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))
- <)
- (write-string "<=" out) (newline 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)
- (write-string "<=<=" out) (newline 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))
- <=)
- (write-string ">" out) (newline 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)
- (write-string ">>" out) (newline 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))
- >)
- (write-string ">=" out) (newline 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)
- (write-string ">=>=" out) (newline 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->scalar-value (string-ref (make-string 3) 2))
- (char->scalar-value #\?))
- "make-string2" 0 out)
- (arith-test (- (char->scalar-value (string-ref (make-string 3 #\a) 2))
- (char->scalar-value #\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->scalar-value (string-ref (make-string 3) 2))
- (char->scalar-value #\?))
- "make-string6" 0 out)
- (arith-test (- (char->scalar-value (string-ref (make-string 3 #\a) 2))
- (char->scalar-value #\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 apply list 1 '(2 (3))))
- "(apply + (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)
- (begin
- (write-string "Success: " out)
- (write-string s out)
- (newline out))
- (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)
- (begin
- (write-string "Success: " out)
- (write-string s out)
- (newline out))
- (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
- (write-byte-vector (string->byte-vector string)
- (car channel-option)))
- (define (write-byte-vector bytes channel)
- (channel-maybe-write channel
- bytes
- 0
- (byte-vector-length bytes)))
- (define (string->byte-vector string)
- ((lambda (size)
- ((lambda (bytes)
- (letrec ((loop
- (lambda (i)
- (if (< i size)
- (begin
- (byte-vector-set! bytes i
- (char->scalar-value (string-ref string i)))
- (loop (+ 1 i)))))))
- (loop 0)
- bytes))
- (make-byte-vector size 0)))
- (string-length string)))
- (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-bytes-to-string! buffer string len)
- string)
- (make-string len #\space))
- (loop (+ have got))))
- (has-newline buffer have got))))
- (channel-maybe-read in buffer have (- 80 have) #f)))))
- (loop 0)))
- (make-byte-vector 80 (char->scalar-value #\space))))
- (define (has-newline bytes start count)
- (letrec ((loop (lambda (i)
- (if (= i count)
- #f
- (if (char=? #\newline
- (scalar-value->char
- (byte-vector-ref bytes (+ start i))))
- (+ start i)
- (loop (+ i 1)))))))
- (loop 0)))
- (define (copy-bytes-to-string! from to count)
- (letrec ((loop (lambda (i)
- (if (< i count)
- (begin
- (string-set! to i
- (scalar-value->char (byte-vector-ref from i)))
- (loop (+ i 1)))))))
- (loop 0)))
|