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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5