From 8f7da7e642be6fb4bf09ba71a986319aa4d47988 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= <mattiase@acm.org>
Date: Fri, 10 Jun 2022 10:16:57 +0200
Subject: [PATCH] function and macro attribute order warning patch

---
 lisp/emacs-lisp/byte-run.el                   | 244 ++++++++++------
 .../bytecomp-resources/fun-attr-warn.el       | 266 ++++++++++++++++++
 test/lisp/emacs-lisp/bytecomp-tests.el        |  63 +++++
 3 files changed, 482 insertions(+), 91 deletions(-)
 create mode 100644 test/lisp/emacs-lisp/bytecomp-resources/fun-attr-warn.el

diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 92c2699c6e..8e5e0e0f5a 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -289,7 +289,7 @@ macro-declarations-alist
 (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
@@ -301,115 +301,177 @@ 'defmacro
 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))))
+       (let ((docstring nil)
+             (declare-form nil)
+             (warnings nil))
+         (while
+             (and body
+                  (let* ((form (car body))
+                         (head (car-safe form)))
+                    (cond
+                     ((or (and (stringp form) (cdr body))
+                          (eq head :documentation))
+                      (cond
+                       (docstring
+                        (push (macroexp-warn-and-return
+                               "More than one doc string" nil nil t form)
+                              warnings))
+                       (declare-form
+                        (push (macroexp-warn-and-return
+                               "Doc string after `declare'" nil nil t
+                               declare-form)
+                              warnings))
+                       (t (setq docstring form)))
+                      t)
+                     ((eq head 'declare)
+                      (cond
+                       (declare-form
+                        (push (macroexp-warn-and-return
+                               "More than one `declare' form" nil nil t form)
+                              warnings))
+                       (t (setq declare-form form)))
+                      t))))
+           (setq body (cdr body)))
+         (if docstring
+             (setq body (cons docstring body))
+           (if (null body)
+               (setq body '(nil))))
+         (let* ((declarations
+                 (nconc
+                  warnings
+                  (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)))))
+                   (cdr declare-form))))
+                ;; Can't use backquote because it's not defined yet!
+                (fun (list 'function (cons 'lambda (cons arglist body))))
+	        (def (list 'defalias
+		           (list 'quote name)
+		           (list 'cons ''macro fun))))
+           ;; 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
+           (if declarations
 	       (cons 'prog1 (cons def 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'.
 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 &optional DOCSTRING DECL INTERACTIVE &rest 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 ((docstring nil)
+        (declare-form nil)
+        (interactive-form nil)
+        (warnings nil))
+    (while
+        (and body
+             (let* ((form (car body))
+                    (head (car-safe form)))
+               (cond
+                ((or (and (stringp form) (cdr body))
+                     (eq head :documentation))
+                 (cond
+                  (docstring
+                   (push (macroexp-warn-and-return
+                          "More than one doc string" nil nil t form)
+                         warnings))
+                  (declare-form
+                   (push (macroexp-warn-and-return
+                          "Doc string after `declare'" nil nil t declare-form)
+                         warnings))
+                  (interactive-form
+                   (push (macroexp-warn-and-return
+                          "Doc string after `interactive'" nil nil t
+                          interactive-form)
+                         warnings))
+                  (t (setq docstring form)))
+                 t)
+                ((eq head 'declare)
+                 (cond
+                  (declare-form
+                   (push (macroexp-warn-and-return
+                          "More than one `declare' form" nil nil t form)
+                         warnings))
+                  (interactive-form
+                   (push (macroexp-warn-and-return
+                          "`declare' after `interactive'" nil nil t form)
+                         warnings))
+                  (t (setq declare-form form)))
+                 t)
+                ((eq head 'interactive)
+                 (cond
+                  (interactive-form
+                   (push (macroexp-warn-and-return
+                          "More than one `interactive' form" nil nil t form)
+                         warnings))
+                  (t (setq interactive-form form)))
+                 t))))
+      (setq body (cdr body)))
     (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
-                     (list 'quote name)
-                     (list 'function
-                           (cons 'lambda
-                                 (cons arglist body))))))
-      (if declarations
-          (cons 'prog1 (cons def declarations))
-          def))))
+           (nconc
+            warnings
+            (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) body)
+                     nil)
+                    (t
+                     (macroexp-warn-and-return
+                      (format-message "Unknown defun property `%S' in %S"
+                                      (car x) name)
+                      nil nil nil (car x))))))
+             (cdr declare-form)))))
+      (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)))))
 
 
 ;; 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 27098d0bb1..0e46bce5f2 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -1574,6 +1574,69 @@ bytecomp-function-attributes
       (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'"
+               "156:2: Warning: More than one doc string"
+               "165:4: Warning: More than one doc string"
+               "170:2: Warning: More than one doc string"
+               "179:4: Warning: More than one doc string"
+               "184:2: Warning: More than one doc string"
+               "191:2: Warning: More than one doc string"
+               "201:4: Warning: More than one doc string"
+               "208: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:
-- 
2.32.0 (Apple Git-132)

