Make add-package-local-nicknames errors continuable

- partly fixes #307
parent 00fd6662
......@@ -780,16 +780,6 @@ public final class Package extends LispObject implements java.io.Serializable
public LispObject addLocalPackageNickname(String name, Package pack)
{
if (name.equals("CL") || name.equals("COMMON-LISP")
|| name.equals("KEYWORD")) {
return error(new LispError("Trying to define a local nickname for "
+ name));
}
if (name.equals(this.name)
|| (nicknames != null && nicknames.contains(name))) {
return error(new LispError("Trying to override package name or nickname with a local nickname "
+ name));
}
if (localNicknames == null) {
localNicknames = new ConcurrentHashMap<String, Package>();
}
......
......@@ -285,7 +285,7 @@ public final class PackageFunctions
// ### add-package-local-nickname
// add-package-local-nickname local-nickname package &optional package-designator => package
private static final Primitive ADD_PACKAGE_LOCAL_NICKNAME =
new Primitive("add-package-local-nickname", PACKAGE_EXT, true,
new Primitive("%add-package-local-nickname", PACKAGE_SYS, false,
"local-nickname package &optional package-designator")
{
@Override
......
......@@ -2968,6 +2968,8 @@ public class Symbol extends LispObject implements java.io.Serializable
PACKAGE_EXT.addExternalSymbol("URL-PATHNAME");
public static final Symbol WEAK_REFERENCE =
PACKAGE_EXT.addExternalSymbol("WEAK-REFERENCE");
public static final Symbol ADD_PACKAGE_LOCAL_NICKNAME =
PACKAGE_EXT.addExternalSymbol("ADD-PACKAGE-LOCAL-NICKNAME");
// MOP.
public static final Symbol CLASS_LAYOUT =
......
......@@ -96,3 +96,24 @@
(defun delete-package (package)
(with-simple-restart (continue "Ignore missing package.")
(sys::%delete-package package)))
(defun add-package-local-nickname (local-nickname actual-package
&optional (package-designator *package*))
(let* ((local-nickname (string local-nickname))
(package-designator (or (find-package package-designator)
(error "Package ~A not found" package-designator)))
(actual-package (or (find-package actual-package)
(error "Package ~A not found" actual-package))))
(when (member local-nickname '("CL" "COMMON-LISP" "KEYWORD")
:test #'string=)
(cerror "Continue anyway"
"Trying to define a local nickname called ~A" local-nickname))
(when (member local-nickname (list* (package-name package-designator)
(package-nicknames package-designator))
:test #'string=)
(cerror "Continue anyway"
"Trying to override the name or nickname ~A for package ~A ~
with a local nickname for another package ~A"
local-nickname package-designator actual-package))
(sys::%add-package-local-nickname local-nickname actual-package
package-designator)))
......@@ -151,31 +151,29 @@
(ext:add-package-local-nickname :own-name-as-nickname1 p2 p1)
(error ()
:oops))))
;; TODO: add continuable errors for this
;; (handler-bind ((error #'continue))
;; (ext:add-package-local-nickname :own-name-as-nickname1 p2 p1))
;; (assert (eq (intern "FOO" p2)
;; (let ((*package* p1))
;; (intern "FOO" :own-name-as-nickname1))))
(handler-bind ((error #'continue))
(ext:add-package-local-nickname :own-name-as-nickname1 p2 p1))
(assert (eq (intern "FOO" p2)
(let ((*package* p1))
(intern "FOO" :own-name-as-nickname1))))
:success)
:success)
(deftest pln-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))))
;; TODO: make errors continuable
;; (handler-bind ((error #'continue))
;; (add-package-local-nickname :own-nickname p2 p1))
;; (assert (eq (intern "FOO" p2)
;; (let ((*package* p1))
;; (intern "FOO" :own-nickname))))
:success)
(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
(ext:add-package-local-nickname :own-nickname p2 p1)
(error ()
:oops))))
(handler-bind ((error #'continue))
(ext:add-package-local-nickname :own-nickname p2 p1))
(assert (eq (intern "FOO" p2)
(let ((*package* p1))
(intern "FOO" :own-nickname))))
:success)
:success)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment