From e87dae6265d0df5fb333d14a840a0175367ad2c7 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Mon, 8 Oct 1990 17:20:44 +0000
Subject: [PATCH] Fixed variable describing.  Made function describing better.
 Added stuff to describe SETF functions.  Fixed closure describing to not
 print too many slots.  Eliminated *describe-implementation-details* and
 downgraded *implementation-properties*.

---
 code/describe.lisp | 133 +++++++++++++++++++++++++--------------------
 1 file changed, 75 insertions(+), 58 deletions(-)

diff --git a/code/describe.lisp b/code/describe.lisp
index 402a2dd39..e4e1ad674 100644
--- a/code/describe.lisp
+++ b/code/describe.lisp
@@ -19,8 +19,7 @@
 
 (in-package "LISP")
 
-(export '(describe *describe-level* *describe-verbose*
-		   *describe-implementation-details* *describe-print-level*
+(export '(describe *describe-level* *describe-verbose* *describe-print-level*
 		   *describe-print-length* *describe-indentation*))
 
 
@@ -33,14 +32,13 @@
   "If non-nil, descriptions may provide interpretations of information and
   pointers to additional information.  Normally nil.")
 
-(defvar *describe-implementation-details* nil
-  "If non-null, normally concealed implementation information won't be.")
-
 (defvar *describe-print-level* 2
-  "*print-level* gets bound to this inside describe.")
+  "*print-level* gets bound to this inside describe.  If null, use
+  *print-level*")
 
 (defvar *describe-print-length* 5
-  "*print-length gets bound to this inside describe.")
+  "*print-length* gets bound to this inside describe.  If null, use
+  *print-length*.")
 
 (defvar *describe-indentation* 3
   "Number of spaces that sets off each line of a recursive description.")
@@ -63,8 +61,7 @@
 (defun describe (x &optional (stream *standard-output*))
   "Prints a description of the object X.
   See also *describe-level*, defdescribe, *describe-verbose*,
-  *describe-implementation-details*, *describe-print-level*,
-  *describe-print-length*, and *describe-indentation*."
+  *describe-print-level*, *describe-print-length*, and *describe-indentation*."
   (unless *describe-output*
     (setq *describe-output* (make-indenting-stream *standard-output*)))
   (cond (*in-describe*
@@ -76,8 +73,8 @@
 	(t
 	 (setf (indenting-stream-stream *describe-output*) stream)
 	 (let ((*standard-output* *describe-output*)
-	       (*print-level* *describe-print-level*)
-	       (*print-length* *describe-print-length*)
+	       (*print-level* (or *describe-print-level* *print-level*))
+	       (*print-length* (or *describe-print-length* *print-length*))
 	       (*used-documentation* ())
 	       (*described-objects* ())
 	       (*in-describe* t)
@@ -109,6 +106,12 @@
     (structure (describe-structure x))
     (array (describe-array x))
     (fixnum (describe-fixnum x))
+    (cons
+     (if (and (eq (car x) 'setf) (consp (cdr x)) (null (cddr x))
+	      (symbolp (cadr x))
+	      (fboundp x))
+	 (describe-function (fdefinition x))
+	 (default-describe x)))
     (t (default-describe x)))
   x)
 
@@ -119,11 +122,7 @@
 ;;; This supresses random garbage that users probably don't want to see.
 ;;;
 (defparameter *implementation-properties*
-  '(%loaded-address
-    ;;
-    ;; Documentation properties:
-    %var-documentation %fun-documentation %struct-documentation
-    %type-documentation %setf-documentation %documentation))
+  '(%loaded-address))
 
 
 ;;;; DESCRIBE methods.
@@ -152,48 +151,50 @@
 	(format t "~&~A is an uninterned symbol." x)))
   ;;
   ;; Describe the value cell.
-  (when (boundp x)
-    (let ((value (symbol-value x))
-	  (constantp (constantp x)))
-      (cond ((get x 'globally-special)
-	     (if constantp
-		 (format t "~&It is a constant; its value is ~S." value)
-		 (format t "~&It is a special variable; ~
-			    its current binding is ~S."
-			 value)))
-	    (t
-	     (fresh-line)
-	     (write-string "Its value is ")
-	     (print-for-describe value nil)))
-      (desc-doc x 'variable
-		(format nil "~:[Variable~;Constant~] Documentation:"
-			constantp))
-      (describe value)))
+  (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)
-	   (describe-function fun)
-	   (desc-doc x 'function "Macro Documentation:")))
+	   (describe-function fun t)
+	   (desc-doc x 'function "Macro documentation:")))
+	((special-form-p x)
+	 (desc-doc x 'function "Special form documentation:"))
 	((fboundp x)
-	 (describe-function (symbol-function 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 (get x '%documentation))
+  (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))
-       (properties-to-ignore (if *describe-implementation-details*
-				 nil
-				 *implementation-properties*)))
+  (do ((plist (symbol-plist X) (cddr plist)))
       ((null plist) ())
-    (unless (member (car plist) properties-to-ignore)
+    (unless (member (car plist) *implementation-properties*)
       (format t "~&Its ~S property is ~S." (car plist) (cadr plist))
       (describe (cadr plist)))))
 
@@ -227,29 +228,45 @@
 	   (format t " can be called with these arguments:~%")
 	   ,output))))
 
-(defun describe-function (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))
+     (describe-function-lex-closure x macro-p))
     ((#.vm:function-header-type #.vm:closure-function-header-type)
-     (describe-function-compiled x))
+     (describe-function-compiled x macro-p))
     (t
      (format t "~&It is an unknown type of function."))))
 
-(defun describe-function-compiled (x)
+(defun describe-function-compiled (x macro-p)
   (let ((args (%function-header-arglist x)))
     (describe-function-arg-list
      *current-describe-object* (string= args "()") (write-string args)))
-  (let ((*print-level* nil)
-	(*print-length* nil)
-	(type (%function-header-type x)))
-    (format t "~&Its argument types are:~%  ~S" (second type))
-    (format t "~&Its result type is:~%  ~S" (third type)))
-  
-  (let ((name (%function-header-name x)))
-    (when (symbolp name)
-      (desc-doc name 'function "Function Documention:")))
+
+  (unless macro-p
+    (let ((name (%function-header-name x)))
+      (let ((*print-level* nil)
+	    (*print-length* nil))
+	(multiple-value-bind
+	    (type where)
+	    (if (stringp name)
+		(values (%function-header-type x)
+			:defined)
+		(values (type-specifier (info function type name))
+			(info function where-from name)))
+	  (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))))
+    
+      (when (symbolp name)
+	(desc-doc name 'function "Function Documention:"))))
   
   (let ((info (di::code-debug-info (di::function-code-header x))))
     (when info
@@ -270,13 +287,13 @@
 	      (:stream (format t "~&~S" name))
 	      (:lisp (format t "~&~S" name)))))))))
 
-(defun describe-function-lex-closure (x)
+(defun describe-function-lex-closure (x macro-p)
   (print-for-describe x)
   (format t " is a lexical closure.~%")
-  (describe-function-compiled (%closure-function x))
+  (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))
+  (dotimes (i (- (get-closure-length x) (1- vm:closure-info-offset)))
     (format t "~&~D: ~S" i (%closure-index-ref x i))))
 
 
-- 
GitLab