1 ;;;; that part of DEFSTRUCT implementation which is needed not just
2 ;;;; in the target Lisp but also in the cross-compilation host
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
13 (in-package "SB!KERNEL")
15 (/show0 "code/defstruct.lisp 15")
19 ;;; Return the compiler layout for NAME. (The class referred to by
20 ;;; NAME must be a structure-like class.)
21 (defun compiler-layout-or-lose (name)
22 (let ((res (info :type :compiler-layout name)))
24 (error "Class is not yet defined or was undefined: ~S" name))
25 ((not (typep (layout-info res) 'defstruct-description))
26 (error "Class is not a structure class: ~S" name))
29 (defun compiler-layout-ready-p (name)
30 (let ((layout (info :type :compiler-layout name)))
31 (and layout (typep (layout-info layout) 'defstruct-description))))
33 (sb!xc:defmacro %make-structure-instance-macro (dd slot-specs &rest slot-vars)
34 (if (compiler-layout-ready-p (dd-name dd))
35 `(truly-the ,(dd-name dd)
36 (%make-structure-instance ,dd ,slot-specs ,@slot-vars))
37 ;; Non-toplevel defstructs don't have a layout at compile time,
38 ;; so we need to construct the actual function at runtime -- but
39 ;; we cache it at the call site, so that we don't perform quite
41 `(let* ((cell (load-time-value (list nil)))
44 (funcall fun ,@slot-vars)
45 (funcall (setf (car cell)
46 (%make-structure-instance-allocator ,dd ,slot-specs))
49 (declaim (ftype (sfunction (defstruct-description list) function)
50 %make-structure-instance-allocator))
51 (defun %make-structure-instance-allocator (dd slot-specs)
52 (let ((vars (make-gensym-list (length slot-specs))))
53 (values (compile nil `(lambda (,@vars)
54 (%make-structure-instance-macro ,dd ',slot-specs ,@vars))))))
56 (defun %make-funcallable-structure-instance-allocator (dd slot-specs)
58 (bug "funcallable-structure-instance allocation with slots unimplemented"))
59 (let ((name (dd-name dd))
60 (length (dd-length dd))
61 (nobject (gensym "OBJECT")))
63 (compile nil `(lambda ()
64 (let ((,nobject (%make-funcallable-instance ,length)))
65 (setf (%funcallable-instance-layout ,nobject)
66 (%delayed-get-compiler-layout ,name))
69 ;;; Delay looking for compiler-layout until the constructor is being
70 ;;; compiled, since it doesn't exist until after the EVAL-WHEN
71 ;;; (COMPILE) stuff is compiled. (Or, in the oddball case when
72 ;;; DEFSTRUCT is executing in a non-toplevel context, the
73 ;;; compiler-layout still doesn't exist at compilation time, and we
74 ;;; delay still further.)
75 (sb!xc:defmacro %delayed-get-compiler-layout (name)
76 (let ((layout (info :type :compiler-layout name)))
78 ;; ordinary case: When the DEFSTRUCT is at top level,
79 ;; then EVAL-WHEN (COMPILE) stuff will have set up the
80 ;; layout for us to use.
81 (unless (typep (layout-info layout) 'defstruct-description)
82 (error "Class is not a structure class: ~S" name))
85 ;; KLUDGE: In the case that DEFSTRUCT is not at top-level
86 ;; the layout doesn't exist at compile time. In that case
87 ;; we laboriously look it up at run time. This code will
88 ;; run on every constructor call and will likely be quite
89 ;; slow, so if anyone cares about performance of
90 ;; non-toplevel DEFSTRUCTs, it should be rewritten to be
91 ;; cleverer. -- WHN 2002-10-23
93 "implementation limitation: ~
94 Non-toplevel DEFSTRUCT constructors are slow.")
95 (with-unique-names (layout)
96 `(let ((,layout (info :type :compiler-layout ',name)))
97 (unless (typep (layout-info ,layout) 'defstruct-description)
98 (error "Class is not a structure class: ~S" ',name))
101 ;;; re. %DELAYED-GET-COMPILER-LAYOUT and COMPILE-TIME-FIND-LAYOUT, above..
103 ;;; FIXME: Perhaps both should be defined with DEFMACRO-MUNDANELY?
104 ;;; FIXME: Do we really need both? If so, their names and implementations
105 ;;; should probably be tweaked to be more parallel.
107 ;;;; DEFSTRUCT-DESCRIPTION
109 ;;; The DEFSTRUCT-DESCRIPTION structure holds compile-time information
110 ;;; about a structure type.
111 (def!struct (defstruct-description
113 (:make-load-form-fun just-dump-it-normally)
114 #-sb-xc-host (:pure t)
115 (:constructor make-defstruct-description
117 (conc-name (symbolicate name "-"))
118 (copier-name (symbolicate "COPY-" name))
119 (predicate-name (symbolicate name "-P")))))
120 ;; name of the structure
121 (name (missing-arg) :type symbol :read-only t)
122 ;; documentation on the structure
123 (doc nil :type (or string null))
124 ;; prefix for slot names. If NIL, none.
125 (conc-name nil :type (or symbol null))
126 ;; the name of the primary standard keyword constructor, or NIL if none
127 (default-constructor nil :type (or symbol null))
128 ;; all the explicit :CONSTRUCTOR specs, with name defaulted
129 (constructors () :type list)
130 ;; name of copying function
131 (copier-name nil :type (or symbol null))
132 ;; name of type predicate
133 (predicate-name nil :type (or symbol null))
134 ;; the arguments to the :INCLUDE option, or NIL if no included
136 (include nil :type list)
137 ;; properties used to define structure-like classes with an
138 ;; arbitrary superclass and that may not have STRUCTURE-CLASS as the
139 ;; metaclass. Syntax is:
140 ;; (superclass-name metaclass-name metaclass-constructor)
141 (alternate-metaclass nil :type list)
142 ;; a list of DEFSTRUCT-SLOT-DESCRIPTION objects for all slots
143 ;; (including included ones)
144 (slots () :type list)
145 ;; a list of (NAME . INDEX) pairs for accessors of included structures
146 (inherited-accessor-alist () :type list)
147 ;; number of elements we've allocated (See also RAW-LENGTH, which is not
148 ;; included in LENGTH.)
149 (length 0 :type index)
150 ;; General kind of implementation.
151 (type 'structure :type (member structure vector list
152 funcallable-structure))
154 ;; The next three slots are for :TYPE'd structures (which aren't
155 ;; classes, DD-CLASS-P = NIL)
157 ;; vector element type
159 ;; T if :NAMED was explicitly specified, NIL otherwise
160 (named nil :type boolean)
161 ;; any INITIAL-OFFSET option on this direct type
162 (offset nil :type (or index null))
164 ;; the argument to the PRINT-FUNCTION option, or NIL if a
165 ;; PRINT-FUNCTION option was given with no argument, or 0 if no
166 ;; PRINT-FUNCTION option was given
167 (print-function 0 :type (or cons symbol (member 0)))
168 ;; the argument to the PRINT-OBJECT option, or NIL if a PRINT-OBJECT
169 ;; option was given with no argument, or 0 if no PRINT-OBJECT option
171 (print-object 0 :type (or cons symbol (member 0)))
172 ;; The number of untagged slots at the end.
173 (raw-length 0 :type index)
174 ;; the value of the :PURE option, or :UNSPECIFIED. This is only
175 ;; meaningful if DD-CLASS-P = T.
176 (pure :unspecified :type (member t nil :substructure :unspecified)))
177 (def!method print-object ((x defstruct-description) stream)
178 (print-unreadable-object (x stream :type t)
179 (prin1 (dd-name x) stream)))
181 ;;; Does DD describe a structure with a class?
182 (defun dd-class-p (dd)
184 '(structure funcallable-structure)))
186 ;;; a type name which can be used when declaring things which operate
187 ;;; on structure instances
188 (defun dd-declarable-type (dd)
190 ;; Native classes are known to the type system, and we can
191 ;; declare them as types.
193 ;; Structures layered on :TYPE LIST or :TYPE VECTOR aren't part
194 ;; of the type system, so all we can declare is the underlying
195 ;; LIST or VECTOR type.
198 (defun dd-layout-or-lose (dd)
199 (compiler-layout-or-lose (dd-name dd)))
201 ;;;; DEFSTRUCT-SLOT-DESCRIPTION
203 ;;; A DEFSTRUCT-SLOT-DESCRIPTION holds compile-time information about
204 ;;; a structure slot.
205 (def!struct (defstruct-slot-description
206 (:make-load-form-fun just-dump-it-normally)
209 #-sb-xc-host (:pure t))
212 ;; its position in the implementation sequence
213 (index (missing-arg) :type fixnum)
214 ;; the name of the accessor function
216 ;; (CMU CL had extra complexity here ("..or NIL if this accessor has
217 ;; the same name as an inherited accessor (which we don't want to
218 ;; shadow)") but that behavior doesn't seem to be specified by (or
219 ;; even particularly consistent with) ANSI, so it's gone in SBCL.)
221 default ; default value expression
222 (type t) ; declared type specifier
223 (safe-p t :type boolean) ; whether the slot is known to be
224 ; always of the specified type
225 ;; If this object does not describe a raw slot, this value is T.
227 ;; If this object describes a raw slot, this value is the type of the
228 ;; value that the raw slot holds.
229 (raw-type t :type (member t single-float double-float
230 #!+long-float long-float
231 complex-single-float complex-double-float
232 #!+long-float complex-long-float
234 (read-only nil :type (member t nil)))
235 (def!method print-object ((x defstruct-slot-description) stream)
236 (print-unreadable-object (x stream :type t)
237 (prin1 (dsd-name x) stream)))
239 ;;;; typed (non-class) structures
241 ;;; Return a type specifier we can use for testing :TYPE'd structures.
242 (defun dd-lisp-type (defstruct)
243 (ecase (dd-type defstruct)
245 (vector `(simple-array ,(dd-element-type defstruct) (*)))))
247 ;;;; shared machinery for inline and out-of-line slot accessor functions
249 ;;; Classic comment preserved for entertainment value:
251 ;;; "A lie can travel halfway round the world while the truth is
252 ;;; putting on its shoes." -- Mark Twain
254 ;; information about how a slot of a given DSD-RAW-TYPE is to be accessed
255 (defstruct (raw-slot-data
258 ;; the raw slot type, or T for a non-raw slot
260 ;; (Non-raw slots are in the ordinary place you'd expect, directly
261 ;; indexed off the instance pointer. Raw slots are indexed from the end
262 ;; of the instance and skipped by GC.)
263 (raw-type (missing-arg) :type (or symbol cons) :read-only t)
264 ;; What operator is used to access a slot of this type?
265 (accessor-name (missing-arg) :type symbol :read-only t)
266 (init-vop (missing-arg) :type symbol :read-only t)
267 ;; How many words are each value of this type?
268 (n-words (missing-arg) :type (and index (integer 1)) :read-only t)
269 ;; Necessary alignment in units of words. Note that instances
270 ;; themselves are aligned by exactly two words, so specifying more
271 ;; than two words here would not work.
272 (alignment 1 :type (integer 1 2) :read-only t)
273 (comparer (missing-arg) :type function :read-only t))
275 (defvar *raw-slot-data-list*
276 (macrolet ((make-comparer (accessor-name)
278 (declare (optimize speed (safety 0)))
279 (= (,accessor-name x index)
280 (,accessor-name y index)))))
281 (let ((double-float-alignment
282 ;; white list of architectures that can load unaligned doubles:
283 #!+(or x86 x86-64 ppc) 1
284 ;; at least sparc, mips and alpha can't:
285 #!-(or x86 x86-64 ppc) 2))
287 (make-raw-slot-data :raw-type 'sb!vm:word
288 :accessor-name '%raw-instance-ref/word
289 :init-vop 'sb!vm::raw-instance-init/word
291 :comparer (make-comparer %raw-instance-ref/word))
292 (make-raw-slot-data :raw-type 'single-float
293 :accessor-name '%raw-instance-ref/single
294 :init-vop 'sb!vm::raw-instance-init/single
295 ;; KLUDGE: On 64 bit architectures, we
296 ;; could pack two SINGLE-FLOATs into the
297 ;; same word if raw slots were indexed
298 ;; using bytes instead of words. However,
299 ;; I don't personally find optimizing
300 ;; SINGLE-FLOAT memory usage worthwile
301 ;; enough. And the other datatype that
302 ;; would really benefit is (UNSIGNED-BYTE
303 ;; 32), but that is a subtype of FIXNUM, so
304 ;; we store it unraw anyway. :-( -- DFL
306 :comparer (make-comparer %raw-instance-ref/single))
307 (make-raw-slot-data :raw-type 'double-float
308 :accessor-name '%raw-instance-ref/double
309 :init-vop 'sb!vm::raw-instance-init/double
310 :alignment double-float-alignment
311 :n-words (/ 8 sb!vm:n-word-bytes)
312 :comparer (make-comparer %raw-instance-ref/double))
313 (make-raw-slot-data :raw-type 'complex-single-float
314 :accessor-name '%raw-instance-ref/complex-single
315 :init-vop 'sb!vm::raw-instance-init/complex-single
316 :n-words (/ 8 sb!vm:n-word-bytes)
317 :comparer (make-comparer %raw-instance-ref/complex-single))
318 (make-raw-slot-data :raw-type 'complex-double-float
319 :accessor-name '%raw-instance-ref/complex-double
320 :init-vop 'sb!vm::raw-instance-init/complex-double
321 :alignment double-float-alignment
322 :n-words (/ 16 sb!vm:n-word-bytes)
323 :comparer (make-comparer %raw-instance-ref/complex-double))
325 (make-raw-slot-data :raw-type long-float
326 :accessor-name '%raw-instance-ref/long
327 :init-vop 'sb!vm::raw-instance-init/long
328 :n-words #!+x86 3 #!+sparc 4
329 :comparer (make-comparer %raw-instance-ref/long))
331 (make-raw-slot-data :raw-type complex-long-float
332 :accessor-name '%raw-instance-ref/complex-long
333 :init-vop 'sb!vm::raw-instance-init/complex-long
334 :n-words #!+x86 6 #!+sparc 8
335 :comparer (make-comparer %raw-instance-ref/complex-long))))))
337 (defun raw-slot-words (type)
338 (let ((rsd (find type *raw-slot-data-list* :key #'raw-slot-data-raw-type)))
340 (raw-slot-data-n-words rsd)
341 (error "Invalid raw slot type: ~S" type))))
343 ;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its
344 ;;;; close personal friend SB!XC:DEFSTRUCT)
346 ;;; Return a list of forms to install PRINT and MAKE-LOAD-FORM funs,
347 ;;; mentioning them in the expansion so that they can be compiled.
348 (defun class-method-definitions (defstruct)
349 (let ((name (dd-name defstruct)))
351 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant
352 ;; class names which creates fast but non-cold-loadable,
353 ;; non-compact code. In this context, we'd rather have
354 ;; compact, cold-loadable code. -- WHN 19990928
355 (declare (notinline find-classoid))
356 ,@(let ((pf (dd-print-function defstruct))
357 (po (dd-print-object defstruct))
358 (x (sb!xc:gensym "OBJECT"))
359 (s (sb!xc:gensym "STREAM")))
360 ;; Giving empty :PRINT-OBJECT or :PRINT-FUNCTION options
361 ;; leaves PO or PF equal to NIL. The user-level effect is
362 ;; to generate a PRINT-OBJECT method specialized for the type,
363 ;; implementing the default #S structure-printing behavior.
364 (when (or (eq pf nil) (eq po nil))
365 (setf pf '(default-structure-print)
367 (flet (;; Given an arg from a :PRINT-OBJECT or :PRINT-FUNCTION
368 ;; option, return the value to pass as an arg to FUNCTION.
370 (destructuring-bind (fun-name) oarg
372 (cond ((not (eql pf 0))
373 `((def!method print-object ((,x ,name) ,s)
374 (funcall #',(farg pf)
377 *current-level-in-print*))))
379 `((def!method print-object ((,x ,name) ,s)
380 (funcall #',(farg po) ,x ,s))))
382 ,@(let ((pure (dd-pure defstruct)))
384 `((setf (layout-pure (classoid-layout
385 (find-classoid ',name)))
387 ((eq pure :substructure)
388 `((setf (layout-pure (classoid-layout
389 (find-classoid ',name)))
391 ,@(let ((def-con (dd-default-constructor defstruct)))
392 (when (and def-con (not (dd-alternate-metaclass defstruct)))
393 `((setf (structure-classoid-constructor (find-classoid ',name))
396 ;;; shared logic for host macroexpansion for SB!XC:DEFSTRUCT and
397 ;;; cross-compiler macroexpansion for CL:DEFSTRUCT
398 (defmacro !expander-for-defstruct (name-and-options
400 expanding-into-code-for-xc-host-p)
401 `(let ((name-and-options ,name-and-options)
402 (slot-descriptions ,slot-descriptions)
403 (expanding-into-code-for-xc-host-p
404 ,expanding-into-code-for-xc-host-p))
405 (let* ((dd (parse-defstruct-name-and-options-and-slot-descriptions
410 (let ((inherits (inherits-for-structure dd)))
412 ;; Note we intentionally enforce package locks and
413 ;; call %DEFSTRUCT first, and especially before
414 ;; %COMPILER-DEFSTRUCT. %DEFSTRUCT has the tests (and
415 ;; resulting CERROR) for collisions with LAYOUTs which
416 ;; already exist in the runtime. If there are any
417 ;; collisions, we want the user's response to CERROR
418 ;; to control what happens. Especially, if the user
419 ;; responds to the collision with ABORT, we don't want
420 ;; %COMPILER-DEFSTRUCT to modify the definition of the
422 (with-single-package-locked-error
423 (:symbol ',name "defining ~A as a structure"))
424 (%defstruct ',dd ',inherits (sb!c:source-location))
425 (eval-when (:compile-toplevel :load-toplevel :execute)
426 (%compiler-defstruct ',dd ',inherits))
427 ,@(unless expanding-into-code-for-xc-host-p
428 (append ;; FIXME: We've inherited from CMU CL nonparallel
429 ;; code for creating copiers for typed and untyped
430 ;; structures. This should be fixed.
431 ;(copier-definition dd)
432 (constructor-definitions dd)
433 (class-method-definitions dd)))
436 (with-single-package-locked-error
437 (:symbol ',name "defining ~A as a structure"))
438 (eval-when (:compile-toplevel :load-toplevel :execute)
439 (setf (info :typed-structure :info ',name) ',dd))
440 (eval-when (:load-toplevel :execute)
441 (setf (info :source-location :typed-structure ',name)
442 (sb!c:source-location)))
443 ,@(unless expanding-into-code-for-xc-host-p
444 (append (typed-accessor-definitions dd)
445 (typed-predicate-definitions dd)
446 (typed-copier-definitions dd)
447 (constructor-definitions dd)
449 `((setf (fdocumentation ',(dd-name dd) 'structure)
453 (sb!xc:defmacro defstruct (name-and-options &rest slot-descriptions)
455 "DEFSTRUCT {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)}
456 Define the structure type Name. Instances are created by MAKE-<name>,
457 which takes &KEY arguments allowing initial slot values to the specified.
458 A SETF'able function <name>-<slot> is defined for each slot to read and
459 write slot values. <name>-p is a type predicate.
461 Popular DEFSTRUCT options (see manual for others):
465 Specify the name for the constructor or predicate.
467 (:CONSTRUCTOR Name Lambda-List)
468 Specify the name and arguments for a BOA constructor
469 (which is more efficient when keyword syntax isn't necessary.)
471 (:INCLUDE Supertype Slot-Spec*)
472 Make this type a subtype of the structure type Supertype. The optional
473 Slot-Specs override inherited slot options.
478 Asserts that the value of this slot is always of the specified type.
481 If true, no setter function is defined for this slot."
482 (!expander-for-defstruct name-and-options slot-descriptions nil))
484 (defmacro sb!xc:defstruct (name-and-options &rest slot-descriptions)
486 "Cause information about a target structure to be built into the
488 (!expander-for-defstruct name-and-options slot-descriptions t))
490 ;;;; functions to generate code for various parts of DEFSTRUCT definitions
492 ;;; First, a helper to determine whether a name names an inherited
494 (defun accessor-inherited-data (name defstruct)
495 (assoc name (dd-inherited-accessor-alist defstruct) :test #'eq))
497 ;;; Return a list of forms which create a predicate function for a
499 (defun typed-predicate-definitions (defstruct)
500 (let ((name (dd-name defstruct))
501 (predicate-name (dd-predicate-name defstruct))
503 (when (and predicate-name (dd-named defstruct))
504 (let ((ltype (dd-lisp-type defstruct))
505 (name-index (cdr (car (last (find-name-indices defstruct))))))
506 `((defun ,predicate-name (,argname)
507 (and (typep ,argname ',ltype)
509 ((subtypep ltype 'list)
510 `(do ((head (the ,ltype ,argname) (cdr head))
512 ((or (not (consp head)) (= i ,name-index))
513 (and (consp head) (eq ',name (car head))))))
514 ((subtypep ltype 'vector)
515 `(and (= (length (the ,ltype ,argname))
516 ,(dd-length defstruct))
517 (eq ',name (aref (the ,ltype ,argname) ,name-index))))
518 (t (bug "Uncatered-for lisp type in typed DEFSTRUCT: ~S."
521 ;;; Return a list of forms to create a copier function of a typed DEFSTRUCT.
522 (defun typed-copier-definitions (defstruct)
523 (when (dd-copier-name defstruct)
524 `((setf (fdefinition ',(dd-copier-name defstruct)) #'copy-seq)
525 (declaim (ftype function ,(dd-copier-name defstruct))))))
527 ;;; Return a list of function definitions for accessing and setting
528 ;;; the slots of a typed DEFSTRUCT. The functions are proclaimed to be
529 ;;; inline, and the types of their arguments and results are declared
530 ;;; as well. We count on the compiler to do clever things with ELT.
531 (defun typed-accessor-definitions (defstruct)
533 (let ((ltype (dd-lisp-type defstruct)))
534 (dolist (slot (dd-slots defstruct))
535 (let ((name (dsd-accessor-name slot))
536 (index (dsd-index slot))
537 (slot-type `(and ,(dsd-type slot)
538 ,(dd-element-type defstruct))))
539 (let ((inherited (accessor-inherited-data name defstruct)))
542 (stuff `(declaim (inline ,name ,@(unless (dsd-read-only slot)
544 (stuff `(defun ,name (structure)
545 (declare (type ,ltype structure))
546 (the ,slot-type (elt structure ,index))))
547 (unless (dsd-read-only slot)
549 `(defun (setf ,name) (new-value structure)
550 (declare (type ,ltype structure) (type ,slot-type new-value))
551 (setf (elt structure ,index) new-value)))))
552 ((not (= (cdr inherited) index))
553 (style-warn "~@<Non-overwritten accessor ~S does not access ~
554 slot with name ~S (accessing an inherited slot ~
555 instead).~:@>" name (dsd-name slot))))))))
560 (defun require-no-print-options-so-far (defstruct)
561 (unless (and (eql (dd-print-function defstruct) 0)
562 (eql (dd-print-object defstruct) 0))
563 (error "No more than one of the following options may be specified:
564 :PRINT-FUNCTION, :PRINT-OBJECT, :TYPE")))
566 ;;; Parse a single DEFSTRUCT option and store the results in DD.
567 (defun parse-1-dd-option (option dd)
568 (let ((args (rest option))
572 (destructuring-bind (&optional conc-name) args
573 (setf (dd-conc-name dd)
574 (if (symbolp conc-name)
576 (make-symbol (string conc-name))))))
578 (destructuring-bind (&optional (cname (symbolicate "MAKE-" name))
581 (push (cons cname stuff) (dd-constructors dd))))
583 (destructuring-bind (&optional (copier (symbolicate "COPY-" name)))
585 (setf (dd-copier-name dd) copier)))
587 (destructuring-bind (&optional (predicate-name (symbolicate name "-P")))
589 (setf (dd-predicate-name dd) predicate-name)))
591 (when (dd-include dd)
592 (error "more than one :INCLUDE option"))
593 (setf (dd-include dd) args))
595 (require-no-print-options-so-far dd)
596 (setf (dd-print-function dd)
597 (the (or symbol cons) args)))
599 (require-no-print-options-so-far dd)
600 (setf (dd-print-object dd)
601 (the (or symbol cons) args)))
603 (destructuring-bind (type) args
604 (cond ((member type '(list vector))
605 (setf (dd-element-type dd) t)
606 (setf (dd-type dd) type))
607 ((and (consp type) (eq (first type) 'vector))
608 (destructuring-bind (vector vtype) type
609 (declare (ignore vector))
610 (setf (dd-element-type dd) vtype)
611 (setf (dd-type dd) 'vector)))
613 (error "~S is a bad :TYPE for DEFSTRUCT." type)))))
615 (error "The DEFSTRUCT option :NAMED takes no arguments."))
617 (destructuring-bind (offset) args
618 (setf (dd-offset dd) offset)))
620 (destructuring-bind (fun) args
621 (setf (dd-pure dd) fun)))
622 (t (error "unknown DEFSTRUCT option:~% ~S" option)))))
624 ;;; Given name and options, return a DD holding that info.
625 (defun parse-defstruct-name-and-options (name-and-options)
626 (destructuring-bind (name &rest options) name-and-options
627 (let ((dd (make-defstruct-description name))
628 (predicate-named-p nil))
629 (dolist (option options)
630 (cond ((eq option :named)
631 (setf (dd-named dd) t))
633 (when (and (eq (car option) :predicate) (second option))
634 (setf predicate-named-p t))
635 (parse-1-dd-option option dd))
636 ((member option '(:conc-name :constructor :copier :predicate))
637 (parse-1-dd-option (list option) dd))
639 (error "unrecognized DEFSTRUCT option: ~S" option))))
644 (error ":OFFSET can't be specified unless :TYPE is specified."))
645 (unless (dd-include dd)
646 ;; FIXME: It'd be cleaner to treat no-:INCLUDE as defaulting
647 ;; to :INCLUDE STRUCTURE-OBJECT, and then let the general-case
648 ;; (INCF (DD-LENGTH DD) (DD-LENGTH included-DD)) logic take
649 ;; care of this. (Except that the :TYPE VECTOR and :TYPE
650 ;; LIST cases, with their :NAMED and un-:NAMED flavors,
651 ;; make that messy, alas.)
652 (incf (dd-length dd))))
654 ;; In case we are here, :TYPE is specified.
655 (when (and predicate-named-p (not (dd-named dd)))
656 (error ":PREDICATE cannot be used with :TYPE unless :NAMED is also specified."))
657 (require-no-print-options-so-far dd)
659 (incf (dd-length dd)))
660 (let ((offset (dd-offset dd)))
661 (when offset (incf (dd-length dd) offset)))))
663 (when (dd-include dd)
664 (frob-dd-inclusion-stuff dd))
668 ;;; Given name and options and slot descriptions (and possibly doc
669 ;;; string at the head of slot descriptions) return a DD holding that
671 (defun parse-defstruct-name-and-options-and-slot-descriptions
672 (name-and-options slot-descriptions)
673 (let ((result (parse-defstruct-name-and-options (if (atom name-and-options)
674 (list name-and-options)
676 (when (stringp (car slot-descriptions))
677 (setf (dd-doc result) (pop slot-descriptions)))
678 (dolist (slot-description slot-descriptions)
679 (allocate-1-slot result (parse-1-dsd result slot-description)))
682 ;;;; stuff to parse slot descriptions
684 ;;; Parse a slot description for DEFSTRUCT, add it to the description
685 ;;; and return it. If supplied, SLOT is a pre-initialized DSD
686 ;;; that we modify to get the new slot. This is supplied when handling
688 (defun parse-1-dsd (defstruct spec &optional
689 (slot (make-defstruct-slot-description :name ""
692 (multiple-value-bind (name default default-p type type-p read-only ro-p)
696 ((or null (member :conc-name :constructor :copier :predicate :named))
697 (warn "slot name of ~S indicates probable syntax error in DEFSTRUCT" spec))
699 (style-warn "slot name of ~S indicates possible syntax error in DEFSTRUCT" spec)))
703 (name &optional (default nil default-p)
704 &key (type nil type-p) (read-only nil ro-p))
706 (when (dd-conc-name defstruct)
707 ;; the warning here is useful, but in principle we cannot
708 ;; distinguish between legitimate and erroneous use of
709 ;; these names when :CONC-NAME is NIL. In the common
710 ;; case (CONC-NAME non-NIL), there are alternative ways
711 ;; of writing code with the same effect, so a full
712 ;; warning is justified.
714 ((member :conc-name :constructor :copier :predicate :include
715 :print-function :print-object :type :initial-offset :pure)
716 (warn "slot name of ~S indicates probable syntax error in DEFSTRUCT" name))))
717 (values name default default-p
718 (uncross type) type-p
720 (t (error 'simple-program-error
721 :format-control "in DEFSTRUCT, ~S is not a legal slot ~
723 :format-arguments (list spec))))
725 (when (find name (dd-slots defstruct)
727 :key (lambda (x) (symbol-name (dsd-name x))))
728 (error 'simple-program-error
729 :format-control "duplicate slot name ~S"
730 :format-arguments (list name)))
731 (setf (dsd-name slot) name)
732 (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list slot)))
734 (let ((accessor-name (if (dd-conc-name defstruct)
735 (symbolicate (dd-conc-name defstruct) name)
737 (predicate-name (dd-predicate-name defstruct)))
738 (setf (dsd-accessor-name slot) accessor-name)
739 (when (eql accessor-name predicate-name)
740 ;; Some adventurous soul has named a slot so that its accessor
741 ;; collides with the structure type predicate. ANSI doesn't
742 ;; specify what to do in this case. As of 2001-09-04, Martin
743 ;; Atzmueller reports that CLISP and Lispworks both give
744 ;; priority to the slot accessor, so that the predicate is
745 ;; overwritten. We might as well do the same (as well as
746 ;; signalling a warning).
748 "~@<The structure accessor name ~S is the same as the name of the ~
749 structure type predicate. ANSI doesn't specify what to do in ~
750 this case. We'll overwrite the type predicate with the slot ~
751 accessor, but you can't rely on this behavior, so it'd be wise to ~
752 remove the ambiguity in your code.~@:>"
754 (setf (dd-predicate-name defstruct) nil))
755 ;; FIXME: It would be good to check for name collisions here, but
758 ;;x(when (and (fboundp accessor-name)
759 ;;x (not (accessor-inherited-data accessor-name defstruct)))
760 ;;x (style-warn "redefining ~/sb-impl::print-symbol-with-prefix/ ~
761 ;; in DEFSTRUCT" accessor-name)))
762 ;; which was done until sbcl-0.8.11.18 or so, is wrong: it causes
763 ;; a warning at MACROEXPAND time, when instead the warning should
764 ;; occur not just because the code was constructed, but because it
765 ;; is actually compiled or loaded.
769 (setf (dsd-default slot) default))
771 (setf (dsd-type slot)
772 (if (eq (dsd-type slot) t)
774 `(and ,(dsd-type slot) ,type))))
777 (setf (dsd-read-only slot) t)
778 (when (dsd-read-only slot)
779 (error "~@<The slot ~S is :READ-ONLY in superclass, and so must ~
780 be :READ-ONLY in subclass.~:@>"
784 ;;; When a value of type TYPE is stored in a structure, should it be
785 ;;; stored in a raw slot? Return the matching RAW-SLOT-DATA structure
786 ;; if TYPE should be stored in a raw slot, or NIL if not.
787 (defun structure-raw-slot-data (type)
788 (multiple-value-bind (fixnum? fixnum-certain?)
789 (sb!xc:subtypep type 'fixnum)
790 ;; (The extra test for FIXNUM-CERTAIN? here is intended for
791 ;; bootstrapping the system. In particular, in sbcl-0.6.2, we set up
792 ;; LAYOUT before FIXNUM is defined, and so could bogusly end up
793 ;; putting INDEX-typed values into raw slots if we didn't test
795 (if (or fixnum? (not fixnum-certain?))
797 (dolist (data *raw-slot-data-list*)
798 (when (sb!xc:subtypep type (raw-slot-data-raw-type data))
801 ;;; Allocate storage for a DSD in DD. This is where we decide whether
802 ;;; a slot is raw or not. Raw objects are aligned on the unit of their size.
803 (defun allocate-1-slot (dd dsd)
805 (if (eq (dd-type dd) 'structure)
806 (structure-raw-slot-data (dsd-type dsd))
810 (setf (dsd-index dsd) (dd-length dd))
811 (incf (dd-length dd)))
813 (let* ((words (raw-slot-data-n-words rsd))
814 (alignment (raw-slot-data-alignment rsd))
815 (off (rem (dd-raw-length dd) alignment)))
817 (incf (dd-raw-length dd) (- alignment off)))
818 (setf (dsd-raw-type dsd) (raw-slot-data-raw-type rsd))
819 (setf (dsd-index dsd) (dd-raw-length dd))
820 (incf (dd-raw-length dd) words)))))
823 (defun typed-structure-info-or-lose (name)
824 (or (info :typed-structure :info name)
825 (error ":TYPE'd DEFSTRUCT ~S not found for inclusion." name)))
827 ;;; Process any included slots pretty much like they were specified.
828 ;;; Also inherit various other attributes.
829 (defun frob-dd-inclusion-stuff (dd)
830 (destructuring-bind (included-name &rest modified-slots) (dd-include dd)
831 (let* ((type (dd-type dd))
834 (layout-info (compiler-layout-or-lose included-name))
835 (typed-structure-info-or-lose included-name))))
837 ;; checks on legality
838 (unless (and (eq type (dd-type included-structure))
839 (type= (specifier-type (dd-element-type included-structure))
840 (specifier-type (dd-element-type dd))))
841 (error ":TYPE option mismatch between structures ~S and ~S"
842 (dd-name dd) included-name))
843 (let ((included-classoid (find-classoid included-name nil)))
844 (when included-classoid
845 ;; It's not particularly well-defined to :INCLUDE any of the
846 ;; CMU CL INSTANCE weirdosities like CONDITION or
847 ;; GENERIC-FUNCTION, and it's certainly not ANSI-compliant.
848 (let* ((included-layout (classoid-layout included-classoid))
849 (included-dd (layout-info included-layout)))
850 (when (and (dd-alternate-metaclass included-dd)
851 ;; As of sbcl-0.pre7.73, anyway, STRUCTURE-OBJECT
852 ;; is represented with an ALTERNATE-METACLASS. But
853 ;; it's specifically OK to :INCLUDE (and PCL does)
854 ;; so in this one case, it's OK to include
855 ;; something with :ALTERNATE-METACLASS after all.
856 (not (eql included-name 'structure-object)))
857 (error "can't :INCLUDE class ~S (has alternate metaclass)"
860 (incf (dd-length dd) (dd-length included-structure))
861 (when (dd-class-p dd)
862 (let ((mc (rest (dd-alternate-metaclass included-structure))))
863 (when (and mc (not (dd-alternate-metaclass dd)))
864 (setf (dd-alternate-metaclass dd)
865 (cons included-name mc))))
866 (when (eq (dd-pure dd) :unspecified)
867 (setf (dd-pure dd) (dd-pure included-structure)))
868 (setf (dd-raw-length dd) (dd-raw-length included-structure)))
870 (setf (dd-inherited-accessor-alist dd)
871 (dd-inherited-accessor-alist included-structure))
872 (dolist (included-slot (dd-slots included-structure))
873 (let* ((included-name (dsd-name included-slot))
874 (modified (or (find included-name modified-slots
875 :key (lambda (x) (if (atom x) x (car x)))
878 ;; We stash away an alist of accessors to parents' slots
879 ;; that have already been created to avoid conflicts later
880 ;; so that structures with :INCLUDE and :CONC-NAME (and
881 ;; other edge cases) can work as specified.
882 (when (dsd-accessor-name included-slot)
883 ;; the "oldest" (i.e. highest up the tree of inheritance)
884 ;; will prevail, so don't push new ones on if they
886 (pushnew (cons (dsd-accessor-name included-slot)
887 (dsd-index included-slot))
888 (dd-inherited-accessor-alist dd)
889 :test #'eq :key #'car))
890 (let ((new-slot (parse-1-dsd dd
892 (copy-structure included-slot))))
893 (when (and (neq (dsd-type new-slot) (dsd-type included-slot))
894 (not (sb!xc:subtypep (dsd-type included-slot)
895 (dsd-type new-slot)))
896 (dsd-safe-p included-slot))
897 (setf (dsd-safe-p new-slot) nil)
901 ;;;; various helper functions for setting up DEFSTRUCTs
903 ;;; This function is called at macroexpand time to compute the INHERITS
904 ;;; vector for a structure type definition.
905 (defun inherits-for-structure (info)
906 (declare (type defstruct-description info))
907 (let* ((include (dd-include info))
908 (superclass-opt (dd-alternate-metaclass info))
911 (compiler-layout-or-lose (first include))
912 (classoid-layout (find-classoid
913 (or (first superclass-opt)
914 'structure-object))))))
917 (concatenate 'simple-vector
918 (layout-inherits super)
919 (vector super (classoid-layout (find-classoid 'stream)))))
921 (concatenate 'simple-vector
922 (layout-inherits super)
924 (classoid-layout (find-classoid 'file-stream)))))
925 ((sb!impl::string-input-stream
926 sb!impl::string-output-stream
927 sb!impl::fill-pointer-output-stream)
928 (concatenate 'simple-vector
929 (layout-inherits super)
931 (classoid-layout (find-classoid 'string-stream)))))
932 (t (concatenate 'simple-vector
933 (layout-inherits super)
936 ;;; Do miscellaneous (LOAD EVAL) time actions for the structure
937 ;;; described by DD. Create the class and LAYOUT, checking for
938 ;;; incompatible redefinition. Define those functions which are
939 ;;; sufficiently stereotyped that we can implement them as standard
941 (defun %defstruct (dd inherits source-location)
942 (declare (type defstruct-description dd))
944 ;; We set up LAYOUTs even in the cross-compilation host.
945 (multiple-value-bind (classoid layout old-layout)
946 (ensure-structure-class dd inherits "current" "new")
947 (cond ((not old-layout)
948 (unless (eq (classoid-layout classoid) layout)
949 (register-layout layout)))
951 (%redefine-defstruct classoid old-layout layout)
952 (let ((old-dd (layout-info old-layout)))
953 (when (defstruct-description-p old-dd)
954 (dolist (slot (dd-slots old-dd))
955 (fmakunbound (dsd-accessor-name slot))
956 (unless (dsd-read-only slot)
957 (fmakunbound `(setf ,(dsd-accessor-name slot)))))))
958 (setq layout (classoid-layout classoid))))
959 (setf (find-classoid (dd-name dd)) classoid)
961 (sb!c:with-source-location (source-location)
962 (setf (layout-source-location layout) source-location))
964 ;; Various other operations only make sense on the target SBCL.
966 (%target-defstruct dd layout))
970 ;;; Return a form describing the writable place used for this slot
971 ;;; in the instance named INSTANCE-NAME.
972 (defun %accessor-place-form (dd dsd instance-name)
973 (let (;; the operator that we'll use to access a typed slot
974 (ref (ecase (dd-type dd)
975 (structure '%instance-ref)
976 (list 'nth-but-with-sane-arg-order)
978 (raw-type (dsd-raw-type dsd)))
979 (if (eq raw-type t) ; if not raw slot
980 `(,ref ,instance-name ,(dsd-index dsd))
981 (let* ((raw-slot-data (find raw-type *raw-slot-data-list*
982 :key #'raw-slot-data-raw-type
984 (raw-slot-accessor (raw-slot-data-accessor-name raw-slot-data)))
985 `(,raw-slot-accessor ,instance-name ,(dsd-index dsd))))))
987 ;;; Return source transforms for the reader and writer functions of
988 ;;; the slot described by DSD. They should be inline expanded, but
989 ;;; source transforms work faster.
990 (defun slot-accessor-transforms (dd dsd)
991 (let ((accessor-place-form (%accessor-place-form dd dsd
992 `(the ,(dd-name dd) instance)))
993 (dsd-type (dsd-type dsd))
994 (value-the (if (dsd-safe-p dsd) 'truly-the 'the)))
995 (values (sb!c:source-transform-lambda (instance)
996 `(,value-the ,dsd-type ,(subst instance 'instance
997 accessor-place-form)))
998 (sb!c:source-transform-lambda (new-value instance)
999 (destructuring-bind (accessor-name &rest accessor-args)
1001 (once-only ((new-value new-value)
1002 (instance instance))
1003 `(,(info :setf :inverse accessor-name)
1004 ,@(subst instance 'instance accessor-args)
1005 (the ,dsd-type ,new-value))))))))
1007 ;;; Return a LAMBDA form which can be used to set a slot.
1008 (defun slot-setter-lambda-form (dd dsd)
1009 ;; KLUDGE: Evaluating the results of SLOT-ACCESSOR-TRANSFORMS needs
1011 (let ((sb!c:*lexenv* (if (boundp 'sb!c:*lexenv*)
1013 (sb!c::make-null-lexenv))))
1014 `(lambda (new-value instance)
1015 ,(funcall (nth-value 1 (slot-accessor-transforms dd dsd))
1016 '(dummy new-value instance)))))
1018 ;;; Blow away all the compiler info for the structure CLASS. Iterate
1019 ;;; over this type, clearing the compiler structure type info, and
1020 ;;; undefining all the associated functions. If SUBCLASSES-P, also do
1021 ;;; the same for subclasses. FIXME: maybe rename UNDEFINE-FUN-NAME to
1022 ;;; UNDECLARE-FUNCTION-NAME?
1023 (defun undeclare-structure (classoid subclasses-p)
1024 (let ((info (layout-info (classoid-layout classoid))))
1025 (when (defstruct-description-p info)
1026 (let ((type (dd-name info)))
1027 (remhash type *typecheckfuns*)
1028 (setf (info :type :compiler-layout type) nil)
1029 (undefine-fun-name (dd-copier-name info))
1030 (undefine-fun-name (dd-predicate-name info))
1031 (dolist (slot (dd-slots info))
1032 (let ((fun (dsd-accessor-name slot)))
1033 (unless (accessor-inherited-data fun info)
1034 (undefine-fun-name fun)
1035 (unless (dsd-read-only slot)
1036 (undefine-fun-name `(setf ,fun)))))))
1037 ;; Clear out the SPECIFIER-TYPE cache so that subsequent
1038 ;; references are unknown types.
1039 (values-specifier-type-cache-clear)))
1041 (let ((subclasses (classoid-subclasses classoid)))
1044 (dohash ((classoid layout)
1047 (declare (ignore layout))
1048 (undeclare-structure classoid nil)
1049 (subs (classoid-proper-name classoid)))
1050 ;; Is it really necessary to warn about
1051 ;; undeclaring functions for subclasses?
1053 (warn "undeclaring functions for old subclasses ~
1055 (classoid-name classoid)
1058 ;;; core compile-time setup of any class with a LAYOUT, used even by
1059 ;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities
1060 (defun %compiler-set-up-layout (dd
1062 ;; Several special cases
1063 ;; (STRUCTURE-OBJECT itself, and
1064 ;; structures with alternate
1065 ;; metaclasses) call this function
1066 ;; directly, and they're all at the
1067 ;; base of the instance class
1068 ;; structure, so this is a handy
1069 ;; default. (But note
1070 ;; FUNCALLABLE-STRUCTUREs need
1072 (inherits (vector (find-layout t))))
1074 (multiple-value-bind (classoid layout old-layout)
1075 (multiple-value-bind (clayout clayout-p)
1076 (info :type :compiler-layout (dd-name dd))
1077 (ensure-structure-class dd
1080 "The most recently compiled"
1082 "the most recently loaded"
1083 :compiler-layout clayout))
1085 (undeclare-structure (layout-classoid old-layout)
1086 (and (classoid-subclasses classoid)
1087 (not (eq layout old-layout))))
1088 (setf (layout-invalid layout) nil)
1089 ;; FIXME: it might be polite to hold onto old-layout and
1090 ;; restore it at the end of the file. -- RMK 2008-09-19
1091 ;; (International Talk Like a Pirate Day).
1092 (warn "~@<Clobbering the compiler's idea of the layout of ~A.~:@>"
1095 (unless (eq (classoid-layout classoid) layout)
1096 (register-layout layout :invalidate nil))
1097 (setf (find-classoid (dd-name dd)) classoid)))
1099 ;; At this point the class should be set up in the INFO database.
1100 ;; But the logic that enforces this is a little tangled and
1101 ;; scattered, so it's not obvious, so let's check.
1102 (aver (find-classoid (dd-name dd) nil))
1104 (setf (info :type :compiler-layout (dd-name dd)) layout))
1108 ;;; Do (COMPILE LOAD EVAL)-time actions for the normal (not
1109 ;;; ALTERNATE-LAYOUT) DEFSTRUCT described by DD.
1110 (defun %compiler-defstruct (dd inherits)
1111 (declare (type defstruct-description dd))
1113 (%compiler-set-up-layout dd inherits)
1115 (let* ((dtype (dd-declarable-type dd)))
1117 (let ((copier-name (dd-copier-name dd)))
1119 (sb!xc:proclaim `(ftype (sfunction (,dtype) ,dtype) ,copier-name))))
1121 (let ((predicate-name (dd-predicate-name dd)))
1122 (when predicate-name
1123 (sb!xc:proclaim `(ftype (sfunction (t) boolean) ,predicate-name))
1124 ;; Provide inline expansion (or not).
1126 ((structure funcallable-structure)
1127 ;; Let the predicate be inlined.
1128 (setf (info :function :inline-expansion-designator predicate-name)
1131 ;; This dead simple definition works because the
1132 ;; type system knows how to generate inline type
1133 ;; tests for instances.
1134 (typep x ',(dd-name dd))))
1135 (info :function :inlinep predicate-name)
1138 ;; Just punt. We could provide inline expansions for :TYPE
1139 ;; LIST and :TYPE VECTOR predicates too, but it'd be a
1140 ;; little messier and we don't bother. (Does anyway use
1141 ;; typed DEFSTRUCTs at all, let alone for high
1145 (dolist (dsd (dd-slots dd))
1146 (let* ((accessor-name (dsd-accessor-name dsd))
1147 (dsd-type (dsd-type dsd)))
1149 (let ((inherited (accessor-inherited-data accessor-name dd)))
1152 (setf (info :function :structure-accessor accessor-name) dd)
1153 (multiple-value-bind (reader-designator writer-designator)
1154 (slot-accessor-transforms dd dsd)
1155 (sb!xc:proclaim `(ftype (sfunction (,dtype) ,dsd-type)
1157 (setf (info :function :source-transform accessor-name)
1159 (unless (dsd-read-only dsd)
1160 (let ((setf-accessor-name `(setf ,accessor-name)))
1162 `(ftype (sfunction (,dsd-type ,dtype) ,dsd-type)
1163 ,setf-accessor-name))
1164 (setf (info :function :source-transform setf-accessor-name)
1165 writer-designator)))))
1166 ((not (= (cdr inherited) (dsd-index dsd)))
1167 (style-warn "~@<Non-overwritten accessor ~S does not access ~
1168 slot with name ~S (accessing an inherited slot ~
1171 (dsd-name dsd)))))))))
1174 ;;;; redefinition stuff
1176 ;;; Compare the slots of OLD and NEW, returning 3 lists of slot names:
1177 ;;; 1. Slots which have moved,
1178 ;;; 2. Slots whose type has changed,
1179 ;;; 3. Deleted slots.
1180 (defun compare-slots (old new)
1181 (let* ((oslots (dd-slots old))
1182 (nslots (dd-slots new))
1183 (onames (mapcar #'dsd-name oslots))
1184 (nnames (mapcar #'dsd-name nslots)))
1187 (dolist (name (intersection onames nnames))
1188 (let ((os (find name oslots :key #'dsd-name :test #'string=))
1189 (ns (find name nslots :key #'dsd-name :test #'string=)))
1190 (unless (sb!xc:subtypep (dsd-type ns) (dsd-type os))
1192 (unless (and (= (dsd-index os) (dsd-index ns))
1193 (eq (dsd-raw-type os) (dsd-raw-type ns)))
1197 (set-difference onames nnames :test #'string=)))))
1199 ;;; If we are redefining a structure with different slots than in the
1200 ;;; currently loaded version, give a warning and return true.
1201 (defun redefine-structure-warning (classoid old new)
1202 (declare (type defstruct-description old new)
1203 (type classoid classoid)
1205 (let ((name (dd-name new)))
1206 (multiple-value-bind (moved retyped deleted) (compare-slots old new)
1207 (when (or moved retyped deleted)
1209 "incompatibly redefining slots of structure class ~S~@
1210 Make sure any uses of affected accessors are recompiled:~@
1211 ~@[ These slots were moved to new positions:~% ~S~%~]~
1212 ~@[ These slots have new incompatible types:~% ~S~%~]~
1213 ~@[ These slots were deleted:~% ~S~%~]"
1214 name moved retyped deleted)
1217 ;;; This function is called when we are incompatibly redefining a
1218 ;;; structure CLASS to have the specified NEW-LAYOUT. We signal an
1219 ;;; error with some proceed options and return the layout that should
1221 (defun %redefine-defstruct (classoid old-layout new-layout)
1222 (declare (type classoid classoid)
1223 (type layout old-layout new-layout))
1224 (let ((name (classoid-proper-name classoid)))
1226 (error "~@<attempt to redefine the ~S class ~S incompatibly with the current definition~:@>"
1232 "~@<Use the new definition of ~S, invalidating ~
1233 already-loaded code and instances.~@:>"
1235 (register-layout new-layout))
1236 (recklessly-continue ()
1239 "~@<Use the new definition of ~S as if it were ~
1240 compatible, allowing old accessors to use new ~
1241 instances and allowing new accessors to use old ~
1244 ;; classic CMU CL warning: "Any old ~S instances will be in a bad way.
1245 ;; I hope you know what you're doing..."
1246 (register-layout new-layout
1248 :destruct-layout old-layout))
1250 ;; FIXME: deprecated 2002-10-16, and since it's only interactive
1251 ;; hackery instead of a supported feature, can probably be deleted
1253 :report "(deprecated synonym for RECKLESSLY-CONTINUE)"
1254 (register-layout new-layout
1256 :destruct-layout old-layout))))
1259 (declaim (inline dd-layout-length))
1260 (defun dd-layout-length (dd)
1261 (+ (dd-length dd) (dd-raw-length dd)))
1263 (declaim (ftype (sfunction (defstruct-description) index) dd-instance-length))
1264 (defun dd-instance-length (dd)
1265 ;; Make sure the object ends at a two-word boundary. Note that this does
1266 ;; not affect the amount of memory used, since the allocator would add the
1267 ;; same padding anyway. However, raw slots are indexed from the length of
1268 ;; the object as indicated in the header, so the pad word needs to be
1269 ;; included in that length to guarantee proper alignment of raw double float
1270 ;; slots, necessary for (at least) the SPARC backend.
1271 (let ((layout-length (dd-layout-length dd)))
1272 (declare (type index layout-length))
1273 (+ layout-length (mod (1+ layout-length) 2))))
1275 ;;; This is called when we are about to define a structure class. It
1276 ;;; returns a (possibly new) class object and the layout which should
1277 ;;; be used for the new definition (may be the current layout, and
1278 ;;; also might be an uninstalled forward referenced layout.) The third
1279 ;;; value is true if this is an incompatible redefinition, in which
1280 ;;; case it is the old layout.
1281 (defun ensure-structure-class (info inherits old-context new-context
1282 &key compiler-layout)
1283 (multiple-value-bind (class old-layout)
1287 (class 'structure-classoid)
1288 (constructor 'make-structure-classoid))
1289 (dd-alternate-metaclass info)
1290 (declare (ignore name))
1291 (insured-find-classoid (dd-name info)
1292 (if (eq class 'structure-classoid)
1294 (sb!xc:typep x 'structure-classoid))
1296 (sb!xc:typep x (classoid-name (find-classoid class)))))
1297 (fdefinition constructor)))
1298 (setf (classoid-direct-superclasses class)
1299 (case (dd-name info)
1302 sb!impl::string-input-stream sb!impl::string-output-stream
1303 sb!impl::fill-pointer-output-stream)
1304 (list (layout-classoid (svref inherits (1- (length inherits))))
1305 (layout-classoid (svref inherits (- (length inherits) 2)))))
1307 (list (layout-classoid
1308 (svref inherits (1- (length inherits))))))))
1309 (let ((new-layout (make-layout :classoid class
1311 :depthoid (length inherits)
1312 :length (dd-layout-length info)
1313 :n-untagged-slots (dd-raw-length info)
1315 (old-layout (or compiler-layout old-layout)))
1318 (values class new-layout nil))
1319 (;; This clause corresponds to an assertion in REDEFINE-LAYOUT-WARNING
1320 ;; of classic CMU CL. I moved it out to here because it was only
1321 ;; exercised in this code path anyway. -- WHN 19990510
1322 (not (eq (layout-classoid new-layout) (layout-classoid old-layout)))
1323 (error "shouldn't happen: weird state of OLD-LAYOUT?"))
1324 ((not *type-system-initialized*)
1325 (setf (layout-info old-layout) info)
1326 (values class old-layout nil))
1327 ((redefine-layout-warning old-context
1330 (layout-length new-layout)
1331 (layout-inherits new-layout)
1332 (layout-depthoid new-layout)
1333 (layout-n-untagged-slots new-layout))
1334 (values class new-layout old-layout))
1336 (let ((old-info (layout-info old-layout)))
1338 ((or defstruct-description)
1339 (cond ((redefine-structure-warning class old-info info)
1340 (values class new-layout old-layout))
1342 (setf (layout-info old-layout) info)
1343 (values class old-layout nil))))
1345 (setf (layout-info old-layout) info)
1346 (values class old-layout nil))
1348 (error "shouldn't happen! strange thing in LAYOUT-INFO:~% ~S"
1350 (values class new-layout old-layout)))))))))
1352 ;;; Return a list of pairs (name . index). Used for :TYPE'd
1353 ;;; constructors to find all the names that we have to splice in &
1354 ;;; where. Note that these types don't have a layout, so we can't look
1355 ;;; at LAYOUT-INHERITS.
1356 (defun find-name-indices (defstruct)
1359 (do ((info defstruct
1360 (typed-structure-info-or-lose (first (dd-include info)))))
1361 ((not (dd-include info))
1366 (dolist (info infos)
1367 (incf i (or (dd-offset info) 0))
1368 (when (dd-named info)
1369 (res (cons (dd-name info) i)))
1370 (setq i (dd-length info)))))
1374 ;;; These functions are called to actually make a constructor after we
1375 ;;; have processed the arglist. The correct variant (according to the
1376 ;;; DD-TYPE) should be called. The function is defined with the
1377 ;;; specified name and arglist. VARS and TYPES are used for argument
1378 ;;; type declarations. VALUES are the values for the slots (in order.)
1380 ;;; This is split three ways because:
1381 ;;; * LIST & VECTOR structures need "name" symbols stuck in at
1382 ;;; various weird places, whereas STRUCTURE structures have
1384 ;;; * We really want to use LIST to make list structures, instead of
1385 ;;; MAKE-LIST/(SETF ELT). (We can't in general use VECTOR in an
1386 ;;; analogous way, since VECTOR makes a SIMPLE-VECTOR and vector-typed
1387 ;;; structures can have arbitrary subtypes of VECTOR, not necessarily
1389 ;;; * STRUCTURE structures can have raw slots that must also be
1390 ;;; allocated and indirectly referenced.
1391 (defun create-vector-constructor (dd cons-name arglist ftype-arglist decls values)
1392 (let ((temp (gensym))
1393 (etype (dd-element-type dd))
1394 (len (dd-length dd)))
1396 `(defun ,cons-name ,arglist
1397 ,@(when decls `((declare ,@decls)))
1398 (let ((,temp (make-array ,len :element-type ',etype)))
1399 ,@(mapcar (lambda (x)
1400 `(setf (aref ,temp ,(cdr x)) ',(car x)))
1401 (find-name-indices dd))
1402 ,@(mapcar (lambda (dsd value)
1403 (unless (eq value '.do-not-initialize-slot.)
1404 `(setf (aref ,temp ,(dsd-index dsd)) ,value)))
1405 (dd-slots dd) values)
1407 `(sfunction ,ftype-arglist (simple-array ,etype (,len))))))
1408 (defun create-list-constructor (dd cons-name arglist ftype-arglist decls values)
1409 (let ((vals (make-list (dd-length dd) :initial-element nil)))
1410 (dolist (x (find-name-indices dd))
1411 (setf (elt vals (cdr x)) `',(car x)))
1412 (loop for dsd in (dd-slots dd) and val in values do
1413 (setf (elt vals (dsd-index dsd))
1414 (if (eq val '.do-not-initialize-slot.) 0 val)))
1416 `(defun ,cons-name ,arglist
1417 ,@(when decls `((declare ,@decls)))
1419 `(sfunction ,ftype-arglist list))))
1420 (defun create-structure-constructor (dd cons-name arglist ftype-arglist decls values)
1422 ;; The difference between the two implementations here is that on all
1423 ;; platforms we don't have the appropriate RAW-INSTANCE-INIT VOPS, which
1424 ;; must be able to deal with immediate values as well -- unlike
1425 ;; RAW-INSTANCE-SET VOPs, which never end up seeing immediate values. With
1426 ;; some additional cleverness we might manage without them and just a single
1427 ;; implementation here, though -- figure out a way to ensure that on those
1428 ;; platforms we always still get a non-immediate TN in every case...
1430 ;; Until someone does that, this means that instances with raw slots can be
1431 ;; DX allocated only on platforms with those additional VOPs.
1432 #!+raw-instance-init-vops
1433 (let* ((slot-values nil)
1435 (mapcan (lambda (dsd value)
1436 (unless (eq value '.do-not-initialize-slot.)
1437 (push value slot-values)
1438 (list (list* :slot (dsd-raw-type dsd) (dsd-index dsd)))))
1441 `(defun ,cons-name ,arglist
1442 ,@(when decls `((declare ,@decls)))
1443 (%make-structure-instance-macro ,dd ',slot-specs ,@(reverse slot-values))))
1444 #!-raw-instance-init-vops
1445 (let ((instance (gensym "INSTANCE")) slot-values slot-specs raw-slots raw-values)
1446 (mapc (lambda (dsd value)
1447 (unless (eq value '.do-not-initialize-slot.)
1448 (let ((raw-type (dsd-raw-type dsd)))
1449 (cond ((eq t raw-type)
1450 (push value slot-values)
1451 (push (list* :slot raw-type (dsd-index dsd)) slot-specs))
1453 (push value raw-values)
1454 (push dsd raw-slots))))))
1457 `(defun ,cons-name ,arglist
1458 ,@(when decls`((declare ,@decls)))
1460 `(let ((,instance (%make-structure-instance-macro ,dd ',slot-specs ,@slot-values)))
1461 ,@(mapcar (lambda (dsd value)
1462 ;; (Note that we can't in general use the
1463 ;; ordinary named slot setter function here
1464 ;; because the slot might be :READ-ONLY, so we
1465 ;; whip up new LAMBDA representations of slot
1466 ;; setters for the occasion.)
1467 `(,(slot-setter-lambda-form dd dsd) ,value ,instance))
1471 `(%make-structure-instance-macro ,dd ',slot-specs ,@slot-values))))
1472 `(sfunction ,ftype-arglist ,(dd-name dd))))
1474 ;;; Create a default (non-BOA) keyword constructor.
1475 (defun create-keyword-constructor (defstruct creator)
1476 (declare (type function creator))
1477 (collect ((arglist (list '&key))
1481 (let ((int-type (if (eq 'vector (dd-type defstruct))
1482 (dd-element-type defstruct)
1484 (dolist (slot (dd-slots defstruct))
1485 (let* ((dum (sb!xc:gensym "DUM"))
1486 (name (dsd-name slot))
1487 (keyword (keywordicate name))
1488 ;; Canonicalize the type for a prettier macro-expansion
1489 (type (type-specifier
1490 (specifier-type `(and ,int-type ,(dsd-type slot))))))
1491 (arglist `((,keyword ,dum) ,(dsd-default slot)))
1493 ;; KLUDGE: we need a separate type declaration for for
1494 ;; keyword arguments, since default values bypass the
1495 ;; checking provided by the FTYPE.
1497 (decls `(type ,type ,dum)))
1498 (ftype-args `(,keyword ,type)))))
1500 defstruct (dd-default-constructor defstruct)
1501 (arglist) `(&key ,@(ftype-args)) (decls) (vals))))
1503 ;;; Given a structure and a BOA constructor spec, call CREATOR with
1504 ;;; the appropriate args to make a constructor.
1505 (defun create-boa-constructor (defstruct boa creator)
1506 (declare (type function creator))
1507 (multiple-value-bind (req opt restp rest keyp keys allowp auxp aux)
1508 (parse-lambda-list (second boa))
1514 (let ((int-type (if (eq 'vector (dd-type defstruct))
1515 (dd-element-type defstruct)
1517 (labels ((get-slot (name)
1518 (let* ((res (find name (dd-slots defstruct)
1521 (type (type-specifier
1523 `(and ,int-type ,(if res
1526 (values type (when res (dsd-default res)))))
1527 (do-default (arg &optional keyp)
1528 (multiple-value-bind (type default) (get-slot arg)
1529 (arglist `(,arg ,default))
1532 (arg-type type (keywordicate arg) arg)
1534 (arg-type (type &optional key var)
1536 ;; KLUDGE: see comment in CREATE-KEYWORD-CONSTRUCTOR.
1538 (decls `(type ,type ,var)))
1539 (ftype-args `(,key ,type)))
1541 (ftype-args type)))))
1545 (arg-type (get-slot arg)))
1548 (arglist '&optional)
1549 (ftype-args '&optional)
1553 ;; FIXME: this shares some logic (though not
1554 ;; code) with the &key case below (and it
1555 ;; looks confusing) -- factor out the logic
1556 ;; if possible. - CSR, 2002-04-19
1559 (def (nth-value 1 (get-slot name)))
1560 (supplied-test nil supplied-test-p))
1562 (arglist `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)))
1564 (arg-type (get-slot name))
1565 (when supplied-test-p
1566 (vars supplied-test))))
1568 (do-default arg)))))
1571 (arglist '&rest rest)
1575 (decls `(type list ,rest)))
1582 (destructuring-bind (wot
1585 (supplied-test nil supplied-test-p))
1587 (multiple-value-bind (key name)
1589 (destructuring-bind (key var) wot
1591 (values (keywordicate wot) wot))
1592 (multiple-value-bind (type slot-def)
1594 (arglist `(,wot ,(if def-p def slot-def)
1595 ,@(if supplied-test-p `(,supplied-test) nil)))
1597 (arg-type type key name)
1598 (when supplied-test-p
1599 (vars supplied-test)))))
1600 (do-default key t))))
1603 (arglist '&allow-other-keys)
1604 (ftype-args '&allow-other-keys))
1609 (if (proper-list-of-length-p arg 2)
1610 (let ((var (first arg)))
1613 (decls `(type ,(get-slot var) ,var)))
1614 (skipped-vars (if (consp arg) (first arg) arg)))))))
1616 (funcall creator defstruct (first boa)
1617 (arglist) (ftype-args) (decls)
1618 (loop for slot in (dd-slots defstruct)
1619 for name = (dsd-name slot)
1620 collect (cond ((find name (skipped-vars) :test #'string=)
1621 ;; CLHS 3.4.6 Boa Lambda Lists
1622 (setf (dsd-safe-p slot) nil)
1623 '.do-not-initialize-slot.)
1624 ((or (find (dsd-name slot) (vars) :test #'string=)
1625 (let ((type (dsd-type slot)))
1628 `(the ,type ,(dsd-default slot))))))))))))
1630 ;;; Grovel the constructor options, and decide what constructors (if
1632 (defun constructor-definitions (defstruct)
1633 (let ((no-constructors nil)
1636 (creator (ecase (dd-type defstruct)
1637 (structure #'create-structure-constructor)
1638 (vector #'create-vector-constructor)
1639 (list #'create-list-constructor))))
1640 (dolist (constructor (dd-constructors defstruct))
1641 (destructuring-bind (name &optional (boa-ll nil boa-p)) constructor
1642 (declare (ignore boa-ll))
1643 (cond ((not name) (setq no-constructors t))
1644 (boa-p (push constructor boas))
1645 (t (push name defaults)))))
1647 (when no-constructors
1648 (when (or defaults boas)
1649 (error "(:CONSTRUCTOR NIL) combined with other :CONSTRUCTORs"))
1650 (return-from constructor-definitions ()))
1652 (unless (or defaults boas)
1653 (push (symbolicate "MAKE-" (dd-name defstruct)) defaults))
1657 (let ((cname (first defaults)))
1658 (setf (dd-default-constructor defstruct) cname)
1659 (multiple-value-bind (cons ftype)
1660 (create-keyword-constructor defstruct creator)
1661 (res `(declaim (ftype ,ftype ,@defaults)))
1663 (dolist (other-name (rest defaults))
1664 (res `(setf (fdefinition ',other-name) (fdefinition ',cname))))))
1667 (multiple-value-bind (cons ftype)
1668 (create-boa-constructor defstruct boa creator)
1669 (res `(declaim (ftype ,ftype ,(first boa))))
1674 ;;;; instances with ALTERNATE-METACLASS
1676 ;;;; The CMU CL support for structures with ALTERNATE-METACLASS was a
1677 ;;;; fairly general extension embedded in the main DEFSTRUCT code, and
1678 ;;;; the result was an fairly impressive mess as ALTERNATE-METACLASS
1679 ;;;; extension mixed with ANSI CL generality (e.g. :TYPE and :INCLUDE)
1680 ;;;; and CMU CL implementation hairiness (esp. raw slots). This SBCL
1681 ;;;; version is much less ambitious, noticing that ALTERNATE-METACLASS
1682 ;;;; is only used to implement CONDITION, STANDARD-INSTANCE, and
1683 ;;;; GENERIC-FUNCTION, and defining a simple specialized
1684 ;;;; separate-from-DEFSTRUCT macro to provide only enough
1685 ;;;; functionality to support those.
1687 ;;;; KLUDGE: The defining macro here is so specialized that it's ugly
1688 ;;;; in its own way. It also violates once-and-only-once by knowing
1689 ;;;; much about structures and layouts that is already known by the
1690 ;;;; main DEFSTRUCT macro. Hopefully it will go away presently
1691 ;;;; (perhaps when CL:CLASS and SB-PCL:CLASS meet) as per FIXME below.
1692 ;;;; -- WHN 2001-10-28
1694 ;;;; FIXME: There seems to be no good reason to shoehorn CONDITION,
1695 ;;;; STANDARD-INSTANCE, and GENERIC-FUNCTION into mutated structures
1696 ;;;; instead of just implementing them as primitive objects. (This
1697 ;;;; reduced-functionality macro seems pretty close to the
1698 ;;;; functionality of DEFINE-PRIMITIVE-OBJECT..)
1700 (defun make-dd-with-alternate-metaclass (&key (class-name (missing-arg))
1701 (superclass-name (missing-arg))
1702 (metaclass-name (missing-arg))
1703 (dd-type (missing-arg))
1704 metaclass-constructor
1706 (let* ((dd (make-defstruct-description class-name))
1707 (conc-name (concatenate 'string (symbol-name class-name) "-"))
1708 (dd-slots (let ((reversed-result nil)
1709 ;; The index starts at 1 for ordinary named
1710 ;; slots because slot 0 is magical, used for
1711 ;; the LAYOUT in CONDITIONs and
1712 ;; FUNCALLABLE-INSTANCEs. (This is the same
1713 ;; in ordinary structures too: see (INCF
1715 ;; PARSE-DEFSTRUCT-NAME-AND-OPTIONS).
1717 (dolist (slot-name slot-names)
1718 (push (make-defstruct-slot-description
1721 :accessor-name (symbolicate conc-name slot-name))
1724 (nreverse reversed-result))))
1726 ;; We don't support inheritance of alternate metaclass stuff,
1727 ;; and it's not a general-purpose facility, so sanity check our
1730 (aver (eq superclass-name 't)))
1731 (funcallable-structure
1732 (aver (eq superclass-name 'function)))
1733 (t (bug "Unknown DD-TYPE in ALTERNATE-METACLASS: ~S" dd-type)))
1734 (setf (dd-alternate-metaclass dd) (list superclass-name
1736 metaclass-constructor)
1737 (dd-slots dd) dd-slots
1738 (dd-length dd) (1+ (length slot-names))
1739 (dd-type dd) dd-type)
1742 ;;; make !DEFSTRUCT-WITH-ALTERNATE-METACLASS compilable by the host
1743 ;;; lisp, installing the information we need to reason about the
1744 ;;; structures (layouts and classoids).
1746 ;;; FIXME: we should share the parsing and the DD construction between
1747 ;;; this and the cross-compiler version, but my brain was too small to
1748 ;;; get that right. -- CSR, 2006-09-14
1750 (defmacro !defstruct-with-alternate-metaclass
1752 (slot-names (missing-arg))
1753 (boa-constructor (missing-arg))
1754 (superclass-name (missing-arg))
1755 (metaclass-name (missing-arg))
1756 (metaclass-constructor (missing-arg))
1757 (dd-type (missing-arg))
1759 (runtime-type-checks-p t))
1761 (declare (type (and list (not null)) slot-names))
1762 (declare (type (and symbol (not null))
1766 metaclass-constructor))
1767 (declare (type symbol predicate))
1768 (declare (type (member structure funcallable-structure) dd-type))
1769 (declare (ignore boa-constructor predicate runtime-type-checks-p))
1771 (let* ((dd (make-dd-with-alternate-metaclass
1772 :class-name class-name
1773 :slot-names slot-names
1774 :superclass-name superclass-name
1775 :metaclass-name metaclass-name
1776 :metaclass-constructor metaclass-constructor
1780 (eval-when (:compile-toplevel :load-toplevel :execute)
1781 (%compiler-set-up-layout ',dd ',(inherits-for-structure dd))))))
1783 (sb!xc:proclaim '(special *defstruct-hooks*))
1785 (sb!xc:defmacro !defstruct-with-alternate-metaclass
1787 (slot-names (missing-arg))
1788 (boa-constructor (missing-arg))
1789 (superclass-name (missing-arg))
1790 (metaclass-name (missing-arg))
1791 (metaclass-constructor (missing-arg))
1792 (dd-type (missing-arg))
1794 (runtime-type-checks-p t))
1796 (declare (type (and list (not null)) slot-names))
1797 (declare (type (and symbol (not null))
1801 metaclass-constructor))
1802 (declare (type symbol predicate))
1803 (declare (type (member structure funcallable-structure) dd-type))
1805 (let* ((dd (make-dd-with-alternate-metaclass
1806 :class-name class-name
1807 :slot-names slot-names
1808 :superclass-name superclass-name
1809 :metaclass-name metaclass-name
1810 :metaclass-constructor metaclass-constructor
1812 (dd-slots (dd-slots dd))
1813 (dd-length (1+ (length slot-names)))
1814 (object-gensym (sb!xc:gensym "OBJECT"))
1815 (new-value-gensym (sb!xc:gensym "NEW-VALUE-"))
1816 (delayed-layout-form `(%delayed-get-compiler-layout ,class-name)))
1817 (multiple-value-bind (raw-maker-form raw-reffer-operator)
1820 (values `(%make-structure-instance-macro ,dd nil)
1822 (funcallable-structure
1823 (values `(let ((,object-gensym
1824 (%make-funcallable-instance ,dd-length)))
1825 (setf (%funcallable-instance-layout ,object-gensym)
1826 ,delayed-layout-form)
1828 '%funcallable-instance-info)))
1831 (eval-when (:compile-toplevel :load-toplevel :execute)
1832 (%compiler-set-up-layout ',dd ',(inherits-for-structure dd)))
1834 ;; slot readers and writers
1835 (declaim (inline ,@(mapcar #'dsd-accessor-name dd-slots)))
1836 ,@(mapcar (lambda (dsd)
1837 `(defun ,(dsd-accessor-name dsd) (,object-gensym)
1838 ,@(when runtime-type-checks-p
1839 `((declare (type ,class-name ,object-gensym))))
1840 (,raw-reffer-operator ,object-gensym
1843 (declaim (inline ,@(mapcar (lambda (dsd)
1844 `(setf ,(dsd-accessor-name dsd)))
1846 ,@(mapcar (lambda (dsd)
1847 `(defun (setf ,(dsd-accessor-name dsd)) (,new-value-gensym
1849 ,@(when runtime-type-checks-p
1850 `((declare (type ,class-name ,object-gensym))))
1851 (setf (,raw-reffer-operator ,object-gensym
1853 ,new-value-gensym)))
1857 (defun ,boa-constructor ,slot-names
1858 (let ((,object-gensym ,raw-maker-form))
1859 ,@(mapcar (lambda (slot-name)
1860 (let ((dsd (find (symbol-name slot-name) dd-slots
1862 (symbol-name (dsd-name x)))
1864 ;; KLUDGE: bug 117 bogowarning. Neither
1865 ;; DECLAREing the type nor TRULY-THE cut
1866 ;; the mustard -- it still gives warnings.
1867 (enforce-type dsd defstruct-slot-description)
1868 `(setf (,(dsd-accessor-name dsd) ,object-gensym)
1875 ;; Just delegate to the compiler's type optimization
1876 ;; code, which knows how to generate inline type tests
1877 ;; for the whole CMU CL INSTANCE menagerie.
1878 `(defun ,predicate (,object-gensym)
1879 (typep ,object-gensym ',class-name)))
1881 (when (boundp '*defstruct-hooks*)
1882 (dolist (fun *defstruct-hooks*)
1883 (funcall fun (find-classoid ',(dd-name dd)))))))))
1885 ;;;; finalizing bootstrapping
1887 ;;; Set up DD and LAYOUT for STRUCTURE-OBJECT class itself.
1889 ;;; Ordinary structure classes effectively :INCLUDE STRUCTURE-OBJECT
1890 ;;; when they have no explicit :INCLUDEs, so (1) it needs to be set up
1891 ;;; before we can define ordinary structure classes, and (2) it's
1892 ;;; special enough (and simple enough) that we just build it by hand
1893 ;;; instead of trying to generalize the ordinary DEFSTRUCT code.
1894 (defun !set-up-structure-object-class ()
1895 (let ((dd (make-defstruct-description 'structure-object)))
1897 ;; Note: This has an ALTERNATE-METACLASS only because of blind
1898 ;; clueless imitation of the CMU CL code -- dunno if or why it's
1900 (dd-alternate-metaclass dd) '(t)
1903 (dd-type dd) 'structure)
1904 (%compiler-set-up-layout dd)))
1905 (!set-up-structure-object-class)
1907 ;;; early structure predeclarations: Set up DD and LAYOUT for ordinary
1908 ;;; (non-ALTERNATE-METACLASS) structures which are needed early.
1910 '#.(sb-cold:read-from-file
1911 "src/code/early-defstruct-args.lisp-expr"))
1912 (let* ((dd (parse-defstruct-name-and-options-and-slot-descriptions
1915 (inherits (inherits-for-structure dd)))
1916 (%compiler-defstruct dd inherits)))
1918 ;;; finding these beasts
1919 (defun find-defstruct-description (name &optional (errorp t))
1920 (let ((info (layout-info (classoid-layout (find-classoid name errorp)))))
1921 (if (defstruct-description-p info)
1924 (error "No DEFSTRUCT-DESCRIPTION for ~S." name)))))
1926 (/show0 "code/defstruct.lisp end of file")