/[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.58.2.3 by pw, Sat Mar 23 18:49:55 2002 UTC revision 1.103 by rtoy, Sun Dec 26 14:54:33 2010 UTC
# Line 13  Line 13 
13  ;;; Written by Rob MacLachlan, William Lott and Skef Wholey.  ;;; Written by Rob MacLachlan, William Lott and Skef Wholey.
14  ;;;  ;;;
15  (in-package "LISP")  (in-package "LISP")
16    
17    (intl:textdomain "cmucl")
18    
19  (export '(defstruct copy-structure structure-object))  (export '(defstruct copy-structure structure-object))
20  (in-package "KERNEL")  (in-package "KERNEL")
21  (export '(default-structure-print make-structure-load-form  (export '(default-structure-print make-structure-load-form
# Line 214  Line 217 
217    ;;    ;;
218    ;; The arguments to the :ALTERNATE-METACLASS option (an extension used to    ;; The arguments to the :ALTERNATE-METACLASS option (an extension used to
219    ;; define structure-like objects with an arbitrary superclass and that may    ;; define structure-like objects with an arbitrary superclass and that may
220    ;; not have STRUCTURE-CLASS as the metaclass.)  Syntax is:    ;; not have STRUCTURE-CLASS as the metaclass).  Syntax is:
221    ;;    (superclass-name metaclass-name metaclass-constructor)    ;;    (superclass-name metaclass-name metaclass-constructor)
222    ;;    ;;
223    (alternate-metaclass nil :type list)    (alternate-metaclass nil :type list)
224    ;;    ;;
225    ;; list of defstruct-slot-description objects for all slots (including    ;; list of defstruct-slot-description objects for all slots (including
226    ;; included ones.)    ;; included ones).
227    (slots () :type list)    (slots () :type list)
228    ;;    ;;
229    ;; Number of elements we've allocated (see also raw-length.)    ;; Number of elements we've allocated (see also raw-length).
230    (length 0 :type index)    (length 0 :type index)
231    ;;    ;;
232    ;; General kind of implementation.    ;; General kind of implementation.
# Line 261  Line 264 
264    ;;    ;;
265    ;; Value of the :PURE option, or :UNSPECIFIED.  Only meaningful if    ;; Value of the :PURE option, or :UNSPECIFIED.  Only meaningful if
266    ;; CLASS-STRUCTURE-P = T.    ;; CLASS-STRUCTURE-P = T.
267    (pure :unspecified :type (member t nil :substructure :unspecified)))    (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)
273      (declare (ignore depth))
274      (format stream "#<Defstruct-Description for ~S>" (dd-name structure)))
275    
276  ;;; DEFSTRUCT-SLOT-DESCRIPTION  holds compile-time information about structure  ;;; DEFSTRUCT-SLOT-DESCRIPTION  holds compile-time information about structure
277  ;;; slots.  ;;; slots.
# Line 272  Line 281 
281               (:print-function print-defstruct-slot-description)               (:print-function print-defstruct-slot-description)
282               (:pure t)               (:pure t)
283               (:make-load-form-fun :just-dump-it-normally))               (:make-load-form-fun :just-dump-it-normally))
284    %name                         ; string name of slot    ;;
285      ;; The name of the slot, a symbol.
286      name
287    ;;    ;;
288    ;; its position in the implementation sequence    ;; its position in the implementation sequence
289    (index (required-argument) :type fixnum)    (index (required-argument) :type fixnum)
# Line 289  Line 300 
300                              unsigned-byte))                              unsigned-byte))
301    (read-only nil :type (member t nil)))    (read-only nil :type (member t nil)))
302    
303  (defun print-defstruct-description (structure stream depth)  (defun print-defstruct-slot-description (structure stream depth)
304    (declare (ignore depth))    (declare (ignore depth))
305    (format stream "#<Defstruct-Description for ~S>" (dd-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  ;;; CLASS-STRUCTURE-P  --  Internal
311  ;;;  ;;;
# Line 309  Line 322 
322  (defun compiler-layout-or-lose (name)  (defun compiler-layout-or-lose (name)
323    (let ((res (info type compiler-layout name)))    (let ((res (info type compiler-layout name)))
324      (cond ((not res)      (cond ((not res)
325             (error "Class not yet defined or was undefined: ~S" name))             (error (intl:gettext "Class not yet defined or was undefined: ~S") name))
326            ((not (typep (layout-info res) 'defstruct-description))            ((not (typep (layout-info res) 'defstruct-description))
327             (error "Class is not a structure class: ~S" name))             (error (intl:gettext "Class is not a structure class: ~S") name))
328            (t res))))            (t res))))
329    
   
 ;;; DSD-Name  --  External  
 ;;;  
 ;;;    Return the name of a defstruct slot as a symbol.  We store it  
 ;;; as a string to avoid creating lots of worthless symbols at load time.  
 ;;;  
 (defun dsd-name (dsd)  
   (intern (string (dsd-%name dsd))  
           (symbol-package (dsd-accessor dsd))))  
   
 (defun print-defstruct-slot-description (structure stream depth)  
   (declare (ignore depth))  
   (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure)))  
   
330  (defun dd-maybe-make-print-method (defstruct)  (defun dd-maybe-make-print-method (defstruct)
331    ;; Maybe generate CLOS DEFMETHOD forms for :print-function/:print-object.    ;; Maybe generate CLOS DEFMETHOD forms for :print-function/:print-object.
332    (let ((print-function-value (dd-print-function defstruct)))    (let ((print-function-value (dd-print-function defstruct)))
# Line 374  Line 373 
373                           `#',mlff)))))                           `#',mlff)))))
374        ,@(let ((pure (dd-pure defstruct)))        ,@(let ((pure (dd-pure defstruct)))
375            (cond ((eq pure 't)            (cond ((eq pure 't)
376                   `((setf (layout-pure (class-layout (find-class ',name)))                   `((setf (layout-pure (%class-layout (find-class ',name)))
377                      t)))                      t)))
378                  ((eq pure :substructure)                  ((eq pure :substructure)
379                   `((setf (layout-pure (class-layout (find-class ',name)))                   `((setf (layout-pure (%class-layout (find-class ',name)))
380                      0)))))                      0)))))
381        ,@(let ((def-con (dd-default-constructor defstruct)))        ,@(let ((def-con (dd-default-constructor defstruct)))
382            (when (and def-con (not (dd-alternate-metaclass defstruct)))            (when (and def-con (not (dd-alternate-metaclass defstruct)))
# Line 402  Line 401 
401                           `#',mlff)))))                           `#',mlff)))))
402        ,@(let ((pure (dd-pure defstruct)))        ,@(let ((pure (dd-pure defstruct)))
403            (cond ((eq pure 't)            (cond ((eq pure 't)
404                   `((setf (layout-pure (class-layout (find-class ',name)))                   `((setf (layout-pure (%class-layout (find-class ',name)))
405                      t)))                      t)))
406                  ((eq pure :substructure)                  ((eq pure :substructure)
407                   `((setf (layout-pure (class-layout (find-class ',name)))                   `((setf (layout-pure (%class-layout (find-class ',name)))
408                      0)))))                      0)))))
409        ,@(let ((def-con (dd-default-constructor defstruct)))        ,@(let ((def-con (dd-default-constructor defstruct)))
410            (when (and def-con (not (dd-alternate-metaclass defstruct)))            (when (and def-con (not (dd-alternate-metaclass defstruct)))
411              `((setf (structure-class-constructor (find-class ',name))              `((setf (structure-class-constructor (find-class ',name))
412                      #',def-con)))))))                      #',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  ;;; DEFSTRUCT  --  Public
419  ;;;  ;;;
# Line 447  Line 449 
449    (let* ((defstruct (parse-name-and-options    (let* ((defstruct (parse-name-and-options
450                       (if (atom name-and-options)                       (if (atom name-and-options)
451                           (list name-and-options)                           (list name-and-options)
452                           name-and-options)))                           name-and-options)))
453           (name (dd-name defstruct)))           (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))      (when (stringp (car slot-descriptions))
477        (setf (dd-doc defstruct) (pop slot-descriptions)))        (setf (dd-doc defstruct) (pop slot-descriptions)))
478      (dolist (slot slot-descriptions)      (dolist (slot slot-descriptions)
# Line 463  Line 487 
487               ,@(define-raw-accessors defstruct)               ,@(define-raw-accessors defstruct)
488               ,@(define-constructors defstruct)               ,@(define-constructors defstruct)
489               ,@(define-class-methods defstruct)               ,@(define-class-methods defstruct)
490                 (lisp::set-defvar-source-location ',name (c::source-location))
491             ',name))             ',name))
492          `(progn          `(progn
493             (eval-when (compile load eval)             (eval-when (compile load eval)
# Line 471  Line 496 
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))))
501    
502    
# Line 485  Line 511 
511          (name (dd-name defstruct)))          (name (dd-name defstruct)))
512      (case (first option)      (case (first option)
513        (:conc-name        (:conc-name
514         (destructuring-bind (conc-name) args         (destructuring-bind (&optional conc-name)
515               args
516           (setf (dd-conc-name defstruct)           (setf (dd-conc-name defstruct)
517                 (if (symbolp conc-name)                 (if (symbolp conc-name)
518                     conc-name                     conc-name
# Line 505  Line 532 
532           (setf (dd-predicate defstruct) pred)))           (setf (dd-predicate defstruct) pred)))
533        (:include        (:include
534         (when (dd-include defstruct)         (when (dd-include defstruct)
535           (error "Can't have more than one :INCLUDE option."))           (error (intl:gettext "Can't have more than one :INCLUDE option.")))
536         (setf (dd-include defstruct) args))         (setf (dd-include defstruct) args))
537        (:alternate-metaclass        (:alternate-metaclass
538         (setf (dd-alternate-metaclass defstruct) args))         (setf (dd-alternate-metaclass defstruct) args))
# Line 528  Line 555 
555                    (setf (dd-element-type defstruct) vtype)                    (setf (dd-element-type defstruct) vtype)
556                    (setf (dd-type defstruct) 'vector)))                    (setf (dd-type defstruct) 'vector)))
557                 (t                 (t
558                  (error "~S is a bad :TYPE for Defstruct." type)))))                  (error (intl:gettext "~S is a bad :TYPE for Defstruct.") type)))))
559        (:named        (:named
560         (error "The Defstruct option :NAMED takes no arguments."))         (error (intl:gettext "The Defstruct option :NAMED takes no arguments.")))
561        (:initial-offset        (:initial-offset
562         (destructuring-bind (offset) args         (destructuring-bind (offset) args
563           (setf (dd-offset defstruct) offset)))           (setf (dd-offset defstruct) offset)))
# Line 540  Line 567 
567        (:pure        (:pure
568         (destructuring-bind (fun) args         (destructuring-bind (fun) args
569           (setf (dd-pure defstruct) fun)))           (setf (dd-pure defstruct) fun)))
570        (t (error "Unknown DEFSTRUCT option~%  ~S" option)))))        (t (error (intl:gettext "Unknown DEFSTRUCT option~%  ~S") option)))))
571    
572  #+ORIGINAL  #+ORIGINAL
573  (defun parse-1-option (option defstruct)  (defun parse-1-option (option defstruct)
# Line 568  Line 595 
595           (setf (dd-predicate defstruct) pred)))           (setf (dd-predicate defstruct) pred)))
596        (:include        (:include
597         (when (dd-include defstruct)         (when (dd-include defstruct)
598           (error "Can't have more than one :INCLUDE option."))           (error (intl:gettext "Can't have more than one :INCLUDE option.")))
599         (setf (dd-include defstruct) args))         (setf (dd-include defstruct) args))
600        (:alternate-metaclass        (:alternate-metaclass
601         (setf (dd-alternate-metaclass defstruct) args))         (setf (dd-alternate-metaclass defstruct) args))
# Line 588  Line 615 
615                    (setf (dd-element-type defstruct) vtype)                    (setf (dd-element-type defstruct) vtype)
616                    (setf (dd-type defstruct) 'vector)))                    (setf (dd-type defstruct) 'vector)))
617                 (t                 (t
618                  (error "~S is a bad :TYPE for Defstruct." type)))))                  (error (intl:gettext "~S is a bad :TYPE for Defstruct.") type)))))
619        (:named        (:named
620         (error "The Defstruct option :NAMED takes no arguments."))         (error (intl:gettext "The Defstruct option :NAMED takes no arguments.")))
621        (:initial-offset        (:initial-offset
622         (destructuring-bind (offset) args         (destructuring-bind (offset) args
623           (setf (dd-offset defstruct) offset)))           (setf (dd-offset defstruct) offset)))
# Line 600  Line 627 
627        (:pure        (:pure
628         (destructuring-bind (fun) args         (destructuring-bind (fun) args
629           (setf (dd-pure defstruct) fun)))           (setf (dd-pure defstruct) fun)))
630        (t (error "Unknown DEFSTRUCT option~%  ~S" option)))))        (t (error (intl:gettext "Unknown DEFSTRUCT option~%  ~S") option)))))
631    
632    
633  ;;; PARSE-NAME-AND-OPTIONS  --  Internal  ;;; PARSE-NAME-AND-OPTIONS  --  Internal
# Line 615  Line 642 
642                 (parse-1-option option defstruct))                 (parse-1-option option defstruct))
643                ((eq option :named)                ((eq option :named)
644                 (setf (dd-named defstruct) t))                 (setf (dd-named defstruct) t))
645                ((member option '(:constructor :copier :predicate :named))                ((member option '(:constructor :copier :predicate :named
646                                    :conc-name))
647                 (parse-1-option (list option) defstruct))                 (parse-1-option (list option) defstruct))
648                (t                (t
649                 (error "Unrecognized DEFSTRUCT option: ~S" option))))                 (error (intl:gettext "Unrecognized DEFSTRUCT option: ~S") option))))
650    
651        (case (dd-type defstruct)        (case (dd-type defstruct)
652          (structure          (structure
653           (when (dd-offset defstruct)           (when (dd-offset defstruct)
654             (error "Can't specify :OFFSET unless :TYPE is specified."))             (error (intl:gettext "Can't specify :OFFSET unless :TYPE is specified.")))
655           (unless (dd-include defstruct)           (unless (dd-include defstruct)
656             (incf (dd-length defstruct))))             (incf (dd-length defstruct))))
657          (funcallable-structure)          (funcallable-structure)
658          (t          (t
659           (when (dd-print-function defstruct)           (when (dd-print-function defstruct)
660             (warn "Silly to specify :PRINT-FUNCTION with :TYPE."))             (warn (intl:gettext "Silly to specify :PRINT-FUNCTION with :TYPE.")))
661           (when (dd-make-load-form-fun defstruct)           (when (dd-make-load-form-fun defstruct)
662             (warn "Silly to specify :MAKE-LOAD-FORM-FUN with :TYPE."))             (warn (intl:gettext "Silly to specify :MAKE-LOAD-FORM-FUN with :TYPE.")))
663           (when (dd-named defstruct) (incf (dd-length defstruct)))           (when (dd-named defstruct) (incf (dd-length defstruct)))
664           (let ((offset (dd-offset defstruct)))           (let ((offset (dd-offset defstruct)))
665             (when offset (incf (dd-length defstruct) offset)))))             (when offset (incf (dd-length defstruct) offset)))))
# Line 652  Line 680 
680  ;;;  ;;;
681  (defun parse-1-dsd (defstruct spec &optional  (defun parse-1-dsd (defstruct spec &optional
682                       (islot (make-defstruct-slot-description                       (islot (make-defstruct-slot-description
683                               :%name "" :index 0 :type t)))                               :name nil :index 0 :type t)))
684    (multiple-value-bind    (multiple-value-bind (name default default-p type type-p read-only ro-p)
685        (name default default-p type type-p read-only ro-p)        (cond ((consp spec)
686        (cond               (destructuring-bind (name &optional (default nil default-p)
687         ((listp spec)                                         &key (type nil type-p)
688          (destructuring-bind (name &optional (default nil default-p)                                         (read-only nil ro-p))
689                                    &key (type nil type-p) (read-only nil ro-p))                   spec
690                              spec                 (values name default default-p type type-p read-only ro-p)))
691            (values name default default-p type type-p read-only ro-p)))              (t
692         (t               (when (keywordp spec)
693          (when (keywordp spec)                 (warn (intl:gettext "Keyword slot name indicates probable syntax ~
694            (warn "Keyword slot name indicates probable syntax ~                        error in DEFSTRUCT -- ~S.")
695                   error in DEFSTRUCT -- ~S."                       spec))
696                  spec))               spec))
         spec))  
697      (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)      (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)
698        (error 'simple-program-error        (error 'simple-program-error
699               :format-control "Duplicate slot name ~S."               :format-control (intl:gettext "Duplicate slot name ~S.")
700               :format-arguments (list name)))               :format-arguments (list name)))
701      (setf (dsd-%name islot) (string name))      (setf (dsd-name islot) name)
702      (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot)))      (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot)))
   
