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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5