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

Last change on this file since 11391 was 11391, checked in by vvoutilainen, 13 years ago

ABCL license is GPL + Classpath exception. This was intended
by Peter Graves, the original author. For reference, see
http://sourceforge.net/mailarchive/forum.php?thread_name=20040721115302.839%40prufrock&forum_name=armedbear-j-announce

  • 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 11391 2008-11-15 22:38:34Z vvoutilainen $
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  (when *inspected-object*
143    (push *inspected-object* *inspected-object-stack*))
144  (setf *inspected-object* obj)
145  (let* ((*inspect-break* t)
146         (*debug-level* (1+ *debug-level*)))
147    (setf *** **
148          ** *
149          * obj)
150    (display-current)
151    (catch 'inspect-exit
152      (tpl::repl)))
153  (setf *** **
154        ** *
155        * obj)
156  (values))
157
158(defun istep (args)
159  (if (null args)
160      (display-current)
161      (let* ((pos (position #\space args))
162             (option-string (if pos (subseq args 0 pos) args))
163             (option (read-from-string option-string)))
164        (cond ((string= option-string "-")
165               (if *inspected-object-stack*
166                   (progn
167                     (setf *inspected-object* (pop *inspected-object-stack*))
168                     (setf *** **
169                           ** *
170                           * *inspected-object*)
171                     (display-current))
172                   (format t "Object has no parent.")))
173              ((string= option-string "q")
174               (setf *inspected-object* nil
175                     *inspected-object-stack* nil
176                     *inspect-break* nil)
177               (throw 'inspect-exit nil))
178              ((fixnump option)
179               (let* ((index option)
180                      (parts (inspected-parts *inspected-object*)))
181                 (cond ((null parts)
182                        (if (typep *inspected-object* 'sequence)
183                            (if (or (minusp index)
184                                    (>= index (length *inspected-object*)))
185                                (format t "Invalid index (~D)." index)
186                                (progn
187                                  (push *inspected-object* *inspected-object-stack*)
188                                  (setf *inspected-object*
189                                        (elt *inspected-object* index))
190                                  (setf * *inspected-object*)
191                                  (display-current)))
192                            (format t "Object has no selectable components.")))
193                       ((or (minusp index)
194                            (>= index (length parts)))
195                        (format t "Invalid index (~D)." index))
196                       (t
197                        (push *inspected-object* *inspected-object-stack*)
198                        (setf *inspected-object* (cdr (elt parts index)))
199                        (setf * *inspected-object*)
200                        (display-current)))))))))
Note: See TracBrowser for help on using the repository browser.