X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdescribe.lisp;h=dc49e9204c826d9c88d8939269cf0572b7f8c2b6;hb=63cef087068afc157283c0a05ae1f16b962303aa;hp=ee403fa05be9bdd2edac6e70141bc27dbe03eb33;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git

diff --git a/src/pcl/describe.lisp b/src/pcl/describe.lisp
index ee403fa..dc49e92 100644
--- a/src/pcl/describe.lisp
+++ b/src/pcl/describe.lisp
@@ -59,25 +59,25 @@
 	  (:class  (push slotd class-slotds))
 	  (otherwise (push slotd other-slotds))))
       (setq max-slot-name-length  (min (+ max-slot-name-length 3) 30))
-      (format stream "~%~S is an instance of class ~S." object class)
+      (format stream "~&~@<~S ~_is an instance of class ~S.~:>" object class)
 
       ;; Now that we know the width, we can print.
       (when instance-slotds
-	(format stream "~% The following slots have :INSTANCE allocation:")
+	(format stream "~%The following slots have :INSTANCE allocation:")
 	(dolist (slotd (nreverse instance-slotds))
 	  (describe-slot
 	   (slot-definition-name slotd)
 	   (slot-value-or-default object
 				  (slot-definition-name slotd)))))
       (when class-slotds
-	(format stream "~% The following slots have :CLASS allocation:")
+	(format stream "~%The following slots have :CLASS allocation:")
 	(dolist (slotd (nreverse class-slotds))
 	  (describe-slot
 	   (slot-definition-name slotd)
 	   (slot-value-or-default object
 				  (slot-definition-name slotd)))))
       (when other-slotds
-	(format stream "~% The following slots have allocation as shown:")
+	(format stream "~%The following slots have allocation as shown:")
 	(dolist (slotd (nreverse other-slotds))
 	  (describe-slot
 	   (slot-definition-name slotd)
@@ -88,17 +88,22 @@
 (defvar *describe-metaobjects-as-objects-p* nil)
 
 (defmethod describe-object ((fun standard-generic-function) stream)
-  (format stream "~A is a generic function.~%" fun)
+  (format stream "~&~A is a generic function.~%" fun)
   (format stream "Its arguments are:~%  ~S~%"
 	  (generic-function-pretty-arglist fun))
-  (format stream "Its methods are:")
-  (dolist (method (generic-function-methods fun))
-    (format stream "~2%    ~{~S ~}~:S =>~%"
-	    (method-qualifiers method)
-	    (unparse-specializers method))
-    (describe-object (or (method-fast-function method)
-			 (method-function method))
-		     stream))
+  (let ((methods (generic-function-methods fun)))
+    (if (null methods)
+	(format stream "It has no methods.~%")
+	(let ((gf-name (generic-function-name fun)))
+	  (format stream "Its methods are:")
+	  (dolist (method methods)
+	    (format stream "~2%    (~A ~{~S ~}~:S) =>~%"
+		    gf-name
+		    (method-qualifiers method)
+		    (unparse-specializers method))
+	    (describe-object (or (method-fast-function method)
+				 (method-function method))
+			     stream)))))
   (when *describe-metaobjects-as-objects-p*
     (call-next-method)))
 
@@ -115,7 +120,7 @@
 	    (ft "It has no name (the name is NIL).~%")))
       (ft "The direct superclasses are: ~:S, and the direct~%~
 	   subclasses are: ~:S. The class precedence list is:~%~S~%~
-	   There are ~D methods specialized for this class."
+	   There are ~W methods specialized for this class."
 	  (mapcar #'pretty-class (class-direct-superclasses class))
 	  (mapcar #'pretty-class (class-direct-subclasses class))
 	  (mapcar #'pretty-class (class-precedence-list class))
@@ -127,20 +132,24 @@
   (pprint-logical-block (stream nil)
     (format stream "~&~S is a ~S." package (type-of package))
     (format stream
-	    "~@[~&It has nicknames ~{~:_~S~^ ~}~]"
+	    "~@[~&It has nicknames ~2I~{~:_~S~^ ~}~]"
 	    (package-nicknames package))
-    (let* ((internal (sb-impl::package-internal-symbols package))
-	   (internal-count (- (sb-impl::package-hashtable-size internal)
-			      (sb-impl::package-hashtable-free internal)))
-	   (external (sb-impl::package-external-symbols package))
-	   (external-count (- (sb-impl::package-hashtable-size external)
-			      (sb-impl::package-hashtable-free external))))
+    (let* ((internal (package-internal-symbols package))
+	   (internal-count (- (package-hashtable-size internal)
+			      (package-hashtable-free internal)))
+	   (external (package-external-symbols package))
+	   (external-count (- (package-hashtable-size external)
+			      (package-hashtable-free external))))
       (format stream
 	      "~&It has ~S internal and ~S external symbols."
 	      internal-count external-count))
-    (format stream
-	    "~@[~&It uses ~{~:_~S~^ ~}~]"
-	    (package-use-list package))
-    (format stream
-	    "~@[~&It is used by ~{~:_~S~^ ~}~]"
-	    (package-used-by-list package))))
+    (flet (;; Turn a list of packages into something a human likes
+	   ;; to read.
+	   (humanize (package-list)
+	     (sort (mapcar #'package-name package-list) #'string<)))
+      (format stream
+	      "~@[~&It uses packages named ~2I~{~:_~S~^ ~}~]"
+	      (humanize (package-use-list package)))
+      (format stream
+	      "~@[~&It is used by packages named ~2I~{~:_~S~^ ~}~]"
+	      (humanize (package-used-by-list package))))))