master 0c4fc70: Fix bug#28557

[Stefan Monnier]

branch: master
commit 0c4fc7032ab32fb639c188d9647eb132d55adfa5
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    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 7cec91b..d8f463e 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 9de47e4..d162dfb 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 87f7e07..a8f046b 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 ac14127..86119d3 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 8fc2986..27c289e 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 94bc759..479afe1 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))