/[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.95.2.1 by rtoy, Mon Dec 19 01:09:49 2005 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 262  Line 265 
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    ;; a list of (NAME . INDEX) pairs for accessors of included structures
270     (inherited-accessor-alist () :type list))    (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))
# Line 319  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    
330  (defun dd-maybe-make-print-method (defstruct)  (defun dd-maybe-make-print-method (defstruct)
# Line 455  Line 458 
458        (restart-case        (restart-case
459            (error 'lisp::package-locked-error            (error 'lisp::package-locked-error
460                   :package pkg                   :package pkg
461                   :format-control "defining structure ~A"                   :format-control (intl:gettext "defining structure ~A")
462                   :format-arguments (list name))                   :format-arguments (list name))
463          (continue ()          (continue ()
464            :report "Ignore the lock and continue")            :report (lambda (stream)
465                        (write-string (intl:gettext "Ignore the lock and continue") stream)))
466          (unlock-package ()          (unlock-package ()
467            :report "Disable package's definition lock then continue"            :report (lambda (stream)
468                        (write-string (intl:gettext "Disable package's definition lock then continue") stream))
469            (setf (ext:package-definition-lock pkg) nil))            (setf (ext:package-definition-lock pkg) nil))
470          (unlock-all ()          (unlock-all ()
471            :report "Unlock all packages, then continue"            :report (lambda (stream)
472                        (write-string (intl:gettext "Unlock all packages, then continue") stream))
473            (lisp::unlock-all-packages))))            (lisp::unlock-all-packages))))
474      (when (info declaration recognized name)      (when (info declaration recognized name)
475        (error "Defstruct already names a declaration: ~S." name))        (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 481  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 489  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 524  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 547  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 559  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 587  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 607  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 619  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 638  Line 646 
646                                  :conc-name))                                  :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 682  Line 690 
690                 (values name default default-p type type-p read-only ro-p)))                 (values name default default-p type type-p read-only ro-p)))
691              (t              (t
692               (when (keywordp spec)               (when (keywordp spec)
693                 (warn "Keyword slot name indicates probable syntax ~                 (warn (intl:gettext "Keyword slot name indicates probable syntax ~
694                        error in DEFSTRUCT -- ~S."                        error in DEFSTRUCT -- ~S.")
695                       spec))                       spec))
696               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) 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)))
# Line 704  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 774  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 824  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 865  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 878  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 895  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 904  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 929  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 970  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 983  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 1050  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 1085  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 1098  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 1111  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 1214  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 1246  Line 1267 
1267                  ((not (= (cdr inherited) index))                  ((not (= (cdr inherited) index))
1268                   (warn 'simple-style-warning                   (warn 'simple-style-warning
1269                         :format-control                         :format-control
1270                         "~@<Non-overwritten accessor ~S does not access ~                         (intl:gettext "~@<Non-overwritten accessor ~S does not access ~
1271                          slot with name ~S (accessing an inherited slot ~                          slot with name ~S (accessing an inherited slot ~
1272                          instead).~:@>"                          instead).~:@>")
1273                         :format-arguments (list aname (dsd-%name slot))))))                         :format-arguments (list aname (dsd-%name slot))))))
1274          ))          ))
1275      (stuff)))      (stuff)))
# Line 1281  Line 1302 
1302                       (eq (aref object ,index) ',name)))))))))                       (eq (aref object ,index) ',name)))))))))
1303    
1304  ;; A predicate to determine if the given list is a defstruct object of  ;; 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)  ;; :type list.  This used to be done using (eq (nth index object) name),
1306  ;; name), but that fails if the (nth index object) doesn't work  ;; but that fails if the (nth index object) doesn't work because object
1307  ;; because object is not a proper list.  ;; is not a proper list.
1308  (defun defstruct-list-p (index list name)  (defun defstruct-list-p (index list name)
1309    ;; Basically do (nth index list), but don't crash if the list is not    ;; Basically do (nth index list), but don't crash if the list is not
1310    ;; a proper list.    ;; a proper list.
# Line 1300  Line 1321 
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 1318  Line 1339 
1339  (defun typep-to-layout (obj layout &optional no-error)  (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)))
# Line 1350  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)))
# Line 1361  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 1375  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)))
# Line 1383  Line 1404 
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 1394  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)))
# Line 1402  Line 1423 
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)))
# Line 1472  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    
# Line 1543  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 1590  Line 1611 
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 1616  Line 1637 
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 already loaded code and instances, use new 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 "Assume redefinition is compatible, allow old code and instances."          :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 1698  Line 1723 
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)))))
# Line 1736  Line 1761 
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)
# Line 1780  Line 1805 
1805                 (unless (= (cdr inherited) (dsd-index slot))                 (unless (= (cdr inherited) (dsd-index slot))
1806                   (warn 'simple-style-warning                   (warn 'simple-style-warning
1807                         :format-control                         :format-control
1808                         "~@<Non-overwritten accessor ~S does not access ~                         (intl:gettext "~@<Non-overwritten accessor ~S does not access ~
1809                          slot with name ~S (accessing an inherited slot ~                          slot with name ~S (accessing an inherited slot ~
1810                          instead).~:@>"                          instead).~:@>")
1811                         :format-arguments (list aname (dsd-%name slot)))))                         :format-arguments (list aname (dsd-%name slot)))))
1812                (t                (t
1813                 (unless (or (dsd-inherited-p info slot)                 (unless (or (dsd-inherited-p info slot)
# Line 1812  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 1850  Line 1875 
1875             ;; then the object is printed as ``#''."             ;; then the object is printed as ``#''."
1876             ;;             ;;
1877             ;; So, if it has no components, and we're at *PRINT-LEVEL*,             ;; So, if it has no components, and we're at *PRINT-LEVEL*,
1878             ;; we print out #(S<name>).             ;; we print out #S(<name>).
1879             (write-string "#S(" stream)             (write-string "#S(" stream)
1880             (prin1 name stream)             (prin1 name stream)
1881             (write-char #\) stream))             (write-char #\) stream))
# Line 1905  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))

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

  ViewVC Help
Powered by ViewVC 1.1.5