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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5