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