tests/deprecation.impure.lisp

   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 &rest args)
 232        (flet ((make-test-case (tag state &key check-describe)
 233                 (let ((type-name (apply #'sb-int::symbolicate
 234                                         (append '(#:type.)
 235                                                 (sb-int:ensure-list tag)
 236                                                 (list '#:. state (gensym)))))
 237                       (replacement 'replacement))
 238                   `(,@(unless (eq state :final)
 239                         `((,definition-name ,type-name)))
 240                     (declaim (deprecated
 241                               ,state ("some-lib" "1.2.3")
 242                               (type ,type-name
 243                                     :replacement ,replacement)))
 244
 245                     (test-util:with-test (:name (deprecated type
 246                                                  ,@(sb-int:ensure-list tag)
 247                                                  ,state))
 248                       (check-deprecated-thing
 249                        'type ',type-name ,state
 250                        (lambda (name)
 251                          `((let ((x))
 252                              (declare (type (or null ,name) x)
 253                                       (ignore x)))
 254                            (typep nil ',name)
 255                            (defmethod ,(gensym) ((x ,name)))
 256                            (defclass ,(gensym) (,name) ())))
 257                        :replacements           '(,(string replacement))
 258                        :call                   nil
 259                        :expected-warning-count '(integer 4 6)
 260                        :check-describe         ,check-describe))))))
 261          `(progn
 262             ,@(apply #'make-test-case tag :early args)
 263             ,@(apply #'make-test-case tag :late  args)
 264             ,@(apply #'make-test-case tag :final :check-describe t args)))))
 265
 266   (define-type-tests :undefined            definition.undefined
 267     :check-describe nil)
 268   (define-type-tests (deftype :empty-body) definition.deftype.empty-body)
 269   (define-type-tests (deftype :t-body)     definition.deftype.t-body)
 270   (define-type-tests defclass              definition.defclass)
 271   (define-type-tests defstruct             definition.defstruct)
 272   (define-type-tests define-condition      definition.define-condition))
 273
 274 (with-test (:name (deprecated type :unrelated-class))
 275   (let ((name (gensym)))
 276     (eval `(progn
 277              (deftype ,name () 'integer)
 278              (declaim (deprecated :early ("some-lib" "1.2.3") (type ,name)))))
 279     ;; Make sure the deprecation declaration works.
 280     (check-deprecated-thing
 281      'type name :early
 282      (lambda (name)
 283        `((typep 1 ',name)))
 284      :call nil)
 285     ;; Check that the declaration does not apply to an unrelated class
 286     ;; of the same name.
 287     (check-deprecated-thing
 288      'type name :early
 289      (lambda (name)
 290        `((make-instance ,(make-instance 'standard-class :name name))))
 291      :call                   nil
 292      :expected-warning-count '(eql 0))))
 293
 294 \f
 295 ;;;; Loader deprecation warnings
 296
 297 (defun please-dont-use-this (x)
 298   (identity x))
 299 (declaim (deprecated :early "1.2.10"
 300                      (function please-dont-use-this
 301                                :replacement moar-better-function)))
 302
 303 (defun really-dont-do-it (x)
 304   (identity x))
 305 (declaim (deprecated :late "1.2.10"
 306                      (function really-dont-do-it
 307                                :replacement use-other-thing-instead)))
 308
 309 (defun you-cant-use-this (x)
 310   (identity x))
 311 (declaim (deprecated :final "1.2.10"
 312                      (function you-cant-use-this
 313                                :replacement replacement-fn)))
 314
 315 (with-test (:name :introspect-deprecation-stage)
 316   (assert (eq (sb-int:deprecated-thing-p 'function 'please-dont-use-this)
 317               :early))
 318   (assert (eq (sb-int:deprecated-thing-p 'function 'really-dont-do-it)
 319               :late))
 320   (assert (eq (sb-int:deprecated-thing-p 'function 'you-cant-use-this)
 321               :final)))
 322
 323 (with-test (:name (:late-deprecated-fun-doc :bug-1439151)
 324                   :skipped-on '(not :sb-doc))
 325   (assert (string= (documentation 'you-cant-use-this 'function)
 326                    (documentation #'you-cant-use-this 'function)))
 327   (assert (string= (documentation 'function.defun.late 'function)
 328                    (documentation #'function.defun.late 'function)))
 329   (assert (string/= (documentation 'you-cant-use-this 'function)
 330                     (documentation 'function.defun.late 'function))))
 331
 332 (with-test (:name :load-time-deprecation-warning)
 333   (let ((source "load-test.tmp") fasl)
 334     (with-open-file (f source :direction :output
 335                        :if-does-not-exist :create :if-exists :supersede)
 336       (write-string "(defun a () (quit))" f)
 337       ;; a full warning even though the PLEASE-DONT- function is only :early
 338       (write-string "(defun b () (please-dont-use-this 1) (really-dont-do-it 2))" f)
 339       (write-string "(defun c () (you-cant-use-this 3))" f))
 340     ;; We expect four deprecation warnings from compiling the source
 341     ;; (four uses of deprecated things) and three from loading it
 342     ;; (loading three functions that contain uses of deprecated
 343     ;; things).
 344     (unwind-protect
 345          (progn (setq fasl
 346                       (assert-signal
 347                        (compile-file source :verbose nil :print nil)
 348                        (or early-deprecation-warning
 349                            late-deprecation-warning
 350                            final-deprecation-warning)
 351                        4))
 352                 (assert-signal (load fasl) warning 3))
 353       (delete-file fasl)
 354       (delete-file source))))