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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.92 - (show annotations)
Fri Aug 8 11:32:52 2003 UTC (10 years, 8 months ago) by emarsden
Branch: MAIN
CVS Tags: snapshot-2003-10, dynamic-extent-base, sparc_gencgc_merge, snapshot-2003-11, snapshot-2003-12, lisp-executable-base
Branch point for: dynamic-extent, lisp-executable
Changes since 1.91: +5 -2 lines
Add a function EXT:UNLOCK-ALL-PACKAGES, that disables both the
structural and the definition locks for all existing packages. Add an
additional restart to the PACKAGE-LOCKED-ERROR signaling points that
allows the user to disable all packages then continue.

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

  ViewVC Help
Powered by ViewVC 1.1.5