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) is compiled.
32 (sb!xc:defmacro %delayed-get-compiler-layout (name)
33 `',(compiler-layout-or-lose name))
35 ;;; Get layout right away.
36 (sb!xc:defmacro compile-time-find-layout (name)
39 ;;; re. %DELAYED-GET-COMPILER-LAYOUT and COMPILE-TIME-FIND-LAYOUT, above..
41 ;;; FIXME: Perhaps both should be defined with DEFMACRO-MUNDANELY?
42 ;;; FIXME: Do we really need both? If so, their names and implementations
43 ;;; should probably be tweaked to be more parallel.
45 ;;; The DEFSTRUCT-DESCRIPTION structure holds compile-time information about a
47 (def!struct (defstruct-description
49 (:make-load-form-fun just-dump-it-normally)
50 #-sb-xc-host (:pure t)
51 (:constructor make-defstruct-description (name)))
52 ;; name of the structure
53 (name (required-argument) :type symbol)
54 ;; documentation on the structure
55 (doc nil :type (or string null))
56 ;; prefix for slot names. If NIL, none.
57 (conc-name (symbolicate name "-") :type (or symbol null))
58 ;; the name of the primary standard keyword constructor, or NIL if none
59 (default-constructor nil :type (or symbol null))
60 ;; all the explicit :CONSTRUCTOR specs, with name defaulted
61 (constructors () :type list)
62 ;; name of copying function
63 (copier-name (symbolicate "COPY-" name) :type (or symbol null))
64 ;; name of type predicate
65 (predicate-name (symbolicate name "-P") :type (or symbol null))
66 ;; the arguments to the :INCLUDE option, or NIL if no included
68 (include nil :type list)
69 ;; The arguments to the :ALTERNATE-METACLASS option (an extension
70 ;; used to define structure-like objects with an arbitrary
71 ;; superclass and that may not have STRUCTURE-CLASS as the
72 ;; metaclass.) Syntax is:
73 ;; (superclass-name metaclass-name metaclass-constructor)
74 (alternate-metaclass nil :type list)
75 ;; a list of DEFSTRUCT-SLOT-DESCRIPTION objects for all slots
76 ;; (including included ones)
78 ;; number of elements we've allocated (See also RAW-LENGTH.)
79 (length 0 :type index)
80 ;; General kind of implementation.
81 (type 'structure :type (member structure vector list
82 funcallable-structure))
84 ;; The next three slots are for :TYPE'd structures (which aren't
85 ;; classes, DD-CLASS-P = NIL)
87 ;; vector element type
89 ;; T if :NAMED was explicitly specified, NIL otherwise
90 (named nil :type boolean)
91 ;; any INITIAL-OFFSET option on this direct type
92 (offset nil :type (or index null))
94 ;; the argument to the PRINT-FUNCTION option, or NIL if a
95 ;; PRINT-FUNCTION option was given with no argument, or 0 if no
96 ;; PRINT-FUNCTION option was given
97 (print-function 0 :type (or cons symbol (member 0)))
98 ;; the argument to the PRINT-OBJECT option, or NIL if a PRINT-OBJECT
99 ;; option was given with no argument, or 0 if no PRINT-OBJECT option
101 (print-object 0 :type (or cons symbol (member 0)))
102 ;; the index of the raw data vector and the number of words in it,
103 ;; or NIL and 0 if not allocated (either because this structure
104 ;; has no raw slots, or because we're still parsing it and haven't
105 ;; run across any raw slots yet)
106 (raw-index nil :type (or index null))
107 (raw-length 0 :type index)
108 ;; the value of the :PURE option, or :UNSPECIFIED. This is only
109 ;; meaningful if DD-CLASS-P = T.
110 (pure :unspecified :type (member t nil :substructure :unspecified)))
111 (def!method print-object ((x defstruct-description) stream)
112 (print-unreadable-object (x stream :type t)
113 (prin1 (dd-name x) stream)))
115 ;;; A DEFSTRUCT-SLOT-DESCRIPTION holds compile-time information about
116 ;;; a structure slot.
117 (def!struct (defstruct-slot-description
118 (:make-load-form-fun just-dump-it-normally)
121 #-sb-xc-host (:pure t))
122 ;; string name of slot
124 ;; its position in the implementation sequence
125 (index (required-argument) :type fixnum)
126 ;; the name of the accessor function
128 ;; (CMU CL had extra complexity here ("..or NIL if this accessor has
129 ;; the same name as an inherited accessor (which we don't want to
130 ;; shadow)") but that behavior doesn't seem to be specified by (or
131 ;; even particularly consistent with) ANSI, so it's gone in SBCL.)
133 default ; default value expression
134 (type t) ; declared type specifier
135 ;; If this object does not describe a raw slot, this value is T.
137 ;; If this object describes a raw slot, this value is the type of the
138 ;; value that the raw slot holds. Mostly. (KLUDGE: If the raw slot has
139 ;; type (UNSIGNED-BYTE 32), the value here is UNSIGNED-BYTE, not
140 ;; (UNSIGNED-BYTE 32).)
141 (raw-type t :type (member t single-float double-float
142 #!+long-float long-float
143 complex-single-float complex-double-float
144 #!+long-float complex-long-float
146 (read-only nil :type (member t nil)))
147 (def!method print-object ((x defstruct-slot-description) stream)
148 (print-unreadable-object (x stream :type t)
149 (prin1 (dsd-name x) stream)))
151 ;;; Is DEFSTRUCT a structure with a class?
152 (defun dd-class-p (defstruct)
153 (member (dd-type defstruct) '(structure funcallable-structure)))
155 ;;; Return the name of a defstruct slot as a symbol. We store it as a
156 ;;; string to avoid creating lots of worthless symbols at load time.
157 (defun dsd-name (dsd)
158 (intern (string (dsd-%name dsd))
159 (if (dsd-accessor-name dsd)
160 (symbol-package (dsd-accessor-name dsd))
163 ;;;; typed (non-class) structures
165 ;;; Return a type specifier we can use for testing :TYPE'd structures.
166 (defun dd-lisp-type (defstruct)
167 (ecase (dd-type defstruct)
169 (vector `(simple-array ,(dd-element-type defstruct) (*)))))
171 ;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its
172 ;;;; close personal friend SB!XC:DEFSTRUCT)
174 ;;; Return a list of forms to install PRINT and MAKE-LOAD-FORM funs,
175 ;;; mentioning them in the expansion so that they can be compiled.
176 (defun class-method-definitions (defstruct)
177 (let ((name (dd-name defstruct)))
179 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant
180 ;; class names which creates fast but non-cold-loadable,
181 ;; non-compact code. In this context, we'd rather have
182 ;; compact, cold-loadable code. -- WHN 19990928
183 (declare (notinline sb!xc:find-class))
184 ,@(let ((pf (dd-print-function defstruct))
185 (po (dd-print-object defstruct))
188 ;; Giving empty :PRINT-OBJECT or :PRINT-FUNCTION options
189 ;; leaves PO or PF equal to NIL. The user-level effect is
190 ;; to generate a PRINT-OBJECT method specialized for the type,
191 ;; implementing the default #S structure-printing behavior.
192 (when (or (eq pf nil) (eq po nil))
193 (setf pf '(default-structure-print)
195 (flet (;; Given an arg from a :PRINT-OBJECT or :PRINT-FUNCTION
196 ;; option, return the value to pass as an arg to FUNCTION.
198 (destructuring-bind (fun-name) oarg
200 (cond ((not (eql pf 0))
201 `((def!method print-object ((,x ,name) ,s)
202 (funcall #',(farg pf) ,x ,s *current-level*))))
204 `((def!method print-object ((,x ,name) ,s)
205 (funcall #',(farg po) ,x ,s))))
207 ,@(let ((pure (dd-pure defstruct)))
209 `((setf (layout-pure (class-layout
210 (sb!xc:find-class ',name)))
212 ((eq pure :substructure)
213 `((setf (layout-pure (class-layout
214 (sb!xc:find-class ',name)))
216 ,@(let ((def-con (dd-default-constructor defstruct)))
217 (when (and def-con (not (dd-alternate-metaclass defstruct)))
218 `((setf (structure-class-constructor (sb!xc:find-class ',name))
220 ;;; FIXME: I really would like to make structure accessors less
221 ;;; special, just ordinary inline functions. (Or perhaps inline
222 ;;; functions with special compact implementations of their
223 ;;; expansions, to avoid bloating the system.)
225 ;;; shared logic for CL:DEFSTRUCT and SB!XC:DEFSTRUCT
226 (defmacro !expander-for-defstruct (name-and-options
228 expanding-into-code-for-xc-host-p)
229 `(let ((name-and-options ,name-and-options)
230 (slot-descriptions ,slot-descriptions)
231 (expanding-into-code-for-xc-host-p
232 ,expanding-into-code-for-xc-host-p))
233 (let* ((dd (parse-defstruct-name-and-options-and-slot-descriptions
238 (let ((inherits (inherits-for-structure dd)))
240 (eval-when (:compile-toplevel :load-toplevel :execute)
241 (%compiler-defstruct ',dd ',inherits))
242 (%defstruct ',dd ',inherits)
243 ,@(unless expanding-into-code-for-xc-host-p
244 (append (raw-accessor-definitions dd)
245 (predicate-definitions dd)
246 ;; FIXME: We've inherited from CMU CL nonparallel
247 ;; code for creating copiers for typed and untyped
248 ;; structures. This should be fixed.
249 ;(copier-definition dd)
250 (constructor-definitions dd)
251 (class-method-definitions dd)))
254 (eval-when (:compile-toplevel :load-toplevel :execute)
255 (setf (info :typed-structure :info ',name) ',dd))
256 ,@(unless expanding-into-code-for-xc-host-p
257 (append (typed-accessor-definitions dd)
258 (typed-predicate-definitions dd)
259 (typed-copier-definitions dd)
260 (constructor-definitions dd)))
263 (sb!xc:defmacro defstruct (name-and-options &rest slot-descriptions)
265 "DEFSTRUCT {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)}
266 Define the structure type Name. Instances are created by MAKE-<name>,
267 which takes &KEY arguments allowing initial slot values to the specified.
268 A SETF'able function <name>-<slot> is defined for each slot to read and
269 write slot values. <name>-p is a type predicate.
271 Popular DEFSTRUCT options (see manual for others):
275 Specify the name for the constructor or predicate.
277 (:CONSTRUCTOR Name Lambda-List)
278 Specify the name and arguments for a BOA constructor
279 (which is more efficient when keyword syntax isn't necessary.)
281 (:INCLUDE Supertype Slot-Spec*)
282 Make this type a subtype of the structure type Supertype. The optional
283 Slot-Specs override inherited slot options.
288 Asserts that the value of this slot is always of the specified type.
291 If true, no setter function is defined for this slot."
292 (!expander-for-defstruct name-and-options slot-descriptions nil))
294 (defmacro sb!xc:defstruct (name-and-options &rest slot-descriptions)
296 "Cause information about a target structure to be built into the
298 (!expander-for-defstruct name-and-options slot-descriptions t))
300 ;;;; functions to generate code for various parts of DEFSTRUCT definitions
302 ;;; Catch requests to mess up definitions in COMMON-LISP.
304 (eval-when (:compile-toplevel :load-toplevel :execute)
305 (defun protect-cl (symbol)
306 (when (and *cold-init-complete-p*
307 (eq (symbol-package symbol) *cl-package*))
308 (cerror "Go ahead and patch the system."
309 "attempting to modify a symbol in the COMMON-LISP package: ~S"
312 ;;; Return forms to define readers and writers for raw slots as inline
314 (defun raw-accessor-definitions (dd)
315 (let* ((name (dd-name dd)))
317 (dolist (slot (dd-slots dd))
318 (let ((slot-type (dsd-type slot))
319 (accessor-name (dsd-accessor-name slot))
320 (argname (gensym "ARG"))
321 (nvname (gensym "NEW-VALUE-")))
322 (multiple-value-bind (accessor offset data)
323 (slot-accessor-form dd slot argname)
324 ;; When accessor exists and is raw
325 (when (and accessor-name
326 (not (eq accessor-name '%instance-ref)))
327 (res `(declaim (inline ,accessor-name)))
328 (res `(declaim (ftype (function (,name) ,slot-type)
330 (res `(defun ,accessor-name (,argname)
331 ;; Note: The DECLARE here might seem redundant
332 ;; with the DECLAIM FTYPE above, but it's not:
333 ;; If we're not at toplevel, the PROCLAIM inside
334 ;; the DECLAIM doesn't get executed until after
335 ;; this function is compiled.
336 (declare (type ,name ,argname))
337 (truly-the ,slot-type (,accessor ,data ,offset))))
338 (unless (dsd-read-only slot)
339 (res `(declaim (inline (setf ,accessor-name))))
340 (res `(declaim (ftype (function (,slot-type ,name) ,slot-type)
341 (setf ,accessor-name))))
342 ;; FIXME: I rewrote this somewhat from the CMU CL definition.
343 ;; Do some basic tests to make sure that reading and writing
344 ;; raw slots still works correctly.
345 (res `(defun (setf ,accessor-name) (,nvname ,argname)
346 (declare (type ,name ,argname))
347 (setf (,accessor ,data ,offset) ,nvname)
351 ;;; Return a list of forms which create a predicate for an untyped DEFSTRUCT.
352 (defun predicate-definitions (dd)
353 (let ((pred (dd-predicate-name dd))
356 (if (eq (dd-type dd) 'funcallable-structure)
357 ;; FIXME: Why does this need to be special-cased for
358 ;; FUNCALLABLE-STRUCTURE? CMU CL did it, but without explanation.
359 ;; Could we do without it? What breaks if we do? Or could we
360 ;; perhaps get by with no predicates for funcallable structures?
361 `((declaim (inline ,pred))
362 (defun ,pred (,argname) (typep ,argname ',(dd-name dd))))
363 `((protect-cl ',pred)
364 (declaim (inline ,pred))
365 (defun ,pred (,argname)
366 (declare (optimize (speed 3) (safety 0)))
367 (typep-to-layout ,argname
368 (compile-time-find-layout ,(dd-name dd)))))))))
370 ;;; Return a list of forms which create a predicate function for a typed
372 (defun typed-predicate-definitions (defstruct)
373 (let ((name (dd-name defstruct))
374 (predicate-name (dd-predicate-name defstruct))
376 (when (and predicate-name (dd-named defstruct))
377 (let ((ltype (dd-lisp-type defstruct)))
378 `((defun ,predicate-name (,argname)
379 (and (typep ,argname ',ltype)
380 (eq (elt (the ,ltype ,argname)
381 ,(cdr (car (last (find-name-indices defstruct)))))
384 ;;; FIXME: We've inherited from CMU CL code to do typed structure copiers
385 ;;; in a completely different way than untyped structure copiers. Fix this.
386 ;;; (This function was my first attempt to fix this, but I stopped before
387 ;;; figuring out how to install it completely and remove the parallel
388 ;;; code which simply SETF's the FDEFINITION of the DD-COPIER name.
390 ;;; Return the copier definition for an untyped DEFSTRUCT.
391 (defun copier-definition (dd)
392 (when (and (dd-copier dd)
393 ;; FUNCALLABLE-STRUCTUREs don't need copiers, and this
394 ;; implementation wouldn't work for them anyway, since
395 ;; COPY-STRUCTURE returns a STRUCTURE-OBJECT and they're not.
396 (not (eq (dd-type info) 'funcallable-structure)))
397 (let ((argname (gensym)))
399 (protect-cl ',(dd-copier dd))
400 (defun ,(dd-copier dd) (,argname)
401 (declare (type ,(dd-name dd) ,argname))
402 (copy-structure ,argname))))))
405 ;;; Return a list of forms to create a copier function of a typed DEFSTRUCT.
406 (defun typed-copier-definitions (defstruct)
407 (when (dd-copier-name defstruct)
408 `((setf (fdefinition ',(dd-copier-name defstruct)) #'copy-seq)
409 (declaim (ftype function ,(dd-copier-name defstruct))))))
411 ;;; Return a list of function definitions for accessing and setting the
412 ;;; slots of a typed DEFSTRUCT. The functions are proclaimed to be inline,
413 ;;; and the types of their arguments and results are declared as well. We
414 ;;; count on the compiler to do clever things with ELT.
415 (defun typed-accessor-definitions (defstruct)
417 (let ((ltype (dd-lisp-type defstruct)))
418 (dolist (slot (dd-slots defstruct))
419 (let ((name (dsd-accessor-name slot))
420 (index (dsd-index slot))
421 (slot-type `(and ,(dsd-type slot)
422 ,(dd-element-type defstruct))))
423 (stuff `(proclaim '(inline ,name (setf ,name))))
424 ;; FIXME: The arguments in the next two DEFUNs should be
425 ;; gensyms. (Otherwise e.g. if NEW-VALUE happened to be the
426 ;; name of a special variable, things could get weird.)
427 (stuff `(defun ,name (structure)
428 (declare (type ,ltype structure))
429 (the ,slot-type (elt structure ,index))))
430 (unless (dsd-read-only slot)
432 `(defun (setf ,name) (new-value structure)
433 (declare (type ,ltype structure) (type ,slot-type new-value))
434 (setf (elt structure ,index) new-value)))))))
439 (defun require-no-print-options-so-far (defstruct)
440 (unless (and (eql (dd-print-function defstruct) 0)
441 (eql (dd-print-object defstruct) 0))
442 (error "No more than one of the following options may be specified:
443 :PRINT-FUNCTION, :PRINT-OBJECT, :TYPE")))
445 ;;; Parse a single DEFSTRUCT option and store the results in DD.
446 (defun parse-1-dd-option (option dd)
447 (let ((args (rest option))
451 (destructuring-bind (conc-name) args
452 (setf (dd-conc-name dd)
453 (if (symbolp conc-name)
455 (make-symbol (string conc-name))))))
457 (destructuring-bind (&optional (cname (symbolicate "MAKE-" name))
460 (push (cons cname stuff) (dd-constructors dd))))
462 (destructuring-bind (&optional (copier (symbolicate "COPY-" name)))
464 (setf (dd-copier-name dd) copier)))
466 (destructuring-bind (&optional (predicate-name (symbolicate name "-P")))
468 (setf (dd-predicate-name dd) predicate-name)))
470 (when (dd-include dd)
471 (error "more than one :INCLUDE option"))
472 (setf (dd-include dd) args))
473 (:alternate-metaclass
474 (setf (dd-alternate-metaclass dd) args))
476 (require-no-print-options-so-far dd)
477 (setf (dd-print-function dd)
478 (the (or symbol cons) args)))
480 (require-no-print-options-so-far dd)
481 (setf (dd-print-object dd)
482 (the (or symbol cons) args)))
484 (destructuring-bind (type) args
485 (cond ((eq type 'funcallable-structure)
486 (setf (dd-type dd) type))
487 ((member type '(list vector))
488 (setf (dd-element-type dd) t)
489 (setf (dd-type dd) type))
490 ((and (consp type) (eq (first type) 'vector))
491 (destructuring-bind (vector vtype) type
492 (declare (ignore vector))
493 (setf (dd-element-type dd) vtype)
494 (setf (dd-type dd) 'vector)))
496 (error "~S is a bad :TYPE for DEFSTRUCT." type)))))
498 (error "The DEFSTRUCT option :NAMED takes no arguments."))
500 (destructuring-bind (offset) args
501 (setf (dd-offset dd) offset)))
503 (destructuring-bind (fun) args
504 (setf (dd-pure dd) fun)))
505 (t (error "unknown DEFSTRUCT option:~% ~S" option)))))
507 ;;; Given name and options, return a DD holding that info.
508 (eval-when (:compile-toplevel :load-toplevel :execute)
509 (defun parse-defstruct-name-and-options (name-and-options)
510 (destructuring-bind (name &rest options) name-and-options
511 (aver name) ; A null name doesn't seem to make sense here.
512 (let ((dd (make-defstruct-description name)))
513 (dolist (option options)
514 (cond ((consp option)
515 (parse-1-dd-option option dd))
517 (setf (dd-named dd) t))
518 ((member option '(:constructor :copier :predicate :named))
519 (parse-1-dd-option (list option) dd))
521 (error "unrecognized DEFSTRUCT option: ~S" option))))
526 (error ":OFFSET can't be specified unless :TYPE is specified."))
527 (unless (dd-include dd)
528 (incf (dd-length dd))))
529 (funcallable-structure)
531 (require-no-print-options-so-far dd)
533 (incf (dd-length dd)))
534 (let ((offset (dd-offset dd)))
535 (when offset (incf (dd-length dd) offset)))))
537 (when (dd-include dd)
538 (do-dd-inclusion-stuff dd))
542 ;;; Given name and options and slot descriptions (and possibly doc
543 ;;; string at the head of slot descriptions) return a DD holding that
545 (defun parse-defstruct-name-and-options-and-slot-descriptions
546 (name-and-options slot-descriptions)
547 (let ((result (parse-defstruct-name-and-options (if (atom name-and-options)
548 (list name-and-options)
550 (when (stringp (car slot-descriptions))
551 (setf (dd-doc result) (pop slot-descriptions)))
552 (dolist (slot-description slot-descriptions)
553 (allocate-1-slot result (parse-1-dsd result slot-description)))
558 ;;;; stuff to parse slot descriptions
560 ;;; Parse a slot description for DEFSTRUCT, add it to the description
561 ;;; and return it. If supplied, SLOT is a pre-initialized DSD
562 ;;; that we modify to get the new slot. This is supplied when handling
564 (defun parse-1-dsd (defstruct spec &optional
565 (slot (make-defstruct-slot-description :%name ""
568 (multiple-value-bind (name default default-p type type-p read-only ro-p)
573 &optional (default nil default-p)
574 &key (type nil type-p) (read-only nil ro-p))
578 (uncross type) type-p
581 (when (keywordp spec)
582 (style-warn "Keyword slot name indicates probable syntax ~
583 error in DEFSTRUCT: ~S."
587 (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)
588 (error 'simple-program-error
589 :format-control "duplicate slot name ~S"
590 :format-arguments (list name)))
591 (setf (dsd-%name slot) (string name))
592 (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list slot)))
594 (let ((accessor-name (symbolicate (or (dd-conc-name defstruct) "") name))
595 (predicate-name (dd-predicate-name defstruct)))
596 (setf (dsd-accessor-name slot) accessor-name)
597 (when (eql accessor-name predicate-name)
598 ;; Some adventurous soul has named a slot so that its accessor
599 ;; collides with the structure type predicate. ANSI doesn't
600 ;; specify what to do in this case. As of 2001-09-04, Martin
601 ;; Atzmueller reports that CLISP and Lispworks both give
602 ;; priority to the slot accessor, so that the predicate is
603 ;; overwritten. We might as well do the same (as well as
604 ;; signalling a warning).
606 "~@<The structure accessor name ~S is the same as the name of the ~
607 structure type predicate. ANSI doesn't specify what to do in ~
608 this case; this implementation chooses to overwrite the type ~
609 predicate with the slot accessor.~@:>"
611 (setf (dd-predicate-name defstruct) nil)))
614 (setf (dsd-default slot) default))
616 (setf (dsd-type slot)
617 (if (eq (dsd-type slot) t)
619 `(and ,(dsd-type slot) ,type))))
622 (setf (dsd-read-only slot) t)
623 (when (dsd-read-only slot)
624 (error "Slot ~S is :READ-ONLY in parent and must be :READ-ONLY in subtype ~S."
629 ;;; When a value of type TYPE is stored in a structure, should it be
630 ;;; stored in a raw slot? Return (VALUES RAW? RAW-TYPE WORDS), where
631 ;;; RAW? is true if TYPE should be stored in a raw slot.
632 ;;; RAW-TYPE is the raw slot type, or NIL if no raw slot.
633 ;;; WORDS is the number of words in the raw slot, or NIL if no raw slot.
634 (defun structure-raw-slot-type-and-size (type)
635 (/noshow "in STRUCTURE-RAW-SLOT-TYPE-AND-SIZE" type (sb!xc:subtypep type 'fixnum))
637 (;; FIXME: For now we suppress raw slots, since there are various
638 ;; issues about the way that the cross-compiler handles them.
639 (not (boundp '*dummy-placeholder-to-stop-compiler-warnings*))
640 (values nil nil nil))
641 ((and (sb!xc:subtypep type '(unsigned-byte 32))
642 (multiple-value-bind (fixnum? fixnum-certain?)
643 (sb!xc:subtypep type 'fixnum)
644 (/noshow fixnum? fixnum-certain?)
645 ;; (The extra test for FIXNUM-CERTAIN? here is
646 ;; intended for bootstrapping the system. In
647 ;; particular, in sbcl-0.6.2, we set up LAYOUT before
648 ;; FIXNUM is defined, and so could bogusly end up
649 ;; putting INDEX-typed values into raw slots if we
650 ;; didn't test FIXNUM-CERTAIN?.)
651 (and (not fixnum?) fixnum-certain?)))
652 (values t 'unsigned-byte 1))
653 ((sb!xc:subtypep type 'single-float)
654 (values t 'single-float 1))
655 ((sb!xc:subtypep type 'double-float)
656 (values t 'double-float 2))
658 ((sb!xc:subtypep type 'long-float)
659 (values t 'long-float #!+x86 3 #!+sparc 4))
660 ((sb!xc:subtypep type '(complex single-float))
661 (values t 'complex-single-float 2))
662 ((sb!xc:subtypep type '(complex double-float))
663 (values t 'complex-double-float 4))
665 ((sb!xc:subtypep type '(complex long-float))
666 (values t 'complex-long-float #!+x86 6 #!+sparc 8))
668 (values nil nil nil))))
670 ;;; Allocate storage for a DSD in DD. This is where we decide whether
671 ;;; a slot is raw or not. If raw, and we haven't allocated a raw-index
672 ;;; yet for the raw data vector, then do it. Raw objects are aligned
673 ;;; on the unit of their size.
674 (defun allocate-1-slot (dd dsd)
675 (multiple-value-bind (raw? raw-type words)
676 (if (eq (dd-type dd) 'structure)
677 (structure-raw-slot-type-and-size (dsd-type dsd))
678 (values nil nil nil))
679 (/noshow "ALLOCATE-1-SLOT" dsd raw? raw-type words)
681 (setf (dsd-index dsd) (dd-length dd))
682 (incf (dd-length dd)))
684 (unless (dd-raw-index dd)
685 (setf (dd-raw-index dd) (dd-length dd))
686 (incf (dd-length dd)))
687 (let ((off (rem (dd-raw-length dd) words)))
689 (incf (dd-raw-length dd) (- words off))))
690 (setf (dsd-raw-type dsd) raw-type)
691 (setf (dsd-index dsd) (dd-raw-length dd))
692 (incf (dd-raw-length dd) words))))
695 (defun typed-structure-info-or-lose (name)
696 (or (info :typed-structure :info name)
697 (error ":TYPE'd DEFSTRUCT ~S not found for inclusion." name)))
699 ;;; Process any included slots pretty much like they were specified.
700 ;;; Also inherit various other attributes.
701 (defun do-dd-inclusion-stuff (dd)
702 (destructuring-bind (included-name &rest modified-slots) (dd-include dd)
703 (let* ((type (dd-type dd))
706 (layout-info (compiler-layout-or-lose included-name))
707 (typed-structure-info-or-lose included-name))))
708 (unless (and (eq type (dd-type included-structure))
709 (type= (specifier-type (dd-element-type included-structure))
710 (specifier-type (dd-element-type dd))))
711 (error ":TYPE option mismatch between structures ~S and ~S"
712 (dd-name dd) included-name))
714 (incf (dd-length dd) (dd-length included-structure))
715 (when (dd-class-p dd)
716 (let ((mc (rest (dd-alternate-metaclass included-structure))))
717 (when (and mc (not (dd-alternate-metaclass dd)))
718 (setf (dd-alternate-metaclass dd)
719 (cons included-name mc))))
720 (when (eq (dd-pure dd) :unspecified)
721 (setf (dd-pure dd) (dd-pure included-structure)))
722 (setf (dd-raw-index dd) (dd-raw-index included-structure))
723 (setf (dd-raw-length dd) (dd-raw-length included-structure)))
725 (dolist (included-slot (dd-slots included-structure))
726 (let* ((included-name (dsd-name included-slot))
727 (modified (or (find included-name modified-slots
728 :key #'(lambda (x) (if (atom x) x (car x)))
733 (copy-structure included-slot)))))))
735 ;;;; various helper functions for setting up DEFSTRUCTs
737 ;;; This function is called at macroexpand time to compute the INHERITS
738 ;;; vector for a structure type definition.
739 (defun inherits-for-structure (info)
740 (declare (type defstruct-description info))
741 (let* ((include (dd-include info))
742 (superclass-opt (dd-alternate-metaclass info))
745 (compiler-layout-or-lose (first include))
746 (class-layout (sb!xc:find-class
747 (or (first superclass-opt)
748 'structure-object))))))
749 (if (eq (dd-name info) 'lisp-stream)
750 ;; a hack to added the stream class as a mixin for LISP-STREAMs
751 (concatenate 'simple-vector
752 (layout-inherits super)
754 (class-layout (sb!xc:find-class 'stream))))
755 (concatenate 'simple-vector
756 (layout-inherits super)
759 ;;; Do miscellaneous (LOAD EVAL) time actions for the structure
760 ;;; described by INFO. Create the class & layout, checking for
761 ;;; incompatible redefinition. Define setters, accessors, copier,
762 ;;; predicate, documentation, instantiate definition in load-time env.
763 ;;; This is only called for default structures.
764 (defun %defstruct (info inherits)
765 (declare (type defstruct-description info))
766 (multiple-value-bind (class layout old-layout)
767 (ensure-structure-class info inherits "current" "new")
768 (cond ((not old-layout)
769 (unless (eq (class-layout class) layout)
770 (register-layout layout)))
772 (let ((old-info (layout-info old-layout)))
773 (when (defstruct-description-p old-info)
774 (dolist (slot (dd-slots old-info))
775 (fmakunbound (dsd-accessor-name slot))
776 (unless (dsd-read-only slot)
777 (fmakunbound `(setf ,(dsd-accessor-name slot)))))))
778 (%redefine-defstruct class old-layout layout)
779 (setq layout (class-layout class))))
781 (setf (sb!xc:find-class (dd-name info)) class)
783 ;; Set FDEFINITIONs for structure accessors, setters, predicates,
786 (unless (eq (dd-type info) 'funcallable-structure)
788 (dolist (slot (dd-slots info))
790 (when (and (dsd-accessor-name slot)
791 (eq (dsd-raw-type slot) t))
792 (protect-cl (dsd-accessor-name slot))
793 (setf (symbol-function (dsd-accessor-name slot))
794 (structure-slot-getter layout dsd))
795 (unless (dsd-read-only slot)
796 (setf (fdefinition `(setf ,(dsd-accessor-name slot)))
797 (structure-slot-setter layout dsd))))))
799 ;; FIXME: Someday it'd probably be good to go back to using
800 ;; closures for the out-of-line forms of structure accessors.
802 (when (dd-predicate info)
803 (protect-cl (dd-predicate info))
804 (setf (symbol-function (dd-predicate info))
806 (declare (optimize (speed 3) (safety 0)))
807 (typep-to-layout object layout))))
810 (when (dd-copier-name info)
811 (protect-cl (dd-copier-name info))
812 (setf (symbol-function (dd-copier-name info))
813 #'(lambda (structure)
814 (declare (optimize (speed 3) (safety 0)))
815 (flet ((layout-test (structure)
816 (typep-to-layout structure layout)))
817 (unless (layout-test structure)
818 (error 'simple-type-error
820 :expected-type '(satisfies layout-test)
822 "Structure for copier is not a ~S:~% ~S"
824 (list (sb!xc:class-name (layout-class layout))
826 (copy-structure structure))))))
829 (setf (fdocumentation (dd-name info) 'type) (dd-doc info)))
833 ;;; Return a form describing the writable place used for this slot
834 ;;; in the instance named INSTANCE-NAME.
835 (defun %accessor-place-form (dd dsd instance-name)
836 (let (;; the operator that we'll use to access a typed slot or, in
837 ;; the case of a raw slot, to read the vector of raw slots
838 (ref (ecase (dd-type dd)
839 (structure '%instance-ref)
840 (funcallable-structure '%funcallable-instance-info)
841 (list 'nth-but-with-sane-arg-order)
843 (raw-type (dsd-raw-type dsd)))
844 (if (eq raw-type t) ; if not raw slot
845 `(,ref ,instance-name ,(dsd-index dsd))
846 (let (;; the operator that we'll use to access one value in
847 ;; the raw data vector
848 (rawref (ecase raw-type
849 ;; The compiler thinks that the raw data
850 ;; vector is a vector of unsigned bytes, so if
851 ;; the slot we want to access actually *is* an
852 ;; unsigned byte, it'll access the slot for
853 ;; us even if we don't lie to it at all.
854 (unsigned-byte 'aref)
855 ;; "A lie can travel halfway round the world while
856 ;; the truth is putting on its shoes." -- Mark Twain
857 (single-float '%raw-ref-single)
858 (double-float '%raw-ref-double)
859 #!+long-float (long-float '%raw-ref-long)
860 (complex-single-float '%raw-ref-complex-single)
861 (complex-double-float '%raw-ref-complex-double)
862 #!+long-float (complex-long-float
863 '%raw-ref-complex-long))))
864 `(,rawref (,ref ,instance-name ,(dd-raw-index dd))
865 ,(dsd-index dsd))))))
867 ;;; Return inline expansion designators (i.e. values suitable for
868 ;;; (INFO :FUNCTION :INLINE-EXPANSSION-DESIGNATOR ..)) for the reader
869 ;;; and writer functions of the slot described by DSD.
870 (defun accessor-inline-expansion-designators (dd dsd)
871 ;; ordinary tagged non-raw slot case
874 (declare (type ,(dd-name dd) instance))
875 (truly-the ,(dsd-type dsd)
876 ,(%accessor-place-form dd dsd 'instance))))
878 `(lambda (new-value instance)
879 (declare (type ,(dsd-type dsd) new-value))
880 (declare (type ,(dd-name dd) structure-object))
881 (setf ,(%accessor-place-form dd dsd 'instance) new-value)))))
883 ;;; Do (COMPILE LOAD EVAL)-time actions for the defstruct described by DD.
884 (defun %compiler-defstruct (dd inherits)
885 (declare (type defstruct-description dd))
886 (multiple-value-bind (class layout old-layout)
887 (multiple-value-bind (clayout clayout-p)
888 (info :type :compiler-layout (dd-name dd))
889 (ensure-structure-class dd
891 (if clayout-p "previously compiled" "current")
893 :compiler-layout clayout))
895 (undefine-structure (layout-class old-layout))
896 (when (and (class-subclasses class)
897 (not (eq layout old-layout)))
899 (dohash (class layout (class-subclasses class))
900 (declare (ignore layout))
901 (undefine-structure class)
902 (subs (class-proper-name class)))
904 (warn "removing old subclasses of ~S:~% ~S"
905 (sb!xc:class-name class)
908 (unless (eq (class-layout class) layout)
909 (register-layout layout :invalidate nil))
910 (setf (sb!xc:find-class (dd-name dd)) class)))
912 (setf (info :type :compiler-layout (dd-name dd)) layout))
914 (let* ((dd-name (dd-name dd))
915 (class (sb!xc:find-class dd-name)))
917 (let ((copier-name (dd-copier-name dd)))
919 (sb!xc:proclaim `(ftype (function (,dd-name) ,dd-name) ,copier-name))))
921 (let ((predicate-name (dd-predicate-name dd)))
923 (sb!xc:proclaim `(ftype (function (t) t) ,predicate-name))))
925 (dolist (dsd (dd-slots dd))
926 (let* ((accessor-name (dsd-accessor-name dsd))
927 (dsd-type (dsd-type dsd)))
929 (multiple-value-bind (reader-designator writer-designator)
930 (accessor-inline-expansion-designators dd dsd)
931 (sb!xc:proclaim `(ftype (function (,dd-name) ,dsd-type)
933 (setf (info :function
934 :inline-expansion-designator
937 (info :function :inlinep accessor-name)
939 (unless (dsd-read-only dsd)
940 (let ((setf-accessor-name `(setf ,accessor-name)))
942 `(ftype (function (,dsd-type ,dd-name) ,dsd-type)
943 ,setf-accessor-name))
944 (setf (info :function
945 :inline-expansion-designator
948 (info :function :inlinep setf-accessor-name)
953 ;;;; redefinition stuff
955 ;;; Compare the slots of OLD and NEW, returning 3 lists of slot names:
956 ;;; 1. Slots which have moved,
957 ;;; 2. Slots whose type has changed,
958 ;;; 3. Deleted slots.
959 (defun compare-slots (old new)
960 (let* ((oslots (dd-slots old))
961 (nslots (dd-slots new))
962 (onames (mapcar #'dsd-name oslots))
963 (nnames (mapcar #'dsd-name nslots)))
966 (dolist (name (intersection onames nnames))
967 (let ((os (find name oslots :key #'dsd-name))
968 (ns (find name nslots :key #'dsd-name)))
969 (unless (subtypep (dsd-type ns) (dsd-type os))
970 (/noshow "found retyped slots" ns os (dsd-type ns) (dsd-type os))
972 (unless (and (= (dsd-index os) (dsd-index ns))
973 (eq (dsd-raw-type os) (dsd-raw-type ns)))
977 (set-difference onames nnames)))))
979 ;;; If we are redefining a structure with different slots than in the
980 ;;; currently loaded version, give a warning and return true.
981 (defun redefine-structure-warning (class old new)
982 (declare (type defstruct-description old new)
983 (type sb!xc:class class)
985 (let ((name (dd-name new)))
986 (multiple-value-bind (moved retyped deleted) (compare-slots old new)
987 (when (or moved retyped deleted)
989 "incompatibly redefining slots of structure class ~S~@
990 Make sure any uses of affected accessors are recompiled:~@
991 ~@[ These slots were moved to new positions:~% ~S~%~]~
992 ~@[ These slots have new incompatible types:~% ~S~%~]~
993 ~@[ These slots were deleted:~% ~S~%~]"
994 name moved retyped deleted)
997 ;;; This function is called when we are incompatibly redefining a
998 ;;; structure Class to have the specified New-Layout. We signal an
999 ;;; error with some proceed options and return the layout that should
1001 (defun %redefine-defstruct (class old-layout new-layout)
1002 (declare (type sb!xc:class class) (type layout old-layout new-layout))
1003 (let ((name (class-proper-name class)))
1005 (error "redefining class ~S incompatibly with the current definition"
1008 :report "Invalidate current definition."
1009 (warn "Previously loaded ~S accessors will no longer work." name)
1010 (register-layout new-layout))
1012 :report "Smash current layout, preserving old code."
1013 (warn "Any old ~S instances will be in a bad way.~@
1014 I hope you know what you're doing..."
1016 (register-layout new-layout :invalidate nil
1017 :destruct-layout old-layout))))
1020 ;;; This is called when we are about to define a structure class. It
1021 ;;; returns a (possibly new) class object and the layout which should
1022 ;;; be used for the new definition (may be the current layout, and
1023 ;;; also might be an uninstalled forward referenced layout.) The third
1024 ;;; value is true if this is an incompatible redefinition, in which
1025 ;;; case it is the old layout.
1026 (defun ensure-structure-class (info inherits old-context new-context
1027 &key compiler-layout)
1028 (multiple-value-bind (class old-layout)
1032 (class 'sb!xc:structure-class)
1033 (constructor 'make-structure-class))
1034 (dd-alternate-metaclass info)
1035 (declare (ignore name))
1036 (insured-find-class (dd-name info)
1037 (if (eq class 'sb!xc:structure-class)
1039 (typep x 'sb!xc:structure-class))
1041 (sb!xc:typep x (sb!xc:find-class class))))
1042 (fdefinition constructor)))
1043 (setf (class-direct-superclasses class)
1044 (if (eq (dd-name info) 'lisp-stream)
1045 ;; a hack to add STREAM as a superclass mixin to LISP-STREAMs
1046 (list (layout-class (svref inherits (1- (length inherits))))
1047 (layout-class (svref inherits (- (length inherits) 2))))
1048 (list (layout-class (svref inherits (1- (length inherits)))))))
1049 (let ((new-layout (make-layout :class class
1051 :depthoid (length inherits)
1052 :length (dd-length info)
1054 (old-layout (or compiler-layout old-layout)))
1057 (values class new-layout nil))
1058 (;; This clause corresponds to an assertion in REDEFINE-LAYOUT-WARNING
1059 ;; of classic CMU CL. I moved it out to here because it was only
1060 ;; exercised in this code path anyway. -- WHN 19990510
1061 (not (eq (layout-class new-layout) (layout-class old-layout)))
1062 (error "shouldn't happen: weird state of OLD-LAYOUT?"))
1063 ((not *type-system-initialized*)
1064 (setf (layout-info old-layout) info)
1065 (values class old-layout nil))
1066 ((redefine-layout-warning old-context
1069 (layout-length new-layout)
1070 (layout-inherits new-layout)
1071 (layout-depthoid new-layout))
1072 (values class new-layout old-layout))
1074 (let ((old-info (layout-info old-layout)))
1076 ((or defstruct-description)
1077 (cond ((redefine-structure-warning class old-info info)
1078 (values class new-layout old-layout))
1080 (setf (layout-info old-layout) info)
1081 (values class old-layout nil))))
1083 (setf (layout-info old-layout) info)
1084 (values class old-layout nil))
1086 (error "shouldn't happen! strange thing in LAYOUT-INFO:~% ~S"
1088 (values class new-layout old-layout)))))))))
1090 ;;; Blow away all the compiler info for the structure CLASS. Iterate
1091 ;;; over this type, clearing the compiler structure type info, and
1092 ;;; undefining all the associated functions.
1093 (defun undefine-structure (class)
1094 (let ((info (layout-info (class-layout class))))
1095 (when (defstruct-description-p info)
1096 (let ((type (dd-name info)))
1097 (setf (info :type :compiler-layout type) nil)
1098 (undefine-fun-name (dd-copier-name info))
1099 (undefine-fun-name (dd-predicate-name info))
1100 (dolist (slot (dd-slots info))
1101 (let ((fun (dsd-accessor-name slot)))
1102 (undefine-fun-name fun)
1103 (unless (dsd-read-only slot)
1104 (undefine-fun-name `(setf ,fun))))))
1105 ;; Clear out the SPECIFIER-TYPE cache so that subsequent
1106 ;; references are unknown types.
1107 (values-specifier-type-cache-clear)))
1110 ;;; Return a list of pairs (name . index). Used for :TYPE'd
1111 ;;; constructors to find all the names that we have to splice in &
1112 ;;; where. Note that these types don't have a layout, so we can't look
1113 ;;; at LAYOUT-INHERITS.
1114 (defun find-name-indices (defstruct)
1117 (do ((info defstruct
1118 (typed-structure-info-or-lose (first (dd-include info)))))
1119 ((not (dd-include info))
1124 (dolist (info infos)
1125 (incf i (or (dd-offset info) 0))
1126 (when (dd-named info)
1127 (res (cons (dd-name info) i)))
1128 (setq i (dd-length info)))))
1132 ;;;; slot accessors for raw slots
1134 ;;; Return info about how to read/write a slot in the value stored in
1135 ;;; OBJECT. This is also used by constructors (since we can't safely
1136 ;;; use the accessor function, since some slots are read-only). If
1137 ;;; supplied, DATA is a variable holding the raw-data vector.
1139 ;;; returned values:
1140 ;;; 1. accessor function name (SETFable)
1141 ;;; 2. index to pass to accessor.
1142 ;;; 3. object form to pass to accessor
1143 (defun slot-accessor-form (defstruct slot object &optional data)
1144 (let ((rtype (dsd-raw-type slot)))
1147 (single-float '%raw-ref-single)
1148 (double-float '%raw-ref-double)
1150 (long-float '%raw-ref-long)
1151 (complex-single-float '%raw-ref-complex-single)
1152 (complex-double-float '%raw-ref-complex-double)
1154 (complex-long-float '%raw-ref-complex-long)
1155 (unsigned-byte 'aref)
1157 (if (eq (dd-type defstruct) 'funcallable-structure)
1158 '%funcallable-instance-info
1163 (truncate (dsd-index slot) #!+x86 6 #!+sparc 8))
1166 (truncate (dsd-index slot) #!+x86 3 #!+sparc 4))
1168 (ash (dsd-index slot) -1))
1169 (complex-double-float
1170 (ash (dsd-index slot) -2))
1171 (complex-single-float
1172 (ash (dsd-index slot) -1))
1176 ((eq rtype t) object)
1179 `(truly-the (simple-array (unsigned-byte 32) (*))
1180 (%instance-ref ,object ,(dd-raw-index defstruct))))))))
1182 ;;; These functions are called to actually make a constructor after we
1183 ;;; have processed the arglist. The correct variant (according to the
1184 ;;; DD-TYPE) should be called. The function is defined with the
1185 ;;; specified name and arglist. Vars and Types are used for argument
1186 ;;; type declarations. Values are the values for the slots (in order.)
1188 ;;; This is split four ways because:
1189 ;;; 1] list & vector structures need "name" symbols stuck in at
1190 ;;; various weird places, whereas STRUCTURE structures have
1192 ;;; 2] We really want to use LIST to make list structures, instead of
1193 ;;; MAKE-LIST/(SETF ELT).
1194 ;;; 3] STRUCTURE structures can have raw slots that must also be
1195 ;;; allocated and indirectly referenced. We use SLOT-ACCESSOR-FORM
1196 ;;; to compute how to set the slots, which deals with raw slots.
1197 ;;; 4] Funcallable structures are weird.
1198 (defun create-vector-constructor
1199 (defstruct cons-name arglist vars types values)
1200 (let ((temp (gensym))
1201 (etype (dd-element-type defstruct)))
1202 `(defun ,cons-name ,arglist
1203 (declare ,@(mapcar #'(lambda (var type) `(type (and ,type ,etype) ,var))
1205 (let ((,temp (make-array ,(dd-length defstruct)
1206 :element-type ',(dd-element-type defstruct))))
1207 ,@(mapcar #'(lambda (x)
1208 `(setf (aref ,temp ,(cdr x)) ',(car x)))
1209 (find-name-indices defstruct))
1210 ,@(mapcar #'(lambda (dsd value)
1211 `(setf (aref ,temp ,(dsd-index dsd)) ,value))
1212 (dd-slots defstruct) values)
1214 (defun create-list-constructor
1215 (defstruct cons-name arglist vars types values)
1216 (let ((vals (make-list (dd-length defstruct) :initial-element nil)))
1217 (dolist (x (find-name-indices defstruct))
1218 (setf (elt vals (cdr x)) `',(car x)))
1219 (loop for dsd in (dd-slots defstruct) and val in values do
1220 (setf (elt vals (dsd-index dsd)) val))
1222 `(defun ,cons-name ,arglist
1223 (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
1226 (defun create-structure-constructor
1227 (defstruct cons-name arglist vars types values)
1228 (let* ((temp (gensym))
1229 (raw-index (dd-raw-index defstruct))
1230 (n-raw-data (when raw-index (gensym))))
1231 `(defun ,cons-name ,arglist
1232 (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
1234 (let ((,temp (truly-the ,(dd-name defstruct)
1235 (%make-instance ,(dd-length defstruct))))
1238 (make-array ,(dd-raw-length defstruct)
1239 :element-type '(unsigned-byte 32))))))
1240 (setf (%instance-layout ,temp)
1241 (%delayed-get-compiler-layout ,(dd-name defstruct)))
1243 `((setf (%instance-ref ,temp ,raw-index) ,n-raw-data)))
1244 ,@(mapcar (lambda (dsd value)
1245 (multiple-value-bind (accessor index data)
1246 (slot-accessor-form defstruct dsd temp n-raw-data)
1247 `(setf (,accessor ,data ,index) ,value)))
1248 (dd-slots defstruct)
1251 (defun create-fin-constructor
1252 (defstruct cons-name arglist vars types values)
1253 (let ((temp (gensym)))
1254 `(defun ,cons-name ,arglist
1255 (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
1257 (let ((,temp (truly-the
1258 ,(dd-name defstruct)
1259 (%make-funcallable-instance
1260 ,(dd-length defstruct)
1261 (%delayed-get-compiler-layout ,(dd-name defstruct))))))
1262 ,@(mapcar #'(lambda (dsd value)
1263 `(setf (%funcallable-instance-info
1264 ,temp ,(dsd-index dsd))
1266 (dd-slots defstruct) values)
1269 ;;; Create a default (non-BOA) keyword constructor.
1270 (defun create-keyword-constructor (defstruct creator)
1271 (collect ((arglist (list '&key))
1274 (dolist (slot (dd-slots defstruct))
1275 (let ((dum (gensym))
1276 (name (dsd-name slot)))
1277 (arglist `((,(keywordicate name) ,dum) ,(dsd-default slot)))
1278 (types (dsd-type slot))
1281 defstruct (dd-default-constructor defstruct)
1282 (arglist) (vals) (types) (vals))))
1284 ;;; Given a structure and a BOA constructor spec, call CREATOR with
1285 ;;; the appropriate args to make a constructor.
1286 (defun create-boa-constructor (defstruct boa creator)
1287 (multiple-value-bind (req opt restp rest keyp keys allowp aux)
1288 (sb!kernel:parse-lambda-list (second boa))
1292 (labels ((get-slot (name)
1293 (let ((res (find name (dd-slots defstruct)
1297 (values (dsd-type res) (dsd-default res))
1300 (multiple-value-bind (type default) (get-slot arg)
1301 (arglist `(,arg ,default))
1307 (types (get-slot arg)))
1310 (arglist '&optional)
1314 (name &optional (def (nth-value 1 (get-slot name))))
1316 (arglist `(,name ,def))
1318 (types (get-slot name))))
1320 (do-default arg)))))
1323 (arglist '&rest rest)
1331 (destructuring-bind (wot &optional (def nil def-p)) key
1332 (let ((name (if (consp wot)
1333 (destructuring-bind (key var) wot
1334 (declare (ignore key))
1337 (multiple-value-bind (type slot-def) (get-slot name)
1338 (arglist `(,wot ,(if def-p def slot-def)))
1343 (when allowp (arglist '&allow-other-keys))
1348 (let* ((arg (if (consp arg) arg (list arg)))
1352 (types (get-slot var))))))
1354 (funcall creator defstruct (first boa)
1355 (arglist) (vars) (types)
1356 (mapcar #'(lambda (slot)
1357 (or (find (dsd-name slot) (vars) :test #'string=)
1358 (dsd-default slot)))
1359 (dd-slots defstruct))))))
1361 ;;; Grovel the constructor options, and decide what constructors (if
1363 (defun constructor-definitions (defstruct)
1364 (let ((no-constructors nil)
1367 (creator (ecase (dd-type defstruct)
1368 (structure #'create-structure-constructor)
1369 (funcallable-structure #'create-fin-constructor)
1370 (vector #'create-vector-constructor)
1371 (list #'create-list-constructor))))
1372 (dolist (constructor (dd-constructors defstruct))
1373 (destructuring-bind (name &optional (boa-ll nil boa-p)) constructor
1374 (declare (ignore boa-ll))
1375 (cond ((not name) (setq no-constructors t))
1376 (boa-p (push constructor boas))
1377 (t (push name defaults)))))
1379 (when no-constructors
1380 (when (or defaults boas)
1381 (error "(:CONSTRUCTOR NIL) combined with other :CONSTRUCTORs"))
1382 (return-from constructor-definitions ()))
1384 (unless (or defaults boas)
1385 (push (symbolicate "MAKE-" (dd-name defstruct)) defaults))
1389 (let ((cname (first defaults)))
1390 (setf (dd-default-constructor defstruct) cname)
1391 (res (create-keyword-constructor defstruct creator))
1392 (dolist (other-name (rest defaults))
1393 (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
1394 (res `(declaim (ftype function ',other-name))))))
1397 (res (create-boa-constructor defstruct boa creator)))
1401 ;;;; finalizing bootstrapping
1403 ;;; early structure placeholder definitions: Set up layout and class
1404 ;;; data for structures which are needed early.
1406 '#.(sb-cold:read-from-file
1407 "src/code/early-defstruct-args.lisp-expr"))
1408 (let* ((dd (parse-defstruct-name-and-options-and-slot-descriptions
1411 (inherits (inherits-for-structure dd)))
1412 (%compiler-defstruct dd inherits)))
1414 (/show0 "code/defstruct.lisp end of file")