1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; While most of SBCL is derived from the CMU CL system, the test
5 ;;;; files (like this one) were written from scratch after the fork
8 ;;;; This software is in the public domain and is provided with
9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
10 ;;;; more information.
12 (cl:in-package
:cl-user
)
14 (use-package :test-util
)
19 (:export
#:code
#:code-msg
#:%code-msg
))
21 (define-condition code
()
22 ((msg :reader code-msg
:reader %code-msg
:initarg
:msg
)))
27 (define-condition code1
(code)
28 ((msg :accessor code-msg
:initarg
:msg
)))
30 (let ((code (make-condition 'code
:msg
1)))
31 (assert (typep code
'code
))
32 (assert (eql (code-msg code
) 1))
33 (assert (eql (%code-msg code
) 1)))
34 (let ((code (make-condition 'code1
:msg
1)))
35 (assert (typep code
'code
))
36 (assert (eql (code-msg code
) 1))
37 (assert (eql (%code-msg code
) 1))
38 (setf (code-msg code
) 2)
39 (assert (eql (code-msg code
) 2))
40 (assert (eql (%code-msg code
) 1)))
44 ;;; Check that initializing the condition class metaobject doesn't create
45 ;;; any instances. Reported by Marco Baringer on sbcl-devel Mon, 05 Jul 2004.
46 (defvar *condition-count
* 0)
47 (define-condition counted-condition
() ((slot :initform
(incf *condition-count
*))))
48 (defmethod frob-counted-condition ((x counted-condition
)) x
)
49 (assert (= 0 *condition-count
*))
50 (assert (typep (sb-mop:class-prototype
(find-class 'counted-condition
))
51 '(and condition counted-condition
)))
53 (define-condition picky-condition
() ())
56 (error 'picky-condition
)
58 (assert (eq (car (compute-restarts)) (car (compute-restarts c
))))))
62 (typep c
'(or null picky-condition
)))
65 ;;; adapted from Helmut Eller on cmucl-imp
69 (error 'picky-condition
)
71 (invoke-restart (find-restart 'give-it c
))))
73 :test
(lambda (c) (typep c
'picky-condition
))
76 ;;; In sbcl-1.0.9, a condition derived from CL:STREAM-ERROR (or
77 ;;; CL:READER-ERROR or or CL:PARSE-ERROR) didn't inherit a usable
78 ;;; PRINT-OBJECT method --- the PRINT-OBJECT code implicitly assumed
79 ;;; that CL:STREAM-ERROR was like a SIMPLE-CONDITION, with args and
80 ;;; format control, which seems to be a preANSIism.
82 ;;; (The spec for DEFINE-CONDITION says that if :REPORT is not
83 ;;; supplied, "information about how to report this type of condition
84 ;;; is inherited from the PARENT-TYPE." The spec doesn't explicitly
85 ;;; forbid the inherited printer from trying to read slots which
86 ;;; aren't portably specified for the condition, but it doesn't seem
87 ;;; reasonable for the inherited printer to do so. It does seem
88 ;;; reasonable for app code to derive a new condition from
89 ;;; CL:READER-ERROR (perhaps for an error in a readmacro) or
90 ;;; CL:PARSE-ERROR (perhaps for an error in an operator
91 ;;; READ-MY-FAVORITE-DATA-STRUCTURE) or CL:STREAM-ERROR (dunno why
92 ;;; offhand, but perhaps for some Gray-stream-ish reason), not define
93 ;;; a :REPORT method for its new condition, and expect to inherit from
94 ;;; the application's printer all the cruft required for describing
95 ;;; the location of the error in the input.)
96 (define-condition my-stream-error-1-0-9
(stream-error) ())
97 (define-condition parse-foo-error-1-0-9
(parse-error) ())
98 (define-condition read-bar-error-1-0-9
(reader-error) ())
99 (with-test (:name
:printable-conditions
)
100 (let (;; instances created initializing all the slots specified in
102 (parse-foo-error-1-0-9 (make-condition 'parse-foo-error-1-0-9
103 :stream
*standard-input
*))
104 (read-foo-error-1-0-9 (make-condition 'read-bar-error-1-0-9
105 :stream
*standard-input
*))
106 (my-stream-error-1-0-9 (make-condition 'my-stream-error-1-0-9
107 :stream
*standard-input
*)))
108 ;; should be printable
110 my-stream-error-1-0-9
111 parse-foo-error-1-0-9
112 read-foo-error-1-0-9
))
113 ;; whether escaped or not
114 (dolist (*print-escape
* '(nil t
))
115 (write c
:stream
(make-string-output-stream))))))
117 ;;; Reported by Michael Weber: restart computation in :TEST-FUNCTION used to
118 ;;; cause infinite recursion.
119 (defun restart-test-finds-restarts ()
122 (return-from restart-test-finds-restarts
42))
125 (declare (ignore condition
))
126 (find-restart 'qux
))))
127 (when (find-restart 'bar
)
128 (invoke-restart 'bar
))))
129 (assert (not (restart-test-finds-restarts)))
131 (with-test (:name
:bug-896379
)
132 (let ((*evaluator-mode
* :compile
))
133 (handler-bind ((style-warning #'error
))
134 (let ((reader (gensym "READER"))
135 (name (gensym "FOO-ERROR")))
136 (eval `(define-condition ,name
(error)
137 ((slot :initarg
:slot
:reader
,reader
))
138 (:report
(lambda (c stream
)
139 (format stream
"Oops: ~S" (,reader c
))))))))))
141 (with-test (:name
:define-condition-result
)
142 (let ((name (gensym "CONDITION")))
144 (eq (eval `(define-condition ,name
() ()))
149 (define-condition condition-with-default-initargs
(condition)
151 (:default-initargs
:foo
1))
153 (with-test (:name
(sb-mop:class-direct-default-initargs
:for-condition-class
155 ;; CLASS-DIRECT-DEFAULT-INITARGS used to return nil for all
156 ;; condition classes.
157 (let ((initargs (sb-mop:class-direct-default-initargs
158 (find-class 'condition-with-default-initargs
))))
159 (assert (equal (subseq (first initargs
) 0 2) '(:foo
1)))))
163 (defconstant +error-when-called
+ (lambda () (error "oops")))
165 (define-condition condition-with-constant-function-initarg
()
167 :reader condition-with-constant-function-initarg-foo
))
168 (:default-initargs
:foo
+error-when-called
+))
170 (with-test (:name
(:condition-with-constant-function-initarg
:bug-539517
))
171 ;; The default initarg handling for condition classes used to
172 ;; confuse constant functions (thus +ERROR-WHEN-CALLED+) and
173 ;; initfunctions. This lead to +ERROR-WHEN-CALLED+ being called as
174 ;; if it was an initfunction.
176 (condition-with-constant-function-initarg-foo
177 (make-condition 'condition-with-constant-function-initarg
))))
179 (condition-with-constant-function-initarg-foo
180 (make-instance 'condition-with-constant-function-initarg
)))))
184 (define-condition condition-with-constant-function-initform
()
186 :reader condition-with-constant-function-initform-foo
187 :initform
+error-when-called
+)))
189 (with-test (:name
(:condition-with-constant-function-slot-initform
))
191 (condition-with-constant-function-initform-foo
192 (make-condition 'condition-with-constant-function-initform
))))
194 (condition-with-constant-function-initform-foo
195 (make-instance 'condition-with-constant-function-initform
)))))
199 (defvar bar-counter
0)
201 (defvar baz-counter
0)
203 (define-condition condition-with-non-constant-default-initarg
()
205 :reader condition-with-non-constant-default-initarg-bar
)
207 :reader condition-with-non-constant-default-initarg-baz
208 :initform
(incf baz-counter
)))
209 (:default-initargs
:bar
(incf bar-counter
)))
210 (define-condition condition-with-non-constant-default-initarg
()
212 :reader condition-with-non-constant-default-initarg-bar
)
214 :reader condition-with-non-constant-default-initarg-baz
215 :initform
(incf baz-counter
)))
216 (:default-initargs
:bar
(incf bar-counter
)))
218 (with-test (:name
(:redefining-condition-with-non-constant-default-initarg
220 ;; Redefining conditions could lead to multiple evaluations of
221 ;; initfunctions for slots and default initargs. We need all the
222 ;; combinations of make-condition/instance and eval/compile because
223 ;; they failed differently.
224 (macrolet ((test (case &body body
)
228 (let ((instance (progn ,@body
)))
230 (= 1 (condition-with-non-constant-default-initarg-bar
233 ,(format nil
"Assertion failed for default initarg initfunction for ~A"
236 (= 1 (condition-with-non-constant-default-initarg-baz
239 ,(format nil
"Assertion failed for slot initfunction for ~A"
241 (assert (= 1 bar-counter
))
242 (assert (= 1 baz-counter
)))))
244 ;; Go through EVAL to avoid optimizations.
245 (test :eval
+make-condition
246 (eval '(make-condition
247 'condition-with-non-constant-default-initarg
)))
248 (test :eval
+make-instance
249 (eval '(make-instance
250 'condition-with-non-constant-default-initarg
)))
252 ;; Allow optimizations.
253 (test :compile
+make-condition
255 'condition-with-non-constant-default-initarg
))
256 (test :compile
+make-instance
258 'condition-with-non-constant-default-initarg
))))
262 (define-condition condition-with-class-allocation
()
263 ((count :accessor condition-with-class-allocation-count
265 :allocation
:class
)))
267 (with-test (:name
(:condition-with-class-allocation
:bug-1049404
))
269 (incf (condition-with-class-allocation-count
270 (make-condition 'condition-with-class-allocation
))))
271 (assert (= 5 (condition-with-class-allocation-count
272 (make-condition 'condition-with-class-allocation
)))))
276 (with-test (:name
(assert :print-intermediate-results
:bug-789497
))
277 (macrolet ((test (bindings expression expected-message
)
279 (handler-case (assert ,expression
)
280 (simple-error (condition)
281 (assert (string= (princ-to-string condition
)
282 ,expected-message
)))))))
283 ;; Constant and variables => no special report.
284 (test () nil
"The assertion NIL failed.")
285 (test ((a nil
)) a
"The assertion A failed.")
286 ;; Special operators => no special report.
287 (test ((a nil
) (b nil
)) (or a b
) "The assertion (OR A B) failed.")
288 (test ((a nil
) (b t
)) (and a b
) "The assertion (AND A B) failed.")
289 ;; Functions with constant and non-constant arguments => include
290 ;; non-constant arguments in report.
291 (test ((a t
)) (not a
) "The assertion (NOT A) failed with A = T.")
292 (test () (not t
) "The assertion (NOT T) failed.")
293 (test ((a -
1)) (plusp (signum a
))
294 "The assertion (PLUSP (SIGNUM A)) failed with (SIGNUM A) = -1.")))