From: Mattias Engdegård Date: Fri, 14 Jul 2023 16:05:32 +0000 (+0200) Subject: Provide backtrace for byte-ops car, cdr, setcar, setcdr, nth and elt X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=8acd52bba40982b4f3cadc17fb35dc96143605fb;p=emacs.git 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. --- 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: