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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5