From f9b461f4e9070735a12d5ef8c4aca4aef6b6e3bd Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Sat, 30 Aug 1997 18:47:40 +0000
Subject: [PATCH] Improved documentation support for CMUCL.

---
 pcl/cmucl-documentation.lisp | 106 +++++++++++++++++++++++++++++++++++
 pcl/defsys.lisp              |   1 +
 2 files changed, 107 insertions(+)
 create mode 100644 pcl/cmucl-documentation.lisp

diff --git a/pcl/cmucl-documentation.lisp b/pcl/cmucl-documentation.lisp
new file mode 100644
index 000000000..4f0cacf24
--- /dev/null
+++ b/pcl/cmucl-documentation.lisp
@@ -0,0 +1,106 @@
+;;;
+;;; **********************************************************************
+;;; This code was written by Douglas T. Crosher and has been placed in
+;;; 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.1 1997/08/30 18:47:40 dtc Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; ANSI CL documentation for CMUCL
+;;; 
+
+(in-package :pcl)
+
+;;; Note some cases are handled by the documentation methods in
+;;; std-class.lisp.
+
+;;; Functions, macros, and special forms.
+(defmethod documentation ((x function) (doc-type (eql 't)))
+  (lisp::function-doc x))
+
+(defmethod documentation ((x function) (doc-type (eql 'function)))
+  (lisp::function-doc x))
+
+(defmethod documentation ((x list) (doc-type (eql 'function)))
+  (or (values (ext:info setf documentation (cadr x)))
+      ;; Try the pcl function documentation.
+      (and (fboundp x) (documentation (fdefinition x) 't))))
+
+(defmethod documentation ((x symbol) (doc-type (eql 'function)))
+  (or (values (ext:info function documentation x))
+      ;; Try the pcl function documentation.
+      (and (fboundp x) (documentation (fdefinition x) 't))))
+
+(defmethod documentation ((x symbol) (doc-type (eql 'setf)))
+  (values (ext:info setf documentation x)))
+
+(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function)))
+  (setf (ext:info setf documentation (cadr x)) new-value))
+
+(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'function)))
+  (setf (ext:info function documentation x) new-value))
+
+(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'setf)))
+  (setf (ext:info setf documentation x) new-value))
+
+;;; Packages.
+(defmethod documentation ((x package) (doc-type (eql 't)))
+  (lisp::package-doc-string x))
+
+(defmethod (setf documentation) (new-value (x package) (doc-type (eql 't)))
+  (setf (lisp::package-doc-string x) new-value))
+
+;;; Types, classes, and structure names.
+(defmethod documentation ((x lisp:structure-class) (doc-type (eql 't)))
+  (values (ext:info type documentation (lisp:class-name x))))
+
+(defmethod documentation ((x structure-class) (doc-type (eql 't)))
+  (values (ext:info type documentation (class-name x))))
+
+(defmethod documentation ((x lisp:structure-class) (doc-type (eql 'type)))
+  (values (ext:info type documentation (lisp:class-name x))))
+
+(defmethod documentation ((x structure-class) (doc-type (eql 'type)))
+  (values (ext:info type documentation (class-name x))))
+
+(defmethod documentation ((x symbol) (doc-type (eql 'type)))
+  (or (values (ext:info type documentation x))
+      (let ((class (find-class x nil)))
+	(when class
+	  (plist-value class 'documentation)))))
+
+(defmethod documentation ((x symbol) (doc-type (eql 'structure)))
+  (when (eq (ext:info type kind x) :instance)
+    (values (ext:info type documentation x))))
+
+(defmethod (setf documentation) (new-value (x lisp:structure-class) (doc-type (eql 't)))
+  (setf (ext:info type documentation (lisp:class-name x)) new-value))
+
+(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 't)))
+  (setf (ext:info type documentation (class-name x)) new-value))
+
+(defmethod (setf documentation) (new-value (x lisp:structure-class) (doc-type (eql 'type)))
+  (setf (ext:info type documentation (lisp:class-name x)) new-value))
+
+(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 'type)))
+  (setf (ext:info type documentation (class-name x)) new-value))
+
+(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type)))
+  (let ((class (find-class x nil)))
+    (if class
+	(setf (plist-value class 'documentation) new-value)
+	(setf (ext:info type documentation x) new-value))))
+
+(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'structure)))
+  (unless (eq (ext:info type kind x) :instance)
+    (error "~S is not the name of a structure type." x))
+  (setf (ext:info type documentation x) new-value))
+
+;;; Variables.
+(defmethod documentation ((x symbol) (doc-type (eql 'variable)))
+  (values (ext:info variable documentation x)))
+
+(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'variable)))
+  (setf (ext:info variable documentation x) new-value))
diff --git a/pcl/defsys.lisp b/pcl/defsys.lisp
index f84658c2c..c3eb0d135 100644
--- a/pcl/defsys.lisp
+++ b/pcl/defsys.lisp
@@ -872,6 +872,7 @@ and load your system with:
    (construct   t                                   t (defclass boot defs low))
    (env         t                                   t (defclass boot defs low fin))
    (compat      t                                   t ())
+   (cmucl-documentation t			    t () CMU)
    (precom1     (dlisp)                             t (defs low cache fin dfun))
    (precom2     (dlisp)                             t (defs low cache fin dfun))
    ))
-- 
GitLab