;;;; test-suite/lib.scm --- generic support for testing
-;;;; Copyright (C) 1999, 2000 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.
-;;;;
+;;;; 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 Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3, 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
+;;;; GNU Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this software; see the file COPYING.LESSER.
+;;;; If not, write to the Free Software Foundation, Inc., 51 Franklin
+;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite lib)
- #:use-module (test-suite paths))
-
-(export
+ :use-module (ice-9 stack-catch)
+ :use-module (ice-9 regex)
+ :export (
+
+ ;; Exceptions which are commonly being tested for.
+ 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 pass-if expect-fail
+ run-test
+ pass-if expect-fail
+ pass-if-exception expect-fail-exception
;; 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
-
- ;; Finding test input files.
- data-file
-
- ;; Noticing whether an error occurs.
- signals-error? signals-error?*)
+ user-reporter))
;;;; If you're using Emacs's Scheme mode:
;;;; environment. All other exceptions thrown by THUNK are considered as
;;;; errors.
;;;;
-;;;; For convenience, the following macros are provided:
-;;;; * (pass-if name body) is a short form for
+;;;;
+;;;; Convenience macros for tests expected to pass or fail
+;;;;
+;;;; * (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)))
-
+;;;;
+;;;;
+;;;; Convenience macros to test for exceptions
+;;;;
+;;;; The following macros take exception parameters which are pairs
+;;;; (type . message), where type is a symbol that denotes an exception type
+;;;; like 'wrong-type-arg or 'out-of-range, and message is a string holding a
+;;;; regular expression that describes the error message for the exception
+;;;; like "Argument .* out of range".
+;;;;
+;;;; * (pass-if-exception name exception body) will pass if the execution of
+;;;; body causes the given exception to be thrown. If no exception is
+;;;; thrown, the test fails. If some other exception is thrown, is is an
+;;;; error.
+;;;; * (expect-fail-exception name exception body) will pass unexpectedly if
+;;;; the execution of body causes the given exception to be thrown. If no
+;;;; exception is thrown, the test fails expectedly. If some other
+;;;; exception is thrown, it is an error.
\f
;;;; TEST NAMES
;;;; - 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.
;;;; MISCELLANEOUS
;;;;
+;;; 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 "^.*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"))
+(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)
(for-each display 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)
- `(run-test ,name #t (lambda () (not (not (begin ,body))))))
+(define-syntax pass-if
+ (syntax-rules ()
+ ((_ 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)))
+ ((_ name rest ...)
+ (run-test name #t (lambda () rest ...)))))
;;; A short form for tests that are expected to fail, taken from Greg.
-(defmacro expect-fail (name body)
- `(run-test ,name #f (lambda () ,body)))
+(define-syntax expect-fail
+ (syntax-rules ()
+ ((_ 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)))
+ ((_ name rest ...)
+ (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 ()
+ (stack-catch (car exception)
+ (lambda () (thunk) #f)
+ (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.
+(define-syntax pass-if-exception
+ (syntax-rules ()
+ ((_ name exception body rest ...)
+ (run-test-exception name exception #t (lambda () body rest ...)))))
+
+;;; A short form for tests expected to fail to throw a certain exception.
+(define-syntax expect-fail-exception
+ (syntax-rules ()
+ ((_ name exception body rest ...)
+ (run-test-exception name exception #f (lambda () body rest ...)))))
\f
;;;; TEST NAMES
(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
-;;;; Helping test cases find their files
-
-;;; Returns FILENAME, relative to the directory the test suite data
-;;; files were installed in, and makes sure the file exists.
-(define (data-file filename)
- (let ((f (in-vicinity datadir filename)))
- (or (file-exists? f)
- (error "Test suite data file does not exist: " f))
- f))
-
-\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)))
HCoop / bpt / guile.git / blobdiff