?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Hoist tests from scan_weak_pointers() into scav_weak_pointer()
[sbcl.git] / tests / deprecation.impure.lisp
blob3b2a317afbf36b56c728f89ec8d1111f5594f53c
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
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
6 ;;;; from CMU CL.
7 ;;;;
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.
11
12 (load "assertoid.lisp")
13 (use-package '#:assertoid)
14 \f
15 ;;;; Helpers
16
17 (defun check-deprecated-thing (namespace name state make-body
18 &key replacements
19 (call t)
20 (expected-warning-count '(eql 1))
21 (check-describe t))
22 (labels ((search-string (string fragments)
23 (let ((start))
24 (dolist (fragment fragments)
25 (let ((match (search fragment string :start2 (or start 0))))
26 (assert match)
27 (setf start (+ match (length fragment)))))))
28 (search-string/documentation (string)
29 (search-string
30 string `(,(string-downcase namespace) ,(string name)
31 "deprecated" "as" "of" "some-lib" "version" "1.2.3"))
32 (when replacements
33 (search-string string `("Use" ,@replacements "instead"))))
34 (search-string/describe (string)
35 (search-string
36 string `(,(string name) ,(string state)
37 "deprecation" "since" "some-lib" "version" "1.2.3"))))
38 ;; Check the signaled warning condition.
39 (multiple-value-bind (function failure-p warnings style-warnings)
40 (checked-compile `(lambda () ,@(funcall make-body name))
41 :allow-style-warnings t ; undefined types, functions
42 :allow-warnings 'deprecation-condition)
43 (declare (ignore failure-p))
44 (let* ((conditions (remove-if-not
45 (lambda (condition)
46 (typep condition 'deprecation-condition))
47 (append warnings style-warnings)))
48 (condition (first conditions))
49 (count (length conditions)))
50 (assert (typep count expected-warning-count))
51 (when condition
52 (assert (typep condition (ecase state
53 (:early 'early-deprecation-warning)
54 (:late 'late-deprecation-warning)
55 (:final 'final-deprecation-warning))))
56 (search-string/documentation (princ-to-string condition)))
57 (when call
58 (ecase state
59 ((:early :late)
60 (assert (eq :deprecated (funcall function))))
61 (:final
62 (assert-error (funcall function) deprecation-error))))))
63 ;; Check DESCRIBE output.
64 (when check-describe
65 (search-string/describe (with-output-to-string (stream)
66 (describe name stream))))
67 ;; Check DOCUMENTATION.
68 (search-string/documentation (documentation name namespace))))
69 \f
70 ;;;; DEPRECATED declaration syntax
71
72 (with-test (:name (deprecated :declaration :syntax))
73 ;; Some syntax errors.
74 (mapc (lambda (declaration)
75 (assert-error (proclaim declaration)))
76 '((deprecated)
77 (deprecated :early)
78 (deprecated :early 1)
79 (deprecated :early ("1"))
80 (deprecated :early ("a" "b" "c"))
81 (deprecated :early 1 (function))
82 (deprecated :early 1 (unsupported-namespace name))))
83
84 ;; These should work.
85 (mapc (lambda (declaration)
86 (assert-no-signal (proclaim declaration)))
87 '((deprecated :early "1")
88 (deprecated :early ("my-software" "1"))
89 (deprecated :early "1" (variable deprecated.declaration.variable))
90 (deprecated :early "1" (function deprecated.declaration.function))
91 (deprecated :early "1" (function (setf deprecated.declaration.function)))
92 (deprecated :early "1" (type deprecated.declaration.type))
93 (deprecated :early "1" (variable deprecated.declaration.thing1)
94 (variable deprecated.declaration.thing2))
95 (deprecated :early "1" (variable deprecated.declaration.replacement
96 :replacement deprecated.declaration.replacement))
97 (deprecated :early "1" (variable deprecated.declaration.replacement
98 :replacement (deprecated.declaration.replacement1
99 deprecated.declaration.replacement2))))))
100 \f
101 ;;;; Deprecated variables
102
103 (macrolet
104 ((definition.undefined (variable-name)
105 (declare (ignore variable-name))
106 ())
107 (definition.declaimed-special (variable-name)
108 `(declaim (special ,variable-name)))
109 (definition.defvar (variable-name)
110 `(defvar ,variable-name :deprecated))
111 (definition.defglobal (variable-name)
112 `(defglobal ,variable-name :deprecated))
113 (definition.defconstant (variable-name)
114 `(defconstant ,variable-name :deprecated))
115 (definition.define-symbol-macro (variable-name)
116 `(define-symbol-macro ,variable-name :deprecated))
117 (define-variable-tests (tag definition-name &rest args)
118 (flet ((make-test-case (tag state
119 &key
120 (call t)
121 (symbol-value t)
122 (check-describe t))
123 (let ((variable-name (sb-int::symbolicate
124 '#:variable. tag '#:. state))
125 (replacement 'replacement))
126 `(,@(unless (eq state :final)
127 `((,definition-name ,variable-name)))
128 (declaim (deprecated
129 ,state ("some-lib" "1.2.3")
130 (variable ,variable-name
131 :replacement ,replacement)))
132
133 (with-test (:name (deprecated variable ,tag ,state))
134 (check-deprecated-thing
135 'variable ',variable-name ,state
136 (lambda (name) `(,name))
137 :replacements '(,(string replacement))
138 :call ,call
139 :check-describe ,check-describe)
140 ,@(when symbol-value
141 `((check-deprecated-thing
142 'variable ',variable-name ,state
143 (lambda (name) `((symbol-value ',name)))
144 :replacements '(,(string replacement))
145 :call ,call
146 :check-describe ,check-describe)
147 (check-deprecated-thing
148 'variable ',variable-name ,state
149 (lambda (name) `((symbol-global-value ',name)))
150 :replacements '(,(string replacement))
151 :call ,call
152 :check-describe ,check-describe))))))))
153 `(progn
154 ,@(apply #'make-test-case tag :early args)
155 ,@(apply #'make-test-case tag :late args)
156 ,@(apply #'make-test-case tag :final :check-describe t args)))))
157
158 (define-variable-tests :undefined definition.undefined
159 :call nil :check-describe nil)
160 (define-variable-tests :declaimed-special definition.declaimed-special
161 :call nil)
162 (define-variable-tests defvar definition.defvar)
163 (define-variable-tests defglobal definition.defglobal)
164 (define-variable-tests defconstant definition.defconstant)
165 (define-variable-tests define-symbol-macro definition.define-symbol-macro
166 :symbol-value nil))
167 \f
168 ;;;; Deprecated functions
169
170 (macrolet
171 ((definition.undefined (function-name)
172 (declare (ignore function-name))
173 ())
174 (definition.declaimed-ftype (function-name)
175 `(declaim (ftype (function () (values keyword &optional))
176 ,function-name)))
177 (definition.defun (function-name)
178 `(defun ,function-name () :deprecated))
179 (definition.defmacro (function-name)
180 `(defmacro ,function-name () :deprecated))
181 (define-function-tests (tag definition-name &rest args)
182 (flet ((make-test-case (tag state
183 &key
184 (call t)
185 (check-describe t))
186 (let ((function-name (sb-int::symbolicate
187 '#:function. tag '#:. state))
188 (replacement 'replacement))
189 `(,@(unless (eq state :final)
190 `((,definition-name ,function-name)))
191 (declaim (deprecated
192 ,state ("some-lib" "1.2.3")
193 (function ,function-name
194 :replacement ,replacement)))
195
196 (with-test (:name (deprecated function ,tag ,state))
197 (check-deprecated-thing
198 'function ',function-name ,state
199 (lambda (name) `((,name)))
200 :replacements '(,(string replacement))
201 :call ,call
202 :check-describe ,check-describe))))))
203 `(progn
204 ,@(apply #'make-test-case tag :early args)
205 ,@(apply #'make-test-case tag :late args)
206 ,@(apply #'make-test-case tag :final :check-describe t args)))))
207
208 (define-function-tests :undefined definition.undefined
209 :call nil :check-describe nil)
210 (define-function-tests :declaimed-ftype definition.declaimed-ftype
211 :call nil :check-describe nil)
212 (define-function-tests defun definition.defun)
213 (define-function-tests defmacro definition.defmacro))
214 \f
215 ;;;; Deprecated types
216
217 (macrolet
218 ((definition.undefined (type-name)
219 (declare (ignore type-name))
220 ())
221 (definition.deftype.empty-body (type-name)
222 `(deftype ,type-name ()))
223 (definition.deftype.t-body (type-name)
224 `(deftype ,type-name () t))
225 (definition.defclass (type-name)
226 `(defclass ,type-name () ()))
227 (definition.defstruct (type-name)
228 `(defstruct ,type-name))
229 (definition.define-condition (type-name)
230 `(define-condition ,type-name () ()))
231 (define-type-tests (tag definition-name method class &rest args)
232 (flet ((make-test-case (tag state &key check-describe)
233 (let* ((method (and method (not (eq state :final))))
234 (class (and class (not (eq state :final))))
235 (type-name (apply #'sb-int::symbolicate
236 (append '(#:type.)
237 (sb-int:ensure-list tag)
238 (list '#:. state (gensym)))))
239 (extra-warning-count (+ (if method 1 0) (if class 1 0)))
240 (replacement 'replacement))
241 `(,@(unless (eq state :final)
242 `((,definition-name ,type-name)))
243 (declaim (deprecated
244 ,state ("some-lib" "1.2.3")
245 (type ,type-name
246 :replacement ,replacement)))
247
248 (test-util:with-test (:name (deprecated type
249 ,@(sb-int:ensure-list tag)
250 ,state))
251 (check-deprecated-thing
252 'type ',type-name ,state
253 (lambda (name)
254 `((let ((x))
255 (declare (type (or null ,name) x)
256 (ignore x)))
257 (typep nil ',name)
258 ,@,(when method
259 '`((defmethod ,(gensym) ((x ,name)))))
260 ,@,(when class
261 '`((defclass ,(gensym) (,name) ())))))
262 :replacements '(,(string replacement))
263 :call nil
264 :expected-warning-count '(integer
265 ,(+ 2 extra-warning-count)
266 ,(+ 4 extra-warning-count))
267 :check-describe ,check-describe))))))
268 `(progn
269 ,@(apply #'make-test-case tag :early args)
270 ,@(apply #'make-test-case tag :late args)
271 ,@(apply #'make-test-case tag :final :check-describe t args)))))
272
273 (define-type-tests :undefined definition.undefined nil nil
274 :check-describe nil)
275 (define-type-tests (deftype :empty-body) definition.deftype.empty-body nil nil)
276 (define-type-tests (deftype :t-body) definition.deftype.t-body nil nil)
277 (define-type-tests defclass definition.defclass t t)
278 (define-type-tests defstruct definition.defstruct t nil)
279 (define-type-tests define-condition definition.define-condition t nil))
280
281 (with-test (:name (deprecated type :unrelated-class))
282 (let ((name (gensym)))
283 (eval `(progn
284 (deftype ,name () 'integer)
285 (declaim (deprecated :early ("some-lib" "1.2.3") (type ,name)))))
286 ;; Make sure the deprecation declaration works.
287 (check-deprecated-thing
288 'type name :early
289 (lambda (name)
290 `((typep 1 ',name)))
291 :call nil)
292 ;; Check that the declaration does not apply to an unrelated class
293 ;; of the same name.
294 (check-deprecated-thing
295 'type name :early
296 (lambda (name)
297 `((make-instance ,(make-instance 'standard-class :name name))))
298 :call nil
299 :expected-warning-count '(eql 0))))
300
301 \f
302 ;;;; Loader deprecation warnings
303
304 (defun please-dont-use-this (x)
305 (identity x))
306 (declaim (deprecated :early "1.2.10"
307 (function please-dont-use-this
308 :replacement moar-better-function)))
309
310 (defun really-dont-do-it (x)
311 (identity x))
312 (declaim (deprecated :late "1.2.10"
313 (function really-dont-do-it
314 :replacement use-other-thing-instead)))
315
316 (defun you-cant-use-this (x)
317 (identity x))
318 (declaim (deprecated :final "1.2.10"
319 (function you-cant-use-this
320 :replacement replacement-fn)))
321
322 (with-test (:name :introspect-deprecation-stage)
323 (assert (eq (sb-int:deprecated-thing-p 'function 'please-dont-use-this)
324 :early))
325 (assert (eq (sb-int:deprecated-thing-p 'function 'really-dont-do-it)
326 :late))
327 (assert (eq (sb-int:deprecated-thing-p 'function 'you-cant-use-this)
328 :final)))
329
330 (with-test (:name (:late-deprecated-fun-doc :bug-1439151)
331 :skipped-on '(not :sb-doc))
332 (assert (string= (documentation 'you-cant-use-this 'function)
333 (documentation #'you-cant-use-this 'function)))
334 (assert (string= (documentation 'function.defun.late 'function)
335 (documentation #'function.defun.late 'function)))
336 (assert (string/= (documentation 'you-cant-use-this 'function)
337 (documentation 'function.defun.late 'function))))
338
339 (with-test (:name :load-time-deprecation-warning)
340 (let ((source "load-test.tmp") fasl)
341 (with-open-file (f source :direction :output
342 :if-does-not-exist :create :if-exists :supersede)
343 (write-string "(defun a () (quit))" f)
344 ;; a full warning even though the PLEASE-DONT- function is only :early
345 (write-string "(defun b () (please-dont-use-this 1) (really-dont-do-it 2))" f)
346 (write-string "(defun c () (you-cant-use-this 3))" f))
347 ;; We expect four deprecation warnings from compiling the source
348 ;; (four uses of deprecated things) and three from loading it
349 ;; (loading three functions that contain uses of deprecated
350 ;; things).
351 (unwind-protect
352 (progn (setq fasl
353 (assert-signal
354 (compile-file source :verbose nil :print nil)
355 (or early-deprecation-warning
356 late-deprecation-warning
357 final-deprecation-warning)
358 4))
359 (assert-signal (load fasl) warning 3))
360 (delete-file fasl)
361 (delete-file source))))
Common Lisp compiler and runtime