Commit 2aae074e authored by Samuel Hunter's avatar Samuel Hunter
Browse files

Fix and standardize all error reader functions

Fixes #388, replaces #389. The reader function `stream-error-stream`
signals a `type-error` if it's applied to conditions that's typep to
`stream-error`, but whose class is a subtype to `stream-error`:

```lisp
(define-condition broken-error (stream-error) ())
  BROKEN-ERROR
(stream-error-stream (make-condition 'stream-error :stream (make-string-input-stream "foo")))
  #S(SYSTEM::STRING-INPUT-STREAM)
(stream-error-stream (make-condition 'broken-error :stream (make-string-input-stream "foo")))
  #<THREAD "interpreter" {2075326}>: Debugger invoked on condition of type TYPE-ERROR
    The value #<BROKEN-ERROR {75A83798}> is not of type STREAM-ERROR.
```

This fault exists within these reader functions:

- file-error-pathname (almost -- instead of a type-error, the function returns NIL instead.)
- package-error-package
- arithmetic-error-operation
- arithmetic-error-operands

The fault exists because the Java code checks if its argument is
instanceof its respective Java class. So, the method will fail on any
conditions defined in CL that subclass these errors.

Furthermore, some reader functions only check if they're instanceof
StandardObject, which allows any CLOS object to succeed as long as the
slot the primitive method is looking for exists:

- cell-error-name
- type-error-datum
- type-error-expected-type

Finally, some reader functions exist in standalone Java files, while
others reside in its condition's class file, adding to some
organizational clutter.

This change fills two main jobs:

- Standardize all reader functions to the same behavior: If the argument
  is typep to the right condition, return the right slot value.
  Otherwise, signal a type error.
- Move standalone reader Java code to the files of errors they apply to.

As an aside, this change would make ABCL's reader functions conformant
to a wave of proposals for WSCL:

