master 73e75e18d1: Warn about misplaced or duplicated function/macro declarations

[Mattias Engdegård]

branch: master
commit 73e75e18d170826e1838324d39ac0698948071f8
Author: Mattias Engdegård <mattiase@acm.org>
Commit: Mattias Engdegård <mattiase@acm.org>

    Warn about misplaced or duplicated function/macro declarations
    
    Doc strings, `declare` and `interactive` forms must appear in that
    order and at most once each.  Complain if they don't, instead of
    silently ignoring the problem (bug#55905).
    
    * lisp/emacs-lisp/byte-run.el (byte-run--parse-body)
    (byte-run--parse-declarations): New.
    (defmacro, defun): Check for declaration well-formedness as
    described above.  Clarify doc strings.  Refactor some common code.
    * test/lisp/emacs-lisp/bytecomp-resources/fun-attr-warn.el:
    * test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp-fun-attr-warn):
    New test.
---
 lisp/emacs-lisp/byte-run.el                        | 208 +++++++++-------
 .../emacs-lisp/bytecomp-resources/fun-attr-warn.el | 266 +++++++++++++++++++++
 test/lisp/emacs-lisp/bytecomp-tests.el             |  63 +++++
 3 files changed, 446 insertions(+), 91 deletions(-)

diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 92c2699c6e..17c1554966 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -272,6 +272,75 @@ This is used by `declare'.")
       (list 'function-put (list 'quote name)
            ''no-font-lock-keyword (list 'quote val))))
 
+(defalias 'byte-run--parse-body
+  #'(lambda (body allow-interactive)
+      "Decompose BODY into (DOCSTRING DECLARE INTERACTIVE BODY-REST WARNINGS)."
+      (let* ((top body)
+             (docstring nil)
+             (declare-form nil)
+             (interactive-form nil)
+             (warnings nil)
+             (warn #'(lambda (msg form)
+                       (push (macroexp-warn-and-return msg nil nil t form)
+                             warnings))))
+        (while
+            (and body
+                 (let* ((form (car body))
+                        (head (car-safe form)))
+                   (cond
+                    ((or (and (stringp form) (cdr body))
+                         (eq head :documentation))
+                     (cond
+                      (docstring (funcall warn "More than one doc string" top))
+                      (declare-form
+                       (funcall warn "Doc string after `declare'" 
declare-form))
+                      (interactive-form
+                       (funcall warn "Doc string after `interactive'"
+                                interactive-form))
+                      (t (setq docstring form)))
+                     t)
+                    ((eq head 'declare)
+                     (cond
+                      (declare-form
+                       (funcall warn "More than one `declare' form" form))
+                      (interactive-form
+                       (funcall warn "`declare' after `interactive'" form))
+                      (t (setq declare-form form)))
+                     t)
+                    ((eq head 'interactive)
+                     (cond
+                      ((not allow-interactive)
+                       (funcall warn "No `interactive' form allowed here" 
form))
+                      (interactive-form
+                       (funcall warn "More than one `interactive' form" form))
+                      (t (setq interactive-form form)))
+                     t))))
+          (setq body (cdr body)))
+        (list docstring declare-form interactive-form body warnings))))
+
+(defalias 'byte-run--parse-declarations
+  #'(lambda (name arglist clauses construct declarations-alist)
+      (let* ((cl-decls nil)
+             (actions
+              (mapcar
+               #'(lambda (x)
+                   (let ((f (cdr (assq (car x) declarations-alist))))
+                     (cond
+                      (f (apply (car f) name arglist (cdr x)))
+                      ;; Yuck!!
+                      ((and (featurep 'cl)
+                            (memq (car x)  ;C.f. cl--do-proclaim.
+                                  '(special inline notinline optimize warn)))
+                       (push (list 'declare x) cl-decls)
+                       nil)
+                      (t
+                       (macroexp-warn-and-return
+                        (format-message "Unknown %s property `%S'"
+                                        construct (car x))
+                        nil nil nil (car x))))))
+               clauses)))
+        (cons actions cl-decls))))
+
 (defvar macro-declarations-alist
   (cons
    (list 'debug #'byte-run--set-debug)
@@ -289,7 +358,7 @@ This is used by `declare'.")
 (defalias 'defmacro
   (cons
    'macro
-   #'(lambda (name arglist &optional docstring &rest body)
+   #'(lambda (name arglist &rest body)
        "Define NAME as a macro.
 When the macro is called, as in (NAME ARGS...),
 the function (lambda ARGLIST BODY...) is applied to
@@ -300,116 +369,73 @@ DECLS is a list of elements of the form (PROP . VALUES). 
 These are
 interpreted according to `macro-declarations-alist'.
 The return value is undefined.
 
-\(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)"
-       ;; We can't just have `decl' as an &optional argument, because we need
-       ;; to distinguish
-       ;;    (defmacro foo (arg) (bar) nil)
-       ;; from
-       ;;    (defmacro foo (arg) (bar)).
-       (let ((decls (cond
-                    ((eq (car-safe docstring) 'declare)
-                     (prog1 (cdr docstring) (setq docstring nil)))
-                    ((and (stringp docstring)
-                          (eq (car-safe (car body)) 'declare))
-                     (prog1 (cdr (car body)) (setq body (cdr body)))))))
-        (if docstring (setq body (cons docstring body))
-          (if (null body) (setq body '(nil))))
-        ;; Can't use backquote because it's not defined yet!
-        (let* ((fun (list 'function (cons 'lambda (cons arglist body))))
-               (def (list 'defalias
-                          (list 'quote name)
-                          (list 'cons ''macro fun)))
-               (declarations
-                (mapcar
-                 #'(lambda (x)
-                     (let ((f (cdr (assq (car x) macro-declarations-alist))))
-                       (if f (apply (car f) name arglist (cdr x))
-                          (macroexp-warn-and-return
-                          (format-message
-                           "Unknown macro property %S in %S"
-                           (car x) name)
-                          nil nil nil (car x)))))
-                 decls)))
-          ;; Refresh font-lock if this is a new macro, or it is an
-          ;; existing macro whose 'no-font-lock-keyword declaration
-          ;; has changed.
-          (if (and
-               ;; If lisp-mode hasn't been loaded, there's no reason
-               ;; to flush.
-               (fboundp 'lisp--el-font-lock-flush-elisp-buffers)
-               (or (not (fboundp name)) ;; new macro
-                   (and (fboundp name)  ;; existing macro
-                        (member `(function-put ',name 'no-font-lock-keyword
-                                               ',(get name 
'no-font-lock-keyword))
-                                declarations))))
-              (lisp--el-font-lock-flush-elisp-buffers))
-          (if declarations
-              (cons 'prog1 (cons def declarations))
+\(fn NAME ARGLIST [DOCSTRING] [DECL] BODY...)"
+       (let* ((parse (byte-run--parse-body body nil))
+              (docstring (nth 0 parse))
+              (declare-form (nth 1 parse))
+              (body (nth 3 parse))
+              (warnings (nth 4 parse))
+              (declarations
+               (and declare-form (byte-run--parse-declarations
+                                  name arglist (cdr declare-form) 'macro
+                                  macro-declarations-alist))))
+         (setq body (nconc warnings body))
+         (setq body (nconc (cdr declarations) body))
+         (if docstring
+             (setq body (cons docstring body)))
+         (if (null body)
+             (setq body '(nil)))
+         (let* ((fun (list 'function (cons 'lambda (cons arglist body))))
+               (def (list 'defalias
+                          (list 'quote name)
+                          (list 'cons ''macro fun))))
+           (if declarations
+              (cons 'prog1 (cons def (car declarations)))
             def))))))
 
 ;; Now that we defined defmacro we can use it!
-(defmacro defun (name arglist &optional docstring &rest body)
+(defmacro defun (name arglist &rest body)
   "Define NAME as a function.
-The definition is (lambda ARGLIST [DOCSTRING] BODY...).
-See also the function `interactive'.
+The definition is (lambda ARGLIST [DOCSTRING] [INTERACTIVE] BODY...).
 DECL is a declaration, optional, of the form (declare DECLS...) where
 DECLS is a list of elements of the form (PROP . VALUES).  These are
 interpreted according to `defun-declarations-alist'.
+INTERACTIVE is an optional `interactive' specification.
 The return value is undefined.
 
-\(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)"
-  ;; We can't just have `decl' as an &optional argument, because we need
-  ;; to distinguish
-  ;;    (defun foo (arg) (toto) nil)
-  ;; from
-  ;;    (defun foo (arg) (toto)).
+\(fn NAME ARGLIST [DOCSTRING] [DECL] [INTERACTIVE] BODY...)"
   (declare (doc-string 3) (indent 2))
   (or name (error "Cannot define '%s' as a function" name))
   (if (null
        (and (listp arglist)
             (null (delq t (mapcar #'symbolp arglist)))))
       (error "Malformed arglist: %s" arglist))
-  (let ((decls (cond
-                ((eq (car-safe docstring) 'declare)
-                 (prog1 (cdr docstring) (setq docstring nil)))
-                ((and (stringp docstring)
-                     (eq (car-safe (car body)) 'declare))
-                 (prog1 (cdr (car body)) (setq body (cdr body)))))))
-    (if docstring (setq body (cons docstring body))
-      (if (null body) (setq body '(nil))))
-    (let ((declarations
-           (mapcar
-            #'(lambda (x)
-                (let ((f (cdr (assq (car x) defun-declarations-alist))))
-                  (cond
-                   (f (apply (car f) name arglist (cdr x)))
-                   ;; Yuck!!
-                   ((and (featurep 'cl)
-                         (memq (car x)  ;C.f. cl-do-proclaim.
-                               '(special inline notinline optimize warn)))
-                    (push (list 'declare x)
-                          (if (stringp docstring)
-                              (if (eq (car-safe (cadr body)) 'interactive)
-                                  (cddr body)
-                                (cdr body))
-                            (if (eq (car-safe (car body)) 'interactive)
-                                (cdr body)
-                              body)))
-                    nil)
-                   (t
-                    (macroexp-warn-and-return
-                     (format-message "Unknown defun property `%S' in %S"
-                                     (car x) name)
-                     nil nil nil (car x))))))
-            decls))
-          (def (list 'defalias
+  (let* ((parse (byte-run--parse-body body t))
+         (docstring (nth 0 parse))
+         (declare-form (nth 1 parse))
+         (interactive-form (nth 2 parse))
+         (body (nth 3 parse))
+         (warnings (nth 4 parse))
+         (declarations
+          (and declare-form (byte-run--parse-declarations
+                             name arglist (cdr declare-form) 'defun
+                             defun-declarations-alist))))
+    (setq body (nconc warnings body))
+    (setq body (nconc (cdr declarations) body))
+    (if interactive-form
+        (setq body (cons interactive-form body)))
+    (if docstring
+        (setq body (cons docstring body)))
+    (if (null body)
+        (setq body '(nil)))
+    (let ((def (list 'defalias
                      (list 'quote name)
                      (list 'function
                            (cons 'lambda
                                  (cons arglist body))))))
       (if declarations
-          (cons 'prog1 (cons def declarations))
-          def))))
+          (cons 'prog1 (cons def (car declarations)))
+        def))))
 
 
 ;; Redefined in byte-opt.el.
diff --git a/test/lisp/emacs-lisp/bytecomp-resources/fun-attr-warn.el 
b/test/lisp/emacs-lisp/bytecomp-resources/fun-attr-warn.el
new file mode 100644
index 0000000000..be907b32f4
--- /dev/null
+++ b/test/lisp/emacs-lisp/bytecomp-resources/fun-attr-warn.el
@@ -0,0 +1,266 @@
+;;; -*- lexical-binding: t -*-
+
+;; Correct
+
+(defun faw-str-decl-code (x)
+  "something"
+  (declare (pure t))
+  (print x))
+
+(defun faw-doc-decl-code (x)
+  (:documentation "something")
+  (declare (pure t))
+  (print x))
+
+(defun faw-str-int-code (x)
+  "something"
+  (interactive "P")
+  (print x))
+
+(defun faw-doc-int-code (x)
+  (:documentation "something")
+  (interactive "P")
+  (print x))
+
+(defun faw-decl-int-code (x)
+  (declare (pure t))
+  (interactive "P")
+  (print x))
+
+(defun faw-str-decl-int-code (x)
+  "something"
+  (declare (pure t))
+  (interactive "P")
+  (print x))
+
+(defun faw-doc-decl-int-code (x)
+  (:documentation "something")
+  (declare (pure t))
+  (interactive "P")
+  (print x))
+
+
+;; Correct (last string is return value)
+
+(defun faw-str ()
+  "something")
+
+(defun faw-decl-str ()
+  (declare (pure t))
+  "something")
+
+(defun faw-decl-int-str ()
+  (declare (pure t))
+  (interactive)
+  "something")
+
+(defun faw-str-str ()
+  "something"
+  "something else")
+
+(defun faw-doc-str ()
+  (:documentation "something")
+  "something else")
+
+
+;; Incorrect (bad order)
+
+(defun faw-int-decl-code (x)
+  (interactive "P")
+  (declare (pure t))
+  (print x))
+
+(defun faw-int-str-code (x)
+  (interactive "P")
+  "something"
+  (print x))
+
+(defun faw-int-doc-code (x)
+  (interactive "P")
+  (:documentation "something")
+  (print x))
+
+(defun faw-decl-str-code (x)
+  (declare (pure t))
+  "something"
+  (print x))
+
+(defun faw-decl-doc-code (x)
+  (declare (pure t))
+  (:documentation "something")
+  (print x))
+
+(defun faw-str-int-decl-code (x)
+  "something"
+  (interactive "P")
+  (declare (pure t))
+  (print x))
+
+(defun faw-doc-int-decl-code (x)
+  (:documentation "something")
+  (interactive "P")
+  (declare (pure t))
+  (print x))
+
+(defun faw-int-str-decl-code (x)
+  (interactive "P")
+  "something"
+  (declare (pure t))
+  (print x))
+
+(defun faw-int-doc-decl-code (x)
+  (interactive "P")
+  (:documentation "something")
+  (declare (pure t))
+  (print x))
+
+(defun faw-int-decl-str-code (x)
+  (interactive "P")
+  (declare (pure t))
+  "something"
+  (print x))
+
+(defun faw-int-decl-doc-code (x)
+  (interactive "P")
+  (declare (pure t))
+  (:documentation "something")
+  (print x))
+
+(defun faw-decl-int-str-code (x)
+  (declare (pure t))
+  (interactive "P")
+  "something"
+  (print x))
+
+(defun faw-decl-int-doc-code (x)
+  (declare (pure t))
+  (interactive "P")
+  (:documentation "something")
+  (print x))
+
+(defun faw-decl-str-int-code (x)
+  (declare (pure t))
+  "something"
+  (interactive "P")
+  (print x))
+
+(defun faw-decl-doc-int-code (x)
+  (declare (pure t))
+  (:documentation "something")
+  (interactive "P")
+  (print x))
+
+
+;; Incorrect (duplication)
+
+(defun faw-str-str-decl-int-code (x)
+  "something"
+  "something else"
+  (declare (pure t))
+  (interactive "P")
+  (print x))
+
+(defun faw-str-doc-decl-int-code (x)
+  "something"
+  (:documentation "something else")
+  (declare (pure t))
+  (interactive "P")
+  (print x))
+
+(defun faw-doc-str-decl-int-code (x)
+  (:documentation "something")
+  "something else"
+  (declare (pure t))
+  (interactive "P")
+  (print x))
+
+(defun faw-doc-doc-decl-int-code (x)
+  (:documentation "something")
+  (:documentation "something else")
+  (declare (pure t))
+  (interactive "P")
+  (print x))
+
+(defun faw-str-decl-str-int-code (x)
+  "something"
+  (declare (pure t))
+  "something else"
+  (interactive "P")
+  (print x))
+
+(defun faw-doc-decl-str-int-code (x)
+  (:documentation "something")
+  (declare (pure t))
+  "something else"
+  (interactive "P")
+  (print x))
+
+(defun faw-str-decl-doc-int-code (x)
+  "something"
+  (declare (pure t))
+  (:documentation "something else")
+  (interactive "P")
+  (print x))
+
+(defun faw-doc-decl-doc-int-code (x)
+  (:documentation "something")
+  (declare (pure t))
+  (:documentation "something else")
+  (interactive "P")
+  (print x))
+
+(defun faw-str-decl-decl-int-code (x)
+  "something"
+  (declare (pure t))
+  (declare (indent 1))
+  (interactive "P")
+  (print x))
+
+(defun faw-doc-decl-decl-int-code (x)
+  (:documentation "something")
+  (declare (pure t))
+  (declare (indent 1))
+  (interactive "P")
+  (print x))
+
+(defun faw-str-decl-int-decl-code (x)
+  "something"
+  (declare (pure t))
+  (interactive "P")
+  (declare (indent 1))
+  (print x))
+
+(defun faw-doc-decl-int-decl-code (x)
+  (:documentation "something")
+  (declare (pure t))
+  (interactive "P")
+  (declare (indent 1))
+  (print x))
+
+(defun faw-str-decl-int-int-code (x)
+  "something"
+  (declare (pure t))
+  (interactive "P")
+  (interactive "p")
+  (print x))
+
+(defun faw-doc-decl-int-int-code (x)
+  (:documentation "something")
+  (declare (pure t))
+  (interactive "P")
+  (interactive "p")
+  (print x))
+
+(defun faw-str-int-decl-int-code (x)
+  "something"
+  (interactive "P")
+  (declare (pure t))
+  (interactive "p")
+  (print x))
+
+(defun faw-doc-int-decl-int-code (x)
+  (:documentation "something")
+  (interactive "P")
+  (declare (pure t))
+  (interactive "p")
+  (print x))
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el 
b/test/lisp/emacs-lisp/bytecomp-tests.el
index 9abc17a1c4..fbc00b30c5 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -1580,6 +1580,69 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode 
js-mode python-mode)) \
       (should (equal (get fname 'lisp-indent-function) 1))
       (should (equal (aref bc 4) "tata\n\n(fn X)")))))
 
+(ert-deftest bytecomp-fun-attr-warn ()
+  ;; Check that warnings are emitted when doc strings, `declare' and
+  ;; `interactive' forms don't come in the proper order, or more than once.
+  (let* ((filename "fun-attr-warn.el")
+         (el (ert-resource-file filename))
+         (elc (concat el "c"))
+         (text-quoting-style 'grave))
+    (with-current-buffer (get-buffer-create "*Compile-Log*")
+      (let ((inhibit-read-only t))
+        (erase-buffer))
+      (byte-compile-file el)
+      (let ((expected
+             '("70:4: Warning: `declare' after `interactive'"
+               "74:4: Warning: Doc string after `interactive'"
+               "79:4: Warning: Doc string after `interactive'"
+               "84:4: Warning: Doc string after `declare'"
+               "89:4: Warning: Doc string after `declare'"
+               "96:4: Warning: `declare' after `interactive'"
+               "102:4: Warning: `declare' after `interactive'"
+               "108:4: Warning: `declare' after `interactive'"
+               "106:4: Warning: Doc string after `interactive'"
+               "114:4: Warning: `declare' after `interactive'"
+               "112:4: Warning: Doc string after `interactive'"
+               "118:4: Warning: Doc string after `interactive'"
+               "119:4: Warning: `declare' after `interactive'"
+               "124:4: Warning: Doc string after `interactive'"
+               "125:4: Warning: `declare' after `interactive'"
+               "130:4: Warning: Doc string after `declare'"
+               "136:4: Warning: Doc string after `declare'"
+               "142:4: Warning: Doc string after `declare'"
+               "148:4: Warning: Doc string after `declare'"
+               "159:4: Warning: More than one doc string"
+               "165:4: Warning: More than one doc string"
+               "171:4: Warning: More than one doc string"
+               "178:4: Warning: More than one doc string"
+               "186:4: Warning: More than one doc string"
+               "192:4: Warning: More than one doc string"
+               "200:4: Warning: More than one doc string"
+               "206:4: Warning: More than one doc string"
+               "215:4: Warning: More than one `declare' form"
+               "222:4: Warning: More than one `declare' form"
+               "230:4: Warning: More than one `declare' form"
+               "237:4: Warning: More than one `declare' form"
+               "244:4: Warning: More than one `interactive' form"
+               "251:4: Warning: More than one `interactive' form"
+               "258:4: Warning: More than one `interactive' form"
+               "257:4: Warning: `declare' after `interactive'"
+               "265:4: Warning: More than one `interactive' form"
+               "264:4: Warning: `declare' after `interactive'")))
+        (goto-char (point-min))
+        (let ((actual nil))
+          (while (re-search-forward
+                  (rx bol (* (not ":")) ":"
+                      (group (+ digit) ":" (+ digit) ": Warning: "
+                             (or "More than one " (+ nonl) " form"
+                                 (: (+ nonl) " after " (+ nonl))))
+                      eol)
+                  nil t)
+            (push (match-string 1) actual))
+          (setq actual (nreverse actual))
+          (should (equal actual expected)))))))
+
+
 ;; Local Variables:
 ;; no-byte-compile: t
 ;; End: