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 ;;; a type name which can be used when declaring things which operate
182 ;;; on structure instances
183 (defun dd-declarable-type (dd)
185 ;; Native classes are known to the type system, and we can
186 ;; declare them as types.
188 ;; Structures layered on :TYPE LIST or :TYPE VECTOR aren't part
189 ;; of the type system, so all we can declare is the underlying
190 ;; LIST or VECTOR type.
193 (defun dd-layout-or-lose (dd)
194 (compiler-layout-or-lose (dd-name dd
)))
196 ;;;; DEFSTRUCT-SLOT-DESCRIPTION
198 ;;; A DEFSTRUCT-SLOT-DESCRIPTION holds compile-time information about
199 ;;; a structure slot.
200 (def!struct
(defstruct-slot-description
201 (:make-load-form-fun just-dump-it-normally
)
204 #-sb-xc-host
(:pure t
))
207 ;; its position in the implementation sequence
208 (index (missing-arg) :type fixnum
)
209 ;; the name of the accessor function
211 ;; (CMU CL had extra complexity here ("..or NIL if this accessor has
212 ;; the same name as an inherited accessor (which we don't want to
213 ;; shadow)") but that behavior doesn't seem to be specified by (or
214 ;; even particularly consistent with) ANSI, so it's gone in SBCL.)
215 (accessor-name nil
:type symbol
)
216 default
; default value expression
217 (type t
) ; declared type specifier
218 (safe-p t
:type boolean
) ; whether the slot is known to be
219 ; always of the specified type
220 ;; If this object does not describe a raw slot, this value is T.
222 ;; If this object describes a raw slot, this value is the type of the
223 ;; value that the raw slot holds.
224 (raw-type t
:type
(member t single-float double-float
225 #!+long-float long-float
226 complex-single-float complex-double-float
227 #!+long-float complex-long-float
229 (read-only nil
:type
(member t nil
)))
230 #!-sb-fluid
(declaim (freeze-type defstruct-slot-description
))
231 (def!method print-object
((x defstruct-slot-description
) stream
)
232 (print-unreadable-object (x stream
:type t
)
233 (prin1 (dsd-name x
) stream
)))
235 ;;;; typed (non-class) structures
237 ;;; Return a type specifier we can use for testing :TYPE'd structures.
238 (defun dd-lisp-type (defstruct)
239 (ecase (dd-type defstruct
)
241 (vector `(simple-array ,(dd-element-type defstruct
) (*)))))
243 ;;;; shared machinery for inline and out-of-line slot accessor functions
245 ;;; Classic comment preserved for entertainment value:
247 ;;; "A lie can travel halfway round the world while the truth is
248 ;;; putting on its shoes." -- Mark Twain
250 ;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its
251 ;;;; close personal friend SB!XC:DEFSTRUCT)
253 (sb!xc
:defmacro delay-defstruct-functions
(name forms
)
254 ;; KLUDGE: If DEFSTRUCT is not at the top-level,
255 ;; (typep x 'name) and similar forms can't get optimized
256 ;; and produce style-warnings for unknown types.
257 (if (compiler-layout-ready-p name
)
261 ;;; shared logic for host macroexpansion for SB!XC:DEFSTRUCT and
262 ;;; cross-compiler macroexpansion for CL:DEFSTRUCT
263 (defun %expander-for-defstruct
(name-and-options slot-descriptions
264 expanding-into-code-for
)
265 ;; The host's version of this allows three choices for 'expanding-into'
266 ;; up until such time as the DEFMACRO is seen (again) for DEFSTRUCT,
267 ;; at which point things are ok because 'early-package' will have been
268 ;; processed. The target has only one possibility.
269 (aver (member expanding-into-code-for
'(:target
272 (let* ((dd (parse-defstruct-name-and-options-and-slot-descriptions
273 name-and-options slot-descriptions
))
274 (inherits (if (dd-class-p dd
) (inherits-for-structure dd
)))
277 (when (dd-print-option dd
)
278 (let* ((x (sb!xc
:gensym
"OBJECT"))
279 (s (sb!xc
:gensym
"STREAM"))
280 (fname (dd-printer-fname dd
))
281 (depthp (eq (dd-print-option dd
) :print-function
)))
282 ;; Giving empty :PRINT-OBJECT or :PRINT-FUNCTION options
283 ;; leaves FNAME eq to NIL. The user-level effect is
284 ;; to generate a PRINT-OBJECT method specialized for the type,
285 ;; implementing the default #S structure-printing behavior.
287 (setf fname
'default-structure-print depthp t
))
288 ((not (symbolp fname
))
289 ;; Don't dump the source form into the DD constant;
290 ;; just indicate that there was an expression there.
291 (setf (dd-printer-fname dd
) t
)))
292 ;; It would be nice to expand into DEFMETHOD, not DEF!METHOD
293 ;; if only because it pprints correctly [or we can go adding
294 ;; pprint dispatch entries for DEF!everything]
295 ;; But alas, building PCL needs it to be DEF!METHOD still.
296 `((def!method print-object
((,x
,name
) ,s
)
297 (funcall #',fname
,x
,s
298 ,@(if depthp
`(*current-level-in-print
*)))))))))
300 ;; Note we intentionally enforce package locks and
301 ;; call %DEFSTRUCT first, and especially before
302 ;; %COMPILER-DEFSTRUCT. %DEFSTRUCT has the tests (and
303 ;; resulting CERROR) for collisions with LAYOUTs which
304 ;; already exist in the runtime. If there are any
305 ;; collisions, we want the user's response to CERROR
306 ;; to control what happens. Especially, if the user
307 ;; responds to the collision with ABORT, we don't want
308 ;; %COMPILER-DEFSTRUCT to modify the definition of the
310 ,@(when (eq expanding-into-code-for
:target
)
311 `((with-single-package-locked-error
312 (:symbol
',name
"defining ~A as a structure"))))
313 ,@(if (dd-class-p dd
)
314 `((%defstruct
',dd
',inherits
(sb!c
:source-location
))
315 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
316 (%compiler-defstruct
',dd
',inherits
))
317 ,@(unless (eq expanding-into-code-for
:host
)
318 `((delay-defstruct-functions
320 (progn ,@(awhen (copier-definition dd
) (list it
))
321 ,@(awhen (predicate-definition dd
) (list it
))
322 ,@(accessor-definitions dd
)))
323 ;; This must be in the same lexical environment
324 ,@(constructor-definitions dd
)
325 ,@(when (eq (dd-pure dd
) t
)
326 ;; Seems like %TARGET-DEFSTRUCT should do this
328 (declare (notinline find-classoid
))
329 (setf (layout-pure (classoid-layout
330 (find-classoid ',name
))) t
))))
332 ;; Various other operations only make sense on the target SBCL.
333 (%target-defstruct
',dd
))))
334 `((eval-when (:compile-toplevel
:load-toplevel
:execute
)
335 (setf (info :typed-structure
:info
',name
) ',dd
))
336 (setf (info :source-location
:typed-structure
',name
)
337 (sb!c
:source-location
))
338 ,@(unless (eq expanding-into-code-for
:host
)
339 (append (typed-accessor-definitions dd
)
340 (typed-predicate-definitions dd
)
341 (typed-copier-definitions dd
)
342 (constructor-definitions dd
)
344 `((setf (fdocumentation ',(dd-name dd
) 'structure
)
349 (sb!xc
:defmacro defstruct
(name-and-options &rest slot-descriptions
)
350 (%expander-for-defstruct name-and-options slot-descriptions
:cold-target
))
353 (sb!xc
:defmacro defstruct
(name-and-options &rest slot-descriptions
)
355 "DEFSTRUCT {Name | (Name Option*)} [Documentation] {Slot | (Slot [Default] {Key Value}*)}
356 Define the structure type Name. Instances are created by MAKE-<name>,
357 which takes &KEY arguments allowing initial slot values to the specified.
358 A SETF'able function <name>-<slot> is defined for each slot to read and
359 write slot values. <name>-p is a type predicate.
361 Popular DEFSTRUCT options (see manual for others):
365 Specify the name for the constructor or predicate.
367 (:CONSTRUCTOR Name Lambda-List)
368 Specify the name and arguments for a BOA constructor
369 (which is more efficient when keyword syntax isn't necessary.)
371 (:INCLUDE Supertype Slot-Spec*)
372 Make this type a subtype of the structure type Supertype. The optional
373 Slot-Specs override inherited slot options.
378 Asserts that the value of this slot is always of the specified type.
381 If true, no setter function is defined for this slot."
382 (%expander-for-defstruct name-and-options slot-descriptions
:target
))
384 (defmacro sb
!xc
:defstruct
(name-and-options &rest slot-descriptions
)
386 "Cause information about a target structure to be built into the
388 (%expander-for-defstruct name-and-options slot-descriptions
:host
))
390 ;;;; functions to generate code for various parts of DEFSTRUCT definitions
392 ;;; First, a helper to determine whether a name names an inherited
394 (defun accessor-inherited-data (name defstruct
)
395 (assoc name
(dd-inherited-accessor-alist defstruct
) :test
#'eq
))
397 ;;; Return a list of forms which create a predicate function for a
399 (defun typed-predicate-definitions (defstruct)
400 (let ((name (dd-name defstruct
))
401 (predicate-name (dd-predicate-name defstruct
))
402 (argname 'x
)) ; KISS: no user code appears in the DEFUN
404 (aver (dd-named defstruct
))
405 (let ((ltype (dd-lisp-type defstruct
))
406 (name-index (cdr (car (last (find-name-indices defstruct
))))))
407 `((defun ,predicate-name
(,argname
)
408 (and (typep ,argname
',ltype
)
410 ((subtypep ltype
'list
)
411 `(do ((head (the ,ltype
,argname
) (cdr head
))
413 ((or (not (consp head
)) (= i
,name-index
))
414 (and (consp head
) (eq ',name
(car head
))))))
415 ((subtypep ltype
'vector
)
416 `(and (>= (length (the ,ltype
,argname
))
417 ,(dd-length defstruct
))
418 (eq ',name
(aref (the ,ltype
,argname
) ,name-index
))))
419 (t (bug "Uncatered-for lisp type in typed DEFSTRUCT: ~S."
422 ;;; Return a list of forms to create a copier function of a typed DEFSTRUCT.
423 (defun typed-copier-definitions (defstruct)
424 (when (dd-copier-name defstruct
)
425 `((setf (fdefinition ',(dd-copier-name defstruct
)) #'copy-seq
)
426 (declaim (ftype function
,(dd-copier-name defstruct
))))))
428 ;;; Return a list of function definitions for accessing and setting
429 ;;; the slots of a typed DEFSTRUCT. The functions are proclaimed to be
430 ;;; inline, and the types of their arguments and results are declared
431 ;;; as well. We count on the compiler to do clever things with ELT.
432 (defun typed-accessor-definitions (defstruct)
434 (let ((ltype (dd-lisp-type defstruct
)))
435 (dolist (slot (dd-slots defstruct
))
436 (let ((name (dsd-accessor-name slot
))
437 (index (dsd-index slot
))
439 (slot-type `(and ,(dsd-type slot
)
440 ,(dd-element-type defstruct
))))
441 (let ((inherited (accessor-inherited-data name defstruct
)))
444 (stuff `(declaim (inline ,name
,@(unless (dsd-read-only slot
)
446 (stuff `(defun ,name
(structure)
447 (declare (type ,ltype structure
))
448 (the ,slot-type
(elt structure
,index
))))
449 (unless (dsd-read-only slot
)
451 `(defun (setf ,name
) (,(car new-value
) structure
)
452 (declare (type ,ltype structure
) (type ,slot-type .
,new-value
))
453 (setf (elt structure
,index
) .
,new-value
)))))
454 ((not (= (cdr inherited
) index
))
455 (style-warn "~@<Non-overwritten accessor ~S does not access ~
456 slot with name ~S (accessing an inherited slot ~
457 instead).~:@>" name
(dsd-name slot
))))))))
463 ;;; A defstruct option can be either a keyword or a list of a keyword
464 ;;; and arguments for that keyword; specifying the keyword by itself is
465 ;;; equivalent to specifying a list consisting of the keyword
466 ;;; and no arguments.
467 ;;; It is unclear whether that is meant to imply that any of the keywords
468 ;;; may be present in their atom form, or only if the grammar at the top
469 ;;; shows the atom form does <atom> have the meaning of (<atom>).
470 ;;; At least one other implementation accepts :NAMED as a singleton list.
471 ;; We take a more rigid view that the depicted grammar is exhaustive.
473 (defconstant-eqx +dd-option-names
+
474 ;; Each keyword, except :CONSTRUCTOR which may appear more than once,
475 ;; and :NAMED which is trivial, and unambiguous if present more than
476 ;; once, though possibly worth a style-warning.
477 #(:include
; at least 1 argument
478 :initial-offset
; exactly 1 argument
479 :pure
; exactly 1 argument [nonstandard]
480 :type
; exactly 1 argument
481 :conc-name
; 0 or 1 arg
488 ;;; Parse a single DEFSTRUCT option and store the results in DD.
489 (defun parse-1-dd-option (option dd seen-options
)
490 (let* ((keyword (first option
))
491 (bit (position keyword
+dd-option-names
+))
494 (arg (if arg-p
(car args
)))
496 (declare (type (unsigned-byte 9) seen-options
)) ; mask over DD-OPTION-NAMES
498 (if (logbitp bit seen-options
)
499 (error "More than one ~S option is not allowed" keyword
)
500 (setf seen-options
(logior seen-options
(ash 1 bit
))))
501 (multiple-value-bind (syntax-group winp
)
502 (cond ; Perform checking per comment at +DD-OPTION-NAMES+.
503 ((= bit
0) (values 0 (and arg-p
(proper-list-p args
)))) ; >1 arg
504 ((< bit
4) (values 1 (and arg-p
(not (cdr args
))))) ; exactly 1
505 (t (values 2 (or (not args
) (singleton-p args
))))) ; 0 or 1
507 (if (proper-list-p option
)
508 (error "DEFSTRUCT option ~S ~[requires at least~;~
509 requires exactly~;accepts at most~] one argument" keyword syntax-group
)
510 (error "Invalid syntax in DEFSTRUCT option ~S" option
)))))
513 ;; unlike (:predicate) and (:copier) which mean "yes" if supplied
514 ;; without their argument, (:conc-name) and :conc-name mean no conc-name.
515 ;; Also note a subtle difference in :conc-name "" vs :conc-name NIL.
516 ;; The former re-interns each slot name into *PACKAGE* which might
517 ;; not be the same as using the given name directly as an accessor.
518 (setf (dd-conc-name dd
) (if arg
(string arg
))))
519 (:constructor
; takes 0 to 2 arguments.
520 (destructuring-bind (&optional
(cname (symbolicate "MAKE-" name
))
522 (declare (ignore lambda-list
))
523 (push (cons cname
(cdr args
)) (dd-constructors dd
))))
525 (setf (dd-copier-name dd
) (if arg-p arg
(symbolicate "COPY-" name
))))
527 (setf (dd-predicate-name dd
) (if arg-p arg
(symbolicate name
"-P"))))
529 (setf (dd-include dd
) args
))
530 ((:print-function
:print-object
)
531 (when (dd-print-option dd
)
532 (error "~S and ~S may not both be specified"
533 (dd-print-option dd
) keyword
))
534 (setf (dd-print-option dd
) keyword
(dd-printer-fname dd
) arg
))
536 (cond ((member arg
'(list vector
))
537 (setf (dd-type dd
) arg
(dd-element-type dd
) t
))
538 ((and (listp arg
) (eq (first arg
) 'vector
))
539 (destructuring-bind (elt-type) (cdr arg
)
540 (setf (dd-type dd
) 'vector
(dd-element-type dd
) elt-type
)))
542 (error "~S is a bad :TYPE for DEFSTRUCT." arg
))))
544 (error "The DEFSTRUCT option :NAMED takes no arguments."))
546 (setf (dd-offset dd
) arg
)) ; FIXME: disallow (:INITIAL-OFFSET NIL)
548 (setf (dd-pure dd
) arg
))
550 (error "unknown DEFSTRUCT option:~% ~S" option
)))
553 ;;; Given name and options, return a DD holding that info.
554 (defun parse-defstruct-name-and-options (name-and-options)
555 (destructuring-bind (name &rest options
) name-and-options
556 (let ((dd (make-defstruct-description name
))
558 (dolist (option options
)
559 (if (eq option
:named
)
560 (setf (dd-named dd
) t
)
563 (cond ((consp option
) option
)
565 '(:conc-name
:constructor
:copier
:predicate
))
568 ;; FIXME: ugly message (defstruct (s :include) a)
569 ;; saying "unrecognized" when it means "bad syntax"
570 (error "unrecognized DEFSTRUCT option: ~S" option
)))
575 (error ":OFFSET can't be specified unless :TYPE is specified."))
576 (unless (dd-include dd
)
577 ;; FIXME: It'd be cleaner to treat no-:INCLUDE as defaulting
578 ;; to :INCLUDE STRUCTURE-OBJECT, and then let the general-case
579 ;; (INCF (DD-LENGTH DD) (DD-LENGTH included-DD)) logic take
580 ;; care of this. (Except that the :TYPE VECTOR and :TYPE
581 ;; LIST cases, with their :NAMED and un-:NAMED flavors,
582 ;; make that messy, alas.)
583 (incf (dd-length dd
))))
585 ;; In case we are here, :TYPE is specified.
587 ;; CLHS - "The structure can be :named only if the type SYMBOL
588 ;; is a subtype of the supplied element-type."
589 (multiple-value-bind (winp certainp
)
590 (subtypep 'symbol
(dd-element-type dd
))
591 (when (and (not winp
) certainp
)
592 (error ":NAMED option is incompatible with element type ~S"
593 (dd-element-type dd
))))
594 (when (dd-predicate-name dd
)
595 (error ":PREDICATE cannot be used with :TYPE ~
596 unless :NAMED is also specified.")))
597 (awhen (dd-print-option dd
)
598 (error ":TYPE option precludes specification of ~S option" it
))
600 (incf (dd-length dd
)))
601 (let ((offset (dd-offset dd
)))
602 (when offset
(incf (dd-length dd
) offset
)))))
604 (flet ((option-present-p (bit-name)
605 (logbitp (position bit-name
+dd-option-names
+) seen-options
)))
606 (declare (inline option-present-p
))
607 (when (and (not (option-present-p :predicate
))
608 (or (dd-class-p dd
) (dd-named dd
)))
609 (setf (dd-predicate-name dd
) (symbolicate name
"-P")))
610 (unless (option-present-p :conc-name
)
611 (setf (dd-conc-name dd
) (concatenate 'string
(string name
) "-")))
612 (unless (option-present-p :copier
)
613 (setf (dd-copier-name dd
) (symbolicate "COPY-" name
))))
614 (when (dd-include dd
)
615 (frob-dd-inclusion-stuff dd
))
619 ;;; BOA constructors is (&aux x), i.e. without the default value, the
620 ;;; value of the slot is unspecified, but it should signal a type
621 ;;; error only when it's accessed. safe-p slot in dsd determines
622 ;;; whether to check the type after accessing the slot.
624 ;;; This was performed during boa constructor creating, but the
625 ;;; constructors are created after this information is used to inform
626 ;;; the compiler how to treat such slots.
627 (defun determine-unsafe-slots (dd)
628 (loop for
(name lambda-list
) in
(dd-constructors dd
)
629 for
&aux
= (cdr (member '&aux lambda-list
))
635 (setf name
(car slot
))
637 (symbol (setf name slot
)
639 do
(let ((dsd (find name
(dd-slots dd
)
643 (setf (dsd-safe-p dsd
) nil
))))))
645 ;;; Given name and options and slot descriptions (and possibly doc
646 ;;; string at the head of slot descriptions) return a DD holding that
648 (defun parse-defstruct-name-and-options-and-slot-descriptions
649 (name-and-options slot-descriptions
)
650 (let ((result (parse-defstruct-name-and-options (if (atom name-and-options
)
651 (list name-and-options
)
653 (when (stringp (car slot-descriptions
))
654 (setf (dd-doc result
) (pop slot-descriptions
)))
655 (dolist (slot-description slot-descriptions
)
656 (allocate-1-slot result
(parse-1-dsd result slot-description
)))
657 (determine-unsafe-slots result
)
660 ;;;; stuff to parse slot descriptions
662 ;;; Parse a slot description for DEFSTRUCT, add it to the description
663 ;;; and return it. If supplied, SLOT is a pre-initialized DSD
664 ;;; that we modify to get the new slot. This is supplied when handling
666 (defun parse-1-dsd (defstruct spec
&optional
667 (slot (make-defstruct-slot-description :name
""
670 (multiple-value-bind (name default default-p type type-p read-only ro-p
)
674 ((or null
(member :conc-name
:constructor
:copier
:predicate
:named
))
675 (warn "slot name of ~S indicates probable syntax error in DEFSTRUCT" spec
))
677 (style-warn "slot name of ~S indicates possible syntax error in DEFSTRUCT" spec
)))
681 (name &optional
(default nil default-p
)
682 &key
(type nil type-p
) (read-only nil ro-p
))
684 (when (dd-conc-name defstruct
)
685 ;; the warning here is useful, but in principle we cannot
686 ;; distinguish between legitimate and erroneous use of
687 ;; these names when :CONC-NAME is NIL. In the common
688 ;; case (CONC-NAME non-NIL), there are alternative ways
689 ;; of writing code with the same effect, so a full
690 ;; warning is justified.
692 ((member :conc-name
:constructor
:copier
:predicate
:include
693 :print-function
:print-object
:type
:initial-offset
:pure
)
694 (warn "slot name of ~S indicates probable syntax error in DEFSTRUCT" name
))))
695 (values name default default-p
696 (uncross type
) type-p
698 (t (error 'simple-program-error
699 :format-control
"in DEFSTRUCT, ~S is not a legal slot ~
701 :format-arguments
(list spec
))))
703 (when (find name
(dd-slots defstruct
)
705 :key
(lambda (x) (symbol-name (dsd-name x
))))
706 (error 'simple-program-error
707 ;; Todo: indicate whether name is a duplicate in the directly
708 ;; specified slots vs. exists in the ancestor and so should
709 ;; be in the (:include ...) clause instead of where it is.
710 :format-control
"duplicate slot name ~S"
711 :format-arguments
(list name
)))
712 (setf (dsd-name slot
) name
)
713 (setf (dd-slots defstruct
) (nconc (dd-slots defstruct
) (list slot
)))
715 (let ((accessor-name (if (dd-conc-name defstruct
)
716 (symbolicate (dd-conc-name defstruct
) name
)
718 (predicate-name (dd-predicate-name defstruct
)))
719 (setf (dsd-accessor-name slot
) accessor-name
)
720 (when (eql accessor-name predicate-name
)
721 ;; Some adventurous soul has named a slot so that its accessor
722 ;; collides with the structure type predicate. ANSI doesn't
723 ;; specify what to do in this case. As of 2001-09-04, Martin
724 ;; Atzmueller reports that CLISP and Lispworks both give
725 ;; priority to the slot accessor, so that the predicate is
726 ;; overwritten. We might as well do the same (as well as
727 ;; signalling a warning).
729 "~@<The structure accessor name ~S is the same as the name of the ~
730 structure type predicate. ANSI doesn't specify what to do in ~
731 this case. We'll overwrite the type predicate with the slot ~
732 accessor, but you can't rely on this behavior, so it'd be wise to ~
733 remove the ambiguity in your code.~@:>"
735 (setf (dd-predicate-name defstruct
) nil
))
736 ;; FIXME: It would be good to check for name collisions here, but
739 ;;x(when (and (fboundp accessor-name)
740 ;;x (not (accessor-inherited-data accessor-name defstruct)))
741 ;;x (style-warn "redefining ~/sb-impl::print-symbol-with-prefix/ ~
742 ;; in DEFSTRUCT" accessor-name)))
743 ;; which was done until sbcl-0.8.11.18 or so, is wrong: it causes
744 ;; a warning at MACROEXPAND time, when instead the warning should
745 ;; occur not just because the code was constructed, but because it
746 ;; is actually compiled or loaded.
750 (setf (dsd-default slot
) default
))
752 (setf (dsd-type slot
)
753 (if (eq (dsd-type slot
) t
)
755 `(and ,(dsd-type slot
) ,type
))))
758 (setf (dsd-read-only slot
) t
)
759 (when (dsd-read-only slot
)
760 (error "~@<The slot ~S is :READ-ONLY in superclass, and so must ~
761 be :READ-ONLY in subclass.~:@>"
765 ;;; When a value of type TYPE is stored in a structure, should it be
766 ;;; stored in a raw slot? Return the matching RAW-SLOT-DATA structure
767 ;; if TYPE should be stored in a raw slot, or NIL if not.
768 (defun structure-raw-slot-data (type)
769 (multiple-value-bind (fixnum? fixnum-certain?
)
770 (sb!xc
:subtypep type
'fixnum
)
771 ;; (The extra test for FIXNUM-CERTAIN? here is intended for
772 ;; bootstrapping the system. In particular, in sbcl-0.6.2, we set up
773 ;; LAYOUT before FIXNUM is defined, and so could bogusly end up
774 ;; putting INDEX-typed values into raw slots if we didn't test
776 (if (or fixnum?
(not fixnum-certain?
))
778 (dolist (data *raw-slot-data-list
*)
779 (when (sb!xc
:subtypep type
(raw-slot-data-raw-type data
))
782 ;;; Allocate storage for a DSD in DD. This is where we decide whether
783 ;;; a slot is raw or not. Raw objects are aligned on the unit of their size.
784 (defun allocate-1-slot (dd dsd
)
785 (let ((rsd (if (eq (dd-type dd
) 'structure
)
786 (structure-raw-slot-data (dsd-type dsd
))
789 (setf (dsd-index dsd
) (dd-length dd
))
790 (incf (dd-length dd
)))
792 (setf (dsd-raw-type dsd
) (raw-slot-data-raw-type rsd
))
793 (let ((words (raw-slot-data-n-words rsd
))
794 (alignment (raw-slot-data-alignment rsd
)))
795 #!-interleaved-raw-slots
796 (let ((off (rem (dd-raw-length dd
) alignment
)))
798 (incf (dd-raw-length dd
) (- alignment off
)))
799 (setf (dsd-index dsd
) (dd-raw-length dd
))
800 (incf (dd-raw-length dd
) words
))
801 #!+interleaved-raw-slots
802 (let ((len (dd-length dd
)))
804 ;; this formula works but can it be made less unclear?
805 (- len
(nth-value 1 (ceiling (1- len
) alignment
))))
806 (setf (dsd-index dsd
) (dd-length dd
))
807 (incf (dd-length dd
) words
))))))
810 (defun typed-structure-info-or-lose (name)
811 (or (info :typed-structure
:info name
)
812 (error ":TYPE'd DEFSTRUCT ~S not found for inclusion." name
)))
814 ;;; Process any included slots pretty much like they were specified.
815 ;;; Also inherit various other attributes.
816 (defun frob-dd-inclusion-stuff (dd)
817 (destructuring-bind (included-name &rest modified-slots
) (dd-include dd
)
818 (let* ((type (dd-type dd
))
821 (layout-info (compiler-layout-or-lose included-name
))
822 (typed-structure-info-or-lose included-name
))))
824 ;; checks on legality
825 (unless (and (eq type
(dd-type included-structure
))
826 (type= (specifier-type (dd-element-type included-structure
))
827 (specifier-type (dd-element-type dd
))))
828 (error ":TYPE option mismatch between structures ~S and ~S"
829 (dd-name dd
) included-name
))
830 (let ((included-classoid (find-classoid included-name nil
)))
831 (when included-classoid
832 ;; It's not particularly well-defined to :INCLUDE any of the
833 ;; CMU CL INSTANCE weirdosities like CONDITION or
834 ;; GENERIC-FUNCTION, and it's certainly not ANSI-compliant.
835 (let* ((included-layout (classoid-layout included-classoid
))
836 (included-dd (layout-info included-layout
)))
837 (when (and (dd-alternate-metaclass included-dd
)
838 ;; As of sbcl-0.pre7.73, anyway, STRUCTURE-OBJECT
839 ;; is represented with an ALTERNATE-METACLASS. But
840 ;; it's specifically OK to :INCLUDE (and PCL does)
841 ;; so in this one case, it's OK to include
842 ;; something with :ALTERNATE-METACLASS after all.
843 (not (eql included-name
'structure-object
)))
844 (error "can't :INCLUDE class ~S (has alternate metaclass)"
847 ;; A few more sanity checks: every allegedly modified slot exists
848 ;; and no name appears more than once.
849 (flet ((included-slot-name (slot-desc)
850 (if (atom slot-desc
) slot-desc
(car slot-desc
))))
851 (mapl (lambda (slots &aux
(name (included-slot-name (car slots
))))
852 (unless (find name
(dd-slots included-structure
)
853 :test
#'string
= :key
#'dsd-name
)
854 (error 'simple-program-error
855 :format-control
"slot name ~S not present in included structure"
856 :format-arguments
(list name
)))
857 (when (find name
(cdr slots
)
858 :test
#'string
= :key
#'included-slot-name
)
859 (error 'simple-program-error
860 :format-control
"included slot name ~S specified more than once"
861 :format-arguments
(list name
))))
864 (incf (dd-length dd
) (dd-length included-structure
))
865 (when (dd-class-p dd
)
866 (let ((mc (rest (dd-alternate-metaclass included-structure
))))
867 (when (and mc
(not (dd-alternate-metaclass dd
)))
868 (setf (dd-alternate-metaclass dd
)
869 (cons included-name mc
))))
870 (when (eq (dd-pure dd
) :unspecified
)
871 (setf (dd-pure dd
) (dd-pure included-structure
)))
872 #!-interleaved-raw-slots
873 (setf (dd-raw-length dd
) (dd-raw-length included-structure
)))
875 (setf (dd-inherited-accessor-alist dd
)
876 (dd-inherited-accessor-alist included-structure
))
877 (dolist (included-slot (dd-slots included-structure
))
878 (let* ((included-name (dsd-name included-slot
))
879 (modified (or (find included-name modified-slots
880 :key
(lambda (x) (if (atom x
) x
(car x
)))
883 ;; We stash away an alist of accessors to parents' slots
884 ;; that have already been created to avoid conflicts later
885 ;; so that structures with :INCLUDE and :CONC-NAME (and
886 ;; other edge cases) can work as specified.
887 (when (dsd-accessor-name included-slot
)
888 ;; the "oldest" (i.e. highest up the tree of inheritance)
889 ;; will prevail, so don't push new ones on if they
891 (pushnew (cons (dsd-accessor-name included-slot
)
892 (dsd-index included-slot
))
893 (dd-inherited-accessor-alist dd
)
894 :test
#'eq
:key
#'car
))
895 (let ((new-slot (parse-1-dsd dd
897 (copy-structure included-slot
))))
898 (when (and (neq (dsd-type new-slot
) (dsd-type included-slot
))
899 (not (sb!xc
:subtypep
(dsd-type included-slot
)
900 (dsd-type new-slot
)))
901 (dsd-safe-p included-slot
))
902 (setf (dsd-safe-p new-slot
) nil
)
906 ;;;; various helper functions for setting up DEFSTRUCTs
908 ;;; This function is called at macroexpand time to compute the INHERITS
909 ;;; vector for a structure type definition.
910 (defun inherits-for-structure (info)
911 (declare (type defstruct-description info
))
912 (let* ((include (dd-include info
))
913 (superclass-opt (dd-alternate-metaclass info
))
916 (compiler-layout-or-lose (first include
))
917 (classoid-layout (find-classoid
918 (or (first superclass-opt
)
919 'structure-object
))))))
922 (concatenate 'simple-vector
923 (layout-inherits super
)
924 (vector super
(classoid-layout (find-classoid 'stream
)))))
926 (concatenate 'simple-vector
927 (layout-inherits super
)
929 (classoid-layout (find-classoid 'file-stream
)))))
930 ((sb!impl
::string-input-stream
931 sb
!impl
::string-output-stream
932 sb
!impl
::fill-pointer-output-stream
)
933 (concatenate 'simple-vector
934 (layout-inherits super
)
936 (classoid-layout (find-classoid 'string-stream
)))))
937 (t (concatenate 'simple-vector
938 (layout-inherits super
)
941 ;;; Do miscellaneous (LOAD EVAL) time actions for the structure
942 ;;; described by DD. Create the class and LAYOUT, checking for
943 ;;; incompatible redefinition.
944 (defun %defstruct
(dd inherits source-location
)
945 (declare (type defstruct-description dd
))
947 ;; We set up LAYOUTs even in the cross-compilation host.
948 (multiple-value-bind (classoid layout old-layout
)
949 (ensure-structure-class dd inherits
"current" "new")
950 (cond ((not old-layout
)
951 (unless (eq (classoid-layout classoid
) layout
)
952 (register-layout layout
)))
954 (%redefine-defstruct classoid old-layout layout
)
955 (let ((old-dd (layout-info old-layout
)))
956 (when (defstruct-description-p old-dd
)
957 (dolist (slot (dd-slots old-dd
))
958 (fmakunbound (dsd-accessor-name slot
))
959 (unless (dsd-read-only slot
)
960 (fmakunbound `(setf ,(dsd-accessor-name slot
)))))))
961 (setq layout
(classoid-layout classoid
))))
962 (setf (find-classoid (dd-name dd
)) classoid
)
964 (sb!c
:with-source-location
(source-location)
965 (setf (layout-source-location layout
) source-location
))))
968 ;;; Return a form describing the writable place used for this slot
969 ;;; in the instance named INSTANCE-NAME.
970 (defun %accessor-place-form
(dd dsd instance-name
)
971 (let (;; the operator that we'll use to access a typed slot
972 (ref (ecase (dd-type dd
)
973 (structure '%instance-ref
)
974 (list 'nth-but-with-sane-arg-order
)
976 (raw-type (dsd-raw-type dsd
)))
977 (if (eq raw-type t
) ; if not raw slot
978 `(,ref
,instance-name
,(dsd-index dsd
))
979 `(,(raw-slot-data-accessor-name (raw-slot-data-or-lose raw-type
))
980 ,instance-name
,(dsd-index dsd
)))))
982 ;;; Return source transforms for the reader and writer functions of
983 ;;; the slot described by DSD. They should be inline expanded, but
984 ;;; source transforms work faster.
985 (defun slot-accessor-transforms (dd dsd
)
986 (let ((accessor-place-form (%accessor-place-form dd dsd
987 `(the ,(dd-name dd
) instance
)))
988 (dsd-type (dsd-type dsd
))
989 (value-the (if (dsd-safe-p dsd
) 'truly-the
'the
)))
990 (values (sb!c
:source-transform-lambda
(instance)
991 `(,value-the
,dsd-type
,(subst instance
'instance
992 accessor-place-form
)))
993 (sb!c
:source-transform-lambda
(new-value instance
)
994 (destructuring-bind (accessor-name &rest accessor-args
)
996 (once-only ((new-value new-value
)
998 `(,(info :setf
:inverse accessor-name
)
999 ,@(subst instance
'instance accessor-args
)
1000 (the ,dsd-type
,new-value
))))))))
1002 ;;; Return a LAMBDA form which can be used to set a slot.
1003 (defun slot-setter-lambda-form (dd dsd
)
1004 ;; KLUDGE: Evaluating the results of SLOT-ACCESSOR-TRANSFORMS needs
1006 (let ((sb!c
:*lexenv
* (if (boundp 'sb
!c
:*lexenv
*)
1008 (sb!c
::make-null-lexenv
))))
1009 `(lambda (new-value instance
)
1010 ,(funcall (nth-value 1 (slot-accessor-transforms dd dsd
))
1011 '(dummy new-value instance
)))))
1013 ;;; Blow away all the compiler info for the structure CLASS. Iterate
1014 ;;; over this type, clearing the compiler structure type info, and
1015 ;;; undefining all the associated functions. If SUBCLASSES-P, also do
1016 ;;; the same for subclasses. FIXME: maybe rename UNDEFINE-FUN-NAME to
1017 ;;; UNDECLARE-FUNCTION-NAME?
1018 (defun undeclare-structure (classoid subclasses-p
)
1019 (let ((info (layout-info (classoid-layout classoid
))))
1020 (when (defstruct-description-p info
)
1021 (let ((type (dd-name info
)))
1022 (clear-info :type
:compiler-layout type
)
1023 (undefine-fun-name (dd-copier-name info
))
1024 (undefine-fun-name (dd-predicate-name info
))
1025 (dolist (slot (dd-slots info
))
1026 (let ((fun (dsd-accessor-name slot
)))
1027 (unless (accessor-inherited-data fun info
)
1028 (undefine-fun-name fun
)
1029 (unless (dsd-read-only slot
)
1030 (undefine-fun-name `(setf ,fun
)))))))
1031 ;; Clear out the SPECIFIER-TYPE cache so that subsequent
1032 ;; references are unknown types.
1033 (values-specifier-type-cache-clear)))
1035 (let ((subclasses (classoid-subclasses classoid
)))
1038 (dohash ((classoid layout
)
1041 (declare (ignore layout
))
1042 (undeclare-structure classoid nil
)
1043 (subs (classoid-proper-name classoid
)))
1044 ;; Is it really necessary to warn about
1045 ;; undeclaring functions for subclasses?
1047 (warn "undeclaring functions for old subclasses ~
1049 (classoid-name classoid
)
1052 ;;; core compile-time setup of any class with a LAYOUT, used even by
1053 ;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities
1054 (defun %compiler-set-up-layout
(dd
1056 ;; Several special cases
1057 ;; (STRUCTURE-OBJECT itself, and
1058 ;; structures with alternate
1059 ;; metaclasses) call this function
1060 ;; directly, and they're all at the
1061 ;; base of the instance class
1062 ;; structure, so this is a handy
1063 ;; default. (But note
1064 ;; FUNCALLABLE-STRUCTUREs need
1066 (inherits (vector (find-layout t
))))
1068 (multiple-value-bind (classoid layout old-layout
)
1069 (multiple-value-bind (clayout clayout-p
)
1070 (info :type
:compiler-layout
(dd-name dd
))
1071 (ensure-structure-class dd
1074 "The most recently compiled"
1076 "the most recently loaded"
1077 :compiler-layout clayout
))
1079 (undeclare-structure (layout-classoid old-layout
)
1080 (and (classoid-subclasses classoid
)
1081 (not (eq layout old-layout
))))
1082 (setf (layout-invalid layout
) nil
)
1083 ;; FIXME: it might be polite to hold onto old-layout and
1084 ;; restore it at the end of the file. -- RMK 2008-09-19
1085 ;; (International Talk Like a Pirate Day).
1086 (warn "~@<Clobbering the compiler's idea of the layout of ~A.~:@>"
1089 (unless (eq (classoid-layout classoid
) layout
)
1090 (register-layout layout
:invalidate nil
))
1091 (setf (find-classoid (dd-name dd
)) classoid
)))
1093 ;; At this point the class should be set up in the INFO database.
1094 ;; But the logic that enforces this is a little tangled and
1095 ;; scattered, so it's not obvious, so let's check.
1096 (aver (find-classoid (dd-name dd
) nil
))
1098 (setf (info :type
:compiler-layout
(dd-name dd
)) layout
))
1101 ;;; Do (COMPILE LOAD EVAL)-time actions for the normal (not
1102 ;;; ALTERNATE-LAYOUT) DEFSTRUCT described by DD.
1103 (defun %compiler-defstruct
(dd inherits
)
1104 (declare (type defstruct-description dd
))
1105 (%compiler-set-up-layout dd inherits
)
1107 (let ((dtype (dd-declarable-type dd
)))
1109 (let ((copier-name (dd-copier-name dd
)))
1111 (sb!xc
:proclaim
`(ftype (sfunction (,dtype
) ,dtype
) ,copier-name
))))
1113 (let ((predicate-name (dd-predicate-name dd
)))
1114 (when predicate-name
1115 ;; Provide inline expansion (or not).
1117 ((structure funcallable-structure
)
1118 ;; Let the predicate be inlined.
1119 (setf (info :function
:inline-expansion-designator predicate-name
)
1122 ;; This dead simple definition works because the
1123 ;; type system knows how to generate inline type
1124 ;; tests for instances.
1125 (typep x
',(dd-name dd
))))
1126 (info :function
:inlinep predicate-name
)
1129 ;; Just punt. We could provide inline expansions for :TYPE
1130 ;; LIST and :TYPE VECTOR predicates too, but it'd be a
1131 ;; little messier and we don't bother. (Does anyone use
1132 ;; typed DEFSTRUCTs at all, let alone for high
1134 (sb!xc
:proclaim
`(ftype (sfunction (t) boolean
) ,predicate-name
))))))
1136 (dolist (dsd (dd-slots dd
))
1137 (let ((accessor-name (dsd-accessor-name dsd
)))
1139 (let ((inherited (accessor-inherited-data accessor-name dd
)))
1142 (setf (info :function
:structure-accessor accessor-name
) dd
)
1143 (multiple-value-bind (reader-designator writer-designator
)
1144 (slot-accessor-transforms dd dsd
)
1145 (setf (info :function
:source-transform accessor-name
)
1147 (unless (dsd-read-only dsd
)
1148 (setf (info :function
:source-transform
`(setf ,accessor-name
))
1149 writer-designator
))))
1150 ((not (= (cdr inherited
) (dsd-index dsd
)))
1151 (style-warn "~@<Non-overwritten accessor ~S does not access ~
1152 slot with name ~S (accessing an inherited slot ~
1155 (dsd-name dsd
))))))))))
1157 ;;;; redefinition stuff
1159 ;;; Compare the slots of OLD and NEW, returning 3 lists of slot names:
1160 ;;; 1. Slots which have moved,
1161 ;;; 2. Slots whose type has changed,
1162 ;;; 3. Deleted slots.
1163 (defun compare-slots (old new
)
1164 (let* ((oslots (dd-slots old
))
1165 (nslots (dd-slots new
))
1166 (onames (mapcar #'dsd-name oslots
))
1167 (nnames (mapcar #'dsd-name nslots
)))
1170 (dolist (name (intersection onames nnames
))
1171 (let ((os (find name oslots
:key
#'dsd-name
:test
#'string
=))
1172 (ns (find name nslots
:key
#'dsd-name
:test
#'string
=)))
1173 (unless (sb!xc
:subtypep
(dsd-type ns
) (dsd-type os
))
1175 (unless (and (= (dsd-index os
) (dsd-index ns
))
1176 (eq (dsd-raw-type os
) (dsd-raw-type ns
)))
1180 (set-difference onames nnames
:test
#'string
=)))))
1182 ;;; If we are redefining a structure with different slots than in the
1183 ;;; currently loaded version, give a warning and return true.
1184 (defun redefine-structure-warning (classoid old new
)
1185 (declare (type defstruct-description old new
)
1186 (type classoid classoid
)
1188 (let ((name (dd-name new
)))
1189 (multiple-value-bind (moved retyped deleted
) (compare-slots old new
)
1190 (when (or moved retyped deleted
)
1192 "incompatibly redefining slots of structure class ~S~@
1193 Make sure any uses of affected accessors are recompiled:~@
1194 ~@[ These slots were moved to new positions:~% ~S~%~]~
1195 ~@[ These slots have new incompatible types:~% ~S~%~]~
1196 ~@[ These slots were deleted:~% ~S~%~]"
1197 name moved retyped deleted
)
1200 ;;; This function is called when we are incompatibly redefining a
1201 ;;; structure CLASS to have the specified NEW-LAYOUT. We signal an
1202 ;;; error with some proceed options and return the layout that should
1204 (defun %redefine-defstruct
(classoid old-layout new-layout
)
1205 (declare (type classoid classoid
)
1206 (type layout old-layout new-layout
))
1207 (let ((name (classoid-proper-name classoid
)))
1209 (error "~@<attempt to redefine the ~S class ~S incompatibly with the current definition~:@>"
1215 "~@<Use the new definition of ~S, invalidating ~
1216 already-loaded code and instances.~@:>"
1218 (register-layout new-layout
))
1219 (recklessly-continue ()
1222 "~@<Use the new definition of ~S as if it were ~
1223 compatible, allowing old accessors to use new ~
1224 instances and allowing new accessors to use old ~
1227 ;; classic CMU CL warning: "Any old ~S instances will be in a bad way.
1228 ;; I hope you know what you're doing..."
1229 (register-layout new-layout
1231 :destruct-layout old-layout
))
1233 ;; FIXME: deprecated 2002-10-16, and since it's only interactive
1234 ;; hackery instead of a supported feature, can probably be deleted
1236 :report
"(deprecated synonym for RECKLESSLY-CONTINUE)"
1237 (register-layout new-layout
1239 :destruct-layout old-layout
))))
1242 (declaim (inline dd-layout-length
))
1243 (defun dd-layout-length (dd)
1244 (+ (dd-length dd
) #!-interleaved-raw-slots
(dd-raw-length dd
)))
1246 (declaim (ftype (sfunction (defstruct-description) index
) dd-instance-length
))
1247 (defun dd-instance-length (dd)
1248 ;; Make sure the object ends at a two-word boundary. Note that this does
1249 ;; not affect the amount of memory used, since the allocator would add the
1250 ;; same padding anyway. However, raw slots are indexed from the length of
1251 ;; the object as indicated in the header, so the pad word needs to be
1252 ;; included in that length to guarantee proper alignment of raw double float
1253 ;; slots, necessary for (at least) the SPARC backend.
1254 ;; On backends with interleaved raw slots, the convention of having the
1255 ;; header possibly "lie" about an extra word is more of a bug than a feature.
1256 ;; Because the structure base is aligned, double-word raw slots are properly
1257 ;; aligned, and won't change alignment in descendant object types. It would
1258 ;; be correct to store the true instance length even though GC preserves
1259 ;; the extra data word (as it does for odd-length SIMPLE-VECTOR), treating
1260 ;; the total physical length as rounded-to-even. But having two different
1261 ;; conventions would be even more unnecessarily confusing, so we use
1262 ;; the not-sensible convention even when it does not make sense.
1263 (logior (dd-layout-length dd
) 1))
1265 (defun dd-bitmap (dd)
1266 ;; The bitmap stores a 1 for each untagged word,
1267 ;; including any internal padding words for alignment.
1268 ;; The 0th bit is initialized to 0 because the LAYOUT is a tagged
1269 ;; slot that is not present in DD-SLOTS.
1270 ;; All other bits start as 1 and are cleared if the word is tagged.
1271 ;; A final padding word, if any, is regarded as tagged.
1272 (let ((bitmap (ldb (byte (dd-length dd
) 0)
1273 (ash -
1 sb
!vm
:instance-data-start
))))
1274 (dolist (slot (dd-slots dd
) bitmap
)
1275 (when (eql t
(dsd-raw-type slot
))
1276 (setf (ldb (byte 1 (dsd-index slot
)) bitmap
) 0)))))
1278 ;;; This is called when we are about to define a structure class. It
1279 ;;; returns a (possibly new) class object and the layout which should
1280 ;;; be used for the new definition (may be the current layout, and
1281 ;;; also might be an uninstalled forward referenced layout.) The third
1282 ;;; value is true if this is an incompatible redefinition, in which
1283 ;;; case it is the old layout.
1284 (defun ensure-structure-class (info inherits old-context new-context
1285 &key compiler-layout
)
1286 (multiple-value-bind (class old-layout
)
1290 (class 'structure-classoid
)
1291 (constructor 'make-structure-classoid
))
1292 (dd-alternate-metaclass info
)
1293 (declare (ignore name
))
1294 (insured-find-classoid (dd-name info
)
1295 (if (eq class
'structure-classoid
)
1297 (sb!xc
:typep x
'structure-classoid
))
1299 (sb!xc
:typep x
(classoid-name (find-classoid class
)))))
1300 (fdefinition constructor
)))
1301 (setf (classoid-direct-superclasses class
)
1302 (case (dd-name info
)
1305 sb
!impl
::string-input-stream sb
!impl
::string-output-stream
1306 sb
!impl
::fill-pointer-output-stream
)
1307 (list (layout-classoid (svref inherits
(1- (length inherits
))))
1308 (layout-classoid (svref inherits
(- (length inherits
) 2)))))
1310 (list (layout-classoid
1311 (svref inherits
(1- (length inherits
))))))))
1312 (let ((new-layout (make-layout :classoid class
1314 :depthoid
(length inherits
)
1315 :length
(dd-layout-length info
)
1317 .
#!-interleaved-raw-slots
1318 (:n-untagged-slots
(dd-raw-length info
))
1319 #!+interleaved-raw-slots
1320 (:untagged-bitmap
(dd-bitmap info
))))
1321 (old-layout (or compiler-layout old-layout
)))
1324 (values class new-layout nil
))
1325 (;; This clause corresponds to an assertion in REDEFINE-LAYOUT-WARNING
1326 ;; of classic CMU CL. I moved it out to here because it was only
1327 ;; exercised in this code path anyway. -- WHN 19990510
1328 (not (eq (layout-classoid new-layout
) (layout-classoid old-layout
)))
1329 (error "shouldn't happen: weird state of OLD-LAYOUT?"))
1330 ((not *type-system-initialized
*)
1331 (setf (layout-info old-layout
) info
)
1332 (values class old-layout nil
))
1333 ((redefine-layout-warning old-context
1336 (layout-length new-layout
)
1337 (layout-inherits new-layout
)
1338 (layout-depthoid new-layout
)
1339 (layout-raw-slot-metadata new-layout
))
1340 (values class new-layout old-layout
))
1342 (let ((old-info (layout-info old-layout
)))
1344 ((or defstruct-description
)
1345 (cond ((redefine-structure-warning class old-info info
)
1346 (values class new-layout old-layout
))
1348 (setf (layout-info old-layout
) info
)
1349 (values class old-layout nil
))))
1351 (setf (layout-info old-layout
) info
)
1352 (values class old-layout nil
))
1354 (error "shouldn't happen! strange thing in LAYOUT-INFO:~% ~S"
1356 (values class new-layout old-layout
)))))))))
1358 ;;; Return a list of pairs (name . index). Used for :TYPE'd
1359 ;;; constructors to find all the names that we have to splice in &
1360 ;;; where. Note that these types don't have a layout, so we can't look
1361 ;;; at LAYOUT-INHERITS.
1362 (defun find-name-indices (defstruct)
1365 (do ((info defstruct
1366 (typed-structure-info-or-lose (first (dd-include info
)))))
1367 ((not (dd-include info
))
1372 (dolist (info infos
)
1373 (incf i
(or (dd-offset info
) 0))
1374 (when (dd-named info
)
1375 (res (cons (dd-name info
) i
)))
1376 (setq i
(dd-length info
)))))
1380 ;;; These functions are called to actually make a constructor after we
1381 ;;; have processed the arglist. The correct variant (according to the
1382 ;;; DD-TYPE) should be called. The function is defined with the
1383 ;;; specified name and arglist. VARS and TYPES are used for argument
1384 ;;; type declarations. VALUES are the values for the slots (in order.)
1386 ;;; This is split three ways because:
1387 ;;; * LIST & VECTOR structures need "name" symbols stuck in at
1388 ;;; various weird places, whereas STRUCTURE structures have
1390 ;;; * We really want to use LIST to make list structures, instead of
1391 ;;; MAKE-LIST/(SETF ELT). (We can't in general use VECTOR in an
1392 ;;; analogous way, since VECTOR makes a SIMPLE-VECTOR and vector-typed
1393 ;;; structures can have arbitrary subtypes of VECTOR, not necessarily
1395 ;;; * STRUCTURE structures can have raw slots that must also be
1396 ;;; allocated and indirectly referenced.
1397 (defun create-vector-constructor (dd cons-name arglist ftype-arglist decls values
)
1398 (let ((temp (gensym))
1399 (etype (dd-element-type dd
))
1400 (len (dd-length dd
)))
1402 `(defun ,cons-name
,arglist
1403 ,@(when decls
`((declare ,@decls
)))
1404 (let ((,temp
(make-array ,len
:element-type
',etype
)))
1405 ,@(mapcar (lambda (x)
1406 `(setf (aref ,temp
,(cdr x
)) ',(car x
)))
1407 (find-name-indices dd
))
1408 ,@(mapcar (lambda (dsd value
)
1409 (unless (eq value
'.do-not-initialize-slot.
)
1410 `(setf (aref ,temp
,(dsd-index dsd
)) ,value
)))
1411 (dd-slots dd
) values
)
1413 `(sfunction ,ftype-arglist
(simple-array ,etype
(,len
))))))
1414 (defun create-list-constructor (dd cons-name arglist ftype-arglist decls values
)
1415 (let ((vals (make-list (dd-length dd
) :initial-element nil
)))
1416 (dolist (x (find-name-indices dd
))
1417 (setf (elt vals
(cdr x
)) `',(car x
)))
1418 (loop for dsd in
(dd-slots dd
) and val in values do
1419 (setf (elt vals
(dsd-index dsd
))
1420 (if (eq val
'.do-not-initialize-slot.
) 0 val
)))
1422 `(defun ,cons-name
,arglist
1423 ,@(when decls
`((declare ,@decls
)))
1425 `(sfunction ,ftype-arglist list
))))
1426 (defun create-structure-constructor (dd cons-name arglist ftype-arglist decls values
)
1428 ;; The difference between the two implementations here is that on all
1429 ;; platforms we don't have the appropriate RAW-INSTANCE-INIT VOPS, which
1430 ;; must be able to deal with immediate values as well -- unlike
1431 ;; RAW-INSTANCE-SET VOPs, which never end up seeing immediate values. With
1432 ;; some additional cleverness we might manage without them and just a single
1433 ;; implementation here, though -- figure out a way to ensure that on those
1434 ;; platforms we always still get a non-immediate TN in every case...
1436 ;; Until someone does that, this means that instances with raw slots can be
1437 ;; DX allocated only on platforms with those additional VOPs.
1438 #!+raw-instance-init-vops
1439 (let* ((slot-values nil
)
1441 (mapcan (lambda (dsd value
)
1442 (unless (eq value
'.do-not-initialize-slot.
)
1443 (push value slot-values
)
1444 (list (list* :slot
(dsd-raw-type dsd
) (dsd-index dsd
)))))
1447 `(defun ,cons-name
,arglist
1448 ,@(when decls
`((declare ,@decls
)))
1449 (%make-structure-instance-macro
,dd
',slot-specs
,@(reverse slot-values
))))
1450 #!-raw-instance-init-vops
1451 (let ((instance (gensym "INSTANCE")) slot-values slot-specs raw-slots raw-values
)
1452 (mapc (lambda (dsd value
)
1453 (unless (eq value
'.do-not-initialize-slot.
)
1454 (let ((raw-type (dsd-raw-type dsd
)))
1455 (cond ((eq t raw-type
)
1456 (push value slot-values
)
1457 (push (list* :slot raw-type
(dsd-index dsd
)) slot-specs
))
1459 (push value raw-values
)
1460 (push dsd raw-slots
))))))
1463 `(defun ,cons-name
,arglist
1464 ,@(when decls
`((declare ,@decls
)))
1466 `(let ((,instance
(%make-structure-instance-macro
,dd
',slot-specs
,@slot-values
)))
1467 ,@(mapcar (lambda (dsd value
)
1468 ;; (Note that we can't in general use the
1469 ;; ordinary named slot setter function here
1470 ;; because the slot might be :READ-ONLY, so we
1471 ;; whip up new LAMBDA representations of slot
1472 ;; setters for the occasion.)
1473 `(,(slot-setter-lambda-form dd dsd
) ,value
,instance
))
1477 `(%make-structure-instance-macro
,dd
',slot-specs
,@slot-values
))))
1478 `(sfunction ,ftype-arglist
,(dd-name dd
))))
1480 ;;; Create a default (non-BOA) keyword constructor.
1481 (defun create-keyword-constructor (defstruct creator
)
1482 (declare (type function creator
))
1483 (collect ((arglist (list '&key
))
1487 (let ((int-type (if (eq 'vector
(dd-type defstruct
))
1488 (dd-element-type defstruct
)
1490 (dolist (slot (dd-slots defstruct
))
1491 (let* ((dum (sb!xc
:gensym
"DUM"))
1492 (name (dsd-name slot
))
1493 (keyword (keywordicate name
))
1494 ;; Canonicalize the type for a prettier macro-expansion
1495 (type (type-specifier
1496 (specifier-type `(and ,int-type
,(dsd-type slot
))))))
1497 (arglist `((,keyword
,dum
) ,(dsd-default slot
)))
1499 ;; KLUDGE: we need a separate type declaration for for
1500 ;; keyword arguments, since default values bypass the
1501 ;; checking provided by the FTYPE.
1503 (decls `(type ,type
,dum
)))
1504 (ftype-args `(,keyword
,type
)))))
1506 defstruct
(dd-default-constructor defstruct
)
1507 (arglist) `(&key
,@(ftype-args)) (decls) (vals))))
1509 ;;; Given a structure and a BOA constructor spec, call CREATOR with
1510 ;;; the appropriate args to make a constructor.
1511 (defun create-boa-constructor (defstruct boa creator
)
1512 (declare (type function creator
))
1513 (multiple-value-bind (req opt restp rest keyp keys allowp auxp aux
)
1514 (parse-lambda-list (second boa
))
1520 (let ((int-type (if (eq 'vector
(dd-type defstruct
))
1521 (dd-element-type defstruct
)
1523 (labels ((get-slot (name)
1524 (let* ((res (find name
(dd-slots defstruct
)
1527 (type (type-specifier
1529 `(and ,int-type
,(if res
1532 (values type
(when res
(dsd-default res
)))))
1533 (do-default (arg &optional keyp
)
1534 (multiple-value-bind (type default
) (get-slot arg
)
1535 (arglist `(,arg
,default
))
1538 (arg-type type
(keywordicate arg
) arg
)
1540 (arg-type (type &optional key var
)
1542 ;; KLUDGE: see comment in CREATE-KEYWORD-CONSTRUCTOR.
1544 (decls `(type ,type
,var
)))
1545 (ftype-args `(,key
,type
)))
1547 (ftype-args type
)))))
1551 (arg-type (get-slot arg
)))
1554 (arglist '&optional
)
1555 (ftype-args '&optional
)
1559 ;; FIXME: this shares some logic (though not
1560 ;; code) with the &key case below (and it
1561 ;; looks confusing) -- factor out the logic
1562 ;; if possible. - CSR, 2002-04-19
1565 (def (nth-value 1 (get-slot name
)))
1566 (supplied-test nil supplied-test-p
))
1568 (arglist `(,name
,def
,@(if supplied-test-p
`(,supplied-test
) nil
)))
1570 (arg-type (get-slot name
))
1571 (when supplied-test-p
1572 (vars supplied-test
))))
1574 (do-default arg
)))))
1577 (arglist '&rest rest
)
1581 (decls `(type list
,rest
)))
1588 (destructuring-bind (wot
1591 (supplied-test nil supplied-test-p
))
1593 (multiple-value-bind (key name
)
1595 (destructuring-bind (key var
) wot
1597 (values (keywordicate wot
) wot
))
1598 (multiple-value-bind (type slot-def
)
1600 (arglist `(,wot
,(if def-p def slot-def
)
1601 ,@(if supplied-test-p
`(,supplied-test
) nil
)))
1603 (arg-type type key name
)
1604 (when supplied-test-p
1605 (vars supplied-test
)))))
1606 (do-default key t
))))
1609 (arglist '&allow-other-keys
)
1610 (ftype-args '&allow-other-keys
))
1616 ((cons symbol
(cons t null
))
1617 (let ((var (first arg
)))
1620 (decls `(type ,(get-slot var
) ,var
))))
1622 (skipped-vars (first arg
)))
1626 (error "Malformed &AUX binding specifier: ~s." arg
)))))))
1628 (funcall creator defstruct
(first boa
)
1629 (arglist) (ftype-args) (decls)
1630 (loop for slot in
(dd-slots defstruct
)
1631 for name
= (dsd-name slot
)
1632 collect
(cond ((find name
(skipped-vars) :test
#'string
=)
1633 ;; CLHS 3.4.6 Boa Lambda Lists
1634 '.do-not-initialize-slot.
)
1635 ((or (find (dsd-name slot
) (vars) :test
#'string
=)
1636 (let ((type (dsd-type slot
)))
1639 `(the ,type
,(dsd-default slot
))))))))))))
1641 ;;; Grovel the constructor options, and decide what constructors (if
1643 (defun constructor-definitions (defstruct)
1644 (let ((no-constructors nil
)
1647 (creator (ecase (dd-type defstruct
)
1648 (structure #'create-structure-constructor
)
1649 (vector #'create-vector-constructor
)
1650 (list #'create-list-constructor
))))
1651 (dolist (constructor (dd-constructors defstruct
))
1652 (destructuring-bind (name &optional
(boa-ll nil boa-p
)) constructor
1653 (declare (ignore boa-ll
))
1654 (cond ((not name
) (setq no-constructors t
))
1655 (boa-p (push constructor boas
))
1656 (t (push name defaults
)))))
1658 (when no-constructors
1659 (when (or defaults boas
)
1660 (error "(:CONSTRUCTOR NIL) combined with other :CONSTRUCTORs"))
1661 (return-from constructor-definitions
()))
1663 (unless (or defaults boas
)
1664 (push (symbolicate "MAKE-" (dd-name defstruct
)) defaults
))
1668 (let ((cname (first defaults
)))
1669 (setf (dd-default-constructor defstruct
) cname
)
1670 (multiple-value-bind (cons ftype
)
1671 (create-keyword-constructor defstruct creator
)
1672 (res `(declaim (ftype ,ftype
,@defaults
)))
1674 (dolist (other-name (rest defaults
))
1675 (res `(setf (fdefinition ',other-name
) (fdefinition ',cname
))))))
1678 (multiple-value-bind (cons ftype
)
1679 (create-boa-constructor defstruct boa creator
)
1680 (res `(declaim (ftype ,ftype
,(first boa
))))
1685 (defun accessor-definitions (dd)
1686 (loop for dsd in
(dd-slots dd
)
1687 for accessor-name
= (dsd-accessor-name dsd
)
1688 for place-form
= (%accessor-place-form dd dsd
`(the ,(dd-name dd
) instance
))
1689 unless
(accessor-inherited-data accessor-name dd
)
1691 `(defun ,accessor-name
(instance)
1692 ,(cond ((not (dsd-type dsd
))
1695 `(truly-the ,(dsd-type dsd
) ,place-form
))
1697 `(the ,(dsd-type dsd
) ,place-form
))))
1698 and unless
(dsd-read-only dsd
)
1700 `(defun (setf ,accessor-name
) (value instance
)
1701 (setf ,place-form
(the ,(dsd-type dsd
) value
)))))
1703 (defun copier-definition (dd)
1704 (when (dd-copier-name dd
)
1705 `(defun ,(dd-copier-name dd
) (instance)
1706 (copy-structure (the ,(dd-name dd
) instance
)))))
1708 (defun predicate-definition (dd)
1709 (when (dd-predicate-name dd
)
1710 `(defun ,(dd-predicate-name dd
) (object)
1711 (typep object
',(dd-name dd
)))))
1714 ;;;; instances with ALTERNATE-METACLASS
1716 ;;;; The CMU CL support for structures with ALTERNATE-METACLASS was a
1717 ;;;; fairly general extension embedded in the main DEFSTRUCT code, and
1718 ;;;; the result was an fairly impressive mess as ALTERNATE-METACLASS
1719 ;;;; extension mixed with ANSI CL generality (e.g. :TYPE and :INCLUDE)
1720 ;;;; and CMU CL implementation hairiness (esp. raw slots). This SBCL
1721 ;;;; version is much less ambitious, noticing that ALTERNATE-METACLASS
1722 ;;;; is only used to implement CONDITION, STANDARD-INSTANCE, and
1723 ;;;; GENERIC-FUNCTION, and defining a simple specialized
1724 ;;;; separate-from-DEFSTRUCT macro to provide only enough
1725 ;;;; functionality to support those.
1727 ;;;; KLUDGE: The defining macro here is so specialized that it's ugly
1728 ;;;; in its own way. It also violates once-and-only-once by knowing
1729 ;;;; much about structures and layouts that is already known by the
1730 ;;;; main DEFSTRUCT macro. Hopefully it will go away presently
1731 ;;;; (perhaps when CL:CLASS and SB-PCL:CLASS meet) as per FIXME below.
1732 ;;;; -- WHN 2001-10-28
1734 ;;;; FIXME: There seems to be no good reason to shoehorn CONDITION,
1735 ;;;; STANDARD-INSTANCE, and GENERIC-FUNCTION into mutated structures
1736 ;;;; instead of just implementing them as primitive objects. (This
1737 ;;;; reduced-functionality macro seems pretty close to the
1738 ;;;; functionality of !DEFINE-PRIMITIVE-OBJECT..)
1740 ;;; The complete list of alternate-metaclass DEFSTRUCTs:
1741 ;;; CONDITION SB-EVAL:INTERPRETED-FUNCTION
1742 ;;; SB-PCL::STANDARD-INSTANCE SB-PCL::STANDARD-FUNCALLABLE-INSTANCE
1743 ;;; SB-PCL::CTOR SB-PCL::%METHOD-FUNCTION
1745 (defun make-dd-with-alternate-metaclass (&key
(class-name (missing-arg))
1746 (superclass-name (missing-arg))
1747 (metaclass-name (missing-arg))
1748 (dd-type (missing-arg))
1749 metaclass-constructor
1751 (let* ((dd (make-defstruct-description class-name
))
1752 (conc-name (concatenate 'string
(symbol-name class-name
) "-"))
1753 (dd-slots (let ((reversed-result nil
)
1754 ;; The index starts at 1 for ordinary named
1755 ;; slots because slot 0 is magical, used for
1756 ;; the LAYOUT in CONDITIONs and
1757 ;; FUNCALLABLE-INSTANCEs. (This is the same
1758 ;; in ordinary structures too: see (INCF
1760 ;; PARSE-DEFSTRUCT-NAME-AND-OPTIONS).
1762 (dolist (slot-name slot-names
)
1763 (push (make-defstruct-slot-description
1766 :accessor-name
(symbolicate conc-name slot-name
))
1769 (nreverse reversed-result
))))
1770 ;; We do *not* fill in the COPIER-NAME and PREDICATE-NAME
1771 ;; because none of the magical alternate-metaclass structures
1772 ;; have copiers and predicates that "Just work"
1774 ;; We don't support inheritance of alternate metaclass stuff,
1775 ;; and it's not a general-purpose facility, so sanity check our
1778 (aver (eq superclass-name
't
)))
1779 (funcallable-structure
1780 (aver (eq superclass-name
'function
)))
1781 (t (bug "Unknown DD-TYPE in ALTERNATE-METACLASS: ~S" dd-type
)))
1782 (setf (dd-alternate-metaclass dd
) (list superclass-name
1784 metaclass-constructor
)
1785 (dd-slots dd
) dd-slots
1786 (dd-length dd
) (1+ (length slot-names
))
1787 (dd-type dd
) dd-type
)
1790 ;;; make !DEFSTRUCT-WITH-ALTERNATE-METACLASS compilable by the host
1791 ;;; lisp, installing the information we need to reason about the
1792 ;;; structures (layouts and classoids).
1794 ;;; FIXME: we should share the parsing and the DD construction between
1795 ;;; this and the cross-compiler version, but my brain was too small to
1796 ;;; get that right. -- CSR, 2006-09-14
1798 (defmacro !defstruct-with-alternate-metaclass
1800 (slot-names (missing-arg))
1801 (boa-constructor (missing-arg))
1802 (superclass-name (missing-arg))
1803 (metaclass-name (missing-arg))
1804 (metaclass-constructor (missing-arg))
1805 (dd-type (missing-arg))
1807 (runtime-type-checks-p t
))
1809 (declare (type (and list
(not null
)) slot-names
))
1810 (declare (type (and symbol
(not null
))
1814 metaclass-constructor
))
1815 (declare (type symbol predicate
))
1816 (declare (type (member structure funcallable-structure
) dd-type
))
1817 (declare (ignore boa-constructor predicate runtime-type-checks-p
))
1819 (let* ((dd (make-dd-with-alternate-metaclass
1820 :class-name class-name
1821 :slot-names slot-names
1822 :superclass-name superclass-name
1823 :metaclass-name metaclass-name
1824 :metaclass-constructor metaclass-constructor
1828 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
1829 (%compiler-set-up-layout
',dd
',(inherits-for-structure dd
))))))
1831 (sb!xc
:proclaim
'(special *defstruct-hooks
*))
1833 (sb!xc
:defmacro
!defstruct-with-alternate-metaclass
1835 (slot-names (missing-arg))
1836 (boa-constructor (missing-arg))
1837 (superclass-name (missing-arg))
1838 (metaclass-name (missing-arg))
1839 (metaclass-constructor (missing-arg))
1840 (dd-type (missing-arg))
1842 (runtime-type-checks-p t
))
1844 (declare (type (and list
(not null
)) slot-names
))
1845 (declare (type (and symbol
(not null
))
1849 metaclass-constructor
))
1850 (declare (type symbol predicate
))
1851 (declare (type (member structure funcallable-structure
) dd-type
))
1853 (let* ((dd (make-dd-with-alternate-metaclass
1854 :class-name class-name
1855 :slot-names slot-names
1856 :superclass-name superclass-name
1857 :metaclass-name metaclass-name
1858 :metaclass-constructor metaclass-constructor
1860 (dd-slots (dd-slots dd
))
1861 (dd-length (1+ (length slot-names
)))
1862 (object-gensym (sb!xc
:gensym
"OBJECT"))
1863 (new-value-gensym (sb!xc
:gensym
"NEW-VALUE-"))
1864 (delayed-layout-form `(%delayed-get-compiler-layout
,class-name
)))
1865 (multiple-value-bind (raw-maker-form raw-reffer-operator
)
1868 (values `(%make-structure-instance-macro
,dd nil
)
1870 (funcallable-structure
1871 (values `(let ((,object-gensym
1872 (%make-funcallable-instance
,dd-length
)))
1873 (setf (%funcallable-instance-layout
,object-gensym
)
1874 ,delayed-layout-form
)
1876 '%funcallable-instance-info
)))
1879 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
1880 (%compiler-set-up-layout
',dd
',(inherits-for-structure dd
)))
1882 ;; slot readers and writers
1883 (declaim (inline ,@(mapcar #'dsd-accessor-name dd-slots
)))
1884 ,@(mapcar (lambda (dsd)
1885 `(defun ,(dsd-accessor-name dsd
) (,object-gensym
)
1886 ,@(when runtime-type-checks-p
1887 `((declare (type ,class-name
,object-gensym
))))
1888 (,raw-reffer-operator
,object-gensym
1891 (declaim (inline ,@(mapcar (lambda (dsd)
1892 `(setf ,(dsd-accessor-name dsd
)))
1894 ,@(mapcar (lambda (dsd)
1895 `(defun (setf ,(dsd-accessor-name dsd
)) (,new-value-gensym
1897 ,@(when runtime-type-checks-p
1898 `((declare (type ,class-name
,object-gensym
))))
1899 (setf (,raw-reffer-operator
,object-gensym
1901 ,new-value-gensym
)))
1905 (defun ,boa-constructor
,slot-names
1906 (let ((,object-gensym
,raw-maker-form
))
1907 ,@(mapcar (lambda (slot-name)
1908 (let ((dsd (find (symbol-name slot-name
) dd-slots
1910 (symbol-name (dsd-name x
)))
1912 ;; KLUDGE: bug 117 bogowarning. Neither
1913 ;; DECLAREing the type nor TRULY-THE cut
1914 ;; the mustard -- it still gives warnings.
1915 (enforce-type dsd defstruct-slot-description
)
1916 `(setf (,(dsd-accessor-name dsd
) ,object-gensym
)
1923 ;; Just delegate to the compiler's type optimization
1924 ;; code, which knows how to generate inline type tests
1925 ;; for the whole CMU CL INSTANCE menagerie.
1926 `(defun ,predicate
(,object-gensym
)
1927 (typep ,object-gensym
',class-name
)))
1929 (aver (null *defstruct-hooks
*))))))
1931 ;;;; finalizing bootstrapping
1933 ;;; Set up DD and LAYOUT for STRUCTURE-OBJECT class itself.
1935 ;;; Ordinary structure classes effectively :INCLUDE STRUCTURE-OBJECT
1936 ;;; when they have no explicit :INCLUDEs, so (1) it needs to be set up
1937 ;;; before we can define ordinary structure classes, and (2) it's
1938 ;;; special enough (and simple enough) that we just build it by hand
1939 ;;; instead of trying to generalize the ordinary DEFSTRUCT code.
1940 (defun !set-up-structure-object-class
()
1941 (let ((dd (make-defstruct-description 'structure-object
)))
1943 ;; Note: This has an ALTERNATE-METACLASS only because of blind
1944 ;; clueless imitation of the CMU CL code -- dunno if or why it's
1946 (dd-alternate-metaclass dd
) '(t)
1949 (dd-type dd
) 'structure
)
1950 (%compiler-set-up-layout dd
)))
1951 #+sb-xc-host
(!set-up-structure-object-class
)
1953 ;;; early structure predeclarations: Set up DD and LAYOUT for ordinary
1954 ;;; (non-ALTERNATE-METACLASS) structures which are needed early.
1956 '#.
(sb-cold:read-from-file
1957 "src/code/early-defstruct-args.lisp-expr"))
1958 (let* ((dd (parse-defstruct-name-and-options-and-slot-descriptions
1961 (inherits (inherits-for-structure dd
)))
1962 (%compiler-defstruct dd inherits
)))
1964 (defun find-defstruct-description (name &optional
(errorp t
))
1965 (let* ((classoid (find-classoid name errorp
))
1967 (layout-info (classoid-layout classoid
)))))
1968 (cond ((defstruct-description-p info
)
1971 (error "No DEFSTRUCT-DESCRIPTION for ~S." name
)))))
1973 (/show0
"code/defstruct.lisp end of file")