1.0.23.6: move code-object allocation to C side on x86 and x86-64
[sbcl.git] / src / code / defstruct.lisp
1 ;;;; that part of DEFSTRUCT implementation which is needed not just
2 ;;;; in the target Lisp but also in the cross-compilation host
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
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.
12
13 (in-package "SB!KERNEL")
14
15 (/show0 "code/defstruct.lisp 15")
16 \f
17 ;;;; getting LAYOUTs
18
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)))
23     (cond ((not res)
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))
27           (t res))))
28
29 (defun compiler-layout-ready-p (name)
30   (let ((layout (info :type :compiler-layout name)))
31     (and layout (typep (layout-info layout) 'defstruct-description))))
32
33 (sb!xc:defmacro %make-structure-instance-macro (dd slot-specs &rest slot-vars)
34   `(truly-the ,(dd-name dd)
35               ,(if (compiler-layout-ready-p (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
40                    ;; so horribly.
41                    `(let* ((cell (load-time-value (list nil)))
42                            (fun (car cell)))
43                       (if (functionp fun)
44                           (funcall fun ,@slot-vars)
45                           (funcall (setf (car cell)
46                                          (%make-structure-instance-allocator ,dd ,slot-specs))
47                                    ,@slot-vars))))))
48
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))))
53     (values (compile nil `(lambda (,@vars)
54                             (%make-structure-instance-macro ,dd ',slot-specs ,@vars))))))
55
56 (defun %make-funcallable-structure-instance-allocator (dd slot-specs)
57   (when slot-specs
58     (bug "funcallable-structure-instance allocation with slots unimplemented"))
59   (let ((name (dd-name dd))
60         (length (dd-length dd))
61         (nobject (gensym "OBJECT")))
62     (values
63      (compile nil `(lambda ()
64                      (let ((,nobject (%make-funcallable-instance ,length)))
65                        (setf (%funcallable-instance-layout ,nobject)
66                              (%delayed-get-compiler-layout ,name))
67                        ,nobject))))))
68
69 ;;; Delay looking for compiler-layout until the constructor is being
70 ;;; compiled, since it doesn't exist until after the EVAL-WHEN
71 ;;; (COMPILE) stuff is compiled. (Or, in the oddball case when
72 ;;; DEFSTRUCT is executing in a non-toplevel context, the
73 ;;; compiler-layout still doesn't exist at compilation time, and we
74 ;;; delay still further.)
75 (sb!xc:defmacro %delayed-get-compiler-layout (name)
76   (let ((layout (info :type :compiler-layout name)))
77     (cond (layout
78            ;; ordinary case: When the DEFSTRUCT is at top level,
79            ;; then EVAL-WHEN (COMPILE) stuff will have set up the
80            ;; layout for us to use.
81            (unless (typep (layout-info layout) 'defstruct-description)
82              (error "Class is not a structure class: ~S" name))
83            `,layout)
84           (t
85            ;; KLUDGE: In the case that DEFSTRUCT is not at top-level
86            ;; the layout doesn't exist at compile time. In that case
87            ;; we laboriously look it up at run time. This code will
88            ;; run on every constructor call and will likely be quite
89            ;; slow, so if anyone cares about performance of
90            ;; non-toplevel DEFSTRUCTs, it should be rewritten to be
91            ;; cleverer. -- WHN 2002-10-23
92            (sb!c:compiler-notify
93             "implementation limitation: ~
94              Non-toplevel DEFSTRUCT constructors are slow.")
95            (with-unique-names (layout)
96              `(let ((,layout (info :type :compiler-layout ',name)))
97                 (unless (typep (layout-info ,layout) 'defstruct-description)
98                   (error "Class is not a structure class: ~S" ',name))
99                 ,layout))))))
100
101 ;;; re. %DELAYED-GET-COMPILER-LAYOUT and COMPILE-TIME-FIND-LAYOUT, above..
102 ;;;
103 ;;; FIXME: Perhaps both should be defined with DEFMACRO-MUNDANELY?
104 ;;; FIXME: Do we really need both? If so, their names and implementations
105 ;;; should probably be tweaked to be more parallel.
106 \f
107 ;;;; DEFSTRUCT-DESCRIPTION
108
109 ;;; The DEFSTRUCT-DESCRIPTION structure holds compile-time information
110 ;;; about a structure type.
111 (def!struct (defstruct-description
112              (:conc-name dd-)
113              (:make-load-form-fun just-dump-it-normally)
114              #-sb-xc-host (:pure t)
115              (:constructor make-defstruct-description
116                            (name &aux
117                                  (conc-name (symbolicate name "-"))
118                                  (copier-name (symbolicate "COPY-" name))
119                                  (predicate-name (symbolicate name "-P")))))
120   ;; name of the structure
121   (name (missing-arg) :type symbol :read-only t)
122   ;; documentation on the structure
123   (doc nil :type (or string null))
124   ;; prefix for slot names. If NIL, none.
125   (conc-name nil :type (or symbol null))
126   ;; the name of the primary standard keyword constructor, or NIL if none
127   (default-constructor nil :type (or symbol null))
128   ;; all the explicit :CONSTRUCTOR specs, with name defaulted
129   (constructors () :type list)
130   ;; name of copying function
131   (copier-name nil :type (or symbol null))
132   ;; name of type predicate
133   (predicate-name nil :type (or symbol null))
134   ;; the arguments to the :INCLUDE option, or NIL if no included
135   ;; structure
136   (include nil :type list)
137   ;; properties used to define structure-like classes with an
138   ;; arbitrary superclass and that may not have STRUCTURE-CLASS as the
139   ;; metaclass. Syntax is:
140   ;;    (superclass-name metaclass-name metaclass-constructor)
141   (alternate-metaclass nil :type list)
142   ;; a list of DEFSTRUCT-SLOT-DESCRIPTION objects for all slots
143   ;; (including included ones)
144   (slots () :type list)
145   ;; a list of (NAME . INDEX) pairs for accessors of included structures
146   (inherited-accessor-alist () :type list)
147   ;; number of elements we've allocated (See also RAW-LENGTH, which is not
148   ;; included in LENGTH.)
149   (length 0 :type index)
150   ;; General kind of implementation.
151   (type 'structure :type (member structure vector list
152                                  funcallable-structure))
153
154   ;; The next three slots are for :TYPE'd structures (which aren't
155   ;; classes, DD-CLASS-P = NIL)
156   ;;
157   ;; vector element type
158   (element-type t)
159   ;; T if :NAMED was explicitly specified, NIL otherwise
160   (named nil :type boolean)
161   ;; any INITIAL-OFFSET option on this direct type
162   (offset nil :type (or index null))
163
164   ;; the argument to the PRINT-FUNCTION option, or NIL if a
165   ;; PRINT-FUNCTION option was given with no argument, or 0 if no
166   ;; PRINT-FUNCTION option was given
167   (print-function 0 :type (or cons symbol (member 0)))
168   ;; the argument to the PRINT-OBJECT option, or NIL if a PRINT-OBJECT
169   ;; option was given with no argument, or 0 if no PRINT-OBJECT option
170   ;; was given
171   (print-object 0 :type (or cons symbol (member 0)))
172   ;; The number of untagged slots at the end.
173   (raw-length 0 :type index)
174   ;; the value of the :PURE option, or :UNSPECIFIED. This is only
175   ;; meaningful if DD-CLASS-P = T.
176   (pure :unspecified :type (member t nil :substructure :unspecified)))
177 (def!method print-object ((x defstruct-description) stream)
178   (print-unreadable-object (x stream :type t)
179     (prin1 (dd-name x) stream)))
180
181 ;;; Does DD describe a structure with a class?
182 (defun dd-class-p (dd)
183   (member (dd-type dd)
184           '(structure funcallable-structure)))
185
186 ;;; a type name which can be used when declaring things which operate
187 ;;; on structure instances
188 (defun dd-declarable-type (dd)
189   (if (dd-class-p dd)
190       ;; Native classes are known to the type system, and we can
191       ;; declare them as types.
192       (dd-name dd)
193       ;; Structures layered on :TYPE LIST or :TYPE VECTOR aren't part
194       ;; of the type system, so all we can declare is the underlying
195       ;; LIST or VECTOR type.
196       (dd-type dd)))
197
198 (defun dd-layout-or-lose (dd)
199   (compiler-layout-or-lose (dd-name dd)))
200 \f
201 ;;;; DEFSTRUCT-SLOT-DESCRIPTION
202
203 ;;; A DEFSTRUCT-SLOT-DESCRIPTION holds compile-time information about
204 ;;; a structure slot.
205 (def!struct (defstruct-slot-description
206              (:make-load-form-fun just-dump-it-normally)
207              (:conc-name dsd-)
208              (:copier nil)
209              #-sb-xc-host (:pure t))
210   ;; name of slot
211   name
212   ;; its position in the implementation sequence
213   (index (missing-arg) :type fixnum)
214   ;; the name of the accessor function
215   ;;
216   ;; (CMU CL had extra complexity here ("..or NIL if this accessor has
217   ;; the same name as an inherited accessor (which we don't want to
218   ;; shadow)") but that behavior doesn't seem to be specified by (or
219   ;; even particularly consistent with) ANSI, so it's gone in SBCL.)
220   (accessor-name nil)
221   default                       ; default value expression
222   (type t)                      ; declared type specifier
223   (safe-p t :type boolean)      ; whether the slot is known to be
224                                 ; always of the specified type
225   ;; If this object does not describe a raw slot, this value is T.
226   ;;
227   ;; If this object describes a raw slot, this value is the type of the
228   ;; value that the raw slot holds.
229   (raw-type t :type (member t single-float double-float
230                             #!+long-float long-float
231                             complex-single-float complex-double-float
232                             #!+long-float complex-long-float
233                             sb!vm:word))
234   (read-only nil :type (member t nil)))
235 (def!method print-object ((x defstruct-slot-description) stream)
236   (print-unreadable-object (x stream :type t)
237     (prin1 (dsd-name x) stream)))
238 \f
239 ;;;; typed (non-class) structures
240
241 ;;; Return a type specifier we can use for testing :TYPE'd structures.
242 (defun dd-lisp-type (defstruct)
243   (ecase (dd-type defstruct)
244     (list 'list)
245     (vector `(simple-array ,(dd-element-type defstruct) (*)))))
246 \f
247 ;;;; shared machinery for inline and out-of-line slot accessor functions
248
249 ;;; Classic comment preserved for entertainment value:
250 ;;;
251 ;;; "A lie can travel halfway round the world while the truth is
252 ;;; putting on its shoes." -- Mark Twain
253
254 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
255
256   ;; information about how a slot of a given DSD-RAW-TYPE is to be accessed
257   (defstruct raw-slot-data
258     ;; the raw slot type, or T for a non-raw slot
259     ;;
260     ;; (Non-raw slots are in the ordinary place you'd expect, directly
261     ;; indexed off the instance pointer.  Raw slots are indexed from the end
262     ;; of the instance and skipped by GC.)
263     (raw-type (missing-arg) :type (or symbol cons) :read-only t)
264     ;; What operator is used to access a slot of this type?
265     (accessor-name (missing-arg) :type symbol :read-only t)
266     (init-vop (missing-arg) :type symbol :read-only t)
267     ;; How many words are each value of this type?
268     (n-words (missing-arg) :type (and index (integer 1)) :read-only t)
269     ;; Necessary alignment in units of words.  Note that instances
270     ;; themselves are aligned by exactly two words, so specifying more
271     ;; than two words here would not work.
272     (alignment 1 :type (integer 1 2) :read-only t))
273
274   (defvar *raw-slot-data-list*
275     #!+hppa
276     nil
277     #!-hppa
278     (let ((double-float-alignment
279            ;; white list of architectures that can load unaligned doubles:
280            #!+(or x86 x86-64 ppc) 1
281            ;; at least sparc, mips and alpha can't:
282            #!-(or x86 x86-64 ppc) 2))
283       (list
284        (make-raw-slot-data :raw-type 'sb!vm:word
285                            :accessor-name '%raw-instance-ref/word
286                            :init-vop 'sb!vm::raw-instance-init/word
287                            :n-words 1)
288        (make-raw-slot-data :raw-type 'single-float
289                            :accessor-name '%raw-instance-ref/single
290                            :init-vop 'sb!vm::raw-instance-init/single
291                            ;; KLUDGE: On 64 bit architectures, we
292                            ;; could pack two SINGLE-FLOATs into the
293                            ;; same word if raw slots were indexed
294                            ;; using bytes instead of words.  However,
295                            ;; I don't personally find optimizing
296                            ;; SINGLE-FLOAT memory usage worthwile
297                            ;; enough.  And the other datatype that
298                            ;; would really benefit is (UNSIGNED-BYTE
299                            ;; 32), but that is a subtype of FIXNUM, so
300                            ;; we store it unraw anyway.  :-( -- DFL
301                            :n-words 1)
302        (make-raw-slot-data :raw-type 'double-float
303                            :accessor-name '%raw-instance-ref/double
304                            :init-vop 'sb!vm::raw-instance-init/double
305                            :alignment double-float-alignment
306                            :n-words (/ 8 sb!vm:n-word-bytes))
307        (make-raw-slot-data :raw-type 'complex-single-float
308                            :accessor-name '%raw-instance-ref/complex-single
309                            :init-vop 'sb!vm::raw-instance-init/complex-single
310                            :n-words (/ 8 sb!vm:n-word-bytes))
311        (make-raw-slot-data :raw-type 'complex-double-float
312                            :accessor-name '%raw-instance-ref/complex-double
313                            :init-vop 'sb!vm::raw-instance-init/complex-double
314                            :alignment double-float-alignment
315                            :n-words (/ 16 sb!vm:n-word-bytes))
316        #!+long-float
317        (make-raw-slot-data :raw-type long-float
318                            :accessor-name '%raw-instance-ref/long
319                            :init-vop 'sb!vm::raw-instance-init/long
320                            :n-words #!+x86 3 #!+sparc 4)
321        #!+long-float
322        (make-raw-slot-data :raw-type complex-long-float
323                            :accessor-name '%raw-instance-ref/complex-long
324                            :init-vop 'sb!vm::raw-instance-init/complex-long
325                            :n-words #!+x86 6 #!+sparc 8)))))
326 (defun raw-slot-words (type)
327   (let ((rsd (find type *raw-slot-data-list* :key #'raw-slot-data-raw-type)))
328     (if rsd
329         (raw-slot-data-n-words rsd)
330         (error "Invalid raw slot type: ~S" type))))
331 \f
332 ;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its
333 ;;;; close personal friend SB!XC:DEFSTRUCT)
334
335 ;;; Return a list of forms to install PRINT and MAKE-LOAD-FORM funs,
336 ;;; mentioning them in the expansion so that they can be compiled.
337 (defun class-method-definitions (defstruct)
338   (let ((name (dd-name defstruct)))
339     `((locally
340         ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant
341         ;; class names which creates fast but non-cold-loadable,
342         ;; non-compact code. In this context, we'd rather have
343         ;; compact, cold-loadable code. -- WHN 19990928
344         (declare (notinline find-classoid))
345         ,@(let ((pf (dd-print-function defstruct))
346                 (po (dd-print-object defstruct))
347                 (x (gensym))
348                 (s (gensym)))
349             ;; Giving empty :PRINT-OBJECT or :PRINT-FUNCTION options
350             ;; leaves PO or PF equal to NIL. The user-level effect is
351             ;; to generate a PRINT-OBJECT method specialized for the type,
352             ;; implementing the default #S structure-printing behavior.
353             (when (or (eq pf nil) (eq po nil))
354               (setf pf '(default-structure-print)
355                     po 0))
356             (flet (;; Given an arg from a :PRINT-OBJECT or :PRINT-FUNCTION
357                    ;; option, return the value to pass as an arg to FUNCTION.
358                    (farg (oarg)
359                      (destructuring-bind (fun-name) oarg
360                        fun-name)))
361               (cond ((not (eql pf 0))
362                      `((def!method print-object ((,x ,name) ,s)
363                          (funcall #',(farg pf)
364                                   ,x
365                                   ,s
366                                   *current-level-in-print*))))
367                     ((not (eql po 0))
368                      `((def!method print-object ((,x ,name) ,s)
369                          (funcall #',(farg po) ,x ,s))))
370                     (t nil))))
371         ,@(let ((pure (dd-pure defstruct)))
372             (cond ((eq pure t)
373                    `((setf (layout-pure (classoid-layout
374                                          (find-classoid ',name)))
375                            t)))
376                   ((eq pure :substructure)
377                    `((setf (layout-pure (classoid-layout
378                                          (find-classoid ',name)))
379                            0)))))
380         ,@(let ((def-con (dd-default-constructor defstruct)))
381             (when (and def-con (not (dd-alternate-metaclass defstruct)))
382               `((setf (structure-classoid-constructor (find-classoid ',name))
383                       #',def-con))))))))
384
385 ;;; shared logic for host macroexpansion for SB!XC:DEFSTRUCT and
386 ;;; cross-compiler macroexpansion for CL:DEFSTRUCT
387 (defmacro !expander-for-defstruct (name-and-options
388                                    slot-descriptions
389                                    expanding-into-code-for-xc-host-p)
390   `(let ((name-and-options ,name-and-options)
391          (slot-descriptions ,slot-descriptions)
392          (expanding-into-code-for-xc-host-p
393           ,expanding-into-code-for-xc-host-p))
394      (let* ((dd (parse-defstruct-name-and-options-and-slot-descriptions
395                  name-and-options
396                  slot-descriptions))
397             (name (dd-name dd)))
398        (if (dd-class-p dd)
399            (let ((inherits (inherits-for-structure dd)))
400              `(progn
401                 ;; Note we intentionally enforce package locks and
402                 ;; call %DEFSTRUCT first, and especially before
403                 ;; %COMPILER-DEFSTRUCT. %DEFSTRUCT has the tests (and
404                 ;; resulting CERROR) for collisions with LAYOUTs which
405                 ;; already exist in the runtime. If there are any
406                 ;; collisions, we want the user's response to CERROR
407                 ;; to control what happens. Especially, if the user
408                 ;; responds to the collision with ABORT, we don't want
409                 ;; %COMPILER-DEFSTRUCT to modify the definition of the
410                 ;; class.
411                 (with-single-package-locked-error
412                     (:symbol ',name "defining ~A as a structure"))
413                 (%defstruct ',dd ',inherits (sb!c:source-location))
414                 (eval-when (:compile-toplevel :load-toplevel :execute)
415                   (%compiler-defstruct ',dd ',inherits))
416                 ,@(unless expanding-into-code-for-xc-host-p
417                     (append ;; FIXME: We've inherited from CMU CL nonparallel
418                             ;; code for creating copiers for typed and untyped
419                             ;; structures. This should be fixed.
420                             ;(copier-definition dd)
421                             (constructor-definitions dd)
422                             (class-method-definitions dd)))
423                 ',name))
424            `(progn
425               (with-single-package-locked-error
426                   (:symbol ',name "defining ~A as a structure"))
427               (eval-when (:compile-toplevel :load-toplevel :execute)
428                 (setf (info :typed-structure :info ',name) ',dd))
429               (eval-when (:load-toplevel :execute)
430                 (setf (info :source-location :typed-structure ',name)
431                       (sb!c:source-location)))
432               ,@(unless expanding-into-code-for-xc-host-p
433                   (append (typed-accessor-definitions dd)
434                           (typed-predicate-definitions dd)
435                           (typed-copier-definitions dd)
436                           (constructor-definitions dd)
437                           (when (dd-doc dd)
438                             `((setf (fdocumentation ',(dd-name dd) 'structure)
439                                ',(dd-doc dd))))))
440               ',name)))))
441
442 (sb!xc:defmacro defstruct (name-and-options &rest slot-descriptions)
443   #!+sb-doc
444   "DEFSTRUCT {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)}
445    Define the structure type Name. Instances are created by MAKE-<name>,
446    which takes &KEY arguments allowing initial slot values to the specified.
447    A SETF'able function <name>-<slot> is defined for each slot to read and
448    write slot values. <name>-p is a type predicate.
449
450    Popular DEFSTRUCT options (see manual for others):
451
452    (:CONSTRUCTOR Name)
453    (:PREDICATE Name)
454        Specify the name for the constructor or predicate.
455
456    (:CONSTRUCTOR Name Lambda-List)
457        Specify the name and arguments for a BOA constructor
458        (which is more efficient when keyword syntax isn't necessary.)
459
460    (:INCLUDE Supertype Slot-Spec*)
461        Make this type a subtype of the structure type Supertype. The optional
462        Slot-Specs override inherited slot options.
463
464    Slot options:
465
466    :TYPE Type-Spec
467        Asserts that the value of this slot is always of the specified type.
468
469    :READ-ONLY {T | NIL}
470        If true, no setter function is defined for this slot."
471     (!expander-for-defstruct name-and-options slot-descriptions nil))
472 #+sb-xc-host
473 (defmacro sb!xc:defstruct (name-and-options &rest slot-descriptions)
474   #!+sb-doc
475   "Cause information about a target structure to be built into the
476   cross-compiler."
477   (!expander-for-defstruct name-and-options slot-descriptions t))
478 \f
479 ;;;; functions to generate code for various parts of DEFSTRUCT definitions
480
481 ;;; First, a helper to determine whether a name names an inherited
482 ;;; accessor.
483 (defun accessor-inherited-data (name defstruct)
484   (assoc name (dd-inherited-accessor-alist defstruct) :test #'eq))
485
486 ;;; Return a list of forms which create a predicate function for a
487 ;;; typed DEFSTRUCT.
488 (defun typed-predicate-definitions (defstruct)
489   (let ((name (dd-name defstruct))
490         (predicate-name (dd-predicate-name defstruct))
491         (argname (gensym)))
492     (when (and predicate-name (dd-named defstruct))
493       (let ((ltype (dd-lisp-type defstruct))
494             (name-index (cdr (car (last (find-name-indices defstruct))))))
495         `((defun ,predicate-name (,argname)
496             (and (typep ,argname ',ltype)
497                  ,(cond
498                    ((subtypep ltype 'list)
499                      `(do ((head (the ,ltype ,argname) (cdr head))
500                            (i 0 (1+ i)))
501                           ((or (not (consp head)) (= i ,name-index))
502                            (and (consp head) (eq ',name (car head))))))
503                    ((subtypep ltype 'vector)
504                     `(and (= (length (the ,ltype ,argname))
505                            ,(dd-length defstruct))
506                           (eq ',name (aref (the ,ltype ,argname) ,name-index))))
507                    (t (bug "Uncatered-for lisp type in typed DEFSTRUCT: ~S."
508                            ltype))))))))))
509
510 ;;; Return a list of forms to create a copier function of a typed DEFSTRUCT.
511 (defun typed-copier-definitions (defstruct)
512   (when (dd-copier-name defstruct)
513     `((setf (fdefinition ',(dd-copier-name defstruct)) #'copy-seq)
514       (declaim (ftype function ,(dd-copier-name defstruct))))))
515
516 ;;; Return a list of function definitions for accessing and setting
517 ;;; the slots of a typed DEFSTRUCT. The functions are proclaimed to be
518 ;;; inline, and the types of their arguments and results are declared
519 ;;; as well. We count on the compiler to do clever things with ELT.
520 (defun typed-accessor-definitions (defstruct)
521   (collect ((stuff))
522     (let ((ltype (dd-lisp-type defstruct)))
523       (dolist (slot (dd-slots defstruct))
524         (let ((name (dsd-accessor-name slot))
525               (index (dsd-index slot))
526               (slot-type `(and ,(dsd-type slot)
527                                ,(dd-element-type defstruct))))
528           (let ((inherited (accessor-inherited-data name defstruct)))
529             (cond
530               ((not inherited)
531                (stuff `(declaim (inline ,name ,@(unless (dsd-read-only slot)
532                                                         `((setf ,name))))))
533                ;; FIXME: The arguments in the next two DEFUNs should
534                ;; be gensyms. (Otherwise e.g. if NEW-VALUE happened to
535                ;; be the name of a special variable, things could get
536                ;; weird.)
537                (stuff `(defun ,name (structure)
538                         (declare (type ,ltype structure))
539                         (the ,slot-type (elt structure ,index))))
540                (unless (dsd-read-only slot)
541                  (stuff
542                   `(defun (setf ,name) (new-value structure)
543                     (declare (type ,ltype structure) (type ,slot-type new-value))
544                     (setf (elt structure ,index) new-value)))))
545               ((not (= (cdr inherited) index))
546                (style-warn "~@<Non-overwritten accessor ~S does not access ~
547                             slot with name ~S (accessing an inherited slot ~
548                             instead).~:@>" name (dsd-name slot))))))))
549     (stuff)))
550 \f
551 ;;;; parsing
552
553 (defun require-no-print-options-so-far (defstruct)
554   (unless (and (eql (dd-print-function defstruct) 0)
555                (eql (dd-print-object defstruct) 0))
556     (error "No more than one of the following options may be specified:
557   :PRINT-FUNCTION, :PRINT-OBJECT, :TYPE")))
558
559 ;;; Parse a single DEFSTRUCT option and store the results in DD.
560 (defun parse-1-dd-option (option dd)
561   (let ((args (rest option))
562         (name (dd-name dd)))
563     (case (first option)
564       (:conc-name
565        (destructuring-bind (&optional conc-name) args
566          (setf (dd-conc-name dd)
567                (if (symbolp conc-name)
568                    conc-name
569                    (make-symbol (string conc-name))))))
570       (:constructor
571        (destructuring-bind (&optional (cname (symbolicate "MAKE-" name))
572                                       &rest stuff)
573            args
574          (push (cons cname stuff) (dd-constructors dd))))
575       (:copier
576        (destructuring-bind (&optional (copier (symbolicate "COPY-" name)))
577            args
578          (setf (dd-copier-name dd) copier)))
579       (:predicate
580        (destructuring-bind (&optional (predicate-name (symbolicate name "-P")))
581            args
582          (setf (dd-predicate-name dd) predicate-name)))
583       (:include
584        (when (dd-include dd)
585          (error "more than one :INCLUDE option"))
586        (setf (dd-include dd) args))
587       (:print-function
588        (require-no-print-options-so-far dd)
589        (setf (dd-print-function dd)
590              (the (or symbol cons) args)))
591       (:print-object
592        (require-no-print-options-so-far dd)
593        (setf (dd-print-object dd)
594              (the (or symbol cons) args)))
595       (:type
596        (destructuring-bind (type) args
597          (cond ((member type '(list vector))
598                 (setf (dd-element-type dd) t)
599                 (setf (dd-type dd) type))
600                ((and (consp type) (eq (first type) 'vector))
601                 (destructuring-bind (vector vtype) type
602                   (declare (ignore vector))
603                   (setf (dd-element-type dd) vtype)
604                   (setf (dd-type dd) 'vector)))
605                (t
606                 (error "~S is a bad :TYPE for DEFSTRUCT." type)))))
607       (:named
608        (error "The DEFSTRUCT option :NAMED takes no arguments."))
609       (:initial-offset
610        (destructuring-bind (offset) args
611          (setf (dd-offset dd) offset)))
612       (:pure
613        (destructuring-bind (fun) args
614          (setf (dd-pure dd) fun)))
615       (t (error "unknown DEFSTRUCT option:~%  ~S" option)))))
616
617 ;;; Given name and options, return a DD holding that info.
618 (defun parse-defstruct-name-and-options (name-and-options)
619   (destructuring-bind (name &rest options) name-and-options
620     (aver name) ; A null name doesn't seem to make sense here.
621     (let ((dd (make-defstruct-description name)))
622       (dolist (option options)
623         (cond ((eq option :named)
624                (setf (dd-named dd) t))
625               ((consp option)
626                (parse-1-dd-option option dd))
627               ((member option '(:conc-name :constructor :copier :predicate))
628                (parse-1-dd-option (list option) dd))
629               (t
630                (error "unrecognized DEFSTRUCT option: ~S" option))))
631
632       (case (dd-type dd)
633         (structure
634          (when (dd-offset dd)
635            (error ":OFFSET can't be specified unless :TYPE is specified."))
636          (unless (dd-include dd)
637            ;; FIXME: It'd be cleaner to treat no-:INCLUDE as defaulting
638            ;; to :INCLUDE STRUCTURE-OBJECT, and then let the general-case
639            ;; (INCF (DD-LENGTH DD) (DD-LENGTH included-DD)) logic take
640            ;; care of this. (Except that the :TYPE VECTOR and :TYPE
641            ;; LIST cases, with their :NAMED and un-:NAMED flavors,
642            ;; make that messy, alas.)
643            (incf (dd-length dd))))
644         (t
645          (require-no-print-options-so-far dd)
646          (when (dd-named dd)
647            (incf (dd-length dd)))
648          (let ((offset (dd-offset dd)))
649            (when offset (incf (dd-length dd) offset)))))
650
651       (when (dd-include dd)
652         (frob-dd-inclusion-stuff dd))
653
654       dd)))
655
656 ;;; Given name and options and slot descriptions (and possibly doc
657 ;;; string at the head of slot descriptions) return a DD holding that
658 ;;; info.
659 (defun parse-defstruct-name-and-options-and-slot-descriptions
660     (name-and-options slot-descriptions)
661   (let ((result (parse-defstruct-name-and-options (if (atom name-and-options)
662                                                       (list name-and-options)
663                                                       name-and-options))))
664     (when (stringp (car slot-descriptions))
665       (setf (dd-doc result) (pop slot-descriptions)))
666     (dolist (slot-description slot-descriptions)
667       (allocate-1-slot result (parse-1-dsd result slot-description)))
668     result))
669 \f
670 ;;;; stuff to parse slot descriptions
671
672 ;;; Parse a slot description for DEFSTRUCT, add it to the description
673 ;;; and return it. If supplied, SLOT is a pre-initialized DSD
674 ;;; that we modify to get the new slot. This is supplied when handling
675 ;;; included slots.
676 (defun parse-1-dsd (defstruct spec &optional
677                     (slot (make-defstruct-slot-description :name ""
678                                                            :index 0
679                                                            :type t)))
680   (multiple-value-bind (name default default-p type type-p read-only ro-p)
681       (typecase spec
682         (symbol
683          (when (keywordp spec)
684            (style-warn "Keyword slot name indicates probable syntax ~
685                         error in DEFSTRUCT: ~S."
686                        spec))
687          spec)
688         (cons
689          (destructuring-bind
690                (name
691                 &optional (default nil default-p)
692                 &key (type nil type-p) (read-only nil ro-p))
693              spec
694            (values name
695                    default default-p
696                    (uncross type) type-p
697                    read-only ro-p)))
698         (t (error 'simple-program-error
699                   :format-control "in DEFSTRUCT, ~S is not a legal slot ~
700                                    description."
701                   :format-arguments (list spec))))
702
703     (when (find name (dd-slots defstruct)
704                 :test #'string=
705                 :key (lambda (x) (symbol-name (dsd-name x))))
706       (error 'simple-program-error
707              :format-control "duplicate slot name ~S"
708              :format-arguments (list name)))
709     (setf (dsd-name slot) name)
710     (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list slot)))
711
712     (let ((accessor-name (if (dd-conc-name defstruct)
713                              (symbolicate (dd-conc-name defstruct) name)
714                              name))
715           (predicate-name (dd-predicate-name defstruct)))
716       (setf (dsd-accessor-name slot) accessor-name)
717       (when (eql accessor-name predicate-name)
718         ;; Some adventurous soul has named a slot so that its accessor
719         ;; collides with the structure type predicate. ANSI doesn't
720         ;; specify what to do in this case. As of 2001-09-04, Martin
721         ;; Atzmueller reports that CLISP and Lispworks both give
722         ;; priority to the slot accessor, so that the predicate is
723         ;; overwritten. We might as well do the same (as well as
724         ;; signalling a warning).
725         (style-warn
726          "~@<The structure accessor name ~S is the same as the name of the ~
727           structure type predicate. ANSI doesn't specify what to do in ~
728           this case. We'll overwrite the type predicate with the slot ~
729           accessor, but you can't rely on this behavior, so it'd be wise to ~
730           remove the ambiguity in your code.~@:>"
731          accessor-name)
732         (setf (dd-predicate-name defstruct) nil))
733       ;; FIXME: It would be good to check for name collisions here, but
734       ;; the easy check,
735       ;;x#-sb-xc-host
736       ;;x(when (and (fboundp accessor-name)
737       ;;x           (not (accessor-inherited-data accessor-name defstruct)))
738       ;;x  (style-warn "redefining ~S in DEFSTRUCT" accessor-name)))
739       ;; which was done until sbcl-0.8.11.18 or so, is wrong: it causes
740       ;; a warning at MACROEXPAND time, when instead the warning should
741       ;; occur not just because the code was constructed, but because it
742       ;; is actually compiled or loaded.
743       )
744
745     (when default-p
746       (setf (dsd-default slot) default))
747     (when type-p
748       (setf (dsd-type slot)
749             (if (eq (dsd-type slot) t)
750                 type
751                 `(and ,(dsd-type slot) ,type))))
752     (when ro-p
753       (if read-only
754           (setf (dsd-read-only slot) t)
755           (when (dsd-read-only slot)
756             (error "~@<The slot ~S is :READ-ONLY in superclass, and so must ~
757                        be :READ-ONLY in subclass.~:@>"
758                    (dsd-name slot)))))
759     slot))
760
761 ;;; When a value of type TYPE is stored in a structure, should it be
762 ;;; stored in a raw slot?  Return the matching RAW-SLOT-DATA structure
763 ;; if TYPE should be stored in a raw slot, or NIL if not.
764 (defun structure-raw-slot-data (type)
765   (multiple-value-bind (fixnum? fixnum-certain?)
766       (sb!xc:subtypep type 'fixnum)
767     ;; (The extra test for FIXNUM-CERTAIN? here is intended for
768     ;; bootstrapping the system. In particular, in sbcl-0.6.2, we set up
769     ;; LAYOUT before FIXNUM is defined, and so could bogusly end up
770     ;; putting INDEX-typed values into raw slots if we didn't test
771     ;; FIXNUM-CERTAIN?.)
772     (if (or fixnum? (not fixnum-certain?))
773         nil
774         (dolist (data *raw-slot-data-list*)
775           (when (sb!xc:subtypep type (raw-slot-data-raw-type data))
776             (return data))))))
777
778 ;;; Allocate storage for a DSD in DD. This is where we decide whether
779 ;;; a slot is raw or not. Raw objects are aligned on the unit of their size.
780 (defun allocate-1-slot (dd dsd)
781   (let ((rsd
782          (if (eq (dd-type dd) 'structure)
783              (structure-raw-slot-data (dsd-type dsd))
784              nil)))
785     (cond
786       ((null rsd)
787         (setf (dsd-index dsd) (dd-length dd))
788         (incf (dd-length dd)))
789       (t
790         (let* ((words (raw-slot-data-n-words rsd))
791                (alignment (raw-slot-data-alignment rsd))
792                (off (rem (dd-raw-length dd) alignment)))
793           (unless (zerop off)
794             (incf (dd-raw-length dd) (- alignment off)))
795           (setf (dsd-raw-type dsd) (raw-slot-data-raw-type rsd))
796           (setf (dsd-index dsd) (dd-raw-length dd))
797           (incf (dd-raw-length dd) words)))))
798   (values))
799
800 (defun typed-structure-info-or-lose (name)
801   (or (info :typed-structure :info name)
802       (error ":TYPE'd DEFSTRUCT ~S not found for inclusion." name)))
803
804 ;;; Process any included slots pretty much like they were specified.
805 ;;; Also inherit various other attributes.
806 (defun frob-dd-inclusion-stuff (dd)
807   (destructuring-bind (included-name &rest modified-slots) (dd-include dd)
808     (let* ((type (dd-type dd))
809            (included-structure
810             (if (dd-class-p dd)
811                 (layout-info (compiler-layout-or-lose included-name))
812                 (typed-structure-info-or-lose included-name))))
813
814       ;; checks on legality
815       (unless (and (eq type (dd-type included-structure))
816                    (type= (specifier-type (dd-element-type included-structure))
817                           (specifier-type (dd-element-type dd))))
818         (error ":TYPE option mismatch between structures ~S and ~S"
819                (dd-name dd) included-name))
820       (let ((included-classoid (find-classoid included-name nil)))
821         (when included-classoid
822           ;; It's not particularly well-defined to :INCLUDE any of the
823           ;; CMU CL INSTANCE weirdosities like CONDITION or
824           ;; GENERIC-FUNCTION, and it's certainly not ANSI-compliant.
825           (let* ((included-layout (classoid-layout included-classoid))
826                  (included-dd (layout-info included-layout)))
827             (when (and (dd-alternate-metaclass included-dd)
828                        ;; As of sbcl-0.pre7.73, anyway, STRUCTURE-OBJECT
829                        ;; is represented with an ALTERNATE-METACLASS. But
830                        ;; it's specifically OK to :INCLUDE (and PCL does)
831                        ;; so in this one case, it's OK to include
832                        ;; something with :ALTERNATE-METACLASS after all.
833                        (not (eql included-name 'structure-object)))
834               (error "can't :INCLUDE class ~S (has alternate metaclass)"
835                      included-name)))))
836
837       (incf (dd-length dd) (dd-length included-structure))
838       (when (dd-class-p dd)
839         (let ((mc (rest (dd-alternate-metaclass included-structure))))
840           (when (and mc (not (dd-alternate-metaclass dd)))
841             (setf (dd-alternate-metaclass dd)
842                   (cons included-name mc))))
843         (when (eq (dd-pure dd) :unspecified)
844           (setf (dd-pure dd) (dd-pure included-structure)))
845         (setf (dd-raw-length dd) (dd-raw-length included-structure)))
846
847       (setf (dd-inherited-accessor-alist dd)
848             (dd-inherited-accessor-alist included-structure))
849       (dolist (included-slot (dd-slots included-structure))
850         (let* ((included-name (dsd-name included-slot))
851                (modified (or (find included-name modified-slots
852                                    :key (lambda (x) (if (atom x) x (car x)))
853                                    :test #'string=)
854                              `(,included-name))))
855           ;; We stash away an alist of accessors to parents' slots
856           ;; that have already been created to avoid conflicts later
857           ;; so that structures with :INCLUDE and :CONC-NAME (and
858           ;; other edge cases) can work as specified.
859           (when (dsd-accessor-name included-slot)
860             ;; the "oldest" (i.e. highest up the tree of inheritance)
861             ;; will prevail, so don't push new ones on if they
862             ;; conflict.
863             (pushnew (cons (dsd-accessor-name included-slot)
864                            (dsd-index included-slot))
865                      (dd-inherited-accessor-alist dd)
866                      :test #'eq :key #'car))
867           (let ((new-slot (parse-1-dsd dd
868                                        modified
869                                        (copy-structure included-slot))))
870             (when (and (neq (dsd-type new-slot) (dsd-type included-slot))
871                        (not (sb!xc:subtypep (dsd-type included-slot)
872                                             (dsd-type new-slot)))
873                        (dsd-safe-p included-slot))
874               (setf (dsd-safe-p new-slot) nil)
875               ;; XXX: notify?
876               )))))))
877 \f
878 ;;;; various helper functions for setting up DEFSTRUCTs
879
880 ;;; This function is called at macroexpand time to compute the INHERITS
881 ;;; vector for a structure type definition.
882 (defun inherits-for-structure (info)
883   (declare (type defstruct-description info))
884   (let* ((include (dd-include info))
885          (superclass-opt (dd-alternate-metaclass info))
886          (super
887           (if include
888               (compiler-layout-or-lose (first include))
889               (classoid-layout (find-classoid
890                                 (or (first superclass-opt)
891                                     'structure-object))))))
892     (case (dd-name info)
893       ((ansi-stream)
894        (concatenate 'simple-vector
895                     (layout-inherits super)
896                     (vector super (classoid-layout (find-classoid 'stream)))))
897       ((fd-stream)
898        (concatenate 'simple-vector
899                     (layout-inherits super)
900                     (vector super
901                             (classoid-layout (find-classoid 'file-stream)))))
902       ((sb!impl::string-input-stream
903         sb!impl::string-output-stream
904         sb!impl::fill-pointer-output-stream)
905        (concatenate 'simple-vector
906                     (layout-inherits super)
907                     (vector super
908                             (classoid-layout (find-classoid 'string-stream)))))
909       (t (concatenate 'simple-vector
910                       (layout-inherits super)
911                       (vector super))))))
912
913 ;;; Do miscellaneous (LOAD EVAL) time actions for the structure
914 ;;; described by DD. Create the class and LAYOUT, checking for
915 ;;; incompatible redefinition. Define those functions which are
916 ;;; sufficiently stereotyped that we can implement them as standard
917 ;;; closures.
918 (defun %defstruct (dd inherits source-location)
919   (declare (type defstruct-description dd))
920
921   ;; We set up LAYOUTs even in the cross-compilation host.
922   (multiple-value-bind (classoid layout old-layout)
923       (ensure-structure-class dd inherits "current" "new")
924     (cond ((not old-layout)
925            (unless (eq (classoid-layout classoid) layout)
926              (register-layout layout)))
927           (t
928            (%redefine-defstruct classoid old-layout layout)
929            (let ((old-dd (layout-info old-layout)))
930              (when (defstruct-description-p old-dd)
931                (dolist (slot (dd-slots old-dd))
932                  (fmakunbound (dsd-accessor-name slot))
933                  (unless (dsd-read-only slot)
934                    (fmakunbound `(setf ,(dsd-accessor-name slot)))))))
935            (setq layout (classoid-layout classoid))))
936     (setf (find-classoid (dd-name dd)) classoid)
937
938     (sb!c:with-source-location (source-location)
939       (setf (layout-source-location layout) source-location))
940
941     ;; Various other operations only make sense on the target SBCL.
942     #-sb-xc-host
943     (%target-defstruct dd layout))
944
945   (values))
946 \f
947 ;;; Return a form describing the writable place used for this slot
948 ;;; in the instance named INSTANCE-NAME.
949 (defun %accessor-place-form (dd dsd instance-name)
950   (let (;; the operator that we'll use to access a typed slot
951         (ref (ecase (dd-type dd)
952                (structure '%instance-ref)
953                (list 'nth-but-with-sane-arg-order)
954                (vector 'aref)))
955         (raw-type (dsd-raw-type dsd)))
956     (if (eq raw-type t) ; if not raw slot
957         `(,ref ,instance-name ,(dsd-index dsd))
958         (let* ((raw-slot-data (find raw-type *raw-slot-data-list*
959                                     :key #'raw-slot-data-raw-type
960                                     :test #'equal))
961                (raw-slot-accessor (raw-slot-data-accessor-name raw-slot-data)))
962           `(,raw-slot-accessor ,instance-name ,(dsd-index dsd))))))
963
964 ;;; Return source transforms for the reader and writer functions of
965 ;;; the slot described by DSD. They should be inline expanded, but
966 ;;; source transforms work faster.
967 (defun slot-accessor-transforms (dd dsd)
968   (let ((accessor-place-form (%accessor-place-form dd dsd
969                                                    `(the ,(dd-name dd) instance)))
970         (dsd-type (dsd-type dsd))
971         (value-the (if (dsd-safe-p dsd) 'truly-the 'the)))
972     (values (sb!c:source-transform-lambda (instance)
973               `(,value-the ,dsd-type ,(subst instance 'instance
974                                              accessor-place-form)))
975             (sb!c:source-transform-lambda (new-value instance)
976               (destructuring-bind (accessor-name &rest accessor-args)
977                   accessor-place-form
978                 (once-only ((new-value new-value)
979                             (instance instance))
980                   `(,(info :setf :inverse accessor-name)
981                      ,@(subst instance 'instance accessor-args)
982                      (the ,dsd-type ,new-value))))))))
983
984 ;;; Return a LAMBDA form which can be used to set a slot.
985 (defun slot-setter-lambda-form (dd dsd)
986   ;; KLUDGE: Evaluating the results of SLOT-ACCESSOR-TRANSFORMS needs
987   ;; a lexenv.
988   (let ((sb!c:*lexenv* (if (boundp 'sb!c:*lexenv*)
989                            sb!c:*lexenv*
990                            (sb!c::make-null-lexenv))))
991     `(lambda (new-value instance)
992        ,(funcall (nth-value 1 (slot-accessor-transforms dd dsd))
993                  '(dummy new-value instance)))))
994
995 ;;; Blow away all the compiler info for the structure CLASS. Iterate
996 ;;; over this type, clearing the compiler structure type info, and
997 ;;; undefining all the associated functions.  If SUBCLASSES-P, also do
998 ;;; the same for subclasses.  FIXME: maybe rename UNDEFINE-FUN-NAME to
999 ;;; UNDECLARE-FUNCTION-NAME?
1000 (defun undeclare-structure (classoid subclasses-p)
1001   (let ((info (layout-info (classoid-layout classoid))))
1002     (when (defstruct-description-p info)
1003       (let ((type (dd-name info)))
1004         (remhash type *typecheckfuns*)
1005         (setf (info :type :compiler-layout type) nil)
1006         (undefine-fun-name (dd-copier-name info))
1007         (undefine-fun-name (dd-predicate-name info))
1008         (dolist (slot (dd-slots info))
1009           (let ((fun (dsd-accessor-name slot)))
1010             (unless (accessor-inherited-data fun info)
1011               (undefine-fun-name fun)
1012               (unless (dsd-read-only slot)
1013                 (undefine-fun-name `(setf ,fun)))))))
1014       ;; Clear out the SPECIFIER-TYPE cache so that subsequent
1015       ;; references are unknown types.
1016       (values-specifier-type-cache-clear)))
1017   (when subclasses-p
1018     (let ((subclasses (classoid-subclasses classoid)))
1019       (when subclasses
1020         (collect ((subs))
1021           (dohash ((classoid layout)
1022                    subclasses
1023                    :locked t)
1024             (declare (ignore layout))
1025             (undeclare-structure classoid nil)
1026             (subs (classoid-proper-name classoid)))
1027           ;; Is it really necessary to warn about
1028           ;; undeclaring functions for subclasses?
1029           (when (subs)
1030             (warn "undeclaring functions for old subclasses ~
1031                                of ~S:~%  ~S"
1032                   (classoid-name classoid)
1033                   (subs))))))))
1034
1035 ;;; core compile-time setup of any class with a LAYOUT, used even by
1036 ;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities
1037 (defun %compiler-set-up-layout (dd
1038                                 &optional
1039                                 ;; Several special cases
1040                                 ;; (STRUCTURE-OBJECT itself, and
1041                                 ;; structures with alternate
1042                                 ;; metaclasses) call this function
1043                                 ;; directly, and they're all at the
1044                                 ;; base of the instance class
1045                                 ;; structure, so this is a handy
1046                                 ;; default.  (But note
1047                                 ;; FUNCALLABLE-STRUCTUREs need
1048                                 ;; assistance here)
1049                                 (inherits (vector (find-layout t))))
1050
1051   (multiple-value-bind (classoid layout old-layout)
1052       (multiple-value-bind (clayout clayout-p)
1053           (info :type :compiler-layout (dd-name dd))
1054         (ensure-structure-class dd
1055                                 inherits
1056                                 (if clayout-p
1057                                     "The most recently compiled"
1058                                     "The current")
1059                                 "the most recently loaded"
1060                                 :compiler-layout clayout))
1061     (cond (old-layout
1062            (undeclare-structure (layout-classoid old-layout)
1063                                 (and (classoid-subclasses classoid)
1064                                      (not (eq layout old-layout))))
1065            (setf (layout-invalid layout) nil)
1066            ;; FIXME: it might be polite to hold onto old-layout and
1067            ;; restore it at the end of the file.  -- RMK 2008-09-19
1068            ;; (International Talk Like a Pirate Day).
1069            (warn "~@<Clobbering the compiler's idea of the layout of ~A.~:@>"
1070                  classoid))
1071           (t
1072            (unless (eq (classoid-layout classoid) layout)
1073              (register-layout layout :invalidate nil))
1074            (setf (find-classoid (dd-name dd)) classoid)))
1075
1076     ;; At this point the class should be set up in the INFO database.
1077     ;; But the logic that enforces this is a little tangled and
1078     ;; scattered, so it's not obvious, so let's check.
1079     (aver (find-classoid (dd-name dd) nil))
1080
1081     (setf (info :type :compiler-layout (dd-name dd)) layout))
1082
1083   (values))
1084
1085 ;;; Do (COMPILE LOAD EVAL)-time actions for the normal (not
1086 ;;; ALTERNATE-LAYOUT) DEFSTRUCT described by DD.
1087 (defun %compiler-defstruct (dd inherits)
1088   (declare (type defstruct-description dd))
1089
1090   (%compiler-set-up-layout dd inherits)
1091
1092   (let* ((dtype (dd-declarable-type dd)))
1093
1094     (let ((copier-name (dd-copier-name dd)))
1095       (when copier-name
1096         (sb!xc:proclaim `(ftype (sfunction (,dtype) ,dtype) ,copier-name))))
1097
1098     (let ((predicate-name (dd-predicate-name dd)))
1099       (when predicate-name
1100         (sb!xc:proclaim `(ftype (sfunction (t) boolean) ,predicate-name))
1101         ;; Provide inline expansion (or not).
1102         (ecase (dd-type dd)
1103           ((structure funcallable-structure)
1104            ;; Let the predicate be inlined.
1105            (setf (info :function :inline-expansion-designator predicate-name)
1106                  (lambda ()
1107                    `(lambda (x)
1108                       ;; This dead simple definition works because the
1109                       ;; type system knows how to generate inline type
1110                       ;; tests for instances.
1111                       (typep x ',(dd-name dd))))
1112                  (info :function :inlinep predicate-name)
1113                  :inline))
1114           ((list vector)
1115            ;; Just punt. We could provide inline expansions for :TYPE
1116            ;; LIST and :TYPE VECTOR predicates too, but it'd be a
1117            ;; little messier and we don't bother. (Does anyway use
1118            ;; typed DEFSTRUCTs at all, let alone for high
1119            ;; performance?)
1120            ))))
1121
1122     (dolist (dsd (dd-slots dd))
1123       (let* ((accessor-name (dsd-accessor-name dsd))
1124              (dsd-type (dsd-type dsd)))
1125         (when accessor-name
1126           (setf (info :function :structure-accessor accessor-name) dd)
1127           (let ((inherited (accessor-inherited-data accessor-name dd)))
1128             (cond
1129               ((not inherited)
1130                (multiple-value-bind (reader-designator writer-designator)
1131                    (slot-accessor-transforms dd dsd)
1132                  (sb!xc:proclaim `(ftype (sfunction (,dtype) ,dsd-type)
1133                                    ,accessor-name))
1134                  (setf (info :function :source-transform accessor-name)
1135                        reader-designator)
1136                  (unless (dsd-read-only dsd)
1137                    (let ((setf-accessor-name `(setf ,accessor-name)))
1138                      (sb!xc:proclaim
1139                       `(ftype (sfunction (,dsd-type ,dtype) ,dsd-type)
1140                         ,setf-accessor-name))
1141                      (setf (info :function :source-transform setf-accessor-name)
1142                            writer-designator)))))
1143               ((not (= (cdr inherited) (dsd-index dsd)))
1144                (style-warn "~@<Non-overwritten accessor ~S does not access ~
1145                             slot with name ~S (accessing an inherited slot ~
1146                             instead).~:@>"
1147                            accessor-name
1148                            (dsd-name dsd)))))))))
1149   (values))
1150 \f
1151 ;;;; redefinition stuff
1152
1153 ;;; Compare the slots of OLD and NEW, returning 3 lists of slot names:
1154 ;;;   1. Slots which have moved,
1155 ;;;   2. Slots whose type has changed,
1156 ;;;   3. Deleted slots.
1157 (defun compare-slots (old new)
1158   (let* ((oslots (dd-slots old))
1159          (nslots (dd-slots new))
1160          (onames (mapcar #'dsd-name oslots))
1161          (nnames (mapcar #'dsd-name nslots)))
1162     (collect ((moved)
1163               (retyped))
1164       (dolist (name (intersection onames nnames))
1165         (let ((os (find name oslots :key #'dsd-name :test #'string=))
1166               (ns (find name nslots :key #'dsd-name :test #'string=)))
1167           (unless (sb!xc:subtypep (dsd-type ns) (dsd-type os))
1168             (retyped name))
1169           (unless (and (= (dsd-index os) (dsd-index ns))
1170                        (eq (dsd-raw-type os) (dsd-raw-type ns)))
1171             (moved name))))
1172       (values (moved)
1173               (retyped)
1174               (set-difference onames nnames :test #'string=)))))
1175
1176 ;;; If we are redefining a structure with different slots than in the
1177 ;;; currently loaded version, give a warning and return true.
1178 (defun redefine-structure-warning (classoid old new)
1179   (declare (type defstruct-description old new)
1180            (type classoid classoid)
1181            (ignore classoid))
1182   (let ((name (dd-name new)))
1183     (multiple-value-bind (moved retyped deleted) (compare-slots old new)
1184       (when (or moved retyped deleted)
1185         (warn
1186          "incompatibly redefining slots of structure class ~S~@
1187           Make sure any uses of affected accessors are recompiled:~@
1188           ~@[  These slots were moved to new positions:~%    ~S~%~]~
1189           ~@[  These slots have new incompatible types:~%    ~S~%~]~
1190           ~@[  These slots were deleted:~%    ~S~%~]"
1191          name moved retyped deleted)
1192         t))))
1193
1194 ;;; This function is called when we are incompatibly redefining a
1195 ;;; structure CLASS to have the specified NEW-LAYOUT. We signal an
1196 ;;; error with some proceed options and return the layout that should
1197 ;;; be used.
1198 (defun %redefine-defstruct (classoid old-layout new-layout)
1199   (declare (type classoid classoid)
1200            (type layout old-layout new-layout))
1201   (let ((name (classoid-proper-name classoid)))
1202     (restart-case
1203         (error "~@<attempt to redefine the ~S class ~S incompatibly with the current definition~:@>"
1204                'structure-object
1205                name)
1206       (continue ()
1207        :report (lambda (s)
1208                  (format s
1209                          "~@<Use the new definition of ~S, invalidating ~
1210                           already-loaded code and instances.~@:>"
1211                          name))
1212        (register-layout new-layout))
1213       (recklessly-continue ()
1214        :report (lambda (s)
1215                  (format s
1216                          "~@<Use the new definition of ~S as if it were ~
1217                           compatible, allowing old accessors to use new ~
1218                           instances and allowing new accessors to use old ~
1219                           instances.~@:>"
1220                          name))
1221        ;; classic CMU CL warning: "Any old ~S instances will be in a bad way.
1222        ;; I hope you know what you're doing..."
1223        (register-layout new-layout
1224                         :invalidate nil
1225                         :destruct-layout old-layout))
1226       (clobber-it ()
1227        ;; FIXME: deprecated 2002-10-16, and since it's only interactive
1228        ;; hackery instead of a supported feature, can probably be deleted
1229        ;; in early 2003
1230        :report "(deprecated synonym for RECKLESSLY-CONTINUE)"
1231        (register-layout new-layout
1232                         :invalidate nil
1233                         :destruct-layout old-layout))))
1234   (values))
1235
1236 (declaim (inline dd-layout-length))
1237 (defun dd-layout-length (dd)
1238   (+ (dd-length dd) (dd-raw-length dd)))
1239
1240 (declaim (ftype (sfunction (defstruct-description) index) dd-instance-length))
1241 (defun dd-instance-length (dd)
1242   ;; Make sure the object ends at a two-word boundary.  Note that this does
1243   ;; not affect the amount of memory used, since the allocator would add the
1244   ;; same padding anyway.  However, raw slots are indexed from the length of
1245   ;; the object as indicated in the header, so the pad word needs to be
1246   ;; included in that length to guarantee proper alignment of raw double float
1247   ;; slots, necessary for (at least) the SPARC backend.
1248   (let ((layout-length (dd-layout-length dd)))
1249     (declare (index layout-length))
1250     (+ layout-length (mod (1+ layout-length) 2))))
1251
1252 ;;; This is called when we are about to define a structure class. It
1253 ;;; returns a (possibly new) class object and the layout which should
1254 ;;; be used for the new definition (may be the current layout, and
1255 ;;; also might be an uninstalled forward referenced layout.) The third
1256 ;;; value is true if this is an incompatible redefinition, in which
1257 ;;; case it is the old layout.
1258 (defun ensure-structure-class (info inherits old-context new-context
1259                                     &key compiler-layout)
1260   (multiple-value-bind (class old-layout)
1261       (destructuring-bind
1262           (&optional
1263            name
1264            (class 'structure-classoid)
1265            (constructor 'make-structure-classoid))
1266           (dd-alternate-metaclass info)
1267         (declare (ignore name))
1268         (insured-find-classoid (dd-name info)
1269                                (if (eq class 'structure-classoid)
1270                                    (lambda (x)
1271                                      (sb!xc:typep x 'structure-classoid))
1272                                    (lambda (x)
1273                                      (sb!xc:typep x (classoid-name (find-classoid class)))))
1274                                (fdefinition constructor)))
1275     (setf (classoid-direct-superclasses class)
1276           (case (dd-name info)
1277             ((ansi-stream
1278               fd-stream
1279               sb!impl::string-input-stream sb!impl::string-output-stream
1280               sb!impl::fill-pointer-output-stream)
1281              (list (layout-classoid (svref inherits (1- (length inherits))))
1282                    (layout-classoid (svref inherits (- (length inherits) 2)))))
1283             (t
1284              (list (layout-classoid
1285                     (svref inherits (1- (length inherits))))))))
1286     (let ((new-layout (make-layout :classoid class
1287                                    :inherits inherits
1288                                    :depthoid (length inherits)
1289                                    :length (dd-layout-length info)
1290                                    :n-untagged-slots (dd-raw-length info)
1291                                    :info info))
1292           (old-layout (or compiler-layout old-layout)))
1293       (cond
1294        ((not old-layout)
1295         (values class new-layout nil))
1296        (;; This clause corresponds to an assertion in REDEFINE-LAYOUT-WARNING
1297         ;; of classic CMU CL. I moved it out to here because it was only
1298         ;; exercised in this code path anyway. -- WHN 19990510
1299         (not (eq (layout-classoid new-layout) (layout-classoid old-layout)))
1300         (error "shouldn't happen: weird state of OLD-LAYOUT?"))
1301        ((not *type-system-initialized*)
1302         (setf (layout-info old-layout) info)
1303         (values class old-layout nil))
1304        ((redefine-layout-warning old-context
1305                                  old-layout
1306                                  new-context
1307                                  (layout-length new-layout)
1308                                  (layout-inherits new-layout)
1309                                  (layout-depthoid new-layout)
1310                                  (layout-n-untagged-slots new-layout))
1311         (values class new-layout old-layout))
1312        (t
1313         (let ((old-info (layout-info old-layout)))
1314           (typecase old-info
1315             ((or defstruct-description)
1316              (cond ((redefine-structure-warning class old-info info)
1317                     (values class new-layout old-layout))
1318                    (t
1319                     (setf (layout-info old-layout) info)
1320                     (values class old-layout nil))))
1321             (null
1322              (setf (layout-info old-layout) info)
1323              (values class old-layout nil))
1324             (t
1325              (error "shouldn't happen! strange thing in LAYOUT-INFO:~%  ~S"
1326                     old-layout)
1327              (values class new-layout old-layout)))))))))
1328 \f
1329 ;;; Return a list of pairs (name . index). Used for :TYPE'd
1330 ;;; constructors to find all the names that we have to splice in &
1331 ;;; where. Note that these types don't have a layout, so we can't look
1332 ;;; at LAYOUT-INHERITS.
1333 (defun find-name-indices (defstruct)
1334   (collect ((res))
1335     (let ((infos ()))
1336       (do ((info defstruct
1337                  (typed-structure-info-or-lose (first (dd-include info)))))
1338           ((not (dd-include info))
1339            (push info infos))
1340         (push info infos))
1341
1342       (let ((i 0))
1343         (dolist (info infos)
1344           (incf i (or (dd-offset info) 0))
1345           (when (dd-named info)
1346             (res (cons (dd-name info) i)))
1347           (setq i (dd-length info)))))
1348
1349     (res)))
1350 \f
1351 ;;; These functions are called to actually make a constructor after we
1352 ;;; have processed the arglist. The correct variant (according to the
1353 ;;; DD-TYPE) should be called. The function is defined with the
1354 ;;; specified name and arglist. VARS and TYPES are used for argument
1355 ;;; type declarations. VALUES are the values for the slots (in order.)
1356 ;;;
1357 ;;; This is split three ways because:
1358 ;;;   * LIST & VECTOR structures need "name" symbols stuck in at
1359 ;;;     various weird places, whereas STRUCTURE structures have
1360 ;;;     a LAYOUT slot.
1361 ;;;   * We really want to use LIST to make list structures, instead of
1362 ;;;     MAKE-LIST/(SETF ELT). (We can't in general use VECTOR in an
1363 ;;;     analogous way, since VECTOR makes a SIMPLE-VECTOR and vector-typed
1364 ;;;     structures can have arbitrary subtypes of VECTOR, not necessarily
1365 ;;;     SIMPLE-VECTOR.)
1366 ;;;   * STRUCTURE structures can have raw slots that must also be
1367 ;;;     allocated and indirectly referenced.
1368 (defun create-vector-constructor (dd cons-name arglist vars types values)
1369   (let ((temp (gensym))
1370         (etype (dd-element-type dd)))
1371     `(defun ,cons-name ,arglist
1372        (declare ,@(mapcar (lambda (var type) `(type (and ,type ,etype) ,var))
1373                           vars types))
1374        (let ((,temp (make-array ,(dd-length dd)
1375                                 :element-type ',(dd-element-type dd))))
1376          ,@(mapcar (lambda (x)
1377                      `(setf (aref ,temp ,(cdr x))  ',(car x)))
1378                    (find-name-indices dd))
1379          ,@(mapcar (lambda (dsd value)
1380                      (unless (eq value '.do-not-initialize-slot.)
1381                          `(setf (aref ,temp ,(dsd-index dsd)) ,value)))
1382                    (dd-slots dd) values)
1383          ,temp))))
1384 (defun create-list-constructor (dd cons-name arglist vars types values)
1385   (let ((vals (make-list (dd-length dd) :initial-element nil)))
1386     (dolist (x (find-name-indices dd))
1387       (setf (elt vals (cdr x)) `',(car x)))
1388     (loop for dsd in (dd-slots dd) and val in values do
1389       (setf (elt vals (dsd-index dsd))
1390             (if (eq val '.do-not-initialize-slot.) 0 val)))
1391     `(defun ,cons-name ,arglist
1392        (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types))
1393        (list ,@vals))))
1394 (defun create-structure-constructor (dd cons-name arglist vars types values)
1395   ;; The difference between the two implementations here is that on all
1396   ;; platforms we don't have the appropriate RAW-INSTANCE-INIT VOPS, which
1397   ;; must be able to deal with immediate values as well -- unlike
1398   ;; RAW-INSTANCE-SET VOPs, which never end up seeing immediate values. With
1399   ;; some additional cleverness we might manage without them and just a single
1400   ;; implementation here, though -- figure out a way to ensure that on those
1401   ;; platforms we always still get a non-immediate TN in every case...
1402   ;;
1403   ;; Until someone does that, this means that instances with raw slots can be
1404   ;; DX allocated only on platforms with those additional VOPs.
1405   #!+raw-instance-init-vops
1406   (let* ((slot-values nil)
1407          (slot-specs
1408           (mapcan (lambda (dsd value)
1409                     (unless (eq value '.do-not-initialize-slot.)
1410                       (push value slot-values)
1411                       (list (list* :slot (dsd-raw-type dsd) (dsd-index dsd)))))
1412                   (dd-slots dd)
1413                   values)))
1414     `(defun ,cons-name ,arglist
1415        (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types))
1416        (%make-structure-instance-macro ,dd ',slot-specs ,@(reverse slot-values))))
1417   #!-raw-instance-init-vops
1418   (let ((instance (gensym "INSTANCE")) slot-values slot-specs raw-slots raw-values)
1419     (mapc (lambda (dsd value)
1420             (unless (eq value '.do-not-initialize-slot.)
1421               (let ((raw-type (dsd-raw-type dsd)))
1422                 (cond ((eq t raw-type)
1423                        (push value slot-values)
1424                        (push (list* :slot raw-type (dsd-index dsd)) slot-specs))
1425                       (t
1426                        (push value raw-values)
1427                        (push dsd raw-slots))))))
1428           (dd-slots dd)
1429           values)
1430     `(defun ,cons-name ,arglist
1431        (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types))
1432        ,(if raw-slots
1433             `(let ((,instance (%make-structure-instance-macro ,dd ',slot-specs ,@slot-values)))
1434               ,@(mapcar (lambda (dsd value)
1435                           ;; (Note that we can't in general use the
1436                           ;; ordinary named slot setter function here
1437                           ;; because the slot might be :READ-ONLY, so we
1438                           ;; whip up new LAMBDA representations of slot
1439                           ;; setters for the occasion.)
1440                           `(,(slot-setter-lambda-form dd dsd) ,value ,instance))
1441                         raw-slots
1442                         raw-values)
1443               ,instance)
1444             `(%make-structure-instance-macro ,dd ',slot-specs ,@slot-values)))))
1445
1446 ;;; Create a default (non-BOA) keyword constructor.
1447 (defun create-keyword-constructor (defstruct creator)
1448   (declare (type function creator))
1449   (collect ((arglist (list '&key))
1450             (types)
1451             (vals))
1452     (dolist (slot (dd-slots defstruct))
1453       (let ((dum (gensym))
1454             (name (dsd-name slot)))
1455         (arglist `((,(keywordicate name) ,dum) ,(dsd-default slot)))
1456         (types (dsd-type slot))
1457         (vals dum)))
1458     (funcall creator
1459              defstruct (dd-default-constructor defstruct)
1460              (arglist) (vals) (types) (vals))))
1461
1462 ;;; Given a structure and a BOA constructor spec, call CREATOR with
1463 ;;; the appropriate args to make a constructor.
1464 (defun create-boa-constructor (defstruct boa creator)
1465   (declare (type function creator))
1466   (multiple-value-bind (req opt restp rest keyp keys allowp auxp aux)
1467       (parse-lambda-list (second boa))
1468     (collect ((arglist)
1469               (vars)
1470               (types)
1471               (skipped-vars))
1472       (labels ((get-slot (name)
1473                  (let ((res (find name (dd-slots defstruct)
1474                                   :test #'string=
1475                                   :key #'dsd-name)))
1476                    (if res
1477                        (values (dsd-type res) (dsd-default res))
1478                        (values t nil))))
1479                (do-default (arg)
1480                  (multiple-value-bind (type default) (get-slot arg)
1481                    (arglist `(,arg ,default))
1482                    (vars arg)
1483                    (types type))))
1484         (dolist (arg req)
1485           (arglist arg)
1486           (vars arg)
1487           (types (get-slot arg)))
1488
1489         (when opt
1490           (arglist '&optional)
1491           (dolist (arg opt)
1492             (cond ((consp arg)
1493                    (destructuring-bind
1494                          ;; FIXME: this shares some logic (though not
1495                          ;; code) with the &key case below (and it
1496                          ;; looks confusing) -- factor out the logic
1497                          ;; if possible. - CSR, 2002-04-19
1498                          (name
1499                           &optional
1500                           (def (nth-value 1 (get-slot name)))
1501                           (supplied-test nil supplied-test-p))
1502                        arg
1503                      (arglist `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)))
1504                      (vars name)
1505                      (types (get-slot name))))
1506                   (t
1507                    (do-default arg)))))
1508
1509         (when restp
1510           (arglist '&rest rest)
1511           (vars rest)
1512           (types 'list))
1513
1514         (when keyp
1515           (arglist '&key)
1516           (dolist (key keys)
1517             (if (consp key)
1518                 (destructuring-bind (wot
1519                                      &optional
1520                                      (def nil def-p)
1521                                      (supplied-test nil supplied-test-p))
1522                     key
1523                   (let ((name (if (consp wot)
1524                                   (destructuring-bind (key var) wot
1525                                     (declare (ignore key))
1526                                     var)
1527                                   wot)))
1528                     (multiple-value-bind (type slot-def)
1529                         (get-slot name)
1530                       (arglist `(,wot ,(if def-p def slot-def)
1531                                  ,@(if supplied-test-p `(,supplied-test) nil)))
1532                       (vars name)
1533                       (types type))))
1534                 (do-default key))))
1535
1536         (when allowp (arglist '&allow-other-keys))
1537
1538         (when auxp
1539           (arglist '&aux)
1540           (dolist (arg aux)
1541             (arglist arg)
1542             (if (proper-list-of-length-p arg 2)
1543               (let ((var (first arg)))
1544                 (vars var)
1545                 (types (get-slot var)))
1546               (skipped-vars (if (consp arg) (first arg) arg))))))
1547
1548       (funcall creator defstruct (first boa)
1549                (arglist) (vars) (types)
1550                (loop for slot in (dd-slots defstruct)
1551                      for name = (dsd-name slot)
1552                      collect (cond ((find name (skipped-vars) :test #'string=)
1553                                     ;; CLHS 3.4.6 Boa Lambda Lists
1554                                     (setf (dsd-safe-p slot) nil)
1555                                     '.do-not-initialize-slot.)
1556                                    ((or (find (dsd-name slot) (vars) :test #'string=)
1557                                         (let ((type (dsd-type slot)))
1558                                           (if (eq t type)
1559                                               (dsd-default slot)
1560                                               `(the ,type ,(dsd-default slot))))))))))))
1561
1562 ;;; Grovel the constructor options, and decide what constructors (if
1563 ;;; any) to create.
1564 (defun constructor-definitions (defstruct)
1565   (let ((no-constructors nil)
1566         (boas ())
1567         (defaults ())
1568         (creator (ecase (dd-type defstruct)
1569                    (structure #'create-structure-constructor)
1570                    (vector #'create-vector-constructor)
1571                    (list #'create-list-constructor))))
1572     (dolist (constructor (dd-constructors defstruct))
1573       (destructuring-bind (name &optional (boa-ll nil boa-p)) constructor
1574         (declare (ignore boa-ll))
1575         (cond ((not name) (setq no-constructors t))
1576               (boa-p (push constructor boas))
1577               (t (push name defaults)))))
1578
1579     (when no-constructors
1580       (when (or defaults boas)
1581         (error "(:CONSTRUCTOR NIL) combined with other :CONSTRUCTORs"))
1582       (return-from constructor-definitions ()))
1583
1584     (unless (or defaults boas)
1585       (push (symbolicate "MAKE-" (dd-name defstruct)) defaults))
1586
1587     (collect ((res) (names))
1588       (when defaults
1589         (let ((cname (first defaults)))
1590           (setf (dd-default-constructor defstruct) cname)
1591           (res (create-keyword-constructor defstruct creator))
1592           (names cname)
1593           (dolist (other-name (rest defaults))
1594             (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
1595             (names other-name))))
1596
1597       (dolist (boa boas)
1598         (res (create-boa-constructor defstruct boa creator))
1599         (names (first boa)))
1600
1601       (res `(declaim (ftype
1602                       (sfunction *
1603                                  ,(if (eq (dd-type defstruct) 'structure)
1604                                       (dd-name defstruct)
1605                                       '*))
1606                       ,@(names))))
1607
1608       (res))))
1609 \f
1610 ;;;; instances with ALTERNATE-METACLASS
1611 ;;;;
1612 ;;;; The CMU CL support for structures with ALTERNATE-METACLASS was a
1613 ;;;; fairly general extension embedded in the main DEFSTRUCT code, and
1614 ;;;; the result was an fairly impressive mess as ALTERNATE-METACLASS
1615 ;;;; extension mixed with ANSI CL generality (e.g. :TYPE and :INCLUDE)
1616 ;;;; and CMU CL implementation hairiness (esp. raw slots). This SBCL
1617 ;;;; version is much less ambitious, noticing that ALTERNATE-METACLASS
1618 ;;;; is only used to implement CONDITION, STANDARD-INSTANCE, and
1619 ;;;; GENERIC-FUNCTION, and defining a simple specialized
1620 ;;;; separate-from-DEFSTRUCT macro to provide only enough
1621 ;;;; functionality to support those.
1622 ;;;;
1623 ;;;; KLUDGE: The defining macro here is so specialized that it's ugly
1624 ;;;; in its own way. It also violates once-and-only-once by knowing
1625 ;;;; much about structures and layouts that is already known by the
1626 ;;;; main DEFSTRUCT macro. Hopefully it will go away presently
1627 ;;;; (perhaps when CL:CLASS and SB-PCL:CLASS meet) as per FIXME below.
1628 ;;;; -- WHN 2001-10-28
1629 ;;;;
1630 ;;;; FIXME: There seems to be no good reason to shoehorn CONDITION,
1631 ;;;; STANDARD-INSTANCE, and GENERIC-FUNCTION into mutated structures
1632 ;;;; instead of just implementing them as primitive objects. (This
1633 ;;;; reduced-functionality macro seems pretty close to the
1634 ;;;; functionality of DEFINE-PRIMITIVE-OBJECT..)
1635
1636 (defun make-dd-with-alternate-metaclass (&key (class-name (missing-arg))
1637                                               (superclass-name (missing-arg))
1638                                               (metaclass-name (missing-arg))
1639                                               (dd-type (missing-arg))
1640                                               metaclass-constructor
1641                                               slot-names)
1642   (let* ((dd (make-defstruct-description class-name))
1643          (conc-name (concatenate 'string (symbol-name class-name) "-"))
1644          (dd-slots (let ((reversed-result nil)
1645                          ;; The index starts at 1 for ordinary named
1646                          ;; slots because slot 0 is magical, used for
1647                          ;; the LAYOUT in CONDITIONs and
1648                          ;; FUNCALLABLE-INSTANCEs.  (This is the same
1649                          ;; in ordinary structures too: see (INCF
1650                          ;; DD-LENGTH) in
1651                          ;; PARSE-DEFSTRUCT-NAME-AND-OPTIONS).
1652                          (index 1))
1653                      (dolist (slot-name slot-names)
1654                        (push (make-defstruct-slot-description
1655                               :name slot-name
1656                               :index index
1657                               :accessor-name (symbolicate conc-name slot-name))
1658                              reversed-result)
1659                        (incf index))
1660                      (nreverse reversed-result))))
1661     (case dd-type
1662       ;; We don't support inheritance of alternate metaclass stuff,
1663       ;; and it's not a general-purpose facility, so sanity check our
1664       ;; own code.
1665       (structure
1666        (aver (eq superclass-name 't)))
1667       (funcallable-structure
1668        (aver (eq superclass-name 'function)))
1669       (t (bug "Unknown DD-TYPE in ALTERNATE-METACLASS: ~S" dd-type)))
1670     (setf (dd-alternate-metaclass dd) (list superclass-name
1671                                             metaclass-name
1672                                             metaclass-constructor)
1673           (dd-slots dd) dd-slots
1674           (dd-length dd) (1+ (length slot-names))
1675           (dd-type dd) dd-type)
1676     dd))
1677
1678 ;;; make !DEFSTRUCT-WITH-ALTERNATE-METACLASS compilable by the host
1679 ;;; lisp, installing the information we need to reason about the
1680 ;;; structures (layouts and classoids).
1681 ;;;
1682 ;;; FIXME: we should share the parsing and the DD construction between
1683 ;;; this and the cross-compiler version, but my brain was too small to
1684 ;;; get that right.  -- CSR, 2006-09-14
1685 #+sb-xc-host
1686 (defmacro !defstruct-with-alternate-metaclass
1687     (class-name &key
1688                 (slot-names (missing-arg))
1689                 (boa-constructor (missing-arg))
1690                 (superclass-name (missing-arg))
1691                 (metaclass-name (missing-arg))
1692                 (metaclass-constructor (missing-arg))
1693                 (dd-type (missing-arg))
1694                 predicate
1695                 (runtime-type-checks-p t))
1696
1697   (declare (type (and list (not null)) slot-names))
1698   (declare (type (and symbol (not null))
1699                  boa-constructor
1700                  superclass-name
1701                  metaclass-name
1702                  metaclass-constructor))
1703   (declare (type symbol predicate))
1704   (declare (type (member structure funcallable-structure) dd-type))
1705   (declare (ignore boa-constructor predicate runtime-type-checks-p))
1706
1707   (let* ((dd (make-dd-with-alternate-metaclass
1708               :class-name class-name
1709               :slot-names slot-names
1710               :superclass-name superclass-name
1711               :metaclass-name metaclass-name
1712               :metaclass-constructor metaclass-constructor
1713               :dd-type dd-type)))
1714     `(progn
1715
1716       (eval-when (:compile-toplevel :load-toplevel :execute)
1717         (%compiler-set-up-layout ',dd ',(inherits-for-structure dd))))))
1718
1719 (sb!xc:proclaim '(special *defstruct-hooks*))
1720
1721 (sb!xc:defmacro !defstruct-with-alternate-metaclass
1722     (class-name &key
1723                 (slot-names (missing-arg))
1724                 (boa-constructor (missing-arg))
1725                 (superclass-name (missing-arg))
1726                 (metaclass-name (missing-arg))
1727                 (metaclass-constructor (missing-arg))
1728                 (dd-type (missing-arg))
1729                 predicate
1730                 (runtime-type-checks-p t))
1731
1732   (declare (type (and list (not null)) slot-names))
1733   (declare (type (and symbol (not null))
1734                  boa-constructor
1735                  superclass-name
1736                  metaclass-name
1737                  metaclass-constructor))
1738   (declare (type symbol predicate))
1739   (declare (type (member structure funcallable-structure) dd-type))
1740
1741   (let* ((dd (make-dd-with-alternate-metaclass
1742               :class-name class-name
1743               :slot-names slot-names
1744               :superclass-name superclass-name
1745               :metaclass-name metaclass-name
1746               :metaclass-constructor metaclass-constructor
1747               :dd-type dd-type))
1748          (dd-slots (dd-slots dd))
1749          (dd-length (1+ (length slot-names)))
1750          (object-gensym (gensym "OBJECT"))
1751          (new-value-gensym (gensym "NEW-VALUE-"))
1752          (delayed-layout-form `(%delayed-get-compiler-layout ,class-name)))
1753     (multiple-value-bind (raw-maker-form raw-reffer-operator)
1754         (ecase dd-type
1755           (structure
1756            (values `(%make-structure-instance-macro ,dd nil)
1757                    '%instance-ref))
1758           (funcallable-structure
1759            (values `(let ((,object-gensym
1760                            (%make-funcallable-instance ,dd-length)))
1761                       (setf (%funcallable-instance-layout ,object-gensym)
1762                             ,delayed-layout-form)
1763                       ,object-gensym)
1764                    '%funcallable-instance-info)))
1765       `(progn
1766
1767          (eval-when (:compile-toplevel :load-toplevel :execute)
1768            (%compiler-set-up-layout ',dd ',(inherits-for-structure dd)))
1769
1770          ;; slot readers and writers
1771          (declaim (inline ,@(mapcar #'dsd-accessor-name dd-slots)))
1772          ,@(mapcar (lambda (dsd)
1773                      `(defun ,(dsd-accessor-name dsd) (,object-gensym)
1774                         ,@(when runtime-type-checks-p
1775                             `((declare (type ,class-name ,object-gensym))))
1776                         (,raw-reffer-operator ,object-gensym
1777                                               ,(dsd-index dsd))))
1778                    dd-slots)
1779          (declaim (inline ,@(mapcar (lambda (dsd)
1780                                       `(setf ,(dsd-accessor-name dsd)))
1781                                     dd-slots)))
1782          ,@(mapcar (lambda (dsd)
1783                      `(defun (setf ,(dsd-accessor-name dsd)) (,new-value-gensym
1784                                                               ,object-gensym)
1785                         ,@(when runtime-type-checks-p
1786                             `((declare (type ,class-name ,object-gensym))))
1787                         (setf (,raw-reffer-operator ,object-gensym
1788                                                     ,(dsd-index dsd))
1789                               ,new-value-gensym)))
1790                    dd-slots)
1791
1792          ;; constructor
1793          (defun ,boa-constructor ,slot-names
1794            (let ((,object-gensym ,raw-maker-form))
1795              ,@(mapcar (lambda (slot-name)
1796                          (let ((dsd (find (symbol-name slot-name) dd-slots
1797                                           :key (lambda (x)
1798                                                  (symbol-name (dsd-name x)))
1799                                           :test #'string=)))
1800                            ;; KLUDGE: bug 117 bogowarning.  Neither
1801                            ;; DECLAREing the type nor TRULY-THE cut
1802                            ;; the mustard -- it still gives warnings.
1803                            (enforce-type dsd defstruct-slot-description)
1804                            `(setf (,(dsd-accessor-name dsd) ,object-gensym)
1805                                   ,slot-name)))
1806                        slot-names)
1807              ,object-gensym))
1808
1809          ;; predicate
1810          ,@(when predicate
1811              ;; Just delegate to the compiler's type optimization
1812              ;; code, which knows how to generate inline type tests
1813              ;; for the whole CMU CL INSTANCE menagerie.
1814              `(defun ,predicate (,object-gensym)
1815                 (typep ,object-gensym ',class-name)))
1816
1817          (when (boundp '*defstruct-hooks*)
1818            (dolist (fun *defstruct-hooks*)
1819              (funcall fun (find-classoid ',(dd-name dd)))))))))
1820 \f
1821 ;;;; finalizing bootstrapping
1822
1823 ;;; Set up DD and LAYOUT for STRUCTURE-OBJECT class itself.
1824 ;;;
1825 ;;; Ordinary structure classes effectively :INCLUDE STRUCTURE-OBJECT
1826 ;;; when they have no explicit :INCLUDEs, so (1) it needs to be set up
1827 ;;; before we can define ordinary structure classes, and (2) it's
1828 ;;; special enough (and simple enough) that we just build it by hand
1829 ;;; instead of trying to generalize the ordinary DEFSTRUCT code.
1830 (defun !set-up-structure-object-class ()
1831   (let ((dd (make-defstruct-description 'structure-object)))
1832     (setf
1833      ;; Note: This has an ALTERNATE-METACLASS only because of blind
1834      ;; clueless imitation of the CMU CL code -- dunno if or why it's
1835      ;; needed. -- WHN
1836      (dd-alternate-metaclass dd) '(t)
1837      (dd-slots dd) nil
1838      (dd-length dd) 1
1839      (dd-type dd) 'structure)
1840     (%compiler-set-up-layout dd)))
1841 (!set-up-structure-object-class)
1842
1843 ;;; early structure predeclarations: Set up DD and LAYOUT for ordinary
1844 ;;; (non-ALTERNATE-METACLASS) structures which are needed early.
1845 (dolist (args
1846          '#.(sb-cold:read-from-file
1847              "src/code/early-defstruct-args.lisp-expr"))
1848   (let* ((dd (parse-defstruct-name-and-options-and-slot-descriptions
1849               (first args)
1850               (rest args)))
1851          (inherits (inherits-for-structure dd)))
1852     (%compiler-defstruct dd inherits)))
1853
1854 ;;; finding these beasts
1855 (defun find-defstruct-description (name &optional (errorp t))
1856   (let ((info (layout-info (classoid-layout (find-classoid name errorp)))))
1857     (if (defstruct-description-p info)
1858         info
1859         (when errorp
1860           (error "No DEFSTRUCT-DESCRIPTION for ~S." name)))))
1861
1862 (/show0 "code/defstruct.lisp end of file")