Fix bug#28557
* test/lisp/emacs-lisp/cconv-tests.el: Remove `:expected-result :failed` from the bug#28557 tests. (cconv-tests-cl-function-:documentation): Account for the presence of the arglist (aka "usage") in the docstring. * lisp/emacs-lisp/cl-macs.el (cl--transform-lambda): * lisp/emacs-lisp/cl-generic.el (cl-defgeneric): Handle non-constant `:documentation`. * lisp/emacs-lisp/generator.el (iter-lambda): * lisp/emacs-lisp/cconv.el (cconv--convert-funcbody): Use `macroexp-parse-body`.
This commit is contained in:
Stefan Monnier
parent
43356423a2
commit
0c4fc7032a
6 changed files with 46 additions and 51 deletions
|
|
@ -293,15 +293,10 @@ of converted forms."
|
|||
(cconv-convert form env nil))
|
||||
funcbody))
|
||||
(if wrappers
|
||||
(let ((special-forms '()))
|
||||
;; Keep special forms at the beginning of the body.
|
||||
(while (or (and (cdr funcbody) (stringp (car funcbody))) ;docstring.
|
||||
(memq (car-safe (car funcbody))
|
||||
'(interactive declare :documentation)))
|
||||
(push (pop funcbody) special-forms))
|
||||
(let ((body (macroexp-progn funcbody)))
|
||||
(pcase-let ((`(,decls . ,body) (macroexp-parse-body funcbody)))
|
||||
(let ((body (macroexp-progn body)))
|
||||
(dolist (wrapper wrappers) (setq body (funcall wrapper body)))
|
||||
`(,@(nreverse special-forms) ,@(macroexp-unprogn body))))
|
||||
`(,@decls ,@(macroexp-unprogn body))))
|
||||
funcbody)))
|
||||
|
||||
(defun cconv--lifted-arg (var env)
|
||||
|
|
|
|||
|
|
@ -286,7 +286,9 @@ DEFAULT-BODY, if present, is used as the body of a default method.
|
|||
(progn
|
||||
(defalias ',name
|
||||
(cl-generic-define ',name ',args ',(nreverse options))
|
||||
,(help-add-fundoc-usage doc args))
|
||||
,(if (consp doc) ;An expression rather than a constant.
|
||||
`(help-add-fundoc-usage ,doc ',args)
|
||||
(help-add-fundoc-usage doc args)))
|
||||
:autoload-end
|
||||
,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method))
|
||||
(nreverse methods)))
|
||||
|
|
|
|||
|
|
@ -301,24 +301,31 @@ FORM is of the form (ARGS . BODY)."
|
|||
(t ;; `simple-args' doesn't handle all the parsing that we need,
|
||||
;; so we pass the rest to cl--do-arglist which will do
|
||||
;; "manual" parsing.
|
||||
(let ((slen (length simple-args)))
|
||||
(when (memq '&optional simple-args)
|
||||
(cl-decf slen))
|
||||
(setq header
|
||||
(let ((slen (length simple-args))
|
||||
(usage-str
|
||||
;; Macro expansion can take place in the middle of
|
||||
;; apparently harmless computation, so it should not
|
||||
;; touch the match-data.
|
||||
(save-match-data
|
||||
(cons (help-add-fundoc-usage
|
||||
(if (stringp (car header)) (pop header))
|
||||
;; Be careful with make-symbol and (back)quote,
|
||||
;; see bug#12884.
|
||||
(help--docstring-quote
|
||||
(let ((print-gensym nil) (print-quoted t)
|
||||
(print-escape-newlines t))
|
||||
(format "%S" (cons 'fn (cl--make-usage-args
|
||||
orig-args))))))
|
||||
header)))
|
||||
(help--docstring-quote
|
||||
(let ((print-gensym nil) (print-quoted t)
|
||||
(print-escape-newlines t))
|
||||
(format "%S" (cons 'fn (cl--make-usage-args
|
||||
orig-args))))))))
|
||||
(when (memq '&optional simple-args)
|
||||
(cl-decf slen))
|
||||
(setq header
|
||||
(cons
|
||||
(if (eq :documentation (car-safe (car header)))
|
||||
`(:documentation (help-add-fundoc-usage
|
||||
,(cadr (pop header))
|
||||
,usage-str))
|
||||
(help-add-fundoc-usage
|
||||
(if (stringp (car header)) (pop header))
|
||||
;; Be careful with make-symbol and (back)quote,
|
||||
;; see bug#12884.
|
||||
usage-str))
|
||||
header))
|
||||
;; FIXME: we'd want to choose an arg name for the &rest param
|
||||
;; and pass that as `expr' to cl--do-arglist, but that ends up
|
||||
;; generating code with a redundant let-binding, so we instead
|
||||
|
|
|
|||
|
|
@ -690,8 +690,10 @@ of values. Callers can retrieve each value using `iter-next'."
|
|||
(declare (indent defun)
|
||||
(debug (&define lambda-list lambda-doc &rest sexp)))
|
||||
(cl-assert lexical-binding)
|
||||
`(lambda ,arglist
|
||||
,(cps-generate-evaluator body)))
|
||||
(pcase-let* ((`(,declarations . ,exps) (macroexp-parse-body body)))
|
||||
`(lambda ,arglist
|
||||
,@declarations
|
||||
,(cps-generate-evaluator exps))))
|
||||
|
||||
(defmacro iter-make (&rest body)
|
||||
"Return a new iterator."
|
||||
|
|
|
|||
|
|
@ -480,6 +480,8 @@ is defined as a macro, alias, command, ..."
|
|||
(get symbol 'advice--pending))
|
||||
(t (symbol-function symbol)))
|
||||
function props)
|
||||
;; FIXME: We could use a defmethod on `function-docstring' instead,
|
||||
;; except when (or (not nf) (autoloadp nf))!
|
||||
(put symbol 'function-documentation `(advice--make-docstring ',symbol))
|
||||
(add-function :around (get symbol 'defalias-fset-function)
|
||||
#'advice--defalias-fset))
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@
|
|||
|
||||
(require 'ert)
|
||||
(require 'cl-lib)
|
||||
(require 'generator)
|
||||
|
||||
(ert-deftest cconv-tests-lambda-:documentation ()
|
||||
"Docstring for lambda can be specified with :documentation."
|
||||
|
|
@ -83,9 +84,6 @@
|
|||
(iter-yield 'cl-iter-defun-result))
|
||||
(ert-deftest cconv-tests-cl-iter-defun-:documentation ()
|
||||
"Docstring for cl-iter-defun can be specified with :documentation."
|
||||
;; FIXME: See Bug#28557.
|
||||
:tags '(:unstable)
|
||||
:expected-result :failed
|
||||
(should (string= (documentation 'cconv-tests-cl-iter-defun)
|
||||
"cl-iter-defun documentation"))
|
||||
(should (eq (iter-next (cconv-tests-cl-iter-defun))
|
||||
|
|
@ -96,36 +94,27 @@
|
|||
(iter-yield 'iter-defun-result))
|
||||
(ert-deftest cconv-tests-iter-defun-:documentation ()
|
||||
"Docstring for iter-defun can be specified with :documentation."
|
||||
;; FIXME: See Bug#28557.
|
||||
:tags '(:unstable)
|
||||
:expected-result :failed
|
||||
(should (string= (documentation 'cconv-tests-iter-defun)
|
||||
"iter-defun documentation"))
|
||||
(should (eq (iter-next (cconv-tests-iter-defun)) 'iter-defun-result)))
|
||||
|
||||
(ert-deftest cconv-tests-iter-lambda-:documentation ()
|
||||
"Docstring for iter-lambda can be specified with :documentation."
|
||||
;; FIXME: See Bug#28557.
|
||||
:expected-result :failed
|
||||
(with-no-warnings ; disable warnings for now as test is expected to fail
|
||||
(let ((iter-fun
|
||||
(iter-lambda ()
|
||||
(:documentation (concat "iter-lambda" " documentation"))
|
||||
(iter-yield 'iter-lambda-result))))
|
||||
(should (string= (documentation iter-fun) "iter-lambda documentation"))
|
||||
(should (eq (iter-next (funcall iter-fun)) 'iter-lambda-result)))))
|
||||
(let ((iter-fun
|
||||
(iter-lambda ()
|
||||
(:documentation (concat "iter-lambda" " documentation"))
|
||||
(iter-yield 'iter-lambda-result))))
|
||||
(should (string= (documentation iter-fun) "iter-lambda documentation"))
|
||||
(should (eq (iter-next (funcall iter-fun)) 'iter-lambda-result))))
|
||||
|
||||
(ert-deftest cconv-tests-cl-function-:documentation ()
|
||||
"Docstring for cl-function can be specified with :documentation."
|
||||
;; FIXME: See Bug#28557.
|
||||
:expected-result :failed
|
||||
(with-no-warnings ; disable warnings for now as test is expected to fail
|
||||
(let ((fun (cl-function (lambda (&key arg)
|
||||
(:documentation (concat "cl-function"
|
||||
" documentation"))
|
||||
(list arg 'cl-function-result)))))
|
||||
(should (string= (documentation fun) "cl-function documentation"))
|
||||
(should (equal (funcall fun :arg t) '(t cl-function-result))))))
|
||||
(let ((fun (cl-function (lambda (&key arg)
|
||||
(:documentation (concat "cl-function"
|
||||
" documentation"))
|
||||
(list arg 'cl-function-result)))))
|
||||
(should (string-match "\\`cl-function documentation$" (documentation fun)))
|
||||
(should (equal (funcall fun :arg t) '(t cl-function-result)))))
|
||||
|
||||
(ert-deftest cconv-tests-function-:documentation ()
|
||||
"Docstring for lambda inside function can be specified with :documentation."
|
||||
|
|
@ -144,8 +133,6 @@
|
|||
(+ 1 n))
|
||||
(ert-deftest cconv-tests-cl-defgeneric-:documentation ()
|
||||
"Docstring for cl-defgeneric can be specified with :documentation."
|
||||
;; FIXME: See Bug#28557.
|
||||
:expected-result :failed
|
||||
(let ((descr (describe-function 'cconv-tests-cl-defgeneric)))
|
||||
(set-text-properties 0 (length descr) nil descr)
|
||||
(should (string-match-p "cl-defgeneric documentation" descr))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue