From 506af5859d361f5e9744ca9a177bf47746333df3 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 21 Feb 2013 13:18:34 +0200 Subject: [PATCH] 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 "~@" 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)))))) + -- 1.7.10.4