/[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.66 by dtc, Sat Dec 19 15:56:19 1998 UTC revision 1.67 by pw, Mon Sep 20 11:12:59 1999 UTC
# Line 1619  Line 1619 
1619        (let* ((type (%instance-layout structure))        (let* ((type (%instance-layout structure))
1620               (name (class-name (layout-class type)))               (name (class-name (layout-class type)))
1621               (dd (layout-info type)))               (dd (layout-info type)))
1622          (if *print-pretty*          (flet ((slot-accessor (slot)
1623              (pprint-logical-block (stream nil :prefix "#S(" :suffix ")")                   (let ((aname
1624                (prin1 name stream)                          (intern (concatenate
1625                (let ((slots (dd-slots dd)))                                   'simple-string
1626                  (when slots                                   (symbol-name (kernel::dd-conc-name dd))
1627                                     (dsd-%name slot)))))
1628                       (fdefinition aname))))
1629              (if *print-pretty*
1630                  (pprint-logical-block (stream nil :prefix "#S(" :suffix ")")
1631                    (prin1 name stream)
1632                    (let ((slots (dd-slots dd)))
1633                      (when slots
1634                        (write-char #\space stream)
1635                        (pprint-indent :block 2 stream)
1636                        (pprint-newline :linear stream)
1637                        (loop
1638                          (pprint-pop)
1639                          (let ((slot (pop slots)))
1640                            (write-char #\: stream)
1641                            (output-symbol-name (dsd-%name slot) stream)
1642                            (write-char #\space stream)
1643                            (pprint-newline :miser stream)
1644                            (output-object
1645                             (funcall (slot-accessor slot) structure) stream)
1646                            (when (null slots)
1647                              (return))
1648                            (write-char #\space stream)
1649                            (pprint-newline :linear stream))))))
1650                  (descend-into (stream)
1651                    (write-string "#S(" stream)
1652                    (prin1 name stream)
1653                    (do ((index 0 (1+ index))
1654                         (slots (dd-slots dd) (cdr slots)))
1655                        ((or (null slots)
1656                             (and (not *print-readably*)(eql *print-length* index)))
1657                         (if (null slots)
1658                             (write-string ")" stream)
1659                             (write-string " ...)" stream)))
1660                      (declare (type index index))
1661                    (write-char #\space stream)                    (write-char #\space stream)
1662                    (pprint-indent :block 2 stream)                    (write-char #\: stream)
1663                    (pprint-newline :linear stream)                    (let ((slot (first slots)))
1664                    (loop                      (output-symbol-name (dsd-%name slot) stream)
1665                      (pprint-pop)                      (write-char #\space stream)
1666                      (let ((slot (pop slots)))                      (output-object
1667                        (write-char #\: stream)                       (funcall (slot-accessor slot) structure) stream)))))))))
                       (output-symbol-name (dsd-%name slot) stream)  
                       (write-char #\space stream)  
                       (pprint-newline :miser stream)  
                       (output-object (funcall (fdefinition (dsd-accessor slot))  
                                               structure)  
                                      stream)  
                       (when (null slots)  
                         (return))  
                       (write-char #\space stream)  
                       (pprint-newline :linear stream))))))  
             (descend-into (stream)  
               (write-string "#S(" stream)  
               (prin1 name stream)  
               (do ((index 0 (1+ index))  
                    (slots (dd-slots dd) (cdr slots)))  
                   ((or (null slots)  
                        (and (not *print-readably*) (eql *print-length* index)))  
                    (if (null slots)  
                        (write-string ")" stream)  
                        (write-string " ...)" stream)))  
                 (declare (type index index))  
                 (write-char #\space stream)  
                 (write-char #\: stream)  
                 (let ((slot (first slots)))  
                   (output-symbol-name (dsd-%name slot) stream)  
                   (write-char #\space stream)  
                   (output-object (funcall (fdefinition (dsd-accessor slot))  
                                           structure)  
                                  stream))))))))  
1668    
1669  (defun make-structure-load-form (structure)  (defun make-structure-load-form (structure)
1670    (declare (type structure-object structure))    (declare (type structure-object structure))

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

  ViewVC Help
Powered by ViewVC 1.1.5