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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.62 - (hide annotations)
Mon Apr 20 11:32:50 1998 UTC (16 years ago) by pw
Branch: MAIN
Changes since 1.61: +4 -2 lines
This revision alters the condition type hierarchy to be in compliance
with the ANSI spec. A default report method is attached to the
serious-condition class and many of the uses of (error "string" arg..)
in filesys.lisp and package.lisp were changed to use, for example,
(error 'file-error :format-control "string" :format-arguments (list stuff))
The end result is no obvious change to what the user sees, and enables
one to establish a handler to catch the particular error type as
mentioned in the "Exceptional Situations:" section of the CLHS
write-ups. There probably are still some places where the error
types need to be fixed.

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

  ViewVC Help
Powered by ViewVC 1.1.5