source: project/release/4/test/test.scm @ 11778

Last change on this file since 11778 was 11778, checked in by sjamaan, 13 years ago

Fix small bug in 4th test clause

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