Avoid forward references to PARSE-mumble-TYPE condition classes.
[sbcl.git] / tests / deprecation.internal.impure.lisp
blob88aa00c5c5f6345d34960fc7bf220f67615ff025
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.
12 (load "assertoid.lisp")
13 (use-package '#:assertoid)
15 ;;;; Helpers
17 (defun check-deprecated-thing (kind name state make-body
18 &key (replacements
19 (list (format nil "~A.~A"
20 name '#:replacement))))
21 (flet ((search-string (string)
22 (declare (ignorable string))
23 (let ((start))
24 (dolist (fragment `(,(string name)
25 "deprecated" "as" "of" "SBCL" "1.2.10"
26 "Use" ,@replacements "instead"))
27 (let ((match (search fragment string :start2 (or start 0))))
28 (assert match)
29 (setf start (+ match (length fragment))))))))
30 ;; Check the signaled warning condition.
31 (let* ((condition)
32 (count 0)
33 (function (handler-bind
34 ((warning (lambda (c)
35 (incf count)
36 (setf condition c)
37 (muffle-warning))))
38 (compile nil `(lambda ()
39 ,@(funcall make-body name))))))
40 (assert (= count 1))
41 (assert (typep condition (ecase state
42 (:early 'early-deprecation-warning)
43 (:late 'late-deprecation-warning)
44 (:final 'final-deprecation-warning))))
45 (search-string (princ-to-string condition))
46 (ecase state
47 ((:early :late)
48 (assert (eq :deprecated (funcall function))))
49 (:final
50 (assert-error (funcall function) deprecation-error))))
51 ;; Check the documentation.
52 #+sb-doc
53 (search-string (documentation name kind))))
55 ;;;; Deprecated variables
57 (sb-int:define-deprecated-variable :early "1.2.10"
58 deprecated-variable.early
59 :value :deprecated
60 :replacement deprecated-variable.early.replacement)
62 (with-test (:name (sb-int:define-deprecated-variable :early))
63 (check-deprecated-thing 'variable 'deprecated-variable.early :early
64 (lambda (name) `(,name)))
65 (check-deprecated-thing 'variable 'deprecated-variable.early :early
66 (lambda (name) `((symbol-value ',name))))
67 (check-deprecated-thing 'variable 'deprecated-variable.early :early
68 (lambda (name) `((symbol-global-value ',name)))))
70 (sb-int:define-deprecated-variable :late "1.2.10"
71 deprecated-variable.late
72 :value :deprecated
73 :replacement deprecated-variable.late.replacement)
75 (with-test (:name (sb-int:define-deprecated-variable :late))
76 (check-deprecated-thing 'variable 'deprecated-variable.late :late
77 (lambda (name) `(,name)))
78 (check-deprecated-thing 'variable 'deprecated-variable.late :late
79 (lambda (name) `((symbol-value ',name))))
80 (check-deprecated-thing 'variable 'deprecated-variable.late :late
81 (lambda (name) `((symbol-global-value ',name)))))
83 (sb-int:define-deprecated-variable :final "1.2.10"
84 deprecated-variable.final
85 :value :deprecated
86 :replacement deprecated-variable.final.replacement)
88 (with-test (:name (sb-int:define-deprecated-variable :final))
89 (check-deprecated-thing 'variable 'deprecated-variable.final :final
90 (lambda (name) `(,name)))
91 (check-deprecated-thing 'variable 'deprecated-variable.final :final
92 (lambda (name) `((symbol-value ',name))))
93 (check-deprecated-thing 'variable 'deprecated-variable.final :final
94 (lambda (name) `((symbol-global-value ',name)))))
97 ;;;; Deprecated functions
99 (sb-int:define-deprecated-function :early "1.2.10"
100 deprecated-function.early deprecated-function.early.replacement ()
101 :deprecated)
103 (with-test (:name (sb-int:define-deprecated-function :early))
104 (check-deprecated-thing 'function 'deprecated-function.early :early
105 (lambda (name) `((,name)))))
107 (sb-int:define-deprecated-function :late "1.2.10"
108 deprecated-function.late deprecated-function.late.replacement ()
109 :deprecated)
111 (with-test (:name (sb-int:define-deprecated-function :late))
112 (check-deprecated-thing 'function 'deprecated-function.late :late
113 (lambda (name) `((,name)))))
115 (sb-int:define-deprecated-function :final "1.2.10"
116 deprecated-function.final deprecated-function.final.replacement ()
117 :deprecated)
119 (with-test (:name (sb-int:define-deprecated-function :final))
120 (check-deprecated-thing 'function 'deprecated-function.final :final
121 (lambda (name) `((,name)))))
123 (sb-int:define-deprecated-function :early "1.2.10"
124 deprecated-function.two-replacements
125 (deprecated-function.two-replacements.replacement1
126 deprecated-function.two-replacements.replacement2)
128 :deprecated)
130 (with-test (:name (sb-int:define-deprecated-function :two-replacements))
131 (check-deprecated-thing
132 'function 'deprecated-function.two-replacements :early
133 (lambda (name) `((,name)))
134 :replacements '("DEPRECATED-FUNCTION.TWO-REPLACEMENTS.REPLACEMENT1"
135 "DEPRECATED-FUNCTION.TWO-REPLACEMENTS.REPLACEMENT2")))
137 (sb-int:define-deprecated-function :early "1.2.10"
138 deprecated-function.three-replacements
139 (deprecated-function.three-replacements.replacement1
140 deprecated-function.three-replacements.replacement2
141 deprecated-function.three-replacements.replacement3)
143 :deprecated)
145 (with-test (:name (sb-int:define-deprecated-function :three-replacements))
146 (check-deprecated-thing
147 'function 'deprecated-function.three-replacements :early
148 (lambda (name) `((,name)))
149 :replacements '("DEPRECATED-FUNCTION.THREE-REPLACEMENTS.REPLACEMENT1"
150 "DEPRECATED-FUNCTION.THREE-REPLACEMENTS.REPLACEMENT2"
151 "DEPRECATED-FUNCTION.THREE-REPLACEMENTS.REPLACEMENT3")))