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 test (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)
  63                            (or deprecation-error cell-error)))))))
  64     ;; Check DESCRIBE output.
  65     (when check-describe
  66       (search-string/describe (with-output-to-string (stream)
  67                                 (describe name stream))))
  68     ;; Check DOCUMENTATION.
  69     (search-string/documentation (documentation name namespace))))
  70 \f
  71 ;;;; DEPRECATED declaration syntax
  72
  73 (with-test (:name (deprecated :declaration :syntax))
  74   ;; Some syntax errors.
  75   (mapc (lambda (declaration)
  76           (assert-error (proclaim declaration)))
  77         '((deprecated)
  78           (deprecated :early)
  79           (deprecated :early 1)
  80           (deprecated :early ("1"))
  81           (deprecated :early ("a" "b" "c"))
  82           (deprecated :early 1 (function))
  83           (deprecated :early 1 (unsupported-namespace name))))
  84
  85   ;; These should work.
  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))))))
 101 \f
 102 ;;;; Deprecated variables
 103
 104 (macrolet
 105     ((definition.undefined (variable-name)
 106        (declare (ignore variable-name))
 107        ())
 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
 120                                    &key
 121                                    (call t)
 122                                    (symbol-value t)
 123                                    (check-describe t))
 124                 (let ((variable-name (sb-int::symbolicate
 125                                       '#:variable. tag '#:. state))
 126                       (replacement   'replacement))
 127                   `(,@(unless (eq state :final)
 128                         `((,definition-name ,variable-name)))
 129                     (declaim (deprecated
 130                               ,state ("some-lib" "1.2.3")
 131                               (variable ,variable-name
 132                                         :replacement ,replacement)))
 133
 134                     (with-test (:name (deprecated variable ,tag ,state))
 135                       (test
 136                        'variable ',variable-name ,state
 137                        (lambda (name) `(,name))
 138                        :replacements   '(,(string replacement))
 139                        :call           ,call
 140                        :check-describe ,check-describe)
 141                       ,@(when symbol-value
 142                           `((test
 143                              'variable ',variable-name ,state
 144                              (lambda (name) `((symbol-value ',name)))
 145                              :replacements   '(,(string replacement))
 146                              :call           ,call
 147                              :check-describe ,check-describe)
 148                             (test
 149                              'variable ',variable-name ,state
 150                              (lambda (name) `((symbol-global-value ',name)))
 151                              :replacements   '(,(string replacement))
 152                              :call           ,call
 153                              :check-describe ,check-describe))))))))
 154          `(progn
 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)))))
 158
 159   (define-variable-tests :undefined          definition.undefined
 160     :call nil :check-describe nil)
 161   (define-variable-tests :declaimed-special  definition.declaimed-special
 162     :call nil)
 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
 167     :symbol-value nil))
 168   \f
 169 ;;;; Deprecated functions
 170
 171 (macrolet
 172     ((definition.undefined (function-name)
 173        (declare (ignore function-name))
 174        ())
 175      (definition.declaimed-ftype (function-name)
 176        `(declaim (ftype (function () (values keyword &optional))
 177                         ,function-name)))
 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
 184                                    &key
 185                                    (call t)
 186                                    (check-describe t))
 187                 (let ((function-name (sb-int::symbolicate
 188                                       '#:function. tag '#:. state))
 189                       (replacement   'replacement))
 190                   `(,@(unless (eq state :final)
 191                         `((,definition-name ,function-name)))
 192                     (declaim (deprecated
 193                               ,state ("some-lib" "1.2.3")
 194                               (function ,function-name
 195                                         :replacement ,replacement)))
 196
 197                     (with-test (:name (deprecated function ,tag ,state))
 198                       (test
 199                        'function ',function-name ,state
 200                        (lambda (name) `((,name)))
 201                        :replacements   '(,(string replacement))
 202                        :call           ,call
 203                        :check-describe ,check-describe))))))
 204          `(progn
 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)))))
 208
 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))
 215 \f
 216 ;;;; Deprecated types
 217
 218 (macrolet
 219     ((definition.undefined (type-name)
 220        (declare (ignore type-name))
 221        ())
 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
 237                                          (append '(#:type.)
 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)))
 244                     (declaim (deprecated
 245                               ,state ("some-lib" "1.2.3")
 246                               (type ,type-name
 247                                     :replacement ,replacement)))
 248
 249                     (test-util:with-test (:name (deprecated type
 250                                                  ,@(sb-int:ensure-list tag)
 251                                                  ,state))
 252                       (test
 253                        'type ',type-name ,state
 254                        (lambda (name)
 255                          `((let ((x))
 256                              (declare (type (or null ,name) x)
 257                                       (ignore x)))
 258                            (typep nil ',name)
 259                            ,@,(when method
 260                                 '`((defmethod ,(gensym) ((x ,name)))))
 261                            ,@,(when class
 262                                 '`((defclass ,(gensym) (,name) ())))))
 263                        :replacements           '(,(string replacement))
 264                        :call                   nil
 265                        :expected-warning-count '(integer
 266                                                  ,(+ 2 extra-warning-count)
 267                                                  ,(+ 4 extra-warning-count))
 268                        :check-describe         ,check-describe))))))
 269          `(progn
 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)))))
 273
 274   (define-type-tests :undefined            definition.undefined          nil nil
 275     :check-describe 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))
 281
 282 (with-test (:name (deprecated type :unrelated-class))
 283   (let ((name (gensym)))
 284     (eval `(progn
 285              (deftype ,name () 'integer)
 286              (declaim (deprecated :early ("some-lib" "1.2.3") (type ,name)))))
 287     ;; Make sure the deprecation declaration works.
 288     (test
 289      'type name :early
 290      (lambda (name)
 291        `((typep 1 ',name)))
 292      :call nil)
 293     ;; Check that the declaration does not apply to an unrelated class
 294     ;; of the same name.
 295     (test
 296      'type name :early
 297      (lambda (name)
 298        `((make-instance ,(make-instance 'standard-class :name name))))
 299      :call                   nil
 300      :expected-warning-count '(eql 0))))
 301
 302 \f
 303 ;;;; Loader deprecation warnings
 304
 305 (defun please-dont-use-this (x)
 306   (identity x))
 307 (declaim (deprecated :early "1.2.10"
 308                      (function please-dont-use-this
 309                                :replacement moar-better-function)))
 310
 311 (defun really-dont-do-it (x)
 312   (identity x))
 313 (declaim (deprecated :late "1.2.10"
 314                      (function really-dont-do-it
 315                                :replacement use-other-thing-instead)))
 316
 317 (defun you-cant-use-this (x)
 318   (identity x))
 319 (declaim (deprecated :final "1.2.10"
 320                      (function you-cant-use-this
 321                                :replacement replacement-fn)))
 322
 323 (with-test (:name :introspect-deprecation-stage)
 324   (assert (eq (sb-int:deprecated-thing-p 'function 'please-dont-use-this)
 325               :early))
 326   (assert (eq (sb-int:deprecated-thing-p 'function 'really-dont-do-it)
 327               :late))
 328   (assert (eq (sb-int:deprecated-thing-p 'function 'you-cant-use-this)
 329               :final)))
 330
 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))))
 339
 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
 351     ;; things).
 352     (unwind-protect
 353          (progn (setq fasl
 354                       (assert-signal
 355                        (compile-file source :verbose nil :print nil)
 356                        (or early-deprecation-warning
 357                            late-deprecation-warning
 358                            final-deprecation-warning)
 359                        4))
 360                 (assert-signal (load fasl) warning 3))
 361       (delete-file fasl)
 362       (delete-file source))))