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 test (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)
  51                        (or deprecation-error cell-error)))))
  52     ;; Check the documentation.
  53     #+sb-doc
  54     (search-string (documentation name kind))))
  55 \f
  56 ;;;; Deprecated variables
  57
  58 (sb-int:define-deprecated-variable :early "1.2.10"
  59   deprecated-variable.early
  60   :value :deprecated
  61   :replacement deprecated-variable.early.replacement)
  62
  63 (with-test (:name (sb-int:define-deprecated-variable :early))
  64   (test 'variable 'deprecated-variable.early :early
  65                           (lambda (name) `(,name)))
  66   (test 'variable 'deprecated-variable.early :early
  67                           (lambda (name) `((symbol-value ',name))))
  68   (test 'variable 'deprecated-variable.early :early
  69                           (lambda (name) `((symbol-global-value ',name)))))
  70
  71 (sb-int:define-deprecated-variable :late "1.2.10"
  72   deprecated-variable.late
  73   :value :deprecated
  74   :replacement deprecated-variable.late.replacement)
  75
  76 (with-test (:name (sb-int:define-deprecated-variable :late))
  77   (test 'variable 'deprecated-variable.late :late
  78                           (lambda (name) `(,name)))
  79   (test 'variable 'deprecated-variable.late :late
  80                           (lambda (name) `((symbol-value ',name))))
  81   (test 'variable 'deprecated-variable.late :late
  82                           (lambda (name) `((symbol-global-value ',name)))))
  83
  84 (sb-int:define-deprecated-variable :final "1.2.10"
  85   deprecated-variable.final
  86   :value :deprecated
  87   :replacement deprecated-variable.final.replacement)
  88
  89 (with-test (:name (sb-int:define-deprecated-variable :final))
  90   (test 'variable 'deprecated-variable.final :final
  91                           (lambda (name) `(,name)))
  92   (test 'variable 'deprecated-variable.final :final
  93                           (lambda (name) `((symbol-value ',name))))
  94   (test 'variable 'deprecated-variable.final :final
  95                           (lambda (name) `((symbol-global-value ',name)))))
  96
  97 \f
  98 ;;;; Deprecated functions
  99
 100 (sb-int:define-deprecated-function :early "1.2.10"
 101     deprecated-function.early deprecated-function.early.replacement ()
 102   :deprecated)
 103
 104 (with-test (:name (sb-int:define-deprecated-function :early))
 105   (test 'function 'deprecated-function.early :early
 106                           (lambda (name) `((,name)))))
 107
 108 (sb-int:define-deprecated-function :late "1.2.10"
 109     deprecated-function.late deprecated-function.late.replacement ()
 110   :deprecated)
 111
 112 (with-test (:name (sb-int:define-deprecated-function :late))
 113   (test 'function 'deprecated-function.late :late
 114                           (lambda (name) `((,name)))))
 115
 116 (sb-int:define-deprecated-function :final "1.2.10"
 117     deprecated-function.final deprecated-function.final.replacement ()
 118   :deprecated)
 119
 120 (with-test (:name (sb-int:define-deprecated-function :final))
 121   (test 'function 'deprecated-function.final :final
 122                           (lambda (name) `((,name)))))
 123
 124 (sb-int:define-deprecated-function :early "1.2.10"
 125     deprecated-function.two-replacements
 126     (deprecated-function.two-replacements.replacement1
 127      deprecated-function.two-replacements.replacement2)
 128     ()
 129   :deprecated)
 130
 131 (with-test (:name (sb-int:define-deprecated-function :two-replacements))
 132   (test
 133    'function 'deprecated-function.two-replacements :early
 134    (lambda (name) `((,name)))
 135    :replacements '("DEPRECATED-FUNCTION.TWO-REPLACEMENTS.REPLACEMENT1"
 136                    "DEPRECATED-FUNCTION.TWO-REPLACEMENTS.REPLACEMENT2")))
 137
 138 (sb-int:define-deprecated-function :early "1.2.10"
 139     deprecated-function.three-replacements
 140     (deprecated-function.three-replacements.replacement1
 141      deprecated-function.three-replacements.replacement2
 142      deprecated-function.three-replacements.replacement3)
 143     ()
 144   :deprecated)
 145
 146 (with-test (:name (sb-int:define-deprecated-function :three-replacements))
 147   (test
 148    'function 'deprecated-function.three-replacements :early
 149    (lambda (name) `((,name)))
 150    :replacements '("DEPRECATED-FUNCTION.THREE-REPLACEMENTS.REPLACEMENT1"
 151                    "DEPRECATED-FUNCTION.THREE-REPLACEMENTS.REPLACEMENT2"
 152                    "DEPRECATED-FUNCTION.THREE-REPLACEMENTS.REPLACEMENT3")))
 153
 154 (with-test (:name :deftype-tricky-constant)
 155   (assert-signal (eval '(deftype cows () (if nil 'foo 'sb-thread::spinlock)))
 156                  warning))