tests/deprecation.internal.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            (let ((start))
  24              (dolist (fragment `(,(string name)
  25                                   "deprecated" "as" "of" "SBCL" "1.2.10"
  26                                   "Use" ,@replacements "instead"))
  27                (let ((match (search fragment string :start2 (or start 0))))
  28                  (assert match)
  29                  (setf start (+ match (length fragment))))))))
  30     ;; Check the signaled warning condition.
  31     (let* ((condition)
  32            (count 0)
  33            (function (handler-bind
  34                          ((warning (lambda (c)
  35                                      (incf count)
  36                                      (setf condition c)
  37                                      (muffle-warning))))
  38                        (compile nil `(lambda ()
  39                                        ,@(funcall make-body name))))))
  40       (assert (= count 1))
  41       (assert (typep condition (ecase state
  42                                  (:early 'early-deprecation-warning)
  43                                  (:late 'late-deprecation-warning)
  44                                  (:final 'final-deprecation-warning))))
  45       (search-string (princ-to-string condition))
  46       (ecase state
  47         ((:early :late)
  48          (assert (eq :deprecated (funcall function))))
  49         (:final
  50          (assert-error (funcall function) deprecation-error))))
  51     ;; Check the documentation.
  52     #+sb-doc
  53     (search-string (documentation name kind))))
  54 \f
  55 ;;;; Deprecated variables
  56
  57 (sb-int:define-deprecated-variable :early "1.2.10"
  58   deprecated-variable.early
  59   :value :deprecated
  60   :replacement deprecated-variable.early.replacement)
  61
  62 (with-test (:name (sb-int:define-deprecated-variable :early))
  63   (check-deprecated-thing 'variable 'deprecated-variable.early :early
  64                           (lambda (name) `(,name)))
  65   (check-deprecated-thing 'variable 'deprecated-variable.early :early
  66                           (lambda (name) `((symbol-value ',name))))
  67   (check-deprecated-thing 'variable 'deprecated-variable.early :early
  68                           (lambda (name) `((symbol-global-value ',name)))))
  69
  70 (sb-int:define-deprecated-variable :late "1.2.10"
  71   deprecated-variable.late
  72   :value :deprecated
  73   :replacement deprecated-variable.late.replacement)
  74
  75 (with-test (:name (sb-int:define-deprecated-variable :late))
  76   (check-deprecated-thing 'variable 'deprecated-variable.late :late
  77                           (lambda (name) `(,name)))
  78   (check-deprecated-thing 'variable 'deprecated-variable.late :late
  79                           (lambda (name) `((symbol-value ',name))))
  80   (check-deprecated-thing 'variable 'deprecated-variable.late :late
  81                           (lambda (name) `((symbol-global-value ',name)))))
  82
  83 (sb-int:define-deprecated-variable :final "1.2.10"
  84   deprecated-variable.final
  85   :value :deprecated
  86   :replacement deprecated-variable.final.replacement)
  87
  88 (with-test (:name (sb-int:define-deprecated-variable :final))
  89   (check-deprecated-thing 'variable 'deprecated-variable.final :final
  90                           (lambda (name) `(,name)))
  91   (check-deprecated-thing 'variable 'deprecated-variable.final :final
  92                           (lambda (name) `((symbol-value ',name))))
  93   (check-deprecated-thing 'variable 'deprecated-variable.final :final
  94                           (lambda (name) `((symbol-global-value ',name)))))
  95
  96 \f
  97 ;;;; Deprecated functions
  98
  99 (sb-int:define-deprecated-function :early "1.2.10"
 100     deprecated-function.early deprecated-function.early.replacement ()
 101   :deprecated)
 102
 103 (with-test (:name (sb-int:define-deprecated-function :early))
 104   (check-deprecated-thing 'function 'deprecated-function.early :early
 105                           (lambda (name) `((,name)))))
 106
 107 (sb-int:define-deprecated-function :late "1.2.10"
 108     deprecated-function.late deprecated-function.late.replacement ()
 109   :deprecated)
 110
 111 (with-test (:name (sb-int:define-deprecated-function :late))
 112   (check-deprecated-thing 'function 'deprecated-function.late :late
 113                           (lambda (name) `((,name)))))
 114
 115 (sb-int:define-deprecated-function :final "1.2.10"
 116     deprecated-function.final deprecated-function.final.replacement ()
 117   :deprecated)
 118
 119 (with-test (:name (sb-int:define-deprecated-function :final))
 120   (check-deprecated-thing 'function 'deprecated-function.final :final
 121                           (lambda (name) `((,name)))))
 122
 123 (sb-int:define-deprecated-function :early "1.2.10"
 124     deprecated-function.two-replacements
 125     (deprecated-function.two-replacements.replacement1
 126      deprecated-function.two-replacements.replacement2)
 127     ()
 128   :deprecated)
 129
 130 (with-test (:name (sb-int:define-deprecated-function :two-replacements))
 131   (check-deprecated-thing
 132    'function 'deprecated-function.two-replacements :early
 133    (lambda (name) `((,name)))
 134    :replacements '("DEPRECATED-FUNCTION.TWO-REPLACEMENTS.REPLACEMENT1"
 135                    "DEPRECATED-FUNCTION.TWO-REPLACEMENTS.REPLACEMENT2")))
 136
 137 (sb-int:define-deprecated-function :early "1.2.10"
 138     deprecated-function.three-replacements
 139     (deprecated-function.three-replacements.replacement1
 140      deprecated-function.three-replacements.replacement2
 141      deprecated-function.three-replacements.replacement3)
 142     ()
 143   :deprecated)
 144
 145 (with-test (:name (sb-int:define-deprecated-function :three-replacements))
 146   (check-deprecated-thing
 147    'function 'deprecated-function.three-replacements :early
 148    (lambda (name) `((,name)))
 149    :replacements '("DEPRECATED-FUNCTION.THREE-REPLACEMENTS.REPLACEMENT1"
 150                    "DEPRECATED-FUNCTION.THREE-REPLACEMENTS.REPLACEMENT2"
 151                    "DEPRECATED-FUNCTION.THREE-REPLACEMENTS.REPLACEMENT3")))
 152
 153 (with-test (:name :deftype-tricky-constant)
 154   (assert-signal (eval '(deftype cows () (if nil 'foo 'sb-thread::spinlock)))
 155                  warning))