From: Mattias Engdegård <mattiase@acm.org>
Date: Tue, 25 Jul 2023 10:16:30 +0000 (+0200)
Subject: Provide backtrace for byte-ops aref and aset
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=82f5f3b8a26249db0679bb7dc38c44352e8fbdf5;p=emacs.git

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 2eb53b0428a..c53ef678edd 100644
--- 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 108ed97d1f6..619ab8fde64 100644
--- 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 16c6408c921..b549ae1fe09 100644
--- 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
     ))