Index: /trunk/ccl/level-1/l1-clos.lisp
===================================================================
--- /trunk/ccl/level-1/l1-clos.lisp	(revision 749)
+++ /trunk/ccl/level-1/l1-clos.lisp	(revision 750)
@@ -413,5 +413,5 @@
 
 ;;; 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,7 +464,4 @@
                   (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,9 +497,16 @@
 
 
-(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,5 +542,4 @@
     (finalize-inheritance class)
     (return-from update-class))
-
   (when (or finalizep
 	    (class-finalized-p class)
@@ -671,5 +674,5 @@
   (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,4 +1231,6 @@
       (fdefinition '%method-lambda-list) #'method-lambda-list
       )
+
+(setf (fdefinition '%add-method) #'add-method)