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           (deprecated :early "1" (variable 1))
  85           (deprecated :early "1" (variable nil))
  86           (deprecated :early "1" (variable :foo))))
  87
  88   ;; These should work.
  89   (mapc (lambda (declaration)
  90           (assert-no-signal (proclaim declaration)))
  91         '((deprecated :early "1")
  92           (deprecated :early ("my-software" "1"))
  93           (deprecated :early "1" (variable deprecated.declaration.variable))
  94           (deprecated :early "1" (function deprecated.declaration.function))
  95           (deprecated :early "1" (function (setf deprecated.declaration.function)))
  96           (deprecated :early "1" (type     deprecated.declaration.type))
  97           (deprecated :early "1" (variable deprecated.declaration.thing1)
  98                                  (variable deprecated.declaration.thing2))
  99           (deprecated :early "1" (variable deprecated.declaration.replacement
 100                                   :replacement deprecated.declaration.replacement))
 101           (deprecated :early "1" (variable deprecated.declaration.replacement
 102                                   :replacement (deprecated.declaration.replacement1
 103                                                 deprecated.declaration.replacement2))))))
 104 \f
 105 ;;;; Deprecated variables
 106
 107 (macrolet
 108     ((definition.undefined (variable-name)
 109        (declare (ignore variable-name))
 110        ())
 111      (definition.declaimed-special (variable-name)
 112        `(declaim (special ,variable-name)))
 113      (definition.defvar (variable-name)
 114        `(defvar ,variable-name :deprecated))
 115      (definition.defglobal (variable-name)
 116        `(defglobal ,variable-name :deprecated))
 117      (definition.defconstant (variable-name)
 118        `(defconstant ,variable-name :deprecated))
 119      (definition.define-symbol-macro (variable-name)
 120        `(define-symbol-macro ,variable-name :deprecated))
 121      (define-variable-tests (tag definition-name &rest args)
 122        (flet ((make-test-case (tag state
 123                                    &key
 124                                    (call t)
 125                                    (symbol-value t)
 126                                    (check-describe t))
 127                 (let ((variable-name (sb-int::symbolicate
 128                                       '#:variable. tag '#:. state))
 129                       (replacement   'replacement))
 130                   `(,@(unless (eq state :final)
 131                         `((,definition-name ,variable-name)))
 132                     (declaim (deprecated
 133                               ,state ("some-lib" "1.2.3")
 134                               (variable ,variable-name
 135                                         :replacement ,replacement)))
 136
 137                     (with-test (:name (deprecated variable ,tag ,state))
 138                       (test
 139                        'variable ',variable-name ,state
 140                        (lambda (name) `(,name))
 141                        :replacements   '(,(string replacement))
 142                        :call           ,call
 143                        :check-describe ,check-describe)
 144                       ,@(when symbol-value
 145                           `((test
 146                              'variable ',variable-name ,state
 147                              (lambda (name) `((symbol-value ',name)))
 148                              :replacements   '(,(string replacement))
 149                              :call           ,call
 150                              :check-describe ,check-describe)
 151                             (test
 152                              'variable ',variable-name ,state
 153                              (lambda (name) `((symbol-global-value ',name)))
 154                              :replacements   '(,(string replacement))
 155                              :call           ,call
 156                              :check-describe ,check-describe))))))))
 157          `(progn
 158             ,@(apply #'make-test-case tag :early args)
 159             ,@(apply #'make-test-case tag :late args)
 160             ,@(apply #'make-test-case tag :final :check-describe t args)))))
 161
 162   (define-variable-tests :undefined          definition.undefined
 163     :call nil :check-describe nil)
 164   (define-variable-tests :declaimed-special  definition.declaimed-special
 165     :call nil)
 166   (define-variable-tests defvar              definition.defvar)
 167   (define-variable-tests defglobal           definition.defglobal)
 168   (define-variable-tests defconstant         definition.defconstant)
 169   (define-variable-tests define-symbol-macro definition.define-symbol-macro
 170     :symbol-value nil))
 171   \f
 172 ;;;; Deprecated functions
 173
 174 (macrolet
 175     ((definition.undefined (function-name)
 176        (declare (ignore function-name))
 177        ())
 178      (definition.declaimed-ftype (function-name)
 179        `(declaim (ftype (function () (values keyword &optional))
 180                         ,function-name)))
 181      (definition.defun (function-name)
 182        `(defun ,function-name () :deprecated))
 183      (definition.defmacro (function-name)
 184        `(defmacro ,function-name () :deprecated))
 185      (define-function-tests (tag definition-name &rest args)
 186        (flet ((make-test-case (tag state
 187                                    &key
 188                                    (call t)
 189                                    (check-describe t))
 190                 (let ((function-name (sb-int::symbolicate
 191                                       '#:function. tag '#:. state))
 192                       (replacement   'replacement))
 193                   `(,@(unless (eq state :final)
 194                         `((,definition-name ,function-name)))
 195                     (declaim (deprecated
 196                               ,state ("some-lib" "1.2.3")
 197                               (function ,function-name
 198                                         :replacement ,replacement)))
 199
 200                     (with-test (:name (deprecated function ,tag ,state))
 201                       (test
 202                        'function ',function-name ,state
 203                        (lambda (name) `((,name)))
 204                        :replacements   '(,(string replacement))
 205                        :call           ,call
 206                        :check-describe ,check-describe))))))
 207          `(progn
 208             ,@(apply #'make-test-case tag :early args)
 209             ,@(apply #'make-test-case tag :late args)
 210             ,@(apply #'make-test-case tag :final :check-describe t args)))))
 211
 212   (define-function-tests :undefined       definition.undefined
 213     :call nil :check-describe nil)
 214   (define-function-tests :declaimed-ftype definition.declaimed-ftype
 215     :call nil :check-describe nil)
 216   (define-function-tests defun            definition.defun)
 217   (define-function-tests defmacro         definition.defmacro))
 218 \f
 219 ;;;; Deprecated types
 220
 221 (macrolet
 222     ((definition.undefined (type-name)
 223        (declare (ignore type-name))
 224        ())
 225      (definition.deftype.empty-body (type-name)
 226        `(deftype ,type-name ()))
 227      (definition.deftype.t-body (type-name)
 228        `(deftype ,type-name () t))
 229      (definition.defclass (type-name)
 230        `(defclass ,type-name () ()))
 231      (definition.defstruct (type-name)
 232        `(defstruct ,type-name))
 233      (definition.define-condition (type-name)
 234        `(define-condition ,type-name () ()))
 235      (define-type-tests (tag definition-name method class &rest args)
 236        (flet ((make-test-case (tag state &key check-describe)
 237                 (let* ((method (and method (not (eq state :final))))
 238                        (class (and class (not (eq state :final))))
 239                        (type-name (apply #'sb-int::symbolicate
 240                                          (append '(#:type.)
 241                                                  (sb-int:ensure-list tag)
 242                                                  (list '#:. state (gensym)))))
 243                        (extra-warning-count (+ (if method 1 0) (if class 1 0)))
 244                        (replacement 'replacement))
 245                   `(,@(unless (eq state :final)
 246                         `((,definition-name ,type-name)))
 247                     (declaim (deprecated
 248                               ,state ("some-lib" "1.2.3")
 249                               (type ,type-name
 250                                     :replacement ,replacement)))
 251
 252                     (test-util:with-test (:name (deprecated type
 253                                                  ,@(sb-int:ensure-list tag)
 254                                                  ,state))
 255                       (test
 256                        'type ',type-name ,state
 257                        (lambda (name)
 258                          `((let ((x))
 259                              (declare (type (or null ,name) x)
 260                                       (ignore x)))
 261                            (typep nil ',name)
 262                            ,@,(when method
 263                                 '`((defmethod ,(gensym) ((x ,name)))))
 264                            ,@,(when class
 265                                 '`((defclass ,(gensym) (,name) ())))))
 266                        :replacements           '(,(string replacement))
 267                        :call                   nil
 268                        :expected-warning-count '(integer
 269                                                  ,(+ 2 extra-warning-count)
 270                                                  ,(+ 4 extra-warning-count))
 271                        :check-describe         ,check-describe))))))
 272          `(progn
 273             ,@(apply #'make-test-case tag :early args)
 274             ,@(apply #'make-test-case tag :late  args)
 275             ,@(apply #'make-test-case tag :final :check-describe t args)))))
 276
 277   (define-type-tests :undefined            definition.undefined          nil nil
 278     :check-describe nil)
 279   (define-type-tests (deftype :empty-body) definition.deftype.empty-body nil nil)
 280   (define-type-tests (deftype :t-body)     definition.deftype.t-body     nil nil)
 281   (define-type-tests defclass              definition.defclass           t   t)
 282   (define-type-tests defstruct             definition.defstruct          t   nil)
 283   (define-type-tests define-condition      definition.define-condition   t   nil))
 284
 285 (with-test (:name (deprecated type :unrelated-class))
 286   (let ((name (gensym)))
 287     (eval `(progn
 288              (deftype ,name () 'integer)
 289              (declaim (deprecated :early ("some-lib" "1.2.3") (type ,name)))))
 290     ;; Make sure the deprecation declaration works.
 291     (test
 292      'type name :early
 293      (lambda (name)
 294        `((typep 1 ',name)))
 295      :call nil)
 296     ;; Check that the declaration does not apply to an unrelated class
 297     ;; of the same name.
 298     (test
 299      'type name :early
 300      (lambda (name)
 301        `((make-instance ,(make-instance 'standard-class :name name))))
 302      :call                   nil
 303      :expected-warning-count '(eql 0))))
 304
 305 \f
 306 ;;;; Loader deprecation warnings
 307
 308 (defun please-dont-use-this (x)
 309   (identity x))
 310 (declaim (deprecated :early "1.2.10"
 311                      (function please-dont-use-this
 312                                :replacement moar-better-function)))
 313
 314 (defun really-dont-do-it (x)
 315   (identity x))
 316 (declaim (deprecated :late "1.2.10"
 317                      (function really-dont-do-it
 318                                :replacement use-other-thing-instead)))
 319
 320 (defun you-cant-use-this (x)
 321   (identity x))
 322 (declaim (deprecated :final "1.2.10"
 323                      (function you-cant-use-this
 324                                :replacement replacement-fn)))
 325
 326 (with-test (:name :introspect-deprecation-stage)
 327   (assert (eq (sb-int:deprecated-thing-p 'function 'please-dont-use-this)
 328               :early))
 329   (assert (eq (sb-int:deprecated-thing-p 'function 'really-dont-do-it)
 330               :late))
 331   (assert (eq (sb-int:deprecated-thing-p 'function 'you-cant-use-this)
 332               :final)))
 333
 334 (with-test (:name (:late-deprecated-fun-doc :bug-1439151)
 335                   :skipped-on (not :sb-doc))
 336   (assert (string= (documentation 'you-cant-use-this 'function)
 337                    (documentation #'you-cant-use-this 'function)))
 338   (assert (string= (documentation 'function.defun.late 'function)
 339                    (documentation #'function.defun.late 'function)))
 340   (assert (string/= (documentation 'you-cant-use-this 'function)
 341                     (documentation 'function.defun.late 'function))))
 342
 343 (with-test (:name :load-time-deprecation-warning)
 344   (let ((source "load-test.tmp") fasl)
 345     (with-open-file (f source :direction :output
 346                        :if-does-not-exist :create :if-exists :supersede)
 347       (write-string "(defun a () (sb-unix:unix-exit))" f)
 348       ;; a full warning even though the PLEASE-DONT- function is only :early
 349       (write-string "(defun b () (please-dont-use-this 1) (really-dont-do-it 2))" f)
 350       (write-string "(defun c () (you-cant-use-this 3))" f))
 351     ;; We expect four deprecation warnings from compiling the source
 352     ;; (four uses of deprecated things) and three from loading it
 353     ;; (loading three functions that contain uses of deprecated
 354     ;; things).
 355     (unwind-protect
 356          (progn (setq fasl
 357                       (assert-signal
 358                        (compile-file source :verbose nil :print nil)
 359                        (or early-deprecation-warning
 360                            late-deprecation-warning
 361                            final-deprecation-warning)
 362                        4))
 363                 (assert-signal (load fasl) warning 3))
 364       (delete-file fasl)
 365       (delete-file source))))