105 lines
2.7 KiB
Scheme
105 lines
2.7 KiB
Scheme
|
|
; 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)))
|