X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdescribe.lisp;h=acd6eec584f536bac2f7a577b13ed5e05d4c90ff;hb=a4640afb239d4de3e348430fd9903fc3a88b9139;hp=e9ae2a43752412b721f30dc8c5db3dfe1e116a89;hpb=648b48d2406f6d6f2bf341bf8ed350aac85398d0;p=sbcl.git diff --git a/src/pcl/describe.lisp b/src/pcl/describe.lisp index e9ae2a4..acd6eec 100644 --- a/src/pcl/describe.lisp +++ b/src/pcl/describe.lisp @@ -32,122 +32,130 @@ (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 ())) (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))))))) + (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)))) + (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. (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)))) + (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)))))) (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)) + (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 "~2% (~A ~{~S ~}~:S) =>" - gf-name - (method-qualifiers method) - (unparse-specializers method)) - (describe (or (method-fast-function method) - (method-function method)) - stream)))))) + (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." - 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 "~&~@~%" - (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)))))) + (if name + (if (eq class (find-class name nil)) + (ft "~&~@" name) + (ft "~&~@" + name)) + (ft "~&~@"))) + (ft "~&~@~%" + (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) (format stream "~&~S is a ~S." package (type-of package)) (format stream - "~@[~&~@~]" - (package-nicknames package)) + "~@[~&~@~]" + (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)))) + (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)) + "~&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<))) + ;; to read. + (humanize (package-list) + (sort (mapcar #'package-name package-list) #'string<))) (format stream - "~@[~&~@~]" - (humanize (package-use-list package))) + "~@[~&~@~]" + (humanize (package-use-list package))) (format stream - "~@[~&~@~]" - (humanize (package-used-by-list package)))) + "~@[~&~@~]" + (humanize (package-used-by-list package)))) (terpri stream))