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                         "Use" ,@replacements "instead")))
  33            (search-string/describe (string)
  34              (search-string
  35               string `(,(string name) ,(string state)
  36                         "deprecation" "since" "some-lib" "version" "1.2.3"))))
  37     ;; Check the signaled warning condition.
  38     (let* ((condition)
  39            (count 0)
  40            (function (handler-bind
  41                          ((deprecation-condition (lambda (c)
  42                                                    (incf count)
  43                                                    (setf condition c)
  44                                                    (muffle-warning)))
  45                           (warning 'muffle-warning))
  46                        (compile nil `(lambda ()
  47                                        ,@(funcall make-body name))))))
  48       (assert (typep count expected-warning-count))
  49       (assert (typep condition (ecase state
  50                                  (:early 'early-deprecation-warning)
  51                                  (:late 'late-deprecation-warning)
  52                                  (:final 'final-deprecation-warning))))
  53       (search-string/documentation (princ-to-string condition))
  54       (when call
  55         (ecase state
  56           ((:early :late)
  57            (assert (eq :deprecated (funcall function))))
  58           (:final
  59            (assert-error (funcall function) deprecation-error)))))
  60     ;; Check DESCRIBE output.
  61     (when check-describe
  62       (search-string/describe (with-output-to-string (stream)
  63                                 (describe name stream))))
  64     ;; Check DOCUMENTATION.
  65     (search-string/documentation (documentation name namespace))))
  66 \f
  67 ;;;; DEPRECATED declaration syntax
  68
  69 (with-test (:name (deprecated :declaration :syntax))
  70   ;; Some syntax errors.
  71   (mapc (lambda (declaration)
  72           (assert-error (proclaim declaration)))
  73         '((deprecated)
  74           (deprecated :early)
  75           (deprecated :early 1)
  76           (deprecated :early ("1"))
  77           (deprecated :early ("a" "b" "c"))
  78           (deprecated :early 1 (function))
  79           (deprecated :early 1 (unsupported-namespace name))))
  80
  81   ;; These should work.
  82   (mapc (lambda (declaration)
  83           (assert-no-signal (proclaim declaration)))
  84         '((deprecated :early "1")
  85           (deprecated :early ("my-software" "1"))
  86           (deprecated :early "1" (variable deprecated.declaration.variable))
  87           (deprecated :early "1" (function deprecated.declaration.function))
  88           (deprecated :early "1" (function (setf deprecated.declaration.function)))
  89           (deprecated :early "1" (type     deprecated.declaration.type))
  90           (deprecated :early "1" (variable deprecated.declaration.thing1)
  91                                  (variable deprecated.declaration.thing2))
  92           (deprecated :early "1" (variable deprecated.declaration.replacement
  93                                   :replacement deprecated.declaration.replacement))
  94           (deprecated :early "1" (variable deprecated.declaration.replacement
  95                                   :replacement (deprecated.declaration.replacement1
  96                                                 deprecated.declaration.replacement2))))))
  97 \f
  98 ;;;; Deprecated variables
  99
 100 (macrolet
 101     ((definition.undefined (variable-name)
 102        (declare (ignore variable-name))
 103        ())
 104      (definition.declaimed-special (variable-name)
 105        `(declaim (special ,variable-name)))
 106      (definition.defvar (variable-name)
 107        `(defvar ,variable-name :deprecated))
 108      (definition.defglobal (variable-name)
 109        `(defglobal ,variable-name :deprecated))
 110      (definition.defconstant (variable-name)
 111        `(defconstant ,variable-name :deprecated))
 112      (definition.define-symbol-macro (variable-name)
 113        `(define-symbol-macro ,variable-name :deprecated))
 114      (define-variable-tests (tag definition-name &rest args)
 115        (flet ((make-test-case (tag state
 116                                    &key
 117                                    (call t)
 118                                    (symbol-value t)
 119                                    (check-describe t))
 120                 (let ((variable-name (sb-int::symbolicate
 121                                       '#:variable. tag '#:. state))
 122                       (replacement   'replacement))
 123                   `(,@(unless (eq state :final)
 124                         `((,definition-name ,variable-name)))
 125                     (declaim (deprecated
 126                               ,state ("some-lib" "1.2.3")
 127                               (variable ,variable-name
 128                                         :replacement ,replacement)))
 129
 130                     (with-test (:name (deprecated variable ,tag ,state))
 131                       (check-deprecated-thing
 132                        'variable ',variable-name ,state
 133                        (lambda (name) `(,name))
 134                        :replacements   '(,(string replacement))
 135                        :call           ,call
 136                        :check-describe ,check-describe)
 137                       ,@(when symbol-value
 138                           `((check-deprecated-thing
 139                              'variable ',variable-name ,state
 140                              (lambda (name) `((symbol-value ',name)))
 141                              :replacements   '(,(string replacement))
 142                              :call           ,call
 143                              :check-describe ,check-describe)
 144                             (check-deprecated-thing
 145                              'variable ',variable-name ,state
 146                              (lambda (name) `((symbol-global-value ',name)))
 147                              :replacements   '(,(string replacement))
 148                              :call           ,call
 149                              :check-describe ,check-describe))))))))
 150          `(progn
 151             ,@(apply #'make-test-case tag :early args)
 152             ,@(apply #'make-test-case tag :late args)
 153             ,@(apply #'make-test-case tag :final :check-describe t args)))))
 154
 155   (define-variable-tests :undefined          definition.undefined
 156     :call nil :check-describe nil)
 157   (define-variable-tests :declaimed-special  definition.declaimed-special
 158     :call nil)
 159   (define-variable-tests defvar              definition.defvar)
 160   (define-variable-tests defglobal           definition.defglobal)
 161   (define-variable-tests defconstant         definition.defconstant)
 162   (define-variable-tests define-symbol-macro definition.define-symbol-macro
 163     :symbol-value nil))
 164   \f
 165 ;;;; Deprecated functions
 166
 167 (macrolet
 168     ((definition.undefined (function-name)
 169        (declare (ignore function-name))
 170        ())
 171      (definition.declaimed-ftype (function-name)
 172        `(declaim (ftype (function () (values keyword &optional))
 173                         ,function-name)))
 174      (definition.defun (function-name)
 175        `(defun ,function-name () :deprecated))
 176      (definition.defmacro (function-name)
 177        `(defmacro ,function-name () :deprecated))
 178      (define-function-tests (tag definition-name &rest args)
 179        (flet ((make-test-case (tag state
 180                                    &key
 181                                    (call t)
 182                                    (check-describe t))
 183                 (let ((function-name (sb-int::symbolicate
 184                                       '#:function. tag '#:. state))
 185                       (replacement   'replacement))
 186                   `(,@(unless (eq state :final)
 187                         `((,definition-name ,function-name)))
 188                     (declaim (deprecated
 189                               ,state ("some-lib" "1.2.3")
 190                               (function ,function-name
 191                                         :replacement ,replacement)))
 192
 193                     (with-test (:name (deprecated function ,tag ,state))
 194                       (check-deprecated-thing
 195                        'function ',function-name ,state
 196                        (lambda (name) `((,name)))
 197                        :replacements   '(,(string replacement))
 198                        :call           ,call
 199                        :check-describe ,check-describe))))))
 200          `(progn
 201             ,@(apply #'make-test-case tag :early args)
 202             ,@(apply #'make-test-case tag :late args)
 203             ,@(apply #'make-test-case tag :final :check-describe t args)))))
 204
 205   (define-function-tests :undefined       definition.undefined
 206     :call nil :check-describe nil)
 207   (define-function-tests :declaimed-ftype definition.declaimed-ftype
 208     :call nil :check-describe nil)
 209   (define-function-tests defun            definition.defun)
 210   (define-function-tests defmacro         definition.defmacro))
 211 \f
 212 ;;;; Deprecated types
 213
 214 (macrolet
 215     ((definition.undefined (type-name)
 216        (declare (ignore type-name))
 217        ())
 218      (definition.deftype.empty-body (type-name)
 219        `(deftype ,type-name ()))
 220      (definition.deftype.t-body (type-name)
 221        `(deftype ,type-name () t))
 222      (definition.defclass (type-name)
 223        `(defclass ,type-name () ()))
 224      (definition.defstruct (type-name)
 225        `(defstruct ,type-name))
 226      (definition.define-condition (type-name)
 227        `(define-condition ,type-name () ()))
 228      (define-type-tests (tag definition-name &rest args)
 229        (flet ((make-test-case (tag state &key check-describe)
 230                 (let ((type-name (apply #'sb-int::symbolicate
 231                                         (append '(#:type.)
 232                                                 (sb-int:ensure-list tag)
 233                                                 (list '#:. state (gensym)))))
 234                       (replacement   'replacement))
 235                   `(,@(unless (eq state :final)
 236                         `((,definition-name ,type-name)))
 237                     (declaim (deprecated
 238                               ,state ("some-lib" "1.2.3")
 239                               (type ,type-name
 240                                     :replacement ,replacement)))
 241
 242                     (test-util:with-test (:name (deprecated type
 243                                                  ,@(sb-int:ensure-list tag)
 244                                                  ,state))
 245                       (check-deprecated-thing
 246                        'type ',type-name ,state
 247                        (lambda (name)
 248                          `((let ((x))
 249                              (declare (type (or null ,name) x)))
 250                            (typep nil ',name)
 251                            (defmethod ,(gensym) ((x ,name)))
 252                            (defclass ,(gensym) (,name) ())))
 253                        :replacements           '(,(string replacement))
 254                        :call                   nil
 255                        :expected-warning-count '(integer 4 6)
 256                        :check-describe         ,check-describe))))))
 257          `(progn
 258             ,@(apply #'make-test-case tag :early args)
 259             ,@(apply #'make-test-case tag :late  args)
 260             ,@(apply #'make-test-case tag :final :check-describe t args)))))
 261
 262   (define-type-tests :undefined            definition.undefined
 263     :check-describe nil)
 264   (define-type-tests (deftype :empty-body) definition.deftype.empty-body)
 265   (define-type-tests (deftype :t-body)     definition.deftype.t-body)
 266   (define-type-tests defclass              definition.defclass)
 267   (define-type-tests defstruct             definition.defstruct)
 268   (define-type-tests define-condition      definition.define-condition))
 269 \f
 270 ;;;; Loader deprecation warnings
 271
 272 (defun please-dont-use-this (x)
 273   (identity x))
 274 (declaim (deprecated :early "1.2.10"
 275                      (function please-dont-use-this
 276                                :replacement moar-better-function)))
 277
 278 (defun really-dont-do-it (x)
 279   (identity x))
 280 (declaim (deprecated :late "1.2.10"
 281                      (function really-dont-do-it
 282                                :replacement use-other-thing-instead)))
 283
 284 (defun you-cant-use-this (x)
 285   (identity x))
 286 (declaim (deprecated :final "1.2.10"
 287                      (function you-cant-use-this
 288                                :replacement replacement-fn)))
 289
 290 (with-test (:name :introspect-deprecation-stage)
 291   (assert (eq (sb-int:deprecated-thing-p 'function 'please-dont-use-this)
 292               :early))
 293   (assert (eq (sb-int:deprecated-thing-p 'function 'really-dont-do-it)
 294               :late))
 295   (assert (eq (sb-int:deprecated-thing-p 'function 'you-cant-use-this)
 296               :final)))
 297
 298 (with-test (:name (:late-deprecated-fun-doc :bug-1439151)
 299                   :skipped-on '(not :sb-doc))
 300   (assert (string= (documentation 'you-cant-use-this 'function)
 301                    (documentation #'you-cant-use-this 'function)))
 302   (assert (string= (documentation 'function.defun.late 'function)
 303                    (documentation #'function.defun.late 'function)))
 304   (assert (string/= (documentation 'you-cant-use-this 'function)
 305                     (documentation 'function.defun.late 'function))))
 306
 307 (with-test (:name :load-time-deprecation-warning)
 308   (let ((source "load-test.tmp") fasl)
 309     (with-open-file (f source :direction :output
 310                        :if-does-not-exist :create :if-exists :supersede)
 311       (write-string "(defun a () (quit))" f)
 312       ;; a full warning even though the PLEASE-DONT- function is only :early
 313       (write-string "(defun b () (please-dont-use-this 1) (really-dont-do-it 2))" f)
 314       (write-string "(defun c () (you-cant-use-this 3))" f))
 315     ;; We expect four deprecation warnings from compiling the source
 316     ;; (four uses of deprecated things) and three from loading it
 317     ;; (loading three functions that contain uses of deprecated
 318     ;; things).
 319     (unwind-protect
 320          (progn (setq fasl
 321                       (assert-signal
 322                        (compile-file source :verbose nil :print nil)
 323                        (or early-deprecation-warning
 324                            late-deprecation-warning
 325                            final-deprecation-warning)
 326                        4))
 327                 (assert-signal (load fasl) warning 3))
 328       (delete-file fasl)
 329       (delete-file source))))