source: project/release/4/test/trunk/test.scm @ 31123

Last change on this file since 31123 was 31123, checked in by Alex Shinn, 6 years ago

Adding patch for test-total-count from Mario.

File size: 4.2 KB
Line 
1;;;; test.scm -- simple friendly test suite
2;;
3;; Copyright (c) 2007-2008 Alex Shinn. All rights reserved.
4;; BSD-style license: http://synthcode.com/license.txt
5
6(module test
7  (test test-error test-assert
8   test-group test-group-inc! current-test-group
9   test-begin test-end test-syntax-error test-info
10   test-vars test-run test-exit
11   current-test-verbosity current-test-epsilon current-test-comparator
12   current-test-applier current-test-handler current-test-skipper
13   current-test-group-reporter test-failure-count test-total-count)
14  (import scheme chicken)
15
16  (include "test-support.scm")
17
18;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
19;; test interface
20
21(define-syntax test
22  (syntax-rules ()
23    ((test expect expr)
24     (test #f expect expr))
25    ((test name expect (expr ...))
26     (test-info name expect (expr ...) ()))
27    ((test name (expect ...) expr)
28     (test-syntax-error
29      'test
30      "the test expression should come last "
31      (test name (expect ...) expr)))
32    ((test name expect expr)
33     (test-info name expect expr ()))
34    ((test a ...)
35     (test-syntax-error 'test "2 or 3 arguments required"
36                        (test a ...)))
37    ))
38
39(define-syntax test-assert
40  (syntax-rules ()
41    ((_ expr)
42    (test-assert #f expr))
43    ((_ name expr)
44     (test-info name #f expr ((assertion . #t))))
45    ((test a ...)
46     (test-syntax-error 'test-assert "1 or 2 arguments required"
47                        (test a ...)))
48    ))
49
50(define-syntax test-error
51  (syntax-rules ()
52    ((_ expr)
53     (test-error #f expr))
54    ((_ name expr)
55     (test-info name #f expr ((expect-error . #t))))
56    ((test a ...)
57     (test-syntax-error 'test-error "1 or 2 arguments required"
58                        (test a ...)))
59    ))
60
61;;    (define-syntax test-error*
62;;      (syntax-rules ()
63;;        ((_ ?msg (?error-type ...) ?expr)
64;;         (let-syntax ((expression:
65;;                       (syntax-rules ()
66;;                         ((_ ?expr)
67;;                          (condition-case (begin ?expr "<no error thrown>")
68;;                            ((?error-type ...) '(?error-type ...))
69;;                            (exn () (##sys#slot exn 1)))))))
70;;           (test ?msg '(?error-type ...) (expression: ?expr))))
71;;        ((_ ?msg ?error-type ?expr)
72;;         (test-error* ?msg (?error-type) ?expr))
73;;        ((_ ?error-type ?expr)
74;;         (test-error* (sprintf "~S" '?expr) ?error-type ?expr))))
75
76;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
77;; group interface
78
79(define-syntax test-group
80  (syntax-rules ()
81    ((_ name-expr body ...)
82     (let ((name name-expr)
83           (old-group (current-test-group)))
84       (if (not (string? name))
85           (syntax-error 'test-group "a name is required, got " 'name-expr name))
86       (test-begin name)
87       (condition-case (begin body ...)
88                       (e ()
89                          (warning "error in group outside of tests")
90                          (print-error-message e)
91                          (test-group-inc! (current-test-group) 'count)
92                          (test-group-inc! (current-test-group) 'ERROR)))
93       (test-end name)
94       (current-test-group old-group)))))
95
96;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
97;; utilities
98
99(define-syntax test-syntax-error
100  (syntax-rules ()
101    ((_) (syntax-error "invalid use of test-syntax-error"))))
102
103(define-syntax test-info
104  (syntax-rules ()
105    ((test-info name expect expr info)
106     (test-vars () name expect expr ((source . expr) . info)))))
107
108(define-syntax test-vars
109  (syntax-rules ()
110    ;; Consider trying to determine "interesting" variables as in
111    ;; Oleg's ASSERT macro (which unfortunately requires code walking
112    ;; to detect lambda's, a point Oleg ignores).  We could hack it by
113    ;; not walking into let/lambda's and/or wrapping the value binding
114    ;; in error handlers.
115    ((_ (vars ...) n expect expr ((key . val) ...))
116     (test-run (lambda () expect)
117               (lambda () expr)
118               (cons (cons 'name n)
119                     '((source . expr)
120                       ;;(var-names . (vars ...))
121                       ;;(var-values . ,(list vars))
122                       (key . val) ...)))))))
Note: See TracBrowser for help on using the repository browser.