home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / lsp / describe.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  17.7 KB  |  469 lines
  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.     (let ((name (symbol-name symbol))tem)
  432.       (declare (special my-lisp-doc))
  433.       (or (boundp 'my-lisp-doc)
  434.       (let ((*package* (find-package "SI")))
  435.         (setq tem (probe-file (src-path "doc/DOC-keys.el")))
  436.         (if tem (load tem) (setq my-lisp-doc nil))))
  437.       (when (setq tem (cdr (assoc name my-lisp-doc :test 'equal)))
  438.     (setq f t)
  439.           (with-open-file (st (src-path "doc/DOC"))
  440.         
  441.             (file-position st  tem)
  442.             (do ((v  #\space (read-char st nil #\^_)))
  443.                 ((eql v #\^_))
  444.                 (princ v)))))
  445.  
  446.   (if called-from-apropos-doc-p
  447.       f
  448.       (progn (if f
  449.                  (format t "~&-----------------------------------------------------------------------------")
  450.                  (format t "~&No documentation for ~:@(~S~)." symbol))
  451.              (values))))
  452.  
  453. (defun apropos-doc (string &optional (package 'lisp) &aux (f nil))
  454.   (setq string (string string))
  455.   (if package
  456.       (do-symbols (symbol package)
  457.         (when (substringp string (string symbol))
  458.           (setq f (or (print-doc symbol t) f))))
  459.       (do-all-symbols (symbol)
  460.         (when (substringp string (string symbol))
  461.           (setq f (or (print-doc symbol t) f)))))
  462.   (if f
  463.       (format t "~&-----------------------------------------------------------------------------")
  464.       (format t "~&No documentation for ~S in ~:[any~;~A~] package."
  465.               string package
  466.               (and package (package-name (coerce-to-package package)))))
  467.   (values))
  468.  
  469.