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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.78 - (hide annotations)
Fri Jan 3 18:02:58 2003 UTC (11 years, 3 months ago) by toy
Branch: MAIN
Changes since 1.77: +102 -9 lines
Gerd Moellmann's port of SBCL's fix for the conc-name/structure
inheritance bug (SBCL bug 127).  Slightly modified to make building a
little easier.

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

  ViewVC Help
Powered by ViewVC 1.1.5