source: trunk/j/src/org/armedbear/lisp/inspect.lisp @ 9266

Last change on this file since 9266 was 8898, checked in by piso, 16 years ago

Work in progress.

File size: 7.1 KB
Line 
1;;; inspect.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: inspect.lisp,v 1.12 2005-04-08 12:44:25 piso Exp $
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(in-package #:system)
21
22(require 'clos)
23
24(require 'format)
25
26(defun leader (name)
27  (let ((size (max 0 (- 12 (length (string name))))))
28    (concatenate 'string (make-string size :initial-element #\-) "->")))
29
30(defun safe-length (x)
31  (do ((n 0 (+ n 2))
32       (fast x (cddr fast))
33       (slow x (cdr slow)))
34      (())
35    (when (null fast)
36      (return (values n :proper)))
37    (when (atom fast)
38      (return (values n :dotted)))
39    (when (null (cdr fast))
40      (return (values (+ n 1) :proper)))
41    (when (atom (cdr fast))
42      (return (values (+ n 1) :dotted)))
43    (when (and (eq fast slow) (> n 0))
44      (return (values nil :circular)))))
45
46(defun display-object (obj display-parts-p)
47  (let ((*print-length* 2)
48        (*print-level* 2))
49    (cond ((typep obj 'standard-object)
50           (let ((parts (inspected-parts obj))
51                 (i 0))
52             (dolist (part parts)
53               (let ((name (car part))
54                     (value (cdr part)))
55                 (format t "~4D ~A ~A ~S~%"
56                         i
57                         name
58                         (leader name)
59                         value)
60                 (incf i)))))
61          ((simple-vector-p obj)
62           (format t "~A at #x~X~%" (inspected-description obj) (identity-hash-code obj))
63           (let ((limit (min (length obj) 25)))
64             (dotimes (i limit)
65               (format t "~4D-> ~A~%" i (aref obj i)))))
66          ((vectorp obj)
67           (format t "~A~%" (inspected-description obj))
68           (let ((limit (min (length obj) 25)))
69             (dotimes (i limit)
70               (format t "~4D-> ~A~%" i (aref obj i)))))
71          ((consp obj)
72           (multiple-value-bind (len kind) (safe-length obj)
73             (case kind
74               (:proper
75                (format t "A proper list with ~D elements at #x~X~%"
76                        len
77                        (identity-hash-code obj))
78                (let ((i 0))
79                  (dolist (item obj)
80                    (cond ((< i 25)
81                           (format t "~4D-> ~S~%" i item))
82                          ((= i 25)
83                           (format t "    ...~%"))
84                          ((= i (1- len))
85                           (format t "~4D-> ~S~%" i item)))
86                    (incf i))))
87               (:dotted
88                (format t "A dotted list with ~D elements at #x~X~%"
89                        len
90                        (identity-hash-code obj))
91                (let* ((rest obj)
92                       (item (car rest))
93                       (i 0))
94                  (loop
95                    (cond ((< i 25)
96                           (format t "~4D-> ~S~%" i item))
97                          ((= i 25)
98                           (format t "    ...~%")))
99                    (incf i)
100                    (setf rest (cdr rest))
101                    (when (atom rest)
102                      (return))
103                    (setf item (car rest)))
104                  (format t "tail-> ~S~%" rest)))
105               (:circular
106                (format t "A circular list at #x~X~%" (identity-hash-code obj))))))
107          (t
108           (format t "~A~%" (inspected-description obj))
109           (let ((parts (inspected-parts obj))
110                 (i 0)
111                 (limit 25))
112             (dolist (part parts)
113               (let ((name (string (car part)))
114                     (value (cdr part)))
115                 (format t "~4D ~A ~A ~S~%" i
116                         name
117                         (leader name)
118                         value)
119                 (incf i)
120                 (when (> i limit)
121                   (return))))))))
122  (values))
123
124(defun display-current ()
125  (if *inspect-break*
126      (display-object *inspected-object* t)
127      (format t "No object is being inspected.")))
128
129(defun inspect (obj)
130  (when *inspected-object*
131    (push *inspected-object* *inspected-object-stack*))
132  (setf *inspected-object* obj)
133  (let* ((*inspect-break* t)
134         (*debug-level* (1+ *debug-level*)))
135    (setf *** **
136          ** *
137          * obj)
138    (display-current)
139    (catch 'inspect-exit
140      (tpl::repl)))
141  (setf *** **
142        ** *
143        * obj)
144  (values))
145
146(defun istep (args)
147  (if (null args)
148      (display-current)
149      (let* ((pos (position #\space args))
150             (option-string (if pos (subseq args 0 pos) args))
151             (option (read-from-string option-string)))
152        (cond ((string= option-string "-")
153               (if *inspected-object-stack*
154                   (progn
155                     (setf *inspected-object* (pop *inspected-object-stack*))
156                     (setf *** **
157                           ** *
158                           * *inspected-object*)
159                     (display-current))
160                   (format t "Object has no parent.")))
161              ((string= option-string "q")
162               (setf *inspected-object* nil
163                     *inspected-object-stack* nil
164                     *inspect-break* nil)
165               (throw 'inspect-exit nil))
166              ((fixnump option)
167               (let* ((index option)
168                      (parts (inspected-parts *inspected-object*)))
169                 (cond ((null parts)
170                        (if (typep *inspected-object* 'sequence)
171                            (if (or (minusp index)
172                                    (>= index (length *inspected-object*)))
173                                (format t "Invalid index (~D)." index)
174                                (progn
175                                  (push *inspected-object* *inspected-object-stack*)
176                                  (setf *inspected-object*
177                                        (elt *inspected-object* index))
178                                  (setf * *inspected-object*)
179                                  (display-current)))
180                            (format t "Object has no selectable components.")))
181                       ((or (minusp index)
182                            (>= index (length parts)))
183                        (format t "Invalid index (~D)." index))
184                       (t
185                        (push *inspected-object* *inspected-object-stack*)
186                        (setf *inspected-object* (cdr (elt parts index)))
187                        (setf * *inspected-object*)
188                        (display-current)))))))))
Note: See TracBrowser for help on using the repository browser.