diff options
author | cvs2svn <admin@example.com> | 1999-09-01 02:52:28 +0000 |
---|---|---|
committer | cvs2svn <admin@example.com> | 1999-09-01 02:52:28 +0000 |
commit | bc3038d6c85aeb23ca35e5758234573c86aed80d (patch) | |
tree | 9537cf49965939b1203e075f8c64aa953d10c486 /test-suite/lib.scm | |
parent | be881b4688376f98b5eaa5c0bfb2cded1cde06b6 (diff) | |
download | guile-jimb_mb_branchpoint_1.tar.gz |
This commit was manufactured by cvs2svn to create tagjimb_mb_branchpoint_1
'jimb_mb_branchpoint_1'.
Diffstat (limited to 'test-suite/lib.scm')
-rw-r--r-- | test-suite/lib.scm | 419 |
1 files changed, 0 insertions, 419 deletions
diff --git a/test-suite/lib.scm b/test-suite/lib.scm deleted file mode 100644 index bcf6bd400..000000000 --- a/test-suite/lib.scm +++ /dev/null @@ -1,419 +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) - - -;;;; 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)) |