[armedbear-cvs] r12528 - branches/metaclass/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Sat Mar 13 21:48:00 UTC 2010
Author: ehuelsmann
Date: Sat Mar 13 16:47:59 2010
New Revision: 12528
Log:
Reference #38: make the following snippet work:
(defclass g (standard-class) ())
(defclass h () () (:metaclass g))
(make-instance 'h)
Modified:
branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java
branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java
branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java
branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java
branches/metaclass/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java
branches/metaclass/abcl/src/org/armedbear/lisp/clos.lisp
Modified: branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java (original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java Sat Mar 13 16:47:59 2010
@@ -48,6 +48,15 @@
return c;
}
+ public static LispObject addClass(Symbol symbol, LispObject c)
+ {
+ synchronized (map)
+ {
+ map.put(symbol, c);
+ }
+ return c;
+ }
+
public static void removeClass(Symbol symbol)
{
synchronized (map)
@@ -68,10 +77,10 @@
{
final Symbol symbol = checkSymbol(name);
- final LispClass c;
+ final LispObject c;
synchronized (map)
{
- c = (LispClass) map.get(symbol);
+ c = map.get(symbol);
}
if (c != null)
return c;
@@ -291,13 +300,29 @@
public boolean subclassp(LispObject obj)
{
- LispObject cpl = getCPL();
+ return false;
+ }
+
+ public static boolean subclassp(LispObject cls, LispObject obj)
+ {
+ LispObject cpl;
+
+ if (cls instanceof LispClass)
+ cpl = ((LispClass)cls).getCPL();
+ else
+ cpl = Symbol.CLASS_PRECEDENCE_LIST.execute(cls);
+
while (cpl != NIL)
{
if (cpl.car() == obj)
return true;
cpl = ((Cons)cpl).cdr;
}
+
+ if (cls instanceof LispClass)
+ // additional checks (currently because of JavaClass)
+ return ((LispClass)cls).subclassp(obj);
+
return false;
}
@@ -340,8 +365,7 @@
removeClass(name);
return second;
}
- final LispClass c = checkClass(second);
- addClass(name, c);
+ addClass(name, second);
return second;
}
};
@@ -354,8 +378,7 @@
public LispObject execute(LispObject first, LispObject second)
{
- final LispClass c = checkClass(first);
- return c.subclassp(second) ? T : NIL;
+ return LispClass.subclassp(first, second) ? T : NIL;
}
};
}
Modified: branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java (original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java Sat Mar 13 16:47:59 2010
@@ -5316,7 +5316,10 @@
@Override
public LispObject execute(LispObject arg) {
- return checkClass(arg).getName();
+ if (arg instanceof LispClass)
+ return ((LispClass)arg).getName();
+
+ return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symName);
}
};
@@ -5331,7 +5334,11 @@
public LispObject execute(LispObject first, LispObject second)
{
- checkClass(second).setName(checkSymbol(first));
+ if (second instanceof LispClass)
+ ((LispClass)second).setName(checkSymbol(first));
+ else
+ ((StandardObject)second).setInstanceSlotValue(StandardClass.symName,
+ checkSymbol(first));
return first;
}
};
@@ -5345,7 +5352,12 @@
@Override
public LispObject execute(LispObject arg) {
- Layout layout = checkClass(arg).getClassLayout();
+ Layout layout;
+ if (arg instanceof LispClass)
+ layout = ((LispClass)arg).getClassLayout();
+ else
+ layout = (Layout)((StandardObject)arg).getInstanceSlotValue(StandardClass.symLayout);
+
return layout != null ? layout : NIL;
}
};
@@ -5362,7 +5374,10 @@
{
if (first == NIL || first instanceof Layout) {
- checkClass(second).setClassLayout(first);
+ if (second instanceof LispClass)
+ ((LispClass)second).setClassLayout(first);
+ else
+ ((StandardObject)second).setInstanceSlotValue(StandardClass.symLayout, first);
return first;
}
return type_error(first, Symbol.LAYOUT);
@@ -5378,7 +5393,10 @@
@Override
public LispObject execute(LispObject arg) {
- return checkClass(arg).getDirectSuperclasses();
+ if (arg instanceof LispClass)
+ return ((LispClass)arg).getDirectSuperclasses();
+ else
+ return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectSuperclasses);
}
};
@@ -5391,9 +5409,11 @@
@Override
public LispObject execute(LispObject first, LispObject second)
-
{
- checkClass(second).setDirectSuperclasses(first);
+ if (second instanceof LispClass)
+ ((LispClass)second).setDirectSuperclasses(first);
+ else
+ ((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectSuperclasses, first);
return first;
}
};
@@ -5407,7 +5427,10 @@
@Override
public LispObject execute(LispObject arg) {
- return checkClass(arg).getDirectSubclasses();
+ if (arg instanceof LispClass)
+ return ((LispClass)arg).getDirectSubclasses();
+ else
+ return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectSubclasses);
}
};
@@ -5421,9 +5444,11 @@
@Override
public LispObject execute(LispObject first, LispObject second)
-
{
- checkClass(second).setDirectSubclasses(first);
+ if (second instanceof LispClass)
+ ((LispClass)second).setDirectSubclasses(first);
+ else
+ ((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectSubclasses, first);
return first;
}
};
@@ -5437,7 +5462,10 @@
@Override
public LispObject execute(LispObject arg) {
- return checkClass(arg).getCPL();
+ if (arg instanceof LispClass)
+ return ((LispClass)arg).getCPL();
+ else
+ return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symClassPrecedenceList);
}
};
@@ -5450,9 +5478,11 @@
@Override
public LispObject execute(LispObject first, LispObject second)
-
{
- checkClass(second).setCPL(first);
+ if (second instanceof LispClass)
+ ((LispClass)second).setCPL(first);
+ else
+ ((StandardObject)second).setInstanceSlotValue(StandardClass.symClassPrecedenceList, first);
return first;
}
};
@@ -5466,9 +5496,11 @@
@Override
public LispObject execute(LispObject arg)
-
{
- return checkClass(arg).getDirectMethods();
+ if (arg instanceof LispClass)
+ return ((LispClass)arg).getDirectMethods();
+ else
+ return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectMethods);
}
};
@@ -5481,9 +5513,11 @@
@Override
public LispObject execute(LispObject first, LispObject second)
-
{
- checkClass(second).setDirectMethods(first);
+ if (second instanceof LispClass)
+ ((LispClass)second).setDirectMethods(first);
+ else
+ ((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectMethods, first);
return first;
}
};
@@ -5500,7 +5534,10 @@
public LispObject execute(LispObject arg)
{
- return checkClass(arg).getDocumentation();
+ if (arg instanceof LispClass)
+ return ((LispClass)arg).getDocumentation();
+ else
+ return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDocumentation);
}
};
@@ -5514,9 +5551,11 @@
@Override
public LispObject execute(LispObject first, LispObject second)
-
{
- checkClass(first).setDocumentation(second);
+ if (first instanceof LispClass)
+ ((LispClass)first).setDocumentation(second);
+ else
+ ((StandardObject)first).setInstanceSlotValue(StandardClass.symDocumentation, second);
return second;
}
};
@@ -5530,7 +5569,10 @@
@Override
public LispObject execute(LispObject arg) {
- return checkClass(arg).isFinalized() ? T : NIL;
+ if (arg instanceof LispClass)
+ return ((LispClass)arg).isFinalized() ? T : NIL;
+ else
+ return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symFinalizedP);
}
};
@@ -5543,9 +5585,11 @@
@Override
public LispObject execute(LispObject first, LispObject second)
-
{
- checkClass(second).setFinalized(first != NIL);
+ if (second instanceof LispClass)
+ ((LispClass)second).setFinalized(first != NIL);
+ else
+ ((StandardObject)second).setInstanceSlotValue(StandardClass.symFinalizedP, first);
return first;
}
};
Modified: branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java (original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java Sat Mar 13 16:47:59 2010
@@ -308,22 +308,4 @@
}
};
- // ### compute-class-default-initargs
- private static final Primitive COMPUTE_CLASS_DEFAULT_INITARGS =
- new Primitive("compute-class-default-initargs", PACKAGE_SYS, true)
- {
- @Override
- public LispObject execute(LispObject arg)
-
- {
- final SlotClass c;
- if (arg instanceof SlotClass) {
- c = (SlotClass) arg;
- }
- else {
- return type_error(arg, Symbol.STANDARD_CLASS);
- }
- return c.computeDefaultInitargs();
- }
- };
}
Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java (original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java Sat Mar 13 16:47:59 2010
@@ -38,27 +38,27 @@
public class StandardClass extends SlotClass
{
- private static Symbol symName = PACKAGE_MOP.intern("NAME");
- private static Symbol symLayout = PACKAGE_MOP.intern("LAYOUT");
- private static Symbol symDirectSuperclasses
+ public static Symbol symName = PACKAGE_MOP.intern("NAME");
+ public static Symbol symLayout = PACKAGE_MOP.intern("LAYOUT");
+ public static Symbol symDirectSuperclasses
= PACKAGE_MOP.intern("DIRECT-SUPERCLASSES");
- private static Symbol symDirectSubclasses
+ public static Symbol symDirectSubclasses
= PACKAGE_MOP.intern("DIRECT-SUBCLASSES");
- private static Symbol symClassPrecedenceList
+ public static Symbol symClassPrecedenceList
= PACKAGE_MOP.intern("CLASS-PRECEDENCE-LIST");
- private static Symbol symDirectMethods
+ public static Symbol symDirectMethods
= PACKAGE_MOP.intern("DIRECT-METHODS");
- private static Symbol symDocumentation
+ public static Symbol symDocumentation
= PACKAGE_MOP.intern("DOCUMENTATION");
- private static Symbol symDirectSlots
+ public static Symbol symDirectSlots
= PACKAGE_MOP.intern("DIRECT-SLOTS");
- private static Symbol symSlots
+ public static Symbol symSlots
= PACKAGE_MOP.intern("SLOTS");
- private static Symbol symDirectDefaultInitargs
+ public static Symbol symDirectDefaultInitargs
= PACKAGE_MOP.intern("DIRECT-DEFAULT-INITARGS");
- private static Symbol symDefaultInitargs
+ public static Symbol symDefaultInitargs
= PACKAGE_MOP.intern("DEFAULT-INITARGS");
- private static Symbol symFinalizedP
+ public static Symbol symFinalizedP
= PACKAGE_MOP.intern("FINALIZED-P");
static Layout layoutStandardClass =
Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java (original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java Sat Mar 13 16:47:59 2010
@@ -47,7 +47,11 @@
if (arg == StandardClass.STANDARD_CLASS)
return new StandardClass();
if (arg instanceof StandardClass)
- return ((StandardClass)arg).allocateInstance();
+ return ((StandardClass)arg).allocateInstance();
+ if (arg.typep(StandardClass.STANDARD_CLASS) != NIL) {
+ Layout layout = (Layout)Symbol.CLASS_LAYOUT.execute(arg);
+ return new StandardObject(layout);
+ }
return type_error(arg, Symbol.STANDARD_CLASS);
}
};
Modified: branches/metaclass/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- branches/metaclass/abcl/src/org/armedbear/lisp/clos.lisp (original)
+++ branches/metaclass/abcl/src/org/armedbear/lisp/clos.lisp Sat Mar 13 16:47:59 2010
@@ -288,6 +288,12 @@
;;; finalize-inheritance
+(defun std-compute-class-default-initargs (class)
+ (mapcan #'(lambda (c)
+ (copy-list
+ (class-direct-default-initargs c)))
+ (class-precedence-list class)))
+
(defun std-finalize-inheritance (class)
(setf (class-precedence-list class)
(funcall (if (eq (class-of class) (find-class 'standard-class))
@@ -331,7 +337,8 @@
(setf (cdr location) (funcall initfunction))))))))
(setf (class-layout class)
(make-layout class (nreverse instance-slots) (nreverse shared-slots))))
- (setf (class-default-initargs class) (compute-class-default-initargs class))
+ (setf (class-default-initargs class)
+ (std-compute-class-default-initargs class))
(setf (class-finalized-p class) t))
;;; Class precedence lists
More information about the armedbear-cvs
mailing list