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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.97 - (hide annotations)
Fri Dec 22 17:39:41 2006 UTC (7 years, 3 months ago) by rtoy
Branch: MAIN
CVS Tags: unicode-utf16-extfmt-2009-03-27, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, sse2-base, sse2-packed-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, snapshot-2007-01, snapshot-2007-02, release-19e, unicode-utf16-sync-2008-12, label-2009-03-16, release-19f-base, merge-sse2-packed, merge-with-19f, unicode-snapshot-2009-05, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, snapshot-2008-04, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, snapshot-2007-04, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2007-06, release-19e-pre1, release-19e-pre2, label-2009-03-25, sse2-checkpoint-2008-10-01, sse2-merge-with-2008-11, sse2-merge-with-2008-10, unicode-utf16-string-support, release-19e-base, unicode-utf16-base, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-05, snapshot-2009-04, pre-telent-clx
Branch point for: RELEASE-19F-BRANCH, sse2-packed-branch, unicode-utf16-branch, release-19e-branch, sse2-branch, unicode-utf16-extfmt-branch
Changes since 1.96: +30 -16 lines
Fix issue reported by Albert Reiner, cmucl-help, 2006/10/20, and fix
another issue with uninitialized &aux variables.

  (defstruct (foobar
               (:constructor make-foobar
                             (xxx
                              &key (aaa nil) (bbb nil)
                              &aux
                              (foobar-data xxx)
                              (aaa (or aaa
                                       (getf foobar-data :aaa)
                                       1))
                              (bbb (or bbb
                                       (getf foobar-data :bbb)
                                       (1+ aaa))))))
    (aaa (required-argument) :type fixnum)
    (bbb (required-argument) :type fixnum))

  (make-foobar nil) -> #<foobar :aaa 1 :bbb 2>

But CMUCL gives type errors.

To fix Albert's issue, modify CREATE-BOA-CONSTRUCTOR to keep track of
the &aux vars separately from the other arglist vars.  Adjust
CREATE-VECTOR-CONSTRUCTOR, CREATE-LIST-CONSTRUCTOR,
CREATE-STRUCTURE-CONSTRUCTOR, and CREATE-FIN-CONSTRUCTOR to take an
extra arg for the &aux vars.  For CREATE-STRUCTURE-CONSTRUCTOR, we
only put declarations for the other arglist vars.  To make sure we
store the right kinds of objects into the slots, we also wrap (the
<type> init) for each initial value.

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

  ViewVC Help
Powered by ViewVC 1.1.5