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 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))))