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 ;;; Delay looking for compiler-layout until the constructor is being
30 ;;; compiled, since it doesn't exist until after the EVAL-WHEN
31 ;;; (COMPILE) stuff is compiled. (Or, in the oddball case when
32 ;;; DEFSTRUCT is executing in a non-toplevel context, the
33 ;;; compiler-layout still doesn't exist at compilation time, and we
34 ;;; delay still further.)
35 (sb!xc:defmacro %delayed-get-compiler-layout (name)
36 (let ((layout (info :type :compiler-layout name)))
38 ;; ordinary case: When the DEFSTRUCT is at top level,
39 ;; then EVAL-WHEN (COMPILE) stuff will have set up the
40 ;; layout for us to use.
41 (unless (typep (layout-info layout) 'defstruct-description)
42 (error "Class is not a structure class: ~S" name))
45 ;; KLUDGE: In the case that DEFSTRUCT is not at top-level
46 ;; the layout doesn't exist at compile time. In that case
47 ;; we laboriously look it up at run time. This code will
48 ;; run on every constructor call and will likely be quite
49 ;; slow, so if anyone cares about performance of
50 ;; non-toplevel DEFSTRUCTs, it should be rewritten to be
51 ;; cleverer. -- WHN 2002-10-23
53 "implementation limitation: ~
54 Non-toplevel DEFSTRUCT constructors are slow.")
55 (let ((layout (gensym "LAYOUT")))
56 `(let ((,layout (info :type :compiler-layout ',name)))
57 (unless (typep (layout-info ,layout) 'defstruct-description)
58 (error "Class is not a structure class: ~S" ',name))
61 ;;; Get layout right away.
62 (sb!xc:defmacro compile-time-find-layout (name)
65 ;;; re. %DELAYED-GET-COMPILER-LAYOUT and COMPILE-TIME-FIND-LAYOUT, above..
67 ;;; FIXME: Perhaps both should be defined with DEFMACRO-MUNDANELY?
68 ;;; FIXME: Do we really need both? If so, their names and implementations
69 ;;; should probably be tweaked to be more parallel.
71 ;;;; DEFSTRUCT-DESCRIPTION
73 ;;; The DEFSTRUCT-DESCRIPTION structure holds compile-time information
74 ;;; about a structure type.
75 (def!struct (defstruct-description
77 (:make-load-form-fun just-dump-it-normally)
78 #-sb-xc-host (:pure t)
79 (:constructor make-defstruct-description
81 (conc-name (symbolicate name "-"))
82 (copier-name (symbolicate "COPY-" name))
83 (predicate-name (symbolicate name "-P")))))
84 ;; name of the structure
85 (name (missing-arg) :type symbol :read-only t)
86 ;; documentation on the structure
87 (doc nil :type (or string null))
88 ;; prefix for slot names. If NIL, none.
89 (conc-name nil :type (or symbol null))
90 ;; the name of the primary standard keyword constructor, or NIL if none
91 (default-constructor nil :type (or symbol null))
92 ;; all the explicit :CONSTRUCTOR specs, with name defaulted
93 (constructors () :type list)
94 ;; name of copying function
95 (copier-name nil :type (or symbol null))
96 ;; name of type predicate
97 (predicate-name nil :type (or symbol null))
98 ;; the arguments to the :INCLUDE option, or NIL if no included
100 (include nil :type list)
101 ;; properties used to define structure-like classes with an
102 ;; arbitrary superclass and that may not have STRUCTURE-CLASS as the
103 ;; metaclass. Syntax is:
104 ;; (superclass-name metaclass-name metaclass-constructor)
105 (alternate-metaclass nil :type list)
106 ;; a list of DEFSTRUCT-SLOT-DESCRIPTION objects for all slots
107 ;; (including included ones)
108 (slots () :type list)
109 ;; a list of (NAME . INDEX) pairs for accessors of included structures
110 (inherited-accessor-alist () :type list)
111 ;; number of elements we've allocated (See also RAW-LENGTH.)
112 (length 0 :type index)
113 ;; General kind of implementation.
114 (type 'structure :type (member structure vector list
115 funcallable-structure))
117 ;; The next three slots are for :TYPE'd structures (which aren't
118 ;; classes, DD-CLASS-P = NIL)
120 ;; vector element type
122 ;; T if :NAMED was explicitly specified, NIL otherwise
123 (named nil :type boolean)
124 ;; any INITIAL-OFFSET option on this direct type
125 (offset nil :type (or index null))
127 ;; the argument to the PRINT-FUNCTION option, or NIL if a
128 ;; PRINT-FUNCTION option was given with no argument, or 0 if no
129 ;; PRINT-FUNCTION option was given
130 (print-function 0 :type (or cons symbol (member 0)))
131 ;; the argument to the PRINT-OBJECT option, or NIL if a PRINT-OBJECT
132 ;; option was given with no argument, or 0 if no PRINT-OBJECT option
134 (print-object 0 :type (or cons symbol (member 0)))
135 ;; the index of the raw data vector and the number of words in it,
136 ;; or NIL and 0 if not allocated (either because this structure
137 ;; has no raw slots, or because we're still parsing it and haven't
138 ;; run across any raw slots yet)
139 (raw-index nil :type (or index null))
140 (raw-length 0 :type index)
141 ;; the value of the :PURE option, or :UNSPECIFIED. This is only
142 ;; meaningful if DD-CLASS-P = T.
143 (pure :unspecified :type (member t nil :substructure :unspecified)))
144 (def!method print-object ((x defstruct-description) stream)
145 (print-unreadable-object (x stream :type t)
146 (prin1 (dd-name x) stream)))
148 ;;; Does DD describe a structure with a class?
149 (defun dd-class-p (dd)
151 '(structure funcallable-structure)))
153 ;;; a type name which can be used when declaring things which operate
154 ;;; on structure instances
155 (defun dd-declarable-type (dd)
157 ;; Native classes are known to the type system, and we can
158 ;; declare them as types.
160 ;; Structures layered on :TYPE LIST or :TYPE VECTOR aren't part
161 ;; of the type system, so all we can declare is the underlying
162 ;; LIST or VECTOR type.
165 (defun dd-layout-or-lose (dd)
166 (compiler-layout-or-lose (dd-name dd)))
168 ;;;; DEFSTRUCT-SLOT-DESCRIPTION
170 ;;; A DEFSTRUCT-SLOT-DESCRIPTION holds compile-time information about
171 ;;; a structure slot.
172 (def!struct (defstruct-slot-description
173 (:make-load-form-fun just-dump-it-normally)
176 #-sb-xc-host (:pure t))
177 ;; string name of slot
179 ;; its position in the implementation sequence
180 (index (missing-arg) :type fixnum)
181 ;; the name of the accessor function
183 ;; (CMU CL had extra complexity here ("..or NIL if this accessor has
184 ;; the same name as an inherited accessor (which we don't want to
185 ;; shadow)") but that behavior doesn't seem to be specified by (or
186 ;; even particularly consistent with) ANSI, so it's gone in SBCL.)
188 default ; default value expression
189 (type t) ; declared type specifier
190 ;; If this object does not describe a raw slot, this value is T.
192 ;; If this object describes a raw slot, this value is the type of the
193 ;; value that the raw slot holds. Mostly. (KLUDGE: If the raw slot has
194 ;; type (UNSIGNED-BYTE 32), the value here is UNSIGNED-BYTE, not
195 ;; (UNSIGNED-BYTE 32).)
196 (raw-type t :type (member t single-float double-float
197 #!+long-float long-float
198 complex-single-float complex-double-float
199 #!+long-float complex-long-float
201 (read-only nil :type (member t nil)))
202 (def!method print-object ((x defstruct-slot-description) stream)
203 (print-unreadable-object (x stream :type t)
204 (prin1 (dsd-name x) stream)))
206 ;;; Return the name of a defstruct slot as a symbol. We store it as a
207 ;;; string to avoid creating lots of worthless symbols at load time.
208 (defun dsd-name (dsd)
209 (intern (string (dsd-%name dsd))
210 (if (dsd-accessor-name dsd)
211 (symbol-package (dsd-accessor-name dsd))
214 ;;;; typed (non-class) structures
216 ;;; Return a type specifier we can use for testing :TYPE'd structures.
217 (defun dd-lisp-type (defstruct)
218 (ecase (dd-type defstruct)
220 (vector `(simple-array ,(dd-element-type defstruct) (*)))))
222 ;;;; shared machinery for inline and out-of-line slot accessor functions
224 (eval-when (:compile-toplevel :load-toplevel :execute)
226 ;; information about how a slot of a given DSD-RAW-TYPE is to be accessed
227 (defstruct raw-slot-data
228 ;; the raw slot type, or T for a non-raw slot
230 ;; (Raw slots are allocated in the raw slots array in a vector which
231 ;; the GC doesn't need to scavenge. Non-raw slots are in the
232 ;; ordinary place you'd expect, directly indexed off the instance
234 (raw-type (missing-arg) :type (or symbol cons) :read-only t)
235 ;; What operator is used (on the raw data vector) to access a slot
237 (accessor-name (missing-arg) :type symbol :read-only t)
238 ;; How many words are each value of this type? (This is used to
239 ;; rescale the offset into the raw data vector.)
240 (n-words (missing-arg) :type (and index (integer 1)) :read-only t))
242 (defvar *raw-slot-data-list*
244 ;; The compiler thinks that the raw data vector is a vector of
245 ;; word-sized unsigned bytes, so if the slot we want to access
246 ;; actually *is* an unsigned byte, it'll access the slot for us
247 ;; even if we don't lie to it at all, just let it use normal AREF.
248 (make-raw-slot-data :raw-type 'unsigned-byte
251 ;; In the other cases, we lie to the compiler, making it use
252 ;; some low-level AREFish access in order to pun the hapless
253 ;; bits into some other-than-unsigned-byte meaning.
255 ;; "A lie can travel halfway round the world while the truth is
256 ;; putting on its shoes." -- Mark Twain
257 (make-raw-slot-data :raw-type 'single-float
258 :accessor-name '%raw-ref-single
260 (make-raw-slot-data :raw-type 'double-float
261 :accessor-name '%raw-ref-double
263 (make-raw-slot-data :raw-type 'complex-single-float
264 :accessor-name '%raw-ref-complex-single
266 (make-raw-slot-data :raw-type 'complex-double-float
267 :accessor-name '%raw-ref-complex-double
270 (make-raw-slot-data :raw-type long-float
271 :accessor-name '%raw-ref-long
272 :n-words #!+x86 3 #!+sparc 4)
274 (make-raw-slot-data :raw-type complex-long-float
275 :accessor-name '%raw-ref-complex-long
276 :n-words #!+x86 6 #!+sparc 8))))
278 ;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its
279 ;;;; close personal friend SB!XC:DEFSTRUCT)
281 ;;; Return a list of forms to install PRINT and MAKE-LOAD-FORM funs,
282 ;;; mentioning them in the expansion so that they can be compiled.
283 (defun class-method-definitions (defstruct)
284 (let ((name (dd-name defstruct)))
286 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant
287 ;; class names which creates fast but non-cold-loadable,
288 ;; non-compact code. In this context, we'd rather have
289 ;; compact, cold-loadable code. -- WHN 19990928
290 (declare (notinline sb!xc:find-class))
291 ,@(let ((pf (dd-print-function defstruct))
292 (po (dd-print-object defstruct))
295 ;; Giving empty :PRINT-OBJECT or :PRINT-FUNCTION options
296 ;; leaves PO or PF equal to NIL. The user-level effect is
297 ;; to generate a PRINT-OBJECT method specialized for the type,
298 ;; implementing the default #S structure-printing behavior.
299 (when (or (eq pf nil) (eq po nil))
300 (setf pf '(default-structure-print)
302 (flet (;; Given an arg from a :PRINT-OBJECT or :PRINT-FUNCTION
303 ;; option, return the value to pass as an arg to FUNCTION.
305 (destructuring-bind (fun-name) oarg
307 (cond ((not (eql pf 0))
308 `((def!method print-object ((,x ,name) ,s)
309 (funcall #',(farg pf)
312 *current-level-in-print*))))
314 `((def!method print-object ((,x ,name) ,s)
315 (funcall #',(farg po) ,x ,s))))
317 ,@(let ((pure (dd-pure defstruct)))
319 `((setf (layout-pure (class-layout
320 (sb!xc:find-class ',name)))
322 ((eq pure :substructure)
323 `((setf (layout-pure (class-layout
324 (sb!xc:find-class ',name)))
326 ,@(let ((def-con (dd-default-constructor defstruct)))
327 (when (and def-con (not (dd-alternate-metaclass defstruct)))
328 `((setf (structure-class-constructor (sb!xc:find-class ',name))
331 ;;; shared logic for CL:DEFSTRUCT and SB!XC:DEFSTRUCT
332 (defmacro !expander-for-defstruct (name-and-options
334 expanding-into-code-for-xc-host-p)
335 `(let ((name-and-options ,name-and-options)
336 (slot-descriptions ,slot-descriptions)
337 (expanding-into-code-for-xc-host-p
338 ,expanding-into-code-for-xc-host-p))
339 (let* ((dd (parse-defstruct-name-and-options-and-slot-descriptions
344 (let ((inherits (inherits-for-structure dd)))
346 ;; Note we intentionally call %DEFSTRUCT first, and
347 ;; especially before %COMPILER-DEFSTRUCT. %DEFSTRUCT
348 ;; has the tests (and resulting CERROR) for collisions
349 ;; with LAYOUTs which already exist in the runtime. If
350 ;; there are any collisions, we want the user's
351 ;; response to CERROR to control what happens.
352 ;; Especially, if the user responds to the collision
353 ;; with ABORT, we don't want %COMPILER-DEFSTRUCT to
354 ;; modify the definition of the class.
355 (%defstruct ',dd ',inherits)
356 (eval-when (:compile-toplevel :load-toplevel :execute)
357 (%compiler-defstruct ',dd ',inherits))
358 ,@(unless expanding-into-code-for-xc-host-p
359 (append ;; FIXME: We've inherited from CMU CL nonparallel
360 ;; code for creating copiers for typed and untyped
361 ;; structures. This should be fixed.
362 ;(copier-definition dd)
363 (constructor-definitions dd)
364 (class-method-definitions dd)))
367 (eval-when (:compile-toplevel :load-toplevel :execute)
368 (setf (info :typed-structure :info ',name) ',dd))
369 ,@(unless expanding-into-code-for-xc-host-p
370 (append (typed-accessor-definitions dd)
371 (typed-predicate-definitions dd)
372 (typed-copier-definitions dd)
373 (constructor-definitions dd)))
376 (sb!xc:defmacro defstruct (name-and-options &rest slot-descriptions)
378 "DEFSTRUCT {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)}
379 Define the structure type Name. Instances are created by MAKE-<name>,
380 which takes &KEY arguments allowing initial slot values to the specified.
381 A SETF'able function <name>-<slot> is defined for each slot to read and
382 write slot values. <name>-p is a type predicate.
384 Popular DEFSTRUCT options (see manual for others):
388 Specify the name for the constructor or predicate.
390 (:CONSTRUCTOR Name Lambda-List)
391 Specify the name and arguments for a BOA constructor
392 (which is more efficient when keyword syntax isn't necessary.)
394 (:INCLUDE Supertype Slot-Spec*)
395 Make this type a subtype of the structure type Supertype. The optional
396 Slot-Specs override inherited slot options.
401 Asserts that the value of this slot is always of the specified type.
404 If true, no setter function is defined for this slot."
405 (!expander-for-defstruct name-and-options slot-descriptions nil))
407 (defmacro sb!xc:defstruct (name-and-options &rest slot-descriptions)
409 "Cause information about a target structure to be built into the
411 (!expander-for-defstruct name-and-options slot-descriptions t))
413 ;;;; functions to generate code for various parts of DEFSTRUCT definitions
415 ;;; First, a helper to determine whether a name names an inherited
417 (defun accessor-inherited-data (name defstruct)
418 (assoc name (dd-inherited-accessor-alist defstruct) :test #'eq))
420 ;;; Return a list of forms which create a predicate function for a
422 (defun typed-predicate-definitions (defstruct)
423 (let ((name (dd-name defstruct))
424 (predicate-name (dd-predicate-name defstruct))
426 (when (and predicate-name (dd-named defstruct))
427 (let ((ltype (dd-lisp-type defstruct)))
428 `((defun ,predicate-name (,argname)
429 (and (typep ,argname ',ltype)
430 (eq (elt (the ,ltype ,argname)
431 ,(cdr (car (last (find-name-indices defstruct)))))
434 ;;; Return a list of forms to create a copier function of a typed DEFSTRUCT.
435 (defun typed-copier-definitions (defstruct)
436 (when (dd-copier-name defstruct)
437 `((setf (fdefinition ',(dd-copier-name defstruct)) #'copy-seq)
438 (declaim (ftype function ,(dd-copier-name defstruct))))))
440 ;;; Return a list of function definitions for accessing and setting
441 ;;; the slots of a typed DEFSTRUCT. The functions are proclaimed to be
442 ;;; inline, and the types of their arguments and results are declared
443 ;;; as well. We count on the compiler to do clever things with ELT.
444 (defun typed-accessor-definitions (defstruct)
446 (let ((ltype (dd-lisp-type defstruct)))
447 (dolist (slot (dd-slots defstruct))
448 (let ((name (dsd-accessor-name slot))
449 (index (dsd-index slot))
450 (slot-type `(and ,(dsd-type slot)
451 ,(dd-element-type defstruct))))
452 (let ((inherited (accessor-inherited-data name defstruct)))
455 (stuff `(proclaim '(inline ,name (setf ,name))))
456 ;; FIXME: The arguments in the next two DEFUNs should
457 ;; be gensyms. (Otherwise e.g. if NEW-VALUE happened to
458 ;; be the name of a special variable, things could get
460 (stuff `(defun ,name (structure)
461 (declare (type ,ltype structure))
462 (the ,slot-type (elt structure ,index))))
463 (unless (dsd-read-only slot)
465 `(defun (setf ,name) (new-value structure)
466 (declare (type ,ltype structure) (type ,slot-type new-value))
467 (setf (elt structure ,index) new-value)))))
468 ((not (= (cdr inherited) index))
469 (style-warn "~@<Non-overwritten accessor ~S does not access ~
470 slot with name ~S (accessing an inherited slot ~
471 instead).~:@>" name (dsd-%name slot))))))))
476 (defun require-no-print-options-so-far (defstruct)
477 (unless (and (eql (dd-print-function defstruct) 0)
478 (eql (dd-print-object defstruct) 0))
479 (error "No more than one of the following options may be specified:
480 :PRINT-FUNCTION, :PRINT-OBJECT, :TYPE")))
482 ;;; Parse a single DEFSTRUCT option and store the results in DD.
483 (defun parse-1-dd-option (option dd)
484 (let ((args (rest option))
488 (destructuring-bind (&optional conc-name) args
489 (setf (dd-conc-name dd)
490 (if (symbolp conc-name)
492 (make-symbol (string conc-name))))))
494 (destructuring-bind (&optional (cname (symbolicate "MAKE-" name))
497 (push (cons cname stuff) (dd-constructors dd))))
499 (destructuring-bind (&optional (copier (symbolicate "COPY-" name)))
501 (setf (dd-copier-name dd) copier)))
503 (destructuring-bind (&optional (predicate-name (symbolicate name "-P")))
505 (setf (dd-predicate-name dd) predicate-name)))
507 (when (dd-include dd)
508 (error "more than one :INCLUDE option"))
509 (setf (dd-include dd) args))
511 (require-no-print-options-so-far dd)
512 (setf (dd-print-function dd)
513 (the (or symbol cons) args)))
515 (require-no-print-options-so-far dd)
516 (setf (dd-print-object dd)
517 (the (or symbol cons) args)))
519 (destructuring-bind (type) args
520 (cond ((member type '(list vector))
521 (setf (dd-element-type dd) t)
522 (setf (dd-type dd) type))
523 ((and (consp type) (eq (first type) 'vector))
524 (destructuring-bind (vector vtype) type
525 (declare (ignore vector))
526 (setf (dd-element-type dd) vtype)
527 (setf (dd-type dd) 'vector)))
529 (error "~S is a bad :TYPE for DEFSTRUCT." type)))))
531 (error "The DEFSTRUCT option :NAMED takes no arguments."))
533 (destructuring-bind (offset) args
534 (setf (dd-offset dd) offset)))
536 (destructuring-bind (fun) args
537 (setf (dd-pure dd) fun)))
538 (t (error "unknown DEFSTRUCT option:~% ~S" option)))))
540 ;;; Given name and options, return a DD holding that info.
541 (defun parse-defstruct-name-and-options (name-and-options)
542 (destructuring-bind (name &rest options) name-and-options
543 (aver name) ; A null name doesn't seem to make sense here.
544 (let ((dd (make-defstruct-description name)))
545 (dolist (option options)
546 (cond ((eq option :named)
547 (setf (dd-named dd) t))
549 (parse-1-dd-option option dd))
550 ((member option '(:conc-name :constructor :copier :predicate))
551 (parse-1-dd-option (list option) dd))
553 (error "unrecognized DEFSTRUCT option: ~S" option))))
558 (error ":OFFSET can't be specified unless :TYPE is specified."))
559 (unless (dd-include dd)
560 ;; FIXME: It'd be cleaner to treat no-:INCLUDE as defaulting
561 ;; to :INCLUDE STRUCTURE-OBJECT, and then let the general-case
562 ;; (INCF (DD-LENGTH DD) (DD-LENGTH included-DD)) logic take
563 ;; care of this. (Except that the :TYPE VECTOR and :TYPE
564 ;; LIST cases, with their :NAMED and un-:NAMED flavors,
565 ;; make that messy, alas.)
566 (incf (dd-length dd))))
568 (require-no-print-options-so-far dd)
570 (incf (dd-length dd)))
571 (let ((offset (dd-offset dd)))
572 (when offset (incf (dd-length dd) offset)))))
574 (when (dd-include dd)
575 (frob-dd-inclusion-stuff dd))
579 ;;; Given name and options and slot descriptions (and possibly doc
580 ;;; string at the head of slot descriptions) return a DD holding that
582 (defun parse-defstruct-name-and-options-and-slot-descriptions
583 (name-and-options slot-descriptions)
584 (let ((result (parse-defstruct-name-and-options (if (atom name-and-options)
585 (list name-and-options)
587 (when (stringp (car slot-descriptions))
588 (setf (dd-doc result) (pop slot-descriptions)))
589 (dolist (slot-description slot-descriptions)
590 (allocate-1-slot result (parse-1-dsd result slot-description)))
593 ;;;; stuff to parse slot descriptions
595 ;;; Parse a slot description for DEFSTRUCT, add it to the description
596 ;;; and return it. If supplied, SLOT is a pre-initialized DSD
597 ;;; that we modify to get the new slot. This is supplied when handling
599 (defun parse-1-dsd (defstruct spec &optional
600 (slot (make-defstruct-slot-description :%name ""
603 (multiple-value-bind (name default default-p type type-p read-only ro-p)
608 &optional (default nil default-p)
609 &key (type nil type-p) (read-only nil ro-p))
613 (uncross type) type-p
616 (when (keywordp spec)
617 (style-warn "Keyword slot name indicates probable syntax ~
618 error in DEFSTRUCT: ~S."
622 (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)
623 (error 'simple-program-error
624 :format-control "duplicate slot name ~S"
625 :format-arguments (list name)))
626 (setf (dsd-%name slot) (string name))
627 (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list slot)))
629 (let ((accessor-name (symbolicate (or (dd-conc-name defstruct) "") name))
630 (predicate-name (dd-predicate-name defstruct)))
631 (setf (dsd-accessor-name slot) accessor-name)
632 (when (eql accessor-name predicate-name)
633 ;; Some adventurous soul has named a slot so that its accessor
634 ;; collides with the structure type predicate. ANSI doesn't
635 ;; specify what to do in this case. As of 2001-09-04, Martin
636 ;; Atzmueller reports that CLISP and Lispworks both give
637 ;; priority to the slot accessor, so that the predicate is
638 ;; overwritten. We might as well do the same (as well as
639 ;; signalling a warning).
641 "~@<The structure accessor name ~S is the same as the name of the ~
642 structure type predicate. ANSI doesn't specify what to do in ~
643 this case. We'll overwrite the type predicate with the slot ~
644 accessor, but you can't rely on this behavior, so it'd be wise to ~
645 remove the ambiguity in your code.~@:>"
647 (setf (dd-predicate-name defstruct) nil))
649 (when (and (fboundp accessor-name)
650 (not (accessor-inherited-data accessor-name defstruct)))
651 (style-warn "redefining ~S in DEFSTRUCT" accessor-name)))
654 (setf (dsd-default slot) default))
656 (setf (dsd-type slot)
657 (if (eq (dsd-type slot) t)
659 `(and ,(dsd-type slot) ,type))))
662 (setf (dsd-read-only slot) t)
663 (when (dsd-read-only slot)
664 (error "Slot ~S is :READ-ONLY in parent and must be :READ-ONLY in subtype ~S."
669 ;;; When a value of type TYPE is stored in a structure, should it be
670 ;;; stored in a raw slot? Return (VALUES RAW? RAW-TYPE WORDS), where
671 ;;; RAW? is true if TYPE should be stored in a raw slot.
672 ;;; RAW-TYPE is the raw slot type, or NIL if no raw slot.
673 ;;; WORDS is the number of words in the raw slot, or NIL if no raw slot.
675 ;;; FIXME: This should use the data in *RAW-SLOT-DATA-LIST*.
676 (defun structure-raw-slot-type-and-size (type)
678 (;; FIXME: For now we suppress raw slots, since there are various
679 ;; issues about the way that the cross-compiler handles them.
680 (not (boundp '*dummy-placeholder-to-stop-compiler-warnings*))
681 (values nil nil nil))
682 ((and (sb!xc:subtypep type '(unsigned-byte 32))
683 (multiple-value-bind (fixnum? fixnum-certain?)
684 (sb!xc:subtypep type 'fixnum)
685 ;; (The extra test for FIXNUM-CERTAIN? here is
686 ;; intended for bootstrapping the system. In
687 ;; particular, in sbcl-0.6.2, we set up LAYOUT before
688 ;; FIXNUM is defined, and so could bogusly end up
689 ;; putting INDEX-typed values into raw slots if we
690 ;; didn't test FIXNUM-CERTAIN?.)
691 (and (not fixnum?) fixnum-certain?)))
692 (values t 'unsigned-byte 1))
693 ((sb!xc:subtypep type 'single-float)
694 (values t 'single-float 1))
695 ((sb!xc:subtypep type 'double-float)
696 (values t 'double-float 2))
698 ((sb!xc:subtypep type 'long-float)
699 (values t 'long-float #!+x86 3 #!+sparc 4))
700 ((sb!xc:subtypep type '(complex single-float))
701 (values t 'complex-single-float 2))
702 ((sb!xc:subtypep type '(complex double-float))
703 (values t 'complex-double-float 4))
705 ((sb!xc:subtypep type '(complex long-float))
706 (values t 'complex-long-float #!+x86 6 #!+sparc 8))
708 (values nil nil nil))))
710 ;;; Allocate storage for a DSD in DD. This is where we decide whether
711 ;;; a slot is raw or not. If raw, and we haven't allocated a raw-index
712 ;;; yet for the raw data vector, then do it. Raw objects are aligned
713 ;;; on the unit of their size.
714 (defun allocate-1-slot (dd dsd)
715 (multiple-value-bind (raw? raw-type words)
716 (if (eq (dd-type dd) 'structure)
717 (structure-raw-slot-type-and-size (dsd-type dsd))
718 (values nil nil nil))
720 (setf (dsd-index dsd) (dd-length dd))
721 (incf (dd-length dd)))
723 (unless (dd-raw-index dd)
724 (setf (dd-raw-index dd) (dd-length dd))
725 (incf (dd-length dd)))
726 (let ((off (rem (dd-raw-length dd) words)))
728 (incf (dd-raw-length dd) (- words off))))
729 (setf (dsd-raw-type dsd) raw-type)
730 (setf (dsd-index dsd) (dd-raw-length dd))
731 (incf (dd-raw-length dd) words))))
734 (defun typed-structure-info-or-lose (name)
735 (or (info :typed-structure :info name)
736 (error ":TYPE'd DEFSTRUCT ~S not found for inclusion." name)))
738 ;;; Process any included slots pretty much like they were specified.
739 ;;; Also inherit various other attributes.
740 (defun frob-dd-inclusion-stuff (dd)
741 (destructuring-bind (included-name &rest modified-slots) (dd-include dd)
742 (let* ((type (dd-type dd))
745 (layout-info (compiler-layout-or-lose included-name))
746 (typed-structure-info-or-lose included-name))))
748 ;; checks on legality
749 (unless (and (eq type (dd-type included-structure))
750 (type= (specifier-type (dd-element-type included-structure))
751 (specifier-type (dd-element-type dd))))
752 (error ":TYPE option mismatch between structures ~S and ~S"
753 (dd-name dd) included-name))
754 (let ((included-class (sb!xc:find-class included-name nil)))
756 ;; It's not particularly well-defined to :INCLUDE any of the
757 ;; CMU CL INSTANCE weirdosities like CONDITION or
758 ;; GENERIC-FUNCTION, and it's certainly not ANSI-compliant.
759 (let* ((included-layout (class-layout included-class))
760 (included-dd (layout-info included-layout)))
761 (when (and (dd-alternate-metaclass included-dd)
762 ;; As of sbcl-0.pre7.73, anyway, STRUCTURE-OBJECT
763 ;; is represented with an ALTERNATE-METACLASS. But
764 ;; it's specifically OK to :INCLUDE (and PCL does)
765 ;; so in this one case, it's OK to include
766 ;; something with :ALTERNATE-METACLASS after all.
767 (not (eql included-name 'structure-object)))
768 (error "can't :INCLUDE class ~S (has alternate metaclass)"
771 (incf (dd-length dd) (dd-length included-structure))
772 (when (dd-class-p dd)
773 (let ((mc (rest (dd-alternate-metaclass included-structure))))
774 (when (and mc (not (dd-alternate-metaclass dd)))
775 (setf (dd-alternate-metaclass dd)
776 (cons included-name mc))))
777 (when (eq (dd-pure dd) :unspecified)
778 (setf (dd-pure dd) (dd-pure included-structure)))
779 (setf (dd-raw-index dd) (dd-raw-index included-structure))
780 (setf (dd-raw-length dd) (dd-raw-length included-structure)))
782 (setf (dd-inherited-accessor-alist dd)
783 (dd-inherited-accessor-alist included-structure))
784 (dolist (included-slot (dd-slots included-structure))
785 (let* ((included-name (dsd-name included-slot))
786 (modified (or (find included-name modified-slots
787 :key (lambda (x) (if (atom x) x (car x)))
790 ;; We stash away an alist of accessors to parents' slots
791 ;; that have already been created to avoid conflicts later
792 ;; so that structures with :INCLUDE and :CONC-NAME (and
793 ;; other edge cases) can work as specified.
794 (when (dsd-accessor-name included-slot)
795 ;; the "oldest" (i.e. highest up the tree of inheritance)
796 ;; will prevail, so don't push new ones on if they
798 (pushnew (cons (dsd-accessor-name included-slot)
799 (dsd-index included-slot))
800 (dd-inherited-accessor-alist dd)
801 :test #'eq :key #'car))
804 (copy-structure included-slot)))))))
806 ;;;; various helper functions for setting up DEFSTRUCTs
808 ;;; This function is called at macroexpand time to compute the INHERITS
809 ;;; vector for a structure type definition.
810 (defun inherits-for-structure (info)
811 (declare (type defstruct-description info))
812 (let* ((include (dd-include info))
813 (superclass-opt (dd-alternate-metaclass info))
816 (compiler-layout-or-lose (first include))
817 (class-layout (sb!xc:find-class
818 (or (first superclass-opt)
819 'structure-object))))))
820 (if (eq (dd-name info) 'ansi-stream)
821 ;; a hack to add the CL:STREAM class as a mixin for ANSI-STREAMs
822 (concatenate 'simple-vector
823 (layout-inherits super)
825 (class-layout (sb!xc:find-class 'stream))))
826 (concatenate 'simple-vector
827 (layout-inherits super)
830 ;;; Do miscellaneous (LOAD EVAL) time actions for the structure
831 ;;; described by DD. Create the class and LAYOUT, checking for
832 ;;; incompatible redefinition. Define those functions which are
833 ;;; sufficiently stereotyped that we can implement them as standard
835 (defun %defstruct (dd inherits)
836 (declare (type defstruct-description dd))
838 ;; We set up LAYOUTs even in the cross-compilation host.
839 (multiple-value-bind (class layout old-layout)
840 (ensure-structure-class dd inherits "current" "new")
841 (cond ((not old-layout)
842 (unless (eq (class-layout class) layout)
843 (register-layout layout)))
845 (let ((old-dd (layout-info old-layout)))
846 (when (defstruct-description-p old-dd)
847 (dolist (slot (dd-slots old-dd))
848 (fmakunbound (dsd-accessor-name slot))
849 (unless (dsd-read-only slot)
850 (fmakunbound `(setf ,(dsd-accessor-name slot)))))))
851 (%redefine-defstruct class old-layout layout)
852 (setq layout (class-layout class))))
853 (setf (sb!xc:find-class (dd-name dd)) class)
855 ;; Various other operations only make sense on the target SBCL.
857 (%target-defstruct dd layout))
861 ;;; Return a form describing the writable place used for this slot
862 ;;; in the instance named INSTANCE-NAME.
863 (defun %accessor-place-form (dd dsd instance-name)
864 (let (;; the operator that we'll use to access a typed slot or, in
865 ;; the case of a raw slot, to read the vector of raw slots
866 (ref (ecase (dd-type dd)
867 (structure '%instance-ref)
868 (list 'nth-but-with-sane-arg-order)
870 (raw-type (dsd-raw-type dsd)))
871 (if (eq raw-type t) ; if not raw slot
872 `(,ref ,instance-name ,(dsd-index dsd))
873 (let* ((raw-slot-data (find raw-type *raw-slot-data-list*
874 :key #'raw-slot-data-raw-type
876 (raw-slot-accessor (raw-slot-data-accessor-name raw-slot-data))
877 (raw-n-words (raw-slot-data-n-words raw-slot-data)))
878 (multiple-value-bind (scaled-dsd-index misalignment)
879 (floor (dsd-index dsd) raw-n-words)
880 (aver (zerop misalignment))
881 `(,raw-slot-accessor (,ref ,instance-name ,(dd-raw-index dd))
882 ,scaled-dsd-index))))))
884 ;;; Return inline expansion designators (i.e. values suitable for
885 ;;; (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR ..)) for the reader
886 ;;; and writer functions of the slot described by DSD.
887 (defun slot-accessor-inline-expansion-designators (dd dsd)
888 (let ((instance-type-decl `(declare (type ,(dd-name dd) instance)))
889 (accessor-place-form (%accessor-place-form dd dsd 'instance))
890 (dsd-type (dsd-type dsd)))
894 (truly-the ,dsd-type ,accessor-place-form)))
896 `(lambda (new-value instance)
897 (declare (type ,dsd-type new-value))
899 (setf ,accessor-place-form new-value))))))
901 ;;; Return a LAMBDA form which can be used to set a slot.
902 (defun slot-setter-lambda-form (dd dsd)
903 (funcall (nth-value 1
904 (slot-accessor-inline-expansion-designators dd dsd))))
906 ;;; core compile-time setup of any class with a LAYOUT, used even by
907 ;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities
908 (defun %compiler-set-up-layout (dd
910 ;; Several special cases (STRUCTURE-OBJECT
911 ;; itself, and structures with alternate
912 ;; metaclasses) call this function directly,
913 ;; and they're all at the base of the
914 ;; instance class structure, so this is
916 (inherits (vector (find-layout t)
917 (find-layout 'instance))))
919 (multiple-value-bind (class layout old-layout)
920 (multiple-value-bind (clayout clayout-p)
921 (info :type :compiler-layout (dd-name dd))
922 (ensure-structure-class dd
924 (if clayout-p "previously compiled" "current")
926 :compiler-layout clayout))
928 (undefine-structure (layout-class old-layout))
929 (when (and (class-subclasses class)
930 (not (eq layout old-layout)))
932 (dohash (class layout (class-subclasses class))
933 (declare (ignore layout))
934 (undefine-structure class)
935 (subs (class-proper-name class)))
937 (warn "removing old subclasses of ~S:~% ~S"
938 (sb!xc:class-name class)
941 (unless (eq (class-layout class) layout)
942 (register-layout layout :invalidate nil))
943 (setf (sb!xc:find-class (dd-name dd)) class)))
945 ;; At this point the class should be set up in the INFO database.
946 ;; But the logic that enforces this is a little tangled and
947 ;; scattered, so it's not obvious, so let's check.
948 (aver (sb!xc:find-class (dd-name dd) nil))
950 (setf (info :type :compiler-layout (dd-name dd)) layout))
954 ;;; Do (COMPILE LOAD EVAL)-time actions for the normal (not
955 ;;; ALTERNATE-LAYOUT) DEFSTRUCT described by DD.
956 (defun %compiler-defstruct (dd inherits)
957 (declare (type defstruct-description dd))
959 (%compiler-set-up-layout dd inherits)
961 (let* ((dtype (dd-declarable-type dd)))
963 (let ((copier-name (dd-copier-name dd)))
965 (sb!xc:proclaim `(ftype (function (,dtype) ,dtype) ,copier-name))))
967 (let ((predicate-name (dd-predicate-name dd)))
969 (sb!xc:proclaim `(ftype (function (t) t) ,predicate-name))
970 ;; Provide inline expansion (or not).
972 ((structure funcallable-structure)
973 ;; Let the predicate be inlined.
974 (setf (info :function :inline-expansion-designator predicate-name)
977 ;; This dead simple definition works because the
978 ;; type system knows how to generate inline type
979 ;; tests for instances.
980 (typep x ',(dd-name dd))))
981 (info :function :inlinep predicate-name)
984 ;; Just punt. We could provide inline expansions for :TYPE
985 ;; LIST and :TYPE VECTOR predicates too, but it'd be a
986 ;; little messier and we don't bother. (Does anyway use
987 ;; typed DEFSTRUCTs at all, let alone for high
991 (dolist (dsd (dd-slots dd))
992 (let* ((accessor-name (dsd-accessor-name dsd))
993 (dsd-type (dsd-type dsd)))
995 (let ((inherited (accessor-inherited-data accessor-name dd)))
998 (multiple-value-bind (reader-designator writer-designator)
999 (slot-accessor-inline-expansion-designators dd dsd)
1000 (sb!xc:proclaim `(ftype (function (,dtype) ,dsd-type)
1002 (setf (info :function :inline-expansion-designator
1005 (info :function :inlinep accessor-name)
1007 (unless (dsd-read-only dsd)
1008 (let ((setf-accessor-name `(setf ,accessor-name)))
1010 `(ftype (function (,dsd-type ,dtype) ,dsd-type)
1011 ,setf-accessor-name))
1012 (setf (info :function
1013 :inline-expansion-designator
1016 (info :function :inlinep setf-accessor-name)
1018 ((not (= (cdr inherited) (dsd-index dsd)))
1019 (style-warn "~@<Non-overwritten accessor ~S does not access ~
1020 slot with name ~S (accessing an inherited slot ~
1023 (dsd-%name dsd)))))))))
1026 ;;;; redefinition stuff
1028 ;;; Compare the slots of OLD and NEW, returning 3 lists of slot names:
1029 ;;; 1. Slots which have moved,
1030 ;;; 2. Slots whose type has changed,
1031 ;;; 3. Deleted slots.
1032 (defun compare-slots (old new)
1033 (let* ((oslots (dd-slots old))
1034 (nslots (dd-slots new))
1035 (onames (mapcar #'dsd-name oslots))
1036 (nnames (mapcar #'dsd-name nslots)))
1039 (dolist (name (intersection onames nnames))
1040 (let ((os (find name oslots :key #'dsd-name))
1041 (ns (find name nslots :key #'dsd-name)))
1042 (unless (subtypep (dsd-type ns) (dsd-type os))
1044 (unless (and (= (dsd-index os) (dsd-index ns))
1045 (eq (dsd-raw-type os) (dsd-raw-type ns)))
1049 (set-difference onames nnames)))))
1051 ;;; If we are redefining a structure with different slots than in the
1052 ;;; currently loaded version, give a warning and return true.
1053 (defun redefine-structure-warning (class old new)
1054 (declare (type defstruct-description old new)
1055 (type sb!xc:class class)
1057 (let ((name (dd-name new)))
1058 (multiple-value-bind (moved retyped deleted) (compare-slots old new)
1059 (when (or moved retyped deleted)
1061 "incompatibly redefining slots of structure class ~S~@
1062 Make sure any uses of affected accessors are recompiled:~@
1063 ~@[ These slots were moved to new positions:~% ~S~%~]~
1064 ~@[ These slots have new incompatible types:~% ~S~%~]~
1065 ~@[ These slots were deleted:~% ~S~%~]"
1066 name moved retyped deleted)
1069 ;;; This function is called when we are incompatibly redefining a
1070 ;;; structure CLASS to have the specified NEW-LAYOUT. We signal an
1071 ;;; error with some proceed options and return the layout that should
1073 (defun %redefine-defstruct (class old-layout new-layout)
1074 (declare (type sb!xc:class class) (type layout old-layout new-layout))
1075 (let ((name (class-proper-name class)))
1077 (error "~@<attempt to redefine the ~S class ~S incompatibly with the current definition~:@>"
1083 "~@<Use the new definition of ~S, invalidating ~
1084 already-loaded code and instances.~@:>"
1086 (register-layout new-layout))
1087 (recklessly-continue ()
1090 "~@<Use the new definition of ~S as if it were ~
1091 compatible, allowing old accessors to use new ~
1092 instances and allowing new accessors to use old ~
1095 ;; classic CMU CL warning: "Any old ~S instances will be in a bad way.
1096 ;; I hope you know what you're doing..."
1097 (register-layout new-layout
1099 :destruct-layout old-layout))
1101 ;; FIXME: deprecated 2002-10-16, and since it's only interactive
1102 ;; hackery instead of a supported feature, can probably be deleted
1104 :report "(deprecated synonym for RECKLESSLY-CONTINUE)"
1105 (register-layout new-layout
1107 :destruct-layout old-layout))))
1110 ;;; This is called when we are about to define a structure class. It
1111 ;;; returns a (possibly new) class object and the layout which should
1112 ;;; be used for the new definition (may be the current layout, and
1113 ;;; also might be an uninstalled forward referenced layout.) The third
1114 ;;; value is true if this is an incompatible redefinition, in which
1115 ;;; case it is the old layout.
1116 (defun ensure-structure-class (info inherits old-context new-context
1117 &key compiler-layout)
1118 (multiple-value-bind (class old-layout)
1122 (class 'sb!xc:structure-class)
1123 (constructor 'make-structure-class))
1124 (dd-alternate-metaclass info)
1125 (declare (ignore name))
1126 (insured-find-class (dd-name info)
1127 (if (eq class 'sb!xc:structure-class)
1129 (typep x 'sb!xc:structure-class))
1131 (sb!xc:typep x (sb!xc:find-class class))))
1132 (fdefinition constructor)))
1133 (setf (class-direct-superclasses class)
1134 (if (eq (dd-name info) 'ansi-stream)
1135 ;; a hack to add CL:STREAM as a superclass mixin to ANSI-STREAMs
1136 (list (layout-class (svref inherits (1- (length inherits))))
1137 (layout-class (svref inherits (- (length inherits) 2))))
1138 (list (layout-class (svref inherits (1- (length inherits)))))))
1139 (let ((new-layout (make-layout :class class
1141 :depthoid (length inherits)
1142 :length (dd-length info)
1144 (old-layout (or compiler-layout old-layout)))
1147 (values class new-layout nil))
1148 (;; This clause corresponds to an assertion in REDEFINE-LAYOUT-WARNING
1149 ;; of classic CMU CL. I moved it out to here because it was only
1150 ;; exercised in this code path anyway. -- WHN 19990510
1151 (not (eq (layout-class new-layout) (layout-class old-layout)))
1152 (error "shouldn't happen: weird state of OLD-LAYOUT?"))
1153 ((not *type-system-initialized*)
1154 (setf (layout-info old-layout) info)
1155 (values class old-layout nil))
1156 ((redefine-layout-warning old-context
1159 (layout-length new-layout)
1160 (layout-inherits new-layout)
1161 (layout-depthoid new-layout))
1162 (values class new-layout old-layout))
1164 (let ((old-info (layout-info old-layout)))
1166 ((or defstruct-description)
1167 (cond ((redefine-structure-warning class old-info info)
1168 (values class new-layout old-layout))
1170 (setf (layout-info old-layout) info)
1171 (values class old-layout nil))))
1173 (setf (layout-info old-layout) info)
1174 (values class old-layout nil))
1176 (error "shouldn't happen! strange thing in LAYOUT-INFO:~% ~S"
1178 (values class new-layout old-layout)))))))))
1180 ;;; Blow away all the compiler info for the structure CLASS. Iterate
1181 ;;; over this type, clearing the compiler structure type info, and
1182 ;;; undefining all the associated functions.
1183 (defun undefine-structure (class)
1184 (let ((info (layout-info (class-layout class))))
1185 (when (defstruct-description-p info)
1186 (let ((type (dd-name info)))
1187 (remhash type *typecheckfuns*)
1188 (setf (info :type :compiler-layout type) nil)
1189 (undefine-fun-name (dd-copier-name info))
1190 (undefine-fun-name (dd-predicate-name info))
1191 (dolist (slot (dd-slots info))
1192 (let ((fun (dsd-accessor-name slot)))
1193 (unless (accessor-inherited-data fun info)
1194 (undefine-fun-name fun)
1195 (unless (dsd-read-only slot)
1196 (undefine-fun-name `(setf ,fun)))))))
1197 ;; Clear out the SPECIFIER-TYPE cache so that subsequent
1198 ;; references are unknown types.
1199 (values-specifier-type-cache-clear)))
1202 ;;; Return a list of pairs (name . index). Used for :TYPE'd
1203 ;;; constructors to find all the names that we have to splice in &
1204 ;;; where. Note that these types don't have a layout, so we can't look
1205 ;;; at LAYOUT-INHERITS.
1206 (defun find-name-indices (defstruct)
1209 (do ((info defstruct
1210 (typed-structure-info-or-lose (first (dd-include info)))))
1211 ((not (dd-include info))
1216 (dolist (info infos)
1217 (incf i (or (dd-offset info) 0))
1218 (when (dd-named info)
1219 (res (cons (dd-name info) i)))
1220 (setq i (dd-length info)))))
1224 ;;; These functions are called to actually make a constructor after we
1225 ;;; have processed the arglist. The correct variant (according to the
1226 ;;; DD-TYPE) should be called. The function is defined with the
1227 ;;; specified name and arglist. VARS and TYPES are used for argument
1228 ;;; type declarations. VALUES are the values for the slots (in order.)
1230 ;;; This is split three ways because:
1231 ;;; * LIST & VECTOR structures need "name" symbols stuck in at
1232 ;;; various weird places, whereas STRUCTURE structures have
1234 ;;; * We really want to use LIST to make list structures, instead of
1235 ;;; MAKE-LIST/(SETF ELT). (We can't in general use VECTOR in an
1236 ;;; analogous way, since VECTOR makes a SIMPLE-VECTOR and vector-typed
1237 ;;; structures can have arbitrary subtypes of VECTOR, not necessarily
1239 ;;; * STRUCTURE structures can have raw slots that must also be
1240 ;;; allocated and indirectly referenced.
1241 (defun create-vector-constructor (dd cons-name arglist vars types values)
1242 (let ((temp (gensym))
1243 (etype (dd-element-type dd)))
1244 `(defun ,cons-name ,arglist
1245 (declare ,@(mapcar (lambda (var type) `(type (and ,type ,etype) ,var))
1247 (let ((,temp (make-array ,(dd-length dd)
1248 :element-type ',(dd-element-type dd))))
1249 ,@(mapcar (lambda (x)
1250 `(setf (aref ,temp ,(cdr x)) ',(car x)))
1251 (find-name-indices dd))
1252 ,@(mapcar (lambda (dsd value)
1253 `(setf (aref ,temp ,(dsd-index dsd)) ,value))
1254 (dd-slots dd) values)
1256 (defun create-list-constructor (dd cons-name arglist vars types values)
1257 (let ((vals (make-list (dd-length dd) :initial-element nil)))
1258 (dolist (x (find-name-indices dd))
1259 (setf (elt vals (cdr x)) `',(car x)))
1260 (loop for dsd in (dd-slots dd) and val in values do
1261 (setf (elt vals (dsd-index dsd)) val))
1263 `(defun ,cons-name ,arglist
1264 (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types))
1266 (defun create-structure-constructor (dd cons-name arglist vars types values)
1267 (let* ((instance (gensym "INSTANCE"))
1268 (raw-index (dd-raw-index dd)))
1269 `(defun ,cons-name ,arglist
1270 (declare ,@(mapcar (lambda (var type) `(type ,type ,var))
1272 (let ((,instance (truly-the ,(dd-name dd)
1273 (%make-instance-with-layout
1274 (%delayed-get-compiler-layout ,(dd-name dd))))))
1276 `((setf (%instance-ref ,instance ,raw-index)
1277 (make-array ,(dd-raw-length dd)
1278 :element-type '(unsigned-byte 32)))))
1279 ,@(mapcar (lambda (dsd value)
1280 ;; (Note that we can't in general use the
1281 ;; ordinary named slot setter function here
1282 ;; because the slot might be :READ-ONLY, so we
1283 ;; whip up new LAMBDA representations of slot
1284 ;; setters for the occasion.)
1285 `(,(slot-setter-lambda-form dd dsd) ,value ,instance))
1290 ;;; Create a default (non-BOA) keyword constructor.
1291 (defun create-keyword-constructor (defstruct creator)
1292 (declare (type function creator))
1293 (collect ((arglist (list '&key))
1296 (dolist (slot (dd-slots defstruct))
1297 (let ((dum (gensym))
1298 (name (dsd-name slot)))
1299 (arglist `((,(keywordicate name) ,dum) ,(dsd-default slot)))
1300 (types (dsd-type slot))
1303 defstruct (dd-default-constructor defstruct)
1304 (arglist) (vals) (types) (vals))))
1306 ;;; Given a structure and a BOA constructor spec, call CREATOR with
1307 ;;; the appropriate args to make a constructor.
1308 (defun create-boa-constructor (defstruct boa creator)
1309 (declare (type function creator))
1310 (multiple-value-bind (req opt restp rest keyp keys allowp auxp aux)
1311 (parse-lambda-list (second boa))
1315 (labels ((get-slot (name)
1316 (let ((res (find name (dd-slots defstruct)
1320 (values (dsd-type res) (dsd-default res))
1323 (multiple-value-bind (type default) (get-slot arg)
1324 (arglist `(,arg ,default))
1330 (types (get-slot arg)))
1333 (arglist '&optional)
1337 ;; FIXME: this shares some logic (though not
1338 ;; code) with the &key case below (and it
1339 ;; looks confusing) -- factor out the logic
1340 ;; if possible. - CSR, 2002-04-19
1343 (def (nth-value 1 (get-slot name)))
1344 (supplied-test nil supplied-test-p))
1346 (arglist `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)))
1348 (types (get-slot name))))
1350 (do-default arg)))))
1353 (arglist '&rest rest)
1361 (destructuring-bind (wot
1364 (supplied-test nil supplied-test-p))
1366 (let ((name (if (consp wot)
1367 (destructuring-bind (key var) wot
1368 (declare (ignore key))
1371 (multiple-value-bind (type slot-def)
1373 (arglist `(,wot ,(if def-p def slot-def)
1374 ,@(if supplied-test-p `(,supplied-test) nil)))
1379 (when allowp (arglist '&allow-other-keys))
1384 (let* ((arg (if (consp arg) arg (list arg)))
1388 (types (get-slot var))))))
1390 (funcall creator defstruct (first boa)
1391 (arglist) (vars) (types)
1392 (mapcar (lambda (slot)
1393 (or (find (dsd-name slot) (vars) :test #'string=)
1394 (dsd-default slot)))
1395 (dd-slots defstruct))))))
1397 ;;; Grovel the constructor options, and decide what constructors (if
1399 (defun constructor-definitions (defstruct)
1400 (let ((no-constructors nil)
1403 (creator (ecase (dd-type defstruct)
1404 (structure #'create-structure-constructor)
1405 (vector #'create-vector-constructor)
1406 (list #'create-list-constructor))))
1407 (dolist (constructor (dd-constructors defstruct))
1408 (destructuring-bind (name &optional (boa-ll nil boa-p)) constructor
1409 (declare (ignore boa-ll))
1410 (cond ((not name) (setq no-constructors t))
1411 (boa-p (push constructor boas))
1412 (t (push name defaults)))))
1414 (when no-constructors
1415 (when (or defaults boas)
1416 (error "(:CONSTRUCTOR NIL) combined with other :CONSTRUCTORs"))
1417 (return-from constructor-definitions ()))
1419 (unless (or defaults boas)
1420 (push (symbolicate "MAKE-" (dd-name defstruct)) defaults))
1424 (let ((cname (first defaults)))
1425 (setf (dd-default-constructor defstruct) cname)
1426 (res (create-keyword-constructor defstruct creator))
1427 (dolist (other-name (rest defaults))
1428 (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
1429 (res `(declaim (ftype function ',other-name))))))
1432 (res (create-boa-constructor defstruct boa creator)))
1436 ;;;; instances with ALTERNATE-METACLASS
1438 ;;;; The CMU CL support for structures with ALTERNATE-METACLASS was a
1439 ;;;; fairly general extension embedded in the main DEFSTRUCT code, and
1440 ;;;; the result was an fairly impressive mess as ALTERNATE-METACLASS
1441 ;;;; extension mixed with ANSI CL generality (e.g. :TYPE and :INCLUDE)
1442 ;;;; and CMU CL implementation hairiness (esp. raw slots). This SBCL
1443 ;;;; version is much less ambitious, noticing that ALTERNATE-METACLASS
1444 ;;;; is only used to implement CONDITION, STANDARD-INSTANCE, and
1445 ;;;; GENERIC-FUNCTION, and defining a simple specialized
1446 ;;;; separate-from-DEFSTRUCT macro to provide only enough
1447 ;;;; functionality to support those.
1449 ;;;; KLUDGE: The defining macro here is so specialized that it's ugly
1450 ;;;; in its own way. It also violates once-and-only-once by knowing
1451 ;;;; much about structures and layouts that is already known by the
1452 ;;;; main DEFSTRUCT macro. Hopefully it will go away presently
1453 ;;;; (perhaps when CL:CLASS and SB-PCL:CLASS meet) as per FIXME below.
1454 ;;;; -- WHN 2001-10-28
1456 ;;;; FIXME: There seems to be no good reason to shoehorn CONDITION,
1457 ;;;; STANDARD-INSTANCE, and GENERIC-FUNCTION into mutated structures
1458 ;;;; instead of just implementing them as primitive objects. (This
1459 ;;;; reduced-functionality macro seems pretty close to the
1460 ;;;; functionality of DEFINE-PRIMITIVE-OBJECT..)
1462 (defun make-dd-with-alternate-metaclass (&key (class-name (missing-arg))
1463 (superclass-name (missing-arg))
1464 (metaclass-name (missing-arg))
1465 (dd-type (missing-arg))
1466 metaclass-constructor
1468 (let* ((dd (make-defstruct-description class-name))
1469 (conc-name (concatenate 'string (symbol-name class-name) "-"))
1470 (dd-slots (let ((reversed-result nil)
1471 ;; The index starts at 1 for ordinary
1472 ;; named slots because slot 0 is
1473 ;; magical, used for LAYOUT in
1474 ;; CONDITIONs or for something (?) in
1475 ;; funcallable instances.
1477 (dolist (slot-name slot-names)
1478 (push (make-defstruct-slot-description
1479 :%name (symbol-name slot-name)
1481 :accessor-name (symbolicate conc-name slot-name))
1484 (nreverse reversed-result))))
1485 (setf (dd-alternate-metaclass dd) (list superclass-name
1487 metaclass-constructor)
1488 (dd-slots dd) dd-slots
1489 (dd-length dd) (1+ (length slot-names))
1490 (dd-type dd) dd-type)
1493 (sb!xc:defmacro !defstruct-with-alternate-metaclass
1495 (slot-names (missing-arg))
1496 (boa-constructor (missing-arg))
1497 (superclass-name (missing-arg))
1498 (metaclass-name (missing-arg))
1499 (metaclass-constructor (missing-arg))
1500 (dd-type (missing-arg))
1502 (runtime-type-checks-p t))
1504 (declare (type (and list (not null)) slot-names))
1505 (declare (type (and symbol (not null))
1509 metaclass-constructor))
1510 (declare (type symbol predicate))
1511 (declare (type (member structure funcallable-structure) dd-type))
1513 (let* ((dd (make-dd-with-alternate-metaclass
1514 :class-name class-name
1515 :slot-names slot-names
1516 :superclass-name superclass-name
1517 :metaclass-name metaclass-name
1518 :metaclass-constructor metaclass-constructor
1520 (dd-slots (dd-slots dd))
1521 (dd-length (1+ (length slot-names)))
1522 (object-gensym (gensym "OBJECT"))
1523 (new-value-gensym (gensym "NEW-VALUE-"))
1524 (delayed-layout-form `(%delayed-get-compiler-layout ,class-name)))
1525 (multiple-value-bind (raw-maker-form raw-reffer-operator)
1528 (values `(let ((,object-gensym (%make-instance ,dd-length)))
1529 (setf (%instance-layout ,object-gensym)
1530 ,delayed-layout-form)
1533 (funcallable-structure
1534 (values `(%make-funcallable-instance ,dd-length
1535 ,delayed-layout-form)
1536 '%funcallable-instance-info)))
1539 (eval-when (:compile-toplevel :load-toplevel :execute)
1540 (%compiler-set-up-layout ',dd))
1542 ;; slot readers and writers
1543 (declaim (inline ,@(mapcar #'dsd-accessor-name dd-slots)))
1544 ,@(mapcar (lambda (dsd)
1545 `(defun ,(dsd-accessor-name dsd) (,object-gensym)
1546 ,@(when runtime-type-checks-p
1547 `((declare (type ,class-name ,object-gensym))))
1548 (,raw-reffer-operator ,object-gensym
1551 (declaim (inline ,@(mapcar (lambda (dsd)
1552 `(setf ,(dsd-accessor-name dsd)))
1554 ,@(mapcar (lambda (dsd)
1555 `(defun (setf ,(dsd-accessor-name dsd)) (,new-value-gensym
1557 ,@(when runtime-type-checks-p
1558 `((declare (type ,class-name ,object-gensym))))
1559 (setf (,raw-reffer-operator ,object-gensym
1561 ,new-value-gensym)))
1565 (defun ,boa-constructor ,slot-names
1566 (let ((,object-gensym ,raw-maker-form))
1567 ,@(mapcar (lambda (slot-name)
1568 (let ((dsd (find (symbol-name slot-name) dd-slots
1571 ;; KLUDGE: bug 117 bogowarning. Neither
1572 ;; DECLAREing the type nor TRULY-THE cut
1573 ;; the mustard -- it still gives warnings.
1574 (enforce-type dsd defstruct-slot-description)
1575 `(setf (,(dsd-accessor-name dsd) ,object-gensym)
1582 ;; Just delegate to the compiler's type optimization
1583 ;; code, which knows how to generate inline type tests
1584 ;; for the whole CMU CL INSTANCE menagerie.
1585 `(defun ,predicate (,object-gensym)
1586 (typep ,object-gensym ',class-name)))))))
1588 ;;;; finalizing bootstrapping
1590 ;;; Set up DD and LAYOUT for STRUCTURE-OBJECT class itself.
1592 ;;; Ordinary structure classes effectively :INCLUDE STRUCTURE-OBJECT
1593 ;;; when they have no explicit :INCLUDEs, so (1) it needs to be set up
1594 ;;; before we can define ordinary structure classes, and (2) it's
1595 ;;; special enough (and simple enough) that we just build it by hand
1596 ;;; instead of trying to generalize the ordinary DEFSTRUCT code.
1597 (defun !set-up-structure-object-class ()
1598 (let ((dd (make-defstruct-description 'structure-object)))
1600 ;; Note: This has an ALTERNATE-METACLASS only because of blind
1601 ;; clueless imitation of the CMU CL code -- dunno if or why it's
1603 (dd-alternate-metaclass dd) '(instance)
1606 (dd-type dd) 'structure)
1607 (%compiler-set-up-layout dd)))
1608 (!set-up-structure-object-class)
1610 ;;; early structure predeclarations: Set up DD and LAYOUT for ordinary
1611 ;;; (non-ALTERNATE-METACLASS) structures which are needed early.
1613 '#.(sb-cold:read-from-file
1614 "src/code/early-defstruct-args.lisp-expr"))
1615 (let* ((dd (parse-defstruct-name-and-options-and-slot-descriptions
1618 (inherits (inherits-for-structure dd)))
1619 (%compiler-defstruct dd inherits)))
1621 (/show0 "code/defstruct.lisp end of file")