source: trunk/abcl/src/org/armedbear/lisp/inspect.lisp @ 11490

Last change on this file since 11490 was 11490, checked in by ehuelsmann, 12 years ago

Implement CDR6: *inspector-hook*.

This implements feature request ticket #9.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 7.8 KB
Line 
1;;; inspect.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: inspect.lisp 11490 2008-12-27 14:59:26Z ehuelsmann $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package #:system)
33
34(require 'clos)
35
36(require 'format)
37
38(defun leader (name)
39  (let ((size (max 0 (- 16 (length (string name))))))
40    (concatenate 'string (make-string size :initial-element #\-) "->")))
41
42(defun safe-length (x)
43  (do ((n 0 (+ n 2))
44       (fast x (cddr fast))
45       (slow x (cdr slow)))
46      (())
47    (when (null fast)
48      (return (values n :proper)))
49    (when (atom fast)
50      (return (values n :dotted)))
51    (when (null (cdr fast))
52      (return (values (+ n 1) :proper)))
53    (when (atom (cdr fast))
54      (return (values (+ n 1) :dotted)))
55    (when (and (eq fast slow) (> n 0))
56      (return (values nil :circular)))))
57
58(defun display-object (obj)
59  (let ((*print-length* 2)
60        (*print-level* 2))
61    (cond ((typep obj 'standard-object)
62           (let ((parts (inspected-parts obj))
63                 (i 0))
64             (dolist (part parts)
65               (let ((name (car part))
66                     (value (cdr part)))
67                 (format t "~4D ~A ~A ~S~%"
68                         i
69                         name
70                         (leader name)
71                         value)
72                 (incf i)))))
73          ((simple-vector-p obj)
74           (format t "~A at #x~X~%" (inspected-description obj) (identity-hash-code obj))
75           (let ((limit (min (length obj) 25)))
76             (dotimes (i limit)
77               (format t "~4D-> ~A~%" i (aref obj i)))))
78          ((vectorp obj)
79           (format t "~A~%" (inspected-description obj))
80           (let ((limit (min (length obj) 25)))
81             (dotimes (i limit)
82               (format t "~4D-> ~A~%" i (aref obj i)))))
83          ((consp obj)
84           (multiple-value-bind (len kind) (safe-length obj)
85             (case kind
86               (:proper
87                (format t "A proper list with ~D elements at #x~X~%"
88                        len
89                        (identity-hash-code obj))
90                (let ((i 0))
91                  (dolist (item obj)
92                    (cond ((< i 25)
93                           (format t "~4D-> ~S~%" i item))
94                          ((= i 25)
95                           (format t "    ...~%"))
96                          ((= i (1- len))
97                           (format t "~4D-> ~S~%" i item)))
98                    (incf i))))
99               (:dotted
100                (format t "A dotted list with ~D elements at #x~X~%"
101                        len
102                        (identity-hash-code obj))
103                (let* ((rest obj)
104                       (item (car rest))
105                       (i 0))
106                  (loop
107                    (cond ((< i 25)
108                           (format t "~4D-> ~S~%" i item))
109                          ((= i 25)
110                           (format t "    ...~%")))
111                    (incf i)
112                    (setf rest (cdr rest))
113                    (when (atom rest)
114                      (return))
115                    (setf item (car rest)))
116                  (format t "tail-> ~S~%" rest)))
117               (:circular
118                (format t "A circular list at #x~X~%" (identity-hash-code obj))))))
119          (t
120           (format t "~A~%" (inspected-description obj))
121           (let ((parts (inspected-parts obj))
122                 (i 0)
123                 (limit 25))
124             (dolist (part parts)
125               (let ((name (string (car part)))
126                     (value (cdr part)))
127                 (format t "~4D ~A ~A ~S~%" i
128                         name
129                         (leader name)
130                         value)
131                 (incf i)
132                 (when (> i limit)
133                   (return))))))))
134  (values))
135
136(defun display-current ()
137  (if *inspect-break*
138      (display-object *inspected-object*)
139      (format t "No object is being inspected.")))
140
141(defun inspect (obj)
142  (unless ext:*inspector-hook*
143    (funcall ext:*inspector-hook* obj))
144  (when *inspected-object*
145    (push *inspected-object* *inspected-object-stack*))
146  (setf *inspected-object* obj)
147  (let* ((*inspect-break* t)
148         (*debug-level* (1+ *debug-level*)))
149    (setf *** **
150          ** *
151          * obj)
152    (display-current)
153    (catch 'inspect-exit
154      (tpl::repl)))
155  (setf *** **
156        ** *
157        * obj)
158  (values))
159
160(defun istep (args)
161  (if (null args)
162      (display-current)
163      (let* ((pos (position #\space args))
164             (option-string (if pos (subseq args 0 pos) args))
165             (option (read-from-string option-string)))
166        (cond ((string= option-string "-")
167               (if *inspected-object-stack*
168                   (progn
169                     (setf *inspected-object* (pop *inspected-object-stack*))
170                     (setf *** **
171                           ** *
172                           * *inspected-object*)
173                     (display-current))
174                   (format t "Object has no parent.")))
175              ((string= option-string "q")
176               (setf *inspected-object* nil
177                     *inspected-object-stack* nil
178                     *inspect-break* nil)
179               (throw 'inspect-exit nil))
180              ((fixnump option)
181               (let* ((index option)
182                      (parts (inspected-parts *inspected-object*)))
183                 (cond ((null parts)
184                        (if (typep *inspected-object* 'sequence)
185                            (if (or (minusp index)
186                                    (>= index (length *inspected-object*)))
187                                (format t "Invalid index (~D)." index)
188                                (progn
189                                  (push *inspected-object* *inspected-object-stack*)
190                                  (setf *inspected-object*
191                                        (elt *inspected-object* index))
192                                  (setf * *inspected-object*)
193                                  (display-current)))
194                            (format t "Object has no selectable components.")))
195                       ((or (minusp index)
196                            (>= index (length parts)))
197                        (format t "Invalid index (~D)." index))
198                       (t
199                        (push *inspected-object* *inspected-object-stack*)
200                        (setf *inspected-object* (cdr (elt parts index)))
201                        (setf * *inspected-object*)
202                        (display-current)))))))))
Note: See TracBrowser for help on using the repository browser.