home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / describe.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  14.4 KB  |  416 lines
  1. ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: describe.lisp,v 1.19 92/05/06 08:52:00 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; This is the describe mechanism for Common Lisp.
  15. ;;;
  16. ;;; Written by Skef Wholey or Rob MacLachlan originally.
  17. ;;; Cleaned up, reorganized, and enhanced by Blaine Burks.
  18. ;;; Ported to the new system and cleaned up some more by Rob MacLachlan.
  19. ;;;
  20. ;;; This should be done better using CLOS more effectively once CMU Common
  21. ;;; Lisp is brought up to the new standard.  The TYPECASE in DESCRIBE-AUX
  22. ;;; should be unnecessary.    -- Bill Chiles
  23. ;;;
  24.  
  25. (in-package "LISP")
  26. (export '(describe))
  27.  
  28. (in-package "EXT")
  29. (export '(*describe-level* *describe-verbose* *describe-print-level*
  30.       *describe-print-length* *describe-indentation*))
  31.  
  32. (in-package "LISP")
  33.  
  34.  
  35. ;;;; DESCRIBE public switches.
  36.  
  37. (defvar *describe-level* 2
  38.   "Depth of recursive descriptions allowed.")
  39.  
  40. (defvar *describe-verbose* nil
  41.   "If non-nil, descriptions may provide interpretations of information and
  42.   pointers to additional information.  Normally nil.")
  43.  
  44. (defvar *describe-print-level* 2
  45.   "*print-level* gets bound to this inside describe.  If null, use
  46.   *print-level*")
  47.  
  48. (defvar *describe-print-length* 5
  49.   "*print-length* gets bound to this inside describe.  If null, use
  50.   *print-length*.")
  51.  
  52. (defvar *describe-indentation* 3
  53.   "Number of spaces that sets off each line of a recursive description.")
  54.  
  55. (defvar *in-describe* nil
  56.   "Used to tell whether we are doing a recursive describe.")
  57. (defvar *current-describe-level* 0
  58.   "Used to implement recursive description cutoff.  Don't touch.")
  59. (defvar *describe-output* nil
  60.   "An output stream used by Describe for indenting and stuff.")
  61. (defvar *described-objects* nil
  62.   "List of all objects describe within the current top-level call to describe.")
  63. (defvar *current-describe-object* nil
  64.   "The last object passed to describe.")
  65.  
  66. ;;; DESCRIBE sets up the output stream and calls DESCRIBE-AUX, which does the
  67. ;;; hard stuff.
  68. ;;;
  69. (defun describe (x &optional stream)
  70.   "Prints a description of the object X."
  71.   (declare (type (or stream (member t nil)) stream))
  72.   (unless *describe-output*
  73.     (setq *describe-output* (make-indenting-stream *standard-output*)))
  74.   (cond (*in-describe*
  75.      (unless (or (eq x nil) (eq x t))
  76.        (let ((*current-describe-level* (1+ *current-describe-level*))
  77.          (*current-describe-object* x))
  78.          (indenting-further *describe-output* *describe-indentation*
  79.            (describe-aux x)))))
  80.     (t
  81.      (setf (indenting-stream-stream *describe-output*)
  82.            (case stream
  83.          ((t) *terminal-io*)
  84.          ((nil) *standard-output*)
  85.          (t stream)))
  86.      (let ((*standard-output* *describe-output*)
  87.            (*print-level* (or *describe-print-level* *print-level*))
  88.            (*print-length* (or *describe-print-length* *print-length*))
  89.            (*described-objects* ())
  90.            (*in-describe* t)
  91.            (*current-describe-object* x))
  92.        (describe-aux x))
  93.      (values))))
  94.  
  95. ;;; DESCRIBE-AUX does different things for each type.  The order of the
  96. ;;; TYPECASE branches matters with respect to:
  97. ;;;    - symbols and functions until the new standard makes them disjoint.
  98. ;;;    - packages and structure since packages are structures.
  99. ;;; We punt a given call if the current level is greater than *describe-level*,
  100. ;;; or if we detect an object into which we have already descended.
  101. ;;;
  102. (defun describe-aux (x)
  103.   (when (or (not (integerp *describe-level*))
  104.         (minusp *describe-level*))
  105.     (error "*describe-level* should be a nonnegative integer - ~A."
  106.        *describe-level*))
  107.   (when (or (>= *current-describe-level* *describe-level*)
  108.         (member x *described-objects*))
  109.     (return-from describe-aux x))
  110.   (push x *described-objects*)
  111.   (typecase x
  112.     (symbol (describe-symbol x))
  113.     (function (describe-function x))
  114.     (package (describe-package x))
  115.     (hash-table (describe-hash-table x))
  116.     (structure (describe-structure x))
  117.     (array (describe-array x))
  118.     (fixnum (describe-fixnum x))
  119.     (cons
  120.      (if (and (eq (car x) 'setf) (consp (cdr x)) (null (cddr x))
  121.           (symbolp (cadr x))
  122.           (fboundp x))
  123.      (describe-function (fdefinition x) :function x)
  124.      (default-describe x)))
  125.     (t (default-describe x)))
  126.   x)
  127.  
  128.  
  129.  
  130. ;;;; Implementation properties.
  131.  
  132. ;;; This supresses random garbage that users probably don't want to see.
  133. ;;;
  134. (defparameter *implementation-properties*
  135.   '(%loaded-address CONDITIONS::MAKE-FUNCTION CONDITIONS::REPORT-FUNCTION
  136.             CONDITIONS::CONC-NAME CONDITIONS::SLOTS
  137.             CONDITIONS::PARENT-TYPE))
  138.  
  139.  
  140. ;;;; Miscellaneous DESCRIBE methods:
  141.       
  142. (defun default-describe (x)
  143.   (format t "~&~S is a ~S." x (type-of x)))
  144.  
  145. (defun describe-structure (x)
  146.   (cond ((and (fboundp 'pcl::std-instance-p)
  147.           (pcl::std-instance-p x))
  148.      (pcl::describe-object x *standard-output*))
  149.     (t
  150.      (format t "~&~S is a structure of type ~A." x (c::structure-ref x 0))
  151.      (dolist (slot (cddr (inspect::describe-parts x)))
  152.        (format t "~%~A: ~S." (car slot) (cdr slot))))))
  153.  
  154. (defun describe-array (x)
  155.   (let ((rank (array-rank x)))
  156.     (cond ((> rank 1)
  157.        (format t "~&~S is " x)
  158.        (write-string (if (%array-displaced-p x) "a displaced" "an"))
  159.        (format t " array of rank ~A." rank)
  160.        (format t "~%Its dimensions are ~S." (array-dimensions x)))
  161.       (t
  162.        (format t "~&~S is a ~:[~;displaced ~]vector of length ~D." x
  163.            (and (array-header-p x) (%array-displaced-p x)) (length x))
  164.        (if (array-has-fill-pointer-p x)
  165.            (format t "~&It has a fill pointer, currently ~d"
  166.                (fill-pointer x))
  167.            (format t "~&It has no fill pointer."))))
  168.   (format t "~&Its element type is ~S." (array-element-type x))))
  169.  
  170. (defun describe-fixnum (x)
  171.   (cond ((not (or *describe-verbose* (zerop *current-describe-level*))))
  172.     ((primep x)
  173.      (format t "~&It is a prime number."))
  174.     (t
  175.      (format t "~&It is a composite number."))))
  176.  
  177. (defun describe-hash-table (x)
  178.   (format t "~&~S is an ~a hash table." x (hash-table-kind x))
  179.   (format t "~&Its size is ~d buckets." (hash-table-size x))
  180.   (format t "~&Its rehash-size is ~d." (hash-table-rehash-size x))
  181.   (format t "~&Its rehash-threshold is ~d."
  182.       (hash-table-rehash-threshold x))
  183.   (format t "~&It currently holds ~d entries."
  184.       (hash-table-number-entries x)))
  185.  
  186. (defun describe-package (x)
  187.   (describe-structure x)
  188.   (let* ((internal (package-internal-symbols x))
  189.      (internal-count (- (package-hashtable-size internal)
  190.                 (package-hashtable-free internal)))
  191.      (external (package-external-symbols x))
  192.      (external-count (- (package-hashtable-size external)
  193.                 (package-hashtable-free external))))
  194.     (format t "~&~d symbols total: ~d internal and ~d external."
  195.          (+ internal-count external-count) internal-count external-count)))
  196.  
  197.  
  198. ;;;; Function and symbol description (documentation):
  199.  
  200. ;;; DESC-DOC prints the specified kind of documentation about the given Name.
  201. ;;; If Name is null, or not a valid name, then don't print anything.
  202. ;;;
  203. (defun desc-doc (name kind kind-doc)
  204.   (when (and name (typep name '(or symbol cons)))
  205.     (let ((doc (documentation name kind)))
  206.       (when doc
  207.     (format t "~&~@(~A documentation:~)~&  ~A"
  208.         (or kind-doc kind) doc)))))
  209.  
  210.  
  211. ;;; DESCRIBE-FUNCTION-NAME  --  Internal
  212. ;;;
  213. ;;;    Describe various stuff about the functional semantics attached to the
  214. ;;; specified Name.  Type-Spec is the function type specifier extracted from
  215. ;;; the definition, or NIL if none.
  216. ;;;
  217. (defun describe-function-name (name type-spec)
  218.   (let ((*print-level* nil)
  219.     (*print-length* nil))
  220.     (multiple-value-bind
  221.     (type where)
  222.     (if (or (symbolp name) (and (listp name) (eq (car name) 'setf)))
  223.         (values (type-specifier (info function type name))
  224.             (info function where-from name))
  225.         (values type-spec :defined))
  226.       (when (consp type)
  227.     (format t "~&Its ~(~A~) argument types are:~%  ~S"
  228.         where (second type))
  229.     (format t "~&Its result type is:~%  ~S" (third type)))))
  230.       
  231.   (let ((inlinep (info function inlinep name)))
  232.     (when inlinep
  233.       (format t "~&It is currently declared ~(~A~);~
  234.          ~:[no~;~] expansion is available."
  235.           inlinep (info function inline-expansion name)))))
  236.  
  237.  
  238. ;;; DESCRIBE-FUNCTION-INTERPRETED  --  Internal
  239. ;;;
  240. ;;;    Interpreted function describing; handles both closure and non-closure
  241. ;;; functions.  Instead of printing the compiled-from info, we print the
  242. ;;; definition.
  243. ;;;
  244. (defun describe-function-interpreted (x kind name)
  245.   (multiple-value-bind (exp closure-p dname)
  246.                (eval:interpreted-function-lambda-expression x)
  247.     (let ((args (eval:interpreted-function-arglist x)))
  248.       (format t "~&~@(~@[~A ~]arguments:~%~)" kind)
  249.       (cond ((not args)
  250.          (write-string "  There are no arguments."))
  251.         (t
  252.          (write-string "  ")
  253.          (indenting-further *standard-output* 2
  254.            (prin1 args)))))
  255.     
  256.     (let ((name (or name dname)))
  257.       (desc-doc name 'function kind)
  258.       (unless (eq kind :macro)
  259.     (describe-function-name
  260.      name
  261.      (type-specifier (eval:interpreted-function-type x)))))
  262.     
  263.     (when closure-p
  264.       (format t "~&Its closure environment is:")
  265.       (indenting-further *standard-output* 2
  266.     (let ((clos (eval:interpreted-function-closure x)))
  267.       (dotimes (i (length clos))
  268.         (format t "~&~D: ~S" i (svref clos i))))))
  269.     
  270.     (format t "~&Its definition is:~%  ~S" exp)))
  271.  
  272.  
  273. ;;; PRINT-COMPILED-FROM  --  Internal
  274. ;;;
  275. ;;;    Print information from the debug-info about where X was compiled from.
  276. ;;;
  277. (defun print-compiled-from (x)
  278.   (let ((info (kernel:code-debug-info (kernel:function-code-header x))))
  279.     (when info
  280.       (let ((sources (c::compiled-debug-info-source info)))
  281.     (format t "~&On ~A it was compiled from:"
  282.         (format-universal-time nil
  283.                        (c::debug-source-compiled
  284.                     (first sources))))
  285.     (dolist (source sources)
  286.       (let ((name (c::debug-source-name source)))
  287.         (ecase (c::debug-source-from source)
  288.           (:file
  289.            (format t "~&~A~%  Created: " (namestring name))
  290.            (ext:format-universal-time t (c::debug-source-created source))
  291.            (let ((comment (c::debug-source-comment source)))
  292.          (when comment
  293.            (format t "~&  Comment: ~A" comment))))
  294.           (:stream (format t "~&~S" name))
  295.           (:lisp (format t "~&~S" name)))))))))
  296.  
  297.  
  298. ;;; DESCRIBE-FUNCTION-COMPILED  --  Internal
  299. ;;;
  300. ;;;    Describe a compiled function.  The closure case calls us to print the
  301. ;;; guts.
  302. ;;;
  303. (defun describe-function-compiled (x kind name)
  304.   (let ((args (%function-header-arglist x)))
  305.     (format t "~&~@(~@[~A ~]arguments:~%~)" kind)
  306.     (cond ((not args)
  307.        (format t "  There is no argument information available."))
  308.       ((string= args "()")
  309.        (write-string "  There are no arguments."))
  310.       (t
  311.        (write-string "  ")
  312.        (indenting-further *standard-output* 2
  313.          (write-string args)))))
  314.  
  315.   (let ((name (or name (%function-header-name x))))
  316.     (desc-doc name 'function kind)
  317.     (unless (eq kind :macro)
  318.       (describe-function-name name (%function-header-type x))))
  319.     
  320.   (print-compiled-from x))
  321.  
  322.  
  323. ;;; DESCRIBE-FUNCTION  --  Internal
  324. ;;;
  325. ;;;    Describe a function with the specified kind and name.  The latter
  326. ;;; arguments provide some information about where the function came from. Kind
  327. ;;; NIL means not from a name.
  328. ;;;
  329. (defun describe-function (x &optional (kind nil) name)
  330.   (declare (type function x) (type (member :macro :function nil) kind))
  331.   (fresh-line)
  332.   (ecase kind
  333.     (:macro (format t "Macro-function: ~S" x))
  334.     (:function (format t "Function: ~S" x))
  335.     ((nil)
  336.      (format t "~S is function." x)))
  337.   (case (get-type x)
  338.     (#.vm:closure-header-type
  339.      (cond ((eval:interpreted-function-p x)
  340.         (describe-function-interpreted x kind name))
  341.        (t
  342.         (describe-function-compiled (%closure-function x) kind name)
  343.         (format t "~&Its closure environment is:")
  344.         (indenting-further *standard-output* 8)
  345.         (dotimes (i (- (get-closure-length x) (1- vm:closure-info-offset)))
  346.           (format t "~&~D: ~S" i (%closure-index-ref x i))))))
  347.     ((#.vm:function-header-type #.vm:closure-function-header-type)
  348.      (describe-function-compiled x kind name))
  349.     (#.vm:funcallable-instance-header-type
  350.      (pcl::describe-object x *standard-output*))
  351.     (t
  352.      (format t "~&It is an unknown type of function."))))
  353.  
  354.  
  355. (defun describe-symbol (x)
  356.   (let ((package (symbol-package x)))
  357.     (if package
  358.     (multiple-value-bind (symbol status)
  359.                  (find-symbol (symbol-name x) package)
  360.       (declare (ignore symbol))
  361.       (format t "~&~A is an ~A symbol in the ~A package." x
  362.           (string-downcase (symbol-name status))
  363.           (package-name (symbol-package x))))
  364.     (format t "~&~A is an uninterned symbol." x)))
  365.   ;;
  366.   ;; Describe the value cell.
  367.   (let* ((kind (info variable kind x))
  368.      (wot (ecase kind
  369.         (:special "special variable")
  370.         (:constant "constant")
  371.         (:global "undefined variable")
  372.         (:alien nil))))
  373.     (cond
  374.      ((eq kind :alien)
  375.       (let ((info (info variable alien-info x)))
  376.     (format t "~&~@<It is an alien at #x~8,'0X of type ~3I~:_~S.~:>~%"
  377.         (sap-int (eval (alien::heap-alien-info-sap-form info)))
  378.         (alien-internals:unparse-alien-type
  379.          (alien::heap-alien-info-type info)))
  380.     (format t "~@<It's current value is ~3I~:_~S.~:>"
  381.         (eval x))))
  382.      ((boundp x)
  383.       (let ((value (symbol-value x)))
  384.     (format t "~&It is a ~A; its value is ~S." wot value)
  385.     (describe value)))
  386.      ((not (eq kind :global))
  387.       (format t "~&It is a ~A; no current value." wot)))
  388.  
  389.     (when (eq (info variable where-from x) :declared)
  390.       (format t "~&Its declared type is ~S."
  391.           (type-specifier (info variable type x))))
  392.  
  393.     (desc-doc x 'variable kind))
  394.   ;;
  395.   ;; Describe the function cell.
  396.   (cond ((macro-function x)
  397.      (describe-function (macro-function x) :macro x))
  398.     ((special-form-p x)
  399.      (desc-doc x 'function "Special form"))
  400.     ((fboundp x)
  401.      (describe-function (fdefinition x) :function x)))
  402.   ;;
  403.   ;; Print other documentation.
  404.   (desc-doc x 'structure "Structure")
  405.   (desc-doc x 'type "Type")
  406.   (desc-doc x 'setf "Setf macro")
  407.   (dolist (assoc (info random-documentation stuff x))
  408.     (format t "~&Documentation on the ~(~A~):~%~A" (car assoc) (cdr assoc)))
  409.   ;;
  410.   ;; Print out properties, possibly ignoring implementation details.
  411.   (do ((plist (symbol-plist X) (cddr plist)))
  412.       ((null plist) ())
  413.     (unless (member (car plist) *implementation-properties*)
  414.       (format t "~&Its ~S property is ~S." (car plist) (cadr plist))
  415.       (describe (cadr plist)))))
  416.