From f181ad9ffeeadf341b6a16c3591eadf0c1e3fa61 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 21 Jun 2009 10:26:24 +0000 Subject: [PATCH] 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). --- NEWS | 2 + package-data-list.lisp-expr | 2 + src/code/defboot.lisp | 7 +--- src/code/defmacro.lisp | 6 ++- src/code/describe.lisp | 2 +- src/code/fop.lisp | 4 +- src/code/kernel.lisp | 45 +++++++++++++++++++++ src/code/macros.lisp | 3 +- src/code/target-misc.lisp | 26 +++++++----- src/compiler/dump.lisp | 2 +- src/compiler/entry.lisp | 7 +++- src/compiler/generic/genesis.lisp | 4 +- src/compiler/generic/objdef.lisp | 15 ++++--- src/compiler/generic/target-core.lisp | 2 +- src/compiler/globaldb.lisp | 6 --- src/compiler/info-functions.lisp | 10 +++-- src/compiler/ir1-translators.lisp | 3 +- src/compiler/ir1tran-lambda.lisp | 3 +- src/compiler/macros.lisp | 31 ++++++++------ src/compiler/node.lisp | 2 + src/compiler/vop.lisp | 4 +- src/pcl/documentation.lisp | 71 +++++++++++++-------------------- src/runtime/gc-common.c | 2 +- tests/interface.impure.lisp | 48 +++++++++++++++++++++- version.lisp-expr | 2 +- 25 files changed, 203 insertions(+), 106 deletions(-) diff --git a/NEWS b/NEWS index 8bd29ad..15c33b4 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,8 @@ * minor incompatible change: SB-THREAD:JOIN-THREAD-ERROR-THREAD and SB-THREAD:INTERRUPT-THREAD-ERROR-THREAD have been deprecated in favor of SB-THREAD:THREAD-ERROR-THREAD. + * new feature: docstrings for local and anonymous functions are no longer + discarded. (thanks to Leslie Polzer) * new feature: SB-THREAD:SYMBOL-VALUE-IN-THREAD provides access to symbol values in other threads. * new feature: SB-INTROSPECT:ALLOCATION-INFORMATION provides information diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 6037122..320a078 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1694,6 +1694,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "SIMPLE-FUN" "SIMPLE-FUN-P" "%SIMPLE-FUN-ARGLIST" + "%SIMPLE-FUN-DOC" + "%SIMPLE-FUN-INFO" "%SIMPLE-FUN-NAME" "%SIMPLE-FUN-NEXT" "%SIMPLE-FUN-SELF" diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index d83ca1a..4147b0e 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -232,11 +232,8 @@ evaluated as a PROGN." (sb!c::note-name-defined name :function) (when doc - (setf (fdocumentation name 'function) doc) - #!+sb-eval - (when (typep def 'sb!eval:interpreted-function) - (setf (sb!eval:interpreted-function-documentation def) - doc))) + (setf (%fun-doc def) doc)) + name) ;;;; DEFVAR and DEFPARAMETER diff --git a/src/code/defmacro.lisp b/src/code/defmacro.lisp index 41a8d10..0f43bd6 100644 --- a/src/code/defmacro.lisp +++ b/src/code/defmacro.lisp @@ -90,8 +90,10 @@ ;; will involve finding the old macro lambda-list ;; and comparing it with the new one. (style-warn "redefining ~S in DEFMACRO" name)) - (setf (sb!xc:macro-function name) definition - (fdocumentation name 'function) doc) + (setf (sb!xc:macro-function name) definition) + #-sb-xc-host + (when doc + (setf (%fun-doc definition) doc)) ,(when set-p `(setf (%fun-lambda-list definition) lambda-list (%fun-name definition) debug-name)) diff --git a/src/code/describe.lisp b/src/code/describe.lisp index b4f1b94..619b224 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -117,7 +117,7 @@ (declaim (ftype (function (t stream t t) (values)) %describe-doc)) (defun %describe-doc (name s kind kind-doc) (when (and name (typep name '(or symbol cons))) - (let ((doc (fdocumentation name kind))) + (let ((doc (documentation name kind))) (when doc (format s "~&~@(~A documentation:~)~% ~A" (or kind-doc kind) doc)))) diff --git a/src/code/fop.lisp b/src/code/fop.lisp index 999faa3..6b2809d 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -662,7 +662,7 @@ a bug.~@:>") #+sb-xc-host ; since xc host doesn't know how to compile %PRIMITIVE (error "FOP-FUN-ENTRY can't be defined without %PRIMITIVE.") #-sb-xc-host - (let ((xrefs (pop-stack)) + (let ((info (pop-stack)) (type (pop-stack)) (arglist (pop-stack)) (name (pop-stack)) @@ -678,7 +678,7 @@ a bug.~@:>") (setf (%simple-fun-name fun) name) (setf (%simple-fun-arglist fun) arglist) (setf (%simple-fun-type fun) type) - (setf (%simple-fun-xrefs fun) xrefs) + (setf (%simple-fun-info fun) info) ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL. #+nil (when *load-print* (load-fresh-line) diff --git a/src/code/kernel.lisp b/src/code/kernel.lisp index 6eb5781..7bf7e4e 100644 --- a/src/code/kernel.lisp +++ b/src/code/kernel.lisp @@ -87,6 +87,48 @@ (deftype simple-fun () '(satisfies simple-fun-p)) +(defun %simple-fun-doc (simple-fun) + (declare (simple-fun simple-fun)) + (let ((info (%simple-fun-info simple-fun))) + (cond ((typep info '(or null string)) + info) + ((simple-vector-p info) + nil) + ((consp info) + (car info)) + (t + (bug "bogus INFO for ~S: ~S" simple-fun info))))) + +(defun (setf %simple-fun-doc) (doc simple-fun) + (declare (type (or null string) doc) + (simple-fun simple-fun)) + (let ((info (%simple-fun-info simple-fun))) + (setf (%simple-fun-info simple-fun) + (cond ((typep info '(or null string)) + doc) + ((simple-vector-p info) + (if doc + (cons doc info) + info)) + ((consp info) + (if doc + (cons doc (cdr info)) + (cdr info))) + (t + (bug "bogus INFO for ~S: ~S" simple-fun info)))))) + +(defun %simple-fun-xrefs (simple-fun) + (declare (simple-fun simple-fun)) + (let ((info (%simple-fun-info simple-fun))) + (cond ((typep info '(or null string)) + nil) + ((simple-vector-p info) + info) + ((consp info) + (cdr info)) + (t + (bug "bogus INFO for ~S: ~S" simple-fun info))))) + ;;; Extract the arglist from the function header FUNC. (defun %simple-fun-arglist (func) (%simple-fun-arglist func)) @@ -98,6 +140,9 @@ (defun %simple-fun-name (func) (%simple-fun-name func)) +(defun (setf %simple-fun-name) (new-value func) + (setf (%simple-fun-name func) new-value)) + ;;; Extract the type from the function header FUNC. (defun %simple-fun-type (func) (%simple-fun-type func)) diff --git a/src/code/macros.lisp b/src/code/macros.lisp index b3e3c03..71d7bad 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -152,7 +152,8 @@ invoked. In that case it will store into PLACE and start over." ;; FIXME: warn about incompatible lambda list with ;; respect to parent function? (setf (sb!xc:compiler-macro-function name) definition) - (setf (fdocumentation name 'compiler-macro) doc) + #-sb-xc-host + (setf (%fun-doc definition) doc) ,(when set-p `(setf (%fun-lambda-list definition) lambda-list (%fun-name definition) debug-name)) diff --git a/src/code/target-misc.lisp b/src/code/target-misc.lisp index 1440394..1352638 100644 --- a/src/code/target-misc.lisp +++ b/src/code/target-misc.lisp @@ -113,15 +113,23 @@ (setf (%simple-fun-name (%fun-fun function)) new-value))) new-value) -(defun %fun-doc (x) - ;; FIXME: This business of going through %FUN-NAME and then globaldb - ;; is the way CMU CL did it, but it doesn't really seem right. - ;; When/if weak hash tables become supported again, using a weak - ;; hash table to maintain the object/documentation association would - ;; probably be better. - (let ((name (%fun-name x))) - (when (and name (typep name '(or symbol cons))) - (values (info :function :documentation name))))) +(defun %fun-doc (function) + (typecase function + #!+sb-eval + (sb!eval:interpreted-function + (sb!eval:interpreted-function-documentation function)) + (t + (%simple-fun-doc (%fun-fun function))))) + +(defun (setf %fun-doc) (new-value function) + (declare (type (or null string) new-value)) + (typecase function + #!+sb-eval + (sb!eval:interpreted-function + (setf (sb!eval:interpreted-function-documentation function) new-value)) + ((or simple-fun closure) + (setf (%simple-fun-doc (%fun-fun function)) new-value))) + new-value) ;;; various environment inquiries diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index 5f007a3..491716a 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -1249,7 +1249,7 @@ (dump-object name file) (dump-object (sb!c::entry-info-arguments entry) file) (dump-object (sb!c::entry-info-type entry) file) - (dump-object (sb!c::entry-info-xref entry) file) + (dump-object (sb!c::entry-info-info entry) file) (dump-fop 'fop-fun-entry file) (dump-word (label-position (sb!c::entry-info-offset entry)) file) (dump-pop file))) diff --git a/src/compiler/entry.lisp b/src/compiler/entry.lisp index 6863e05..ae95297 100644 --- a/src/compiler/entry.lisp +++ b/src/compiler/entry.lisp @@ -43,8 +43,11 @@ (setf (entry-info-offset info) (gen-label)) (setf (entry-info-name info) (leaf-debug-name internal-fun)) - (setf (entry-info-xref info) - (pack-xref-data (functional-xref internal-fun))) + (let ((doc (functional-documentation internal-fun)) + (xrefs (pack-xref-data (functional-xref internal-fun)))) + (setf (entry-info-info info) (if (and doc xrefs) + (cons doc xrefs) + (or doc xrefs)))) (when (policy bind (>= debug 1)) (let ((args (functional-arg-documentation internal-fun))) (aver (not (eq args :unspecified))) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 4b8a53a..bb2887c 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -2492,7 +2492,7 @@ core and return a descriptor to it." (write-wordindexed code slot value))) (define-cold-fop (fop-fun-entry) - (let* ((xrefs (pop-stack)) + (let* ((info (pop-stack)) (type (pop-stack)) (arglist (pop-stack)) (name (pop-stack)) @@ -2550,7 +2550,7 @@ core and return a descriptor to it." (write-wordindexed fn sb!vm:simple-fun-name-slot name) (write-wordindexed fn sb!vm:simple-fun-arglist-slot arglist) (write-wordindexed fn sb!vm:simple-fun-type-slot type) - (write-wordindexed fn sb!vm::simple-fun-xrefs-slot xrefs) + (write-wordindexed fn sb!vm::simple-fun-info-slot info) fn)) (define-cold-fop (fop-foreign-fixup) diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index e942b54..dd22370 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -14,9 +14,6 @@ ;;;; KLUDGE: The primitive objects here may look like self-contained ;;;; definitions, but in general they're not. In particular, if you ;;;; try to add a slot to them, beware of the following: -;;;; * (mysterious crashes which occur after changing the length -;;;; of SIMPLE-FUN, just adding a new slot not even doing anything -;;;; with it, still dunno why) ;;;; * The GC scavenging code (and for all I know other GC code too) ;;;; is not automatically generated from these layouts, but instead ;;;; was hand-written to correspond to them. The offsets are @@ -214,11 +211,13 @@ :ref-trans %simple-fun-type :set-known (unsafe) :set-trans (setf %simple-fun-type)) - (xrefs :init :null - :ref-trans %simple-fun-xrefs - :ref-known (flushable) - :set-trans (setf %simple-fun-xrefs) - :set-known ()) + ;; NIL for empty, STRING for a docstring, SIMPLE-VECTOR for XREFS, and (CONS + ;; STRING SIMPLE-VECTOR) for both. + (info :init :null + :ref-trans %simple-fun-info + :ref-known (flushable) + :set-trans (setf %simple-fun-info) + :set-known (unsafe)) ;; the SB!C::DEBUG-FUN object corresponding to this object, or NIL for none #+nil ; FIXME: doesn't work (gotcha, lowly maintenoid!) See notes on bug 137. (debug-fun :ref-known (flushable) diff --git a/src/compiler/generic/target-core.lisp b/src/compiler/generic/target-core.lisp index d70ede9..fddd407 100644 --- a/src/compiler/generic/target-core.lisp +++ b/src/compiler/generic/target-core.lisp @@ -41,7 +41,7 @@ (setf (%simple-fun-name res) (entry-info-name entry-info)) (setf (%simple-fun-arglist res) (entry-info-arguments entry-info)) (setf (%simple-fun-type res) (entry-info-type entry-info)) - (setf (%simple-fun-xrefs res) (entry-info-xref entry-info)) + (setf (%simple-fun-info res) (entry-info-info entry-info)) (note-fun entry-info res object)))) diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index 56fc8c2..d20e894 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -1035,12 +1035,6 @@ (define-info-type :class :function - :type :documentation - :type-spec (or string null) - :default nil) - -(define-info-type - :class :function :type :definition :type-spec (or fdefn null) :default nil) diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index 293b123..386441a 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -230,7 +230,7 @@ return NIL. Can be set with SETF when ENV is NIL." (cond ((functionp x) (%fun-doc x)) ((legal-fun-name-p x) - (values (info :function :documentation x))))) + (%fun-doc (fdefinition x))))) (structure (typecase x (symbol (cond @@ -259,8 +259,12 @@ return NIL. Can be set with SETF when ENV is NIL." (case doc-type (variable (setf (info :variable :documentation name) string)) (function - (when (legal-fun-name-p name) - (setf (info :function :documentation name) string))) + ;; KLUDGE: FDEFINITION isn't ready early enough during cold-init, so + ;; special case for symbols. + (if (symbolp name) + (setf (%fun-doc (symbol-function name)) string) + (when (legal-fun-name-p name) + (setf (%fun-doc (fdefinition name)) string)))) (structure (cond ((eq (info :type :kind name) :instance) (setf (info :type :documentation name) string)) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 7556b7e..9b04e0f 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -754,8 +754,9 @@ also processed as top level forms." (program-assert-symbol-home-package-unlocked :compile name "binding ~A as a local function")) (names name) - (multiple-value-bind (forms decls) (parse-body (cddr def)) + (multiple-value-bind (forms decls doc) (parse-body (cddr def)) (defs `(lambda ,(second def) + ,@(when doc (list doc)) ,@decls (block ,(fun-name-block-name name) . ,forms)))))) diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index efe3a48..ab8bd8b 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -919,7 +919,7 @@ (setf debug-name (name-lambdalike form))) (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals) (make-lambda-vars (cadr form)) - (multiple-value-bind (forms decls) (parse-body (cddr form)) + (multiple-value-bind (forms decls doc) (parse-body (cddr form)) (binding* (((*lexenv* result-type post-binding-lexenv) (process-decls decls (append aux-vars vars) nil :binding-form-p t)) @@ -952,6 +952,7 @@ :system-lambda system-lambda))))) (setf (functional-inline-expansion res) form) (setf (functional-arg-documentation res) (cadr form)) + (setf (functional-documentation res) doc) (when (boundp '*lambda-conversions*) ;; KLUDGE: Not counting TL-XEPs is a lie, of course, but ;; keeps things less confusing to users of TIME, where this diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 7ec86bd..66b034d 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -40,7 +40,8 @@ ;;; kind to associate with NAME. (defmacro def-ir1-translator (name (lambda-list start-var next-var result-var) &body body) - (let ((fn-name (symbolicate "IR1-CONVERT-" name))) + (let ((fn-name (symbolicate "IR1-CONVERT-" name)) + (guard-name (symbolicate name "-GUARD"))) (with-unique-names (whole-var n-env) (multiple-value-bind (body decls doc) (parse-defmacro lambda-list whole-var body name "special form" @@ -56,24 +57,28 @@ ,@decls ,body (values)) - ,@(when doc - `((setf (fdocumentation ',name 'function) ,doc))) + #-sb-xc-host + ;; It's nice to do this for error checking in the target + ;; SBCL, but it's not nice to do this when we're running in + ;; the cross-compilation host Lisp, which owns the + ;; SYMBOL-FUNCTION of its COMMON-LISP symbols. These guard + ;; functions also provide the documentation for special forms. + (progn + (defun ,guard-name (&rest args) + ,@(when doc (list doc)) + (declare (ignore args)) + (error 'special-form-function :name ',name)) + (let ((fun #',guard-name)) + (setf (%simple-fun-arglist fun) ',lambda-list + (%simple-fun-name fun) ',name + (symbol-function ',name) fun) + (fmakunbound ',guard-name))) ;; 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) ;; FIXME: rename this to SPECIAL-OPERATOR, to update it to ;; the 1990s? (setf (info :function :kind ',name) :special-form) - ;; It's nice to do this for error checking in the target - ;; SBCL, but it's not nice to do this when we're running in - ;; the cross-compilation host Lisp, which owns the - ;; SYMBOL-FUNCTION of its COMMON-LISP symbols. - #-sb-xc-host - (let ((fun (lambda (&rest rest) - (declare (ignore rest)) - (error 'special-form-function :name ',name)))) - (setf (%simple-fun-arglist fun) ',lambda-list) - (setf (symbol-function ',name) fun)) ',name))))) ;;; (This is similar to DEF-IR1-TRANSLATOR, except that we pass if the diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index ceb1a2b..2d9d405 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -861,6 +861,8 @@ ;; the original function or macro lambda list, or :UNSPECIFIED if ;; this is a compiler created function (arg-documentation nil :type (or list (member :unspecified))) + ;; the documentation string for the lambda + (documentation nil :type (or null string)) ;; Node, allocating closure for this lambda. May be NIL when we are ;; sure that no closure is needed. (allocator nil :type (or null combination)) diff --git a/src/compiler/vop.lisp b/src/compiler/vop.lisp index 035a215..99d7111 100644 --- a/src/compiler/vop.lisp +++ b/src/compiler/vop.lisp @@ -324,8 +324,8 @@ ;; a function type specifier representing the arguments and results ;; of this function (type 'function :type (or list (member function))) - ;; xref information for the XEP - (xref nil :type (or null simple-vector))) + ;; docstring and/or xref information for the XEP + (info nil :type (or null simple-vector string (cons string simple-vector)))) ;;; An IR2-PHYSENV is used to annotate non-LET LAMBDAs with their ;;; passing locations. It is stored in the PHYSENV-INFO. diff --git a/src/pcl/documentation.lisp b/src/pcl/documentation.lisp index 281d94e..b06a53c 100644 --- a/src/pcl/documentation.lisp +++ b/src/pcl/documentation.lisp @@ -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)) diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c index c358039..d38c9b5 100644 --- a/src/runtime/gc-common.c +++ b/src/runtime/gc-common.c @@ -382,7 +382,7 @@ scav_code_header(lispobj *where, lispobj object) scavenge(&function_ptr->name, 1); scavenge(&function_ptr->arglist, 1); scavenge(&function_ptr->type, 1); - scavenge(&function_ptr->xrefs, 1); + scavenge(&function_ptr->info, 1); } return n_words; diff --git a/tests/interface.impure.lisp b/tests/interface.impure.lisp index 1b7978b..785edcd 100644 --- a/tests/interface.impure.lisp +++ b/tests/interface.impure.lisp @@ -12,7 +12,9 @@ ;;;; more information. (load "assertoid.lisp") +(load "test-util.lisp") (use-package "ASSERTOID") +(use-package "TEST-UTIL") (defun (setf foo) (x) "(setf foo) documentation" @@ -177,7 +179,7 @@ "setf compiler macro" y) -(with-test (:name (documentation 'compiler-macro)) +(with-test (:name (documentation compiler-macro)) (unless (equal "compiler macro" (documentation 'cmacro 'compiler-macro)) (error "got ~S for cmacro" @@ -185,5 +187,49 @@ (unless (equal "setf compiler macro" (documentation '(setf cmacro) 'compiler-macro)) (error "got ~S for setf macro" (documentation '(setf cmacro) 'compiler-macro)))) + +(with-test (:name (documentation lambda)) + (let ((f (lambda () "aos the zos" t)) + (g (sb-int:named-lambda fii () "zoot the fruit" t))) + (dolist (doc-type '(t function)) + (assert (string= (documentation f doc-type) "aos the zos")) + (assert (string= (documentation g doc-type) "zoot the fruit"))) + (setf (documentation f t) "fire") + (assert (string= (documentation f t) "fire")) + (assert (string= (documentation g t) "zoot the fruit")))) + +(with-test (:name (documentation flet)) + (assert + (string= (documentation + (flet ((quux (x) + "this is FLET quux" + (/ x 2))) + #'quux) + t) + "this is FLET quux"))) + +(with-test (:name (documentation labels)) + (assert + (string= (documentation + (labels ((rec (x) + "this is LABELS rec" + (if (plusp x) + (* x (rec (1- x))) + 1))) + #'rec) + t) + "this is LABELS rec"))) + +(let ((x 1)) + (defun docfoo (y) + "bar" + (incf x y))) + +(with-test (:name (documentation closure)) + (assert (string= (documentation 'docfoo 'function) "bar")) + (assert (string= (documentation #'docfoo t) "bar")) + (assert (string= (setf (documentation 'docfoo 'function) "baz") "baz")) + (assert (string= (documentation 'docfoo 'function) "baz")) + (assert (string= (documentation #'docfoo t) "baz"))) ;;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 17d08ae..d633550 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.29.23" +"1.0.29.24" -- 1.7.10.4