/[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.67 by pw, Mon Sep 20 11:12:59 1999 UTC revision 1.68 by dtc, Wed Sep 22 15:07:49 1999 UTC
# Line 272  Line 272 
272    ;; its position in the implementation sequence    ;; its position in the implementation sequence
273    (index (required-argument) :type fixnum)    (index (required-argument) :type fixnum)
274    ;;    ;;
275    ;; Name of accesor, or NIL if this accessor has the same name as an inherited    ;; Name of accessor.
   ;; accessor (which we don't want to shadow.)  
276    (accessor nil)    (accessor nil)
277    default                       ; default value expression    default                       ; default value expression
278    (type t)                      ; declared type specifier    (type t)                      ; declared type specifier
# Line 318  Line 317 
317  ;;;  ;;;
318  (defun dsd-name (dsd)  (defun dsd-name (dsd)
319    (intern (string (dsd-%name dsd))    (intern (string (dsd-%name dsd))
320            (if (dsd-accessor dsd)            (symbol-package (dsd-accessor dsd))))
               (symbol-package (dsd-accessor dsd))  
               *package*)))  
321    
322  (defun print-defstruct-slot-description (structure stream depth)  (defun print-defstruct-slot-description (structure stream depth)
323    (declare (ignore depth))    (declare (ignore depth))
# Line 533  Line 530 
530  ;;;  ;;;
531  ;;;    Parse a slot description for DEFSTRUCT, add it to the description and  ;;;    Parse a slot description for DEFSTRUCT, add it to the description and
532  ;;; return it.  If supplied, ISLOT is a pre-initialized DSD that we modify to  ;;; return it.  If supplied, ISLOT is a pre-initialized DSD that we modify to
533  ;;; get the new slot.  This is supplied when handling included slots.  If the  ;;; get the new slot.  This is supplied when handling included slots.
 ;;; new accessor name is already an accessor for same slot in some included  
 ;;; structure, then set the DSD-ACCESSOR to NIL so that we don't clobber the  
 ;;; more general accessor.  
534  ;;;  ;;;
535  (defun parse-1-dsd (defstruct spec &optional  (defun parse-1-dsd (defstruct spec &optional
536                       (islot (make-defstruct-slot-description                       (islot (make-defstruct-slot-description
# Line 562  Line 556 
556      (setf (dsd-%name islot) (string name))      (setf (dsd-%name islot) (string name))
557      (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot)))      (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot)))
558    
559      (let* ((aname (concat-pnames (dd-conc-name defstruct) name))      (setf (dsd-accessor islot) (concat-pnames (dd-conc-name defstruct) name))
560             (existing (info function accessor-for aname)))  
       (if (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))  
                         name))  
           (setf (dsd-accessor islot) nil)  
           (setf (dsd-accessor islot) aname)))  
   
561      (when default-p      (when default-p
562        (setf (dsd-default islot) default))        (setf (dsd-default islot) default))
563      (when type-p      (when type-p
# Line 1019  Line 1002 
1002                     (%instance-ref object ,(dd-raw-index defstruct))))))))                     (%instance-ref object ,(dd-raw-index defstruct))))))))
1003    
1004    
1005    ;;; dsd-inherited-p  --  Internal
1006    ;;;
1007    ;;; True when the defstruct slot has been inherited from an included
1008    ;;; structure.
1009    ;;;
1010    (defun dsd-inherited-p (defstruct slot)
1011      (let* ((aname (dsd-accessor slot))
1012             (existing (info function accessor-for aname)))
1013        (and (structure-class-p existing)
1014             (not (eq (class-name existing) (dd-name defstruct)))
1015             (string= (dsd-%name (find aname
1016                                       (dd-slots
1017                                        (layout-info (class-layout existing)))
1018                                       :key #'dsd-accessor))
1019                      (dsd-%name slot)))))
1020    
1021    
1022  ;;; DEFINE-RAW-ACCESSORS  --  Internal  ;;; DEFINE-RAW-ACCESSORS  --  Internal
1023  ;;;  ;;;
1024  ;;;    Define readers and writers for raw slots as inline functions.  We use  ;;;    Define readers and writers for raw slots as inline functions.  We use
# Line 1032  Line 1032 
1032          (let ((stype (dsd-type slot))          (let ((stype (dsd-type slot))
1033                (aname (dsd-accessor slot)))                (aname (dsd-accessor slot)))
1034            (multiple-value-bind (accessor offset data)            (multiple-value-bind (accessor offset data)
1035                                 (slot-accessor-form defstruct slot)                (slot-accessor-form defstruct slot)
1036              (when (and aname (not (eq accessor '%instance-ref)))              (unless (or (dsd-inherited-p defstruct slot)
1037                            (eq accessor '%instance-ref))
1038                (res `(declaim (inline ,aname)))                (res `(declaim (inline ,aname)))
1039                (res `(declaim (ftype (function (,name) ,stype) ,aname)))                (res `(declaim (ftype (function (,name) ,stype) ,aname)))
1040                (res                (res `(defun ,aname (object)
1041                 `(defun ,aname (object)                        (truly-the ,stype (,accessor ,data ,offset))))
                   (truly-the ,stype (,accessor ,data ,offset))))  
1042                (unless (dsd-read-only slot)                (unless (dsd-read-only slot)
1043                  (res `(declaim (inline (setf ,aname))))                  (res `(declaim (inline (setf ,aname))))
1044                  (res `(declaim (ftype (function (,stype ,name) ,stype)                  (res `(declaim (ftype (function (,stype ,name) ,stype)
# Line 1080  Line 1080 
1080    (collect ((stuff))    (collect ((stuff))
1081      (let ((ltype (dd-lisp-type defstruct)))      (let ((ltype (dd-lisp-type defstruct)))
1082        (dolist (slot (dd-slots defstruct))        (dolist (slot (dd-slots defstruct))
1083          (let ((name (dsd-accessor slot))          (let ((aname (dsd-accessor slot))
1084                (index (dsd-index slot))                (index (dsd-index slot))
1085                (slot-type `(and ,(dsd-type slot)                (slot-type `(and ,(dsd-type slot)
1086                                 ,(dd-element-type defstruct))))                                 ,(dd-element-type defstruct))))
1087            (stuff `(proclaim '(inline ,name (setf ,name))))            (stuff `(proclaim '(inline ,aname (setf ,aname))))
1088            (stuff `(defun ,name (structure)            (stuff `(defun ,aname (structure)
1089                      (declare (type ,ltype structure))                      (declare (type ,ltype structure))
1090                      (the ,slot-type (elt structure ,index))))                      (the ,slot-type (elt structure ,index))))
1091            (unless (dsd-read-only slot)            (unless (dsd-read-only slot)
1092              (stuff              (stuff
1093               `(defun (setf ,name) (new-value structure)               `(defun (setf ,aname) (new-value structure)
1094                  (declare (type ,ltype structure) (type ,slot-type new-value))                  (declare (type ,ltype structure) (type ,slot-type new-value))
1095                  (setf (elt structure ,index) new-value)))))))                  (setf (elt structure ,index) new-value)))))))
1096      (stuff)))      (stuff)))
# Line 1123  Line 1123 
1123  ;;;  ;;;
1124  ;;;    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
1125  ;;; 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
1126  ;;; speed, since there can be thousands of defined slot accesors.  ;;; speed, since there can be thousands of defined slot accessors.
1127  ;;;  ;;;
1128  ;;;    What we do is defined the accessors and copier as closures over  ;;;    What we do is defined the accessors and copier as closures over
1129  ;;; general-case code.  Since the compiler will normally open-code accesors,  ;;; general-case code.  Since the compiler will normally open-code accessors,
1130  ;;; the (minor) efficiency penalty is not a concern.  ;;; the (minor) efficiency penalty is not a concern.
1131    
1132  ;;; Typep-To-Layout  --  Internal  ;;; Typep-To-Layout  --  Internal
# Line 1245  Line 1245 
1245             (let ((old-info (layout-info old-layout)))             (let ((old-info (layout-info old-layout)))
1246               (when (defstruct-description-p old-info)               (when (defstruct-description-p old-info)
1247                 (dolist (slot (dd-slots old-info))                 (dolist (slot (dd-slots old-info))
1248                   (fmakunbound (dsd-accessor slot))                   (unless (dsd-inherited-p old-info slot)
1249                   (unless (dsd-read-only slot)                     (let ((aname (dsd-accessor slot)))
1250                     (fmakunbound `(setf ,(dsd-accessor slot)))))))                       (fmakunbound aname)
1251                         (unless (dsd-read-only slot)
1252                           (fmakunbound `(setf ,aname slot))))))))
1253             (%redefine-defstruct class old-layout layout)             (%redefine-defstruct class old-layout layout)
1254             (setq layout (class-layout class))))             (setq layout (class-layout class))))
1255    
# Line 1255  Line 1257 
1257    
1258      (unless (eq (dd-type info) 'funcallable-structure)      (unless (eq (dd-type info) 'funcallable-structure)
1259        (dolist (slot (dd-slots info))        (dolist (slot (dd-slots info))
1260          (let ((dsd slot))          (unless (or (dsd-inherited-p info slot)
1261            (when (and (dsd-accessor slot)                      (not (eq (dsd-raw-type slot) 't)))
1262                       (eq (dsd-raw-type slot) 't))            (let ((aname (dsd-accessor slot)))
1263              (setf (symbol-function (dsd-accessor slot))              (setf (symbol-function aname)
1264                    (structure-slot-accessor layout dsd))                    (structure-slot-accessor layout slot))
1265    
1266              (unless (dsd-read-only slot)              (unless (dsd-read-only slot)
1267                (setf (fdefinition `(setf ,(dsd-accessor slot)))                (setf (fdefinition `(setf ,aname))
1268                      (structure-slot-setter layout dsd))))))                      (structure-slot-setter layout slot))))))
1269    
1270        (when (dd-predicate info)        (when (dd-predicate info)
1271          (setf (symbol-function (dd-predicate info))          (setf (symbol-function (dd-predicate info))
1272                #'(lambda (object)                #'(lambda (object)
1273                    (declare (optimize (speed 3) (safety 0)))                    (declare (optimize (speed 3) (safety 0)))
1274                    (typep-to-layout object layout))))                    (typep-to-layout object layout))))
1275    
1276        (when (dd-copier info)        (when (dd-copier info)
1277          (setf (symbol-function (dd-copier info))          (setf (symbol-function (dd-copier info))
1278                #'(lambda (structure)                #'(lambda (structure)
# Line 1442  Line 1444 
1444          (undefine-function-name (dd-copier info))          (undefine-function-name (dd-copier info))
1445          (undefine-function-name (dd-predicate info))          (undefine-function-name (dd-predicate info))
1446          (dolist (slot (dd-slots info))          (dolist (slot (dd-slots info))
1447            (let ((fun (dsd-accessor slot)))            (unless (dsd-inherited-p info slot)
1448              (undefine-function-name fun)              (let ((aname (dsd-accessor slot)))
1449              (unless (dsd-read-only slot)                (undefine-function-name aname)
1450                (undefine-function-name `(setf ,fun))))))                (unless (dsd-read-only slot)
1451                    (undefine-function-name `(setf ,aname)))))))
1452        ;;        ;;
1453        ;; Clear out the SPECIFIER-TYPE cache so that subsequent references are        ;; Clear out the SPECIFIER-TYPE cache so that subsequent references are
1454        ;; unknown types.        ;; unknown types.
# Line 1563  Line 1566 
1566                `(lambda (x) (typep x ',name)))))                `(lambda (x) (typep x ',name)))))
1567    
1568      (dolist (slot (dd-slots info))      (dolist (slot (dd-slots info))
1569        (let* ((fun (dsd-accessor slot))        (let* ((aname (dsd-accessor slot))
1570               (setf-fun `(setf ,fun)))               (setf-fun `(setf ,aname)))
1571          (when (and fun (eq (dsd-raw-type slot) 't))          (unless (or (dsd-inherited-p info slot)
1572            (define-defstruct-name fun)                      (not (eq (dsd-raw-type slot) 't)))
1573            (setf (info function accessor-for fun) class)            (define-defstruct-name aname)
1574              (setf (info function accessor-for aname) class)
1575            (unless (dsd-read-only slot)            (unless (dsd-read-only slot)
1576              (define-defstruct-name setf-fun)              (define-defstruct-name setf-fun)
1577              (setf (info function accessor-for setf-fun) class))))))              (setf (info function accessor-for setf-fun) class))))))
# Line 1619  Line 1623 
1623        (let* ((type (%instance-layout structure))        (let* ((type (%instance-layout structure))
1624               (name (class-name (layout-class type)))               (name (class-name (layout-class type)))
1625               (dd (layout-info type)))               (dd (layout-info type)))
1626          (flet ((slot-accessor (slot)          (if *print-pretty*
1627                   (let ((aname              (pprint-logical-block (stream nil :prefix "#S(" :suffix ")")
1628                          (intern (concatenate                (prin1 name stream)
1629                                   'simple-string                (let ((slots (dd-slots dd)))
1630                                   (symbol-name (kernel::dd-conc-name dd))                  (when slots
1631                                   (dsd-%name slot)))))                    (write-char #\space stream)
1632                     (fdefinition aname))))                    (pprint-indent :block 2 stream)
1633            (if *print-pretty*                    (pprint-newline :linear stream)
1634                (pprint-logical-block (stream nil :prefix "#S(" :suffix ")")                    (loop
1635                  (prin1 name stream)                      (pprint-pop)
1636                  (let ((slots (dd-slots dd)))                      (let ((slot (pop slots)))
1637                    (when slots                        (write-char #\: stream)
1638                      (write-char #\space stream)                        (output-symbol-name (dsd-%name slot) stream)
1639                      (pprint-indent :block 2 stream)                        (write-char #\space stream)
1640                      (pprint-newline :linear stream)                        (pprint-newline :miser stream)
1641                      (loop                        (output-object (funcall (fdefinition (dsd-accessor slot))
1642                        (pprint-pop)                                                structure)
1643                        (let ((slot (pop slots)))                                       stream)
1644                          (write-char #\: stream)                        (when (null slots)
1645                          (output-symbol-name (dsd-%name slot) stream)                          (return))
1646                          (write-char #\space stream)                        (write-char #\space stream)
1647                          (pprint-newline :miser stream)                        (pprint-newline :linear stream))))))
1648                          (output-object              (descend-into (stream)
1649                           (funcall (slot-accessor slot) structure) stream)                (write-string "#S(" stream)
1650                          (when (null slots)                (prin1 name stream)
1651                            (return))                (do ((index 0 (1+ index))
1652                          (write-char #\space stream)                     (slots (dd-slots dd) (cdr slots)))
1653                          (pprint-newline :linear stream))))))                    ((or (null slots)
1654                (descend-into (stream)                         (and (not *print-readably*) (eql *print-length* index)))
1655                  (write-string "#S(" stream)                     (if (null slots)
1656                  (prin1 name stream)                         (write-string ")" stream)
1657                  (do ((index 0 (1+ index))                         (write-string " ...)" stream)))
1658                       (slots (dd-slots dd) (cdr slots)))                  (declare (type index index))
1659                      ((or (null slots)                  (write-char #\space stream)
1660                           (and (not *print-readably*)(eql *print-length* index)))                  (write-char #\: stream)
1661                       (if (null slots)                  (let ((slot (first slots)))
1662                           (write-string ")" stream)                    (output-symbol-name (dsd-%name slot) stream)
                          (write-string " ...)" stream)))  
                   (declare (type index index))  
1663                    (write-char #\space stream)                    (write-char #\space stream)
1664                    (write-char #\: stream)                    (output-object (funcall (fdefinition (dsd-accessor slot))
1665                    (let ((slot (first slots)))                                            structure)
1666                      (output-symbol-name (dsd-%name slot) stream)                                   stream))))))))
                     (write-char #\space stream)  
                     (output-object  
                      (funcall (slot-accessor slot) structure) stream)))))))))  
1667    
1668  (defun make-structure-load-form (structure)  (defun make-structure-load-form (structure)
1669    (declare (type structure-object structure))    (declare (type structure-object structure))

Legend:
Removed from v.1.67  
changed lines
  Added in v.1.68

  ViewVC Help
Powered by ViewVC 1.1.5