X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdescribe.lisp;h=d459b530fbaab4845f407ed14aaacf8dbabc4563;hb=a22dd643fb599880f4c0856e1a85bffe4358aea8;hp=ee403fa05be9bdd2edac6e70141bc27dbe03eb33;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/pcl/describe.lisp b/src/pcl/describe.lisp index ee403fa..d459b53 100644 --- a/src/pcl/describe.lisp +++ b/src/pcl/describe.lisp @@ -31,6 +31,8 @@ (defmethod describe-object ((object slot-object) stream) + (fresh-line stream) + (let* ((class (class-of object)) (slotds (slots-to-inspect class object)) (max-slot-name-length 0) @@ -38,109 +40,120 @@ (class-slotds ()) (other-slotds ())) + (format stream "~&~@<~S ~_is an instance of class ~S.~:>" object class) + + ;; Figure out a good width for the slot-name column. (flet ((adjust-slot-name-length (name) (setq max-slot-name-length (max max-slot-name-length - (length (the string (symbol-name name)))))) - (describe-slot (name value &optional (allocation () alloc-p)) - (if alloc-p - (format stream - "~% ~A ~S ~VT ~S" - name allocation (+ max-slot-name-length 7) value) - (format stream - "~% ~A~VT ~S" - name max-slot-name-length value)))) - - ;; Figure out a good width for the slot-name column. + (length (the string (symbol-name name))))))) (dolist (slotd slotds) (adjust-slot-name-length (slot-definition-name slotd)) (case (slot-definition-allocation slotd) (:instance (push slotd instance-slotds)) (: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) + (setq max-slot-name-length (min (+ max-slot-name-length 3) 30))) - ;; Now that we know the width, we can print. + ;; Now that we know the width, we can print. + (flet ((describe-slot (name value &optional (allocation () alloc-p)) + (if alloc-p + (format stream + "~& ~A ~S ~VT ~S" + name allocation (+ max-slot-name-length 7) value) + (format stream + "~& ~A~VT ~S" + name max-slot-name-length value)))) (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) (slot-value-or-default object (slot-definition-name slotd)) - (slot-definition-allocation slotd))))))) + (slot-definition-allocation slotd)))))) -(defvar *describe-metaobjects-as-objects-p* nil) + (terpri stream)) (defmethod describe-object ((fun standard-generic-function) stream) - (format stream "~A is a generic function.~%" fun) - (format stream "Its arguments are:~% ~S~%" + (format stream "~&~A is a generic function." fun) + (when (documentation fun t) + (format stream "~& Function documentation: ~A" (documentation fun t))) + (format stream "~&Its lambda-list is:~& ~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)) - (when *describe-metaobjects-as-objects-p* - (call-next-method))) + (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 "~& (~A ~{~S ~}~:S)~%" + gf-name + (method-qualifiers method) + (unparse-specializers method)) + (when (documentation method t) + (format stream "~& Method documentation: ~A" + (documentation method t)))))))) (defmethod describe-object ((class class) stream) (flet ((pretty-class (c) (or (class-name c) c))) (macrolet ((ft (string &rest args) `(format stream ,string ,@args))) - (ft "~&~S is a class, it is an instance of ~S.~%" + (ft "~&~@<~S is a class. It is an instance of ~S.~:@>" class (pretty-class (class-of class))) (let ((name (class-name class))) (if name (if (eq class (find-class name nil)) - (ft "Its proper name is ~S.~%" name) - (ft "Its name is ~S, but this is not a proper name.~%" name)) - (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." + (ft "~&~@" name) + (ft "~&~@" + name)) + (ft "~&~@"))) + (ft "~&~@~%" (mapcar #'pretty-class (class-direct-superclasses class)) (mapcar #'pretty-class (class-direct-subclasses class)) - (mapcar #'pretty-class (class-precedence-list class)) - (length (specializer-direct-methods class))))) - (when *describe-metaobjects-as-objects-p* - (call-next-method))) + (class-finalized-p class) + (mapcar #'pretty-class (cpl-or-nil class)) + (length (specializer-direct-methods class)))))) (defmethod describe-object ((package package) stream) - (pprint-logical-block (stream nil) - (format stream "~&~S is a ~S." package (type-of package)) + (format stream "~&~S is a ~S." package (type-of package)) + (format stream + "~@[~&~@~]" + (package-nicknames package)) + (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 nicknames ~{~:_~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)))) - (format stream - "~&It has ~S internal and ~S external symbols." - internal-count external-count)) + "~&It has ~S internal and ~S external symbols." + internal-count external-count)) + (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 ~{~:_~S~^ ~}~]" - (package-use-list package)) + "~@[~&~@~]" + (humanize (package-use-list package))) (format stream - "~@[~&It is used by ~{~:_~S~^ ~}~]" - (package-used-by-list package)))) + "~@[~&~@~]" + (humanize (package-used-by-list package)))) + (terpri stream))