[armedbear-cvs] r14004 - trunk/abcl/src/org/armedbear/lisp
rschlatte at common-lisp.net
rschlatte at common-lisp.net
Fri Jul 13 14:07:32 UTC 2012
Author: rschlatte
Date: Fri Jul 13 07:07:31 2012
New Revision: 14004
Log:
Move definition of eql-specializer metaclass into Lisp side
Modified:
trunk/abcl/src/org/armedbear/lisp/StandardClass.java
trunk/abcl/src/org/armedbear/lisp/clos.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Fri Jul 13 07:07:27 2012 (r14003)
+++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Fri Jul 13 07:07:31 2012 (r14004)
@@ -199,16 +199,18 @@
{
LispObject layout = getInstanceSlotValue(symLayout);
if (layout == UNBOUND_VALUE)
- return null;
+ return null;
if (! (layout instanceof Layout)) {
- (new Error()).printStackTrace();
- LispThread.currentThread().printBacktrace();
- return (Layout)Lisp.error(Symbol.TYPE_ERROR,
- new SimpleString("The value " + layout.princToString()
- + " is not of expected type " + Symbol.LAYOUT.princToString()
- + " in class " + this.princToString() + "."));
- }
+ (new Error()).printStackTrace();
+ LispThread.currentThread().printBacktrace();
+ System.out.println("Class: " + this.princToString());
+ return (Layout)Lisp.error(Symbol.TYPE_ERROR,
+ new SimpleString("The value " + layout.princToString()
+ + " is not of expected type "
+ + Symbol.LAYOUT.princToString()
+ + " in class " + this.princToString() + "."));
+ }
return (layout == UNBOUND_VALUE) ? null : (Layout)layout;
}
@@ -448,8 +450,6 @@
addStandardClass(Symbol.METAOBJECT, list(STANDARD_OBJECT));
public static final StandardClass SPECIALIZER =
addStandardClass(Symbol.SPECIALIZER, list(METAOBJECT));
- public static final StandardClass EQL_SPECIALIZER =
- addStandardClass(Symbol.EQL_SPECIALIZER, list(SPECIALIZER));
public static final StandardClass SLOT_DEFINITION =
addStandardClass(Symbol.SLOT_DEFINITION, list(METAOBJECT));
@@ -731,11 +731,6 @@
list(new SlotDefinition(Symbol.CAUSE, list(Symbol.JAVA_EXCEPTION_CAUSE))));
METAOBJECT.setCPL(METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T);
SPECIALIZER.setCPL(SPECIALIZER, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T);
- EQL_SPECIALIZER.setCPL(EQL_SPECIALIZER, SPECIALIZER, METAOBJECT,
- STANDARD_OBJECT, BuiltInClass.CLASS_T);
- EQL_SPECIALIZER.setDirectSlotDefinitions(
- list(new SlotDefinition(Symbol.OBJECT, NIL, constantlyNil),
- new SlotDefinition(symDirectMethods, NIL, constantlyNil)));
METHOD.setCPL(METHOD, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T);
STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, METAOBJECT, STANDARD_OBJECT,
BuiltInClass.CLASS_T);
@@ -912,7 +907,6 @@
SPECIALIZER.finalizeClass();
CLASS.finalizeClass();
BUILT_IN_CLASS.finalizeClass();
- EQL_SPECIALIZER.finalizeClass();
METHOD_COMBINATION.finalizeClass();
SHORT_METHOD_COMBINATION.finalizeClass();
LONG_METHOD_COMBINATION.finalizeClass();
Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jul 13 07:07:27 2012 (r14003)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jul 13 07:07:31 2012 (r14004)
@@ -214,7 +214,6 @@
(add-subclasses 'direct-slot-definition 'standard-direct-slot-definition)
(add-subclasses 'effective-slot-definition
'standard-effective-slot-definition)
- (add-subclasses 'specializer '(eql-specializer class))
(add-subclasses 'class
'(built-in-class forward-referenced-class standard-class
funcallable-standard-class))))
@@ -483,26 +482,36 @@
(setf (slot-definition-documentation slot) documentation)
slot)
+(declaim (notinline direct-slot-definition-class))
+(defun direct-slot-definition-class (class &rest args)
+ (declare (ignore class args))
+ +the-standard-direct-slot-definition-class+)
+
(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+)))
- (apply #'init-slot-definition slot :allocation-class class args)
- slot)
- (progn
- (let ((slot (apply #'make-instance slot-class :allocation-class class
- args)))
- slot)))))
+ (let ((slot (make-slot-definition +the-standard-direct-slot-definition-class+)))
+ (apply #'init-slot-definition slot :allocation-class class args)
+ slot)
+ (progn
+ (let ((slot (apply #'make-instance slot-class :allocation-class class
+ args)))
+ slot)))))
+
+(declaim (notinline effective-slot-definition-class))
+(defun effective-slot-definition-class (class &rest args)
+ (declare (ignore class args))
+ +the-standard-effective-slot-definition-class+)
(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+)))
- (apply #'init-slot-definition slot args)
- slot)
- (progn
- (let ((slot (apply #'make-instance slot-class args)))
- slot)))))
+ (let ((slot (make-slot-definition +the-standard-effective-slot-definition-class+)))
+ (apply #'init-slot-definition slot args)
+ slot)
+ (progn
+ (let ((slot (apply #'make-instance slot-class args)))
+ slot)))))
;;; finalize-inheritance
@@ -529,8 +538,8 @@
#'compute-class-precedence-list)
class))
(setf (class-slots class)
- (funcall (if (eq (class-of class) +the-standard-class+)
- #'std-compute-slots
+ (funcall (if (eq (class-of class) +the-standard-class+)
+ #'std-compute-slots
#'compute-slots) class))
(let ((old-layout (class-layout class))
(length 0)
@@ -688,8 +697,7 @@
:key 'slot-definition-documentation))
(types (delete-duplicates
(delete t (mapcar #'slot-definition-type direct-slots))
- :test #'equal))
- )
+ :test #'equal)))
(make-effective-slot-definition
class
:name name
@@ -711,7 +719,9 @@
:type (cond ((null types) t)
((= 1 (length types)) types)
(t (list* 'and types)))
- :documentation (documentation documentation-slot t))))
+ :documentation (if documentation-slot
+ (documentation documentation-slot t)
+ nil))))
;;; Standard instance slot access
@@ -816,6 +826,12 @@
(unless (class-finalized-p class) (error "Class ~A not finalized" (class-name class)))
(std-allocate-instance class))
+(defun maybe-finalize-class-subtree (class)
+ (when (every #'class-finalized-p (class-direct-superclasses class))
+ (finalize-inheritance class)
+ (dolist (subclass (class-direct-subclasses class))
+ (maybe-finalize-class-subtree subclass))))
+
(defun make-instance-standard-class (metaclass
&rest initargs
&key name direct-superclasses direct-slots
@@ -823,12 +839,15 @@
documentation)
(declare (ignore metaclass))
(let ((class (std-allocate-instance +the-standard-class+)))
- (check-initargs (list #'allocate-instance #'initialize-instance)
- (list* class initargs)
- class t initargs
- *make-instance-initargs-cache* 'make-instance)
+ (unless *clos-booting*
+ (check-initargs (list #'allocate-instance #'initialize-instance)
+ (list* class initargs)
+ class t initargs
+ *make-instance-initargs-cache* 'make-instance))
(%set-class-name name class)
- (%set-class-layout nil class)
+ ;; KLUDGE: necessary in define-primordial-class, otherwise
+ ;; StandardClass.getClassLayout() throws an error
+ (unless *clos-booting* (%set-class-layout nil class))
(%set-class-direct-subclasses () class)
(%set-class-direct-methods () class)
(%set-class-documentation class documentation)
@@ -870,6 +889,26 @@
(maybe-finalize-class-subtree class)
(values))
+;;; Bootstrap the lower parts of the metaclass hierarchy.
+
+(defmacro define-primordial-class (name superclasses direct-slots)
+ "Primitive class definition tool.
+No non-standard metaclasses, accessor methods, duplicate slots,
+non-existent superclasses, default initargs, or other complicated stuff.
+Handle with care."
+ (let ((class (gensym)))
+ `(let ((,class (make-instance-standard-class
+ nil
+ :name ',name
+ :direct-superclasses ',(mapcar #'find-class superclasses)
+ :direct-slots ,(canonicalize-direct-slots direct-slots))))
+ (%set-find-class ',name ,class)
+ ,class)))
+
+(define-primordial-class eql-specializer (specializer)
+ ((object :initform nil)
+ (direct-methods :initform nil)))
+
(defvar *extensible-built-in-classes*
(list (find-class 'sequence)
(find-class 'java:java-object)))
@@ -1343,13 +1382,13 @@
;; we will be called during generic function invocation
;; setup, so have to rely on plain functions here.
(let ((instance (std-allocate-instance (find-class 'eql-specializer))))
- (setf (std-slot-value instance 'sys::object) object)
+ (setf (std-slot-value instance 'object) object)
(setf (std-slot-value instance 'direct-methods) nil)
instance))))
(defun eql-specializer-object (eql-specializer)
(check-type eql-specializer eql-specializer)
- (std-slot-value eql-specializer 'sys::object))
+ (std-slot-value eql-specializer 'object))
;;; Initial versions of some method metaobject readers. Defined on
;;; AMOP pg. 218ff, will be redefined when generic functions are set up.
@@ -2998,12 +3037,6 @@
all-keys)
class)
-(defun maybe-finalize-class-subtree (class)
- (when (every #'class-finalized-p (class-direct-superclasses class))
- (finalize-inheritance class)
- (dolist (subclass (class-direct-subclasses class))
- (maybe-finalize-class-subtree subclass))))
-
(defmacro defclass (&whole form name direct-superclasses direct-slots &rest options)
(unless (>= (length form) 3)
(error 'program-error "Wrong number of arguments for DEFCLASS."))
More information about the armedbear-cvs
mailing list