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 (load "assertoid.lisp")
13 (use-package '#:assertoid
)
17 (defun test (namespace name state make-body
20 (expected-warning-count '(eql 1))
22 (labels ((search-string (string fragments
)
24 (dolist (fragment fragments
)
25 (let ((match (search fragment string
:start2
(or start
0))))
27 (setf start
(+ match
(length fragment
)))))))
28 (search-string/documentation
(string)
30 string
`(,(string-downcase namespace
) ,(string name
)
31 "deprecated" "as" "of" "some-lib" "version" "1.2.3"))
33 (search-string string
`("Use" ,@replacements
"instead"))))
34 (search-string/describe
(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
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
))
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
)))
60 (assert (eq :deprecated
(funcall function
))))
62 (assert-error (funcall function
)
63 (or deprecation-error cell-error
)))))))
64 ;; Check DESCRIBE output.
66 (search-string/describe
(with-output-to-string (stream)
67 (describe name stream
))))
68 ;; Check DOCUMENTATION.
69 (search-string/documentation
(documentation name namespace
))))
71 ;;;; DEPRECATED declaration syntax
73 (with-test (:name
(deprecated :declaration
:syntax
))
74 ;; Some syntax errors.
75 (mapc (lambda (declaration)
76 (assert-error (proclaim declaration
)))
80 (deprecated :early
("1"))
81 (deprecated :early
("a" "b" "c"))
82 (deprecated :early
1 (function))
83 (deprecated :early
1 (unsupported-namespace name
))))
86 (mapc (lambda (declaration)
87 (assert-no-signal (proclaim declaration
)))
88 '((deprecated :early
"1")
89 (deprecated :early
("my-software" "1"))
90 (deprecated :early
"1" (variable deprecated.declaration.variable
))
91 (deprecated :early
"1" (function deprecated.declaration.function
))
92 (deprecated :early
"1" (function (setf deprecated.declaration.function
)))
93 (deprecated :early
"1" (type deprecated.declaration.type
))
94 (deprecated :early
"1" (variable deprecated.declaration.thing1
)
95 (variable deprecated.declaration.thing2
))
96 (deprecated :early
"1" (variable deprecated.declaration.replacement
97 :replacement deprecated.declaration.replacement
))
98 (deprecated :early
"1" (variable deprecated.declaration.replacement
99 :replacement
(deprecated.declaration.replacement1
100 deprecated.declaration.replacement2
))))))
102 ;;;; Deprecated variables
105 ((definition.undefined
(variable-name)
106 (declare (ignore variable-name
))
108 (definition.declaimed-special
(variable-name)
109 `(declaim (special ,variable-name
)))
110 (definition.defvar
(variable-name)
111 `(defvar ,variable-name
:deprecated
))
112 (definition.defglobal
(variable-name)
113 `(defglobal ,variable-name
:deprecated
))
114 (definition.defconstant
(variable-name)
115 `(defconstant ,variable-name
:deprecated
))
116 (definition.define-symbol-macro
(variable-name)
117 `(define-symbol-macro ,variable-name
:deprecated
))
118 (define-variable-tests (tag definition-name
&rest args
)
119 (flet ((make-test-case (tag state
124 (let ((variable-name (sb-int::symbolicate
125 '#:variable. tag
'#:. state
))
126 (replacement 'replacement
))
127 `(,@(unless (eq state
:final
)
128 `((,definition-name
,variable-name
)))
130 ,state
("some-lib" "1.2.3")
131 (variable ,variable-name
132 :replacement
,replacement
)))
134 (with-test (:name
(deprecated variable
,tag
,state
))
136 'variable
',variable-name
,state
137 (lambda (name) `(,name
))
138 :replacements
'(,(string replacement
))
140 :check-describe
,check-describe
)
143 'variable
',variable-name
,state
144 (lambda (name) `((symbol-value ',name
)))
145 :replacements
'(,(string replacement
))
147 :check-describe
,check-describe
)
149 'variable
',variable-name
,state
150 (lambda (name) `((symbol-global-value ',name
)))
151 :replacements
'(,(string replacement
))
153 :check-describe
,check-describe
))))))))
155 ,@(apply #'make-test-case tag
:early args
)
156 ,@(apply #'make-test-case tag
:late args
)
157 ,@(apply #'make-test-case tag
:final
:check-describe t args
)))))
159 (define-variable-tests :undefined definition.undefined
160 :call nil
:check-describe nil
)
161 (define-variable-tests :declaimed-special definition.declaimed-special
163 (define-variable-tests defvar definition.defvar
)
164 (define-variable-tests defglobal definition.defglobal
)
165 (define-variable-tests defconstant definition.defconstant
)
166 (define-variable-tests define-symbol-macro definition.define-symbol-macro
169 ;;;; Deprecated functions
172 ((definition.undefined
(function-name)
173 (declare (ignore function-name
))
175 (definition.declaimed-ftype
(function-name)
176 `(declaim (ftype (function () (values keyword
&optional
))
178 (definition.defun
(function-name)
179 `(defun ,function-name
() :deprecated
))
180 (definition.defmacro
(function-name)
181 `(defmacro ,function-name
() :deprecated
))
182 (define-function-tests (tag definition-name
&rest args
)
183 (flet ((make-test-case (tag state
187 (let ((function-name (sb-int::symbolicate
188 '#:function. tag
'#:. state
))
189 (replacement 'replacement
))
190 `(,@(unless (eq state
:final
)
191 `((,definition-name
,function-name
)))
193 ,state
("some-lib" "1.2.3")
194 (function ,function-name
195 :replacement
,replacement
)))
197 (with-test (:name
(deprecated function
,tag
,state
))
199 'function
',function-name
,state
200 (lambda (name) `((,name
)))
201 :replacements
'(,(string replacement
))
203 :check-describe
,check-describe
))))))
205 ,@(apply #'make-test-case tag
:early args
)
206 ,@(apply #'make-test-case tag
:late args
)
207 ,@(apply #'make-test-case tag
:final
:check-describe t args
)))))
209 (define-function-tests :undefined definition.undefined
210 :call nil
:check-describe nil
)
211 (define-function-tests :declaimed-ftype definition.declaimed-ftype
212 :call nil
:check-describe nil
)
213 (define-function-tests defun
definition.defun
)
214 (define-function-tests defmacro definition.defmacro
))
216 ;;;; Deprecated types
219 ((definition.undefined
(type-name)
220 (declare (ignore type-name
))
222 (definition.deftype.empty-body
(type-name)
223 `(deftype ,type-name
()))
224 (definition.deftype.t-body
(type-name)
225 `(deftype ,type-name
() t
))
226 (definition.defclass
(type-name)
227 `(defclass ,type-name
() ()))
228 (definition.defstruct
(type-name)
229 `(defstruct ,type-name
))
230 (definition.define-condition
(type-name)
231 `(define-condition ,type-name
() ()))
232 (define-type-tests (tag definition-name method class
&rest args
)
233 (flet ((make-test-case (tag state
&key check-describe
)
234 (let* ((method (and method
(not (eq state
:final
))))
235 (class (and class
(not (eq state
:final
))))
236 (type-name (apply #'sb-int
::symbolicate
238 (sb-int:ensure-list tag
)
239 (list '#:. state
(gensym)))))
240 (extra-warning-count (+ (if method
1 0) (if class
1 0)))
241 (replacement 'replacement
))
242 `(,@(unless (eq state
:final
)
243 `((,definition-name
,type-name
)))
245 ,state
("some-lib" "1.2.3")
247 :replacement
,replacement
)))
249 (test-util:with-test
(:name
(deprecated type
250 ,@(sb-int:ensure-list tag
)
253 'type
',type-name
,state
256 (declare (type (or null
,name
) x
)
260 '`((defmethod ,(gensym) ((x ,name
)))))
262 '`((defclass ,(gensym) (,name
) ())))))
263 :replacements
'(,(string replacement
))
265 :expected-warning-count
'(integer
266 ,(+ 2 extra-warning-count
)
267 ,(+ 4 extra-warning-count
))
268 :check-describe
,check-describe
))))))
270 ,@(apply #'make-test-case tag
:early args
)
271 ,@(apply #'make-test-case tag
:late args
)
272 ,@(apply #'make-test-case tag
:final
:check-describe t args
)))))
274 (define-type-tests :undefined definition.undefined nil nil
276 (define-type-tests (deftype :empty-body
) definition.deftype.empty-body nil nil
)
277 (define-type-tests (deftype :t-body
) definition.deftype.t-body nil nil
)
278 (define-type-tests defclass definition.defclass t t
)
279 (define-type-tests defstruct definition.defstruct t nil
)
280 (define-type-tests define-condition definition.define-condition t nil
))
282 (with-test (:name
(deprecated type
:unrelated-class
))
283 (let ((name (gensym)))
285 (deftype ,name
() 'integer
)
286 (declaim (deprecated :early
("some-lib" "1.2.3") (type ,name
)))))
287 ;; Make sure the deprecation declaration works.
293 ;; Check that the declaration does not apply to an unrelated class
298 `((make-instance ,(make-instance 'standard-class
:name name
))))
300 :expected-warning-count
'(eql 0))))
303 ;;;; Loader deprecation warnings
305 (defun please-dont-use-this (x)
307 (declaim (deprecated :early
"1.2.10"
308 (function please-dont-use-this
309 :replacement moar-better-function
)))
311 (defun really-dont-do-it (x)
313 (declaim (deprecated :late
"1.2.10"
314 (function really-dont-do-it
315 :replacement use-other-thing-instead
)))
317 (defun you-cant-use-this (x)
319 (declaim (deprecated :final
"1.2.10"
320 (function you-cant-use-this
321 :replacement replacement-fn
)))
323 (with-test (:name
:introspect-deprecation-stage
)
324 (assert (eq (sb-int:deprecated-thing-p
'function
'please-dont-use-this
)
326 (assert (eq (sb-int:deprecated-thing-p
'function
'really-dont-do-it
)
328 (assert (eq (sb-int:deprecated-thing-p
'function
'you-cant-use-this
)
331 (with-test (:name
(:late-deprecated-fun-doc
:bug-1439151
)
332 :skipped-on
'(not :sb-doc
))
333 (assert (string= (documentation 'you-cant-use-this
'function
)
334 (documentation #'you-cant-use-this
'function
)))
335 (assert (string= (documentation 'function.defun.late
'function
)
336 (documentation #'function.defun.late
'function
)))
337 (assert (string/= (documentation 'you-cant-use-this
'function
)
338 (documentation 'function.defun.late
'function
))))
340 (with-test (:name
:load-time-deprecation-warning
)
341 (let ((source "load-test.tmp") fasl
)
342 (with-open-file (f source
:direction
:output
343 :if-does-not-exist
:create
:if-exists
:supersede
)
344 (write-string "(defun a () (quit))" f
)
345 ;; a full warning even though the PLEASE-DONT- function is only :early
346 (write-string "(defun b () (please-dont-use-this 1) (really-dont-do-it 2))" f
)
347 (write-string "(defun c () (you-cant-use-this 3))" f
))
348 ;; We expect four deprecation warnings from compiling the source
349 ;; (four uses of deprecated things) and three from loading it
350 ;; (loading three functions that contain uses of deprecated
355 (compile-file source
:verbose nil
:print nil
)
356 (or early-deprecation-warning
357 late-deprecation-warning
358 final-deprecation-warning
)
360 (assert-signal (load fasl
) warning
3))
362 (delete-file source
))))