1;;;; This software is part of the SBCL system. See the README file for 2;;;; more information. 3 4;;;; This software is derived from software originally released by Xerox 5;;;; Corporation. Copyright and release statements follow. Later modifications 6;;;; to the software are in the public domain and are provided with 7;;;; absolutely no warranty. See the COPYING and CREDITS files for more 8;;;; information. 9 10;;;; copyright information from original PCL sources: 11;;;; 12;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. 13;;;; All rights reserved. 14;;;; 15;;;; Use and copying of this software and preparation of derivative works based 16;;;; upon this software are permitted. Any distribution of this software or 17;;;; derivative works must comply with all applicable United States export 18;;;; control laws. 19;;;; 20;;;; This software is made available AS IS, and Xerox Corporation makes no 21;;;; warranty about the software, its performance or its conformity to any 22;;;; specification. 23 24(in-package "SB-PCL") 25 26;;;; COMPUTE-CLASS-PRECEDENCE-LIST and friends 27 28;;; Knuth section 2.2.3 has some interesting notes on this. 29;;; 30;;; What appears here is basically the algorithm presented there. 31;;; 32;;; The key idea is that we use class-precedence-description (CPD) structures 33;;; to store the precedence information as we proceed. The CPD structure for 34;;; a class stores two critical pieces of information: 35;;; 36;;; - a count of the number of "reasons" why the class can't go 37;;; into the class precedence list yet. 38;;; 39;;; - a list of the "reasons" this class prevents others from 40;;; going in until after it 41;; 42;;; A "reason" is essentially a single local precedence constraint. If a 43;;; constraint between two classes arises more than once it generates more 44;;; than one reason. This makes things simpler, linear, and isn't a problem 45;;; as long as we make sure to keep track of each instance of a "reason". 46;;; 47;;; This code is divided into three phases. 48;;; 49;;; - the first phase simply generates the CPD's for each of the class 50;;; and its superclasses. The remainder of the code will manipulate 51;;; these CPDs rather than the class objects themselves. At the end 52;;; of this pass, the CPD-SUPERS field of a CPD is a list of the CPDs 53;;; of the direct superclasses of the class. 54;;; 55;;; - the second phase folds all the local constraints into the CPD 56;;; structure. The CPD-COUNT of each CPD is built up, and the 57;;; CPD-AFTER fields are augmented to include precedence constraints 58;;; from the CPD-SUPERS field and from the order of classes in other 59;;; CPD-SUPERS fields. 60;;; 61;;; After this phase, the CPD-AFTER field of a class includes all the 62;;; direct superclasses of the class plus any class that immediately 63;;; follows the class in the direct superclasses of another. There 64;;; can be duplicates in this list. The CPD-COUNT field is equal to 65;;; the number of times this class appears in the CPD-AFTER field of 66;;; all the other CPDs. 67;;; 68;;; - In the third phase, classes are put into the precedence list one 69;;; at a time, with only those classes with a CPD-COUNT of 0 being 70;;; candidates for insertion. When a class is inserted , every CPD 71;;; in its CPD-AFTER field has its count decremented. 72;;; 73;;; In the usual case, there is only one candidate for insertion at 74;;; any point. If there is more than one, the specified tiebreaker 75;;; rule is used to choose among them. 76 77(defmethod compute-class-precedence-list ((root class)) 78 (compute-std-cpl root (class-direct-superclasses root))) 79 80(defstruct (class-precedence-description 81 (:conc-name nil) 82 (:constructor make-cpd ()) 83 (:copier nil)) 84 (cpd-class nil) 85 (cpd-supers ()) 86 (cpd-after ()) 87 (cpd-count 0)) 88 89(defun compute-std-cpl (class supers) 90 (cond 91 ;; the first two branches of this COND are implementing an 92 ;; optimization for single inheritance. 93 ((and (null supers) 94 (not (forward-referenced-class-p class))) 95 (list class)) 96 ((and (car supers) 97 (null (cdr supers)) 98 (not (forward-referenced-class-p (car supers)))) 99 (cons class 100 (compute-std-cpl (car supers) 101 (class-direct-superclasses (car supers))))) 102 (t 103 (multiple-value-bind (all-cpds nclasses) 104 (compute-std-cpl-phase-1 class supers) 105 (compute-std-cpl-phase-2 all-cpds) 106 (compute-std-cpl-phase-3 class all-cpds nclasses))))) 107 108(defvar *compute-std-cpl-class->entry-table-size* 60) 109 110(defun compute-std-cpl-phase-1 (class supers) 111 (let ((nclasses 0) 112 (all-cpds ()) 113 (table (make-hash-table :size *compute-std-cpl-class->entry-table-size* 114 :test #'eq))) 115 (declare (fixnum nclasses)) 116 (labels ((get-cpd (c) 117 (or (gethash c table) 118 (setf (gethash c table) (make-cpd)))) 119 (walk (c supers) 120 (declare (special *allow-forward-referenced-classes-in-cpl-p*)) 121 (if (and (forward-referenced-class-p c) 122 (not *allow-forward-referenced-classes-in-cpl-p*)) 123 (cpl-forward-referenced-class-error class c) 124 (let ((cpd (get-cpd c))) 125 (unless (cpd-class cpd) ;If we have already done this 126 ;class before, we can quit. 127 (setf (cpd-class cpd) c) 128 (incf nclasses) 129 (push cpd all-cpds) 130 (setf (cpd-supers cpd) (mapcar #'get-cpd supers)) 131 (dolist (super supers) 132 (walk super (class-direct-superclasses super)))))))) 133 (walk class supers) 134 (values all-cpds nclasses)))) 135 136(defun compute-std-cpl-phase-2 (all-cpds) 137 (dolist (cpd all-cpds) 138 (let ((supers (cpd-supers cpd))) 139 (when supers 140 (setf (cpd-after cpd) (nconc (cpd-after cpd) supers)) 141 (incf (cpd-count (car supers)) 1) 142 (do* ((t1 supers t2) 143 (t2 (cdr t1) (cdr t1))) 144 ((null t2)) 145 (incf (cpd-count (car t2)) 2) 146 (push (car t2) (cpd-after (car t1)))))))) 147 148(defun compute-std-cpl-phase-3 (class all-cpds nclasses) 149 (let ((candidates ()) 150 (next-cpd nil) 151 (rcpl ())) 152 153 ;; We have to bootstrap the collection of those CPD's that 154 ;; have a zero count. Once we get going, we will maintain 155 ;; this list incrementally. 156 (dolist (cpd all-cpds) 157 (when (zerop (cpd-count cpd)) (push cpd candidates))) 158 159 (loop 160 (when (null candidates) 161 162 ;; If there are no candidates, and enough classes have been put 163 ;; into the precedence list, then we are all done. Otherwise 164 ;; it means there is a consistency problem. 165 (if (zerop nclasses) 166 (return (reverse rcpl)) 167 (cpl-inconsistent-error class all-cpds))) 168 169 ;; Try to find the next class to put in from among the candidates. 170 ;; If there is only one, its easy, otherwise we have to use the 171 ;; famous RPG tiebreaker rule. There is some hair here to avoid 172 ;; having to call DELETE on the list of candidates. I dunno if 173 ;; its worth it but what the hell. 174 (setq next-cpd 175 (if (null (cdr candidates)) 176 (prog1 (car candidates) 177 (setq candidates ())) 178 (block tie-breaker 179 (dolist (c rcpl) 180 (let ((supers (class-direct-superclasses c))) 181 (if (memq (cpd-class (car candidates)) supers) 182 (return-from tie-breaker (pop candidates)) 183 (do ((loc candidates (cdr loc))) 184 ((null (cdr loc))) 185 (let ((cpd (cadr loc))) 186 (when (memq (cpd-class cpd) supers) 187 (setf (cdr loc) (cddr loc)) 188 (return-from tie-breaker cpd)))))))))) 189 (decf nclasses) 190 (push (cpd-class next-cpd) rcpl) 191 (dolist (after (cpd-after next-cpd)) 192 (when (zerop (decf (cpd-count after))) 193 (push after candidates)))))) 194 195;;;; support code for signalling nice error messages 196 197(defun cpl-error (class format-string &rest format-args) 198 (error "While computing the class precedence list of the class ~A.~%~A" 199 (if (class-name class) 200 (format nil "named ~/sb-impl::print-symbol-with-prefix/" 201 (class-name class)) 202 class) 203 (apply #'format nil format-string format-args))) 204 205(defun cpl-forward-referenced-class-error (class forward-class) 206 (flet ((class-or-name (class) 207 (if (class-name class) 208 (format nil "named ~/sb-impl::print-symbol-with-prefix/" 209 (class-name class)) 210 class))) 211 (if (eq class forward-class) 212 (cpl-error class 213 "The class ~A is a forward referenced class." 214 (class-or-name class)) 215 (let ((names (mapcar #'class-or-name 216 (cdr (find-superclass-chain class forward-class))))) 217 (cpl-error class 218 "The class ~A is a forward referenced class.~@ 219 The class ~A is ~A." 220 (class-or-name forward-class) 221 (class-or-name forward-class) 222 (if (null (cdr names)) 223 (format nil 224 "a direct superclass of the class ~A" 225 (class-or-name class)) 226 (format nil 227 "reached from the class ~A by following~@ 228 the direct superclass chain through: ~A~ 229 ~% ending at the class ~A" 230 (class-or-name class) 231 (format nil 232 "~{~% the class ~A,~}" 233 (butlast names)) 234 (car (last names))))))))) 235 236(defun find-superclass-chain (bottom top) 237 (labels ((walk (c chain) 238 (if (eq c top) 239 (return-from find-superclass-chain (nreverse chain)) 240 (dolist (super (class-direct-superclasses c)) 241 (walk super (cons super chain)))))) 242 (walk bottom (list bottom)))) 243 244(defun cpl-inconsistent-error (class all-cpds) 245 (let ((reasons (find-cycle-reasons all-cpds))) 246 (cpl-error class 247 "It is not possible to compute the class precedence list because~@ 248 there ~A in the local precedence relations.~@ 249 ~A because:~{~% ~A~}." 250 (if (cdr reasons) "are circularities" "is a circularity") 251 (if (cdr reasons) "These arise" "This arises") 252 (format-cycle-reasons (apply #'append reasons))))) 253 254(defun format-cycle-reasons (reasons) 255 (flet ((class-or-name (cpd) 256 (let ((class (cpd-class cpd))) 257 (if (class-name class) 258 (format nil "named ~/sb-impl::print-symbol-with-prefix/" 259 (class-name class)) 260 class)))) 261 (mapcar 262 (lambda (reason) 263 (ecase (caddr reason) 264 (:super 265 (format 266 nil 267 "The class ~A appears in the supers of the class ~A." 268 (class-or-name (cadr reason)) 269 (class-or-name (car reason)))) 270 (:in-supers 271 (format 272 nil 273 "The class ~A follows the class ~A in the supers of the class ~A." 274 (class-or-name (cadr reason)) 275 (class-or-name (car reason)) 276 (class-or-name (cadddr reason)))))) 277 reasons))) 278 279(defun find-cycle-reasons (all-cpds) 280 (let ((been-here ()) ; list of classes we have visited 281 (cycle-reasons ())) 282 283 (labels ((chase (path) 284 (if (memq (car path) (cdr path)) 285 (record-cycle (memq (car path) (nreverse path))) 286 (unless (memq (car path) been-here) 287 (push (car path) been-here) 288 (dolist (after (cpd-after (car path))) 289 (chase (cons after path)))))) 290 (record-cycle (cycle) 291 (let ((reasons ())) 292 (do* ((t1 cycle t2) 293 (t2 (cdr t1) (cdr t1))) 294 ((null t2)) 295 (let ((c1 (car t1)) 296 (c2 (car t2))) 297 (if (memq c2 (cpd-supers c1)) 298 (push (list c1 c2 :super) reasons) 299 (dolist (cpd all-cpds) 300 (when (memq c2 (memq c1 (cpd-supers cpd))) 301 (return 302 (push (list c1 c2 :in-supers cpd) reasons))))))) 303 (push (nreverse reasons) cycle-reasons)))) 304 305 (dolist (cpd all-cpds) 306 (unless (zerop (cpd-count cpd)) 307 (chase (list cpd)))) 308 309 cycle-reasons))) 310 311