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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5