0.6.8.9:
[sbcl.git] / tests / assertoid.lisp
1 ;;;; the ASSERTOID macro, asserting something with added generality
2 ;;;; to help in regression tests
3
4 (cl:in-package :cl-user)
5
6 ;;; EXPR is an expression to evaluate (both with EVAL and with
7 ;;; COMPILE/FUNCALL). EXTRA-OPTIMIZATIONS is a list of lists of
8 ;;; optimizations to pass to (DECLARE (OPTIMIZE ..)), to cause the
9 ;;; expression to be tested in other than the default optimization
10 ;;; level(s).
11 ;;;
12 ;;; The messiness with the various flavors of EXPECTED stuff is 
13 ;;; to handle various issues:
14 ;;;   * Some things are expected to signal errors instead of returning
15 ;;;     ordinary values.
16 ;;;   * Some things are expected to return multiple values.
17 ;;;   * Some things can return any of several values (e.g. generalized
18 ;;;     booleans).
19 ;;; The default is to expect a generalized boolean true.
20 ;;;
21 ;;; Use EXPECTED-LAMBDA to require an answer which satisfies the given
22 ;;; LAMBDA. EXPECTED-EQL, EXPECTED-EQUAL, and EXPECTED-EQUALP are
23 ;;; shorthand for special cases of EXPECTED-LAMBDA.
24 ;;;
25 ;;; Use EXPECTED-ERROR to require an error to be thrown. Use
26 ;;; EXPECTED-ERROR-LAMBDA to require that an error be thrown and
27 ;;; that further it satisfies the given lambda.
28 (defmacro assertoid (expr
29                      &key
30                      extra-optimizations
31                      (expected-eql nil expected-eql-p)
32                      (expected-equal nil expected-equal-p)
33                      (expected-equalp nil expected-equalp-p)
34                      (expected-lambda (cond
35                                        (expected-eql-p
36                                         (lambda (x)
37                                           (eql x (eval expected-eql))))
38                                        (expected-equal-p
39                                         (lambda (x)
40                                           (equal x (eval expected-equal))))
41                                        (expected-equalp-p
42                                         (lambda (x)
43                                           (equalp x (eval expected-equalp))))
44                                        (t
45                                         (lambda (x)
46                                           x)))
47                                       expected-lambda-p)
48                      (expected-error-type nil expected-error-type-p)
49                      (expected-error-lambda (if expected-error-type
50                                                 (lambda (condition)
51                                                   (typep condition
52                                                          expected-error-type))
53                                                 nil)
54                                             expected-error-lambda-p))
55   (when (> (count-if #'identity
56                      (vector expected-eql-p
57                              expected-equal-p
58                              expected-equalp-p
59                              expected-lambda-p
60                              expected-error-type-p
61                              expected-error-lambda-p))
62            1)
63     (error "multiple EXPECTED-FOO arguments"))
64   (when expected-error-lambda
65     (error "stub: expected-error functionality not supported yet"))
66   (let ((eval-expected-lambda (eval expected-lambda)))
67     (flet ((frob (evaloid)
68                  (let ((result (funcall evaloid expr)))
69                    (unless (funcall eval-expected-lambda result)
70                      (error "failed assertoid" expr))))
71            (compile-as-evaloid (optimizations)
72              (lambda (expr)
73                (funcall (compile nil
74                                  `(lambda ()
75                                     (declare (optimize ,@optimizations))
76                                     ,expr))))))
77       (frob #'eval)
78       (frob (compile-as-evaloid ()))
79       (dolist (i extra-optimizations)
80         (frob (compile-as-evaloid i))))))
81
82 ;;; examples
83 (assertoid (= 2 (length (list 1 2))))
84 (assertoid (= 2 (length (list 1 2)))
85            :extra-optimizations (((speed 2) (space 3))
86                                  ((speed 1) (space 3))))
87 (assertoid (cons 1 2)
88            :expected-lambda (lambda (x) (equal x '(1 . 2))))
89 (assertoid (cons (list 1 2) (list 1 2))
90            :expected-equal '((1 2) 1 2))
91 ;;; not implemented yet:
92 #+nil (assertoid (length (eval (find-package :cl)))
93                  :expected-error-type 'type-error)