From 152b68d61a8d5e616264534fcfad5d6894f3ae3f Mon Sep 17 00:00:00 2001 From: Jan Moringen Date: Tue, 7 Jul 2015 15:08:33 +0200 Subject: [PATCH] Split deprecation "since" into "software" and "version" This is necessary for a user-facing deprecation facility since users want deprecation conditions to say "PKG:FOO has been deprecated as of my-lib 1.2.3" instead of "PKG:FOO has been deprecated as of SBCL 1.2.3" --- package-data-list.lisp-expr | 6 ++-- src/code/condition.lisp | 19 +++++++----- src/code/early-extensions.lisp | 65 ++++++++++++++++++++++++++++-------------- src/code/symbol.lisp | 3 +- src/code/thread.lisp | 6 ++-- src/compiler/policy.lisp | 4 +-- src/compiler/proclaim.lisp | 11 +++---- 7 files changed, 73 insertions(+), 41 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 8242bac51..7c236d523 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -734,7 +734,8 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "DEPRECATED" ; declaration "DEPRECATION-CONDITION" "DEPRECATION-CONDITION-NAME" - "DEPRECATION-CONDITION-SINCE" + "DEPRECATION-CONDITION-SOFTWARE" + "DEPRECATION-CONDITION-VERSION" "DEPRECATION-CONDITION-REPLACEMENTS" "DEPRECATION-CONDITION-RUNTIME-ERROR" "EARLY-DEPRECATION-WARNING" @@ -1086,7 +1087,8 @@ possibly temporarily, because it might be used internally." "DEPRECATION-STATE" "DEPRECATION-INFO" "MAKE-DEPRECATION-INFO" "DEPRECATION-INFO-STATE" - "DEPRECATION-INFO-SINCE" + "DEPRECATION-INFO-SOFTWARE" + "DEPRECATION-INFO-VERSION" "DEPRECATION-INFO-REPLACEMENTS" "PRINT-DEPRECATION-MESSAGE" "CHECK-DEPRECATED-THING" "CHECK-DEPRECATED-TYPE" diff --git a/src/code/condition.lisp b/src/code/condition.lisp index f4c0dd908..488c0e925 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -1530,15 +1530,18 @@ the usual naming convention (names like *FOO*) for special variables" :reader deprecation-condition-name) (replacements :initarg :replacements :reader deprecation-condition-replacements) - (since :initarg :since - :reader deprecation-condition-since) + (software :initarg :software + :reader deprecation-condition-software) + (version :initarg :version + :reader deprecation-condition-version) (runtime-error :initarg :runtime-error :reader deprecation-condition-runtime-error :initform nil)) (:default-initargs :name (missing-arg) :replacements (missing-arg) - :since (missing-arg)) + :software (missing-arg) + :version (missing-arg)) #!+sb-doc (:documentation "Superclass for deprecation-related error and warning @@ -1548,7 +1551,8 @@ conditions.")) (flet ((print-it (stream) (print-deprecation-message (deprecation-condition-name condition) - (deprecation-condition-since condition) + (deprecation-condition-software condition) + (deprecation-condition-version condition) (deprecation-condition-replacements condition) stream))) (if *print-escape* @@ -1570,11 +1574,12 @@ conditions.")) ,@(when check-runtime-error `((deprecation-condition-runtime-error condition)))) (format stream ,format-string + (deprecation-condition-software condition) (deprecation-condition-name condition))))))) (define-deprecation-warning early-deprecation-warning style-warning nil (!uncross-format-control - "~%~@<~:@_In future SBCL versions ~ + "~%~@<~:@_In future ~A versions ~ ~/sb!impl:print-symbol-with-prefix/ will signal a full warning ~ at compile-time.~:@>") #!+sb-doc @@ -1585,7 +1590,7 @@ error.") (define-deprecation-warning late-deprecation-warning warning t (!uncross-format-control - "~%~@<~:@_In future SBCL versions ~ + "~%~@<~:@_In future ~A versions ~ ~/sb!impl:print-symbol-with-prefix/ will signal a runtime ~ error.~:@>") #!+sb-doc @@ -1596,7 +1601,7 @@ error.") (define-deprecation-warning final-deprecation-warning warning t (!uncross-format-control - "~%~@<~:@_An error will be signaled at runtime for ~ + "~%~@<~:@_~*An error will be signaled at runtime for ~ ~/sb!impl:print-symbol-with-prefix/.~:@>") #!+sb-doc "This warning is signaled when the use of a variable, diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 4428fe46c..64e8cecfd 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -1247,6 +1247,21 @@ (deftype deprecation-state () '(member :early :late :final)) +(deftype deprecation-software-and-version () + '(or string (cons string (cons string null)))) + +(defun normalize-deprecation-since (since) + (unless (typep since 'deprecation-software-and-version) + (error 'simple-type-error + :datum since + :expected-type 'deprecation-software-and-version + :format-control "~@" + :format-arguments (list since))) + (if (typep since 'string) + (values "SBCL" since) + (values-list since))) + (defun normalize-deprecation-replacements (replacements) (if (or (not (listp replacements)) (eq 'setf (car replacements))) @@ -1255,12 +1270,14 @@ (defstruct (deprecation-info (:constructor make-deprecation-info - (state since &optional replacement-spec - &aux (replacements (normalize-deprecation-replacements - replacement-spec)))) + (state software version &optional replacement-spec + &aux + (replacements (normalize-deprecation-replacements + replacement-spec)))) (:copier nil)) (state (missing-arg) :type deprecation-state :read-only t) - (since (missing-arg) :type string :read-only t) + (software (missing-arg) :type string :read-only t) + (version (missing-arg) :type string :read-only t) (replacements '() :type list :read-only t)) ;; Return the state of deprecation of the thing identified by @@ -1273,31 +1290,35 @@ (type (info :type :deprecated name))) (when infop (values (deprecation-info-state info) - (deprecation-info-since info) + (list (deprecation-info-software info) + (deprecation-info-version info)) (deprecation-info-replacements info))))) -(defun deprecation-error (since name replacements) +(defun deprecation-error (software version name replacements) (error 'deprecation-error :name name - :replacements (normalize-deprecation-replacements replacements) - :since since)) + :software software + :version version + :replacements (normalize-deprecation-replacements replacements))) -(defun deprecation-warn (state since name replacements +(defun deprecation-warn (state software version name replacements &key (runtime-error (neq :early state))) (warn (ecase state (:early 'early-deprecation-warning) (:late 'late-deprecation-warning) (:final 'final-deprecation-warning)) :name name + :software software + :version version :replacements (normalize-deprecation-replacements replacements) - :since since :runtime-error runtime-error)) (defun check-deprecated-thing (namespace name) (multiple-value-bind (state since replacements) (deprecated-thing-p namespace name) (when state - (deprecation-warn state since name replacements) + (deprecation-warn + state (first since) (second since) name replacements) (values state since replacements)))) ;;; For-effect-only variant of CHECK-DEPRECATED-THING for @@ -1347,8 +1368,8 @@ (%check-deprecated-type name))))) (values)) -(defun deprecated-function (since name replacements &optional doc) - (declare (ignorable since name replacements doc)) +(defun deprecated-function (software version name replacements &optional doc) + (declare (ignorable software version name replacements doc)) #+sb-xc-host (error "Can't define deprecated functions on the host") #-sb-xc-host @@ -1358,7 +1379,7 @@ (set-closure-name (lambda (&rest deprecated-function-args) (declare (ignore deprecated-function-args)) - (deprecation-error since name replacements)) + (deprecation-error software version name replacements)) name))) (when doc (setf (%fun-doc closure) doc)) @@ -1436,11 +1457,12 @@ ;;; - SB-THREAD:JOIN-THREAD-ERROR-THREAD, since 1.0.29.17 (06/2009) -> Final: 09/2012 ;;; - SB-THREAD:INTERRUPT-THREAD-ERROR-THREAD since 1.0.29.17 (06/2009) -> Final: 06/2012 -(defun print-deprecation-message (name since &optional replacements stream) +(defun print-deprecation-message (name software version + &optional replacements stream) (apply #'format stream (!uncross-format-control "~/sb!impl:print-symbol-with-prefix/ has been ~ - deprecated as of SBCL ~A.~ + deprecated as of ~A ~A.~ ~#[~;~ ~2%Use ~/sb!impl:print-symbol-with-prefix/ instead.~;~ ~2%Use ~/sb!impl:print-symbol-with-prefix/ or ~ @@ -1448,7 +1470,7 @@ ~2%Use~@{~#[~; or~] ~ ~/sb!impl:print-symbol-with-prefix/~^,~} instead.~ ~]") - name since replacements)) + name software version replacements)) (defmacro define-deprecated-function (state since name replacements lambda-list &body body) @@ -1458,7 +1480,8 @@ (type (or function-name list) replacements) (type list lambda-list)) (let ((doc (print-deprecation-message - name since (normalize-deprecation-replacements replacements)))) + name "SBCL" since + (normalize-deprecation-replacements replacements)))) (declare (ignorable doc)) `(prog1 ,(ecase state @@ -1470,8 +1493,8 @@ `(progn (declaim (ftype (function * nil) ,name)) (setf (fdefinition ',name) - (deprecated-function ,since ',name ',replacements - #!+sb-doc ,doc)) + (deprecated-function + "SBCL" ,since ',name ',replacements #!+sb-doc ,doc)) ',name))) (proclaim '(deprecated ,state ,since @@ -1493,7 +1516,7 @@ `(:replacement ,replacement))))) #!+sb-doc (setf (fdocumentation ',name 'variable) - ,(print-deprecation-message name since (list replacement))))) + ,(print-deprecation-message name "SBCL" since (list replacement))))) ;; Given DECLS as returned by from parse-body, and SYMBOLS to be bound ;; (with LET, MULTIPLE-VALUE-BIND, etc) return two sets of declarations: diff --git a/src/code/symbol.lisp b/src/code/symbol.lisp index 90b57ecb1..bbb13b179 100644 --- a/src/code/symbol.lisp +++ b/src/code/symbol.lisp @@ -23,7 +23,8 @@ (multiple-value-bind (state since replacements) (check-deprecated-thing 'variable name) (when (eq state :final) - `(deprecation-error ,since ',name '(,@replacements)))))) + `(deprecation-error ,(first since) ,(second since) + ',name '(,@replacements)))))) (defun symbol-value (symbol) #!+sb-doc diff --git a/src/code/thread.lisp b/src/code/thread.lisp index c00ca2fb5..560f49313 100644 --- a/src/code/thread.lisp +++ b/src/code/thread.lisp @@ -93,7 +93,7 @@ stale value, use MUTEX-OWNER instead." (deftype spinlock () #!+sb-doc "Spinlock type." - (deprecation-warn :early "1.0.53.11" 'spinlock 'mutex) + (deprecation-warn :early "SBCL" "1.0.53.11" 'spinlock 'mutex) 'mutex) (define-deprecated-function :early "1.0.53.11" make-spinlock make-mutex (&key name) @@ -115,12 +115,12 @@ stale value, use MUTEX-OWNER instead." (release-mutex lock)) (sb!xc:defmacro with-recursive-spinlock ((lock) &body body) - (deprecation-warn :early "1.0.53.11" 'with-recursive-spinlock 'with-recursive-lock) + (deprecation-warn :early "SBCL" "1.0.53.11" 'with-recursive-spinlock 'with-recursive-lock) `(with-recursive-lock (,lock) ,@body)) (sb!xc:defmacro with-spinlock ((lock) &body body) - (deprecation-warn :early "1.0.53.11" 'with-spinlock 'with-mutex) + (deprecation-warn :early "SBCL" "1.0.53.11" 'with-spinlock 'with-mutex) `(with-mutex (,lock) ,@body)) diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp index 20bc66f58..7e6136fdd 100644 --- a/src/compiler/policy.lisp +++ b/src/compiler/policy.lisp @@ -178,11 +178,11 @@ EXPERIMENTAL INTERFACE: Subject to change." (defun policy-quality-deprecation-warning (quality) (case quality ((stack-allocate-dynamic-extent stack-allocate-vector stack-allocate-value-cells) - (deprecation-warn :late "1.0.19.7" quality '*stack-allocate-dynamic-extent* + (deprecation-warn :late "SBCL" "1.0.19.7" quality '*stack-allocate-dynamic-extent* :runtime-error nil) t) ((merge-tail-calls) - (deprecation-warn :early "1.0.53.74" quality nil :runtime-error nil) + (deprecation-warn :early "SBCL" "1.0.53.74" quality nil :runtime-error nil) t) (otherwise nil))) diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index e31178c82..4d158f1c7 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -206,11 +206,12 @@ of ~{~A~^, ~}.~@:>" :format-arguments (list form state (rest (typexpand 'deprecation-state))))) - (values state since)) + (multiple-value-call #'values + state (sb!impl::normalize-deprecation-since since))) -(defun process-deprecation-declaration (thing state since) +(defun process-deprecation-declaration (thing state software version) (destructuring-bind (namespace name &key replacement) thing - (let ((info (make-deprecation-info state since replacement))) + (let ((info (make-deprecation-info state software version replacement))) (ecase namespace (function (setf (info :function :deprecated name) info)) @@ -306,10 +307,10 @@ (map-args #'process-inline-declaration kind)) (deprecated (destructuring-bind (state since &rest things) args - (multiple-value-bind (state since) + (multiple-value-bind (state software version) (check-deprecation-declaration state since form) (map-names things #'process-deprecation-declaration - state since)))) + state software version)))) (declaration (map-args #'process-declaration-declaration form)) (t -- 2.11.4.GIT