0.7.7.38:
[sbcl.git] / tests / assertoid.lisp
1 ;;;; the ASSERTOID macro, asserting something with added generality
2 ;;;; to help in regression tests
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
7 ;;;; While most of SBCL is derived from the CMU CL system, the test
8 ;;;; files (like this one) were written from scratch after the fork
9 ;;;; from CMU CL.
10 ;;;; 
11 ;;;; This software is in the public domain and is provided with
12 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
13 ;;;; more information.
14
15 (cl:in-package :cl-user)
16
17 (defmacro grab-condition (&body body)
18   `(nth-value 1
19      (ignore-errors ,@body)))
20
21 (defmacro raises-error? (form &optional (error-subtype-spec 'error))
22   `(typep (nth-value 1 (ignore-errors ,form)) ',error-subtype-spec))
23
24 ;;; EXPR is an expression to evaluate (both with EVAL and with
25 ;;; COMPILE/FUNCALL). EXTRA-OPTIMIZATIONS is a list of lists of
26 ;;; optimizations to pass to (DECLARE (OPTIMIZE ..)), to cause the
27 ;;; expression to be tested in other than the default optimization
28 ;;; level(s).
29 ;;;
30 ;;; The messiness with the various flavors of EXPECTED stuff is 
31 ;;; to handle various issues:
32 ;;;   * Some things are expected to signal errors instead of returning
33 ;;;     ordinary values.
34 ;;;   * Some things are expected to return multiple values.
35 ;;;   * Some things can return any of several values (e.g. generalized
36 ;;;     booleans).
37 ;;; The default is to expect a generalized boolean true.
38 ;;;
39 ;;; Use EXPECTED-LAMBDA to require an answer which satisfies the given
40 ;;; LAMBDA. EXPECTED-EQL, EXPECTED-EQUAL, and EXPECTED-EQUALP are
41 ;;; shorthand for special cases of EXPECTED-LAMBDA.
42 ;;;
43 ;;; Use EXPECTED-ERROR to require an error to be signalled. Use
44 ;;; EXPECTED-ERROR-LAMBDA to require that an error be signalled and
45 ;;; that further it satisfies the given lambda.
46 (defmacro assertoid (expr
47                      &key
48                      extra-optimizations
49                      (expected-eql nil expected-eql-p)
50                      (expected-equal nil expected-equal-p)
51                      (expected-equalp nil expected-equalp-p)
52                      (expected-lambda (cond
53                                        (expected-eql-p
54                                         (lambda (x)
55                                           (eql x (eval expected-eql))))
56                                        (expected-equal-p
57                                         (lambda (x)
58                                           (equal x (eval expected-equal))))
59                                        (expected-equalp-p
60                                         (lambda (x)
61                                           (equalp x (eval expected-equalp))))
62                                        (t
63                                         (lambda (x)
64                                           x)))
65                                       expected-lambda-p)
66                      (expected-error-type nil expected-error-type-p)
67                      (expected-error-lambda (if expected-error-type
68                                                 (lambda (condition)
69                                                   (typep condition
70                                                          expected-error-type))
71                                                 nil)
72                                             expected-error-lambda-p))
73   (when (> (count-if #'identity
74                      (vector expected-eql-p
75                              expected-equal-p
76                              expected-equalp-p
77                              expected-lambda-p
78                              expected-error-type-p
79                              expected-error-lambda-p))
80            1)
81     (error "multiple EXPECTED-FOO arguments"))
82   (when expected-error-lambda
83     (error "stub: expected-error functionality not supported yet"))
84   (let ((eval-expected-lambda (eval expected-lambda)))
85     (flet ((frob (evaloid)
86                  (let ((result (funcall evaloid expr)))
87                    (unless (funcall eval-expected-lambda result)
88                      (error "failed assertoid" expr))))
89            (compile-as-evaloid (optimizations)
90              (lambda (expr)
91                (funcall (compile nil
92                                  `(lambda ()
93                                     (declare (optimize ,@optimizations))
94                                     ,expr))))))
95       (frob #'eval)
96       (frob (compile-as-evaloid ()))
97       (dolist (i extra-optimizations)
98         (frob (compile-as-evaloid i))))))
99
100 ;;; examples
101 (assertoid (= 2 (length (list 1 2))))
102 (assertoid (= 2 (length (list 1 2)))
103            :extra-optimizations (((speed 2) (space 3))
104                                  ((speed 1) (space 3))))
105 (assertoid (cons 1 2)
106            :expected-lambda (lambda (x) (equal x '(1 . 2))))
107 (assertoid (cons (list 1 2) (list 1 2))
108            :expected-equal '((1 2) 1 2))
109 ;;; not implemented yet:
110 #+nil (assertoid (length (eval (find-package :cl)))
111                  :expected-error-type 'type-error)