master 8acd52bba40 1/2: Provide backtrace for byte-ops car, cdr, setcar, setcdr, nth and elt

[Mattias Engdegård]

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

    Provide backtrace for byte-ops car, cdr, setcar, setcdr, nth and elt
    
    Include calls to these primitives from byte-compiled code in
    backtraces.  For nth and elt, not all errors are covered.
    (Bug#64613)
    
    * src/bytecode.c (exec_byte_code): Add error backtrace records for
    car, cdr, setcar, setcdr, nth and elt.
    * src/data.c (syms_of_data): Add missing defsyms for car, setcar,
    setcdr, nth and elt.
    * test/lisp/emacs-lisp/bytecomp-tests.el
    (bytecomp-tests--error-frame, bytecomp-tests--byte-op-error-cases)
    (bytecomp--byte-op-error-backtrace): New test.
---
 src/bytecode.c                         | 42 ++++++++++++++++++++----
 src/data.c                             |  5 +++
 test/lisp/emacs-lisp/bytecomp-tests.el | 58 ++++++++++++++++++++++++++++++++++
 3 files changed, 99 insertions(+), 6 deletions(-)

diff --git a/src/bytecode.c b/src/bytecode.c
index 4207ff0b71f..2eb53b0428a 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -646,7 +646,10 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
          if (CONSP (TOP))
            TOP = XCAR (TOP);
          else if (!NILP (TOP))
-           wrong_type_argument (Qlistp, TOP);
+           {
+             record_in_backtrace (Qcar, &TOP, 1);
+             wrong_type_argument (Qlistp, TOP);
+           }
          NEXT;
 
        CASE (Beq):
@@ -668,7 +671,10 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
            if (CONSP (TOP))
              TOP = XCDR (TOP);
            else if (!NILP (TOP))
-             wrong_type_argument (Qlistp, TOP);
+             {
+               record_in_backtrace (Qcdr, &TOP, 1);
+               wrong_type_argument (Qlistp, TOP);
+             }
            NEXT;
          }
 
@@ -1032,7 +1038,15 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
              {
                for (EMACS_INT n = XFIXNUM (v1); 0 < n && CONSP (v2); n--)
                  v2 = XCDR (v2);
-               TOP = CAR (v2);
+               if (CONSP (v2))
+                 TOP = XCAR (v2);
+               else if (NILP (v2))
+                 TOP = Qnil;
+               else
+                 {
+                   record_in_backtrace (Qnth, &TOP, 2);
+                   wrong_type_argument (Qlistp, v2);
+                 }
              }
            else
              TOP = Fnth (v1, v2);
@@ -1552,7 +1566,15 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
                /* Like the fast case for Bnth, but with args reversed.  */
                for (EMACS_INT n = XFIXNUM (v2); 0 < n && CONSP (v1); n--)
                  v1 = XCDR (v1);
-               TOP = CAR (v1);
+               if (CONSP (v1))
+                 TOP = XCAR (v1);
+               else if (NILP (v1))
+                 TOP = Qnil;
+               else
+                 {
+                   record_in_backtrace (Qelt, &TOP, 2);
+                   wrong_type_argument (Qlistp, v1);
+                 }
              }
            else
              TOP = Felt (v1, v2);
