Don't go through fdefn when referencing #'known-functions.
[sbcl.git] / src / pcl / cpl.lisp
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 \f
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             (:print-object (lambda (obj str)
83                              (print-unreadable-object (obj str :type t)
84                                (format str "~D" (cpd-count obj)))))
85             (:constructor make-cpd ())
86             (:copier nil))
87   (cpd-class  nil)
88   (cpd-supers ())
89   (cpd-after  ())
90   (cpd-count  0))
91
92 (defun compute-std-cpl (class supers)
93   (cond
94     ;; the first two branches of this COND are implementing an
95     ;; optimization for single inheritance.
96     ((and (null supers)
97           (not (forward-referenced-class-p class)))
98      (list class))
99     ((and (car supers)
100           (null (cdr supers))
101           (not (forward-referenced-class-p (car supers))))
102      (cons class
103            (compute-std-cpl (car supers)
104                             (class-direct-superclasses (car supers)))))
105     (t
106      (multiple-value-bind (all-cpds nclasses)
107          (compute-std-cpl-phase-1 class supers)
108        (compute-std-cpl-phase-2 all-cpds)
109        (compute-std-cpl-phase-3 class all-cpds nclasses)))))
110
111 (defvar *compute-std-cpl-class->entry-table-size* 60)
112
113 (defun compute-std-cpl-phase-1 (class supers)
114   (let ((nclasses 0)
115         (all-cpds ())
116         (table (make-hash-table :size *compute-std-cpl-class->entry-table-size*
117                                 :test #'eq)))
118     (declare (fixnum nclasses))
119     (labels ((get-cpd (c)
120                (or (gethash c table)
121                    (setf (gethash c table) (make-cpd))))
122              (walk (c supers)
123                (declare (special *allow-forward-referenced-classes-in-cpl-p*))
124                (if (and (forward-referenced-class-p c)
125                         (not *allow-forward-referenced-classes-in-cpl-p*))
126                    (cpl-forward-referenced-class-error class c)
127                    (let ((cpd (get-cpd c)))
128                      (unless (cpd-class cpd)    ;If we have already done this
129                                                 ;class before, we can quit.
130                        (setf (cpd-class cpd) c)
131                        (incf nclasses)
132                        (push cpd all-cpds)
133                        (setf (cpd-supers cpd) (mapcar #'get-cpd supers))
134                        (dolist (super supers)
135                          (walk super (class-direct-superclasses super))))))))
136       (walk class supers)
137       (values all-cpds nclasses))))
138
139 (defun compute-std-cpl-phase-2 (all-cpds)
140   (dolist (cpd all-cpds)
141     (let ((supers (cpd-supers cpd)))
142       (when supers
143         (setf (cpd-after cpd) (nconc (cpd-after cpd) supers))
144         (incf (cpd-count (car supers)) 1)
145         (do* ((t1 supers t2)
146               (t2 (cdr t1) (cdr t1)))
147              ((null t2))
148           (incf (cpd-count (car t2)) 2)
149           (push (car t2) (cpd-after (car t1))))))))
150
151 (defun compute-std-cpl-phase-3 (class all-cpds nclasses)
152   (let ((candidates ())
153         (next-cpd nil)
154         (rcpl ()))
155
156     ;; We have to bootstrap the collection of those CPD's that
157     ;; have a zero count. Once we get going, we will maintain
158     ;; this list incrementally.
159     (dolist (cpd all-cpds)
160       (when (zerop (cpd-count cpd)) (push cpd candidates)))
161
162     (loop
163       (when (null candidates)
164
165         ;; If there are no candidates, and enough classes have been put
166         ;; into the precedence list, then we are all done. Otherwise
167         ;; it means there is a consistency problem.
168         (if (zerop nclasses)
169             (return (reverse rcpl))
170             (cpl-inconsistent-error class all-cpds)))
171
172       ;; Try to find the next class to put in from among the candidates.
173       ;; If there is only one, its easy, otherwise we have to use the
174       ;; famous RPG tiebreaker rule. There is some hair here to avoid
175       ;; having to call DELETE on the list of candidates. I dunno if
176       ;; its worth it but what the hell.
177       (setq next-cpd
178             (if (null (cdr candidates))
179                 (prog1 (car candidates)
180                        (setq candidates ()))
181                 (block tie-breaker
182                   (dolist (c rcpl)
183                     (let ((supers (class-direct-superclasses c)))
184                       (if (memq (cpd-class (car candidates)) supers)
185                           (return-from tie-breaker (pop candidates))
186                           (do ((loc candidates (cdr loc)))
187                               ((null (cdr loc)))
188                             (let ((cpd (cadr loc)))
189                               (when (memq (cpd-class cpd) supers)
190                                 (setf (cdr loc) (cddr loc))
191                                 (return-from tie-breaker cpd))))))))))
192       (decf nclasses)
193       (push (cpd-class next-cpd) rcpl)
194       (dolist (after (cpd-after next-cpd))
195         (when (zerop (decf (cpd-count after)))
196           (push after candidates))))))
197 \f
198 ;;;; support code for signalling nice error messages
199
200 (defun cpl-error (class format-string &rest format-args)
201   (error "While computing the class precedence list of the class ~A.~%~A"
202           (if (class-name class)
203               (format nil "named ~/sb-impl::print-symbol-with-prefix/"
204                       (class-name class))
205               class)
206           (apply #'format nil format-string format-args)))
207
208 (defun cpl-forward-referenced-class-error (class forward-class)
209   (flet ((class-or-name (class)
210            (if (class-name class)
211                (format nil "named ~/sb-impl::print-symbol-with-prefix/"
212                        (class-name class))
213                class)))
214     (if (eq class forward-class)
215         (cpl-error class
216                    "The class ~A is a forward referenced class."
217                    (class-or-name class))
218         (let ((names (mapcar #'class-or-name
219                              (cdr (find-superclass-chain class forward-class)))))
220           (cpl-error class
221                      "The class ~A is a forward referenced class.~@
222                       The class ~A is ~A."
223                      (class-or-name forward-class)
224                      (class-or-name forward-class)
225                      (if (null (cdr names))
226                          (format nil
227                                  "a direct superclass of the class ~A"
228                                  (class-or-name class))
229                          (format nil
230                                  "reached from the class ~A by following~@
231                               the direct superclass chain through: ~A~
232                               ~%  ending at the class ~A"
233                                  (class-or-name class)
234                                  (format nil
235                                          "~{~%  the class ~A,~}"
236                                          (butlast names))
237                                  (car (last names)))))))))
238
239 (defun find-superclass-chain (bottom top)
240   (labels ((walk (c chain)
241              (if (eq c top)
242                  (return-from find-superclass-chain (nreverse chain))
243                  (dolist (super (class-direct-superclasses c))
244                    (walk super (cons super chain))))))
245     (walk bottom (list bottom))))
246
247 (defun cpl-inconsistent-error (class all-cpds)
248   (let ((reasons (find-cycle-reasons all-cpds)))
249     (cpl-error class
250       "It is not possible to compute the class precedence list because~@
251        there ~A in the local precedence relations.~@
252        ~A because:~{~%  ~A~}."
253       (if (cdr reasons) "are circularities" "is a circularity")
254       (if (cdr reasons) "These arise" "This arises")
255       (format-cycle-reasons (apply #'append reasons)))))
256
257 (defun format-cycle-reasons (reasons)
258   (flet ((class-or-name (cpd)
259            (let ((class (cpd-class cpd)))
260              (if (class-name class)
261                  (format nil "named ~/sb-impl::print-symbol-with-prefix/"
262                          (class-name class))
263                  class))))
264     (mapcar
265       (lambda (reason)
266         (ecase (caddr reason)
267           (:super
268            (format
269             nil
270             "The class ~A appears in the supers of the class ~A."
271             (class-or-name (cadr reason))
272             (class-or-name (car reason))))
273           (:in-supers
274            (format
275             nil
276             "The class ~A follows the class ~A in the supers of the class ~A."
277             (class-or-name (cadr reason))
278             (class-or-name (car reason))
279             (class-or-name (cadddr reason))))))
280       reasons)))
281
282 (defun find-cycle-reasons (all-cpds)
283   (let ((been-here ())     ; list of classes we have visited
284         (cycle-reasons ()))
285
286     (labels ((chase (path)
287                (if (memq (car path) (cdr path))
288                    (record-cycle (memq (car path) (nreverse path)))
289                    (unless (memq (car path) been-here)
290                      (push (car path) been-here)
291                      (dolist (after (cpd-after (car path)))
292                        (chase (cons after path))))))
293              (record-cycle (cycle)
294                (let ((reasons ()))
295                  (do* ((t1 cycle t2)
296                        (t2 (cdr t1) (cdr t1)))
297                       ((null t2))
298                    (let ((c1 (car t1))
299                          (c2 (car t2)))
300                      (if (memq c2 (cpd-supers c1))
301                          (push (list c1 c2 :super) reasons)
302                          (dolist (cpd all-cpds)
303                            (when (memq c2 (memq c1 (cpd-supers cpd)))
304                              (return
305                                (push (list c1 c2 :in-supers cpd) reasons)))))))
306                  (push (nreverse reasons) cycle-reasons))))
307
308       (dolist (cpd all-cpds)
309         (unless (zerop (cpd-count cpd))
310           (chase (list cpd))))
311
312       cycle-reasons)))
313