procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Provide backtrace for byte-ops car, cdr, setcar, setcdr, nth and elt

Browse source 
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.
This commit is contained in:
Mattias Engdegård 2023-07-14 18:05:32 +02:00
parent 2df086d121
commit 8acd52bba4
3 changed files with 99 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

42
src/bytecode.c
View file

@ -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;

5
src/data.c
View file

@ -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);

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

@ -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: