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

Last change on this file since 8164 was 8164, checked in by piso, 17 years ago

Work in progress.

File size: 6.6 KB
Line 
1;;; inspect.lisp
2;;;
3;;; Copyright (C) 2003-2004 Peter Graves
4;;; $Id: inspect.lisp,v 1.10 2004-11-18 15:47:58 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* 1)
48        (*print-level* 1))
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          ((vectorp 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 (inspected-description (aref obj i))))))
66          ((consp obj)
67           (multiple-value-bind (len kind) (safe-length obj)
68             (case kind
69               (:proper
70                (format t "A proper list with ~D elements at #x~X~%"
71                        len
72                        (identity-hash-code obj))
73                (let ((i 0))
74                  (dolist (item obj)
75                    (cond ((< i 25)
76                           (format t "~4D-> ~A~%" i item))
77                          ((= i 25)
78                           (format t "    ...~%"))
79                          ((= i (1- len))
80                           (format t "~4D-> ~A~%" i item)))
81                    (incf i))))
82               (:dotted
83                (format t "A dotted list with ~D elements at #x~X~%"
84                        len
85                        (identity-hash-code obj))
86                (let* ((rest obj)
87                       (item (car rest))
88                       (i 0))
89                  (loop
90                    (cond ((< i 25)
91                           (format t "~4D-> ~A~%" i (inspected-description item)))
92                          ((= i 25)
93                           (format t "    ...~%")))
94                    (incf i)
95                    (setf rest (cdr rest))
96                    (when (atom rest)
97                      (return))
98                    (setf item (car rest)))
99                  (format t "tail-> ~A~%" (inspected-description rest))))
100               (:circular
101                (format t "A circular list at #x~X~%" (identity-hash-code obj))))))
102          (t
103           (format t "~A at #x~X~%" (inspected-description obj) (identity-hash-code obj))
104           (let ((parts (inspected-parts obj))
105                 (i 0)
106                 (limit 25))
107             (dolist (part parts)
108               (let ((name (string (car part)))
109                     (value (cdr part)))
110                 (format t "~4D ~A ~A ~S~%" i
111                         name
112                         (leader name)
113                         value)
114                 (incf i)
115                 (when (> i limit)
116                   (return))))))))
117  (values))
118
119(defun display-current ()
120  (if *inspect-break*
121      (display-object *inspected-object* t)
122      (format t "No object is being inspected.")))
123
124(defun inspect (obj)
125  (when *inspected-object*
126    (push *inspected-object* *inspected-object-stack*))
127  (setf *inspected-object* obj)
128  (let ((*inspect-break* t)
129        (*debug-level* (1+ *debug-level*)))
130    (display-current)
131    (catch 'inspect-exit
132      (tpl::repl)))
133  (values))
134
135(defun istep (args)
136  (if (null args)
137      (display-current)
138      (let* ((pos (position #\space args))
139             (option-string (if pos (subseq args 0 pos) args))
140             (option (read-from-string option-string)))
141        (cond ((string= option-string "-")
142               (if *inspected-object-stack*
143                   (progn
144                     (setf *inspected-object* (pop *inspected-object-stack*))
145                     (display-current))
146                   (format t "Object has no parent.")))
147              ((string= option-string "q")
148               (setf *inspected-object* nil
149                     *inspected-object-stack* nil
150                     *inspect-break* nil)
151               (throw 'inspect-exit nil))
152              ((fixnump option)
153               (let* ((index option)
154                      (parts (inspected-parts *inspected-object*)))
155                 (cond ((null parts)
156                        (if (typep *inspected-object* 'sequence)
157                            (if (or (minusp index)
158                                    (>= index (length *inspected-object*)))
159                                (format t "Invalid index (~D)." index)
160                                (progn
161                                  (push *inspected-object* *inspected-object-stack*)
162                                  (setf *inspected-object*
163                                        (elt *inspected-object* index))
164                                  (display-current)))
165                            (format t "Object has no selectable components.")))
166                       ((or (minusp index)
167                            (>= index (length parts)))
168                        (format t "Invalid index (~D)." index))
169                       (t
170                        (push *inspected-object* *inspected-object-stack*)
171                        (setf *inspected-object* (cdr (elt parts index)))
172                        (display-current)))))))))
Note: See TracBrowser for help on using the repository browser.