diff --git a/code/describe.lisp b/code/describe.lisp index 30fd374bcd18ba2743138ac713445ab9e48a55c1..c368598c9da90b8c996d773a009340b6ce2b9d09 100644 --- a/code/describe.lisp +++ b/code/describe.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/describe.lisp,v 1.39 2003/02/05 11:08:45 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/describe.lisp,v 1.40 2003/02/06 15:20:13 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -430,9 +430,14 @@ (format t "~&Documentation on the ~(~A~):~%~A" (car assoc) (cdr assoc))) ;; ;; Print Class information - (when (find-class x nil) - (format t "~&It names a class ~A." (find-class x)) - (describe (find-class x))) + (let ((class (find-class x nil))) + (when class + (format t "~&It names a class ~A." class) + (describe class) + (let ((pcl-class (class-pcl-class class))) + (when pcl-class + (format t "~&It names a PCL class ~A." pcl-class) + (describe pcl-class))))) ;; ;; Print out information about any types named by the symbol (when (eq (info type kind x) :defined) diff --git a/pcl/cmucl-documentation.lisp b/pcl/cmucl-documentation.lisp index 2fc9c2d156c72146c2928143478c57f4e3a85291..aa190d689195f46e4138c946996a0827dfb69d13 100644 --- a/pcl/cmucl-documentation.lisp +++ b/pcl/cmucl-documentation.lisp @@ -4,7 +4,7 @@ ;;; the public domain, and is provided 'as is'. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cmucl-documentation.lisp,v 1.8 2002/08/27 19:01:37 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cmucl-documentation.lisp,v 1.9 2003/02/06 15:20:13 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -125,11 +125,7 @@ (values (ext:info random-documentation stuff x))))) (defmethod (setf documentation) (new-value (x symbol) (doc-type symbol)) - (let ((pair (assoc doc-type (ext:info random-documentation stuff x)))) - (if pair - (setf (cdr pair) new-value) - (push (cons doc-type new-value) - (ext:info random-documentation stuff x)))) + (set-random-documentation x doc-type new-value) new-value) ;;; Replace the minimal documentation function with the PCL version diff --git a/pcl/defcombin.lisp b/pcl/defcombin.lisp index 22fdecfe56d3e38d65bc9ddef3a33929a9d639e7..3987e32619d535b0a9be234cf04acdfd4c32ead2 100644 --- a/pcl/defcombin.lisp +++ b/pcl/defcombin.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.20 2003/01/03 18:50:23 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.21 2003/02/06 15:20:13 gerd Exp $") ;;; (in-package :pcl) @@ -120,6 +120,14 @@ `(load-short-defcombin ',type ',operator ',identity-with-one-arg ',documentation)))) +(defun set-random-documentation (type doc-type doc) + (let ((pair (assoc doc-type + (ext:info random-documentation stuff type)))) + (if pair + (setf (cdr pair) doc) + (push (cons doc-type doc) + (ext:info random-documentation stuff type))))) + (defun load-short-defcombin (type operator ioa doc) (let* ((specializers (list (find-class 'generic-function) @@ -133,7 +141,7 @@ :qualifiers () :specializers specializers :lambda-list '(generic-function type options) - :function (lambda(args nms &rest cm-args) + :function (lambda (args nms &rest cm-args) (declare (ignore nms cm-args)) (apply (lambda (gf type options) @@ -146,6 +154,7 @@ (when old-method (remove-method #'find-method-combination old-method)) (add-method #'find-method-combination new-method) + (set-random-documentation type 'method-combination doc) type)) (defun make-short-method-combination (type options operator ioa method doc) @@ -271,6 +280,7 @@ (setf (gethash type *long-method-combination-functions*) function) (when old-method (remove-method #'find-method-combination old-method)) (add-method #'find-method-combination new-method) + (set-random-documentation type 'method-combination doc) type)) (defmethod compute-effective-method ((generic-function generic-function) diff --git a/pcl/defs.lisp b/pcl/defs.lisp index 399cc71309312650dd3e529666c654877562a54f..028db2f44d5a8e2d083b56e49c69ea32a5ea41c4 100644 --- a/pcl/defs.lisp +++ b/pcl/defs.lisp @@ -648,7 +648,7 @@ (defclass method (standard-object) ()) -(defclass standard-method (definition-source-mixin plist-mixin method) +(defclass standard-method (definition-source-mixin documentation-mixin method) ((generic-function :initform nil :accessor method-generic-function) diff --git a/pcl/env.lisp b/pcl/env.lisp index 05eb4571f598cdf5d36ea69481e3f838a9191e97..0f4acbea7acce85e49f629d2753b00b509728b3c 100644 --- a/pcl/env.lisp +++ b/pcl/env.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/env.lisp,v 1.16 2002/11/28 16:23:33 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/env.lisp,v 1.17 2003/02/06 15:20:12 gerd Exp $") ;;; ;;; Basic environmental stuff. ;;; @@ -100,20 +100,24 @@ (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 "Its arguments are:~% ~S~%" - (generic-function-pretty-arglist fun)) - (format stream "Its methods are:") - (dolist (meth (generic-function-methods fun)) - (format stream "~2% ~{~S ~}~:S =>~%" - (method-qualifiers meth) - (unparse-specializers meth)) - (describe-object (or (method-fast-function meth) - (method-function meth)) - stream)) - (when *describe-metaobjects-as-objects-p* - (call-next-method))) +(defmethod describe-object ((gf standard-generic-function) stream) + (format stream "~A is a generic function.~%" gf) + (let* ((gf-name (generic-function-name gf)) + (doc (documentation gf-name 'function))) + (format stream "Its arguments are:~% ~S~%" + (generic-function-pretty-arglist gf)) + (when doc + (format stream "Generic function documentation:~% ~s~%" doc)) + (format stream "Its methods are:~%") + (loop for method in (generic-function-methods gf) and i from 1 + as doc = (plist-value method 'documentation) do + (format stream " ~d: ~a ~@[~{~s ~}~]~:s~%" + i gf-name (method-qualifiers method) + (unparse-specializers method)) + (when doc + (format stream " Method documentation: ~s~%" doc))) + (when *describe-metaobjects-as-objects-p* + (call-next-method)))) ;;; ;;; @@ -121,7 +125,7 @@ (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 @@ -135,7 +139,13 @@ (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))))) + (length (specializer-direct-methods class))) + (loop initially + (ft "~&Its direct slots are:~%") + for slotd in (class-direct-slots class) + as name = (slot-definition-name slotd) + as doc = (slot-value slotd 'documentation) do + (ft " ~a~@[, documentation ~s~]~%" name doc)))) (when *describe-metaobjects-as-objects-p* (call-next-method))) diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index 6f019c0857cb89bbd5c8da2f46c74b325907cdce..175919f1c0f89537812468678a7d2e5116727102 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.42 2003/01/03 21:41:00 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.43 2003/02/06 15:20:12 gerd Exp $") ;;; (in-package :pcl) @@ -114,7 +114,7 @@ &key (documentation nil documentation-p)) (declare (ignore slot-names)) (when documentation-p - (setf (plist-value object 'documentation) documentation))) + (setf (documentation object nil) documentation))) (defmethod documentation (object doc-type) (declare (ignore object doc-type)) @@ -132,7 +132,6 @@ (declare (ignore doc-type)) (setf (plist-value object 'documentation) new-value)) - (defmethod documentation ((slotd standard-slot-definition) doc-type) (declare (ignore doc-type)) (slot-value slotd 'documentation)) @@ -141,6 +140,11 @@ (declare (ignore doc-type)) (setf (slot-value slotd 'documentation) new-value)) +(defmethod (setf documentation) (doc (gf generic-function) type) + (declare (ignore type)) + (setf (ext:info function documentation (generic-function-name gf)) + doc)) + ;;; ;;; Various class accessors that are a little more complicated than can be