X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdescribe.lisp;h=4b47de6b9b8f2735728aeaca9087a120cf7aaa40;hb=65b5ab7e713d04e0d76bc0ee196374f6e57b922f;hp=7762f8e97db9a580c3e865ad6dcfbfd8686c1d43;hpb=073f54bf68f2917e92e79d1e6564b1623930e8f5;p=sbcl.git

diff --git a/src/code/describe.lisp b/src/code/describe.lisp
index 7762f8e..4b47de6 100644
--- a/src/code/describe.lisp
+++ b/src/code/describe.lisp
@@ -167,42 +167,42 @@
     (base-char "base-char")
     (t "character")))
 
-(defgeneric describe-object (x stream))
-
-(defvar *in-describe* nil)
+(defun print-standard-describe-header (x stream)
+  (format stream "~&~A~%  [~A]~%"
+          (object-self-string x)
+          (object-type-string x)))
 
-(defmethod describe-object :around (x s)
-  (cond (*in-describe*
-         (call-next-method))
-        (t
-         (format s "~&~A~%  [~A]~%"
-                 (object-self-string x)
-                 (object-type-string x))
-         (pprint-logical-block (s nil)
-           (call-next-method x s)))))
+(defgeneric describe-object (x stream))
 
 ;;; Catch-all.
+
 (defmethod describe-object ((x t) s)
-  (values))
+  (print-standard-describe-header x s))
 
 (defmethod describe-object ((x cons) s)
+  (print-standard-describe-header x s)
   (describe-function x nil s))
 
 (defmethod describe-object ((x function) s)
+  (print-standard-describe-header x s)
   (describe-function nil x s))
 
 (defmethod describe-object ((x class) s)
+  (print-standard-describe-header x s)
   (describe-class nil x s)
   (describe-instance x s))
 
 (defmethod describe-object ((x sb-pcl::slot-object) s)
+  (print-standard-describe-header x s)
   (describe-instance x s))
 
 (defmethod describe-object ((x character) s)
+  (print-standard-describe-header x s)
   (format s "~%:_Char-code: ~S" (char-code x))
   (format s "~%:_Char-name: ~A~%_" (char-name x)))
 
 (defmethod describe-object ((x array) s)
+  (print-standard-describe-header x s)
   (format s "~%Element-type: ~S" (array-element-type x))
   (if (vectorp x)
       (if (array-has-fill-pointer-p x)
@@ -225,9 +225,11 @@
     (terpri s)))
 
 (defmethod describe-object ((x hash-table) s)
-  ;; Don't print things which are already apparent from the printed representation
-  ;; -- COUNT, TEST, and WEAKNESS
-  (format s "~%Occupancy: ~,1F" (float (/ (hash-table-count x) (hash-table-size x))))
+  (print-standard-describe-header x s)
+  ;; Don't print things which are already apparent from the printed
+  ;; representation -- COUNT, TEST, and WEAKNESS
+  (format s "~%Occupancy: ~,1F" (float (/ (hash-table-count x)
+                                          (hash-table-size x))))
   (format s "~%Rehash-threshold: ~S" (hash-table-rehash-threshold x))
   (format s "~%Rehash-size: ~S" (hash-table-rehash-size x))
   (format s "~%Size: ~S" (hash-table-size x))
@@ -235,6 +237,7 @@
   (terpri s))
 
 (defmethod describe-object ((symbol symbol) stream)
+  (print-standard-describe-header symbol stream)
   ;; Describe the value cell.
   (let* ((kind (info :variable :kind symbol))
          (wot (ecase kind
@@ -318,41 +321,43 @@
       (terpri stream))))
 
 (defmethod describe-object ((package package) stream)
-  (describe-documentation package t stream)
-  (flet ((humanize (list)
-           (sort (mapcar (lambda (x)
-                           (if (packagep x)
-                               (package-name x)
-                               x))
-                         list)
-                 #'string<))
-         (out (label list)
-           (describe-stuff label list stream :escape nil)))
-    (let ((implemented (humanize (package-implemented-by-list package)))
-          (implements (humanize (package-implements-list package)))
-          (nicks (humanize (package-nicknames package)))
-          (uses (humanize (package-use-list package)))
-          (used (humanize (package-used-by-list package)))
-          (shadows (humanize (package-shadowing-symbols package)))
-          (this (list (package-name package)))
-          (exports nil))
-      (do-external-symbols (ext package)
-        (push ext exports))
-      (setf exports (humanize exports))
-      (when (package-locked-p package)
-        (format stream "~@:_Locked."))
-      (when (set-difference implemented this :test #'string=)
-        (out "Implemented-by-list" implemented))
-      (when (set-difference implements this :test #'string=)
-        (out "Implements-list" implements))
-      (out "Nicknames" nicks)
-      (out "Use-list" uses)
-      (out "Used-by-list" used)
-      (out "Shadows" shadows)
-      (out "Exports" exports)
-      (format stream "~@:_~S internal symbols."
-              (package-internal-symbol-count package))))
-  (terpri stream))
+  (print-standard-describe-header package stream)
+  (pprint-logical-block (stream nil)
+    (describe-documentation package t stream)
+    (flet ((humanize (list)
+             (sort (mapcar (lambda (x)
+                             (if (packagep x)
+                                 (package-name x)
+                                 x))
+                           list)
+                   #'string<))
+           (out (label list)
+             (describe-stuff label list stream :escape nil)))
+      (let ((implemented (humanize (package-implemented-by-list package)))
+            (implements (humanize (package-implements-list package)))
+            (nicks (humanize (package-nicknames package)))
+            (uses (humanize (package-use-list package)))
+            (used (humanize (package-used-by-list package)))
+            (shadows (humanize (package-shadowing-symbols package)))
+            (this (list (package-name package)))
+            (exports nil))
+        (do-external-symbols (ext package)
+          (push ext exports))
+        (setf exports (humanize exports))
+        (when (package-locked-p package)
+          (format stream "~@:_Locked."))
+        (when (set-difference implemented this :test #'string=)
+          (out "Implemented-by-list" implemented))
+        (when (set-difference implements this :test #'string=)
+          (out "Implements-list" implements))
+        (out "Nicknames" nicks)
+        (out "Use-list" uses)
+        (out "Used-by-list" used)
+        (out "Shadows" shadows)
+        (out "Exports" exports)
+        (format stream "~@:_~S internal symbols."
+                (package-internal-symbol-count package))))
+    (terpri stream)))
 
 ;;;; Helpers to deal with shared functionality