From 0c4fc7032ab32fb639c188d9647eb132d55adfa5 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 20 Dec 2021 11:04:37 -0500 Subject: 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`. --- lisp/emacs-lisp/cconv.el | 11 +++-------- lisp/emacs-lisp/cl-generic.el | 4 +++- lisp/emacs-lisp/cl-macs.el | 35 ++++++++++++++++++++------------- lisp/emacs-lisp/generator.el | 6 ++++-- lisp/emacs-lisp/nadvice.el | 2 ++ test/lisp/emacs-lisp/cconv-tests.el | 39 +++++++++++++------------------------ 6 files changed, 46 insertions(+), 51 deletions(-) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 7cec91bfa82..d8f463e9d6a 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -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) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 9de47e4987d..d162dfbbeb5 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -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))) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 87f7e078516..a8f046b148c 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -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 diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index ac1412704b0..86119d3e3ed 100644 --- a/lisp/emacs-lisp/generator.el +++ b/lisp/emacs-lisp/generator.el @@ -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." diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 8fc2986ab41..27c289e385e 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -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)) diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el index 94bc759fa07..479afe12c0d 100644 --- a/test/lisp/emacs-lisp/cconv-tests.el +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -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)) -- cgit v1.2.3