mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-23 06:00:41 -08:00
Code Issues Projects Releases Wiki Activity

Provide backtrace for byte-ops aref and aset

Browse source 
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.
This commit is contained in:
Mattias Engdegård 2023-07-25 12:16:30 +02:00
parent c50f6538cf
commit 82f5f3b8a2
3 changed files with 46 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

40
src/bytecode.c
View file

@ -1115,14 +1115,24 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
{ {
Lisp_Object idxval = POP; Lisp_Object idxval = POP;
Lisp_Object arrayval = TOP; Lisp_Object arrayval = TOP;
if (!FIXNUMP (idxval))
{
record_in_backtrace (Qaref, &TOP, 2);
wrong_type_argument (Qfixnump, idxval);
}
ptrdiff_t size; ptrdiff_t size;
ptrdiff_t idx;
if (((VECTORP (arrayval) && (size = ASIZE (arrayval), true)) if (((VECTORP (arrayval) && (size = ASIZE (arrayval), true))
|| (RECORDP (arrayval) && (size = PVSIZE (arrayval), true))) || (RECORDP (arrayval) && (size = PVSIZE (arrayval), true))))
&& FIXNUMP (idxval) {
&& (idx = XFIXNUM (idxval), ptrdiff_t idx = XFIXNUM (idxval);
idx >= 0 && idx < size)) if (idx >= 0 && idx < size)
TOP = AREF (arrayval, idx); TOP = AREF (arrayval, idx);
else
{
record_in_backtrace (Qaref, &TOP, 2);
args_out_of_range (arrayval, idxval);
}
}
else else
TOP = Faref (arrayval, idxval); TOP = Faref (arrayval, idxval);
NEXT; NEXT;
@ -1133,17 +1143,27 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
Lisp_Object newelt = POP; Lisp_Object newelt = POP;
Lisp_Object idxval = POP; Lisp_Object idxval = POP;
Lisp_Object arrayval = TOP; Lisp_Object arrayval = TOP;
if (!FIXNUMP (idxval))
{
record_in_backtrace (Qaset, &TOP, 3);
wrong_type_argument (Qfixnump, idxval);
}
ptrdiff_t size; ptrdiff_t size;
ptrdiff_t idx;
if (((VECTORP (arrayval) && (size = ASIZE (arrayval), true)) if (((VECTORP (arrayval) && (size = ASIZE (arrayval), true))
|| (RECORDP (arrayval) && (size = PVSIZE (arrayval), true))) || (RECORDP (arrayval) && (size = PVSIZE (arrayval), true))))
&& FIXNUMP (idxval) {
&& (idx = XFIXNUM (idxval), ptrdiff_t idx = XFIXNUM (idxval);
idx >= 0 && idx < size)) if (idx >= 0 && idx < size)
{ {
ASET (arrayval, idx, newelt); ASET (arrayval, idx, newelt);
TOP = newelt; TOP = newelt;
} }
else
{
record_in_backtrace (Qaset, &TOP, 3);
args_out_of_range (arrayval, idxval);
}
}
else else
TOP = Faset (arrayval, idxval, newelt); TOP = Faset (arrayval, idxval, newelt);
NEXT; NEXT;

2
src/data.c
View file

@ -4116,6 +4116,8 @@ syms_of_data (void)
DEFSYM (Qelt, "elt"); DEFSYM (Qelt, "elt");
DEFSYM (Qsetcar, "setcar"); DEFSYM (Qsetcar, "setcar");
DEFSYM (Qsetcdr, "setcdr"); DEFSYM (Qsetcdr, "setcdr");
DEFSYM (Qaref, "aref");
DEFSYM (Qaset, "aset");
error_tail = pure_cons (Qerror, Qnil); error_tail = pure_cons (Qerror, Qnil);

9
test/lisp/emacs-lisp/bytecomp-tests.el
View file

@ -1953,6 +1953,15 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode python-mode)) \
((setcdr c 5) (wrong-type-argument consp c)) ((setcdr c 5) (wrong-type-argument consp c))
((nth 2 "abcd") (wrong-type-argument listp "abcd")) ((nth 2 "abcd") (wrong-type-argument listp "abcd"))
((elt (x y . z) 2) (wrong-type-argument listp z)) ((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 ;; Many more to add
)) ))