214 lines
6.3 KiB
Scheme
214 lines
6.3 KiB
Scheme
;;; Basic functions for the scsh-test-suite
|
|
;;; Author: 2001 David Frese
|
|
|
|
;; --- The list to store the tests ---
|
|
|
|
(define *test-list* '())
|
|
|
|
;; --- add-test! ------------------------------------------------
|
|
;; This is the main function to add a test to the test-suite
|
|
;; name - a symbol naming the test uniquely
|
|
;; group - a symbol for the group of this test
|
|
;; proc - the function that does the test
|
|
;; args - the arguments for proc
|
|
;; add-test deletes all previously added tests that have the same
|
|
;; name (group is ignored)!
|
|
;; proc should return #f or signal an error, if the test failed.
|
|
;; Every other value means, that the test succeeded.
|
|
|
|
(define (add-test! name group proc . args)
|
|
(let ((test (make-testdt name group proc args)))
|
|
(let ((other (filter (lambda (test)
|
|
(equal? (testdt-name test)
|
|
name))
|
|
*test-list*)))
|
|
(for-each (lambda (test)
|
|
(set! *test-list* (delete! test *test-list*)))
|
|
other))
|
|
(set! *test-list* (cons test *test-list*))))
|
|
|
|
(define (find-test name)
|
|
(find (lambda (test)
|
|
(eq? (testdt-name test) name))
|
|
*test-list*))
|
|
|
|
;; --- add-test-multiple! ----------------------------------------
|
|
;; This function calls add-test! multiple times, with the same proc,
|
|
;; but different arguments.
|
|
;; name, group, proc see add-test! above
|
|
;; input-lists - each additional parameter has to be a list, specifying
|
|
;; alternative operands for proc.
|
|
;; Now add-test! is called for each permutation of input-lists.
|
|
;; If there's more than 1 permutation, the name is appended with
|
|
;; "-1"..."-n" respectively.
|
|
;; Example:
|
|
;; (add-test-multiple! 'test 'general proc '(a b) '(1 2))
|
|
;; results in 4 tests, that could have been generated with
|
|
;; (add-test 'test-1 'general proc 'a 1)
|
|
;; (add-test 'test-2 'general proc 'b 1)
|
|
;; (add-test 'test-3 'general proc 'a 2)
|
|
;; (add-test 'test-4 'general proc 'b 2)
|
|
;; Note: In future versions, these tests will run simultanously
|
|
;; with multi-threading.
|
|
|
|
(define (add-test-multiple! name group proc . input-lists)
|
|
(let* ((permutations (permute-lists input-lists))
|
|
(single? (and (not (null? permutations))
|
|
(null? (cdr permutations)))))
|
|
(let loop ((i 0)
|
|
(permutations permutations))
|
|
(if (not (null? permutations))
|
|
(let ((input-params (car permutations))
|
|
(new-name (if single?
|
|
name
|
|
(string->symbol (string-append
|
|
(symbol->string name)
|
|
"-"
|
|
(number->string i))))))
|
|
(apply add-test!
|
|
new-name
|
|
group
|
|
proc
|
|
input-params)
|
|
(loop (+ i 1) (cdr permutations)))))))
|
|
|
|
(define (permute-lists lists)
|
|
(cond
|
|
((null? lists) lists)
|
|
((null? (cdr lists)) (map list (car lists)))
|
|
(else
|
|
(let ((first-list (car lists))
|
|
(rest-perm (permute-lists (cdr lists))))
|
|
(fold-right (lambda (elem result)
|
|
(append
|
|
(map (lambda (new-param)
|
|
(cons new-param elem))
|
|
first-list)
|
|
result))
|
|
'()
|
|
rest-perm)))))
|
|
|
|
;; --- Functions for the test-datatype ---
|
|
|
|
(define-record-type testdt :testdt
|
|
(make-testdt name group proc args)
|
|
testdt?
|
|
(name testdt-name)
|
|
(group testdt-group)
|
|
(proc testdt-proc)
|
|
(args testdt-args))
|
|
|
|
|
|
;; --- Basic function to make a test ---
|
|
|
|
(define (run-test test . rest)
|
|
(let ((silent (if (null? rest) #f (car rest)))
|
|
|
|
(name (testdt-name test))
|
|
(group (testdt-group test))
|
|
(proc (testdt-proc test))
|
|
(args (testdt-args test)))
|
|
|
|
(let ((display-start (lambda ()
|
|
(display "Testing ")
|
|
(display group)
|
|
(display ":")
|
|
(display name)
|
|
(display " ... "))))
|
|
(if (not silent)
|
|
(display-start))
|
|
|
|
(call-with-current-continuation
|
|
(lambda (k)
|
|
(if (with-handler
|
|
(lambda (cond more)
|
|
(display "Error: ")
|
|
(display cond)
|
|
(newline)
|
|
(k #f))
|
|
(lambda ()
|
|
(apply proc args)))
|
|
(begin
|
|
(if silent
|
|
(display ".")
|
|
(display "OK\n"))
|
|
#t)
|
|
(begin
|
|
(if silent
|
|
(begin (newline)
|
|
(display-start)))
|
|
(display "Error! Input was ")
|
|
(display args)
|
|
(newline)
|
|
#f)))))))
|
|
|
|
;; --- Exported functions to make a test -------------------------------
|
|
;; The following 3 functions start the testing. They all have an
|
|
;; optional parameter >silent< with default #f. if silent is #t,
|
|
;; only those tests that signaled an error are printed on the screen.
|
|
;; test-single - runs the test with that name, returns the result of proc.
|
|
;; test-group - runs all tests that are part of that group. the result
|
|
;; is unspecified.
|
|
;; test-all - runs all tests in the test-suite.
|
|
|
|
(define (test-single name . rest)
|
|
(let ((test (find-test name)))
|
|
(if test
|
|
(apply run-test test rest)
|
|
(begin
|
|
(display "Test ") (display name)
|
|
(display " not found")
|
|
(newline)))))
|
|
|
|
(define (test-single/args name . args)
|
|
(let* ((test (find-test name))
|
|
(group (testdt-group test))
|
|
(proc (testdt-proc test)))
|
|
(run-test (apply make-testdt name group proc args))))
|
|
|
|
(define (test-group group . rest)
|
|
(let ((tests (filter (lambda (test)
|
|
(eq? (testdt-group test)
|
|
group))
|
|
*test-list*)))
|
|
(if (null? tests)
|
|
(begin
|
|
(display "Group ") (display group)
|
|
(display " doesn't contain any tests")
|
|
(newline))
|
|
(for-each (lambda (test)
|
|
(apply run-test
|
|
test rest))
|
|
tests))))
|
|
|
|
(define (test-all . rest)
|
|
(for-each (lambda (test)
|
|
(apply run-test
|
|
test rest))
|
|
*test-list*))
|
|
|
|
;; --- Summary functions -------------------------------------------
|
|
;; test-summary displays all registered tests in the test-suite, if
|
|
;; called with no arguments. Calling it with the additional parameter
|
|
;; group, displays only those tests that belong to that group.
|
|
|
|
(define (test-summary . rest)
|
|
(let ((group (if (null? rest) #f (car rest))))
|
|
(if group
|
|
(begin
|
|
(display "Listing group: ") (display group) (newline)
|
|
(for-each (lambda (test)
|
|
(if (eq? (testdt-group test) group)
|
|
(begin
|
|
(display (testdt-name test))
|
|
(newline))))
|
|
*test-list*))
|
|
(begin
|
|
(display "Listing all tests in format: group:name") (newline)
|
|
(for-each (lambda (test)
|
|
(display (testdt-group test))
|
|
(display ":")
|
|
(display (testdt-name test))
|
|
(newline))
|
|
*test-list*)))))
|