/[cmucl]/src/code/defstruct.lisp
ViewVC logotype

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.37.1.6 - (show annotations) (vendor branch)
Sat Feb 13 13:30:26 1993 UTC (21 years, 2 months ago) by ram
Branch: new_struct
Changes since 1.37.1.5: +10 -5 lines
Don't use load-time-value to get layout in the constructor, instead
reference as a constant.  Avoids cold-load init problem & saves space
1 ;;; -*- Package: KERNEL -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/defstruct.lisp,v 1.37.1.6 1993/02/13 13:30:26 ram Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Defstruct structure definition package (Mark III).
15 ;;; Written by Rob MacLachlan, William Lott and Skef Wholey.
16 ;;;
17 (in-package "LISP")
18 (export '(defstruct copy-structure structure-object))
19 (in-package "KERNEL")
20 (export '(
21 default-structure-print make-structure-load-form
22 %compiler-defstruct %%compiler-defstruct
23 %make-instance
24 %instance-length %instance-ref %instance-set %instance-layout
25 %set-instance-layout
26 %raw-ref-single %raw-set-single
27 %raw-ref-double %raw-set-double
28 defstruct-description dd-name dd-default-constructor dd-copier
29 dd-predicate dd-slots dd-length dd-type dd-raw-index dd-raw-length
30 defstruct-slot-description dsd-name dsd-%name dsd-accessor dsd-type
31 dsd-index dsd-raw-type dsd-read-only undefine-structure))
32
33
34 ;;;; Structure frobbing primitives.
35
36 #+ns-boot
37 (defun %instancep (x)
38 (structurep x))
39
40 #-ns-boot
41 (defun %make-instance (length)
42 "Allocate a new instance with LENGTH data slots."
43 (declare (type index length))
44 (%make-instance length))
45
46 (defun %instance-length (instance)
47 "Given an instance, return its length."
48 (declare (type instance instance))
49 #+ns-boot
50 (structure-length instance)
51 #-ns-boot
52 (%instance-length instance))
53
54 (defun %instance-ref (instance index)
55 "Return the value from the INDEXth slot of INSTANCE. This is SETFable."
56 #+ns-boot
57 (structure-ref instance index)
58 #-ns-boot
59 (%instance-ref instance index))
60
61 #-ns-boot (progn
62 (defun %instance-set (instance index new-value)
63 "Set the INDEXth slot of INSTANCE to NEW-VALUE."
64 (setf (%instance-ref instance index) new-value))
65
66 (defun %raw-ref-single (vec index)
67 (declare (type index index))
68 (%raw-ref-single vec index))
69
70 (defun %raw-ref-double (vec index)
71 (declare (type index index))
72 (%raw-ref-double vec index))
73
74 (defun %raw-set-single (vec index val)
75 (declare (type index index))
76 (%raw-set-single vec index val))
77
78 (defun %raw-set-double (vec index val)
79 (declare (type index index))
80 (%raw-set-double vec index val))
81
82 ); #-ns-boot progn
83
84 (defun %instance-layout (instance)
85 #+ns-boot
86 (layout-of instance)
87 #-ns-boot
88 (%instance-layout instance))
89
90 #-ns-boot
91 (defun %set-instance-layout (instance new-value)
92 (%set-instance-layout instance new-value))
93
94 (defsetf %instance-ref %instance-set)
95 (defsetf %raw-ref-single %raw-set-single)
96 (defsetf %raw-ref-double %raw-set-double)
97 (defsetf %instance-layout %set-instance-layout)
98
99 ;;; This version of Defstruct is implemented using Defstruct, and is free of
100 ;;; Maclisp compatability nonsense. For bootstrapping, you're on your own.
101
102 #-ns-boot
103 ;;; Define the STRUCTURE-OBJECT class as a subclass of INSTANCE.
104 ;;;
105 (defstruct (structure-object (:alternate-metaclass instance)))
106
107
108 ;;; The DEFSTRUCT-DESCRIPTION structure holds compile-time information about a
109 ;;; structure type.
110 ;;;
111 (defstruct (defstruct-description
112 (:conc-name dd-)
113 (:print-function print-defstruct-description)
114 (:make-load-form-fun :just-dump-it-normally)
115 (:constructor make-defstruct-description (name)))
116 ;;
117 ;; name of the structure
118 (name (required-argument) :type symbol)
119 ;;
120 ;; documentation on the structure
121 (doc nil :type (or string null))
122 ;;
123 ;; prefix for slot names. If NIL, none.
124 (conc-name (concat-pnames name '-) :type (or symbol null))
125 ;;
126 ;; The name of the primary standard keyword constructor, or NIL if none.
127 (default-constructor nil :type (or symbol null))
128 ;;
129 ;; All the explicit :CONSTRUCTOR specs, with name defaulted.
130 (constructors () :type list)
131 ;;
132 ;; name of copying function
133 (copier (concat-pnames 'copy- name) :type (or symbol null))
134 ;;
135 ;; Name of type predictate
136 (predicate (concat-pnames name '-p) :type (or symbol null))
137 ;;
138 ;; The arguments to the :INCLUDE option, or NIL if no included structure.
139 (include nil :type list)
140 ;;
141 ;; The arguments to the :ALTERNATE-METACLASS option (an extension used to
142 ;; define structure-like objects with an arbitrary superclass and that may
143 ;; not have STRUCTURE-CLASS as the metaclass.) Syntax is:
144 ;; (superclass-name metaclass-name metaclass-constructor)
145 ;;
146 (alternate-metaclass nil :type list)
147 ;;
148 ;; list of defstruct-slot-description objects for all slots (including
149 ;; included ones.)
150 (slots () :type list)
151 ;;
152 ;; Number of elements we've allocated (see also raw-length.)
153 (length 0 :type index)
154 ;;
155 ;; General kind of implementation.
156 (type 'structure :type (member structure vector list))
157 ;;
158 ;; The next three slots are for :TYPE'd structures (which aren't classes,
159 ;; i.e. dd-type /= structure.)
160 ;;
161 ;; Vector element type.
162 (element-type 't)
163 ;;
164 ;; T if :NAMED was explicitly specified, Nil otherwise.
165 (named nil :type boolean)
166 ;;
167 ;; Any INITIAL-OFFSET option on this direct type.
168 (offset nil :type (or index null))
169 ;;
170 ;; The next five slots are only meaningful in real default structures (i.e.
171 ;; dd-type = structure), since they are recognizably typed objects (classes.)
172 ;;
173 ;; The argument to the PRINT-FUNCTION option, or NIL if none. If we see an
174 ;; explicit (:PRINT-FUNCTION) option, then this is DEFAULT-STRUCTURE-PRINT.
175 ;; See also STRUCTURE-CLASS-PRINTER.
176 (print-function nil :type (or cons symbol null))
177 ;;
178 ;; Make-load-form function option. See also STRUCTURE-CLASS-LOAD-FORM-MAKER.
179 (make-load-form-fun nil :type (or symbol cons null))
180 ;;
181 ;; The index of the raw data vector and the number of words in it. NIL and 0
182 ;; if not allocated yet.
183 (raw-index nil :type (or index null))
184 (raw-length 0 :type index))
185
186
187 ;;; DEFSTRUCT-SLOT-DESCRIPTION holds compile-time information about structure
188 ;;; slots.
189 ;;;
190 (defstruct (defstruct-slot-description
191 (:conc-name dsd-)
192 (:print-function print-defstruct-slot-description)
193 (:make-load-form-fun :just-dump-it-normally))
194 %name ; string name of slot
195 ;;
196 ;; its position in the implementation sequence
197 (index (required-argument) :type fixnum)
198 ;;
199 ;; Name of accesor, or NIL if this accessor has the same name as an inherited
200 ;; accessor (which we don't want to shadow.)
201 (accessor nil)
202 default ; default value expression
203 (type t) ; declared type specifier
204 ;;
205 ;; If a raw slot, what it holds. T means not raw.
206 (raw-type t :type (member t single-float double-float unsigned-byte))
207 (read-only nil :type (member t nil)))
208
209 (defun print-defstruct-description (structure stream depth)
210 (declare (ignore depth))
211 (format stream "#<Defstruct-Description for ~S>" (dd-name structure)))
212
213
214 (defun compiler-layout-or-lose (name)
215 (let ((res (info type compiler-layout name)))
216 (cond ((not res)
217 (error "Class not yet defined or was undefined: ~S" name))
218 ((not (defstruct-description-p (layout-info res)))
219 (error "Inherited class is not a STRUCTURE-CLASS: ~S" name))
220 (t res))))
221
222
223 ;;; DSD-Name -- External
224 ;;;
225 ;;; Return the the name of a defstruct slot as a symbol. We store it
226 ;;; as a string to avoid creating lots of worthless symbols at load time.
227 ;;;
228 (defun dsd-name (dsd)
229 (intern (string (dsd-%name dsd))
230 (if (dsd-accessor dsd)
231 (symbol-package (dsd-accessor dsd))
232 *package*)))
233
234 (defun print-defstruct-slot-description (structure stream depth)
235 (declare (ignore depth))
236 (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure)))
237
238
239 ;;; The legendary macro itself.
240
241 ;;; DEFINE-CLASS-METHODS -- Internal
242 ;;;
243 ;;; Return a list of forms to install print and make-load-form funs, mentioning
244 ;;; them in the expansion so that they can be compiled.
245 ;;;
246 (defun define-class-methods (defstruct)
247 (let ((name (dd-name defstruct)))
248 `(,@(let ((pf (dd-print-function defstruct)))
249 (when pf
250 `((setf (structure-class-print-function (find-class ',name))
251 ,(if (symbolp pf)
252 `',pf
253 `#',pf)))))
254 ,@(let ((mlff (dd-make-load-form-fun defstruct)))
255 (when mlff
256 `((setf (structure-class-make-load-form-fun (find-class ',name))
257 ,(if (symbolp mlff)
258 `',mlff
259 `#',mlff))))))))
260
261 ;;; DEFSTRUCT -- Public
262 ;;;
263 (defmacro defstruct (name-and-options &rest slot-descriptions)
264 "DEFSTRUCT {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)}
265 Define the structure type Name. Instances are created by MAKE-<name>, which
266 takes keyword arguments allowing initial slot values to the specified.
267 A SETF'able function <name>-<slot> is defined for each slot to read&write
268 slot values. <name>-p is a type predicate.
269
270 Popular DEFSTRUCT options (see manual for others):
271
272 (:CONSTRUCTOR Name)
273 (:PREDICATE Name)
274 Specify an alternate name for the constructor or predicate.
275
276 (:CONSTRUCTOR Name Lambda-List)
277 Explicitly specify the name and arguments to create a BOA constructor
278 (which is more efficient when keyword syntax isn't necessary.)
279
280 (:INCLUDE Supertype Slot-Spec*)
281 Make this type a subtype of the structure type Supertype. The optional
282 Slot-Specs override inherited slot options.
283
284 Slot options:
285
286 :TYPE Type-Spec
287 Asserts that the value of this slot is always of the specified type.
288
289 :READ-ONLY {T | NIL}
290 If true, no setter function is defined for this slot."
291
292 (let* ((defstruct (parse-name-and-options
293 (if (atom name-and-options)
294 (list name-and-options)
295 name-and-options)))
296 (name (dd-name defstruct)))
297 (when (stringp (car slot-descriptions))
298 (setf (dd-doc defstruct) (pop slot-descriptions)))
299 (dolist (slot slot-descriptions)
300 (allocate-1-slot defstruct (parse-1-dsd defstruct slot)))
301 (if (eq (dd-type defstruct) 'structure)
302 (let ((inherits (inherits-for-structure defstruct)))
303 `(progn
304 (%defstruct ',defstruct ',inherits)
305 (eval-when (compile)
306 (%compiler-only-defstruct ',defstruct ',inherits))
307 (%compiler-defstruct ',defstruct)
308 ,@(define-raw-accessors defstruct)
309 ,@(define-constructors defstruct)
310 ,@(define-class-methods defstruct)
311 ',name))
312 `(progn
313 (eval-when (compile load eval)
314 (setf (info typed-structure info ',name) ',defstruct))
315 ,@(define-constructors defstruct)
316 ,@(define-predicate defstruct)
317 ,@(define-accessors defstruct)
318 ,@(define-copier defstruct)
319 ',name))))
320
321
322 ;;;; Parsing:
323
324 ;;; PARSE-1-OPTION -- Internal
325 ;;;
326 ;;; Parse a single defstruct option and store the results in Defstruct.
327 ;;;
328 (defun parse-1-option (option defstruct)
329 (let ((args (rest option))
330 (name (dd-name defstruct)))
331 (case (first option)
332 (:conc-name
333 (destructuring-bind (conc-name) args
334 (setf (dd-conc-name defstruct)
335 (if (symbolp conc-name)
336 conc-name
337 (make-symbol (string conc-name))))))
338 (:constructor
339 (destructuring-bind (&optional (cname (concat-pnames 'make- name))
340 &rest stuff)
341 args
342 (push (cons cname stuff) (dd-constructors defstruct))))
343 (:copier
344 (destructuring-bind (&optional (copier (concat-pnames 'copy- name)))
345 args
346 (setf (dd-copier defstruct) copier)))
347 (:predicate
348 (destructuring-bind (&optional (pred (concat-pnames name '-p)))
349 args
350 (setf (dd-predicate defstruct) pred)))
351 (:include
352 (when (dd-include defstruct)
353 (error "Can't have more than one :INCLUDE option."))
354 (setf (dd-include defstruct) args))
355 (:alternate-metaclass
356 (setf (dd-alternate-metaclass defstruct) args))
357 (:print-function
358 (destructuring-bind (&optional (fun 'default-structure-print)) args
359 (setf (dd-print-function defstruct) fun)))
360 (:type
361 (destructuring-bind (type) args
362 (cond ((member type '(list vector))
363 (setf (dd-element-type defstruct) 't)
364 (setf (dd-type defstruct) type))
365 ((and (consp type) (eq (first type) 'vector))
366 (destructuring-bind (vector vtype) type
367 (declare (ignore vector))
368 (setf (dd-element-type defstruct) vtype)
369 (setf (dd-type defstruct) 'vector)))
370 (t
371 (error "~S is a bad :TYPE for Defstruct." type)))))
372 (:named
373 (error "The Defstruct option :NAMED takes no arguments."))
374 (:initial-offset
375 (destructuring-bind (offset) args
376 (setf (dd-offset defstruct) offset)))
377 (:make-load-form-fun
378 (destructuring-bind (fun) args
379 (setf (dd-make-load-form-fun defstruct) fun)))
380 (t (error "Unknown DEFSTRUCT option~% ~S" option)))))
381
382
383 ;;; PARSE-NAME-AND-OPTIONS -- Internal
384 ;;;
385 ;;; Given name and options, return a DD holding that info.
386 ;;;
387 (defun parse-name-and-options (name-and-options)
388 (destructuring-bind (name &rest options) name-and-options
389 (let ((defstruct (make-defstruct-description name)))
390 (dolist (option options)
391 (cond ((consp option)
392 (parse-1-option option defstruct))
393 ((eq option :named)
394 (setf (dd-named defstruct) t))
395 ((member option '(:constructor :copier :predicate :named))
396 (parse-1-option (list option) defstruct))
397 (t
398 (error "Unrecognized DEFSTRUCT option: ~S" option))))
399
400 (cond
401 ((eq (dd-type defstruct) 'structure)
402 (when (dd-offset defstruct)
403 (error "Can't specify :OFFSET unless :TYPE is specified."))
404 (unless (dd-include defstruct)
405 (incf (dd-length defstruct))))
406 (t
407 (when (dd-print-function defstruct)
408 (warn "Silly to specify :PRINT-FUNCTION with :TYPE."))
409 (when (dd-make-load-form-fun defstruct)
410 (warn "Silly to specify :MAKE-LOAD-FORM-FUN with :TYPE."))
411 (when (dd-named defstruct) (incf (dd-length defstruct)))
412 (let ((offset (dd-offset defstruct)))
413 (when offset (incf (dd-length defstruct) offset)))))
414
415 (when (dd-include defstruct)
416 (do-inclusion-stuff defstruct))
417
418 defstruct)))
419
420
421 ;;;; Stuff to parse slot descriptions.
422
423 ;;; PARSE-1-DSD -- Internal
424 ;;;
425 ;;; Parse a slot description for DEFSTRUCT, add it to the description and
426 ;;; return it. If supplied, ISLOT is a pre-initialized DSD that we modify to
427 ;;; get the new slot. This is supplied when handling included slots. If the
428 ;;; new accessor name is already an accessor for same slot in some included
429 ;;; structure, then set the DSD-ACCESSOR to NIL so that we don't clobber the
430 ;;; more general accessor.
431 ;;;
432 (defun parse-1-dsd (defstruct spec &optional
433 (islot (make-defstruct-slot-description
434 :%name "" :index 0 :type t)))
435 (multiple-value-bind
436 (name default default-p type type-p read-only ro-p)
437 (cond
438 ((listp spec)
439 (destructuring-bind (name &optional (default nil default-p)
440 &key (type nil type-p) (read-only nil ro-p))
441 spec
442 (values name default default-p type type-p read-only ro-p)))
443 (t
444 (when (keywordp spec)
445 (warn "Keyword slot name indicates probable syntax ~
446 error in DEFSTRUCT -- ~S."
447 spec))
448 spec))
449 (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)
450 (error "Duplicate slot name ~S." name))
451 (setf (dsd-%name islot) (string name))
452 (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot)))
453
454 (let* ((aname (concat-pnames (dd-conc-name defstruct) name))
455 (existing (info function accessor-for aname)))
456 (if #-ns-boot
457 (and (structure-class-p existing)
458 (not (eq (class-name existing) (dd-name defstruct)))
459 (string= (dsd-%name (find aname (dd-slots existing)
460 :key #'dsd-accessor))
461 name))
462 #+ns-boot nil
463 (setf (dsd-accessor islot) nil)
464 (setf (dsd-accessor islot) aname)))
465
466 (when default-p
467 (setf (dsd-default islot) default))
468 (when type-p
469 (setf (dsd-type islot)
470 (if (eq (dsd-type islot) 't)
471 type
472 `(and ,(dsd-type islot) ,type))))
473 (when ro-p
474 (if read-only
475 (setf (dsd-read-only islot) t)
476 (when (dsd-read-only islot)
477 (error "Slot ~S must be read-only in subtype ~S." name
478 (dsd-name islot)))))
479 islot))
480
481
482 ;;; ALLOCATE-1-SLOT -- Internal
483 ;;;
484 ;;; Allocate storage for a DSD in Defstruct. This is where we decide if a
485 ;;; slot is raw or not. If raw, and we haven't allocated a raw-index yet for
486 ;;; the raw data vector, then do it. Raw objects are aligned on the unit of
487 ;;; their size.
488 ;;;
489 (defun allocate-1-slot (defstruct dsd)
490 (let ((type (dsd-type dsd)))
491 (multiple-value-bind
492 (raw-type words)
493 (cond ((not (eq (dd-type defstruct) 'structure))
494 (values nil nil))
495 ((and (subtypep type '(unsigned-byte 32))
496 (not (subtypep type 'fixnum)))
497 (values 'unsigned-byte 1))
498 ((subtypep type 'single-float)
499 (values 'single-float 1))
500 ((subtypep type 'double-float)
501 (values 'double-float 2))
502 (t (values nil nil)))
503
504 (cond ((not raw-type)
505 (setf (dsd-index dsd) (dd-length defstruct))
506 (incf (dd-length defstruct)))
507 (t
508 (unless (dd-raw-index defstruct)
509 (setf (dd-raw-index defstruct) (dd-length defstruct))
510 (incf (dd-length defstruct)))
511 (let ((off (rem (dd-length defstruct) words)))
512 (unless (zerop off)
513 (incf (dd-raw-length defstruct) (- words off))))
514 (setf (dsd-raw-type dsd) raw-type)
515 (setf (dsd-index dsd) (dd-raw-length defstruct))
516 (incf (dd-raw-length defstruct) words)))))
517
518 (undefined-value))
519
520
521 ;;; DO-INCLUSION-STUFF -- Internal
522 ;;;
523 ;;; Process any included slots pretty much like they were specified. Also
524 ;;; inherit various other attributes (print function, etc.)
525 ;;;
526 (defun do-inclusion-stuff (defstruct)
527 (destructuring-bind (included-name &rest modified-slots)
528 (dd-include defstruct)
529 (let* ((type (dd-type defstruct))
530 (included-structure
531 (if (eq type 'structure)
532 (layout-info (compiler-layout-or-lose included-name))
533 (typed-structure-info-or-lose included-name))))
534 (unless (and (eq type (dd-type included-structure))
535 (type= (specifier-type (dd-element-type included-structure))
536 (specifier-type (dd-element-type defstruct))))
537 (error ":TYPE option mismatch between structures ~S and ~S."
538 (dd-name defstruct) included-name))
539
540 (incf (dd-length defstruct) (dd-length included-structure))
541 (when (eq (dd-type defstruct) 'structure)
542 (unless (dd-print-function defstruct)
543 (setf (dd-print-function defstruct)
544 (dd-print-function included-structure)))
545 (unless (dd-make-load-form-fun defstruct)
546 (setf (dd-make-load-form-fun defstruct)
547 (dd-make-load-form-fun included-structure)))
548 (setf (dd-raw-index defstruct) (dd-raw-index included-structure))
549 (setf (dd-raw-length defstruct) (dd-raw-length included-structure)))
550
551 (dolist (islot (dd-slots included-structure))
552 (let* ((iname (dsd-name islot))
553 (modified (or (find iname modified-slots
554 :key #'(lambda (x) (if (atom x) x (car x)))
555 :test #'string=)
556 `(,iname))))
557 (parse-1-dsd defstruct modified
558 (copy-defstruct-slot-description islot)))))))
559
560
561
562 ;;;; Constructors:
563
564 (defun typed-structure-info-or-lose (name)
565 (or (info typed-structure info name)
566 (error ":TYPE'd defstruct ~S not found for inclusion." name)))
567
568 ;;; %GET-COMPILER-LAYOUT -- Internal
569 ;;;
570 ;;; Delay looking for compiler-layout until the constructor is being compiled,
571 ;;; since it doesn't exist until after the eval-when (compile) is compiled.
572 ;;;
573 (defmacro %get-compiler-layout (name)
574 `',(compiler-layout-or-lose name))
575
576 ;;; FIND-NAME-INDICES -- Internal
577 ;;;
578 ;;; Returns a list of pairs (name . index). Used for :TYPE'd constructors
579 ;;; to find all the names that we have to splice in & where. Note that these
580 ;;; types don't have a layout, so we can't look at LAYOUT-INHERITS.
581 ;;;
582 (defun find-name-indices (defstruct)
583 (collect ((res))
584 (let ((infos ()))
585 (do ((info defstruct
586 (typed-structure-info-or-lose (first (dd-include info)))))
587 ((not (dd-include info))
588 (push info infos))
589 (push info infos))
590
591 (let ((i 0))
592 (dolist (info infos)
593 (incf i (or (dd-offset info) 0))
594 (when (dd-named info)
595 (res (cons (dd-name info) i)))
596 (setq i (dd-length info)))))
597
598 (res)))
599
600
601 ;;; CREATE-{STRUCTURE,VECTOR,LIST}-CONSTRUCTOR -- Internal
602 ;;;
603 ;;; These functions are called to actually make a constructor after we have
604 ;;; processed the arglist. The correct variant (according to the DD-TYPE)
605 ;;; should be called. The function is defined with the specified name and
606 ;;; arglist. Vars and Types are used for argument type declarations. Values
607 ;;; are the values for the slots (in order.)
608 ;;;
609 ;;; This is split three ways because:
610 ;;; 1] list & vector structures need "name" symbols stuck in at various weird
611 ;;; places, whereas STRUCTURE structures have a LAYOUT slot.
612 ;;; 2] We really want to use LIST to make list structures, instead of
613 ;;; MAKE-LIST/(SETF ELT).
614 ;;; 3] STRUCTURE structures can have raw slots that must also be allocated and
615 ;;; indirectly referenced. We use SLOT-ACCESSOR-FORM to compute how to set
616 ;;; the slots, which deals with raw slots.
617 ;;;
618 (defun create-vector-constructor
619 (defstruct cons-name arglist vars types values)
620 (let ((temp (gensym))
621 (etype (dd-element-type defstruct)))
622 `(defun ,cons-name ,arglist
623 (declare ,@(mapcar #'(lambda (var type) `(type (and ,type ,etype) ,var))
624 vars types))
625 (let ((,temp (make-array ,(dd-length defstruct)
626 :element-type ',(dd-element-type defstruct))))
627 ,@(mapcar #'(lambda (x)
628 `(setf (aref ,temp ,(cdr x)) ',(car x)))
629 (find-name-indices defstruct))
630 ,@(mapcar #'(lambda (dsd value)
631 `(setf (aref ,temp ,(dsd-index dsd)) ,value))
632 (dd-slots defstruct) values)
633 ,temp))))
634 ;;;
635 (defun create-list-constructor
636 (defstruct cons-name arglist vars types values)
637 (let ((vals (make-list (dd-length defstruct) :initial-element nil)))
638 (dolist (x (find-name-indices defstruct))
639 (setf (elt vals (cdr x)) `',(car x)))
640 (loop for dsd in (dd-slots defstruct) and val in values do
641 (setf (elt vals (dsd-index dsd)) val))
642
643 `(defun ,cons-name ,arglist
644 (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
645 vars types))
646 (list ,@vals))))
647 ;;;
648 (defun create-structure-constructor
649 (defstruct cons-name arglist vars types values)
650 (let* ((temp (gensym))
651 (raw-index (dd-raw-index defstruct))
652 (n-raw-data (when raw-index (gensym))))
653 `(defun ,cons-name ,arglist
654 (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
655 vars types))
656 (let ((,temp (truly-the ,(dd-name defstruct)
657 (%make-instance ,(dd-length defstruct))))
658 ,@(when n-raw-data
659 `(,n-raw-data
660 (make-array ,(dd-raw-length defstruct)
661 :element-type '(unsigned-byte 32)))))
662 (setf (%instance-layout ,temp)
663 (%get-compiler-layout ,(dd-name defstruct)))
664 ,@(when n-raw-data
665 `((setf (%instance-ref ,temp ,raw-index) ,n-raw-data)))
666 ,@(mapcar #'(lambda (dsd value)
667 (multiple-value-bind
668 (accessor index data)
669 (slot-accessor-form defstruct dsd temp n-raw-data)
670 `(setf (,accessor ,data ,index) ,value)))
671 (dd-slots defstruct)
672 values)
673 ,temp))))
674
675
676 ;;; CREATE-KEYWORD-CONSTRUCTOR -- Internal
677 ;;;
678 ;;; Create a default (non-BOA) keyword constructor.
679 ;;;
680 (defun create-keyword-constructor (defstruct creator)
681 (collect ((arglist (list '&key))
682 (types)
683 (vals))
684 (dolist (slot (dd-slots defstruct))
685 (let ((dum (gensym))
686 (name (dsd-name slot)))
687 (arglist `((,(intern (string name) "KEYWORD") ,dum)
688 ,(dsd-default slot)))
689 (types (dsd-type slot))
690 (vals dum)))
691 (funcall creator
692 defstruct (dd-default-constructor defstruct)
693 (arglist) (vals) (types) (vals))))
694
695
696 ;;; CREATE-BOA-CONSTRUCTOR -- Internal
697 ;;;
698 ;;; Given a structure and a BOA constructor spec, call Creator with the
699 ;;; appropriate args to make a constructor.
700 ;;;
701 (defun create-boa-constructor (defstruct boa creator)
702 (multiple-value-bind (req opt restp rest keyp keys allowp aux)
703 (kernel:parse-lambda-list (second boa))
704 (collect ((arglist)
705 (vars)
706 (types))
707 (labels ((get-slot (name)
708 (let ((res (find name (dd-slots defstruct) :test #'string=
709 :key #'dsd-name)))
710 (if res
711 (values (dsd-type res) (dsd-default res))
712 (values t nil))))
713 (do-default (arg)
714 (multiple-value-bind (type default) (get-slot arg)
715 (arglist `(,arg ,default))
716 (vars arg)
717 (types type))))
718 (dolist (arg req)
719 (arglist arg)
720 (vars arg)
721 (types (get-slot arg)))
722
723 (when opt
724 (arglist '&optional)
725 (dolist (arg opt)
726 (cond ((consp arg)
727 (destructuring-bind
728 (name &optional (def (nth-value 1 (get-slot name))))
729 arg
730 (arglist `(,name ,def))
731 (vars name)
732 (types (get-slot name))))
733 (t
734 (do-default arg)))))
735
736 (when restp
737 (arglist '&rest rest)
738 (vars rest)
739 (types 'list))
740
741 (when keyp
742 (arglist '&key)
743 (dolist (key keys)
744 (if (consp key)
745 (destructuring-bind (wot &optional (def nil def-p))
746 key
747 (let ((name (if (consp wot)
748 (destructuring-bind (key var) wot
749 (declare (ignore key))
750 var)
751 wot)))
752 (multiple-value-bind (type slot-def) (get-slot name)
753 (arglist `(,wot ,(if def-p def slot-def)))
754 (vars name)
755 (types type))))
756 (do-default key))))
757
758 (when allowp (arglist '&allow-other-keys))
759
760 (when aux
761 (arglist '&aux)
762 (dolist (arg aux)
763 (let* ((arg (if (consp arg) arg (list arg)))
764 (var (first arg)))
765 (arglist arg)
766 (vars var)
767 (types (get-slot var))))))
768
769 (funcall creator defstruct (first boa)
770 (arglist) (vars) (types)
771 (mapcar #'(lambda (slot)
772 (or (find (dsd-name slot) (vars))
773 (dsd-default slot)))
774 (dd-slots defstruct))))))
775
776
777 ;;; DEFINE-CONSTRUCTORS -- Internal
778 ;;;
779 ;;; Grovel the constructor options, and decide what constructors (if any) to
780 ;;; create.
781 ;;;
782 (defun define-constructors (defstruct)
783 (let ((no-constructors nil)
784 (boas ())
785 (defaults ())
786 (creator (ecase (dd-type defstruct)
787 (structure #'create-structure-constructor)
788 (vector #'create-vector-constructor)
789 (list #'create-list-constructor))))
790 (dolist (constructor (dd-constructors defstruct))
791 (destructuring-bind (name &optional (boa-ll nil boa-p))
792 constructor
793 (declare (ignore boa-ll))
794 (cond ((not name) (setq no-constructors t))
795 (boa-p (push constructor boas))
796 (t (push name defaults)))))
797
798 (when no-constructors
799 (when (or defaults boas)
800 (error "(:CONSTRUCTOR NIL) combined with other :CONSTRUCTORs."))
801 (return-from define-constructors ()))
802
803 (unless (or defaults boas)
804 (push (concat-pnames 'make- (dd-name defstruct)) defaults))
805
806 (collect ((res))
807 (when defaults
808 (let ((cname (first defaults)))
809 (setf (dd-default-constructor defstruct) cname)
810 (res (create-keyword-constructor defstruct creator))
811 (dolist (other-name (rest defaults))
812 (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
813 (res `(declaim (ftype function ',other-name))))))
814
815 (dolist (boa boas)
816 (res (create-boa-constructor defstruct boa creator)))
817
818 (res))))
819
820 ;;;; Slot accessors for raw slots:
821
822 ;;; SLOT-ACCESSOR-FORM -- Internal
823 ;;;
824 ;;; Return info about how to read/write a slot in the value stored in
825 ;;; Object. This is also used by constructors (we can't use the accessor
826 ;;; function, since some slots are read-only.) If supplied, Data is a variable
827 ;;; holding the raw-data vector.
828 ;;;
829 ;;; Values:
830 ;;; 1] Accessor function name (setfable)
831 ;;; 2] Index to pass to accessor.
832 ;;; 3] Object form to pass to accessor.
833 ;;;
834 (defun slot-accessor-form (defstruct slot &optional (object 'object) data)
835 (let ((rtype (dsd-raw-type slot)))
836 (values
837 (ecase rtype
838 (single-float '%raw-ref-single)
839 (double-float '%raw-ref-double)
840 (unsigned-byte 'aref)
841 ((t) '%instance-ref))
842 (if (eq rtype 'double-float)
843 (ash (dsd-index slot) -1)
844 (dsd-index slot))
845 (cond
846 ((eq rtype 't) object)
847 (data)
848 (t
849 `(truly-the (simple-array (unsigned-byte 32) (*))
850 (%instance-ref object ,(dd-raw-index defstruct))))))))
851
852
853 ;;; DEFINE-RAW-ACCESSORS -- Internal
854 ;;;
855 ;;; Define readers and writers for raw slots as inline functions. We use
856 ;;; the special RAW-REF operations to store floats in the raw data vector.
857 ;;;
858 (defun define-raw-accessors (defstruct)
859 (let ((name (dd-name defstruct)))
860 (collect ((res))
861 (dolist (slot (dd-slots defstruct))
862 (let ((stype (dsd-type slot))
863 (aname (dsd-accessor slot)))
864 (multiple-value-bind (accessor offset data)
865 (slot-accessor-form defstruct slot)
866 (when (and aname (not (eq accessor '%instance-ref)))
867 (res `(declaim (inline ,aname)))
868 (res `(declaim (ftype (function (,name) ,stype) ,aname)))
869 (res
870 `(defun ,aname (object)
871 (truly-the ,stype (,accessor ,data ,offset))))
872 (unless (dsd-read-only slot)
873 (res `(declaim (inline (setf ,aname))))
874 (res `(declaim (ftype (function (,stype ,name) ,stype)
875 (setf ,aname))))
876 (res
877 `(defun (setf ,aname) (new-value object)
878 (setf (,accessor ,data ,offset) new-value)
879 new-value)))))))
880 (res))))
881
882
883 ;;;; Typed (non-class) structures:
884
885 ;;; DD-LISP-TYPE -- Internal
886 ;;;
887 ;;; Return a type specifier we can use for testing :TYPE'd structures.
888 ;;;
889 (defun dd-lisp-type (defstruct)
890 (ecase (dd-type defstruct)
891 (list 'list)
892 (vector `(simple-array ,(dd-element-type defstruct)
893 (*)))))
894
895 ;;; DEFINE-ACCESSORS -- Internal
896 ;;;
897 ;;; Returns a list of function definitions for accessing and setting the
898 ;;; slots of the a typed Defstruct. The functions are proclaimed to be inline,
899 ;;; and the types of their arguments and results are declared as well. We
900 ;;; count on the compiler to do clever things with Elt.
901 ;;;
902 (defun define-accessors (defstruct)
903 (collect ((stuff))
904 (let ((ltype (dd-lisp-type defstruct)))
905 (dolist (slot (dd-slots defstruct))
906 (let ((name (dsd-accessor slot))
907 (index (dsd-index slot))
908 (slot-type `(and ,(dsd-type slot)
909 ,(dd-element-type defstruct))))
910 (stuff `(proclaim '(inline ,name (setf ,name))))
911 (stuff `(defun ,name (structure)
912 (declare (type ,ltype structure))
913 (the ,slot-type (elt structure ,index))))
914 (unless (dsd-read-only slot)
915 (stuff
916 `(defun (setf ,name) (new-value structure)
917 (declare (type ,ltype structure) (type ,slot-type new-value))
918 (setf (elt structure ,index) new-value)))))))
919 (stuff)))
920
921
922 ;;; Define-Copier returns the definition for a copier function of a typed
923 ;;; Defstruct if one is desired.
924 (defun define-copier (defstruct)
925 (when (dd-copier defstruct)
926 `((setf (fdefinition ',(dd-copier defstruct)) #'copy-seq)
927 (declaim (ftype function ,(dd-copier defstruct))))))
928
929
930 ;;; Define-Predicate returns a definition for a predicate function if one is
931 ;;; desired. Rather vaguely specified w.r.t. inclusion.
932 ;;;
933 (defun define-predicate (defstruct)
934 (let ((name (dd-name defstruct))
935 (pred (dd-predicate defstruct)))
936 (when (and pred (dd-named defstruct))
937 (let ((ltype (dd-lisp-type defstruct)))
938 `((defun ,pred (object)
939 (and (typep object ',ltype)
940 (eq (elt (the ,ltype object)
941 ,(cdr (car (last (find-name-indices defstruct)))))
942 ',name))))))))
943
944
945 ;;;; Load time support for default structures (%DEFSTRUCT)
946 ;;;
947 ;;; In the normal case of structures that have a real type (i.e. no :Type
948 ;;; option was specified), we want to optimize things for space as well as
949 ;;; speed, since there can be thousands of defined slot accesors.
950 ;;;
951 ;;; What we do is defined the accessors and copier as closures over
952 ;;; general-case code. Since the compiler will normally open-code accesors,
953 ;;; the (minor) efficiency penalty is not a concern.
954
955 #+ns-boot
956 (defun %defstruct (&rest ignore)
957 (declare (ignore ignore)))
958
959 #-ns-boot(progn
960 ;;; Typep-To-Layout -- Internal
961 ;;;
962 ;;; Return true if Obj is an object of the structure type corresponding to
963 ;;; Layout. This is called by the accessor closures, which have a handle on
964 ;;; the type's layout.
965 ;;;
966 (proclaim '(inline typep-to-layout))
967 (defun typep-to-structure (obj layout)
968 (declare (type layout layout) (optimize (speed 3) (safety 0)))
969 (when (layout-invalid layout)
970 (error "Obsolete structure accessor function called."))
971 (and (%instancep obj)
972 (let ((depth (layout-inheritance-depth layout))
973 (obj-layout (%instance-layout obj)))
974 (cond ((eq obj-layout layout) t)
975 ((layout-invalid obj-layout)
976 (error "Structure accessor called on obsolete instance:~% ~S"
977 obj))
978 (t
979 (and (> (layout-inheritance-depth obj-layout) depth)
980 (eq (svref (layout-inherits obj-layout) depth)
981 layout)))))))
982
983
984 ;;; STRUCTURE-SLOT-SETTER, STRUCTURE-SLOT-ACCESSOR -- Internal
985 ;;;
986 ;;; Return closures to do slot access (set), according to Layout and DSD.
987 ;;; We check types, then do the access. This is only used for normal slots
988 ;;; (not raw.)
989 ;;;
990 (defun structure-slot-accessor (layout dsd)
991 #'(lambda (structure)
992 (declare (optimize (speed 3) (safety 0)))
993 (unless (typep-to-structure structure layout)
994 (error "Structure for accessor ~S is not a ~S:~% ~S"
995 (dsd-accessor dsd) (class-name (layout-class layout))
996 structure))
997 (%instance-ref structure (dsd-index dsd))))
998 ;;;
999 (defun structure-slot-setter (layout dsd)
1000 #'(lambda (new-value structure)
1001 (declare (optimize (speed 3) (safety 0)))
1002 (unless (typep-to-structure structure layout)
1003 (error "Structure for setter ~S is not a ~S:~% ~S"
1004 `(setf ,(dsd-accessor dsd)) (class-name (layout-class layout))
1005 structure))
1006 (unless (typep new-value (dsd-type dsd))
1007 (error "New-Value for setter ~S is not a ~S:~% ~S."
1008 `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
1009 new-value))
1010 (setf (%instance-ref structure (dsd-index dsd)) new-value)))
1011
1012
1013 ;;; %Defstruct -- Internal
1014 ;;;
1015 ;;; Do miscellaneous (LOAD EVAL) time actions for the structure described by
1016 ;;; Info. Create the class & layout, checking for incompatible redefinition.
1017 ;;; Define setters, accessors, copier, predicate, documentation, instantiate
1018 ;;; definition in load-time env. This is only called for default structures.
1019 ;;;
1020 (defun %defstruct (info inherits)
1021 (declare (type defstruct-description info))
1022 (multiple-value-bind (class layout old-layout)
1023 (ensure-structure-class info inherits "current" "new")
1024 (cond (old-layout
1025 (let ((old-info (layout-info old-layout)))
1026 (when (defstruct-description-p old-info)
1027 (dolist (slot (dd-slots old-info))
1028 (fmakunbound (dsd-accessor slot))
1029 (unless (dsd-read-only slot)
1030 (fmakunbound `(setf ,(dsd-accessor slot)))))))
1031 (unless (eq layout old-layout)
1032 (%redefine-defstruct class old-layout layout)))
1033 (t
1034 (register-layout layout nil nil)))
1035
1036 (setf (find-class (dd-name info)) class)
1037
1038 (dolist (slot (dd-slots info))
1039 (let ((dsd slot))
1040 (when (and (dsd-accessor slot)
1041 (not (eq (dsd-raw-type slot) 'T)))
1042 (setf (symbol-function (dsd-accessor slot))
1043 (structure-slot-accessor layout dsd))
1044
1045 (unless (dsd-read-only slot)
1046 (setf (fdefinition `(setf ,(dsd-accessor slot)))
1047 (structure-slot-setter layout dsd))))))
1048
1049 (when (dd-predicate info)
1050 (setf (symbol-function (dd-predicate info))
1051 #'(lambda (object)
1052 (declare (optimize (speed 3) (safety 0)))
1053 (typep-to-layout object layout))))
1054
1055 (when (dd-copier info)
1056 (setf (symbol-function (dd-copier info))
1057 #'(lambda (structure)
1058 (declare (optimize (speed 3) (safety 0)))
1059 (unless (typep-to-layout structure layout)
1060 (error "Structure for copier is not a ~S:~% ~S"
1061 (class-name (layout-class layout))
1062 structure))
1063 (copy-structure structure)))))
1064
1065 (when (dd-doc info)
1066 (setf (documentation (dd-name info) 'type) (dd-doc info)))
1067
1068 (undefined-value))
1069
1070 ); #-ns-boot progn
1071
1072 ;;;; Redefinition stuff:
1073
1074 ;;; ENSURE-STRUCTURE-CLASS -- Internal
1075 ;;;
1076 ;;; Called when we are about to define a structure class. Returns a
1077 ;;; (possibly new) class object and the layout which should be used for the new
1078 ;;; definition (may be the current layout.) The third value is any old layout
1079 ;;; for this class (may be NIL, and also might be an uninstalled forward
1080 ;;; referenced layout.)
1081 ;;;
1082 (defun ensure-structure-class (info inherits old-context new-context)
1083 (multiple-value-bind
1084 (class old-layout)
1085 (destructuring-bind (&optional name (class 'structure-class)
1086 (constructor 'make-structure-class))
1087 (dd-alternate-metaclass info)
1088 (declare (ignore name))
1089 (insured-find-class (dd-name info) (find-class class)
1090 (fdefinition constructor)))
1091 (let ((new-layout (make-layout :class class
1092 :inherits inherits
1093 :inheritance-depth (length inherits)
1094 :length (dd-length info)
1095 :info info)))
1096 (if (or (not old-layout)
1097 (let ((old-info (layout-info old-layout)))
1098 (or (redefine-layout-warning old-layout old-context
1099 new-layout new-context)
1100 (not (defstruct-description-p old-info))
1101 (redefine-structure-warning class old-info info))))
1102 (values class new-layout old-layout)
1103 (values class old-layout old-layout)))))
1104
1105
1106 ;;; COMPARE-SLOTS -- Internal
1107 ;;;
1108 ;;; Compares the slots of Old and New, returning 3 lists of slot names:
1109 ;;; 1] Slots which have moved,
1110 ;;; 2] Slots whose type has changed,
1111 ;;; 3] Deleted slots.
1112 ;;;
1113 (defun compare-slots (old new)
1114 (let* ((oslots (dd-slots old))
1115 (nslots (dd-slots new))
1116 (onames (mapcar #'dsd-name oslots))
1117 (nnames (mapcar #'dsd-name nslots)))
1118 (collect ((moved)
1119 (retyped))
1120 (dolist (name (intersection onames nnames))
1121 (let ((os (find name oslots :key #'dsd-name))
1122 (ns (find name nslots :key #'dsd-name)))
1123 (unless (subtypep (dsd-type ns) (dsd-type os))
1124 (retyped name))
1125 (unless (and (= (dsd-index os) (dsd-index ns))
1126 (eq (dsd-raw-type os) (dsd-raw-type ns)))
1127 (moved name))))
1128 (values (moved)
1129 (retyped)
1130 (set-difference onames nnames)))))
1131
1132
1133 ;;; REDEFINE-STRUCTURE-WARNING -- Internal
1134 ;;;
1135 ;;; Give a warning and return true if we are redefining a structure with
1136 ;;; different slots than in the currently loaded version.
1137 ;;;
1138 (defun redefine-structure-warning (class old new)
1139 (declare (type defstruct-description old new) (type class class)
1140 (ignore class))
1141 (let ((name (dd-name new)))
1142 (multiple-value-bind (moved retyped deleted)
1143 (compare-slots old new)
1144 (when (or moved retyped deleted)
1145 (warn
1146 "Incompatibly redefining slots of structure class ~S~@
1147 Make sure any uses of affected accessors are recompiled:~@
1148 ~@[ These slots were moved to new positions:~% ~S~%~]
1149 ~@[ These slots have new incompatible types:~% ~S~%~]
1150 ~@[ These slots were deleted:~% ~S~%~]"
1151 name moved retyped deleted)
1152 t))))
1153
1154
1155 ;;; %REDEFINE-DEFSTRUCT -- Internal
1156 ;;;
1157 ;;; This function is called when we are incompatibly redefining a structure
1158 ;;; Class to have the specified New-Layout. We signal an error with some
1159 ;;; proceed options.
1160 ;;;
1161 (defun %redefine-defstruct (class old-layout new-layout)
1162 (declare (type class class) (type layout new-layout)
1163 (ignore old-layout))
1164 (let ((name (class-proper-name class)))
1165 (restart-case
1166 (error "Redefining class ~S incompatibly with the current ~
1167 definition."
1168 name)
1169 (continue ()
1170 :report "Invalidate current definition."
1171 (warn "Previously loaded ~S accessors will no longer work." name)
1172 (register-layout new-layout t nil))
1173 (clobber-it ()
1174 :report "Smash current layout, preserving old code."
1175 (warn "Any old ~S instances will be in a bad way.~@
1176 I hope you know what you're doing..."
1177 name)
1178 (register-layout new-layout nil t))))
1179
1180 (undefined-value))
1181
1182
1183 ;;; UNDEFINE-STRUCTURE -- Interface
1184 ;;;
1185 ;;; Blow away all the compiler info for the structure described by Info.
1186 ;;; Iterate over this type, clearing the compiler structure
1187 ;;; type info, and undefining all the associated functions.
1188 ;;;
1189 (defun undefine-structure (info)
1190 (when (defstruct-description-p info)
1191 (let ((type (dd-name info)))
1192 (setf (info type compiler-layout type) nil)
1193 (undefine-function-name (dd-copier info))
1194 (undefine-function-name (dd-predicate info))
1195 (dolist (slot (dd-slots info))
1196 (let ((fun (dsd-accessor slot)))
1197 (undefine-function-name fun)
1198 (unless (dsd-read-only slot)
1199 (undefine-function-name `(setf ,fun))))))
1200 ;;
1201 ;; Clear out the SPECIFIER-TYPE cache so that subsequent references are
1202 ;; unknown types.
1203 (values-specifier-type-cache-clear))
1204 (undefined-value))
1205
1206
1207 ;;;; Compiler stuff:
1208
1209 ;;; DEFINE-DEFSTRUCT-NAME -- Internal
1210 ;;;
1211 ;;; Like DEFINE-FUNCTION-NAME, but we also set the kind to :DECLARED and
1212 ;;; blow away any ASSUMED-TYPE. Also, if the thing is a slot accessor
1213 ;;; currently, quietly unaccessorize it. And if there are any undefined
1214 ;;; warnings, we nuke them.
1215 ;;;
1216 (defun define-defstruct-name (name)
1217 (when name
1218 (when (info function accessor-for name)
1219 (setf (info function accessor-for name) nil))
1220 (define-function-name name)
1221 (note-name-defined name :function)
1222 (setf (info function where-from name) :declared)
1223 (when (info function assumed-type name)
1224 (setf (info function assumed-type name) nil)))
1225 (undefined-value))
1226
1227
1228 ;;; INHERITS-FOR-STRUCTURE -- Internal
1229 ;;;
1230 ;;; This function is called at macroexpand time to compute the INHERITS
1231 ;;; vector for a structure type definition.
1232 ;;;
1233 (defun inherits-for-structure (info)
1234 (declare (type defstruct-description info))
1235 (let* ((include (dd-include info))
1236 (superclass-opt (dd-alternate-metaclass info))
1237 (super
1238 (if include
1239 (compiler-layout-or-lose (first include))
1240 (class-layout (find-class (or (first superclass-opt)
1241 'structure-object))))))
1242 (concatenate 'simple-vector (layout-inherits super) (vector super))))
1243
1244
1245 ;;; %COMPILER-ONLY-DEFSTRUCT -- Internal
1246 ;;;
1247 ;;; This function is called by an EVAL-WHEN to do the compile-time-only
1248 ;;; actions for defining a structure type. It installs the class in the type
1249 ;;; system in a similar way to %DEFSTRUCT, but is quieter and safer in the case
1250 ;;; of redefinition. This is not called at all for interpreted defstructs.
1251 ;;;
1252 ;;; Basically, this function avoids trashing the compiler by only actually
1253 ;;; defining the class if there is no current definition. Instead, we just set
1254 ;;; the INFO TYPE COMPILER-LAYOUT.
1255 ;;;
1256 (defun %compiler-only-defstruct (info inherits)
1257 (multiple-value-bind (class layout old-layout)
1258 (ensure-structure-class info inherits
1259 "current" "compiled")
1260 (cond
1261 (old-layout
1262 (undefine-structure (layout-info old-layout))
1263 (when (and (class-subclasses class)
1264 (not (eq layout old-layout)))
1265 (collect ((subs))
1266 (do-hash (class layout (class-subclasses class))
1267 (undefine-structure (layout-info layout))
1268 (subs (class-proper-name class)))
1269 (when (subs)
1270 (warn "Removing old subclasses of ~S:~% ~S"
1271 (class-name class) (subs))))))
1272 (t
1273 (register-layout layout nil nil)
1274 (setf (find-class (dd-name info)) class)))
1275
1276 (setf (info type compiler-layout (dd-name info)) layout))
1277
1278 (undefined-value))
1279
1280
1281 ;;; %%Compiler-Defstruct -- External
1282 ;;;
1283 ;;; This function does the (compile load eval) time actions for updating the
1284 ;;; compiler's global meta-information to represent the definition of the the
1285 ;;; structure described by Info. This primarily amounts to setting up info
1286 ;;; about the accessor and other implicitly defined functions. The
1287 ;;; constructors are explicitly defined by top-level code.
1288 ;;;
1289 (defun %%compiler-defstruct (info)
1290 (declare (type defstruct-description info))
1291 (let* ((name (dd-name info))
1292 (class (find-class name)))
1293 (let ((copier (dd-copier info)))
1294 (when copier
1295 (proclaim `(ftype (function (,name) ,name) ,copier))))
1296
1297 (let ((pred (dd-predicate info)))
1298 (when pred
1299 (define-defstruct-name pred)
1300 (setf (info function inlinep pred) :inline)
1301 (setf (info function inline-expansion pred)
1302 `(lambda (x) (typep x ',name)))))
1303
1304 (dolist (slot (dd-slots info))
1305 (let* ((fun (dsd-accessor slot))
1306 (setf-fun `(setf ,fun)))
1307 (when (and fun (eq (dsd-raw-type slot) 't))
1308 (define-defstruct-name fun)
1309 (setf (info function accessor-for fun) class)
1310 (unless (dsd-read-only slot)
1311 (define-defstruct-name setf-fun)
1312 (setf (info function accessor-for setf-fun) class))))))
1313
1314 (undefined-value))
1315
1316 (setf (symbol-function '%compiler-defstruct) #'%%compiler-defstruct)
1317
1318
1319 ;;; COPY-STRUCTURE -- Public
1320 ;;;
1321 ;;; Copy any old kind of structure.
1322 ;;;
1323 #-ns-boot
1324 (defun copy-structure (structure)
1325 "Return a copy of Structure with the same (EQL) slot values."
1326 (declare (type instance structure) (optimize (speed 3) (safety 0)))
1327 (let* ((len (%instance-length structure))
1328 (res (%make-instance len))
1329 (layout (%instance-layout structure)))
1330 (declare (type structure-index len))
1331 (unless (structure-class-p (layout-class layout))
1332 (error "Not a structure-class object:~% ~S" structure))
1333 (when (layout-invalid layout)
1334 (error "Copying an obsolete structure:~% ~S" structure))
1335
1336 (dotimes (i len)
1337 (declare (type structure-index i))
1338 (setf (%instance-ref res i)
1339 (%instance-ref structure i)))
1340
1341 (let ((raw-index (dd-raw-index (layout-info layout))))
1342 (when raw-index
1343 (let* ((data (%instance-ref structure raw-index))
1344 (raw-len (length data))
1345 (new (make-array raw-len :element-type '(unsigned-byte 32))))
1346 (declare (type (simple-array (unsigned-byte 32) (*)) data))
1347 (setf (%instance-ref res raw-index) new)
1348 (dotimes (i raw-len)
1349 (setf (aref new i) (aref data i))))))
1350
1351 res))
1352
1353
1354 ;;; Default print and make-load-form methods.
1355
1356 #-ns-boot
1357 (defun default-structure-print (structure stream depth)
1358 (declare (ignore depth))
1359 (let* ((type (%instance-layout structure))
1360 (name (class-name (layout-class type)))
1361 (dd (layout-info type)))
1362 (if *print-pretty*
1363 (pprint-logical-block (stream nil :prefix "#S(" :suffix ")")
1364 (prin1 name stream)
1365 (let ((slots (dd-slots dd)))
1366 (when slots
1367 (write-char #\space stream)
1368 (pprint-indent :block 2 stream)
1369 (pprint-newline :linear stream)
1370 (loop
1371 (pprint-pop)
1372 (let ((slot (pop slots)))
1373 (write-char #\: stream)
1374 (output-symbol-name (dsd-%name slot) stream)
1375 (write-char #\space stream)
1376 (pprint-newline :miser stream)
1377 (output-object (%instance-ref structure (dsd-index slot))
1378 stream)
1379 (when (null slots)
1380 (return))
1381 (write-char #\space stream)
1382 (pprint-newline :linear stream))))))
1383 (descend-into (stream)
1384 (write-string "#S(" stream)
1385 (prin1 name stream)
1386 (do ((index 1 (1+ index))
1387 (length (%instance-length structure))
1388 (slots (dd-slots dd) (cdr slots)))
1389 ((or (= index length)
1390 (and *print-length*
1391 (= index *print-length*)))
1392 (if (= index length)
1393 (write-string ")" stream)
1394 (write-string "...)" stream)))
1395 (declare (type index index))
1396 (write-char #\space stream)
1397 (write-char #\: stream)
1398 (output-symbol-name (dsd-%name (car slots)) stream)
1399 (write-char #\space stream)
1400 (output-object (%instance-ref structure index) stream))))))
1401
1402 #-ns-boot
1403 (defun make-structure-load-form (structure)
1404 (declare (type structure-object structure))
1405 (let* ((class (layout-class (%instance-layout structure)))
1406 (fun (structure-class-make-load-form-fun class)))
1407 (etypecase fun
1408 ((member :just-dump-it-normally :ignore-it)
1409 fun)
1410 (null
1411 (error "Structures of type ~S cannot be dumped as constants."
1412 (class-name class)))
1413 (function
1414 (funcall fun structure))
1415 (symbol
1416 (funcall (symbol-function fun) structure)))))

  ViewVC Help
Powered by ViewVC 1.1.5