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

Diff of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

Legend:
Removed from v.1.37  
changed lines
  Added in v.1.38

  ViewVC Help
Powered by ViewVC 1.1.5