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")
20 ;;; Return the compiler layout for Name. (The class referred to by
21 ;;; NAME must be a structure-like class.)
22 (defun compiler-layout-or-lose (name)
23 (let ((res (info :type :compiler-layout name)))
25 (error "Class is not yet defined or was undefined: ~S" name))
26 ((not (typep (layout-info res) 'defstruct-description))
27 (error "Class is not a structure class: ~S" name))
30 ;;; Delay looking for compiler-layout until the constructor is being
31 ;;; compiled, since it doesn't exist until after the eval-when
32 ;;; (compile) is compiled.
33 (sb!xc:defmacro %delayed-get-compiler-layout (name)
34 `',(compiler-layout-or-lose name))
36 ;;; Get layout right away.
37 (sb!xc:defmacro compile-time-find-layout (name)
40 ;;; re. %DELAYED-GET-COMPILER-LAYOUT and COMPILE-TIME-FIND-LAYOUT, above..
42 ;;; FIXME: Perhaps both should be defined with DEFMACRO-MUNDANELY?
43 ;;; FIXME: Do we really need both? If so, their names and implementations
44 ;;; should probably be tweaked to be more parallel.
46 ;;; The DEFSTRUCT-DESCRIPTION structure holds compile-time information about a
48 (def!struct (defstruct-description
50 (:make-load-form-fun just-dump-it-normally)
51 #-sb-xc-host (:pure t)
52 (:constructor make-defstruct-description (name)))
53 ;; name of the structure
54 (name (required-argument) :type symbol)
55 ;; documentation on the structure
56 (doc nil :type (or string null))
57 ;; prefix for slot names. If NIL, none.
58 (conc-name (concat-pnames name '-) :type (or symbol null))
59 ;; the name of the primary standard keyword constructor, or NIL if none
60 (default-constructor nil :type (or symbol null))
61 ;; all the explicit :CONSTRUCTOR specs, with name defaulted
62 (constructors () :type list)
63 ;; name of copying function
64 (copier (concat-pnames 'copy- name) :type (or symbol null))
65 ;; name of type predicate
66 (predicate (concat-pnames name '-p) :type (or symbol null))
67 ;; the arguments to the :INCLUDE option, or NIL if no included
69 (include nil :type list)
70 ;; The arguments to the :ALTERNATE-METACLASS option (an extension
71 ;; used to define structure-like objects with an arbitrary
72 ;; superclass and that may not have STRUCTURE-CLASS as the
73 ;; metaclass.) Syntax is:
74 ;; (superclass-name metaclass-name metaclass-constructor)
75 (alternate-metaclass nil :type list)
76 ;; a list of DEFSTRUCT-SLOT-DESCRIPTION objects for all slots
77 ;; (including included ones)
79 ;; number of elements we've allocated (See also RAW-LENGTH.)
80 (length 0 :type index)
81 ;; General kind of implementation.
82 (type 'structure :type (member structure vector list
83 funcallable-structure))
85 ;; The next three slots are for :TYPE'd structures (which aren't
86 ;; classes, CLASS-STRUCTURE-P = NIL)
88 ;; vector element type
90 ;; T if :NAMED was explicitly specified, NIL otherwise
91 (named nil :type boolean)
92 ;; any INITIAL-OFFSET option on this direct type
93 (offset nil :type (or index null))
95 ;; the argument to the PRINT-FUNCTION option, or NIL if a
96 ;; PRINT-FUNCTION option was given with no argument, or 0 if no
97 ;; PRINT-FUNCTION option was given
98 (print-function 0 :type (or cons symbol (member 0)))
99 ;; the argument to the PRINT-OBJECT option, or NIL if a PRINT-OBJECT
100 ;; option was given with no argument, or 0 if no PRINT-OBJECT option
102 (print-object 0 :type (or cons symbol (member 0)))
103 ;; the index of the raw data vector and the number of words in it.
104 ;; NIL and 0 if not allocated yet.
105 (raw-index nil :type (or index null))
106 (raw-length 0 :type index)
107 ;; the value of the :PURE option, or :UNSPECIFIED. This is only
108 ;; meaningful if CLASS-STRUCTURE-P = T.
109 (pure :unspecified :type (member t nil :substructure :unspecified)))
110 (def!method print-object ((x defstruct-description) stream)
111 (print-unreadable-object (x stream :type t)
112 (prin1 (dd-name x) stream)))
114 ;;; A DEFSTRUCT-SLOT-DESCRIPTION holds compile-time information about
115 ;;; a structure slot.
116 (def!struct (defstruct-slot-description
117 (:make-load-form-fun just-dump-it-normally)
120 #-sb-xc-host (:pure t))
121 ;; string name of slot
123 ;; its position in the implementation sequence
124 (index (required-argument) :type fixnum)
125 ;; Name of accessor, or NIL if this accessor has the same name as an
126 ;; inherited accessor (which we don't want to shadow.)
128 default ; default value expression
129 (type t) ; declared type specifier
130 ;; If this object does not describe a raw slot, this value is T.
132 ;; If this object describes a raw slot, this value is the type of the
133 ;; value that the raw slot holds. Mostly. (KLUDGE: If the raw slot has
134 ;; type (UNSIGNED-BYTE 32), the value here is UNSIGNED-BYTE, not
135 ;; (UNSIGNED-BYTE 32).)
136 (raw-type t :type (member t single-float double-float
137 #!+long-float long-float
138 complex-single-float complex-double-float
139 #!+long-float complex-long-float
141 (read-only nil :type (member t nil)))
142 (def!method print-object ((x defstruct-slot-description) stream)
143 (print-unreadable-object (x stream :type t)
144 (prin1 (dsd-name x) stream)))
146 ;;; Is DEFSTRUCT a structure with a class?
147 (defun class-structure-p (defstruct)
148 (member (dd-type defstruct) '(structure funcallable-structure)))
150 ;;; Return the name of a defstruct slot as a symbol. We store it as a
151 ;;; string to avoid creating lots of worthless symbols at load time.
152 (defun dsd-name (dsd)
153 (intern (string (dsd-%name dsd))
154 (if (dsd-accessor dsd)
155 (symbol-package (dsd-accessor dsd))
158 ;;;; typed (non-class) structures
160 ;;; Return a type specifier we can use for testing :TYPE'd structures.
161 (defun dd-lisp-type (defstruct)
162 (ecase (dd-type defstruct)
164 (vector `(simple-array ,(dd-element-type defstruct) (*)))))
166 ;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its
167 ;;;; close personal friend SB!XC:DEFSTRUCT)
169 ;;; Return a list of forms to install print and make-load-form funs, mentioning
170 ;;; them in the expansion so that they can be compiled.
171 (defun class-method-definitions (defstruct)
172 (let ((name (dd-name defstruct)))
174 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant
175 ;; class names which creates fast but non-cold-loadable,
176 ;; non-compact code. In this context, we'd rather have
177 ;; compact, cold-loadable code. -- WHN 19990928
178 (declare (notinline sb!xc:find-class))
179 ,@(let ((pf (dd-print-function defstruct))
180 (po (dd-print-object defstruct))
183 ;; Giving empty :PRINT-OBJECT or :PRINT-FUNCTION options
184 ;; leaves PO or PF equal to NIL. The user-level effect is
185 ;; to generate a PRINT-OBJECT method specialized for the type,
186 ;; implementing the default #S structure-printing behavior.
187 (when (or (eq pf nil) (eq po nil))
188 (setf pf '(default-structure-print)
190 (flet (;; Given an arg from a :PRINT-OBJECT or :PRINT-FUNCTION
191 ;; option, return the value to pass as an arg to FUNCTION.
193 (destructuring-bind (function-name) oarg
195 (cond ((not (eql pf 0))
196 `((def!method print-object ((,x ,name) ,s)
197 (funcall #',(farg pf) ,x ,s *current-level*))))
199 `((def!method print-object ((,x ,name) ,s)
200 (funcall #',(farg po) ,x ,s))))
202 ,@(let ((pure (dd-pure defstruct)))
204 `((setf (layout-pure (class-layout
205 (sb!xc:find-class ',name)))
207 ((eq pure :substructure)
208 `((setf (layout-pure (class-layout
209 (sb!xc:find-class ',name)))
211 ,@(let ((def-con (dd-default-constructor defstruct)))
212 (when (and def-con (not (dd-alternate-metaclass defstruct)))
213 `((setf (structure-class-constructor (sb!xc:find-class ',name))
215 ;; FIXME: MAKE-LOAD-FORM is supposed to be handled here, too.
217 ;;; FIXME: I really would like to make structure accessors less special,
218 ;;; just ordinary inline functions. (Or perhaps inline functions with special
219 ;;; compact implementations of their expansions, to avoid bloating the system.)
221 ;;; shared logic for CL:DEFSTRUCT and SB!XC:DEFSTRUCT
223 ;;; FIXME: There should be some way to make this not be present in the
224 ;;; target executable, with EVAL-WHEN (COMPILE EXECUTE) and all that good
225 ;;; stuff, but for now I can't be bothered because of the messiness of
226 ;;; using CL:DEFMACRO in one case and SB!XC:DEFMACRO in another case.
227 ;;; Perhaps I could dodge this by defining it as an inline function instead?
228 ;;; Or perhaps just use MACROLET? I tried MACROLET and got nowhere and thought
229 ;;; I was tripping over either a compiler bug or ANSI weirdness, but this
230 ;;; test case seems to work in Debian CMU CL 2.4.9:
231 ;;; (macrolet ((emit-printer () ''(print "********")))
232 ;;; (defmacro fizz () (emit-printer)))
238 (defmacro expander-for-defstruct (name-and-options
240 expanding-into-code-for-xc-host-p)
241 `(let ((name-and-options ,name-and-options)
242 (slot-descriptions ,slot-descriptions)
243 (expanding-into-code-for-xc-host-p
244 ,expanding-into-code-for-xc-host-p))
245 (let* ((dd (parse-name-and-options-and-slot-descriptions
249 (if (class-structure-p dd)
250 (let ((inherits (inherits-for-structure dd)))
252 (eval-when (:compile-toplevel :load-toplevel :execute)
253 (%compiler-only-defstruct ',dd ',inherits))
254 (%defstruct ',dd ',inherits)
255 ,@(when (eq (dd-type dd) 'structure)
256 `((%compiler-defstruct ',dd)))
257 ,@(unless expanding-into-code-for-xc-host-p
258 (append (raw-accessor-definitions dd)
259 (predicate-definitions dd)
260 ;; FIXME: We've inherited from CMU CL nonparallel
261 ;; code for creating copiers for typed and untyped
262 ;; structures. This should be fixed.
263 ;(copier-definition dd)
264 (constructor-definitions dd)
265 (class-method-definitions dd)))
268 (eval-when (:compile-toplevel :load-toplevel :execute)
269 (setf (info :typed-structure :info ',name) ',dd))
270 ,@(unless expanding-into-code-for-xc-host-p
271 (append (typed-accessor-definitions dd)
272 (typed-predicate-definitions dd)
273 (typed-copier-definitions dd)
274 (constructor-definitions dd)))
277 (sb!xc:defmacro defstruct (name-and-options &rest slot-descriptions)
279 "DEFSTRUCT {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)}
280 Define the structure type Name. Instances are created by MAKE-<name>, which
281 takes keyword arguments allowing initial slot values to the specified.
282 A SETF'able function <name>-<slot> is defined for each slot to read and
283 write slot values. <name>-p is a type predicate.
285 Popular DEFSTRUCT options (see manual for others):
289 Specify the name for the constructor or predicate.
291 (:CONSTRUCTOR Name Lambda-List)
292 Specify the name and arguments for a BOA constructor
293 (which is more efficient when keyword syntax isn't necessary.)
295 (:INCLUDE Supertype Slot-Spec*)
296 Make this type a subtype of the structure type Supertype. The optional
297 Slot-Specs override inherited slot options.
302 Asserts that the value of this slot is always of the specified type.
305 If true, no setter function is defined for this slot."
306 (expander-for-defstruct name-and-options slot-descriptions nil))
308 (defmacro sb!xc:defstruct (name-and-options &rest slot-descriptions)
310 "Cause information about a target structure to be built into the
312 (expander-for-defstruct name-and-options slot-descriptions t))
314 ;;;; functions to create various parts of DEFSTRUCT definitions
316 ;;; Catch requests to mess up definitions in COMMON-LISP.
318 (eval-when (:compile-toplevel :load-toplevel :execute)
319 (defun protect-cl (symbol)
320 (when (and *cold-init-complete-p*
321 (eq (symbol-package symbol) *cl-package*))
322 (cerror "Go ahead and patch the system."
323 "attempting to modify a symbol in the COMMON-LISP package: ~S"
326 ;;; Return forms to define readers and writers for raw slots as inline
328 (defun raw-accessor-definitions (dd)
329 (let* ((name (dd-name dd)))
331 (dolist (slot (dd-slots dd))
332 (let ((stype (dsd-type slot))
333 (accname (dsd-accessor slot))
334 (argname (gensym "ARG"))
335 (nvname (gensym "NEW-VALUE-")))
336 (multiple-value-bind (accessor offset data)
337 (slot-accessor-form dd slot argname)
338 ;; When accessor exists and is raw
339 (when (and accname (not (eq accessor '%instance-ref)))
340 (res `(declaim (inline ,accname)))
341 (res `(declaim (ftype (function (,name) ,stype) ,accname)))
342 (res `(defun ,accname (,argname)
343 (truly-the ,stype (,accessor ,data ,offset))))
344 (unless (dsd-read-only slot)
345 (res `(declaim (inline (setf ,accname))))
346 (res `(declaim (ftype (function (,stype ,name) ,stype)
348 ;; FIXME: I rewrote this somewhat from the CMU CL definition.
349 ;; Do some basic tests to make sure that reading and writing
350 ;; raw slots still works correctly.
351 (res `(defun (setf ,accname) (,nvname ,argname)
352 (setf (,accessor ,data ,offset) ,nvname)
356 ;;; Return a list of forms which create a predicate for an untyped DEFSTRUCT.
357 (defun predicate-definitions (dd)
358 (let ((pred (dd-predicate dd))
361 (if (eq (dd-type dd) 'funcallable-structure)
362 ;; FIXME: Why does this need to be special-cased for
363 ;; FUNCALLABLE-STRUCTURE? CMU CL did it, but without explanation.
364 ;; Could we do without it? What breaks if we do? Or could we
365 ;; perhaps get by with no predicates for funcallable structures?
366 `((declaim (inline ,pred))
367 (defun ,pred (,argname) (typep ,argname ',(dd-name dd))))
368 `((protect-cl ',pred)
369 (declaim (inline ,pred))
370 (defun ,pred (,argname)
371 (declare (optimize (speed 3) (safety 0)))
372 (typep-to-layout ,argname
373 (compile-time-find-layout ,(dd-name dd)))))))))
375 ;;; Return a list of forms which create a predicate function for a typed
377 (defun typed-predicate-definitions (defstruct)
378 (let ((name (dd-name defstruct))
379 (pred (dd-predicate defstruct))
381 (when (and pred (dd-named defstruct))
382 (let ((ltype (dd-lisp-type defstruct)))
383 `((defun ,pred (,argname)
384 (and (typep ,argname ',ltype)
385 (eq (elt (the ,ltype ,argname)
386 ,(cdr (car (last (find-name-indices defstruct)))))
389 ;;; FIXME: We've inherited from CMU CL code to do typed structure copiers
390 ;;; in a completely different way than untyped structure copiers. Fix this.
391 ;;; (This function was my first attempt to fix this, but I stopped before
392 ;;; figuring out how to install it completely and remove the parallel
393 ;;; code which simply SETF's the FDEFINITION of the DD-COPIER name.
395 ;;; Return the copier definition for an untyped DEFSTRUCT.
396 (defun copier-definition (dd)
397 (when (and (dd-copier dd)
398 ;; FUNCALLABLE-STRUCTUREs don't need copiers, and this
399 ;; implementation wouldn't work for them anyway, since
400 ;; COPY-STRUCTURE returns a STRUCTURE-OBJECT and they're not.
401 (not (eq (dd-type info) 'funcallable-structure)))
402 (let ((argname (gensym)))
404 (protect-cl ',(dd-copier dd))
405 (defun ,(dd-copier dd) (,argname)
406 (declare (type ,(dd-name dd) ,argname))
407 (copy-structure ,argname))))))
410 ;;; Return a list of forms to create a copier function of a typed DEFSTRUCT.
411 (defun typed-copier-definitions (defstruct)
412 (when (dd-copier defstruct)
413 `((setf (fdefinition ',(dd-copier defstruct)) #'copy-seq)
414 (declaim (ftype function ,(dd-copier defstruct))))))
416 ;;; Return a list of function definitions for accessing and setting the
417 ;;; slots of a typed DEFSTRUCT. The functions are proclaimed to be inline,
418 ;;; and the types of their arguments and results are declared as well. We
419 ;;; count on the compiler to do clever things with ELT.
420 (defun typed-accessor-definitions (defstruct)
422 (let ((ltype (dd-lisp-type defstruct)))
423 (dolist (slot (dd-slots defstruct))
424 (let ((name (dsd-accessor slot))
425 (index (dsd-index slot))
426 (slot-type `(and ,(dsd-type slot)
427 ,(dd-element-type defstruct))))
428 (stuff `(proclaim '(inline ,name (setf ,name))))
429 ;; FIXME: The arguments in the next two DEFUNs should be
430 ;; gensyms. (Otherwise e.g. if NEW-VALUE happened to be the
431 ;; name of a special variable, things could get weird.)
432 (stuff `(defun ,name (structure)
433 (declare (type ,ltype structure))
434 (the ,slot-type (elt structure ,index))))
435 (unless (dsd-read-only slot)
437 `(defun (setf ,name) (new-value structure)
438 (declare (type ,ltype structure) (type ,slot-type new-value))
439 (setf (elt structure ,index) new-value)))))))
444 (defun require-no-print-options-so-far (defstruct)
445 (unless (and (eql (dd-print-function defstruct) 0)
446 (eql (dd-print-object defstruct) 0))
447 (error "no more than one of the following options may be specified:
448 :PRINT-FUNCTION, :PRINT-OBJECT, :TYPE")))
450 ;;; Parse a single defstruct option and store the results in DEFSTRUCT.
451 (defun parse-1-option (option defstruct)
452 (let ((args (rest option))
453 (name (dd-name defstruct)))
456 (destructuring-bind (conc-name) args
457 (setf (dd-conc-name defstruct)
458 (if (symbolp conc-name)
460 (make-symbol (string conc-name))))))
462 (destructuring-bind (&optional (cname (concat-pnames 'make- name))
465 (push (cons cname stuff) (dd-constructors defstruct))))
467 (destructuring-bind (&optional (copier (concat-pnames 'copy- name)))
469 (setf (dd-copier defstruct) copier)))
471 (destructuring-bind (&optional (pred (concat-pnames name '-p))) args
472 (setf (dd-predicate defstruct) pred)))
474 (when (dd-include defstruct)
475 (error "more than one :INCLUDE option"))
476 (setf (dd-include defstruct) args))
477 (:alternate-metaclass
478 (setf (dd-alternate-metaclass defstruct) args))
480 (require-no-print-options-so-far defstruct)
481 (setf (dd-print-function defstruct)
482 (the (or symbol cons) args)))
484 (require-no-print-options-so-far defstruct)
485 (setf (dd-print-object defstruct)
486 (the (or symbol cons) args)))
488 (destructuring-bind (type) args
489 (cond ((eq type 'funcallable-structure)
490 (setf (dd-type defstruct) type))
491 ((member type '(list vector))
492 (setf (dd-element-type defstruct) 't)
493 (setf (dd-type defstruct) type))
494 ((and (consp type) (eq (first type) 'vector))
495 (destructuring-bind (vector vtype) type
496 (declare (ignore vector))
497 (setf (dd-element-type defstruct) vtype)
498 (setf (dd-type defstruct) 'vector)))
500 (error "~S is a bad :TYPE for Defstruct." type)))))
502 (error "The DEFSTRUCT option :NAMED takes no arguments."))
504 (destructuring-bind (offset) args
505 (setf (dd-offset defstruct) offset)))
507 (destructuring-bind (fun) args
508 (setf (dd-pure defstruct) fun)))
509 (t (error "unknown DEFSTRUCT option:~% ~S" option)))))
511 ;;; Given name and options, return a DD holding that info.
512 (eval-when (:compile-toplevel :load-toplevel :execute)
513 (defun parse-name-and-options (name-and-options)
514 (destructuring-bind (name &rest options) name-and-options
515 (let ((defstruct (make-defstruct-description name)))
516 (dolist (option options)
517 (cond ((consp option)
518 (parse-1-option option defstruct))
520 (setf (dd-named defstruct) t))
521 ((member option '(:constructor :copier :predicate :named))
522 (parse-1-option (list option) defstruct))
524 (error "unrecognized DEFSTRUCT option: ~S" option))))
526 (case (dd-type defstruct)
528 (when (dd-offset defstruct)
529 (error ":OFFSET can't be specified unless :TYPE is specified."))
530 (unless (dd-include defstruct)
531 (incf (dd-length defstruct))))
532 (funcallable-structure)
534 (require-no-print-options-so-far defstruct)
535 (when (dd-named defstruct)
536 (incf (dd-length defstruct)))
537 (let ((offset (dd-offset defstruct)))
538 (when offset (incf (dd-length defstruct) offset)))))
540 (when (dd-include defstruct)
541 (do-inclusion-stuff defstruct))
545 ;;; Given name and options and slot descriptions (and possibly doc
546 ;;; string at the head of slot descriptions) return a DD holding that
548 (defun parse-name-and-options-and-slot-descriptions (name-and-options
550 (/noshow "PARSE-NAME-AND-OPTIONS-AND-SLOT-DESCRIPTIONS" name-and-options)
551 (let ((result (parse-name-and-options (if (atom name-and-options)
552 (list name-and-options)
554 (when (stringp (car slot-descriptions))
555 (setf (dd-doc result) (pop slot-descriptions)))
556 (dolist (slot slot-descriptions)
557 (allocate-1-slot result (parse-1-dsd result slot)))
562 ;;;; stuff to parse slot descriptions
564 ;;; Parse a slot description for DEFSTRUCT, add it to the description
565 ;;; and return it. If supplied, ISLOT is a pre-initialized DSD that we
566 ;;; modify to get the new slot. This is supplied when handling
567 ;;; included slots. If the new accessor name is already an accessor
568 ;;; for same slot in some included structure, then set the
569 ;;; DSD-ACCESSOR to NIL so that we don't clobber the more general
571 (defun parse-1-dsd (defstruct spec &optional
572 (islot (make-defstruct-slot-description :%name ""
575 (multiple-value-bind (name default default-p type type-p read-only ro-p)
580 &optional (default nil default-p)
581 &key (type nil type-p) (read-only nil ro-p))
585 (uncross type) type-p
588 (when (keywordp spec)
589 ;; FIXME: should be style warning
590 (warn "Keyword slot name indicates probable syntax ~
591 error in DEFSTRUCT -- ~S."
595 (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)
596 (error 'program-error
597 :format-control "duplicate slot name ~S"
598 :format-arguments (list name)))
599 (setf (dsd-%name islot) (string name))
600 (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot)))
602 (let* ((accname (concat-pnames (dd-conc-name defstruct) name))
603 (existing (info :function :accessor-for accname)))
604 (if (and (structure-class-p existing)
605 (not (eq (sb!xc:class-name existing) (dd-name defstruct)))
606 (string= (dsd-%name (find accname
609 (class-layout existing)))
610 :key #'dsd-accessor))
612 (setf (dsd-accessor islot) nil)
613 (setf (dsd-accessor islot) accname)))
616 (setf (dsd-default islot) default))
618 (setf (dsd-type islot)
619 (if (eq (dsd-type islot) 't)
621 `(and ,(dsd-type islot) ,type))))
624 (setf (dsd-read-only islot) t)
625 (when (dsd-read-only islot)
626 (error "Slot ~S is :READ-ONLY in parent and must be :READ-ONLY in subtype ~S."
631 ;;; When a value of type TYPE is stored in a structure, should it be
632 ;;; stored in a raw slot? Return (VALUES RAW? RAW-TYPE WORDS), where
633 ;;; RAW? is true if TYPE should be stored in a raw slot.
634 ;;; RAW-TYPE is the raw slot type, or NIL if no raw slot.
635 ;;; WORDS is the number of words in the raw slot, or NIL if no raw slot.
636 (defun structure-raw-slot-type-and-size (type)
637 (/noshow "in STRUCTURE-RAW-SLOT-TYPE-AND-SIZE" type (sb!xc:subtypep type 'fixnum))
639 (;; FIXME: For now we suppress raw slots, since there are various
640 ;; issues about the way that the cross-compiler handles them.
641 (not (boundp '*dummy-placeholder-to-stop-compiler-warnings*))
642 (values nil nil nil))
643 ((and (sb!xc:subtypep type '(unsigned-byte 32))
644 (multiple-value-bind (fixnum? fixnum-certain?)
645 (sb!xc:subtypep type 'fixnum)
646 (/noshow fixnum? fixnum-certain?)
647 ;; (The extra test for FIXNUM-CERTAIN? here is
648 ;; intended for bootstrapping the system. In
649 ;; particular, in sbcl-0.6.2, we set up LAYOUT before
650 ;; FIXNUM is defined, and so could bogusly end up
651 ;; putting INDEX-typed values into raw slots if we
652 ;; didn't test FIXNUM-CERTAIN?.)
653 (and (not fixnum?) fixnum-certain?)))
654 (values t 'unsigned-byte 1))
655 ((sb!xc:subtypep type 'single-float)
656 (values t 'single-float 1))
657 ((sb!xc:subtypep type 'double-float)
658 (values t 'double-float 2))
660 ((sb!xc:subtypep type 'long-float)
661 (values t 'long-float #!+x86 3 #!+sparc 4))
662 ((sb!xc:subtypep type '(complex single-float))
663 (values t 'complex-single-float 2))
664 ((sb!xc:subtypep type '(complex double-float))
665 (values t 'complex-double-float 4))
667 ((sb!xc:subtypep type '(complex long-float))
668 (values t 'complex-long-float #!+x86 6 #!+sparc 8))
670 (values nil nil nil))))
672 ;;; Allocate storage for a DSD in DEFSTRUCT. This is where we decide
673 ;;; whether a slot is raw or not. If raw, and we haven't allocated a
674 ;;; raw-index yet for the raw data vector, then do it. Raw objects are
675 ;;; aligned on the unit of their size.
676 (defun allocate-1-slot (defstruct dsd)
677 (multiple-value-bind (raw? raw-type words)
678 (if (eq (dd-type defstruct) 'structure)
679 (structure-raw-slot-type-and-size (dsd-type dsd))
680 (values nil nil nil))
681 (/noshow "ALLOCATE-1-SLOT" dsd raw? raw-type words)
683 (setf (dsd-index dsd) (dd-length defstruct))
684 (incf (dd-length defstruct)))
686 (unless (dd-raw-index defstruct)
687 (setf (dd-raw-index defstruct) (dd-length defstruct))
688 (incf (dd-length defstruct)))
689 (let ((off (rem (dd-raw-length defstruct) words)))
691 (incf (dd-raw-length defstruct) (- words off))))
692 (setf (dsd-raw-type dsd) raw-type)
693 (setf (dsd-index dsd) (dd-raw-length defstruct))
694 (incf (dd-raw-length defstruct) words))))
697 (defun typed-structure-info-or-lose (name)
698 (or (info :typed-structure :info name)
699 (error ":TYPE'd DEFSTRUCT ~S not found for inclusion." name)))
701 ;;; Process any included slots pretty much like they were specified.
702 ;;; Also inherit various other attributes.
703 (defun do-inclusion-stuff (defstruct)
705 (included-name &rest modified-slots)
706 (dd-include defstruct)
707 (let* ((type (dd-type defstruct))
709 (if (class-structure-p defstruct)
710 (layout-info (compiler-layout-or-lose included-name))
711 (typed-structure-info-or-lose included-name))))
712 (unless (and (eq type (dd-type included-structure))
713 (type= (specifier-type (dd-element-type included-structure))
714 (specifier-type (dd-element-type defstruct))))
715 (error ":TYPE option mismatch between structures ~S and ~S."
716 (dd-name defstruct) included-name))
718 (incf (dd-length defstruct) (dd-length included-structure))
719 (when (class-structure-p defstruct)
720 (let ((mc (rest (dd-alternate-metaclass included-structure))))
721 (when (and mc (not (dd-alternate-metaclass defstruct)))
722 (setf (dd-alternate-metaclass defstruct)
723 (cons included-name mc))))
724 (when (eq (dd-pure defstruct) :unspecified)
725 (setf (dd-pure defstruct) (dd-pure included-structure)))
726 (setf (dd-raw-index defstruct) (dd-raw-index included-structure))
727 (setf (dd-raw-length defstruct) (dd-raw-length included-structure)))
729 (dolist (islot (dd-slots included-structure))
730 (let* ((iname (dsd-name islot))
731 (modified (or (find iname modified-slots
732 :key #'(lambda (x) (if (atom x) x (car x)))
735 (parse-1-dsd defstruct modified (copy-structure islot)))))))
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 slot))
776 (unless (dsd-read-only slot)
777 (fmakunbound `(setf ,(dsd-accessor 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 slot)
791 (eq (dsd-raw-type slot) t))
792 (protect-cl (dsd-accessor slot))
793 (setf (symbol-function (dsd-accessor slot))
794 (structure-slot-getter layout dsd))
795 (unless (dsd-read-only slot)
796 (setf (fdefinition `(setf ,(dsd-accessor slot)))
797 (structure-slot-setter layout dsd))))))
799 ;; FIXME: See comment on corresponding code in %%COMPILER-DEFSTRUCT.
801 (when (dd-predicate info)
802 (protect-cl (dd-predicate info))
803 (setf (symbol-function (dd-predicate info))
805 (declare (optimize (speed 3) (safety 0)))
806 (typep-to-layout object layout))))
809 (when (dd-copier info)
810 (protect-cl (dd-copier info))
811 (setf (symbol-function (dd-copier info))
812 #'(lambda (structure)
813 (declare (optimize (speed 3) (safety 0)))
814 (flet ((layout-test (structure)
815 (typep-to-layout structure layout)))
816 (unless (layout-test structure)
817 (error 'simple-type-error
819 :expected-type '(satisfies layout-test)
821 "Structure for copier is not a ~S:~% ~S"
823 (list (sb!xc:class-name (layout-class layout))
825 (copy-structure structure))))))
828 (setf (fdocumentation (dd-name info) 'type) (dd-doc info)))
832 ;;; This function is called at compile-time to do the
833 ;;; compile-time-only actions for defining a structure type. It
834 ;;; installs the class in the type system in a similar way to
835 ;;; %DEFSTRUCT, but is quieter and safer in the case of redefinition.
837 ;;; The comments for the classic CMU CL version of this function said
838 ;;; that EVAL-WHEN doesn't do the right thing when nested or
839 ;;; non-top-level, and so CMU CL had the function magically called by
840 ;;; the compiler. Unfortunately, this doesn't do the right thing
841 ;;; either: compiling a function (DEFUN FOO () (DEFSTRUCT FOO X Y))
842 ;;; causes the class FOO to become defined, even though FOO is never
843 ;;; loaded or executed. Even more unfortunately, I've been unable to
844 ;;; come up with any EVAL-WHEN tricks which work -- I finally gave up
845 ;;; on this approach when trying to get the system to cross-compile
846 ;;; error.lisp. (Just because I haven't found it doesn't mean that it
847 ;;; doesn't exist, of course. Alas, I continue to have some trouble
848 ;;; understanding compile/load semantics in Common Lisp.) So we
849 ;;; continue to use the IR1 transformation approach, even though it's
850 ;;; known to be buggy. -- WHN 19990507
852 ;;; Basically, this function avoids trashing the compiler by only
853 ;;; actually defining the class if there is no current definition.
854 ;;; Instead, we just set the INFO TYPE COMPILER-LAYOUT. This behavior
855 ;;; is left over from classic CMU CL and may not be necessary in the
856 ;;; new build system. -- WHN 19990507
858 ;;; FUNCTION-%COMPILER-ONLY-DEFSTRUCT is an ordinary function, called
859 ;;; by both the IR1 transform version of %COMPILER-ONLY-DEFSTRUCT and
860 ;;; by the ordinary function version of %COMPILER-ONLY-DEFSTRUCT. (The
861 ;;; ordinary function version is there for the interpreter and for
863 (defun %compiler-only-defstruct (info inherits)
864 (function-%compiler-only-defstruct info inherits))
865 (defun function-%compiler-only-defstruct (info inherits)
866 (multiple-value-bind (class layout old-layout)
867 (multiple-value-bind (clayout clayout-p)
868 (info :type :compiler-layout (dd-name info))
869 (ensure-structure-class info
871 (if clayout-p "previously compiled" "current")
873 :compiler-layout clayout))
875 (undefine-structure (layout-class old-layout))
876 (when (and (class-subclasses class)
877 (not (eq layout old-layout)))
879 (dohash (class layout (class-subclasses class))
880 (declare (ignore layout))
881 (undefine-structure class)
882 (subs (class-proper-name class)))
884 (warn "Removing old subclasses of ~S:~% ~S"
885 (sb!xc:class-name class)
888 (unless (eq (class-layout class) layout)
889 (register-layout layout :invalidate nil))
890 (setf (sb!xc:find-class (dd-name info)) class)))
892 (setf (info :type :compiler-layout (dd-name info)) layout))
895 ;;; This function does the (COMPILE LOAD EVAL) time actions for updating the
896 ;;; compiler's global meta-information to represent the definition of the
897 ;;; structure described by Info. This primarily amounts to setting up info
898 ;;; about the accessor and other implicitly defined functions. The constructors
899 ;;; are explicitly defined by top-level code.
900 (defun %%compiler-defstruct (info)
901 (declare (type defstruct-description info))
902 (let* ((name (dd-name info))
903 (class (sb!xc:find-class name)))
904 (let ((copier (dd-copier info)))
906 (proclaim `(ftype (function (,name) ,name) ,copier))))
908 ;; FIXME: This (and corresponding code in %DEFSTRUCT) are the way
909 ;; that CMU CL defined the predicate, instead of using DEFUN.
910 ;; Perhaps it would be better to go back to to the CMU CL way, or
911 ;; something similar. I want to reduce the amount of magic in
912 ;; defstruct functions, but making the predicate be a closure
913 ;; looks like a good thing, and can even be done without magic.
914 ;; (OTOH, there are some bootstrapping issues involved, since
915 ;; GENESIS understands DEFUN but doesn't understand a
916 ;; (SETF SYMBOL-FUNCTION) call inside %DEFSTRUCT.)
918 (let ((pred (dd-predicate info)))
920 (proclaim-as-defstruct-function-name pred)
921 (setf (info :function :inlinep pred) :inline)
922 (setf (info :function :inline-expansion pred)
923 `(lambda (x) (typep x ',name)))))
926 (dolist (slot (dd-slots info))
927 (let* ((fun (dsd-accessor slot))
928 (setf-fun `(setf ,fun)))
929 (when (and fun (eq (dsd-raw-type slot) t))
930 (proclaim-as-defstruct-function-name fun)
931 (setf (info :function :accessor-for fun) class)
932 (unless (dsd-read-only slot)
933 (proclaim-as-defstruct-function-name setf-fun)
934 (setf (info :function :accessor-for setf-fun) class))))))
938 ;;; Ordinarily this is preempted by an IR1 transformation, but this
939 ;;; definition is still useful for the interpreter and code walkers.
940 (defun %compiler-defstruct (info)
941 (%%compiler-defstruct info))
943 ;;;; redefinition stuff
945 ;;; Compare the slots of OLD and NEW, returning 3 lists of slot names:
946 ;;; 1. Slots which have moved,
947 ;;; 2. Slots whose type has changed,
948 ;;; 3. Deleted slots.
949 (defun compare-slots (old new)
950 (let* ((oslots (dd-slots old))
951 (nslots (dd-slots new))
952 (onames (mapcar #'dsd-name oslots))
953 (nnames (mapcar #'dsd-name nslots)))
956 (dolist (name (intersection onames nnames))
957 (let ((os (find name oslots :key #'dsd-name))
958 (ns (find name nslots :key #'dsd-name)))
959 (unless (subtypep (dsd-type ns) (dsd-type os))
960 (/noshow "found retyped slots" ns os (dsd-type ns) (dsd-type os))
962 (unless (and (= (dsd-index os) (dsd-index ns))
963 (eq (dsd-raw-type os) (dsd-raw-type ns)))
967 (set-difference onames nnames)))))
969 ;;; If we are redefining a structure with different slots than in the
970 ;;; currently loaded version, give a warning and return true.
971 (defun redefine-structure-warning (class old new)
972 (declare (type defstruct-description old new)
973 (type sb!xc:class class)
975 (let ((name (dd-name new)))
976 (multiple-value-bind (moved retyped deleted) (compare-slots old new)
977 (when (or moved retyped deleted)
979 "incompatibly redefining slots of structure class ~S~@
980 Make sure any uses of affected accessors are recompiled:~@
981 ~@[ These slots were moved to new positions:~% ~S~%~]~
982 ~@[ These slots have new incompatible types:~% ~S~%~]~
983 ~@[ These slots were deleted:~% ~S~%~]"
984 name moved retyped deleted)
987 ;;; This function is called when we are incompatibly redefining a
988 ;;; structure Class to have the specified New-Layout. We signal an
989 ;;; error with some proceed options and return the layout that should
991 (defun %redefine-defstruct (class old-layout new-layout)
992 (declare (type sb!xc:class class) (type layout old-layout new-layout))
993 (let ((name (class-proper-name class)))
995 (error "redefining class ~S incompatibly with the current definition"
998 :report "Invalidate current definition."
999 (warn "Previously loaded ~S accessors will no longer work." name)
1000 (register-layout new-layout))
1002 :report "Smash current layout, preserving old code."
1003 (warn "Any old ~S instances will be in a bad way.~@
1004 I hope you know what you're doing..."
1006 (register-layout new-layout :invalidate nil
1007 :destruct-layout old-layout))))
1010 ;;; This is called when we are about to define a structure class. It
1011 ;;; returns a (possibly new) class object and the layout which should
1012 ;;; be used for the new definition (may be the current layout, and
1013 ;;; also might be an uninstalled forward referenced layout.) The third
1014 ;;; value is true if this is an incompatible redefinition, in which
1015 ;;; case it is the old layout.
1016 (defun ensure-structure-class (info inherits old-context new-context
1017 &key compiler-layout)
1018 (multiple-value-bind (class old-layout)
1022 (class 'sb!xc:structure-class)
1023 (constructor 'make-structure-class))
1024 (dd-alternate-metaclass info)
1025 (declare (ignore name))
1026 (insured-find-class (dd-name info)
1027 (if (eq class 'sb!xc:structure-class)
1029 (typep x 'sb!xc:structure-class))
1031 (sb!xc:typep x (sb!xc:find-class class))))
1032 (fdefinition constructor)))
1033 (setf (class-direct-superclasses class)
1034 (if (eq (dd-name info) 'lisp-stream)
1035 ;; a hack to add STREAM as a superclass mixin to LISP-STREAMs
1036 (list (layout-class (svref inherits (1- (length inherits))))
1037 (layout-class (svref inherits (- (length inherits) 2))))
1038 (list (layout-class (svref inherits (1- (length inherits)))))))
1039 (let ((new-layout (make-layout :class class
1041 :depthoid (length inherits)
1042 :length (dd-length info)
1044 (old-layout (or compiler-layout old-layout)))
1047 (values class new-layout nil))
1048 (;; This clause corresponds to an assertion in REDEFINE-LAYOUT-WARNING
1049 ;; of classic CMU CL. I moved it out to here because it was only
1050 ;; exercised in this code path anyway. -- WHN 19990510
1051 (not (eq (layout-class new-layout) (layout-class old-layout)))
1052 (error "shouldn't happen: weird state of OLD-LAYOUT?"))
1053 ((not *type-system-initialized*)
1054 (setf (layout-info old-layout) info)
1055 (values class old-layout nil))
1056 ((redefine-layout-warning old-context
1059 (layout-length new-layout)
1060 (layout-inherits new-layout)
1061 (layout-depthoid new-layout))
1062 (values class new-layout old-layout))
1064 (let ((old-info (layout-info old-layout)))
1066 ((or defstruct-description)
1067 (cond ((redefine-structure-warning class old-info info)
1068 (values class new-layout old-layout))
1070 (setf (layout-info old-layout) info)
1071 (values class old-layout nil))))
1073 (setf (layout-info old-layout) info)
1074 (values class old-layout nil))
1076 (error "shouldn't happen! strange thing in LAYOUT-INFO:~% ~S"
1078 (values class new-layout old-layout)))))))))
1080 ;;; Blow away all the compiler info for the structure CLASS. Iterate
1081 ;;; over this type, clearing the compiler structure type info, and
1082 ;;; undefining all the associated functions.
1083 (defun undefine-structure (class)
1084 (let ((info (layout-info (class-layout class))))
1085 (when (defstruct-description-p info)
1086 (let ((type (dd-name info)))
1087 (setf (info :type :compiler-layout type) nil)
1088 (undefine-function-name (dd-copier info))
1089 (undefine-function-name (dd-predicate info))
1090 (dolist (slot (dd-slots info))
1091 (let ((fun (dsd-accessor slot)))
1092 (undefine-function-name fun)
1093 (unless (dsd-read-only slot)
1094 (undefine-function-name `(setf ,fun))))))
1095 ;; Clear out the SPECIFIER-TYPE cache so that subsequent
1096 ;; references are unknown types.
1097 (values-specifier-type-cache-clear)))
1100 ;;; Return a list of pairs (name . index). Used for :TYPE'd
1101 ;;; constructors to find all the names that we have to splice in &
1102 ;;; where. Note that these types don't have a layout, so we can't look
1103 ;;; at LAYOUT-INHERITS.
1104 (defun find-name-indices (defstruct)
1107 (do ((info defstruct
1108 (typed-structure-info-or-lose (first (dd-include info)))))
1109 ((not (dd-include info))
1114 (dolist (info infos)
1115 (incf i (or (dd-offset info) 0))
1116 (when (dd-named info)
1117 (res (cons (dd-name info) i)))
1118 (setq i (dd-length info)))))
1122 ;;;; slot accessors for raw slots
1124 ;;; Return info about how to read/write a slot in the value stored in
1125 ;;; OBJECT. This is also used by constructors (we can't use the
1126 ;;; accessor function, since some slots are read-only.) If supplied,
1127 ;;; DATA is a variable holding the raw-data vector.
1129 ;;; returned values:
1130 ;;; 1. accessor function name (SETFable)
1131 ;;; 2. index to pass to accessor.
1132 ;;; 3. object form to pass to accessor
1133 (defun slot-accessor-form (defstruct slot object &optional data)
1134 (let ((rtype (dsd-raw-type slot)))
1137 (single-float '%raw-ref-single)
1138 (double-float '%raw-ref-double)
1140 (long-float '%raw-ref-long)
1141 (complex-single-float '%raw-ref-complex-single)
1142 (complex-double-float '%raw-ref-complex-double)
1144 (complex-long-float '%raw-ref-complex-long)
1145 (unsigned-byte 'aref)
1147 (if (eq (dd-type defstruct) 'funcallable-structure)
1148 '%funcallable-instance-info
1153 (truncate (dsd-index slot) #!+x86 6 #!+sparc 8))
1156 (truncate (dsd-index slot) #!+x86 3 #!+sparc 4))
1158 (ash (dsd-index slot) -1))
1159 (complex-double-float
1160 (ash (dsd-index slot) -2))
1161 (complex-single-float
1162 (ash (dsd-index slot) -1))
1166 ((eq rtype 't) object)
1169 `(truly-the (simple-array (unsigned-byte 32) (*))
1170 (%instance-ref ,object ,(dd-raw-index defstruct))))))))
1172 ;;; These functions are called to actually make a constructor after we
1173 ;;; have processed the arglist. The correct variant (according to the
1174 ;;; DD-TYPE) should be called. The function is defined with the
1175 ;;; specified name and arglist. Vars and Types are used for argument
1176 ;;; type declarations. Values are the values for the slots (in order.)
1178 ;;; This is split four ways because:
1179 ;;; 1] list & vector structures need "name" symbols stuck in at
1180 ;;; various weird places, whereas STRUCTURE structures have
1182 ;;; 2] We really want to use LIST to make list structures, instead of
1183 ;;; MAKE-LIST/(SETF ELT).
1184 ;;; 3] STRUCTURE structures can have raw slots that must also be
1185 ;;; allocated and indirectly referenced. We use SLOT-ACCESSOR-FORM
1186 ;;; to compute how to set the slots, which deals with raw slots.
1187 ;;; 4] Funcallable structures are weird.
1188 (defun create-vector-constructor
1189 (defstruct cons-name arglist vars types values)
1190 (let ((temp (gensym))
1191 (etype (dd-element-type defstruct)))
1192 `(defun ,cons-name ,arglist
1193 (declare ,@(mapcar #'(lambda (var type) `(type (and ,type ,etype) ,var))
1195 (let ((,temp (make-array ,(dd-length defstruct)
1196 :element-type ',(dd-element-type defstruct))))
1197 ,@(mapcar #'(lambda (x)
1198 `(setf (aref ,temp ,(cdr x)) ',(car x)))
1199 (find-name-indices defstruct))
1200 ,@(mapcar #'(lambda (dsd value)
1201 `(setf (aref ,temp ,(dsd-index dsd)) ,value))
1202 (dd-slots defstruct) values)
1204 (defun create-list-constructor
1205 (defstruct cons-name arglist vars types values)
1206 (let ((vals (make-list (dd-length defstruct) :initial-element nil)))
1207 (dolist (x (find-name-indices defstruct))
1208 (setf (elt vals (cdr x)) `',(car x)))
1209 (loop for dsd in (dd-slots defstruct) and val in values do
1210 (setf (elt vals (dsd-index dsd)) val))
1212 `(defun ,cons-name ,arglist
1213 (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
1216 (defun create-structure-constructor
1217 (defstruct cons-name arglist vars types values)
1218 (let* ((temp (gensym))
1219 (raw-index (dd-raw-index defstruct))
1220 (n-raw-data (when raw-index (gensym))))
1221 `(defun ,cons-name ,arglist
1222 (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
1224 (let ((,temp (truly-the ,(dd-name defstruct)
1225 (%make-instance ,(dd-length defstruct))))
1228 (make-array ,(dd-raw-length defstruct)
1229 :element-type '(unsigned-byte 32))))))
1230 (setf (%instance-layout ,temp)
1231 (%delayed-get-compiler-layout ,(dd-name defstruct)))
1233 `((setf (%instance-ref ,temp ,raw-index) ,n-raw-data)))
1234 ,@(mapcar #'(lambda (dsd value)
1235 (multiple-value-bind (accessor index data)
1236 (slot-accessor-form defstruct dsd temp n-raw-data)
1237 `(setf (,accessor ,data ,index) ,value)))
1238 (dd-slots defstruct)
1241 (defun create-fin-constructor
1242 (defstruct cons-name arglist vars types values)
1243 (let ((temp (gensym)))
1244 `(defun ,cons-name ,arglist
1245 (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
1247 (let ((,temp (truly-the
1248 ,(dd-name defstruct)
1249 (%make-funcallable-instance
1250 ,(dd-length defstruct)
1251 (%delayed-get-compiler-layout ,(dd-name defstruct))))))
1252 ,@(mapcar #'(lambda (dsd value)
1253 `(setf (%funcallable-instance-info
1254 ,temp ,(dsd-index dsd))
1256 (dd-slots defstruct) values)
1259 ;;; Create a default (non-BOA) keyword constructor.
1260 (defun create-keyword-constructor (defstruct creator)
1261 (collect ((arglist (list '&key))
1264 (dolist (slot (dd-slots defstruct))
1265 (let ((dum (gensym))
1266 (name (dsd-name slot)))
1267 (arglist `((,(intern (string name) "KEYWORD") ,dum)
1268 ,(dsd-default slot)))
1269 (types (dsd-type slot))
1272 defstruct (dd-default-constructor defstruct)
1273 (arglist) (vals) (types) (vals))))
1275 ;;; Given a structure and a BOA constructor spec, call Creator with
1276 ;;; the appropriate args to make a constructor.
1277 (defun create-boa-constructor (defstruct boa creator)
1278 (multiple-value-bind (req opt restp rest keyp keys allowp aux)
1279 (sb!kernel:parse-lambda-list (second boa))
1283 (labels ((get-slot (name)
1284 (let ((res (find name (dd-slots defstruct)
1288 (values (dsd-type res) (dsd-default res))
1291 (multiple-value-bind (type default) (get-slot arg)
1292 (arglist `(,arg ,default))
1298 (types (get-slot arg)))
1301 (arglist '&optional)
1305 (name &optional (def (nth-value 1 (get-slot name))))
1307 (arglist `(,name ,def))
1309 (types (get-slot name))))
1311 (do-default arg)))))
1314 (arglist '&rest rest)
1322 (destructuring-bind (wot &optional (def nil def-p)) key
1323 (let ((name (if (consp wot)
1324 (destructuring-bind (key var) wot
1325 (declare (ignore key))
1328 (multiple-value-bind (type slot-def) (get-slot name)
1329 (arglist `(,wot ,(if def-p def slot-def)))
1334 (when allowp (arglist '&allow-other-keys))
1339 (let* ((arg (if (consp arg) arg (list arg)))
1343 (types (get-slot var))))))
1345 (funcall creator defstruct (first boa)
1346 (arglist) (vars) (types)
1347 (mapcar #'(lambda (slot)
1348 (or (find (dsd-name slot) (vars) :test #'string=)
1349 (dsd-default slot)))
1350 (dd-slots defstruct))))))
1352 ;;; Grovel the constructor options, and decide what constructors (if
1354 (defun constructor-definitions (defstruct)
1355 (let ((no-constructors nil)
1358 (creator (ecase (dd-type defstruct)
1359 (structure #'create-structure-constructor)
1360 (funcallable-structure #'create-fin-constructor)
1361 (vector #'create-vector-constructor)
1362 (list #'create-list-constructor))))
1363 (dolist (constructor (dd-constructors defstruct))
1364 (destructuring-bind (name &optional (boa-ll nil boa-p)) constructor
1365 (declare (ignore boa-ll))
1366 (cond ((not name) (setq no-constructors t))
1367 (boa-p (push constructor boas))
1368 (t (push name defaults)))))
1370 (when no-constructors
1371 (when (or defaults boas)
1372 (error "(:CONSTRUCTOR NIL) combined with other :CONSTRUCTORs"))
1373 (return-from constructor-definitions ()))
1375 (unless (or defaults boas)
1376 (push (concat-pnames 'make- (dd-name defstruct)) defaults))
1380 (let ((cname (first defaults)))
1381 (setf (dd-default-constructor defstruct) cname)
1382 (res (create-keyword-constructor defstruct creator))
1383 (dolist (other-name (rest defaults))
1384 (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
1385 (res `(declaim (ftype function ',other-name))))))
1388 (res (create-boa-constructor defstruct boa creator)))
1394 ;;; Like PROCLAIM-AS-FUNCTION-NAME, but we also set the kind to
1395 ;;; :DECLARED and blow away any ASSUMED-TYPE. Also, if the thing is a
1396 ;;; slot accessor currently, quietly unaccessorize it. And if there
1397 ;;; are any undefined warnings, we nuke them.
1398 (defun proclaim-as-defstruct-function-name (name)
1400 (when (info :function :accessor-for name)
1401 (setf (info :function :accessor-for name) nil))
1402 (proclaim-as-function-name name)
1403 (note-name-defined name :function)
1404 (setf (info :function :where-from name) :declared)
1405 (when (info :function :assumed-type name)
1406 (setf (info :function :assumed-type name) nil)))
1409 ;;;; finalizing bootstrapping
1411 ;;; early structure placeholder definitions: Set up layout and class
1412 ;;; data for structures which are needed early.
1414 '#.(sb-cold:read-from-file
1415 "src/code/early-defstruct-args.lisp-expr"))
1416 (let* ((defstruct (parse-name-and-options-and-slot-descriptions
1419 (inherits (inherits-for-structure defstruct)))
1420 (function-%compiler-only-defstruct defstruct inherits)))