@@ -1581,7 +1603,11 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
          {
            Lisp_Object newval = POP;
            Lisp_Object cell = TOP;
-           CHECK_CONS (cell);
+           if (!CONSP (cell))
+             {
+               record_in_backtrace (Qsetcar, &TOP, 2);
+               wrong_type_argument (Qconsp, cell);
+             }
            CHECK_IMPURE (cell, XCONS (cell));
            XSETCAR (cell, newval);
            TOP = newval;
@@ -1592,7 +1618,11 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
          {
            Lisp_Object newval = POP;
            Lisp_Object cell = TOP;
-           CHECK_CONS (cell);
+           if (!CONSP (cell))
+             {
+               record_in_backtrace (Qsetcdr, &TOP, 2);
+               wrong_type_argument (Qconsp, cell);
+             }
            CHECK_IMPURE (cell, XCONS (cell));
            XSETCDR (cell, newval);
            TOP = newval;
diff --git a/src/data.c b/src/data.c
index 5a31462d8ca..108ed97d1f6 100644
--- a/src/data.c
+++ b/src/data.c
@@ -4110,7 +4110,12 @@ syms_of_data (void)
   DEFSYM (Qunevalled, "unevalled");
   DEFSYM (Qmany, "many");
 
+  DEFSYM (Qcar, "car");
   DEFSYM (Qcdr, "cdr");
+  DEFSYM (Qnth, "nth");
+  DEFSYM (Qelt, "elt");
+  DEFSYM (Qsetcar, "setcar");
+  DEFSYM (Qsetcdr, "setcdr");
 
   error_tail = pure_cons (Qerror, Qnil);
 
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el 
b/test/lisp/emacs-lisp/bytecomp-tests.el
index 278496f5259..9813e9459c8 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -1929,6 +1929,64 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode 
js-mode python-mode)) \
                       "#4=(a #5=(#4# b . #6=(#5# c . #4#)) (#6# d))"
                       ")"))))))
 
+(require 'backtrace)
+
+(defun bytecomp-tests--error-frame (fun args)
+  "Call FUN with ARGS.  Return result or (ERROR . BACKTRACE-FRAME)."
+  (let* ((debugger
+          (lambda (&rest args)
+            ;; Make sure Emacs doesn't think our debugger is buggy.
+            (cl-incf num-nonmacro-input-events)
+            (throw 'bytecomp-tests--backtrace
+                   (cons args (cadr (backtrace-get-frames debugger))))))
+         (debug-on-error t)
+         (backtrace-on-error-noninteractive nil)
+         (debug-on-quit t)
+         (debug-ignored-errors nil))
+    (catch 'bytecomp-tests--backtrace
+      (apply fun args))))
+
+(defconst bytecomp-tests--byte-op-error-cases
+  '(((car a) (wrong-type-argument listp a))
+    ((cdr 3) (wrong-type-argument listp 3))
+    ((setcar 4 b) (wrong-type-argument consp 4))
+    ((setcdr c 5) (wrong-type-argument consp c))
+    ((nth 2 "abcd") (wrong-type-argument listp "abcd"))
+    ((elt (x y . z) 2) (wrong-type-argument listp z))
+    ;; Many more to add
+    ))
+
+(ert-deftest bytecomp--byte-op-error-backtrace ()
+  "Check that signalling byte ops show up in the backtrace."
+  (dolist (case bytecomp-tests--byte-op-error-cases)
+    (ert-info ((prin1-to-string case) :prefix "case: ")
+      (let* ((call (nth 0 case))
+             (expected-error (nth 1 case))
+             (fun-sym (car call))
+             (actuals (cdr call)))
+        ;; Test both calling the function directly, and calling
+        ;; a byte-compiled η-expansion (lambda (ARGS...) (FUN ARGS...))
+        ;; which should turn the function call into a byte-op.
+        (dolist (byte-op '(nil t))
+          (ert-info ((prin1-to-string byte-op) :prefix "byte-op: ")
+            (let* ((fun
+                    (if byte-op
+                        (let* ((nargs (length (cdr call)))
+                               (formals (mapcar (lambda (i)
+                                                  (intern (format "x%d" i)))
+                                                (number-sequence 1 nargs))))
+                          (byte-compile
+                           `(lambda ,formals (,fun-sym ,@formals))))
+                      fun-sym))
+                   (error-frame (bytecomp-tests--error-frame fun actuals)))
+              (should (consp error-frame))
+              (should (equal (car error-frame) (list 'error expected-error)))
+              (let ((frame (cdr error-frame)))
+                (should (equal (type-of frame) 'backtrace-frame))
+                (should (equal (cons (backtrace-frame-fun frame)
+                                     (backtrace-frame-args frame))
+                               call))))))))))
+
 ;; Local Variables:
 ;; no-byte-compile: t
 ;; End: