/[cmucl]/src/pcl/cpl.lisp
ViewVC logotype

Contents of /src/pcl/cpl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (hide annotations)
Sat Mar 22 16:15:17 2003 UTC (11 years ago) by gerd
Branch: MAIN
Changes since 1.10: +44 -33 lines
* bootfiles/18e/boot[12].lisp: Bootstrap files for the lisp:class
= pcl:class part.  To get it booted from 18e, cross-compile using
boot1.lisp as bootstrap.lisp in pmai's build scripts, then do a
normal compile with boot2.lisp as bootstrap.lisp with the
resulting Lisp.

* code/byte-interp.lisp, code/defstruct.lisp, code/describe.lisp:
* code/error.lisp, code/exports.lisp, code/hash-new.lisp:
* code/hash.lisp, code/macros.lisp, code/misc.lisp:
* code/package.lisp, code/pred.lisp, code/sharpm.lisp, code/type.lisp:
* compiler/dump.lisp, compiler/fndb.lisp, compiler/globaldb.lisp:
* compiler/proclaim.lisp, compiler/typetran.lisp, compiler/xref.lisp:
* compiler/generic/primtype.lisp, compiler/generic/vm-type.lisp:
Changes for to use kernel::class etc.

* code/class.lisp (toplevel): Shadow class, built-in-class etc.
(class): Give it conc-name %class-.
(toplevel) [#+bootstrap-lisp-class=pcl-class]: Define old accessors.
(everywhere): Use new class accessors.

* compiler/generic/vm-fndb.lisp (%make-instance): Change from
unsafe to flushable and movable.

* code/ntrace.lisp (expand-trace, untrace): Changes for method
tracing.

* code/profile.lisp (profile, profile-all, unprofile): Method
profiling.

* pcl/*.text, pcl/bench.lisp, pcl/extensions.lisp:
* pcl/fast-init.lisp, pcl/precom1.lisp, pcl/precom4.lisp:
* pcl/structure-class.lisp, pcl/user-instances.lisp:
Removed.

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

  ViewVC Help
Powered by ViewVC 1.1.5