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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.98.14.1 - (hide annotations)
Thu Feb 25 20:34:48 2010 UTC (4 years, 1 month ago) by rtoy
Branch: intl-2-branch
Changes since 1.98: +60 -51 lines
Restart internalization work.  This new branch starts with code from
the intl-branch on date 2010-02-12 18:00:00+0500.  This version works
and

LANG=en@piglatin bin/lisp

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

  ViewVC Help
Powered by ViewVC 1.1.5