Changeset 12949


Ignore:
Timestamp:
Oct 9, 2009, 6:01:30 PM (10 years ago)
Author:
gz
Message:

cleanup of function inspectors and disassembly (r12650, r12682, r12756, r12838, r12846, r12848)

Location:
branches/working-0711/ccl
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp

    r12339 r12949  
    26712671
    26722672
    2673    
     2673(defmethod x86-lap-operand-constant-offset (op ds)
     2674  (declare (ignore op ds))
     2675  nil)
     2676
     2677(defmethod x86-lap-operand-constant-offset ((op x86::x86-memory-operand) ds)
     2678  (let* ((disp (x86::x86-memory-operand-disp op))
     2679         (base (x86::x86-memory-operand-base op))
     2680         (index (x86::x86-memory-operand-index op))
     2681         (scale (x86::x86-memory-operand-scale op))
     2682         (code-limit (x86-ds-code-limit ds))
     2683         (val (and base
     2684                   (eq (x86::x86-register-operand-entry base)
     2685                       (if (x86-ds-mode-64 ds)
     2686                         (x86::x86-reg64 13)
     2687                         (x86::x86-reg32 x8632::fn)))
     2688                   (null index)
     2689                   (or (eql scale 0) (null scale))
     2690                   (typecase disp
     2691                     (constant-x86-lap-expression
     2692                      (+ (x86-ds-entry-point ds)
     2693                         (constant-x86-lap-expression-value disp)))
     2694                     (integer
     2695                      (+ (x86-ds-entry-point ds) disp))
     2696                     (t nil)))))
     2697    (when (and val (>= val code-limit))
     2698      (- val code-limit))))
     2699
     2700(defun x86-lap-operand-constant (op ds)
     2701  (let ((diff (x86-lap-operand-constant-offset op ds)))
     2702    (when diff
     2703      (values (uvref (x86-ds-constants-vector ds)
     2704                     (1+ (ash diff (if (x86-ds-mode-64 ds)
     2705                                     (- x8664::word-shift)
     2706                                     (- x8632::word-shift)))))
     2707              t))))
     2708
     2709
    26742710(defmethod unparse-x86-lap-operand ((x x86::x86-memory-operand) ds)
    2675   (let* ((seg (x86::x86-memory-operand-seg x))
    2676          (disp (x86::x86-memory-operand-disp x))
    2677          (base (x86::x86-memory-operand-base x))
    2678          (index (x86::x86-memory-operand-index x))
    2679          (scale (x86::x86-memory-operand-scale x))
    2680          (val nil))
    2681     (if (and base
    2682              (eq (x86::x86-register-operand-entry base)
    2683                  (if (x86-ds-mode-64 ds)
    2684                    (x86::x86-reg64 13)
    2685                    (x86::x86-reg32 x8632::fn)))
    2686              (null index)
    2687              (or (eql scale 0) (null scale))
    2688              (and (if (typep disp 'constant-x86-lap-expression)
    2689                     (+ (x86-ds-entry-point ds)
    2690                                   (constant-x86-lap-expression-value disp))
    2691                     (unless (typep disp 'x86-lap-expression)
    2692                       (setq val (if disp
    2693                                   (+ (x86-ds-entry-point ds)
    2694                                      disp)))))
    2695                   (>= val (x86-ds-code-limit ds))))
    2696       (let* ((diff (- val (x86-ds-code-limit ds)))
    2697              (constant (uvref (x86-ds-constants-vector ds)
    2698                               (1+ (ash diff (if (x86-ds-mode-64 ds)
    2699                                               (- x8664::word-shift)
    2700                                               (- x8632::word-shift)))))))
    2701         `(@ ',constant ,(unparse-x86-lap-operand base ds)))
    2702       (collect ((subforms))
    2703         (subforms '@)
    2704         (if seg
    2705           (subforms (unparse-x86-lap-operand seg ds)))
    2706         (if disp
    2707           (subforms (unparse-x86-lap-expression disp ds)))
    2708         (if base
    2709           (subforms (unparse-x86-lap-operand base ds)))
    2710         (if index
    2711           (subforms (unparse-x86-lap-operand index ds)))
    2712         (if (and scale (not (eql scale 0)))
    2713           (subforms (ash 1 scale)))
    2714         (subforms)))))
     2711  (multiple-value-bind (constant foundp) (x86-lap-operand-constant x ds)
     2712    (if foundp
     2713      `(@ ',constant ,(unparse-x86-lap-operand (x86::x86-memory-operand-base x) ds))
     2714      (let* ((seg (x86::x86-memory-operand-seg x))
     2715             (disp (x86::x86-memory-operand-disp x))
     2716             (base (x86::x86-memory-operand-base x))
     2717             (index (x86::x86-memory-operand-index x))
     2718             (scale (x86::x86-memory-operand-scale x)))
     2719        (collect ((subforms))
     2720          (subforms '@)
     2721          (if seg
     2722            (subforms (unparse-x86-lap-operand seg ds)))
     2723          (if disp
     2724            (subforms (unparse-x86-lap-expression disp ds)))
     2725          (if base
     2726            (subforms (unparse-x86-lap-operand base ds)))
     2727          (if index
     2728            (subforms (unparse-x86-lap-operand index ds)))
     2729          (if (and scale (not (eql scale 0)))
     2730            (subforms (ash 1 scale)))
     2731          (subforms))))))
    27152732   
    27162733(defmethod unparse-x86-lap-operand :around ((op x86::x86-operand)
     
    27222739      `(* ,usual)
    27232740      usual)))
     2741
     2742(defun write-x86-lap-operand (stream op ds)
     2743  ;; Basically, have to princ because some parts are already stringified,
     2744  ;; plus don't want package prefixes on assembler syntax.  But want to
     2745  ;; prin1 immediates.
     2746  (let ((expr (unparse-x86-lap-operand op ds)))
     2747    (format stream " ")
     2748    (labels ((out (stream expr)
     2749               (cond ((atom expr)
     2750                      (format stream "~a" expr))
     2751                     ((quoted-form-p expr)
     2752                      (format stream "'~s" (cadr expr)))
     2753                     (t
     2754                      (loop for item in expr as pre = "(" then " "
     2755                        do (format stream pre)
     2756                        do (out stream item))
     2757                      (format stream ")")))))
     2758      (out stream expr))))
    27242759
    27252760(defvar *previous-source-note*)
     
    27492784           (op2 (x86-di-op2 instruction)))
    27502785      (when op0
    2751         (format t " ~a" (unparse-x86-lap-operand op0 ds))
     2786        (write-x86-lap-operand t op0 ds)
    27522787        (when op1
    2753           (format t " ~a" (unparse-x86-lap-operand op1 ds))
     2788        (write-x86-lap-operand t op1 ds)
    27542789          (when op2
    2755             (format t " ~a" (unparse-x86-lap-operand op2 ds))))))
     2790            (write-x86-lap-operand t op2 ds)))))
    27562791    (format t ")")
    27572792    (format t "~%")
     
    27692804      (ensure-source-note-text source-note))))
    27702805
    2771 (defun x8664-disassemble-xfunction (function xfunction
    2772                                     &key (symbolic-names x8664::*x8664-symbolic-register-names*)
    2773                                          (collect-function #'x86-print-disassembled-instruction)
    2774                                          (header-function #'x86-print-disassembled-function-header))
     2806(defun x86-disassemble-xfunction (function xfunction
     2807                                  &key (symbolic-names #+x8664-target target::*x8664-symbolic-register-names*
     2808                                                       #+x8632-target target::*x8632-symbolic-register-names*)
     2809                                       (collect-function #'x86-print-disassembled-instruction)
     2810                                       (header-function #'x86-print-disassembled-function-header))
    27752811  (check-type xfunction xfunction)
    27762812  (check-type (uvref xfunction 0) (simple-array (unsigned-byte 8) (*)))
    2777   (let* ((ds (make-x86-disassembly-state
     2813  (let* ((entry-point  #+x8664-target 7  #+x8632-target 2)
     2814         (ds (make-x86-disassembly-state
     2815              :mode-64 #+x8664-target t #+x8632-target nil
    27782816              :code-vector (uvref xfunction 0)
    27792817              :constants-vector xfunction
    2780               :entry-point 7
    2781               :code-pointer 0           ; for next-u32 below
     2818              :entry-point entry-point
     2819              :code-pointer 0           ; for next-u32/next-u16 below
    27822820              :symbolic-names symbolic-names
    2783               :pending-labels (list 7)))
     2821              :pending-labels (list entry-point)))
    27842822         (blocks (x86-ds-blocks ds)))
    27852823    (setf (x86-ds-code-limit ds)
    2786           (ash (x86-ds-next-u32 ds) 3))
     2824          #+x8664-target (ash (x86-ds-next-u32 ds) 3)
     2825          #+x8632-target (ash (x86-ds-next-u16 ds) 2))
    27872826    (do* ()
    27882827         ((null (x86-ds-pending-labels ds)))
     
    27902829        (or (x86-dis-find-label lab blocks)
    27912830            (x86-disassemble-new-block ds lab))))
    2792     (when (and blocks (let ((something-to-disassemble nil))
    2793                         (do-dll-nodes (block blocks)
    2794                           (do-dll-nodes (instruction (x86-dis-block-instructions block))
    2795                             (setf something-to-disassemble t)))
    2796                         something-to-disassemble))
     2831    (when (and header-function
     2832               blocks
     2833               (let ((something-to-disassemble nil))
     2834                 (do-dll-nodes (block blocks)
     2835                   (do-dll-nodes (instruction (x86-dis-block-instructions block))
     2836                     (setf something-to-disassemble t)))
     2837                 something-to-disassemble))
    27972838      (funcall header-function function xfunction))
    27982839    (let* ((seq 0)
     
    28032844          (setq seq (funcall collect-function ds instruction seq function)))))))
    28042845
    2805 (defun x8632-disassemble-xfunction (function xfunction
    2806                                     &key (symbolic-names x8632::*x8632-symbolic-register-names*)
    2807                                          (collect-function #'x86-print-disassembled-instruction)
    2808                                          (header-function #'x86-print-disassembled-function-header))
    2809   (check-type xfunction xfunction)
    2810   (check-type (uvref xfunction 0) (simple-array (unsigned-byte 8) (*)))
    2811   (let* ((ds (make-x86-disassembly-state
    2812               :mode-64 nil
    2813               :code-vector (uvref xfunction 0)
    2814               :constants-vector xfunction
    2815               :entry-point 2
    2816               :code-pointer 0           ; for next-u16 below
    2817               :symbolic-names symbolic-names
    2818               :pending-labels (list 2)))
    2819          (blocks (x86-ds-blocks ds)))
    2820     (setf (x86-ds-code-limit ds) (ash (x86-ds-next-u16 ds) 2))
    2821     (do* ()
    2822          ((null (x86-ds-pending-labels ds)))
    2823       (let* ((lab (pop (x86-ds-pending-labels ds))))
    2824         (or (x86-dis-find-label lab blocks)
    2825             (x86-disassemble-new-block ds lab))))
    2826     (when (and blocks (let ((something-to-disassemble nil))
    2827                         (do-dll-nodes (block blocks)
    2828                           (do-dll-nodes (instruction (x86-dis-block-instructions block))
    2829                             (setf something-to-disassemble t)))
    2830                         something-to-disassemble))
    2831       (funcall header-function function xfunction))
    2832     (let* ((seq 0)
    2833            (*previous-source-note* nil))
    2834       (declare (special *previous-source-note*))
    2835       (do-dll-nodes (block blocks)
    2836         (do-dll-nodes (instruction (x86-dis-block-instructions block))
    2837           (setq seq (funcall collect-function ds instruction seq function)))))))
    2838 
    2839 #+x8664-target
    2840 (defun x8664-xdisassemble (function
    2841                            &optional (collect-function #'x86-print-disassembled-instruction)
    2842                                      (header-function #'x86-print-disassembled-function-header))
    2843   (let* ((fv (%function-to-function-vector function))
     2846(defun x86-xdisassemble (function
     2847                         &optional (collect-function #'x86-print-disassembled-instruction)
     2848                                   (header-function #'x86-print-disassembled-function-header))
     2849  (let* ((fv (function-to-function-vector function))
    28442850         (function-size-in-words (uvsize fv))
    28452851         (code-words (%function-code-words function))
    2846          (ncode-bytes (ash function-size-in-words x8664::word-shift))
     2852         (ncode-bytes (ash function-size-in-words target::word-shift))
    28472853         (code-bytes (make-array ncode-bytes
    28482854                                 :element-type '(unsigned-byte 8)))
     
    28552861          (j 1 (1+ j)))
    28562862         ((= k function-size-in-words)
    2857           (x8664-disassemble-xfunction function xfunction
    2858                                        :collect-function collect-function
    2859                                        :header-function header-function))
     2863          (x86-disassemble-xfunction function xfunction
     2864                                     :collect-function collect-function
     2865                                     :header-function header-function))
    28602866      (declare (fixnum j k))
    28612867      (setf (uvref xfunction j) (uvref fv k)))))
    28622868
    2863 #+x8632-target
    2864 (defun x8632-xdisassemble (function
    2865                            &optional (collect-function #'x86-print-disassembled-instruction)
    2866                                      (header-function #'x86-print-disassembled-function-header))
    2867   (let* ((fv (function-to-function-vector function))
    2868          (function-size-in-words (uvsize fv))
    2869          (code-words (%function-code-words function))
    2870          (ncode-bytes (ash function-size-in-words x8632::word-shift))
    2871          (code-bytes (make-array ncode-bytes
    2872                                  :element-type '(unsigned-byte 8)))
    2873          (numimms (- function-size-in-words code-words))
    2874          (xfunction (%alloc-misc (the fixnum (1+ numimms)) target::subtag-xfunction)))
    2875     (declare (fixnum code-words ncode-bytes numimms))
    2876     (%copy-ivector-to-ivector fv 0 code-bytes 0 ncode-bytes)
    2877     (setf (uvref xfunction 0) code-bytes)
    2878     (do* ((k code-words (1+ k))
    2879           (j 1 (1+ j)))
    2880          ((= k function-size-in-words)
    2881           (x8632-disassemble-xfunction function xfunction
    2882                                        :collect-function collect-function
    2883                                        :header-function header-function))
    2884       (declare (fixnum j k))
    2885       (setf (uvref xfunction j) (uvref fv k)))))
    2886 
    28872869(defun disassemble-list (function)
    28882870  (collect ((instructions))
    2889     (#+x8632-target x8632-xdisassemble #+x8664-target x8664-xdisassemble
     2871    (x86-xdisassemble
    28902872     function
    28912873     #'(lambda (ds instruction seq function)
     
    29132895                     (insn (unparse-x86-lap-operand op2 ds))  ))))
    29142896             (instructions (insn))
    2915              (1+ seq)))))
     2897             (1+ seq))))
     2898     nil)
    29162899    (instructions)))
    2917                          
    2918              
    2919 
    2920            
    2921          
    2922 
    2923                                      
    2924            
    2925      
    2926            
    2927              
     2900
     2901(defun x86-disassembled-instruction-line (ds instruction function &optional string-stream)
     2902  (if (null string-stream)
     2903    (with-output-to-string (stream)
     2904      (return-from x86-disassembled-instruction-line
     2905                   (x86-disassembled-instruction-line ds instruction function stream)))
     2906    (let* ((addr (x86-di-address instruction))
     2907           (entry (x86-ds-entry-point ds))
     2908           (pc (- addr entry))
     2909           (op0 (x86-di-op0 instruction))
     2910           (op1 (x86-di-op1 instruction))
     2911           (op2 (x86-di-op2 instruction))
     2912           (label (if (x86-di-labeled instruction) (list :label pc) pc))
     2913           (instr (progn
     2914                    (dolist (p (x86-di-prefixes instruction))
     2915                      (format string-stream "(~a) " p))
     2916                    (format string-stream "(~a" (x86-di-mnemonic instruction))
     2917                    (when op0 (write-x86-lap-operand string-stream op0 ds))
     2918                    (when op1 (write-x86-lap-operand string-stream op1 ds))
     2919                    (when op2 (write-x86-lap-operand string-stream op2 ds))
     2920                    (format string-stream ")")
     2921                    (get-output-stream-string string-stream)))
     2922           (comment (let ((source-note (find-source-note-at-pc function pc)))
     2923                      (unless (eql (source-note-file-range source-note)
     2924                                   (source-note-file-range *previous-source-note*))
     2925                        (setf *previous-source-note* source-note)
     2926                        (let* ((source-text (source-note-text source-note))
     2927                               (text (if source-text
     2928                                       (string-sans-most-whitespace source-text 100)
     2929                                       "#<no source text>")))
     2930                          (format string-stream ";;; ~A" text)
     2931                          (get-output-stream-string string-stream)))))
     2932           (imms (let ((imms nil))
     2933                   (multiple-value-bind (imm foundp) (x86-lap-operand-constant op2 ds)
     2934                     (when foundp (push imm imms)))
     2935                   (multiple-value-bind (imm foundp) (x86-lap-operand-constant op1 ds)
     2936                     (when foundp (push imm imms)))
     2937                   (multiple-value-bind (imm foundp) (x86-lap-operand-constant op0 ds)
     2938                     (when foundp (push imm imms)))
     2939                   imms)))
     2940      ;; Subtle difference between no imms and a single NIL imm, so if anybody ever
     2941      ;; cares for some reason, they could distinguish the two cases.
     2942      (if imms
     2943        (values comment label instr (if (cdr imms) (coerce imms 'vector) (car imms)))
     2944        (values comment label instr)))))
     2945
     2946(defun disassemble-lines (function)
     2947  (let ((source-note (function-source-note function)))
     2948    (when source-note
     2949      ;; Fetch source from file if don't already have it.
     2950      (ensure-source-note-text source-note)))
     2951  (let ((lines (make-array 20 :adjustable t :fill-pointer 0)))
     2952    (with-output-to-string (stream)
     2953      (x86-xdisassemble
     2954       function
     2955       #'(lambda (ds instruction seq function)
     2956           (declare (ignore seq))
     2957           (multiple-value-bind (comment label instr object)
     2958                                (x86-disassembled-instruction-line ds instruction function stream)
     2959             (when comment
     2960               (vector-push-extend comment lines))
     2961             (vector-push-extend (list object label instr) lines)))
     2962       nil))
     2963    (coerce lines 'simple-vector)))
  • branches/working-0711/ccl/compiler/X86/x862.lisp

    r12694 r12949  
    1013110131      (when disassemble
    1013210132        (format t "~%~%")
    10133         (apply #'x8664-disassemble-xfunction
     10133        (apply #'x86-disassemble-xfunction
    1013410134               xlfun
    1013510135               (unless symbolic-names (list nil))))
     
    1015310153        (let ((*target-backend* backend))
    1015410154          (format t "~%~%")
    10155           (apply #'x8632-disassemble-xfunction
     10155          (apply #'x86-disassemble-xfunction
    1015610156                 xlfun
    1015710157                 (unless symbolic-names (list nil)))))
  • branches/working-0711/ccl/lib/describe.lisp

    r12408 r12949  
    2020           "COMPUTE-LINE-COUNT"
    2121           "LINE-N"
     22           "INSPECTOR-OBJECT"
     23           "INSPECTOR-LINE-COUNT"
    2224
    2325           "*INSPECTOR-DISASSEMBLY*"))
     
    3537(defclass inspector ()
    3638  ((object :accessor inspector-object :initarg :object)
    37    (line-count :accessor inspector-line-count :initarg :line-count :initform nil)))
     39   (line-count :accessor inspector-line-count :initarg :line-count :initform nil)
     40   ;; so can refresh.
     41   (initargs :reader inspector-initargs :initform nil)))
     42
     43(defmethod initialize-instance :before ((i inspector) &rest initargs)
     44  (setf (slot-value i 'initargs) initargs))
    3845
    3946;;; The usual way to cons up an inspector
     
    4552  (when update-line-count
    4653    (update-line-count i)))
     54
     55(defmethod refresh-inspector ((i inspector))
     56  (apply #'make-instance (class-of i) (slot-value i 'initargs)))
     57
     58;; New protocol, used by gui inspector instead of the line-n protocol, which isn't quite right.
     59;; Perhaps tty inspector should use it as well.  Returns the line inspector rather than object,
     60;; and returns the value string rather than having the caller print it.
     61(defmethod inspector-line ((i inspector) index)
     62  (let ((line-i (multiple-value-bind (value label type) (inspector::line-n i index)
     63                  (and (not (eq (parse-type i type) :comment))
     64                       (line-n-inspector i index value label type)))))
     65    (multiple-value-bind (label-string value-string) (line-n-strings i index)
     66      (values line-i label-string value-string))))
     67
     68;; for a comment value = nil, label = "the comment" type = :comment
     69;;; => line-i = nil
    4770
    4871;;;;;;;
     
    89112  (multiple-value-call #'prin1-line i stream (line-n i n)))
    90113
    91 (defmethod prin1-line ((i inspector) stream value &optional
    92                        label type function)
     114(defmethod prin1-line ((i inspector) stream value &optional label type function)
    93115  (unless function
    94116    (setq function (inspector-print-function i type)))
    95117  (funcall function i stream value label type))
    96118
     119(defvar *collect-labels-if-list* t)
     120
     121(defmethod end-of-label ((stream string-output-stream))
     122  (when (listp *collect-labels-if-list*)
     123    (push (get-output-stream-string stream) *collect-labels-if-list*)))
     124
     125(defmethod line-n-strings ((i inspector) n)
     126  (let* ((*collect-labels-if-list* ())
     127         (value-string (with-output-to-string (stream)
     128                         (prin1-line-n i stream n)))
     129         (label-string (pop *collect-labels-if-list*))
     130         (end (or (position-if-not #'whitespacep label-string :from-end t) -1)))
     131    (assert (null *collect-labels-if-list*))
     132    (unless (and (>= end 0) (eql (char label-string end) #\:)) (incf end))
     133    (setq label-string (subseq label-string 0 end))
     134    (values label-string value-string)))
     135
    97136(defmethod inspector-print-function ((i inspector) type)
    98   (if (consp type) (setq type (car type)))
    99   (if (eq type :comment)
    100     'prin1-comment
    101     'prin1-normal-line))
    102 
     137  (declare (ignore type))
     138  'prin1-normal-line)
    103139
    104140; Print a value to a stream.
     
    111147      (if colon-p (princ ": " stream)))
    112148    (end-of-label stream)              ; used by cacheing code
    113     (prin1-value i stream value label type)))
     149    (unless (eq type-sym :comment)
     150      (prin1-value i stream value label type))))
    114151
    115152(defun prin1-colon-line (i stream value &optional label type)
     
    126163  (prin1 value stream))
    127164
    128 (defmethod prin1-comment ((i inspector) stream value &optional label type)
    129   (when label
    130     (prin1-label i stream value label type)
    131     (end-of-label stream)))
    132  
    133165;;; Call function on the inspector object and its value, label, & type, for
    134166;;; each line in the selected range (default to the whole thing).
     
    139171                      (start 0)
    140172                      end)
     173  (when (null (inspector-line-count i))
     174    (update-line-count i))
    141175  (unless end
    142176    (setq end (inspector-line-count i)))
     
    144178    (let ((index start))
    145179      (dotimes (c (- end start))
    146         (declare (fixnum c))
    147         (multiple-value-call function i (line-n i index))
     180        (multiple-value-call function i index (inspector-line i index))
    148181        (incf index)))))
    149182
     
    213246         (*signal-printing-errors* nil))
    214247     ,@body))
     248
     249(defun format-line-for-tty (stream label-string value-string)
     250  (when (equal label-string "") (setq label-string nil))
     251  (when (equal value-string "") (setq value-string nil))
     252  (format stream "~@[~a~]~@[~a~]~@[~a~]"
     253          label-string
     254          (and label-string
     255               value-string
     256               (not (eql #\space (char label-string (1- (length label-string)))))
     257               ": ")
     258          value-string))
    215259
    216260(defun describe (object &optional stream)
     
    226270(defmethod describe-object (object stream)
    227271  (let ((inspector (make-inspector object)))
    228     (when (null (inspector-line-count inspector))
    229       (update-line-count inspector))
    230272    (with-errorfree-printing
    231273        (let* ((*print-pretty* (or *print-pretty* *describe-pretty*))
    232                (temp #'(lambda (i value &rest rest)
    233                          (declare (dynamic-extent rest))
    234                          (apply #'prin1-line i stream value rest)
    235                         (terpri stream))))
     274               (temp #'(lambda (i index child &optional label-string value-string)
     275                         (declare (ignore i index child))
     276                         (format-line-for-tty stream label-string value-string)
     277                        (terpri stream))))
    236278          (declare (dynamic-extent temp))
    237279          (map-lines inspector temp))))
     
    257299(defmethod prin1-line ((i formatting-inspector) stream value
    258300                       &optional label type (format-string "~s"))
    259   (if (eq :comment (if (consp type) (car type) type))
    260     (prin1-comment i stream value label type)
    261     (funcall (if (listp format-string) #'apply #'funcall)
    262              #'format-normal-line i stream value label type format-string)))
     301  (funcall (if (listp format-string) #'apply #'funcall)
     302           #'format-normal-line i stream value label type format-string))
    263303
    264304(defmethod format-normal-line ((i inspector) stream value &optional
     
    267307    (if (eq type-sym :colon) (setq colon-p t))
    268308    (when label
    269       (if (stringp label)
    270           (write-string label stream)
    271           (princ label stream))
     309      (prin1-label i stream value label type)
    272310      (if colon-p (princ ": " stream)))
    273311    (end-of-label stream)              ; used by cacheing code
    274     (format stream format-string value)))
     312    (unless (eq type-sym :comment)
     313      (format stream format-string value))))
    275314
    276315;;;;;;;
     
    353392      (2 (values (class-of object) "Class: " :static))
    354393      (t (call-next-method i (- n 3))))))
     394
     395(defmethod line-n-inspector :around ((i basics-first-mixin) n value label type)
     396  (if (< n 3)
     397    (make-inspector value)
     398    (call-next-method i (- n 3) value label type)))
    355399
    356400(defmethod (setf line-n) :around (new-value (i basics-first-mixin) n)
     
    9811025      (find-class sym nil)))
    9821026
    983 (defmethod inspector-class ((sym symbol)) 'usual-inspector)
     1027(defmethod inspector-class ((sym symbol)) 'usual-basics-first-inspector)
    9841028
    9851029(defmethod compute-line-count ((sym symbol))
    986   (+ 1                                  ; The symbol
    987      (if (symbol-has-bindings-p sym) 1 0)
     1030  (+ (if (symbol-has-bindings-p sym) 1 0)
    9881031     1                                  ; package
    9891032     1                                  ; symbol-name
     
    9971040
    9981041(defmethod normalize-line-number ((sym symbol) n)
    999   (if (and (>= n 1) (not (symbol-has-bindings-p sym))) (incf n))
    1000   (if (and (>= n 6) (not (fboundp sym))) (incf n))
     1042  (if (and (>= n 0) (not (symbol-has-bindings-p sym))) (incf n))
     1043  (if (and (>= n 5) (not (fboundp sym))) (incf n))
    10011044  n)
    10021045
     
    10071050        (static :static))
    10081051    (ecase n
    1009       (0 (values sym "Symbol: " type))
    1010       (1 (values nil (symbol-type-line sym) comment))
    1011       (2 (let ((p (symbol-package sym)))
     1052      (0 (values nil (symbol-type-line sym) comment))
     1053      (1 (let ((p (symbol-package sym)))
    10121054           (if (null p)
    10131055             (values nil "No home package." comment)
     
    10181060                         (format nil "~a in package: " kind))
    10191061                       static)))))
    1020       (3 (values (symbol-name sym) "Print name: " static))
    1021       (4 (values (if (boundp sym) (symbol-value sym) *unbound-marker*)
     1062      (2 (values (symbol-name sym) "Print name: " static))
     1063      (3 (values (if (boundp sym) (symbol-value sym) *unbound-marker*)
    10221064                 "Value: " type))
    1023       (5 (values (if (fboundp sym)
     1065      (4 (values (if (fboundp sym)
    10241066                   (cond ((macro-function sym))
    10251067                         ((special-operator-p sym) sym)
     
    10271069                   *unbound-marker*)
    10281070                 "Function: " type))
    1029       (6 (values (and (fboundp sym) (arglist sym))
     1071      (5 (values (and (fboundp sym) (arglist sym))
    10301072                 "Arglist: " static))
    1031       (7 (values (symbol-plist sym) "Plist: " type))
    1032       (8 (values (find-class sym) "Class: " static)))))
     1073      (6 (values (symbol-plist sym) "Plist: " type))
     1074      (7 (values (find-class sym) "Class: " static)))))
    10331075
    10341076(defmethod (setf line-n) (value (sym symbol) n)
     
    10371079    (setq value (restore-unbound value))
    10381080    (ecase n
    1039       (0 (replace-object *inspector* value))
    1040       ((1 2 3 6) (setf-line-n-out-of-range sym n))
    1041       (4 (setf resample-p (not (boundp sym))
     1081      ((0 1 2 5) (setf-line-n-out-of-range sym n))
     1082      (3 (setf resample-p (not (boundp sym))
    10421083               (symbol-value sym) value))
    1043       (5 (setf resample-p (not (fboundp sym))
     1084      (4 (setf resample-p (not (fboundp sym))
    10441085               (symbol-function sym) value))
    1045       (7 (setf (symbol-plist sym) value)))
     1086      (6 (setf (symbol-plist sym) value)))
    10461087    (when resample-p (resample-it))
    10471088    value))
     
    11051146  (declare (ignore label type))
    11061147  (setq n (normalize-line-number sym n))
    1107   (if (eql n 7)
     1148  (if (eql n 6)
    11081149    (make-instance 'plist-inspector :symbol sym :object value)
    11091150    (call-next-method)))
     
    11431184;;
    11441185(defclass function-inspector (inspector)
    1145   ((disasm-p :accessor disasm-p :initform *inspector-disassembly*)
     1186  ((header-lines :initform nil :reader header-lines)
     1187   (disasm-p :accessor disasm-p :initform *inspector-disassembly*)
    11461188   (disasm-info :accessor disasm-info)
    11471189   (pc-width :accessor pc-width)
    11481190   (pc :initarg :pc :initform nil :accessor pc)))
    11491191
     1192(defmethod standard-header-count ((f function-inspector)) (length (header-lines f)))
     1193
     1194(defmethod header-count ((f function-inspector)) (standard-header-count f))
     1195
    11501196(defclass closure-inspector (function-inspector)
    11511197  ((n-closed :accessor closure-n-closed)))
    11521198
    1153 
    1154 
    11551199(defmethod inspector-class ((f function)) 'function-inspector)
    11561200(defmethod inspector-class ((f compiled-lexical-closure)) 'closure-inspector)
    11571201
     1202(defmethod compute-line-count :before ((f function-inspector))
     1203  (let* ((o (inspector-object f))
     1204         (doc (documentation o t))
     1205         (sn (ccl::function-source-note o))
     1206         (lines (nconc (list (list o ""))
     1207                       (list (list (function-name o) "Name" :colon))
     1208                       (list (multiple-value-bind (arglist type) (arglist o)
     1209                               (let ((label (if type
     1210                                              (format nil "Arglist (~(~a~))" type)
     1211                                              "Arglist unknown")))
     1212                                 (list arglist label (if type :colon '(:comment (:plain)))))))
     1213                       (when doc (list (list (substitute #\space #\newline doc) "Documentation" :colon)))
     1214                       (when sn (list (list sn "Source Location" :colon))))))
     1215    (setf (slot-value f 'header-lines) lines)))
     1216
    11581217(defmethod compute-line-count ((f function-inspector))
    1159   (+ 1                                  ; the function
    1160      1                                  ; name
    1161      1                                  ; arglist
    1162      (let* ((doc (documentation (inspector-object f) t)))
    1163        (if doc 1 0))
    1164      (compute-disassembly-lines f)))
     1218  (+ (header-count f) (compute-disassembly-lines f)))
     1219
     1220(defmethod line-n-strings ((f function-inspector) n)
     1221  (if (< (decf n (header-count f)) 0)
     1222    (call-next-method)
     1223    (disassembly-line-n-strings f n)))
     1224
     1225(defmethod line-n-inspector ((f function-inspector) n value label type)
     1226  (declare (ignore value label type))
     1227  (if (< (decf n (header-count f)) 0)
     1228    (call-next-method)
     1229    (disassembly-line-n-inspector f n)))
    11651230
    11661231(defmethod line-n ((f function-inspector) n)
    1167   (let* ((o (inspector-object f))
    1168          (doc (documentation o t)))
    1169     (case n
    1170       (0 (values o ""))
    1171       (1 (values (function-name o) "Name" :colon))
    1172       (2 (multiple-value-bind (arglist type) (arglist o)
    1173            (let ((label (if type (format nil "Arglist (~(~a~))" type) "Arglist unknown")))
    1174              (values arglist label (if type :colon '(:comment (:plain)))))))
    1175       (3 (if doc
    1176            (values (substitute #\space #\newline doc) "Documentation" :colon)
    1177            (disassembly-line-n f (- n 3))))
    1178       (t (disassembly-line-n f (- n (if doc 4 3)))))))
    1179 
    1180 (defmethod compute-line-count ((f closure-inspector))
     1232  (let* ((lines (header-lines f))
     1233         (nlines (length lines)))
     1234    (if (< n nlines)
     1235      (apply #'values (nth n lines))
     1236      (disassembly-line-n f (- n nlines)))))
     1237
     1238(defmethod compute-line-count :before ((f closure-inspector))
    11811239  (let* ((o (inspector-object f))
    11821240         (nclosed (nth-value 8 (function-args (ccl::closure-function o)))))
    1183     (setf (closure-n-closed f) nclosed)
    1184     (+ (call-next-method)
    1185        1                              ; the function we close over
    1186        1                              ; "Closed over values"
    1187        nclosed
    1188        (if (disasm-p f) 1 0))))      ; "Disassembly"
     1241    (setf (closure-n-closed f) nclosed)))
     1242
     1243(defmethod header-count ((f closure-inspector))
     1244  (+ (standard-header-count f)
     1245     1                              ; the function we close over
     1246     1                              ; "Closed over values"
     1247     (closure-n-closed f)))
    11891248
    11901249(defmethod line-n ((f closure-inspector) n)
    11911250  (let ((o (inspector-object f))
    11921251        (nclosed (closure-n-closed f)))
    1193     (if (<= (decf n 2) 0)
     1252    (if (< (decf n (standard-header-count f)) 0)
    11941253      (call-next-method)
    1195       (cond ((eql (decf n) 0)
     1254      (cond ((< (decf n) 0)
    11961255             (values (ccl::closure-function o) "Inner lfun: " :static))
    1197             ((eql (decf n) 0)
    1198              (values nclosed "Closed over values" :comment #'prin1-comment))
    1199             ((< (decf n) nclosed)
     1256            ((< (decf n) 0)
     1257             (values nclosed "Closed over values" :comment))
     1258            ((< n nclosed)
    12001259             (let* ((value (ccl::nth-immediate o (1+ (- nclosed n))))
    12011260                    (map (car (ccl::function-symbol-map (ccl::closure-function o))))
     
    12071266                       label (format nil "(~a)" label)))
    12081267               (values value label (if cellp :normal :static) #'prin1-colon-line)))
    1209             ((eql (decf n nclosed) 0)
    1210              (values 0 "Disassembly" :comment #'prin1-comment))
    1211             (t (disassembly-line-n f (- n 1)))))))
     1268            (t (disassembly-line-n f (- n nclosed)))))))
    12121269
    12131270(defmethod (setf line-n) (new-value (f function-inspector) n)
    1214   (let ((o (inspector-object f)))
    1215     (case n
    1216       (0 (replace-object f new-value))
    1217       (1 (ccl::lfun-name o new-value) (resample-it))
    1218       (2 (setf (arglist o) new-value))
    1219       (t
    1220        (if (>= n 3)
    1221          (set-disassembly-line-n f (- n 3) new-value)
    1222          (setf-line-n-out-of-range f n)))))
     1271  (let ((o (inspector-object f))
     1272        (standard-header-count (standard-header-count f)))
     1273    (if (< n standard-header-count)
     1274      (case n
     1275        (0 (replace-object f new-value))
     1276        (1 (ccl::lfun-name o new-value) (resample-it))
     1277        (t (setf-line-n-out-of-range f n)))
     1278      (set-disassembly-line-n f (- n standard-header-count) new-value)))
    12231279  new-value)
    12241280
     
    12261282  (let ((o (inspector-object f))
    12271283        (nclosed (closure-n-closed f)))
    1228     (if (<= (decf n 2) 0)               ; function itself, name, or arglist
     1284    (if (< (decf n (standard-header-count f)) 0)
    12291285      (call-next-method)
    1230       (cond ((<= (decf n 2) 0)          ; inner-lfun or "Closed over values"
     1286      (cond ((< (decf n 2) 0)          ; inner-lfun or "Closed over values"
    12311287             (setf-line-n-out-of-range f en))
    1232             ((< (decf n) nclosed)       ; closed-over variable
     1288            ((< n nclosed)       ; closed-over variable
    12331289             (let* ((value (ccl::nth-immediate o (1+ (- nclosed n))))
    12341290                    (cellp (ccl::closed-over-value-p value)))
    12351291               (unless cellp (setf-line-n-out-of-range f en))
    12361292               (ccl::set-closed-over-value value new-value)))
    1237             ((eql (decf n nclosed) 0)   ; "Disassembly"
    1238              (setf-line-n-out-of-range f en))
    1239             (t (set-disassembly-line-n f (- n 1) new-value))))))
     1293            (t (set-disassembly-line-n f (- n nclosed) new-value))))))
    12401294
    12411295(defun compute-disassembly-lines (f &optional (function (inspector-object f)))
    1242   (if (functionp function)
    1243     (let* ((info (and (disasm-p f)  (list-to-vector (ccl::disassemble-list function))))
    1244            (length (length info))
    1245            (last-pc (if info (car (svref info (1- length))) 0)))
    1246       (if (listp last-pc) (setq last-pc (cadr last-pc)))
    1247       (setf (pc-width f) (length (format nil "~d" last-pc)))
    1248       (setf (disasm-info f) info)
    1249       length)
     1296  (if (and (functionp function) (disasm-p f))
     1297    (let* ((lines (ccl::disassemble-lines function)) ;; list of (object label instr)
     1298           (length (length lines))
     1299           (last-label (loop for n from (1- length) downto 0 as line = (aref lines n)
     1300                             thereis (and (consp line) (cadr line))))
     1301           (max-pc (if (consp last-label) (cadr last-label) last-label)))
     1302      (setf (pc-width f) (length (format nil "~d" max-pc)))
     1303      (setf (disasm-info f) lines)
     1304      (1+ length))
    12501305    0))
    12511306
    1252 (defun list-to-vector (list)
    1253   (let* ((length (length list))
    1254          (vec (make-array length)))
    1255     (dotimes (i length)
    1256       (declare (fixnum i))
    1257       (setf (svref vec i) (pop list)))
    1258     vec))
    1259 
    12601307(defun disassembly-line-n (f n)
    1261   (let* ((line (svref (disasm-info f) n))
    1262          (value (disasm-line-immediate line)))
    1263     (values value line (if value :static :comment))))
     1308  (if (< (decf n) 0)
     1309    (values nil "Disassembly:" :comment)
     1310    (let ((line (svref (disasm-info f) n)))
     1311      (if (consp line)
     1312        (destructuring-bind (object label instr) line
     1313          (values object (cons label instr) :static))
     1314        (values nil (cons nil line) :static)))))
     1315
     1316(defun disassembly-line-n-inspector (f n)
     1317  (unless (< (decf n) 0)
     1318    (let ((line (svref (disasm-info f) n)))
     1319      (and (consp line)
     1320           (car line)
     1321           (make-inspector (car line))))))
     1322
     1323(defun disassembly-line-n-strings (f n)
     1324  (if (< (decf n) 0)
     1325    (values "Disassembly:" nil)
     1326    (let ((line (svref (disasm-info f) n)))
     1327      (if (consp line)
     1328        (destructuring-bind (object label instr) line
     1329          (declare (ignore object))
     1330          (unless (stringp label)
     1331            (setq label (with-output-to-string (stream)
     1332                          (prin1-disassembly-label f stream label))))
     1333          (values label instr))
     1334        (values nil line)))))
    12641335
    12651336(defun set-disassembly-line-n (f n new-value &optional
     
    12681339  (setf-line-n-out-of-range f n))
    12691340
    1270 (defun disasm-line-immediate (line &optional (lookup-functions t))
    1271   (pop line)                        ; remove address
    1272   (when (eq (car line) 'ccl::jsr_subprim)
    1273     (return-from disasm-line-immediate (find-symbol (cadr line) :ccl)))
    1274   (let ((res nil))
    1275     (labels ((inner-last (l)
    1276                (cond ((atom l) l)
    1277                      ((null (cdr l)) (car l))
    1278                      (t (inner-last (last l))))))
    1279       (dolist (e line)
    1280         (cond ((numberp e) (when (null res) (setq res e)))
    1281               ((consp e)
    1282                (cond ((eq (car e) 'function)
    1283                       (setq res (or (and lookup-functions (fboundp (cadr e))) (cadr e))))
    1284                      ((eq (car e) 17)   ; locative
    1285                       (setq e (cadr e))
    1286                       (unless (atom e)
    1287                         (cond ((eq (car e) 'special)
    1288                                (setq res (cadr e)))
    1289                               ((eq (car e) 'function)
    1290                                (setq res (or (and lookup-functions (fboundp (cadr e))) (cadr e))))
    1291                               (t (setq res (inner-last e))))))
    1292                      ((or (null res) (numberp res))
    1293                       (setq res (inner-last e))))))))
    1294     res))
    1295 
    1296 (defmethod inspector-print-function ((i function-inspector) type)
    1297   (declare (ignore type))
    1298   'prin1-normal-line)
    1299 
    1300 (defmethod prin1-label ((f function-inspector) stream value &optional label type)
     1341(defmethod prin1-label ((f function-inspector) stream value &optional data type)
    13011342  (declare (ignore value type))
    1302   (if (atom label)                      ; not a disassembly line
     1343  (if (atom data)                      ; not a disassembly line
    13031344    (call-next-method)
    1304     (let* ((pc (car label))
    1305            (label-p (and (listp pc) (setq pc (cadr pc))))
    1306            (pc-mark (pc f)))
    1307       (if (eq pc pc-mark)
    1308         (format stream "*~vd" (pc-width f) pc)
    1309         (format stream "~vd" (+ (pc-width f) (if pc-mark 1 0)) pc))
    1310       (write-char (if label-p #\= #\ ) stream))))
     1345    (prin1-disassembly-label f stream (car data))))
     1346
     1347(defun prin1-disassembly-label (f stream label)
     1348  (let* ((pc label)
     1349         (label-p (and (consp pc) (setq pc (cadr pc))))
     1350         (pc-mark (pc f))
     1351         (pc-width (pc-width f)))
     1352    (when pc
     1353      (write-char (if (eql pc pc-mark) #\* #\Space) stream)
     1354      (format stream "~@[L~d~]~vT~v<[~d]~> " label-p (+ pc-width 3) (+ pc-width 2) pc))))
     1355
     1356#+x86-target
     1357(defmethod prin1-value ((f function-inspector) stream value &optional data type)
     1358  (declare (ignore value type))
     1359  (if (atom data) ;; not a disassembly line
     1360    (call-next-method)
     1361    (princ (cdr data) stream)))
     1362
    13111363
    13121364#+ppc-target
     
    13271379;; (They're also inside the dispatch-table which is the first immediate in the disassembly).
    13281380(defclass gf-inspector (function-inspector)
    1329   ((method-count :accessor method-count)
    1330    (slot-count :accessor slot-count :initform 0)))
     1381  ((method-count :accessor method-count)))
    13311382
    13321383(defmethod inspector-class ((f standard-generic-function))
     
    13351386    'standard-object-inspector))
    13361387
    1337 (defmethod compute-line-count ((f gf-inspector))
     1388(defmethod compute-line-count :before ((f gf-inspector))
    13381389  (let* ((gf (inspector-object f))
    1339          (count (length (generic-function-methods gf)))
    1340          (res (+ 1 (setf (method-count f) count) 
    1341                  (call-next-method))))
    1342     (if (disasm-p f) (1+ res) res)))
     1390         (count (length (generic-function-methods gf))))
     1391    (setf (method-count f) count)))
     1392
     1393(defmethod header-count ((f gf-inspector))
     1394  (+ (standard-header-count f) 1 (method-count f)))
    13431395
    13441396(defmethod line-n ((f gf-inspector) n)
    13451397  (let* ((count (method-count f))
    1346          (slot-count (slot-count f))
    1347          (lines (1+ count)))
    1348     (if (<= 3 n (+ lines slot-count 3))
    1349       (let ((methods (generic-function-methods (inspector-object f))))
    1350         (cond ((eql (decf n 3) 0) (values methods "Methods: " :static))
    1351               ((<= n count)
    1352                (values (nth (- n 1) methods) nil :static))
    1353               ((< (decf n (1+ count)) slot-count)
    1354                (standard-object-line-n f n))
    1355               (t
    1356                (values 0 "Disassembly" :comment #'prin1-comment))))
    1357       (call-next-method f (if (< n 3) n (- n lines slot-count 1))))))
     1398         (methods (generic-function-methods (inspector-object f))))
     1399    (cond ((< (decf n  (standard-header-count f)) 0)
     1400           (call-next-method))
     1401          ((< (decf n) 0)
     1402           (values methods "Methods: " :comment))
     1403          ((< n count)
     1404           (values (nth n methods) nil :static))
     1405          (t (disassembly-line-n f (- n count))))))
    13581406
    13591407(defmethod (setf line-n) (new-value (f gf-inspector) n)
    13601408  (let* ((count (method-count f))
    1361          (slot-count (slot-count f))
    1362          (lines (1+ count)))
    1363     (if (<= 3 n (+ lines slot-count 3))
    1364       (let ((en n))
    1365         (cond ((<= (decf en 3) count)
    1366                (setf-line-n-out-of-range f n))
    1367               ((< (decf en (1+ count)) slot-count)
    1368                (standard-object-setf-line-n new-value f en))
    1369               (t (setf-line-n-out-of-range f n))))
    1370       (call-next-method new-value f (if (< n 3) n (- n lines slot-count 1))))))
     1409         (en n))
     1410    (cond ((< (decf n (standard-header-count f)) 0)
     1411           (call-next-method))
     1412          ((< (decf n) count)
     1413           (setf-line-n-out-of-range f en))
     1414          (t (set-disassembly-line-n f (- n count) new-value)))))
    13711415
    13721416#|
     
    13831427      (call-next-method))))
    13841428|#
    1385 
    1386 (defclass method-inspector (standard-object-inspector function-inspector)
    1387   ((standard-object-lines :accessor standard-object-lines)))
    1388 
    1389 (defmethod inspector-class ((object standard-method))
    1390   'method-inspector)
    1391 
    1392 (defmethod compute-line-count ((i method-inspector))
    1393   (+ (setf (standard-object-lines i) (call-next-method))
    1394      (if (disasm-p i) 1 0)              ; "Disassembly"
    1395      (compute-disassembly-lines i (method-function (inspector-object i)))))
    1396 
    1397 (defmethod line-n ((i method-inspector) n)
    1398   (let ((sol (standard-object-lines i)))
    1399     (cond ((< n sol) (call-next-method))
    1400           ((eql n sol) (values nil "Disassembly" :comment))
    1401           (t (disassembly-line-n i (- n sol 1))))))
    1402 
    1403 (defmethod (setf line-n) (new-value (i method-inspector) n)
    1404   (let ((sol (standard-object-lines i)))
    1405     (cond ((< n sol) (call-next-method))
    1406           ((eql n sol) (setf-line-n-out-of-range i n))
    1407           (t (set-disassembly-line-n
    1408               i n new-value (method-function (inspector-object i)))))))
    1409 
    1410 ;;; funtion-inspector never does prin1-comment.
    1411 (defmethod prin1-normal-line ((i method-inspector) stream value &optional
    1412                               label type colon-p)
    1413   (declare (ignore colon-p))
    1414   (if (eq type :comment)
    1415     (prin1-comment i stream value label type)
    1416     (call-next-method)))
    1417 
    14181429
    14191430;;;;;;;
     
    15651576
    15661577(defmethod initialize-addresses ((f error-frame))
    1567   (let* ((addresses (list-to-vector (ccl::%stack-frames-in-context (context f)))))
     1578  (let* ((addresses (coerce (ccl::%stack-frames-in-context (context f)) 'vector)))
    15681579      (setf (frame-count f) (length addresses)
    15691580            (addresses f) addresses)))
     
    17861797(defmethod ui-present ((ui inspector-tty-ui))
    17871798  (let* ((inspector (inspector-ui-inspector ui)))
    1788     (when (null (inspector-line-count inspector))
    1789       (update-line-count inspector))
    17901799    (with-errorfree-printing
    17911800        (let* ((stream *debug-io*)
     
    17951804               (n (compute-line-count inspector))
    17961805               (end (min page-end n))
    1797                (tag origin)
     1806               (tag -1)
    17981807               (*print-pretty* (or *print-pretty* *describe-pretty*))
    17991808               (*print-length* 5)
    18001809               (*print-level* 5)
    1801                (func #'(lambda (i value &rest rest)
    1802                          (declare (dynamic-extent rest))
    1803                          (let* ((type (cadr rest)))
    1804                            (unless (or (eq type :comment)
    1805                                    (and (consp type)
    1806                                         (eq (car type) :comment)))
    1807                              (format stream "[~d] " tag))
    1808                            (incf tag))
    1809                          (format stream "~8t")
    1810                          (apply #'prin1-line i stream value rest)
    1811                          (terpri stream))))
     1810               (func #'(lambda (i index child &optional label-string value-string)
     1811                         (declare (ignore i))
     1812                         (when child (incf tag))
     1813                         (unless (< index origin)
     1814                           (format stream "~@[[~d]~]~8t" (and child tag))
     1815                           (format-line-for-tty stream label-string value-string)
     1816                           (terpri stream)))))
    18121817          (declare (dynamic-extent func))
    1813           (map-lines inspector func origin end)))
     1818          (map-lines inspector func 0 end)))
    18141819    (values)))
    18151820
     
    18931898
    18941899(defmethod inspector-ui-inspect-nth ((ui inspector-tty-ui) n)
    1895   (let* ((inspector (inspector-ui-inspector ui)))
    1896     (multiple-value-bind (value label type)
    1897         (line-n inspector n)
    1898       (unless (or (eq type :comment)
    1899                   (and (consp type) (eq (car type) :comment)))
    1900         (let* ((new-inspector (line-n-inspector inspector n value label type))
    1901                (ccl::@ value))
    1902           (inspector-ui-inspect
    1903            (make-instance 'inspector-tty-ui
    1904                           :level (1+ (inspector-ui-level ui))
    1905                           :inspector new-inspector)))))))
    1906      
     1900  (let* ((inspector (inspector-ui-inspector ui))
     1901         (new-inspector (block nil
     1902                          (let* ((tag -1)
     1903                                 (func #'(lambda (i index child &rest strings)
     1904                                           (declare (ignore i index strings))
     1905                                           (when (and child (eql (incf tag) n)) (return child)))))
     1906                            (declare (dynamic-extent func))
     1907                            (map-lines inspector func))))
     1908         (ccl::@ (inspector-object new-inspector)))
     1909    (inspector-ui-inspect
     1910     (make-instance 'inspector-tty-ui
     1911       :level (1+ (inspector-ui-level ui))
     1912       :inspector new-inspector))))
     1913
    19071914(defparameter *default-inspector-ui-class-name* 'inspector-tty-ui)
    19081915
  • branches/working-0711/ccl/lib/misc.lisp

    r12935 r12949  
    774774  disassemble."
    775775  (#+ppc-target ppc-xdisassemble
    776    #+x8632-target x8632-xdisassemble
    777    #+x8664-target x8664-xdisassemble
     776   #+x86-target x86-xdisassemble
    778777   (require-type (function-for-disassembly thing) 'compiled-function)))
    779778
Note: See TracChangeset for help on using the changeset viewer.