(in-package "SB-PCL")
-(sb-int:file-comment
- "$Header$")
-
(defmethod slots-to-inspect ((class slot-class) (object slot-object))
(class-slots class))
(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)
- (instance-slotds ())
- (class-slotds ())
- (other-slotds ()))
+ (slotds (slots-to-inspect class object))
+ (max-slot-name-length 0)
+ (instance-slotds ())
+ (class-slotds ())
+ (other-slotds ()))
- (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))))
+ (format stream "~&~@<~S ~_is an instance of class ~S.~:>" object class)
- ;; Figure out a good width for the slot-name column.
+ ;; 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)))))))
(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)
+ (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)))
- ;; 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:")
- (dolist (slotd (nreverse instance-slotds))
- (describe-slot
- (slot-definition-name slotd)
- (slot-value-or-default object
- (slot-definition-name slotd)))))
+ (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:")
- (dolist (slotd (nreverse class-slotds))
- (describe-slot
- (slot-definition-name slotd)
- (slot-value-or-default object
- (slot-definition-name slotd)))))
+ (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:")
- (dolist (slotd (nreverse other-slotds))
- (describe-slot
- (slot-definition-name slotd)
- (slot-value-or-default object
- (slot-definition-name slotd))
- (slot-definition-allocation slotd)))))))
+ (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))))))
-(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~%"
- (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)))
+ (format stream "~&~A is a generic function." fun)
+ (when (documentation fun t)
+ (format stream "~&Its documentation is: ~A" (documentation fun t)))
+ (format stream "~&Its lambda-list is:~& ~S"
+ (generic-function-pretty-arglist fun))
+ (format stream "~&Its method-combination is:~& ~S"
+ (generic-function-method-combination fun))
+ (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 fun (method-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.~%"
- class (pretty-class (class-of class)))
+ (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."
- (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)))
+ (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.~I~_The class is ~:[not ~;~]finalized~
+ ~:[. ~;; its class precedence list is:~2I~_~:*~S.~]~I~_~
+ There ~[are~;is~:;are~] ~:*~S method~:P specialized for ~
+ this class.~:@>~%"
+ (mapcar #'pretty-class (class-direct-superclasses class))
+ (mapcar #'pretty-class (class-direct-subclasses class))
+ (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
- "~@[~&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))
+ (format stream "~&~S is a ~S." package (type-of package))
+ (format stream
+ "~@[~&~@<It has nicknames ~2I~{~:_~S~^ ~}~:>~]"
+ (package-nicknames package))
+ (format stream
+ "~&It has ~S internal and ~S external symbols."
+ (package-internal-symbol-count package)
+ (package-external-symbol-count 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 ~{~:_~S~^ ~}~]"
- (package-use-list package))
+ "~@[~&~@<It uses packages named ~2I~{~:_~S~^ ~}~:>~]"
+ (humanize (package-use-list package)))
(format stream
- "~@[~&It is used by ~{~:_~S~^ ~}~]"
- (package-used-by-list package))))
+ "~@[~&~@<It is used by packages named ~2I~{~:_~S~^ ~}~:>~]"
+ (humanize (package-used-by-list package))))
+ (terpri stream))
projects / sbcl.git / blobdiff