[Sbcl-commits] master: prohibit adding name of a package to itself as a local nickname

[Nikodemus S. <de...@us...>]

The branch "master" has been updated in SBCL:
       via  506af5859d361f5e9744ca9a177bf47746333df3 (commit)
      from  f1e41363fc77b7fc7da410eafef587b683be777a (commit)

- Log -----------------------------------------------------------------
commit 506af5859d361f5e9744ca9a177bf47746333df3
Author: Nikodemus Siivola <nik...@ra...>
Date:   Thu Feb 21 13:18:34 2013 +0200

    prohibit adding name of a package to itself as a local nickname
    
      Seems useless, confusing, and probably unintentional. Make it a
      continuable error, though. Thanks to Rudi Schlatte for thinking
      about this.
    
      So, NO MORE:
    
       (in-package :foo)
       (add-package-local-nickname :foo :bar)
       'foo::x ; => BAR::X
---
 src/code/target-package.lisp |   16 +++++++++-
 tests/packages.impure.lisp   |   61 +++++++++++++++++++++++++++++++++---------
 2 files changed, 62 insertions(+), 15 deletions(-)

diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp
index 2e0e47f..4b19fa7 100644
--- a/src/code/target-package.lisp
+++ b/src/code/target-package.lisp
@@ -385,7 +385,8 @@ Returns the designated package.
 
 Signals a continuable error if LOCAL-NICKNAME is already a package local
 nickname for a different package, or if LOCAL-NICKNAME is one of \"CL\",
-\"COMMON-LISP\", or, \"KEYWORD\".
+\"COMMON-LISP\", or, \"KEYWORD\", or if LOCAL-NICKNAME is a global name or
+nickname for the package to which the nickname would be added.
 
 When in the designated package, calls to FIND-PACKAGE with the LOCAL-NICKNAME
 will return the package the designated ACTUAL-PACKAGE instead. This also
@@ -413,7 +414,18 @@ Experimental: interface subject to change."
                   nick actual))
     (when (member nick '("CL" "COMMON-LISP" "KEYWORD") :test #'string=)
       (cerror "Continue, use it as local nickname anyways."
-              "Attempt to use ~A as a package local nickname." nick))
+              "Attempt to use ~A as a package local nickname (for ~A)."
+              nick (package-name actual)))
+    (when (string= nick (package-name package))
+      (cerror "Continue, use it as a local nickname anyways."
+              "Attempt to use ~A as a package local nickname (for ~A) in ~
+               package named globally ~A."
+              nick (package-name actual) nick))
+    (when (member nick (package-nicknames package) :test #'string=)
+      (cerror "Continue, use it as a local nickname anyways."
+              "Attempt to use ~A as a package local nickname (for ~A) in ~
+               package nicknamed globally ~A."
+              nick (package-name actual) nick))
     (when (and cell (neq actual (cdr cell)))
       (restart-case
           (error "~@<Cannot add ~A as local nickname for ~A in ~S: already nickname for ~A.~:@>"
diff --git a/tests/packages.impure.lisp b/tests/packages.impure.lisp
index a67dca2..015bca1 100644
--- a/tests/packages.impure.lisp
+++ b/tests/packages.impure.lisp
@@ -583,23 +583,58 @@ if a restart was invoked."
   (add-package-local-nickname :c :sb-c :package-local-nicknames-test-1)
   (remove-package-local-nickname :l :package-local-nicknames-test-1))
 
+(defmacro with-tmp-packages (bindings &body body)
+  `(let ,(mapcar #'car bindings)
+     (unwind-protect
+          (progn
+            (setf ,@(apply #'append bindings))
+            ,@body)
+       ,@(mapcar (lambda (p)
+                   `(when ,p (delete-package ,p)))
+                 (mapcar #'car bindings)))))
+
 (with-test (:name (:delete-package :locally-nicknames-others))
-  (let (p1 p2)
-    (unwind-protect
-         (progn
-           (setf p1 (make-package "LOCALLY-NICKNAMES-OTHERS")
-                 p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS"))
-               (add-package-local-nickname :foo p2 p1)
-               (assert (equal (list p1) (package-locally-nicknamed-by-list p2)))
-               (delete-package p1)
-               (assert (not (package-locally-nicknamed-by-list p2))))
-      (when p1 (delete-package p1))
-      (when p2 (delete-package p2)))))
+  (with-tmp-packages ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS"))
+                      (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS")))
+    (add-package-local-nickname :foo p2 p1)
+    (assert (equal (list p1) (package-locally-nicknamed-by-list p2)))
+    (delete-package p1)
+    (assert (not (package-locally-nicknamed-by-list p2)))))
 
 (with-test (:name (:delete-package :locally-nicknamed-by-others))
-  (let ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS"))
-        (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS")))
+  (with-tmp-packages ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS"))
+                      (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS")))
     (add-package-local-nickname :foo p2 p1)
     (assert (package-local-nicknames p1))
     (delete-package p2)
     (assert (not (package-local-nicknames p1)))))
+
+(with-test (:name :own-name-as-local-nickname)
+  (with-tmp-packages ((p1 (make-package "OWN-NAME-AS-NICKNAME1"))
+                      (p2 (make-package "OWN-NAME-AS-NICKNAME2")))
+    (assert (eq :oops
+                (handler-case
+                    (add-package-local-nickname :own-name-as-nickname1 p2 p1)
+                  (error ()
+                    :oops))))
+    (handler-bind ((error #'continue))
+      (add-package-local-nickname :own-name-as-nickname1 p2 p1))
+    (assert (eq (intern "FOO" p2)
+                (let ((*package* p1))
+                  (intern "FOO" :own-name-as-nickname1))))))
+
+(with-test (:name :own-nickname-as-local-nickname)
+  (with-tmp-packages ((p1 (make-package "OWN-NICKNAME-AS-NICKNAME1"
+                                        :nicknames '("OWN-NICKNAME")))
+                      (p2 (make-package "OWN-NICKNAME-AS-NICKNAME2")))
+    (assert (eq :oops
+                (handler-case
+                    (add-package-local-nickname :own-nickname p2 p1)
+                  (error ()
+                    :oops))))
+    (handler-bind ((error #'continue))
+      (add-package-local-nickname :own-nickname p2 p1))
+    (assert (eq (intern "FOO" p2)
+                (let ((*package* p1))
+                  (intern "FOO" :own-nickname))))))
+

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


hooks/post-receive
-- 
SBCL