1 ;;;; the ASSERTOID macro, asserting something with added generality
2 ;;;; to help in regression tests
4 ;;;; This software is part of the SBCL system. See the README file for
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
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.
15 (cl:defpackage
"ASSERTOID"
17 (:export
"GRAB-CONDITION" "ASSERT-ERROR"
18 "HAS-ERROR?" "IS" "ASSERTOID"
19 "ASSERT-SIGNAL" "ASSERT-NO-SIGNAL"
22 (cl:in-package
"ASSERTOID")
24 (defmacro grab-condition
(&body body
)
26 (ignore-errors ,@body
)))
28 (defmacro has-error?
(form &optional
(error-subtype-spec 'error
))
29 `(typep (nth-value 1 (ignore-errors ,form
)) ',error-subtype-spec
))
31 (defmacro assert-error
(form &optional
(error-subtype-spec 'error
))
32 `(assert (typep (nth-value 1 (ignore-errors ,form
)) ',error-subtype-spec
)))
34 (defun %assert-signal
(thunk condition-type
35 expected-min-count expected-max-count
)
36 (declare (ignore condition-type
))
39 (funcall thunk
(lambda (condition)
41 (when (typep condition
'warning
)
42 (muffle-warning condition
))))
43 (assert (<= expected-min-count count expected-max-count
)))))
45 (defmacro assert-signal
(form &optional
46 (condition-type 'condition
)
47 (expected-min-count 1)
48 (expected-max-count expected-min-count
))
49 (let ((handle (gensym)))
52 (handler-bind ((,condition-type
,handle
)) ,form
))
53 ',condition-type
,expected-min-count
,expected-max-count
)))
55 (defun %assert-no-signal
(thunk condition-type
)
56 (declare (ignore condition-type
))
57 (let ((signaled-condition))
59 (funcall thunk
(lambda (condition)
60 (setf signaled-condition condition
)
61 (when (typep condition
'warning
)
62 (muffle-warning condition
))))
63 (assert (not signaled-condition
)))))
65 (defmacro assert-no-signal
(form &optional
(condition-type 'condition
))
66 (let ((handle (gensym)))
69 (handler-bind ((,condition-type
,handle
)) ,form
))
72 ;;; EXPR is an expression to evaluate (both with EVAL and with
73 ;;; COMPILE/FUNCALL). EXTRA-OPTIMIZATIONS is a list of lists of
74 ;;; optimizations to pass to (DECLARE (OPTIMIZE ..)), to cause the
75 ;;; expression to be tested in other than the default optimization
78 ;;; The messiness with the various flavors of EXPECTED stuff is
79 ;;; to handle various issues:
80 ;;; * Some things are expected to signal errors instead of returning
82 ;;; * Some things are expected to return multiple values.
83 ;;; * Some things can return any of several values (e.g. generalized
85 ;;; The default is to expect a generalized boolean true.
87 ;;; Use EXPECTED-LAMBDA to require an answer which satisfies the given
88 ;;; LAMBDA. EXPECTED-EQL, EXPECTED-EQUAL, and EXPECTED-EQUALP are
89 ;;; shorthand for special cases of EXPECTED-LAMBDA.
91 ;;; Use EXPECTED-ERROR to require an error to be signalled. Use
92 ;;; EXPECTED-ERROR-LAMBDA to require that an error be signalled and
93 ;;; that further it satisfies the given lambda.
94 (defmacro assertoid
(expr
97 (expected-eql nil expected-eql-p
)
98 (expected-equal nil expected-equal-p
)
99 (expected-equalp nil expected-equalp-p
)
100 (expected-lambda (cond
103 (eql x
(eval expected-eql
))))
106 (equal x
(eval expected-equal
))))
109 (equalp x
(eval expected-equalp
))))
114 (expected-error-type nil expected-error-type-p
)
115 (expected-error-lambda (if expected-error-type
118 expected-error-type
))
120 expected-error-lambda-p
))
121 (when (> (count-if #'identity
122 (vector expected-eql-p
126 expected-error-type-p
127 expected-error-lambda-p
))
129 (error "multiple EXPECTED-FOO arguments"))
130 (when expected-error-lambda
131 (error "stub: expected-error functionality not supported yet"))
132 (let ((eval-expected-lambda (eval expected-lambda
)))
133 (flet ((frob (evaloid)
134 (let ((result (funcall evaloid expr
)))
135 (unless (funcall eval-expected-lambda result
)
136 (error "failed assertoid ~S" expr
))))
137 (compile-as-evaloid (optimizations)
139 (funcall (compile nil
141 (declare (optimize ,@optimizations
))
144 (frob (compile-as-evaloid ()))
145 (dolist (i extra-optimizations
)
146 (frob (compile-as-evaloid i
))))))
149 (assertoid (= 2 (length (list 1 2))))
150 (assertoid (= 2 (length (list 1 2)))
151 :extra-optimizations
(((speed 2) (space 3))
152 ((speed 1) (space 3))))
153 (assertoid (cons 1 2)
154 :expected-lambda
(lambda (x) (equal x
'(1 .
2))))
155 (assertoid (cons (list 1 2) (list 1 2))
156 :expected-equal
'((1 2) 1 2))
157 ;;; not implemented yet:
158 #+nil
(assertoid (length (eval (find-package :cl
)))
159 :expected-error-type
'type-error
)
163 (destructuring-bind (op expected real
) form
164 `(let ((expected-value ,expected
)
166 (unless (,op expected-value real-value
)
167 (error "Wanted ~S, got ~S:~% ~S"
168 expected-value real-value
',form
))))
170 (error "~S evaluated to NIL" ',form
))))
172 ;; Return T if two sexprs are EQUAL, considering uninterned symbols
173 ;; in expression A as EQ to one in B provided that there exists a
174 ;; mapping that makes the forms EQUAL.
175 ;; This is helpful when testing complicated macroexpanders.
176 ;; Note that this is much simpler than unification,
177 ;; because symbols can only be replaced by other symbols.
178 (defun equal-mod-gensyms (a b
&optional
(pred #'equal
))
179 (let ((subst-table (make-hash-table :test
'eq
)))
180 (labels ((recurse (a b
)
181 (cond ((and (consp a
) (consp b
))
182 (and (recurse (car a
) (car b
))
183 (recurse (cdr a
) (cdr b
))))
184 ((and (symbolp a
) (symbolp b
))
185 (multiple-value-bind (replacement found
)
186 (gethash a subst-table a
)
187 (or (eq replacement b
)
189 (not (symbol-package a
))
190 (setf (gethash a subst-table
) b
)))))
191 (t ; strings, numbers
192 (funcall pred a b
)))))