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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5