Provide backtrace for byte-ops aref and aset

Produce synthetic backtrace entries for `aref` and `aset` byte-ops
when the index is non-fixnum, or is out of range for vector or record
arguments (bug#64613).

* src/bytecode.c (exec_byte_code): Detect type and range errors
in-line for aref and aset.
* src/data.c (syms_of_data): Declare symbols Qaref and Qaset.
* test/lisp/emacs-lisp/bytecomp-tests.el
(bytecomp-tests--byte-op-error-cases): Add test cases.

diff --git a/src/bytecode.c b/src/bytecode.c
index 2eb53b0428a608653c647e71bf1e56930aa4f53a..c53ef678edd56db94a1c52c748205e79efb0bcf8 100644 (file)
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -1115,14 +1115,24 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
          {
            Lisp_Object idxval = POP;
            Lisp_Object arrayval = TOP;
+           if (!FIXNUMP (idxval))
+             {
+               record_in_backtrace (Qaref, &TOP, 2);
+               wrong_type_argument (Qfixnump, idxval);
+             }
            ptrdiff_t size;
-           ptrdiff_t idx;
            if (((VECTORP (arrayval) && (size = ASIZE (arrayval), true))
-                || (RECORDP (arrayval) && (size = PVSIZE (arrayval), true)))
-               && FIXNUMP (idxval)
-               && (idx = XFIXNUM (idxval),
-                   idx >= 0 && idx < size))
-             TOP = AREF (arrayval, idx);
+                || (RECORDP (arrayval) && (size = PVSIZE (arrayval), true))))
+             {
+               ptrdiff_t idx = XFIXNUM (idxval);
+               if (idx >= 0 && idx < size)
+                 TOP = AREF (arrayval, idx);
+               else
+                 {
+                   record_in_backtrace (Qaref, &TOP, 2);
+                   args_out_of_range (arrayval, idxval);
+                 }
+             }
            else
              TOP = Faref (arrayval, idxval);
            NEXT;
@@ -1133,16 +1143,26 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
            Lisp_Object newelt = POP;
            Lisp_Object idxval = POP;
            Lisp_Object arrayval = TOP;
+           if (!FIXNUMP (idxval))
+             {
+               record_in_backtrace (Qaset, &TOP, 3);
+               wrong_type_argument (Qfixnump, idxval);
+             }
            ptrdiff_t size;
-           ptrdiff_t idx;
            if (((VECTORP (arrayval) && (size = ASIZE (arrayval), true))
-                || (RECORDP (arrayval) && (size = PVSIZE (arrayval), true)))
-               && FIXNUMP (idxval)
-               && (idx = XFIXNUM (idxval),
-                   idx >= 0 && idx < size))
+                || (RECORDP (arrayval) && (size = PVSIZE (arrayval), true))))
              {
-               ASET (arrayval, idx, newelt);
-               TOP = newelt;
+               ptrdiff_t idx = XFIXNUM (idxval);
+               if (idx >= 0 && idx < size)
+                 {
+                   ASET (arrayval, idx, newelt);
+                   TOP = newelt;
+                 }
+               else
+                 {
+                   record_in_backtrace (Qaset, &TOP, 3);
+                   args_out_of_range (arrayval, idxval);
+                 }
              }
            else
              TOP = Faset (arrayval, idxval, newelt);

diff --git a/src/data.c b/src/data.c
index 108ed97d1f632e49ac88b9184c157218b0993d57..619ab8fde64fd95d920c207d36bb3fafb360a2f0 100644 (file)
--- a/src/data.c
+++ b/src/data.c
@@ -4116,6 +4116,8 @@ syms_of_data (void)
   DEFSYM (Qelt, "elt");
   DEFSYM (Qsetcar, "setcar");
   DEFSYM (Qsetcdr, "setcdr");
+  DEFSYM (Qaref, "aref");
+  DEFSYM (Qaset, "aset");
 
   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 16c6408c921e02fbbd5af3acb871c3d27d2c12e0..b549ae1fe09ff6a62d76622878b1bf9b92ccf6fc 100644 (file)
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -1953,6 +1953,15 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode python-mode)) \
     ((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))
+    ((aref [2 3 5] p) (wrong-type-argument fixnump p))
+    ((aref #s(a b c) p) (wrong-type-argument fixnump p))
+    ((aref "abc" p) (wrong-type-argument fixnump p))
+    ((aref [2 3 5] 3) (args-out-of-range [2 3 5] 3))
+    ((aref #s(a b c) 3) (args-out-of-range #s(a b c) 3))
+    ((aset [2 3 5] q 1) (wrong-type-argument fixnump q))
+    ((aset #s(a b c) q 1) (wrong-type-argument fixnump q))
+    ((aset [2 3 5] -1 1) (args-out-of-range [2 3 5] -1))
+    ((aset #s(a b c) -1 1) (args-out-of-range #s(a b c) -1))
     ;; Many more to add
     ))