/[gcl]/gcl/lsp/gcl_describe.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_describe.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Sun Sep 14 02:30:35 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:05 2003 UTC
# Line 0  Line 1 
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    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26