- https://github.com/s-expressionists/wscl/blob/main/wscl-issues/proposed/cell-error-name-type-error
- https://github.com/s-expressionists/wscl/blob/main/wscl-issues/proposed/stream-error-stream-type-error
- https://github.com/s-expressionists/wscl/blob/main/wscl-issues/proposed/type-error-datum-type-error
- And the rest
parent d91e3735
......@@ -129,14 +129,15 @@ public class ArithmeticError extends LispError
@Override
public LispObject execute(LispObject arg)
{
if (arg instanceof ArithmeticError) {
return ((ArithmeticError)arg).getOperation();
}
else {
if (arg.typep(Symbol.ARITHMETIC_ERROR) == NIL) {
return type_error(arg, Symbol.ARITHMETIC_ERROR);
}
final StandardObject obj = (StandardObject) arg;
return obj.getInstanceSlotValue(Symbol.OPERATION);
}
};
// ### arithmetic-error-operands
private static final Primitive ARITHMETIC_ERROR_OPERANDS =
new Primitive("arithmetic-error-operands", "condition")
......@@ -144,12 +145,12 @@ public class ArithmeticError extends LispError
@Override
public LispObject execute(LispObject arg)
{
if (arg instanceof ArithmeticError) {
return ((ArithmeticError)arg).getOperands();
}
else {
if (arg.typep(Symbol.ARITHMETIC_ERROR) == NIL) {
return type_error(arg, Symbol.ARITHMETIC_ERROR);
}
final StandardObject obj = (StandardObject) arg;
return obj.getInstanceSlotValue(Symbol.OPERANDS);
}
};
}
......@@ -279,7 +279,7 @@ public class Autoload extends Function
args="symbol-or-symbols &optional filename",
doc="Setup the autoload for SYMBOL-OR-SYMBOLS optionally corresponding to FILENAME.")
private static final class pf_autoload extends Primitive {
pf_autoload() {
pf_autoload() {
super("autoload", PACKAGE_EXT, true);
}
@Override
......@@ -321,7 +321,7 @@ public class Autoload extends Function
};
public static final Primitive RESOLVE = new pf_resolve();
@DocString(name="resolve",
@DocString(name="resolve",
args="symbol",
doc="Resolve the function named by SYMBOL via the autoloader mechanism.\n"
+ "Returns either the function or NIL if no resolution was possible.")
......@@ -343,14 +343,14 @@ public class Autoload extends Function
}
public static final Primitive AUTOLOADP = new pf_autoloadp();
@DocString(name="autoloadp",
@DocString(name="autoloadp",
args="symbol",
doc="Boolean predicate for whether SYMBOL stands for a function that currently needs to be autoloaded.")
private static final class pf_autoloadp extends Primitive {
pf_autoloadp() {
super("autoloadp", PACKAGE_EXT, true, "symbol");
}
@Override
public LispObject execute(LispObject arg)
{
......@@ -374,7 +374,6 @@ public class Autoload extends Function
autoload("atanh", "MathFunctions");
autoload("broadcast-stream-streams", "BroadcastStream");
autoload("ceiling", "ceiling");
autoload("cell-error-name", "cell_error_name");
autoload("char", "StringFunctions");
autoload("char-equal", "CharacterFunctions");
autoload("char-greaterp", "CharacterFunctions");
......@@ -397,7 +396,6 @@ public class Autoload extends Function
autoload("exp", "MathFunctions");
autoload("expt", "MathFunctions");
autoload("file-author", "file_author");
autoload("file-error-pathname", "file_error_pathname");
autoload("file-length", "file_length");
autoload("file-string-length", "file_string_length");
autoload("file-write-date", "file_write_date");
......@@ -464,8 +462,6 @@ public class Autoload extends Function
autoload("mod", "mod");
autoload("open-stream-p", "open_stream_p");
autoload("output-stream-p", "output_stream_p");
autoload("package-error-package", "package_error_package");
autoload("package-error-package", "package_error_package");
autoload("package-name", "PackageFunctions");
autoload("package-nicknames", "PackageFunctions");
autoload("package-shadowing-symbols", "PackageFunctions");
......@@ -670,7 +666,7 @@ public class Autoload extends Function
autoload(PACKAGE_SYS, "make-memory-class-loader", "MemoryClassLoader", false);
autoload(PACKAGE_SYS, "put-memory-function", "MemoryClassLoader", false);
autoload(PACKAGE_SYS, "get-memory-function", "MemoryClassLoader", false);
autoload(Symbol.SET_CHAR, "StringFunctions");
autoload(Symbol.SET_SCHAR, "StringFunctions");
......
......@@ -107,4 +107,20 @@ public class CellError extends LispError
sb.append(getCellName().princToString());
return unreadableString(sb.toString());
}
// ### cell-error-name
private static final Primitive CELL_ERROR_NAME =
new Primitive("cell-error-name", "condition")
{
@Override
public LispObject execute(LispObject arg)
{
if (arg.typep(Symbol.CELL_ERROR) == NIL) {
return type_error(arg, Symbol.CELL_ERROR);
}
final StandardObject obj = (StandardObject) arg;
return obj.getInstanceSlotValue(Symbol.NAME);
}
};
}
......@@ -112,4 +112,20 @@ public final class FileError extends LispError
return T;
return super.typep(type);
}
// ### file-error-pathname
private static final Primitive FILE_ERROR_PATHNAME =
new Primitive("file-error-pathname", "condition")
{
@Override
public LispObject execute(LispObject arg)
{
if (arg.typep(Symbol.FILE_ERROR) == NIL) {
return type_error(arg, Symbol.FILE_ERROR);
}
final StandardObject obj = (StandardObject) arg;
return obj.getInstanceSlotValue(Symbol.PATHNAME);
}
};
}
......@@ -125,4 +125,20 @@ public final class PackageError extends LispError
{
setInstanceSlotValue(Symbol.PACKAGE, pkg);
}
// ### package-error-package
private static final Primitive PACKAGE_ERROR_PACKAGE =
new Primitive("package-error-package", "condition")
{
@Override
public LispObject execute(LispObject arg)
{
if (arg.typep(Symbol.PACKAGE_ERROR) == NIL) {
return type_error(arg, Symbol.PACKAGE_ERROR);
}
final StandardObject obj = (StandardObject) arg;
return obj.getInstanceSlotValue(Symbol.PACKAGE);
}
};
}
......@@ -161,9 +161,12 @@ public class StreamError extends LispError
@Override
public LispObject execute(LispObject arg)
{
if (arg instanceof StreamError)
return ((StreamError)arg).getStream();
return type_error(arg, Symbol.STREAM_ERROR);
if (arg.typep(Symbol.STREAM_ERROR) == NIL) {
return type_error(arg, Symbol.STREAM_ERROR);
}
final StandardObject obj = (StandardObject) arg;
return obj.getInstanceSlotValue(Symbol.STREAM);
}
};
}
......@@ -191,13 +191,11 @@ public class TypeError extends LispError
@Override
public LispObject execute(LispObject arg)
{
final StandardObject obj;
if (arg instanceof StandardObject) {
obj = (StandardObject) arg;
}
else {
return type_error(arg, Symbol.STANDARD_OBJECT);
if (arg.typep(Symbol.TYPE_ERROR) == NIL) {
return type_error(arg, Symbol.TYPE_ERROR);
}
final StandardObject obj = (StandardObject) arg;
return obj.getInstanceSlotValue(Symbol.DATUM);
}
};
......@@ -209,13 +207,11 @@ public class TypeError extends LispError
@Override
public LispObject execute(LispObject arg)
{
final StandardObject obj;
if (arg instanceof StandardObject) {
obj = (StandardObject) arg;
}
else {
return type_error(arg, Symbol.STANDARD_OBJECT);
if (arg.typep(Symbol.TYPE_ERROR) == NIL) {
return type_error(arg, Symbol.TYPE_ERROR);
}
final StandardObject obj = (StandardObject) arg;
return obj.getInstanceSlotValue(Symbol.EXPECTED_TYPE);
}
};
......
/*
* file_error_pathname.java
*
* Copyright (C) 2004 Peter Graves
* $Id$
*
* This program is free software; you can redistribute it and/or
* modify it under the terms of the GNU General Public License
* as published by the Free Software Foundation; either version 2
* of the License, or (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*
* As a special exception, the copyright holders of this library give you
* permission to link this library with independent modules to produce an
* executable, regardless of the license terms of these independent
* modules, and to copy and distribute the resulting executable under
* terms of your choice, provided that you also meet, for each linked
* independent module, the terms and conditions of the license of that
* module. An independent module is a module which is not derived from
* or based on this library. If you modify this library, you may extend
* this exception to your version of the library, but you are not
* obligated to do so. If you do not wish to do so, delete this
* exception statement from your version.
*/
package org.armedbear.lisp;
import static org.armedbear.lisp.Lisp.*;
// ### file-error-pathname
public final class file_error_pathname extends Primitive
{
private file_error_pathname()
{
super("file-error-pathname");
}
@Override
public LispObject execute(LispObject arg)
{
return arg instanceof FileError ? ((FileError)arg).getPathname() : NIL;
}
private static final file_error_pathname FILE_ERROR_PATHNAME
= new file_error_pathname();
}
/*
* package_error_package.java
*
* Copyright (C) 2003-2004 Peter Graves
* $Id$
*
* This program is free software; you can redistribute it and/or
* modify it under the terms of the GNU General Public License
* as published by the Free Software Foundation; either version 2
* of the License, or (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*
* As a special exception, the copyright holders of this library give you
* permission to link this library with independent modules to produce an
* executable, regardless of the license terms of these independent
* modules, and to copy and distribute the resulting executable under
* terms of your choice, provided that you also meet, for each linked
* independent module, the terms and conditions of the license of that
* module. An independent module is a module which is not derived from
* or based on this library. If you modify this library, you may extend
* this exception to your version of the library, but you are not
* obligated to do so. If you do not wish to do so, delete this
* exception statement from your version.
*/
package org.armedbear.lisp;
import static org.armedbear.lisp.Lisp.*;
@DocString(name="package-error-package")
public final class package_error_package extends Primitive
{
private package_error_package()
{
super("package-error-package");
}
@Override
public LispObject execute(LispObject arg)
{
if (arg instanceof PackageError)
return ((PackageError)arg).getPackage();
return type_error(arg, Symbol.PACKAGE_ERROR);
}
private static final Primitive PACKAGE_ERROR_PACKAGE =
new package_error_package();
}
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