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

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

  ViewVC Help
Powered by ViewVC 1.1.5