common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Remove %FUN-DOC

Browse source 
The indirection around function documentation (FUN-DOC calls %FUN-DOC
calls %SIMPLE-FUN-DOC) was excessive and no longer necessary.
This commit is contained in:
Douglas Katzman 2018-07-06 11:41:18 -04:00
parent 017fb98322
commit 4c864f624f
6 changed files with 52 additions and 53 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
package-data-list.lisp-expr
View file

@ -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"

2
src/code/inspect.lisp
View file

@ -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

37
src/code/simple-fun.lisp
View file

@ -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))))

2
src/compiler/macros.lisp
View file

@ -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)

56
src/pcl/documentation.lisp
View file

@ -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))

2
tests/fun-names.pure.lisp
View file

@ -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)))))))