5 files changed, 36 insertions, 30 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index ced342baeb9..6352d77ca3a 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,11 @@
+2015-02-23  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+        * emacs-lisp/macroexp.el (macroexp-parse-body): Handle cl-declare
+        and :documentation.  Change return value format accordingly.
+        * emacs-lisp/cl-generic.el (cl--generic-lambda):
+        * emacs-lisp/pcase.el (pcase-lambda): Adjust accordingly.
+        * emacs-lisp/cl-macs.el (cl--transform-lambda): Use macroexp-parse-body.
+
 2015-02-23  Dmitry Gutov  <dgutov@yandex.ru>
 
         Introduce `xref-etags-mode'.
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index ccd5bec5685..99924ba288f 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -278,7 +278,7 @@ This macro can only be used within the lexical scope of a cl-generic method."
                   (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody)))
              (cons (not (not uses-cnm))
                    `#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
-                        ,@(delq nil (car parsed-body))
+                        ,@(car parsed-body)
                         ,(if (not (memq nmp uses-cnm))
                              nbody
                            `(let ((,nmp (lambda ()
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index c5f49b0ed91..c3da091fb00 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -234,10 +234,9 @@ FORM is of the form (ARGS . BODY)."
   (let* ((args (car form)) (body (cdr form)) (orig-args args)
          (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil)
          (cl--bind-lets nil) (cl--bind-forms nil)
-         (header nil) (simple-args nil))
-    (while (or (stringp (car body))
-               (memq (car-safe (car body)) '(interactive declare cl-declare)))
-      (push (pop body) header))
+         (parsed-body (macroexp-parse-body body))
+         (header (car parsed-body)) (simple-args nil))
+    (setq body (cdr parsed-body))
     (setq args (if (listp args) (cl-copy-list args) (list '&rest args)))
     (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
     (if (setq cl--bind-defs (cadr (memq '&cl-defs args)))
@@ -258,7 +257,7 @@ FORM is of the form (ARGS . BODY)."
     (or (eq cl--bind-block 'cl-none)
         (setq body (list `(cl-block ,cl--bind-block ,@body))))
     (if (null args)
-        (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body))
+        (cl-list* nil (nreverse simple-args) (nconc header body))
       (if (memq '&optional simple-args) (push '&optional args))
       (cl--do-arglist args nil (- (length simple-args)
                                   (if (memq '&optional simple-args) 1 0)))
@@ -266,20 +265,18 @@ FORM is of the form (ARGS . BODY)."
       (cl-list* nil
              (nconc (nreverse simple-args)
                     (list '&rest (car (pop cl--bind-lets))))
-             (nconc (let ((hdr (nreverse header)))
-                      ;; Macro expansion can take place in the middle of
-                      ;; apparently harmless computation, so it should not
-                      ;; touch the match-data.
-                      (save-match-data
-                        (require 'help-fns)
-                        (cons (help-add-fundoc-usage
-                               (if (stringp (car hdr)) (pop hdr))
-                               ;; Be careful with make-symbol and (back)quote,
-                               ;; see bug#12884.
-                               (let ((print-gensym nil) (print-quoted t))
-                                 (format "%S" (cons 'fn (cl--make-usage-args
-                                                         orig-args)))))
-                              hdr)))
+             (nconc (save-match-data ;; Macro expansion can take place in the
+                      ;; middle of apparently harmless computation, so it
+                      ;; should not touch the match-data.
+                      (require 'help-fns)
+                      (cons (help-add-fundoc-usage
+                             (if (stringp (car header)) (pop header))
+                             ;; Be careful with make-symbol and (back)quote,
+                             ;; see bug#12884.
+                             (let ((print-gensym nil) (print-quoted t))
+                               (format "%S" (cons 'fn (cl--make-usage-args
+                                                       orig-args)))))
+                            header))
                     (list `(let* ,cl--bind-lets
                              ,@(nreverse cl--bind-forms)
                              ,@body)))))))
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index b75c8cc50a7..68bf4f62c34 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -297,15 +297,16 @@ definitions to shadow the loaded ones for use in file byte-compilation."
 
 ;;; Handy functions to use in macros.
 
-(defun macroexp-parse-body (exps)
-  "Parse EXPS into ((DOC DECLARE-FORM INTERACTIVE-FORM) . BODY)."
-  `((,(and (stringp (car exps))
-           (pop exps))
-     ,(and (eq (car-safe (car exps)) 'declare)
-           (pop exps))
-     ,(and (eq (car-safe (car exps)) 'interactive)
-           (pop exps)))
-    ,@exps))
+(defun macroexp-parse-body (body)
+  "Parse a function BODY into (DECLARATIONS . EXPS)."
+  (let ((decls ()))
+    (while (and (cdr body)
+                (let ((e (car body)))
+                  (or (stringp e)
+                      (memq (car-safe e)
+                            '(:documentation declare interactive cl-declare)))))
+      (push (pop body) decls))
+    (cons (nreverse decls) body)))
 
 (defun macroexp-progn (exps)
   "Return an expression equivalent to `(progn ,@EXPS)."
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 057b12894f9..4706be5e57c 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -180,7 +180,7 @@ like `(,a . ,(pred (< a))) or, with more checks:
     (when (eq nil (car (last pats 2)))
       (setq pats (append (butlast pats 2) (car (last pats)))))
     `(lambda (&rest ,args)
-       ,@(remq nil (car body))
+       ,@(car body)
        (pcase ,args
          (,(list '\` pats) . ,(cdr body))))))