From 4c864f624f2471e5dfba749f0a5367020cb1ac8d Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Fri, 6 Jul 2018 11:41:18 -0400 Subject: [PATCH] Remove %FUN-DOC The indirection around function documentation (FUN-DOC calls %FUN-DOC calls %SIMPLE-FUN-DOC) was excessive and no longer necessary. --- package-data-list.lisp-expr | 6 +++- src/code/inspect.lisp | 2 +- src/code/simple-fun.lisp | 37 ------------------------ src/compiler/macros.lisp | 2 +- src/pcl/documentation.lisp | 56 +++++++++++++++++++++++++++++-------- tests/fun-names.pure.lisp | 2 +- 6 files changed, 52 insertions(+), 53 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index ff8ac9c7e..b0c6b82b1 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1373,6 +1373,11 @@ possibly temporarily, because it might be used internally." "DESCRIPTOR-SAP" "DO-PACKED-VARINTS" + "CLOSURE-EXTRA-VALUES" + "PACK-CLOSURE-EXTRA-VALUES" + "SET-CLOSURE-EXTRA-VALUES" + "+CLOSURE-NAME-INDEX+" + ;; These could be moved back into SB!EXT if someone has ;; compelling reasons, but hopefully we can get by ;; without supporting them, at least not as publicly @@ -2105,7 +2110,6 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%CLOSURE-VALUES" ;; Abstract function accessors - "%FUN-DOC" "%FUN-FUN" "%FUN-LAMBDA-LIST" "%FUN-NAME" diff --git a/src/code/inspect.lisp b/src/code/inspect.lisp index c2333541f..007532855 100644 --- a/src/code/inspect.lisp +++ b/src/code/inspect.lisp @@ -238,7 +238,7 @@ evaluated expressions. (list (cons "Lambda-list" (%fun-lambda-list object)) (cons "Definition" defn) - (cons "Documentation" (%fun-doc object)))))) + (cons "Documentation" (documentation object t)))))) (defmethod inspected-parts ((object vector)) (values (format nil diff --git a/src/code/simple-fun.lisp b/src/code/simple-fun.lisp index ee997e3d0..ee89d43e4 100644 --- a/src/code/simple-fun.lisp +++ b/src/code/simple-fun.lisp @@ -334,43 +334,6 @@ (bug "bogus INFO for ~S: ~S" simple-fun info))))) doc) -(defun %fun-doc (function) - (typecase function - #!+sb-fasteval - (sb!interpreter:interpreted-function - (sb!interpreter:proto-fn-docstring (sb!interpreter:fun-proto-fn function))) - #!+sb-eval - (sb!eval:interpreted-function - (sb!eval:interpreted-function-documentation function)) - (t - (when (closurep function) - (let ((val (nth-value +closure-doc-index+ (closure-extra-values function)))) - (unless (unbound-marker-p val) - (return-from %fun-doc val)))) - (%simple-fun-doc (%fun-fun function))))) - -(defun (setf %fun-doc) (new-value function) - (declare (type (or null string) new-value)) - (typecase function - #!+sb-fasteval - (sb!interpreter:interpreted-function - (setf (sb!interpreter:proto-fn-docstring - (sb!interpreter:fun-proto-fn function)) new-value)) - #!+sb-eval - (sb!eval:interpreted-function - (setf (sb!eval:interpreted-function-documentation function) new-value)) - (closure - (set-closure-extra-values - function nil - (pack-closure-extra-values - (nth-value +closure-name-index+ (closure-extra-values function)) - new-value))) - (simple-fun - ;; Don't allow PCL CTORs and other random functions through - ;; because we don't want to affect builtin docstrings. - (setf (%simple-fun-doc function) new-value))) - new-value) - (defun %simple-fun-next (simple-fun) ; DO NOT USE IN NEW CODE (%code-entry-point (fun-code-header simple-fun) (1+ (%simple-fun-index simple-fun)))) diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index aa9fc90bb..0a2d06a70 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -50,7 +50,7 @@ (values)) #-sb-xc-host (progn (install-guard-function ',name '(:special ,name)) - (setf (%fun-doc (symbol-function ',name)) ',doc)) + (setf (documentation (symbol-function ',name) t) ',doc)) ;; FIXME: Evidently "there can only be one!" -- we overwrite any ;; other :IR1-CONVERT value. This deserves a warning, I think. (setf (info :function :ir1-convert ',name) #',fn-name) diff --git a/src/pcl/documentation.lisp b/src/pcl/documentation.lisp index e6cbfde12..af2b3d499 100644 --- a/src/pcl/documentation.lisp +++ b/src/pcl/documentation.lisp @@ -8,6 +8,48 @@ (in-package "SB-PCL") +(defun fun-doc (function) + (typecase function + #+sb-fasteval + (sb-interpreter:interpreted-function + (sb-interpreter:proto-fn-docstring (sb-interpreter:fun-proto-fn function))) + #+sb-eval + (sb-eval:interpreted-function + (sb-eval:interpreted-function-documentation function)) + (generic-function + (slot-value function '%documentation)) + (t + (when (closurep function) + (let ((val (nth-value sb-impl::+closure-doc-index+ + (closure-extra-values function)))) + (unless (unbound-marker-p val) + (return-from fun-doc val)))) + (%simple-fun-doc (%fun-fun function))))) + +(defun (setf fun-doc) (new-value function) + (declare (type (or null string) new-value)) + (typecase function + #+sb-fasteval + (sb-interpreter:interpreted-function + (setf (sb-interpreter:proto-fn-docstring + (sb-interpreter:fun-proto-fn function)) new-value)) + #+sb-eval + (sb-eval:interpreted-function + (setf (sb-eval:interpreted-function-documentation function) new-value)) + (generic-function + (setf (slot-value function '%documentation) new-value)) + (closure + (set-closure-extra-values + function nil + (pack-closure-extra-values + (nth-value +closure-name-index+ (closure-extra-values function)) + new-value))) + (simple-fun + ;; Don't allow PCL CTORs and other random functions through + ;; because we don't want to affect builtin docstrings. + (setf (%simple-fun-doc function) new-value))) + new-value) + ;;; (SETF %DOC-INFO) is a thin wrapper on INFO that set or clears ;;; a :DOCUMENTATION info value depending on whether STRING is NIL. ;;; It, and the corresponding reader, are not for use outside this file. @@ -49,7 +91,7 @@ ((not (equal (sb-c::real-function-name name) name)) (setf (random-documentation name 'function) string)) (t - (setf (%fun-doc (fdefinition name)) string)))) + (setf (fun-doc (fdefinition name)) string)))) ((typep name '(or symbol cons)) (setf (random-documentation name doc-type) string))))) @@ -73,7 +115,7 @@ (t (and (typep x 'symbol) (values (info :type :documentation x)))))) ((t) (typecase x - (function (%fun-doc x)) + (function (fun-doc x)) (structure-class (values (info :type :documentation (class-name x)))) ((or symbol cons) (random-documentation x doc-type)))) @@ -81,16 +123,6 @@ (when (typep x '(or symbol cons)) (random-documentation x doc-type))))) -(defun 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))) - (defun set-function-name-documentation (name documentation) (aver name) (cond ((not (legal-fun-name-p name)) diff --git a/tests/fun-names.pure.lisp b/tests/fun-names.pure.lisp index 2661a535d..b024cb57e 100644 --- a/tests/fun-names.pure.lisp +++ b/tests/fun-names.pure.lisp @@ -55,5 +55,5 @@ (sb-impl::closure-extra-values closure) (assert (eq stored-name name)) (assert (eq stored-doc doc))) - (assert (string= (sb-kernel:%fun-doc closure) + (assert (string= (documentation closure t) (if (eq doc sb-pcl:+slot-unbound+) "doc" doc)))))))