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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5