From 6b223b43ffab1ddd8c72857d3b3d3c8dc2ca09e7 Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Tue, 8 Aug 2000 13:41:19 +0000
Subject: [PATCH] Add support for computing class precedence lists, and use
 this to correctly calculate the CPL for the condition classes.

---
 code/class.lisp   | 88 +++++++++++++++++++++++++++++++++++++++++++++--
 code/error.lisp   | 21 +++--------
 code/exports.lisp |  3 +-
 3 files changed, 93 insertions(+), 19 deletions(-)

diff --git a/code/class.lisp b/code/class.lisp
index 300d05b09..b1f45d782 100644
--- a/code/class.lisp
+++ b/code/class.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.45 2000/08/07 14:27:25 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.46 2000/08/08 13:41:18 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -34,7 +34,7 @@
 		 built-in-class-direct-superclasses
 		 find-class-cell class-cell-name class-cell-class
 		 make-layout make-undefined-class insured-find-class
-		 redefine-layout-warning))
+		 redefine-layout-warning std-compute-class-precedence-list))
 
 (in-package "LISP")
 (export '(class structure-class standard-class class-name find-class class-of
@@ -1125,6 +1125,90 @@
 	       old)))
 	  (t old))))
 
+
+;;; Class precedence lists
+
+;;; topological-sort  --  Public.
+;;;
+;;; Topologically sort the list of objects to meet a set of ordering
+;;; constraints given by pairs (A . B) constraining A to precede B.  When
+;;; there are multiple objects to choose, the tie-breaker function is called
+;;; with both the list of object to choose from and the reverse ordering built
+;;; so far.
+;;;
+(defun topological-sort (objects constraints tie-breaker)
+  (declare (list objects constraints)
+	   (function tie-breaker))
+  (let ((obj-info (make-hash-table :size (length objects)))
+	(free-objs nil)
+	(result nil))
+    (dolist (constraint constraints)
+      (let ((obj1 (car constraint))
+	    (obj2 (cdr constraint)))
+	(let ((info2 (gethash obj2 obj-info)))
+	  (if info2
+	      (incf (first info2))
+	      (setf (gethash obj2 obj-info) (list 1))))
+	(let ((info1 (gethash obj1 obj-info)))
+	  (if info1
+	      (push obj2 (rest info1))
+	      (setf (gethash obj1 obj-info) (list 0 obj2))))))
+    (dolist (obj objects)
+      (let ((info (gethash obj obj-info)))
+	(when (or (not info) (zerop (first info)))
+	  (push obj free-objs))))
+    (loop
+     (flet ((next-result (obj)
+	      (push obj result)
+	      (dolist (successor (rest (gethash obj obj-info)))
+		(let* ((successor-info (gethash successor obj-info))
+		       (count (1- (first successor-info))))
+		  (setf (first successor-info) count)
+		  (when (zerop count)
+		    (push successor free-objs))))))
+       (cond ((endp free-objs)
+	      (do-hash (obj info obj-info)
+		(unless (zerop (first info))
+		  (error "Topological sort failed due to constrain on ~S."
+			 obj)))
+	      (return (nreverse result)))
+	     ((endp (rest free-objs))
+	      (next-result (pop free-objs)))
+	     (t
+	      (let ((obj (funcall tie-breaker free-objs result)))
+		(setf free-objs (remove obj free-objs))
+		(next-result obj))))))))
+
+
+;;; std-compute-class-precedence-list  --  Internal.
+;;;
+;;; Standard class precedence list computation.
+;;;
+(defun std-compute-class-precedence-list (class)
+  (let ((classes nil)
+	(constraints nil))
+    (labels ((note-class (class)
+	       (unless (member class classes)
+		 (push class classes)
+		 (let ((superclasses (class-direct-superclasses class)))
+		   (do ((prev class)
+			(rest superclasses (rest rest)))
+		       ((endp rest))
+		     (let ((next (first rest)))
+		       (push (cons prev next) constraints)
+		       (setf prev next)))
+		   (dolist (class superclasses)
+		     (note-class class)))))
+	     (std-cpl-tie-breaker (free-classes rev-cpl)
+	       (dolist (class rev-cpl (first free-classes))
+		 (let* ((superclasses (class-direct-superclasses class))
+			(intersection (intersection free-classes
+						    superclasses)))
+		   (when intersection
+		     (return (first intersection)))))))
+      (note-class class)
+      (topological-sort classes constraints #'std-cpl-tie-breaker))))
+
 
 ;;; PCL stuff:
 
diff --git a/code/error.lisp b/code/error.lisp
index 9eb7cfd0d..996291256 100644
--- a/code/error.lisp
+++ b/code/error.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.56 2000/08/06 19:12:17 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.57 2000/08/08 13:41:18 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -437,9 +437,6 @@
 
 ;;;; Condition reporting:
 
-;;; 7/13/98 BUG? CPL is not sorted and results here depend on order of
-;;; superclasses in define-condition call!
-
 (defun %print-condition (s stream d)
   (declare (ignore d))
   (if *print-escape*
@@ -583,18 +580,10 @@
 
     (setf (find-class name) class)
     ;;
-    ;; Initialize CPL slot from layout.
-    (collect ((cpl))
-      (cpl class)
-      (let ((inherits (layout-inherits layout)))
-	(do ((i (1- (length inherits)) (1- i)))
-	    ((minusp i))
-	  (let ((super (find-class
-			(class-name
-			 (layout-class (svref inherits i))))))
-	    (when (typep super 'condition-class)
-	      (cpl super)))))
-      (setf (condition-class-cpl class) (cpl))))
+    ;; Initialize CPL slot.
+    (setf (condition-class-cpl class)
+	  (remove-if-not #'condition-class-p 
+			 (std-compute-class-precedence-list class))))
   (undefined-value))
 
 ); eval-when (compile load eval)
diff --git a/code/exports.lisp b/code/exports.lisp
index 00e1628ba..819134361 100644
--- a/code/exports.lisp
+++ b/code/exports.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.171 2000/08/06 19:12:18 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.172 2000/08/08 13:41:19 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1594,6 +1594,7 @@
 	   "SIMPLE-ARRAY-SIGNED-BYTE-32-P" "SIMPLE-ARRAY-SIGNED-BYTE-8-P" 
 	   "SIMPLE-UNBOXED-ARRAY" "SINGLE-FLOAT-BITS" "SINGLE-FLOAT-EXPONENT"
 	   "SINGLE-FLOAT-P" "SINGLE-VALUE-TYPE" "SPECIFIER-TYPE" "STACK-REF"
+	   "STD-COMPUTE-CLASS-PRECEDENCE-LIST"
 	   "STREAMLIKE" "STRINGABLE" "STRINGLIKE"
 	   "%INSTANCE-LENGTH"
 	   "%INSTANCE-REF" "%INSTANCE-SET"
-- 
GitLab