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
))
28 (sb!int
:check-deprecated-type name
)
31 (defun compiler-layout-ready-p (name)
32 (let ((layout (info :type
:compiler-layout name
)))
33 (and layout
(typep (layout-info layout
) 'defstruct-description
))))
35 (sb!xc
:defmacro %make-structure-instance-macro
(dd slot-specs
&rest slot-vars
)
36 (if (compiler-layout-ready-p (dd-name dd
))
37 `(truly-the ,(dd-name dd
)
38 (%make-structure-instance
,dd
,slot-specs
,@slot-vars
))
39 ;; Non-toplevel defstructs don't have a layout at compile time,
40 ;; so we need to construct the actual function at runtime -- but
41 ;; we cache it at the call site, so that we don't perform quite
43 `(let* ((cell (load-time-value (list nil
)))
46 (funcall fun
,@slot-vars
)
47 (funcall (setf (car cell
)
48 (%make-structure-instance-allocator
,dd
,slot-specs
))
51 (declaim (ftype (sfunction (defstruct-description list
) function
)
52 %make-structure-instance-allocator
))
53 (defun %make-structure-instance-allocator
(dd slot-specs
)
54 (let ((vars (make-gensym-list (length slot-specs
))))
57 (%make-structure-instance-macro
,dd
',slot-specs
,@vars
))))))
59 (defun %make-funcallable-structure-instance-allocator
(dd slot-specs
)
61 (bug "funcallable-structure-instance allocation with slots unimplemented"))
62 (let ((name (dd-name dd
))
63 (length (dd-length dd
))
64 (nobject (gensym "OBJECT")))
66 (compile nil
`(lambda ()
67 (let ((,nobject
(%make-funcallable-instance
,length
)))
68 (setf (%funcallable-instance-layout
,nobject
)
69 (%delayed-get-compiler-layout
,name
))
72 ;;; Delay looking for compiler-layout until the constructor is being
73 ;;; compiled, since it doesn't exist until after the EVAL-WHEN
74 ;;; (COMPILE) stuff is compiled. (Or, in the oddball case when
75 ;;; DEFSTRUCT is executing in a non-toplevel context, the
76 ;;; compiler-layout still doesn't exist at compilation time, and we
77 ;;; delay still further.)
78 (sb!xc
:defmacro %delayed-get-compiler-layout
(name)
79 (let ((layout (info :type
:compiler-layout name
)))
81 ;; ordinary case: When the DEFSTRUCT is at top level,
82 ;; then EVAL-WHEN (COMPILE) stuff will have set up the
83 ;; layout for us to use.
84 (unless (typep (layout-info layout
) 'defstruct-description
)
85 (error "Class is not a structure class: ~S" name
))
88 ;; KLUDGE: In the case that DEFSTRUCT is not at top-level
89 ;; the layout doesn't exist at compile time. In that case
90 ;; we laboriously look it up at run time. This code will
91 ;; run on every constructor call and will likely be quite
92 ;; slow, so if anyone cares about performance of
93 ;; non-toplevel DEFSTRUCTs, it should be rewritten to be
94 ;; cleverer. -- WHN 2002-10-23
96 "implementation limitation: ~
97 Non-toplevel DEFSTRUCT constructors are slow.")
98 (with-unique-names (layout)
99 `(let ((,layout
(info :type
:compiler-layout
',name
)))
100 (unless (typep (layout-info ,layout
) 'defstruct-description
)
101 (error "Class is not a structure class: ~S" ',name
))
104 ;;; re. %DELAYED-GET-COMPILER-LAYOUT and COMPILE-TIME-FIND-LAYOUT, above..
106 ;;; FIXME: Perhaps both should be defined with SB!XC:DEFMACRO?
107 ;;; FIXME: Do we really need both? If so, their names and implementations
108 ;;; should probably be tweaked to be more parallel.
110 ;;;; DEFSTRUCT-DESCRIPTION
112 ;;; The DEFSTRUCT-DESCRIPTION structure holds compile-time information
113 ;;; about a structure type.
114 ;;; Its definition occurs in 'early-classoid.lisp'
115 (def!method print-object
((x defstruct-description
) stream
)
116 (print-unreadable-object (x stream
:type t
:identity t
)
117 (prin1 (dd-name x
) stream
)))
119 ;;; Does DD describe a structure with a class?
120 (defun dd-class-p (dd)
121 (if (member (dd-type dd
) '(structure funcallable-structure
)) t nil
))
123 (defun dd-layout-or-lose (dd)
124 (compiler-layout-or-lose (dd-name dd
)))
126 ;;;; DEFSTRUCT-SLOT-DESCRIPTION
128 ;;; A DEFSTRUCT-SLOT-DESCRIPTION holds compile-time information about
129 ;;; a structure slot.
130 (def!struct
(defstruct-slot-description
131 (:make-load-form-fun just-dump-it-normally
)
134 #-sb-xc-host
(:pure t
))
137 ;; its position in the implementation sequence
138 (index (missing-arg) :type fixnum
)
139 ;; the name of the accessor function
141 ;; (CMU CL had extra complexity here ("..or NIL if this accessor has
142 ;; the same name as an inherited accessor (which we don't want to
143 ;; shadow)") but that behavior doesn't seem to be specified by (or
144 ;; even particularly consistent with) ANSI, so it's gone in SBCL.)
145 (accessor-name nil
:type symbol
)
146 default
; default value expression
147 (type t
) ; declared type specifier
148 (safe-p t
:type boolean
) ; whether the slot is known to be
149 ; always of the specified type
150 ;; Index into *RAW-SLOT-DATA* vector of the RAW-SLOT-DATA for this slot.
151 ;; The index is -1 if this slot is not raw.
152 (%raw-type -
1 :type
(integer -
1 (#.
(length *raw-slot-data
*))))
153 (read-only nil
:type
(member t nil
)))
154 #!-sb-fluid
(declaim (freeze-type defstruct-slot-description
))
155 (def!method print-object
((x defstruct-slot-description
) stream
)
156 (print-unreadable-object (x stream
:type t
)
157 (prin1 (dsd-name x
) stream
)))
158 (defun dsd-raw-slot-data (dsd)
159 (let ((type-index (dsd-%raw-type dsd
)))
160 (and (>= type-index
0)
161 (svref *raw-slot-data
* type-index
))))
162 (defun dsd-raw-type (dsd)
163 (acond ((dsd-raw-slot-data dsd
) (raw-slot-data-raw-type it
))
166 ;;;; typed (non-class) structures
168 ;;; Return a type specifier we can use for testing :TYPE'd structures.
169 (defun dd-lisp-type (defstruct)
170 (ecase (dd-type defstruct
)
172 (vector `(simple-array ,(dd-element-type defstruct
) (*)))))
174 ;;;; shared machinery for inline and out-of-line slot accessor functions
176 ;;; Classic comment preserved for entertainment value:
178 ;;; "A lie can travel halfway round the world while the truth is
179 ;;; putting on its shoes." -- Mark Twain
181 ;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its
182 ;;;; close personal friend SB!XC:DEFSTRUCT)
184 (sb!xc
:defmacro delay-defstruct-functions
(name &rest forms
)
185 ;; KLUDGE: If DEFSTRUCT is not at the top-level,
186 ;; (typep x 'name) and similar forms can't get optimized
187 ;; and produce style-warnings for unknown types.
188 (let ((forms (cons 'progn forms
)))
189 (if (compiler-layout-ready-p name
)
193 (defun %defstruct-package-locks
(dd)
194 (let ((name (dd-name dd
)))
195 #+sb-xc-host
(declare (ignore name
))
196 (with-single-package-locked-error
197 (:symbol name
"defining ~S as a structure"))
198 (awhen (dd-predicate-name dd
)
199 (with-single-package-locked-error
200 (:symbol it
"defining ~s as a predicate for ~s structure" name
)))
201 (awhen (dd-copier-name dd
)
202 (with-single-package-locked-error
203 (:symbol it
"defining ~s as a copier for ~s structure" name
)))
204 #-sb-xc-host
; does nothing anyway except warn about non-use of CTOR
205 (dolist (ctor (dd-constructors dd
))
206 (with-single-package-locked-error
207 (:symbol
(car ctor
) "defining ~s as a constructor for ~s structure" name
)))
208 (dolist (dsd (dd-slots dd
))
209 (awhen (dsd-accessor-name dsd
)
210 (with-single-package-locked-error
211 (:symbol it
"defining ~s as an accessor for ~s structure" name
))))))
213 ;;; shared logic for host macroexpansion for SB!XC:DEFSTRUCT and
214 ;;; cross-compiler macroexpansion for CL:DEFSTRUCT
215 ;;; This monster has exactly one inline use in the final image,
216 ;;; and we can drop the definition.
217 (declaim (inline !expander-for-defstruct
))
218 (defun !expander-for-defstruct
(null-env-p name-and-options slot-descriptions
219 expanding-into-code-for
)
221 (((dd classoid inherits
)
222 (parse-defstruct null-env-p name-and-options slot-descriptions
))
223 (boa-constructors (member-if #'listp
(dd-constructors dd
) :key
#'cdr
))
224 (keyword-constructors (ldiff (dd-constructors dd
) boa-constructors
))
225 (constructor-definitions
227 (when keyword-constructors
228 (let ((primary (caar keyword-constructors
)))
230 `(defun ,primary
,@(structure-ctor-lambda-parts dd
:default
))
231 ;; Quasi-bogus: not all the right effects on globaldb
232 ;; happen by defining functions this cheating way.
233 (mapcar (lambda (other)
234 `(setf (fdefinition ',(car other
))
235 (fdefinition ',primary
)))
236 (rest keyword-constructors
)))))
237 (mapcar (lambda (ctor)
239 ,@(structure-ctor-lambda-parts dd
(cdr ctor
))))
243 (when (dd-print-option dd
)
244 (let* ((x (sb!xc
:gensym
"OBJECT"))
245 (s (sb!xc
:gensym
"STREAM"))
246 (fname (dd-printer-fname dd
))
247 (depthp (eq (dd-print-option dd
) :print-function
)))
248 ;; Giving empty :PRINT-OBJECT or :PRINT-FUNCTION options
249 ;; leaves FNAME eq to NIL. The user-level effect is
250 ;; to generate a PRINT-OBJECT method specialized for the type,
251 ;; implementing the default #S structure-printing behavior.
253 (setf fname
'default-structure-print depthp t
))
254 ((not (symbolp fname
))
255 ;; Don't dump the source form into the DD constant;
256 ;; just indicate that there was an expression there.
257 (setf (dd-printer-fname dd
) t
)))
258 `((sb!xc
:defmethod
print-object ((,x
,name
) ,s
)
259 (funcall #',fname
,x
,s
260 ,@(if depthp
`(*current-level-in-print
*)))))))))
261 ;; Return a list of forms and the DD-NAME.
264 `(,@(when (eq expanding-into-code-for
:target
)
265 ;; Note we intentionally enforce package locks, calling
266 ;; %DEFSTRUCT first. %DEFSTRUCT has the tests (and resulting
267 ;; CERROR) for collisions with LAYOUTs which already exist in
268 ;; the runtime. If there are collisions, we want the user's
269 ;; response to CERROR to control what happens. If the ABORT
270 ;; restart is chosen, %COMPILER-DEFSTRUCT should not modify
271 ;; the definition the class.
272 `((eval-when (:compile-toplevel
:load-toplevel
:execute
)
273 (%defstruct-package-locks
',dd
))))
274 (%defstruct
',dd
',inherits
(sb!c
:source-location
))
275 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
276 (%compiler-defstruct
',dd
',inherits
))
277 ,@(when (eq expanding-into-code-for
:target
)
278 `((delay-defstruct-functions
280 ,@(awhen (dd-copier-name dd
)
281 `((defun ,(dd-copier-name dd
) (instance)
282 (copy-structure (the ,(dd-name dd
) instance
)))))
283 ,@(awhen (dd-predicate-name dd
)
284 `((defun ,(dd-predicate-name dd
) (object)
285 (typep object
',(dd-name dd
)))))
286 ,@(accessor-definitions dd classoid
))
287 ;; This must be in the same lexical environment
288 ,@constructor-definitions
290 ;; Various other operations only make sense on the target SBCL.
291 (%target-defstruct
',dd
))))
293 ;; FIXME: missing package lock checks
294 `((eval-when (:compile-toplevel
:load-toplevel
:execute
)
295 (%proclaim-defstruct-ctors
',dd
)
296 (setf (info :typed-structure
:info
',name
) ',dd
))
297 (setf (info :source-location
:typed-structure
',name
)
298 (sb!c
:source-location
))
299 ,@(when (eq expanding-into-code-for
:target
)
300 `(,@(typed-accessor-definitions dd
)
301 ,@(typed-predicate-definitions dd
)
302 ,@(typed-copier-definitions dd
)
303 ,@constructor-definitions
305 `((setf (fdocumentation ',(dd-name dd
) 'structure
)
310 (sb!xc
:defmacro defstruct
(name-and-options &rest slot-descriptions
)
311 ;; All defstructs are toplevel in SBCL's own source code,
312 ;; so pass T for null-lexenv.
313 `(progn ,@(!expander-for-defstruct
314 t name-and-options slot-descriptions
:target
)))
317 (sb!xc
:defmacro defstruct
(name-and-options &rest slot-descriptions
320 "DEFSTRUCT {Name | (Name Option*)} [Documentation] {Slot | (Slot [Default] {Key Value}*)}
321 Define the structure type Name. Instances are created by MAKE-<name>,
322 which takes &KEY arguments allowing initial slot values to the specified.
323 A SETF'able function <name>-<slot> is defined for each slot to read and
324 write slot values. <name>-p is a type predicate.
326 Popular DEFSTRUCT options (see manual for others):
330 Specify the name for the constructor or predicate.
332 (:CONSTRUCTOR Name Lambda-List)
333 Specify the name and arguments for a BOA constructor
334 (which is more efficient when keyword syntax isn't necessary.)
336 (:INCLUDE Supertype Slot-Spec*)
337 Make this type a subtype of the structure type Supertype. The optional
338 Slot-Specs override inherited slot options.
343 Asserts that the value of this slot is always of the specified type.
346 If true, no setter function is defined for this slot."
347 (multiple-value-bind (forms name
)
348 (!expander-for-defstruct
350 (sb!kernel
:lexenv
(sb!c
::null-lexenv-p env
))
351 ;; a LOCALLY environment would be fine,
352 ;; but is not an important case to handle.
353 #!+sb-fasteval
(sb!interpreter
:basic-env nil
)
355 name-and-options slot-descriptions
:target
)
356 `(progn ,@forms
',name
)))
359 (defmacro sb
!xc
:defstruct
(name-and-options &rest slot-descriptions
)
361 "Cause information about a target structure to be built into the
363 `(progn ,@(!expander-for-defstruct
364 t name-and-options slot-descriptions
:host
)))
366 ;;;; functions to generate code for various parts of DEFSTRUCT definitions
368 ;;; First, a helper to determine whether a name names an inherited
370 (defun accessor-inherited-data (name defstruct
)
371 (assoc name
(dd-inherited-accessor-alist defstruct
) :test
#'eq
))
373 ;;; Return a list of forms which create a predicate function for a
375 (defun typed-predicate-definitions (defstruct)
376 (let ((name (dd-name defstruct
))
377 (predicate-name (dd-predicate-name defstruct
))
378 (argname 'x
)) ; KISS: no user code appears in the DEFUN
380 (aver (dd-named defstruct
))
381 (let ((ltype (dd-lisp-type defstruct
))
382 (name-index (cdr (car (last (find-name-indices defstruct
))))))
383 `((defun ,predicate-name
(,argname
)
384 (and (typep ,argname
',ltype
)
386 ((subtypep ltype
'list
)
387 `(do ((head (the ,ltype
,argname
) (cdr head
))
389 ((or (not (consp head
)) (= i
,name-index
))
390 (and (consp head
) (eq ',name
(car head
))))))
391 ((subtypep ltype
'vector
)
392 `(and (>= (length (the ,ltype
,argname
))
393 ,(dd-length defstruct
))
394 (eq ',name
(aref (the ,ltype
,argname
) ,name-index
))))
395 (t (bug "Uncatered-for lisp type in typed DEFSTRUCT: ~S."
398 ;;; Return a list of forms to create a copier function of a typed DEFSTRUCT.
399 (defun typed-copier-definitions (defstruct)
400 (when (dd-copier-name defstruct
)
401 `((setf (fdefinition ',(dd-copier-name defstruct
)) #'copy-seq
)
402 (declaim (ftype function
,(dd-copier-name defstruct
))))))
404 ;;; Return a list of function definitions for accessing and setting
405 ;;; the slots of a typed DEFSTRUCT. The functions are proclaimed to be
406 ;;; inline, and the types of their arguments and results are declared
407 ;;; as well. We count on the compiler to do clever things with ELT.
408 (defun typed-accessor-definitions (defstruct)
410 (let ((ltype (dd-lisp-type defstruct
)))
411 (dolist (slot (dd-slots defstruct
))
412 (let ((name (dsd-accessor-name slot
))
413 (index (dsd-index slot
))
415 (slot-type `(and ,(dsd-type slot
)
416 ,(dd-element-type defstruct
))))
417 (let ((inherited (accessor-inherited-data name defstruct
)))
420 (stuff `(declaim (inline ,name
,@(unless (dsd-read-only slot
)
422 (stuff `(defun ,name
(structure)
423 (declare (type ,ltype structure
))
424 (the ,slot-type
(elt structure
,index
))))
425 (unless (dsd-read-only slot
)
427 `(defun (setf ,name
) (,(car new-value
) structure
)
428 (declare (type ,ltype structure
) (type ,slot-type .
,new-value
))
429 (setf (elt structure
,index
) .
,new-value
)))))
430 ((not (= (cdr inherited
) index
))
431 (style-warn "~@<Non-overwritten accessor ~S does not access ~
432 slot with name ~S (accessing an inherited slot ~
433 instead).~:@>" name
(dsd-name slot
))))))))
439 ;;; A defstruct option can be either a keyword or a list of a keyword
440 ;;; and arguments for that keyword; specifying the keyword by itself is
441 ;;; equivalent to specifying a list consisting of the keyword
442 ;;; and no arguments.
443 ;;; It is unclear whether that is meant to imply that any of the keywords
444 ;;; may be present in their atom form, or only if the grammar at the top
445 ;;; shows the atom form does <atom> have the meaning of (<atom>).
446 ;;; At least one other implementation accepts :NAMED as a singleton list.
447 ;; We take a more rigid view that the depicted grammar is exhaustive.
449 (defconstant-eqx +dd-option-names
+
450 ;; Each keyword, except :CONSTRUCTOR which may appear more than once,
451 ;; and :NAMED which is trivial, and unambiguous if present more than
452 ;; once, though possibly worth a style-warning.
453 #(:include
; at least 1 argument
454 :initial-offset
; exactly 1 argument
455 :pure
; exactly 1 argument [nonstandard]
456 :type
; exactly 1 argument
457 :conc-name
; 0 or 1 arg
464 ;;; Parse a single DEFSTRUCT option and store the results in DD.
465 (defun parse-1-dd-option (option dd seen-options
)
466 (let* ((keyword (first option
))
467 (bit (position keyword
+dd-option-names
+))
470 (arg (if arg-p
(car args
)))
472 (declare (type (unsigned-byte 9) seen-options
)) ; mask over DD-OPTION-NAMES
474 (if (logbitp bit seen-options
)
475 (error "More than one ~S option is not allowed" keyword
)
476 (setf seen-options
(logior seen-options
(ash 1 bit
))))
477 (multiple-value-bind (syntax-group winp
)
478 (cond ; Perform checking per comment at +DD-OPTION-NAMES+.
479 ((= bit
0) (values 0 (and arg-p
(proper-list-p args
)))) ; >1 arg
480 ((< bit
4) (values 1 (and arg-p
(not (cdr args
))))) ; exactly 1
481 (t (values 2 (or (not args
) (singleton-p args
))))) ; 0 or 1
483 (if (proper-list-p option
)
484 (error "DEFSTRUCT option ~S ~[requires at least~;~
485 requires exactly~;accepts at most~] one argument" keyword syntax-group
)
486 (error "Invalid syntax in DEFSTRUCT option ~S" option
)))))
489 ;; unlike (:predicate) and (:copier) which mean "yes" if supplied
490 ;; without their argument, (:conc-name) and :conc-name mean no conc-name.
491 ;; Also note a subtle difference in :conc-name "" vs :conc-name NIL.
492 ;; The former re-interns each slot name into *PACKAGE* which might
493 ;; not be the same as using the given name directly as an accessor.
494 (setf (dd-conc-name dd
) (if arg
(string arg
))))
495 (:constructor
; takes 0 to 2 arguments.
496 (destructuring-bind (&optional
(cname (symbolicate "MAKE-" name
))
497 (lambda-list nil ll-supplied-p
)) args
500 ;; Implementations disagree on the meaning of
501 ;; (:CONSTRUCTOR NIL (A B C)).
502 ;; The choices seem to be: don't define a constructor,
503 ;; define a constructor named NIL, signal a user error,
504 ;; or crash the system itself. The spec implies
505 ;; the behavior that we have, but at least a
506 ;; style-warning seems appropriate.
508 (style-warn "~S does not define a constructor" option
)))
509 ((not ll-supplied-p
) :default
)
513 (declare (dynamic-extent x
))
514 (subseq x
0 ; remove trailing NILs
515 (1+ (position-if #'identity x
:from-end t
))))
518 :accept
(lambda-list-keyword-mask
519 '(&optional
&rest
&key
&allow-other-keys
&aux
))
521 (dd-constructors dd
) ; preserve order, just because
522 (nconc (dd-constructors dd
) (list (cons cname lambda-list
))))))
524 (setf (dd-copier-name dd
) (if arg-p arg
(symbolicate "COPY-" name
))))
526 (setf (dd-predicate-name dd
) (if arg-p arg
(symbolicate name
"-P"))))
528 (setf (dd-include dd
) args
))
529 ((:print-function
:print-object
)
530 (when (dd-print-option dd
)
531 (error "~S and ~S may not both be specified"
532 (dd-print-option dd
) keyword
))
533 (setf (dd-print-option dd
) keyword
(dd-printer-fname dd
) arg
))
535 (cond ((member arg
'(list vector
))
536 (setf (dd-type dd
) arg
(dd-element-type dd
) t
))
537 ((and (listp arg
) (eq (first arg
) 'vector
))
538 (destructuring-bind (elt-type) (cdr arg
)
539 (setf (dd-type dd
) 'vector
(dd-element-type dd
) elt-type
)))
541 (error "~S is a bad :TYPE for DEFSTRUCT." arg
))))
543 (error "The DEFSTRUCT option :NAMED takes no arguments."))
545 (setf (dd-offset dd
) arg
)) ; FIXME: disallow (:INITIAL-OFFSET NIL)
547 (setf (dd-pure dd
) arg
))
549 (error "unknown DEFSTRUCT option:~% ~S" option
)))
552 ;;; Parse OPTIONS into the given DD.
553 (defun parse-defstruct-options (options dd
)
554 (let ((seen-options 0)
556 (dolist (option options
)
557 (if (eq option
:named
)
558 (setf named-p t
(dd-named dd
) t
)
561 (cond ((consp option
) option
)
563 '(:conc-name
:constructor
:copier
:predicate
))
566 ;; FIXME: ugly message (defstruct (s :include) a)
567 ;; saying "unrecognized" when it means "bad syntax"
568 (error "unrecognized DEFSTRUCT option: ~S" option
)))
573 (error ":OFFSET can't be specified unless :TYPE is specified."))
574 (unless (dd-include dd
)
575 ;; FIXME: It'd be cleaner to treat no-:INCLUDE as defaulting
576 ;; to :INCLUDE STRUCTURE-OBJECT, and then let the general-case
577 ;; (INCF (DD-LENGTH DD) (DD-LENGTH included-DD)) logic take
578 ;; care of this. (Except that the :TYPE VECTOR and :TYPE
579 ;; LIST cases, with their :NAMED and un-:NAMED flavors,
580 ;; make that messy, alas.)
581 (incf (dd-length dd
))))
583 ;; In case we are here, :TYPE is specified.
585 ;; CLHS - "The structure can be :named only if the type SYMBOL
586 ;; is a subtype of the supplied element-type."
587 (multiple-value-bind (winp certainp
)
588 (subtypep 'symbol
(dd-element-type dd
))
589 (when (and (not winp
) certainp
)
590 (error ":NAMED option is incompatible with element type ~S"
591 (dd-element-type dd
))))
592 (when (dd-predicate-name dd
)
593 (error ":PREDICATE cannot be used with :TYPE ~
594 unless :NAMED is also specified.")))
595 (awhen (dd-print-option dd
)
596 (error ":TYPE option precludes specification of ~S option" it
))
598 (incf (dd-length dd
)))
599 (let ((offset (dd-offset dd
)))
600 (when offset
(incf (dd-length dd
) offset
)))))
602 (let ((name (dd-name dd
)))
603 (collect ((keyword-ctors) (boa-ctors))
604 (let (no-constructors)
605 (dolist (constructor (dd-constructors dd
))
606 (destructuring-bind (ctor-name . ll
) constructor
607 (cond ((not ctor-name
) (setq no-constructors t
))
608 ((eq ll
:default
) (keyword-ctors constructor
))
609 (t (boa-ctors constructor
)))))
610 ;; Remove (NIL) and sort so that BOA constructors are last.
611 (setf (dd-constructors dd
)
614 (when (or (keyword-ctors) (boa-ctors))
615 (error "(:CONSTRUCTOR NIL) combined with other :CONSTRUCTORs"))
617 (append (or (keyword-ctors)
619 `((,(symbolicate "MAKE-" name
) .
:default
))))
622 (flet ((option-present-p (bit-name)
623 (logbitp (position bit-name
+dd-option-names
+) seen-options
)))
624 (declare (inline option-present-p
))
625 (when (and (not (option-present-p :predicate
))
626 (or (dd-class-p dd
) named-p
))
627 (setf (dd-predicate-name dd
) (symbolicate name
"-P")))
628 (unless (option-present-p :conc-name
)
629 (setf (dd-conc-name dd
) (concatenate 'string
(string name
) "-")))
630 (unless (option-present-p :copier
)
631 (setf (dd-copier-name dd
) (symbolicate "COPY-" name
))))))
634 ;;; BOA constructors is (&aux x), i.e. without the default value, the
635 ;;; value of the slot is unspecified, but it should signal a type
636 ;;; error only when it's accessed. safe-p slot in dsd determines
637 ;;; whether to check the type after accessing the slot.
639 ;;; This was performed during boa constructor creating, but the
640 ;;; constructors are created after this information is used to inform
641 ;;; the compiler how to treat such slots.
642 (defun determine-unsafe-slots (dd)
643 (dolist (ctor (dd-constructors dd
))
644 (let ((ll-parts (cdr ctor
))) ; = (llks req opt rest key aux)
645 (dolist (var (if (listp ll-parts
) (sixth ll-parts
)))
646 (let* ((name (if (listp var
) (car var
) var
))
647 (dsd (find name
(dd-slots dd
)
649 ;; FIXME: Not sure why this is #'EQ.
650 ;; Everywhere else we use STRING=.
653 (setf (dsd-safe-p dsd
) nil
)))))))
655 ;;; Given name and options and slot descriptions (and possibly doc
656 ;;; string at the head of slot descriptions) return a DD holding that
658 (defun parse-defstruct (null-env-p name-and-options slot-descriptions
)
659 (binding* (((name options
)
660 (if (listp name-and-options
)
661 (values (car name-and-options
) (cdr name-and-options
))
662 (values name-and-options nil
)))
663 (dd (make-defstruct-description null-env-p name
)))
664 (parse-defstruct-options options dd
)
665 (when (dd-include dd
)
666 (frob-dd-inclusion-stuff dd
))
667 (when (stringp (car slot-descriptions
))
668 (setf (dd-doc dd
) (pop slot-descriptions
)))
671 #+sb-xc-host
(!inherits-for-structure dd
)
673 (let ((super (compiler-layout-or-lose (or (first (dd-include dd
))
674 'structure-object
))))
675 (concatenate 'simple-vector
676 (layout-inherits super
) (vector super
)))))
679 (let* ((classoid (make-structure-classoid :name
(dd-name dd
)))
680 (layout (make-layout :classoid classoid
:inherits inherits
)))
681 (setf (layout-invalid layout
) nil
682 (classoid-layout classoid
) layout
)
684 ;; Bind *pending-defstruct-type* to this classoid, which fixes a problem
685 ;; when redefining a DEFTYPE which appeared to be a raw slot. e.g.
686 ;; (DEFTYPE X () 'SINGLE-FLOAT) and later (DEFSTRUCT X (A 0 :TYPE X)).
687 ;; This is probably undefined behavior, but at least we'll not crash.
688 ;; Also make self-referential definitions not signal PARSE-UNKNOWN-TYPE
689 ;; on slots whose :TYPE option allows an instance of itself
690 (flet ((parse-slots ()
691 (dolist (slot-description slot-descriptions
)
692 (allocate-1-slot dd
(parse-1-dsd dd slot-description
)))))
695 (when (info :type
:kind name
)
696 ;; It could be buried anywhere in a complicated type expression.
697 ;; There's no way to clear selectively, so just flush the cache.
698 (values-specifier-type-cache-clear))
699 (let ((*pending-defstruct-type
* proto-classoid
))
702 (determine-unsafe-slots dd
)
703 (values dd proto-classoid inherits
))))
705 ;;;; stuff to parse slot descriptions
707 ;;; Parse a slot description for DEFSTRUCT, add it to the description
708 ;;; and return it. If supplied, SLOT is a pre-initialized DSD
709 ;;; that we modify to get the new slot. This is supplied when handling
711 (defun parse-1-dsd (defstruct spec
&optional
712 (slot (make-defstruct-slot-description :name
""
715 #-sb-xc-host
(declare (muffle-conditions style-warning
))
716 (multiple-value-bind (name default default-p type type-p read-only ro-p
)
720 ((or null
(member :conc-name
:constructor
:copier
:predicate
:named
))
721 (warn "slot name of ~S indicates probable syntax error in DEFSTRUCT" spec
))
723 (style-warn "slot name of ~S indicates possible syntax error in DEFSTRUCT" spec
)))
727 (name &optional
(default nil default-p
)
728 &key
(type nil type-p
) (read-only nil ro-p
))
730 (when (dd-conc-name defstruct
)
731 ;; the warning here is useful, but in principle we cannot
732 ;; distinguish between legitimate and erroneous use of
733 ;; these names when :CONC-NAME is NIL. In the common
734 ;; case (CONC-NAME non-NIL), there are alternative ways
735 ;; of writing code with the same effect, so a full
736 ;; warning is justified.
738 ((member :conc-name
:constructor
:copier
:predicate
:include
739 :print-function
:print-object
:type
:initial-offset
:pure
)
740 (warn "slot name of ~S indicates probable syntax error in DEFSTRUCT" name
))))
741 (values name default default-p
742 (uncross type
) type-p
744 (t (error 'simple-program-error
745 :format-control
"in DEFSTRUCT, ~S is not a legal slot ~
747 :format-arguments
(list spec
))))
749 (when (find name
(dd-slots defstruct
)
751 :key
(lambda (x) (symbol-name (dsd-name x
))))
752 (error 'simple-program-error
753 ;; Todo: indicate whether name is a duplicate in the directly
754 ;; specified slots vs. exists in the ancestor and so should
755 ;; be in the (:include ...) clause instead of where it is.
756 :format-control
"duplicate slot name ~S"
757 :format-arguments
(list name
)))
758 (setf (dsd-name slot
) name
)
759 (setf (dd-slots defstruct
) (nconc (dd-slots defstruct
) (list slot
)))
761 (let ((accessor-name (if (dd-conc-name defstruct
)
762 (symbolicate (dd-conc-name defstruct
) name
)
764 (predicate-name (dd-predicate-name defstruct
)))
765 (setf (dsd-accessor-name slot
) accessor-name
)
766 (when (eql accessor-name predicate-name
)
767 ;; Some adventurous soul has named a slot so that its accessor
768 ;; collides with the structure type predicate. ANSI doesn't
769 ;; specify what to do in this case. As of 2001-09-04, Martin
770 ;; Atzmueller reports that CLISP and Lispworks both give
771 ;; priority to the slot accessor, so that the predicate is
772 ;; overwritten. We might as well do the same (as well as
773 ;; signalling a warning).
775 "~@<The structure accessor name ~S is the same as the name of the ~
776 structure type predicate. ANSI doesn't specify what to do in ~
777 this case. We'll overwrite the type predicate with the slot ~
778 accessor, but you can't rely on this behavior, so it'd be wise to ~
779 remove the ambiguity in your code.~@:>"
781 (setf (dd-predicate-name defstruct
) nil
))
782 ;; FIXME: It would be good to check for name collisions here, but
785 ;;x(when (and (fboundp accessor-name)
786 ;;x (not (accessor-inherited-data accessor-name defstruct)))
787 ;;x (style-warn "redefining ~/sb-impl::print-symbol-with-prefix/ ~
788 ;; in DEFSTRUCT" accessor-name)))
789 ;; which was done until sbcl-0.8.11.18 or so, is wrong: it causes
790 ;; a warning at MACROEXPAND time, when instead the warning should
791 ;; occur not just because the code was constructed, but because it
792 ;; is actually compiled or loaded.
796 (setf (dsd-default slot
) default
))
798 (setf (dsd-type slot
)
799 (if (eq (dsd-type slot
) t
)
801 `(and ,(dsd-type slot
) ,type
))))
804 (setf (dsd-read-only slot
) t
)
805 (when (dsd-read-only slot
)
806 (error "~@<The slot ~S is :READ-ONLY in superclass, and so must ~
807 be :READ-ONLY in subclass.~:@>"
811 ;;; When a value of type TYPE is stored in a structure, should it be
812 ;;; stored in a raw slot? Return the index of the matching RAW-SLOT-DATA
813 ;;; if TYPE should be stored in a raw slot, or NIL if not.
814 (defun structure-raw-slot-data-index (type)
815 (multiple-value-bind (fixnum? fixnum-certain?
)
816 (sb!xc
:subtypep type
'fixnum
)
817 ;; (The extra test for FIXNUM-CERTAIN? here is intended for
818 ;; bootstrapping the system. In particular, in sbcl-0.6.2, we set up
819 ;; LAYOUT before FIXNUM is defined, and so could bogusly end up
820 ;; putting INDEX-typed values into raw slots if we didn't test
822 (if (or fixnum?
(not fixnum-certain?
))
824 (dotimes (i (length *raw-slot-data
*))
825 (let ((data (svref *raw-slot-data
* i
)))
826 (when (sb!xc
:subtypep type
(raw-slot-data-raw-type data
))
829 ;;; Allocate storage for a DSD in DD. This is where we decide whether
830 ;;; a slot is raw or not. Raw objects are aligned on the unit of their size.
831 (defun allocate-1-slot (dd dsd
)
832 (let ((rsd-index (if (eq (dd-type dd
) 'structure
)
833 (structure-raw-slot-data-index (dsd-type dsd
))
835 (cond ((null rsd-index
)
836 (setf (dsd-index dsd
) (dd-length dd
))
837 (incf (dd-length dd
)))
839 (setf (dsd-%raw-type dsd
) rsd-index
)
840 (let* ((rsd (svref *raw-slot-data
* rsd-index
))
841 (words (raw-slot-data-n-words rsd
))
842 (alignment (raw-slot-data-alignment rsd
)))
843 #!-interleaved-raw-slots
844 (let ((off (rem (dd-raw-length dd
) alignment
)))
846 (incf (dd-raw-length dd
) (- alignment off
)))
847 (setf (dsd-index dsd
) (dd-raw-length dd
))
848 (incf (dd-raw-length dd
) words
))
849 #!+interleaved-raw-slots
850 (let ((len (dd-length dd
)))
852 ;; this formula works but can it be made less unclear?
853 (- len
(nth-value 1 (ceiling (1- len
) alignment
))))
854 (setf (dsd-index dsd
) (dd-length dd
))
855 (incf (dd-length dd
) words
))))))
858 (defun typed-structure-info-or-lose (name)
859 (or (info :typed-structure
:info name
)
860 (error ":TYPE'd DEFSTRUCT ~S not found for inclusion." name
)))
862 ;;; Process any included slots pretty much like they were specified.
863 ;;; Also inherit various other attributes.
864 (defun frob-dd-inclusion-stuff (dd)
865 (destructuring-bind (included-name &rest modified-slots
) (dd-include dd
)
866 (let* ((type (dd-type dd
))
869 (layout-info (compiler-layout-or-lose included-name
))
870 (typed-structure-info-or-lose included-name
))))
872 ;; checks on legality
873 (unless (and (eq type
(dd-type included-structure
))
874 (type= (specifier-type (dd-element-type included-structure
))
875 (specifier-type (dd-element-type dd
))))
876 (error ":TYPE option mismatch between structures ~S and ~S"
877 (dd-name dd
) included-name
))
878 (let ((included-classoid (find-classoid included-name nil
)))
879 (when included-classoid
880 ;; It's not particularly well-defined to :INCLUDE any of the
881 ;; CMU CL INSTANCE weirdosities like CONDITION or
882 ;; GENERIC-FUNCTION, and it's certainly not ANSI-compliant.
883 (let* ((included-layout (classoid-layout included-classoid
))
884 (included-dd (layout-info included-layout
)))
885 (when (dd-alternate-metaclass included-dd
)
886 (error "can't :INCLUDE class ~S (has alternate metaclass)"
889 ;; A few more sanity checks: every allegedly modified slot exists
890 ;; and no name appears more than once.
891 (flet ((included-slot-name (slot-desc)
892 (if (atom slot-desc
) slot-desc
(car slot-desc
))))
893 (mapl (lambda (slots &aux
(name (included-slot-name (car slots
))))
894 (unless (find name
(dd-slots included-structure
)
895 :test
#'string
= :key
#'dsd-name
)
896 (error 'simple-program-error
897 :format-control
"slot name ~S not present in included structure"
898 :format-arguments
(list name
)))
899 (when (find name
(cdr slots
)
900 :test
#'string
= :key
#'included-slot-name
)
901 (error 'simple-program-error
902 :format-control
"included slot name ~S specified more than once"
903 :format-arguments
(list name
))))
906 (incf (dd-length dd
) (dd-length included-structure
))
907 (when (dd-class-p dd
)
908 (when (eq (dd-pure dd
) :unspecified
)
909 (setf (dd-pure dd
) (dd-pure included-structure
)))
910 #!-interleaved-raw-slots
911 (setf (dd-raw-length dd
) (dd-raw-length included-structure
)))
913 (setf (dd-inherited-accessor-alist dd
)
914 (dd-inherited-accessor-alist included-structure
))
915 (dolist (included-slot (dd-slots included-structure
))
916 (let* ((included-name (dsd-name included-slot
))
917 (modified (or (find included-name modified-slots
918 :key
(lambda (x) (if (atom x
) x
(car x
)))
921 ;; We stash away an alist of accessors to parents' slots
922 ;; that have already been created to avoid conflicts later
923 ;; so that structures with :INCLUDE and :CONC-NAME (and
924 ;; other edge cases) can work as specified.
925 (when (dsd-accessor-name included-slot
)
926 ;; the "oldest" (i.e. highest up the tree of inheritance)
927 ;; will prevail, so don't push new ones on if they
929 (pushnew (cons (dsd-accessor-name included-slot
)
930 (dsd-index included-slot
))
931 (dd-inherited-accessor-alist dd
)
932 :test
#'eq
:key
#'car
))
933 (let ((new-slot (parse-1-dsd dd
935 (copy-structure included-slot
))))
936 (when (and (neq (dsd-type new-slot
) (dsd-type included-slot
))
937 (not (sb!xc
:subtypep
(dsd-type included-slot
)
938 (dsd-type new-slot
)))
939 (dsd-safe-p included-slot
))
940 (setf (dsd-safe-p new-slot
) nil
)
944 ;;;; various helper functions for setting up DEFSTRUCTs
946 ;;; This function is called at macroexpand time to compute the INHERITS
947 ;;; vector for a structure type definition.
948 ;;; The cross-compiler is allowed to magically compute LAYOUT-INHERITS.
949 (defun !inherits-for-structure
(info)
950 (declare (type defstruct-description info
))
951 (let* ((include (dd-include info
))
952 (superclass-opt (dd-alternate-metaclass info
))
955 (compiler-layout-or-lose (first include
))
956 (classoid-layout (find-classoid
957 (or (first superclass-opt
)
958 'structure-object
))))))
961 ;; STREAM is an abstract class and you can't :include it,
962 ;; so the inheritance has to be hardcoded.
963 (concatenate 'simple-vector
964 (layout-inherits super
)
965 (vector super
(classoid-layout (find-classoid 'stream
)))))
966 ((fd-stream) ; Similarly, FILE-STREAM is abstract
967 (concatenate 'simple-vector
968 (layout-inherits super
)
970 (classoid-layout (find-classoid 'file-stream
)))))
971 ((sb!impl
::string-input-stream
; etc
972 sb
!impl
::string-output-stream
973 sb
!impl
::fill-pointer-output-stream
)
974 (concatenate 'simple-vector
975 (layout-inherits super
)
977 (classoid-layout (find-classoid 'string-stream
)))))
978 (t (concatenate 'simple-vector
979 (layout-inherits super
)
982 ;;; Do miscellaneous (LOAD EVAL) time actions for the structure
983 ;;; described by DD. Create the class and LAYOUT, checking for
984 ;;; incompatible redefinition.
985 (defun %defstruct
(dd inherits source-location
)
986 (declare (type defstruct-description dd
))
988 ;; We set up LAYOUTs even in the cross-compilation host.
989 (multiple-value-bind (classoid layout old-layout
)
990 (ensure-structure-class dd inherits
"current" "new")
991 (cond ((not old-layout
)
992 (unless (eq (classoid-layout classoid
) layout
)
993 (register-layout layout
)))
995 (%redefine-defstruct classoid old-layout layout
)
996 (let ((old-dd (layout-info old-layout
)))
997 (when (defstruct-description-p old-dd
)
998 (dolist (slot (dd-slots old-dd
))
999 (fmakunbound (dsd-accessor-name slot
))
1000 (unless (dsd-read-only slot
)
1001 (fmakunbound `(setf ,(dsd-accessor-name slot
)))))))
1002 (setq layout
(classoid-layout classoid
))))
1003 (setf (find-classoid (dd-name dd
)) classoid
)
1005 (when source-location
1006 (setf (layout-source-location layout
) source-location
))))
1009 ;;; Return a form accessing the writable place used for the slot
1010 ;;; described by DD and DSD in the INSTANCE (a form).
1011 (defun %accessor-place-form
(dd dsd instance
)
1012 (let (;; Compute REF even if not using it, as a sanity-check of DD-TYPE.
1013 (ref (ecase (dd-type dd
)
1014 (structure '%instance-ref
)
1017 (index (dsd-index dsd
))
1018 (rsd (dsd-raw-slot-data dsd
)))
1019 (if (not rsd
) ; if not raw slot
1020 (multiple-value-call 'list ref
1021 (if (eq ref
'nth
) (values index instance
) (values instance index
)))
1022 `(,(raw-slot-data-accessor-name rsd
) ,instance
,index
))))
1024 ;;; Return the transform of conceptual FUNCTION one of {:READ,:WRITE,:SETF}
1025 ;;; as applied to ARGS, given SLOT-KEY which is a cons of a DD and a DSD.
1026 ;;; Return NIL on failure.
1027 (defun slot-access-transform (function args slot-key
)
1028 (when (consp args
) ; need at least one arg
1029 (let* ((dd (car slot-key
))
1030 (dsd (cdr slot-key
))
1031 ;; optimistically compute PLACE before checking length of ARGS
1032 ;; because we expect success, and this unifies the three cases.
1033 ;; :SETF is like an invocation of the SETF macro - newval is
1034 ;; the second arg, but :WRITER is #'(SETF fn) - newval is first.
1036 (%accessor-place-form
1037 dd dsd
`(the ,(dd-name dd
)
1038 ,(car (if (eq function
:write
) (cdr args
) args
)))))
1039 (type-spec (dsd-type dsd
)))
1040 (if (eq function
:read
)
1041 (when (singleton-p args
)
1042 (if (eq type-spec t
)
1044 `(,(if (dsd-safe-p dsd
) 'truly-the
'the
) ,type-spec
,place
)))
1045 (when (singleton-p (cdr args
))
1046 (let ((inverse (info :setf
:inverse
(car place
))))
1047 (flet ((check (newval)
1048 (if (eq type-spec t
) newval
`(the ,type-spec
,newval
))))
1051 ;; Instance setters take newval last, which matches
1052 ;; the order in which a use of SETF has them.
1053 `(,inverse
,@(cdr place
) ,(check (second args
))))
1055 ;; The call to #'(SETF fn) had newval first.
1056 ;; We need to preserve L-to-R evaluation.
1057 (once-only ((new (first args
)))
1058 `(,inverse
,@(cdr place
) ,(check new
))))))))))))
1060 ;;; Return a LAMBDA form which can be used to set a slot
1061 (defun slot-setter-lambda-form (dd dsd
)
1062 `(lambda (newval instance
)
1063 ,(slot-access-transform :setf
'(instance newval
) (cons dd dsd
))))
1065 ;;; Blow away all the compiler info for the structure CLASS. Iterate
1066 ;;; over this type, clearing the compiler structure type info, and
1067 ;;; undefining all the associated functions. If SUBCLASSES-P, also do
1068 ;;; the same for subclasses. FIXME: maybe rename UNDEFINE-FUN-NAME to
1069 ;;; UNDECLARE-FUNCTION-NAME?
1070 (defun undeclare-structure (classoid subclasses-p
)
1071 (let ((info (layout-info (classoid-layout classoid
))))
1072 (when (defstruct-description-p info
)
1073 (let ((type (dd-name info
)))
1074 (clear-info :type
:compiler-layout type
)
1075 ;; FIXME: shouldn't this undeclare any constructors too?
1076 (undefine-fun-name (dd-copier-name info
))
1077 (undefine-fun-name (dd-predicate-name info
))
1078 (dolist (slot (dd-slots info
))
1079 (let ((fun (dsd-accessor-name slot
)))
1080 (unless (accessor-inherited-data fun info
)
1081 (undefine-fun-name fun
)
1082 (unless (dsd-read-only slot
)
1083 (undefine-fun-name `(setf ,fun
)))))))
1084 ;; Clear out the SPECIFIER-TYPE cache so that subsequent
1085 ;; references are unknown types.
1086 (values-specifier-type-cache-clear)))
1088 (let ((subclasses (classoid-subclasses classoid
)))
1091 (dohash ((classoid layout
)
1094 (declare (ignore layout
))
1095 (undeclare-structure classoid nil
)
1096 (subs (classoid-proper-name classoid
)))
1097 ;; Is it really necessary to warn about
1098 ;; undeclaring functions for subclasses?
1100 (warn "undeclaring functions for old subclasses ~
1102 (classoid-name classoid
)
1105 ;;; core compile-time setup of any class with a LAYOUT, used even by
1106 ;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities
1107 (defun %compiler-set-up-layout
(dd
1109 ;; Several special cases
1110 ;; (STRUCTURE-OBJECT itself, and
1111 ;; structures with alternate
1112 ;; metaclasses) call this function
1113 ;; directly, and they're all at the
1114 ;; base of the instance class
1115 ;; structure, so this is a handy
1116 ;; default. (But note
1117 ;; FUNCALLABLE-STRUCTUREs need
1119 (inherits (vector (find-layout t
))))
1121 (multiple-value-bind (classoid layout old-layout
)
1122 (multiple-value-bind (clayout clayout-p
)
1123 (info :type
:compiler-layout
(dd-name dd
))
1124 (ensure-structure-class dd
1127 "The most recently compiled"
1129 "the most recently loaded"
1130 :compiler-layout clayout
))
1132 (undeclare-structure (layout-classoid old-layout
)
1133 (and (classoid-subclasses classoid
)
1134 (not (eq layout old-layout
))))
1135 (setf (layout-invalid layout
) nil
)
1136 ;; FIXME: it might be polite to hold onto old-layout and
1137 ;; restore it at the end of the file. -- RMK 2008-09-19
1138 ;; (International Talk Like a Pirate Day).
1139 (warn "~@<Clobbering the compiler's idea of the layout of ~A.~:@>"
1142 (unless (eq (classoid-layout classoid
) layout
)
1143 (register-layout layout
:invalidate nil
))
1144 (setf (find-classoid (dd-name dd
)) classoid
)))
1146 ;; At this point the class should be set up in the INFO database.
1147 ;; But the logic that enforces this is a little tangled and
1148 ;; scattered, so it's not obvious, so let's check.
1149 (aver (find-classoid (dd-name dd
) nil
))
1151 (setf (info :type
:compiler-layout
(dd-name dd
)) layout
))
1154 (defun %proclaim-defstruct-ctors
(dd)
1155 (dolist (ctor (dd-constructors dd
))
1156 (let ((ftype (%struct-ctor-ftype dd
(cdr ctor
) (dd-element-type dd
))))
1157 (sb!c
:proclaim-ftype
(car ctor
) dd ftype
:declared
))))
1159 ;;; Do (COMPILE LOAD EVAL)-time actions for the normal (not
1160 ;;; ALTERNATE-LAYOUT) DEFSTRUCT described by DD.
1161 ;;; This includes generation of a style-warning about previously compiled
1162 ;;; calls to the accessors and/or predicate that weren't inlined.
1163 (defun %compiler-defstruct
(dd inherits
)
1164 (declare (type defstruct-description dd
))
1166 (aver (dd-class-p dd
)) ; LIST and VECTOR representation are not allowed
1167 (let ((check-inlining
1168 ;; Why use the secondary result of INFO, not the primary?
1169 ;; Because when DEFSTRUCT is evaluated, not via the file-compiler,
1170 ;; the first thing to happen is %DEFSTRUCT, which sets up FIND-CLASS.
1171 ;; Due to :COMPILER-LAYOUT's defaulting expression in globaldb,
1172 ;; it has a value - the layout of the classoid - that we don't want.
1173 ;; Also, since structures are technically not redefineable,
1174 ;; I don't worry about failure to inline a function that was
1175 ;; formerly not known as an accessor but now is.
1176 (null (nth-value 1 (info :type
:compiler-layout
(dd-name dd
)))))
1178 (%compiler-set-up-layout dd inherits
)
1179 (%proclaim-defstruct-ctors dd
)
1181 (awhen (dd-copier-name dd
)
1182 (let ((dtype (dd-name dd
)))
1183 (sb!xc
:proclaim
`(ftype (sfunction (,dtype
) ,dtype
) ,it
))))
1185 (let ((predicate-name (dd-predicate-name dd
)))
1186 (when predicate-name
1187 (when check-inlining
1188 (push predicate-name fnames
))
1189 (setf (info :function
:source-transform predicate-name
)
1190 (cons dd
:predicate
))))
1192 (dolist (dsd (dd-slots dd
))
1193 (let ((accessor-name (dsd-accessor-name dsd
)))
1194 ;; Why this WHEN guard here, if there is neither a standards-specified
1195 ;; nor implementation-specific way to skip defining an accessor? Dunno.
1196 ;; And furthermore, by ignoring a package lock, it's possible to name
1197 ;; an accessor NIL: (defstruct (x (:conc-name "N")) IL)
1198 ;; making this test kinda bogus in two different ways.
1200 (let ((inherited (accessor-inherited-data accessor-name dd
)))
1203 (let ((writer `(setf ,accessor-name
))
1204 (slot-key (cons dd dsd
)))
1205 (when check-inlining
1206 (push accessor-name fnames
))
1207 (setf (info :function
:source-transform accessor-name
)
1209 (unless (dsd-read-only dsd
)
1210 (when check-inlining
1211 (push writer fnames
))
1212 (setf (info :function
:source-transform writer
) slot-key
))))
1213 ((not (= (cdr inherited
) (dsd-index dsd
)))
1214 (style-warn "~@<Non-overwritten accessor ~S does not access ~
1215 slot with name ~S (accessing an inherited slot ~
1218 (dsd-name dsd
))))))))
1220 (awhen (remove-if-not #'sb
!c
::emitted-full-call-count fnames
)
1221 (sb!c
:compiler-style-warn
1222 'sb
!c
:inlining-dependency-failure
1223 ;; This message omits the http://en.wikipedia.org/wiki/Serial_comma
1225 (!uncross-format-control
1226 "~@<Previously compiled call~P to ~
1227 ~{~/sb!impl:print-symbol-with-prefix/~^~#[~; and~:;,~] ~} ~
1228 could not be inlined because the structure definition for ~
1229 ~/sb!impl:print-symbol-with-prefix/ was not yet seen. To avoid this warning, ~
1230 DEFSTRUCT should precede references to the affected functions, ~
1231 or they must be declared locally notinline at each call site.~@:>")
1232 :format-arguments
(list (length it
) (nreverse it
) (dd-name dd
))))))
1234 ;;;; redefinition stuff
1236 ;;; Compare the slots of OLD and NEW, returning 3 lists of slot names:
1237 ;;; 1. Slots which have moved,
1238 ;;; 2. Slots whose type has changed,
1239 ;;; 3. Deleted slots.
1240 (defun compare-slots (old new
)
1241 (let* ((oslots (dd-slots old
))
1242 (nslots (dd-slots new
))
1243 (onames (mapcar #'dsd-name oslots
))
1244 (nnames (mapcar #'dsd-name nslots
)))
1247 (dolist (name (intersection onames nnames
))
1248 (let ((os (find name oslots
:key
#'dsd-name
:test
#'string
=))
1249 (ns (find name nslots
:key
#'dsd-name
:test
#'string
=)))
1250 (unless (sb!xc
:subtypep
(dsd-type ns
) (dsd-type os
))
1252 (unless (and (= (dsd-index os
) (dsd-index ns
))
1253 (eq (dsd-raw-type os
) (dsd-raw-type ns
)))
1257 (set-difference onames nnames
:test
#'string
=)))))
1259 ;;; If we are redefining a structure with different slots than in the
1260 ;;; currently loaded version, give a warning and return true.
1261 (defun redefine-structure-warning (classoid old new
)
1262 (declare (type defstruct-description old new
)
1263 (type classoid classoid
)
1265 (let ((name (dd-name new
)))
1266 (multiple-value-bind (moved retyped deleted
) (compare-slots old new
)
1267 (when (or moved retyped deleted
)
1269 "incompatibly redefining slots of structure class ~S~@
1270 Make sure any uses of affected accessors are recompiled:~@
1271 ~@[ These slots were moved to new positions:~% ~S~%~]~
1272 ~@[ These slots have new incompatible types:~% ~S~%~]~
1273 ~@[ These slots were deleted:~% ~S~%~]"
1274 name moved retyped deleted
)
1277 ;;; This function is called when we are incompatibly redefining a
1278 ;;; structure CLASS to have the specified NEW-LAYOUT. We signal an
1279 ;;; error with some proceed options and return the layout that should
1281 (defun %redefine-defstruct
(classoid old-layout new-layout
)
1282 (declare (type classoid classoid
)
1283 (type layout old-layout new-layout
))
1284 (let ((name (classoid-proper-name classoid
)))
1286 (error "~@<attempt to redefine the ~S class ~S incompatibly with the current definition~:@>"
1292 "~@<Use the new definition of ~S, invalidating ~
1293 already-loaded code and instances.~@:>"
1295 (register-layout new-layout
))
1296 (recklessly-continue ()
1299 "~@<Use the new definition of ~S as if it were ~
1300 compatible, allowing old accessors to use new ~
1301 instances and allowing new accessors to use old ~
1304 ;; classic CMU CL warning: "Any old ~S instances will be in a bad way.
1305 ;; I hope you know what you're doing..."
1306 (register-layout new-layout
1308 :destruct-layout old-layout
))
1310 ;; FIXME: deprecated 2002-10-16, and since it's only interactive
1311 ;; hackery instead of a supported feature, can probably be deleted
1313 :report
"(deprecated synonym for RECKLESSLY-CONTINUE)"
1314 (register-layout new-layout
1316 :destruct-layout old-layout
))))
1319 (declaim (inline dd-layout-length
))
1320 (defun dd-layout-length (dd)
1321 (+ (dd-length dd
) #!-interleaved-raw-slots
(dd-raw-length dd
)))
1323 (declaim (ftype (sfunction (defstruct-description) index
) dd-instance-length
))
1324 (defun dd-instance-length (dd)
1325 ;; Make sure the object ends at a two-word boundary. Note that this does
1326 ;; not affect the amount of memory used, since the allocator would add the
1327 ;; same padding anyway. However, raw slots are indexed from the length of
1328 ;; the object as indicated in the header, so the pad word needs to be
1329 ;; included in that length to guarantee proper alignment of raw double float
1330 ;; slots, necessary for (at least) the SPARC backend.
1331 ;; On backends with interleaved raw slots, the convention of having the
1332 ;; header possibly "lie" about an extra word is more of a bug than a feature.
1333 ;; Because the structure base is aligned, double-word raw slots are properly
1334 ;; aligned, and won't change alignment in descendant object types. It would
1335 ;; be correct to store the true instance length even though GC preserves
1336 ;; the extra data word (as it does for odd-length SIMPLE-VECTOR), treating
1337 ;; the total physical length as rounded-to-even. But having two different
1338 ;; conventions would be even more unnecessarily confusing, so we use
1339 ;; the not-sensible convention even when it does not make sense.
1340 (logior (dd-layout-length dd
) 1))
1342 (defun dd-bitmap (dd)
1343 ;; The bitmap stores a 1 for each untagged word,
1344 ;; including any internal padding words for alignment.
1345 ;; The 0th bit is initialized to 0 because the LAYOUT is a tagged
1346 ;; slot that is not present in DD-SLOTS.
1347 ;; All other bits start as 1 and are cleared if the word is tagged.
1348 ;; A final padding word, if any, is regarded as tagged.
1349 (let ((bitmap (ldb (byte (dd-length dd
) 0)
1350 (ash -
1 sb
!vm
:instance-data-start
))))
1351 (dolist (slot (dd-slots dd
) bitmap
)
1352 (when (eql t
(dsd-raw-type slot
))
1353 (setf (ldb (byte 1 (dsd-index slot
)) bitmap
) 0)))))
1355 ;;; This is called when we are about to define a structure class. It
1356 ;;; returns a (possibly new) class object and the layout which should
1357 ;;; be used for the new definition (may be the current layout, and
1358 ;;; also might be an uninstalled forward referenced layout.) The third
1359 ;;; value is true if this is an incompatible redefinition, in which
1360 ;;; case it is the old layout.
1361 (defun ensure-structure-class (info inherits old-context new-context
1362 &key compiler-layout
)
1363 (declare (type defstruct-description info
))
1364 (multiple-value-bind (class old-layout
)
1365 (multiple-value-bind (class constructor
)
1366 (acond ((cdr (dd-alternate-metaclass info
))
1367 (values (first it
) (second it
)))
1369 (values 'structure-classoid
'make-structure-classoid
)))
1370 (insured-find-classoid (dd-name info
)
1371 (if (eq class
'structure-classoid
)
1373 (sb!xc
:typep x
'structure-classoid
))
1375 (sb!xc
:typep x
(classoid-name (find-classoid class
)))))
1376 (fdefinition constructor
)))
1377 (setf (classoid-direct-superclasses class
)
1378 (case (dd-name info
)
1381 sb
!impl
::string-input-stream sb
!impl
::string-output-stream
1382 sb
!impl
::fill-pointer-output-stream
)
1383 (list (layout-classoid (svref inherits
(1- (length inherits
))))
1384 (layout-classoid (svref inherits
(- (length inherits
) 2)))))
1386 (list (layout-classoid
1387 (svref inherits
(1- (length inherits
))))))))
1388 (let* ((old-layout (or compiler-layout old-layout
))
1390 (when (or (not old-layout
) *type-system-initialized
*)
1391 (make-layout :classoid class
1393 :depthoid
(length inherits
)
1394 :length
(dd-layout-length info
)
1395 :info info .
#!-interleaved-raw-slots
1396 (:n-untagged-slots
(dd-raw-length info
))
1397 #!+interleaved-raw-slots
1398 (:untagged-bitmap
(dd-bitmap info
))))))
1401 (values class new-layout nil
))
1403 ;; The assignment of INFO here can almost be deleted,
1404 ;; except for a few magical types that don't d.t.r.t. in cold-init:
1405 ;; STRUCTURE-OBJECT, CONDITION, ALIEN-VALUE, INTERPRETED-FUNCTION
1406 (setf (layout-info old-layout
) info
)
1407 (values class old-layout nil
))
1408 (;; This clause corresponds to an assertion in REDEFINE-LAYOUT-WARNING
1409 ;; of classic CMU CL. I moved it out to here because it was only
1410 ;; exercised in this code path anyway. -- WHN 19990510
1411 (not (eq (layout-classoid new-layout
) (layout-classoid old-layout
)))
1412 (error "shouldn't happen: weird state of OLD-LAYOUT?"))
1413 ((redefine-layout-warning old-context
1416 (layout-length new-layout
)
1417 (layout-inherits new-layout
)
1418 (layout-depthoid new-layout
)
1419 (layout-raw-slot-metadata new-layout
))
1420 (values class new-layout old-layout
))
1422 (let ((old-info (layout-info old-layout
)))
1424 (cond ((redefine-structure-warning class old-info info
)
1425 (values class new-layout old-layout
))
1427 (setf (layout-info old-layout
) info
)
1428 (values class old-layout nil
)))
1430 (setf (layout-info old-layout
) info
)
1431 (values class old-layout nil
)))))))))
1433 ;;; Return a list of pairs (name . index). Used for :TYPE'd
1434 ;;; constructors to find all the names that we have to splice in &
1435 ;;; where. Note that these types don't have a layout, so we can't look
1436 ;;; at LAYOUT-INHERITS.
1437 (defun find-name-indices (defstruct)
1440 (do ((info defstruct
1441 (typed-structure-info-or-lose (first (dd-include info
)))))
1442 ((not (dd-include info
))
1447 (dolist (info infos
)
1448 (incf i
(or (dd-offset info
) 0))
1449 (when (dd-named info
)
1450 (res (cons (dd-name info
) i
)))
1451 (setq i
(dd-length info
)))))
1455 ;;; These functions are called to actually make a constructor after we
1456 ;;; have processed the arglist. The correct variant (according to the
1457 ;;; DD-TYPE) should be called. The function is defined with the
1458 ;;; specified name and arglist. VARS and TYPES are used for argument
1459 ;;; type declarations. VALUES are the values for the slots (in order.)
1461 ;;; This is split into two functions:
1462 ;;; * INSTANCE-CONSTRUCTOR-FORM has to deal with raw slots
1463 ;;; (there are two variations on this)
1464 ;;; * TYPED-CONSTRUCTOR-FORM deal with LIST & VECTOR
1465 ;;; which might have "name" symbols stuck in at various weird places.
1466 (defun instance-constructor-form (dd values
)
1467 ;; The difference between the two implementations here is that on all
1468 ;; platforms we don't have the appropriate RAW-INSTANCE-INIT VOPS, which
1469 ;; must be able to deal with immediate values as well -- unlike
1470 ;; RAW-INSTANCE-SET VOPs, which never end up seeing immediate values. With
1471 ;; some additional cleverness we might manage without them and just a single
1472 ;; implementation here, though -- figure out a way to ensure that on those
1473 ;; platforms we always still get a non-immediate TN in every case...
1475 ;; Until someone does that, this means that instances with raw slots can be
1476 ;; DX allocated only on platforms with those additional VOPs.
1477 (let ((dd-slots (dd-slots dd
)))
1478 (aver (= (length dd-slots
) (length values
)))
1479 #!+raw-instance-init-vops
1480 (collect ((slot-specs) (slot-values))
1481 (mapc (lambda (dsd value
)
1482 (unless (eq value
'.do-not-initialize-slot.
)
1483 (slot-specs (list* :slot
(dsd-raw-type dsd
) (dsd-index dsd
)))
1484 (slot-values value
)))
1486 `(%make-structure-instance-macro
,dd
',(slot-specs) ,@(slot-values)))
1487 #!-raw-instance-init-vops
1488 (collect ((slot-specs) (slot-values) (raw-slots) (raw-values))
1489 ;; Partition into non-raw and raw
1490 (mapc (lambda (dsd value
)
1491 (unless (eq value
'.do-not-initialize-slot.
)
1492 (let ((raw-type (dsd-raw-type dsd
)))
1493 (cond ((eq t raw-type
)
1494 (slot-specs (list* :slot raw-type
(dsd-index dsd
)))
1495 (slot-values value
))
1498 (raw-values value
))))))
1500 (let ((instance-form
1501 `(%make-structure-instance-macro
,dd
1502 ',(slot-specs) ,@(slot-values))))
1504 (let ((temp (make-symbol "INSTANCE")))
1505 `(let ((,temp
,instance-form
))
1506 ;; Transform to %RAW-INSTANCE-SET/foo, not SETF,
1507 ;; in case any slots are readonly.
1508 ,@(mapcar (lambda (dsd value
)
1509 (slot-access-transform
1510 :setf
(list temp value
) (cons dd dsd
)))
1511 (raw-slots) (raw-values))
1515 ;;; A "typed" constructors prefers to use a single call to LIST or VECTOR
1516 ;;; if possible, but can't always do that for VECTOR because it might not
1517 ;;; be a (VECTOR T). If not, we fallback to MAKE-ARRAY and (SETF AREF).
1518 (defun typed-constructor-form (dd values
)
1519 (multiple-value-bind (operator initial-element
)
1520 (cond ((and (eq (dd-type dd
) 'vector
) (eq (dd-element-type dd
) t
))
1522 ((eq (dd-type dd
) 'list
)
1523 (values 'list nil
)))
1524 (let* ((length (dd-length dd
))
1525 (slots (dd-slots dd
))
1526 ;; Possibly the most useless feature ever: more than one name slot.
1527 (names (find-name-indices dd
)))
1528 (aver (= (length slots
) (length values
)))
1530 ;; The initial-element provides values for slots that are skipped
1531 ;; due to :initial-offset, not slots that are skipped due to
1532 ;; &AUX variables with no initial value.
1533 (let ((vals (make-list length
:initial-element initial-element
)))
1535 (setf (elt vals
(cdr x
)) `',(car x
)))
1536 (mapc (lambda (dsd val
)
1537 ;; For both vectors and lists, .DO-NOT-INITIALIZE-SLOT.
1538 ;; becomes 0 even though lists otherwise use NIL for slots
1539 ;; that are skipped to due :initial-offset.
1540 (setf (elt vals
(dsd-index dsd
))
1541 ;; All VALs have been wrapped in THE if necessary.
1542 (if (eq val
'.do-not-initialize-slot.
) 0 val
)))
1544 (cons operator vals
))
1545 (let ((temp (make-symbol "OBJ")))
1546 `(let ((,temp
(make-array ,length
1547 :element-type
',(dd-element-type dd
))))
1548 ,@(mapcar (lambda (x) `(setf (aref ,temp
,(cdr x
)) ',(car x
)))
1550 ,@(mapcan (lambda (dsd val
)
1551 (unless (eq val
'.do-not-initialize-slot.
)
1552 `((setf (aref ,temp
,(dsd-index dsd
)) ,val
))))
1556 ;;; Return the FTYPE for a DD constructor.
1557 ;;; This is tricky in uses such as the following:
1558 ;;; (DEFSTRUCT (S (:CONSTRUCTOR MS (A &AUX (A (ABS A))))) (A 0 :TYPE (MOD 4)))
1559 ;;; The constructor accepts integers betweeen -3 and 3 because the &AUX binding
1560 ;;; hides the positional argument A, and we can't actually put any constraint
1561 ;;; on A unless we figure out what the action of ABS is.
1563 ;;; The FTYPE is actually not a strong enough constraint anyway, so when IR1
1564 ;;; tests for the call compatibility it will test for correctness *after*
1565 ;;; argument defaulting.
1566 (defun %struct-ctor-ftype
(dd args elt-type
)
1567 (flet ((elt-type-intersect (dsd &aux
(slot-type (dsd-type dsd
)))
1568 (cond ((eq slot-type t
) elt-type
)
1569 ((eq elt-type t
) slot-type
)
1570 (t `(and ,elt-type
,slot-type
)))))
1572 ,(if (eq args
:default
)
1573 `(&key
,@(mapcar (lambda (dsd)
1574 `(,(keywordicate (dsd-name dsd
))
1575 ,(elt-type-intersect dsd
)))
1577 (destructuring-bind (llks &optional req opt rest keys aux
) args
1578 (let ((aux (mapcar (lambda (var) (if (listp var
) (car var
) var
))
1580 (flet ((get-arg-type (name)
1581 (let ((slot (unless (member name aux
:test
#'string
=)
1582 (find name
(dd-slots dd
) :key
#'dsd-name
1584 ;; If no slot, the arg restriction is T,
1585 ;; because we don't know where it goes.
1586 (if slot
(elt-type-intersect slot
) t
))))
1588 llks nil
(mapcar #'get-arg-type req
)
1589 (mapcar (lambda (arg)
1590 (get-arg-type (parse-optional-arg-spec arg
)))
1593 (mapcar (lambda (arg)
1594 (multiple-value-bind (key var
) (parse-key-arg-spec arg
)
1595 `(,key
,(get-arg-type var
))))
1597 (values ,(cond ((dd-class-p dd
) (dd-name dd
))
1598 ((eq (dd-type dd
) 'list
) 'list
)
1599 (t `(vector ,(dd-element-type dd
) ,(dd-length dd
))))
1602 (defun struct-ctor-ftype (dd name
)
1603 (let ((ctor (assq name
(dd-constructors dd
))))
1605 (%struct-ctor-ftype dd
(cdr ctor
) (dd-element-type dd
))))
1607 (defun proclaimed-ftype (name)
1608 (multiple-value-bind (info foundp
) (info :function
:type name
)
1609 (values (cond ((defstruct-description-p info
)
1610 (specifier-type (struct-ctor-ftype info name
)))
1611 #-sb-xc-host
; PCL doesn't exist
1612 ((eq info
:generic-function
) (sb!pcl
::compute-gf-ftype name
))
1616 ;;; Given a DD and a constructor spec (a cons of name and pre-parsed
1617 ;;; BOA lambda list, or the symbol :DEFAULT), return the effective
1618 ;;; lambda list and the body of the lambda.
1619 (defun structure-ctor-lambda-parts
1620 (dd args
&aux
(creator (ecase (dd-type dd
)
1621 (structure #'instance-constructor-form
)
1622 ((list vector
) #'typed-constructor-form
))))
1623 (when (eq args
:default
)
1624 (let ((lambda-list (mapcar (lambda (dsd)
1625 (let* ((temp (copy-symbol (dsd-name dsd
)))
1626 (keyword (keywordicate temp
)))
1627 `((,keyword
,temp
) ,(dsd-default dsd
))))
1629 (return-from structure-ctor-lambda-parts
1630 `((&key
,@lambda-list
)
1631 (declare (explicit-check))
1632 ,(funcall creator dd
1633 (mapcar (lambda (dsd arg
)
1634 (let ((type (dsd-type dsd
))
1636 (if (eq type t
) var
`(the ,type
,var
))))
1637 (dd-slots dd
) lambda-list
))))))
1638 (destructuring-bind (llks &optional req opt rest keys aux
) args
1639 (collect ((vars (copy-list req
)) ; list of bound vars
1642 (dolist (binding aux
)
1643 (let ((name (if (listp binding
) (car binding
) binding
)))
1645 (unless (typep binding
'(cons t cons
))
1646 (skipped-vars name
))))
1647 (macrolet ((rewrite (input key parse
)
1650 (multiple-value-bind (,@key var def sup-p
) (,parse arg
)
1651 (declare (ignore ,@key def
))
1652 (rewrite-1 arg var sup-p
)))
1654 (flet ((rewrite-1 (arg var sup-p-var
)
1656 (when sup-p-var
(vars (car sup-p-var
)))
1657 (let* ((slot (unless (member var
(aux-vars) :test
#'string
=)
1658 (find var
(dd-slots dd
)
1659 :key
#'dsd-name
:test
#'string
=)))
1660 (default (and slot
(dsd-default slot
))))
1661 ;; If VAR initializes a slot and did not have a default in
1662 ;; the lambda list, and DSD-DEFAULT is not NIL,
1663 ;; then change the lambda-list's default for the variable.
1664 ;; Always prefer to insert (CAR ARG) if ARG was a list
1665 ;; so that (:KEY var) syntax is preserved.
1666 (if (and slot
(not (typep arg
'(cons t cons
))) default
)
1667 `(,(if (consp arg
) (car arg
) var
) ,default
,@sup-p-var
)
1668 arg
)))) ; keep it as it was
1669 ;; Can we substitute symbols that are not EQ to symbols
1670 ;; naming slots, so we don't have to compare by STRING= later?
1671 ;; Probably not because other symbols could reference them.
1672 (setq opt
(rewrite opt
() parse-optional-arg-spec
))
1673 (when rest
(vars (car rest
)))
1674 (setq keys
(rewrite keys
(key) parse-key-arg-spec
))
1675 (dolist (arg (aux-vars)) (vars arg
))))
1676 `(,(sb!c
::make-lambda-list
1677 llks nil req opt rest keys
1678 ;; &AUX vars which do not initialize a slot are not mentioned
1679 ;; in the lambda list, though it's not clear what to do if
1680 ;; subsequent bindings refer to the deleted ones.
1681 ;; And worse, what if it's SETQd - is that even legal?
1682 (remove-if (lambda (x) (not (typep x
'(cons t cons
)))) aux
))
1683 (declare (explicit-check))
1687 (lambda (slot &aux
(name (dsd-name slot
)))
1688 (if (find name
(skipped-vars) :test
#'string
=)
1689 ;; CLHS 3.4.6 Boa Lambda Lists
1690 '.do-not-initialize-slot.
1691 (let* ((type (dsd-type slot
))
1692 (found (member (dsd-name slot
) (vars) :test
#'string
=))
1693 (initform (if found
(car found
) (dsd-default slot
))))
1694 ;; We can ignore the DD-ELEMENT-TYPE
1695 ;; because the container itself will check.
1696 (if (eq type t
) initform
`(the ,type
,initform
)))))
1699 (defun accessor-definitions (dd *pending-defstruct-type
*)
1700 (loop for dsd in
(dd-slots dd
)
1701 for accessor-name
= (dsd-accessor-name dsd
)
1702 unless
(accessor-inherited-data accessor-name dd
)
1703 nconc
(dx-let ((key (cons dd dsd
)))
1704 `(,@(unless (dsd-read-only dsd
)
1705 `((defun (setf ,accessor-name
) (value instance
)
1706 ,(slot-access-transform :setf
'(instance value
) key
))))
1707 (defun ,accessor-name
(instance)
1708 ,(slot-access-transform :read
'(instance) key
))))))
1710 ;;;; instances with ALTERNATE-METACLASS
1712 ;;;; The CMU CL support for structures with ALTERNATE-METACLASS was a
1713 ;;;; fairly general extension embedded in the main DEFSTRUCT code, and
1714 ;;;; the result was an fairly impressive mess as ALTERNATE-METACLASS
1715 ;;;; extension mixed with ANSI CL generality (e.g. :TYPE and :INCLUDE)
1716 ;;;; and CMU CL implementation hairiness (esp. raw slots). This SBCL
1717 ;;;; version is much less ambitious, noticing that ALTERNATE-METACLASS
1718 ;;;; is only used to implement CONDITION, STANDARD-INSTANCE, and
1719 ;;;; GENERIC-FUNCTION, and defining a simple specialized
1720 ;;;; separate-from-DEFSTRUCT macro to provide only enough
1721 ;;;; functionality to support those.
1723 ;;;; KLUDGE: The defining macro here is so specialized that it's ugly
1724 ;;;; in its own way. It also violates once-and-only-once by knowing
1725 ;;;; much about structures and layouts that is already known by the
1726 ;;;; main DEFSTRUCT macro. Hopefully it will go away presently
1727 ;;;; (perhaps when CL:CLASS and SB-PCL:CLASS meet) as per FIXME below.
1728 ;;;; -- WHN 2001-10-28
1730 ;;;; FIXME: There seems to be no good reason to shoehorn CONDITION,
1731 ;;;; STANDARD-INSTANCE, and GENERIC-FUNCTION into mutated structures
1732 ;;;; instead of just implementing them as primitive objects. (This
1733 ;;;; reduced-functionality macro seems pretty close to the
1734 ;;;; functionality of !DEFINE-PRIMITIVE-OBJECT..)
1736 ;;; The complete list of alternate-metaclass DEFSTRUCTs:
1737 ;;; CONDITION SB-EVAL:INTERPRETED-FUNCTION
1738 ;;; SB-PCL::STANDARD-INSTANCE SB-PCL::STANDARD-FUNCALLABLE-INSTANCE
1739 ;;; SB-PCL::CTOR SB-PCL::%METHOD-FUNCTION
1741 (defun make-dd-with-alternate-metaclass (&key
(class-name (missing-arg))
1742 (superclass-name (missing-arg))
1743 (metaclass-name (missing-arg))
1744 (dd-type (missing-arg))
1745 metaclass-constructor
1747 (let* ((dd (make-defstruct-description t class-name
))
1748 (conc-name (concatenate 'string
(symbol-name class-name
) "-"))
1749 (dd-slots (let ((reversed-result nil
)
1750 ;; The index starts at 1 for ordinary named
1751 ;; slots because slot 0 is magical, used for
1752 ;; the LAYOUT in CONDITIONs and
1753 ;; FUNCALLABLE-INSTANCEs. (This is the same
1754 ;; in ordinary structures too: see (INCF
1756 ;; PARSE-DEFSTRUCT-NAME-AND-OPTIONS).
1758 (dolist (slot-name slot-names
)
1759 (push (make-defstruct-slot-description
1762 :accessor-name
(symbolicate conc-name slot-name
))
1765 (nreverse reversed-result
))))
1766 ;; We do *not* fill in the COPIER-NAME and PREDICATE-NAME
1767 ;; because none of the magical alternate-metaclass structures
1768 ;; have copiers and predicates that "Just work"
1770 ;; We don't support inheritance of alternate metaclass stuff,
1771 ;; and it's not a general-purpose facility, so sanity check our
1774 (aver (eq superclass-name
't
)))
1775 (funcallable-structure
1776 (aver (eq superclass-name
'function
)))
1777 (t (bug "Unknown DD-TYPE in ALTERNATE-METACLASS: ~S" dd-type
)))
1778 (setf (dd-alternate-metaclass dd
) (list superclass-name
1780 metaclass-constructor
)
1781 (dd-slots dd
) dd-slots
1782 (dd-length dd
) (1+ (length slot-names
))
1783 (dd-type dd
) dd-type
)
1786 ;;; make !DEFSTRUCT-WITH-ALTERNATE-METACLASS compilable by the host
1787 ;;; lisp, installing the information we need to reason about the
1788 ;;; structures (layouts and classoids).
1790 ;;; FIXME: we should share the parsing and the DD construction between
1791 ;;; this and the cross-compiler version, but my brain was too small to
1792 ;;; get that right. -- CSR, 2006-09-14
1794 (defmacro !defstruct-with-alternate-metaclass
1796 (slot-names (missing-arg))
1797 (boa-constructor (missing-arg))
1798 (superclass-name (missing-arg))
1799 (metaclass-name (missing-arg))
1800 (metaclass-constructor (missing-arg))
1801 (dd-type (missing-arg))
1803 (runtime-type-checks-p t
))
1805 (declare (type (and list
(not null
)) slot-names
))
1806 (declare (type (and symbol
(not null
))
1810 metaclass-constructor
))
1811 (declare (type symbol predicate
))
1812 (declare (type (member structure funcallable-structure
) dd-type
))
1813 (declare (ignore boa-constructor predicate runtime-type-checks-p
))
1815 (let* ((dd (make-dd-with-alternate-metaclass
1816 :class-name class-name
1817 :slot-names slot-names
1818 :superclass-name superclass-name
1819 :metaclass-name metaclass-name
1820 :metaclass-constructor metaclass-constructor
1824 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
1825 (%compiler-set-up-layout
',dd
',(!inherits-for-structure dd
))))))
1827 (sb!xc
:defmacro
!defstruct-with-alternate-metaclass
1829 (slot-names (missing-arg))
1830 (boa-constructor (missing-arg))
1831 (superclass-name (missing-arg))
1832 (metaclass-name (missing-arg))
1833 (metaclass-constructor (missing-arg))
1834 (dd-type (missing-arg))
1836 (runtime-type-checks-p t
))
1838 (declare (type (and list
(not null
)) slot-names
))
1839 (declare (type (and symbol
(not null
))
1843 metaclass-constructor
))
1844 (declare (type symbol predicate
))
1845 (declare (type (member structure funcallable-structure
) dd-type
))
1847 (let* ((dd (make-dd-with-alternate-metaclass
1848 :class-name class-name
1849 :slot-names slot-names
1850 :superclass-name superclass-name
1851 :metaclass-name metaclass-name
1852 :metaclass-constructor metaclass-constructor
1854 (dd-slots (dd-slots dd
))
1855 (dd-length (1+ (length slot-names
)))
1856 (object-gensym (make-symbol "OBJECT"))
1857 (new-value-gensym (make-symbol "NEW-VALUE"))
1858 (delayed-layout-form `(%delayed-get-compiler-layout
,class-name
)))
1859 (multiple-value-bind (raw-maker-form raw-reffer-operator
)
1862 (values `(%make-structure-instance-macro
,dd nil
)
1864 (funcallable-structure
1865 (values `(let ((,object-gensym
1866 (%make-funcallable-instance
,dd-length
)))
1867 (setf (%funcallable-instance-layout
,object-gensym
)
1868 ,delayed-layout-form
)
1870 '%funcallable-instance-info
)))
1873 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
1874 (%compiler-set-up-layout
',dd
',(!inherits-for-structure dd
)))
1876 ;; slot readers and writers
1877 (declaim (inline ,@(mapcar #'dsd-accessor-name dd-slots
)))
1878 ,@(mapcar (lambda (dsd)
1879 `(defun ,(dsd-accessor-name dsd
) (,object-gensym
)
1880 ,@(when runtime-type-checks-p
1881 `((declare (type ,class-name
,object-gensym
))))
1882 (,raw-reffer-operator
,object-gensym
1885 (declaim (inline ,@(mapcar (lambda (dsd)
1886 `(setf ,(dsd-accessor-name dsd
)))
1888 ,@(mapcar (lambda (dsd)
1889 `(defun (setf ,(dsd-accessor-name dsd
)) (,new-value-gensym
1891 ,@(when runtime-type-checks-p
1892 `((declare (type ,class-name
,object-gensym
))))
1893 (setf (,raw-reffer-operator
,object-gensym
1895 ,new-value-gensym
)))
1899 (defun ,boa-constructor
,slot-names
1900 (let ((,object-gensym
,raw-maker-form
))
1901 ,@(mapcar (lambda (slot-name)
1902 (let ((dsd (or (find slot-name dd-slots
1903 :key
#'dsd-name
:test
#'string
=)
1904 (bug "Bogus alt-metaclass boa ctor"))))
1905 `(setf (,(dsd-accessor-name dsd
) ,object-gensym
)
1912 ;; Just delegate to the compiler's type optimization
1913 ;; code, which knows how to generate inline type tests
1914 ;; for the whole CMU CL INSTANCE menagerie.
1915 `(defun ,predicate
(,object-gensym
)
1916 (typep ,object-gensym
',class-name
)))
1918 ;; Usually we AVER instead of ASSERT, but one alternate-metaclass
1919 ;; structure definition is cross-compiled before AVER is a known macro.
1920 ;; It could be a def!macro perhaps, but ASSERT works just fine here
1921 ;; without adding to image size, since these toplevel forms
1922 ;; belong to code that is discarded after cold-init.
1923 (assert (null (symbol-value '*defstruct-hooks
*)))))))
1925 ;;;; finalizing bootstrapping
1927 ;;; Set up DD and LAYOUT for STRUCTURE-OBJECT class itself.
1929 ;;; Ordinary structure classes effectively :INCLUDE STRUCTURE-OBJECT
1930 ;;; when they have no explicit :INCLUDEs, so (1) it needs to be set up
1931 ;;; before we can define ordinary structure classes, and (2) it's
1932 ;;; special enough (and simple enough) that we just build it by hand
1933 ;;; instead of trying to generalize the ordinary DEFSTRUCT code.
1934 (defun !set-up-structure-object-class
()
1935 (let ((dd (make-defstruct-description t
'structure-object
)))
1939 (dd-type dd
) 'structure
)
1940 (%compiler-set-up-layout dd
)))
1941 #+sb-xc-host
(!set-up-structure-object-class
)
1943 ;;; early structure predeclarations: Set up DD and LAYOUT for ordinary
1944 ;;; (non-ALTERNATE-METACLASS) structures which are needed early.
1946 '#.
(sb-cold:read-from-file
1947 "src/code/early-defstruct-args.lisp-expr"))
1948 (let* ((dd (parse-defstruct t
(first args
) (rest args
)))
1949 (inherits (!inherits-for-structure dd
)))
1950 (%compiler-defstruct dd inherits
)))
1952 (defun find-defstruct-description (name &optional
(errorp t
))
1953 (let* ((classoid (find-classoid name errorp
))
1955 (layout-info (classoid-layout classoid
)))))
1956 (cond ((defstruct-description-p info
)
1959 (error "No DEFSTRUCT-DESCRIPTION for ~S." name
)))))
1961 (defun structure-instance-accessor-p (name)
1962 (let ((info (info :function
:source-transform name
)))
1964 (defstruct-slot-description-p (cdr info
))
1967 (defun dd-default-constructor (dd)
1968 (let ((ctor (first (dd-constructors dd
))))
1969 (when (typep ctor
'(cons t
(eql :default
)))
1972 ;;; These functions are required to emulate SBCL kernel functions
1973 ;;; in a vanilla ANSI Common Lisp cross-compilation host.
1974 ;;; The emulation doesn't need to be efficient, since it's needed
1975 ;;; only for object dumping.
1978 (defun xc-dumpable-structure-instance-p (x)
1979 (and (typep x
'cl
:structure-object
)
1980 (let ((name (type-of x
)))
1981 ;; Don't allow totally random structures, only ones that the
1982 ;; cross-compiler has been advised will work.
1983 (and (get name
:sb-xc-allow-dumping-instances
)
1984 ;; but we must also have cross-compiled it for real.
1985 (sb!kernel
::compiler-layout-ready-p name
)
1986 ;; and I don't know anything about raw slots
1987 ;; Coincidentally, in either representation of
1988 ;; raw-slot-metadata, 0 represents no untagged slots.
1989 (zerop (layout-raw-slot-metadata
1990 (info :type
:compiler-layout name
)))))))
1991 (defun %instance-layout
(instance)
1992 (aver (or (typep instance
'structure
!object
)
1993 (xc-dumpable-structure-instance-p instance
)))
1994 (classoid-layout (find-classoid (type-of instance
))))
1995 (defun %instance-length
(instance)
1996 ;; INSTANCE-LENGTH tells you how many data words the backend is able to
1997 ;; physically access in this structure. Since every structure occupies
1998 ;; an even number of words, the storage slots comprise an odd number
1999 ;; of words after subtracting 1 for the header.
2000 ;; And in fact the fasl dumper / loader do write and read potentially
2001 ;; one cell beyond the instance's LAYOUT-LENGTH if it was not odd.
2002 ;; I'm not sure whether that is a good or bad thing.
2003 ;; But be that as it may, in the cross-compiler you must not access
2004 ;; more cells than there are in the declared structure because there
2005 ;; is no lower level storage that you can peek at.
2006 ;; So INSTANCE-LENGTH is exactly the same as LAYOUT-LENGTH on the host.
2007 (layout-length (%instance-layout instance
)))
2008 (defun %instance-ref
(instance index
)
2009 (let ((layout (%instance-layout instance
)))
2010 ;; with compact headers, 0 is an ordinary slot index.
2011 ;; without, it's the layout.
2012 (if (eql index
(1- sb
!vm
:instance-data-start
))
2013 (error "XC Host should use %INSTANCE-LAYOUT, not %INSTANCE-REF 0")
2014 (let* ((dd (layout-info layout
))
2015 ;; If data starts at 1, then subtract 1 from index.
2016 ;; otherwise use the index as-is.
2017 (dsd (elt (dd-slots dd
)
2018 (- index sb
!vm
:instance-data-start
)))
2019 (accessor-name (dsd-accessor-name dsd
)))
2020 ;; Why AVER these: because it is slightly abstraction-breaking
2021 ;; to assume that the slot-index N is the NTH item in the DSDs.
2022 ;; The target Lisp never assumes that.
2023 (aver (and (eql (dsd-index dsd
) index
) (eq (dsd-raw-type dsd
) t
)))
2024 (funcall accessor-name instance
)))))
2026 (defun %raw-instance-ref
/word
(instance index
)
2027 (declare (ignore instance index
))
2028 (error "No such thing as raw structure access on the host"))
2030 ;; Setting with (FUNCALL `(SETF ,accessor) ...) is unportable because
2031 ;; "The mechanism by which defstruct arranges for slot accessors to be
2032 ;; usable with setf is implementation-dependent; for example, it may
2033 ;; use setf functions, setf expanders, or some other
2034 ;; implementation-dependent mechanism ..."
2035 ;; But such capability seems not to be needed.
2036 (defun %instance-set
(instance index new-value
)
2037 (declare (ignore instance index new-value
))
2038 (error "Can not use %INSTANCE-SET on cross-compilation host.")))
2040 ;;; If LAMBDA-LIST and BODY constitute an auto-generated structure function
2041 ;;; (accessor or predicate) for NAME, return the kind of thing it is.
2042 (defun defstruct-generated-defn-p (name lambda-list body
)
2043 (unless (singleton-p body
)
2044 (return-from defstruct-generated-defn-p nil
))
2045 (let ((info (info :function
:source-transform name
))
2048 (when (and (eq (cdr info
) :predicate
)
2049 (equal lambda-list
'(object))
2053 (cons (cons (eql quote
) (cons t null
))
2055 ;; extract dd-name from `(TYPEP OBJECT ',THING)
2056 (eq (second (third form
)) (dd-name (car info
))))
2057 (return-from defstruct-generated-defn-p
:predicate
))
2058 (when (defstruct-slot-description-p (cdr info
))
2059 (multiple-value-bind (mode expected-lambda-list xform-args
)
2061 (values :setf
'(value instance
) '(instance value
))
2062 (values :read
'(instance) '(instance)))
2063 (when (and (equal expected-lambda-list lambda-list
)
2064 (equal (slot-access-transform mode xform-args info
) form
))
2065 (return-from defstruct-generated-defn-p
:accessor
)))))))
2067 (/show0
"code/defstruct.lisp end of file")