* 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
"SIMPLE-FUN"
"SIMPLE-FUN-P"
"%SIMPLE-FUN-ARGLIST"
+ "%SIMPLE-FUN-DOC"
+ "%SIMPLE-FUN-INFO"
"%SIMPLE-FUN-NAME"
"%SIMPLE-FUN-NEXT"
"%SIMPLE-FUN-SELF"
(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)
\f
;;;; DEFVAR and DEFPARAMETER
;; 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))
(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))))
#+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))
(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)
(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))
(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))
;; 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))
(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)
\f
;;; various environment inquiries
(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)))
(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)))
(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))
(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)
;;;; 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
: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)
(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))))
(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)
(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
(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))
(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))))))
(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))
: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
;;; 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"
,@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
;; 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))
;; 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.
(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)))
(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))
(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))
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;
;;;; more information.
(load "assertoid.lisp")
+(load "test-util.lisp")
(use-package "ASSERTOID")
+(use-package "TEST-UTIL")
(defun (setf foo) (x)
"(setf foo) documentation"
"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"
(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")))
\f
;;;; success
;;; 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"
projects / sbcl.git / commitdiff