Redefine DOCUMENTATION as a generic function which can also handle

packages, structures, classes, etc.

src/clos/defsys.lsp.in

@@ -32,12 +32,12 @@
     (defclass  (kernel slot)     (kernel slot)          (boot))
     (standard  (boot defclass precomp)
 	      			 (boot defclass)	(method defclass))
-    (inspect   (standard)        (standard)             (standard))
     (change    (standard)	 (standard)		(standard))
     (builtin   (standard)        (standard)	   	(standard))
     (stdmethod (builtin)	 (builtin)	        (builtin))
     (generic   (stdmethod)       (stdmethod)            ())
     (fixup     (stdmethod)       (stdmethod)            (standard))
+    (inspect   (standard)        (standard)             (standard))
     (conditions ()		 ()			())
     ))
 

src/clos/inspect.lsp

@@ -456,3 +456,65 @@ q (or Q):             quits the inspection.~%~
   (incf si::*inspect-level*))
 
 ;;; -------------------------------------------------------------------------
+;;;
+;;; Documentation
+;;;
+
+(defconstant +valid-documentation-types+
+    '(compiler-macro function method-combination setf structure
+      t type variable))
+
+(defgeneric documentation (object doc-type))
+(defgeneric (setf documentation) (new-value object doc-type))
+
+(defmethod documentation ((object symbol) doc-type)
+  (when (member doc-type +valid-documentation-types+)
+    (or (when (eq doc-type 'type)
+	  (let ((c (find-class object nil)))
+	    (and c (documentation c t))))
+	(si::get-documentation object doc-type))))
+
+(defmethod (setf documentation) (new-value (object symbol) doc-type)
+  (when (member doc-type +valid-documentation-types+)
+    (or (when (eq doc-type 'type)
+	  (let ((c (find-class object nil)))
+	    (when c
+	      (si::set-documentation object 'type nil)
+	      (si::set-documentation object 'structure nil)
+	      (setf (documentation c t) new-value))))
+	(si::get-documentation object doc-type)))
+  new-value)
+
+(defmethod documentation ((object package) doc-type)
+  (when (member doc-type '(t package))
+    (si::get-documentation object 'package)))
+
+(defmethod (setf documentation) (new-value (object package) doc-type)
+  (when (member doc-type '(t package))
+    (si::set-documentation object 'package new-value)))
+
+(defmethod documentation ((object class) doc-type)
+  (when (member doc-type '(t type))
+    (clos::documentation-of object)))
+
+(defmethod (setf documentation) (new-value (object class) doc-type)
+  (when (member doc-type '(t type))
+    (setf (clos::documentation-of object) new-value)))
+
+(defmethod documentation ((object structure-class) doc-type)
+  (when (member doc-type '(t type))
+    (si::get-documentation (class-name object) 'structure)))
+
+(defmethod (setf documentation) (new-value (object class) doc-type)
+  (when (member doc-type '(t type))
+    (setf (documentation (class-name object) 'structure) new-value)))
+
+(defmethod documentation ((object list) doc-type)
+  (when (and (si::valid-function-name-p list)
+	     (member doc-type '(function compiler-macro)))
+    (si::get-documentation object doc-type)))
+
+(defmethod (setf documentation) (new-value (object list) doc-type)
+  (when (and (si::valid-function-name-p object)
+	     (member doc-type '(function compiler-macro)))
+    (si::set-documentation object doc-type new-value)))

src/clos/load.lsp.in

@@ -10,10 +10,10 @@
 (load "@srcdir@/print")
 (load "@srcdir@/defclass")
 (load "@srcdir@/standard")
-(load "@srcdir@/inspect")
 (load "@srcdir@/change")
 (load "@srcdir@/builtin")
 (load "@srcdir@/stdmethod")
 (load "@srcdir@/generic")
 (load "@srcdir@/fixup")
+(load "@srcdir@/inspect")
 (load "@srcdir@/conditions")

src/clos/slot.lsp

@@ -61,15 +61,14 @@
                      (:documentation     (push value documentation)))))))
 
     (setf (slotd-name slotd)       name
-;	  (slotd-keyword slotd)    (make-keyword name)
 	  (slotd-initargs slotd)   initargs
 	  (slotd-initform slotd)   initform
 	  (slotd-accessors slotd)  accessors
 	  (slotd-readers slotd)    readers
 	  (slotd-writers slotd)    writers
 	  (slotd-allocation slotd) allocation
-	  (slotd-type slotd)       type)
-;	  (slotd-documentation slotd)    documentation
+	  (slotd-type slotd)       type
+	  (slotd-documentation slotd)    documentation)
 
     slotd))
 

src/lsp/defpackage.lsp

@@ -201,10 +201,9 @@
       (when use
 	(unuse-package (package-use-list (find-package name)) name)))
     (make-package name :use nil :nicknames nicknames))
-  #+nil
-  (when documentation ((put-sysprop (intern name :keyword) :package-documentation
-				    documentation)))
   (let ((*package* (find-package name)))
+    (when documentation
+      (setf (documentation *package* t) documentation))
     (shadow shadowed-symbol-names)
     (dolist (item shadowing-imported-from-symbol-names-list)
       (let ((package (find-package (first item))))

src/lsp/defstruct.lsp

@@ -250,6 +250,7 @@
   (put-sysprop name 'STRUCTURE-NAMED named)
   (put-sysprop name 'STRUCTURE-OFFSET offset)
   (put-sysprop name 'STRUCTURE-CONSTRUCTORS constructors)
+  #+clos
   (when *keep-documentation*
     (sys:set-documentation name 'STRUCTURE documentation))
   (and (consp type) (eq (car type) 'VECTOR)

src/lsp/helpfile.lsp

@@ -46,7 +46,8 @@
 		 hash-table)
 	(setq hash-table (pop *documentation-pool*))))
     (maphash #'(lambda (key doc)
-		 (when doc (push (cons key doc) entries)))
+		 (when (and (symbolp key) doc)
+		   (push (cons key doc) entries)))
 	     hash-table)
     (setq entries (sort entries #'string-lessp :key #'car))
     (let* ((*package* (find-package "CL"))
@@ -96,7 +97,6 @@
   (setq *documentation-pool* nil)
   (*make-special '*keep-documentation*)
   (setq *keep-documentation* t))
-
 #-ecl-min
 (progn
   (defvar *documentation-pool* (list (make-hash-table :test #'eq :size 128)
@@ -119,35 +119,30 @@ the help file."
       (dump-help-file dict file merge)
       (rplaca *documentation-pool* file))))
 
-(defun get-documentation (symbol doc-type &aux output)
-  (when (not (member doc-type '(variable function setf type structure)))
-    (error "~S is not a valid documentation type" doc-type))
+(defun get-documentation (object doc-type &aux output)
   (dolist (dict *documentation-pool*)
     (cond ((hash-table-p dict)
-	   (when (and (setq output (gethash symbol dict))
+	   (when (and (setq output (gethash object dict))
 		      (setq output (getf output doc-type)))
 	     (return-from get-documentation output)))
-	  ((stringp dict)
-	   (when (and (setq output (search-help-file symbol dict))
+	  ((and (symbolp object) (stringp dict))
+	   (when (and (setq output (search-help-file object dict))
 		      (setq output (getf output doc-type)))
 	     (return-from get-documentation output)))))))
 
-(defun set-documentation (symbol doc-type string)
-  (tan 1.0)
-  (when (not (member doc-type '(variable function setf type structure)))
-    (error "~S is not a valid documentation type" doc-type))
+(defun set-documentation (object doc-type string)
   (when (not (or (stringp string) (null string)))
     (error "~S is not a valid documentation string" string))
   (let ((dict (first *documentation-pool*)))
     (when (hash-table-p dict)
-      (let ((plist (gethash symbol dict)))
+      (let ((plist (gethash object dict)))
 	(setq plist (if string
 			(put-f plist string doc-type)
 			(rem-f plist doc-type)))
 	(if plist
-	  (si::hash-set symbol dict plist)
-	  (remhash symbol dict)))))
-  nil)
+	  (si::hash-set object dict plist)
+	  (remhash object dict)))))
+  string)
 
 (defun expand-set-documentation (symbol doc-type string)
   (when (and *keep-documentation* string)
@@ -155,6 +150,7 @@ the help file."
       (error "~S is not a valid documentation string" string))
     `((set-documentation ',symbol ',doc-type ,string))))
 
+#-clos
 (defun documentation (object type)
   "Args: (symbol doc-type)
 Returns the DOC-TYPE doc-string of SYMBOL; NIL if none exists.  Possible doc-

src/lsp/setf.lsp

@@ -206,6 +206,7 @@ Does not check if the third gang is a single-element list."
 (defsetf fill-pointer sys:fill-pointer-set)
 (defsetf symbol-plist sys:set-symbol-plist)
 (defsetf gethash (k h &optional d) (v) `(sys:hash-set ,k ,h ,v))
+#-clos
 (defsetf documentation (s d) (v) `(sys::set-documentation ,s ,d ,v))
 #+clos
 (defsetf sys:instance-ref sys:instance-set)