Changeset 13791

Timestamp:

01/17/12 22:44:37 (11 years ago)

Author:

rschlatte

Message:

Merge branch 'mop-work'

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• ForwardReferencedClass.java (deleted)
• StandardClass.java (modified) (2 diffs)
• clos.lisp (modified) (7 diffs)

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

@@ -655 +655 @@
     FORWARD_REFERENCED_CLASS.setCPL(FORWARD_REFERENCED_CLASS, CLASS,
                                     SPECIALIZER, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T);
-    FUNCALLABLE_STANDARD_OBJECT.setCPL(FUNCALLABLE_STANDARD_OBJECT, STANDARD_OBJECT, BuiltInClass.FUNCTION, BuiltInClass.CLASS_T);
+    // Not all of these slots are necessary, but for now we take the
+    // standard layout.  Instances of this class will be redefined and
+    // get a new layout in due course.
+    FORWARD_REFERENCED_CLASS.setClassLayout(layoutStandardClass);
+    FORWARD_REFERENCED_CLASS.setDirectSlotDefinitions(standardClassSlotDefinitions());
+    FUNCALLABLE_STANDARD_OBJECT.setCPL(FUNCALLABLE_STANDARD_OBJECT,
+                                       STANDARD_OBJECT, BuiltInClass.FUNCTION,
+                                       BuiltInClass.CLASS_T);
     GENERIC_FUNCTION.setCPL(GENERIC_FUNCTION, METAOBJECT,
                             FUNCALLABLE_STANDARD_OBJECT, STANDARD_OBJECT,
@@ -786 +793 @@
     CLASS.finalizeClass();
     FUNCALLABLE_STANDARD_CLASS.finalizeClass();
+    FORWARD_REFERENCED_CLASS.finalizeClass();
     GENERIC_FUNCTION.finalizeClass();
     ARITHMETIC_ERROR.finalizeClass();

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

@@ -103 +103 @@
 (defconstant +the-standard-object-class+ (find-class 'standard-object))
 (defconstant +the-standard-method-class+ (find-class 'standard-method))
+(defconstant +the-forward-referenced-class+
+  (find-class 'forward-referenced-class))
 (defconstant +the-standard-reader-method-class+
   (find-class 'standard-reader-method))
@@ -286 +288 @@
   (when (fboundp 'note-name-defined)
     (note-name-defined name)))
-
-(defun canonicalize-direct-superclasses (direct-superclasses)
-  (let ((classes '()))
-    (dolist (class-specifier direct-superclasses)
-      (let ((class (if (classp class-specifier)
-                       class-specifier
-                       (find-class class-specifier nil))))
-        (unless class
-          (setf class (make-forward-referenced-class class-specifier)))
-        (when (and (typep class 'built-in-class)
-                   (not (member class *extensible-built-in-classes*)))
-          (error "Attempt to define a subclass of built-in-class ~S."
-                 class-specifier))
-        (push class classes)))
-    (nreverse classes)))
 
 (defun canonicalize-defclass-options (options)
@@ -2548 +2535 @@
                :format-arguments (list name))))))
 
+(defun canonicalize-direct-superclasses (direct-superclasses)
+  (let ((classes '()))
+    (dolist (class-specifier direct-superclasses)
+      (let ((class (if (classp class-specifier)
+                       class-specifier
+                       (find-class class-specifier nil))))
+        (unless class
+          (setf class (make-instance +the-forward-referenced-class+
+                                     :name class-specifier))
+          (setf (find-class class-specifier) class))
+        (when (and (typep class 'built-in-class)
+                   (not (member class *extensible-built-in-classes*)))
+          (error "Attempt to define a subclass of built-in-class ~S."
+                 class-specifier))
+        (push class classes)))
+    (nreverse classes)))
+
  ;;; AMOP pg. 182
 (defun ensure-class (name &rest all-keys &key &allow-other-keys)
@@ -2554 +2558 @@
 ;;; AMOP pg. 183ff.
 (defgeneric ensure-class-using-class (class name &key direct-default-initargs
-                                      direct-slots direct-superclasses name
+                                      direct-slots direct-superclasses
                                       metaclass &allow-other-keys))
 
@@ -2584 +2588 @@
   (error "The symbol ~S names a built-in class." name))
 
- (defmethod ensure-class-using-class ((class forward-referenced-class) name
-                                      &key (metaclass +the-standard-class+)
-                                      direct-superclasses
-                                      &rest all-keys &key &allow-other-keys)
-   (setf all-keys (copy-list all-keys))  ; since we modify it
-   (remf all-keys :metaclass)
-   (change-class class metaclass)
-   (apply #'reinitialize-instance class
-          :direct-superclasses (canonicalize-direct-superclasses
-                                direct-superclasses)
-          all-keys)
-   class)
+(defmethod ensure-class-using-class ((class forward-referenced-class) name
+                                     &rest all-keys
+                                     &key (metaclass +the-standard-class+)
+                                     direct-superclasses &allow-other-keys)
+  (setf all-keys (copy-list all-keys))  ; since we modify it
+  (remf all-keys :metaclass)
+  (change-class class metaclass)
+  (apply #'reinitialize-instance class
+         :name name
+         :direct-superclasses (canonicalize-direct-superclasses
+                               direct-superclasses)
+         all-keys)
+  class)
 
 (defmethod ensure-class-using-class ((class class) name
@@ -2601 +2606 @@
                                      direct-superclasses &rest all-keys
                                      &allow-other-keys)
+  (declare (ignore name))
   (setf all-keys (copy-list all-keys))  ; since we modify it
   (remf all-keys :metaclass)
@@ -3047 +3053 @@
   (std-shared-initialize instance slot-names initargs))
 
+(defmethod shared-initialize :after ((instance standard-class) slot-names
+                                     &key direct-superclasses
+                                     direct-slots direct-default-initargs
+                                     &allow-other-keys)
+  (std-after-initialization-for-classes
+   instance :direct-superclasses direct-superclasses
+   :direct-slots direct-slots
+   :direct-default-initargs direct-default-initargs))
+
+(defmethod shared-initialize :after ((instance funcallable-standard-class)
+                                     slot-names &key direct-superclasses
+                                     direct-slots direct-default-initargs
+                                     &allow-other-keys)
+  (std-after-initialization-for-classes
+   instance :direct-superclasses direct-superclasses
+   :direct-slots direct-slots
+   :direct-default-initargs direct-default-initargs))
+
 (defmethod shared-initialize ((slot slot-definition) slot-names
                               &rest args