Menu
▾
▴
[Sbcl-commits] master: DEFINE-DEPRECATED-{FUNCTION, VARIABLE} improvements
|
From: Jan M. <sc...@us...> - 2015-03-01 03:39:38
|
The branch "master" has been updated in SBCL:
via 307d72de43717e632abaad96f18a163f283cd17c (commit)
from 1ca37cfba3ce983ac96fb79b838edbdadffd9a7b (commit)
- Log -----------------------------------------------------------------
commit 307d72de43717e632abaad96f18a163f283cd17c
Author: Jan Moringen <jmo...@te...>
Date: Mon Feb 23 00:16:45 2015 +0100
DEFINE-DEPRECATED-{FUNCTION,VARIABLE} improvements
* At runtime, deprecated variables in the :FINAL state behave like
functions in that state: instead of an "undefined variable" error, a
DEPRECATION-ERROR is signaled.
* GLOBAL-SYMBOL-VALUE checks for deprecated variables at compile-time
like SYMBOL-MACRO already did.
* DEFINE-DEPRECATED-FUNCTION calls DEPRECATED-FUNCTION correctly and
checks argument types.
* Some technicalities:
* Moved PRINT-SYMBOL-WITH-PREFIX to early-extensions.lisp to make it
available in the deprecation machinery.
* DEFINE-DEPRECATED-VARIABLE checks argument types.
* Added tests.
---
src/code/early-extensions.lisp | 100 +++++++++++++++++++++++------------
src/code/early-format.lisp | 11 ----
src/code/symbol.lisp | 20 ++++++-
src/compiler/ir1tran.lisp | 42 +++++++++------
tests/deprecation.impure.lisp | 112 ++++++++++++++++++++++++++++++++++++++++
5 files changed, 220 insertions(+), 65 deletions(-)
diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index 89f9c4e..9e079b7 100644
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -1095,6 +1095,17 @@
:type t
:identity ,identity)
,@(nreverse reversed-prints))))))
+
+(defun print-symbol-with-prefix (stream symbol colon at)
+ #!+sb-doc
+ "For use with ~/: Write SYMBOL to STREAM as if it is not accessible from
+ the current package."
+ (declare (ignore colon at))
+ ;; Only keywords should be accessible from the keyword package, and
+ ;; keywords are always printed with colons, so this guarantees that the
+ ;; symbol will not be printed without a prefix.
+ (let ((*package* *keyword-package*))
+ (write symbol :stream stream :escape t)))
;;;; etc.
@@ -1183,51 +1194,72 @@
;;; - 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
-(defmacro define-deprecated-function (state since name replacements lambda-list &body body)
+(deftype deprecation-state ()
+ '(member :early :late :final))
+
+(defmacro define-deprecated-function (state since name replacements lambda-list
+ &body body)
+ (declare (type deprecation-state state)
+ (type string since)
+ (type function-name name)
+ (type (or function-name list) replacements)
+ (type list lambda-list))
(let* ((replacements (normalize-deprecation-replacements replacements))
#!+sb-doc
(doc
- (let ((*package* (find-package :keyword))
- (*print-pretty* nil))
- (apply #'format nil
- "~S has been deprecated as of SBCL ~A.~
- ~#[~;~2%Use ~S instead.~;~2%~
- Use ~S or ~S instead.~:;~2%~
- Use~@{~#[~; or~] ~S~^,~} instead.~]"
- name since replacements))))
- `(progn
- ,(ecase state
- ((:early :late)
- `(progn
- (defun ,name ,lambda-list
+ (apply #'format nil
+ "~/sb-impl:print-symbol-with-prefix/ has been ~
+ deprecated as of SBCL ~A.~
+ ~#[~;~
+ ~2%Use ~/sb-impl:print-symbol-with-prefix/ instead.~;~
+ ~2%Use ~/sb-impl:print-symbol-with-prefix/ or ~
+ /sb-impl:print-symbol-with-prefix/ instead.~:;~
+ ~2%Use~@{~#[~; or~] ~
+ ~/sb-impl:print-symbol-with-prefix/~^,~} instead.~
+ ~]"
+ name since replacements)))
+ `(prog1
+ ,(ecase state
+ ((:early :late)
+ `(defun ,name ,lambda-list
#!+sb-doc ,doc
- ,@body)))
- ((:final)
- `(progn
- (declaim (ftype (function * nil) ,name))
- (setf (fdefinition ',name)
- (deprecated-function ',name ',replacements ,since))
- #!+sb-doc
- (setf (documentation ',name 'function) ,doc))))
+ ,@body))
+ ((:final)
+ `(progn
+ (declaim (ftype (function * nil) ,name))
+ (setf (fdefinition ',name)
+ (deprecated-function ,since ',name ',replacements))
+ #!+sb-doc
+ (setf (fdocumentation ',name 'function) ,doc)
+ ',name)))
(setf (compiler-macro-function ',name)
(deprecation-compiler-macro ,state ,since ',name ',replacements)))))
(defun check-deprecated-variable (name)
(let ((info (info :variable :deprecated name)))
(when info
- (deprecation-warning (car info) (cdr info) name nil))))
+ (deprecation-warning (first info) (second info) name (third info))
+ (values-list info))))
-(defmacro define-deprecated-variable (state since name &key (value nil valuep) replacement)
- (declare (ignorable replacement))
- `(progn
- (setf (info :variable :deprecated ',name) (cons ,state ,since))
- ,@(when (member state '(:early :late))
- `((defvar ,name ,@(when valuep (list value))
- #!+sb-doc
- ,(let ((*package* (find-package :keyword)))
- (format nil
- "~@<~S has been deprecated as of SBCL ~A~@[, use ~S instead~].~:>"
- name since replacement)))))))
+(defmacro define-deprecated-variable (state since name
+ &key (value nil valuep) replacement)
+ (declare (ignorable replacement)
+ (type deprecation-state state)
+ (type string since)
+ (type symbol name))
+ `(prog2
+ (setf (info :variable :deprecated ',name)
+ '(,state ,since ,(when replacement `(,replacement))))
+ ,(if (member state '(:early :late))
+ `(defvar ,name ,@(when valuep (list value)))
+ `',name)
+ #!+sb-doc
+ (setf (fdocumentation ',name 'variable)
+ ,(format nil "~@<~/sb-impl:print-symbol-with-prefix/ has ~
+ been deprecated as of SBCL ~A.~@[~2% Use ~
+ ~/sb-impl:print-symbol-with-prefix/ ~
+ instead~].~:>"
+ name since replacement))))
;;; Anaphoric macros
(defmacro awhen (test &body body)
diff --git a/src/code/early-format.lisp b/src/code/early-format.lisp
index f0fbfcb..9cd7009 100644
--- a/src/code/early-format.lisp
+++ b/src/code/early-format.lisp
@@ -53,14 +53,3 @@
;;; Used by the expander stuff. List of (symbol . offset) for simple args.
(defvar *simple-args*)
-
-(defun print-symbol-with-prefix (stream symbol colon at)
- #!+sb-doc
- "For use with ~/: Write SYMBOL to STREAM as if it is not accessible from
- the current package."
- (declare (ignore colon at))
- ;; Only keywords should be accessible from the keyword package, and
- ;; keywords are always printed with colons, so this guarantees that the
- ;; symbol will not be printed without a prefix.
- (let ((*package* *keyword-package*))
- (write symbol :stream stream :escape t)))
diff --git a/src/code/symbol.lisp b/src/code/symbol.lisp
index 48ba515..46c67c5 100644
--- a/src/code/symbol.lisp
+++ b/src/code/symbol.lisp
@@ -17,6 +17,14 @@
(declaim (maybe-inline get get3 %put getf remprop %putf get-properties keywordp))
+#-sb-xc-host
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun handle-deprecated-global-variable (name)
+ (multiple-value-bind (state since replacements)
+ (check-deprecated-variable name)
+ (when (eq state :final)
+ `(deprecation-error ,since ',name '(,@replacements))))))
+
(defun symbol-value (symbol)
#!+sb-doc
"Return SYMBOL's current bound value."
@@ -27,8 +35,8 @@
(define-compiler-macro symbol-value (&whole form symbol &environment env)
(when (sb!xc:constantp symbol env)
(let ((name (constant-form-value symbol env)))
- (when (symbolp name)
- (check-deprecated-variable name))))
+ (awhen (and (symbolp name) (handle-deprecated-global-variable name))
+ (return-from symbol-value it))))
form)
(defun boundp (symbol)
@@ -54,6 +62,14 @@ distinct from the global value. Can also be SETF."
(declare (optimize (safety 1)))
(symbol-global-value symbol))
+#-sb-xc-host
+(define-compiler-macro symbol-global-value (&whole form symbol &environment env)
+ (when (sb!xc:constantp symbol env)
+ (let ((name (constant-form-value symbol env)))
+ (awhen (and (symbolp name) (handle-deprecated-global-variable name))
+ (return-from symbol-global-value it))))
+ form)
+
(defun set-symbol-global-value (symbol new-value)
(about-to-modify-symbol-value symbol 'set new-value)
(%set-symbol-global-value symbol new-value))
diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 69203ae..c325546 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -270,7 +270,7 @@
(let ((kind (info :variable :kind name))
(type (info :variable :type name))
(where-from (info :variable :where-from name)))
- (when (eq kind :unknown)
+ (when (and (eq kind :unknown) (not (check-deprecated-variable name)))
(note-undefined-reference name :variable))
(setf (gethash name *free-vars*)
(case kind
@@ -689,24 +689,30 @@
`(symbol-value ',name)))
(etypecase var
(leaf
- (when (lambda-var-p var)
- (let ((home (ctran-home-lambda-or-null start)))
- (when home
- (sset-adjoin var (lambda-calls-or-closes home))))
- (when (lambda-var-ignorep var)
- ;; (ANSI's specification for the IGNORE declaration requires
- ;; that this be a STYLE-WARNING, not a full WARNING.)
- #-sb-xc-host
- (compiler-style-warn "reading an ignored variable: ~S" name)
- ;; there's no need for us to accept ANSI's lameness when
- ;; processing our own code, though.
- #+sb-xc-host
- (warn "reading an ignored variable: ~S" name)))
- (when (global-var-p var)
- (check-deprecated-variable name))
+ (cond
+ ((lambda-var-p var)
+ (let ((home (ctran-home-lambda-or-null start)))
+ (when home
+ (sset-adjoin var (lambda-calls-or-closes home))))
+ (when (lambda-var-ignorep var)
+ ;; (ANSI's specification for the IGNORE declaration requires
+ ;; that this be a STYLE-WARNING, not a full WARNING.)
+ #-sb-xc-host
+ (compiler-style-warn "reading an ignored variable: ~S" name)
+ ;; there's no need for us to accept ANSI's lameness when
+ ;; processing our own code, though.
+ #+sb-xc-host
+ (warn "reading an ignored variable: ~S" name)))
+ (t
+ (multiple-value-bind (state since replacements)
+ (check-deprecated-variable name)
+ (when (eq state :final)
+ (ir1-convert
+ start next result
+ `(deprecation-error ,since ',name '(,@replacements)))
+ (return-from ir1-convert-var (values))))))
(reference-leaf start next result var name))
- (cons
- (aver (eq (car var) 'macro))
+ ((cons (eql macro)) ; symbol-macro
;; FIXME: [Free] type declarations. -- APD, 2002-01-26
(ir1-convert start next result (cdr var)))
(heap-alien-info
diff --git a/tests/deprecation.impure.lisp b/tests/deprecation.impure.lisp
new file mode 100644
index 0000000..00d0e9d
--- /dev/null
+++ b/tests/deprecation.impure.lisp
@@ -0,0 +1,112 @@
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(load "assertoid.lisp")
+(use-package '#:assertoid)
+
+;;;; Helpers
+
+(defun check-deprecated-thing (kind name state make-body)
+ (flet ((search-string (string)
+ (dolist (fragment `(,(string name)
+ "deprecated" "as" "of" "SBCL" "1.2.10"
+ "Use"
+ ,(format nil "~A.~A" name '#:replacement)
+ "instead"))
+ (assert (search fragment string)))))
+ ;; Check the signaled warning condition.
+ (let* ((condition)
+ (function (handler-bind
+ ((warning (lambda (c)
+ (setf condition c)
+ (muffle-warning))))
+ (compile nil `(lambda ()
+ ,@(funcall make-body name))))))
+ (assert (typep condition (ecase state
+ (:early 'sb-int:early-deprecation-warning)
+ (:late 'sb-int:late-deprecation-warning)
+ (:final 'sb-int:final-deprecation-warning))))
+ (search-string (princ-to-string condition))
+ (ecase state
+ ((:early :late)
+ (assert (eq :deprecated (funcall function))))
+ (:final
+ (assert-error (funcall function) sb-int:deprecation-error))))
+ ;; Check the documentation.
+ (search-string (documentation name kind))))
+
+;;;; Deprecated variables
+
+(sb-impl::define-deprecated-variable :early "1.2.10"
+ deprecated-variable.early
+ :value :deprecated
+ :replacement deprecated-variable.early.replacement)
+
+(with-test (:name (sb-impl::define-deprecated-variable :early))
+ (check-deprecated-thing 'variable 'deprecated-variable.early :early
+ (lambda (name) `(,name)))
+ (check-deprecated-thing 'variable 'deprecated-variable.early :early
+ (lambda (name) `((symbol-value ',name))))
+ (check-deprecated-thing 'variable 'deprecated-variable.early :early
+ (lambda (name) `((symbol-global-value ',name)))))
+
+(sb-impl::define-deprecated-variable :late "1.2.10"
+ deprecated-variable.late
+ :value :deprecated
+ :replacement deprecated-variable.late.replacement)
+
+(with-test (:name (sb-impl::define-deprecated-variable :late))
+ (check-deprecated-thing 'variable 'deprecated-variable.late :late
+ (lambda (name) `(,name)))
+ (check-deprecated-thing 'variable 'deprecated-variable.late :late
+ (lambda (name) `((symbol-value ',name))))
+ (check-deprecated-thing 'variable 'deprecated-variable.late :late
+ (lambda (name) `((symbol-global-value ',name)))))
+
+(sb-impl::define-deprecated-variable :final "1.2.10"
+ deprecated-variable.final
+ :value :deprecated
+ :replacement deprecated-variable.final.replacement)
+
+(with-test (:name (sb-impl::define-deprecated-variable :final))
+ (check-deprecated-thing 'variable 'deprecated-variable.final :final
+ (lambda (name) `(,name)))
+ (check-deprecated-thing 'variable 'deprecated-variable.final :final
+ (lambda (name) `((symbol-value ',name))))
+ (check-deprecated-thing 'variable 'deprecated-variable.final :final
+ (lambda (name) `((symbol-global-value ',name)))))
+
+
+;;;; Deprecated functions
+
+(sb-impl::define-deprecated-function :early "1.2.10"
+ deprecated-function.early deprecated-function.early.replacement ()
+ :deprecated)
+
+(with-test (:name (sb-impl::define-deprecated-function :early))
+ (check-deprecated-thing 'function 'deprecated-function.early :early
+ (lambda (name) `((,name)))))
+
+(sb-impl::define-deprecated-function :late "1.2.10"
+ deprecated-function.late deprecated-function.late.replacement ()
+ :deprecated)
+
+(with-test (:name (sb-impl::define-deprecated-function :late))
+ (check-deprecated-thing 'function 'deprecated-function.late :late
+ (lambda (name) `((,name)))))
+
+(sb-impl::define-deprecated-function :final "1.2.10"
+ deprecated-function.final deprecated-function.final.replacement ()
+ :deprecated)
+
+(with-test (:name (sb-impl::define-deprecated-function :final))
+ (check-deprecated-thing 'function 'deprecated-function.final :final
+ (lambda (name) `((,name)))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|