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

diff --git a/src/pcl/cpl.lisp b/src/pcl/cpl.lisp
index 162ba55..fd09bfd 100644
--- a/src/pcl/cpl.lisp
+++ b/src/pcl/cpl.lisp
@@ -23,8 +23,8 @@
 
 (in-package "SB-PCL")
 
-;;; compute-class-precedence-list
-;;;
+;;;; COMPUTE-CLASS-PRECEDENCE-LIST and friends
+
 ;;; Knuth section 2.2.3 has some interesting notes on this.
 ;;;
 ;;; What appears here is basically the algorithm presented there.
@@ -74,32 +74,39 @@
 ;;;    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
-	     (:conc-name nil)
-	     (:print-object (lambda (obj str)
-			      (print-unreadable-object (obj str :type t)
-				(format str "~D" (cpd-count obj)))))
-	     (:constructor make-cpd ()))
+	    (:conc-name nil)
+	    (:print-object (lambda (obj str)
+			     (print-unreadable-object (obj str :type t)
+			       (format str "~D" (cpd-count obj)))))
+	    (:constructor make-cpd ())
+	    (:copier nil))
   (cpd-class  nil)
   (cpd-supers ())
   (cpd-after  ())
   (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)
 
@@ -113,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
@@ -200,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)
@@ -246,21 +259,21 @@
 		 (format nil "named ~S" (class-name class))
 		 class))))
     (mapcar
-      #'(lambda (reason)
-	  (ecase (caddr reason)
-	    (:super
-	      (format
-		nil
-		"The class ~A appears in the supers of the class ~A."
-		(class-or-name (cadr reason))
-		(class-or-name (car reason))))
-	    (:in-supers
-	      (format
-		nil
-		"The class ~A follows the class ~A in the supers of the class ~A."
-		(class-or-name (cadr reason))
-		(class-or-name (car reason))
-		(class-or-name (cadddr reason))))))
+      (lambda (reason)
+	(ecase (caddr reason)
+	  (:super
+	   (format
+	    nil
+	    "The class ~A appears in the supers of the class ~A."
+	    (class-or-name (cadr reason))
+	    (class-or-name (car reason))))
+	  (:in-supers
+	   (format
+	    nil
+	    "The class ~A follows the class ~A in the supers of the class ~A."
+	    (class-or-name (cadr reason))
+	    (class-or-name (car reason))
+	    (class-or-name (cadddr reason))))))
       reasons)))
 
 (defun find-cycle-reasons (all-cpds)