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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5