1 ;;;; This software is part of the SBCL system. See the README file for
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
10 ;;;; copyright information from original PCL sources:
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
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
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
29 ;;; compute-class-precedence-list
31 ;;; Knuth section 2.2.3 has some interesting notes on this.
33 ;;; What appears here is basically the algorithm presented there.
35 ;;; The key idea is that we use class-precedence-description (CPD) structures
36 ;;; to store the precedence information as we proceed. The CPD structure for
37 ;;; a class stores two critical pieces of information:
39 ;;; - a count of the number of "reasons" why the class can't go
40 ;;; into the class precedence list yet.
42 ;;; - a list of the "reasons" this class prevents others from
43 ;;; going in until after it
45 ;;; A "reason" is essentially a single local precedence constraint. If a
46 ;;; constraint between two classes arises more than once it generates more
47 ;;; than one reason. This makes things simpler, linear, and isn't a problem
48 ;;; as long as we make sure to keep track of each instance of a "reason".
50 ;;; This code is divided into three phases.
52 ;;; - the first phase simply generates the CPD's for each of the class
53 ;;; and its superclasses. The remainder of the code will manipulate
54 ;;; these CPDs rather than the class objects themselves. At the end
55 ;;; of this pass, the CPD-SUPERS field of a CPD is a list of the CPDs
56 ;;; of the direct superclasses of the class.
58 ;;; - the second phase folds all the local constraints into the CPD
59 ;;; structure. The CPD-COUNT of each CPD is built up, and the
60 ;;; CPD-AFTER fields are augmented to include precedence constraints
61 ;;; from the CPD-SUPERS field and from the order of classes in other
62 ;;; CPD-SUPERS fields.
64 ;;; After this phase, the CPD-AFTER field of a class includes all the
65 ;;; direct superclasses of the class plus any class that immediately
66 ;;; follows the class in the direct superclasses of another. There
67 ;;; can be duplicates in this list. The CPD-COUNT field is equal to
68 ;;; the number of times this class appears in the CPD-AFTER field of
69 ;;; all the other CPDs.
71 ;;; - In the third phase, classes are put into the precedence list one
72 ;;; at a time, with only those classes with a CPD-COUNT of 0 being
73 ;;; candidates for insertion. When a class is inserted , every CPD
74 ;;; in its CPD-AFTER field has its count decremented.
76 ;;; In the usual case, there is only one candidate for insertion at
77 ;;; any point. If there is more than one, the specified tiebreaker
78 ;;; rule is used to choose among them.
80 (defmethod compute-class-precedence-list ((root slot-class))
81 (compute-std-cpl root (class-direct-superclasses root)))
83 (defstruct (class-precedence-description
85 (:print-object (lambda (obj str)
86 (print-unreadable-object (obj str :type t)
87 (format str "~D" (cpd-count obj)))))
88 (:constructor make-cpd ()))
94 (defun compute-std-cpl (class supers)
95 (cond ((null supers) ;First two branches of COND
96 (list class)) ;are implementing the single
97 ((null (cdr supers)) ;inheritance optimization.
99 (compute-std-cpl (car supers)
100 (class-direct-superclasses (car supers)))))
102 (multiple-value-bind (all-cpds nclasses)
103 (compute-std-cpl-phase-1 class supers)
104 (compute-std-cpl-phase-2 all-cpds)
105 (compute-std-cpl-phase-3 class all-cpds nclasses)))))
107 (defvar *compute-std-cpl-class->entry-table-size* 60)
109 (defun compute-std-cpl-phase-1 (class supers)
112 (table (make-hash-table :size *compute-std-cpl-class->entry-table-size*
114 (declare (fixnum nclasses))
115 (labels ((get-cpd (c)
116 (or (gethash c table)
117 (setf (gethash c table) (make-cpd))))
119 (if (forward-referenced-class-p c)
120 (cpl-forward-referenced-class-error class c)
121 (let ((cpd (get-cpd c)))
122 (unless (cpd-class cpd) ;If we have already done this
123 ;class before, we can quit.
124 (setf (cpd-class cpd) c)
127 (setf (cpd-supers cpd) (mapcar #'get-cpd supers))
128 (dolist (super supers)
129 (walk super (class-direct-superclasses super))))))))
131 (values all-cpds nclasses))))
133 (defun compute-std-cpl-phase-2 (all-cpds)
134 (dolist (cpd all-cpds)
135 (let ((supers (cpd-supers cpd)))
137 (setf (cpd-after cpd) (nconc (cpd-after cpd) supers))
138 (incf (cpd-count (car supers)) 1)
140 (t2 (cdr t1) (cdr t1)))
142 (incf (cpd-count (car t2)) 2)
143 (push (car t2) (cpd-after (car t1))))))))
145 (defun compute-std-cpl-phase-3 (class all-cpds nclasses)
146 (let ((candidates ())
150 ;; We have to bootstrap the collection of those CPD's that
151 ;; have a zero count. Once we get going, we will maintain
152 ;; this list incrementally.
153 (dolist (cpd all-cpds)
154 (when (zerop (cpd-count cpd)) (push cpd candidates)))
157 (when (null candidates)
159 ;; If there are no candidates, and enough classes have been put
160 ;; into the precedence list, then we are all done. Otherwise
161 ;; it means there is a consistency problem.
163 (return (reverse rcpl))
164 (cpl-inconsistent-error class all-cpds)))
166 ;; Try to find the next class to put in from among the candidates.
167 ;; If there is only one, its easy, otherwise we have to use the
168 ;; famous RPG tiebreaker rule. There is some hair here to avoid
169 ;; having to call DELETE on the list of candidates. I dunno if
170 ;; its worth it but what the hell.
172 (if (null (cdr candidates))
173 (prog1 (car candidates)
174 (setq candidates ()))
177 (let ((supers (class-direct-superclasses c)))
178 (if (memq (cpd-class (car candidates)) supers)
179 (return-from tie-breaker (pop candidates))
180 (do ((loc candidates (cdr loc)))
182 (let ((cpd (cadr loc)))
183 (when (memq (cpd-class cpd) supers)
184 (setf (cdr loc) (cddr loc))
185 (return-from tie-breaker cpd))))))))))
187 (push (cpd-class next-cpd) rcpl)
188 (dolist (after (cpd-after next-cpd))
189 (when (zerop (decf (cpd-count after)))
190 (push after candidates))))))
192 ;;;; support code for signalling nice error messages
194 (defun cpl-error (class format-string &rest format-args)
195 (error "While computing the class precedence list of the class ~A.~%~A"
196 (if (class-name class)
197 (format nil "named ~S" (class-name class))
199 (apply #'format nil format-string format-args)))
201 (defun cpl-forward-referenced-class-error (class forward-class)
202 (flet ((class-or-name (class)
203 (if (class-name class)
204 (format nil "named ~S" (class-name class))
206 (let ((names (mapcar #'class-or-name
207 (cdr (find-superclass-chain class forward-class)))))
209 "The class ~A is a forward referenced class.~@
211 (class-or-name forward-class)
212 (class-or-name forward-class)
213 (if (null (cdr names))
215 "a direct superclass of the class ~A"
216 (class-or-name class))
218 "reached from the class ~A by following~@
219 the direct superclass chain through: ~A~
220 ~% ending at the class ~A"
221 (class-or-name class)
223 "~{~% the class ~A,~}"
225 (car (last names))))))))
227 (defun find-superclass-chain (bottom top)
228 (labels ((walk (c chain)
230 (return-from find-superclass-chain (nreverse chain))
231 (dolist (super (class-direct-superclasses c))
232 (walk super (cons super chain))))))
233 (walk bottom (list bottom))))
235 (defun cpl-inconsistent-error (class all-cpds)
236 (let ((reasons (find-cycle-reasons all-cpds)))
238 "It is not possible to compute the class precedence list because~@
239 there ~A in the local precedence relations.~@
240 ~A because:~{~% ~A~}."
241 (if (cdr reasons) "are circularities" "is a circularity")
242 (if (cdr reasons) "These arise" "This arises")
243 (format-cycle-reasons (apply #'append reasons)))))
245 (defun format-cycle-reasons (reasons)
246 (flet ((class-or-name (cpd)
247 (let ((class (cpd-class cpd)))
248 (if (class-name class)
249 (format nil "named ~S" (class-name class))
253 (ecase (caddr reason)
257 "The class ~A appears in the supers of the class ~A."
258 (class-or-name (cadr reason))
259 (class-or-name (car reason))))
263 "The class ~A follows the class ~A in the supers of the class ~A."
264 (class-or-name (cadr reason))
265 (class-or-name (car reason))
266 (class-or-name (cadddr reason))))))
269 (defun find-cycle-reasons (all-cpds)
270 (let ((been-here ()) ; list of classes we have visited
273 (labels ((chase (path)
274 (if (memq (car path) (cdr path))
275 (record-cycle (memq (car path) (nreverse path)))
276 (unless (memq (car path) been-here)
277 (push (car path) been-here)
278 (dolist (after (cpd-after (car path)))
279 (chase (cons after path))))))
280 (record-cycle (cycle)
283 (t2 (cdr t1) (cdr t1)))
287 (if (memq c2 (cpd-supers c1))
288 (push (list c1 c2 :super) reasons)
289 (dolist (cpd all-cpds)
290 (when (memq c2 (memq c1 (cpd-supers cpd)))
292 (push (list c1 c2 :in-supers cpd) reasons)))))))
293 (push (nreverse reasons) cycle-reasons))))
295 (dolist (cpd all-cpds)
296 (unless (zerop (cpd-count cpd))