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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5