1 ;;;; This file contains structures and functions for the maintenance of
2 ;;;; basic information about defined types. Different object systems
3 ;;;; can be supported simultaneously.
5 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; This software is derived from the CMU CL system, which was
9 ;;;; written at Carnegie Mellon University and released into the
10 ;;;; public domain. The software is in the public domain and is
11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
12 ;;;; files for more information.
14 (in-package "SB!KERNEL")
16 ;;;; DEFSTRUCT-DESCRIPTION
18 ;;; The DEFSTRUCT-DESCRIPTION structure holds compile-time information
19 ;;; about a structure type.
20 ;;; It is defined prior to LAYOUT because a LAYOUT-INFO slot
21 ;;; is declared to hold a DEFSTRUCT-DESCRIPTION.
22 (def!struct
(defstruct-description
24 (:make-load-form-fun just-dump-it-normally
)
25 #-sb-xc-host
(:pure t
)
26 (:constructor make-defstruct-description
(null-lexenv-p name
)))
27 ;; name of the structure
28 (name (missing-arg) :type symbol
:read-only t
)
29 ;; documentation on the structure
30 (doc nil
:type
(or string null
))
31 ;; prefix for slot names. If NIL, none.
32 (conc-name nil
:type
(or string null
))
33 ;; All the :CONSTRUCTOR specs and posssibly an implied constructor,
34 ;; keyword constructors first, then BOA constructors. NIL if none.
35 (constructors () :type list
)
36 ;; True if the DEFSTRUCT appeared in a null lexical environment.
37 (null-lexenv-p nil
:type boolean
:read-only t
) ; the safe default is NIL
38 ;; name of copying function
39 (copier-name nil
:type symbol
)
40 ;; name of type predicate
41 (predicate-name nil
:type symbol
)
42 ;; the arguments to the :INCLUDE option, or NIL if no included
44 (include nil
:type list
)
45 ;; properties used to define structure-like classes with an
46 ;; arbitrary superclass and that may not have STRUCTURE-CLASS as the
47 ;; metaclass. Syntax is:
48 ;; (superclass-name metaclass-name metaclass-constructor)
49 (alternate-metaclass nil
:type list
)
50 ;; a list of DEFSTRUCT-SLOT-DESCRIPTION objects for all slots
51 ;; (including included ones)
53 ;; a list of (NAME . INDEX) pairs for accessors of included structures
54 (inherited-accessor-alist () :type list
)
55 ;; number of elements we've allocated (See also RAW-LENGTH, which is not
56 ;; included in LENGTH.)
57 (length 0 :type index
)
58 ;; General kind of implementation.
59 (type 'structure
:type
(member structure vector list
60 funcallable-structure
))
62 ;; The next three slots are for :TYPE'd structures (which aren't
63 ;; classes, DD-CLASS-P = NIL)
65 ;; vector element type
67 ;; T if :NAMED was explicitly specified, NIL otherwise
68 (named nil
:type boolean
)
69 ;; any INITIAL-OFFSET option on this direct type
70 (offset nil
:type
(or index null
))
72 ;; which :PRINT-mumble option was given, if either was.
73 (print-option nil
:type
(member nil
:print-function
:print-object
))
74 ;; the argument to the PRINT-FUNCTION or PRINT-OBJECT option.
75 ;; NIL if the option was given with no argument.
76 (printer-fname nil
:type
(or cons symbol
))
78 ;; the value of the :PURE option, or :UNSPECIFIED. This is only
79 ;; meaningful if DD-CLASS-P = T.
80 (pure :unspecified
:type
(member t nil
:unspecified
)))
81 #!-sb-fluid
(declaim (freeze-type defstruct-description
))
83 ;;;; basic LAYOUT stuff
85 ;;; Note: This bound is set somewhat less than MOST-POSITIVE-FIXNUM
86 ;;; in order to guarantee that several hash values can be added without
87 ;;; overflowing into a bignum.
88 (defconstant layout-clos-hash-limit
(1+ (ash sb
!xc
:most-positive-fixnum -
3))
90 "the exclusive upper bound on LAYOUT-CLOS-HASH values")
91 ;; This must be DEF!TYPE and not just DEFTYPE because access to slots
92 ;; of a layout occur "before" the structure definition is made in the
93 ;; run-the-xc pass, and the source-transform of a slot accessor
94 ;; wraps (TRULY-THE <type> ...) around %INSTANCE-REF,
95 ;; so <type> had best be defined at that point.
96 (def!type layout-clos-hash
() `(integer 0 ,layout-clos-hash-limit
))
97 (declaim (ftype (sfunction () layout-clos-hash
) random-layout-clos-hash
))
99 ;;; The LAYOUT structure is pointed to by the first cell of instance
100 ;;; (or structure) objects. It represents what we need to know for
101 ;;; type checking and garbage collection. Whenever a class is
102 ;;; incompatibly redefined, a new layout is allocated. If two object's
103 ;;; layouts are EQ, then they are exactly the same type.
105 ;;; *** IMPORTANT ***
107 ;;; If you change the slots of LAYOUT, you need to alter genesis as
108 ;;; well, since the initialization of layout slots is hardcoded there.
110 ;;; FIXME: ...it would be better to automate this, of course...
112 ;; KLUDGE: A special hack keeps this from being
113 ;; called when building code for the
114 ;; cross-compiler. See comments at the DEFUN for
115 ;; this. -- WHN 19990914
116 (:make-load-form-fun
#-sb-xc-host ignore-it
117 ;; KLUDGE: DEF!STRUCT at #+SB-XC-HOST
118 ;; time controls both the
119 ;; build-the-cross-compiler behavior
120 ;; and the run-the-cross-compiler
121 ;; behavior. The value below only
122 ;; works for build-the-cross-compiler.
123 ;; There's a special hack in
124 ;; EMIT-MAKE-LOAD-FORM which gives
125 ;; effectively IGNORE-IT behavior for
126 ;; LAYOUT at run-the-cross-compiler
127 ;; time. It would be cleaner to
128 ;; actually have an IGNORE-IT value
129 ;; stored, but it's hard to see how to
130 ;; do that concisely with the current
131 ;; DEF!STRUCT setup. -- WHN 19990930
133 make-load-form-for-layout
))
134 ;; a pseudo-random hash value for use by CLOS.
135 (clos-hash (random-layout-clos-hash) :type layout-clos-hash
)
136 ;; the class that this is a layout for
137 (classoid (missing-arg) :type classoid
)
138 ;; The value of this slot can be:
139 ;; * :UNINITIALIZED if not initialized yet;
140 ;; * NIL if this is the up-to-date layout for a class; or
141 ;; * T if this layout has been invalidated (by being replaced by
142 ;; a new, more-up-to-date LAYOUT).
143 ;; * something else (probably a list) if the class is a PCL wrapper
144 ;; and PCL has made it invalid and made a note to itself about it
145 (invalid :uninitialized
:type
(or cons
(member nil t
:uninitialized
)))
146 ;; the layouts for all classes we inherit. If hierarchical, i.e. if
147 ;; DEPTHOID >= 0, then these are ordered by ORDER-LAYOUT-INHERITS
148 ;; (least to most specific), so that each inherited layout appears
149 ;; at its expected depth, i.e. at its LAYOUT-DEPTHOID value.
151 ;; Remaining elements are filled by the non-hierarchical layouts or,
152 ;; if they would otherwise be empty, by copies of succeeding layouts.
153 (inherits #() :type simple-vector
)
154 ;; If inheritance is not hierarchical, this is -1. If inheritance is
155 ;; hierarchical, this is the inheritance depth, i.e. (LENGTH INHERITS).
157 ;; (1) This turns out to be a handy encoding for arithmetically
158 ;; comparing deepness; it is generally useful to do a bare numeric
159 ;; comparison of these depthoid values, and we hardly ever need to
160 ;; test whether the values are negative or not.
161 ;; (2) This was called INHERITANCE-DEPTH in classic CMU CL. It was
162 ;; renamed because some of us find it confusing to call something
163 ;; a depth when it isn't quite.
164 (depthoid -
1 :type layout-depthoid
)
165 ;; the number of top level descriptor cells in each instance
166 (length 0 :type index
)
167 ;; If this layout has some kind of compiler meta-info, then this is
168 ;; it. If a structure, then we store the DEFSTRUCT-DESCRIPTION here.
169 (info nil
:type
(or null defstruct-description
))
170 ;; This is true if objects of this class are never modified to
171 ;; contain dynamic pointers in their slots or constant-like
172 ;; substructure (and hence can be copied into read-only space by
175 ;; This slot is known to the C runtime support code.
176 (pure nil
:type
(member t nil
0))
177 ;; Map of raw slot indices.
178 (bitmap 0 :type unsigned-byte
)
179 ;; Per-slot comparator for implementing EQUALP.
180 (equalp-tests #() :type simple-vector
)
181 ;; Definition location
182 (source-location nil
)
183 ;; If this layout is for an object of metatype STANDARD-CLASS,
184 ;; these are the EFFECTIVE-SLOT-DEFINITION metaobjects.
185 (slot-list nil
:type list
)
186 ;; Information about slots in the class to PCL: this provides fast
187 ;; access to slot-definitions and locations by name, etc.
188 ;; See MAKE-SLOT-TABLE in pcl/slots-boot.lisp for further details.
189 (slot-table #(1 nil
) :type simple-vector
)
190 ;; True IFF the layout belongs to a standand-instance or a
191 ;; standard-funcallable-instance.
193 ;; FIXME: If we unify wrappers and layouts this can go away, since
194 ;; it is only used in SB-PCL::EMIT-FETCH-WRAPPERS, which can then
195 ;; use INSTANCE-SLOTS-LAYOUT instead (if there is are no slot
196 ;; layouts, there are no slots for it to pull.)
197 ;; But while that's conceivable, it still seems advantageous to have
198 ;; a single bit that decides whether something is STANDARD-OBJECT.
199 (%for-std-class-b
0 :type bit
:read-only t
))
200 (declaim (freeze-type layout
))
202 ;;; The CLASSOID structure is a supertype of all classoid types. A
203 ;;; CLASSOID is also a CTYPE structure as recognized by the type
204 ;;; system. (FIXME: It's also a type specifier, though this might go
205 ;;; away as with the merger of SB-PCL:CLASS and CL:CLASS it's no
206 ;;; longer necessary)
207 (def!struct
(classoid
208 (:make-load-form-fun classoid-make-load-form-fun
)
210 (class-info (type-class-or-lose 'classoid
)))
212 #-no-ansi-print-object
214 (lambda (class stream
)
215 (let ((name (classoid-name class
)))
216 (print-unreadable-object (class stream
218 :identity
(not name
))
220 ;; FIXME: Make sure that this prints
221 ;; reasonably for anonymous classes.
222 "~:[anonymous~;~:*~S~]~@[ (~(~A~))~]"
224 (classoid-state class
))))))
225 #-sb-xc-host
(:pure nil
))
226 ;; the value to be returned by CLASSOID-NAME.
227 (name nil
:type symbol
)
228 ;; the current layout for this class, or NIL if none assigned yet
229 (layout nil
:type
(or layout null
))
230 ;; How sure are we that this class won't be redefined?
231 ;; :READ-ONLY = We are committed to not changing the effective
232 ;; slots or superclasses.
233 ;; :SEALED = We can't even add subclasses.
234 ;; NIL = Anything could happen.
235 (state nil
:type
(member nil
:read-only
:sealed
))
236 ;; direct superclasses of this class. Always NIL for CLOS classes.
237 (direct-superclasses () :type list
)
238 ;; representation of all of the subclasses (direct or indirect) of
239 ;; this class. This is NIL if no subclasses or not initalized yet;
240 ;; otherwise, it's an EQ hash-table mapping CLASSOID objects to the
241 ;; subclass layout that was in effect at the time the subclass was
243 (subclasses nil
:type
(or null hash-table
))
244 ;; the PCL class (= CL:CLASS, but with a view to future flexibility
245 ;; we don't just call it the CLASS slot) object for this class, or
246 ;; NIL if none assigned yet
249 ;;;; object types to represent classes
251 ;;; An UNDEFINED-CLASSOID is a cookie we make up to stick in forward
252 ;;; referenced layouts. Users should never see them.
253 (def!struct
(undefined-classoid
255 (:constructor make-undefined-classoid
(name))))
257 ;;; BUILT-IN-CLASS is used to represent the standard classes that
258 ;;; aren't defined with DEFSTRUCT and other specially implemented
259 ;;; primitive types whose only attribute is their name.
261 ;;; Some BUILT-IN-CLASSes have a TRANSLATION, which means that they
262 ;;; are effectively DEFTYPE'd to some other type (usually a union of
263 ;;; other classes or a "primitive" type such as NUMBER, ARRAY, etc.)
264 ;;; This translation is done when type specifiers are parsed. Type
265 ;;; system operations (union, subtypep, etc.) should never encounter
266 ;;; translated classes, only their translation.
267 (def!struct
(built-in-classoid (:include classoid
)
268 (:constructor make-built-in-classoid
))
269 ;; the type we translate to on parsing. If NIL, then this class
270 ;; stands on its own; or it can be set to :INITIALIZING for a period
272 (translation nil
:type
(or ctype
(member nil
:initializing
))))
274 (def!struct
(condition-classoid (:include classoid
)
275 (:constructor make-condition-classoid
))
276 ;; list of CONDITION-SLOT structures for the direct slots of this
278 (slots nil
:type list
)
279 ;; list of CONDITION-SLOT structures for all of the effective class
280 ;; slots of this class
281 (class-slots nil
:type list
)
282 ;; report function or NIL
283 (report nil
:type
(or function null
))
284 ;; list of specifications of the form
286 ;; (INITARG INITFORM THUNK)
288 ;; where THUNK, when called without arguments, returns the value for
290 (direct-default-initargs () :type list
)
291 ;; class precedence list as a list of CLASS objects, with all
292 ;; non-CONDITION classes removed
294 ;; a list of all the effective instance allocation slots of this
295 ;; class that have a non-constant initform or default-initarg.
296 ;; Values for these slots must be computed in the dynamic
297 ;; environment of MAKE-CONDITION.
298 (hairy-slots nil
:type list
))
300 ;;;; classoid namespace
302 ;;; We use an indirection to allow forward referencing of class
303 ;;; definitions with load-time resolution.
304 (def!struct
(classoid-cell
305 (:constructor make-classoid-cell
(name &optional classoid
))
306 (:make-load-form-fun
(lambda (c)
308 ',(classoid-cell-name c
)
310 #-no-ansi-print-object
311 (:print-object
(lambda (s stream
)
312 (print-unreadable-object (s stream
:type t
)
313 (prin1 (classoid-cell-name s
) stream
)))))
314 ;; Name of class we expect to find.
315 (name nil
:type symbol
:read-only t
)
316 ;; Classoid or NIL if not yet defined.
317 (classoid nil
:type
(or classoid null
))
320 (declaim (freeze-type classoid-cell
))
322 (defun find-classoid-cell (name &key create
)
323 (let ((real-name (uncross name
)))
324 (cond ((info :type
:classoid-cell real-name
))
326 (get-info-value-initializing :type
:classoid-cell real-name
327 (make-classoid-cell real-name
))))))
329 ;;; Return the classoid with the specified NAME. If ERRORP is false,
330 ;;; then NIL is returned when no such class exists.
331 (defun find-classoid (name &optional
(errorp t
))
332 (declare (type symbol name
))
333 (let ((cell (find-classoid-cell name
)))
334 (cond ((and cell
(classoid-cell-classoid cell
)))
336 (error 'simple-type-error
338 :expected-type
'class
339 :format-control
"Class not yet defined: ~S"
340 :format-arguments
(list name
))))))
344 ;;; the CLASSOID that we use to represent type information for
345 ;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. The type system
346 ;;; side does not need to distinguish between STANDARD-CLASS and
347 ;;; FUNCALLABLE-STANDARD-CLASS.
348 (def!struct
(standard-classoid (:include classoid
)
349 (:constructor make-standard-classoid
)))
350 ;;; a metaclass for classes which aren't standardlike but will never
352 (def!struct
(static-classoid (:include classoid
)
353 (:constructor make-static-classoid
)))
355 (declaim (freeze-type built-in-classoid condition-classoid
356 standard-classoid static-classoid
))
360 ;;; layout for this type being used by the compiler
361 (define-info-type (:type
:compiler-layout
)
362 :type-spec
(or layout null
)
363 :default
(lambda (name)
364 (let ((class (find-classoid name nil
)))
365 (when class
(classoid-layout class
)))))
367 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
368 (defun ftype-from-fdefn (name)
369 (declare (ignorable name
))
370 ;; Again [as in (DEFINE-INFO-TYPE (:FUNCTION :TYPE) ...)] it's
371 ;; not clear how to generalize the FBOUNDP expression to the
372 ;; cross-compiler. -- WHN 19990330
374 (specifier-type 'function
)
376 (let* ((fdefn (sb!kernel
::find-fdefn name
))
377 (fun (and fdefn
(fdefn-fun fdefn
))))
379 (handler-bind ((style-warning #'muffle-warning
))
380 (specifier-type (sb!impl
::%fun-type fun
)))
381 (specifier-type 'function
)))))
383 ;;; The type specifier for this function, or a DEFSTRUCT-DESCRIPTION
384 ;;; or the symbol :GENERIC-FUNTION.
385 ;;; If a DD, it must contain a constructor whose name is
386 ;;; the one being sought in globaldb, which is used to derive the type.
387 ;;; If :GENERIC-FUNCTION, the info is recomputed from existing methods
388 ;;; and stored back into globaldb.
389 (define-info-type (:function
:type
)
390 :type-spec
(or ctype defstruct-description
(member :generic-function
))
391 :default
#'ftype-from-fdefn
)
393 ;;; A random place for this :-(
394 #+sb-xc-host
(setq *info-environment
* (make-info-hashtable))