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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5