Rename and slightly refactor sys:make-slot-definition

- rename to %make-slot-definition, make class argument mandatory

- adjust call sites

- also move checkSlotDefinition() method to location of sole caller
parent 29f53277
......@@ -642,7 +642,7 @@ public class Autoload extends Function
autoload(PACKAGE_SYS, "make-fill-pointer-output-stream", "FillPointerOutputStream");
autoload(PACKAGE_SYS, "make-layout", "Layout", true);
autoload(PACKAGE_SYS, "make-single-float", "FloatFunctions", true);
autoload(PACKAGE_SYS, "make-slot-definition", "SlotDefinition", true);
autoload(PACKAGE_SYS, "%make-slot-definition", "SlotDefinition", true);
autoload(PACKAGE_SYS, "make-structure-class", "StructureClass");
autoload(PACKAGE_SYS, "make-symbol-macro", "Primitives");
autoload(PACKAGE_SYS, "psxhash", "HashTableFunctions");
......
......@@ -37,7 +37,7 @@ import static org.armedbear.lisp.Lisp.*;
public final class SlotDefinition extends StandardObject
{
public SlotDefinition()
private SlotDefinition()
{
super(StandardClass.STANDARD_SLOT_DEFINITION,
StandardClass.STANDARD_SLOT_DEFINITION.getClassLayout().getLength());
......@@ -46,7 +46,7 @@ public final class SlotDefinition extends StandardObject
setInstanceSlotValue(Symbol._DOCUMENTATION, NIL);
}
public SlotDefinition(StandardClass clazz) {
private SlotDefinition(StandardClass clazz) {
// clazz layout needs to have SlotDefinitionClass layout as prefix
// or indexed slot access won't work
super(clazz, clazz.getClassLayout().getLength());
......@@ -122,11 +122,6 @@ public final class SlotDefinition extends StandardObject
setInstanceSlotValue(Symbol.ALLOCATION, Keyword.INSTANCE);
}
public static StandardObject checkSlotDefinition(LispObject obj) {
if (obj instanceof StandardObject) return (StandardObject)obj;
return (StandardObject)type_error(obj, Symbol.SLOT_DEFINITION);
}
@Override
public String printObject()
{
......@@ -142,24 +137,25 @@ public final class SlotDefinition extends StandardObject
private static final Primitive MAKE_SLOT_DEFINITION
= new pf_make_slot_definition();
@DocString(name="make-slot-definition",
args="&optional class",
doc="Cannot be called with user-defined subclasses of standard-slot-definition.")
@DocString(name="%make-slot-definition",
args="slot-class",
doc="Argument must be a subclass of standard-slot-definition")
private static final class pf_make_slot_definition extends Primitive
{
pf_make_slot_definition()
{
super("make-slot-definition", PACKAGE_SYS, true, "&optional class");
}
@Override
public LispObject execute()
{
return new SlotDefinition();
super("%make-slot-definition", PACKAGE_SYS, true, "slot-class");
}
@Override
public LispObject execute(LispObject slotDefinitionClass)
{
return new SlotDefinition((StandardClass) slotDefinitionClass);
if (!(slotDefinitionClass instanceof StandardClass))
return type_error(slotDefinitionClass,
StandardClass.STANDARD_SLOT_DEFINITION);
// we could check whether slotClass is a subtype of
// standard-slot-definition here, but subtypep doesn't work early
// in the build process
return new SlotDefinition((StandardClass)slotDefinitionClass);
}
};
......
......@@ -62,18 +62,23 @@ public final class SlotDefinitionClass extends StandardClass
// in its constructor; here we make Lisp-side subclasses of
// standard-*-slot-definition do the same.
StandardObject locationSlot =
SlotDefinition.checkSlotDefinition(slotDefinitions.nthcdr(8).car());
checkSlotDefinition(slotDefinitions.nthcdr(8).car());
locationSlot.setInstanceSlotValue(Symbol.INITFORM, NIL);
locationSlot.setInstanceSlotValue(Symbol.INITFUNCTION, StandardClass.constantlyNil);
// Fix initargs of TYPE, DOCUMENTATION slots.
StandardObject typeSlot =
SlotDefinition.checkSlotDefinition(slotDefinitions.nthcdr(9).car());
checkSlotDefinition(slotDefinitions.nthcdr(9).car());
typeSlot.setInstanceSlotValue(Symbol.INITARGS, list(internKeyword("TYPE")));
StandardObject documentationSlot =
SlotDefinition.checkSlotDefinition(slotDefinitions.nthcdr(10).car());
checkSlotDefinition(slotDefinitions.nthcdr(10).car());
documentationSlot.setInstanceSlotValue(Symbol.INITARGS, list(internKeyword("DOCUMENTATION")));
setDirectSlotDefinitions(slotDefinitions);
setSlotDefinitions(slotDefinitions);
setFinalized(true);
}
private static StandardObject checkSlotDefinition(LispObject obj) {
if (obj instanceof StandardObject) return (StandardObject)obj;
return (StandardObject)type_error(obj, Symbol.SLOT_DEFINITION);
}
}
......@@ -485,7 +485,7 @@
(defun make-direct-slot-definition (class &rest args)
(let ((slot-class (apply #'direct-slot-definition-class class args)))
(if (eq slot-class +the-standard-direct-slot-definition-class+)
(let ((slot (make-slot-definition +the-standard-direct-slot-definition-class+)))
(let ((slot (%make-slot-definition +the-standard-direct-slot-definition-class+)))
(apply #'init-slot-definition slot :allocation-class class args)
slot)
(progn
......@@ -501,7 +501,7 @@
(defun make-effective-slot-definition (class &rest args)
(let ((slot-class (apply #'effective-slot-definition-class class args)))
(if (eq slot-class +the-standard-effective-slot-definition-class+)
(let ((slot (make-slot-definition +the-standard-effective-slot-definition-class+)))
(let ((slot (%make-slot-definition +the-standard-effective-slot-definition-class+)))
(apply #'init-slot-definition slot args)
slot)
(progn
......
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