From 55f0576ebd4601fbf8e5e7ba9ab14e00fa2821b0 Mon Sep 17 00:00:00 2001
From: Mattias Engdegård <mattiase@acm.org>
Date: Wed, 7 Apr 2021 13:11:43 +0200
Subject: Fix mistakes in bytecomp-tests

* test/lisp/emacs-lisp/bytecomp-tests.el
(byte-opt-testsuite-arith-data): Fix typos and avoid errors that made
the tests less powerful than intended.
---
 test/lisp/emacs-lisp/bytecomp-tests.el | 20 ++++++++++----------
 1 file changed, 10 insertions(+), 10 deletions(-)

(limited to 'test/lisp/emacs-lisp/bytecomp-tests.el')

diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el
index 5147cd26883..0f7a0ccc851 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -364,17 +364,17 @@
             '((a c) (b c) (7 c) (-3 c) (nil nil) (t c) (q c) (r c) (s c)
               (t c) (x "a") (x "c") (x c) (x d) (x e)))
 
-    (mapcar (lambda (x) (cond ((member '(a . b) x) 1)
-                              ((equal x '(c)) 2)))
+    (mapcar (lambda (x) (ignore-errors (cond ((member '(a . b) x) 1)
+                                             ((equal x '(c)) 2))))
             '(((a . b)) a b (c) (d)))
-    (mapcar (lambda (x) (cond ((memq '(a . b) x) 1)
-                              ((equal x '(c)) 2)))
+    (mapcar (lambda (x) (ignore-errors (cond ((memq '(a . b) x) 1)
+                                             ((equal x '(c)) 2))))
             '(((a . b)) a b (c) (d)))
-    (mapcar (lambda (x) (cond ((member '(a b) x) 1)
-                              ((equal x '(c)) 2)))
+    (mapcar (lambda (x) (ignore-errors (cond ((member '(a b) x) 1)
+                                             ((equal x '(c)) 2))))
             '(((a b)) a b (c) (d)))
-    (mapcar (lambda (x) (cond ((memq '(a b) x) 1)
-                              ((equal x '(c)) 2)))
+    (mapcar (lambda (x) (ignore-errors (cond ((memq '(a b) x) 1)
+                                             ((equal x '(c)) 2))))
             '(((a b)) a b (c) (d)))
 
     (assoc 'b '((a 1) (b 2) (c 3)))
@@ -396,7 +396,7 @@
       x)
 
     (let ((x 1) (bytecomp-test-var 2) (y 3))
-      (list x bytecomp-test-var (bytecomp-get-test-var) y))
+      (list x bytecomp-test-var (bytecomp-test-get-var) y))
 
     (progn
       (defvar d)
@@ -430,7 +430,7 @@
       (list s x i))
 
     (let ((x 2))
-      (list (or (bytecomp-identity 'a) (setq x 3)) x)))
+      (list (or (bytecomp-test-identity 'a) (setq x 3)) x)))
   "List of expression for test.
 Each element will be executed by interpreter and with
 bytecompiled code, and their results compared.")
-- 
cgit v1.2.3


From a2a7cfde29aa71f9ea503b8dc467d694f6e5b69f Mon Sep 17 00:00:00 2001
From: Mattias Engdegård <mattiase@acm.org>
Date: Fri, 9 Apr 2021 18:42:12 +0200
Subject: Clean up bytecomp-tests.el

Now all test cases are run with both lexical and dynamic binding
where applicable, comparing interpreted against compiled results.
Previously, almost all tests were only run with dynamic binding
which was definitely not intended.

* test/lisp/emacs-lisp/bytecomp-tests.el
(byte-opt-testsuite-arith-data): Rename to bytecomp-tests--test-cases.
(bytecomp-check-1, bytecomp-explain-1, bytecomp-tests)
(bytecomp-lexbind-tests, bytecomp-lexbind-check-1)
(bytecomp-lexbind-explain-1): Remove.
(bytecomp-tests--eval-interpreted, bytecomp-tests--eval-compiled)
(bytecomp-tests-lexbind, bytecomp-tests-dynbind)
(bytecomp-tests--test-cases-lexbind-only): New.
---
 test/lisp/emacs-lisp/bytecomp-tests.el | 150 +++++++++++----------------------
 1 file changed, 47 insertions(+), 103 deletions(-)

(limited to 'test/lisp/emacs-lisp/bytecomp-tests.el')

diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el
index 0f7a0ccc851..b1377e59f77 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -41,7 +41,7 @@
   "Identity, but hidden from some optimisations."
   x)
 
-(defconst byte-opt-testsuite-arith-data
+(defconst bytecomp-tests--test-cases
   '(
     ;; some functional tests
     (let ((a most-positive-fixnum) (b 1) (c 1.0))  (+ a b c))
@@ -430,69 +430,54 @@
       (list s x i))
 
     (let ((x 2))
-      (list (or (bytecomp-test-identity 'a) (setq x 3)) x)))
-  "List of expression for test.
-Each element will be executed by interpreter and with
-bytecompiled code, and their results compared.")
+      (list (or (bytecomp-test-identity 'a) (setq x 3)) x))
+    )
+  "List of expressions for cross-testing interpreted and compiled code.")
 
-(defun bytecomp-check-1 (pat)
-  "Return non-nil if PAT is the same whether directly evalled or compiled."
-  (let ((warning-minimum-log-level :emergency)
-        (byte-compile-warnings nil)
-	(v0 (condition-case err
-		(eval pat)
-	      (error (list 'bytecomp-check-error (car err)))))
-	(v1 (condition-case err
-		(funcall (byte-compile (list 'lambda nil pat)))
-	      (error (list 'bytecomp-check-error (car err))))))
-    (equal v0 v1)))
-
-(put 'bytecomp-check-1 'ert-explainer 'bytecomp-explain-1)
-
-(defun bytecomp-explain-1 (pat)
-  (let ((v0 (condition-case err
-		(eval pat)
-	      (error (list 'bytecomp-check-error (car err)))))
-	(v1 (condition-case err
-		(funcall (byte-compile (list 'lambda nil pat)))
-	      (error (list 'bytecomp-check-error (car err))))))
-    (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled."
-	    pat v0 v1)))
-
-(ert-deftest bytecomp-tests ()
-  "Test the Emacs byte compiler."
-  (dolist (pat byte-opt-testsuite-arith-data)
-    (should (bytecomp-check-1 pat))))
-
-(defun test-byte-opt-arithmetic (&optional arg)
-  "Unit test for byte-opt arithmetic operations.
-Subtests signal errors if something goes wrong."
-  (interactive "P")
-  (switch-to-buffer (generate-new-buffer "*Font Pase Test*"))
+(defconst bytecomp-tests--test-cases-lexbind-only
+  `(
+    ;; This would infloop (and exhaust stack) with dynamic binding.
+    (let ((f #'car))
+      (let ((f (lambda (x) (cons (funcall f x) (cdr x)))))
+        (funcall f '(1 . 2))))
+    )
+  "List of expressions for cross-testing interpreted and compiled code.
+These are only tested with lexical binding.")
+
+(defun bytecomp-tests--eval-interpreted (form)
+  "Evaluate FORM using the Lisp interpreter, returning errors as a
+special value."
+  (condition-case err
+      (eval form lexical-binding)
+    (error (list 'bytecomp-check-error (car err)))))
+
+(defun bytecomp-tests--eval-compiled (form)
+  "Evaluate FORM using the Lisp byte-code compiler, returning errors as a
+special value."
   (let ((warning-minimum-log-level :emergency)
-	(byte-compile-warnings nil)
-	(pass-face '((t :foreground "green")))
-	(fail-face '((t :foreground "red")))
-	(print-escape-nonascii t)
-	(print-escape-newlines t)
-	(print-quoted t)
-	v0 v1)
-    (dolist (pat byte-opt-testsuite-arith-data)
-      (condition-case err
-	  (setq v0 (eval pat))
-	(error (setq v0 (list 'bytecomp-check-error (car err)))))
-      (condition-case err
-	  (setq v1 (funcall (byte-compile (list 'lambda nil pat))))
-	(error (setq v1 (list 'bytecomp-check-error (car err)))))
-      (insert (format "%s" pat))
-      (indent-to-column 65)
-      (if (equal v0 v1)
-	  (insert (propertize "OK" 'face pass-face))
-	(insert (propertize "FAIL\n" 'face fail-face))
-	(indent-to-column 55)
-	(insert (propertize (format "[%s] vs [%s]" v0 v1)
-			    'face fail-face)))
-      (insert "\n"))))
+        (byte-compile-warnings nil))
+    (condition-case err
+	(funcall (byte-compile (list 'lambda nil form)))
+      (error (list 'bytecomp-check-error (car err))))))
+
+(ert-deftest bytecomp-tests-lexbind ()
+  "Check that various expressions behave the same when interpreted and
+byte-compiled.  Run with lexical binding."
+  (let ((lexical-binding t))
+    (dolist (form (append bytecomp-tests--test-cases-lexbind-only
+                          bytecomp-tests--test-cases))
+      (ert-info ((prin1-to-string form) :prefix "form: ")
+        (should (equal (bytecomp-tests--eval-interpreted form)
+                       (bytecomp-tests--eval-compiled form)))))))
+
+(ert-deftest bytecomp-tests-dynbind ()
+  "Check that various expressions behave the same when interpreted and
+byte-compiled.  Run with dynamic binding."
+  (let ((lexical-binding nil))
+    (dolist (form bytecomp-tests--test-cases)
+      (ert-info ((prin1-to-string form) :prefix "form: ")
+        (should (equal (bytecomp-tests--eval-interpreted form)
+                       (bytecomp-tests--eval-compiled form)))))))
 
 (defun test-byte-comp-compile-and-load (compile &rest forms)
   (declare (indent 1))
@@ -813,47 +798,6 @@ Subtests signal errors if something goes wrong."
       (defun def () (m))))
   (should (equal (funcall 'def) 4)))
 
-(defconst bytecomp-lexbind-tests
-  `(
-    (let ((f #'car))
-      (let ((f (lambda (x) (cons (funcall f x) (cdr x)))))
-        (funcall f '(1 . 2))))
-    )
-  "List of expression for test.
-Each element will be executed by interpreter and with
-bytecompiled code, and their results compared.")
-
-(defun bytecomp-lexbind-check-1 (pat)
-  "Return non-nil if PAT is the same whether directly evalled or compiled."
-  (let ((warning-minimum-log-level :emergency)
-	(byte-compile-warnings nil)
-	(v0 (condition-case err
-		(eval pat t)
-	      (error (list 'bytecomp-check-error (car err)))))
-	(v1 (condition-case err
-		(funcall (let ((lexical-binding t))
-                           (byte-compile `(lambda nil ,pat))))
-	      (error (list 'bytecomp-check-error (car err))))))
-    (equal v0 v1)))
-
-(put 'bytecomp-lexbind-check-1 'ert-explainer 'bytecomp-lexbind-explain-1)
-
-(defun bytecomp-lexbind-explain-1 (pat)
-  (let ((v0 (condition-case err
-		(eval pat t)
-	      (error (list 'bytecomp-check-error (car err)))))
-	(v1 (condition-case err
-		(funcall (let ((lexical-binding t))
-                           (byte-compile (list 'lambda nil pat))))
-	      (error (list 'bytecomp-check-error (car err))))))
-    (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled."
-	    pat v0 v1)))
-
-(ert-deftest bytecomp-lexbind-tests ()
-  "Test the Emacs byte compiler lexbind handling."
-  (dolist (pat bytecomp-lexbind-tests)
-    (should (bytecomp-lexbind-check-1 pat))))
-
 (defmacro bytecomp-tests--with-temp-file (file-name-var &rest body)
   (declare (indent 1))
   (cl-check-type file-name-var symbol)
-- 
cgit v1.2.3


From b7a7e879d02570cbf74aa87686b6b0ed4e6b0c3b Mon Sep 17 00:00:00 2001
From: Mattias Engdegård <mattiase@acm.org>
Date: Fri, 9 Apr 2021 18:49:16 +0200
Subject: Better compiler warning tests

These changes allow all bytecomp-tests to be run interactively.

* test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp--with-warning-test)
(bytecomp--define-warning-file-test): Interpret any space in the
pattern as arbitrary whitespace to tolerate line breaks.
Don't abuse the expected-failure mechanism when checking
for the expected absense of a warning.
(bytecomp/*.el): Rewrite patterns to work with line breaks
in the middle.
---
 test/lisp/emacs-lisp/bytecomp-tests.el | 49 +++++++++++++++++-----------------
 1 file changed, 25 insertions(+), 24 deletions(-)

(limited to 'test/lisp/emacs-lisp/bytecomp-tests.el')

diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el
index b1377e59f77..1953878d6f5 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -569,8 +569,8 @@ byte-compiled.  Run with dynamic binding."
   `(with-current-buffer (get-buffer-create "*Compile-Log*")
      (let ((inhibit-read-only t)) (erase-buffer))
      (byte-compile ,@form)
-     (ert-info ((buffer-string) :prefix "buffer: ")
-       (should (re-search-forward ,re-warning)))))
+     (ert-info ((prin1-to-string (buffer-string)) :prefix "buffer: ")
+       (should (re-search-forward ,(string-replace " " "[ \n]+" re-warning))))))
 
 (ert-deftest bytecomp-warn-wrong-args ()
   (bytecomp--with-warning-test "remq.*3.*2"
@@ -596,12 +596,13 @@ byte-compiled.  Run with dynamic binding."
 
 (defmacro bytecomp--define-warning-file-test (file re-warning &optional reverse)
   `(ert-deftest ,(intern (format "bytecomp/%s" file)) ()
-     :expected-result ,(if reverse :failed :passed)
      (with-current-buffer (get-buffer-create "*Compile-Log*")
        (let ((inhibit-read-only t)) (erase-buffer))
        (byte-compile-file ,(ert-resource-file file))
        (ert-info ((buffer-string) :prefix "buffer: ")
-         (should (re-search-forward ,re-warning))))))
+         (,(if reverse 'should-not 'should)
+          (re-search-forward ,(string-replace " " "[ \n]+" re-warning)
+                             nil t))))))
 
 (bytecomp--define-warning-file-test "error-lexical-var-with-add-hook.el"
                             "add-hook.*lexical var")
@@ -643,10 +644,10 @@ byte-compiled.  Run with dynamic binding."
                             "free.*foo")
 
 (bytecomp--define-warning-file-test "warn-free-variable-reference.el"
-                            "free.*bar")
+                            "free variable .bar")
 
 (bytecomp--define-warning-file-test "warn-make-variable-buffer-local.el"
-                            "make-variable-buffer-local.*not called at toplevel")
+                            "make-variable-buffer-local. not called at toplevel")
 
 (bytecomp--define-warning-file-test "warn-interactive-only.el"
                             "next-line.*interactive use only.*forward-line")
@@ -655,19 +656,19 @@ byte-compiled.  Run with dynamic binding."
                             "malformed interactive spec")
 
 (bytecomp--define-warning-file-test "warn-obsolete-defun.el"
-                            "foo-obsolete.*obsolete function.*99.99")
+  "foo-obsolete. is an obsolete function (as of 99.99)")
 
 (defvar bytecomp--tests-obsolete-var nil)
 (make-obsolete-variable 'bytecomp--tests-obsolete-var nil "99.99")
 
 (bytecomp--define-warning-file-test "warn-obsolete-hook.el"
-                            "bytecomp--tests-obs.*obsolete[^z-a]*99.99")
+  "bytecomp--tests-obsolete-var. is an obsolete variable (as of 99.99)")
 
 (bytecomp--define-warning-file-test "warn-obsolete-variable-same-file.el"
                             "foo-obs.*obsolete.*99.99" t)
 
 (bytecomp--define-warning-file-test "warn-obsolete-variable.el"
-                            "bytecomp--tests-obs.*obsolete[^z-a]*99.99")
+  "bytecomp--tests-obsolete-var. is an obsolete variable (as of 99.99)")
 
 (bytecomp--define-warning-file-test "warn-obsolete-variable-bound.el"
                             "bytecomp--tests-obs.*obsolete.*99.99" t)
@@ -698,64 +699,64 @@ byte-compiled.  Run with dynamic binding."
 
 (bytecomp--define-warning-file-test
  "warn-wide-docstring-autoload.el"
- "autoload.*foox.*wider than.*characters")
+ "autoload .foox. docstring wider than .* characters")
 
 (bytecomp--define-warning-file-test
  "warn-wide-docstring-custom-declare-variable.el"
- "custom-declare-variable.*foo.*wider than.*characters")
+ "custom-declare-variable .foo. docstring wider than .* characters")
 
 (bytecomp--define-warning-file-test
  "warn-wide-docstring-defalias.el"
- "defalias.*foo.*wider than.*characters")
+ "defalias .foo. docstring wider than .* characters")
 
 (bytecomp--define-warning-file-test
  "warn-wide-docstring-defconst.el"
- "defconst.*foo.*wider than.*characters")
+ "defconst .foo-bar. docstring wider than .* characters")
 
 (bytecomp--define-warning-file-test
  "warn-wide-docstring-define-abbrev-table.el"
- "define-abbrev.*foo.*wider than.*characters")
+ "define-abbrev-table .foo. docstring wider than .* characters")
 
 (bytecomp--define-warning-file-test
  "warn-wide-docstring-define-obsolete-function-alias.el"
- "defalias.*foo.*wider than.*characters")
+ "defalias .foo. docstring wider than .* characters")
 
 (bytecomp--define-warning-file-test
  "warn-wide-docstring-define-obsolete-variable-alias.el"
- "defvaralias.*foo.*wider than.*characters")
+ "defvaralias .foo. docstring wider than .* characters")
 
 ;; TODO: We don't yet issue warnings for defuns.
 (bytecomp--define-warning-file-test
  "warn-wide-docstring-defun.el"
- "wider than.*characters" 'reverse)
+ "wider than .* characters" 'reverse)
 
 (bytecomp--define-warning-file-test
  "warn-wide-docstring-defvar.el"
- "defvar.*foo.*wider than.*characters")
+ "defvar .foo-bar. docstring wider than .* characters")
 
 (bytecomp--define-warning-file-test
  "warn-wide-docstring-defvaralias.el"
- "defvaralias.*foo.*wider than.*characters")
+ "defvaralias .foo-bar. docstring wider than .* characters")
 
 (bytecomp--define-warning-file-test
  "warn-wide-docstring-ignore-fill-column.el"
- "defvar.*foo.*wider than.*characters" 'reverse)
+ "defvar .foo-bar. docstring wider than .* characters" 'reverse)
 
 (bytecomp--define-warning-file-test
  "warn-wide-docstring-ignore-override.el"
- "defvar.*foo.*wider than.*characters" 'reverse)
+ "defvar .foo-bar. docstring wider than .* characters" 'reverse)
 
 (bytecomp--define-warning-file-test
  "warn-wide-docstring-ignore.el"
- "defvar.*foo.*wider than.*characters" 'reverse)
+ "defvar .foo-bar. docstring wider than .* characters" 'reverse)
 
 (bytecomp--define-warning-file-test
  "warn-wide-docstring-multiline-first.el"
- "defvar.*foo.*wider than.*characters")
+ "defvar .foo-bar. docstring wider than .* characters")
 
 (bytecomp--define-warning-file-test
  "warn-wide-docstring-multiline.el"
- "defvar.*foo.*wider than.*characters")
+ "defvar .foo-bar. docstring wider than .* characters")
 
 (bytecomp--define-warning-file-test
  "nowarn-inline-after-defvar.el"
-- 
cgit v1.2.3


From 59342f689eaa4839b0fc15351ae48b4f1074a6fc Mon Sep 17 00:00:00 2001
From: Mattias Engdegård <mattiase@acm.org>
Date: Fri, 9 Apr 2021 18:59:09 +0200
Subject: Fix condition-case optimiser bug

* lisp/emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): Don't
perform incorrect optimisations when a condition-case variable shadows
another lexical variable.
* test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp-tests--test-cases):
New test case.
---
 lisp/emacs-lisp/byte-opt.el            | 10 ++++++++--
 test/lisp/emacs-lisp/bytecomp-tests.el |  6 ++++++
 2 files changed, 14 insertions(+), 2 deletions(-)

(limited to 'test/lisp/emacs-lisp/bytecomp-tests.el')

diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index db8d825cfec..e5265375314 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -528,8 +528,14 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.")
          `(condition-case ,var          ;Not evaluated.
               ,(byte-optimize-form exp for-effect)
             ,@(mapcar (lambda (clause)
-                        `(,(car clause)
-                          ,@(byte-optimize-body (cdr clause) for-effect)))
+                        (let ((byte-optimize--lexvars
+                               (and lexical-binding
+                                    (if var
+                                        (cons (list var t)
+                                              byte-optimize--lexvars)
+                                      byte-optimize--lexvars))))
+                          (cons (car clause)
+                                (byte-optimize-body (cdr clause) for-effect))))
                       clauses))))
 
       (`(unwind-protect ,exp . ,exps)
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el
index 1953878d6f5..94e33a7770e 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -431,6 +431,12 @@
 
     (let ((x 2))
       (list (or (bytecomp-test-identity 'a) (setq x 3)) x))
+
+    (let* ((x 1)
+           (y (condition-case x
+                  (/ 1 0)
+                (arith-error x))))
+      (list x y))
     )
   "List of expressions for cross-testing interpreted and compiled code.")
 
-- 
cgit v1.2.3


From 01a513bf0beb9478e2ef801ca28ebc992455fe3c Mon Sep 17 00:00:00 2001
From: Mattias Engdegård <mattiase@acm.org>
Date: Sun, 11 Apr 2021 12:38:37 +0200
Subject: Fix typo in cconv

* lisp/emacs-lisp/cconv.el (cconv-convert): Typo.
* test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp-tests--test-cases):
Add test case.
---
 lisp/emacs-lisp/cconv.el               | 2 +-
 test/lisp/emacs-lisp/bytecomp-tests.el | 7 +++++++
 2 files changed, 8 insertions(+), 1 deletion(-)

(limited to 'test/lisp/emacs-lisp/bytecomp-tests.el')

diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index afaa13a8695..b37cfebab31 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -498,7 +498,7 @@ places where they originally did not directly appear."
      (let* ((class (and var (cconv--var-classification (list var) form)))
             (newenv
              (cond ((eq class :captured+mutated)
-                    (cons `(,var . (car-save ,var)) env))
+                    (cons `(,var . (car-safe ,var)) env))
                    ((assq var env) (cons `(,var) env))
                    (t env)))
             (msg (when (eq class :unused)
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el
index 94e33a7770e..a11832d805e 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -437,6 +437,13 @@
                   (/ 1 0)
                 (arith-error x))))
       (list x y))
+
+    (funcall
+     (condition-case x
+         (/ 1 0)
+       (arith-error (prog1 (lambda (y) (+ y x))
+                      (setq x 10))))
+     4)
     )
   "List of expressions for cross-testing interpreted and compiled code.")
 
-- 
cgit v1.2.3


From 7893945cc8f9421d0be5b07b9ed404bdf25ce140 Mon Sep 17 00:00:00 2001
From: Mattias Engdegård <mattiase@acm.org>
Date: Wed, 7 Apr 2021 11:31:07 +0200
Subject: Add condition-case success handler (bug#47677)

Allow a condition-case handler on the form (:success BODY) to be
specified as the success continuation of the protected form, with
the specified variable bound to its result.

* src/eval.c (Fcondition_case): Update the doc string.
(internal_lisp_condition_case): Implement in interpreter.
(syms_of_eval): Defsym :success.
* lisp/emacs-lisp/bytecomp.el (byte-compile-condition-case):
Implement in byte-compiler.
* lisp/emacs-lisp/cl-macs.el (cl--self-tco): Allow self-TCO
from success handler.
* doc/lispref/control.texi (Handling Errors): Update manual.
* etc/NEWS: Announce.
* test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp-tests--test-cases)
(bytecomp-condition-case-success):
* test/lisp/emacs-lisp/cl-macs-tests.el (cl-macs--labels):
Add test cases.
---
 doc/lispref/control.texi               |   9 ++-
 etc/NEWS                               |   6 ++
 lisp/emacs-lisp/bytecomp.el            |  63 +++++++++-------
 lisp/emacs-lisp/cl-macs.el             |   4 +-
 src/eval.c                             |  34 ++++++++-
 test/lisp/emacs-lisp/bytecomp-tests.el | 127 +++++++++++++++++++++++++++++++++
 test/lisp/emacs-lisp/cl-macs-tests.el  |   9 +--
 7 files changed, 219 insertions(+), 33 deletions(-)

(limited to 'test/lisp/emacs-lisp/bytecomp-tests.el')

diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi
index 3388102f694..22b665bc931 100644
--- a/doc/lispref/control.texi
+++ b/doc/lispref/control.texi
@@ -2012,7 +2012,8 @@ that can be handled).
 This special form establishes the error handlers @var{handlers} around
 the execution of @var{protected-form}.  If @var{protected-form} executes
 without error, the value it returns becomes the value of the
-@code{condition-case} form; in this case, the @code{condition-case} has
+@code{condition-case} form (in the absence of a success handler; see below).
+In this case, the @code{condition-case} has
 no effect.  The @code{condition-case} form makes a difference when an
 error occurs during @var{protected-form}.
 
@@ -2062,6 +2063,12 @@ error description.
 If @var{var} is @code{nil}, that means no variable is bound.  Then the
 error symbol and associated data are not available to the handler.
 
+@cindex success handler
+As a special case, one of the @var{handlers} can be a list of the
+form @code{(:success @var{body}@dots{})}, where @var{body} is executed
+with @var{var} (if non-@code{nil}) bound to the return value of
+@var{protected-form} when that expression terminates without error.
+
 @cindex rethrow a signal
 Sometimes it is necessary to re-throw a signal caught by
 @code{condition-case}, for some outer-level handler to catch.  Here's
diff --git a/etc/NEWS b/etc/NEWS
index d4f942bafe3..6113aa6fb22 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -2935,6 +2935,12 @@ arrays nor objects.
 The special events 'dbus-event' and 'file-notify' are now ignored in
 'while-no-input' when added to this variable.
 
++++
+** 'condition-case' now allows for a success handler.
+It is written as (:success BODY...) where BODY is executed whenever
+the protected form terminates without error, with the specified
+variable bound to the the value of the protected form.
+
 
 * Changes in Emacs 28.1 on Non-Free Operating Systems
 
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 0babbbb978d..4f91f0d5dea 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -4621,10 +4621,15 @@ binding slots have been popped."
 (defun byte-compile-condition-case (form)
   (let* ((var (nth 1 form))
          (body (nth 2 form))
+         (handlers (nthcdr 3 form))
          (depth byte-compile-depth)
+         (success-handler (assq :success handlers))
+         (failure-handlers (if success-handler
+                               (remq success-handler handlers)
+                             handlers))
          (clauses (mapcar (lambda (clause)
                             (cons (byte-compile-make-tag) clause))
-                          (nthcdr 3 form)))
+                          failure-handlers))
          (endtag (byte-compile-make-tag)))
     (byte-compile-set-symbol-position 'condition-case)
     (unless (symbolp var)
@@ -4650,30 +4655,40 @@ binding slots have been popped."
 
     (byte-compile-form body) ;; byte-compile--for-effect
     (dolist (_ clauses) (byte-compile-out 'byte-pophandler))
-    (byte-compile-goto 'byte-goto endtag)
 
-    (while clauses
-      (let ((clause (pop clauses))
-            (byte-compile-bound-variables byte-compile-bound-variables)
-            (byte-compile--lexical-environment
-             byte-compile--lexical-environment))
-        (setq byte-compile-depth (1+ depth))
-        (byte-compile-out-tag (pop clause))
-        (dolist (_ clauses) (byte-compile-out 'byte-pophandler))
-        (cond
-         ((null var) (byte-compile-discard))
-         (lexical-binding
-          (push (cons var (1- byte-compile-depth))
-                byte-compile--lexical-environment))
-         (t (byte-compile-dynamic-variable-bind var)))
-        (byte-compile-body (cdr clause)) ;; byte-compile--for-effect
-        (cond
-         ((null var) nil)
-         (lexical-binding (byte-compile-discard 1 'preserve-tos))
-         (t (byte-compile-out 'byte-unbind 1)))
-        (byte-compile-goto 'byte-goto endtag)))
-
-    (byte-compile-out-tag endtag)))
+    (let ((compile-handler-body
+           (lambda (body)
+             (let ((byte-compile-bound-variables byte-compile-bound-variables)
+                   (byte-compile--lexical-environment
+                    byte-compile--lexical-environment))
+               (cond
+                ((null var) (byte-compile-discard))
+                (lexical-binding
+                 (push (cons var (1- byte-compile-depth))
+                       byte-compile--lexical-environment))
+                (t (byte-compile-dynamic-variable-bind var)))
+
+               (byte-compile-body body) ;; byte-compile--for-effect
+
+               (cond
+                ((null var))
+                (lexical-binding (byte-compile-discard 1 'preserve-tos))
+                (t (byte-compile-out 'byte-unbind 1)))))))
+
+      (when success-handler
+        (funcall compile-handler-body (cdr success-handler)))
+
+      (byte-compile-goto 'byte-goto endtag)
+
+      (while clauses
+        (let ((clause (pop clauses)))
+          (setq byte-compile-depth (1+ depth))
+          (byte-compile-out-tag (pop clause))
+          (dolist (_ clauses) (byte-compile-out 'byte-pophandler))
+          (funcall compile-handler-body (cdr clause))
+          (byte-compile-goto 'byte-goto endtag)))
+
+      (byte-compile-out-tag endtag))))
 
 (defun byte-compile-save-excursion (form)
   (if (and (eq 'set-buffer (car-safe (car-safe (cdr form))))
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 68211ec4106..b7e5be95bc3 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2144,7 +2144,9 @@ Like `cl-flet' but the definitions can refer to previous ones.
             ((and `(condition-case ,err-var ,bodyform . ,handlers)
                   (guard (not (eq err-var var))))
              `(condition-case ,err-var
-                  (progn (setq ,retvar ,bodyform) nil)
+                  ,(if (assq :success handlers)
+                       bodyform
+                     `(progn (setq ,retvar ,bodyform) nil))
                 . ,(mapcar (lambda (h)
                              (cons (car h) (funcall opt-exps (cdr h))))
                            handlers)))
diff --git a/src/eval.c b/src/eval.c
index ddaa8edd817..fd93f5b9e1f 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1301,7 +1301,7 @@ DEFUN ("condition-case", Fcondition_case, Scondition_case, 2, UNEVALLED, 0,
        doc: /* Regain control when an error is signaled.
 Executes BODYFORM and returns its value if no error happens.
 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
-where the BODY is made of Lisp expressions.
+or (:success BODY...), where the BODY is made of Lisp expressions.
 
 A handler is applicable to an error if CONDITION-NAME is one of the
 error's condition names.  Handlers may also apply when non-error
@@ -1323,6 +1323,10 @@ with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
 Then the value of the last BODY form is returned from the `condition-case'
 expression.
 
+The special handler (:success BODY...) is invoked if BODYFORM terminated
+without signalling an error.  BODY is then evaluated with VAR bound to
+the value returned by BODYFORM.
+
 See also the function `signal' for more info.
 usage: (condition-case VAR BODYFORM &rest HANDLERS)  */)
   (Lisp_Object args)
@@ -1346,16 +1350,21 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform,
 
   CHECK_SYMBOL (var);
 
+  Lisp_Object success_handler = Qnil;
+
   for (Lisp_Object tail = handlers; CONSP (tail); tail = XCDR (tail))
     {
       Lisp_Object tem = XCAR (tail);
-      clausenb++;
       if (! (NILP (tem)
 	     || (CONSP (tem)
 		 && (SYMBOLP (XCAR (tem))
 		     || CONSP (XCAR (tem))))))
 	error ("Invalid condition handler: %s",
 	       SDATA (Fprin1_to_string (tem, Qt)));
+      if (EQ (XCAR (tem), QCsuccess))
+	success_handler = XCDR (tem);
+      else
+	clausenb++;
     }
 
   /* The first clause is the one that should be checked first, so it
@@ -1369,7 +1378,8 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform,
   Lisp_Object volatile *clauses = alloca (clausenb * sizeof *clauses);
   clauses += clausenb;
   for (Lisp_Object tail = handlers; CONSP (tail); tail = XCDR (tail))
-    *--clauses = XCAR (tail);
+    if (!EQ (XCAR (XCAR (tail)), QCsuccess))
+      *--clauses = XCAR (tail);
   for (ptrdiff_t i = 0; i < clausenb; i++)
     {
       Lisp_Object clause = clauses[i];
@@ -1409,6 +1419,23 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform,
 
   Lisp_Object result = eval_sub (bodyform);
   handlerlist = oldhandlerlist;
+  if (!NILP (success_handler))
+    {
+      if (NILP (var))
+	return Fprogn (success_handler);
+
+      Lisp_Object handler_var = var;
+      if (!NILP (Vinternal_interpreter_environment))
+	{
+	  result = Fcons (Fcons (var, result),
+		       Vinternal_interpreter_environment);
+	  handler_var = Qinternal_interpreter_environment;
+	}
+
+      ptrdiff_t count = SPECPDL_INDEX ();
+      specbind (handler_var, result);
+      return unbind_to (count, Fprogn (success_handler));
+    }
   return result;
 }
 
@@ -4381,6 +4408,7 @@ alist of active lexical bindings.  */);
   defsubr (&Sthrow);
   defsubr (&Sunwind_protect);
   defsubr (&Scondition_case);
+  DEFSYM (QCsuccess, ":success");
   defsubr (&Ssignal);
   defsubr (&Scommandp);
   defsubr (&Sautoload);
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el
index a11832d805e..c9ab3ec1f1b 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -444,6 +444,65 @@
        (arith-error (prog1 (lambda (y) (+ y x))
                       (setq x 10))))
      4)
+
+    ;; No error, no success handler.
+    (condition-case x
+        (list 42)
+      (error (cons 'bad x)))
+    ;; Error, no success handler.
+    (condition-case x
+        (/ 1 0)
+      (error (cons 'bad x)))
+    ;; No error, success handler.
+    (condition-case x
+        (list 42)
+      (error (cons 'bad x))
+      (:success (cons 'good x)))
+    ;; Error, success handler.
+    (condition-case x
+        (/ 1 0)
+      (error (cons 'bad x))
+      (:success (cons 'good x)))
+    ;; Verify that the success code is not subject to the error handlers.
+    (condition-case x
+        (list 42)
+      (error (cons 'bad x))
+      (:success (/ (car x) 0)))
+    ;; Check variable scoping on success.
+    (let ((x 2))
+      (condition-case x
+          (list x)
+        (error (list 'bad x))
+        (:success (list 'good x))))
+    ;; Check variable scoping on failure.
+    (let ((x 2))
+      (condition-case x
+          (/ 1 0)
+        (error (list 'bad x))
+        (:success (list 'good x))))
+    ;; Check capture of mutated result variable.
+    (funcall
+     (condition-case x
+         3
+       (:success (prog1 (lambda (y) (+ y x))
+                   (setq x 10))))
+     4)
+    ;; Check for-effect context, on error.
+    (let ((f (lambda (x)
+               (condition-case nil
+                   (/ 1 0)
+                 (error 'bad)
+                 (:success 'good))
+               (1+ x))))
+      (funcall f 3))
+    ;; Check for-effect context, on success.
+    (let ((f (lambda (x)
+               (condition-case nil
+                   nil
+                 (error 'bad)
+                 (:success 'good))
+               (1+ x))))
+      (funcall f 3))
     )
   "List of expressions for cross-testing interpreted and compiled code.")
 
@@ -1185,6 +1244,74 @@ compiled correctly."
   (let ((lexical-binding t))
     (should (equal (funcall (byte-compile '(lambda (x) "foo")) 'dummy) "foo"))))
 
+(ert-deftest bytecomp-condition-case-success ()
+  ;; No error, no success handler.
+  (should (equal (condition-case x
+                     (list 42)
+                   (error (cons 'bad x)))
+                 '(42)))
+  ;; Error, no success handler.
+  (should (equal (condition-case x
+                     (/ 1 0)
+                   (error (cons 'bad x)))
+                 '(bad arith-error)))
+  ;; No error, success handler.
+  (should (equal (condition-case x
+                     (list 42)
+                   (error (cons 'bad x))
+                   (:success (cons 'good x)))
+                 '(good 42)))
+  ;; Error, success handler.
+  (should (equal (condition-case x
+                     (/ 1 0)
+                   (error (cons 'bad x))
+                   (:success (cons 'good x)))
+                 '(bad arith-error)))
+  ;; Verify that the success code is not subject to the error handlers.
+  (should-error (condition-case x
+                    (list 42)
+                  (error (cons 'bad x))
+                  (:success (/ (car x) 0)))
+                :type 'arith-error)
+  ;; Check variable scoping.
+  (let ((x 2))
+    (should (equal (condition-case x
+                       (list x)
+                     (error (list 'bad x))
+                     (:success (list 'good x)))
+                   '(good (2))))
+    (should (equal (condition-case x
+                       (/ 1 0)
+                     (error (list 'bad x))
+                     (:success (list 'good x)))
+                   '(bad (arith-error)))))
+  ;; Check capture of mutated result variable.
+  (should (equal (funcall
+                  (condition-case x
+                      3
+                    (:success (prog1 (lambda (y) (+ y x))
+                                (setq x 10))))
+                  4)
+                 14))
+    ;; Check for-effect context, on error.
+  (should (equal (let ((f (lambda (x)
+                            (condition-case nil
+                                (/ 1 0)
+                              (error 'bad)
+                              (:success 'good))
+                            (1+ x))))
+                   (funcall f 3))
+                 4))
+  ;; Check for-effect context, on success.
+  (should (equal (let ((f (lambda (x)
+                            (condition-case nil
+                                nil
+                              (error 'bad)
+                              (:success 'good))
+                            (1+ x))))
+                   (funcall f 3))
+                 4)))
+
 ;; Local Variables:
 ;; no-byte-compile: t
 ;; End:
diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el
index 5c3e603b92e..f4e2e46a019 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -630,12 +630,13 @@ collection clause."
                             (and xs
                                  (progn (setq n1 (1+ n))
                                         (len2 (cdr xs) n1))))))
-         ;; Tail call in error handler.
+         ;; Tail calls in error and success handlers.
          (len3 (xs n)
                (if xs
-                   (condition-case nil
-                       (/ 1 0)
-                     (arith-error (len3 (cdr xs) (1+ n))))
+                   (condition-case k
+                       (/ 1 (logand n 1))
+                     (arith-error (len3 (cdr xs) (1+ n)))
+                     (:success (len3 (cdr xs) (+ n k))))
                  n)))
       (should (equal (len nil 0) 0))
       (should (equal (len2 nil 0) 0))
-- 
cgit v1.2.3