diff --git a/code/describe.lisp b/code/describe.lisp index b81df3df6dcacf09828b7b8343575537bda4ca5b..19db4f82d6b692c18e65a1cdb9b10edec5c8fb92 100644 --- a/code/describe.lisp +++ b/code/describe.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/describe.lisp,v 1.12 1991/10/28 12:22:23 chiles Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/describe.lisp,v 1.13 1991/12/19 18:08:15 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -15,6 +15,7 @@ ;;; ;;; Written by Skef Wholey or Rob MacLachlan originally. ;;; Cleaned up, reorganized, and enhanced by Blaine Burks. +;;; Ported to the new system and cleaned up some more by Rob MacLachlan. ;;; ;;; This should be done better using CLOS more effectively once CMU Common ;;; Lisp is brought up to the new standard. The TYPECASE in DESCRIBE-AUX @@ -53,7 +54,6 @@ "Used to implement recursive description cutoff. Don't touch.") (defvar *describe-output* nil "An output stream used by Describe for indenting and stuff.") -(defvar *used-documentation* nil "Documentation already described.") (defvar *described-objects* nil "List of all objects describe within the current top-level call to describe.") (defvar *current-describe-object* nil @@ -79,7 +79,6 @@ (let ((*standard-output* *describe-output*) (*print-level* (or *describe-print-level* *print-level*)) (*print-length* (or *describe-print-length* *print-length*)) - (*used-documentation* ()) (*described-objects* ()) (*in-describe* t) (*current-describe-object* x)) @@ -114,7 +113,7 @@ (if (and (eq (car x) 'setf) (consp (cdr x)) (null (cddr x)) (symbolp (cadr x)) (fboundp x)) - (describe-function (fdefinition x)) + (describe-function (fdefinition x) :function x) (default-describe x))) (t (default-describe x))) x) @@ -126,82 +125,17 @@ ;;; This supresses random garbage that users probably don't want to see. ;;; (defparameter *implementation-properties* - '(%loaded-address)) + '(%loaded-address CONDITIONS::MAKE-FUNCTION CONDITIONS::REPORT-FUNCTION + CONDITIONS::CONC-NAME CONDITIONS::SLOTS + CONDITIONS::PARENT-TYPE + #+pcl walker::walker-template)) -;;;; DESCRIBE methods. - -;;; DESC-DOC prints the specified kind of documentation about the given Symbol. -;;; -(defun desc-doc (symbol name string) - (let ((doc (documentation symbol name))) - (when (and doc (not (member doc *used-documentation*))) - (push doc *used-documentation*) - (format t "~&~A~& ~A" string doc)))) - +;;;; Miscellaneous DESCRIBE methods: (defun default-describe (x) (format t "~&~S is a ~S." x (type-of x))) -(defun describe-symbol (x) - (let ((package (symbol-package x))) - (if package - (multiple-value-bind (symbol status) - (find-symbol (symbol-name x) package) - (declare (ignore symbol)) - (format t "~&~A is an ~A symbol in the ~A package." x - (string-downcase (symbol-name status)) - (package-name (symbol-package x)))) - (format t "~&~A is an uninterned symbol." x))) - ;; - ;; Describe the value cell. - (let* ((kind (info variable kind x)) - (wot (ecase kind - (:special "special variable") - (:constant "constant") - (:global "undefined variable")))) - (cond - ((boundp x) - (let ((value (symbol-value x))) - (format t "~&It is a ~A; its value is ~S." wot value) - (describe value))) - ((not (eq kind :global)) - (format t "~&It is a ~A; no current value." wot))) - - (when (eq (info variable where-from x) :declared) - (format t "~&Its declared type is ~S." - (type-specifier (info variable type x)))) - - (desc-doc x 'variable - (format nil "~:[Variable~;Constant~] documentation:" - (eq kind :constant)))) - ;; - ;; Describe the function cell. - (cond ((macro-function x) - (let ((fun (macro-function x))) - (format t "~&Its macroexpansion function is ~A." fun) - (desc-doc x 'function "Macro documentation:") - (describe-function fun t))) - ((special-form-p x) - (desc-doc x 'function "Special form documentation:")) - ((fboundp x) - (describe-function (fdefinition x)))) - ;; - ;; Print other documentation. - (desc-doc x 'structure "Documentation on the structure:") - (desc-doc x 'type "Documentation on the type:") - (desc-doc x 'setf "Documentation on the SETF form:") - (dolist (assoc (info random-documentation stuff x)) - (unless (member (cdr assoc) *used-documentation*) - (format t "~&Documentation on the ~(~A~):~%~A" (car assoc) (cdr assoc)))) - ;; - ;; Print out properties, possibly ignoring implementation details. - (do ((plist (symbol-plist X) (cddr plist))) - ((null plist) ()) - (unless (member (car plist) *implementation-properties*) - (format t "~&Its ~S property is ~S." (car plist) (cadr plist)) - (describe (cadr plist))))) - (defun describe-structure (x) (cond ((and (fboundp 'pcl::std-instance-p) (pcl::std-instance-p x)) @@ -227,53 +161,113 @@ (format t "~&It has no fill pointer.")))) (format t "~&Its element type is ~S." (array-element-type x)))) -(defun describe-function (x &optional macro-p) - (declare (type function x)) - (case (get-type x) - (#.vm:closure-header-type - (describe-function-lex-closure x macro-p)) - ((#.vm:function-header-type #.vm:closure-function-header-type) - (describe-function-compiled x macro-p)) - (#.vm:funcallable-instance-header-type - (pcl::describe-object x *standard-output*)) - (t - (format t "~&It is an unknown type of function.")))) +(defun describe-fixnum (x) + (cond ((not (or *describe-verbose* (zerop *current-describe-level*)))) + ((primep x) + (format t "~&It is a prime number.")) + (t + (format t "~&It is a composite number.")))) + +(defun describe-hash-table (x) + (format t "~&~S is an ~a hash table." x (hash-table-kind x)) + (format t "~&Its size is ~d buckets." (hash-table-size x)) + (format t "~&Its rehash-size is ~d." (hash-table-rehash-size x)) + (format t "~&Its rehash-threshold is ~d." + (hash-table-rehash-threshold x)) + (format t "~&It currently holds ~d entries." + (hash-table-number-entries x))) + +(defun describe-package (x) + (describe-structure x) + (let* ((internal (package-internal-symbols x)) + (internal-count (- (package-hashtable-size internal) + (package-hashtable-free internal))) + (external (package-external-symbols x)) + (external-count (- (package-hashtable-size external) + (package-hashtable-free external)))) + (format t "~&~d symbols total: ~d internal and ~d external." + (+ internal-count external-count) internal-count external-count))) + + +;;;; Function and symbol description (documentation): + +;;; DESC-DOC prints the specified kind of documentation about the given Name. +;;; If Name is null, or not a valid name, then don't print anything. +;;; +(defun desc-doc (name kind kind-doc) + (when (and name (typep name '(or symbol cons))) + (let ((doc (documentation name kind))) + (when doc + (format t "~&~@(~A~) documentation:~& ~A" kind-doc doc))))) + + +;;; DESCRIBE-FUNCTION-NAME -- Internal +;;; +;;; Describe various stuff about the functional semantics attached to the +;;; specified Name. Type-Spec is the function type specifier extracted from +;;; the definition, or NIL if none. +;;; +(defun describe-function-name (name type-spec) + (let ((*print-level* nil) + (*print-length* nil)) + (multiple-value-bind + (type where) + (if (or (symbolp name) (and (listp name) (eq (car name) 'setf))) + (values (type-specifier (info function type name)) + (info function where-from name)) + (values type-spec :defined)) + (when (consp type) + (format t "~&Its ~(~A~) argument types are:~% ~S" + where (second type)) + (format t "~&Its result type is:~% ~S" (third type))))) + + (let ((inlinep (info function inlinep name))) + (when inlinep + (format t "~&It is currently declared ~(~A~);~ + ~:[no~;~] expansion is available." + inlinep (info function inline-expansion name))))) -(defun describe-function-compiled (x macro-p) - (let ((name (%function-header-name x))) - (format t "~&Function:~% ~S~%" x) - (let ((args (%function-header-arglist x))) - (write-line "Function Arguments:") + +;;; DESCRIBE-FUNCTION-INTERPRETED -- Internal +;;; +;;; Interpreted function describing; handles both closure and non-closure +;;; functions. Instead of printing the compiled-from info, we print the +;;; definition. +;;; +(defun describe-function-interpreted (x kind name) + (multiple-value-bind (exp closure-p dname) + (eval:interpreted-function-lambda-expression x) + (let ((args (eval:interpreted-function-arglist x))) + (format t "~&~@(~@[~A ~]arguments:~%~)" kind) (cond ((not args) - (format t " There is no argument information available.")) - ((string= args "()") (write-string " There are no arguments.")) (t (write-string " ") (indenting-further *standard-output* 2 - (write-string args))))) - (when (symbolp name) - (desc-doc name 'function "Function Documention:")) - (unless macro-p - (let ((*print-level* nil) - (*print-length* nil)) - (multiple-value-bind - (type where) - (if (or (symbolp name) (and (listp name) (eq (car name) 'setf))) - (values (type-specifier (info function type name)) - (info function where-from name)) - (values (%function-header-type x) - :defined)) - (when (consp type) - (format t "~&Its ~(~A~) argument types are:~% ~S" - where (second type)) - (format t "~&Its result type is:~% ~S" (third type))))) - - (let ((inlinep (info function inlinep name))) - (when inlinep - (format t "~&It is currently declared ~(~A~);~ - ~:[no~;~] expansion is available." - inlinep (info function inline-expansion name)))))) + (prin1 args))))) + + (let ((name (or name dname))) + (desc-doc name 'function kind) + (unless (eq kind :macro) + (describe-function-name + name + (type-specifier (eval:interpreted-function-type x))))) + + (when closure-p + (format t "~&Its closure environment is:") + (indenting-further *standard-output* 2 + (let ((clos (eval:interpreted-function-closure x))) + (dotimes (i (length clos)) + (format t "~&~D: ~S" i (svref clos i)))))) + + (format t "~&Its definition is:~% ~S" exp))) + + +;;; PRINT-COMPILED-FROM -- Internal +;;; +;;; Print information from the debug-info about where X was compiled from. +;;; +(defun print-compiled-from (x) (let ((info (kernel:code-debug-info (kernel:function-code-header x)))) (when info (let ((sources (c::compiled-debug-info-source info))) @@ -293,47 +287,114 @@ (:stream (format t "~&~S" name)) (:lisp (format t "~&~S" name))))))))) -(defun describe-function-lex-closure (x macro-p) - (print-for-describe x) - (format t " is a lexical closure.~%") - (describe-function-compiled (%closure-function x) macro-p) - (format t "~&Its lexical environment is:") - (indenting-further *standard-output* 8) - (dotimes (i (- (get-closure-length x) (1- vm:closure-info-offset))) - (format t "~&~D: ~S" i (%closure-index-ref x i)))) +;;; DESCRIBE-FUNCTION-COMPILED -- Internal +;;; +;;; Describe a compiled function. The closure case calls us to print the +;;; guts. +;;; +(defun describe-function-compiled (x kind name) + (let ((args (%function-header-arglist x))) + (format t "~&~@(~@[~A ~]arguments:~%~)" kind) + (cond ((not args) + (format t " There is no argument information available.")) + ((string= args "()") + (write-string " There are no arguments.")) + (t + (write-string " ") + (indenting-further *standard-output* 2 + (write-string args))))) -(defun print-for-describe (x &optional (freshp t)) - (when freshp (fresh-line)) - (cond ((symbolp x) - (write-string (symbol-name x))) - (t - (princ x)))) + (let ((name (or name (%function-header-name x)))) + (desc-doc name 'function kind) + (unless (eq kind :macro) + (describe-function-name name (%function-header-type x)))) + + (print-compiled-from x)) -(defun describe-fixnum (x) - (cond ((not (or *describe-verbose* (zerop *current-describe-level*)))) - ((primep x) - (format t "~&It is a prime number.")) - (t - (format t "~&It is a composite number.")))) -(defun describe-hash-table (x) - (format t "~&~S is an ~a hash table." x (hash-table-kind x)) - (format t "~&Its size is ~d buckets." (hash-table-size x)) - (format t "~&Its rehash-size is ~d." (hash-table-rehash-size x)) - (format t "~&Its rehash-threshold is ~d." - (hash-table-rehash-threshold x)) - (format t "~&It currently holds ~d entries." - (hash-table-number-entries x))) +;;; DESCRIBE-FUNCTION -- Internal +;;; +;;; Describe a function with the specified kind and name. The latter +;;; arguments provide some information about where the function came from. Kind +;;; NIL means not from a name. +;;; +(defun describe-function (x &optional (kind nil) name) + (declare (type function x) (type (member :macro :function nil) kind)) + (fresh-line) + (ecase kind + (:macro (format t "Macro-function: ~S" x)) + (:function (format t "Function: ~S" x)) + ((nil) + (format t "~S is function." x))) + (case (get-type x) + (#.vm:closure-header-type + (cond ((eval:interpreted-function-p x) + (describe-function-interpreted x kind name)) + (t + (describe-function-compiled (%closure-function x) kind name) + (format t "~&Its closure environment is:") + (indenting-further *standard-output* 8) + (dotimes (i (- (get-closure-length x) (1- vm:closure-info-offset))) + (format t "~&~D: ~S" i (%closure-index-ref x i)))))) + ((#.vm:function-header-type #.vm:closure-function-header-type) + (describe-function-compiled x kind name)) + (#.vm:funcallable-instance-header-type + (pcl::describe-object x *standard-output*)) + (t + (format t "~&It is an unknown type of function.")))) -(defun describe-package (x) - (describe-structure x) - (let* ((internal (package-internal-symbols x)) - (internal-count (- (package-hashtable-size internal) - (package-hashtable-free internal))) - (external (package-external-symbols x)) - (external-count (- (package-hashtable-size external) - (package-hashtable-free external)))) - (format t "~&~d symbols total: ~d internal and ~d external." - (+ internal-count external-count) internal-count external-count))) +(defun describe-symbol (x) + (let ((package (symbol-package x))) + (if package + (multiple-value-bind (symbol status) + (find-symbol (symbol-name x) package) + (declare (ignore symbol)) + (format t "~&~A is an ~A symbol in the ~A package." x + (string-downcase (symbol-name status)) + (package-name (symbol-package x)))) + (format t "~&~A is an uninterned symbol." x))) + ;; + ;; Describe the value cell. + (let* ((kind (info variable kind x)) + (wot (ecase kind + (:special "special variable") + (:constant "constant") + (:global "undefined variable")))) + (cond + ((boundp x) + (let ((value (symbol-value x))) + (format t "~&It is a ~A; its value is ~S." wot value) + (describe value))) + ((not (eq kind :global)) + (format t "~&It is a ~A; no current value." wot))) + + (when (eq (info variable where-from x) :declared) + (format t "~&Its declared type is ~S." + (type-specifier (info variable type x)))) + + (desc-doc x 'variable kind)) + ;; + ;; Describe the function cell. + (cond ((macro-function x) + (describe-function (macro-function x) :macro x)) + ((special-form-p x) + (desc-doc x 'function "Special form")) + ((fboundp x) + (describe-function (fdefinition x) :function x))) + ;; + ;; Print other documentation. + (desc-doc x 'structure "Structure") + (desc-doc x 'type "Type") + (desc-doc x 'setf "Setf macro") + (dolist (assoc (info random-documentation stuff x)) + (unless (member (cdr assoc) *used-documentation*) + (format t "~&Documentation on the ~(~A~):~%~A" (car assoc) (cdr assoc)))) + ;; + ;; Print out properties, possibly ignoring implementation details. + (do ((plist (symbol-plist X) (cddr plist))) + ((null plist) ()) + (unless (member (car plist) *implementation-properties*) + (format t "~&Its ~S property is ~S." (car plist) (cadr plist)) + (describe (cadr plist)))))