1 |
|
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
2 |
|
|
3 |
|
;; This file is part of GNU Common Lisp, herein referred to as GCL |
4 |
|
;; |
5 |
|
;; GCL is free software; you can redistribute it and/or modify it under |
6 |
|
;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by |
7 |
|
;; the Free Software Foundation; either version 2, or (at your option) |
8 |
|
;; any later version. |
9 |
|
;; |
10 |
|
;; GCL is distributed in the hope that it will be useful, but WITHOUT |
11 |
|
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
12 |
|
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public |
13 |
|
;; License for more details. |
14 |
|
;; |
15 |
|
;; You should have received a copy of the GNU Library General Public License |
16 |
|
;; along with GCL; see the file COPYING. If not, write to the Free Software |
17 |
|
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
18 |
|
|
19 |
|
|
20 |
|
;;;; describe.lsp |
21 |
|
;;;; |
22 |
|
;;;; DESCRIBE and INSPECT |
23 |
|
|
24 |
|
|
25 |
|
(in-package 'lisp) |
26 |
|
|
27 |
|
(export '(describe inspect)) |
28 |
|
|
29 |
|
|
30 |
|
(in-package 'system) |
31 |
|
|
32 |
|
|
33 |
|
(proclaim '(optimize (safety 2) (space 3))) |
34 |
|
|
35 |
|
|
36 |
|
(defvar *inspect-level* 0) |
37 |
|
(defvar *inspect-history* nil) |
38 |
|
(defvar *inspect-mode* nil) |
39 |
|
|
40 |
|
(defvar *old-print-level* nil) |
41 |
|
(defvar *old-print-length* nil) |
42 |
|
|
43 |
|
|
44 |
|
(defun inspect-read-line () |
45 |
|
(do ((char (read-char *query-io*) (read-char *query-io*))) |
46 |
|
((or (char= char #\Newline) (char= char #\Return))))) |
47 |
|
|
48 |
|
(defun read-inspect-command (label object allow-recursive) |
49 |
|
(unless *inspect-mode* |
50 |
|
(inspect-indent-1) |
51 |
|
(if allow-recursive |
52 |
|
(progn (princ label) (inspect-object object)) |
53 |
|
(format t label object)) |
54 |
|
(return-from read-inspect-command nil)) |
55 |
|
(loop |
56 |
|
(inspect-indent-1) |
57 |
|
(if allow-recursive |
58 |
|
(progn (princ label) |
59 |
|
(inspect-indent) |
60 |
|
(prin1 object)) |
61 |
|
(format t label object)) |
62 |
|
(write-char #\Space) |
63 |
|
(force-output) |
64 |
|
(case (do ((char (read-char *query-io*) (read-char *query-io*))) |
65 |
|
((and (char/= char #\Space) (char/= #\Tab)) char)) |
66 |
|
((#\Newline #\Return) |
67 |
|
(when allow-recursive (inspect-object object)) |
68 |
|
(return nil)) |
69 |
|
((#\n #\N) |
70 |
|
(inspect-read-line) |
71 |
|
(when allow-recursive (inspect-object object)) |
72 |
|
(return nil)) |
73 |
|
((#\s #\S) (inspect-read-line) (return nil)) |
74 |
|
((#\p #\P) |
75 |
|
(inspect-read-line) |
76 |
|
(let ((*print-pretty* t) (*print-level* nil) (*print-length* nil)) |
77 |
|
(prin1 object) |
78 |
|
(terpri))) |
79 |
|
((#\a #\A) (inspect-read-line) (throw 'abort-inspect nil)) |
80 |
|
((#\u #\U) |
81 |
|
(return (values t (prog1 |
82 |
|
(eval (read-preserving-whitespace *query-io*)) |
83 |
|
(inspect-read-line))))) |
84 |
|
((#\e #\E) |
85 |
|
(dolist (x (multiple-value-list |
86 |
|
(multiple-value-prog1 |
87 |
|
(eval (read-preserving-whitespace *query-io*)) |
88 |
|
(inspect-read-line)))) |
89 |
|
(write x |
90 |
|
:level *old-print-level* |
91 |
|
:length *old-print-length*) |
92 |
|
(terpri))) |
93 |
|
((#\q #\Q) (inspect-read-line) (throw 'quit-inspect nil)) |
94 |
|
(t (inspect-read-line) |
95 |
|
(terpri) |
96 |
|
(format t |
97 |
|
"Inspect commands:~%~ |
98 |
|
n (or N or Newline): inspects the field (recursively).~%~ |
99 |
|
s (or S): skips the field.~%~ |
100 |
|
p (or P): pretty-prints the field.~%~ |
101 |
|
a (or A): aborts the inspection ~ |
102 |
|
of the rest of the fields.~%~ |
103 |
|
u (or U) form: updates the field ~ |
104 |
|
with the value of the form.~%~ |
105 |
|
e (or E) form: evaluates and prints the form.~%~ |
106 |
|
q (or Q): quits the inspection.~%~ |
107 |
|
?: prints this.~%~%"))))) |
108 |
|
|
109 |
|
(defmacro inspect-recursively (label object &optional place) |
110 |
|
(if place |
111 |
|
`(multiple-value-bind (update-flag new-value) |
112 |
|
(read-inspect-command ,label ,object t) |
113 |
|
(when update-flag (setf ,place new-value))) |
114 |
|
`(when (read-inspect-command ,label ,object t) |
115 |
|
(princ "Not updated.") |
116 |
|
(terpri)))) |
117 |
|
|
118 |
|
(defmacro inspect-print (label object &optional place) |
119 |
|
(if place |
120 |
|
`(multiple-value-bind (update-flag new-value) |
121 |
|
(read-inspect-command ,label ,object nil) |
122 |
|
(when update-flag (setf ,place new-value))) |
123 |
|
`(when (read-inspect-command ,label ,object nil) |
124 |
|
(princ "Not updated.") |
125 |
|
(terpri)))) |
126 |
|
|
127 |
|
(defun inspect-indent () |
128 |
|
(fresh-line) |
129 |
|
(format t "~V@T" |
130 |
|
(* 4 (if (< *inspect-level* 8) *inspect-level* 8)))) |
131 |
|
|
132 |
|
(defun inspect-indent-1 () |
133 |
|
(fresh-line) |
134 |
|
(format t "~V@T" |
135 |
|
(- (* 4 (if (< *inspect-level* 8) *inspect-level* 8)) 3))) |
136 |
|
|
137 |
|
|
138 |
|
(defun inspect-symbol (symbol) |
139 |
|
(let ((p (symbol-package symbol))) |
140 |
|
(cond ((null p) |
141 |
|
(format t "~:@(~S~) - uninterned symbol" symbol)) |
142 |
|
((eq p (find-package "KEYWORD")) |
143 |
|
(format t "~:@(~S~) - keyword" symbol)) |
144 |
|
(t |
145 |
|
(format t "~:@(~S~) - ~:[internal~;external~] symbol in ~A package" |
146 |
|
symbol |
147 |
|
(multiple-value-bind (b f) |
148 |
|
(find-symbol (symbol-name symbol) p) |
149 |
|
(declare (ignore b)) |
150 |
|
(eq f :external)) |
151 |
|
(package-name p))))) |
152 |
|
|
153 |
|
(when (boundp symbol) |
154 |
|
(if *inspect-mode* |
155 |
|
(inspect-recursively "value:" |
156 |
|
(symbol-value symbol) |
157 |
|
(symbol-value symbol)) |
158 |
|
(inspect-print "value:~% ~S" |
159 |
|
(symbol-value symbol) |
160 |
|
(symbol-value symbol)))) |
161 |
|
|
162 |
|
(do ((pl (symbol-plist symbol) (cddr pl))) |
163 |
|
((endp pl)) |
164 |
|
(unless (and (symbolp (car pl)) |
165 |
|
(or (eq (symbol-package (car pl)) (find-package 'system)) |
166 |
|
(eq (symbol-package (car pl)) (find-package 'compiler)))) |
167 |
|
(if *inspect-mode* |
168 |
|
(inspect-recursively (format nil "property ~S:" (car pl)) |
169 |
|
(cadr pl) |
170 |
|
(get symbol (car pl))) |
171 |
|
(inspect-print (format nil "property ~:@(~S~):~% ~~S" (car pl)) |
172 |
|
(cadr pl) |
173 |
|
(get symbol (car pl)))))) |
174 |
|
|
175 |
|
(when (print-doc symbol t) |
176 |
|
(format t "~&-----------------------------------------------------------------------------~%")) |
177 |
|
) |
178 |
|
|
179 |
|
(defun inspect-package (package) |
180 |
|
(format t "~S - package" package) |
181 |
|
(when (package-nicknames package) |
182 |
|
(inspect-print "nicknames: ~S" (package-nicknames package))) |
183 |
|
(when (package-use-list package) |
184 |
|
(inspect-print "use list: ~S" (package-use-list package))) |
185 |
|
(when (package-used-by-list package) |
186 |
|
(inspect-print "used-by list: ~S" (package-used-by-list package))) |
187 |
|
(when (package-shadowing-symbols package) |
188 |
|
(inspect-print "shadowing symbols: ~S" |
189 |
|
(package-shadowing-symbols package)))) |
190 |
|
|
191 |
|
(defun inspect-character (character) |
192 |
|
(format t |
193 |
|
(cond ((standard-char-p character) "~S - standard character") |
194 |
|
((string-char-p character) "~S - string character") |
195 |
|
(t "~S - character")) |
196 |
|
character) |
197 |
|
(inspect-print "code: #x~X" (char-code character)) |
198 |
|
(inspect-print "bits: ~D" (char-bits character)) |
199 |
|
(inspect-print "font: ~D" (char-font character))) |
200 |
|
|
201 |
|
(defun inspect-number (number) |
202 |
|
(case (type-of number) |
203 |
|
(fixnum (format t "~S - fixnum (32 bits)" number)) |
204 |
|
(bignum (format t "~S - bignum" number)) |
205 |
|
(ratio |
206 |
|
(format t "~S - ratio" number) |
207 |
|
(inspect-recursively "numerator:" (numerator number)) |
208 |
|
(inspect-recursively "denominator:" (denominator number))) |
209 |
|
(complex |
210 |
|
(format t "~S - complex" number) |
211 |
|
(inspect-recursively "real part:" (realpart number)) |
212 |
|
(inspect-recursively "imaginary part:" (imagpart number))) |
213 |
|
((short-float single-float) |
214 |
|
(format t "~S - short-float" number) |
215 |
|
(multiple-value-bind (signif expon sign) |
216 |
|
(integer-decode-float number) |
217 |
|
(declare (ignore sign)) |
218 |
|
(inspect-print "exponent: ~D" expon) |
219 |
|
(inspect-print "mantissa: ~D" signif))) |
220 |
|
((long-float double-float) |
221 |
|
(format t "~S - long-float" number) |
222 |
|
(multiple-value-bind (signif expon sign) |
223 |
|
(integer-decode-float number) |
224 |
|
(declare (ignore sign)) |
225 |
|
(inspect-print "exponent: ~D" expon) |
226 |
|
(inspect-print "mantissa: ~D" signif))))) |
227 |
|
|
228 |
|
(defun inspect-cons (cons) |
229 |
|
(format t |
230 |
|
(case (car cons) |
231 |
|
((lambda lambda-block lambda-closure lambda-block-closure) |
232 |
|
"~S - function") |
233 |
|
(quote "~S - constant") |
234 |
|
(t "~S - cons")) |
235 |
|
cons) |
236 |
|
(when *inspect-mode* |
237 |
|
(do ((i 0 (1+ i)) |
238 |
|
(l cons (cdr l))) |
239 |
|
((atom l) |
240 |
|
(inspect-recursively (format nil "nthcdr ~D:" i) |
241 |
|
l (cdr (nthcdr (1- i) cons)))) |
242 |
|
(inspect-recursively (format nil "nth ~D:" i) |
243 |
|
(car l) (nth i cons))))) |
244 |
|
|
245 |
|
(defun inspect-string (string) |
246 |
|
(format t (if (simple-string-p string) "~S - simple string" "~S - string") |
247 |
|
string) |
248 |
|
(inspect-print "dimension: ~D"(array-dimension string 0)) |
249 |
|
(when (array-has-fill-pointer-p string) |
250 |
|
(inspect-print "fill pointer: ~D" |
251 |
|
(fill-pointer string) |
252 |
|
(fill-pointer string))) |
253 |
|
(when *inspect-mode* |
254 |
|
(dotimes (i (array-dimension string 0)) |
255 |
|
(inspect-recursively (format nil "aref ~D:" i) |
256 |
|
(char string i) |
257 |
|
(char string i))))) |
258 |
|
|
259 |
|
(defun inspect-vector (vector) |
260 |
|
(format t (if (simple-vector-p vector) "~S - simple vector" "~S - vector") |
261 |
|
vector) |
262 |
|
(inspect-print "dimension: ~D" (array-dimension vector 0)) |
263 |
|
(when (array-has-fill-pointer-p vector) |
264 |
|
(inspect-print "fill pointer: ~D" |
265 |
|
(fill-pointer vector) |
266 |
|
(fill-pointer vector))) |
267 |
|
(when *inspect-mode* |
268 |
|
(dotimes (i (array-dimension vector 0)) |
269 |
|
(inspect-recursively (format nil "aref ~D:" i) |
270 |
|
(aref vector i) |
271 |
|
(aref vector i))))) |
272 |
|
|
273 |
|
(defun inspect-array (array) |
274 |
|
(format t (if (adjustable-array-p array) |
275 |
|
"~S - adjustable aray" |
276 |
|
"~S - array") |
277 |
|
array) |
278 |
|
(inspect-print "rank: ~D" (array-rank array)) |
279 |
|
(inspect-print "dimensions: ~D" (array-dimensions array)) |
280 |
|
(inspect-print "total size: ~D" (array-total-size array))) |
281 |
|
|
282 |
|
(defun inspect-structure (x &aux name) |
283 |
|
(format t "Structure of type ~a ~%Byte:[Slot Type]Slot Name :Slot Value" |
284 |
|
(setq name (type-of x))) |
285 |
|
(let* ((sd (get name 'si::s-data)) |
286 |
|
(spos (s-data-slot-position sd))) |
287 |
|
(dolist (v (s-data-slot-descriptions sd)) |
288 |
|
(format t "~%~4d:~@[[~s] ~]~20a:~s" |
289 |
|
(aref spos (nth 4 v)) |
290 |
|
(let ((type (nth 2 v))) |
291 |
|
(if (eq t type) nil type)) |
292 |
|
(car v) |
293 |
|
(structure-ref1 x (nth 4 v)))))) |
294 |
|
|
295 |
|
|
296 |
|
(defun inspect-object (object &aux (*inspect-level* *inspect-level*)) |
297 |
|
(inspect-indent) |
298 |
|
(when (and (not *inspect-mode*) |
299 |
|
(or (> *inspect-level* 5) |
300 |
|
(member object *inspect-history*))) |
301 |
|
(prin1 object) |
302 |
|
(return-from inspect-object)) |
303 |
|
(incf *inspect-level*) |
304 |
|
(push object *inspect-history*) |
305 |
|
(catch 'abort-inspect |
306 |
|
(cond ((symbolp object) (inspect-symbol object)) |
307 |
|
((packagep object) (inspect-package object)) |
308 |
|
((characterp object) (inspect-character object)) |
309 |
|
((numberp object) (inspect-number object)) |
310 |
|
((consp object) (inspect-cons object)) |
311 |
|
((stringp object) (inspect-string object)) |
312 |
|
((vectorp object) (inspect-vector object)) |
313 |
|
((arrayp object) (inspect-array object)) |
314 |
|
((structurep object)(inspect-structure object)) |
315 |
|
(t (format t "~S - ~S" object (type-of object)))))) |
316 |
|
|
317 |
|
|
318 |
|
(defun describe (object &aux (*inspect-mode* nil) |
319 |
|
(*inspect-level* 0) |
320 |
|
(*inspect-history* nil) |
321 |
|
(*print-level* nil) |
322 |
|
(*print-length* nil)) |
323 |
|
; "The lisp function DESCRIBE." |
324 |
|
(terpri) |
325 |
|
(catch 'quit-inspect (inspect-object object)) |
326 |
|
(terpri) |
327 |
|
(values)) |
328 |
|
|
329 |
|
(defun inspect (object &aux (*inspect-mode* t) |
330 |
|
(*inspect-level* 0) |
331 |
|
(*inspect-history* nil) |
332 |
|
(*old-print-level* *print-level*) |
333 |
|
(*old-print-length* *print-length*) |
334 |
|
(*print-level* 3) |
335 |
|
(*print-length* 3)) |
336 |
|
; "The lisp function INSPECT." |
337 |
|
(read-line) |
338 |
|
(princ "Type ? and a newline for help.") |
339 |
|
(terpri) |
340 |
|
(catch 'quit-inspect (inspect-object object)) |
341 |
|
(terpri) |
342 |
|
(values)) |
343 |
|
|
344 |
|
(defun print-doc (symbol &optional (called-from-apropos-doc-p nil) |
345 |
|
&aux (f nil) x) |
346 |
|
(flet ((doc1 (doc ind) |
347 |
|
(setq f t) |
348 |
|
(format t |
349 |
|
"~&-----------------------------------------------------------------------------~%~53S~24@A~%~A" |
350 |
|
symbol ind doc)) |
351 |
|
(good-package () |
352 |
|
(if (eq (symbol-package symbol) (find-package "LISP")) |
353 |
|
(find-package "SYSTEM") |
354 |
|
*package*))) |
355 |
|
|
356 |
|
(cond ((special-form-p symbol) |
357 |
|
(doc1 (or (documentation symbol 'function) "") |
358 |
|
(if (macro-function symbol) |
359 |
|
"[Special form and Macro]" |
360 |
|
"[Special form]"))) |
361 |
|
((macro-function symbol) |
362 |
|
(doc1 (or (documentation symbol 'function) "") "[Macro]")) |
363 |
|
((fboundp symbol) |
364 |
|
(doc1 |
365 |
|
(or (documentation symbol 'function) |
366 |
|
(if (consp (setq x (symbol-function symbol))) |
367 |
|
(case (car x) |
368 |
|
(lambda (format nil "~%Args: ~S" (cadr x))) |
369 |
|
(lambda-block (format nil "~%Args: ~S" (caddr x))) |
370 |
|
(lambda-closure |
371 |
|
(format nil "~%Args: ~S" (car (cddddr x)))) |
372 |
|
(lambda-block-closure |
373 |
|
(format nil "~%Args: ~S" (cadr (cddddr x)))) |
374 |
|
(t "")) |
375 |
|
"")) |
376 |
|
"[Function]")) |
377 |
|
((setq x (documentation symbol 'function)) |
378 |
|
(doc1 x "[Macro or Function]"))) |
379 |
|
|
380 |
|
(cond ((constantp symbol) |
381 |
|
(unless (and (eq (symbol-package symbol) (find-package "KEYWORD")) |
382 |
|
(null (documentation symbol 'variable))) |
383 |
|
(doc1 (or (documentation symbol 'variable) "") "[Constant]"))) |
384 |
|
((si:specialp symbol) |
385 |
|
(doc1 (or (documentation symbol 'variable) "") |
386 |
|
"[Special variable]")) |
387 |
|
((or (setq x (documentation symbol 'variable)) (boundp symbol)) |
388 |
|
(doc1 (or x "") "[Variable]"))) |
389 |
|
|
390 |
|
(cond ((setq x (documentation symbol 'type)) |
391 |
|
(doc1 x "[Type]")) |
392 |
|
((setq x (get symbol 'deftype-form)) |
393 |
|
(let ((*package* (good-package))) |
394 |
|
(doc1 (format nil "~%Defined as: ~S~%See the doc of DEFTYPE." x) |
395 |
|
"[Type]")))) |
396 |
|
|
397 |
|
(cond ((setq x (documentation symbol 'structure)) |
398 |
|
(doc1 x "[Structure]")) |
399 |
|
((setq x (get symbol 'defstruct-form)) |
400 |
|
(doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSTRUCT." x) |
401 |
|
"[Structure]"))) |
402 |
|
|
403 |
|
(cond ((setq x (documentation symbol 'setf)) |
404 |
|
(doc1 x "[Setf]")) |
405 |
|
((setq x (get symbol 'setf-update-fn)) |
406 |
|
(let ((*package* (good-package))) |
407 |
|
(doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSETF." |
408 |
|
`(defsetf ,symbol ,(get symbol 'setf-update-fn))) |
409 |
|
"[Setf]"))) |
410 |
|
((setq x (get symbol 'setf-lambda)) |
411 |
|
(let ((*package* (good-package))) |
412 |
|
(doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSETF." |
413 |
|
`(defsetf ,symbol ,@(get symbol 'setf-lambda))) |
414 |
|
"[Setf]"))) |
415 |
|
((setq x (get symbol 'setf-method)) |
416 |
|
(let ((*package* (good-package))) |
417 |
|
(doc1 |
418 |
|
(format nil |
419 |
|
"~@[~%Defined as: ~S~%See the doc of DEFINE-SETF-METHOD.~]" |
420 |
|
(if (consp x) |
421 |
|
(case (car x) |
422 |
|
(lambda `(define-setf-method ,@(cdr x))) |
423 |
|
(lambda-block `(define-setf-method ,@(cddr x))) |
424 |
|
(lambda-closure `(define-setf-method ,@(cddddr x))) |
425 |
|
(lambda-block-closure |
426 |
|
`(define-setf-method ,@(cdr (cddddr x)))) |
427 |
|
(t nil)) |
428 |
|
nil)) |
429 |
|
"[Setf]")))) |
430 |
|
) |
431 |
|
(idescribe (symbol-name symbol)) |
432 |
|
(if called-from-apropos-doc-p |
433 |
|
f |
434 |
|
(progn (if f |
435 |
|
(format t "~&-----------------------------------------------------------------------------") |
436 |
|
(format t "~&No documentation for ~:@(~S~)." symbol)) |
437 |
|
(values)))) |
438 |
|
|
439 |
|
(defun apropos-doc (string &optional (package 'lisp) &aux (f nil)) |
440 |
|
(setq string (string string)) |
441 |
|
(if package |
442 |
|
(do-symbols (symbol package) |
443 |
|
(when (substringp string (string symbol)) |
444 |
|
(setq f (or (print-doc symbol t) f)))) |
445 |
|
(do-all-symbols (symbol) |
446 |
|
(when (substringp string (string symbol)) |
447 |
|
(setq f (or (print-doc symbol t) f))))) |
448 |
|
(if f |
449 |
|
(format t "~&-----------------------------------------------------------------------------") |
450 |
|
(format t "~&No documentation for ~S in ~:[any~;~A~] package." |
451 |
|
string package |
452 |
|
(and package (package-name (coerce-to-package package))))) |
453 |
|
(values)) |
454 |
|
|