;;;; test-suite/lib.scm --- generic support for testing
-;;;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.
-;;;;
+;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
+;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
-;;;;
+;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
-;;;;
+;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;;;; Boston, MA 02111-1307 USA
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
(define-module (test-suite lib)
- :use-module (ice-9 regex))
-
-(export
+ :use-module (ice-9 stack-catch)
+ :use-module (ice-9 regex)
+ :export (
;; Exceptions which are commonly being tested for.
- exception:out-of-range exception:wrong-type-arg
+ exception:bad-variable
+ exception:missing-expression
+ exception:out-of-range exception:unbound-var
+ exception:used-before-defined
+ exception:wrong-num-args exception:wrong-type-arg
+ exception:numerical-overflow
+ exception:struct-set!-denied
+ exception:system-error
+ exception:miscellaneous-error
+ exception:string-contains-nul
;; Reporting passes and failures.
run-test
;; Naming groups of tests in a regular fashion.
with-test-prefix with-test-prefix* current-test-prefix
+ format-test-name
+
+ ;; Using the debugging evaluator.
+ with-debugging-evaluator with-debugging-evaluator*
;; Reporting results in various ways.
register-reporter unregister-reporter reporter-registered?
make-count-reporter print-counts
- make-log-reporter
+ make-log-reporter
full-reporter
- user-reporter
- format-test-name
-
- ;; Noticing whether an error occurs.
- signals-error? signals-error?*)
+ user-reporter))
;;;; If you're using Emacs's Scheme mode:
;;;;
;;;; Convenience macros for tests expected to pass or fail
;;;;
-;;;; * (pass-if name body) is a short form for
+;;;; * (pass-if name body) is a short form for
;;;; (run-test name #t (lambda () body))
-;;;; * (expect-fail name body) is a short form for
+;;;; * (expect-fail name body) is a short form for
;;;; (run-test name #f (lambda () body))
;;;;
-;;;; For example:
+;;;; For example:
;;;;
;;;; (pass-if "integer addition" (= 2 (+ 1 1)))
;;;;
;;;; - Test names can be compared with EQUAL?.
;;;; - Test names can be reliably stored and retrieved with the standard WRITE
;;;; and READ procedures; doing so preserves their identity.
-;;;;
+;;;;
;;;; For example:
-;;;;
+;;;;
;;;; (pass-if "simple addition" (= 4 (+ 2 2)))
-;;;;
+;;;;
;;;; In that case, the test name is the list ("simple addition").
;;;;
+;;;; In the case of simple tests the expression that is tested would often
+;;;; suffice as a test name by itself. Therefore, the convenience macros
+;;;; pass-if and expect-fail provide a shorthand notation that allows to omit
+;;;; a test name in such cases.
+;;;;
+;;;; * (pass-if expression) is a short form for
+;;;; (run-test 'expression #t (lambda () expression))
+;;;; * (expect-fail expression) is a short form for
+;;;; (run-test 'expression #f (lambda () expression))
+;;;;
+;;;; For example:
+;;;;
+;;;; (pass-if (= 2 (+ 1 1)))
+;;;;
;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish
;;;; a prefix for the names of all tests whose results are reported
;;;; within their dynamic scope. For example:
-;;;;
+;;;;
;;;; (begin
;;;; (with-test-prefix "basic arithmetic"
;;;; (pass-if "addition" (= (+ 2 2) 4))
;;;; (pass-if "subtraction" (= (- 4 2) 2)))
;;;; (pass-if "multiplication" (= (* 2 2) 4)))
-;;;;
+;;;;
;;;; In that example, the three test names are:
;;;; ("basic arithmetic" "addition"),
;;;; ("basic arithmetic" "subtraction"), and
;;;;
;;;; WITH-TEST-PREFIX can be nested. Each WITH-TEST-PREFIX postpends
;;;; a new element to the current prefix:
-;;;;
+;;;;
;;;; (with-test-prefix "arithmetic"
;;;; (with-test-prefix "addition"
;;;; (pass-if "integer" (= (+ 2 2) 4))
;;;; (with-test-prefix "subtraction"
;;;; (pass-if "integer" (= (- 2 2) 0))
;;;; (pass-if "complex" (= (- 2+3i 1+2i) 1+1i))))
-;;;;
+;;;;
;;;; The four test names here are:
;;;; ("arithmetic" "addition" "integer")
;;;; ("arithmetic" "addition" "complex")
;;;; To print a name for a human reader, we DISPLAY its elements,
;;;; separated by ": ". So, the last set of test names would be
;;;; reported as:
-;;;;
+;;;;
;;;; arithmetic: addition: integer
;;;; arithmetic: addition: complex
;;;; arithmetic: subtraction: integer
\f
;;;; REPORTERS
-;;;;
+;;;;
;;;; A reporter is a function which we apply to each test outcome.
;;;; Reporters can log results, print interesting results to the
;;;; standard output, collect statistics, etc.
-;;;;
+;;;;
;;;; A reporter function takes two mandatory arguments, RESULT and TEST, and
;;;; possibly additional arguments depending on RESULT; its return value
;;;; is ignored. RESULT has one of the following forms:
;;;;
-;;;; pass - The test named TEST passed.
+;;;; pass - The test named TEST passed.
;;;; Additional arguments are ignored.
;;;; upass - The test named TEST passed unexpectedly.
;;;; Additional arguments are ignored.
;;;; tested because something else went wrong.
;;;; Additional arguments are ignored.
;;;; untested - The test named TEST was not actually performed, for
-;;;; example because the test case is not complete yet.
+;;;; example because the test case is not complete yet.
;;;; Additional arguments are ignored.
;;;; unsupported - The test named TEST requires some feature that is not
;;;; available in the configured testing environment.
;;;;
;;; Define some exceptions which are commonly being tested for.
+(define exception:bad-variable
+ (cons 'syntax-error "Bad variable"))
+(define exception:missing-expression
+ (cons 'misc-error "^missing or extra expression"))
(define exception:out-of-range
- (cons 'out-of-range "^Argument .*out of range"))
+ (cons 'out-of-range "^.*out of range"))
+(define exception:unbound-var
+ (cons 'unbound-variable "^Unbound variable"))
+(define exception:used-before-defined
+ (cons 'unbound-variable "^Variable used before given a value"))
+(define exception:wrong-num-args
+ (cons 'wrong-number-of-args "^Wrong number of arguments"))
(define exception:wrong-type-arg
- (cons 'wrong-type-arg "^Wrong type argument"))
+ (cons 'wrong-type-arg "^Wrong type"))
+(define exception:numerical-overflow
+ (cons 'numerical-overflow "^Numerical overflow"))
+(define exception:struct-set!-denied
+ (cons 'misc-error "^set! denied for field"))
+(define exception:system-error
+ (cons 'system-error ".*"))
+(define exception:miscellaneous-error
+ (cons 'misc-error "^.*"))
+
+;; as per throw in scm_to_locale_stringn()
+(define exception:string-contains-nul
+ (cons 'misc-error "^string contains #\\\\nul character"))
+
;;; Display all parameters to the default output port, followed by a newline.
(define (display-line . objs)
(throw 'unresolved)))
(lambda (key . args)
(case key
- ((pass)
+ ((pass)
(report (if expect-pass 'pass 'upass) test-name))
- ((fail)
+ ((fail)
(report (if expect-pass 'fail 'xfail) test-name))
- ((unresolved untested unsupported)
+ ((unresolved untested unsupported)
(report key test-name))
- ((quit)
+ ((quit)
(report 'unresolved test-name)
(quit))
- (else
+ (else
(report 'error test-name (cons key args))))))
(set! test-running #f))))
(set! run-test local-run-test))
;;; A short form for tests that are expected to pass, taken from Greg.
-(defmacro pass-if (name body . rest)
- `(run-test ,name #t (lambda () ,body ,@rest)))
+(defmacro pass-if (name . rest)
+ (if (and (null? rest) (pair? name))
+ ;; presume this is a simple test, i.e. (pass-if (even? 2))
+ ;; where the body should also be the name.
+ `(run-test ',name #t (lambda () ,name))
+ `(run-test ,name #t (lambda () ,@rest))))
;;; A short form for tests that are expected to fail, taken from Greg.
-(defmacro expect-fail (name body . rest)
- `(run-test ,name #f (lambda () ,body ,@rest)))
+(defmacro expect-fail (name . rest)
+ (if (and (null? rest) (pair? name))
+ ;; presume this is a simple test, i.e. (expect-fail (even? 2))
+ ;; where the body should also be the name.
+ `(run-test ',name #f (lambda () ,name))
+ `(run-test ,name #f (lambda () ,@rest))))
;;; A helper function to implement the macros that test for exceptions.
(define (run-test-exception name exception expect-pass thunk)
(run-test name expect-pass
(lambda ()
- (catch (car exception)
+ (stack-catch (car exception)
(lambda () (thunk) #f)
- (lambda (key proc message . rest)
- (if (not (string-match (cdr exception) message))
- (apply throw key proc message rest)
- #t))))))
+ (lambda (key proc message . rest)
+ (cond
+ ;; handle explicit key
+ ((string-match (cdr exception) message)
+ #t)
+ ;; handle `(error ...)' which uses `misc-error' for key and doesn't
+ ;; yet format the message and args (we have to do it here).
+ ((and (eq? 'misc-error (car exception))
+ (list? rest)
+ (string-match (cdr exception)
+ (apply simple-format #f message (car rest))))
+ #t)
+ ;; handle syntax errors which use `syntax-error' for key and don't
+ ;; yet format the message and args (we have to do it here).
+ ((and (eq? 'syntax-error (car exception))
+ (list? rest)
+ (string-match (cdr exception)
+ (apply simple-format #f message (car rest))))
+ #t)
+ ;; unhandled; throw again
+ (else
+ (apply throw key proc message rest))))))))
;;; A short form for tests that expect a certain exception to be thrown.
(defmacro pass-if-exception (name exception body . rest)
(defmacro with-test-prefix (prefix . body)
`(with-test-prefix* ,prefix (lambda () ,@body)))
+;;; Call THUNK using the debugging evaluator.
+(define (with-debugging-evaluator* thunk)
+ (let ((dopts #f))
+ (dynamic-wind
+ (lambda ()
+ (set! dopts (debug-options))
+ (debug-enable 'debug))
+ thunk
+ (lambda ()
+ (debug-options dopts)))))
+
+;;; Evaluate BODY... using the debugging evaluator.
+(define-macro (with-debugging-evaluator . body)
+ `(with-debugging-evaluator* (lambda () ,@body)))
+
+
\f
;;;; REPORTERS
-;;;;
+;;;;
;;; The global list of reporters.
(define reporters '())
;;;; User reporters write interesting test results to the standard output.
;;; The complete list of possible test results.
-(define result-tags
+(define result-tags
'((pass "PASS" "passes: ")
(fail "FAIL" "failures: ")
(upass "UPASS" "unexpected passes: ")
(error "ERROR" "errors: ")))
;;; The list of important test results.
-(define important-result-tags
+(define important-result-tags
'(fail upass unresolved error))
;;; Display a single test result in formatted form to the given port
(list
(lambda (result name . args)
(let ((pair (assq result counts)))
- (if pair
+ (if pair
(set-cdr! pair (+ 1 (cdr pair)))
- (error "count-reporter: unexpected test result: "
+ (error "count-reporter: unexpected test result: "
(cons result (cons name args))))))
(lambda ()
(append counts '())))))
;;; Print a count reporter's results nicely. Pass this function the value
;;; returned by a count reporter's RESULTS procedure.
(define (print-counts results . port?)
- (let ((port (if (pair? port?)
+ (let ((port (if (pair? port?)
(car port?)
(current-output-port))))
(newline port)
(apply full-reporter result name args)))
(set! default-reporter full-reporter)
-
-\f
-;;;; Detecting whether errors occur
-
-;;; (signals-error? KEY BODY ...)
-;;; Evaluate the expressions BODY ... . If any errors occur, return #t;
-;;; otherwise, return #f.
-;;;
-;;; KEY indicates the sort of errors to look for; it can be a symbol,
-;;; indicating that only errors with that name should be caught, or
-;;; #t, meaning that any kind of error should be caught.
-(defmacro signals-error? key-and-body
- `(signals-error?* ,(car key-and-body)
- (lambda () ,@(cdr key-and-body))))
-
-;;; (signals-error?* KEY THUNK)
-;;; Apply THUNK, catching errors. If any errors occur, return #t;
-;;; otherwise, return #f.
-;;;
-;;; KEY indicates the sort of errors to look for; it can be a symbol,
-;;; indicating that only errors with that name should be caught, or
-;;; #t, meaning that any kind of error should be caught.
-(define (signals-error?* key thunk)
- (catch key
- (lambda () (thunk) #f)
- (lambda args #t)))