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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5