tests: Avoid nonsensical classes and methods in deprecation.impure.lisp
[sbcl.git] / src / pcl / cpl.lisp
blob560e8da7225b7771f97b526702346486ef81c909
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
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.
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.
24 (in-package "SB-PCL")
26 ;;;; COMPUTE-CLASS-PRECEDENCE-LIST and friends
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
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.
77 (defmethod compute-class-precedence-list ((root class))
78 (compute-std-cpl root (class-direct-superclasses root)))
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))
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)))))
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)))))
108 (defvar *compute-std-cpl-class->entry-table-size* 60)
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))))
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))))))))
148 (defun compute-std-cpl-phase-3 (class all-cpds nclasses)
149 (let ((candidates ())
150 (next-cpd nil)
151 (rcpl ()))
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)))
159 (loop
160 (when (null candidates)
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)))
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))))))
195 ;;;; support code for signalling nice error messages
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)))
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)))))))))
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))))
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)))))
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
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
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)))
279 (defun find-cycle-reasons (all-cpds)
280 (let ((been-here ()) ; list of classes we have visited
281 (cycle-reasons ()))
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))))
305 (dolist (cpd all-cpds)
306 (unless (zerop (cpd-count cpd))
307 (chase (list cpd))))
309 cycle-reasons)))