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)))))