scsh-0.5/debug/check.scm

105 lines
2.7 KiB
Scheme
Raw Normal View History

1995-10-13 23:34:21 -04:00
; The barest skeleton of a test suite.
; Mostly it makes sure that many of the external packages load without
; error.
; ,exec ,load debug/check.scm
; (done)
(load-package 'testing)
(config '(run
(define-structure bar (export)
(open scheme testing))))
(in 'bar '(bench off))
(in 'bar '(run (define (foo) (cadr '(a b)))))
(in 'bar '(run (define cadr list)))
(in 'bar '(run (test "non-bench" equal? '((a b)) (foo))))
(in 'bar '(bench on))
(in 'bar '(run (define (foo) (car '(a b)))))
(in 'bar '(run (define car list)))
(in 'bar '(run (test "bench" equal? 'a (foo))))
(config '(run
(define-structure foo (export)
(open scheme testing
assembler
queues
random
sort
big-scheme
arrays
dump/restore
search-trees
threads
sicp)
(begin
(test "* 1" = 6 (* 1 2 3))
(test "* 2" = (* 214760876 10) 2147608760)
(test "* 3" = (* 47123 46039) 2169495797)
(test "apply" equal? '(1 2 3 4) (apply list 1 2 '(3 4)))
(test "char<->integer" eq? #\a (integer->char (char->integer #\a)))
(test "lap" equal? #f ((lap #f (false) (return))))
(let ((q (make-queue)))
(enqueue q 'a)
(test "q" eq? 'a (dequeue q)))
(test "random" <= 0 ((make-random 7)))
(test "sort" equal? '(1 2 3 3) (sort-list '(2 3 1 3) <))
(test "bigbit" = (expt 2 100) (arithmetic-shift 1 100))
(test "format" string=? "x(1 2)" (format #f "x~s" '(1 2)))
(test "destructure" eq? 'a (destructure (((x (y) z) '(b (a) c))) y))
(test "array" eq? 'a
(let ((a (make-array 'b 3 4)))
(array-set! a 'a 1 2)
(array-ref a 1 2)))
(test "receive" eq? 'a (receive (x y) (values 'b 'a) y))
(let ((z '(a "b" 3 #t)))
(test "dump" equal? z
(let ((q (make-queue)))
(dump z (lambda (c) (enqueue q c)) -1)
(restore (lambda () (dequeue q))))))
(with-multitasking
(lambda ()
(let* ((cv (make-condvar))
(th (spawn (lambda ()
(relinquish-timeslice)
(condvar-set! cv 'foo))
'test)))
(test "threads" eq? 'foo (condvar-ref cv)))))
(test "explode" equal? 'ab3 (implode (explode 'ab3)))
(test "get/put" equal? 'a (begin (put 'foo 'prop 'a)
(get 'foo 'prop)))
(test "search-trees" eq? 'a
(let ((t (make-search-tree = <)))
(search-tree-set! t 3 'b)
(search-tree-set! t 4 'a)
(search-tree-set! t 5 'c)
(search-tree-ref t 4)))
))))
(load-package 'foo)
(load-package 'floatnums)
(in 'foo '(run (let* ((one (exact->inexact 1))
(three (exact->inexact 3))
(third (/ one three))
(xthird (inexact->exact third)))
(test "float" eq? #f (= 1/3 xthird))
(test "exact<->inexact" = third (exact->inexact xthird)))))
; All done.
(if (in 'testing '(run (lost?)))
(display "Some tests failed.")
(display "All tests succeeded."))
(newline)
(define (done)
(exit (if (in 'testing '(run (lost?))) 1 0)))