[Sbcl-commits] master: Source locations for DEPRECATION declarations (DECLAIM only)

[Jan M. <sc...@us...>]

The branch "master" has been updated in SBCL:
       via  4de5974e4ed5c70a7e1ce8a577d374824725a3c4 (commit)
      from  57c3f506eeeac65d3b9523a4fe58d346a99c11b0 (commit)

- Log -----------------------------------------------------------------
commit 4de5974e4ed5c70a7e1ce8a577d374824725a3c4
Author: Jan Moringen <jmo...@te...>
Date:   Fri Jul 31 06:22:53 2015 +0200

    Source locations for DEPRECATION declarations (DECLAIM only)
    
    DEPRECATED declarations (via DECLAIM, not PROCLAIM) use info entries of
    the form
    
      (:SOURCE-LOCATION :DECLARATION name (DEPRECATED (FUNCTION | VARIABLE | TYPE)))
    
    and thus appear as
    
      (DECLAIM name DEPRECATED (FUNCTION | VARIABLE | TYPE))
    
    in SLIME.
---
 contrib/sb-introspect/introspect.lisp |    5 ++++-
 src/code/early-extensions.lisp        |   21 ++++++++++-----------
 src/compiler/proclaim.lisp            |   23 ++++++++++++++++++-----
 3 files changed, 32 insertions(+), 17 deletions(-)

diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp
index fcd296f..b115013 100644
--- a/contrib/sb-introspect/introspect.lisp
+++ b/contrib/sb-introspect/introspect.lisp
@@ -397,7 +397,10 @@ If an unsupported TYPE is requested, the function will return NIL.
           (loop for (kind loc) on locations by #'cddr
                 when loc
                 collect (let ((loc (translate-source-location loc)))
-                          (setf (definition-source-description loc) (list kind))
+                          (setf (definition-source-description loc)
+                                ;; Copy list to ensure that user code
+                                ;; cannot mutate the original.
+                                (copy-list (sb-int:ensure-list kind)))
                           loc))))
        (t
         nil)))))
diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index 184a8c3..0dbb3f8 100644
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -1471,13 +1471,12 @@
               (lambda (replacement)
                 `',replacement)
               (normalize-deprecation-replacements replacement-spec))))
-   (sb!c:source-location)))
+   nil))
 
 (defun setup-type-in-final-deprecation
     (software version name replacement-spec)
   (declare (ignore software version replacement-spec))
-  (%compiler-deftype name (constant-type-expander t)
-                     (sb!c:source-location)))
+  (%compiler-deftype name (constant-type-expander t) nil))
 
 (defmacro define-deprecated-function (state version name replacements lambda-list
                                       &body body)
@@ -1495,10 +1494,10 @@
           ((:final)
            `',name))
      #-sb-xc-host
-     (proclaim '(deprecated
-                 ,state ("SBCL" ,version)
-                 (function ,name ,@(when replacements
-                                     `(:replacement ,replacements)))))))
+     (declaim (deprecated
+               ,state ("SBCL" ,version)
+               (function ,name ,@(when replacements
+                                   `(:replacement ,replacements)))))))
 
 (defmacro define-deprecated-variable (state version name
                                       &key (value nil valuep) replacement)
@@ -1511,10 +1510,10 @@
             `(defvar ,name ,@(when valuep (list value)))
             `',name)
      #-sb-xc-host
-     (proclaim '(deprecated
-                 ,state ("SBCL" ,version)
-                 (variable ,name ,@(when replacement
-                                     `(:replacement ,replacement)))))))
+     (declaim (deprecated
+               ,state ("SBCL" ,version)
+               (variable ,name ,@(when replacement
+                                   `(:replacement ,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/compiler/proclaim.lisp b/src/compiler/proclaim.lisp
index 05fd4d6..c7bd16b 100644
--- a/src/compiler/proclaim.lisp
+++ b/src/compiler/proclaim.lisp
@@ -264,14 +264,22 @@
           (t
            decl-spec))))
 
+;; These return values are intended for EQ-comparison in
+;; STORE-LOCATION in %PROCLAIM.
+(defun deprecation-location-key (namespace)
+  (case namespace
+    (function '(deprecated function))
+    (variable '(deprecated variable))
+    (type     '(deprecated type))))
+
 (defun %proclaim (raw-form location)
   (destructuring-bind (&whole form &optional kind &rest args)
       (canonized-decl-spec raw-form)
-    (labels ((store-location (name)
+    (labels ((store-location (name &key (key kind))
                (if location
-                   (setf (getf (info :source-location :declaration name) kind)
+                   (setf (getf (info :source-location :declaration name) key)
                          location)
-                   (remf (info :source-location :declaration name) kind)))
+                   (remf (info :source-location :declaration name) key)))
              (map-names (names function &rest extra-args)
                (mapc (lambda (name)
                        (store-location name)
@@ -318,8 +326,13 @@
          (destructuring-bind (state since &rest things) args
            (multiple-value-bind (state software version)
                (check-deprecation-declaration state since form)
-             (map-names things #'process-deprecation-declaration
-                        state software version))))
+             (mapc (lambda (thing)
+                     (destructuring-bind (namespace name &rest rest) thing
+                       (declare (ignore rest))
+                       (store-location
+                        name :key (deprecation-location-key namespace)))
+                     (process-deprecation-declaration thing state software version))
+                   things))))
         (declaration
          (map-args #'process-declaration-declaration form))
         (t

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL