summaryrefslogtreecommitdiff
path: root/test-suite/lib.scm
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/lib.scm')
-rw-r--r--test-suite/lib.scm450
1 files changed, 0 insertions, 450 deletions
diff --git a/test-suite/lib.scm b/test-suite/lib.scm
deleted file mode 100644
index aab9fa62b..000000000
--- a/test-suite/lib.scm
+++ /dev/null
@@ -1,450 +0,0 @@
-;;;; test-suite/lib.scm --- generic support for testing
-;;;; Copyright (C) 1999 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
-
-(define-module (test-suite lib)
- #:use-module (test-suite paths))
-
-(export
-
- ;; Reporting passes and failures.
- pass fail pass-if
-
- ;; Indicating tests that are expected to fail.
- expect-failure expect-failure-if expect-failure-if*
-
- ;; Marking independent groups of tests.
- catch-test-errors catch-test-errors*
-
- ;; Naming groups of tests in a regular fashion.
- with-test-prefix with-test-prefix* current-test-prefix
-
- ;; Reporting results in various ways.
- register-reporter unregister-reporter reporter-registered?
- make-count-reporter print-counts
- 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?*)
-
-
-;;;; If you're using Emacs's Scheme mode:
-;;;; (put 'expect-failure 'scheme-indent-function 0)
-;;;; (put 'with-test-prefix 'scheme-indent-function 1)
-
-
-;;;; TEST NAMES
-;;;;
-;;;; Every test in the test suite has a unique name, to help
-;;;; developers find tests that are failing (or unexpectedly passing),
-;;;; and to help gather statistics.
-;;;;
-;;;; A test name is a list of printable objects. For example:
-;;;; ("ports.scm" "file" "read and write back list of strings")
-;;;; ("ports.scm" "pipe" "read")
-;;;;
-;;;; Test names may contain arbitrary objects, but they always have
-;;;; the following properties:
-;;;; - 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.
-;;;;
-;;;; The functions for reporting results (PASS, FAIL, PASS-IF, ...)
-;;;; take the name of the passing/failing test as an argument.
-;;;; For example:
-;;;;
-;;;; (if (= 4 (+ 2 2))
-;;;; (pass "simple addition"))
-;;;;
-;;;; In that case, the test name is the list ("simple addition").
-;;;;
-;;;; 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 "division" (= (- 4 2) 2)))
-;;;; (pass-if "multiplication" (= (* 2 2) 4)))
-;;;;
-;;;; In that example, the three test names are:
-;;;; ("basic arithmetic" "addition"),
-;;;; ("basic arithmetic" "division"), and
-;;;; ("multiplication").
-;;;;
-;;;; 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))
-;;;; (pass-if "complex" (= (+ 2+3i 4+5i) 6+8i)))
-;;;; (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")
-;;;; ("arithmetic" "subtraction" "integer")
-;;;; ("arithmetic" "subtraction" "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
-;;;; arithmetic: subtraction: complex
-;;;;
-;;;; The Guile benchmarks use with-test-prefix to include the name of
-;;;; the source file containing the test in the test name, to help
-;;;; developers to find failing tests, and to provide each file with its
-;;;; own namespace.
-
-
-;;;; 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 one argument, RESULT; its return value
-;;;; is ignored. RESULT has one of the following forms:
-;;;;
-;;;; (pass TEST) - The test named TEST passed.
-;;;; (fail TEST) - The test named TEST failed.
-;;;; (xpass TEST) - The test named TEST passed unexpectedly.
-;;;; (xfail TEST) - The test named TEST failed, as expected.
-;;;; (error PREFIX) - An error occurred, with TEST as the current
-;;;; test name prefix. Some tests were
-;;;; probably not executed because of this.
-;;;;
-;;;; This library provides some standard reporters for logging results
-;;;; to a file, reporting interesting results to the user, and
-;;;; collecting totals.
-;;;;
-;;;; You can use the REGISTER-REPORTER function and friends to add
-;;;; whatever reporting functions you like. If you don't register any
-;;;; reporters, the library uses FULL-REPORTER, which simply writes
-;;;; all results to the standard output.
-
-
-;;;; with-test-prefix: naming groups of tests
-;;;; See the discussion of TEST
-
-;;; A fluid containing the current test prefix, as a list.
-(define prefix-fluid (make-fluid))
-(fluid-set! prefix-fluid '())
-
-;;; Postpend PREFIX to the current name prefix while evaluting THUNK.
-;;; The name prefix is only changed within the dynamic scope of the
-;;; call to with-test-prefix*. Return the value returned by THUNK.
-(define (with-test-prefix* prefix thunk)
- (with-fluids ((prefix-fluid
- (append (fluid-ref prefix-fluid) (list prefix))))
- (thunk)))
-
-;;; (with-test-prefix PREFIX BODY ...)
-;;; Postpend PREFIX to the current name prefix while evaluating BODY ...
-;;; The name prefix is only changed within the dynamic scope of the
-;;; with-test-prefix expression. Return the value returned by the last
-;;; BODY expression.
-(defmacro with-test-prefix (prefix . body)
- `(with-test-prefix* ,prefix (lambda () ,@body)))
-
-(define (current-test-prefix)
- (fluid-ref prefix-fluid))
-
-
-;;;; register-reporter, etc. --- the global reporter list
-
-;;; The global list of reporters.
-(define reporters '())
-
-;;; The default reporter, to be used only if no others exist.
-(define default-reporter #f)
-
-;;; Add the procedure REPORTER to the current set of reporter functions.
-;;; Signal an error if that reporter procedure object is already registered.
-(define (register-reporter reporter)
- (if (memq reporter reporters)
- (error "register-reporter: reporter already registered: " reporter))
- (set! reporters (cons reporter reporters)))
-
-;;; Remove the procedure REPORTER from the current set of reporter
-;;; functions. Signal an error if REPORTER is not currently registered.
-(define (unregister-reporter reporter)
- (if (memq reporter reporters)
- (set! reporters (delq! reporter reporters))
- (error "unregister-reporter: reporter not registered: " reporter)))
-
-;;; Return true iff REPORTER is in the current set of reporter functions.
-(define (reporter-registered? reporter)
- (if (memq reporter reporters) #t #f))
-
-
-;;; Send RESULT to all currently registered reporter functions.
-(define (report result)
- (if (pair? reporters)
- (for-each (lambda (reporter) (reporter result))
- reporters)
- (default-reporter result)))
-
-
-;;;; Some useful reporter functions.
-
-;;; Return a list of the form (COUNTER RESULTS), where:
-;;; - COUNTER is a reporter procedure, and
-;;; - RESULTS is a procedure taking no arguments which returns the
-;;; results seen so far by COUNTER. The return value is an alist
-;;; mapping outcome symbols (`pass', `fail', etc.) onto counts.
-(define (make-count-reporter)
- (let ((counts (map (lambda (outcome) (cons outcome 0))
- '(pass fail xpass xfail error))))
- (list
- (lambda (result)
- (let ((pair (assq (car result) counts)))
- (if pair (set-cdr! pair (+ 1 (cdr pair)))
- (error "count-reporter: unexpected test result: " result))))
- (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
- (let ((tags '(pass fail xpass xfail error))
- (labels
- '("passes: "
- "failures: "
- "unexpected passes: "
- "expected failures: "
- "errors: ")))
- (lambda (results . port?)
- (let ((port (if (pair? port?)
- (car port?)
- (current-output-port))))
- (newline port)
- (display-line-port port "Totals for this test run:")
- (for-each
- (lambda (tag label)
- (let ((result (assq tag results)))
- (if result
- (display-line-port port label (cdr result))
- (display-line-port port
- "Test suite bug: "
- "no total available for `" tag "'"))))
- tags labels)
- (newline port)))))
-
-;;; Handy functions. Should be in a library somewhere.
-(define (display-line . objs)
- (for-each display objs)
- (newline))
-(define (display-line-port port . objs)
- (for-each (lambda (obj) (display obj port))
- objs)
- (newline port))
-
-;;; Turn a test name into a nice human-readable string.
-(define (format-test-name name)
- (call-with-output-string
- (lambda (port)
- (let loop ((name name))
- (if (pair? name)
- (begin
- (display (car name) port)
- (if (pair? (cdr name))
- (display ": " port))
- (loop (cdr name))))))))
-
-;;; Return a reporter procedure which prints all results to the file
-;;; FILE, in human-readable form. FILE may be a filename, or a port.
-(define (make-log-reporter file)
- (let ((port (if (output-port? file) file
- (open-output-file file))))
- (lambda (result)
- (display (car result) port)
- (display ": " port)
- (display (format-test-name (cadr result)) port)
- (newline port)
- (force-output port))))
-
-;;; A reporter that reports all results to the user.
-(define (full-reporter result)
- (let ((label (case (car result)
- ((pass) "pass")
- ((fail) "FAIL")
- ((xpass) "XPASS")
- ((xfail) "xfail")
- ((error) "ERROR")
- (else #f))))
- (if label
- (display-line label ": " (format-test-name (cadr result)))
- (error "(test-suite lib) FULL-REPORTER: unrecognized result: "
- result))))
-
-;;; A reporter procedure which shows interesting results (failures,
-;;; unexpected passes) to the user.
-(define (user-reporter result)
- (case (car result)
- ((fail xpass) (full-reporter result))))
-
-(set! default-reporter full-reporter)
-
-
-;;;; Marking independent groups of tests.
-
-;;; When test code encounters an error (like "file not found" or "()
-;;; is not a pair"), that may mean that that particular test can't
-;;; continue, or that some nearby tests shouldn't be run, but it
-;;; doesn't mean the whole test suite must be aborted.
-;;;
-;;; Wrap each group of interdependent tests in a CATCH-TEST-ERRORS
-;;; form, so that if an error occurs, that group will be aborted, but
-;;; control will continue after the catch-test-errors form.
-
-;;; Evaluate thunk, catching errors. If THUNK returns without
-;;; signalling any errors, return a list containing its value.
-;;; Otherwise, return #f.
-(define (catch-test-errors* thunk)
-
- (letrec ((handler
- (lambda (key . args)
- (display-line "ERROR in test "
- (format-test-name (current-test-prefix))
- ":")
- (apply display-error
- (make-stack #t handler)
- (current-error-port)
- args)
- (throw 'catch-test-errors))))
-
- ;; I don't know if we should really catch everything here. If you
- ;; find a case where an error is signalled which really should abort
- ;; the whole test case, feel free to adjust this appropriately.
- (catch 'catch-test-errors
- (lambda ()
- (lazy-catch #t
- (lambda () (list (thunk)))
- handler))
- (lambda args
- (report (list 'error (current-test-prefix)))
- #f))))
-
-;;; (catch-test-errors BODY ...)
-;;; Evaluate the expressions BODY ... If a BODY expression signals an
-;;; error, record that in the test results, and return #f. Otherwise,
-;;; return a list containing the value of the last BODY expression.
-(defmacro catch-test-errors body
- `(catch-test-errors* (lambda () ,@body)))
-
-
-;;;; Indicating tests that are expected to fail.
-
-;;; Fluid indicating whether we're currently expecting tests to fail.
-(define expected-failure-fluid (make-fluid))
-
-;;; Hmm. The documentation treats EXPECT-FAILURE-IF as the primitive,
-;;; but in the implementation, EXPECT-FAILURE-IF* is the primitive.
-
-;;; (expect-failure-if TEST BODY ...)
-;;; Evaluate the expression TEST, then evaluate BODY ...
-;;; If TEST evaluates to a true value, expect all tests whose results
-;;; are reported by the BODY expressions to fail.
-;;; Return the value of the last BODY form.
-(defmacro expect-failure-if (test . body)
- `(expect-failure-if* ,test (lambda () ,@body)))
-
-;;; Call THUNK; if SHOULD-FAIL is true, expect any tests whose results
-;;; are reported by THUNK to fail. Return the value returned by THUNK.
-(define (expect-failure-if* should-fail thunk)
- (with-fluids ((expected-failure-fluid (not (not should-fail))))
- (thunk)))
-
-;;; (expect-failure BODY ...)
-;;; Evaluate the expressions BODY ..., expecting all tests whose results
-;;; they report to fail.
-(defmacro expect-failure body
- `(expect-failure-if #t ,@body))
-
-(define (pessimist?)
- (fluid-ref expected-failure-fluid))
-
-
-;;;; Reporting passes and failures.
-
-(define (full-name name)
- (append (current-test-prefix) (list name)))
-
-(define (pass name)
- (report (list (if (pessimist?) 'xpass 'pass)
- (full-name name))))
-
-(define (fail name)
- (report (list (if (pessimist?) 'xfail 'fail)
- (full-name name))))
-
-(define (pass-if name condition)
- ((if condition pass fail) name))
-
-
-;;;; 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))
-
-
-;;;; 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)))
-
-