/[cmucl]/src/code/class.lisp
ViewVC logotype

Contents of /src/code/class.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.65 - (show annotations)
Tue Apr 20 17:57:43 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.64: +33 -33 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Package: Kernel -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/class.lisp,v 1.65 2010/04/20 17:57:43 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains structures and functions for the maintenance of basic
13 ;;; information about defined types. Different object systems can be supported
14 ;;; simultaneously. Some of the functions here are nominally generic, and are
15 ;;; overwritten when CLOS is loaded.
16 ;;;
17 (in-package "KERNEL")
18
19 (intl:textdomain "cmucl")
20
21 (export '(layout layout-hash layout-hash-length layout-hash-max
22 initialize-layout-hash layout-class layout-invalid
23 layout-inherits layout-inheritance-depth layout-length
24 layout-info layout-pure
25 layout-of structure-class-p
26 slot-class-print-function
27 structure-class-make-load-form-fun find-layout
28 class-proper-name
29 class-init
30 register-layout
31 basic-structure-class slot-class funcallable-instance
32 funcallable-structure-class
33 make-funcallable-structure-class
34 funcallable-structure-class-p make-standard-class
35 random-pcl-class make-random-pcl-class
36 built-in-class-direct-superclasses
37 find-class-cell class-cell-name class-cell-class
38 make-layout make-undefined-class insured-find-class
39 redefine-layout-warning std-compute-class-precedence-list
40
41 %class-name
42 %class-layout
43 %class-state
44 %class-direct-superclasses
45 %class-subclasses
46 %class-pcl-class))
47
48 (in-package "LISP")
49 (export '(class-name))
50
51 (in-package "KERNEL")
52
53 (shadow '("CLASS" "BUILT-IN-CLASS" "STANDARD-CLASS" "STRUCTURE-CLASS"
54 "FIND-CLASS" "CLASS-OF"))
55
56 (with-cold-load-init-forms)
57
58 ;;; Table mapping class names to layouts for classes we have referenced but not
59 ;;; yet loaded. This is initialized from an ALIST created by Genesis
60 ;;; describing the layouts it created at cold-load time. *LAYOUT-HASH-INITS*
61 ;;; is a list of all the layouts whose hash hasn't been initialized. We delay
62 ;;; this because the random-number generator needs top-level forms to work.
63 ;;;
64 (defvar *forward-referenced-layouts*)
65 (defvar lisp::*initial-layouts*)
66 (defvar *layout-hash-inits*)
67 (cold-load-init
68 (setq *forward-referenced-layouts* (make-hash-table :test #'equal))
69 (setq *layout-hash-inits* ())
70 (dolist (x lisp::*initial-layouts*)
71 (setf (gethash (car x) *forward-referenced-layouts*) (cdr x))
72 (push (cdr x) *layout-hash-inits*))
73 (makunbound 'lisp::*initial-layouts*))
74
75
76 ;;;; Class definition structures:
77
78 ;;; The LAYOUT structure is pointed to by the first cell of instance (or
79 ;;; structure) objects. It represents what we need to know for type checking
80 ;;; and garbage collection. Whenever a class is incompatibly redefined, a new
81 ;;; layout is allocated. If two object's layouts are EQ, then they are exactly
82 ;;; the same type.
83 ;;;
84 ;;; LAYOUTs are treated specially by the dumper so that genesis can help us
85 ;;; bootstrap the type system. Only layouts for named classes can be dumped.
86 ;;; This is resolved at load-time to the current layout for the class of that
87 ;;; name --- except that genesis simply ensures that only one layout is
88 ;;; allocated for each class (interns the layouts by name.) Only the INHERITS,
89 ;;; INHERITANCE-DEPTH and LENGTH slots are dumped. In normal load, these slots
90 ;;; had better agree with any current loaded value. In cold load, these slots
91 ;;; are used to create the LAYOUT if it doesn't exist yet (other slots left
92 ;;; unitialized.)
93 ;;;
94 (defstruct (layout (:print-function
95 (lambda (s stream d)
96 (declare (ignore d))
97 (print-unreadable-object (s stream :identity t)
98 (format stream (intl:gettext "Layout for ~S~@[, Invalid=~S~]")
99 (class-proper-name (layout-class s))
100 (layout-invalid s)))))
101 (:make-load-form-fun :ignore-it)
102 (:constructor %make-layout))
103 ;;
104 ;; Some hash bits for this layout. Sleazily accessed via %INSTANCE-REF, see
105 ;; LAYOUT-HASH.
106 (hash0 0 :type index)
107 (hash1 0 :type index)
108 (hash2 0 :type index)
109 (hash3 0 :type index)
110 (hash4 0 :type index)
111 (hash5 0 :type index)
112 (hash6 0 :type index)
113 (hash7 0 :type index)
114 ;;
115 ;; The class this is a layout for.
116 (class (required-argument) :type kernel::class)
117 ;;
118 ;; NIL if this is the latest layout for this class. If non-null, then the
119 ;; class was changed after this instance was created. The exact value may
120 ;; provide some information about what to do.
121 (invalid nil)
122 ;;
123 ;; Vector of the layouts for all classes we inherit. If hierarchical
124 ;; these are in order from most general down to (but not including) this
125 ;; class.
126 (inherits #() :type simple-vector)
127 ;;
128 ;; Number of classes this class hierachically inherits
129 ;; (length inherits), or -1 if not hierarchical.
130 (inheritance-depth -1 :type (or index (integer -1 -1)))
131 ;;
132 ;; The number of top-level descriptor cells in each instance.
133 (length 0 :type index)
134 ;;
135 ;; If this layout has some kind of compiler meta-info, then this is it. If a
136 ;; structure, then we store the DEFSTRUCT-DESCRIPTION here.
137 (info nil)
138 ;;
139 ;; True if objects of this class are never modified to contain dynamic
140 ;; pointers in their slots or constant-like substructure (hence can be copied
141 ;; into read-only space by purify.)
142 ;;
143 ;; ### this slot is known to the C startup code.
144 (pure nil :type (member t nil 0)))
145
146 ;;; MAKE-LAYOUT -- Interface
147 ;;;
148 ;;; Make a layout and initialize it. If type system is initialized
149 ;;; (actually, the top-level forms for RANDOM run), then initialize the hash
150 ;;; now, otherwise, delay initialization.
151 ;;;
152 (defun make-layout (&rest args &key &allow-other-keys)
153 (let ((res (apply #'%make-layout args)))
154 (if *type-system-initialized*
155 (initialize-layout-hash res)
156 (push res *layout-hash-inits*))
157 res))
158
159 (defconstant layout-hash-length 8)
160 (declaim (inline layout-hash))
161 (defun layout-hash (layout i)
162 (declare (type layout layout) (type index i))
163 (truly-the index (%instance-ref layout (1+ i))))
164 (declaim (inline (setf layout-hash)))
165 (defun (setf layout-hash) (new-value layout i)
166 (declare (type layout layout) (type index new-value i))
167 (setf (%instance-ref layout (1+ i)) new-value))
168
169 (defconstant layout-hash-max (ash most-positive-fixnum -3)
170 "The inclusive upper bound on LAYOUT-HASH values.")
171
172 (defvar *layout-hash-seed* nil)
173
174 ;;; INITIALIZE-LAYOUT-HASH -- Interface
175 ;;;
176 ;;; Set the layout-hash slots to non-zero random numbers between 1 and
177 ;;; layout-hash-max (inclusive). The layout is returned.
178 ;;;
179 (defun initialize-layout-hash (layout)
180 (let ((seed *layout-hash-seed*))
181 (unless seed
182 (setq seed (setq *layout-hash-seed* (make-random-state))))
183 (dotimes (i layout-hash-length)
184 (setf (layout-hash layout i)
185 (1+ (random layout-hash-max seed)))))
186 layout)
187
188 ;;; order-layout-inherits -- Interface
189 ;;;
190 ;;; Arrange the inherited layouts to appear at their expected depth, ensuring
191 ;;; that hierarchical type tests succeed. Layouts with a specific depth are
192 ;;; placed first, then the non-hierarchical layouts fill remaining elements.
193 ;;; Any empty elements are filled with layout copies ensuring that all
194 ;;; elements have a valid layout. This re-ordering may destroy CPL ordering so
195 ;;; the inherits should not be read as being in CPL order, and further
196 ;;; duplicates may be introduced.
197 ;;;
198 (defun order-layout-inherits (layouts)
199 (declare (simple-vector layouts))
200 (let ((length (length layouts))
201 (max-depth -1))
202 (dotimes (i length)
203 (let ((depth (layout-inheritance-depth (svref layouts i))))
204 (when (> depth max-depth)
205 (setf max-depth depth))))
206 (let* ((new-length (max (1+ max-depth) length))
207 (inherits (make-array new-length)))
208 (dotimes (i length)
209 (let* ((layout (svref layouts i))
210 (depth (layout-inheritance-depth layout)))
211 (unless (eql depth -1)
212 (let ((old-layout (svref inherits depth)))
213 (unless (or (eql old-layout 0) (eq old-layout layout))
214 (error (intl:gettext "Layout depth conflict: ~S~% ~
215 (~S collides at ~S with ~S)~%")
216 layouts layout depth old-layout)))
217 (setf (svref inherits depth) layout))))
218 (do ((i 0 (1+ i))
219 (j 0))
220 ((>= i length))
221 (declare (type index i j))
222 (let* ((layout (svref layouts i))
223 (depth (layout-inheritance-depth layout)))
224 (when (eql depth -1)
225 (loop (when (eql (svref inherits j) 0)
226 (return))
227 (incf j))
228 (setf (svref inherits j) layout))))
229 (do ((i (1- new-length) (1- i)))
230 ((< i 0))
231 (declare (type fixnum i))
232 (when (eql (svref inherits i) 0)
233 (setf (svref inherits i) (svref inherits (1+ i)))))
234 inherits)))
235
236
237 ;;; The CLASS structure is a supertype of all CLASS types. A CLASS is also a
238 ;;; CTYPE structure as recognized by the type system.
239 ;;;
240 (defstruct (class
241 (:conc-name %class-)
242 (:make-load-form-fun class-make-load-form-fun)
243 (:print-function %print-class)
244 (:include ctype
245 (:class-info (type-class-or-lose 'class)))
246 (:pure nil))
247 ;;
248 ;; Optional name, for printing.
249 (name nil)
250 ;;
251 ;; Current layout for this class. Null if not assigned yet.
252 (layout nil :type (or layout null))
253 ;;
254 ;; How sure we are that this class won't be redefined. If :READ-ONLY, we are
255 ;; committed to not changing the effective slots or superclasses. If
256 ;; :SEALED, we can't even add subclasses.
257 (state nil :type (member nil :read-only :sealed))
258 ;;
259 ;; Direct superclasses of this class.
260 (direct-superclasses () :type list)
261 ;;
262 ;; Representation of all of the subclasses (direct or indirect) of this
263 ;; class. NIL if no subclasses or not initalized yet. Otherwise, an EQ
264 ;; hash-table mapping class-objects to the subclass layout that was in effect
265 ;; at the time the subclass was created.
266 (subclasses nil :type (or hash-table null))
267 ;;
268 ;; The PCL class object, or NIL if none assigned yet.
269 (pcl-class nil))
270
271 ;;;
272 ;;; Remove this whole stuff once everyone has bootstrapped the
273 ;;; LISP:CLASS = PCL:CLASS stuff, that is, when the bootstrap file
274 ;;; using this feature is no longer needed.
275 ;;;
276 #+bootstrap-lisp-class=pcl-class
277 (macrolet ((def (o n)
278 `(progn
279 (defun ,o (x) (,n x))
280 (defun (setf ,o) (v x) (setf (,n x) v)))))
281 (def class-layout %class-layout)
282 (def class-name %class-name)
283 (def class-state %class-state)
284 (def class-direct-subclasses %class-direct-superclasses)
285 (def class-subclasses %class-subclasses))
286
287 ;;;
288 (defun class-make-load-form-fun (class)
289 (let ((name (%class-name class)))
290 (unless (and name (eq (find-class name nil) class))
291 (error
292 (intl:gettext "Can't use anonymous or undefined class as constant:~% ~S")
293 class))
294 `(find-class ',name)))
295 ;;;
296 (defun %print-class (s stream d)
297 (declare (ignore d))
298 (print-unreadable-object (s stream :identity t :type t)
299 (format stream (intl:gettext "~:[<anonymous>~;~:*~S~]~@[ (~(~A~))~]")
300 (%class-name s) (%class-state s))))
301
302
303 ;;; The UNDEFINED-CLASS is a cookie we make up to stick in forward referenced
304 ;;; layouts. Users should never see them.
305 ;;;
306 (defstruct (undefined-class
307 (:include class)
308 (:constructor make-undefined-class (name))))
309
310
311 ;;; BUILT-IN-CLASS is used to represent the standard classes that aren't
312 ;;; defined with DEFSTRUCT and other specially implemented primitve types whose
313 ;;; only attribute is their name.
314 ;;;
315 ;;; Some BUILT-IN-CLASSes have a TRANSLATION, which means that they are
316 ;;; effectively DEFTYPE'd to some other type (usually a union of other classes
317 ;;; or a "primitive" type such as NUMBER, ARRAY, etc.) This translation is
318 ;;; done when type specifiers are parsed. Type system operations (union,
319 ;;; subtypep, etc.) should never encounter translated classes, only their
320 ;;; translation.
321 ;;;
322 (defstruct (built-in-class (:include class))
323 ;;
324 ;; Type we translate to on parsing. If NIL, then this class stands on its
325 ;; own. Only :INITIALIZING for a period during cold-load. See below.
326 (translation nil :type (or ctype (member nil :initializing))))
327
328 ;;; Class with print function, but not necessarily a structure class.
329 ;;; (CONDITIONs)
330 ;;;
331 (defstruct (slot-class (:include class))
332 ;;
333 ;; Print function, or NIL if none.
334 (print-function nil :type (or function symbol null)))
335
336 ;;; STRUCTURE-CLASS represents what we need to know about structure classes.
337 ;;; Non-structure "typed" defstructs are a special case, and don't have a
338 ;;; corresponding class.
339 ;;;
340 (defstruct (basic-structure-class (:include slot-class)))
341
342 (defstruct (structure-class (:include basic-structure-class))
343 ;;
344 ;; MAKE-LOAD-FORM method, or NIL if none. :J-D-I-N dumps the slots.
345 ;; :IGNORE-IT is used for magic structures which the compiler inserts in IR1,
346 ;; but that are never actually dumped.
347 (make-load-form-fun nil :type (or function symbol
348 (member :just-dump-it-normally
349 :ignore-it
350 nil)))
351 ;;
352 ;; If true, a default keyword constructor for this structure.
353 (constructor nil :type (or function null)))
354
355 ;;; FUNCALLABLE-STRUCTURE-CLASS is used to represent funcallable structures,
356 ;;; which are used to implement generic functions.
357 ;;;
358 (defstruct (funcallable-structure-class (:include basic-structure-class)))
359
360
361 ;;;; Class namespace:
362
363 ;;; FIND-CLASS-CELL, CLASS-CELL-NAME, CLASS-CELL-CLASS -- Interface
364 ;;;
365 ;;; We use an indirection to allow forward referencing of class definitions
366 ;;; with load-time resolution.
367 ;;;
368 (defstruct (class-cell
369 (:constructor make-class-cell (name &optional class))
370 (:print-function
371 (lambda (s stream d)
372 (declare (ignore d))
373 (print-unreadable-object (s stream :type t)
374 (prin1 (class-cell-name s) stream))))
375 (:make-load-form-fun
376 (lambda (cell)
377 `(find-class-cell ',(class-cell-name cell)))))
378 ;;
379 ;; Name of class we expect to find.
380 (name nil :type symbol :read-only t)
381 ;;
382 ;; Class or NIL if not yet defined.
383 (class nil :type (or class null)))
384
385 (defun find-class-cell (name)
386 (or (info type class name)
387 (setf (info type class name) (make-class-cell name))))
388
389
390 ;;; FIND-CLASS -- Public
391 ;;;
392 (defun find-class (name &optional (errorp t) environment)
393 "Return the class with the specified Name. If ERRORP is false, then NIL is
394 returned when no such class exists."
395 (declare (type symbol name) (ignore environment))
396 (let ((res (class-cell-class (find-class-cell name))))
397 (if (or res (not errorp))
398 res
399 (error 'simple-type-error
400 :datum name
401 :expected-type t ; Not really
402 :format-control (intl:gettext "Class not yet defined:~% ~S")
403 :format-arguments (list name)))))
404 ;;;
405 (defun (setf find-class) (new-value name &optional (errorp t) environment)
406 (declare (type (or null class) new-value) (ignore errorp environment))
407 (cond
408 ((null new-value)
409 ;; Clear info db if name names a class
410 (ecase (info type kind name)
411 (:primitive
412 (error (intl:gettext "Illegal to redefine standard type ~S.") name))
413 (:defined)
414 ((nil))
415 (:instance
416 (setf (info type kind name) nil
417 (info type class name) nil
418 (info type documentation name) nil
419 (info type compiler-layout name) nil))))
420 (t
421 (ecase (info type kind name)
422 ((nil))
423 (:instance
424 (let ((old (class-of (find-class name)))
425 (new (class-of new-value)))
426 (unless (eq old new)
427 (warn (intl:gettext "Changing meta-class of ~S from ~S to ~S.")
428 name (%class-name old) (%class-name new)))))
429 (:primitive
430 (error (intl:gettext "Illegal to redefine standard type ~S.") name))
431 (:defined
432 (warn (intl:gettext "Redefining DEFTYPE type to be a class: ~S.")
433 name)
434 (setf (info type expander name) nil)))
435
436 (remhash name *forward-referenced-layouts*)
437 (%note-type-defined name)
438 (setf (info type kind name) :instance)
439 (setf (class-cell-class (find-class-cell name)) new-value)
440 (unless (eq (info type compiler-layout name)
441 (%class-layout new-value))
442 (setf (info type compiler-layout name) (%class-layout new-value)))))
443 new-value)
444
445
446 ;;; INSURED-FIND-CLASS -- Interface
447 ;;;
448 ;;; Called when we are about to define Name as a class meeting some
449 ;;; predicate (such as a meta-class type test.) The first result is always of
450 ;;; the desired class. The second result is any existing layout for this name.
451 ;;;
452 (defun insured-find-class (name predicate constructor)
453 (declare (function predicate constructor))
454 (let* ((old (find-class name nil))
455 (res (if (and old (funcall predicate old))
456 old
457 (funcall constructor :name name)))
458 (found (or (gethash name *forward-referenced-layouts*)
459 (when old (%class-layout old)))))
460 (when found
461 (setf (layout-class found) res))
462
463 (values res found)))
464
465
466 ;;; CLASS-PROPER-NAME -- Exported
467 ;;;
468 ;;; If the class has a proper name, return the name, otherwise return
469 ;;; the class.
470 ;;;
471 (defun class-proper-name (class)
472 (declare (type class class))
473 (let ((name (%class-name class)))
474 (if (and name (eq (find-class name nil) class))
475 name
476 class)))
477
478
479 ;;;; CLASS type operations:
480
481 (define-type-class class)
482
483 ;;; Simple methods for TYPE= and SUBTYPEP should never be called when the two
484 ;;; classes are equal, since there are EQ checks in those operations.
485 ;;;
486 (define-type-method (class :simple-=) (type1 type2)
487 (assert (not (eq type1 type2)))
488 (values nil t))
489
490 (define-type-method (class :simple-subtypep) (class1 class2)
491 (assert (not (eq class1 class2)))
492 (let ((subclasses (%class-subclasses class2)))
493 (if (and subclasses (gethash class1 subclasses))
494 (values t t)
495 (values nil t))))
496
497
498 ;;; SEALED-CLASS-INTERSECTION -- Internal
499 ;;;
500 ;;; When finding the intersection of a sealed class and some other class
501 ;;; (not hierarchically related) the intersection is the union of the currently
502 ;;; shared subclasses.
503 ;;;
504 (defun sealed-class-intersection (sealed other)
505 (declare (type class sealed other))
506 (let ((s-sub (%class-subclasses sealed))
507 (o-sub (%class-subclasses other)))
508 (if (and s-sub o-sub)
509 (collect ((res *empty-type* type-union))
510 (do-hash (subclass layout s-sub)
511 (declare (ignore layout))
512 (when (gethash subclass o-sub)
513 (res (specifier-type subclass))))
514 (res))
515 *empty-type*)))
516
517
518 ;;; If one is a subclass of the other, then that is the intersection, but we
519 ;;; can only be sure the intersection is otherwise empty if they are structure
520 ;;; classes, since a subclass of both might be defined. If either class is
521 ;;; sealed, we can eliminate this possibility.
522 ;;;
523 (define-type-method (class :simple-intersection) (class1 class2)
524 (declare (type class class1 class2))
525 (cond ((eq class1 class2) class1)
526 ((let ((subclasses (%class-subclasses class2)))
527 (and subclasses (gethash class1 subclasses)))
528 class1)
529 ((let ((subclasses (%class-subclasses class1)))
530 (and subclasses (gethash class2 subclasses)))
531 class2)
532 ((or (basic-structure-class-p class1)
533 (basic-structure-class-p class2))
534 *empty-type*)
535 ((eq (%class-state class1) :sealed)
536 (sealed-class-intersection class1 class2))
537 ((eq (%class-state class2) :sealed)
538 (sealed-class-intersection class2 class1))
539 (t
540 nil)))
541
542 ;;;
543 ;;; KLUDGE: we need this because of the need to represent
544 ;;; intersections of two classes, even when empty at a given time, as
545 ;;; uncanonicalized intersections because of the possibility of later
546 ;;; defining a subclass of both classes. The necessity for changing
547 ;;; the default return value from SUBTYPEP to NIL, T if no alternate
548 ;;; method is present comes about because, unlike the other places we
549 ;;; use INVOKE-COMPLEX-SUBTYPEP-ARG1-METHOD, in HAIRY methods and the
550 ;;; like, classes are in their own hierarchy with no possibility of
551 ;;; mixtures with other type classes.
552 ;;;
553 (define-type-method (class :complex-subtypep-arg2) (type1 class2)
554 (if (and (intersection-type-p type1)
555 (> (count-if #'class-p (intersection-type-types type1)) 1))
556 (values nil nil)
557 (invoke-complex-subtypep-arg1-method type1 class2 nil t)))
558
559 (define-type-method (class :complex-subtypep-arg1) (type1 type2)
560 (if (and (function-type-p type2)
561 (eq type1 (specifier-type 'function))
562 (function-type-wild-args type2)
563 (eq *wild-type* (function-type-returns type2)))
564 (values t t)
565 (values nil t)))
566
567 (define-type-method (class :unparse) (type)
568 (class-proper-name type))
569
570
571 ;;;; Built-in classes & class-of:
572 ;;;
573 ;;; The BUILT-IN-CLASSES list is a data structure which configures the
574 ;;; creation of all the built-in classes. It contains all the info that we
575 ;;; need to maintain the mapping between classes, compile-time types and
576 ;;; run-time type codes. These options are defined:
577 ;;;
578 ;;; :TRANSLATION (default none)
579 ;;; When this class is "parsed" as a type specifier, it is translated into
580 ;;; the specified internal type representation, rather than being left as a
581 ;;; class. This is used for types which we want to canonicalize to
582 ;;; some other kind of type object because in general we want to be able to
583 ;;; include more information than just the class (e.g. for numeric types).
584 ;;; Default none.
585 ;;;
586 ;;; :ENUMERABLE (default NIL)
587 ;;; The value of the :ENUMERABLE slot in the created class. Meaningless in
588 ;;; translated classes.
589 ;;;
590 ;;; :STATE (default :SEALED)
591 ;;; The value of CLASS-STATE which we want on completion, indicating
592 ;;; whether subclasses can be created at run-time.
593 ;;;
594 ;;; :HIERARCHICAL (default T unless any of the inherits are non-hierarchical)
595 ;;; True if we can assign this class a unique INHERITANCE-DEPTH.
596 ;;;
597 ;;; :CODES (default none)
598 ;;; Run-time type codes which should be translated back to this class by
599 ;;; CLASS-OF. Unspecified for abstract classes.
600 ;;;
601 ;;; :INHERITS (default this class & T)
602 ;;; The class-precedence list for this class, with this class and T
603 ;;; implicit.
604 ;;;
605 ;;; :DIRECT-SUPERCLASSES (default to head of CPL)
606 ;;; List of the direct superclasses of this class.
607 ;;;
608
609 (defvar built-in-classes)
610 (cold-load-init
611 (setq built-in-classes
612 '((t :state :read-only :translation t)
613 (character :enumerable t :translation base-char)
614 (base-char :enumerable t :inherits (character)
615 :codes (#.vm:base-char-type))
616
617 (symbol :codes (#.vm:symbol-header-type))
618
619 (instance :state :read-only)
620
621 (system-area-pointer :codes (#.vm:sap-type))
622 (weak-pointer :codes (#.vm:weak-pointer-type))
623 (scavenger-hook #+(or gengc gencgc) :codes
624 #+(or gengc gencgc) (#.vm:scavenger-hook-type))
625 (code-component :codes (#.vm:code-header-type))
626 #-gengc (lra :codes (#.vm:return-pc-header-type))
627 (fdefn :codes (#.vm:fdefn-type))
628 (random-class) ; Used for unknown type codes.
629
630 (function
631 :codes
632 (#.vm:byte-code-closure-type
633 #.vm:byte-code-function-type
634 #.vm:closure-header-type #.vm:function-header-type)
635 :state :read-only)
636 (funcallable-instance :inherits (function) :state :read-only)
637
638 (collection :hierarchical nil :state :read-only)
639 (explicit-key-collection :state :read-only :inherits (collection))
640 (mutable-collection :state :read-only :inherits (collection))
641 (mutable-explicit-key-collection
642 :state :read-only
643 :direct-superclasses (explicit-key-collection mutable-collection)
644 :inherits (explicit-key-collection mutable-collection collection))
645 (generic-sequence :state :read-only :inherits (collection))
646 (mutable-sequence
647 :state :read-only
648 :direct-superclasses (mutable-collection generic-sequence)
649 :inherits (mutable-collection generic-sequence collection))
650 (generic-array
651 :state :read-only
652 :inherits (mutable-sequence mutable-collection generic-sequence
653 collection))
654 (generic-vector
655 :state :read-only
656 :inherits (generic-array mutable-sequence mutable-collection
657 generic-sequence collection))
658 (array
659 :translation array :codes (#.vm:complex-array-type)
660 :inherits (generic-array mutable-sequence mutable-collection
661 generic-sequence collection))
662 (simple-array
663 :translation simple-array :codes (#.vm:simple-array-type)
664 :inherits (array generic-array mutable-sequence mutable-collection
665 generic-sequence collection))
666 (sequence
667 :translation (or cons (member nil) vector)
668 :inherits (mutable-sequence mutable-collection generic-sequence
669 collection))
670 (vector
671 :translation vector :codes (#.vm:complex-vector-type)
672 :direct-superclasses (array sequence generic-vector)
673 :inherits (array sequence generic-vector generic-array
674 mutable-sequence mutable-collection generic-sequence
675 collection))
676 (simple-vector
677 :translation simple-vector :codes (#.vm:simple-vector-type)
678 :direct-superclasses (vector simple-array)
679 :inherits (vector simple-array array sequence generic-vector
680 generic-array mutable-sequence mutable-collection
681 generic-sequence collection))
682 (bit-vector
683 :translation bit-vector :codes (#.vm:complex-bit-vector-type)
684 :inherits (vector array sequence generic-vector generic-array
685 mutable-sequence mutable-collection generic-sequence
686 collection))
687 (simple-bit-vector
688 :translation simple-bit-vector :codes (#.vm:simple-bit-vector-type)
689 :direct-superclasses (bit-vector simple-array)
690 :inherits (bit-vector vector simple-array array sequence
691 generic-vector generic-array mutable-sequence
692 mutable-collection generic-sequence collection))
693 (simple-array-unsigned-byte-2
694 :translation (simple-array (unsigned-byte 2) (*))
695 :codes (#.vm:simple-array-unsigned-byte-2-type)
696 :direct-superclasses (vector simple-array)
697 :inherits (vector simple-array array sequence generic-vector
698 generic-array mutable-sequence mutable-collection
699 generic-sequence collection))
700 (simple-array-unsigned-byte-4
701 :translation (simple-array (unsigned-byte 4) (*))
702 :codes (#.vm:simple-array-unsigned-byte-4-type)
703 :direct-superclasses (vector simple-array)
704 :inherits (vector simple-array array sequence generic-vector
705 generic-array mutable-sequence mutable-collection
706 generic-sequence collection))
707 (simple-array-unsigned-byte-8
708 :translation (simple-array (unsigned-byte 8) (*))
709 :codes (#.vm:simple-array-unsigned-byte-8-type)
710 :direct-superclasses (vector simple-array)
711 :inherits (vector simple-array array sequence generic-vector
712 generic-array mutable-sequence mutable-collection
713 generic-sequence collection))
714 (simple-array-unsigned-byte-16
715 :translation (simple-array (unsigned-byte 16) (*))
716 :codes (#.vm:simple-array-unsigned-byte-16-type)
717 :direct-superclasses (vector simple-array)
718 :inherits (vector simple-array array sequence generic-vector
719 generic-array mutable-sequence mutable-collection
720 generic-sequence collection))
721 (simple-array-unsigned-byte-32
722 :translation (simple-array (unsigned-byte 32) (*))
723 :codes (#.vm:simple-array-unsigned-byte-32-type)
724 :direct-superclasses (vector simple-array)
725 :inherits (vector simple-array array sequence generic-vector
726 generic-array mutable-sequence mutable-collection
727 generic-sequence collection))
728 (simple-array-signed-byte-8
729 :translation (simple-array (signed-byte 8) (*))
730 :codes (#.vm:simple-array-signed-byte-8-type)
731 :direct-superclasses (vector simple-array)
732 :inherits (vector simple-array array sequence generic-vector
733 generic-array mutable-sequence mutable-collection
734 generic-sequence collection))
735 (simple-array-signed-byte-16
736 :translation (simple-array (signed-byte 16) (*))
737 :codes (#.vm:simple-array-signed-byte-16-type)
738 :direct-superclasses (vector simple-array)
739 :inherits (vector simple-array array sequence generic-vector
740 generic-array mutable-sequence mutable-collection
741 generic-sequence collection))
742 (simple-array-signed-byte-30
743 :translation (simple-array (signed-byte 30) (*))
744 :codes (#.vm:simple-array-signed-byte-30-type)
745 :direct-superclasses (vector simple-array)
746 :inherits (vector simple-array array sequence generic-vector
747 generic-array mutable-sequence mutable-collection
748 generic-sequence collection))
749 (simple-array-signed-byte-32
750 :translation (simple-array (signed-byte 32) (*))
751 :codes (#.vm:simple-array-signed-byte-32-type)
752 :direct-superclasses (vector simple-array)
753 :inherits (vector simple-array array sequence generic-vector
754 generic-array mutable-sequence mutable-collection
755 generic-sequence collection))
756 (simple-array-single-float
757 :translation (simple-array single-float (*))
758 :codes (#.vm:simple-array-single-float-type)
759 :direct-superclasses (vector simple-array)
760 :inherits (vector simple-array array sequence generic-vector
761 generic-array mutable-sequence mutable-collection
762 generic-sequence collection))
763 (simple-array-double-float
764 :translation (simple-array double-float (*))
765 :codes (#.vm:simple-array-double-float-type)
766 :direct-superclasses (vector simple-array)
767 :inherits (vector simple-array array sequence generic-vector
768 generic-array mutable-sequence mutable-collection
769 generic-sequence collection))
770 #+long-float
771 (simple-array-long-float
772 :translation (simple-array long-float (*))
773 :codes (#.vm:simple-array-long-float-type)
774 :direct-superclasses (vector simple-array)
775 :inherits (vector simple-array array sequence generic-vector
776 generic-array mutable-sequence mutable-collection
777 generic-sequence collection))
778 #+double-double
779 (simple-array-double-double-float
780 :translation (simple-array double-double-float (*))
781 :codes (#.vm::simple-array-double-double-float-type)
782 :direct-superclasses (vector simple-array)
783 :inherits (vector simple-array array sequence generic-vector
784 generic-array mutable-sequence mutable-collection
785 generic-sequence collection))
786 (simple-array-complex-single-float
787 :translation (simple-array (complex single-float) (*))
788 :codes (#.vm:simple-array-complex-single-float-type)
789 :direct-superclasses (vector simple-array)
790 :inherits (vector simple-array array sequence generic-vector
791 generic-array mutable-sequence mutable-collection
792 generic-sequence collection))
793 (simple-array-complex-double-float
794 :translation (simple-array (complex double-float) (*))
795 :codes (#.vm:simple-array-complex-double-float-type)
796 :direct-superclasses (vector simple-array)
797 :inherits (vector simple-array array sequence generic-vector
798 generic-array mutable-sequence mutable-collection
799 generic-sequence collection))
800 #+long-float
801 (simple-array-complex-long-float
802 :translation (simple-array (complex long-float) (*))
803 :codes (#.vm:simple-array-complex-long-float-type)
804 :direct-superclasses (vector simple-array)
805 :inherits (vector simple-array array sequence generic-vector
806 generic-array mutable-sequence mutable-collection
807 generic-sequence collection))
808 #+double-double
809 (simple-array-complex-double-double-float
810 :translation (simple-array (complex double-double-float) (*))
811 :codes (#.vm::simple-array-complex-double-double-float-type)
812 :direct-superclasses (vector simple-array)
813 :inherits (vector simple-array array sequence generic-vector
814 generic-array mutable-sequence mutable-collection
815 generic-sequence collection))
816 (generic-string
817 :state :read-only
818 :inherits (mutable-sequence mutable-collection generic-sequence
819 collection))
820 (string
821 :translation string :codes (#.vm:complex-string-type)
822 :direct-superclasses (vector generic-string)
823 :inherits (vector array sequence generic-vector generic-array
824 generic-string mutable-sequence mutable-collection
825 generic-sequence collection))
826 (simple-string
827 :translation simple-string :codes (#.vm:simple-string-type)
828 :direct-superclasses (string simple-array)
829 :inherits (string vector generic-string simple-array array sequence
830 generic-vector generic-array mutable-sequence
831 mutable-collection generic-sequence collection))
832
833 (generic-number :state :read-only)
834 (number :translation number :inherits (generic-number))
835 (complex :translation complex :inherits (number generic-number)
836 :codes (#.vm:complex-type))
837 (complex-single-float
838 :translation (complex single-float)
839 :inherits (complex number generic-number)
840 :codes (#.vm:complex-single-float-type))
841 (complex-double-float
842 :translation (complex double-float)
843 :inherits (complex number generic-number)
844 :codes (#.vm:complex-double-float-type))
845 #+long-float
846 (complex-long-float
847 :translation (complex long-float)
848 :inherits (complex number generic-number)
849 :codes (#.vm:complex-long-float-type))
850 #+double-double
851 (complex-double-double-float
852 :translation (complex double-double-float)
853 :inherits (complex number generic-number)
854 :codes (#.vm::complex-double-double-float-type))
855 (real :translation real :inherits (number generic-number))
856 (float :translation float :inherits (real number generic-number))
857 (single-float
858 :translation single-float
859 :inherits (float real number generic-number)
860 :codes (#.vm:single-float-type))
861 (double-float
862 :translation double-float
863 :inherits (float real number generic-number)
864 :codes (#.vm:double-float-type))
865 #+long-float
866 (long-float
867 :translation long-float
868 :inherits (float real number generic-number)
869 :codes (#.vm:long-float-type))
870 #+double-double
871 (double-double-float
872 :translation double-double-float
873 :inherits (float real number generic-number)
874 :codes (#.vm::double-double-float-type))
875 (rational
876 :translation rational
877 :inherits (real number generic-number))
878 (ratio
879 :translation (and rational (not integer))
880 :inherits (rational real number generic-number)
881 :codes (#.vm:ratio-type))
882 (integer
883 :translation integer
884 :inherits (rational real number generic-number))
885 (fixnum
886 :translation (integer #.vm:target-most-negative-fixnum
887 #.vm:target-most-positive-fixnum)
888 :inherits (integer rational real number generic-number)
889 :codes (#.vm:even-fixnum-type #.vm:odd-fixnum-type))
890 (bignum
891 :translation (or (integer * (#.vm:target-most-negative-fixnum))
892 (integer (#.vm:target-most-positive-fixnum) *))
893 :inherits (integer rational real number generic-number)
894 :codes (#.vm:bignum-type))
895
896 (list :translation (or cons (member nil))
897 :inherits (sequence mutable-sequence mutable-collection
898 generic-sequence collection))
899 (cons :translation cons :codes (#.vm:list-pointer-type)
900 :inherits (list sequence mutable-sequence mutable-collection
901 generic-sequence collection))
902 (null :translation (member nil)
903 :inherits (symbol list sequence mutable-sequence mutable-collection
904 generic-sequence collection)
905 :direct-superclasses (symbol list))
906
907 (stream :state :read-only :depth 3 :inherits (instance)))))
908
909 ;;; See also type-init.lisp where we finish setting up the translations for
910 ;;; built-in types.
911 ;;;
912 (cold-load-init
913 (dolist (x built-in-classes)
914 (destructuring-bind (name &key (translation nil trans-p) inherits codes
915 enumerable state (hierarchical t) depth
916 (direct-superclasses
917 (if inherits (list (car inherits)) '(t))))
918 x
919 (declare (ignore codes state translation))
920 (let ((inherits (if (eq name 't)
921 ()
922 (cons 't (reverse inherits))))
923 (class (make-built-in-class
924 :enumerable enumerable
925 :name name
926 :translation (if trans-p :initializing nil)
927 :direct-superclasses
928 (if (eq name 't)
929 ()
930 (mapcar #'find-class direct-superclasses)))))
931 (setf (info type kind name) :primitive)
932 (setf (class-cell-class (find-class-cell name)) class)
933 (unless trans-p
934 (setf (info type builtin name) class))
935 (let* ((inheritance-depth (if hierarchical
936 (or depth (length inherits))
937 -1))
938 (inherit-layouts
939 (map 'vector
940 #'(lambda (x)
941 (let ((super-layout (%class-layout (find-class x))))
942 (when (= (layout-inheritance-depth super-layout) -1)
943 (setf inheritance-depth -1))
944 super-layout))
945 inherits)))
946 (register-layout
947 (find-layout name 0 inherit-layouts inheritance-depth)
948 :invalidate nil))))))
949
950 ;;; Define temporary PCL standard-classes; these will be setup
951 ;;; correctly and the lisp layout replaced by a PCL wrapper after PCL
952 ;;; is loaded and the class defined.
953 (cold-load-init
954 (dolist (x '((fundamental-stream (t instance stream stream))
955 (stream:simple-stream (t instance stream))
956 (stream:single-channel-simple-stream (t instance stream
957 stream:simple-stream))
958 (stream:dual-channel-simple-stream (t instance stream
959 stream:simple-stream))
960 (stream:string-simple-stream (t instance stream
961 stream:simple-stream))))
962 (let* ((name (first x))
963 (inherits (second x))
964 (class (make-standard-class :name name))
965 (class-cell (find-class-cell name)))
966 (setf (class-cell-class class-cell) class)
967 (setf (info type class name) class-cell)
968 (setf (info type kind name) :instance)
969 (let ((inherit-layouts
970 (map 'vector #'(lambda (x)
971 (%class-layout (find-class x)))
972 inherits)))
973 (register-layout (find-layout name 0 inherit-layouts -1)
974 :invalidate nil)))))
975
976 ;;; Now that we have set up the class heterarchy, seal the sealed classes.
977 ;;; This must be done after the subclasses have been set up.
978 ;;;
979 (cold-load-init
980 (dolist (x built-in-classes)
981 (destructuring-bind (name &key (state :sealed) &allow-other-keys) x
982 (setf (%class-state (find-class name)) state))))
983
984
985 ;;; A vector that maps type codes to layouts, used for quickly finding the
986 ;;; layouts of built-in classes.
987 ;;;
988 (defvar built-in-class-codes)
989 (cold-load-init
990 (setq built-in-class-codes
991 (let ((res (make-array 256 :initial-element
992 '#.(%class-layout (find-class 'random-class)))))
993 (dolist (x built-in-classes res)
994 (destructuring-bind (name &key codes &allow-other-keys)
995 x
996 (let ((layout (%class-layout (find-class name))))
997 (dolist (code codes)
998 (setf (svref res code) layout))))))))
999
1000
1001 ;;; LAYOUT-OF -- Exported
1002 ;;;
1003 ;;; Return the layout for an object. This is the basic operation for
1004 ;;; finding out the "type" of an object, and is used for generic function
1005 ;;; dispatch. The standard doesn't seem to say as much as it should about what
1006 ;;; this returns for built-in objects. For example, it seems that we must
1007 ;;; return NULL rather than LIST when X is NIL so that GF's can specialize on
1008 ;;; NULL.
1009 ;;;
1010 (declaim (inline layout-of))
1011 (defun layout-of (x)
1012 (declare (optimize (speed 3) (safety 0)))
1013 (cond ((%instancep x) (%instance-layout x))
1014 ((funcallable-instance-p x) (%funcallable-instance-layout x))
1015 ((null x) '#.(%class-layout (find-class 'null)))
1016 (t (svref built-in-class-codes (get-type x)))))
1017
1018
1019 ;;; CLASS-OF -- Public
1020 ;;;
1021 (declaim (inline class-of))
1022 (defun class-of (object)
1023 "Return the class of the supplied object, which may be any Lisp object, not
1024 just a CLOS STANDARD-OBJECT."
1025 (layout-class (layout-of object)))
1026
1027
1028 ;;;; Class definition/redefinition:
1029
1030 ;;; MODIFY-CLASS -- Internal
1031 ;;;
1032 ;;; Called whenever we are altering a class. Clear type system caches and
1033 ;;; warn if read-only.
1034 ;;;
1035 (defun modify-class (class)
1036 (clear-type-caches)
1037 (when (member (%class-state class) '(:read-only :frozen))
1038 (warn (intl:gettext "Modifing ~(~A~) class ~S; making it writable.")
1039 (%class-state class) (%class-name class))
1040 (setf (%class-state class) nil)))
1041
1042
1043 ;;; INVALIDATE-LAYOUT -- Internal
1044 ;;;
1045 ;;; Mark a layout as invalid. Depth -1 causes unsafe structure type tests
1046 ;;; to fail. Remove class from all superclasses (might not be registered, so
1047 ;;; might not be in subclasses of the nominal superclasses.)
1048 ;;;
1049 (defun invalidate-layout (layout)
1050 (declare (type layout layout))
1051 (setf (layout-invalid layout) :invalid)
1052 (setf (layout-inheritance-depth layout) -1)
1053 (let ((inherits (layout-inherits layout))
1054 (class (layout-class layout)))
1055 (modify-class class)
1056 (dotimes (i (length inherits))
1057 (let* ((super (svref inherits i))
1058 (subs (%class-subclasses (layout-class super))))
1059 (when subs
1060 (remhash class subs)))))
1061 (undefined-value))
1062
1063
1064 ;;; REGISTER-LAYOUT -- Interface
1065 ;;;
1066 ;;; Record Layout as the layout for its class, adding it as a subtype of all
1067 ;;; superclasses. This is the operation that "installs" a layout for a class
1068 ;;; in the type system, clobbering any old layout. However, this does not
1069 ;;; modify the class namespace; that is a separate operation (think anonymous
1070 ;;; classes.)
1071 ;;; -- If INVALIDATE, then all the layouts for any old definition
1072 ;;; and subclasses are invalidated, and the SUBCLASSES slot is cleared.
1073 ;; -- If DESTRUCT-LAYOUT, then this is some old layout, and is to be
1074 ;;; destructively modified to hold the same type information.
1075 ;;;
1076 (defun register-layout (layout &key (invalidate t) destruct-layout)
1077 (declare (type layout layout) (type (or layout null) destruct-layout))
1078 (let* ((class (layout-class layout))
1079 (class-layout (%class-layout class))
1080 (subclasses (%class-subclasses class)))
1081 (assert (not (eq class-layout layout)))
1082 (when class-layout
1083 (modify-class class)
1084 (when subclasses
1085 (do-hash (c l subclasses)
1086 (modify-class c)
1087 (when invalidate (invalidate-layout l))))
1088 (when invalidate
1089 (invalidate-layout class-layout)
1090 (setf (%class-subclasses class) nil)))
1091
1092 (cond (destruct-layout
1093 (setf (layout-invalid destruct-layout) nil)
1094 (setf (layout-inherits destruct-layout) (layout-inherits layout))
1095 (setf (layout-inheritance-depth destruct-layout)
1096 (layout-inheritance-depth layout))
1097 (setf (layout-length destruct-layout) (layout-length layout))
1098 (setf (layout-info destruct-layout) (layout-info layout))
1099 (setf (%class-layout class) destruct-layout))
1100 (t
1101 (setf (layout-invalid layout) nil)
1102 (setf (%class-layout class) layout)))
1103
1104 (let ((inherits (layout-inherits layout)))
1105 (dotimes (i (length inherits))
1106 (let* ((super (layout-class (svref inherits i)))
1107 (subclasses (or (%class-subclasses super)
1108 (setf (%class-subclasses super)
1109 (make-hash-table :test #'eq)))))
1110 (when (and (eq (%class-state super) :sealed)
1111 (not (gethash class subclasses)))
1112 (warn (intl:gettext "Subclassing sealed class ~S; unsealing it.")
1113 (%class-name super))
1114 (setf (%class-state super) :read-only))
1115 (setf (gethash class subclasses)
1116 (or destruct-layout layout))))))
1117
1118 (undefined-value))
1119
1120
1121 ;;; LAYOUT-PROPER-NAME -- Internal
1122 ;;;
1123 (defun layout-proper-name (layout)
1124 (class-proper-name (layout-class layout)))
1125
1126
1127 ;;; REDEFINE-LAYOUT-WARNING -- Interface
1128 ;;;
1129 ;;; If layouts Old and New differ in any interesting way, then give a
1130 ;;; warning and return T.
1131 ;;;
1132 (defun redefine-layout-warning (old old-context new new-context)
1133 (declare (type layout old new) (simple-string old-context new-context))
1134 (when (typep (layout-class old) 'undefined-class)
1135 (setf (layout-class old) (layout-class new)))
1136 (assert (eq (layout-class old) (layout-class new)))
1137 (let ((name (layout-proper-name old)))
1138 (or (let ((oldi (layout-inherits old))
1139 (newi (layout-inherits new)))
1140 (or (when (mismatch oldi newi :key #'layout-proper-name)
1141 (warn
1142 (intl:gettext "Change in superclasses of class ~S:~% ~
1143 ~A superclasses: ~S~% ~
1144 ~A superclasses: ~S")
1145 name
1146 old-context (map 'list #'layout-proper-name oldi)
1147 new-context (map 'list #'layout-proper-name newi))
1148 t)
1149 (let ((diff (mismatch oldi newi)))
1150 (when diff
1151 (warn
1152 (intl:gettext "In class ~S:~% ~
1153 ~:(~A~) definition of superclass ~S incompatible with~% ~
1154 ~A definition.")
1155 name old-context (layout-proper-name (svref oldi diff))
1156 new-context)
1157 t))))
1158 (let ((old-len (layout-length old))
1159 (new-len (layout-length new)))
1160 (unless (= old-len new-len)
1161 (warn (intl:gettext "Change in instance length of class ~S:~% ~
1162 ~A length: ~D~% ~
1163 ~A length: ~D")
1164 name
1165 old-context old-len
1166 new-context new-len)
1167 t))
1168 (when (/= (layout-inheritance-depth old)
1169 (layout-inheritance-depth new))
1170 (warn (intl:gettext "Change in the inheritance structure of class ~S~% ~
1171 between the ~A definition and the ~A definition.")
1172 name old-context new-context)
1173 t))))
1174
1175
1176 ;;; FIND-LAYOUT -- Interface
1177 ;;;
1178 ;;; Used by the loader to forward-reference layouts for classes whose
1179 ;;; definitions may not have been loaded yet. This allows type tests to be
1180 ;;; loaded when the type definition hasn't been loaded yet. Name is the class
1181 ;;; name, Length is the length of instances, Inherits is a simple-vector of the
1182 ;;; layouts for the classes it inherits, and Depth is the Inheritance-Depth.
1183 ;;;
1184 ;;; If we can't find any existing layout, then we create a new one with the
1185 ;;; supplied information, storing it in *FORWARD-REFERENCED-LAYOUTS*. If we
1186 ;;; can find the layout, then return it, after checking for compatibility. If
1187 ;;; incompatible, we allow the layout to be replaced, altered or left alone.
1188 ;;;
1189 (defun find-layout (name length inherits depth)
1190 (declare (type index length) (simple-vector inherits)
1191 (type (or index (integer -1 -1)) depth))
1192 (let* ((class (or (find-class name nil)
1193 (make-undefined-class name)))
1194 (old (or (%class-layout class)
1195 (gethash name *forward-referenced-layouts*)))
1196 (res (make-layout :class class
1197 :invalid :undefined
1198 :inherits inherits
1199 :inheritance-depth depth
1200 :length length)))
1201 (cond ((not old)
1202 (setf (gethash name *forward-referenced-layouts*) res))
1203 ((not *type-system-initialized*)
1204 (setf (layout-class old) class)
1205 old)
1206 #-bootstrap-dynamic-extent
1207 ((redefine-layout-warning old "current" res "compile time")
1208 (restart-case
1209 (error (intl:gettext "Loading a reference to class ~S when the compile~
1210 ~% time definition was incompatible with the current ~
1211 one.")
1212 name)
1213 (continue ()
1214 :report (lambda (stream)
1215 (write-string (intl:gettext "Invalidate current definition.") stream))
1216 (warn (intl:gettext "New definition of ~S must be loaded eventually.") name)
1217 (invalidate-layout old)
1218 (setf (gethash name *forward-referenced-layouts*) res))
1219 (clobber-it ()
1220 :report (lambda (stream)
1221 (write-string (intl:gettext "Smash current layout, preserving old code.") stream))
1222 (warn (intl:gettext "Any old ~S instances will be in a bad way.~@
1223 I hope you know what you're doing...")
1224 name)
1225 (setf (layout-inherits old) inherits)
1226 (setf (layout-inheritance-depth old) depth)
1227 (setf (layout-length old) length)
1228 old)
1229 (use-current ()
1230 :report (lambda (stream)
1231 (write-string (intl:gettext "Ignore the incompatibility, leave class alone.") stream))
1232 (warn (intl:gettext "Assuming the current definition of ~S is correct, and~@
1233 that the loaded code doesn't care about the ~
1234 incompatibility.")
1235 name)
1236 old)))
1237 (t old))))
1238
1239
1240 ;;; Class precedence lists
1241
1242 ;;; topological-sort -- Public.
1243 ;;;
1244 ;;; Topologically sort the list of objects to meet a set of ordering
1245 ;;; constraints given by pairs (A . B) constraining A to precede B. When
1246 ;;; there are multiple objects to choose, the tie-breaker function is called
1247 ;;; with both the list of object to choose from and the reverse ordering built
1248 ;;; so far.
1249 ;;;
1250 (defun topological-sort (objects constraints tie-breaker)
1251 (declare (list objects constraints)
1252 (function tie-breaker))
1253 (let ((obj-info (make-hash-table :size (length objects)))
1254 (free-objs nil)
1255 (result nil))
1256 (dolist (constraint constraints)
1257 (let ((obj1 (car constraint))
1258 (obj2 (cdr constraint)))
1259 (let ((info2 (gethash obj2 obj-info)))
1260 (if info2
1261 (incf (first info2))
1262 (setf (gethash obj2 obj-info) (list 1))))
1263 (let ((info1 (gethash obj1 obj-info)))
1264 (if info1
1265 (push obj2 (rest info1))
1266 (setf (gethash obj1 obj-info) (list 0 obj2))))))
1267 (dolist (obj objects)
1268 (let ((info (gethash obj obj-info)))
1269 (when (or (not info) (zerop (first info)))
1270 (push obj free-objs))))
1271 (loop
1272 (flet ((next-result (obj)
1273 (push obj result)
1274 (dolist (successor (rest (gethash obj obj-info)))
1275 (let* ((successor-info (gethash successor obj-info))
1276 (count (1- (first successor-info))))
1277 (setf (first successor-info) count)
1278 (when (zerop count)
1279 (push successor free-objs))))))
1280 (cond ((endp free-objs)
1281 (do-hash (obj info obj-info)
1282 (unless (zerop (first info))
1283 (error (intl:gettext "Topological sort failed due to constraint on ~S.")
1284 obj)))
1285 (return (nreverse result)))
1286 ((endp (rest free-objs))
1287 (next-result (pop free-objs)))
1288 (t
1289 (let ((obj (funcall tie-breaker free-objs result)))
1290 (setf free-objs (remove obj free-objs))
1291 (next-result obj))))))))
1292
1293
1294 ;;; std-compute-class-precedence-list -- Internal.
1295 ;;;
1296 ;;; Standard class precedence list computation.
1297 ;;;
1298 (defun std-compute-class-precedence-list (class)
1299 (let ((classes nil)
1300 (constraints nil))
1301 (labels ((note-class (class)
1302 (unless (member class classes)
1303 (push class classes)
1304 (let ((superclasses (%class-direct-superclasses class)))
1305 (do ((prev class)
1306 (rest superclasses (rest rest)))
1307 ((endp rest))
1308 (let ((next (first rest)))
1309 (push (cons prev next) constraints)
1310 (setf prev next)))
1311 (dolist (class superclasses)
1312 (note-class class)))))
1313 (std-cpl-tie-breaker (free-classes rev-cpl)
1314 (dolist (class rev-cpl (first free-classes))
1315 (let* ((superclasses (%class-direct-superclasses class))
1316 (intersection (intersection free-classes
1317 superclasses)))
1318 (when intersection
1319 (return (first intersection)))))))
1320 (note-class class)
1321 (topological-sort classes constraints #'std-cpl-tie-breaker))))
1322
1323
1324 ;;; PCL stuff:
1325
1326 (defstruct (std-class (:include class)))
1327 (defstruct (standard-class (:include std-class)))
1328 (defstruct (random-pcl-class (:include std-class)))
1329
1330
1331 ;;;; Cold loading initializations.
1332
1333 (defun class-finalize ()
1334 (dolist (layout *layout-hash-inits*)
1335 (initialize-layout-hash layout))
1336 (makunbound '*layout-hash-inits*)
1337 (do-hash (name layout *forward-referenced-layouts*)
1338 (let ((class (find-class name nil)))
1339 (cond ((not class)
1340 (setf (layout-class layout) (make-undefined-class name)))
1341 ((eq (%class-layout class) layout)
1342 (remhash name *forward-referenced-layouts*))
1343 (t
1344 (warn (intl:gettext "Something strange with forward layout for ~S:~% ~S")
1345 name layout))))))
1346
1347 (emit-cold-load-defuns "CLASS")

  ViewVC Help
Powered by ViewVC 1.1.5