From: Nikodemus S. <de...@us...> - 2009-06-21 10:29:56
|
Update of /cvsroot/sbcl/sbcl/src/pcl In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv31988/src/pcl Modified Files: documentation.lisp Log Message: 1.0.29.24: preserve docstrings for local and anonymous functions Based on patch by Lessie Polzer: * Rename SIMPLE-FUN-XREFS to SIMPLE-FUN-INFO. Slot holds the docstring and/or XREF vector for the function. This saves space in the common case of no dostring -- the patch actually ends up shrinking sbcl.core a bit. * Teach the compiler how to grab the docstrings from LAMBDAs and how to preserve them for the lambdas constructed for FLET and LABELS functions. * Store COMPILER-MACRO documentation in the COMPILER-MACRO-FUNCTION. * Store macro documentation in the MACRO-FUNCTION. * Nuke (INFO :FUNCTION :DOCUMENTATION). Index: documentation.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/documentation.lisp,v retrieving revision 1.19 retrieving revision 1.20 diff -u -d -r1.19 -r1.20 --- documentation.lisp 20 Jun 2009 11:37:26 -0000 1.19 +++ documentation.lisp 21 Jun 2009 10:26:25 -0000 1.20 @@ -9,14 +9,14 @@ (in-package "SB-PCL") (defun fun-doc (x) - (etypecase x - (generic-function - (slot-value x '%documentation)) - #+sb-eval - (sb-eval:interpreted-function - (sb-eval:interpreted-function-documentation x)) - (function - (%fun-doc x)))) + (if (typep x 'generic-function) + (slot-value x '%documentation) + (%fun-doc x))) + +(defun (setf fun-doc) (new-value x) + (if (typep x 'generic-function) + (setf (slot-value x '%documentation) new-value) + (setf (%fun-doc x) new-value))) ;;; functions, macros, and special forms (defmethod documentation ((x function) (doc-type (eql 't))) @@ -26,20 +26,20 @@ (fun-doc x)) (defmethod documentation ((x list) (doc-type (eql 'function))) - (and (legal-fun-name-p x) - (fboundp x) - (documentation (fdefinition x) t))) + (when (and (legal-fun-name-p x) (fboundp x)) + (documentation (fdefinition x) t))) (defmethod documentation ((x list) (doc-type (eql 'compiler-macro))) - (random-documentation x 'compiler-macro)) + (awhen (compiler-macro-function x) + (documentation it t))) (defmethod documentation ((x symbol) (doc-type (eql 'function))) - (or (fdocumentation x 'function) - ;; Try the pcl function documentation. - (and (fboundp x) (documentation (fdefinition x) t)))) + (when (fboundp x) + (documentation (symbol-function x) t))) (defmethod documentation ((x symbol) (doc-type (eql 'compiler-macro))) - (random-documentation x 'compiler-macro)) + (awhen (compiler-macro-function x) + (documentation it t))) (defmethod documentation ((x symbol) (doc-type (eql 'setf))) (fdocumentation x 'setf)) @@ -47,42 +47,27 @@ (defmethod documentation ((x symbol) (doc-type (eql 'optimize))) (random-documentation x 'optimize)) -(defun (setf fun-doc) (new-value x) - (etypecase x - (generic-function - (setf (slot-value x '%documentation) new-value)) - #+sb-eval - (sb-eval:interpreted-function - (setf (sb-eval:interpreted-function-documentation x) - new-value)) - (function - (setf (focumentation (%fun-name x) 'function) new-value))) - new-value) - - (defmethod (setf documentation) (new-value (x function) (doc-type (eql 't))) (setf (fun-doc x) new-value)) -(defmethod (setf documentation) (new-value - (x function) - (doc-type (eql 'function))) +(defmethod (setf documentation) (new-value (x function) (doc-type (eql 'function))) (setf (fun-doc x) new-value)) (defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function))) - (setf (fdocumentation x 'function) new-value)) + (when (and (legal-fun-name-p x) (fboundp x)) + (setf (documentation (fdefinition x) t) new-value))) -(defmethod (setf documentation) - (new-value (x list) (doc-type (eql 'compiler-macro))) - (setf (random-documentation x 'compiler-macro) new-value)) +(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'compiler-macro))) + (awhen (compiler-macro-function x) + (setf (documentation it t) new-value))) -(defmethod (setf documentation) (new-value - (x symbol) - (doc-type (eql 'function))) - (setf (fdocumentation x 'function) new-value)) +(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'function))) + (when (and (legal-fun-name-p x) (fboundp x)) + (setf (documentation (symbol-function x) t) new-value))) -(defmethod (setf documentation) - (new-value (x symbol) (doc-type (eql 'compiler-macro))) - (setf (random-documentation x 'compiler-macro) new-value)) +(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'compiler-macro))) + (awhen (compiler-macro-function x) + (setf (documentation it t) new-value))) (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'setf))) (setf (fdocumentation x 'setf) new-value)) |