Fix `PACKAGE-ERROR-PACKAGE` behaviour

(Olof-Joachim Frahm)

Also the slot is now always bound, no chance to get an `#<UNBOUND>`
object anymore.

C.f. <http://abcl.org/trac/ticket/325>, but adds the package to a lot more
cases too.

From <https://github.com/Ferada/abcl/commit/9c76a19b73e734c62f1195168c4f4a5a01e8233e>.
parent dc2d211f
......@@ -1868,10 +1868,11 @@ public final class Lisp
{
if (obj instanceof Package)
return (Package) obj;
Package pkg = getCurrentPackage().findPackage(javaString(obj));
String name = javaString(obj);
Package pkg = getCurrentPackage().findPackage(name);
if (pkg != null)
return pkg;
error(new PackageError(obj.princToString() + " is not the name of a package."));
error(new PackageError(obj.princToString() + " is not the name of a package.", obj));
// Not reached.
return null;
}
......
......@@ -460,7 +460,7 @@ public final class Package extends LispObject implements java.io.Serializable
sb.append(sym.getQualifiedName());
sb.append(" and ");
sb.append(s.getQualifiedName());
return error(new PackageError(sb.toString()));
return error(new PackageError(sb.toString(), this));
}
}
usedPackages = usedPackages.cdr();
......@@ -500,7 +500,7 @@ public final class Package extends LispObject implements java.io.Serializable
sb.append(" is already accessible in package ");
sb.append(name);
sb.append('.');
error(new PackageError(sb.toString()));
error(new PackageError(sb.toString(), this));
}
internalSymbols.put(symbol.name.toString(), symbol);
if (symbol.getPackage() == NIL)
......@@ -519,7 +519,7 @@ public final class Package extends LispObject implements java.io.Serializable
sb.append(" is not accessible in package ");
sb.append(name);
sb.append('.');
error(new PackageError(sb.toString()));
error(new PackageError(sb.toString(), this));
return;
}
internalSymbols.put(symbol.name.toString(), symbol);
......@@ -540,7 +540,7 @@ public final class Package extends LispObject implements java.io.Serializable
sb.append(" is already accessible in package ");
sb.append(pkg.getName());
sb.append('.');
error(new PackageError(sb.toString()));
error(new PackageError(sb.toString(), pkg));
return;
}
}
......@@ -559,7 +559,7 @@ public final class Package extends LispObject implements java.io.Serializable
sb.append(" is not accessible in package ");
sb.append(name);
sb.append('.');
error(new PackageError(sb.toString()));
error(new PackageError(sb.toString(), this));
}
public synchronized void unexport(final Symbol symbol)
......@@ -573,7 +573,7 @@ public final class Package extends LispObject implements java.io.Serializable
sb.append(symbol.getQualifiedName());
sb.append(" is not accessible in package ");
sb.append(name);
error(new PackageError(sb.toString()));
error(new PackageError(sb.toString(), this));
}
}
......@@ -646,7 +646,7 @@ public final class Package extends LispObject implements java.io.Serializable
{
error(new PackageError("A symbol named " + symbol.getName() +
" is already accessible in package " +
name + "."));
name + ".", this));
return;
}
}
......@@ -932,7 +932,7 @@ public final class Package extends LispObject implements java.io.Serializable
if(pkg != null) {
return pkg;
} else {
return error(new PackageError(name + " is not the name of a package."));
return error(new PackageError(name + " is not the name of a package.", new SimpleString(name)));
}
}
}
......@@ -84,6 +84,14 @@ public final class PackageError extends LispError
{
super(StandardClass.PACKAGE_ERROR);
setFormatControl(message);
setPackage(NIL);
}
public PackageError(String message, LispObject pkg)
{
super(StandardClass.PACKAGE_ERROR);
setFormatControl(message);
setPackage(pkg);
}
@Override
......@@ -110,17 +118,11 @@ public final class PackageError extends LispError
public LispObject getPackage()
{
Debug.assertTrue(layout != null);
int index = layout.getSlotIndex(Symbol.PACKAGE);
Debug.assertTrue(index >= 0);
return slots[index];
return getInstanceSlotValue(Symbol.PACKAGE);
}
public void setPackage(LispObject pkg)
{
Debug.assertTrue(layout != null);
int index = layout.getSlotIndex(Symbol.PACKAGE);
Debug.assertTrue(index >= 0);
slots[index] = pkg;
setInstanceSlotValue(Symbol.PACKAGE, pkg);
}
}
......@@ -363,10 +363,11 @@ public final class PackageFunctions
if (nicknames != NIL) {
LispObject list = nicknames;
while (list != NIL) {
String nick = javaString(list.car());
LispObject lispNick = list.car();
String nick = javaString(lispNick);
if (currentpkg.findPackage(nick) != null) {
return error(new PackageError("A package named " + nick +
" already exists."));
" already exists.", lispNick));
}
list = list.cdr();
}
......
......@@ -125,7 +125,7 @@ public final class Packages
Object obj = map.get(nickname);
if (obj != null && obj != pkg)
{
error(new PackageError("A package named " + nickname + " already exists."));
error(new PackageError("A package named " + nickname + " already exists.", new SimpleString(nickname)));
return;
}
map.put(nickname, pkg);
......
......@@ -3235,10 +3235,11 @@ public final class Primitives {
if (nicknames != NIL) {
LispObject list = nicknames;
while (list != NIL) {
String nick = javaString(list.car());
LispObject lispNick = list.car();
String nick = javaString(lispNick);
if (currentpkg.findPackage(nick) != null) {
error(new PackageError("A package named " + nick +
" already exists."));
" already exists.", lispNick));
}
list = list.cdr();
}
......@@ -3304,7 +3305,7 @@ public final class Primitives {
final Package pkg = getCurrentPackage().findPackage(packageName);
if (pkg == null)
return error(new PackageError("The name " + packageName +
" does not designate any package."));
" does not designate any package.", arg));
SpecialBinding binding =
LispThread.currentThread().getSpecialBinding(Symbol._PACKAGE_);
if (binding != null)
......
......@@ -148,3 +148,7 @@
(deftest throw.representation.3
(prog1 T (compile NIL (lambda () (if (the boolean (throw 'foo 42)) 1 2))))
T)
(deftest package-error-package.1
(package-error-package (nth-value 1 (ignore-errors (intern "FOO" :bar))))
:bar)
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