703      (setf (dsd-accessor islot) (concat-pnames (dd-conc-name defstruct) name))      (setf (dsd-accessor islot) (concat-pnames (dd-conc-name defstruct) name))
   
704      (when default-p      (when default-p
705        (setf (dsd-default islot) default))        (setf (dsd-default islot) default))
706      (when type-p      (when type-p
# Line 687  Line 712 
712        (if read-only        (if read-only
713            (setf (dsd-read-only islot) t)            (setf (dsd-read-only islot) t)
714            (when (dsd-read-only islot)            (when (dsd-read-only islot)
715              (error "Slot ~S must be read-only in subtype ~S." name              (error (intl:gettext "Slot ~S must be read-only in subtype ~S.") name
716                     (dsd-name islot)))))                     (dsd-name islot)))))
717      islot))      islot))
718    
# Line 757  Line 782 
782        (unless (and (eq type (dd-type included-structure))        (unless (and (eq type (dd-type included-structure))
783                     (type= (specifier-type (dd-element-type included-structure))                     (type= (specifier-type (dd-element-type included-structure))
784                            (specifier-type (dd-element-type defstruct))))                            (specifier-type (dd-element-type defstruct))))
785          (error ":TYPE option mismatch between structures ~S and ~S."          (error (intl:gettext ":TYPE option mismatch between structures ~S and ~S.")
786                 (dd-name defstruct) included-name))                 (dd-name defstruct) included-name))
787    
788        (incf (dd-length defstruct) (dd-length included-structure))        (incf (dd-length defstruct) (dd-length included-structure))
# Line 776  Line 801 
801            (setf (dd-pure defstruct) (dd-pure included-structure)))            (setf (dd-pure defstruct) (dd-pure included-structure)))
802          (setf (dd-raw-index defstruct) (dd-raw-index included-structure))          (setf (dd-raw-index defstruct) (dd-raw-index included-structure))
803          (setf (dd-raw-length defstruct) (dd-raw-length included-structure)))          (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))        (dolist (islot (dd-slots included-structure))
809          (let* ((iname (dsd-name islot))          (let* ((iname (dsd-name islot))
# Line 783  Line 811 
811                                     :key #'(lambda (x) (if (atom x) x (car x)))                                     :key #'(lambda (x) (if (atom x) x (car x)))
812                                     :test #'string=)                                     :test #'string=)
813                               `(,iname))))                               `(,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            (parse-1-dsd defstruct modified
827                         (copy-defstruct-slot-description islot)))))))                         (copy-defstruct-slot-description islot)))))))
828    
# Line 792  Line 832 
832    
833  (defun typed-structure-info-or-lose (name)  (defun typed-structure-info-or-lose (name)
834    (or (info typed-structure info name)    (or (info typed-structure info name)
835        (error ":TYPE'd defstruct ~S not found for inclusion." name)))        (error (intl:gettext ":TYPE'd defstruct ~S not found for inclusion.") name)))
836    
837  ;;; %GET-COMPILER-LAYOUT  --  Internal  ;;; %GET-COMPILER-LAYOUT  --  Internal
838  ;;;  ;;;
# Line 833  Line 873 
873  ;;; processed the arglist.  The correct variant (according to the DD-TYPE)  ;;; processed the arglist.  The correct variant (according to the DD-TYPE)
874  ;;; should be called.  The function is defined with the specified name and  ;;; should be called.  The function is defined with the specified name and
875  ;;; arglist.  Vars and Types are used for argument type declarations.  Values  ;;; arglist.  Vars and Types are used for argument type declarations.  Values
876  ;;; are the values for the slots (in order.)  ;;; are the values for the slots (in order).
877  ;;;  ;;;
878  ;;; This is split four ways because:  ;;; This is split four ways because:
879  ;;; 1] list & vector structures need "name" symbols stuck in at various weird  ;;; 1] list & vector structures need "name" symbols stuck in at various weird
# Line 846  Line 886 
886  ;;; 4] funcallable structures are weird.  ;;; 4] funcallable structures are weird.
887  ;;;  ;;;
888  (defun create-vector-constructor  (defun create-vector-constructor
889         (defstruct cons-name arglist vars types values)         (defstruct cons-name arglist vars aux-vars types values)
890    (let ((temp (gensym))    (let ((temp (gensym))
891          (etype (dd-element-type defstruct)))          (etype (dd-element-type defstruct)))
892      `(defun ,cons-name ,arglist      `(defun ,cons-name ,arglist
893         (declare ,@(mapcar #'(lambda (var type) `(type (and ,type ,etype) ,var))         (declare ,@(mapcar #'(lambda (var type) `(type (and ,type ,etype) ,var))
894                            vars types))                            (append vars aux-vars) types))
895         (let ((,temp (make-array ,(dd-length defstruct)         (let ((,temp (make-array ,(dd-length defstruct)
896                                  :element-type ',(dd-element-type defstruct))))                                  :element-type ',(dd-element-type defstruct))))
897           ,@(mapcar #'(lambda (x)           ,@(mapcar #'(lambda (x)
# Line 863  Line 903 
903           ,temp))))           ,temp))))
904  ;;;  ;;;
905  (defun create-list-constructor  (defun create-list-constructor
906         (defstruct cons-name arglist vars types values)         (defstruct cons-name arglist vars aux-vars types values)
907    (let ((vals (make-list (dd-length defstruct) :initial-element nil)))    (let ((vals (make-list (dd-length defstruct) :initial-element nil)))
908      (dolist (x (find-name-indices defstruct))      (dolist (x (find-name-indices defstruct))
909        (setf (elt vals (cdr x)) `',(car x)))        (setf (elt vals (cdr x)) `',(car x)))
# Line 872  Line 912 
912    
913      `(defun ,cons-name ,arglist      `(defun ,cons-name ,arglist
914         (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))         (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
915                            vars types))                            (append vars aux-vars) types))
916         (list ,@vals))))         (list ,@vals))))
917  ;;;  ;;;
918  (defun create-structure-constructor  (defun create-structure-constructor
919         (defstruct cons-name arglist vars types values)         (defstruct cons-name arglist vars aux-vars types values)
920    (let* ((temp (gensym))    (let* ((temp (gensym))
921           (raw-index (dd-raw-index defstruct))           (raw-index (dd-raw-index defstruct))
922           (n-raw-data (when raw-index (gensym))))           (n-raw-data (when raw-index (gensym))))
923      `(defun ,cons-name ,arglist      `(defun ,cons-name ,arglist
924         (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))         (declare ,@(remove nil
925                            vars types))                            (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)         (let ((,temp (truly-the ,(dd-name defstruct)
931                                 (%make-instance ,(dd-length defstruct))))                                 (%make-instance ,(dd-length defstruct))))
932               ,@(when n-raw-data               ,@(when n-raw-data
# Line 897  Line 941 
941                         (multiple-value-bind                         (multiple-value-bind
942                             (accessor index data)                             (accessor index data)
943                             (slot-accessor-form defstruct dsd temp n-raw-data)                             (slot-accessor-form defstruct dsd temp n-raw-data)
944                           `(setf (,accessor ,data ,index) ,value)))                           (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)                     (dd-slots defstruct)
950                     values)                     values)
951           ,temp))))           ,temp))))
952  ;;;  ;;;
953  (defun create-fin-constructor  (defun create-fin-constructor
954         (defstruct cons-name arglist vars types values)         (defstruct cons-name arglist vars aux-vars types values)
955    (let ((temp (gensym)))    (let ((temp (gensym)))
956      `(defun ,cons-name ,arglist      `(defun ,cons-name ,arglist
957         (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))         (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
958                            vars types))                            (append vars aux-vars) types))
959         (let ((,temp (truly-the         (let ((,temp (truly-the
960                       ,(dd-name defstruct)                       ,(dd-name defstruct)
961                       (%make-funcallable-instance                       (%make-funcallable-instance
# Line 938  Line 986 
986          (vals dum)))          (vals dum)))
987      (funcall creator      (funcall creator
988               defstruct (dd-default-constructor defstruct)               defstruct (dd-default-constructor defstruct)
989               (arglist) (vals) (types) (vals))))               (arglist) (vals) nil (types) (vals))))
990    
991    
992  ;;; CREATE-BOA-CONSTRUCTOR  --  Internal  ;;; CREATE-BOA-CONSTRUCTOR  --  Internal
# Line 951  Line 999 
999                         (kernel:parse-lambda-list (second boa))                         (kernel:parse-lambda-list (second boa))
1000      (collect ((arglist)      (collect ((arglist)
1001                (vars)                (vars)
1002                  (aux-vars)
1003                (types))                (types))
1004        (labels ((get-slot (name)        (labels ((get-slot (name)
1005                   (let ((res (find name (dd-slots defstruct) :test #'string=                   (let ((res (find name (dd-slots defstruct) :test #'string=
# Line 971  Line 1020 
1020          (when opt          (when opt
1021            (arglist '&optional)            (arglist '&optional)
1022            (dolist (arg opt)            (dolist (arg opt)
1023              (cond ((consp arg)              (if (consp arg)
1024                     (destructuring-bind                  (destructuring-bind (name &optional
1025                         (name &optional (def (nth-value 1 (get-slot name))))                                            (def (nth-value 1 (get-slot name)))
1026                         arg                                            (supplied-test nil supplied-test-p))
1027                       (arglist `(,name ,def))                      arg
1028                       (vars name)                    (arglist
1029                       (types (get-slot name))))                     `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)))
1030                    (t                    (vars name)
1031                     (do-default arg)))))                    (types (get-slot name)))
1032                    (do-default arg))))
1033    
1034          (when restp          (when restp
1035            (arglist '&rest rest)            (arglist '&rest rest)
# Line 988  Line 1038 
1038    
1039          (when keyp          (when keyp
1040            (arglist '&key)            (arglist '&key)
1041            (dolist (key keys)            (dolist (arg keys)
1042              (if (consp key)              (if (consp arg)
1043                  (destructuring-bind (wot &optional (def nil def-p))                  (destructuring-bind
1044                                      key                        (name-spec &optional
1045                    (let ((name (if (consp wot)                                   (def nil def-p)
1046                                    (destructuring-bind (key var) wot                                   (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))                                      (declare (ignore key))
1051                                      var)                                      var)
1052                                    wot)))                                    name-spec)))
1053                      (multiple-value-bind (type slot-def) (get-slot name)                      (multiple-value-bind (type slot-def) (get-slot name)
1054                        (arglist `(,wot ,(if def-p def slot-def)))                        (arglist
1055                           `(,name-spec
1056                             ,(if def-p def slot-def)
1057                             ,@(if supplied-test-p `(,supplied-test) nil)))
1058                        (vars name)                        (vars name)
1059                        (types type))))                        (types type))))
1060                  (do-default key))))                  (do-default arg))))
1061    
1062          (when allowp (arglist '&allow-other-keys))          (when allowp (arglist '&allow-other-keys))
1063    
# Line 1011  Line 1067 
1067              (let* ((arg (if (consp arg) arg (list arg)))              (let* ((arg (if (consp arg) arg (list arg)))
1068                     (var (first arg)))                     (var (first arg)))
1069                (arglist arg)                (arglist arg)
1070                (vars var)                (aux-vars var)
1071                (types (get-slot var))))))                (types (get-slot var))))))
1072    
1073        (funcall creator defstruct (first boa)        (funcall creator defstruct (first boa)
1074                 (arglist) (vars) (types)                 (arglist) (vars) (aux-vars) (types)
1075                 (mapcar #'(lambda (slot)                 (mapcar #'(lambda (slot)
1076                             (or (find (dsd-name slot) (vars) :test #'string=)                             (let ((v (find (dsd-name slot) (vars) :test #'string=)))
1077                                 (dsd-default slot)))                               (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))))))                         (dd-slots defstruct))))))
1084    
1085    
# Line 1046  Line 1107 
1107    
1108      (when no-constructors      (when no-constructors
1109        (when (or defaults boas)        (when (or defaults boas)
1110          (error "(:CONSTRUCTOR NIL) combined with other :CONSTRUCTORs."))          (error (intl:gettext "(:CONSTRUCTOR NIL) combined with other :CONSTRUCTORs.")))
1111        (return-from define-constructors ()))        (return-from define-constructors ()))
1112    
1113      (unless (or defaults boas)      (unless (or defaults boas)
# Line 1059  Line 1120 
1120            (res (create-keyword-constructor defstruct creator))            (res (create-keyword-constructor defstruct creator))
1121            (dolist (other-name (rest defaults))            (dolist (other-name (rest defaults))
1122              (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))              (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
1123              (res `(declaim (ftype function ',other-name))))))              (res `(declaim (ftype function ,other-name))))))
1124    
1125        (dolist (boa boas)        (dolist (boa boas)
1126          (res (create-boa-constructor defstruct boa creator)))          (res (create-boa-constructor defstruct boa creator)))
# Line 1072  Line 1133 
1133  ;;;  ;;;
1134  ;;;     Return info about how to read/write a slot in the value stored in  ;;;     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  ;;; 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  ;;; function, since some slots are read-only).  If supplied, Data is a variable
1137  ;;; holding the raw-data vector.  ;;; holding the raw-data vector.
1138  ;;;  ;;;
1139  ;;; Values:  ;;; Values:
# Line 1126  Line 1187 
1187  ;;; structure.  ;;; structure.
1188  ;;;  ;;;
1189  (defun dsd-inherited-p (defstruct slot)  (defun dsd-inherited-p (defstruct slot)
1190    (let* ((aname (dsd-accessor slot))    (assoc (dsd-accessor slot) (dd-inherited-accessor-alist defstruct) :test #'eq))
          (existing (info function accessor-for aname)))  
     (and (structure-class-p existing)  
          (not (eq (class-name existing) (dd-name defstruct)))  
          (string= (dsd-%name (find aname  
                                    (dd-slots  
                                     (layout-info (class-layout existing)))  
                                    :key #'dsd-accessor))  
                   (dsd-%name slot)))))  
   
1191    
1192  ;;; DEFINE-RAW-ACCESSORS  --  Internal  ;;; DEFINE-RAW-ACCESSORS  --  Internal
1193  ;;;  ;;;
# Line 1184  Line 1236 
1236  (defun dd-lisp-type (defstruct)  (defun dd-lisp-type (defstruct)
1237    (ecase (dd-type defstruct)    (ecase (dd-type defstruct)
1238      (list 'list)      (list 'list)
1239      (vector `(simple-array ,(dd-element-type defstruct)      (vector `(simple-array ,(dd-element-type defstruct) (*)))))
                            (*)))))  
1240    
1241  ;;; DEFINE-ACCESSORS  --  Internal  ;;; DEFINE-ACCESSORS  --  Internal
1242  ;;;  ;;;
# Line 1198  Line 1249 
1249    (collect ((stuff))    (collect ((stuff))
1250      (let ((ltype (dd-lisp-type defstruct)))      (let ((ltype (dd-lisp-type defstruct)))
1251        (dolist (slot (dd-slots defstruct))        (dolist (slot (dd-slots defstruct))
1252          (let ((aname (dsd-accessor slot))          (let* ((aname (dsd-accessor slot))
1253                (index (dsd-index slot))                 (index (dsd-index slot))
1254                (slot-type `(and ,(dsd-type slot)                 (slot-type `(and ,(dsd-type slot)
1255                                 ,(dd-element-type defstruct))))                              ,(dd-element-type defstruct)))
1256            (stuff `(declaim (inline ,aname (setf ,aname))))                 (inherited (accessor-inherited-data aname defstruct)))
1257            (stuff `(defun ,aname (structure)            (cond ((not inherited)
1258                      (declare (type ,ltype structure))                   (stuff `(declaim (inline ,aname (setf ,aname))))
1259                      (the ,slot-type (elt structure ,index))))                   (stuff `(defun ,aname (structure)
1260            (unless (dsd-read-only slot)                            (declare (type ,ltype structure))
1261              (stuff                            (the ,slot-type (elt structure ,index))))
1262               `(defun (setf ,aname) (new-value structure)                   (unless (dsd-read-only slot)
1263                  (declare (type ,ltype structure) (type ,slot-type new-value))                     (stuff
1264                  (setf (elt structure ,index) new-value)))))))                      `(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)))      (stuff)))
1276    
1277    
# Line 1231  Line 1292 
1292      (when (and pred (dd-named defstruct))      (when (and pred (dd-named defstruct))
1293        (let ((ltype (dd-lisp-type defstruct))        (let ((ltype (dd-lisp-type defstruct))
1294              (index (cdr (car (last (find-name-indices defstruct))))))              (index (cdr (car (last (find-name-indices defstruct))))))
1295          `((defun ,pred (object)          (if (eq ltype 'list)
1296              (and (typep object ',ltype)              `((defun ,pred (object)
1297                   (eq ,(if (eq ltype 'list)                  (and (typep object 'list)
1298                            `(nth ,index object)                       (defstruct-list-p ,index object ',name))))
1299                            `(elt object ,index))              `((defun ,pred (object)
1300                       ',name))))))))                  (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)  ;;;; Load time support for default structures (%DEFSTRUCT)
1323  ;;;  ;;;
1324  ;;;    In the normal case of structures that have a real type (i.e. no :Type  ;;;    In the normal case of structures that have a real type (i.e., no :Type
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 accessors.  ;;; speed, since there can be thousands of defined slot accessors.
1327  ;;;  ;;;
# Line 1256  Line 1336 
1336  ;;; the type's layout.  ;;; the type's layout.
1337  ;;;  ;;;
1338  (declaim (inline typep-to-layout))  (declaim (inline typep-to-layout))
1339  (defun typep-to-layout (obj layout)  (defun typep-to-layout (obj layout &optional no-error)
1340    (declare (type layout layout) (optimize (speed 3) (safety 0)))    (declare (type layout layout) (optimize (speed 3) (safety 0)))
1341    (when (layout-invalid layout)    (when (layout-invalid layout)
1342      (error "Obsolete structure accessor function called."))      (error (intl:gettext "Obsolete structure accessor function called.")))
1343    (and (%instancep obj)    (and (%instancep obj)
1344         (let ((depth (layout-inheritance-depth layout))         (let ((depth (layout-inheritance-depth layout))
1345               (obj-layout (%instance-layout obj)))               (obj-layout (%instance-layout obj)))
1346           (cond ((eq obj-layout layout) t)           (cond ((eq obj-layout layout) t)
1347                 ((layout-invalid obj-layout)                 ((layout-invalid obj-layout)
1348                  (error 'layout-invalid :expected-type (layout-class obj-layout)                  (if no-error
1349                         :datum obj))                      nil
1350                        (error 'layout-invalid
1351                               :expected-type (layout-class obj-layout)
1352                               :datum obj)))
1353                 (t                 (t
1354                  (and (> (layout-inheritance-depth obj-layout) depth)                  (and (> (layout-inheritance-depth obj-layout) depth)
1355                       (eq (svref (layout-inherits obj-layout) depth)                       (eq (svref (layout-inherits obj-layout) depth)
# Line 1288  Line 1371 
1371                (error 'simple-type-error                (error 'simple-type-error
1372                       :datum structure                       :datum structure
1373                       :expected-type class                       :expected-type class
1374                       :format-control "Structure for accessor ~S is not a ~S:~% ~S"                       :format-control (intl:gettext "Structure for accessor ~S is not a ~S:~% ~S")
1375                       :format-arguments (list (dsd-accessor dsd)                       :format-arguments (list (dsd-accessor dsd)
1376                                               (class-name class)                                               (%class-name class)
1377                                               structure)))                                               structure)))
1378              (%instance-ref structure (dsd-index dsd)))              (%instance-ref structure (dsd-index dsd)))
1379          #'(lambda (structure)          #'(lambda (structure)
# Line 1299  Line 1382 
1382                (error 'simple-type-error                (error 'simple-type-error
1383                       :datum structure                       :datum structure
1384                       :expected-type class                       :expected-type class
1385                       :format-control "Structure for accessor ~S is not a ~S:~% ~S"                       :format-control (intl:gettext "Structure for accessor ~S is not a ~S:~% ~S")
1386                       :format-arguments (list (dsd-accessor dsd) class                       :format-arguments (list (dsd-accessor dsd) class
1387                                               structure)))                                               structure)))
1388              (%instance-ref structure (dsd-index dsd))))))              (%instance-ref structure (dsd-index dsd))))))
# Line 1313  Line 1396 
1396                (error 'simple-type-error                (error 'simple-type-error
1397                       :datum structure                       :datum structure
1398                       :expected-type class                       :expected-type class
1399                       :format-control "Structure for setter ~S is not a ~S:~% ~S"                       :format-control (intl:gettext "Structure for setter ~S is not a ~S:~% ~S")
1400                       :format-arguments (list `(setf ,(dsd-accessor dsd))                       :format-arguments (list `(setf ,(dsd-accessor dsd))
1401                                               (class-name class)                                               (%class-name class)
1402                                               structure)))                                               structure)))
1403              (unless (%typep new-value (dsd-type dsd))              (unless (%typep new-value (dsd-type dsd))
1404                (error 'simple-type-error                (error 'simple-type-error
1405                       :datum new-value                       :datum new-value
1406                       :expected-type (dsd-type dsd)                       :expected-type (dsd-type dsd)
1407                       :format-control "New-Value for setter ~S is not a ~S:~% ~S."                       :format-control (intl:gettext "New-Value for setter ~S is not a ~S:~% ~S.")
1408                       :format-arguments (list `(setf ,(dsd-accessor dsd))                       :format-arguments (list `(setf ,(dsd-accessor dsd))
1409                                               (dsd-type dsd)                                               (dsd-type dsd)
1410                                               new-value)))                                               new-value)))
# Line 1332  Line 1415 
1415                (error 'simple-type-error                (error 'simple-type-error
1416                       :datum structure                       :datum structure
1417                       :expected-type class                       :expected-type class
1418                       :format-control "Structure for setter ~S is not a ~S:~% ~S"                       :format-control (intl:gettext "Structure for setter ~S is not a ~S:~% ~S")
1419                       :format-arguments (list `(setf ,(dsd-accessor dsd))                       :format-arguments (list `(setf ,(dsd-accessor dsd))
1420                                               (class-name class)                                               (%class-name class)
1421                                               structure)))                                               structure)))
1422              (unless (%typep new-value (dsd-type dsd))              (unless (%typep new-value (dsd-type dsd))
1423                (error 'simple-type-error                (error 'simple-type-error
1424                       :datum new-value                       :datum new-value
1425                       :expected-type (dsd-type dsd)                       :expected-type (dsd-type dsd)
1426                       :format-control "New-Value for setter ~S is not a ~S:~% ~S."                       :format-control (intl:gettext "New-Value for setter ~S is not a ~S:~% ~S.")
1427                       :format-arguments (list `(setf ,(dsd-accessor dsd))                       :format-arguments (list `(setf ,(dsd-accessor dsd))
1428                                               (dsd-type dsd)                                               (dsd-type dsd)
1429                                               new-value)))                                               new-value)))
1430              (setf (%instance-ref structure (dsd-index dsd)) new-value)))))              (setf (%instance-ref structure (dsd-index dsd)) new-value)))))
1431    
1432    
1433    ;;;
1434    ;;; Used for updating CLOS structure classes.  Hooks are called
1435    ;;; with one argument, the kernel::class.
1436    ;;;
1437    (defvar *defstruct-hooks* nil)
1438    
1439  ;;; %Defstruct  --  Internal  ;;; %Defstruct  --  Internal
1440  ;;;  ;;;
1441  ;;;    Do miscellaneous (LOAD EVAL) time actions for the structure described by  ;;;    Do miscellaneous (LOAD EVAL) time actions for the structure described by
# Line 1359  Line 1448 
1448    (multiple-value-bind (class layout old-layout)    (multiple-value-bind (class layout old-layout)
1449        (ensure-structure-class info inherits "current" "new")        (ensure-structure-class info inherits "current" "new")
1450      (cond ((not old-layout)      (cond ((not old-layout)
1451             (unless (eq (class-layout class) layout)             (unless (eq (%class-layout class) layout)
1452               (register-layout layout)))               (register-layout layout)))
1453            (t            (t
1454             (let ((old-info (layout-info old-layout)))             (let ((old-info (layout-info old-layout)))
# Line 1371  Line 1460 
1460                       (unless (dsd-read-only slot)                       (unless (dsd-read-only slot)
1461                         (fmakunbound `(setf ,aname))))))))                         (fmakunbound `(setf ,aname))))))))
1462             (%redefine-defstruct class old-layout layout)             (%redefine-defstruct class old-layout layout)
1463             (setq layout (class-layout class))))             (setq layout (%class-layout class))))
1464    
1465      (setf (find-class (dd-name info)) class)      (setf (find-class (dd-name info)) class)
1466    
1467      (unless (eq (dd-type info) 'funcallable-structure)      (unless (eq (dd-type info) 'funcallable-structure)
1468        (dolist (slot (dd-slots info))        (dolist (slot (dd-slots info))
1469          (unless (or (dsd-inherited-p info slot)          (unless (or (dsd-inherited-p info slot)
1470                      (not (eq (dsd-raw-type slot) 't)))                      (not (eq (dsd-raw-type slot) 't)))
1471            (let ((aname (dsd-accessor slot)))            (let* ((aname (dsd-accessor slot))
1472              (setf (symbol-function aname)                   (inherited (accessor-inherited-data aname info)))
1473                    (structure-slot-accessor layout slot))              (unless inherited
1474                  (setf (symbol-function aname)
1475              (unless (dsd-read-only slot)                      (structure-slot-accessor layout slot))
1476                (setf (fdefinition `(setf ,aname))                (unless (dsd-read-only slot)
1477                      (structure-slot-setter layout slot))))))                  (setf (fdefinition `(setf ,aname))
1478                          (structure-slot-setter layout slot)))))
1479    
1480              ))
1481    
1482        (when (dd-predicate info)        (when (dd-predicate info)
1483          (setf (symbol-function (dd-predicate info))          (setf (symbol-function (dd-predicate info))
1484                #'(lambda (object)                #'(lambda (object)
1485                    (declare (optimize (speed 3) (safety 0)))                    (declare (optimize (speed 3) (safety 0)))
1486                    (typep-to-layout object layout))))                    (typep-to-layout object layout t))))
1487    
1488        (when (dd-copier info)        (when (dd-copier info)
1489          (setf (symbol-function (dd-copier info))          (setf (symbol-function (dd-copier info))
# Line 1401  Line 1493 
1493                      (error 'simple-type-error                      (error 'simple-type-error
1494                             :datum structure                             :datum structure
1495                             :expected-type class                             :expected-type class
1496                             :format-control "Structure for copier is not a ~S:~% ~S"                             :format-control (intl:gettext "Structure for copier is not a ~S:~% ~S")
1497                             :format-arguments (list class structure)))                             :format-arguments (list class structure)))
1498                    (copy-structure structure))))))                    (copy-structure structure))))
1499    
1500          (when (boundp '*defstruct-hooks*)
1501            (dolist (fn *defstruct-hooks*)
1502              (funcall fn class)))))
1503    
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)))
# Line 1425  Line 1521 
1521                                      &optional compiler-layout)                                      &optional compiler-layout)
1522    (multiple-value-bind    (multiple-value-bind
1523        (class old-layout)        (class old-layout)
1524        (destructuring-bind (&optional name (class 'structure-class)        (destructuring-bind (&optional name (class 'kernel::structure-class)
1525                                       (constructor 'make-structure-class))                                       (constructor 'make-structure-class))
1526                            (dd-alternate-metaclass info)                            (dd-alternate-metaclass info)
1527          (declare (ignore name))          (declare (ignore name))
1528          (insured-find-class (dd-name info)          (insured-find-class (dd-name info)
1529                              (if (eq class 'structure-class)                              (if (eq class 'kernel::structure-class)
1530                                  #'(lambda (x) (typep x 'structure-class))                                  #'(lambda (x) (typep x 'kernel::structure-class))
1531                                  #'(lambda (x) (typep x (find-class class))))                                  #'(lambda (x) (typep x (find-class class))))
1532                              (fdefinition constructor)))                              (fdefinition constructor)))
1533      (setf (class-direct-superclasses class)      (setf (%class-direct-superclasses class)
1534            (if (eq (dd-name info) 'lisp-stream)            (if (eq (dd-name info) 'lisp-stream)
1535                ;; Hack to add stream as a superclass mixin to lisp-streams.                ;; Hack to add stream as a superclass mixin to lisp-streams.
1536                (list (layout-class (svref inherits (1- (length inherits))))                (list (layout-class (svref inherits (1- (length inherits))))
# Line 1468  Line 1564 
1564               (setf (layout-info old-layout) info)               (setf (layout-info old-layout) info)
1565               (values class old-layout nil))               (values class old-layout nil))
1566              (t              (t
1567               (warn "Shouldn't happen!  Some strange thing in LAYOUT-INFO:~               (warn (intl:gettext "Shouldn't happen!  Some strange thing in LAYOUT-INFO:~
1568                      ~%  ~S"                      ~%  ~S")
1569                     old-layout)                     old-layout)
1570               (values class new-layout old-layout)))))))))               (values class new-layout old-layout)))))))))
1571    
# Line 1507  Line 1603 
1603  ;;; different slots than in the currently loaded version.  ;;; different slots than in the currently loaded version.
1604  ;;;  ;;;
1605  (defun redefine-structure-warning (class old new)  (defun redefine-structure-warning (class old new)
1606    (declare (type defstruct-description old new) (type class class)    (declare (type defstruct-description old new)
1607               (type kernel::class class)
1608             (ignore class))             (ignore class))
1609    (let ((name (dd-name new)))    (let ((name (dd-name new)))
1610      (multiple-value-bind (moved retyped deleted)      (multiple-value-bind (moved retyped deleted)
1611                           (compare-slots old new)                           (compare-slots old new)
1612        (when (or moved retyped deleted)        (when (or moved retyped deleted)
1613          (warn          (warn
1614           "Incompatibly redefining slots of structure class ~S~@           (intl:gettext "Incompatibly redefining slots of structure class ~S~@
1615            Make sure any uses of affected accessors are recompiled:~@            Make sure any uses of affected accessors are recompiled:~@
1616            ~@[  These slots were moved to new positions:~%    ~S~%~]~            ~@[  These slots were moved to new positions:~%    ~S~%~]~
1617            ~@[  These slots have new incompatible types:~%    ~S~%~]~            ~@[  These slots have new incompatible types:~%    ~S~%~]~
1618            ~@[  These slots were deleted:~%    ~S~%~]"            ~@[  These slots were deleted:~%    ~S~%~]")
1619           name moved retyped deleted)           name moved retyped deleted)
1620          t))))          t))))
1621    
# Line 1529  Line 1626 
1626  ;;; Class to have the specified New-Layout.  We signal an error with some  ;;; Class to have the specified New-Layout.  We signal an error with some
1627  ;;; proceed options and return the layout that should be used.  ;;; 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)  (defun %redefine-defstruct (class old-layout new-layout)
1637    (declare (type class class) (type layout old-layout new-layout))    (declare (type class class) (type layout old-layout new-layout))
1638    (let ((name (class-proper-name class)))    (let ((name (class-proper-name class)))
1639      (restart-case      (restart-case
1640          (error "Redefining class ~S incompatibly with the current ~          (error (intl:gettext "Redefining class ~S incompatibly with the current ~
1641                  definition."                  definition.")
1642                 name)                 name)
1643        (continue ()        (continue ()
1644          :report "Invalidate current definition."          :report (lambda (stream)
1645          (warn "Previously loaded ~S accessors will no longer work." name)                    (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))          (register-layout new-layout))
1649        (clobber-it ()        (clobber-it ()
1650          :report "Smash current layout, preserving old code."          :report (lambda (stream)
1651          (warn "Any old ~S instances will be in a bad way.~@                    (write-string "Assume redefinition is compatible, allow old code and instances."
1652                 I hope you know what you're doing..."                                  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)                name)
1656          (register-layout new-layout :invalidate nil          (register-layout new-layout :invalidate nil
1657                           :destruct-layout old-layout))))                           :destruct-layout old-layout))))
# Line 1557  Line 1665 
1665  ;;; type info, and undefining all the associated functions.  ;;; type info, and undefining all the associated functions.
1666  ;;;  ;;;
1667  (defun undefine-structure (class)  (defun undefine-structure (class)
1668    (let ((info (layout-info (class-layout class))))    (let ((info (layout-info (%class-layout class))))
1669      (when (defstruct-description-p info)      (when (defstruct-description-p info)
1670        (let ((type (dd-name info)))        (let ((type (dd-name info)))
1671          (setf (info type compiler-layout type) nil)          (setf (info type compiler-layout type) nil)
# Line 1566  Line 1674 
1674          (dolist (slot (dd-slots info))          (dolist (slot (dd-slots info))
1675            (unless (dsd-inherited-p info slot)            (unless (dsd-inherited-p info slot)
1676              (let ((aname (dsd-accessor slot)))              (let ((aname (dsd-accessor slot)))
1677                (undefine-function-name aname)                (unless (accessor-inherited-data aname info)
1678                (unless (dsd-read-only slot)                  (undefine-function-name aname)
1679                  (undefine-function-name `(setf ,aname)))))))                  (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        ;; Clear out the SPECIFIER-TYPE cache so that subsequent references are
1685        ;; unknown types.        ;; unknown types.
# Line 1609  Line 1720 
1720           (super           (super
1721            (if include            (if include
1722                (compiler-layout-or-lose (first include))                (compiler-layout-or-lose (first include))
1723                (class-layout (find-class (or (first superclass-opt)                (%class-layout (find-class (or (first superclass-opt)
1724                                              'structure-object))))))                                              'structure-object))))))
1725      (if (eq (dd-name info) 'lisp-stream)      (if (eq (dd-name info) 'lisp-stream)
1726          ;; Hack to added the stream class as a mixin for lisp-streams.          ;; Hack to add the stream class as a mixin for lisp-streams.
1727          (concatenate 'simple-vector (layout-inherits super)          (concatenate 'simple-vector (layout-inherits super)
1728                       (vector super (class-layout (find-class 'stream))))                       (vector super (%class-layout (find-class 'stream))))
1729          (concatenate 'simple-vector (layout-inherits super) (vector super)))))          (concatenate 'simple-vector (layout-inherits super) (vector super)))))
1730    
1731  ;;; %COMPILER-ONLY-DEFSTRUCT  --  Internal  ;;; %COMPILER-ONLY-DEFSTRUCT  --  Internal
# Line 1642  Line 1753 
1753      (cond      (cond
1754       (old-layout       (old-layout
1755        (undefine-structure (layout-class old-layout))        (undefine-structure (layout-class old-layout))
1756        (when (and (class-subclasses class)        (when (and (%class-subclasses class)
1757                   (not (eq layout old-layout)))                   (not (eq layout old-layout)))
1758          (collect ((subs))          (collect ((subs))
1759            (do-hash (class layout (class-subclasses class))            (do-hash (class layout (%class-subclasses class))
1760              (declare (ignore layout))              (declare (ignore layout))
1761              (undefine-structure class)              (undefine-structure class)
1762              (subs (class-proper-name class)))              (subs (class-proper-name class)))
1763            (when (subs)            (when (subs)
1764              (warn "Removing old subclasses of ~S:~%  ~S"              (warn (intl:gettext "Removing old subclasses of ~S:~%  ~S")
1765                    (class-name class) (subs))))))                    (%class-name class) (subs))))))
1766       (t       (t
1767        (unless (eq (class-layout class) layout)        (unless (eq (%class-layout class) layout)
1768          (register-layout layout :invalidate nil))          (register-layout layout :invalidate nil))
1769        (setf (find-class (dd-name info)) class)))        (setf (find-class (dd-name info)) class)))
1770    
# Line 1687  Line 1798 
1798    
1799      (dolist (slot (dd-slots info))      (dolist (slot (dd-slots info))
1800        (let* ((aname (dsd-accessor slot))        (let* ((aname (dsd-accessor slot))
1801               (setf-fun `(setf ,aname)))               (setf-fun `(setf ,aname))
1802          (unless (or (dsd-inherited-p info slot)               (inherited (and aname (accessor-inherited-data aname info))))
1803                      (not (eq (dsd-raw-type slot) 't)))  
1804            (define-defstruct-name aname)          (cond (inherited
1805            (setf (info function accessor-for aname) class)                 (unless (= (cdr inherited) (dsd-index slot))
1806            (unless (dsd-read-only slot)                   (warn 'simple-style-warning
1807              (define-defstruct-name setf-fun)                         :format-control
1808              (setf (info function accessor-for setf-fun) class))))))                         (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))    (undefined-value))
1824    
# Line 1713  Line 1837 
1837           (layout (%instance-layout structure)))           (layout (%instance-layout structure)))
1838      (declare (type index len))      (declare (type index len))
1839      (when (layout-invalid layout)      (when (layout-invalid layout)
1840        (error "Copying an obsolete structure:~%  ~S" structure))        (error (intl:gettext "Copying an obsolete structure:~%  ~S") structure))
1841    
1842      (dotimes (i len)      (dotimes (i len)
1843        (declare (type index i))        (declare (type index i))
# Line 1741  Line 1865 
1865        (print-unreadable-object (structure stream :identity t :type t)        (print-unreadable-object (structure stream :identity t :type t)
1866          (write-string "Funcallable Structure" stream))          (write-string "Funcallable Structure" stream))
1867        (let* ((type (%instance-layout structure))        (let* ((type (%instance-layout structure))
1868               (name (class-name (layout-class type)))               (name (%class-name (layout-class type)))
1869               (dd (layout-info type)))               (dd (layout-info type)))
1870          (if *print-pretty*          (cond
1871              (pprint-logical-block (stream nil :prefix "#S(" :suffix ")")            ((and (null (dd-slots dd)) *print-level* (>= *current-level* *print-level*))
1872                (prin1 name stream)             ;; The CLHS entry for *PRINT-LENGTH* says "If an object to
1873                (let ((slots (dd-slots dd)))             ;; be recursively printed has components and is at a level
1874                  (when slots             ;; equal to or greater than the value of *print-level*,
1875                    (write-char #\space stream)             ;; then the object is printed as ``#''."
1876                    (pprint-indent :block 2 stream)             ;;
1877                    (pprint-newline :linear stream)             ;; So, if it has no components, and we're at *PRINT-LEVEL*,
1878                    (loop             ;; we print out #S(<name>).
1879               (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)                      (pprint-pop)
1892                      (let ((slot (pop slots)))                      (let ((slot (pop slots)))
1893                        (write-char #\: stream)                        (write-char #\: stream)
# Line 1764  Line 1900 
1900                        (when (null slots)                        (when (null slots)
1901                          (return))                          (return))
1902                        (write-char #\space stream)                        (write-char #\space stream)
1903                        (pprint-newline :linear stream))))))                        (pprint-newline :linear stream)))))))
1904              (descend-into (stream)            (t
1905                (write-string "#S(" stream)             (descend-into (stream)
1906                (prin1 name stream)               (write-string "#S(" stream)
1907                (do ((index 0 (1+ index))               (prin1 name stream)
1908                     (slots (dd-slots dd) (cdr slots)))               (do ((index 0 (1+ index))
1909                    ((or (null slots)                    (slots (dd-slots dd) (cdr slots)))
1910                         (and (not *print-readably*) (eql *print-length* index)))                   ((or (null slots)
1911                     (if (null slots)                        (and (not *print-readably*) (eql *print-length* index)))
1912                         (write-string ")" stream)                    (if (null slots)
1913                         (write-string " ...)" stream)))                        (write-string ")" stream)
1914                  (declare (type index index))                        (write-string " ...)" stream)))
1915                  (write-char #\space stream)                 (declare (type index index))
1916                  (write-char #\: stream)                 (write-char #\space stream)
1917                  (let ((slot (first slots)))                 (write-char #\: stream)
1918                    (output-symbol-name (dsd-%name slot) stream)                 (let ((slot (first slots)))
1919                    (write-char #\space stream)                   (output-symbol-name (dsd-%name slot) stream)
1920                    (output-object (funcall (fdefinition (dsd-accessor slot))                   (write-char #\space stream)
1921                                            structure)                   (output-object (funcall (fdefinition (dsd-accessor slot))
1922                                   stream))))))))                                           structure)
1923                                    stream)))))))))
1924    
1925  (defun make-structure-load-form (structure)  (defun make-structure-load-form (structure)
1926    (declare (type structure-object structure))    (declare (type structure-object structure))
# Line 1793  Line 1930 
1930        ((member :just-dump-it-normally :ignore-it)        ((member :just-dump-it-normally :ignore-it)
1931         fun)         fun)
1932        (null        (null
1933         (error "Structures of type ~S cannot be dumped as constants."         (error (intl:gettext "Structures of type ~S cannot be dumped as constants.")
1934                (class-name class)))                (%class-name class)))
1935        (function        (function
1936         (funcall fun structure))         (funcall fun structure))
1937        (symbol        (symbol

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

  ViewVC Help
Powered by ViewVC 1.1.5