Changeset 14004

Timestamp:

07/13/12 14:07:31 (9 years ago)

Author:

rschlatte

Message:

Move definition of eql-specializer metaclass into Lisp side

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• StandardClass.java (modified) (4 diffs)
• clos.lisp (modified) (11 diffs)

trunk/abcl/src/org/armedbear/lisp/StandardClass.java

@@ -200 +200 @@
     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;
@@ -449 +451 @@
   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 =
@@ -732 +732 @@
     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,
@@ -913 +908 @@
     CLASS.finalizeClass();
     BUILT_IN_CLASS.finalizeClass();
-    EQL_SPECIALIZER.finalizeClass();
     METHOD_COMBINATION.finalizeClass();
     SHORT_METHOD_COMBINATION.finalizeClass();

trunk/abcl/src/org/armedbear/lisp/clos.lisp

@@ -215 +215 @@
     (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
@@ -484 +483 @@
   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
@@ -530 +539 @@
             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))
@@ -689 +698 @@
         (types (delete-duplicates
                 (delete t (mapcar #'slot-definition-type direct-slots))
-                :test #'equal))
-        )
+                :test #'equal)))
     (make-effective-slot-definition
      class
@@ -712 +720 @@
                  ((= 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
@@ -817 +827 @@
   (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
@@ -824 +840 @@
   (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)
@@ -870 +889 @@
   (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*
@@ -1344 +1383 @@
             ;; 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))))
@@ -1350 +1389 @@
 (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
@@ -2999 +3038 @@
   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)