1 ;;;; that part of DEFSTRUCT implementation which is needed not just
2 ;;;; in the target Lisp but also in the cross-compilation host
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
13 (in-package "SB!KERNEL")
15 (/show0
"code/defstruct.lisp 15")
19 ;;; Return the compiler layout for NAME. (The class referred to by
20 ;;; NAME must be a structure-like class.)
21 (defun compiler-layout-or-lose (name)
22 (let ((res (info :type
:compiler-layout name
)))
24 (error "Class is not yet defined or was undefined: ~S" name
))
25 ((not (typep (layout-info res
) 'defstruct-description
))
26 (error "Class is not a structure class: ~S" name
))
29 (defun compiler-layout-ready-p (name)
30 (let ((layout (info :type
:compiler-layout name
)))
31 (and layout
(typep (layout-info layout
) 'defstruct-description
))))
33 (sb!xc
:defmacro %make-structure-instance-macro
(dd slot-specs
&rest slot-vars
)
34 (if (compiler-layout-ready-p (dd-name dd
))
35 `(truly-the ,(dd-name dd
)
36 (%make-structure-instance
,dd
,slot-specs
,@slot-vars
))
37 ;; Non-toplevel defstructs don't have a layout at compile time,
38 ;; so we need to construct the actual function at runtime -- but
39 ;; we cache it at the call site, so that we don't perform quite
41 `(let* ((cell (load-time-value (list nil
)))
44 (funcall fun
,@slot-vars
)
45 (funcall (setf (car cell
)
46 (%make-structure-instance-allocator
,dd
,slot-specs
))
49 (declaim (ftype (sfunction (defstruct-description list
) function
)
50 %make-structure-instance-allocator
))
51 (defun %make-structure-instance-allocator
(dd slot-specs
)
52 (let ((vars (make-gensym-list (length slot-specs
))))
55 (%make-structure-instance-macro
,dd
',slot-specs
,@vars
))))))
57 (defun %make-funcallable-structure-instance-allocator
(dd slot-specs
)
59 (bug "funcallable-structure-instance allocation with slots unimplemented"))
60 (let ((name (dd-name dd
))
61 (length (dd-length dd
))
62 (nobject (gensym "OBJECT")))
64 (compile nil
`(lambda ()
65 (let ((,nobject
(%make-funcallable-instance
,length
)))
66 (setf (%funcallable-instance-layout
,nobject
)
67 (%delayed-get-compiler-layout
,name
))
70 ;;; Delay looking for compiler-layout until the constructor is being
71 ;;; compiled, since it doesn't exist until after the EVAL-WHEN
72 ;;; (COMPILE) stuff is compiled. (Or, in the oddball case when
73 ;;; DEFSTRUCT is executing in a non-toplevel context, the
74 ;;; compiler-layout still doesn't exist at compilation time, and we
75 ;;; delay still further.)
76 (sb!xc
:defmacro %delayed-get-compiler-layout
(name)
77 (let ((layout (info :type
:compiler-layout name
)))
79 ;; ordinary case: When the DEFSTRUCT is at top level,
80 ;; then EVAL-WHEN (COMPILE) stuff will have set up the
81 ;; layout for us to use.
82 (unless (typep (layout-info layout
) 'defstruct-description
)
83 (error "Class is not a structure class: ~S" name
))
86 ;; KLUDGE: In the case that DEFSTRUCT is not at top-level
87 ;; the layout doesn't exist at compile time. In that case
88 ;; we laboriously look it up at run time. This code will
89 ;; run on every constructor call and will likely be quite
90 ;; slow, so if anyone cares about performance of
91 ;; non-toplevel DEFSTRUCTs, it should be rewritten to be
92 ;; cleverer. -- WHN 2002-10-23
94 "implementation limitation: ~
95 Non-toplevel DEFSTRUCT constructors are slow.")
96 (with-unique-names (layout)
97 `(let ((,layout
(info :type
:compiler-layout
',name
)))
98 (unless (typep (layout-info ,layout
) 'defstruct-description
)
99 (error "Class is not a structure class: ~S" ',name
))
102 ;;; re. %DELAYED-GET-COMPILER-LAYOUT and COMPILE-TIME-FIND-LAYOUT, above..
104 ;;; FIXME: Perhaps both should be defined with DEFMACRO-MUNDANELY?
105 ;;; FIXME: Do we really need both? If so, their names and implementations
106 ;;; should probably be tweaked to be more parallel.
108 ;;;; DEFSTRUCT-DESCRIPTION
110 ;;; The DEFSTRUCT-DESCRIPTION structure holds compile-time information
111 ;;; about a structure type.
112 (def!struct
(defstruct-description
114 (:make-load-form-fun just-dump-it-normally
)
115 #-sb-xc-host
(:pure t
)
116 (:constructor make-defstruct-description
(name)))
117 ;; name of the structure
118 (name (missing-arg) :type symbol
:read-only t
)
119 ;; documentation on the structure
120 (doc nil
:type
(or string null
))
121 ;; prefix for slot names. If NIL, none.
122 (conc-name nil
:type
(or string null
))
123 ;; the name of the primary standard keyword constructor, or NIL if none
124 (default-constructor nil
:type symbol
)
125 ;; all the explicit :CONSTRUCTOR specs, with name defaulted
126 (constructors () :type list
)
127 ;; name of copying function
128 (copier-name nil
:type symbol
)
129 ;; name of type predicate
130 (predicate-name nil
:type symbol
)
131 ;; the arguments to the :INCLUDE option, or NIL if no included
133 (include nil
:type list
)
134 ;; properties used to define structure-like classes with an
135 ;; arbitrary superclass and that may not have STRUCTURE-CLASS as the
136 ;; metaclass. Syntax is:
137 ;; (superclass-name metaclass-name metaclass-constructor)
138 (alternate-metaclass nil
:type list
)
139 ;; a list of DEFSTRUCT-SLOT-DESCRIPTION objects for all slots
140 ;; (including included ones)
141 (slots () :type list
)
142 ;; a list of (NAME . INDEX) pairs for accessors of included structures
143 (inherited-accessor-alist () :type list
)
144 ;; number of elements we've allocated (See also RAW-LENGTH, which is not
145 ;; included in LENGTH.)
146 (length 0 :type index
)
147 ;; General kind of implementation.
148 (type 'structure
:type
(member structure vector list
149 funcallable-structure
))
151 ;; The next three slots are for :TYPE'd structures (which aren't
152 ;; classes, DD-CLASS-P = NIL)
154 ;; vector element type
156 ;; T if :NAMED was explicitly specified, NIL otherwise
157 (named nil
:type boolean
)
158 ;; any INITIAL-OFFSET option on this direct type
159 (offset nil
:type
(or index null
))
161 ;; which :PRINT-mumble option was given, if either was.
162 (print-option nil
:type
(member nil
:print-function
:print-object
))
163 ;; the argument to the PRINT-FUNCTION or PRINT-OBJECT option.
164 ;; NIL if the option was given with no argument.
165 (printer-fname nil
:type
(or cons symbol
))
167 ;; The number of untagged slots at the end.
168 #!-interleaved-raw-slots
(raw-length 0 :type index
)
169 ;; the value of the :PURE option, or :UNSPECIFIED. This is only
170 ;; meaningful if DD-CLASS-P = T.
171 (pure :unspecified
:type
(member t nil
:unspecified
)))
172 #!-sb-fluid
(declaim (freeze-type defstruct-description
))
173 (def!method print-object
((x defstruct-description
) stream
)
174 (print-unreadable-object (x stream
:type t
:identity t
)
175 (prin1 (dd-name x
) stream
)))
177 ;;; Does DD describe a structure with a class?
178 (defun dd-class-p (dd)
179 (if (member (dd-type dd
) '(structure funcallable-structure
)) t nil
))
181 (defun dd-layout-or-lose (dd)
182 (compiler-layout-or-lose (dd-name dd
)))
184 ;;;; DEFSTRUCT-SLOT-DESCRIPTION
186 ;;; A DEFSTRUCT-SLOT-DESCRIPTION holds compile-time information about
187 ;;; a structure slot.
188 (def!struct
(defstruct-slot-description
189 (:make-load-form-fun just-dump-it-normally
)
192 #-sb-xc-host
(:pure t
))
195 ;; its position in the implementation sequence
196 (index (missing-arg) :type fixnum
)
197 ;; the name of the accessor function
199 ;; (CMU CL had extra complexity here ("..or NIL if this accessor has
200 ;; the same name as an inherited accessor (which we don't want to
201 ;; shadow)") but that behavior doesn't seem to be specified by (or
202 ;; even particularly consistent with) ANSI, so it's gone in SBCL.)
203 (accessor-name nil
:type symbol
)
204 default
; default value expression
205 (type t
) ; declared type specifier
206 (safe-p t
:type boolean
) ; whether the slot is known to be
207 ; always of the specified type
208 ;; If this object does not describe a raw slot, this value is T.
210 ;; If this object describes a raw slot, this value is the type of the
211 ;; value that the raw slot holds.
212 ;; Note: if there were more than about 5 raw types - and there aren't -
213 ;; this could be made more efficient by storing either a raw-type-id
214 ;; as an integer index to a vector of the raw types (presently a list,
215 ;; but easily a vector), or actually just the RSD object (raw-slot-data).
216 ;; Doing so would avoid some frequent re-scanning of the RSD list.
217 (raw-type t
:type
(member t single-float double-float
218 #!+long-float long-float
219 complex-single-float complex-double-float
220 #!+long-float complex-long-float
222 (read-only nil
:type
(member t nil
)))
223 #!-sb-fluid
(declaim (freeze-type defstruct-slot-description
))
224 (def!method print-object
((x defstruct-slot-description
) stream
)
225 (print-unreadable-object (x stream
:type t
)
226 (prin1 (dsd-name x
) stream
)))
228 ;;;; typed (non-class) structures
230 ;;; Return a type specifier we can use for testing :TYPE'd structures.
231 (defun dd-lisp-type (defstruct)
232 (ecase (dd-type defstruct
)
234 (vector `(simple-array ,(dd-element-type defstruct
) (*)))))
236 ;;;; shared machinery for inline and out-of-line slot accessor functions
238 ;;; Classic comment preserved for entertainment value:
240 ;;; "A lie can travel halfway round the world while the truth is
241 ;;; putting on its shoes." -- Mark Twain
243 ;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its
244 ;;;; close personal friend SB!XC:DEFSTRUCT)
246 (sb!xc
:defmacro delay-defstruct-functions
(name forms
)
247 ;; KLUDGE: If DEFSTRUCT is not at the top-level,
248 ;; (typep x 'name) and similar forms can't get optimized
249 ;; and produce style-warnings for unknown types.
250 (if (compiler-layout-ready-p name
)
254 ;;; shared logic for host macroexpansion for SB!XC:DEFSTRUCT and
255 ;;; cross-compiler macroexpansion for CL:DEFSTRUCT
256 (defun %expander-for-defstruct
(name-and-options slot-descriptions
257 expanding-into-code-for
)
258 ;; The host's version of this allows three choices for 'expanding-into'
259 ;; up until such time as the DEFMACRO is seen (again) for DEFSTRUCT,
260 ;; at which point things are ok because 'early-package' will have been
261 ;; processed. The target has only one possibility.
262 (aver (member expanding-into-code-for
'(:target
265 (let* ((dd (parse-defstruct-name-and-options-and-slot-descriptions
266 name-and-options slot-descriptions
))
267 (inherits (if (dd-class-p dd
) (inherits-for-structure dd
)))
270 (when (dd-print-option dd
)
271 (let* ((x (sb!xc
:gensym
"OBJECT"))
272 (s (sb!xc
:gensym
"STREAM"))
273 (fname (dd-printer-fname dd
))
274 (depthp (eq (dd-print-option dd
) :print-function
)))
275 ;; Giving empty :PRINT-OBJECT or :PRINT-FUNCTION options
276 ;; leaves FNAME eq to NIL. The user-level effect is
277 ;; to generate a PRINT-OBJECT method specialized for the type,
278 ;; implementing the default #S structure-printing behavior.
280 (setf fname
'default-structure-print depthp t
))
281 ((not (symbolp fname
))
282 ;; Don't dump the source form into the DD constant;
283 ;; just indicate that there was an expression there.
284 (setf (dd-printer-fname dd
) t
)))
285 `((sb!xc
:defmethod
print-object ((,x
,name
) ,s
)
286 (funcall #',fname
,x
,s
287 ,@(if depthp
`(*current-level-in-print
*)))))))))
289 ;; Note we intentionally enforce package locks and
290 ;; call %DEFSTRUCT first, and especially before
291 ;; %COMPILER-DEFSTRUCT. %DEFSTRUCT has the tests (and
292 ;; resulting CERROR) for collisions with LAYOUTs which
293 ;; already exist in the runtime. If there are any
294 ;; collisions, we want the user's response to CERROR
295 ;; to control what happens. Especially, if the user
296 ;; responds to the collision with ABORT, we don't want
297 ;; %COMPILER-DEFSTRUCT to modify the definition of the
299 ,@(when (eq expanding-into-code-for
:target
)
300 `((with-single-package-locked-error
301 (:symbol
',name
"defining ~A as a structure"))))
302 ,@(if (dd-class-p dd
)
303 `((%defstruct
',dd
',inherits
(sb!c
:source-location
))
304 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
305 (%compiler-defstruct
',dd
',inherits
))
306 ,@(unless (eq expanding-into-code-for
:host
)
307 `((delay-defstruct-functions
309 (progn ,@(awhen (copier-definition dd
) (list it
))
310 ,@(awhen (predicate-definition dd
) (list it
))
311 ,@(accessor-definitions dd
)))
312 ;; This must be in the same lexical environment
313 ,@(constructor-definitions dd
)
314 ,@(when (eq (dd-pure dd
) t
)
315 ;; Seems like %TARGET-DEFSTRUCT should do this
317 (declare (notinline find-classoid
))
318 (setf (layout-pure (classoid-layout
319 (find-classoid ',name
))) t
))))
321 ;; Various other operations only make sense on the target SBCL.
322 (%target-defstruct
',dd
))))
323 `((eval-when (:compile-toplevel
:load-toplevel
:execute
)
324 (setf (info :typed-structure
:info
',name
) ',dd
))
325 (setf (info :source-location
:typed-structure
',name
)
326 (sb!c
:source-location
))
327 ,@(unless (eq expanding-into-code-for
:host
)
328 (append (typed-accessor-definitions dd
)
329 (typed-predicate-definitions dd
)
330 (typed-copier-definitions dd
)
331 (constructor-definitions dd
)
333 `((setf (fdocumentation ',(dd-name dd
) 'structure
)
338 (sb!xc
:defmacro defstruct
(name-and-options &rest slot-descriptions
)
339 (%expander-for-defstruct name-and-options slot-descriptions
:cold-target
))
342 (sb!xc
:defmacro defstruct
(name-and-options &rest slot-descriptions
)
344 "DEFSTRUCT {Name | (Name Option*)} [Documentation] {Slot | (Slot [Default] {Key Value}*)}
345 Define the structure type Name. Instances are created by MAKE-<name>,
346 which takes &KEY arguments allowing initial slot values to the specified.
347 A SETF'able function <name>-<slot> is defined for each slot to read and
348 write slot values. <name>-p is a type predicate.
350 Popular DEFSTRUCT options (see manual for others):
354 Specify the name for the constructor or predicate.
356 (:CONSTRUCTOR Name Lambda-List)
357 Specify the name and arguments for a BOA constructor
358 (which is more efficient when keyword syntax isn't necessary.)
360 (:INCLUDE Supertype Slot-Spec*)
361 Make this type a subtype of the structure type Supertype. The optional
362 Slot-Specs override inherited slot options.
367 Asserts that the value of this slot is always of the specified type.
370 If true, no setter function is defined for this slot."
371 (%expander-for-defstruct name-and-options slot-descriptions
:target
))
373 (defmacro sb
!xc
:defstruct
(name-and-options &rest slot-descriptions
)
375 "Cause information about a target structure to be built into the
377 (%expander-for-defstruct name-and-options slot-descriptions
:host
))
379 ;;;; functions to generate code for various parts of DEFSTRUCT definitions
381 ;;; First, a helper to determine whether a name names an inherited
383 (defun accessor-inherited-data (name defstruct
)
384 (assoc name
(dd-inherited-accessor-alist defstruct
) :test
#'eq
))
386 ;;; Return a list of forms which create a predicate function for a
388 (defun typed-predicate-definitions (defstruct)
389 (let ((name (dd-name defstruct
))
390 (predicate-name (dd-predicate-name defstruct
))
391 (argname 'x
)) ; KISS: no user code appears in the DEFUN
393 (aver (dd-named defstruct
))
394 (let ((ltype (dd-lisp-type defstruct
))
395 (name-index (cdr (car (last (find-name-indices defstruct
))))))
396 `((defun ,predicate-name
(,argname
)
397 (and (typep ,argname
',ltype
)
399 ((subtypep ltype
'list
)
400 `(do ((head (the ,ltype
,argname
) (cdr head
))
402 ((or (not (consp head
)) (= i
,name-index
))
403 (and (consp head
) (eq ',name
(car head
))))))
404 ((subtypep ltype
'vector
)
405 `(and (>= (length (the ,ltype
,argname
))
406 ,(dd-length defstruct
))
407 (eq ',name
(aref (the ,ltype
,argname
) ,name-index
))))
408 (t (bug "Uncatered-for lisp type in typed DEFSTRUCT: ~S."
411 ;;; Return a list of forms to create a copier function of a typed DEFSTRUCT.
412 (defun typed-copier-definitions (defstruct)
413 (when (dd-copier-name defstruct
)
414 `((setf (fdefinition ',(dd-copier-name defstruct
)) #'copy-seq
)
415 (declaim (ftype function
,(dd-copier-name defstruct
))))))
417 ;;; Return a list of function definitions for accessing and setting
418 ;;; the slots of a typed DEFSTRUCT. The functions are proclaimed to be
419 ;;; inline, and the types of their arguments and results are declared
420 ;;; as well. We count on the compiler to do clever things with ELT.
421 (defun typed-accessor-definitions (defstruct)
423 (let ((ltype (dd-lisp-type defstruct
)))
424 (dolist (slot (dd-slots defstruct
))
425 (let ((name (dsd-accessor-name slot
))
426 (index (dsd-index slot
))
428 (slot-type `(and ,(dsd-type slot
)
429 ,(dd-element-type defstruct
))))
430 (let ((inherited (accessor-inherited-data name defstruct
)))
433 (stuff `(declaim (inline ,name
,@(unless (dsd-read-only slot
)
435 (stuff `(defun ,name
(structure)
436 (declare (type ,ltype structure
))
437 (the ,slot-type
(elt structure
,index
))))
438 (unless (dsd-read-only slot
)
440 `(defun (setf ,name
) (,(car new-value
) structure
)
441 (declare (type ,ltype structure
) (type ,slot-type .
,new-value
))
442 (setf (elt structure
,index
) .
,new-value
)))))
443 ((not (= (cdr inherited
) index
))
444 (style-warn "~@<Non-overwritten accessor ~S does not access ~
445 slot with name ~S (accessing an inherited slot ~
446 instead).~:@>" name
(dsd-name slot
))))))))
452 ;;; A defstruct option can be either a keyword or a list of a keyword
453 ;;; and arguments for that keyword; specifying the keyword by itself is
454 ;;; equivalent to specifying a list consisting of the keyword
455 ;;; and no arguments.
456 ;;; It is unclear whether that is meant to imply that any of the keywords
457 ;;; may be present in their atom form, or only if the grammar at the top
458 ;;; shows the atom form does <atom> have the meaning of (<atom>).
459 ;;; At least one other implementation accepts :NAMED as a singleton list.
460 ;; We take a more rigid view that the depicted grammar is exhaustive.
462 (defconstant-eqx +dd-option-names
+
463 ;; Each keyword, except :CONSTRUCTOR which may appear more than once,
464 ;; and :NAMED which is trivial, and unambiguous if present more than
465 ;; once, though possibly worth a style-warning.
466 #(:include
; at least 1 argument
467 :initial-offset
; exactly 1 argument
468 :pure
; exactly 1 argument [nonstandard]
469 :type
; exactly 1 argument
470 :conc-name
; 0 or 1 arg
477 ;;; Parse a single DEFSTRUCT option and store the results in DD.
478 (defun parse-1-dd-option (option dd seen-options
)
479 (let* ((keyword (first option
))
480 (bit (position keyword
+dd-option-names
+))
483 (arg (if arg-p
(car args
)))
485 (declare (type (unsigned-byte 9) seen-options
)) ; mask over DD-OPTION-NAMES
487 (if (logbitp bit seen-options
)
488 (error "More than one ~S option is not allowed" keyword
)
489 (setf seen-options
(logior seen-options
(ash 1 bit
))))
490 (multiple-value-bind (syntax-group winp
)
491 (cond ; Perform checking per comment at +DD-OPTION-NAMES+.
492 ((= bit
0) (values 0 (and arg-p
(proper-list-p args
)))) ; >1 arg
493 ((< bit
4) (values 1 (and arg-p
(not (cdr args
))))) ; exactly 1
494 (t (values 2 (or (not args
) (singleton-p args
))))) ; 0 or 1
496 (if (proper-list-p option
)
497 (error "DEFSTRUCT option ~S ~[requires at least~;~
498 requires exactly~;accepts at most~] one argument" keyword syntax-group
)
499 (error "Invalid syntax in DEFSTRUCT option ~S" option
)))))
502 ;; unlike (:predicate) and (:copier) which mean "yes" if supplied
503 ;; without their argument, (:conc-name) and :conc-name mean no conc-name.
504 ;; Also note a subtle difference in :conc-name "" vs :conc-name NIL.
505 ;; The former re-interns each slot name into *PACKAGE* which might
506 ;; not be the same as using the given name directly as an accessor.
507 (setf (dd-conc-name dd
) (if arg
(string arg
))))
508 (:constructor
; takes 0 to 2 arguments.
509 (destructuring-bind (&optional
(cname (symbolicate "MAKE-" name
))
511 (declare (ignore lambda-list
))
512 (push (cons cname
(cdr args
)) (dd-constructors dd
))))
514 (setf (dd-copier-name dd
) (if arg-p arg
(symbolicate "COPY-" name
))))
516 (setf (dd-predicate-name dd
) (if arg-p arg
(symbolicate name
"-P"))))
518 (setf (dd-include dd
) args
))
519 ((:print-function
:print-object
)
520 (when (dd-print-option dd
)
521 (error "~S and ~S may not both be specified"
522 (dd-print-option dd
) keyword
))
523 (setf (dd-print-option dd
) keyword
(dd-printer-fname dd
) arg
))
525 (cond ((member arg
'(list vector
))
526 (setf (dd-type dd
) arg
(dd-element-type dd
) t
))
527 ((and (listp arg
) (eq (first arg
) 'vector
))
528 (destructuring-bind (elt-type) (cdr arg
)
529 (setf (dd-type dd
) 'vector
(dd-element-type dd
) elt-type
)))
531 (error "~S is a bad :TYPE for DEFSTRUCT." arg
))))
533 (error "The DEFSTRUCT option :NAMED takes no arguments."))
535 (setf (dd-offset dd
) arg
)) ; FIXME: disallow (:INITIAL-OFFSET NIL)
537 (setf (dd-pure dd
) arg
))
539 (error "unknown DEFSTRUCT option:~% ~S" option
)))
542 ;;; Given name and options, return a DD holding that info.
543 (defun parse-defstruct-name-and-options (name-and-options)
544 (destructuring-bind (name &rest options
) name-and-options
545 (let ((dd (make-defstruct-description name
))
547 (dolist (option options
)
548 (if (eq option
:named
)
549 (setf (dd-named dd
) t
)
552 (cond ((consp option
) option
)
554 '(:conc-name
:constructor
:copier
:predicate
))
557 ;; FIXME: ugly message (defstruct (s :include) a)
558 ;; saying "unrecognized" when it means "bad syntax"
559 (error "unrecognized DEFSTRUCT option: ~S" option
)))
564 (error ":OFFSET can't be specified unless :TYPE is specified."))
565 (unless (dd-include dd
)
566 ;; FIXME: It'd be cleaner to treat no-:INCLUDE as defaulting
567 ;; to :INCLUDE STRUCTURE-OBJECT, and then let the general-case
568 ;; (INCF (DD-LENGTH DD) (DD-LENGTH included-DD)) logic take
569 ;; care of this. (Except that the :TYPE VECTOR and :TYPE
570 ;; LIST cases, with their :NAMED and un-:NAMED flavors,
571 ;; make that messy, alas.)
572 (incf (dd-length dd
))))
574 ;; In case we are here, :TYPE is specified.
576 ;; CLHS - "The structure can be :named only if the type SYMBOL
577 ;; is a subtype of the supplied element-type."
578 (multiple-value-bind (winp certainp
)
579 (subtypep 'symbol
(dd-element-type dd
))
580 (when (and (not winp
) certainp
)
581 (error ":NAMED option is incompatible with element type ~S"
582 (dd-element-type dd
))))
583 (when (dd-predicate-name dd
)
584 (error ":PREDICATE cannot be used with :TYPE ~
585 unless :NAMED is also specified.")))
586 (awhen (dd-print-option dd
)
587 (error ":TYPE option precludes specification of ~S option" it
))
589 (incf (dd-length dd
)))
590 (let ((offset (dd-offset dd
)))
591 (when offset
(incf (dd-length dd
) offset
)))))
593 (flet ((option-present-p (bit-name)
594 (logbitp (position bit-name
+dd-option-names
+) seen-options
)))
595 (declare (inline option-present-p
))
596 (when (and (not (option-present-p :predicate
))
597 (or (dd-class-p dd
) (dd-named dd
)))
598 (setf (dd-predicate-name dd
) (symbolicate name
"-P")))
599 (unless (option-present-p :conc-name
)
600 (setf (dd-conc-name dd
) (concatenate 'string
(string name
) "-")))
601 (unless (option-present-p :copier
)
602 (setf (dd-copier-name dd
) (symbolicate "COPY-" name
))))
603 (when (dd-include dd
)
604 (frob-dd-inclusion-stuff dd
))
608 ;;; BOA constructors is (&aux x), i.e. without the default value, the
609 ;;; value of the slot is unspecified, but it should signal a type
610 ;;; error only when it's accessed. safe-p slot in dsd determines
611 ;;; whether to check the type after accessing the slot.
613 ;;; This was performed during boa constructor creating, but the
614 ;;; constructors are created after this information is used to inform
615 ;;; the compiler how to treat such slots.
616 (defun determine-unsafe-slots (dd)
617 (loop for
(name lambda-list
) in
(dd-constructors dd
)
618 for
&aux
= (cdr (member '&aux lambda-list
))
624 (setf name
(car slot
))
626 (symbol (setf name slot
)
628 do
(let ((dsd (find name
(dd-slots dd
)
632 (setf (dsd-safe-p dsd
) nil
))))))
634 ;;; Given name and options and slot descriptions (and possibly doc
635 ;;; string at the head of slot descriptions) return a DD holding that
637 (defun parse-defstruct-name-and-options-and-slot-descriptions
638 (name-and-options slot-descriptions
)
639 (let ((result (parse-defstruct-name-and-options (if (atom name-and-options
)
640 (list name-and-options
)
642 (when (stringp (car slot-descriptions
))
643 (setf (dd-doc result
) (pop slot-descriptions
)))
644 (dolist (slot-description slot-descriptions
)
645 (allocate-1-slot result
(parse-1-dsd result slot-description
)))
646 (determine-unsafe-slots result
)
649 ;;;; stuff to parse slot descriptions
651 ;;; Parse a slot description for DEFSTRUCT, add it to the description
652 ;;; and return it. If supplied, SLOT is a pre-initialized DSD
653 ;;; that we modify to get the new slot. This is supplied when handling
655 (defun parse-1-dsd (defstruct spec
&optional
656 (slot (make-defstruct-slot-description :name
""
659 (multiple-value-bind (name default default-p type type-p read-only ro-p
)
663 ((or null
(member :conc-name
:constructor
:copier
:predicate
:named
))
664 (warn "slot name of ~S indicates probable syntax error in DEFSTRUCT" spec
))
666 (style-warn "slot name of ~S indicates possible syntax error in DEFSTRUCT" spec
)))
670 (name &optional
(default nil default-p
)
671 &key
(type nil type-p
) (read-only nil ro-p
))
673 (when (dd-conc-name defstruct
)
674 ;; the warning here is useful, but in principle we cannot
675 ;; distinguish between legitimate and erroneous use of
676 ;; these names when :CONC-NAME is NIL. In the common
677 ;; case (CONC-NAME non-NIL), there are alternative ways
678 ;; of writing code with the same effect, so a full
679 ;; warning is justified.
681 ((member :conc-name
:constructor
:copier
:predicate
:include
682 :print-function
:print-object
:type
:initial-offset
:pure
)
683 (warn "slot name of ~S indicates probable syntax error in DEFSTRUCT" name
))))
684 (values name default default-p
685 (uncross type
) type-p
687 (t (error 'simple-program-error
688 :format-control
"in DEFSTRUCT, ~S is not a legal slot ~
690 :format-arguments
(list spec
))))
692 (when (find name
(dd-slots defstruct
)
694 :key
(lambda (x) (symbol-name (dsd-name x
))))
695 (error 'simple-program-error
696 ;; Todo: indicate whether name is a duplicate in the directly
697 ;; specified slots vs. exists in the ancestor and so should
698 ;; be in the (:include ...) clause instead of where it is.
699 :format-control
"duplicate slot name ~S"
700 :format-arguments
(list name
)))
701 (setf (dsd-name slot
) name
)
702 (setf (dd-slots defstruct
) (nconc (dd-slots defstruct
) (list slot
)))
704 (let ((accessor-name (if (dd-conc-name defstruct
)
705 (symbolicate (dd-conc-name defstruct
) name
)
707 (predicate-name (dd-predicate-name defstruct
)))
708 (setf (dsd-accessor-name slot
) accessor-name
)
709 (when (eql accessor-name predicate-name
)
710 ;; Some adventurous soul has named a slot so that its accessor
711 ;; collides with the structure type predicate. ANSI doesn't
712 ;; specify what to do in this case. As of 2001-09-04, Martin
713 ;; Atzmueller reports that CLISP and Lispworks both give
714 ;; priority to the slot accessor, so that the predicate is
715 ;; overwritten. We might as well do the same (as well as
716 ;; signalling a warning).
718 "~@<The structure accessor name ~S is the same as the name of the ~
719 structure type predicate. ANSI doesn't specify what to do in ~
720 this case. We'll overwrite the type predicate with the slot ~
721 accessor, but you can't rely on this behavior, so it'd be wise to ~
722 remove the ambiguity in your code.~@:>"
724 (setf (dd-predicate-name defstruct
) nil
))
725 ;; FIXME: It would be good to check for name collisions here, but
728 ;;x(when (and (fboundp accessor-name)
729 ;;x (not (accessor-inherited-data accessor-name defstruct)))
730 ;;x (style-warn "redefining ~/sb-impl::print-symbol-with-prefix/ ~
731 ;; in DEFSTRUCT" accessor-name)))
732 ;; which was done until sbcl-0.8.11.18 or so, is wrong: it causes
733 ;; a warning at MACROEXPAND time, when instead the warning should
734 ;; occur not just because the code was constructed, but because it
735 ;; is actually compiled or loaded.
739 (setf (dsd-default slot
) default
))
741 (setf (dsd-type slot
)
742 (if (eq (dsd-type slot
) t
)
744 `(and ,(dsd-type slot
) ,type
))))
747 (setf (dsd-read-only slot
) t
)
748 (when (dsd-read-only slot
)
749 (error "~@<The slot ~S is :READ-ONLY in superclass, and so must ~
750 be :READ-ONLY in subclass.~:@>"
754 ;;; When a value of type TYPE is stored in a structure, should it be
755 ;;; stored in a raw slot? Return the matching RAW-SLOT-DATA structure
756 ;; if TYPE should be stored in a raw slot, or NIL if not.
757 (defun structure-raw-slot-data (type)
758 (multiple-value-bind (fixnum? fixnum-certain?
)
759 (sb!xc
:subtypep type
'fixnum
)
760 ;; (The extra test for FIXNUM-CERTAIN? here is intended for
761 ;; bootstrapping the system. In particular, in sbcl-0.6.2, we set up
762 ;; LAYOUT before FIXNUM is defined, and so could bogusly end up
763 ;; putting INDEX-typed values into raw slots if we didn't test
765 (if (or fixnum?
(not fixnum-certain?
))
767 (dolist (data *raw-slot-data-list
*)
768 (when (sb!xc
:subtypep type
(raw-slot-data-raw-type data
))
771 ;;; Allocate storage for a DSD in DD. This is where we decide whether
772 ;;; a slot is raw or not. Raw objects are aligned on the unit of their size.
773 (defun allocate-1-slot (dd dsd
)
774 (let ((rsd (if (eq (dd-type dd
) 'structure
)
775 (structure-raw-slot-data (dsd-type dsd
))
778 (setf (dsd-index dsd
) (dd-length dd
))
779 (incf (dd-length dd
)))
781 (setf (dsd-raw-type dsd
) (raw-slot-data-raw-type rsd
))
782 (let ((words (raw-slot-data-n-words rsd
))
783 (alignment (raw-slot-data-alignment rsd
)))
784 #!-interleaved-raw-slots
785 (let ((off (rem (dd-raw-length dd
) alignment
)))
787 (incf (dd-raw-length dd
) (- alignment off
)))
788 (setf (dsd-index dsd
) (dd-raw-length dd
))
789 (incf (dd-raw-length dd
) words
))
790 #!+interleaved-raw-slots
791 (let ((len (dd-length dd
)))
793 ;; this formula works but can it be made less unclear?
794 (- len
(nth-value 1 (ceiling (1- len
) alignment
))))
795 (setf (dsd-index dsd
) (dd-length dd
))
796 (incf (dd-length dd
) words
))))))
799 (defun typed-structure-info-or-lose (name)
800 (or (info :typed-structure
:info name
)
801 (error ":TYPE'd DEFSTRUCT ~S not found for inclusion." name
)))
803 ;;; Process any included slots pretty much like they were specified.
804 ;;; Also inherit various other attributes.
805 (defun frob-dd-inclusion-stuff (dd)
806 (destructuring-bind (included-name &rest modified-slots
) (dd-include dd
)
807 (let* ((type (dd-type dd
))
810 (layout-info (compiler-layout-or-lose included-name
))
811 (typed-structure-info-or-lose included-name
))))
813 ;; checks on legality
814 (unless (and (eq type
(dd-type included-structure
))
815 (type= (specifier-type (dd-element-type included-structure
))
816 (specifier-type (dd-element-type dd
))))
817 (error ":TYPE option mismatch between structures ~S and ~S"
818 (dd-name dd
) included-name
))
819 (let ((included-classoid (find-classoid included-name nil
)))
820 (when included-classoid
821 ;; It's not particularly well-defined to :INCLUDE any of the
822 ;; CMU CL INSTANCE weirdosities like CONDITION or
823 ;; GENERIC-FUNCTION, and it's certainly not ANSI-compliant.
824 (let* ((included-layout (classoid-layout included-classoid
))
825 (included-dd (layout-info included-layout
)))
826 (when (and (dd-alternate-metaclass included-dd
)
827 ;; As of sbcl-0.pre7.73, anyway, STRUCTURE-OBJECT
828 ;; is represented with an ALTERNATE-METACLASS. But
829 ;; it's specifically OK to :INCLUDE (and PCL does)
830 ;; so in this one case, it's OK to include
831 ;; something with :ALTERNATE-METACLASS after all.
832 (not (eql included-name
'structure-object
)))
833 (error "can't :INCLUDE class ~S (has alternate metaclass)"
836 ;; A few more sanity checks: every allegedly modified slot exists
837 ;; and no name appears more than once.
838 (flet ((included-slot-name (slot-desc)
839 (if (atom slot-desc
) slot-desc
(car slot-desc
))))
840 (mapl (lambda (slots &aux
(name (included-slot-name (car slots
))))
841 (unless (find name
(dd-slots included-structure
)
842 :test
#'string
= :key
#'dsd-name
)
843 (error 'simple-program-error
844 :format-control
"slot name ~S not present in included structure"
845 :format-arguments
(list name
)))
846 (when (find name
(cdr slots
)
847 :test
#'string
= :key
#'included-slot-name
)
848 (error 'simple-program-error
849 :format-control
"included slot name ~S specified more than once"
850 :format-arguments
(list name
))))
853 (incf (dd-length dd
) (dd-length included-structure
))
854 (when (dd-class-p dd
)
855 (let ((mc (rest (dd-alternate-metaclass included-structure
))))
856 (when (and mc
(not (dd-alternate-metaclass dd
)))
857 (setf (dd-alternate-metaclass dd
)
858 (cons included-name mc
))))
859 (when (eq (dd-pure dd
) :unspecified
)
860 (setf (dd-pure dd
) (dd-pure included-structure
)))
861 #!-interleaved-raw-slots
862 (setf (dd-raw-length dd
) (dd-raw-length included-structure
)))
864 (setf (dd-inherited-accessor-alist dd
)
865 (dd-inherited-accessor-alist included-structure
))
866 (dolist (included-slot (dd-slots included-structure
))
867 (let* ((included-name (dsd-name included-slot
))
868 (modified (or (find included-name modified-slots
869 :key
(lambda (x) (if (atom x
) x
(car x
)))
872 ;; We stash away an alist of accessors to parents' slots
873 ;; that have already been created to avoid conflicts later
874 ;; so that structures with :INCLUDE and :CONC-NAME (and
875 ;; other edge cases) can work as specified.
876 (when (dsd-accessor-name included-slot
)
877 ;; the "oldest" (i.e. highest up the tree of inheritance)
878 ;; will prevail, so don't push new ones on if they
880 (pushnew (cons (dsd-accessor-name included-slot
)
881 (dsd-index included-slot
))
882 (dd-inherited-accessor-alist dd
)
883 :test
#'eq
:key
#'car
))
884 (let ((new-slot (parse-1-dsd dd
886 (copy-structure included-slot
))))
887 (when (and (neq (dsd-type new-slot
) (dsd-type included-slot
))
888 (not (sb!xc
:subtypep
(dsd-type included-slot
)
889 (dsd-type new-slot
)))
890 (dsd-safe-p included-slot
))
891 (setf (dsd-safe-p new-slot
) nil
)
895 ;;;; various helper functions for setting up DEFSTRUCTs
897 ;;; This function is called at macroexpand time to compute the INHERITS
898 ;;; vector for a structure type definition.
899 (defun inherits-for-structure (info)
900 (declare (type defstruct-description info
))
901 (let* ((include (dd-include info
))
902 (superclass-opt (dd-alternate-metaclass info
))
905 (compiler-layout-or-lose (first include
))
906 (classoid-layout (find-classoid
907 (or (first superclass-opt
)
908 'structure-object
))))))
911 (concatenate 'simple-vector
912 (layout-inherits super
)
913 (vector super
(classoid-layout (find-classoid 'stream
)))))
915 (concatenate 'simple-vector
916 (layout-inherits super
)
918 (classoid-layout (find-classoid 'file-stream
)))))
919 ((sb!impl
::string-input-stream
920 sb
!impl
::string-output-stream
921 sb
!impl
::fill-pointer-output-stream
)
922 (concatenate 'simple-vector
923 (layout-inherits super
)
925 (classoid-layout (find-classoid 'string-stream
)))))
926 (t (concatenate 'simple-vector
927 (layout-inherits super
)
930 ;;; Do miscellaneous (LOAD EVAL) time actions for the structure
931 ;;; described by DD. Create the class and LAYOUT, checking for
932 ;;; incompatible redefinition.
933 (defun %defstruct
(dd inherits source-location
)
934 (declare (type defstruct-description dd
))
936 ;; We set up LAYOUTs even in the cross-compilation host.
937 (multiple-value-bind (classoid layout old-layout
)
938 (ensure-structure-class dd inherits
"current" "new")
939 (cond ((not old-layout
)
940 (unless (eq (classoid-layout classoid
) layout
)
941 (register-layout layout
)))
943 (%redefine-defstruct classoid old-layout layout
)
944 (let ((old-dd (layout-info old-layout
)))
945 (when (defstruct-description-p old-dd
)
946 (dolist (slot (dd-slots old-dd
))
947 (fmakunbound (dsd-accessor-name slot
))
948 (unless (dsd-read-only slot
)
949 (fmakunbound `(setf ,(dsd-accessor-name slot
)))))))
950 (setq layout
(classoid-layout classoid
))))
951 (setf (find-classoid (dd-name dd
)) classoid
)
953 (sb!c
:with-source-location
(source-location)
954 (setf (layout-source-location layout
) source-location
))))
957 ;;; Return a form describing the writable place used for this slot
958 ;;; in the instance named INSTANCE-NAME.
959 (defun %accessor-place-form
(dd dsd instance-name
)
960 (let (;; the operator that we'll use to access a typed slot
961 (ref (ecase (dd-type dd
)
962 (structure '%instance-ref
)
963 (list 'nth-but-with-sane-arg-order
)
965 (raw-type (dsd-raw-type dsd
)))
966 (if (eq raw-type t
) ; if not raw slot
967 `(,ref
,instance-name
,(dsd-index dsd
))
968 `(,(raw-slot-data-accessor-name (raw-slot-data-or-lose raw-type
))
969 ,instance-name
,(dsd-index dsd
)))))
971 ;;; Return the transformation of conceptual FUNCTION (either :READ or :WRITE)
972 ;;; applied to ARGS, given SLOT-KEY which is a cons of a DD and a DSD.
973 ;;; Return NIL on failure.
974 (defun slot-access-transform (function args slot-key
)
975 (when (consp args
) ; need at least one arg
976 (let* ((dd (car slot-key
))
978 ;; optimistically compute PLACE before checking length of ARGS
979 ;; because we expect success, and this unifies the two cases.
980 ;; :WRITE has the arg order of (SETF fn), i.e. newval is first,
981 ;; so if more than one arg exists, take the second as the INSTANCE.
983 (%accessor-place-form
984 dd dsd
`(the ,(dd-name dd
)
985 ,(car (if (consp (cdr args
)) (cdr args
) args
)))))
986 (type-spec (dsd-type dsd
)))
989 (when (singleton-p args
)
992 `(,(if (dsd-safe-p dsd
) 'truly-the
'the
) ,type-spec
,place
))))
994 (when (singleton-p (cdr args
))
995 (once-only ((new (first args
)))
996 ;; instance setters take newval last.
997 `(,(info :setf
:inverse
(car place
)) ,@(cdr place
)
998 ,(if (eq type-spec t
) new
`(the ,type-spec
,new
))))))))))
1000 ;;; Return a LAMBDA form which can be used to set a slot
1001 (defun slot-setter-lambda-form (dd dsd
)
1002 `(lambda (newval instance
)
1003 ,(slot-access-transform :write
'(newval instance
) (cons dd dsd
))))
1005 ;;; Blow away all the compiler info for the structure CLASS. Iterate
1006 ;;; over this type, clearing the compiler structure type info, and
1007 ;;; undefining all the associated functions. If SUBCLASSES-P, also do
1008 ;;; the same for subclasses. FIXME: maybe rename UNDEFINE-FUN-NAME to
1009 ;;; UNDECLARE-FUNCTION-NAME?
1010 (defun undeclare-structure (classoid subclasses-p
)
1011 (let ((info (layout-info (classoid-layout classoid
))))
1012 (when (defstruct-description-p info
)
1013 (let ((type (dd-name info
)))
1014 (clear-info :type
:compiler-layout type
)
1015 (undefine-fun-name (dd-copier-name info
))
1016 (undefine-fun-name (dd-predicate-name info
))
1017 (dolist (slot (dd-slots info
))
1018 (let ((fun (dsd-accessor-name slot
)))
1019 (unless (accessor-inherited-data fun info
)
1020 (undefine-fun-name fun
)
1021 (unless (dsd-read-only slot
)
1022 (undefine-fun-name `(setf ,fun
)))))))
1023 ;; Clear out the SPECIFIER-TYPE cache so that subsequent
1024 ;; references are unknown types.
1025 (values-specifier-type-cache-clear)))
1027 (let ((subclasses (classoid-subclasses classoid
)))
1030 (dohash ((classoid layout
)
1033 (declare (ignore layout
))
1034 (undeclare-structure classoid nil
)
1035 (subs (classoid-proper-name classoid
)))
1036 ;; Is it really necessary to warn about
1037 ;; undeclaring functions for subclasses?
1039 (warn "undeclaring functions for old subclasses ~
1041 (classoid-name classoid
)
1044 ;;; core compile-time setup of any class with a LAYOUT, used even by
1045 ;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities
1046 (defun %compiler-set-up-layout
(dd
1048 ;; Several special cases
1049 ;; (STRUCTURE-OBJECT itself, and
1050 ;; structures with alternate
1051 ;; metaclasses) call this function
1052 ;; directly, and they're all at the
1053 ;; base of the instance class
1054 ;; structure, so this is a handy
1055 ;; default. (But note
1056 ;; FUNCALLABLE-STRUCTUREs need
1058 (inherits (vector (find-layout t
))))
1060 (multiple-value-bind (classoid layout old-layout
)
1061 (multiple-value-bind (clayout clayout-p
)
1062 (info :type
:compiler-layout
(dd-name dd
))
1063 (ensure-structure-class dd
1066 "The most recently compiled"
1068 "the most recently loaded"
1069 :compiler-layout clayout
))
1071 (undeclare-structure (layout-classoid old-layout
)
1072 (and (classoid-subclasses classoid
)
1073 (not (eq layout old-layout
))))
1074 (setf (layout-invalid layout
) nil
)
1075 ;; FIXME: it might be polite to hold onto old-layout and
1076 ;; restore it at the end of the file. -- RMK 2008-09-19
1077 ;; (International Talk Like a Pirate Day).
1078 (warn "~@<Clobbering the compiler's idea of the layout of ~A.~:@>"
1081 (unless (eq (classoid-layout classoid
) layout
)
1082 (register-layout layout
:invalidate nil
))
1083 (setf (find-classoid (dd-name dd
)) classoid
)))
1085 ;; At this point the class should be set up in the INFO database.
1086 ;; But the logic that enforces this is a little tangled and
1087 ;; scattered, so it's not obvious, so let's check.
1088 (aver (find-classoid (dd-name dd
) nil
))
1090 (setf (info :type
:compiler-layout
(dd-name dd
)) layout
))
1093 ;;; Do (COMPILE LOAD EVAL)-time actions for the normal (not
1094 ;;; ALTERNATE-LAYOUT) DEFSTRUCT described by DD.
1095 ;;; This includes generation of a style-warning about previously compiled
1096 ;;; calls to the accessors and/or predicate that weren't inlined.
1097 (defun %compiler-defstruct
(dd inherits
)
1098 (declare (type defstruct-description dd
))
1100 (aver (dd-class-p dd
)) ; LIST and VECTOR representation are not allowed
1101 (let ((check-inlining
1102 ;; Why use the secondary result of INFO, not the primary?
1103 ;; Because when DEFSTRUCT is evaluated, not via the file-compiler,
1104 ;; the first thing to happen is %DEFSTRUCT, which sets up FIND-CLASS.
1105 ;; Due to :COMPILER-LAYOUT's defaulting expression in globaldb,
1106 ;; it has a value - the layout of the classoid - that we don't want.
1107 ;; Also, since structures are technically not redefineable,
1108 ;; I don't worry about failure to inline a function that was
1109 ;; formerly not known as an accessor but now is.
1110 (null (nth-value 1 (info :type
:compiler-layout
(dd-name dd
)))))
1112 (%compiler-set-up-layout dd inherits
)
1114 (awhen (dd-copier-name dd
)
1115 (let ((dtype (dd-name dd
)))
1116 (sb!xc
:proclaim
`(ftype (sfunction (,dtype
) ,dtype
) ,it
))))
1118 (let ((predicate-name (dd-predicate-name dd
)))
1119 (when predicate-name
1120 (when check-inlining
1121 (push predicate-name fnames
))
1122 (setf (info :function
:source-transform predicate-name
)
1123 (cons dd
:predicate
))))
1125 (dolist (dsd (dd-slots dd
))
1126 (let ((accessor-name (dsd-accessor-name dsd
)))
1127 ;; Why this WHEN guard here, if there is neither a standards-specified
1128 ;; nor implementation-specific way to skip defining an accessor? Dunno.
1129 ;; And furthermore, by ignoring a package lock, it's possible to name
1130 ;; an accessor NIL: (defstruct (x (:conc-name "N")) IL)
1131 ;; making this test kinda bogus in two different ways.
1133 (let ((inherited (accessor-inherited-data accessor-name dd
)))
1136 (let ((writer `(setf ,accessor-name
))
1137 (slot-key (cons dd dsd
)))
1138 (when check-inlining
1139 (push accessor-name fnames
))
1140 (setf (info :function
:source-transform accessor-name
)
1142 (unless (dsd-read-only dsd
)
1143 (when check-inlining
1144 (push writer fnames
))
1145 (setf (info :function
:source-transform writer
) slot-key
))))
1146 ((not (= (cdr inherited
) (dsd-index dsd
)))
1147 (style-warn "~@<Non-overwritten accessor ~S does not access ~
1148 slot with name ~S (accessing an inherited slot ~
1151 (dsd-name dsd
))))))))
1153 (awhen (remove-if-not #'sb
!c
::emitted-full-call-count fnames
)
1154 (sb!c
:compiler-style-warn
1155 'sb
!c
:inlining-dependency-failure
1156 ;; This message omits the http://en.wikipedia.org/wiki/Serial_comma
1158 (!uncross-format-control
1159 "~@<Previously compiled call~P to ~
1160 ~{~/sb!impl:print-symbol-with-prefix/~^~#[~; and~:;,~] ~} ~
1161 could not be inlined because the structure definition for ~
1162 ~/sb!impl:print-symbol-with-prefix/ was not yet seen. To avoid this warning, ~
1163 DEFSTRUCT should precede references to the affected functions, ~
1164 or they must be declared locally notinline at each call site.~@:>")
1165 :format-arguments
(list (length it
) (nreverse it
) (dd-name dd
))))))
1167 ;;;; redefinition stuff
1169 ;;; Compare the slots of OLD and NEW, returning 3 lists of slot names:
1170 ;;; 1. Slots which have moved,
1171 ;;; 2. Slots whose type has changed,
1172 ;;; 3. Deleted slots.
1173 (defun compare-slots (old new
)
1174 (let* ((oslots (dd-slots old
))
1175 (nslots (dd-slots new
))
1176 (onames (mapcar #'dsd-name oslots
))
1177 (nnames (mapcar #'dsd-name nslots
)))
1180 (dolist (name (intersection onames nnames
))
1181 (let ((os (find name oslots
:key
#'dsd-name
:test
#'string
=))
1182 (ns (find name nslots
:key
#'dsd-name
:test
#'string
=)))
1183 (unless (sb!xc
:subtypep
(dsd-type ns
) (dsd-type os
))
1185 (unless (and (= (dsd-index os
) (dsd-index ns
))
1186 (eq (dsd-raw-type os
) (dsd-raw-type ns
)))
1190 (set-difference onames nnames
:test
#'string
=)))))
1192 ;;; If we are redefining a structure with different slots than in the
1193 ;;; currently loaded version, give a warning and return true.
1194 (defun redefine-structure-warning (classoid old new
)
1195 (declare (type defstruct-description old new
)
1196 (type classoid classoid
)
1198 (let ((name (dd-name new
)))
1199 (multiple-value-bind (moved retyped deleted
) (compare-slots old new
)
1200 (when (or moved retyped deleted
)
1202 "incompatibly redefining slots of structure class ~S~@
1203 Make sure any uses of affected accessors are recompiled:~@
1204 ~@[ These slots were moved to new positions:~% ~S~%~]~
1205 ~@[ These slots have new incompatible types:~% ~S~%~]~
1206 ~@[ These slots were deleted:~% ~S~%~]"
1207 name moved retyped deleted
)
1210 ;;; This function is called when we are incompatibly redefining a
1211 ;;; structure CLASS to have the specified NEW-LAYOUT. We signal an
1212 ;;; error with some proceed options and return the layout that should
1214 (defun %redefine-defstruct
(classoid old-layout new-layout
)
1215 (declare (type classoid classoid
)
1216 (type layout old-layout new-layout
))
1217 (let ((name (classoid-proper-name classoid
)))
1219 (error "~@<attempt to redefine the ~S class ~S incompatibly with the current definition~:@>"
1225 "~@<Use the new definition of ~S, invalidating ~
1226 already-loaded code and instances.~@:>"
1228 (register-layout new-layout
))
1229 (recklessly-continue ()
1232 "~@<Use the new definition of ~S as if it were ~
1233 compatible, allowing old accessors to use new ~
1234 instances and allowing new accessors to use old ~
1237 ;; classic CMU CL warning: "Any old ~S instances will be in a bad way.
1238 ;; I hope you know what you're doing..."
1239 (register-layout new-layout
1241 :destruct-layout old-layout
))
1243 ;; FIXME: deprecated 2002-10-16, and since it's only interactive
1244 ;; hackery instead of a supported feature, can probably be deleted
1246 :report
"(deprecated synonym for RECKLESSLY-CONTINUE)"
1247 (register-layout new-layout
1249 :destruct-layout old-layout
))))
1252 (declaim (inline dd-layout-length
))
1253 (defun dd-layout-length (dd)
1254 (+ (dd-length dd
) #!-interleaved-raw-slots
(dd-raw-length dd
)))
1256 (declaim (ftype (sfunction (defstruct-description) index
) dd-instance-length
))
1257 (defun dd-instance-length (dd)
1258 ;; Make sure the object ends at a two-word boundary. Note that this does
1259 ;; not affect the amount of memory used, since the allocator would add the
1260 ;; same padding anyway. However, raw slots are indexed from the length of
1261 ;; the object as indicated in the header, so the pad word needs to be
1262 ;; included in that length to guarantee proper alignment of raw double float
1263 ;; slots, necessary for (at least) the SPARC backend.
1264 ;; On backends with interleaved raw slots, the convention of having the
1265 ;; header possibly "lie" about an extra word is more of a bug than a feature.
1266 ;; Because the structure base is aligned, double-word raw slots are properly
1267 ;; aligned, and won't change alignment in descendant object types. It would
1268 ;; be correct to store the true instance length even though GC preserves
1269 ;; the extra data word (as it does for odd-length SIMPLE-VECTOR), treating
1270 ;; the total physical length as rounded-to-even. But having two different
1271 ;; conventions would be even more unnecessarily confusing, so we use
1272 ;; the not-sensible convention even when it does not make sense.
1273 (logior (dd-layout-length dd
) 1))
1275 (defun dd-bitmap (dd)
1276 ;; The bitmap stores a 1 for each untagged word,
1277 ;; including any internal padding words for alignment.
1278 ;; The 0th bit is initialized to 0 because the LAYOUT is a tagged
1279 ;; slot that is not present in DD-SLOTS.
1280 ;; All other bits start as 1 and are cleared if the word is tagged.
1281 ;; A final padding word, if any, is regarded as tagged.
1282 (let ((bitmap (ldb (byte (dd-length dd
) 0)
1283 (ash -
1 sb
!vm
:instance-data-start
))))
1284 (dolist (slot (dd-slots dd
) bitmap
)
1285 (when (eql t
(dsd-raw-type slot
))
1286 (setf (ldb (byte 1 (dsd-index slot
)) bitmap
) 0)))))
1288 ;;; This is called when we are about to define a structure class. It
1289 ;;; returns a (possibly new) class object and the layout which should
1290 ;;; be used for the new definition (may be the current layout, and
1291 ;;; also might be an uninstalled forward referenced layout.) The third
1292 ;;; value is true if this is an incompatible redefinition, in which
1293 ;;; case it is the old layout.
1294 (defun ensure-structure-class (info inherits old-context new-context
1295 &key compiler-layout
)
1296 (declare (type defstruct-description info
))
1297 (multiple-value-bind (class old-layout
)
1301 (class 'structure-classoid
)
1302 (constructor 'make-structure-classoid
))
1303 (dd-alternate-metaclass info
)
1304 (declare (ignore name
))
1305 (insured-find-classoid (dd-name info
)
1306 (if (eq class
'structure-classoid
)
1308 (sb!xc
:typep x
'structure-classoid
))
1310 (sb!xc
:typep x
(classoid-name (find-classoid class
)))))
1311 (fdefinition constructor
)))
1312 (setf (classoid-direct-superclasses class
)
1313 (case (dd-name info
)
1316 sb
!impl
::string-input-stream sb
!impl
::string-output-stream
1317 sb
!impl
::fill-pointer-output-stream
)
1318 (list (layout-classoid (svref inherits
(1- (length inherits
))))
1319 (layout-classoid (svref inherits
(- (length inherits
) 2)))))
1321 (list (layout-classoid
1322 (svref inherits
(1- (length inherits
))))))))
1323 (let* ((old-layout (or compiler-layout old-layout
))
1325 (when (or (not old-layout
) *type-system-initialized
*)
1326 (make-layout :classoid class
1328 :depthoid
(length inherits
)
1329 :length
(dd-layout-length info
)
1330 :info info .
#!-interleaved-raw-slots
1331 (:n-untagged-slots
(dd-raw-length info
))
1332 #!+interleaved-raw-slots
1333 (:untagged-bitmap
(dd-bitmap info
))))))
1336 (values class new-layout nil
))
1338 ;; The assignment of INFO here can almost be deleted,
1339 ;; except for a few magical types that don't d.t.r.t. in cold-init:
1340 ;; STRUCTURE-OBJECT, CONDITION, ALIEN-VALUE, INTERPRETED-FUNCTION
1341 (setf (layout-info old-layout
) info
)
1342 (values class old-layout nil
))
1343 (;; This clause corresponds to an assertion in REDEFINE-LAYOUT-WARNING
1344 ;; of classic CMU CL. I moved it out to here because it was only
1345 ;; exercised in this code path anyway. -- WHN 19990510
1346 (not (eq (layout-classoid new-layout
) (layout-classoid old-layout
)))
1347 (error "shouldn't happen: weird state of OLD-LAYOUT?"))
1348 ((redefine-layout-warning old-context
1351 (layout-length new-layout
)
1352 (layout-inherits new-layout
)
1353 (layout-depthoid new-layout
)
1354 (layout-raw-slot-metadata new-layout
))
1355 (values class new-layout old-layout
))
1357 (let ((old-info (layout-info old-layout
)))
1359 (cond ((redefine-structure-warning class old-info info
)
1360 (values class new-layout old-layout
))
1362 (setf (layout-info old-layout
) info
)
1363 (values class old-layout nil
)))
1365 (setf (layout-info old-layout
) info
)
1366 (values class old-layout nil
)))))))))
1368 ;;; Return a list of pairs (name . index). Used for :TYPE'd
1369 ;;; constructors to find all the names that we have to splice in &
1370 ;;; where. Note that these types don't have a layout, so we can't look
1371 ;;; at LAYOUT-INHERITS.
1372 (defun find-name-indices (defstruct)
1375 (do ((info defstruct
1376 (typed-structure-info-or-lose (first (dd-include info
)))))
1377 ((not (dd-include info
))
1382 (dolist (info infos
)
1383 (incf i
(or (dd-offset info
) 0))
1384 (when (dd-named info
)
1385 (res (cons (dd-name info
) i
)))
1386 (setq i
(dd-length info
)))))
1390 ;;; These functions are called to actually make a constructor after we
1391 ;;; have processed the arglist. The correct variant (according to the
1392 ;;; DD-TYPE) should be called. The function is defined with the
1393 ;;; specified name and arglist. VARS and TYPES are used for argument
1394 ;;; type declarations. VALUES are the values for the slots (in order.)
1396 ;;; This is split three ways because:
1397 ;;; * LIST & VECTOR structures need "name" symbols stuck in at
1398 ;;; various weird places, whereas STRUCTURE structures have
1400 ;;; * We really want to use LIST to make list structures, instead of
1401 ;;; MAKE-LIST/(SETF ELT). (We can't in general use VECTOR in an
1402 ;;; analogous way, since VECTOR makes a SIMPLE-VECTOR and vector-typed
1403 ;;; structures can have arbitrary subtypes of VECTOR, not necessarily
1405 ;;; * STRUCTURE structures can have raw slots that must also be
1406 ;;; allocated and indirectly referenced.
1407 (defun create-vector-constructor (dd cons-name arglist ftype-arglist decls values
)
1408 (let ((temp (gensym))
1409 (etype (dd-element-type dd
))
1410 (len (dd-length dd
)))
1412 `(defun ,cons-name
,arglist
1413 ,@(when decls
`((declare ,@decls
)))
1414 (let ((,temp
(make-array ,len
:element-type
',etype
)))
1415 ,@(mapcar (lambda (x)
1416 `(setf (aref ,temp
,(cdr x
)) ',(car x
)))
1417 (find-name-indices dd
))
1418 ,@(mapcar (lambda (dsd value
)
1419 (unless (eq value
'.do-not-initialize-slot.
)
1420 `(setf (aref ,temp
,(dsd-index dsd
)) ,value
)))
1421 (dd-slots dd
) values
)
1423 `(sfunction ,ftype-arglist
(simple-array ,etype
(,len
))))))
1424 (defun create-list-constructor (dd cons-name arglist ftype-arglist decls values
)
1425 (let ((vals (make-list (dd-length dd
) :initial-element nil
)))
1426 (dolist (x (find-name-indices dd
))
1427 (setf (elt vals
(cdr x
)) `',(car x
)))
1428 (loop for dsd in
(dd-slots dd
) and val in values do
1429 (setf (elt vals
(dsd-index dsd
))
1430 (if (eq val
'.do-not-initialize-slot.
) 0 val
)))
1432 `(defun ,cons-name
,arglist
1433 ,@(when decls
`((declare ,@decls
)))
1435 `(sfunction ,ftype-arglist list
))))
1436 (defun create-structure-constructor (dd cons-name arglist ftype-arglist decls values
)
1438 ;; The difference between the two implementations here is that on all
1439 ;; platforms we don't have the appropriate RAW-INSTANCE-INIT VOPS, which
1440 ;; must be able to deal with immediate values as well -- unlike
1441 ;; RAW-INSTANCE-SET VOPs, which never end up seeing immediate values. With
1442 ;; some additional cleverness we might manage without them and just a single
1443 ;; implementation here, though -- figure out a way to ensure that on those
1444 ;; platforms we always still get a non-immediate TN in every case...
1446 ;; Until someone does that, this means that instances with raw slots can be
1447 ;; DX allocated only on platforms with those additional VOPs.
1448 #!+raw-instance-init-vops
1449 (let* ((slot-values nil
)
1451 (mapcan (lambda (dsd value
)
1452 (unless (eq value
'.do-not-initialize-slot.
)
1453 (push value slot-values
)
1454 (list (list* :slot
(dsd-raw-type dsd
) (dsd-index dsd
)))))
1457 `(defun ,cons-name
,arglist
1458 ,@(when decls
`((declare ,@decls
)))
1459 (%make-structure-instance-macro
,dd
',slot-specs
,@(reverse slot-values
))))
1460 #!-raw-instance-init-vops
1461 (let ((instance (gensym "INSTANCE")) slot-values slot-specs raw-slots raw-values
)
1462 (mapc (lambda (dsd value
)
1463 (unless (eq value
'.do-not-initialize-slot.
)
1464 (let ((raw-type (dsd-raw-type dsd
)))
1465 (cond ((eq t raw-type
)
1466 (push value slot-values
)
1467 (push (list* :slot raw-type
(dsd-index dsd
)) slot-specs
))
1469 (push value raw-values
)
1470 (push dsd raw-slots
))))))
1473 `(defun ,cons-name
,arglist
1474 ,@(when decls
`((declare ,@decls
)))
1476 `(let ((,instance
(%make-structure-instance-macro
,dd
',slot-specs
,@slot-values
)))
1477 ,@(mapcar (lambda (dsd value
)
1478 ;; (Note that we can't in general use the
1479 ;; ordinary named slot setter function here
1480 ;; because the slot might be :READ-ONLY, so we
1481 ;; whip up new LAMBDA representations of slot
1482 ;; setters for the occasion.)
1483 `(,(slot-setter-lambda-form dd dsd
) ,value
,instance
))
1487 `(%make-structure-instance-macro
,dd
',slot-specs
,@slot-values
))))
1488 `(sfunction ,ftype-arglist
,(dd-name dd
))))
1490 ;;; Create a default (non-BOA) keyword constructor.
1491 (defun create-keyword-constructor (defstruct creator
)
1492 (declare (type function creator
))
1493 (collect ((arglist (list '&key
))
1497 (let ((int-type (if (eq 'vector
(dd-type defstruct
))
1498 (dd-element-type defstruct
)
1500 (dolist (slot (dd-slots defstruct
))
1501 (let* ((name (dsd-name slot
))
1502 (dum (copy-symbol name
))
1503 (keyword (keywordicate name
))
1504 ;; Canonicalize the type for a prettier macro-expansion
1505 (type (type-specifier
1506 (specifier-type `(and ,int-type
,(dsd-type slot
))))))
1507 (arglist `((,keyword
,dum
) ,(dsd-default slot
)))
1509 ;; KLUDGE: we need a separate type declaration for for
1510 ;; keyword arguments, since default values bypass the
1511 ;; checking provided by the FTYPE.
1513 (decls `(type ,type
,dum
)))
1514 (ftype-args `(,keyword
,type
)))))
1516 defstruct
(dd-default-constructor defstruct
)
1517 (arglist) `(&key
,@(ftype-args)) (decls) (vals))))
1519 ;;; Given a structure and a BOA constructor spec, call CREATOR with
1520 ;;; the appropriate args to make a constructor.
1521 (defun create-boa-constructor (defstruct boa creator
)
1522 (declare (type function creator
))
1523 (multiple-value-bind (llks req opt rest keys aux
)
1524 (parse-lambda-list (second boa
)
1526 (lambda-list-keyword-mask
1527 '(&optional
&rest
&key
&allow-other-keys
&aux
)))
1533 (let ((int-type (if (eq 'vector
(dd-type defstruct
))
1534 (dd-element-type defstruct
)
1536 (labels ((get-slot (name)
1537 (let* ((res (find name
(dd-slots defstruct
)
1540 (type (type-specifier
1542 `(and ,int-type
,(if res
1545 (values type
(when res
(dsd-default res
)))))
1546 (do-default (arg &optional keyp
)
1547 (multiple-value-bind (type default
) (get-slot arg
)
1548 (arglist `(,arg
,default
))
1551 (arg-type type
(keywordicate arg
) arg
)
1553 (arg-type (type &optional key var
)
1555 ;; KLUDGE: see comment in CREATE-KEYWORD-CONSTRUCTOR.
1557 (decls `(type ,type
,var
)))
1558 (ftype-args `(,key
,type
)))
1560 (ftype-args type
)))))
1564 (arg-type (get-slot arg
)))
1567 (arglist '&optional
)
1568 (ftype-args '&optional
)
1572 ;; FIXME: this shares some logic (though not
1573 ;; code) with the &key case below (and it
1574 ;; looks confusing) -- factor out the logic
1575 ;; if possible. - CSR, 2002-04-19
1578 (def (nth-value 1 (get-slot name
)))
1579 (supplied-test nil supplied-test-p
))
1581 (arglist `(,name
,def
,@(if supplied-test-p
`(,supplied-test
) nil
)))
1583 (arg-type (get-slot name
))
1584 (when supplied-test-p
1585 (vars supplied-test
))))
1587 (do-default arg
)))))
1590 (let ((rest (car rest
)))
1591 (arglist '&rest rest
)
1595 (decls `(type list
,rest
))))
1597 (when (ll-kwds-keyp llks
)
1602 (destructuring-bind (wot
1605 (supplied-test nil supplied-test-p
))
1607 (multiple-value-bind (key name
)
1609 (destructuring-bind (key var
) wot
1611 (values (keywordicate wot
) wot
))
1612 (multiple-value-bind (type slot-def
)
1614 (arglist `(,wot
,(if def-p def slot-def
)
1615 ,@(if supplied-test-p
`(,supplied-test
) nil
)))
1617 (arg-type type key name
)
1618 (when supplied-test-p
1619 (vars supplied-test
)))))
1620 (do-default key t
))))
1622 (when (ll-kwds-allowp llks
)
1623 (arglist '&allow-other-keys
)
1624 (ftype-args '&allow-other-keys
))
1626 ;; PARSE-LAMBDA-LIST doesn't distinguish between &AUX with nothing
1627 ;; after it, and absence of &AUX. They mean the same thing, even as
1628 ;; "interesting" as &AUX can be in a BOA lambda list [CLHS 3.4.6]
1634 (let ((var (first arg
)))
1637 (decls `(type ,(get-slot var
) ,var
))))
1639 ;; (&AUX X) and (&AUX (X)) both skip the slot
1640 (skipped-vars (if (consp arg
) (first arg
) arg
))))))))
1642 (funcall creator defstruct
(first boa
)
1643 (arglist) (ftype-args) (decls)
1644 (loop for slot in
(dd-slots defstruct
)
1645 for name
= (dsd-name slot
)
1646 collect
(cond ((find name
(skipped-vars) :test
#'string
=)
1647 ;; CLHS 3.4.6 Boa Lambda Lists
1648 '.do-not-initialize-slot.
)
1649 ((or (find (dsd-name slot
) (vars) :test
#'string
=)
1650 (let ((type (dsd-type slot
)))
1653 `(the ,type
,(dsd-default slot
))))))))))))
1655 ;;; Grovel the constructor options, and decide what constructors (if
1657 (defun constructor-definitions (defstruct)
1658 (let ((no-constructors nil
)
1661 (creator (ecase (dd-type defstruct
)
1662 (structure #'create-structure-constructor
)
1663 (vector #'create-vector-constructor
)
1664 (list #'create-list-constructor
))))
1665 (dolist (constructor (dd-constructors defstruct
))
1666 (destructuring-bind (name &optional
(boa-ll nil boa-p
)) constructor
1667 (declare (ignore boa-ll
))
1668 (cond ((not name
) (setq no-constructors t
))
1669 (boa-p (push constructor boas
))
1670 (t (push name defaults
)))))
1672 (when no-constructors
1673 (when (or defaults boas
)
1674 (error "(:CONSTRUCTOR NIL) combined with other :CONSTRUCTORs"))
1675 (return-from constructor-definitions
()))
1677 (unless (or defaults boas
)
1678 (push (symbolicate "MAKE-" (dd-name defstruct
)) defaults
))
1682 (let ((cname (first defaults
)))
1683 (setf (dd-default-constructor defstruct
) cname
)
1684 (multiple-value-bind (cons ftype
)
1685 (create-keyword-constructor defstruct creator
)
1686 (res `(declaim (ftype ,ftype
,@defaults
)))
1688 (dolist (other-name (rest defaults
))
1689 (res `(setf (fdefinition ',other-name
) (fdefinition ',cname
))))))
1692 (multiple-value-bind (cons ftype
)
1693 (create-boa-constructor defstruct boa creator
)
1694 (res `(declaim (ftype ,ftype
,(first boa
))))
1699 (defun accessor-definitions (dd)
1700 (loop for dsd in
(dd-slots dd
)
1701 for accessor-name
= (dsd-accessor-name dsd
)
1702 for place-form
= (%accessor-place-form dd dsd
`(the ,(dd-name dd
) instance
))
1703 unless
(accessor-inherited-data accessor-name dd
)
1705 `(defun ,accessor-name
(instance)
1706 ,(cond ((not (dsd-type dsd
))
1709 `(truly-the ,(dsd-type dsd
) ,place-form
))
1711 `(the ,(dsd-type dsd
) ,place-form
))))
1712 and unless
(dsd-read-only dsd
)
1714 `(defun (setf ,accessor-name
) (value instance
)
1715 (setf ,place-form
(the ,(dsd-type dsd
) value
)))))
1717 (defun copier-definition (dd)
1718 (when (dd-copier-name dd
)
1719 `(defun ,(dd-copier-name dd
) (instance)
1720 (copy-structure (the ,(dd-name dd
) instance
)))))
1722 (defun predicate-definition (dd)
1723 (when (dd-predicate-name dd
)
1724 `(defun ,(dd-predicate-name dd
) (object)
1725 (typep object
',(dd-name dd
)))))
1728 ;;;; instances with ALTERNATE-METACLASS
1730 ;;;; The CMU CL support for structures with ALTERNATE-METACLASS was a
1731 ;;;; fairly general extension embedded in the main DEFSTRUCT code, and
1732 ;;;; the result was an fairly impressive mess as ALTERNATE-METACLASS
1733 ;;;; extension mixed with ANSI CL generality (e.g. :TYPE and :INCLUDE)
1734 ;;;; and CMU CL implementation hairiness (esp. raw slots). This SBCL
1735 ;;;; version is much less ambitious, noticing that ALTERNATE-METACLASS
1736 ;;;; is only used to implement CONDITION, STANDARD-INSTANCE, and
1737 ;;;; GENERIC-FUNCTION, and defining a simple specialized
1738 ;;;; separate-from-DEFSTRUCT macro to provide only enough
1739 ;;;; functionality to support those.
1741 ;;;; KLUDGE: The defining macro here is so specialized that it's ugly
1742 ;;;; in its own way. It also violates once-and-only-once by knowing
1743 ;;;; much about structures and layouts that is already known by the
1744 ;;;; main DEFSTRUCT macro. Hopefully it will go away presently
1745 ;;;; (perhaps when CL:CLASS and SB-PCL:CLASS meet) as per FIXME below.
1746 ;;;; -- WHN 2001-10-28
1748 ;;;; FIXME: There seems to be no good reason to shoehorn CONDITION,
1749 ;;;; STANDARD-INSTANCE, and GENERIC-FUNCTION into mutated structures
1750 ;;;; instead of just implementing them as primitive objects. (This
1751 ;;;; reduced-functionality macro seems pretty close to the
1752 ;;;; functionality of !DEFINE-PRIMITIVE-OBJECT..)
1754 ;;; The complete list of alternate-metaclass DEFSTRUCTs:
1755 ;;; CONDITION SB-EVAL:INTERPRETED-FUNCTION
1756 ;;; SB-PCL::STANDARD-INSTANCE SB-PCL::STANDARD-FUNCALLABLE-INSTANCE
1757 ;;; SB-PCL::CTOR SB-PCL::%METHOD-FUNCTION
1759 (defun make-dd-with-alternate-metaclass (&key
(class-name (missing-arg))
1760 (superclass-name (missing-arg))
1761 (metaclass-name (missing-arg))
1762 (dd-type (missing-arg))
1763 metaclass-constructor
1765 (let* ((dd (make-defstruct-description class-name
))
1766 (conc-name (concatenate 'string
(symbol-name class-name
) "-"))
1767 (dd-slots (let ((reversed-result nil
)
1768 ;; The index starts at 1 for ordinary named
1769 ;; slots because slot 0 is magical, used for
1770 ;; the LAYOUT in CONDITIONs and
1771 ;; FUNCALLABLE-INSTANCEs. (This is the same
1772 ;; in ordinary structures too: see (INCF
1774 ;; PARSE-DEFSTRUCT-NAME-AND-OPTIONS).
1776 (dolist (slot-name slot-names
)
1777 (push (make-defstruct-slot-description
1780 :accessor-name
(symbolicate conc-name slot-name
))
1783 (nreverse reversed-result
))))
1784 ;; We do *not* fill in the COPIER-NAME and PREDICATE-NAME
1785 ;; because none of the magical alternate-metaclass structures
1786 ;; have copiers and predicates that "Just work"
1788 ;; We don't support inheritance of alternate metaclass stuff,
1789 ;; and it's not a general-purpose facility, so sanity check our
1792 (aver (eq superclass-name
't
)))
1793 (funcallable-structure
1794 (aver (eq superclass-name
'function
)))
1795 (t (bug "Unknown DD-TYPE in ALTERNATE-METACLASS: ~S" dd-type
)))
1796 (setf (dd-alternate-metaclass dd
) (list superclass-name
1798 metaclass-constructor
)
1799 (dd-slots dd
) dd-slots
1800 (dd-length dd
) (1+ (length slot-names
))
1801 (dd-type dd
) dd-type
)
1804 ;;; make !DEFSTRUCT-WITH-ALTERNATE-METACLASS compilable by the host
1805 ;;; lisp, installing the information we need to reason about the
1806 ;;; structures (layouts and classoids).
1808 ;;; FIXME: we should share the parsing and the DD construction between
1809 ;;; this and the cross-compiler version, but my brain was too small to
1810 ;;; get that right. -- CSR, 2006-09-14
1812 (defmacro !defstruct-with-alternate-metaclass
1814 (slot-names (missing-arg))
1815 (boa-constructor (missing-arg))
1816 (superclass-name (missing-arg))
1817 (metaclass-name (missing-arg))
1818 (metaclass-constructor (missing-arg))
1819 (dd-type (missing-arg))
1821 (runtime-type-checks-p t
))
1823 (declare (type (and list
(not null
)) slot-names
))
1824 (declare (type (and symbol
(not null
))
1828 metaclass-constructor
))
1829 (declare (type symbol predicate
))
1830 (declare (type (member structure funcallable-structure
) dd-type
))
1831 (declare (ignore boa-constructor predicate runtime-type-checks-p
))
1833 (let* ((dd (make-dd-with-alternate-metaclass
1834 :class-name class-name
1835 :slot-names slot-names
1836 :superclass-name superclass-name
1837 :metaclass-name metaclass-name
1838 :metaclass-constructor metaclass-constructor
1842 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
1843 (%compiler-set-up-layout
',dd
',(inherits-for-structure dd
))))))
1845 (sb!xc
:proclaim
'(special *defstruct-hooks
*))
1847 (sb!xc
:defmacro
!defstruct-with-alternate-metaclass
1849 (slot-names (missing-arg))
1850 (boa-constructor (missing-arg))
1851 (superclass-name (missing-arg))
1852 (metaclass-name (missing-arg))
1853 (metaclass-constructor (missing-arg))
1854 (dd-type (missing-arg))
1856 (runtime-type-checks-p t
))
1858 (declare (type (and list
(not null
)) slot-names
))
1859 (declare (type (and symbol
(not null
))
1863 metaclass-constructor
))
1864 (declare (type symbol predicate
))
1865 (declare (type (member structure funcallable-structure
) dd-type
))
1867 (let* ((dd (make-dd-with-alternate-metaclass
1868 :class-name class-name
1869 :slot-names slot-names
1870 :superclass-name superclass-name
1871 :metaclass-name metaclass-name
1872 :metaclass-constructor metaclass-constructor
1874 (dd-slots (dd-slots dd
))
1875 (dd-length (1+ (length slot-names
)))
1876 (object-gensym (sb!xc
:gensym
"OBJECT"))
1877 (new-value-gensym (sb!xc
:gensym
"NEW-VALUE-"))
1878 (delayed-layout-form `(%delayed-get-compiler-layout
,class-name
)))
1879 (multiple-value-bind (raw-maker-form raw-reffer-operator
)
1882 (values `(%make-structure-instance-macro
,dd nil
)
1884 (funcallable-structure
1885 (values `(let ((,object-gensym
1886 (%make-funcallable-instance
,dd-length
)))
1887 (setf (%funcallable-instance-layout
,object-gensym
)
1888 ,delayed-layout-form
)
1890 '%funcallable-instance-info
)))
1893 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
1894 (%compiler-set-up-layout
',dd
',(inherits-for-structure dd
)))
1896 ;; slot readers and writers
1897 (declaim (inline ,@(mapcar #'dsd-accessor-name dd-slots
)))
1898 ,@(mapcar (lambda (dsd)
1899 `(defun ,(dsd-accessor-name dsd
) (,object-gensym
)
1900 ,@(when runtime-type-checks-p
1901 `((declare (type ,class-name
,object-gensym
))))
1902 (,raw-reffer-operator
,object-gensym
1905 (declaim (inline ,@(mapcar (lambda (dsd)
1906 `(setf ,(dsd-accessor-name dsd
)))
1908 ,@(mapcar (lambda (dsd)
1909 `(defun (setf ,(dsd-accessor-name dsd
)) (,new-value-gensym
1911 ,@(when runtime-type-checks-p
1912 `((declare (type ,class-name
,object-gensym
))))
1913 (setf (,raw-reffer-operator
,object-gensym
1915 ,new-value-gensym
)))
1919 (defun ,boa-constructor
,slot-names
1920 (let ((,object-gensym
,raw-maker-form
))
1921 ,@(mapcar (lambda (slot-name)
1922 (let ((dsd (find (symbol-name slot-name
) dd-slots
1924 (symbol-name (dsd-name x
)))
1926 ;; KLUDGE: bug 117 bogowarning. Neither
1927 ;; DECLAREing the type nor TRULY-THE cut
1928 ;; the mustard -- it still gives warnings.
1929 (enforce-type dsd defstruct-slot-description
)
1930 `(setf (,(dsd-accessor-name dsd
) ,object-gensym
)
1937 ;; Just delegate to the compiler's type optimization
1938 ;; code, which knows how to generate inline type tests
1939 ;; for the whole CMU CL INSTANCE menagerie.
1940 `(defun ,predicate
(,object-gensym
)
1941 (typep ,object-gensym
',class-name
)))
1943 (aver (null *defstruct-hooks
*))))))
1945 ;;;; finalizing bootstrapping
1947 ;;; Set up DD and LAYOUT for STRUCTURE-OBJECT class itself.
1949 ;;; Ordinary structure classes effectively :INCLUDE STRUCTURE-OBJECT
1950 ;;; when they have no explicit :INCLUDEs, so (1) it needs to be set up
1951 ;;; before we can define ordinary structure classes, and (2) it's
1952 ;;; special enough (and simple enough) that we just build it by hand
1953 ;;; instead of trying to generalize the ordinary DEFSTRUCT code.
1954 (defun !set-up-structure-object-class
()
1955 (let ((dd (make-defstruct-description 'structure-object
)))
1957 ;; Note: This has an ALTERNATE-METACLASS only because of blind
1958 ;; clueless imitation of the CMU CL code -- dunno if or why it's
1960 (dd-alternate-metaclass dd
) '(t)
1963 (dd-type dd
) 'structure
)
1964 (%compiler-set-up-layout dd
)))
1965 #+sb-xc-host
(!set-up-structure-object-class
)
1967 ;;; early structure predeclarations: Set up DD and LAYOUT for ordinary
1968 ;;; (non-ALTERNATE-METACLASS) structures which are needed early.
1970 '#.
(sb-cold:read-from-file
1971 "src/code/early-defstruct-args.lisp-expr"))
1972 (let* ((dd (parse-defstruct-name-and-options-and-slot-descriptions
1975 (inherits (inherits-for-structure dd
)))
1976 (%compiler-defstruct dd inherits
)))
1978 (defun find-defstruct-description (name &optional
(errorp t
))
1979 (let* ((classoid (find-classoid name errorp
))
1981 (layout-info (classoid-layout classoid
)))))
1982 (cond ((defstruct-description-p info
)
1985 (error "No DEFSTRUCT-DESCRIPTION for ~S." name
)))))
1987 (defun structure-instance-accessor-p (name)
1988 (let ((info (info :function
:source-transform name
)))
1990 (defstruct-slot-description-p (cdr info
))
1993 (/show0
"code/defstruct.lisp end of file")