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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5