scratch/oclosure 20e5cd82ae 13/25: Fix bug#28557

[Stefan Monnier]

branch: scratch/oclosure
commit 20e5cd82aec81a411dd5e4fd880cccc8dabe3455
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/oclosure.el (oclosure-lambda):
    * lisp/emacs-lisp/cconv.el (cconv--convert-funcbody):
    Use `macroexp-parse-body`.
    
    * lisp/calendar/icalendar.el (icalendar--decode-isodatetime):
    Fix misuse of `cl-lib` without requiring it.
---
 lisp/calendar/icalendar.el          |  4 +--
 lisp/emacs-lisp/cconv.el            | 11 ++------
 lisp/emacs-lisp/cl-generic.el       |  4 ++-
 lisp/emacs-lisp/cl-macs.el          | 29 ++++++++++++-------
 lisp/emacs-lisp/generator.el        |  6 ++--
 lisp/emacs-lisp/nadvice.el          |  2 ++
 lisp/emacs-lisp/oclosure.el         | 55 +++++++++++++++++++------------------
 test/lisp/emacs-lisp/cconv-tests.el | 14 +---------
 8 files changed, 62 insertions(+), 63 deletions(-)

diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el
index 7a483d4062..01387341d6 100644
--- a/lisp/calendar/icalendar.el
+++ b/lisp/calendar/icalendar.el
@@ -645,10 +645,10 @@ FIXME: multiple comma-separated values should be allowed!"
           (setq second (read (substring isodatetimestring 13 15))))
        ;; FIXME: Support subseconds.
         (when (> (length isodatetimestring) 15)
-          (cl-case (aref isodatetimestring 15)
+          (pcase (aref isodatetimestring 15)
             (?Z
              (setq source-zone t))
-            ((?- ?+)
+            ((or ?- ?+)
              (setq source-zone
                    (concat "UTC" (substring isodatetimestring 15))))))
         ;; shift if necessary
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index 97066da0ee..66e0c35941 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -294,15 +294,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 44018da30e..1886f309e3 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.
+                  `(docstring-add-fundoc-usage ,doc ',args)
+                (docstring-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 6bd0d0c328..96559fbfb6 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -301,24 +301,33 @@ 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
+                        (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
+                      (cond
+                       ((eq :documentation (caar header))
+                        `((:documentation (docstring-add-fundoc-usage
+                                           ,(cadr (car header))
+                                           ,usage-str))
+                          ,@(cdr header)))
+                       (t
                         (cons (docstring-add-fundoc-usage
                                (if (stringp (car header)) (pop header))
                                ;; Be careful with make-symbol and (back)quote,
                                ;; see bug#12884.
-                               (docstring--quote
-                                (let ((print-gensym nil) (print-quoted t)
-                                      (print-escape-newlines t))
-                                  (format "%S" (cons 'fn (cl--make-usage-args
-                                                          orig-args))))))
-                              header)))
+                               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 cb0241017a..a768c6ae83 100644
--- a/lisp/emacs-lisp/generator.el
+++ b/lisp/emacs-lisp/generator.el
@@ -692,8 +692,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 ea6b4d73d3..3a1c4a2a58 100644
--- a/lisp/emacs-lisp/nadvice.el
+++ b/lisp/emacs-lisp/nadvice.el
@@ -484,6 +484,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/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
index f8ed5bfa39..3462e62a43 100644
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -187,33 +187,34 @@
 
 (defmacro oclosure-lambda (type fields args &rest body)
   (declare (indent 3) (debug (sexp (&rest (sexp form)) sexp def-body)))
-  ;; FIXME: Provide the fields in the order specified by `type'.
-  (let* ((class (cl--find-class type))
-         (slots (oclosure--class-slots class))
-         (prebody '())
-         (slotbinds (nreverse
-                     (mapcar (lambda (slot)
-                               (list (cl--slot-descriptor-name slot)))
-                             slots)))
-         (tempbinds (mapcar
-                     (lambda (field)
-                       (let* ((name (car field))
-                              (bind (assq name slotbinds)))
-                         (cond
-                          ((not bind)
-                           (error "Unknown slots: %S" name))
-                          ((cdr bind)
-                           (error "Duplicate slots: %S" name))
-                          (t
-                           (let ((temp (gensym "temp")))
-                             (setcdr bind (list temp))
-                             (cons temp (cdr field)))))))
-                     fields)))
-    ;; FIXME: Since we use the docstring internally to store the
-    ;; type we can't handle actual docstrings.  We could fix this by adding
-    ;; a docstring slot to OClosures.
-    (while (memq (car-safe (car-safe body)) '(interactive declare))
-      (push (pop body) prebody))
+  ;; FIXME: Should `oclosure-define' distinguish "optional" from
+  ;; "mandatory" slots, and/or provide default values for slots missing
+  ;; from `fields'?
+  (pcase-let*
+      ((class (cl--find-class type))
+       (slots (oclosure--class-slots class))
+       ;; FIXME: Since we use the docstring internally to store the
+       ;; type we can't handle actual docstrings.  We could fix this by adding
+       ;; a docstring slot to OClosures.
+       (`(,prebody . ,body) (macroexp-parse-body body))
+       (slotbinds (nreverse
+                   (mapcar (lambda (slot)
+                             (list (cl--slot-descriptor-name slot)))
+                           slots)))
+       (tempbinds (mapcar
+                   (lambda (field)
+                     (let* ((name (car field))
+                            (bind (assq name slotbinds)))
+                       (cond
+                        ((not bind)
+                         (error "Unknown slots: %S" name))
+                        ((cdr bind)
+                         (error "Duplicate slots: %S" name))
+                        (t
+                         (let ((temp (gensym "temp")))
+                           (setcdr bind (list temp))
+                           (cons temp (cdr field)))))))
+                   fields)))
     ;; FIXME: Optimize temps away when they're provided in the right order?
     ;; FIXME: Slots not specified in `fields' tend to emit "Variable FOO left
     ;; uninitialized"!
diff --git a/test/lisp/emacs-lisp/cconv-tests.el 
b/test/lisp/emacs-lisp/cconv-tests.el
index 0701892b8c..d7f9af1899 100644
--- a/test/lisp/emacs-lisp/cconv-tests.el
+++ b/test/lisp/emacs-lisp/cconv-tests.el
@@ -83,9 +83,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,17 +93,12 @@
   (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
   (let ((iter-fun
          (iter-lambda ()
            (:documentation (concat "iter-lambda" " documentation"))
@@ -116,13 +108,11 @@
 
 (ert-deftest cconv-tests-cl-function-:documentation ()
   "Docstring for cl-function can be specified with :documentation."
-  ;; FIXME: See Bug#28557.
-  :expected-result :failed
   (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 (string-match "\\`cl-function documentation$" (documentation fun)))
     (should (equal (funcall fun :arg t) '(t cl-function-result)))))
 
 (ert-deftest cconv-tests-function-:documentation ()
@@ -142,8 +132,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))