Changeset 12682


Ignore:
Timestamp:
Aug 25, 2009, 6:56:24 PM (10 years ago)
Author:
gz
Message:

Add source-note line to the function inspector. Fix it so adding a new line to the function inspector doesn't involve changing magic constants all over the place

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/describe.lisp

    r12650 r12682  
    9191  (multiple-value-call #'prin1-line i stream (line-n i n)))
    9292
    93 (defmethod prin1-line ((i inspector) stream value &optional
    94                        label type function)
     93(defmethod prin1-line ((i inspector) stream value &optional label type function)
    9594  (unless function
    9695    (setq function (inspector-print-function i type)))
     
    269268    (if (eq type-sym :colon) (setq colon-p t))
    270269    (when label
    271       (if (stringp label)
    272           (write-string label stream)
    273           (princ label stream))
     270      (prin1-label i stream value label type)
    274271      (if colon-p (princ ": " stream)))
    275272    (end-of-label stream)              ; used by cacheing code
     
    11451142;;
    11461143(defclass function-inspector (inspector)
    1147   ((disasm-p :accessor disasm-p :initform *inspector-disassembly*)
     1144  ((header-lines :initform nil :reader header-lines)
     1145   (disasm-p :accessor disasm-p :initform *inspector-disassembly*)
    11481146   (disasm-info :accessor disasm-info)
    11491147   (pc-width :accessor pc-width)
    11501148   (pc :initarg :pc :initform nil :accessor pc)))
    11511149
     1150(defmethod header-count ((i function-inspector)) (length (header-lines i)))
     1151
    11521152(defclass closure-inspector (function-inspector)
    11531153  ((n-closed :accessor closure-n-closed)))
     
    11591159
    11601160(defmethod compute-line-count ((f function-inspector))
    1161   (+ 1                                  ; the function
    1162      1                                  ; name
    1163      1                                  ; arglist
    1164      (let* ((doc (documentation (inspector-object f) t)))
    1165        (if doc 1 0))
    1166      (compute-disassembly-lines f)))
     1161  (let* ((o (inspector-object f))
     1162         (doc (documentation o t))
     1163         (sn (ccl::function-source-note o))
     1164         (lines (nconc (list (list o ""))
     1165                       (list (list (function-name o) "Name" :colon))
     1166                       (list (multiple-value-bind (arglist type) (arglist o)
     1167                               (let ((label (if type
     1168                                              (format nil "Arglist (~(~a~))" type)
     1169                                              "Arglist unknown")))
     1170                                 (list arglist label (if type :colon '(:comment (:plain)))))))
     1171                       (when doc (list (substitute #\space #\newline doc) "Documentation" :colon))
     1172                       (when sn (list (list sn "Source Location" :colon))))))
     1173    (setf (slot-value f 'header-lines) lines)
     1174    (+ (length lines) (compute-disassembly-lines f))))
    11671175
    11681176(defmethod line-n ((f function-inspector) n)
    1169   (let* ((o (inspector-object f))
    1170          (doc (documentation o t)))
    1171     (case n
    1172       (0 (values o ""))
    1173       (1 (values (function-name o) "Name" :colon))
    1174       (2 (multiple-value-bind (arglist type) (arglist o)
    1175            (let ((label (if type (format nil "Arglist (~(~a~))" type) "Arglist unknown")))
    1176              (values arglist label (if type :colon '(:comment (:plain)))))))
    1177       (3 (if doc
    1178            (values (substitute #\space #\newline doc) "Documentation" :colon)
    1179            (disassembly-line-n f (- n 3))))
    1180       (t (disassembly-line-n f (- n (if doc 4 3)))))))
     1177  (let* ((lines (header-lines f))
     1178         (nlines (length lines)))
     1179    (if (< n nlines)
     1180      (apply #'values (nth n lines))
     1181      (disassembly-line-n f (- n nlines)))))
    11811182
    11821183(defmethod compute-line-count ((f closure-inspector))
     
    11931194  (let ((o (inspector-object f))
    11941195        (nclosed (closure-n-closed f)))
    1195     (if (<= (decf n 2) 0)
     1196    (if (< (decf n (header-count f)) 0)
    11961197      (call-next-method)
    1197       (cond ((eql (decf n) 0)
     1198      (cond ((< (decf n) 0)
    11981199             (values (ccl::closure-function o) "Inner lfun: " :static))
    1199             ((eql (decf n) 0)
     1200            ((< (decf n) 0)
    12001201             (values nclosed "Closed over values" :comment #'prin1-comment))
    1201             ((< (decf n) nclosed)
     1202            ((< n nclosed)
    12021203             (let* ((value (ccl::nth-immediate o (1+ (- nclosed n))))
    12031204                    (map (car (ccl::function-symbol-map (ccl::closure-function o))))
     
    12201221      (2 (setf (arglist o) new-value))
    12211222      (t
    1222        (if (>= n 3)
    1223          (set-disassembly-line-n f (- n 3) new-value)
    1224          (setf-line-n-out-of-range f n)))))
     1223       (let ((line (- n (header-count f))))
     1224         (if (>= line 0)
     1225           (set-disassembly-line-n f line new-value)
     1226           (setf-line-n-out-of-range f n))))))
    12251227  new-value)
    12261228
     
    12281230  (let ((o (inspector-object f))
    12291231        (nclosed (closure-n-closed f)))
    1230     (if (<= (decf n 2) 0)               ; function itself, name, or arglist
     1232    (if (< (decf n (header-count f)) 0)
    12311233      (call-next-method)
    1232       (cond ((<= (decf n 2) 0)          ; inner-lfun or "Closed over values"
     1234      (cond ((< (decf n 2) 0)          ; inner-lfun or "Closed over values"
    12331235             (setf-line-n-out-of-range f en))
    1234             ((< (decf n) nclosed)       ; closed-over variable
     1236            ((< n nclosed)       ; closed-over variable
    12351237             (let* ((value (ccl::nth-immediate o (1+ (- nclosed n))))
    12361238                    (cellp (ccl::closed-over-value-p value)))
     
    12431245(defun compute-disassembly-lines (f &optional (function (inspector-object f)))
    12441246  (if (functionp function)
    1245     (let* ((info (and (disasm-p f)  (list-to-vector (ccl::disassemble-list function))))
     1247    (let* ((info (and (disasm-p f)  (coerce (ccl::disassemble-list function) 'vector)))
    12461248           (length (length info))
    12471249           (last-pc (if info (car (svref info (1- length))) 0)))
     
    12511253      length)
    12521254    0))
    1253 
    1254 (defun list-to-vector (list)
    1255   (let* ((length (length list))
    1256          (vec (make-array length)))
    1257     (dotimes (i length)
    1258       (declare (fixnum i))
    1259       (setf (svref vec i) (pop list)))
    1260     vec))
    12611255
    12621256(defun disassembly-line-n (f n)
     
    13461340(defmethod line-n ((f gf-inspector) n)
    13471341  (let* ((count (method-count f))
     1342         (header-count (header-count f))
    13481343         (slot-count (slot-count f))
    13491344         (lines (1+ count)))
    1350     (if (<= 3 n (+ lines slot-count 3))
     1345    (if (<= header-count n (+ lines slot-count header-count))
    13511346      (let ((methods (generic-function-methods (inspector-object f))))
    1352         (cond ((eql (decf n 3) 0) (values methods "Methods: " :static))
     1347        (cond ((eql (decf n header-count) 0) (values methods "Methods: " :static))
    13531348              ((<= n count)
    13541349               (values (nth (- n 1) methods) nil :static))
     
    13571352              (t
    13581353               (values 0 "Disassembly" :comment #'prin1-comment))))
    1359       (call-next-method f (if (< n 3) n (- n lines slot-count 1))))))
     1354      (call-next-method f (if (< n header-count) n (- n lines slot-count 1))))))
    13601355
    13611356(defmethod (setf line-n) (new-value (f gf-inspector) n)
    13621357  (let* ((count (method-count f))
     1358         (header-count (header-count f))
    13631359         (slot-count (slot-count f))
    13641360         (lines (1+ count)))
    1365     (if (<= 3 n (+ lines slot-count 3))
     1361    (if (<= header-count n (+ lines slot-count header-count))
    13661362      (let ((en n))
    1367         (cond ((<= (decf en 3) count)
     1363        (cond ((<= (decf en header-count) count)
    13681364               (setf-line-n-out-of-range f n))
    13691365              ((< (decf en (1+ count)) slot-count)
    13701366               (standard-object-setf-line-n new-value f en))
    13711367              (t (setf-line-n-out-of-range f n))))
    1372       (call-next-method new-value f (if (< n 3) n (- n lines slot-count 1))))))
     1368      (call-next-method new-value f (if (< n header-count) n (- n lines slot-count 1))))))
    13731369
    13741370#|
     
    15671563
    15681564(defmethod initialize-addresses ((f error-frame))
    1569   (let* ((addresses (list-to-vector (ccl::%stack-frames-in-context (context f)))))
     1565  (let* ((addresses (coerce (ccl::%stack-frames-in-context (context f)) 'vector)))
    15701566      (setf (frame-count f) (length addresses)
    15711567            (addresses f) addresses)))
Note: See TracChangeset for help on using the changeset viewer.