/[slime]/slime/swank-scl.lisp
ViewVC logotype

Diff of /slime/swank-scl.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.16 by heller, Sat Feb 9 18:39:02 2008 UTC revision 1.17 by heller, Sat Feb 9 18:47:05 2008 UTC
# Line 1742  The `symbol-value' of each element is a Line 1742  The `symbol-value' of each element is a
1742    
1743  (defmethod emacs-inspect ((o t))  (defmethod emacs-inspect ((o t))
1744    (cond ((di::indirect-value-cell-p o)    (cond ((di::indirect-value-cell-p o)
1745           (values (format nil "~A is a value cell." o)                   `("Value: " (:value ,(c:value-cell-ref o))))
                  `("Value: " (:value ,(c:value-cell-ref o)))))  
1746          ((alien::alien-value-p o)          ((alien::alien-value-p o)
1747           (inspect-alien-value o))           (inspect-alien-value o))
1748          (t          (t
# Line 1752  The `symbol-value' of each element is a Line 1751  The `symbol-value' of each element is a
1751  (defun scl-inspect (o)  (defun scl-inspect (o)
1752    (destructuring-bind (text labeledp . parts)    (destructuring-bind (text labeledp . parts)
1753        (inspect::describe-parts o)        (inspect::describe-parts o)
1754      (values (format nil "~A~%" text)      (list*  (format nil "~A~%" text)
1755              (if labeledp              (if labeledp
1756                  (loop for (label . value) in parts                  (loop for (label . value) in parts
1757                        append (label-value-line label value))                        append (label-value-line label value))
# Line 1762  The `symbol-value' of each element is a Line 1761  The `symbol-value' of each element is a
1761  (defmethod emacs-inspect ((o function))  (defmethod emacs-inspect ((o function))
1762    (let ((header (kernel:get-type o)))    (let ((header (kernel:get-type o)))
1763      (cond ((= header vm:function-header-type)      (cond ((= header vm:function-header-type)
1764             (values (format nil "~A is a function." o)             (list*  (format nil "~A is a function.~%" o)
1765                     (append (label-value-line*                     (append (label-value-line*
1766                              ("Self" (kernel:%function-self o))                              ("Self" (kernel:%function-self o))
1767                              ("Next" (kernel:%function-next o))                              ("Next" (kernel:%function-next o))
# Line 1774  The `symbol-value' of each element is a Line 1773  The `symbol-value' of each element is a
1773                              (with-output-to-string (s)                              (with-output-to-string (s)
1774                                (disassem:disassemble-function o :stream s))))))                                (disassem:disassemble-function o :stream s))))))
1775            ((= header vm:closure-header-type)            ((= header vm:closure-header-type)
1776             (values (format nil "~A is a closure" o)             (list* (format nil "~A is a closure.~%" o)
1777                     (append                     (append
1778                      (label-value-line "Function" (kernel:%closure-function o))                      (label-value-line "Function" (kernel:%closure-function o))
1779                      `("Environment:" (:newline))                      `("Environment:" (:newline))
# Line 1789  The `symbol-value' of each element is a Line 1788  The `symbol-value' of each element is a
1788    
1789    
1790  (defmethod emacs-inspect ((o kernel:code-component))  (defmethod emacs-inspect ((o kernel:code-component))
   (values (format nil "~A is a code data-block." o)  
1791            (append            (append
1792             (label-value-line*             (label-value-line*
1793              ("code-size" (kernel:%code-code-size o))              ("code-size" (kernel:%code-code-size o))
# Line 1813  The `symbol-value' of each element is a Line 1811  The `symbol-value' of each element is a
1811                               (* vm:code-constants-offset vm:word-bytes))                               (* vm:code-constants-offset vm:word-bytes))
1812                            (ash 1 vm:lowtag-bits))                            (ash 1 vm:lowtag-bits))
1813                           (ash (kernel:%code-code-size o) vm:word-shift)                           (ash (kernel:%code-code-size o) vm:word-shift)
1814                           :stream s))))))))                           :stream s)))))))
1815    
1816  (defmethod emacs-inspect ((o kernel:fdefn))  (defmethod emacs-inspect ((o kernel:fdefn))
1817    (values (format nil "~A is a fdenf object." o)    (label-value-line*
           (label-value-line*  
1818             ("name" (kernel:fdefn-name o))             ("name" (kernel:fdefn-name o))
1819             ("function" (kernel:fdefn-function o))             ("function" (kernel:fdefn-function o))
1820             ("raw-addr" (sys:sap-ref-32             ("raw-addr" (sys:sap-ref-32
1821                          (sys:int-sap (kernel:get-lisp-obj-address o))                          (sys:int-sap (kernel:get-lisp-obj-address o))
1822                          (* vm:fdefn-raw-addr-slot vm:word-bytes))))))                          (* vm:fdefn-raw-addr-slot vm:word-bytes)))))
1823    
1824  (defmethod emacs-inspect ((o array))  (defmethod emacs-inspect ((o array))
1825    (cond ((kernel:array-header-p o)    (cond ((kernel:array-header-p o)
1826           (values (format nil "~A is an array." o)           (list*  (format nil "~A is an array.~%" o)
1827                   (label-value-line*                   (label-value-line*
1828                    (:header (describe-primitive-type o))                    (:header (describe-primitive-type o))
1829                    (:rank (array-rank o))                    (:rank (array-rank o))
# Line 1838  The `symbol-value' of each element is a Line 1835  The `symbol-value' of each element is a
1835                    (:displaced-p (kernel:%array-displaced-p o))                    (:displaced-p (kernel:%array-displaced-p o))
1836                    (:dimensions (array-dimensions o)))))                    (:dimensions (array-dimensions o)))))
1837          (t          (t
1838           (values (format nil "~A is an simple-array." o)           (list*  (format nil "~A is an simple-array.~%" o)
1839                   (label-value-line*                   (label-value-line*
1840                    (:header (describe-primitive-type o))                    (:header (describe-primitive-type o))
1841                    (:length (length o)))))))                    (:length (length o)))))))
1842    
1843  (defmethod emacs-inspect ((o simple-vector))  (defmethod emacs-inspect ((o simple-vector))
1844    (values (format nil "~A is a vector." o)    (list*  (format nil "~A is a vector.~%" o)
1845            (append            (append
1846             (label-value-line*             (label-value-line*
1847              (:header (describe-primitive-type o))              (:header (describe-primitive-type o))
# Line 1854  The `symbol-value' of each element is a Line 1851  The `symbol-value' of each element is a
1851                     append (label-value-line i (aref o i)))))))                     append (label-value-line i (aref o i)))))))
1852    
1853  (defun inspect-alien-record (alien)  (defun inspect-alien-record (alien)
   (values  
    (format nil "~A is an alien value." alien)  
1854     (with-struct (alien::alien-value- sap type) alien     (with-struct (alien::alien-value- sap type) alien
1855       (with-struct (alien::alien-record-type- kind name fields) type       (with-struct (alien::alien-record-type- kind name fields) type
1856         (append         (append
# Line 1865  The `symbol-value' of each element is a Line 1860  The `symbol-value' of each element is a
1860           (:name name))           (:name name))
1861          (loop for field in fields          (loop for field in fields
1862                append (let ((slot (alien::alien-record-field-name field)))                append (let ((slot (alien::alien-record-field-name field)))
1863                         (label-value-line slot (alien:slot alien slot)))))))))                         (label-value-line slot (alien:slot alien slot))))))))
1864    
1865  (defun inspect-alien-pointer (alien)  (defun inspect-alien-pointer (alien)
1866    (values    (with-struct (alien::alien-value- sap type) alien
    (format nil "~A is an alien value." alien)  
    (with-struct (alien::alien-value- sap type) alien  
1867       (label-value-line*       (label-value-line*
1868        (:sap sap)        (:sap sap)
1869        (:type type)        (:type type)
1870        (:to (alien::deref alien))))))        (:to (alien::deref alien)))))
1871    
1872  (defun inspect-alien-value (alien)  (defun inspect-alien-value (alien)
1873    (typecase (alien::alien-value-type alien)    (typecase (alien::alien-value-type alien)

Legend:
Removed from v.1.16  
changed lines
  Added in v.1.17

  ViewVC Help
Powered by ViewVC 1.1.5