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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5