[armedbear-cvs] r13214 - trunk/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Sat Feb 12 13:10:07 2011
New Revision: 13214

Log:
Finalize subclasses as soon as a forward-referenced class gets defined
(and itself can be finalized).

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

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Sat Feb 12 13:10:07 2011
@@ -784,6 +784,7 @@
                       (setf (class-direct-superclasses subclass)
                             (substitute new-class old-class
                                         (class-direct-superclasses subclass))))
+                    (finalize-class-subtree new-class)
                     new-class))
                  (t
                   ;; We're redefining the class.
@@ -804,6 +805,13 @@
              (%set-find-class name class)
              class)))))
 
+
+(defun finalize-class-subtree (class)
+  (when (every #'class-finalized-p (class-direct-superclasses class))
+    (finalize-inheritance class)
+    (dolist (subclass (class-direct-subclasses class))
+       (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."))
@@ -2577,12 +2585,12 @@
             (mapcan #'(lambda (gf)
                         (compute-applicable-methods gf args))
                     gf-list)))
-          (slots (class-slots (class-of instance))))
+	  (slots (class-slots (class-of instance))))
       (do* ((tail initargs (cddr tail))
             (initarg (car tail) (car tail)))
            ((null tail))
         (unless (or (valid-initarg-p initarg slots)
-                    (valid-methodarg-p initarg methods)
+		    (valid-methodarg-p initarg methods)
                     (eq initarg :allow-other-keys))
           (error 'program-error
                  :format-control "Invalid initarg ~S."
@@ -2661,12 +2669,12 @@
   ;; 'initialization argument list' (which is not the same as
   ;; checking initarg validity
   (do* ((tail all-keys (cddr tail))
-        (initarg (car tail) (car tail)))
+	(initarg (car tail) (car tail)))
       ((null tail))
     (unless (symbolp initarg)
       (error 'program-error
-             :format-control "Invalid initarg ~S."
-             :format-arguments (list initarg))))
+	     :format-control "Invalid initarg ~S."
+	     :format-arguments (list initarg))))
   (dolist (slot (class-slots (class-of instance)))
     (let ((slot-name (slot-definition-name slot)))
       (multiple-value-bind (init-key init-value foundp)