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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.90 - (show annotations)
Fri Jun 20 10:34:37 2003 UTC (10 years, 10 months ago) by gerd
Branch: MAIN
Changes since 1.89: +8 -5 lines
	Structure predicates used to signal an error when applied to an
	object that is an obsolete instances.  Reported by Andre Valente
	on cmucl-imp.

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

  ViewVC Help
Powered by ViewVC 1.1.5