X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcpl.lisp;h=fd09bfd3e894b31f0aa8b515a7ad0ea52f1ef57f;hb=bd0ba0f214518e8d72ff2d44de5a1e3e4b02af2c;hp=f834b1a6e870852c127363915dd02aa9909e3bbe;hpb=ed7ba4dad8a79726fdfeba5aa12e276ea852c540;p=sbcl.git

diff --git a/src/pcl/cpl.lisp b/src/pcl/cpl.lisp
index f834b1a..fd09bfd 100644
--- a/src/pcl/cpl.lisp
+++ b/src/pcl/cpl.lisp
@@ -74,7 +74,7 @@
 ;;;    any point. If there is more than one, the specified tiebreaker
 ;;;    rule is used to choose among them.
 
-(defmethod compute-class-precedence-list ((root slot-class))
+(defmethod compute-class-precedence-list ((root class))
   (compute-std-cpl root (class-direct-superclasses root)))
 
 (defstruct (class-precedence-description
@@ -90,17 +90,23 @@
   (cpd-count  0))
 
 (defun compute-std-cpl (class supers)
-  (cond ((null supers)				;First two branches of COND
-	 (list class))				;are implementing the single
-	((null (cdr supers))			;inheritance optimization.
-	 (cons class
-	       (compute-std-cpl (car supers)
-				(class-direct-superclasses (car supers)))))
-	(t
-	 (multiple-value-bind (all-cpds nclasses)
-	     (compute-std-cpl-phase-1 class supers)
-	   (compute-std-cpl-phase-2 all-cpds)
-	   (compute-std-cpl-phase-3 class all-cpds nclasses)))))
+  (cond
+    ;; the first two branches of this COND are implementing an
+    ;; optimization for single inheritance.
+    ((and (null supers)
+	  (not (forward-referenced-class-p class)))
+     (list class))
+    ((and (car supers)
+	  (null (cdr supers))
+	  (not (forward-referenced-class-p (car supers))))
+     (cons class
+	   (compute-std-cpl (car supers)
+			    (class-direct-superclasses (car supers)))))
+    (t
+     (multiple-value-bind (all-cpds nclasses)
+	 (compute-std-cpl-phase-1 class supers)
+       (compute-std-cpl-phase-2 all-cpds)
+       (compute-std-cpl-phase-3 class all-cpds nclasses)))))
 
 (defvar *compute-std-cpl-class->entry-table-size* 60)
 
@@ -114,7 +120,9 @@
 	       (or (gethash c table)
 		   (setf (gethash c table) (make-cpd))))
 	     (walk (c supers)
-	       (if (forward-referenced-class-p c)
+	       (declare (special *allow-forward-referenced-classes-in-cpl-p*))
+	       (if (and (forward-referenced-class-p c)
+			(not *allow-forward-referenced-classes-in-cpl-p*))
 		   (cpl-forward-referenced-class-error class c)
 		   (let ((cpd (get-cpd c)))
 		     (unless (cpd-class cpd)	;If we have already done this
@@ -201,26 +209,30 @@
 	   (if (class-name class)
 	       (format nil "named ~S" (class-name class))
 	       class)))
-    (let ((names (mapcar #'class-or-name
-			 (cdr (find-superclass-chain class forward-class)))))
-      (cpl-error class
-		 "The class ~A is a forward referenced class.~@
-		  The class ~A is ~A."
-		 (class-or-name forward-class)
-		 (class-or-name forward-class)
-		 (if (null (cdr names))
-		     (format nil
-			     "a direct superclass of the class ~A"
-			     (class-or-name class))
-		     (format nil
-			     "reached from the class ~A by following~@
+    (if (eq class forward-class)
+	(cpl-error class
+		   "The class ~A is a forward referenced class."
+		   (class-or-name class))
+	(let ((names (mapcar #'class-or-name
+			     (cdr (find-superclass-chain class forward-class)))))
+	  (cpl-error class
+		     "The class ~A is a forward referenced class.~@
+                      The class ~A is ~A."
+		     (class-or-name forward-class)
+		     (class-or-name forward-class)
+		     (if (null (cdr names))
+			 (format nil
+				 "a direct superclass of the class ~A"
+				 (class-or-name class))
+			 (format nil
+				 "reached from the class ~A by following~@
 			      the direct superclass chain through: ~A~
 			      ~%  ending at the class ~A"
-			     (class-or-name class)
-			     (format nil
-				     "~{~%  the class ~A,~}"
-				     (butlast names))
-			     (car (last names))))))))
+				 (class-or-name class)
+				 (format nil
+					 "~{~%  the class ~A,~}"
+					 (butlast names))
+				 (car (last names)))))))))
 
 (defun find-superclass-chain (bottom top)
   (labels ((walk (c chain)