1 ;;;; that part of DEFSTRUCT implementation which is needed not just
2 ;;;; in the target Lisp but also in the cross-compilation host
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
13 (in-package "SB!KERNEL")
15 (/show0 "code/defstruct.lisp 15")
19 ;;; Return the compiler layout for NAME. (The class referred to by
20 ;;; NAME must be a structure-like class.)
21 (defun compiler-layout-or-lose (name)
22 #+sb-xc (/show0 "entering COMPILER-LAYOUT-OR-LOSE")
23 (let ((res (info :type :compiler-layout name)))
25 (error "Class is not yet defined or was undefined: ~S" name))
26 ((not (typep (layout-info res) 'defstruct-description))
27 (error "Class is not a structure class: ~S" name))
30 ;;; Delay looking for compiler-layout until the constructor is being
31 ;;; compiled, since it doesn't exist until after the EVAL-WHEN (COMPILE)
32 ;;; stuff is compiled.
33 (sb!xc:defmacro %delayed-get-compiler-layout (name)
34 `',(compiler-layout-or-lose name))
36 ;;; Get layout right away.
37 (sb!xc:defmacro compile-time-find-layout (name)
40 ;;; re. %DELAYED-GET-COMPILER-LAYOUT and COMPILE-TIME-FIND-LAYOUT, above..
42 ;;; FIXME: Perhaps both should be defined with DEFMACRO-MUNDANELY?
43 ;;; FIXME: Do we really need both? If so, their names and implementations
44 ;;; should probably be tweaked to be more parallel.
46 ;;;; DEFSTRUCT-DESCRIPTION
48 ;;; The DEFSTRUCT-DESCRIPTION structure holds compile-time information
49 ;;; about a structure type.
50 (def!struct (defstruct-description
52 (:make-load-form-fun just-dump-it-normally)
53 #-sb-xc-host (:pure t)
54 (:constructor make-defstruct-description (name)))
55 ;; name of the structure
56 (name (missing-arg) :type symbol)
57 ;; documentation on the structure
58 (doc nil :type (or string null))
59 ;; prefix for slot names. If NIL, none.
60 (conc-name (symbolicate name "-") :type (or symbol null))
61 ;; the name of the primary standard keyword constructor, or NIL if none
62 (default-constructor nil :type (or symbol null))
63 ;; all the explicit :CONSTRUCTOR specs, with name defaulted
64 (constructors () :type list)
65 ;; name of copying function
66 (copier-name (symbolicate "COPY-" name) :type (or symbol null))
67 ;; name of type predicate
68 (predicate-name (symbolicate name "-P") :type (or symbol null))
69 ;; the arguments to the :INCLUDE option, or NIL if no included
71 (include nil :type list)
72 ;; properties used to define structure-like classes with an
73 ;; arbitrary 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)
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))
86 ;; The next three slots are for :TYPE'd structures (which aren't
87 ;; classes, DD-CLASS-P = NIL)
89 ;; vector element type
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))
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
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)))
117 ;;; Does DD describe a structure with a class?
118 (defun dd-class-p (dd)
120 '(structure funcallable-structure)))
122 ;;; a type name which can be used when declaring things which operate
123 ;;; on structure instances
124 (defun dd-declarable-type (dd)
126 ;; Native classes are known to the type system, and we can
127 ;; declare them as types.
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.
134 (defun dd-layout-or-lose (dd)
135 (compiler-layout-or-lose (dd-name dd)))
137 ;;;; DEFSTRUCT-SLOT-DESCRIPTION
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)
145 #-sb-xc-host (:pure t))
146 ;; string name of slot
148 ;; its position in the implementation sequence
149 (index (missing-arg) :type fixnum)
150 ;; the name of the accessor function
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.)
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.
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
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)))
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))
183 ;;;; typed (non-class) structures
185 ;;; Return a type specifier we can use for testing :TYPE'd structures.
186 (defun dd-lisp-type (defstruct)
187 (ecase (dd-type defstruct)
189 (vector `(simple-array ,(dd-element-type defstruct) (*)))))
191 ;;;; shared machinery for inline and out-of-line slot accessor functions
193 ;;; an alist mapping from raw slot type to the operator used to access
196 ;;; FIXME: should be shared
197 (eval-when (:compile-toplevel :load-toplevel :execute)
198 (defvar *raw-type->rawref-fun-name*
199 '(;; The compiler thinks that the raw data vector is a vector of
200 ;; unsigned bytes, so if the slot we want to access actually *is*
201 ;; an unsigned byte, it'll access the slot for us even if we don't
203 (unsigned-byte . aref)
204 ;; "A lie can travel halfway round the world while the truth is
205 ;; putting on its shoes." -- Mark Twain
206 (single-float . %raw-ref-single)
207 (double-float . %raw-ref-double)
208 #!+long-float (long-float . %raw-ref-long)
209 (complex-single-float . %raw-ref-complex-single)
210 (complex-double-float . %raw-ref-complex-double)
211 #!+long-float (complex-long-float . %raw-ref-complex-long))))
213 ;;;; generating out-of-line slot accessor functions
215 ;;; FIXME: Ideally, the presence of the type checks in the functions
216 ;;; here would be conditional on the optimization policy at the point
217 ;;; of expansion of DEFSTRUCT. (For now we're just doing the simpler
218 ;;; thing, putting in the type checks unconditionally.)
220 ;;; Return (VALUES SLOT-READER-FUN SLOT-WRITER-FUN).
221 (defun slot-accessor-funs (dd dsd)
223 #+sb-xc (/show0 "entering SLOT-ACCESSOR-FUNS")
225 ;; various code generators
227 ;; Note: They're only minimally parameterized, and cavalierly grab
228 ;; things like INSTANCE and DSD-INDEX from the namespace they're
230 (macrolet (;; code shared between funcallable instance case and the
231 ;; ordinary STRUCTURE-OBJECT case: Handle native
232 ;; structures with LAYOUTs and (possibly) raw slots.
233 (%native-slot-accessor-funs (dd-ref-fun-name)
234 (let ((instance-type-check-form
235 '(%check-structure-type-from-layout instance layout)))
236 (/show "macroexpanding %NATIVE-SLOT-ACCESSOR-FUNS" dd-ref-fun-name instance-type-check-form)
237 `(let ((layout (dd-layout-or-lose dd))
238 (dsd-raw-type (dsd-raw-type dsd)))
239 #+sb-xc (/show0 "in %NATIVE-SLOT-ACCESSOR-FUNS macroexpanded code")
240 ;; Map over all the possible RAW-TYPEs, compiling
241 ;; a different closure-function for each one, so
242 ;; that once the COND over RAW-TYPEs happens (at
243 ;; the time closure is allocated) there are no
244 ;; more decisions to be made and things execute
245 ;; reasonably efficiently.
248 ((eql dsd-raw-type t)
249 #+sb-xc (/show0 "in nonraw slot case")
250 (%slotplace-accessor-funs
251 (,dd-ref-fun-name instance dsd-index)
252 ,instance-type-check-form))
254 ,@(mapcar (lambda (raw-type-and-rawref-fun-name)
255 (destructuring-bind (raw-type
257 raw-type-and-rawref-fun-name
258 `((equal dsd-raw-type ',raw-type)
259 #+sb-xc (/show0 "in raw slot case")
260 (let ((raw-index (dd-raw-index dd)))
261 (%slotplace-accessor-funs
262 (,rawref-fun-name (,dd-ref-fun-name
266 ,instance-type-check-form)))))
267 *raw-type->rawref-fun-name*)
270 (error "internal error: unexpected DSD-RAW-TYPE ~S"
272 ;; code shared between DEFSTRUCT :TYPE LIST and
273 ;; DEFSTRUCT :TYPE VECTOR cases: Handle the "typed
274 ;; structure" case, with no LAYOUTs and no raw slots.
275 (%colontyped-slot-accessor-funs () (error "stub"))
276 ;; the common structure of the raw-slot and not-raw-slot
277 ;; cases, defined in terms of the writable SLOTPLACE. All
278 ;; possible flavors of slot access should be able to pass
280 (%slotplace-accessor-funs (slotplace instance-type-check-form)
281 (/show "macroexpanding %SLOTPLACE-ACCESSOR-FUNS" slotplace instance-type-check-form)
282 `(values (lambda (instance)
283 (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader")
284 ,instance-type-check-form
285 (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM")
287 (let ((typecheckfun (typespec-typecheckfun dsd-type)))
288 (lambda (new-value instance)
289 (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined writer")
290 ,instance-type-check-form
291 (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM")
292 (funcall typecheckfun new-value)
293 (/noshow0 "back from TYPECHECKFUN")
294 (setf ,slotplace new-value))))))
296 (let ((dsd-index (dsd-index dsd))
297 (dsd-type (dsd-type dsd)))
299 #+sb-xc (/show0 "got DSD-TYPE=..")
300 #+sb-xc (/hexstr dsd-type)
305 #+sb-xc (/show0 "case of DSD-TYPE = STRUCTURE")
306 (%native-slot-accessor-funs %instance-ref))
308 ;; structures with the :TYPE option
310 ;; FIXME: Worry about these later..
312 ;; In :TYPE LIST and :TYPE VECTOR structures, ANSI specifies the
313 ;; layout completely, so that raw slots are impossible.
315 (dd-type-slot-accessor-funs nth-but-with-sane-arg-order
316 `(%check-structure-type-from-dd
319 (dd-type-slot-accessor-funs aref
324 ;;;; baby steps for the new out-of-line slot accessor functions
326 ;;;; REMOVEME after new structure code works
329 (in-package :sb-kernel)
334 (b 5 :type package :read-only t)
336 (x 5 :type (unsigned-byte 32))
337 (y 5.0 :type single-float :read-only t))
339 (load "/usr/stuff/sbcl/src/cold/chill")
340 (cl-user:fasl "/usr/stuff/sbcl/src/code/typecheckfuns")
341 (cl-user:fasl "/usr/stuff/outsacc")
343 (let* ((foo-layout (compiler-layout-or-lose 'foo))
344 (foo-dd (layout-info foo-layout))
345 (foo-dsds (dd-slots foo-dd))
346 (foo-a-dsd (find "A" foo-dsds :test #'string= :key #'dsd-%name))
347 (foo-b-dsd (find "B" foo-dsds :test #'string= :key #'dsd-%name))
348 (foo-x-dsd (find "X" foo-dsds :test #'string= :key #'dsd-%name))
349 (foo-y-dsd (find "X" foo-dsds :test #'string= :key #'dsd-%name))
350 (foo (make-foo :a 'avalue
351 :b (find-package :cl)
353 (declare (type layout foo-layout))
354 (declare (type defstruct-description foo-dd))
355 (declare (type defstruct-slot-description foo-a-dsd))
359 (multiple-value-bind (foo-a-reader foo-a-writer)
360 (slot-accessor-funs foo-dd foo-a-dsd)
362 ;; basic functionality
363 (cl-user:/show foo-a-reader)
364 (cl-user:/show (funcall foo-a-reader foo))
365 (aver (eql (funcall foo-a-reader foo) 'avalue))
366 (cl-user:/show foo-a-writer)
367 (cl-user:/show (funcall foo-a-writer 'replacedavalue foo))
368 (cl-user:/show "new" (funcall foo-a-reader foo))
369 (aver (eql (funcall foo-a-reader foo) 'replacedavalue))
371 ;; type checks on FOO-ness of instance argument
372 (cl-user:/show (nth-value 1 (ignore-errors (funcall foo-a-reader 3))))
373 (aver (typep (nth-value 1 (ignore-errors (funcall foo-a-reader 3)))
375 (aver (typep (nth-value 1 (ignore-errors (funcall foo-a-writer 3 4)))
378 ;; type checks on written slot value
379 (multiple-value-bind (foo-b-reader foo-b-writer)
380 (slot-accessor-funs foo-dd foo-b-dsd)
381 (cl-user:/show "old" (funcall foo-b-reader foo))
382 (aver (not (eql (funcall foo-b-reader foo) (find-package :cl-user))))
383 (funcall foo-b-writer (find-package :cl-user) foo)
384 (cl-user:/show "new" (funcall foo-b-reader foo))
385 (aver (eql (funcall foo-b-reader foo) (find-package :cl-user)))
386 (aver (typep (nth-value 1 (ignore-errors (funcall foo-b-writer 5 foo)))
388 (aver (eql (funcall foo-b-reader foo) (find-package :cl-user))))
391 (cl-user:/describe foo-x-dsd)
392 (cl-user:/describe foo-y-dsd)
393 (multiple-value-bind (foo-x-reader foo-x-writer)
394 (slot-accessor-funs foo-dd foo-x-dsd)
395 (multiple-value-bind (foo-y-reader foo-y-writer)
396 (slot-accessor-funs foo-dd foo-y-dsd)
398 ;; basic functionality for (UNSIGNED-BYTE 32) slot
399 (cl-user:/show foo-x-reader)
400 (cl-user:/show (funcall foo-x-reader foo))
401 (aver (eql (funcall foo-x-reader foo) 50))
402 (cl-user:/show foo-x-writer)
403 (cl-user:/show (funcall foo-x-writer 14 foo))
404 (cl-user:/show "new" (funcall foo-x-reader foo))
405 (aver (eql (funcall foo-x-reader foo) 14)))
407 ;; type check for (UNSIGNED-BYTE 32) slot
408 (/show "to do: type check X")
414 ;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its
415 ;;;; close personal friend SB!XC:DEFSTRUCT)
417 ;;; Return a list of forms to install PRINT and MAKE-LOAD-FORM funs,
418 ;;; mentioning them in the expansion so that they can be compiled.
419 (defun class-method-definitions (defstruct)
420 (let ((name (dd-name defstruct)))
422 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant
423 ;; class names which creates fast but non-cold-loadable,
424 ;; non-compact code. In this context, we'd rather have
425 ;; compact, cold-loadable code. -- WHN 19990928
426 (declare (notinline sb!xc:find-class))
427 #+sb-xc (/show0 "beginning CLASS-METHOD-DEFINITIONS forms")
428 ,@(let ((pf (dd-print-function defstruct))
429 (po (dd-print-object defstruct))
432 ;; Giving empty :PRINT-OBJECT or :PRINT-FUNCTION options
433 ;; leaves PO or PF equal to NIL. The user-level effect is
434 ;; to generate a PRINT-OBJECT method specialized for the type,
435 ;; implementing the default #S structure-printing behavior.
436 (when (or (eq pf nil) (eq po nil))
437 (setf pf '(default-structure-print)
439 (flet (;; Given an arg from a :PRINT-OBJECT or :PRINT-FUNCTION
440 ;; option, return the value to pass as an arg to FUNCTION.
442 (destructuring-bind (fun-name) oarg
444 (cond ((not (eql pf 0))
445 `((def!method print-object ((,x ,name) ,s)
446 (funcall #',(farg pf) ,x ,s *current-level*))))
448 `((def!method print-object ((,x ,name) ,s)
449 (funcall #',(farg po) ,x ,s))))
451 ,@(let ((pure (dd-pure defstruct)))
453 `((setf (layout-pure (class-layout
454 (sb!xc:find-class ',name)))
456 ((eq pure :substructure)
457 `((setf (layout-pure (class-layout
458 (sb!xc:find-class ',name)))
460 ,@(let ((def-con (dd-default-constructor defstruct)))
461 (when (and def-con (not (dd-alternate-metaclass defstruct)))
462 `((setf (structure-class-constructor (sb!xc:find-class ',name))
464 #+sb-xc (/show0 "done with CLASS-METHOD-DEFINITIONS forms")))))
465 ;;; FIXME: I really would like to make structure accessors less
466 ;;; special, just ordinary inline functions. (Or perhaps inline
467 ;;; functions with special compact implementations of their
468 ;;; expansions, to avoid bloating the system.)
470 ;;; shared logic for CL:DEFSTRUCT and SB!XC:DEFSTRUCT
471 (defmacro !expander-for-defstruct (name-and-options
473 expanding-into-code-for-xc-host-p)
474 `(let ((name-and-options ,name-and-options)
475 (slot-descriptions ,slot-descriptions)
476 (expanding-into-code-for-xc-host-p
477 ,expanding-into-code-for-xc-host-p))
478 (let* ((dd (parse-defstruct-name-and-options-and-slot-descriptions
483 (let ((inherits (inherits-for-structure dd)))
485 (/show0 "beginning macroexpanded DEFSTRUCT code")
486 (eval-when (:compile-toplevel :load-toplevel :execute)
487 (%compiler-defstruct ',dd ',inherits))
488 (/show0 "back from %COMPILER-DEFSTRUCT")
489 (%defstruct ',dd ',inherits)
490 (/show0 "back from %DEFSTRUCT")
491 ,@(unless expanding-into-code-for-xc-host-p
492 (append #|(raw-accessor-definitions dd)|# ; REMOVEME
493 (predicate-definitions dd)
494 ;; FIXME: We've inherited from CMU CL nonparallel
495 ;; code for creating copiers for typed and untyped
496 ;; structures. This should be fixed.
497 ;(copier-definition dd)
498 (constructor-definitions dd)
499 (class-method-definitions dd)))
500 (/show0 "done with macroexpanded DEFSTRUCT code")
503 (/show0 "beginning macroexpanded typed DEFSTRUCT code")
504 (eval-when (:compile-toplevel :load-toplevel :execute)
505 (setf (info :typed-structure :info ',name) ',dd))
506 ,@(unless expanding-into-code-for-xc-host-p
507 (append (typed-accessor-definitions dd)
508 (typed-predicate-definitions dd)
509 (typed-copier-definitions dd)
510 (constructor-definitions dd)))
511 (/show0 "done with macroexpanded typed DEFSTRUCT code")
514 (sb!xc:defmacro defstruct (name-and-options &rest slot-descriptions)
516 "DEFSTRUCT {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)}
517 Define the structure type Name. Instances are created by MAKE-<name>,
518 which takes &KEY arguments allowing initial slot values to the specified.
519 A SETF'able function <name>-<slot> is defined for each slot to read and
520 write slot values. <name>-p is a type predicate.
522 Popular DEFSTRUCT options (see manual for others):
526 Specify the name for the constructor or predicate.
528 (:CONSTRUCTOR Name Lambda-List)
529 Specify the name and arguments for a BOA constructor
530 (which is more efficient when keyword syntax isn't necessary.)
532 (:INCLUDE Supertype Slot-Spec*)
533 Make this type a subtype of the structure type Supertype. The optional
534 Slot-Specs override inherited slot options.
539 Asserts that the value of this slot is always of the specified type.
542 If true, no setter function is defined for this slot."
543 (!expander-for-defstruct name-and-options slot-descriptions nil))
545 (defmacro sb!xc:defstruct (name-and-options &rest slot-descriptions)
547 "Cause information about a target structure to be built into the
549 (!expander-for-defstruct name-and-options slot-descriptions t))
551 ;;;; functions to generate code for various parts of DEFSTRUCT definitions
553 ;;; REMOVEME: no longer used
555 ;;; Return forms to define readers and writers for raw slots as inline
557 (defun raw-accessor-definitions (dd)
558 (let* ((name (dd-name dd))
559 (dtype (dd-declarable-type dd)))
561 (dolist (slot (dd-slots dd))
562 (let ((slot-type (dsd-type slot))
563 (accessor-name (dsd-accessor-name slot))
564 (argname (gensym "ARG"))
565 (nvname (gensym "NEW-VALUE-")))
566 (multiple-value-bind (accessor offset data)
567 (slot-accessor-form dd slot argname)
568 ;; When accessor exists and is raw
569 (when (and accessor-name
570 (not (eq accessor-name '%instance-ref)))
571 (res `(/show0 "doing one slot, ACCESSOR-NAME=.."))
572 (res `(/hexstr ',accessor-name))
573 (res `(declaim (inline ,accessor-name)))
574 (res `(/show0 "done with reader DECLAIM INLINE"))
575 (res `(declaim (ftype (function (,dtype) ,slot-type)
577 (res `(/show0 "done with reader DECLAIM FTYPE, doing DEFUN"))
578 (res `(defun ,accessor-name (,argname)
579 ;; Note: The DECLARE here might seem redundant
580 ;; with the DECLAIM FTYPE above, but it's not:
581 ;; If we're not at toplevel, the PROCLAIM inside
582 ;; the DECLAIM doesn't get executed until after
583 ;; this function is compiled.
584 (declare (type ,dtype ,argname))
585 (truly-the ,slot-type (,accessor ,data ,offset))))
586 (unless (dsd-read-only slot)
587 (res `(/show0 "doing writer DECLAIM INLINE"))
588 (res `(declaim (inline (setf ,accessor-name))))
589 (res `(/show0 "doing writer DECLAIM FTYPE"))
590 (res `(declaim (ftype (function (,slot-type ,dtype) ,slot-type)
591 (setf ,accessor-name))))
592 ;; FIXME: I rewrote this somewhat from the CMU CL definition.
593 ;; Do some basic tests to make sure that reading and writing
594 ;; raw slots still works correctly.
595 (res `(/show0 "doing writer DEFUN"))
596 (res `(defun (setf ,accessor-name) (,nvname ,argname)
597 (declare (type ,dtype ,argname))
598 (setf (,accessor ,data ,offset) ,nvname)
600 (res `(/show0 "done with one slot"))))))
601 `((/show0 "beginning RAW-ACCESSOR-DEFINITIONS forms")
603 (/show0 "done with RAW-ACCESSOR-DEFINITIONS forms")))))
606 ;;; Return a list of forms which create a predicate for an untyped DEFSTRUCT.
607 (defun predicate-definitions (dd)
608 (let ((pred (dd-predicate-name dd))
609 (argname (gensym "ARG")))
611 `((/show0 "beginning PREDICATE-DEFINITIONS forms")
613 (declaim (inline ,pred))
614 (defun ,pred (,argname)
615 (declare (optimize (speed 3) (safety 0)))
616 (typep-to-layout ,argname
617 (compile-time-find-layout ,(dd-name dd))))
618 (/show0 "done with PREDICATE-DEFINITIONS forms")))))
620 ;;; Return a list of forms which create a predicate function for a typed
622 (defun typed-predicate-definitions (defstruct)
623 (let ((name (dd-name defstruct))
624 (predicate-name (dd-predicate-name defstruct))
626 (when (and predicate-name (dd-named defstruct))
627 (let ((ltype (dd-lisp-type defstruct)))
628 `((defun ,predicate-name (,argname)
629 (and (typep ,argname ',ltype)
630 (eq (elt (the ,ltype ,argname)
631 ,(cdr (car (last (find-name-indices defstruct)))))
634 ;;; FIXME: We've inherited from CMU CL code to do typed structure copiers
635 ;;; in a completely different way than untyped structure copiers. Fix this.
636 ;;; (This function was my first attempt to fix this, but I stopped before
637 ;;; figuring out how to install it completely and remove the parallel
638 ;;; code which simply SETF's the FDEFINITION of the DD-COPIER name.
640 ;;; Return the copier definition for an untyped DEFSTRUCT.
641 (defun copier-definition (dd)
643 (let ((argname (gensym)))
645 (protect-cl ',(dd-copier dd))
646 (defun ,(dd-copier dd) (,argname)
647 (declare (type ,(dd-name dd) ,argname))
648 (copy-structure ,argname))))))
651 ;;; Return a list of forms to create a copier function of a typed DEFSTRUCT.
652 (defun typed-copier-definitions (defstruct)
653 (when (dd-copier-name defstruct)
654 `((setf (fdefinition ',(dd-copier-name defstruct)) #'copy-seq)
655 (declaim (ftype function ,(dd-copier-name defstruct))))))
657 ;;; Return a list of function definitions for accessing and setting
658 ;;; the slots of a typed DEFSTRUCT. The functions are proclaimed to be
659 ;;; inline, and the types of their arguments and results are declared
660 ;;; as well. We count on the compiler to do clever things with ELT.
661 (defun typed-accessor-definitions (defstruct)
663 (let ((ltype (dd-lisp-type defstruct)))
664 (dolist (slot (dd-slots defstruct))
665 (let ((name (dsd-accessor-name slot))
666 (index (dsd-index slot))
667 (slot-type `(and ,(dsd-type slot)
668 ,(dd-element-type defstruct))))
669 (stuff `(proclaim '(inline ,name (setf ,name))))
670 ;; FIXME: The arguments in the next two DEFUNs should be
671 ;; gensyms. (Otherwise e.g. if NEW-VALUE happened to be the
672 ;; name of a special variable, things could get weird.)
673 (stuff `(defun ,name (structure)
674 (declare (type ,ltype structure))
675 (the ,slot-type (elt structure ,index))))
676 (unless (dsd-read-only slot)
678 `(defun (setf ,name) (new-value structure)
679 (declare (type ,ltype structure) (type ,slot-type new-value))
680 (setf (elt structure ,index) new-value)))))))
685 (defun require-no-print-options-so-far (defstruct)
686 (unless (and (eql (dd-print-function defstruct) 0)
687 (eql (dd-print-object defstruct) 0))
688 (error "No more than one of the following options may be specified:
689 :PRINT-FUNCTION, :PRINT-OBJECT, :TYPE")))
691 ;;; Parse a single DEFSTRUCT option and store the results in DD.
692 (defun parse-1-dd-option (option dd)
693 (let ((args (rest option))
697 (destructuring-bind (conc-name) args
698 (setf (dd-conc-name dd)
699 (if (symbolp conc-name)
701 (make-symbol (string conc-name))))))
703 (destructuring-bind (&optional (cname (symbolicate "MAKE-" name))
706 (push (cons cname stuff) (dd-constructors dd))))
708 (destructuring-bind (&optional (copier (symbolicate "COPY-" name)))
710 (setf (dd-copier-name dd) copier)))
712 (destructuring-bind (&optional (predicate-name (symbolicate name "-P")))
714 (setf (dd-predicate-name dd) predicate-name)))
716 (when (dd-include dd)
717 (error "more than one :INCLUDE option"))
718 (setf (dd-include dd) args))
720 (require-no-print-options-so-far dd)
721 (setf (dd-print-function dd)
722 (the (or symbol cons) args)))
724 (require-no-print-options-so-far dd)
725 (setf (dd-print-object dd)
726 (the (or symbol cons) args)))
728 (destructuring-bind (type) args
729 (cond ((member type '(list vector))
730 (setf (dd-element-type dd) t)
731 (setf (dd-type dd) type))
732 ((and (consp type) (eq (first type) 'vector))
733 (destructuring-bind (vector vtype) type
734 (declare (ignore vector))
735 (setf (dd-element-type dd) vtype)
736 (setf (dd-type dd) 'vector)))
738 (error "~S is a bad :TYPE for DEFSTRUCT." type)))))
740 (error "The DEFSTRUCT option :NAMED takes no arguments."))
742 (destructuring-bind (offset) args
743 (setf (dd-offset dd) offset)))
745 (destructuring-bind (fun) args
746 (setf (dd-pure dd) fun)))
747 (t (error "unknown DEFSTRUCT option:~% ~S" option)))))
749 ;;; Given name and options, return a DD holding that info.
750 (eval-when (:compile-toplevel :load-toplevel :execute)
751 (defun parse-defstruct-name-and-options (name-and-options)
752 (destructuring-bind (name &rest options) name-and-options
753 (aver name) ; A null name doesn't seem to make sense here.
754 (let ((dd (make-defstruct-description name)))
755 (dolist (option options)
756 (cond ((eq option :named)
757 (setf (dd-named dd) t))
759 (parse-1-dd-option option dd))
760 ((member option '(:conc-name :constructor :copier :predicate))
761 (parse-1-dd-option (list option) dd))
763 (error "unrecognized DEFSTRUCT option: ~S" option))))
768 (error ":OFFSET can't be specified unless :TYPE is specified."))
769 (unless (dd-include dd)
770 ;; FIXME: It'd be cleaner to treat no-:INCLUDE as defaulting
771 ;; to :INCLUDE STRUCTURE-OBJECT, and then let the general-case
772 ;; (INCF (DD-LENGTH DD) (DD-LENGTH included-DD)) logic take
773 ;; care of this. (Except that the :TYPE VECTOR and :TYPE
774 ;; LIST cases, with their :NAMED and un-:NAMED flavors,
775 ;; make that messy, alas.)
776 (incf (dd-length dd))))
778 (require-no-print-options-so-far dd)
780 (incf (dd-length dd)))
781 (let ((offset (dd-offset dd)))
782 (when offset (incf (dd-length dd) offset)))))
784 (when (dd-include dd)
785 (do-dd-inclusion-stuff dd))
789 ;;; Given name and options and slot descriptions (and possibly doc
790 ;;; string at the head of slot descriptions) return a DD holding that
792 (defun parse-defstruct-name-and-options-and-slot-descriptions
793 (name-and-options slot-descriptions)
794 (let ((result (parse-defstruct-name-and-options (if (atom name-and-options)
795 (list name-and-options)
797 (when (stringp (car slot-descriptions))
798 (setf (dd-doc result) (pop slot-descriptions)))
799 (dolist (slot-description slot-descriptions)
800 (allocate-1-slot result (parse-1-dsd result slot-description)))
805 ;;;; stuff to parse slot descriptions
807 ;;; Parse a slot description for DEFSTRUCT, add it to the description
808 ;;; and return it. If supplied, SLOT is a pre-initialized DSD
809 ;;; that we modify to get the new slot. This is supplied when handling
811 (defun parse-1-dsd (defstruct spec &optional
812 (slot (make-defstruct-slot-description :%name ""
815 (multiple-value-bind (name default default-p type type-p read-only ro-p)
820 &optional (default nil default-p)
821 &key (type nil type-p) (read-only nil ro-p))
825 (uncross type) type-p
828 (when (keywordp spec)
829 (style-warn "Keyword slot name indicates probable syntax ~
830 error in DEFSTRUCT: ~S."
834 (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)
835 (error 'simple-program-error
836 :format-control "duplicate slot name ~S"
837 :format-arguments (list name)))
838 (setf (dsd-%name slot) (string name))
839 (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list slot)))
841 (let ((accessor-name (symbolicate (or (dd-conc-name defstruct) "") name))
842 (predicate-name (dd-predicate-name defstruct)))
843 (setf (dsd-accessor-name slot) accessor-name)
844 (when (eql accessor-name predicate-name)
845 ;; Some adventurous soul has named a slot so that its accessor
846 ;; collides with the structure type predicate. ANSI doesn't
847 ;; specify what to do in this case. As of 2001-09-04, Martin
848 ;; Atzmueller reports that CLISP and Lispworks both give
849 ;; priority to the slot accessor, so that the predicate is
850 ;; overwritten. We might as well do the same (as well as
851 ;; signalling a warning).
853 "~@<The structure accessor name ~S is the same as the name of the ~
854 structure type predicate. ANSI doesn't specify what to do in ~
855 this case. We'll overwrite the type predicate with the slot ~
856 accessor, but you can't rely on this behavior, so it'd be wise to ~
857 remove the ambiguity in your code.~@:>"
859 (setf (dd-predicate-name defstruct) nil)))
862 (setf (dsd-default slot) default))
864 (setf (dsd-type slot)
865 (if (eq (dsd-type slot) t)
867 `(and ,(dsd-type slot) ,type))))
870 (setf (dsd-read-only slot) t)
871 (when (dsd-read-only slot)
872 (error "Slot ~S is :READ-ONLY in parent and must be :READ-ONLY in subtype ~S."
877 ;;; When a value of type TYPE is stored in a structure, should it be
878 ;;; stored in a raw slot? Return (VALUES RAW? RAW-TYPE WORDS), where
879 ;;; RAW? is true if TYPE should be stored in a raw slot.
880 ;;; RAW-TYPE is the raw slot type, or NIL if no raw slot.
881 ;;; WORDS is the number of words in the raw slot, or NIL if no raw slot.
882 (defun structure-raw-slot-type-and-size (type)
883 (/noshow "in STRUCTURE-RAW-SLOT-TYPE-AND-SIZE" type (sb!xc:subtypep type 'fixnum))
885 (;; FIXME: For now we suppress raw slots, since there are various
886 ;; issues about the way that the cross-compiler handles them.
887 (not (boundp '*dummy-placeholder-to-stop-compiler-warnings*))
888 (values nil nil nil))
889 ((and (sb!xc:subtypep type '(unsigned-byte 32))
890 (multiple-value-bind (fixnum? fixnum-certain?)
891 (sb!xc:subtypep type 'fixnum)
892 (/noshow fixnum? fixnum-certain?)
893 ;; (The extra test for FIXNUM-CERTAIN? here is
894 ;; intended for bootstrapping the system. In
895 ;; particular, in sbcl-0.6.2, we set up LAYOUT before
896 ;; FIXNUM is defined, and so could bogusly end up
897 ;; putting INDEX-typed values into raw slots if we
898 ;; didn't test FIXNUM-CERTAIN?.)
899 (and (not fixnum?) fixnum-certain?)))
900 (values t 'unsigned-byte 1))
901 ((sb!xc:subtypep type 'single-float)
902 (values t 'single-float 1))
903 ((sb!xc:subtypep type 'double-float)
904 (values t 'double-float 2))
906 ((sb!xc:subtypep type 'long-float)
907 (values t 'long-float #!+x86 3 #!+sparc 4))
908 ((sb!xc:subtypep type '(complex single-float))
909 (values t 'complex-single-float 2))
910 ((sb!xc:subtypep type '(complex double-float))
911 (values t 'complex-double-float 4))
913 ((sb!xc:subtypep type '(complex long-float))
914 (values t 'complex-long-float #!+x86 6 #!+sparc 8))
916 (values nil nil nil))))
918 ;;; Allocate storage for a DSD in DD. This is where we decide whether
919 ;;; a slot is raw or not. If raw, and we haven't allocated a raw-index
920 ;;; yet for the raw data vector, then do it. Raw objects are aligned
921 ;;; on the unit of their size.
922 (defun allocate-1-slot (dd dsd)
923 #+sb-xc (/show0 "entering ALLOCATE-1-SLOT")
924 (multiple-value-bind (raw? raw-type words)
925 (if (eq (dd-type dd) 'structure)
926 (structure-raw-slot-type-and-size (dsd-type dsd))
927 (values nil nil nil))
928 (/noshow "ALLOCATE-1-SLOT" dsd raw? raw-type words)
930 (setf (dsd-index dsd) (dd-length dd))
931 (incf (dd-length dd)))
933 (unless (dd-raw-index dd)
934 (setf (dd-raw-index dd) (dd-length dd))
935 (incf (dd-length dd)))
936 (let ((off (rem (dd-raw-length dd) words)))
938 (incf (dd-raw-length dd) (- words off))))
939 (setf (dsd-raw-type dsd) raw-type)
940 (setf (dsd-index dsd) (dd-raw-length dd))
941 (incf (dd-raw-length dd) words))))
942 #+sb-xc (/show0 "leaving ALLOCATE-1-SLOT")
945 (defun typed-structure-info-or-lose (name)
946 (or (info :typed-structure :info name)
947 (error ":TYPE'd DEFSTRUCT ~S not found for inclusion." name)))
949 ;;; Process any included slots pretty much like they were specified.
950 ;;; Also inherit various other attributes.
951 (defun do-dd-inclusion-stuff (dd)
952 (destructuring-bind (included-name &rest modified-slots) (dd-include dd)
953 (let* ((type (dd-type dd))
956 (layout-info (compiler-layout-or-lose included-name))
957 (typed-structure-info-or-lose included-name))))
959 ;; checks on legality
960 (unless (and (eq type (dd-type included-structure))
961 (type= (specifier-type (dd-element-type included-structure))
962 (specifier-type (dd-element-type dd))))
963 (error ":TYPE option mismatch between structures ~S and ~S"
964 (dd-name dd) included-name))
965 (let ((included-class (sb!xc:find-class included-name nil)))
967 ;; It's not particularly well-defined to :INCLUDE any of the
968 ;; CMU CL INSTANCE weirdosities like CONDITION or
969 ;; GENERIC-FUNCTION, and it's certainly not ANSI-compliant.
970 (let* ((included-layout (class-layout included-class))
971 (included-dd (layout-info included-layout)))
972 (when (and (dd-alternate-metaclass included-dd)
973 ;; As of sbcl-0.pre7.73, anyway, STRUCTURE-OBJECT
974 ;; is represented with an ALTERNATE-METACLASS. But
975 ;; it's specifically OK to :INCLUDE (and PCL does)
976 ;; so in this one case, it's OK to include
977 ;; something with :ALTERNATE-METACLASS after all.
978 (not (eql included-name 'structure-object)))
979 (error "can't :INCLUDE class ~S (has alternate metaclass)"
982 (incf (dd-length dd) (dd-length included-structure))
983 (when (dd-class-p dd)
984 (let ((mc (rest (dd-alternate-metaclass included-structure))))
985 (when (and mc (not (dd-alternate-metaclass dd)))
986 (setf (dd-alternate-metaclass dd)
987 (cons included-name mc))))
988 (when (eq (dd-pure dd) :unspecified)
989 (setf (dd-pure dd) (dd-pure included-structure)))
990 (setf (dd-raw-index dd) (dd-raw-index included-structure))
991 (setf (dd-raw-length dd) (dd-raw-length included-structure)))
993 (dolist (included-slot (dd-slots included-structure))
994 (let* ((included-name (dsd-name included-slot))
995 (modified (or (find included-name modified-slots
996 :key #'(lambda (x) (if (atom x) x (car x)))
1001 (copy-structure included-slot)))))))
1003 ;;;; various helper functions for setting up DEFSTRUCTs
1005 ;;; This function is called at macroexpand time to compute the INHERITS
1006 ;;; vector for a structure type definition.
1007 (defun inherits-for-structure (info)
1008 (declare (type defstruct-description info))
1009 (let* ((include (dd-include info))
1010 (superclass-opt (dd-alternate-metaclass info))
1013 (compiler-layout-or-lose (first include))
1014 (class-layout (sb!xc:find-class
1015 (or (first superclass-opt)
1016 'structure-object))))))
1017 (if (eq (dd-name info) 'ansi-stream)
1018 ;; a hack to add the CL:STREAM class as a mixin for ANSI-STREAMs
1019 (concatenate 'simple-vector
1020 (layout-inherits super)
1022 (class-layout (sb!xc:find-class 'stream))))
1023 (concatenate 'simple-vector
1024 (layout-inherits super)
1027 ;;; Do miscellaneous (LOAD EVAL) time actions for the structure
1028 ;;; described by DD. Create the class & LAYOUT, checking for
1029 ;;; incompatible redefinition. Define those functions which are
1030 ;;; sufficiently stereotyped that we can implement them as standard
1032 (defun %defstruct (dd inherits)
1033 (declare (type defstruct-description dd))
1035 #+sb-xc (/show0 "entering %DEFSTRUCT")
1037 ;; We set up LAYOUTs even in the cross-compilation host.
1038 (multiple-value-bind (class layout old-layout)
1039 (ensure-structure-class dd inherits "current" "new")
1040 (cond ((not old-layout)
1041 (unless (eq (class-layout class) layout)
1042 (register-layout layout)))
1044 (let ((old-dd (layout-info old-layout)))
1045 (when (defstruct-description-p old-dd)
1046 (dolist (slot (dd-slots old-dd))
1047 (fmakunbound (dsd-accessor-name slot))
1048 (unless (dsd-read-only slot)
1049 (fmakunbound `(setf ,(dsd-accessor-name slot)))))))
1050 (%redefine-defstruct class old-layout layout)
1051 (setq layout (class-layout class))))
1052 (setf (sb!xc:find-class (dd-name dd)) class)
1054 ;; It doesn't make sense to do these in the cross-compilation host.
1057 #+sb-xc (/show0 "doing #+SB-XC stuff in %DEFSTRUCT")
1058 (remhash (dd-name dd) *typecheckfuns*)
1059 (%target-defstruct dd layout)
1061 (setf (fdocumentation (dd-name dd) 'type)
1063 #+sb-xc (/show0 "done with #+SB-XC stuff in %DEFSTRUCT")
1066 #+sb-xc (/show0 "leaving %DEFSTRUCT")
1069 ;;; Return a form describing the writable place used for this slot
1070 ;;; in the instance named INSTANCE-NAME.
1071 (defun %accessor-place-form (dd dsd instance-name)
1072 (let (;; the operator that we'll use to access a typed slot or, in
1073 ;; the case of a raw slot, to read the vector of raw slots
1074 (ref (ecase (dd-type dd)
1075 (structure '%instance-ref)
1076 (list 'nth-but-with-sane-arg-order)
1078 (raw-type (dsd-raw-type dsd)))
1079 (if (eq raw-type t) ; if not raw slot
1080 `(,ref ,instance-name ,(dsd-index dsd))
1081 (let (;; the operator that we'll use to access one value in
1082 ;; the raw data vector
1083 (rawref (ecase raw-type
1084 ;; The compiler thinks that the raw data
1085 ;; vector is a vector of unsigned bytes, so if
1086 ;; the slot we want to access actually *is* an
1087 ;; unsigned byte, it'll access the slot for
1088 ;; us even if we don't lie to it at all.
1089 (unsigned-byte 'aref)
1090 ;; "A lie can travel halfway round the world while
1091 ;; the truth is putting on its shoes." -- Mark Twain
1092 (single-float '%raw-ref-single)
1093 (double-float '%raw-ref-double)
1094 #!+long-float (long-float '%raw-ref-long)
1095 (complex-single-float '%raw-ref-complex-single)
1096 (complex-double-float '%raw-ref-complex-double)
1097 #!+long-float (complex-long-float
1098 '%raw-ref-complex-long))))
1099 `(,rawref (,ref ,instance-name ,(dd-raw-index dd))
1100 ,(dsd-index dsd))))))
1102 ;;; Return inline expansion designators (i.e. values suitable for
1103 ;;; (INFO :FUNCTION :INLINE-EXPANSSION-DESIGNATOR ..)) for the reader
1104 ;;; and writer functions of the slot described by DSD.
1105 (defun accessor-inline-expansion-designators (dd dsd)
1108 (declare (type ,(dd-name dd) instance))
1109 (truly-the ,(dsd-type dsd)
1110 ,(%accessor-place-form dd dsd 'instance))))
1112 `(lambda (new-value instance)
1113 (declare (type ,(dsd-type dsd) new-value))
1114 (declare (type ,(dd-name dd) structure-object))
1115 (setf ,(%accessor-place-form dd dsd 'instance) new-value)))))
1117 ;;; core compile-time setup of any class with a LAYOUT, used even by
1118 ;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities
1119 (defun %compiler-set-up-layout (dd
1121 ;; Several special cases (STRUCTURE-OBJECT
1122 ;; itself, and structures with alternate
1123 ;; metaclasses) call this function directly,
1124 ;; and they're all at the base of the
1125 ;; instance class structure, so this is
1127 (inherits (vector (find-layout t)
1128 (find-layout 'instance))))
1130 (/show "entering %COMPILER-SET-UP-LAYOUT for" (dd-name dd))
1132 (multiple-value-bind (class layout old-layout)
1133 (multiple-value-bind (clayout clayout-p)
1134 (info :type :compiler-layout (dd-name dd))
1135 (ensure-structure-class dd
1137 (if clayout-p "previously compiled" "current")
1139 :compiler-layout clayout))
1141 (/show "non-NIL" old-layout)
1142 (undefine-structure (layout-class old-layout))
1143 (when (and (class-subclasses class)
1144 (not (eq layout old-layout)))
1146 (dohash (class layout (class-subclasses class))
1147 (declare (ignore layout))
1148 (undefine-structure class)
1149 (subs (class-proper-name class)))
1151 (warn "removing old subclasses of ~S:~% ~S"
1152 (sb!xc:class-name class)
1155 (unless (eq (class-layout class) layout)
1156 (register-layout layout :invalidate nil))
1157 (setf (sb!xc:find-class (dd-name dd)) class)))
1159 ;; At this point the class should be set up in the INFO database.
1160 ;; But the logic that enforces this is a little tangled and
1161 ;; scattered, so it's not obvious, so let's check.
1162 (aver (sb!xc:find-class (dd-name dd) nil))
1164 (setf (info :type :compiler-layout (dd-name dd)) layout))
1166 (/show0 "leaving %COMPILER-SET-UP-LAYOUT")
1170 ;;; Do (COMPILE LOAD EVAL)-time actions for the normal (not
1171 ;;; ALTERNATE-LAYOUT) DEFSTRUCT described by DD.
1172 (defun %compiler-defstruct (dd inherits)
1173 (declare (type defstruct-description dd))
1174 #+sb-xc (/show0 "entering %COMPILER-DEFSTRUCT")
1176 (%compiler-set-up-layout dd inherits)
1178 (let* ((dd-name (dd-name dd))
1179 (dtype (dd-declarable-type dd))
1180 (class (sb!xc:find-class dd-name)))
1182 (let ((copier-name (dd-copier-name dd)))
1184 (sb!xc:proclaim `(ftype (function (,dtype) ,dtype) ,copier-name))))
1186 (let ((predicate-name (dd-predicate-name dd)))
1187 (when predicate-name
1188 (sb!xc:proclaim `(ftype (function (t) t) ,predicate-name))))
1190 (dolist (dsd (dd-slots dd))
1191 (let* ((accessor-name (dsd-accessor-name dsd))
1192 (dsd-type (dsd-type dsd)))
1194 (multiple-value-bind (reader-designator writer-designator)
1195 (accessor-inline-expansion-designators dd dsd)
1196 (sb!xc:proclaim `(ftype (function (,dtype) ,dsd-type)
1198 (setf (info :function
1199 :inline-expansion-designator
1202 (info :function :inlinep accessor-name)
1204 (unless (dsd-read-only dsd)
1205 (let ((setf-accessor-name `(setf ,accessor-name)))
1207 `(ftype (function (,dsd-type ,dtype) ,dsd-type)
1208 ,setf-accessor-name))
1209 (setf (info :function
1210 :inline-expansion-designator
1213 (info :function :inlinep setf-accessor-name)
1216 #+sb-xc (/show0 "leaving %COMPILER-DEFSTRUCT")
1219 ;;;; redefinition stuff
1221 ;;; Compare the slots of OLD and NEW, returning 3 lists of slot names:
1222 ;;; 1. Slots which have moved,
1223 ;;; 2. Slots whose type has changed,
1224 ;;; 3. Deleted slots.
1225 (defun compare-slots (old new)
1226 (let* ((oslots (dd-slots old))
1227 (nslots (dd-slots new))
1228 (onames (mapcar #'dsd-name oslots))
1229 (nnames (mapcar #'dsd-name nslots)))
1232 (dolist (name (intersection onames nnames))
1233 (let ((os (find name oslots :key #'dsd-name))
1234 (ns (find name nslots :key #'dsd-name)))
1235 (unless (subtypep (dsd-type ns) (dsd-type os))
1236 (/noshow "found retyped slots" ns os (dsd-type ns) (dsd-type os))
1238 (unless (and (= (dsd-index os) (dsd-index ns))
1239 (eq (dsd-raw-type os) (dsd-raw-type ns)))
1243 (set-difference onames nnames)))))
1245 ;;; If we are redefining a structure with different slots than in the
1246 ;;; currently loaded version, give a warning and return true.
1247 (defun redefine-structure-warning (class old new)
1248 (declare (type defstruct-description old new)
1249 (type sb!xc:class class)
1251 (let ((name (dd-name new)))
1252 (multiple-value-bind (moved retyped deleted) (compare-slots old new)
1253 (when (or moved retyped deleted)
1255 "incompatibly redefining slots of structure class ~S~@
1256 Make sure any uses of affected accessors are recompiled:~@
1257 ~@[ These slots were moved to new positions:~% ~S~%~]~
1258 ~@[ These slots have new incompatible types:~% ~S~%~]~
1259 ~@[ These slots were deleted:~% ~S~%~]"
1260 name moved retyped deleted)
1263 ;;; This function is called when we are incompatibly redefining a
1264 ;;; structure CLASS to have the specified NEW-LAYOUT. We signal an
1265 ;;; error with some proceed options and return the layout that should
1267 (defun %redefine-defstruct (class old-layout new-layout)
1268 (declare (type sb!xc:class class) (type layout old-layout new-layout))
1269 #+sb-xc (/show0 "entering %REDEFINE-DEFSTRUCT")
1270 (let ((name (class-proper-name class)))
1272 (error "redefining class ~S incompatibly with the current definition"
1275 :report "Invalidate current definition."
1276 (warn "Previously loaded ~S accessors will no longer work." name)
1277 (register-layout new-layout))
1279 :report "Smash current layout, preserving old code."
1280 (warn "Any old ~S instances will be in a bad way.~@
1281 I hope you know what you're doing..."
1283 (register-layout new-layout :invalidate nil
1284 :destruct-layout old-layout))))
1285 #+sb-xc (/show0 "leaving %REDEFINE-DEFSTRUCT")
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)
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)
1307 (typep x 'sb!xc:structure-class))
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) 'ansi-stream)
1313 ;; a hack to add CL:STREAM as a superclass mixin to ANSI-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
1319 :depthoid (length inherits)
1320 :length (dd-length info)
1322 (old-layout (or compiler-layout 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
1337 (layout-length new-layout)
1338 (layout-inherits new-layout)
1339 (layout-depthoid new-layout))
1340 (values class new-layout old-layout))
1342 (let ((old-info (layout-info old-layout)))
1344 ((or defstruct-description)
1345 (cond ((redefine-structure-warning class old-info info)
1346 (values class new-layout old-layout))
1348 (setf (layout-info old-layout) info)
1349 (values class old-layout nil))))
1351 (setf (layout-info old-layout) info)
1352 (values class old-layout nil))
1354 (error "shouldn't happen! strange thing in LAYOUT-INFO:~% ~S"
1356 (values class new-layout old-layout)))))))))
1358 ;;; 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 #+sb-xc (/show0 "entering UNDEFINE-STRUCTURE")
1363 (let ((info (layout-info (class-layout class))))
1364 (when (defstruct-description-p info)
1365 (let ((type (dd-name info)))
1366 (remhash type *typecheckfuns*)
1367 (setf (info :type :compiler-layout type) nil)
1368 (undefine-fun-name (dd-copier-name info))
1369 (undefine-fun-name (dd-predicate-name info))
1370 (dolist (slot (dd-slots info))
1371 (let ((fun (dsd-accessor-name slot)))
1372 (undefine-fun-name fun)
1373 (unless (dsd-read-only slot)
1374 (undefine-fun-name `(setf ,fun))))))
1375 ;; Clear out the SPECIFIER-TYPE cache so that subsequent
1376 ;; references are unknown types.
1377 (values-specifier-type-cache-clear)))
1378 #+sb-xc (/show0 "leaving UNDEFINE-STRUCTURE")
1381 ;;; Return a list of pairs (name . index). Used for :TYPE'd
1382 ;;; constructors to find all the names that we have to splice in &
1383 ;;; where. Note that these types don't have a layout, so we can't look
1384 ;;; at LAYOUT-INHERITS.
1385 (defun find-name-indices (defstruct)
1388 (do ((info defstruct
1389 (typed-structure-info-or-lose (first (dd-include info)))))
1390 ((not (dd-include info))
1395 (dolist (info infos)
1396 (incf i (or (dd-offset info) 0))
1397 (when (dd-named info)
1398 (res (cons (dd-name info) i)))
1399 (setq i (dd-length info)))))
1403 ;;;; slot accessors for raw slots
1405 ;;; Return info about how to read/write a slot in the value stored in
1406 ;;; OBJECT. This is also used by constructors (since we can't safely
1407 ;;; use the accessor function, since some slots are read-only). If
1408 ;;; supplied, DATA is a variable holding the raw-data vector.
1410 ;;; returned values:
1411 ;;; 1. accessor function name (SETFable)
1412 ;;; 2. index to pass to accessor.
1413 ;;; 3. object form to pass to accessor
1414 (defun slot-accessor-form (defstruct slot object &optional data)
1415 (let ((rtype (dsd-raw-type slot)))
1418 (single-float '%raw-ref-single)
1419 (double-float '%raw-ref-double)
1421 (long-float '%raw-ref-long)
1422 (complex-single-float '%raw-ref-complex-single)
1423 (complex-double-float '%raw-ref-complex-double)
1425 (complex-long-float '%raw-ref-complex-long)
1426 (unsigned-byte 'aref)
1427 ((t) '%instance-ref))
1431 (truncate (dsd-index slot) #!+x86 6 #!+sparc 8))
1434 (truncate (dsd-index slot) #!+x86 3 #!+sparc 4))
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))
1444 ((eq rtype t) object)
1447 `(truly-the (simple-array (unsigned-byte 32) (*))
1448 (%instance-ref ,object ,(dd-raw-index defstruct))))))))
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.)
1456 ;;; This is split three ways because:
1457 ;;; * LIST & VECTOR structures need "name" symbols stuck in at
1458 ;;; various weird places, whereas STRUCTURE structures have
1460 ;;; * We really want to use LIST to make list structures, instead of
1461 ;;; MAKE-LIST/(SETF ELT).
1462 ;;; * 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 (defun create-vector-constructor (dd cons-name arglist vars types values)
1466 (let ((temp (gensym))
1467 (etype (dd-element-type dd)))
1468 `(defun ,cons-name ,arglist
1469 (declare ,@(mapcar #'(lambda (var type) `(type (and ,type ,etype) ,var))
1471 (let ((,temp (make-array ,(dd-length dd)
1472 :element-type ',(dd-element-type dd))))
1473 ,@(mapcar #'(lambda (x)
1474 `(setf (aref ,temp ,(cdr x)) ',(car x)))
1475 (find-name-indices dd))
1476 ,@(mapcar #'(lambda (dsd value)
1477 `(setf (aref ,temp ,(dsd-index dsd)) ,value))
1478 (dd-slots dd) values)
1480 (defun create-list-constructor (dd cons-name arglist vars types values)
1481 (let ((vals (make-list (dd-length dd) :initial-element nil)))
1482 (dolist (x (find-name-indices dd))
1483 (setf (elt vals (cdr x)) `',(car x)))
1484 (loop for dsd in (dd-slots dd) and val in values do
1485 (setf (elt vals (dsd-index dsd)) val))
1487 `(defun ,cons-name ,arglist
1488 (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
1491 (defun create-structure-constructor (dd cons-name arglist vars types values)
1492 (let* ((temp (gensym))
1493 (raw-index (dd-raw-index dd))
1494 (n-raw-data (when raw-index (gensym))))
1495 `(defun ,cons-name ,arglist
1496 (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
1498 (let ((,temp (truly-the ,(dd-name dd)
1499 (%make-instance ,(dd-length dd))))
1502 (make-array ,(dd-raw-length dd)
1503 :element-type '(unsigned-byte 32))))))
1504 (setf (%instance-layout ,temp)
1505 (%delayed-get-compiler-layout ,(dd-name dd)))
1507 `((setf (%instance-ref ,temp ,raw-index) ,n-raw-data)))
1508 ,@(mapcar (lambda (dsd value)
1509 (multiple-value-bind (accessor index data)
1510 (slot-accessor-form dd dsd temp n-raw-data)
1511 `(setf (,accessor ,data ,index) ,value)))
1516 ;;; Create a default (non-BOA) keyword constructor.
1517 (defun create-keyword-constructor (defstruct creator)
1518 (collect ((arglist (list '&key))
1521 (dolist (slot (dd-slots defstruct))
1522 (let ((dum (gensym))
1523 (name (dsd-name slot)))
1524 (arglist `((,(keywordicate name) ,dum) ,(dsd-default slot)))
1525 (types (dsd-type slot))
1528 defstruct (dd-default-constructor defstruct)
1529 (arglist) (vals) (types) (vals))))
1531 ;;; Given a structure and a BOA constructor spec, call CREATOR with
1532 ;;; the appropriate args to make a constructor.
1533 (defun create-boa-constructor (defstruct boa creator)
1534 (multiple-value-bind (req opt restp rest keyp keys allowp aux)
1535 (sb!kernel:parse-lambda-list (second boa))
1539 (labels ((get-slot (name)
1540 (let ((res (find name (dd-slots defstruct)
1544 (values (dsd-type res) (dsd-default res))
1547 (multiple-value-bind (type default) (get-slot arg)
1548 (arglist `(,arg ,default))
1554 (types (get-slot arg)))
1557 (arglist '&optional)
1561 (name &optional (def (nth-value 1 (get-slot name))))
1563 (arglist `(,name ,def))
1565 (types (get-slot name))))
1567 (do-default arg)))))
1570 (arglist '&rest rest)
1578 (destructuring-bind (wot &optional (def nil def-p)) key
1579 (let ((name (if (consp wot)
1580 (destructuring-bind (key var) wot
1581 (declare (ignore key))
1584 (multiple-value-bind (type slot-def) (get-slot name)
1585 (arglist `(,wot ,(if def-p def slot-def)))
1590 (when allowp (arglist '&allow-other-keys))
1595 (let* ((arg (if (consp arg) arg (list arg)))
1599 (types (get-slot var))))))
1601 (funcall creator defstruct (first boa)
1602 (arglist) (vars) (types)
1603 (mapcar #'(lambda (slot)
1604 (or (find (dsd-name slot) (vars) :test #'string=)
1605 (dsd-default slot)))
1606 (dd-slots defstruct))))))
1608 ;;; Grovel the constructor options, and decide what constructors (if
1610 (defun constructor-definitions (defstruct)
1611 (let ((no-constructors nil)
1614 (creator (ecase (dd-type defstruct)
1615 (structure #'create-structure-constructor)
1616 (vector #'create-vector-constructor)
1617 (list #'create-list-constructor))))
1618 (dolist (constructor (dd-constructors defstruct))
1619 (destructuring-bind (name &optional (boa-ll nil boa-p)) constructor
1620 (declare (ignore boa-ll))
1621 (cond ((not name) (setq no-constructors t))
1622 (boa-p (push constructor boas))
1623 (t (push name defaults)))))
1625 (when no-constructors
1626 (when (or defaults boas)
1627 (error "(:CONSTRUCTOR NIL) combined with other :CONSTRUCTORs"))
1628 (return-from constructor-definitions ()))
1630 (unless (or defaults boas)
1631 (push (symbolicate "MAKE-" (dd-name defstruct)) defaults))
1635 (let ((cname (first defaults)))
1636 (setf (dd-default-constructor defstruct) cname)
1637 (res (create-keyword-constructor defstruct creator))
1638 (dolist (other-name (rest defaults))
1639 (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
1640 (res `(declaim (ftype function ',other-name))))))
1643 (res (create-boa-constructor defstruct boa creator)))
1645 `((/show0 "beginning CONSTRUCTOR-DEFINITIONS forms")
1647 (/show0 "done with CONSTRUCTOR-DEFINITIONS forms")))))
1649 ;;;; instances with ALTERNATE-METACLASS
1651 ;;;; The CMU CL support for structures with ALTERNATE-METACLASS was a
1652 ;;;; fairly general extension embedded in the main DEFSTRUCT code, and
1653 ;;;; the result was an fairly impressive mess as ALTERNATE-METACLASS
1654 ;;;; extension mixed with ANSI CL generality (e.g. :TYPE and :INCLUDE)
1655 ;;;; and CMU CL implementation hairiness (esp. raw slots). This SBCL
1656 ;;;; version is much less ambitious, noticing that ALTERNATE-METACLASS
1657 ;;;; is only used to implement CONDITION, STANDARD-INSTANCE, and
1658 ;;;; GENERIC-FUNCTION, and defining a simple specialized
1659 ;;;; separate-from-DEFSTRUCT macro to provide only enough
1660 ;;;; functionality to support those.
1662 ;;;; KLUDGE: The defining macro here is so specialized that it's ugly
1663 ;;;; in its own way. It also violates once-and-only-once by knowing
1664 ;;;; much about structures and layouts that is already known by the
1665 ;;;; main DEFSTRUCT macro. Hopefully it will go away presently
1666 ;;;; (perhaps when CL:CLASS and SB-PCL:CLASS meet) as per FIXME below.
1667 ;;;; -- WHN 2001-10-28
1669 ;;;; FIXME: There seems to be no good reason to shoehorn CONDITION,
1670 ;;;; STANDARD-INSTANCE, and GENERIC-FUNCTION into mutated structures
1671 ;;;; instead of just implementing them as primitive objects. (This
1672 ;;;; reduced-functionality macro seems pretty close to the
1673 ;;;; functionality of DEFINE-PRIMITIVE-OBJECT..)
1675 (defun make-dd-with-alternate-metaclass (&key (class-name (missing-arg))
1676 (superclass-name (missing-arg))
1677 (metaclass-name (missing-arg))
1678 (dd-type (missing-arg))
1679 metaclass-constructor
1681 (let* ((dd (make-defstruct-description class-name))
1682 (conc-name (concatenate 'string (symbol-name class-name) "-"))
1683 (dd-slots (let ((reversed-result nil)
1684 ;; The index starts at 1 for ordinary
1685 ;; named slots because slot 0 is
1686 ;; magical, used for LAYOUT in
1687 ;; CONDITIONs or for something (?) in
1688 ;; funcallable instances.
1690 (dolist (slot-name slot-names)
1691 (push (make-defstruct-slot-description
1692 :%name (symbol-name slot-name)
1694 :accessor-name (symbolicate conc-name slot-name))
1697 (nreverse reversed-result))))
1698 (setf (dd-alternate-metaclass dd) (list superclass-name
1700 metaclass-constructor)
1701 (dd-slots dd) dd-slots
1702 (dd-length dd) (1+ (length slot-names))
1703 (dd-type dd) dd-type)
1706 (sb!xc:defmacro !defstruct-with-alternate-metaclass
1708 (slot-names (missing-arg))
1709 (boa-constructor (missing-arg))
1710 (superclass-name (missing-arg))
1711 (metaclass-name (missing-arg))
1712 (metaclass-constructor (missing-arg))
1713 (dd-type (missing-arg))
1715 (runtime-type-checks-p t))
1717 (declare (type (and list (not null)) slot-names))
1718 (declare (type (and symbol (not null))
1722 metaclass-constructor))
1723 (declare (type symbol predicate))
1724 (declare (type (member structure funcallable-structure) dd-type))
1726 (/show "entering !DEFSTRUCT-WITH-ALTERNATE-METACLASS expander" class-name)
1727 (let* ((dd (make-dd-with-alternate-metaclass
1728 :class-name class-name
1729 :slot-names slot-names
1730 :superclass-name superclass-name
1731 :metaclass-name metaclass-name
1732 :metaclass-constructor metaclass-constructor
1734 (conc-name (concatenate 'string (symbol-name class-name) "-"))
1735 (dd-slots (dd-slots dd))
1736 (dd-length (1+ (length slot-names)))
1737 (object-gensym (gensym "OBJECT"))
1738 (new-value-gensym (gensym "NEW-VALUE-"))
1739 (delayed-layout-form `(%delayed-get-compiler-layout ,class-name)))
1740 (multiple-value-bind (raw-maker-form raw-reffer-operator)
1743 (values `(let ((,object-gensym (%make-instance ,dd-length)))
1744 (setf (%instance-layout ,object-gensym)
1745 ,delayed-layout-form)
1748 (funcallable-structure
1749 (values `(%make-funcallable-instance ,dd-length
1750 ,delayed-layout-form)
1751 '%funcallable-instance-info)))
1752 (/show dd raw-maker-form raw-reffer-operator)
1755 (eval-when (:compile-toplevel :load-toplevel :execute)
1756 (%compiler-set-up-layout ',dd))
1758 ;; slot readers and writers
1759 (declaim (inline ,@(mapcar #'dsd-accessor-name dd-slots)))
1760 ,@(mapcar (lambda (dsd)
1761 `(defun ,(dsd-accessor-name dsd) (,object-gensym)
1762 ,@(when runtime-type-checks-p
1763 `((declare (type ,class-name ,object-gensym))))
1764 (,raw-reffer-operator ,object-gensym
1767 (declaim (inline ,@(mapcar (lambda (dsd)
1768 `(setf ,(dsd-accessor-name dsd)))
1770 ,@(mapcar (lambda (dsd)
1771 `(defun (setf ,(dsd-accessor-name dsd)) (,new-value-gensym
1773 ,@(when runtime-type-checks-p
1774 `((declare (type ,class-name ,object-gensym))))
1775 (setf (,raw-reffer-operator ,object-gensym
1777 ,new-value-gensym)))
1781 (defun ,boa-constructor ,slot-names
1782 (let ((,object-gensym ,raw-maker-form))
1783 ,@(mapcar (lambda (slot-name)
1784 (let ((dsd (find (symbol-name slot-name) dd-slots
1787 `(setf (,(dsd-accessor-name dsd) ,object-gensym)
1794 ;; Just delegate to the compiler's type optimization
1795 ;; code, which knows how to generate inline type tests
1796 ;; for the whole CMU CL INSTANCE menagerie.
1797 `(defun ,predicate (,object-gensym)
1798 (typep ,object-gensym ',class-name)))))))
1800 ;;;; finalizing bootstrapping
1802 ;;; Set up DD and LAYOUT for STRUCTURE-OBJECT class itself.
1804 ;;; Ordinary structure classes effectively :INCLUDE STRUCTURE-OBJECT
1805 ;;; when they have no explicit :INCLUDEs, so (1) it needs to be set up
1806 ;;; before we can define ordinary structure classes, and (2) it's
1807 ;;; special enough (and simple enough) that we just build it by hand
1808 ;;; instead of trying to generalize the ordinary DEFSTRUCT code.
1809 (defun !set-up-structure-object-class ()
1810 (/show0 "entering !SET-UP-STRUCTURE-OBJECT-CLASS")
1811 (let ((dd (make-defstruct-description 'structure-object)))
1813 ;; Note: This has an ALTERNATE-METACLASS only because of blind
1814 ;; clueless imitation of the CMU CL code -- dunno if or why it's
1816 (dd-alternate-metaclass dd) '(instance)
1819 (dd-type dd) 'structure)
1820 (/show0 "about to %COMPILER-SET-UP-LAYOUT")
1821 (%compiler-set-up-layout dd))
1822 (/show0 "leaving !SET-UP-STRUCTURE-OBJECT-CLASS"))
1823 (!set-up-structure-object-class)
1825 ;;; early structure predeclarations: Set up DD and LAYOUT for ordinary
1826 ;;; (non-ALTERNATE-METACLASS) structures which are needed early.
1828 '#.(sb-cold:read-from-file
1829 "src/code/early-defstruct-args.lisp-expr"))
1830 (let* ((dd (parse-defstruct-name-and-options-and-slot-descriptions
1833 (inherits (inherits-for-structure dd)))
1834 (%compiler-defstruct dd inherits)))
1836 (/show0 "code/defstruct.lisp end of file")