Changeset 750

Timestamp:

Apr 2, 2004, 9:44:35 PM (21 years ago)

Author:

Gary Byers

Message:

Check for circularities when checking for forward-referenced superclasses.
Redefine %ADD-METHOD as ADD-METHOD when we're able to.
ENSURE-CLASS-USING-CLASS of a forward-referenced class passes initargs
to CHANGE-CLASS.

File:

• trunk/ccl/level-1/l1-clos.lisp (modified) (6 diffs)

trunk/ccl/level-1/l1-clos.lisp

@@ -413 +413 @@
 
 ;;; Standard classes are finalized if they have a wrapper and that
-;;; wrapper as an instance-slots vector; that implies that
+;;; wrapper has an instance-slots vector; that implies that
 ;;; both UPDATE-CPL and UPDATE-SLOTS have been called on the class.
 (defmethod class-finalized-p ((class std-class))
@@ -464 +464 @@
                   (unless (eq (%slot-definition-name (car sup-slotds))
                               (%slot-definition-name (car primary-slotds)))
-                    (format t "~&name of sup-slotds = ~s, name of prim = ~s"
-                            (%slot-definition-name (car sup-slotds))
-                            (%slot-definition-name (car primary-slotds)))
                     (error "While initializing ~s:~%~
                             attempt to mix incompatible primary classes:~%~
@@ -500 +497 @@
 
 
-(defun class-has-a-forward-referenced-superclass-p (class)
-  (or (if (forward-referenced-class-p class) class)
-      (dolist (s (%class-direct-superclasses class))
-        (let* ((fwdref (class-has-a-forward-referenced-superclass-p s)))
-          (when fwdref (return fwdref))))))
+(defun class-has-a-forward-referenced-superclass-p (original)
+  (labels ((scan-forward-refs (class seen)
+             (unless (memq class seen)
+               (or (if (forward-referenced-class-p class) class)
+                   (progn
+                     (push class seen)
+                     (dolist (s (%class-direct-superclasses class))
+                       (when (eq s original)
+                         (error "circular class hierarchy: the class ~s is a superclass of at least one of its superclasses (~s)." original class))
+                       (let* ((fwdref (scan-forward-refs s seen)))
+                         (when fwdref (return fwdref)))))))))
+    (scan-forward-refs original ())))
 
 
@@ -538 +542 @@
     (finalize-inheritance class)
     (return-from update-class))
-
   (when (or finalizep
             (class-finalized-p class)
@@ -671 +674 @@
   (multiple-value-bind (metaclass initargs)
       (ensure-class-metaclass-and-initargs class keys)
-    (change-class class metaclass)
+    (apply #'change-class class metaclass initargs)
     (apply #'reinitialize-instance class initargs)
     (setf (find-class name) class)))
@@ -1228 +1231 @@
       (fdefinition '%method-lambda-list) #'method-lambda-list
       )
+
+(setf (fdefinition '%add-method) #'add-method)