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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5