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 ;;; Delay looking for compiler-layout until the constructor is being
  30 ;;; compiled, since it doesn't exist until after the eval-when
  31 ;;; (compile) is compiled.
  32 (sb!xc:defmacro %delayed-get-compiler-layout (name)
  33   `',(compiler-layout-or-lose name))
  34
  35 ;;; Get layout right away.
  36 (sb!xc:defmacro compile-time-find-layout (name)
  37   (find-layout name))
  38
  39 ;;; re. %DELAYED-GET-COMPILER-LAYOUT and COMPILE-TIME-FIND-LAYOUT, above..
  40 ;;;
  41 ;;; FIXME: Perhaps both should be defined with DEFMACRO-MUNDANELY?
  42 ;;; FIXME: Do we really need both? If so, their names and implementations
  43 ;;; should probably be tweaked to be more parallel.
  44 \f
  45 ;;;; DEFSTRUCT-DESCRIPTION
  46
  47 ;;; The DEFSTRUCT-DESCRIPTION structure holds compile-time information
  48 ;;; about a structure type.
  49 (def!struct (defstruct-description
  50              (:conc-name dd-)
  51              (:make-load-form-fun just-dump-it-normally)
  52              #-sb-xc-host (:pure t)
  53              (:constructor make-defstruct-description (name)))
  54   ;; name of the structure
  55   (name (required-argument) :type symbol)
  56   ;; documentation on the structure
  57   (doc nil :type (or string null))
  58   ;; prefix for slot names. If NIL, none.
  59   (conc-name (symbolicate name "-") :type (or symbol null))
  60   ;; the name of the primary standard keyword constructor, or NIL if none
  61   (default-constructor nil :type (or symbol null))
  62   ;; all the explicit :CONSTRUCTOR specs, with name defaulted
  63   (constructors () :type list)
  64   ;; name of copying function
  65   (copier-name (symbolicate "COPY-" name) :type (or symbol null))
  66   ;; name of type predicate
  67   (predicate-name (symbolicate name "-P") :type (or symbol null))
  68   ;; the arguments to the :INCLUDE option, or NIL if no included
  69   ;; structure
  70   (include nil :type list)
  71   ;; The arguments to the :ALTERNATE-METACLASS option (an extension
  72   ;; used to define structure-like objects with an arbitrary
  73   ;; superclass and that may not have STRUCTURE-CLASS as the
  74   ;; metaclass.) Syntax is:
  75   ;;    (superclass-name metaclass-name metaclass-constructor)
  76   (alternate-metaclass nil :type list)
  77   ;; a list of DEFSTRUCT-SLOT-DESCRIPTION objects for all slots
  78   ;; (including included ones)
  79   (slots () :type list)
  80   ;; number of elements we've allocated (See also RAW-LENGTH.)
  81   (length 0 :type index)
  82   ;; General kind of implementation.
  83   (type 'structure :type (member structure vector list
  84                                  funcallable-structure))
  85
  86   ;; The next three slots are for :TYPE'd structures (which aren't
  87   ;; classes, DD-CLASS-P = NIL)
  88   ;;
  89   ;; vector element type
  90   (element-type t)
  91   ;; T if :NAMED was explicitly specified, NIL otherwise
  92   (named nil :type boolean)
  93   ;; any INITIAL-OFFSET option on this direct type
  94   (offset nil :type (or index null))
  95
  96   ;; the argument to the PRINT-FUNCTION option, or NIL if a
  97   ;; PRINT-FUNCTION option was given with no argument, or 0 if no
  98   ;; PRINT-FUNCTION option was given
  99   (print-function 0 :type (or cons symbol (member 0)))
 100   ;; the argument to the PRINT-OBJECT option, or NIL if a PRINT-OBJECT
 101   ;; option was given with no argument, or 0 if no PRINT-OBJECT option
 102   ;; was given
 103   (print-object 0 :type (or cons symbol (member 0)))
 104   ;; the index of the raw data vector and the number of words in it,
 105   ;; or NIL and 0 if not allocated (either because this structure
 106   ;; has no raw slots, or because we're still parsing it and haven't
 107   ;; run across any raw slots yet)
 108   (raw-index nil :type (or index null))
 109   (raw-length 0 :type index)
 110   ;; the value of the :PURE option, or :UNSPECIFIED. This is only
 111   ;; meaningful if DD-CLASS-P = T.
 112   (pure :unspecified :type (member t nil :substructure :unspecified)))
 113 (def!method print-object ((x defstruct-description) stream)
 114   (print-unreadable-object (x stream :type t)
 115     (prin1 (dd-name x) stream)))
 116
 117 ;;; Is DD a structure with a class?
 118 (defun dd-class-p (defstruct)
 119   (member (dd-type defstruct) '(structure funcallable-structure)))
 120
 121 (defun dd-layout-or-lose (dd)
 122   (compiler-layout-or-lose (dd-name dd)))
 123 \f
 124 ;;;; DEFSTRUCT-SLOT-DESCRIPTION
 125
 126 ;;; A DEFSTRUCT-SLOT-DESCRIPTION holds compile-time information about
 127 ;;; a structure slot.
 128 (def!struct (defstruct-slot-description
 129              (:make-load-form-fun just-dump-it-normally)
 130              (:conc-name dsd-)
 131              (:copier nil)
 132              #-sb-xc-host (:pure t))
 133   ;; string name of slot
 134   %name
 135   ;; its position in the implementation sequence
 136   (index (required-argument) :type fixnum)
 137   ;; the name of the accessor function
 138   ;;
 139   ;; (CMU CL had extra complexity here ("..or NIL if this accessor has
 140   ;; the same name as an inherited accessor (which we don't want to
 141   ;; shadow)") but that behavior doesn't seem to be specified by (or
 142   ;; even particularly consistent with) ANSI, so it's gone in SBCL.)
 143   (accessor-name nil)
 144   default                       ; default value expression
 145   (type t)                      ; declared type specifier
 146   ;; If this object does not describe a raw slot, this value is T.
 147   ;;
 148   ;; If this object describes a raw slot, this value is the type of the
 149   ;; value that the raw slot holds. Mostly. (KLUDGE: If the raw slot has
 150   ;; type (UNSIGNED-BYTE 32), the value here is UNSIGNED-BYTE, not
 151   ;; (UNSIGNED-BYTE 32).)
 152   (raw-type t :type (member t single-float double-float
 153                             #!+long-float long-float
 154                             complex-single-float complex-double-float
 155                             #!+long-float complex-long-float
 156                             unsigned-byte))
 157   (read-only nil :type (member t nil)))
 158 (def!method print-object ((x defstruct-slot-description) stream)
 159   (print-unreadable-object (x stream :type t)
 160     (prin1 (dsd-name x) stream)))
 161
 162 ;;; Return the name of a defstruct slot as a symbol. We store it as a
 163 ;;; string to avoid creating lots of worthless symbols at load time.
 164 (defun dsd-name (dsd)
 165   (intern (string (dsd-%name dsd))
 166           (if (dsd-accessor-name dsd)
 167               (symbol-package (dsd-accessor-name dsd))
 168               (sane-package))))
 169 \f
 170 ;;;; typed (non-class) structures
 171
 172 ;;; Return a type specifier we can use for testing :TYPE'd structures.
 173 (defun dd-lisp-type (defstruct)
 174   (ecase (dd-type defstruct)
 175     (list 'list)
 176     (vector `(simple-array ,(dd-element-type defstruct) (*)))))
 177 \f
 178 ;;;; checking structure types
 179
 180 ;;; Check that X is an instance of the named structure type.
 181 (defmacro %check-structure-type-from-name (x name)
 182   `(%check-structure-type-from-layout ,x ,(compiler-layout-or-lose name)))
 183
 184 ;;; Check that X is a structure of the type described by DD.
 185 (defmacro %check-structure-type-from-dd (x dd)
 186   (declare (type defstruct-description dd))
 187   (let ((class-name (dd-name dd)))
 188     (ecase (dd-type dd)
 189       ((structure funcallable-instance)
 190        `(%check-structure-type-from-layout
 191          ,x
 192          ,(compiler-layout-or-lose class-name)))
 193       ((vector)
 194        (let ((xx (gensym "X")))
 195          `(let ((,xx ,x))
 196             (declare (type vector ,xx))
 197             ,@(when (dd-named dd)
 198                 `((unless (eql (aref ,xx 0) ',class-name)
 199                     (error
 200                      'simple-type-error
 201                      :datum (aref ,xx 0)
 202                      :expected-type `(member ,class-name)
 203                      :format-control
 204                      "~@<missing name in instance of ~
 205                       VECTOR-typed structure ~S: ~2I~_S~:>"
 206                      :format-arguments (list ',class-name ,xx)))))))
 207        (values))
 208       ((list)
 209        (let ((xx (gensym "X")))
 210          `(let ((,xx ,x))
 211             (declare (type list ,xx))
 212             ,@(when (dd-named dd)
 213                 `((unless (eql (first ,xx) ',class-name)
 214                     (error
 215                      'simple-type-error
 216                      :datum (aref ,xx 0)
 217                      :expected-type `(member ,class-name)
 218                      :format-control
 219                      "~@<missing name in instance of LIST-typed structure ~S: ~
 220                       ~2I~_S~:>"
 221                      :format-arguments (list ',class-name ,xx)))))
 222             (values)))))))
 223
 224 ;;; Check that X is an instance of the structure class with layout LAYOUT.
 225 (defun %check-structure-type-from-layout (x layout)
 226   (unless (typep-to-layout x layout)
 227     (error 'simple-type-error
 228            :datum x
 229            :expected-type (sb!xc:class-name (layout-class layout))))
 230   (values))
 231 \f
 232 ;;;; shared machinery for inline and out-of-line slot accessor functions
 233
 234 ;;; an alist mapping from raw slot type to the operator used to access
 235 ;;; the raw slot
 236 ;;;
 237 ;;; FIXME: should be shared
 238 (eval-when (:compile-toplevel :load-toplevel :execute)
 239   (defvar *raw-type->rawref-fun-name*
 240     '(;; The compiler thinks that the raw data vector is a vector of
 241       ;; unsigned bytes, so if the slot we want to access actually *is*
 242       ;; an unsigned byte, it'll access the slot for us even if we don't
 243       ;; lie to it at all.
 244       (unsigned-byte . aref)
 245       ;; "A lie can travel halfway round the world while the truth is
 246       ;; putting on its shoes." -- Mark Twain
 247       (single-float . %raw-ref-single)
 248       (double-float . %raw-ref-double)
 249       #!+long-float (long-float . %raw-ref-long)
 250       (complex-single-float . %raw-ref-complex-single)
 251       (complex-double-float . %raw-ref-complex-double)
 252       #!+long-float (complex-long-float . %raw-ref-complex-long))))
 253 \f
 254 ;;;; generating out-of-line slot accessor functions
 255
 256 ;;; code generators for cases of DEFUN SLOT-ACCESSOR-FUNS
 257 ;;;
 258 ;;; (caution: These macros are sleazily specialized for use only in
 259 ;;; DEFUN SLOT-ACCESSOR-FUNS, not anywhere near fully parameterized:
 260 ;;; they grab symbols like INSTANCE and DSD-FOO automatically.
 261 ;;; Logically they probably belong in a MACROLET inside the DEFUN, but
 262 ;;; separating them like this makes it easier to experiment with them
 263 ;;; in the interpreter and reduces indentation hell.)
 264 ;;;
 265 ;;; FIXME: Ideally, the presence of the type checks in the functions
 266 ;;; here would be conditional on the optimization policy at the point
 267 ;;; of expansion of DEFSTRUCT. (For now we're just doing the simpler
 268 ;;; thing, putting in the type checks unconditionally.)
 269 (eval-when (:compile-toplevel)
 270
 271   ;; code shared between funcallable instance case and the ordinary
 272   ;; STRUCTURE-OBJECT case: Handle native structures with LAYOUTs and
 273   ;; (possibly) raw slots.
 274   (defmacro %native-slot-accessor-funs (dd-ref-fun-name)
 275     (let ((instance-type-check-form '(%check-structure-type-from-layout
 276                                       instance layout)))
 277       `(let ((layout (dd-layout-or-lose dd))
 278              (dsd-raw-type (dsd-raw-type dsd)))
 279          ;; Map over all the possible RAW-TYPEs, compiling a different
 280          ;; closure-function for each one, so that once the COND over
 281          ;; RAW-TYPEs happens (at the time closure is allocated) there
 282          ;; are no more decisions to be made and things execute
 283          ;; reasonably efficiently.
 284          (cond
 285           ;; nonraw slot case
 286           ((eql (dsd-raw-type dsd) t)
 287            (%slotplace-accessor-funs (,dd-ref-fun-name instance dsd-index)
 288                                      ,instance-type-check-form))
 289           ;; raw slot cases
 290           ,@(mapcar (lambda (raw-type-and-rawref-fun-name)
 291                       (destructuring-bind (raw-type . rawref-fun-name)
 292                           raw-type-and-rawref-fun-name
 293                         `((equal dsd-raw-type ',raw-type)
 294                           (let ((raw-index (dd-raw-index dd)))
 295                             (%slotplace-accessor-funs
 296                              (,rawref-fun-name (,dd-ref-fun-name instance
 297                                                                  raw-index)
 298                                                dsd-index)
 299                              ,instance-type-check-form)))))
 300                     *raw-type->rawref-fun-name*)))))
 301
 302   ;; code shared between DEFSTRUCT :TYPE LIST and
 303   ;; DEFSTRUCT :TYPE VECTOR cases: Handle the "typed structure" case,
 304   ;; with no LAYOUTs and no raw slots.
 305   (defmacro %colontyped-slot-accessor-funs () (error "stub"))
 306
 307   ;; the common structure of the raw-slot and not-raw-slot cases,
 308   ;; defined in terms of the writable SLOTPLACE. All possible flavors
 309   ;; of slot access should be able to pass through here.
 310   (defmacro %slotplace-accessor-funs (slotplace instance-type-check-form)
 311     (cl-user:/show slotplace instance-type-check-form)
 312     `(values (lambda (instance)
 313                ,instance-type-check-form
 314                ,slotplace)
 315              (let ((typecheckfun (typespec-typecheckfun dsd-type)))
 316                (lambda (new-value instance)
 317                  ,instance-type-check-form
 318                  (funcall typecheckfun new-value)
 319                  (setf ,slotplace new-value))))))
 320
 321 ;;; Return (VALUES SLOT-READER-FUN SLOT-WRITER-FUN).
 322 (defun slot-accessor-funs (dd dsd)
 323
 324   (let ((dsd-index (dsd-index dsd))
 325         (dsd-type (dsd-type dsd)))
 326
 327       (ecase (dd-type dd)
 328
 329         ;; native structures
 330         (structure (%native-slot-accessor-funs %instance-ref))
 331         (funcallable-structure (%native-slot-accessor-funs
 332                                 %funcallable-instance-info))
 333
 334         ;; structures with the :TYPE option
 335
 336         ;; FIXME: Worry about these later..
 337         #|
 338         ;; In :TYPE LIST and :TYPE VECTOR structures, ANSI specifies the
 339         ;; layout completely, so that raw slots are impossible.
 340         (list
 341          (dd-type-slot-accessor-funs nth-but-with-sane-arg-order
 342                                  `(%check-structure-type-from-dd
 343                                  :maybe-raw-p nil))
 344         (vector
 345          (dd-type-slot-accessor-funs aref
 346                                  :maybe-raw-p nil)))
 347         |#
 348         )))
 349 \f
 350 ;;;; REMOVEME: baby steps for the new out-of-line slot accessor functions
 351
 352 #|
 353 (in-package :sb-kernel)
 354
 355 (defstruct foo
 356   ;; vanilla slots
 357   a
 358   (b 5 :type package :read-only t)
 359   ;; raw slots
 360   (x 5 :type (unsigned-byte 32))
 361   (y 5.0 :type single-float :read-only t))
 362
 363 (load "/usr/stuff/sbcl/src/cold/chill")
 364 (cl-user:fasl "/usr/stuff/sbcl/src/code/typecheckfuns")
 365 (cl-user:fasl "/usr/stuff/outsacc")
 366
 367 (let* ((foo-layout (compiler-layout-or-lose 'foo))
 368        (foo-dd (layout-info foo-layout))
 369        (foo-dsds (dd-slots foo-dd))
 370        (foo-a-dsd (find "A" foo-dsds :test #'string= :key #'dsd-%name))
 371        (foo-b-dsd (find "B" foo-dsds :test #'string= :key #'dsd-%name))
 372        (foo-x-dsd (find "X" foo-dsds :test #'string= :key #'dsd-%name))
 373        (foo-y-dsd (find "X" foo-dsds :test #'string= :key #'dsd-%name))
 374        (foo (make-foo :a 'avalue
 375                       :b (find-package :cl)
 376                       :x 50)))
 377   (declare (type layout foo-layout))
 378   (declare (type defstruct-description foo-dd))
 379   (declare (type defstruct-slot-description foo-a-dsd))
 380
 381   (cl-user:/show foo)
 382
 383   (multiple-value-bind (foo-a-reader foo-a-writer)
 384       (slot-accessor-funs foo-dd foo-a-dsd)
 385
 386     ;; basic functionality
 387     (cl-user:/show foo-a-reader)
 388     (cl-user:/show (funcall foo-a-reader foo))
 389     (aver (eql (funcall foo-a-reader foo) 'avalue))
 390     (cl-user:/show foo-a-writer)
 391     (cl-user:/show (funcall foo-a-writer 'replacedavalue foo))
 392     (cl-user:/show "new" (funcall foo-a-reader foo))
 393     (aver (eql (funcall foo-a-reader foo) 'replacedavalue))
 394
 395     ;; type checks on FOO-ness of instance argument
 396     (cl-user:/show (nth-value 1 (ignore-errors (funcall foo-a-reader 3))))
 397     (aver (typep (nth-value 1 (ignore-errors (funcall foo-a-reader 3)))
 398                  'type-error))
 399     (aver (typep (nth-value 1 (ignore-errors (funcall foo-a-writer 3 4)))
 400                  'type-error)))
 401
 402   ;; type checks on written slot value
 403   (multiple-value-bind (foo-b-reader foo-b-writer)
 404       (slot-accessor-funs foo-dd foo-b-dsd)
 405     (cl-user:/show "old" (funcall foo-b-reader foo))
 406     (aver (not (eql (funcall foo-b-reader foo) (find-package :cl-user))))
 407     (funcall foo-b-writer (find-package :cl-user) foo)
 408     (cl-user:/show "new" (funcall foo-b-reader foo))
 409     (aver (eql (funcall foo-b-reader foo) (find-package :cl-user)))
 410     (aver (typep (nth-value 1 (ignore-errors (funcall foo-b-writer 5 foo)))
 411                  'type-error))
 412     (aver (eql (funcall foo-b-reader foo) (find-package :cl-user))))
 413
 414   ;; raw slots
 415   (cl-user:/describe foo-x-dsd)
 416   (cl-user:/describe foo-y-dsd)
 417   (multiple-value-bind (foo-x-reader foo-x-writer)
 418       (slot-accessor-funs foo-dd foo-x-dsd)
 419     (multiple-value-bind (foo-y-reader foo-y-writer)
 420         (slot-accessor-funs foo-dd foo-y-dsd)
 421
 422       ;; basic functionality for (UNSIGNED-BYTE 32) slot
 423       (cl-user:/show foo-x-reader)
 424       (cl-user:/show (funcall foo-x-reader foo))
 425       (aver (eql (funcall foo-x-reader foo) 50))
 426       (cl-user:/show foo-x-writer)
 427       (cl-user:/show (funcall foo-x-writer 14 foo))
 428       (cl-user:/show "new" (funcall foo-x-reader foo))
 429       (aver (eql (funcall foo-x-reader foo) 14)))
 430
 431       ;; type check for (UNSIGNED-BYTE 32) slot
 432       (/show "to do: type check X")
 433
 434       ;; SINGLE-FLOAT slot
 435       (/show "to do: Y")))
 436 |#
 437 \f
 438 ;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its
 439 ;;;; close personal friend SB!XC:DEFSTRUCT)
 440
 441 ;;; Return a list of forms to install PRINT and MAKE-LOAD-FORM funs,
 442 ;;; mentioning them in the expansion so that they can be compiled.
 443 (defun class-method-definitions (defstruct)
 444   (let ((name (dd-name defstruct)))
 445     `((locally
 446         ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant
 447         ;; class names which creates fast but non-cold-loadable,
 448         ;; non-compact code. In this context, we'd rather have
 449         ;; compact, cold-loadable code. -- WHN 19990928
 450         (declare (notinline sb!xc:find-class))
 451         ,@(let ((pf (dd-print-function defstruct))
 452                 (po (dd-print-object defstruct))
 453                 (x (gensym))
 454                 (s (gensym)))
 455             ;; Giving empty :PRINT-OBJECT or :PRINT-FUNCTION options
 456             ;; leaves PO or PF equal to NIL. The user-level effect is
 457             ;; to generate a PRINT-OBJECT method specialized for the type,
 458             ;; implementing the default #S structure-printing behavior.
 459             (when (or (eq pf nil) (eq po nil))
 460               (setf pf '(default-structure-print)
 461                     po 0))
 462             (flet (;; Given an arg from a :PRINT-OBJECT or :PRINT-FUNCTION
 463                    ;; option, return the value to pass as an arg to FUNCTION.
 464                    (farg (oarg)
 465                      (destructuring-bind (fun-name) oarg
 466                        fun-name)))
 467               (cond ((not (eql pf 0))
 468                      `((def!method print-object ((,x ,name) ,s)
 469                          (funcall #',(farg pf) ,x ,s *current-level*))))
 470                     ((not (eql po 0))
 471                      `((def!method print-object ((,x ,name) ,s)
 472                          (funcall #',(farg po) ,x ,s))))
 473                     (t nil))))
 474         ,@(let ((pure (dd-pure defstruct)))
 475             (cond ((eq pure t)
 476                    `((setf (layout-pure (class-layout
 477                                          (sb!xc:find-class ',name)))
 478                            t)))
 479                   ((eq pure :substructure)
 480                    `((setf (layout-pure (class-layout
 481                                          (sb!xc:find-class ',name)))
 482                            0)))))
 483         ,@(let ((def-con (dd-default-constructor defstruct)))
 484             (when (and def-con (not (dd-alternate-metaclass defstruct)))
 485               `((setf (structure-class-constructor (sb!xc:find-class ',name))
 486                       #',def-con))))))))
 487 ;;; FIXME: I really would like to make structure accessors less
 488 ;;; special, just ordinary inline functions. (Or perhaps inline
 489 ;;; functions with special compact implementations of their
 490 ;;; expansions, to avoid bloating the system.)
 491
 492 ;;; shared logic for CL:DEFSTRUCT and SB!XC:DEFSTRUCT
 493 (defmacro !expander-for-defstruct (name-and-options
 494                                    slot-descriptions
 495                                    expanding-into-code-for-xc-host-p)
 496   `(let ((name-and-options ,name-and-options)
 497          (slot-descriptions ,slot-descriptions)
 498          (expanding-into-code-for-xc-host-p
 499           ,expanding-into-code-for-xc-host-p))
 500      (let* ((dd (parse-defstruct-name-and-options-and-slot-descriptions
 501                  name-and-options
 502                  slot-descriptions))
 503             (name (dd-name dd)))
 504        (if (dd-class-p dd)
 505            (let ((inherits (inherits-for-structure dd)))
 506              `(progn
 507                 (eval-when (:compile-toplevel :load-toplevel :execute)
 508                   (%compiler-defstruct ',dd ',inherits))
 509                 (%defstruct ',dd ',inherits)
 510                 ,@(unless expanding-into-code-for-xc-host-p
 511                     (append (raw-accessor-definitions dd)
 512                             (predicate-definitions dd)
 513                             ;; FIXME: We've inherited from CMU CL nonparallel
 514                             ;; code for creating copiers for typed and untyped
 515                             ;; structures. This should be fixed.
 516                                         ;(copier-definition dd)
 517                             (constructor-definitions dd)
 518                             (class-method-definitions dd)))
 519                 ',name))
 520            `(progn
 521               (eval-when (:compile-toplevel :load-toplevel :execute)
 522                 (setf (info :typed-structure :info ',name) ',dd))
 523               ,@(unless expanding-into-code-for-xc-host-p
 524                   (append (typed-accessor-definitions dd)
 525                           (typed-predicate-definitions dd)
 526                           (typed-copier-definitions dd)
 527                           (constructor-definitions dd)))
 528               ',name)))))
 529
 530 (sb!xc:defmacro defstruct (name-and-options &rest slot-descriptions)
 531   #!+sb-doc
 532   "DEFSTRUCT {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)}
 533    Define the structure type Name. Instances are created by MAKE-<name>,
 534    which takes &KEY arguments allowing initial slot values to the specified.
 535    A SETF'able function <name>-<slot> is defined for each slot to read and
 536    write slot values. <name>-p is a type predicate.
 537
 538    Popular DEFSTRUCT options (see manual for others):
 539
 540    (:CONSTRUCTOR Name)
 541    (:PREDICATE Name)
 542        Specify the name for the constructor or predicate.
 543
 544    (:CONSTRUCTOR Name Lambda-List)
 545        Specify the name and arguments for a BOA constructor
 546        (which is more efficient when keyword syntax isn't necessary.)
 547
 548    (:INCLUDE Supertype Slot-Spec*)
 549        Make this type a subtype of the structure type Supertype. The optional
 550        Slot-Specs override inherited slot options.
 551
 552    Slot options:
 553
 554    :TYPE Type-Spec
 555        Asserts that the value of this slot is always of the specified type.
 556
 557    :READ-ONLY {T | NIL}
 558        If true, no setter function is defined for this slot."
 559     (!expander-for-defstruct name-and-options slot-descriptions nil))
 560 #+sb-xc-host
 561 (defmacro sb!xc:defstruct (name-and-options &rest slot-descriptions)
 562   #!+sb-doc
 563   "Cause information about a target structure to be built into the
 564   cross-compiler."
 565   (!expander-for-defstruct name-and-options slot-descriptions t))
 566 \f
 567 ;;;; functions to generate code for various parts of DEFSTRUCT definitions
 568
 569 ;;; Catch requests to mess up definitions in COMMON-LISP.
 570 #-sb-xc-host
 571 (eval-when (:compile-toplevel :load-toplevel :execute)
 572   (defun protect-cl (symbol)
 573     (when (and *cold-init-complete-p*
 574                (eq (symbol-package symbol) *cl-package*))
 575       (cerror "Go ahead and patch the system."
 576               "attempting to modify a symbol in the COMMON-LISP package: ~S"
 577               symbol))))
 578
 579 ;;; Return forms to define readers and writers for raw slots as inline
 580 ;;; functions.
 581 (defun raw-accessor-definitions (dd)
 582   (let* ((name (dd-name dd)))
 583     (collect ((res))
 584       (dolist (slot (dd-slots dd))
 585         (let ((slot-type (dsd-type slot))
 586               (accessor-name (dsd-accessor-name slot))
 587               (argname (gensym "ARG"))
 588               (nvname (gensym "NEW-VALUE-")))
 589           (multiple-value-bind (accessor offset data)
 590               (slot-accessor-form dd slot argname)
 591             ;; When accessor exists and is raw
 592             (when (and accessor-name
 593                        (not (eq accessor-name '%instance-ref)))
 594               (res `(declaim (inline ,accessor-name)))
 595               (res `(declaim (ftype (function (,name) ,slot-type)
 596                                     ,accessor-name)))
 597               (res `(defun ,accessor-name (,argname)
 598                       ;; Note: The DECLARE here might seem redundant
 599                       ;; with the DECLAIM FTYPE above, but it's not:
 600                       ;; If we're not at toplevel, the PROCLAIM inside
 601                       ;; the DECLAIM doesn't get executed until after
 602                       ;; this function is compiled.
 603                       (declare (type ,name ,argname))
 604                       (truly-the ,slot-type (,accessor ,data ,offset))))
 605               (unless (dsd-read-only slot)
 606                 (res `(declaim (inline (setf ,accessor-name))))
 607                 (res `(declaim (ftype (function (,slot-type ,name) ,slot-type)
 608                                       (setf ,accessor-name))))
 609                 ;; FIXME: I rewrote this somewhat from the CMU CL definition.
 610                 ;; Do some basic tests to make sure that reading and writing
 611                 ;; raw slots still works correctly.
 612                 (res `(defun (setf ,accessor-name) (,nvname ,argname)
 613                         (declare (type ,name ,argname))
 614                         (setf (,accessor ,data ,offset) ,nvname)
 615                         ,nvname)))))))
 616       (res))))
 617
 618 ;;; Return a list of forms which create a predicate for an untyped DEFSTRUCT.
 619 (defun predicate-definitions (dd)
 620   (let ((pred (dd-predicate-name dd))
 621         (argname (gensym)))
 622     (when pred
 623       (if (eq (dd-type dd) 'funcallable-structure)
 624           ;; FIXME: Why does this need to be special-cased for
 625           ;; FUNCALLABLE-STRUCTURE? CMU CL did it, but without explanation.
 626           ;; Could we do without it? What breaks if we do? Or could we
 627           ;; perhaps get by with no predicates for funcallable structures?
 628           `((declaim (inline ,pred))
 629             (defun ,pred (,argname) (typep ,argname ',(dd-name dd))))
 630           `((protect-cl ',pred)
 631             (declaim (inline ,pred))
 632             (defun ,pred (,argname)
 633               (declare (optimize (speed 3) (safety 0)))
 634               (typep-to-layout ,argname
 635                                (compile-time-find-layout ,(dd-name dd)))))))))
 636
 637 ;;; Return a list of forms which create a predicate function for a typed
 638 ;;; DEFSTRUCT.
 639 (defun typed-predicate-definitions (defstruct)
 640   (let ((name (dd-name defstruct))
 641         (predicate-name (dd-predicate-name defstruct))
 642         (argname (gensym)))
 643     (when (and predicate-name (dd-named defstruct))
 644       (let ((ltype (dd-lisp-type defstruct)))
 645         `((defun ,predicate-name (,argname)
 646             (and (typep ,argname ',ltype)
 647                  (eq (elt (the ,ltype ,argname)
 648                           ,(cdr (car (last (find-name-indices defstruct)))))
 649                      ',name))))))))
 650
 651 ;;; FIXME: We've inherited from CMU CL code to do typed structure copiers
 652 ;;; in a completely different way than untyped structure copiers. Fix this.
 653 ;;; (This function was my first attempt to fix this, but I stopped before
 654 ;;; figuring out how to install it completely and remove the parallel
 655 ;;; code which simply SETF's the FDEFINITION of the DD-COPIER name.
 656 #|
 657 ;;; Return the copier definition for an untyped DEFSTRUCT.
 658 (defun copier-definition (dd)
 659   (when (and (dd-copier dd)
 660              ;; FUNCALLABLE-STRUCTUREs don't need copiers, and this
 661              ;; implementation wouldn't work for them anyway, since
 662              ;; COPY-STRUCTURE returns a STRUCTURE-OBJECT and they're not.
 663              (not (eq (dd-type info) 'funcallable-structure)))
 664     (let ((argname (gensym)))
 665       `(progn
 666          (protect-cl ',(dd-copier dd))
 667          (defun ,(dd-copier dd) (,argname)
 668            (declare (type ,(dd-name dd) ,argname))
 669            (copy-structure ,argname))))))
 670 |#
 671
 672 ;;; Return a list of forms to create a copier function of a typed DEFSTRUCT.
 673 (defun typed-copier-definitions (defstruct)
 674   (when (dd-copier-name defstruct)
 675     `((setf (fdefinition ',(dd-copier-name defstruct)) #'copy-seq)
 676       (declaim (ftype function ,(dd-copier-name defstruct))))))
 677
 678 ;;; Return a list of function definitions for accessing and setting the
 679 ;;; slots of a typed DEFSTRUCT. The functions are proclaimed to be inline,
 680 ;;; and the types of their arguments and results are declared as well. We
 681 ;;; count on the compiler to do clever things with ELT.
 682 (defun typed-accessor-definitions (defstruct)
 683   (collect ((stuff))
 684     (let ((ltype (dd-lisp-type defstruct)))
 685       (dolist (slot (dd-slots defstruct))
 686         (let ((name (dsd-accessor-name slot))
 687               (index (dsd-index slot))
 688               (slot-type `(and ,(dsd-type slot)
 689                                ,(dd-element-type defstruct))))
 690           (stuff `(proclaim '(inline ,name (setf ,name))))
 691           ;; FIXME: The arguments in the next two DEFUNs should be
 692           ;; gensyms. (Otherwise e.g. if NEW-VALUE happened to be the
 693           ;; name of a special variable, things could get weird.)
 694           (stuff `(defun ,name (structure)
 695                     (declare (type ,ltype structure))
 696                     (the ,slot-type (elt structure ,index))))
 697           (unless (dsd-read-only slot)
 698             (stuff
 699              `(defun (setf ,name) (new-value structure)
 700                 (declare (type ,ltype structure) (type ,slot-type new-value))
 701                 (setf (elt structure ,index) new-value)))))))
 702     (stuff)))
 703 \f
 704 ;;;; parsing
 705
 706 (defun require-no-print-options-so-far (defstruct)
 707   (unless (and (eql (dd-print-function defstruct) 0)
 708                (eql (dd-print-object defstruct) 0))
 709     (error "No more than one of the following options may be specified:
 710   :PRINT-FUNCTION, :PRINT-OBJECT, :TYPE")))
 711
 712 ;;; Parse a single DEFSTRUCT option and store the results in DD.
 713 (defun parse-1-dd-option (option dd)
 714   (let ((args (rest option))
 715         (name (dd-name dd)))
 716     (case (first option)
 717       (:conc-name
 718        (destructuring-bind (conc-name) args
 719          (setf (dd-conc-name dd)
 720                (if (symbolp conc-name)
 721                    conc-name
 722                    (make-symbol (string conc-name))))))
 723       (:constructor
 724        (destructuring-bind (&optional (cname (symbolicate "MAKE-" name))
 725                                       &rest stuff)
 726            args
 727          (push (cons cname stuff) (dd-constructors dd))))
 728       (:copier
 729        (destructuring-bind (&optional (copier (symbolicate "COPY-" name)))
 730            args
 731          (setf (dd-copier-name dd) copier)))
 732       (:predicate
 733        (destructuring-bind (&optional (predicate-name (symbolicate name "-P")))
 734            args
 735          (setf (dd-predicate-name dd) predicate-name)))
 736       (:include
 737        (when (dd-include dd)
 738          (error "more than one :INCLUDE option"))
 739        (setf (dd-include dd) args))
 740       (:alternate-metaclass
 741        (setf (dd-alternate-metaclass dd) args))
 742       (:print-function
 743        (require-no-print-options-so-far dd)
 744        (setf (dd-print-function dd)
 745              (the (or symbol cons) args)))
 746       (:print-object
 747        (require-no-print-options-so-far dd)
 748        (setf (dd-print-object dd)
 749              (the (or symbol cons) args)))
 750       (:type
 751        (destructuring-bind (type) args
 752          (cond ((eq type 'funcallable-structure)
 753                 (setf (dd-type dd) type))
 754                ((member type '(list vector))
 755                 (setf (dd-element-type dd) t)
 756                 (setf (dd-type dd) type))
 757                ((and (consp type) (eq (first type) 'vector))
 758                 (destructuring-bind (vector vtype) type
 759                   (declare (ignore vector))
 760                   (setf (dd-element-type dd) vtype)
 761                   (setf (dd-type dd) 'vector)))
 762                (t
 763                 (error "~S is a bad :TYPE for DEFSTRUCT." type)))))
 764       (:named
 765        (error "The DEFSTRUCT option :NAMED takes no arguments."))
 766       (:initial-offset
 767        (destructuring-bind (offset) args
 768          (setf (dd-offset dd) offset)))
 769       (:pure
 770        (destructuring-bind (fun) args
 771          (setf (dd-pure dd) fun)))
 772       (t (error "unknown DEFSTRUCT option:~%  ~S" option)))))
 773
 774 ;;; Given name and options, return a DD holding that info.
 775 (eval-when (:compile-toplevel :load-toplevel :execute)
 776 (defun parse-defstruct-name-and-options (name-and-options)
 777   (destructuring-bind (name &rest options) name-and-options
 778     (aver name) ; A null name doesn't seem to make sense here.
 779     (let ((dd (make-defstruct-description name)))
 780       (dolist (option options)
 781         (cond ((consp option)
 782                (parse-1-dd-option option dd))
 783               ((eq option :named)
 784                (setf (dd-named dd) t))
 785               ((member option '(:constructor :copier :predicate :named))
 786                (parse-1-dd-option (list option) dd))
 787               (t
 788                (error "unrecognized DEFSTRUCT option: ~S" option))))
 789
 790       (case (dd-type dd)
 791         (structure
 792          (when (dd-offset dd)
 793            (error ":OFFSET can't be specified unless :TYPE is specified."))
 794          (unless (dd-include dd)
 795            (incf (dd-length dd))))
 796         (funcallable-structure)
 797         (t
 798          (require-no-print-options-so-far dd)
 799          (when (dd-named dd)
 800            (incf (dd-length dd)))
 801          (let ((offset (dd-offset dd)))
 802            (when offset (incf (dd-length dd) offset)))))
 803
 804       (when (dd-include dd)
 805         (do-dd-inclusion-stuff dd))
 806
 807       dd)))
 808
 809 ;;; Given name and options and slot descriptions (and possibly doc
 810 ;;; string at the head of slot descriptions) return a DD holding that
 811 ;;; info.
 812 (defun parse-defstruct-name-and-options-and-slot-descriptions
 813     (name-and-options slot-descriptions)
 814   (let ((result (parse-defstruct-name-and-options (if (atom name-and-options)
 815                                                       (list name-and-options)
 816                                                       name-and-options))))
 817     (when (stringp (car slot-descriptions))
 818       (setf (dd-doc result) (pop slot-descriptions)))
 819     (dolist (slot-description slot-descriptions)
 820       (allocate-1-slot result (parse-1-dsd result slot-description)))
 821     result))
 822
 823 ) ; EVAL-WHEN
 824 \f
 825 ;;;; stuff to parse slot descriptions
 826
 827 ;;; Parse a slot description for DEFSTRUCT, add it to the description
 828 ;;; and return it. If supplied, SLOT is a pre-initialized DSD
 829 ;;; that we modify to get the new slot. This is supplied when handling
 830 ;;; included slots.
 831 (defun parse-1-dsd (defstruct spec &optional
 832                     (slot (make-defstruct-slot-description :%name ""
 833                                                            :index 0
 834                                                            :type t)))
 835   (multiple-value-bind (name default default-p type type-p read-only ro-p)
 836       (cond
 837        ((listp spec)
 838         (destructuring-bind
 839             (name
 840              &optional (default nil default-p)
 841              &key (type nil type-p) (read-only nil ro-p))
 842             spec
 843           (values name
 844                   default default-p
 845                   (uncross type) type-p
 846                   read-only ro-p)))
 847        (t
 848         (when (keywordp spec)
 849           (style-warn "Keyword slot name indicates probable syntax ~
 850                        error in DEFSTRUCT: ~S."
 851                       spec))
 852         spec))
 853
 854     (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)
 855       (error 'simple-program-error
 856              :format-control "duplicate slot name ~S"
 857              :format-arguments (list name)))
 858     (setf (dsd-%name slot) (string name))
 859     (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list slot)))
 860
 861     (let ((accessor-name (symbolicate (or (dd-conc-name defstruct) "") name))
 862           (predicate-name (dd-predicate-name defstruct)))
 863       (setf (dsd-accessor-name slot) accessor-name)
 864       (when (eql accessor-name predicate-name)
 865         ;; Some adventurous soul has named a slot so that its accessor
 866         ;; collides with the structure type predicate. ANSI doesn't
 867         ;; specify what to do in this case. As of 2001-09-04, Martin
 868         ;; Atzmueller reports that CLISP and Lispworks both give
 869         ;; priority to the slot accessor, so that the predicate is
 870         ;; overwritten. We might as well do the same (as well as
 871         ;; signalling a warning).
 872         (style-warn
 873          "~@<The structure accessor name ~S is the same as the name of the ~
 874           structure type predicate. ANSI doesn't specify what to do in ~
 875           this case; this implementation chooses to overwrite the type ~
 876           predicate with the slot accessor.~@:>"
 877          accessor-name)
 878         (setf (dd-predicate-name defstruct) nil)))
 879
 880     (when default-p
 881       (setf (dsd-default slot) default))
 882     (when type-p
 883       (setf (dsd-type slot)
 884             (if (eq (dsd-type slot) t)
 885                 type
 886                 `(and ,(dsd-type slot) ,type))))
 887     (when ro-p
 888       (if read-only
 889           (setf (dsd-read-only slot) t)
 890           (when (dsd-read-only slot)
 891             (error "Slot ~S is :READ-ONLY in parent and must be :READ-ONLY in subtype ~S."
 892                    name
 893                    (dsd-name slot)))))
 894     slot))
 895
 896 ;;; When a value of type TYPE is stored in a structure, should it be
 897 ;;; stored in a raw slot? Return (VALUES RAW? RAW-TYPE WORDS), where
 898 ;;;   RAW? is true if TYPE should be stored in a raw slot.
 899 ;;;   RAW-TYPE is the raw slot type, or NIL if no raw slot.
 900 ;;;   WORDS is the number of words in the raw slot, or NIL if no raw slot.
 901 (defun structure-raw-slot-type-and-size (type)
 902   (/noshow "in STRUCTURE-RAW-SLOT-TYPE-AND-SIZE" type (sb!xc:subtypep type 'fixnum))
 903   (cond #+nil
 904         (;; FIXME: For now we suppress raw slots, since there are various
 905          ;; issues about the way that the cross-compiler handles them.
 906          (not (boundp '*dummy-placeholder-to-stop-compiler-warnings*))
 907          (values nil nil nil))
 908         ((and (sb!xc:subtypep type '(unsigned-byte 32))
 909               (multiple-value-bind (fixnum? fixnum-certain?)
 910                   (sb!xc:subtypep type 'fixnum)
 911                 (/noshow fixnum? fixnum-certain?)
 912                 ;; (The extra test for FIXNUM-CERTAIN? here is
 913                 ;; intended for bootstrapping the system. In
 914                 ;; particular, in sbcl-0.6.2, we set up LAYOUT before
 915                 ;; FIXNUM is defined, and so could bogusly end up
 916                 ;; putting INDEX-typed values into raw slots if we
 917                 ;; didn't test FIXNUM-CERTAIN?.)
 918                 (and (not fixnum?) fixnum-certain?)))
 919          (values t 'unsigned-byte 1))
 920         ((sb!xc:subtypep type 'single-float)
 921          (values t 'single-float 1))
 922         ((sb!xc:subtypep type 'double-float)
 923          (values t 'double-float 2))
 924         #!+long-float
 925         ((sb!xc:subtypep type 'long-float)
 926          (values t 'long-float #!+x86 3 #!+sparc 4))
 927         ((sb!xc:subtypep type '(complex single-float))
 928          (values t 'complex-single-float 2))
 929         ((sb!xc:subtypep type '(complex double-float))
 930          (values t 'complex-double-float 4))
 931         #!+long-float
 932         ((sb!xc:subtypep type '(complex long-float))
 933          (values t 'complex-long-float #!+x86 6 #!+sparc 8))
 934         (t
 935          (values nil nil nil))))
 936
 937 ;;; Allocate storage for a DSD in DD. This is where we decide whether
 938 ;;; a slot is raw or not. If raw, and we haven't allocated a raw-index
 939 ;;; yet for the raw data vector, then do it. Raw objects are aligned
 940 ;;; on the unit of their size.
 941 (defun allocate-1-slot (dd dsd)
 942   (multiple-value-bind (raw? raw-type words)
 943       (if (eq (dd-type dd) 'structure)
 944           (structure-raw-slot-type-and-size (dsd-type dsd))
 945           (values nil nil nil))
 946     (/noshow "ALLOCATE-1-SLOT" dsd raw? raw-type words)
 947     (cond ((not raw?)
 948            (setf (dsd-index dsd) (dd-length dd))
 949            (incf (dd-length dd)))
 950           (t
 951            (unless (dd-raw-index dd)
 952              (setf (dd-raw-index dd) (dd-length dd))
 953              (incf (dd-length dd)))
 954            (let ((off (rem (dd-raw-length dd) words)))
 955              (unless (zerop off)
 956                (incf (dd-raw-length dd) (- words off))))
 957            (setf (dsd-raw-type dsd) raw-type)
 958            (setf (dsd-index dsd) (dd-raw-length dd))
 959            (incf (dd-raw-length dd) words))))
 960   (values))
 961
 962 (defun typed-structure-info-or-lose (name)
 963   (or (info :typed-structure :info name)
 964       (error ":TYPE'd DEFSTRUCT ~S not found for inclusion." name)))
 965
 966 ;;; Process any included slots pretty much like they were specified.
 967 ;;; Also inherit various other attributes.
 968 (defun do-dd-inclusion-stuff (dd)
 969   (destructuring-bind (included-name &rest modified-slots) (dd-include dd)
 970     (let* ((type (dd-type dd))
 971            (included-structure
 972             (if (dd-class-p dd)
 973                 (layout-info (compiler-layout-or-lose included-name))
 974                 (typed-structure-info-or-lose included-name))))
 975       (unless (and (eq type (dd-type included-structure))
 976                    (type= (specifier-type (dd-element-type included-structure))
 977                           (specifier-type (dd-element-type dd))))
 978         (error ":TYPE option mismatch between structures ~S and ~S"
 979                (dd-name dd) included-name))
 980
 981       (incf (dd-length dd) (dd-length included-structure))
 982       (when (dd-class-p dd)
 983         (let ((mc (rest (dd-alternate-metaclass included-structure))))
 984           (when (and mc (not (dd-alternate-metaclass dd)))
 985             (setf (dd-alternate-metaclass dd)
 986                   (cons included-name mc))))
 987         (when (eq (dd-pure dd) :unspecified)
 988           (setf (dd-pure dd) (dd-pure included-structure)))
 989         (setf (dd-raw-index dd) (dd-raw-index included-structure))
 990         (setf (dd-raw-length dd) (dd-raw-length included-structure)))
 991
 992       (dolist (included-slot (dd-slots included-structure))
 993         (let* ((included-name (dsd-name included-slot))
 994                (modified (or (find included-name modified-slots
 995                                    :key #'(lambda (x) (if (atom x) x (car x)))
 996                                    :test #'string=)
 997                              `(,included-name))))
 998           (parse-1-dsd dd
 999                        modified
1000                        (copy-structure included-slot)))))))
1001 \f
1002 ;;;; various helper functions for setting up DEFSTRUCTs
1003
1004 ;;; This function is called at macroexpand time to compute the INHERITS
1005 ;;; vector for a structure type definition.
1006 (defun inherits-for-structure (info)
1007   (declare (type defstruct-description info))
1008   (let* ((include (dd-include info))
1009          (superclass-opt (dd-alternate-metaclass info))
1010          (super
1011           (if include
1012               (compiler-layout-or-lose (first include))
1013               (class-layout (sb!xc:find-class
1014                              (or (first superclass-opt)
1015                                  'structure-object))))))
1016     (if (eq (dd-name info) 'lisp-stream)
1017         ;; a hack to added the stream class as a mixin for LISP-STREAMs
1018         (concatenate 'simple-vector
1019                      (layout-inherits super)
1020                      (vector super
1021                              (class-layout (sb!xc:find-class 'stream))))
1022         (concatenate 'simple-vector
1023                      (layout-inherits super)
1024                      (vector super)))))
1025
1026 ;;; Do miscellaneous (LOAD EVAL) time actions for the structure
1027 ;;; described by DD. Create the class & LAYOUT, checking for
1028 ;;; incompatible redefinition. Define setters, accessors, copier,
1029 ;;; predicate, documentation, instantiate definition in load-time
1030 ;;; environment.
1031 (defun %defstruct (dd inherits)
1032   (declare (type defstruct-description dd))
1033   (remhash (dd-name dd) *typecheckfuns*)
1034   (multiple-value-bind (class layout old-layout)
1035       (ensure-structure-class dd inherits "current" "new")
1036     (cond ((not old-layout)
1037            (unless (eq (class-layout class) layout)
1038              (register-layout layout)))
1039           (t
1040            (let ((old-dd (layout-dd old-layout)))
1041              (when (defstruct-description-p old-dd)
1042                (dolist (slot (dd-slots old-dd))
1043                  (fmakunbound (dsd-accessor-name slot))
1044                  (unless (dsd-read-only slot)
1045                    (fmakunbound `(setf ,(dsd-accessor-name slot)))))))
1046            (%redefine-defstruct class old-layout layout)
1047            (setq layout (class-layout class))))
1048
1049     (setf (sb!xc:find-class (dd-name dd)) class)
1050
1051     ;; Set FDEFINITIONs for structure accessors, setters, predicates,
1052     ;; and copiers.
1053     #-sb-xc-host
1054     (unless (eq (dd-type dd) 'funcallable-structure)
1055
1056       (dolist (slot (dd-slots dd))
1057         (let ((dsd slot))
1058           (when (and (dsd-accessor-name slot)
1059                      (eq (dsd-raw-type slot) t))
1060             (protect-cl (dsd-accessor-name slot))
1061             (setf (symbol-function (dsd-accessor-name slot))
1062                   (structure-slot-getter layout dsd))
1063             (unless (dsd-read-only slot)
1064               (setf (fdefinition `(setf ,(dsd-accessor-name slot)))
1065                     (structure-slot-setter layout dsd))))))
1066
1067       ;; FIXME: Someday it'd probably be good to go back to using
1068       ;; closures for the out-of-line forms of structure accessors.
1069       #|
1070       (when (dd-predicate dd)
1071         (protect-cl (dd-predicate dd))
1072         (setf (symbol-function (dd-predicate dd))
1073               #'(lambda (object)
1074                   (declare (optimize (speed 3) (safety 0)))
1075                   (typep-to-layout object layout))))
1076       |#
1077
1078       (when (dd-copier-name dd)
1079         (protect-cl (dd-copier-name dd))
1080         (setf (symbol-function (dd-copier-name dd))
1081               #'(lambda (structure)
1082                   (declare (optimize (speed 3) (safety 0)))
1083                   (flet ((layout-test (structure)
1084                            (typep-to-layout structure layout)))
1085                     (unless (layout-test structure)
1086                       (error 'simple-type-error
1087                              :datum structure
1088                              :expected-type '(satisfies layout-test)
1089                              :format-control
1090                              "Structure for copier is not a ~S:~% ~S"
1091                              :format-arguments
1092                              (list (sb!xc:class-name (layout-class layout))
1093                                    structure))))
1094                   (copy-structure structure))))))
1095
1096   (when (dd-doc dd)
1097     (setf (fdocumentation (dd-name dd) 'type)
1098           (dd-doc dd)))
1099
1100   (values))
1101
1102 ;;; Return a form describing the writable place used for this slot
1103 ;;; in the instance named INSTANCE-NAME.
1104 (defun %accessor-place-form (dd dsd instance-name)
1105   (let (;; the operator that we'll use to access a typed slot or, in
1106         ;; the case of a raw slot, to read the vector of raw slots
1107         (ref (ecase (dd-type dd)
1108                (structure '%instance-ref)
1109                (funcallable-structure '%funcallable-instance-info)
1110                (list 'nth-but-with-sane-arg-order)
1111                (vector 'aref)))
1112         (raw-type (dsd-raw-type dsd)))
1113     (if (eq raw-type t) ; if not raw slot
1114         `(,ref ,instance-name ,(dsd-index dsd))
1115         (let (;; the operator that we'll use to access one value in
1116               ;; the raw data vector
1117               (rawref (ecase raw-type
1118                         ;; The compiler thinks that the raw data
1119                         ;; vector is a vector of unsigned bytes, so if
1120                         ;; the slot we want to access actually *is* an
1121                         ;; unsigned byte, it'll access the slot for
1122                         ;; us even if we don't lie to it at all.
1123                         (unsigned-byte 'aref)
1124                         ;; "A lie can travel halfway round the world while
1125                         ;; the truth is putting on its shoes." -- Mark Twain
1126                         (single-float '%raw-ref-single)
1127                         (double-float '%raw-ref-double)
1128                         #!+long-float (long-float '%raw-ref-long)
1129                         (complex-single-float '%raw-ref-complex-single)
1130                         (complex-double-float '%raw-ref-complex-double)
1131                         #!+long-float (complex-long-float
1132                                        '%raw-ref-complex-long))))
1133           `(,rawref (,ref ,instance-name ,(dd-raw-index dd))
1134                     ,(dsd-index dsd))))))
1135
1136 ;;; Return inline expansion designators (i.e. values suitable for
1137 ;;; (INFO :FUNCTION :INLINE-EXPANSSION-DESIGNATOR ..)) for the reader
1138 ;;; and writer functions of the slot described by DSD.
1139 (defun accessor-inline-expansion-designators (dd dsd)
1140   (values (lambda ()
1141             `(lambda (instance)
1142                (declare (type ,(dd-name dd) instance))
1143                (truly-the ,(dsd-type dsd)
1144                           ,(%accessor-place-form dd dsd 'instance))))
1145           (lambda ()
1146             `(lambda (new-value instance)
1147                (declare (type ,(dsd-type dsd) new-value))
1148                (declare (type ,(dd-name dd) structure-object))
1149                (setf ,(%accessor-place-form dd dsd 'instance) new-value)))))
1150
1151 ;;; Do (COMPILE LOAD EVAL)-time actions for the defstruct described by DD.
1152 (defun %compiler-defstruct (dd inherits)
1153   (declare (type defstruct-description dd))
1154   (multiple-value-bind (class layout old-layout)
1155       (multiple-value-bind (clayout clayout-p)
1156           (info :type :compiler-layout (dd-name dd))
1157         (ensure-structure-class dd
1158                                 inherits
1159                                 (if clayout-p "previously compiled" "current")
1160                                 "compiled"
1161                                 :compiler-layout clayout))
1162     (cond (old-layout
1163            (undefine-structure (layout-class old-layout))
1164            (when (and (class-subclasses class)
1165                       (not (eq layout old-layout)))
1166              (collect ((subs))
1167                       (dohash (class layout (class-subclasses class))
1168                         (declare (ignore layout))
1169                         (undefine-structure class)
1170                         (subs (class-proper-name class)))
1171                       (when (subs)
1172                         (warn "removing old subclasses of ~S:~%  ~S"
1173                               (sb!xc:class-name class)
1174                               (subs))))))
1175           (t
1176            (unless (eq (class-layout class) layout)
1177              (register-layout layout :invalidate nil))
1178            (setf (sb!xc:find-class (dd-name dd)) class)))
1179
1180     (setf (info :type :compiler-layout (dd-name dd)) layout))
1181
1182   (let* ((dd-name (dd-name dd))
1183          (class (sb!xc:find-class dd-name)))
1184
1185     (let ((copier-name (dd-copier-name dd)))
1186       (when copier-name
1187         (sb!xc:proclaim `(ftype (function (,dd-name) ,dd-name) ,copier-name))))
1188
1189     (let ((predicate-name (dd-predicate-name dd)))
1190       (when predicate-name
1191         (sb!xc:proclaim `(ftype (function (t) t) ,predicate-name))))
1192
1193     (dolist (dsd (dd-slots dd))
1194       (let* ((accessor-name (dsd-accessor-name dsd))
1195              (dsd-type (dsd-type dsd)))
1196         (when accessor-name
1197           (multiple-value-bind (reader-designator writer-designator)
1198               (accessor-inline-expansion-designators dd dsd)
1199             (sb!xc:proclaim `(ftype (function (,dd-name) ,dsd-type)
1200                                     ,accessor-name))
1201             (setf (info :function
1202                         :inline-expansion-designator
1203                         accessor-name)
1204                   reader-designator
1205                   (info :function :inlinep accessor-name)
1206                   :inline)
1207             (unless (dsd-read-only dsd)
1208               (let ((setf-accessor-name `(setf ,accessor-name)))
1209                 (sb!xc:proclaim
1210                  `(ftype (function (,dsd-type ,dd-name) ,dsd-type)
1211                          ,setf-accessor-name))
1212                 (setf (info :function
1213                             :inline-expansion-designator
1214                             setf-accessor-name)
1215                       writer-designator
1216                       (info :function :inlinep setf-accessor-name)
1217                       :inline))))))))
1218
1219   (values))
1220 \f
1221 ;;;; redefinition stuff
1222
1223 ;;; Compare the slots of OLD and NEW, returning 3 lists of slot names:
1224 ;;;   1. Slots which have moved,
1225 ;;;   2. Slots whose type has changed,
1226 ;;;   3. Deleted slots.
1227 (defun compare-slots (old new)
1228   (let* ((oslots (dd-slots old))
1229          (nslots (dd-slots new))
1230          (onames (mapcar #'dsd-name oslots))
1231          (nnames (mapcar #'dsd-name nslots)))
1232     (collect ((moved)
1233               (retyped))
1234       (dolist (name (intersection onames nnames))
1235         (let ((os (find name oslots :key #'dsd-name))
1236               (ns (find name nslots :key #'dsd-name)))
1237           (unless (subtypep (dsd-type ns) (dsd-type os))
1238             (/noshow "found retyped slots" ns os (dsd-type ns) (dsd-type os))
1239             (retyped name))
1240           (unless (and (= (dsd-index os) (dsd-index ns))
1241                        (eq (dsd-raw-type os) (dsd-raw-type ns)))
1242             (moved name))))
1243       (values (moved)
1244               (retyped)
1245               (set-difference onames nnames)))))
1246
1247 ;;; If we are redefining a structure with different slots than in the
1248 ;;; currently loaded version, give a warning and return true.
1249 (defun redefine-structure-warning (class old new)
1250   (declare (type defstruct-description old new)
1251            (type sb!xc:class class)
1252            (ignore class))
1253   (let ((name (dd-name new)))
1254     (multiple-value-bind (moved retyped deleted) (compare-slots old new)
1255       (when (or moved retyped deleted)
1256         (warn
1257          "incompatibly redefining slots of structure class ~S~@
1258           Make sure any uses of affected accessors are recompiled:~@
1259           ~@[  These slots were moved to new positions:~%    ~S~%~]~
1260           ~@[  These slots have new incompatible types:~%    ~S~%~]~
1261           ~@[  These slots were deleted:~%    ~S~%~]"
1262          name moved retyped deleted)
1263         t))))
1264
1265 ;;; This function is called when we are incompatibly redefining a
1266 ;;; structure CLASS to have the specified NEW-LAYOUT. We signal an
1267 ;;; error with some proceed options and return the layout that should
1268 ;;; be used.
1269 (defun %redefine-defstruct (class old-layout new-layout)
1270   (declare (type sb!xc:class class) (type layout old-layout new-layout))
1271   (let ((name (class-proper-name class)))
1272     (restart-case
1273         (error "redefining class ~S incompatibly with the current definition"
1274                name)
1275       (continue ()
1276         :report "Invalidate current definition."
1277         (warn "Previously loaded ~S accessors will no longer work." name)
1278         (register-layout new-layout))
1279       (clobber-it ()
1280         :report "Smash current layout, preserving old code."
1281         (warn "Any old ~S instances will be in a bad way.~@
1282                I hope you know what you're doing..."
1283               name)
1284         (register-layout new-layout :invalidate nil
1285                          :destruct-layout old-layout))))
1286   (values))
1287
1288 ;;; This is called when we are about to define a structure class. It
1289 ;;; returns a (possibly new) class object and the layout which should
1290 ;;; be used for the new definition (may be the current layout, and
1291 ;;; also might be an uninstalled forward referenced layout.) The third
1292 ;;; value is true if this is an incompatible redefinition, in which
1293 ;;; case it is the old layout.
1294 (defun ensure-structure-class (info inherits old-context new-context
1295                                     &key compiler-layout)
1296   (multiple-value-bind (class old-layout)
1297       (destructuring-bind
1298           (&optional
1299            name
1300            (class 'sb!xc:structure-class)
1301            (constructor 'make-structure-class))
1302           (dd-alternate-metaclass info)
1303         (declare (ignore name))
1304         (insured-find-class (dd-name info)
1305                             (if (eq class 'sb!xc:structure-class)
1306                               (lambda (x)
1307                                 (typep x 'sb!xc:structure-class))
1308                               (lambda (x)
1309                                 (sb!xc:typep x (sb!xc:find-class class))))
1310                             (fdefinition constructor)))
1311     (setf (class-direct-superclasses class)
1312           (if (eq (dd-name info) 'lisp-stream)
1313               ;; a hack to add STREAM as a superclass mixin to LISP-STREAMs
1314               (list (layout-class (svref inherits (1- (length inherits))))
1315                     (layout-class (svref inherits (- (length inherits) 2))))
1316               (list (layout-class (svref inherits (1- (length inherits)))))))
1317     (let ((new-layout (make-layout :class class
1318                                    :inherits inherits
1319                                    :depthoid (length inherits)
1320                                    :length (dd-length info)
1321                                    :info info))
1322           (old-layout (or compiler-layout old-layout)))
1323       (cond
1324        ((not old-layout)
1325         (values class new-layout nil))
1326        (;; This clause corresponds to an assertion in REDEFINE-LAYOUT-WARNING
1327         ;; of classic CMU CL. I moved it out to here because it was only
1328         ;; exercised in this code path anyway. -- WHN 19990510
1329         (not (eq (layout-class new-layout) (layout-class old-layout)))
1330         (error "shouldn't happen: weird state of OLD-LAYOUT?"))
1331        ((not *type-system-initialized*)
1332         (setf (layout-info old-layout) info)
1333         (values class old-layout nil))
1334        ((redefine-layout-warning old-context
1335                                  old-layout
1336                                  new-context
1337                                  (layout-length new-layout)
1338                                  (layout-inherits new-layout)
1339                                  (layout-depthoid new-layout))
1340         (values class new-layout old-layout))
1341        (t
1342         (let ((old-info (layout-info old-layout)))
1343           (typecase old-info
1344             ((or defstruct-description)
1345              (cond ((redefine-structure-warning class old-info info)
1346                     (values class new-layout old-layout))
1347                    (t
1348                     (setf (layout-info old-layout) info)
1349                     (values class old-layout nil))))
1350             (null
1351              (setf (layout-info old-layout) info)
1352              (values class old-layout nil))
1353             (t
1354              (error "shouldn't happen! strange thing in LAYOUT-INFO:~%  ~S"
1355                     old-layout)
1356              (values class new-layout old-layout)))))))))
1357
1358 ;;; Blow away all the compiler info for the structure CLASS. Iterate
1359 ;;; over this type, clearing the compiler structure type info, and
1360 ;;; undefining all the associated functions.
1361 (defun undefine-structure (class)
1362   (let ((info (layout-info (class-layout class))))
1363     (when (defstruct-description-p info)
1364       (let ((type (dd-name info)))
1365         (setf (info :type :compiler-layout type) nil)
1366         (undefine-fun-name (dd-copier-name info))
1367         (undefine-fun-name (dd-predicate-name info))
1368         (dolist (slot (dd-slots info))
1369           (let ((fun (dsd-accessor-name slot)))
1370             (undefine-fun-name fun)
1371             (unless (dsd-read-only slot)
1372               (undefine-fun-name `(setf ,fun))))))
1373       ;; Clear out the SPECIFIER-TYPE cache so that subsequent
1374       ;; references are unknown types.
1375       (values-specifier-type-cache-clear)))
1376   (values))
1377 \f
1378 ;;; Return a list of pairs (name . index). Used for :TYPE'd
1379 ;;; constructors to find all the names that we have to splice in &
1380 ;;; where. Note that these types don't have a layout, so we can't look
1381 ;;; at LAYOUT-INHERITS.
1382 (defun find-name-indices (defstruct)
1383   (collect ((res))
1384     (let ((infos ()))
1385       (do ((info defstruct
1386                  (typed-structure-info-or-lose (first (dd-include info)))))
1387           ((not (dd-include info))
1388            (push info infos))
1389         (push info infos))
1390
1391       (let ((i 0))
1392         (dolist (info infos)
1393           (incf i (or (dd-offset info) 0))
1394           (when (dd-named info)
1395             (res (cons (dd-name info) i)))
1396           (setq i (dd-length info)))))
1397
1398     (res)))
1399 \f
1400 ;;;; slot accessors for raw slots
1401
1402 ;;; Return info about how to read/write a slot in the value stored in
1403 ;;; OBJECT. This is also used by constructors (since we can't safely
1404 ;;; use the accessor function, since some slots are read-only). If
1405 ;;; supplied, DATA is a variable holding the raw-data vector.
1406 ;;;
1407 ;;; returned values:
1408 ;;; 1. accessor function name (SETFable)
1409 ;;; 2. index to pass to accessor.
1410 ;;; 3. object form to pass to accessor
1411 (defun slot-accessor-form (defstruct slot object &optional data)
1412   (let ((rtype (dsd-raw-type slot)))
1413     (values
1414      (ecase rtype
1415        (single-float '%raw-ref-single)
1416        (double-float '%raw-ref-double)
1417        #!+long-float
1418        (long-float '%raw-ref-long)
1419        (complex-single-float '%raw-ref-complex-single)
1420        (complex-double-float '%raw-ref-complex-double)
1421        #!+long-float
1422        (complex-long-float '%raw-ref-complex-long)
1423        (unsigned-byte 'aref)
1424        ((t)
1425         (if (eq (dd-type defstruct) 'funcallable-structure)
1426             '%funcallable-instance-info
1427             '%instance-ref)))
1428      (case rtype
1429        #!+long-float
1430        (complex-long-float
1431         (truncate (dsd-index slot) #!+x86 6 #!+sparc 8))
1432        #!+long-float
1433        (long-float
1434         (truncate (dsd-index slot) #!+x86 3 #!+sparc 4))
1435        (double-float
1436         (ash (dsd-index slot) -1))
1437        (complex-double-float
1438         (ash (dsd-index slot) -2))
1439        (complex-single-float
1440         (ash (dsd-index slot) -1))
1441        (t
1442         (dsd-index slot)))
1443      (cond
1444       ((eq rtype t) object)
1445       (data)
1446       (t
1447        `(truly-the (simple-array (unsigned-byte 32) (*))
1448                    (%instance-ref ,object ,(dd-raw-index defstruct))))))))
1449 \f
1450 ;;; These functions are called to actually make a constructor after we
1451 ;;; have processed the arglist. The correct variant (according to the
1452 ;;; DD-TYPE) should be called. The function is defined with the
1453 ;;; specified name and arglist. Vars and Types are used for argument
1454 ;;; type declarations. Values are the values for the slots (in order.)
1455 ;;;
1456 ;;; This is split four ways because:
1457 ;;; 1] list & vector structures need "name" symbols stuck in at
1458 ;;;    various weird places, whereas STRUCTURE structures have
1459 ;;;    a LAYOUT slot.
1460 ;;; 2] We really want to use LIST to make list structures, instead of
1461 ;;;    MAKE-LIST/(SETF ELT).
1462 ;;; 3] STRUCTURE structures can have raw slots that must also be
1463 ;;;    allocated and indirectly referenced. We use SLOT-ACCESSOR-FORM
1464 ;;;    to compute how to set the slots, which deals with raw slots.
1465 ;;; 4] Funcallable structures are weird.
1466 (defun create-vector-constructor
1467        (defstruct cons-name arglist vars types values)
1468   (let ((temp (gensym))
1469         (etype (dd-element-type defstruct)))
1470     `(defun ,cons-name ,arglist
1471        (declare ,@(mapcar #'(lambda (var type) `(type (and ,type ,etype) ,var))
1472                           vars types))
1473        (let ((,temp (make-array ,(dd-length defstruct)
1474                                 :element-type ',(dd-element-type defstruct))))
1475          ,@(mapcar #'(lambda (x)
1476                        `(setf (aref ,temp ,(cdr x))  ',(car x)))
1477                    (find-name-indices defstruct))
1478          ,@(mapcar #'(lambda (dsd value)
1479                        `(setf (aref ,temp ,(dsd-index dsd)) ,value))
1480                    (dd-slots defstruct) values)
1481          ,temp))))
1482 (defun create-list-constructor
1483        (defstruct cons-name arglist vars types values)
1484   (let ((vals (make-list (dd-length defstruct) :initial-element nil)))
1485     (dolist (x (find-name-indices defstruct))
1486       (setf (elt vals (cdr x)) `',(car x)))
1487     (loop for dsd in (dd-slots defstruct) and val in values do
1488       (setf (elt vals (dsd-index dsd)) val))
1489
1490     `(defun ,cons-name ,arglist
1491        (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
1492                           vars types))
1493        (list ,@vals))))
1494 (defun create-structure-constructor
1495        (defstruct cons-name arglist vars types values)
1496   (let* ((temp (gensym))
1497          (raw-index (dd-raw-index defstruct))
1498          (n-raw-data (when raw-index (gensym))))
1499     `(defun ,cons-name ,arglist
1500        (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
1501                           vars types))
1502        (let ((,temp (truly-the ,(dd-name defstruct)
1503                                (%make-instance ,(dd-length defstruct))))
1504              ,@(when n-raw-data
1505                  `((,n-raw-data
1506                     (make-array ,(dd-raw-length defstruct)
1507                                 :element-type '(unsigned-byte 32))))))
1508          (setf (%instance-layout ,temp)
1509                (%delayed-get-compiler-layout ,(dd-name defstruct)))
1510          ,@(when n-raw-data
1511              `((setf (%instance-ref ,temp ,raw-index) ,n-raw-data)))
1512          ,@(mapcar (lambda (dsd value)
1513                      (multiple-value-bind (accessor index data)
1514                          (slot-accessor-form defstruct dsd temp n-raw-data)
1515                        `(setf (,accessor ,data ,index) ,value)))
1516                    (dd-slots defstruct)
1517                    values)
1518          ,temp))))
1519 (defun create-fin-constructor
1520        (defstruct cons-name arglist vars types values)
1521   (let ((temp (gensym)))
1522     `(defun ,cons-name ,arglist
1523        (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
1524                           vars types))
1525        (let ((,temp (truly-the
1526                      ,(dd-name defstruct)
1527                      (%make-funcallable-instance
1528                       ,(dd-length defstruct)
1529                       (%delayed-get-compiler-layout ,(dd-name defstruct))))))
1530          ,@(mapcar #'(lambda (dsd value)
1531                        `(setf (%funcallable-instance-info
1532                                ,temp ,(dsd-index dsd))
1533                               ,value))
1534                    (dd-slots defstruct) values)
1535          ,temp))))
1536
1537 ;;; Create a default (non-BOA) keyword constructor.
1538 (defun create-keyword-constructor (defstruct creator)
1539   (collect ((arglist (list '&key))
1540             (types)
1541             (vals))
1542     (dolist (slot (dd-slots defstruct))
1543       (let ((dum (gensym))
1544             (name (dsd-name slot)))
1545         (arglist `((,(keywordicate name) ,dum) ,(dsd-default slot)))
1546         (types (dsd-type slot))
1547         (vals dum)))
1548     (funcall creator
1549              defstruct (dd-default-constructor defstruct)
1550              (arglist) (vals) (types) (vals))))
1551
1552 ;;; Given a structure and a BOA constructor spec, call CREATOR with
1553 ;;; the appropriate args to make a constructor.
1554 (defun create-boa-constructor (defstruct boa creator)
1555   (multiple-value-bind (req opt restp rest keyp keys allowp aux)
1556       (sb!kernel:parse-lambda-list (second boa))
1557     (collect ((arglist)
1558               (vars)
1559               (types))
1560       (labels ((get-slot (name)
1561                  (let ((res (find name (dd-slots defstruct)
1562                                   :test #'string=
1563                                   :key #'dsd-name)))
1564                    (if res
1565                        (values (dsd-type res) (dsd-default res))
1566                        (values t nil))))
1567                (do-default (arg)
1568                  (multiple-value-bind (type default) (get-slot arg)
1569                    (arglist `(,arg ,default))
1570                    (vars arg)
1571                    (types type))))
1572         (dolist (arg req)
1573           (arglist arg)
1574           (vars arg)
1575           (types (get-slot arg)))
1576
1577         (when opt
1578           (arglist '&optional)
1579           (dolist (arg opt)
1580             (cond ((consp arg)
1581                    (destructuring-bind
1582                        (name &optional (def (nth-value 1 (get-slot name))))
1583                        arg
1584                      (arglist `(,name ,def))
1585                      (vars name)
1586                      (types (get-slot name))))
1587                   (t
1588                    (do-default arg)))))
1589
1590         (when restp
1591           (arglist '&rest rest)
1592           (vars rest)
1593           (types 'list))
1594
1595         (when keyp
1596           (arglist '&key)
1597           (dolist (key keys)
1598             (if (consp key)
1599                 (destructuring-bind (wot &optional (def nil def-p)) key
1600                   (let ((name (if (consp wot)
1601                                   (destructuring-bind (key var) wot
1602                                     (declare (ignore key))
1603                                     var)
1604                                   wot)))
1605                     (multiple-value-bind (type slot-def) (get-slot name)
1606                       (arglist `(,wot ,(if def-p def slot-def)))
1607                       (vars name)
1608                       (types type))))
1609                 (do-default key))))
1610
1611         (when allowp (arglist '&allow-other-keys))
1612
1613         (when aux
1614           (arglist '&aux)
1615           (dolist (arg aux)
1616             (let* ((arg (if (consp arg) arg (list arg)))
1617                    (var (first arg)))
1618               (arglist arg)
1619               (vars var)
1620               (types (get-slot var))))))
1621
1622       (funcall creator defstruct (first boa)
1623                (arglist) (vars) (types)
1624                (mapcar #'(lambda (slot)
1625                            (or (find (dsd-name slot) (vars) :test #'string=)
1626                                (dsd-default slot)))
1627                        (dd-slots defstruct))))))
1628
1629 ;;; Grovel the constructor options, and decide what constructors (if
1630 ;;; any) to create.
1631 (defun constructor-definitions (defstruct)
1632   (let ((no-constructors nil)
1633         (boas ())
1634         (defaults ())
1635         (creator (ecase (dd-type defstruct)
1636                    (structure #'create-structure-constructor)
1637                    (funcallable-structure #'create-fin-constructor)
1638                    (vector #'create-vector-constructor)
1639                    (list #'create-list-constructor))))
1640     (dolist (constructor (dd-constructors defstruct))
1641       (destructuring-bind (name &optional (boa-ll nil boa-p)) constructor
1642         (declare (ignore boa-ll))
1643         (cond ((not name) (setq no-constructors t))
1644               (boa-p (push constructor boas))
1645               (t (push name defaults)))))
1646
1647     (when no-constructors
1648       (when (or defaults boas)
1649         (error "(:CONSTRUCTOR NIL) combined with other :CONSTRUCTORs"))
1650       (return-from constructor-definitions ()))
1651
1652     (unless (or defaults boas)
1653       (push (symbolicate "MAKE-" (dd-name defstruct)) defaults))
1654
1655     (collect ((res))
1656       (when defaults
1657         (let ((cname (first defaults)))
1658           (setf (dd-default-constructor defstruct) cname)
1659           (res (create-keyword-constructor defstruct creator))
1660           (dolist (other-name (rest defaults))
1661             (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
1662             (res `(declaim (ftype function ',other-name))))))
1663
1664       (dolist (boa boas)
1665         (res (create-boa-constructor defstruct boa creator)))
1666
1667       (res))))
1668 \f
1669 ;;;; finalizing bootstrapping
1670
1671 ;;; early structure placeholder definitions: Set up layout and class
1672 ;;; data for structures which are needed early.
1673 (dolist (args
1674          '#.(sb-cold:read-from-file
1675              "src/code/early-defstruct-args.lisp-expr"))
1676   (let* ((dd (parse-defstruct-name-and-options-and-slot-descriptions
1677               (first args)
1678               (rest args)))
1679          (inherits (inherits-for-structure dd)))
1680     (%compiler-defstruct dd inherits)))
1681
1682 (/show0 "code/defstruct.lisp end of file")