/[guile]/guile/guile-core/test-suite/lib.scm
ViewVC logotype

Diff of /guile/guile-core/test-suite/lib.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.9 by dirk, Mon May 8 17:42:03 2000 UTC revision 1.9.4.1 by ttn, Sat Feb 9 23:10:56 2002 UTC
# Line 1  Line 1 
1  ;;;; test-suite/lib.scm --- generic support for testing  ;;;; test-suite/lib.scm --- generic support for testing
2  ;;;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.  ;;;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc.
3  ;;;;  ;;;;
4  ;;;; This program is free software; you can redistribute it and/or modify  ;;;; This program is free software; you can redistribute it and/or modify
5  ;;;; it under the terms of the GNU General Public License as published by  ;;;; it under the terms of the GNU General Public License as published by
6  ;;;; the Free Software Foundation; either version 2, or (at your option)  ;;;; the Free Software Foundation; either version 2, or (at your option)
7  ;;;; any later version.  ;;;; any later version.
8  ;;;;  ;;;;
9  ;;;; This program is distributed in the hope that it will be useful,  ;;;; This program is distributed in the hope that it will be useful,
10  ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of  ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11  ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the  ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12  ;;;; GNU General Public License for more details.  ;;;; GNU General Public License for more details.
13  ;;;;  ;;;;
14  ;;;; You should have received a copy of the GNU General Public License  ;;;; You should have received a copy of the GNU General Public License
15  ;;;; along with this software; see the file COPYING.  If not, write to  ;;;; along with this software; see the file COPYING.  If not, write to
16  ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,  ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
17  ;;;; Boston, MA 02111-1307 USA  ;;;; Boston, MA 02111-1307 USA
18    
19  (define-module (test-suite lib)  (define-module (test-suite lib)
20    #:use-module (test-suite paths))    ;;:use-module (ice-9 stack-catch)
21      :use-module (ice-9 regex))
22    
23  (export  (export
24    
25     ;; Exceptions which are commonly being tested for.
26     exception:out-of-range exception:unbound-var
27     exception:wrong-num-args exception:wrong-type-arg
28    
29   ;; Reporting passes and failures.   ;; Reporting passes and failures.
30   run-test pass-if expect-fail   run-test
31     pass-if expect-fail
32     pass-if-exception expect-fail-exception
33    
34   ;; Naming groups of tests in a regular fashion.   ;; Naming groups of tests in a regular fashion.
35   with-test-prefix with-test-prefix* current-test-prefix   with-test-prefix with-test-prefix* current-test-prefix
# Line 30  Line 37 
37   ;; Reporting results in various ways.   ;; Reporting results in various ways.
38   register-reporter unregister-reporter reporter-registered?   register-reporter unregister-reporter reporter-registered?
39   make-count-reporter print-counts   make-count-reporter print-counts
40   make-log-reporter   make-log-reporter
41   full-reporter   full-reporter
42   user-reporter   user-reporter
43   format-test-name   format-test-name
44    
45   ;; Finding test input files.   ;; The more modern way to check exceptions is to use `run-test-exception',
46   data-file   ;; but that uses (ice-9 stack-catch), which is not available yet, so we use
47     ;; these two.  We also prevent `run-test-exception' definition below.
  ;; Noticing whether an error occurs.  
48   signals-error? signals-error?*)   signals-error? signals-error?*)
49    
   
50  ;;;; If you're using Emacs's Scheme mode:  ;;;; If you're using Emacs's Scheme mode:
51  ;;;;   (put 'with-test-prefix 'scheme-indent-function 1)  ;;;;   (put 'with-test-prefix 'scheme-indent-function 1)
52    
# Line 71  Line 76 
76  ;;;; environment.  All other exceptions thrown by THUNK are considered as  ;;;; environment.  All other exceptions thrown by THUNK are considered as
77  ;;;; errors.  ;;;; errors.
78  ;;;;  ;;;;
79  ;;;; For convenience, the following macros are provided:  ;;;;
80  ;;;; * (pass-if name body) is a short form for  ;;;; Convenience macros for tests expected to pass or fail
81    ;;;;
82    ;;;; * (pass-if name body) is a short form for
83  ;;;;   (run-test name #t (lambda () body))  ;;;;   (run-test name #t (lambda () body))
84  ;;;; * (expect-fail name body) is a short form for  ;;;; * (expect-fail name body) is a short form for
85  ;;;;   (run-test name #f (lambda () body))  ;;;;   (run-test name #f (lambda () body))
86  ;;;;  ;;;;
87  ;;;; For example:    ;;;; For example:
88  ;;;;  ;;;;
89  ;;;;    (pass-if "integer addition" (= 2 (+ 1 1)))  ;;;;    (pass-if "integer addition" (= 2 (+ 1 1)))
90    ;;;;
91    ;;;;
92    ;;;; Convenience macros to test for exceptions
93    ;;;;
94    ;;;; The following macros take exception parameters which are pairs
95    ;;;; (type . message), where type is a symbol that denotes an exception type
96    ;;;; like 'wrong-type-arg or 'out-of-range, and message is a string holding a
97    ;;;; regular expression that describes the error message for the exception
98    ;;;; like "Argument .* out of range".
99    ;;;;
100    ;;;; * (pass-if-exception name exception body) will pass if the execution of
101    ;;;;   body causes the given exception to be thrown.  If no exception is
102    ;;;;   thrown, the test fails.  If some other exception is thrown, is is an
103    ;;;;   error.
104    ;;;; * (expect-fail-exception name exception body) will pass unexpectedly if
105    ;;;;   the execution of body causes the given exception to be thrown.  If no
106    ;;;;   exception is thrown, the test fails expectedly.  If some other
107    ;;;;   exception is thrown, it is an error.
108    
109    
110  ;;;; TEST NAMES  ;;;; TEST NAMES
# Line 98  Line 122 
122  ;;;; - Test names can be compared with EQUAL?.  ;;;; - Test names can be compared with EQUAL?.
123  ;;;; - Test names can be reliably stored and retrieved with the standard WRITE  ;;;; - Test names can be reliably stored and retrieved with the standard WRITE
124  ;;;;   and READ procedures; doing so preserves their identity.  ;;;;   and READ procedures; doing so preserves their identity.
125  ;;;;  ;;;;
126  ;;;; For example:  ;;;; For example:
127  ;;;;  ;;;;
128  ;;;;    (pass-if "simple addition" (= 4 (+ 2 2)))  ;;;;    (pass-if "simple addition" (= 4 (+ 2 2)))
129  ;;;;  ;;;;
130  ;;;; In that case, the test name is the list ("simple addition").  ;;;; In that case, the test name is the list ("simple addition").
131  ;;;;  ;;;;
132  ;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish  ;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish
133  ;;;; a prefix for the names of all tests whose results are reported  ;;;; a prefix for the names of all tests whose results are reported
134  ;;;; within their dynamic scope.  For example:  ;;;; within their dynamic scope.  For example:
135  ;;;;  ;;;;
136  ;;;; (begin  ;;;; (begin
137  ;;;;   (with-test-prefix "basic arithmetic"  ;;;;   (with-test-prefix "basic arithmetic"
138  ;;;;     (pass-if "addition" (= (+ 2 2) 4))  ;;;;     (pass-if "addition" (= (+ 2 2) 4))
139  ;;;;     (pass-if "subtraction" (= (- 4 2) 2)))  ;;;;     (pass-if "subtraction" (= (- 4 2) 2)))
140  ;;;;   (pass-if "multiplication" (= (* 2 2) 4)))  ;;;;   (pass-if "multiplication" (= (* 2 2) 4)))
141  ;;;;  ;;;;
142  ;;;; In that example, the three test names are:  ;;;; In that example, the three test names are:
143  ;;;;   ("basic arithmetic" "addition"),  ;;;;   ("basic arithmetic" "addition"),
144  ;;;;   ("basic arithmetic" "subtraction"), and  ;;;;   ("basic arithmetic" "subtraction"), and
# Line 122  Line 146 
146  ;;;;  ;;;;
147  ;;;; WITH-TEST-PREFIX can be nested.  Each WITH-TEST-PREFIX postpends  ;;;; WITH-TEST-PREFIX can be nested.  Each WITH-TEST-PREFIX postpends
148  ;;;; a new element to the current prefix:  ;;;; a new element to the current prefix:
149  ;;;;  ;;;;
150  ;;;; (with-test-prefix "arithmetic"  ;;;; (with-test-prefix "arithmetic"
151  ;;;;   (with-test-prefix "addition"  ;;;;   (with-test-prefix "addition"
152  ;;;;     (pass-if "integer" (= (+ 2 2) 4))  ;;;;     (pass-if "integer" (= (+ 2 2) 4))
# Line 130  Line 154 
154  ;;;;   (with-test-prefix "subtraction"  ;;;;   (with-test-prefix "subtraction"
155  ;;;;     (pass-if "integer" (= (- 2 2) 0))  ;;;;     (pass-if "integer" (= (- 2 2) 0))
156  ;;;;     (pass-if "complex" (= (- 2+3i 1+2i) 1+1i))))  ;;;;     (pass-if "complex" (= (- 2+3i 1+2i) 1+1i))))
157  ;;;;  ;;;;
158  ;;;; The four test names here are:  ;;;; The four test names here are:
159  ;;;;   ("arithmetic" "addition" "integer")  ;;;;   ("arithmetic" "addition" "integer")
160  ;;;;   ("arithmetic" "addition" "complex")  ;;;;   ("arithmetic" "addition" "complex")
# Line 140  Line 164 
164  ;;;; To print a name for a human reader, we DISPLAY its elements,  ;;;; To print a name for a human reader, we DISPLAY its elements,
165  ;;;; separated by ": ".  So, the last set of test names would be  ;;;; separated by ": ".  So, the last set of test names would be
166  ;;;; reported as:  ;;;; reported as:
167  ;;;;  ;;;;
168  ;;;;   arithmetic: addition: integer  ;;;;   arithmetic: addition: integer
169  ;;;;   arithmetic: addition: complex  ;;;;   arithmetic: addition: complex
170  ;;;;   arithmetic: subtraction: integer  ;;;;   arithmetic: subtraction: integer
# Line 153  Line 177 
177    
178    
179  ;;;; REPORTERS  ;;;; REPORTERS
180  ;;;;  ;;;;
181  ;;;; A reporter is a function which we apply to each test outcome.  ;;;; A reporter is a function which we apply to each test outcome.
182  ;;;; Reporters can log results, print interesting results to the  ;;;; Reporters can log results, print interesting results to the
183  ;;;; standard output, collect statistics, etc.  ;;;; standard output, collect statistics, etc.
184  ;;;;  ;;;;
185  ;;;; A reporter function takes two mandatory arguments, RESULT and TEST, and  ;;;; A reporter function takes two mandatory arguments, RESULT and TEST, and
186  ;;;; possibly additional arguments depending on RESULT; its return value  ;;;; possibly additional arguments depending on RESULT; its return value
187  ;;;; is ignored.  RESULT has one of the following forms:  ;;;; is ignored.  RESULT has one of the following forms:
188  ;;;;  ;;;;
189  ;;;; pass         - The test named TEST passed.    ;;;; pass         - The test named TEST passed.
190  ;;;;                Additional arguments are ignored.  ;;;;                Additional arguments are ignored.
191  ;;;; upass        - The test named TEST passed unexpectedly.  ;;;; upass        - The test named TEST passed unexpectedly.
192  ;;;;                Additional arguments are ignored.  ;;;;                Additional arguments are ignored.
# Line 175  Line 199 
199  ;;;;                tested because something else went wrong.  ;;;;                tested because something else went wrong.
200  ;;;;                Additional arguments are ignored.  ;;;;                Additional arguments are ignored.
201  ;;;; untested     - The test named TEST was not actually performed, for  ;;;; untested     - The test named TEST was not actually performed, for
202  ;;;;                example because the test case is not complete yet.  ;;;;                example because the test case is not complete yet.
203  ;;;;                Additional arguments are ignored.  ;;;;                Additional arguments are ignored.
204  ;;;; unsupported  - The test named TEST requires some feature that is not  ;;;; unsupported  - The test named TEST requires some feature that is not
205  ;;;;                available in the configured testing environment.  ;;;;                available in the configured testing environment.
# Line 198  Line 222 
222  ;;;; MISCELLANEOUS  ;;;; MISCELLANEOUS
223  ;;;;  ;;;;
224    
225    ;;; Define some exceptions which are commonly being tested for.
226    (define exception:out-of-range
227      (cons 'out-of-range "^Argument .*out of range"))
228    (define exception:unbound-var
229      (cons 'unbound-variable "^Unbound variable"))
230    (define exception:wrong-num-args
231      (cons 'wrong-number-of-args "^Wrong number of arguments"))
232    (define exception:wrong-type-arg
233      (cons 'wrong-type-arg "^Wrong type argument"))
234    
235  ;;; Display all parameters to the default output port, followed by a newline.  ;;; Display all parameters to the default output port, followed by a newline.
236  (define (display-line . objs)  (define (display-line . objs)
237    (for-each display objs)    (for-each display objs)
# Line 229  Line 263 
263                  (throw 'unresolved)))                  (throw 'unresolved)))
264              (lambda (key . args)              (lambda (key . args)
265                (case key                (case key
266                  ((pass)                  ((pass)
267                   (report (if expect-pass 'pass 'upass) test-name))                   (report (if expect-pass 'pass 'upass) test-name))
268                  ((fail)                  ((fail)
269                   (report (if expect-pass 'fail 'xfail) test-name))                   (report (if expect-pass 'fail 'xfail) test-name))
270                  ((unresolved untested unsupported)                  ((unresolved untested unsupported)
271                   (report key test-name))                   (report key test-name))
272                  ((quit)                  ((quit)
273                   (report 'unresolved test-name)                   (report 'unresolved test-name)
274                   (quit))                   (quit))
275                  (else                  (else
276                   (report 'error test-name (cons key args))))))                   (report 'error test-name (cons key args))))))
277            (set! test-running #f))))            (set! test-running #f))))
278    (set! run-test local-run-test))    (set! run-test local-run-test))
279    
280  ;;; A short form for tests that are expected to pass, taken from Greg.  ;;; A short form for tests that are expected to pass, taken from Greg.
281  (defmacro pass-if (name body)  (defmacro pass-if (name body . rest)
282    `(run-test ,name #t (lambda () (not (not (begin ,body))))))    `(run-test ,name #t (lambda () ,body ,@rest)))
283    
284  ;;; A short form for tests that are expected to fail, taken from Greg.  ;;; A short form for tests that are expected to fail, taken from Greg.
285  (defmacro expect-fail (name body)  (defmacro expect-fail (name body . rest)
286    `(run-test ,name #f (lambda () ,body)))    `(run-test ,name #f (lambda () ,body ,@rest)))
287    
288    ;;; A helper function to implement the macros that test for exceptions.
289    '(define (run-test-exception name exception expect-pass thunk)
290      (run-test name expect-pass
291        (lambda ()
292          (stack-catch (car exception)
293            (lambda () (thunk) #f)
294            (lambda (key proc message . rest)
295              (cond
296               ;; handle explicit key
297               ((string-match (cdr exception) message)
298                #t)
299               ;; handle `(error ...)' which uses `misc-error' for key and doesn't
300               ;; yet format the message and args (we have to do it here).
301               ((and (eq? 'misc-error (car exception))
302                     (list? rest)
303                     (string-match (cdr exception)
304                                   (apply simple-format #f message (car rest))))
305                #t)
306               ;; unhandled; throw again
307               (else
308                (apply throw key proc message rest))))))))
309    
310    ;;; A short form for tests that expect a certain exception to be thrown.
311    (defmacro pass-if-exception (name exception body . rest)
312      `(,run-test-exception ,name ,exception #t (lambda () ,body ,@rest)))
313    
314    ;;; A short form for tests expected to fail to throw a certain exception.
315    (defmacro expect-fail-exception (name exception body . rest)
316      `(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest)))
317    
318    
319  ;;;; TEST NAMES  ;;;; TEST NAMES
# Line 295  Line 359 
359    
360    
361  ;;;; REPORTERS  ;;;; REPORTERS
362  ;;;;  ;;;;
363    
364  ;;; The global list of reporters.  ;;; The global list of reporters.
365  (define reporters '())  (define reporters '())
# Line 336  Line 400 
400  ;;;; User reporters write interesting test results to the standard output.  ;;;; User reporters write interesting test results to the standard output.
401    
402  ;;; The complete list of possible test results.  ;;; The complete list of possible test results.
403  (define result-tags  (define result-tags
404    '((pass        "PASS"        "passes:                 ")    '((pass        "PASS"        "passes:                 ")
405      (fail        "FAIL"        "failures:               ")      (fail        "FAIL"        "failures:               ")
406      (upass       "UPASS"       "unexpected passes:      ")      (upass       "UPASS"       "unexpected passes:      ")
# Line 347  Line 411 
411      (error       "ERROR"       "errors:                 ")))      (error       "ERROR"       "errors:                 ")))
412    
413  ;;; The list of important test results.  ;;; The list of important test results.
414  (define important-result-tags  (define important-result-tags
415    '(fail upass unresolved error))    '(fail upass unresolved error))
416    
417  ;;; Display a single test result in formatted form to the given port  ;;; Display a single test result in formatted form to the given port
# Line 377  Line 441 
441      (list      (list
442       (lambda (result name . args)       (lambda (result name . args)
443         (let ((pair (assq result counts)))         (let ((pair (assq result counts)))
444           (if pair           (if pair
445               (set-cdr! pair (+ 1 (cdr pair)))               (set-cdr! pair (+ 1 (cdr pair)))
446               (error "count-reporter: unexpected test result: "               (error "count-reporter: unexpected test result: "
447                      (cons result (cons name args))))))                      (cons result (cons name args))))))
448       (lambda ()       (lambda ()
449         (append counts '())))))         (append counts '())))))
# Line 387  Line 451 
451  ;;; Print a count reporter's results nicely.  Pass this function the value  ;;; Print a count reporter's results nicely.  Pass this function the value
452  ;;; returned by a count reporter's RESULTS procedure.  ;;; returned by a count reporter's RESULTS procedure.
453  (define (print-counts results . port?)  (define (print-counts results . port?)
454    (let ((port (if (pair? port?)    (let ((port (if (pair? port?)
455                    (car port?)                    (car port?)
456                    (current-output-port))))                    (current-output-port))))
457      (newline port)      (newline port)
# Line 425  Line 489 
489  (set! default-reporter full-reporter)  (set! default-reporter full-reporter)
490    
491    
 ;;;; 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))  
   
   
492  ;;;; Detecting whether errors occur  ;;;; Detecting whether errors occur
493    
494  ;;; (signals-error? KEY BODY ...)  ;;; (signals-error? KEY BODY ...)

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.9.4.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26