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 (kind name state make-body
  18                                &key (replacements
  19                                      (list (format nil "~A.~A"
  20                                                    name '#:replacement))))
  21   (flet ((search-string (string)
  22            (declare (ignorable string))
  23            #+sb-doc
  24            (dolist (fragment `(,(string name)
  25                                 "deprecated" "as" "of" "SBCL" "1.2.10"
  26                                 "Use"
  27                                 ,@replacements
  28                                 "instead"))
  29              (assert (search fragment string)))))
  30     ;; Check the signaled warning condition.
  31     (let* ((condition)
  32            (function (handler-bind
  33                          ((warning (lambda (c)
  34                                      (setf condition c)
  35                                      (muffle-warning))))
  36                        (compile nil `(lambda ()
  37                                        ,@(funcall make-body name))))))
  38       (assert (typep condition (ecase state
  39                                  (:early 'sb-int:early-deprecation-warning)
  40                                  (:late 'sb-int:late-deprecation-warning)
  41                                  (:final 'sb-int:final-deprecation-warning))))
  42       (search-string (princ-to-string condition))
  43       (ecase state
  44         ((:early :late)
  45          (assert (eq :deprecated (funcall function))))
  46         (:final
  47          (assert-error (funcall function) sb-int:deprecation-error))))
  48     ;; Check the documentation.
  49     (search-string (documentation name kind))))
  50 \f
  51 ;;;; Deprecated variables
  52
  53 (sb-impl::define-deprecated-variable :early "1.2.10"
  54   deprecated-variable.early
  55   :value :deprecated
  56   :replacement deprecated-variable.early.replacement)
  57
  58 (with-test (:name (sb-impl::define-deprecated-variable :early))
  59   (check-deprecated-thing 'variable 'deprecated-variable.early :early
  60                           (lambda (name) `(,name)))
  61   (check-deprecated-thing 'variable 'deprecated-variable.early :early
  62                           (lambda (name) `((symbol-value ',name))))
  63   (check-deprecated-thing 'variable 'deprecated-variable.early :early
  64                           (lambda (name) `((symbol-global-value ',name)))))
  65
  66 (sb-impl::define-deprecated-variable :late "1.2.10"
  67   deprecated-variable.late
  68   :value :deprecated
  69   :replacement deprecated-variable.late.replacement)
  70
  71 (with-test (:name (sb-impl::define-deprecated-variable :late))
  72   (check-deprecated-thing 'variable 'deprecated-variable.late :late
  73                           (lambda (name) `(,name)))
  74   (check-deprecated-thing 'variable 'deprecated-variable.late :late
  75                           (lambda (name) `((symbol-value ',name))))
  76   (check-deprecated-thing 'variable 'deprecated-variable.late :late
  77                           (lambda (name) `((symbol-global-value ',name)))))
  78
  79 (sb-impl::define-deprecated-variable :final "1.2.10"
  80   deprecated-variable.final
  81   :value :deprecated
  82   :replacement deprecated-variable.final.replacement)
  83
  84 (with-test (:name (sb-impl::define-deprecated-variable :final))
  85   (check-deprecated-thing 'variable 'deprecated-variable.final :final
  86                           (lambda (name) `(,name)))
  87   (check-deprecated-thing 'variable 'deprecated-variable.final :final
  88                           (lambda (name) `((symbol-value ',name))))
  89   (check-deprecated-thing 'variable 'deprecated-variable.final :final
  90                           (lambda (name) `((symbol-global-value ',name)))))
  91
  92 \f
  93 ;;;; Deprecated functions
  94
  95 (sb-impl::define-deprecated-function :early "1.2.10"
  96     deprecated-function.early deprecated-function.early.replacement ()
  97   :deprecated)
  98
  99 (with-test (:name (sb-impl::define-deprecated-function :early))
 100   (check-deprecated-thing 'function 'deprecated-function.early :early
 101                           (lambda (name) `((,name)))))
 102
 103 (sb-impl::define-deprecated-function :late "1.2.10"
 104     deprecated-function.late deprecated-function.late.replacement ()
 105   :deprecated)
 106
 107 (with-test (:name (sb-impl::define-deprecated-function :late))
 108   (check-deprecated-thing 'function 'deprecated-function.late :late
 109                           (lambda (name) `((,name)))))
 110
 111 (sb-impl::define-deprecated-function :final "1.2.10"
 112     deprecated-function.final deprecated-function.final.replacement ()
 113   :deprecated)
 114
 115 (with-test (:name (sb-impl::define-deprecated-function :final))
 116   (check-deprecated-thing 'function 'deprecated-function.final :final
 117                           (lambda (name) `((,name)))))
 118
 119 (sb-impl::define-deprecated-function :early "1.2.10"
 120     deprecated-function.two-replacements
 121     (deprecated-function.two-replacements.replacement1
 122      deprecated-function.two-replacements.replacement2)
 123     ()
 124   :deprecated)
 125
 126 (with-test (:name (sb-impl::define-deprecated-function :two-replacements))
 127   (check-deprecated-thing
 128    'function 'deprecated-function.two-replacements :early
 129    (lambda (name) `((,name)))
 130    :replacements '("DEPRECATED-FUNCTION.TWO-REPLACEMENTS.REPLACEMENT1"
 131                    "DEPRECATED-FUNCTION.TWO-REPLACEMENTS.REPLACEMENT2")))
 132
 133 (sb-impl::define-deprecated-function :early "1.2.10"
 134     deprecated-function.three-replacements
 135     (deprecated-function.three-replacements.replacement1
 136      deprecated-function.three-replacements.replacement2
 137      deprecated-function.three-replacements.replacement3)
 138     ()
 139   :deprecated)
 140
 141 (with-test (:name (sb-impl::define-deprecated-function :three-replacements))
 142   (check-deprecated-thing
 143    'function 'deprecated-function.three-replacements :early
 144    (lambda (name) `((,name)))
 145    :replacements '("DEPRECATED-FUNCTION.THREE-REPLACEMENTS.REPLACEMENT1"
 146                    "DEPRECATED-FUNCTION.THREE-REPLACEMENTS.REPLACEMENT2"
 147                    "DEPRECATED-FUNCTION.THREE-REPLACEMENTS.REPLACEMENT3")))
 148
 149
 150 (sb-int:define-deprecated-function :early "1.2.10"
 151   please-dont-use-this moar-better-function (x) (identity x))
 152 (sb-int:define-deprecated-function :late "1.2.10"
 153   really-dont-do-it use-other-thing-instead (x) (identity x))
 154 (sb-int:define-deprecated-function :final "1.2.10"
 155   you-cant-use-this replacement-fn (x) (identity x))
 156
 157 (with-test (:name :introspect-deprecation-stage)
 158   (assert (eq (sb-int:deprecated-thing-p :function 'please-dont-use-this)
 159               :early))
 160   (assert (eq (sb-int:deprecated-thing-p :function 'really-dont-do-it)
 161               :late))
 162   (assert (eq (sb-int:deprecated-thing-p :function 'you-cant-use-this)
 163               :final)))
 164
 165 ;; lp#1439151
 166 (with-test (:name :late-deprecated-fun-doc :skipped-on '(not :sb-doc))
 167   (assert (string= (documentation 'you-cant-use-this 'function)
 168                    (documentation #'you-cant-use-this 'function)))
 169   (assert (string= (documentation 'deprecated-function.late 'function)
 170                    (documentation #'deprecated-function.late 'function)))
 171   (assert (string/= (documentation 'you-cant-use-this 'function)
 172                     (documentation 'deprecated-function.late 'function))))
 173
 174 (with-test (:name :load-time-deprecation-warning)
 175   (let ((source "load-test.tmp") fasl)
 176     (with-open-file (f source :direction :output
 177                        :if-does-not-exist :create :if-exists :supersede)
 178       (write-string "(defun a () (quit))" f)
 179       ;; a full warning even though the PLEASE-DONT- function is only :early
 180       (write-string "(defun b () (please-dont-use-this) (really-dont-do-it))" f)
 181       (write-string "(defun c () (you-cant-use-this))" f))
 182     (unwind-protect
 183          (progn (setq fasl
 184                       (let ((*error-output* (make-broadcast-stream)))
 185                         (compile-file source :verbose nil :print nil)))
 186                 (assert-signal (load fasl) warning))
 187       (delete-file fasl)
 188       (delete-file source))))