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

Legend:
Removed from v.1.8.1.3  
changed lines
  Added in v.1.103

  ViewVC Help
Powered by ViewVC 1.1.5