/[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.3 - (show annotations) (vendor branch)
Wed Feb 10 23:39:22 1993 UTC (21 years, 2 months ago) by ram
Branch: new_struct
Changes since 1.37.1.2: +15 -8 lines
fixed stuff

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.3 1993/02/10 23:39:22 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 ;;; FIND-NAME-INDICES -- Internal
569 ;;;
570 ;;; Returns a list of pairs (name . index). Used for :TYPE'd constructors
571 ;;; to find all the names that we have to splice in & where. Note that these
572 ;;; types don't have a layout, so we can't look at LAYOUT-INHERITS.
573 ;;;
574 (defun find-name-indices (defstruct)
575 (collect ((res))
576 (let ((infos ()))
577 (do ((info defstruct
578 (typed-structure-info-or-lose (first (dd-include info)))))
579 ((not (dd-include info)))
580 (push info infos))
581
582 (let ((i 0))
583 (dolist (info infos)
584 (incf i (dd-offset info))
585 (when (dd-named info)
586 (res (cons (dd-name info) i)))
587 (setq i (dd-length info)))))
588
589 (res)))
590
591
592 ;;; CREATE-{STRUCTURE,VECTOR,LIST}-CONSTRUCTOR -- Internal
593 ;;;
594 ;;; These functions are called to actually make a constructor after we have
595 ;;; processed the arglist. The correct variant (according to the DD-TYPE)
596 ;;; should be called. The function is defined with the specified name and
597 ;;; arglist. Vars and Types are used for argument type declarations. Values
598 ;;; are the values for the slots (in order.)
599 ;;;
600 ;;; This is split three ways because:
601 ;;; 1] list & vector structures need "name" symbols stuck in at various weird
602 ;;; places, whereas STRUCTURE structures have a LAYOUT slot.
603 ;;; 2] We really want to use LIST to make list structures, instead of
604 ;;; MAKE-LIST/(SETF ELT).
605 ;;; 3] STRUCTURE structures can have raw slots that must also be allocated and
606 ;;; indirectly referenced. We just call the setter function and let the
607 ;;; compiler figure out the references.
608 ;;;
609 (defun create-vector-constructor
610 (defstruct cons-name arglist vars types values)
611 (let ((temp (gensym)))
612 `(defun ,cons-name ,arglist
613 (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
614 vars types))
615 (let ((,temp (make-array ,(dd-length defstruct)
616 :element-type ',(dd-element-type defstruct))))
617 ,@(mapcar #'(lambda (x)
618 `(setf (%instance-ref ,temp ,(cdr x)) ',(car x)))
619 (find-name-indices defstruct))
620 ,@(mapcar #'(lambda (dsd value)
621 `(setf (aref ,temp ,(dsd-index dsd)) ,value))
622 (dd-slots defstruct) values)
623 ,temp))))
624 ;;;
625 (defun create-list-constructor
626 (defstruct cons-name arglist vars types values)
627 (let ((vals (make-list (dd-length defstruct) :initial-element nil)))
628 (dolist (x (find-name-indices defstruct))
629 (setf (elt vals (cdr x)) `',(car x)))
630 (loop for dsd in (dd-slots defstruct) and val in values do
631 (setf (elt vals (dsd-index dsd)) val))
632
633 `(defun ,cons-name ,arglist
634 (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
635 vars types))
636 (list ,@vals))))
637 ;;;
638 (defun create-structure-constructor
639 (defstruct cons-name arglist vars types values)
640 (let ((temp (gensym)))
641 `(defun ,cons-name ,arglist
642 (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
643 vars types))
644 (let ((,temp (truly-the ,(dd-name defstruct)
645 (%make-instance ,(dd-length defstruct)))))
646 (setf (%instance-layout ,temp)
647 (truly-the layout
648 (load-time-value
649 (class-layout
650 (find-class ',(dd-name defstruct))))))
651 ,@(when (dd-raw-index defstruct)
652 `((setf (%instance-ref ,temp ,(dd-raw-index defstruct))
653 (make-array ,(dd-raw-length defstruct)
654 :element-type '(unsigned-byte 32)))))
655 ,@(mapcar #'(lambda (dsd value)
656 `(setf (,(concat-pnames (dd-conc-name defstruct)
657 (dsd-name dsd))
658 ,temp)
659 ,value))
660 (dd-slots defstruct)
661 values)
662 ,temp))))
663
664
665 ;;; CREATE-KEYWORD-CONSTRUCTOR -- Internal
666 ;;;
667 ;;; Create a default (non-BOA) keyword constructor.
668 ;;;
669 (defun create-keyword-constructor (defstruct creator)
670 (collect ((arglist (list '&key))
671 (types)
672 (vals))
673 (dolist (slot (dd-slots defstruct))
674 (let ((dum (gensym))
675 (name (dsd-name slot)))
676 (arglist `((,(intern (string name) "KEYWORD") ,dum)
677 ,(dsd-default slot)))
678 (types (dsd-type slot))
679 (vals dum)))
680 (funcall creator
681 defstruct (dd-default-constructor defstruct)
682 (arglist) (vals) (types) (vals))))
683
684
685 ;;; CREATE-BOA-CONSTRUCTOR -- Internal
686 ;;;
687 ;;; Given a structure and a BOA constructor spec, call Creator with the
688 ;;; appropriate args to make a constructor.
689 ;;;
690 (defun create-boa-constructor (defstruct boa creator)
691 (multiple-value-bind (req opt restp rest keyp keys allowp aux)
692 (kernel:parse-lambda-list (second boa))
693 (collect ((arglist)
694 (vars)
695 (types))
696 (labels ((get-slot (name)
697 (let ((res (find name (dd-slots defstruct) :test #'string=
698 :key #'dsd-name)))
699 (if res
700 (values (dsd-type res) (dsd-default res))
701 (values t nil))))
702 (do-default (arg)
703 (multiple-value-bind (type default) (get-slot arg)
704 (arglist `(,arg ,default))
705 (vars arg)
706 (types type))))
707 (dolist (arg req)
708 (arglist arg)
709 (vars arg)
710 (types (get-slot arg)))
711
712 (when opt
713 (arglist '&optional)
714 (dolist (arg opt)
715 (cond ((consp arg)
716 (destructuring-bind
717 (name &optional (def (nth-value 1 (get-slot name))))
718 arg
719 (arglist `(,name ,def))
720 (vars name)
721 (types (get-slot name))))
722 (t
723 (do-default arg)))))
724
725 (when restp
726 (arglist '&rest rest)
727 (vars rest)
728 (types 'list))
729
730 (when keyp
731 (arglist '&key)
732 (dolist (key keys)
733 (if (consp key)
734 (destructuring-bind (wot &optional (def nil def-p))
735 key
736 (let ((name (if (consp wot)
737 (destructuring-bind (key var) wot
738 (declare (ignore key))
739 var)
740 wot)))
741 (multiple-value-bind (type slot-def) (get-slot name)
742 (arglist `(,wot ,(if def-p def slot-def)))
743 (vars name)
744 (types type))))
745 (do-default key))))
746
747 (when allowp (arglist '&allow-other-keys))
748
749 (when aux
750 (arglist '&aux)
751 (dolist (arg aux)
752 (let* ((arg (if (consp arg) arg (list arg)))
753 (var (first arg)))
754 (arglist arg)
755 (vars var)
756 (types (get-slot var))))))
757
758 (funcall creator defstruct (first boa)
759 (arglist) (vars) (types)
760 (mapcar #'(lambda (slot)
761 (or (find (dsd-name slot) (vars))
762 (dsd-default slot)))
763 (dd-slots defstruct))))))
764
765
766 ;;; DEFINE-CONSTRUCTORS -- Internal
767 ;;;
768 ;;; Grovel the constructor options, and decide what constructors (if any) to
769 ;;; create.
770 ;;;
771 (defun define-constructors (defstruct)
772 (let ((no-constructors nil)
773 (boas ())
774 (defaults ())
775 (creator (ecase (dd-type defstruct)
776 (structure #'create-structure-constructor)
777 (vector #'create-vector-constructor)
778 (list #'create-list-constructor))))
779 (dolist (constructor (dd-constructors defstruct))
780 (destructuring-bind (name &optional (boa-ll nil boa-p))
781 constructor
782 (declare (ignore boa-ll))
783 (cond ((not name) (setq no-constructors t))
784 (boa-p (push constructor boas))
785 (t (push name defaults)))))
786
787 (when no-constructors
788 (when (or defaults boas)
789 (error "(:CONSTRUCTOR NIL) combined with other :CONSTRUCTORs."))
790 (return-from define-constructors ()))
791
792 (unless (or defaults boas)
793 (push (concat-pnames 'make- (dd-name defstruct)) defaults))
794
795 (collect ((res))
796 (when defaults
797 (let ((cname (first defaults)))
798 (setf (dd-default-constructor defstruct) cname)
799 (res (create-keyword-constructor defstruct creator))
800 (dolist (other-name (rest defaults))
801 (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
802 (res `(declaim (ftype function ',other-name))))))
803
804 (dolist (boa boas)
805 (res (create-boa-constructor defstruct boa creator)))
806
807 (res))))
808
809 ;;;; Slot accessors for raw slots:
810
811 ;;; DEFINE-RAW-ACCESSORS -- Internal
812 ;;;
813 ;;; Define readers and writers for raw slots as inline functions. We use
814 ;;; the special RAW-REF operations to store floats in the raw data vector.
815 ;;;
816 (defun define-raw-accessors (defstruct)
817 (collect ((res))
818 (dolist (slot (dd-slots defstruct))
819 (let ((rtype (dsd-raw-type slot))
820 (aname (dsd-accessor slot)))
821 (when (and aname (not (eq rtype 't)))
822 (let ((accessor
823 (ecase rtype
824 (single-float '%raw-ref-single)
825 (double-float '%raw-ref-double)
826 (unsigned-byte 'aref)))
827 (offset
828 (if (eq rtype 'double-float)
829 (ash (dsd-index slot) -1)
830 (dsd-index slot)))
831 (data `(truly-the (simple-array (unsigned-byte 32) (*))
832 (%instance-ref object
833 ,(dd-raw-index defstruct))))
834 (name (dd-name defstruct))
835 (stype (dsd-type slot)))
836 (res `(declaim (inline ,aname)))
837 (res `(declaim (ftype (function (,name) ,stype) ,aname)))
838 (res
839 `(defun ,aname (object)
840 (truly-the ,stype (,accessor ,data ,offset))))
841 (unless (dsd-read-only slot)
842 (res `(declaim (inline (setf ,aname))))
843 (res `(declaim (ftype (function (,stype ,name) ,stype)
844 (setf ,aname))))
845 (res
846 `(defun (setf ,aname) (new-value object)
847 (setf (,accessor ,data ,offset) new-value)
848 new-value)))))))
849 (res)))
850
851
852 ;;;; Typed (non-class) structures:
853
854 ;;; DD-LISP-TYPE -- Internal
855 ;;;
856 ;;; Return a type specifier we can use for testing :TYPE'd structures.
857 ;;;
858 (defun dd-lisp-type (defstruct)
859 (ecase (dd-type defstruct)
860 (list 'list)
861 (vector `(simple-array ,(dd-element-type defstruct)
862 (*)))))
863
864 ;;; DEFINE-ACCESSORS -- Internal
865 ;;;
866 ;;; Returns a list of function definitions for accessing and setting the
867 ;;; slots of the a typed Defstruct. The functions are proclaimed to be inline,
868 ;;; and the types of their arguments and results are declared as well. We
869 ;;; count on the compiler to do clever things with Elt.
870 ;;;
871 (defun define-accessors (defstruct)
872 (collect ((stuff))
873 (let ((ltype (dd-lisp-type defstruct)))
874 (dolist (slot (dd-slots defstruct))
875 (let ((name (dsd-accessor slot))
876 (index (dsd-index slot))
877 (slot-type (dsd-type slot)))
878 (stuff `(proclaim '(inline ,name (setf ,name))))
879 (stuff `(defun ,name (structure)
880 (declare (type ,ltype structure))
881 (the ,slot-type (elt structure ,index))))
882 (unless (dsd-read-only slot)
883 (stuff
884 `(defun (setf ,name) (new-value structure)
885 (declare (type ,ltype structure) (type ,slot-type new-value))
886 (setf (elt structure ,index) new-value)))))))
887 (stuff)))
888
889
890 ;;; Define-Copier returns the definition for a copier function of a typed
891 ;;; Defstruct if one is desired.
892 (defun define-copier (defstruct)
893 (when (dd-copier defstruct)
894 `((setf (fdefinition ',(dd-copier defstruct)) #'copy-seq)
895 (declaim (ftype function ,(dd-copier defstruct))))))
896
897
898 ;;; Define-Predicate returns a definition for a predicate function if one is
899 ;;; desired. Rather vaguely specified w.r.t. inclusion.
900 ;;;
901 (defun define-predicate (defstruct)
902 (let ((name (dd-name defstruct))
903 (pred (dd-predicate defstruct)))
904 (when (and pred (dd-named defstruct))
905 (let ((ltype (dd-lisp-type defstruct)))
906 `((defun ,pred (object)
907 (and (typep object ',ltype)
908 (eq (elt (the ,ltype object)
909 ,(cdr (car (last (find-name-indices defstruct)))))
910 ',name))))))))
911
912
913 ;;;; Load time support for default structures (%DEFSTRUCT)
914 ;;;
915 ;;; In the normal case of structures that have a real type (i.e. no :Type
916 ;;; option was specified), we want to optimize things for space as well as
917 ;;; speed, since there can be thousands of defined slot accesors.
918 ;;;
919 ;;; What we do is defined the accessors and copier as closures over
920 ;;; general-case code. Since the compiler will normally open-code accesors,
921 ;;; the (minor) efficiency penalty is not a concern.
922
923 #+ns-boot
924 (defun %defstruct (&rest ignore)
925 (declare (ignore ignore)))
926
927 #-ns-boot(progn
928 ;;; Typep-To-Layout -- Internal
929 ;;;
930 ;;; Return true if Obj is an object of the structure type corresponding to
931 ;;; Layout. This is called by the accessor closures, which have a handle on
932 ;;; the type's layout.
933 ;;;
934 (proclaim '(inline typep-to-layout))
935 (defun typep-to-structure (obj layout)
936 (declare (type layout layout) (optimize (speed 3) (safety 0)))
937 (when (layout-invalid layout)
938 (error "Obsolete structure accessor function called."))
939 (and (%instancep obj)
940 (let ((depth (layout-inheritance-depth layout))
941 (obj-layout (%instance-layout obj)))
942 (cond ((eq obj-layout layout) t)
943 ((layout-invalid obj-layout)
944 (error "Structure accessor called on obsolete instance:~% ~S"
945 obj))
946 (t
947 (and (> (layout-inheritance-depth obj-layout) depth)
948 (eq (svref (layout-inherits obj-layout) depth)
949 layout)))))))
950
951
952 ;;; STRUCTURE-SLOT-SETTER, STRUCTURE-SLOT-ACCESSOR -- Internal
953 ;;;
954 ;;; Return closures to do slot access (set), according to Layout and DSD.
955 ;;; We check types, then do the access. This is only used for normal slots
956 ;;; (not raw.)
957 ;;;
958 (defun structure-slot-accessor (layout dsd)
959 #'(lambda (structure)
960 (declare (optimize (speed 3) (safety 0)))
961 (unless (typep-to-structure structure layout)
962 (error "Structure for accessor ~S is not a ~S:~% ~S"
963 (dsd-accessor dsd) (class-name (layout-class layout))
964 structure))
965 (%instance-ref structure (dsd-index dsd))))
966 ;;;
967 (defun structure-slot-setter (layout dsd)
968 #'(lambda (new-value structure)
969 (declare (optimize (speed 3) (safety 0)))
970 (unless (typep-to-structure structure layout)
971 (error "Structure for setter ~S is not a ~S:~% ~S"
972 `(setf ,(dsd-accessor dsd)) (class-name (layout-class layout))
973 structure))
974 (unless (typep new-value (dsd-type dsd))
975 (error "New-Value for setter ~S is not a ~S:~% ~S."
976 `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
977 new-value))
978 (setf (%instance-ref structure (dsd-index dsd)) new-value)))
979
980
981 ;;; %Defstruct -- Internal
982 ;;;
983 ;;; Do miscellaneous (LOAD EVAL) time actions for the structure described by
984 ;;; Info. Create the class & layout, checking for incompatible redefinition.
985 ;;; Define setters, accessors, copier, predicate, documentation, instantiate
986 ;;; definition in load-time env. This is only called for default structures.
987 ;;;
988 (defun %defstruct (info inherits)
989 (declare (type defstruct-description info))
990 (multiple-value-bind (class layout old-layout)
991 (ensure-structure-class info inherits "current" "new")
992 (cond (old-layout
993 (let ((old-info (layout-info old-layout)))
994 (when (defstruct-description-p old-info)
995 (dolist (slot (dd-slots old-info))
996 (fmakunbound (dsd-accessor slot))
997 (unless (dsd-read-only slot)
998 (fmakunbound `(setf ,(dsd-accessor slot)))))))
999 (unless (eq layout old-layout)
1000 (%redefine-defstruct class old-layout layout)))
1001 (t
1002 (register-layout layout nil nil)))
1003
1004 (setf (find-class (dd-name info)) class)
1005
1006 (dolist (slot (dd-slots info))
1007 (let ((dsd slot))
1008 (when (and (dsd-accessor slot)
1009 (not (eq (dsd-raw-type slot) 'T)))
1010 (setf (symbol-function (dsd-accessor slot))
1011 (structure-slot-accessor layout dsd))
1012
1013 (unless (dsd-read-only slot)
1014 (setf (fdefinition `(setf ,(dsd-accessor slot)))
1015 (structure-slot-setter layout dsd))))))
1016
1017 (when (dd-predicate info)
1018 (setf (symbol-function (dd-predicate info))
1019 #'(lambda (object)
1020 (declare (optimize (speed 3) (safety 0)))
1021 (typep-to-layout object layout))))
1022
1023 (when (dd-copier info)
1024 (setf (symbol-function (dd-copier info))
1025 #'(lambda (structure)
1026 (declare (optimize (speed 3) (safety 0)))
1027 (unless (typep-to-layout structure layout)
1028 (error "Structure for copier is not a ~S:~% ~S"
1029 (class-name (layout-class layout))
1030 structure))
1031 (copy-structure structure)))))
1032
1033 (when (dd-doc info)
1034 (setf (documentation (dd-name info) 'type) (dd-doc info)))
1035
1036 (undefined-value))
1037
1038 ); #-ns-boot progn
1039
1040 ;;;; Redefinition stuff:
1041
1042 ;;; ENSURE-STRUCTURE-CLASS -- Internal
1043 ;;;
1044 ;;; Called when we are about to define a structure class. Returns a
1045 ;;; (possibly new) class object and the layout which should be used for the new
1046 ;;; definition (may be the current layout.) The third value is any old layout
1047 ;;; for this class (may be NIL, and also might be an uninstalled forward
1048 ;;; referenced layout.)
1049 ;;;
1050 (defun ensure-structure-class (info inherits old-context new-context)
1051 (multiple-value-bind
1052 (class old-layout)
1053 (destructuring-bind (&optional name (class 'structure-class)
1054 (constructor 'make-structure-class))
1055 (dd-alternate-metaclass info)
1056 (declare (ignore name))
1057 (insured-find-class (dd-name info) (find-class class)
1058 (fdefinition constructor)))
1059 (let ((new-layout (make-layout :class class
1060 :inherits inherits
1061 :inheritance-depth (length inherits)
1062 :length (dd-length info)
1063 :info info)))
1064 (if (or (not old-layout)
1065 (let ((old-info (layout-info old-layout)))
1066 (or (redefine-layout-warning old-layout old-context
1067 new-layout new-context)
1068 (not (defstruct-description-p old-info))
1069 (redefine-structure-warning class old-info info))))
1070 (values class new-layout old-layout)
1071 (values class old-layout old-layout)))))
1072
1073
1074 ;;; COMPARE-SLOTS -- Internal
1075 ;;;
1076 ;;; Compares the slots of Old and New, returning 3 lists of slot names:
1077 ;;; 1] Slots which have moved,
1078 ;;; 2] Slots whose type has changed,
1079 ;;; 3] Deleted slots.
1080 ;;;
1081 (defun compare-slots (old new)
1082 (let* ((oslots (dd-slots old))
1083 (nslots (dd-slots new))
1084 (onames (mapcar #'dsd-name oslots))
1085 (nnames (mapcar #'dsd-name nslots)))
1086 (collect ((moved)
1087 (retyped))
1088 (dolist (name (intersection onames nnames))
1089 (let ((os (find name oslots :key #'dsd-name))
1090 (ns (find name nslots :key #'dsd-name)))
1091 (unless (subtypep (dsd-type ns) (dsd-type os))
1092 (retyped name))
1093 (unless (and (= (dsd-index os) (dsd-index ns))
1094 (eq (dsd-raw-type os) (dsd-raw-type ns)))
1095 (moved name))))
1096 (values (moved)
1097 (retyped)
1098 (set-difference onames nnames)))))
1099
1100
1101 ;;; REDEFINE-STRUCTURE-WARNING -- Internal
1102 ;;;
1103 ;;; Give a warning and return true if we are redefining a structure with
1104 ;;; different slots than in the currently loaded version.
1105 ;;;
1106 (defun redefine-structure-warning (class old new)
1107 (declare (type defstruct-description old new) (type class class)
1108 (ignore class))
1109 (let ((name (dd-name new)))
1110 (multiple-value-bind (moved retyped deleted)
1111 (compare-slots old new)
1112 (when (or moved retyped deleted)
1113 (warn
1114 "Incompatibly redefining slots of structure class ~S~@
1115 Make sure any uses of affected accessors are recompiled:~@
1116 ~@[ These slots were moved to new positions:~% ~S~%~]
1117 ~@[ These slots have new incompatible types:~% ~S~%~]
1118 ~@[ These slots were deleted:~% ~S~%~]"
1119 name moved retyped deleted)
1120 t))))
1121
1122
1123 ;;; %REDEFINE-DEFSTRUCT -- Internal
1124 ;;;
1125 ;;; This function is called when we are incompatibly redefining a structure
1126 ;;; Class to have the specified New-Layout. We signal an error with some
1127 ;;; proceed options.
1128 ;;;
1129 (defun %redefine-defstruct (class old-layout new-layout)
1130 (declare (type class class) (type layout new-layout)
1131 (ignore old-layout))
1132 (let ((name (class-proper-name class)))
1133 (restart-case
1134 (error "Redefining class ~S incompatibly with the current ~
1135 definition."
1136 name)
1137 (continue ()
1138 :report "Invalidate current definition."
1139 (warn "Previously loaded ~S accessors will no longer work." name)
1140 (register-layout new-layout t nil))
1141 (clobber-it ()
1142 :report "Smash current layout, preserving old code."
1143 (warn "Any old ~S instances will be in a bad way.~@
1144 I hope you know what you're doing..."
1145 name)
1146 (register-layout new-layout nil t))))
1147
1148 (undefined-value))
1149
1150
1151 ;;; UNDEFINE-STRUCTURE -- Interface
1152 ;;;
1153 ;;; Blow away all the compiler info for the structure described by Info.
1154 ;;; Iterate over this type, clearing the compiler structure
1155 ;;; type info, and undefining all the associated functions.
1156 ;;;
1157 (defun undefine-structure (info)
1158 (when (defstruct-description-p info)
1159 (let ((type (dd-name info)))
1160 (setf (info type compiler-layout type) nil)
1161 (undefine-function-name (dd-copier info))
1162 (undefine-function-name (dd-predicate info))
1163 (dolist (slot (dd-slots info))
1164 (let ((fun (dsd-accessor slot)))
1165 (undefine-function-name fun)
1166 (unless (dsd-read-only slot)
1167 (undefine-function-name `(setf ,fun))))))
1168 ;;
1169 ;; Clear out the SPECIFIER-TYPE cache so that subsequent references are
1170 ;; unknown types.
1171 (values-specifier-type-cache-clear))
1172 (undefined-value))
1173
1174
1175 ;;;; Compiler stuff:
1176
1177 ;;; DEFINE-DEFSTRUCT-NAME -- Internal
1178 ;;;
1179 ;;; Like DEFINE-FUNCTION-NAME, but we also set the kind to :DECLARED and
1180 ;;; blow away any ASSUMED-TYPE. Also, if the thing is a slot accessor
1181 ;;; currently, quietly unaccessorize it. And if there are any undefined
1182 ;;; warnings, we nuke them.
1183 ;;;
1184 (defun define-defstruct-name (name)
1185 (when name
1186 (when (info function accessor-for name)
1187 (setf (info function accessor-for name) nil))
1188 (define-function-name name)
1189 (note-name-defined name :function)
1190 (setf (info function where-from name) :declared)
1191 (when (info function assumed-type name)
1192 (setf (info function assumed-type name) nil)))
1193 (undefined-value))
1194
1195
1196 ;;; INHERITS-FOR-STRUCTURE -- Internal
1197 ;;;
1198 ;;; This function is called at macroexpand time to compute the INHERITS
1199 ;;; vector for a structure type definition.
1200 ;;;
1201 (defun inherits-for-structure (info)
1202 (declare (type defstruct-description info))
1203 (let* ((include (dd-include info))
1204 (superclass-opt (dd-alternate-metaclass info))
1205 (super
1206 (if include
1207 (compiler-layout-or-lose (first include))
1208 (class-layout (find-class (or (first superclass-opt)
1209 'structure-object))))))
1210 (concatenate 'simple-vector (layout-inherits super) (vector super))))
1211
1212
1213 ;;; %COMPILER-ONLY-DEFSTRUCT -- Internal
1214 ;;;
1215 ;;; This function is called by an EVAL-WHEN to do the compile-time-only
1216 ;;; actions for defining a structure type. It installs the class in the type
1217 ;;; system in a similar way to %DEFSTRUCT, but is quieter and safer in the case
1218 ;;; of redefinition. This is not called at all for interpreted defstructs.
1219 ;;;
1220 ;;; Basically, this function avoids trashing the compiler by only actually
1221 ;;; defining the class if there is no current definition. Instead, we just set
1222 ;;; the INFO TYPE COMPILER-LAYOUT.
1223 ;;;
1224 (defun %compiler-only-defstruct (info inherits)
1225 (multiple-value-bind (class layout old-layout)
1226 (ensure-structure-class info inherits
1227 "current" "compiled")
1228 (cond
1229 (old-layout
1230 (undefine-structure (layout-info old-layout))
1231 (when (and (class-subclasses class)
1232 (not (eq layout old-layout)))
1233 (collect ((subs))
1234 (do-hash (class layout (class-subclasses class))
1235 (undefine-structure (layout-info layout))
1236 (subs (class-proper-name class)))
1237 (when (subs)
1238 (warn "Removing old subclasses of ~S:~% ~S"
1239 (class-name class) (subs))))))
1240 (t
1241 (register-layout layout nil nil)
1242 (setf (find-class (dd-name info)) class)))
1243
1244 (setf (info type compiler-layout (dd-name info)) layout))
1245
1246 (undefined-value))
1247
1248
1249 ;;; %%Compiler-Defstruct -- External
1250 ;;;
1251 ;;; This function does the (compile load eval) time actions for updating the
1252 ;;; compiler's global meta-information to represent the definition of the the
1253 ;;; structure described by Info. This primarily amounts to setting up info
1254 ;;; about the accessor and other implicitly defined functions. The
1255 ;;; constructors are explicitly defined by top-level code.
1256 ;;;
1257 (defun %%compiler-defstruct (info)
1258 (declare (type defstruct-description info))
1259 (let* ((name (dd-name info))
1260 (class (find-class name)))
1261 (let ((copier (dd-copier info)))
1262 (when copier
1263 (proclaim `(ftype (function (,name) ,name) ,copier))))
1264
1265 (let ((pred (dd-predicate info)))
1266 (when pred
1267 (define-defstruct-name pred)
1268 (setf (info function inlinep pred) :inline)
1269 (setf (info function inline-expansion pred)
1270 `(lambda (x) (typep x ',name)))))
1271
1272 (dolist (slot (dd-slots info))
1273 (let* ((fun (dsd-accessor slot))
1274 (setf-fun `(setf ,fun)))
1275 (when (and fun (eq (dsd-raw-type slot) 't))
1276 (define-defstruct-name fun)
1277 (setf (info function accessor-for fun) class)
1278 (unless (dsd-read-only slot)
1279 (define-defstruct-name setf-fun)
1280 (setf (info function accessor-for setf-fun) class))))))
1281
1282 (undefined-value))
1283
1284 (setf (symbol-function '%compiler-defstruct) #'%%compiler-defstruct)
1285
1286
1287 ;;; COPY-STRUCTURE -- Public
1288 ;;;
1289 ;;; Copy any old kind of structure.
1290 ;;;
1291 #-ns-boot
1292 (defun copy-structure (structure)
1293 "Return a copy of Structure with the same (EQL) slot values."
1294 (declare (type instance structure) (optimize (speed 3) (safety 0)))
1295 (let* ((len (%instance-length structure))
1296 (res (%make-instance len))
1297 (layout (%instance-layout structure)))
1298 (declare (type structure-index len))
1299 (unless (structure-class-p (layout-class layout))
1300 (error "Not a structure-class object:~% ~S" structure))
1301 (when (layout-invalid layout)
1302 (error "Copying an obsolete structure:~% ~S" structure))
1303
1304 (dotimes (i len)
1305 (declare (type structure-index i))
1306 (setf (%instance-ref res i)
1307 (%instance-ref structure i)))
1308
1309 (let ((raw-index (dd-raw-index (layout-info layout))))
1310 (when raw-index
1311 (let* ((data (%instance-ref structure raw-index))
1312 (raw-len (length data))
1313 (new (make-array raw-len :element-type '(unsigned-byte 32))))
1314 (declare (type (simple-array (unsigned-byte 32) (*)) data))
1315 (setf (%instance-ref res raw-index) new)
1316 (dotimes (i raw-len)
1317 (setf (aref new i) (aref data i))))))
1318
1319 res))
1320
1321
1322 ;;; Default print and make-load-form methods.
1323
1324 #-ns-boot
1325 (defun default-structure-print (structure stream depth)
1326 (declare (ignore depth))
1327 (let* ((type (%instance-layout structure))
1328 (name (class-name (layout-class type)))
1329 (dd (layout-info type)))
1330 (if *print-pretty*
1331 (pprint-logical-block (stream nil :prefix "#S(" :suffix ")")
1332 (prin1 name stream)
1333 (let ((slots (dd-slots dd)))
1334 (when slots
1335 (write-char #\space stream)
1336 (pprint-indent :block 2 stream)
1337 (pprint-newline :linear stream)
1338 (loop
1339 (pprint-pop)
1340 (let ((slot (pop slots)))
1341 (write-char #\: stream)
1342 (output-symbol-name (dsd-%name slot) stream)
1343 (write-char #\space stream)
1344 (pprint-newline :miser stream)
1345 (output-object (%instance-ref structure (dsd-index slot))
1346 stream)
1347 (when (null slots)
1348 (return))
1349 (write-char #\space stream)
1350 (pprint-newline :linear stream))))))
1351 (descend-into (stream)
1352 (write-string "#S(" stream)
1353 (prin1 name stream)
1354 (do ((index 1 (1+ index))
1355 (length (%instance-length structure))
1356 (slots (dd-slots dd) (cdr slots)))
1357 ((or (= index length)
1358 (and *print-length*
1359 (= index *print-length*)))
1360 (if (= index length)
1361 (write-string ")" stream)
1362 (write-string "...)" stream)))
1363 (declare (type index index))
1364 (write-char #\space stream)
1365 (write-char #\: stream)
1366 (output-symbol-name (dsd-%name (car slots)) stream)
1367 (write-char #\space stream)
1368 (output-object (%instance-ref structure index) stream))))))
1369
1370 #-ns-boot
1371 (defun make-structure-load-form (structure)
1372 (declare (type structure structure))
1373 (let* ((class (layout-class (%instance-layout structure)))
1374 (fun (structure-class-make-load-form-fun class)))
1375 (etypecase fun
1376 ((member :just-dump-it-normally :ignore-it)
1377 fun)
1378 (null
1379 (error "Structures of type ~S cannot be dumped as constants."
1380 (class-name class)))
1381 (function
1382 (funcall fun structure))
1383 (symbol
1384 (funcall (symbol-function fun) structure)))))

  ViewVC Help
Powered by ViewVC 1.1.5