diff --git a/src/clos/defsys.lsp.in b/src/clos/defsys.lsp.in index 15a95daff..921bc57f1 100644 --- a/src/clos/defsys.lsp.in +++ b/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 () () ()) )) diff --git a/src/clos/inspect.lsp b/src/clos/inspect.lsp index 0c524e76d..ed9c86a20 100644 --- a/src/clos/inspect.lsp +++ b/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))) diff --git a/src/clos/load.lsp.in b/src/clos/load.lsp.in index 2e0390992..8084063cf 100644 --- a/src/clos/load.lsp.in +++ b/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") diff --git a/src/clos/slot.lsp b/src/clos/slot.lsp index 29093b65e..034eb20c7 100644 --- a/src/clos/slot.lsp +++ b/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)) diff --git a/src/lsp/defpackage.lsp b/src/lsp/defpackage.lsp index 58f6b04d8..bcc13723a 100644 --- a/src/lsp/defpackage.lsp +++ b/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)))) diff --git a/src/lsp/defstruct.lsp b/src/lsp/defstruct.lsp index 4a07f7f6a..bb9471f59 100644 --- a/src/lsp/defstruct.lsp +++ b/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) diff --git a/src/lsp/helpfile.lsp b/src/lsp/helpfile.lsp index e68ba7ae2..9d84d8fa7 100644 --- a/src/lsp/helpfile.lsp +++ b/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- diff --git a/src/lsp/setf.lsp b/src/lsp/setf.lsp index 69b1b8c0c..afc7eeb02 100644 --- a/src/lsp/setf.lsp +++ b/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)