← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to lsp/gcl_describe.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
lsp/gcl_describe.lsp
 
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