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

Merge branch 'handler-bind'

Browse source
This commit is contained in:
Stefan Monnier 2024-01-04 18:46:16 -05:00
commit 1081e975c9
20 changed files with 704 additions and 481 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

118
doc/lispref/control.texi
View file

@ -1,6 +1,6 @@
@c -*- mode: texinfo; coding: utf-8 -*-
@c This is part of the GNU Emacs Lisp Reference Manual.
@c Copyright (C) 1990--1995, 1998--1999, 2001--2024 Free Software
@c Copyright (C) 1990--2024 Free Software
@c Foundation, Inc.
@c See the file elisp.texi for copying conditions.
@node Control Structures
@ -2293,6 +2293,122 @@ should be robust if one does occur. Note that this macro uses
@code{condition-case-unless-debug} rather than @code{condition-case}.
@end defmac
Occasionally, we want to catch some errors and record some information
about the conditions in which they occurred, such as the full
backtrace, or the current buffer. This kinds of information is sadly
not available in the handlers of a @code{condition-case} because the
stack is unwound before running that handler, so the handler is run in
the dynamic context of the @code{condition-case} rather than that of
the place where the error was signaled. For those circumstances, you
can use the following form:
@defmac handler-bind handlers body@dots{}
This special form runs @var{body} and if it executes without error,
the value it returns becomes the value of the @code{handler-bind}
form. In this case, the @code{handler-bind} has no effect.
@var{handlers} should be a list of elements of the form
@code{(@var{conditions} @var{handler})} where @var{conditions} is an
error condition name to be handled, or a list of condition names, and
@var{handler} should be a form whose evaluation should return a function.
As with @code{condition-case}, condition names are symbols.
Before running @var{body}, @code{handler-bind} evaluates all the
@var{handler} forms and installs those handlers to be active during
the evaluation of @var{body}. When an error is signaled,
Emacs searches all the active @code{condition-case} and
@code{handler-bind} forms for a handler that
specifies one or more of these condition names. When the innermost
matching handler is one installed by @code{handler-bind}, the
@var{handler} function is called with a single argument holding the
error description.
Contrary to what happens with @code{condition-case}, @var{handler} is
called in the dynamic context where the error happened. This means it
is executed unbinding any variable bindings or running any cleanups of
@code{unwind-protect}, so that all those dynamic bindings are still in
effect. There is one exception: while running the @var{handler}
function, all the error handlers between the code that signaled the
error and the @code{handler-bind} are temporarily suspended, meaning
that when an error is signaled, Emacs will only search the active
@code{condition-case} and @code{handler-bind} forms that are inside
the @var{handler} function or outside of the current
@code{handler-bind}. Note also that lexical variables are not
affected, since they do not have dynamic extent.
Like any normal function, @var{handler} can exit non-locally,
typically via @code{throw}, or it can return normally.
If @var{handler} returns normally, it means the handler
@emph{declined} to handle the error and the search for an error
handler is continued where it left off.
For example, if we wanted to keep a log of all the errors that occur
during the execution of a particular piece of code together with the
buffer that's current when the error is signaled, but without
otherwise affecting the behavior of that code, we can do it with:
@example
@group
(handler-bind
((error
(lambda (err)
(push (cons err (current-buffer)) my-log-of-errors))))
@var{body-forms}@dots{})
@end group
@end example
This will log only those errors that are not caught internally to
@var{body-forms}@dots{}, in other words errors that ``escape'' from
@var{body-forms}@dots{}, and it will not prevent those errors from
being passed on to surrounding @code{condition-case} handlers (or
@code{handler-bind} handlers for that matter) since the above handler
returns normally.
We can also use @code{handler-bind} to replace an error with another,
as in the code below which turns all errors of type @code{user-error}
that occur during the execution of @var{body-forms}@dots{} into plain
@code{error}:
@example
@group
(handler-bind
((user-error
(lambda (err)
(signal 'error (cdr err)))))
@var{body-forms}@dots{})
@end group
@end example
We can get almost the same result with @code{condition-case}:
@example
@group
(condition-case err
(progn @var{body-forms}@dots{})
(user-error (signal 'error (cdr err))))
@end group
@end example
@noindent
but with the difference that when we (re)signal the new error in
@code{handler-bind} the dynamic environment from the original error is
still active, which means for example that if we enter the
debugger at this point, it will show us a complete backtrace including
the point where we signaled the original error:
@example
@group
Debugger entered--Lisp error: (error "Oops")
signal(error ("Oops"))
(closure (t) (err) (signal 'error (cdr err)))((user-error "Oops"))
user-error("Oops")
@dots{}
eval((handler-bind ((user-error (lambda (err) @dots{}
@end group
@end example
@end defmac
@node Error Symbols
@subsubsection Error Symbols and Condition Names
@cindex error symbol

19
doc/lispref/eval.texi
View file

@ -844,11 +844,24 @@ function body forms, as well as explicit calls in Lisp code.
The default value of this variable is 1600. If you set it to a value
less than 100, Lisp will reset it to 100 if the given value is
reached. Entry to the Lisp debugger increases the value, if there is
little room left, to make sure the debugger itself has room to
execute.
reached.
@end defopt
@defopt lisp-eval-depth-reserve
In order to be able to debug infinite recursion errors, when invoking the
Lisp debugger, Emacs increases temporarily the value of
@code{max-lisp-eval-depth}, if there is little room left, to make sure
the debugger itself has room to execute. The same happens when
running the handler of a @code{handler-bind}. @xref{Handling Errors}.
The variable @code{lisp-eval-depth-reserve} bounds the extra depth
that Emacs can add to @code{max-lisp-eval-depth} for those
exceptional circumstances.
The default value of this variable is 200.
@end defopt
@defvar values
The value of this variable is a list of the values returned by all the
expressions that were read, evaluated, and printed from buffers

4
doc/lispref/variables.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Emacs Lisp Reference Manual.
@c Copyright (C) 1990--1995, 1998--2024 Free Software Foundation, Inc.
@c Copyright (C) 1990--2024 Free Software Foundation, Inc.
@c See the file elisp.texi for copying conditions.
@node Variables
@chapter Variables
@ -978,6 +978,7 @@ program is executing, the binding exists.
@cindex lexical binding
@cindex lexical scope
@cindex static scope
@cindex indefinite extent
For historical reasons, there are two dialects of Emacs Lisp,
selected via the @code{lexical-binding} buffer-local variable.
@ -989,6 +990,7 @@ binding can also be accessed from the Lisp debugger.}. It also has
@dfn{indefinite extent}, meaning that under some circumstances the
binding can live on even after the binding construct has finished
executing, by means of objects called @dfn{closures}.
Lexical scoping is also commonly called @dfn{static scoping}.
@cindex dynamic binding
@cindex dynamic scope

12
etc/NEWS
View file

@ -1395,6 +1395,18 @@ This is like 'require', but it checks whether the argument 'feature'
is already loaded, in which case it either signals an error or
forcibly reloads the file that defines the feature.
+++
** New variable 'lisp-eval-depth-reserve'.
It puts a limit to the amount by which Emacs can temporarily increase
'max-lisp-eval-depth' when handling signals.
+++
** New special form 'handler-bind'.
Provides a functionality similar to `condition-case` except it runs the
handler code without unwinding the stack, such that we can record the
backtrace and other dynamic state at the point of the error.
See the Info node "(elisp) Handling Errors".
+++
** New 'pop-up-frames' action alist entry for 'display-buffer'.
This has the same effect as the variable of the same name and takes

39
lisp/emacs-lisp/bytecomp.el
View file

@ -1879,34 +1879,39 @@ It is too wide if it has any lines longer than the largest of
`(bytecomp--displaying-warnings (lambda () ,@body)))
(defun bytecomp--displaying-warnings (body-fn)
(let* ((warning-series-started
(let* ((wrapped-body
(lambda ()
(if byte-compile-debug
(funcall body-fn)
;; Use a `handler-bind' to remember the `byte-compile-form-stack'
;; active at the time the error is signaled, so as to
;; get more precise error locations.
(let ((form-stack nil))
(condition-case error-info
(handler-bind
((error (lambda (_err)
(setq form-stack byte-compile-form-stack))))
(funcall body-fn))
(error (let ((byte-compile-form-stack form-stack))
(byte-compile-report-error error-info))))))))
(warning-series-started
(and (markerp warning-series)
(eq (marker-buffer warning-series)
(get-buffer byte-compile-log-buffer))))
(byte-compile-form-stack byte-compile-form-stack))
(if (or (eq warning-series 'byte-compile-warning-series)
(if (or (eq warning-series #'byte-compile-warning-series)
warning-series-started)
;; warning-series does come from compilation,
;; so don't bind it, but maybe do set it.
(let (tem)
;; Log the file name. Record position of that text.
(setq tem (byte-compile-log-file))
(let ((tem (byte-compile-log-file))) ;; Log the file name.
(unless warning-series-started
(setq warning-series (or tem 'byte-compile-warning-series)))
(if byte-compile-debug
(funcall body-fn)
(condition-case error-info
(funcall body-fn)
(error (byte-compile-report-error error-info)))))
(setq warning-series (or tem #'byte-compile-warning-series)))
(funcall wrapped-body))
;; warning-series does not come from compilation, so bind it.
(let ((warning-series
;; Log the file name. Record position of that text.
(or (byte-compile-log-file) 'byte-compile-warning-series)))
(if byte-compile-debug
(funcall body-fn)
(condition-case error-info
(funcall body-fn)
(error (byte-compile-report-error error-info))))))))
(or (byte-compile-log-file) #'byte-compile-warning-series)))
(funcall wrapped-body)))))
;;;###autoload
(defun byte-force-recompile (directory)

83
lisp/emacs-lisp/debug-early.el
View file

@ -27,14 +27,17 @@
;; This file dumps a backtrace on stderr when an error is thrown. It
;; has no dependencies on any Lisp libraries and is thus used for
;; generating backtraces for bugs in the early parts of bootstrapping.
;; It is also always used in batch model. It was introduced in Emacs
;; It is also always used in batch mode. It was introduced in Emacs
;; 29, before which there was no backtrace available during early
;; bootstrap.
;;; Code:
;; For bootstrap reasons, we cannot use any macros here since they're
;; not defined yet.
(defalias 'debug-early-backtrace
#'(lambda ()
#'(lambda (&optional base)
"Print a trace of Lisp function calls currently active.
The output stream used is the value of `standard-output'.
@ -51,26 +54,39 @@ of the build process."
(require 'cl-print)
(error nil)))
#'cl-prin1
#'prin1)))
#'prin1))
(first t))
(mapbacktrace
#'(lambda (evald func args _flags)
(let ((args args))
(if evald
(if first
;; The first is the debug-early entry point itself.
(setq first nil)
(let ((args args))
(if evald
(progn
(princ " ")
(funcall prin1 func)
(princ "("))
(progn
(princ " ")
(funcall prin1 func)
(princ "("))
(progn
(princ " (")
(setq args (cons func args))))
(if args
(while (progn
(funcall prin1 (car args))
(setq args (cdr args)))
(princ " ")))
(princ ")\n")))))))
(princ " (")
(setq args (cons func args))))
(if args
(while (progn
(funcall prin1 (car args))
(setq args (cdr args)))
(princ " ")))
(princ ")\n"))))
base))))
(defalias 'debug-early
(defalias 'debug--early
#'(lambda (error base)
(princ "\nError: ")
(prin1 (car error)) ; The error symbol.
(princ " ")
(prin1 (cdr error)) ; The error data.
(debug-early-backtrace base)))
(defalias 'debug-early ;Called from C.
#'(lambda (&rest args)
"Print an error message with a backtrace of active Lisp function calls.
The output stream used is the value of `standard-output'.
@ -88,10 +104,31 @@ support the latter, except in batch mode which always uses
\(In versions of Emacs prior to Emacs 29, no backtrace was
available before `debug' was usable.)"
(princ "\nError: ")
(prin1 (car (car (cdr args)))) ; The error symbol.
(princ " ")
(prin1 (cdr (car (cdr args)))) ; The error data.
(debug-early-backtrace)))
(debug--early (car (cdr args)) #'debug-early))) ; The error object.
(defalias 'debug-early--handler ;Called from C.
#'(lambda (err)
(if backtrace-on-error-noninteractive
(debug--early err #'debug-early--handler))))
(defalias 'debug-early--muted ;Called from C.
#'(lambda (err)
(save-current-buffer
(set-buffer (get-buffer-create "*Redisplay-trace*"))
(goto-char (point-max))
(if (bobp) nil
(let ((separator "\n\n\n\n"))
(save-excursion
;; The C code tested `backtrace_yet', instead we
;; keep a max of 10 backtraces.
(if (search-backward separator nil t 10)
(delete-region (point-min) (match-end 0))))
(insert separator)))
(insert "-- Caught at " (current-time-string) "\n")
(let ((standard-output (current-buffer)))
(debug--early err #'debug-early--muted))
(setq delayed-warnings-list
(cons '(error "Error in a redisplay Lisp hook. See buffer *Redisplay-trace*")
delayed-warnings-list)))))
;;; debug-early.el ends here.

139
lisp/emacs-lisp/ert.el
View file

@ -278,14 +278,6 @@ DATA is displayed to the user and should state the reason for skipping."
(when ert--should-execution-observer
(funcall ert--should-execution-observer form-description)))
;; See Bug#24402 for why this exists
(defun ert--should-signal-hook (error-symbol data)
"Stupid hack to stop `condition-case' from catching ert signals.
It should only be stopped when ran from inside `ert--run-test-internal'."
(when (and (not (symbolp debugger)) ; only run on anonymous debugger
(memq error-symbol '(ert-test-failed ert-test-skipped)))
(funcall debugger 'error (cons error-symbol data))))
(defun ert--special-operator-p (thing)
"Return non-nil if THING is a symbol naming a special operator."
(and (symbolp thing)
@ -324,8 +316,7 @@ It should only be stopped when ran from inside `ert--run-test-internal'."
(default-value (gensym "ert-form-evaluation-aborted-")))
`(let* ((,fn (function ,fn-name))
(,args (condition-case err
(let ((signal-hook-function #'ert--should-signal-hook))
(list ,@arg-forms))
(list ,@arg-forms)
(error (progn (setq ,fn #'signal)
(list (car err)
(cdr err)))))))
@ -728,78 +719,68 @@ in front of the value of MESSAGE-FORM."
;; value and test execution should be terminated. Should not
;; return.
(exit-continuation (cl-assert nil))
;; The binding of `debugger' outside of the execution of the test.
next-debugger
;; The binding of `ert-debug-on-error' that is in effect for the
;; execution of the current test. We store it to avoid being
;; affected by any new bindings the test itself may establish. (I
;; don't remember whether this feature is important.)
ert-debug-on-error)
(defun ert--run-test-debugger (info args)
"During a test run, `debugger' is bound to a closure that calls this function.
(defun ert--run-test-debugger (info condition debugfun)
"Error handler used during the test run.
This function records failures and errors and either terminates
the test silently or calls the interactive debugger, as
appropriate.
INFO is the ert--test-execution-info corresponding to this test
run. ARGS are the arguments to `debugger'."
(cl-destructuring-bind (first-debugger-arg &rest more-debugger-args)
args
(cl-ecase first-debugger-arg
((lambda debug t exit nil)
(apply (ert--test-execution-info-next-debugger info) args))
(error
(let* ((condition (car more-debugger-args))
(type (cl-case (car condition)
((quit) 'quit)
((ert-test-skipped) 'skipped)
(otherwise 'failed)))
;; We store the backtrace in the result object for
;; `ert-results-pop-to-backtrace-for-test-at-point'.
;; This means we have to limit `print-level' and
;; `print-length' when printing result objects. That
;; might not be worth while when we can also use
;; `ert-results-rerun-test-at-point-debugging-errors',
;; (i.e., when running interactively) but having the
;; backtrace ready for printing is important for batch
;; use.
;;
;; Grab the frames above the debugger.
(backtrace (cdr (backtrace-get-frames debugger)))
(infos (reverse ert--infos)))
(setf (ert--test-execution-info-result info)
(cl-ecase type
(quit
(make-ert-test-quit :condition condition
:backtrace backtrace
:infos infos))
(skipped
(make-ert-test-skipped :condition condition
:backtrace backtrace
:infos infos))
(failed
(make-ert-test-failed :condition condition
:backtrace backtrace
:infos infos))))
;; Work around Emacs's heuristic (in eval.c) for detecting
;; errors in the debugger.
(cl-incf num-nonmacro-input-events)
;; FIXME: We should probably implement more fine-grained
;; control a la non-t `debug-on-error' here.
(cond
((ert--test-execution-info-ert-debug-on-error info)
(apply (ert--test-execution-info-next-debugger info) args))
(t))
(funcall (ert--test-execution-info-exit-continuation info)))))))
INFO is the `ert--test-execution-info' corresponding to this test run.
ERR is the error object."
(let* ((type (cl-case (car condition)
((quit) 'quit)
((ert-test-skipped) 'skipped)
(otherwise 'failed)))
;; We store the backtrace in the result object for
;; `ert-results-pop-to-backtrace-for-test-at-point'.
;; This means we have to limit `print-level' and
;; `print-length' when printing result objects. That
;; might not be worth while when we can also use
;; `ert-results-rerun-test-at-point-debugging-errors',
;; (i.e., when running interactively) but having the
;; backtrace ready for printing is important for batch
;; use.
;;
;; Grab the frames above ourselves.
(backtrace (cdr (backtrace-get-frames debugfun)))
(infos (reverse ert--infos)))
(setf (ert--test-execution-info-result info)
(cl-ecase type
(quit
(make-ert-test-quit :condition condition
:backtrace backtrace
:infos infos))
(skipped
(make-ert-test-skipped :condition condition
:backtrace backtrace
:infos infos))
(failed
(make-ert-test-failed :condition condition
:backtrace backtrace
:infos infos))))
;; FIXME: We should probably implement more fine-grained
;; control a la non-t `debug-on-error' here.
(cond
((ert--test-execution-info-ert-debug-on-error info)
;; The `debugfun' arg tells `debug' which backtrace frame starts
;; the "entering the debugger" code so it can hide those frames
;; from the backtrace.
(funcall debugger 'error condition :backtrace-base debugfun))
(t))
(funcall (ert--test-execution-info-exit-continuation info))))
(defun ert--run-test-internal (test-execution-info)
"Low-level function to run a test according to TEST-EXECUTION-INFO.
This mainly sets up debugger-related bindings."
(setf (ert--test-execution-info-next-debugger test-execution-info) debugger
(ert--test-execution-info-ert-debug-on-error test-execution-info)
(setf (ert--test-execution-info-ert-debug-on-error test-execution-info)
ert-debug-on-error)
(catch 'ert--pass
;; For now, each test gets its own temp buffer and its own
@ -807,26 +788,14 @@ This mainly sets up debugger-related bindings."
;; too expensive, we can remove it.
(with-temp-buffer
(save-window-excursion
;; FIXME: Use `signal-hook-function' instead of `debugger' to
;; handle ert errors. Once that's done, remove
;; `ert--should-signal-hook'. See Bug#24402 and Bug#11218 for
;; details.
(let ((lexical-binding t)
(debugger (lambda (&rest args)
(ert--run-test-debugger test-execution-info
args)))
(debug-on-error t)
;; Don't infloop if the error being called is erroring
;; out, and we have `debug-on-error' bound to nil inside
;; the test.
(backtrace-on-error-noninteractive nil)
(debug-on-quit t)
;; FIXME: Do we need to store the old binding of this
;; and consider it in `ert--run-test-debugger'?
(debug-ignored-errors nil)
(let ((lexical-binding t) ;;FIXME: Why?
(ert--infos '()))
(funcall (ert-test-body (ert--test-execution-info-test
test-execution-info))))))
(letrec ((debugfun (lambda (err)
(ert--run-test-debugger test-execution-info
err debugfun))))
(handler-bind (((error quit) debugfun))
(funcall (ert-test-body (ert--test-execution-info-test
test-execution-info))))))))
(ert-pass))
(setf (ert--test-execution-info-result test-execution-info)
(make-ert-test-passed))

5
lisp/emacs-lisp/lisp-mode.el
View file

@ -343,7 +343,7 @@ This will generate compile-time constants from BINDINGS."
(lisp-vdefs '("defvar"))
(lisp-kw '("cond" "if" "while" "let" "let*" "progn" "prog1"
"prog2" "lambda" "unwind-protect" "condition-case"
"when" "unless" "with-output-to-string"
"when" "unless" "with-output-to-string" "handler-bind"
"ignore-errors" "dotimes" "dolist" "declare"))
(lisp-errs '("warn" "error" "signal"))
;; Elisp constructs. Now they are update dynamically
@ -376,7 +376,7 @@ This will generate compile-time constants from BINDINGS."
(cl-kw '("block" "break" "case" "ccase" "compiler-let" "ctypecase"
"declaim" "destructuring-bind" "do" "do*"
"ecase" "etypecase" "eval-when" "flet" "flet*"
"go" "handler-case" "handler-bind" "in-package" ;; "inline"
"go" "handler-case" "in-package" ;; "inline"
"labels" "letf" "locally" "loop"
"macrolet" "multiple-value-bind" "multiple-value-prog1"
"proclaim" "prog" "prog*" "progv"
@ -1346,7 +1346,6 @@ Lisp function does not specify a special indentation."
(put 'catch 'lisp-indent-function 1)
(put 'condition-case 'lisp-indent-function 2)
(put 'handler-case 'lisp-indent-function 1) ;CL
(put 'handler-bind 'lisp-indent-function 1) ;CL
(put 'unwind-protect 'lisp-indent-function 1)
(put 'with-output-to-temp-buffer 'lisp-indent-function 1)
(put 'closure 'lisp-indent-function 2)

10
lisp/emacs-lisp/macroexp.el
View file

@ -42,14 +42,8 @@ condition-case handling a signaled error.")
(defmacro macroexp--with-extended-form-stack (expr &rest body)
"Evaluate BODY with EXPR pushed onto `byte-compile-form-stack'."
(declare (indent 1))
;; FIXME: We really should just be using a simple dynamic let-binding here,
;; but these explicit push and pop make the extended stack value visible
;; to error handlers. Remove that need for that!
`(progn
(push ,expr byte-compile-form-stack)
(prog1
(progn ,@body)
(pop byte-compile-form-stack))))
`(let ((byte-compile-form-stack (cons ,expr byte-compile-form-stack)))
,@body))
;; Bound by the top-level `macroexpand-all', and modified to include any
;; macros defined by `defmacro'.

29
lisp/simple.el
View file

@ -2087,6 +2087,9 @@ of the prefix argument for `eval-expression' and
((= num -1) most-positive-fixnum)
(t eval-expression-print-maximum-character)))))
(defun eval-expression--debug (err)
(funcall debugger 'error err :backtrace-base #'eval-expression--debug))
;; We define this, rather than making `eval' interactive,
;; for the sake of completion of names like eval-region, eval-buffer.
(defun eval-expression (exp &optional insert-value no-truncate char-print-limit)
@ -2120,23 +2123,17 @@ this command arranges for all errors to enter the debugger."
(cons (read--expression "Eval: ")
(eval-expression-get-print-arguments current-prefix-arg)))
(let (result)
(let* (result
(runfun
(lambda ()
(setq result
(values--store-value
(eval (let ((lexical-binding t)) (macroexpand-all exp))
t))))))
(if (null eval-expression-debug-on-error)
(setq result
(values--store-value
(eval (let ((lexical-binding t)) (macroexpand-all exp)) t)))
(let ((old-value (make-symbol "t")) new-value)
;; Bind debug-on-error to something unique so that we can
;; detect when evalled code changes it.
(let ((debug-on-error old-value))
(setq result
(values--store-value
(eval (let ((lexical-binding t)) (macroexpand-all exp)) t)))
(setq new-value debug-on-error))
;; If evalled code has changed the value of debug-on-error,
;; propagate that change to the global binding.
(unless (eq old-value new-value)
(setq debug-on-error new-value))))
(funcall runfun)
(handler-bind ((error #'eval-expression--debug))
(funcall runfun)))
(let ((print-length (unless no-truncate eval-expression-print-length))
(print-level (unless no-truncate eval-expression-print-level))

211
lisp/startup.el
View file

@ -393,7 +393,7 @@ If this is nil, Emacs uses `system-name'."
"The email address of the current user.
This defaults to either: the value of EMAIL environment variable; or
user@host, using `user-login-name' and `mail-host-address' (or `system-name')."
:initialize 'custom-initialize-delay
:initialize #'custom-initialize-delay
:set-after '(mail-host-address)
:type 'string
:group 'mail)
@ -492,7 +492,7 @@ DIRS are relative."
(setq tail (cdr tail)))
;;Splice the new section in.
(when tail
(setcdr tail (append (mapcar 'expand-file-name dirs) (cdr tail))))))
(setcdr tail (append (mapcar #'expand-file-name dirs) (cdr tail))))))
;; The default location for XDG-convention Emacs init files.
(defconst startup--xdg-config-default "~/.config/emacs/")
@ -1019,6 +1019,9 @@ If STYLE is nil, display appropriately for the terminal."
(when standard-display-table
(aset standard-display-table char nil)))))))
(defun startup--debug (err)
(funcall debugger 'error err :backtrace-base #'startup--debug))
(defun startup--load-user-init-file
(filename-function &optional alternate-filename-function load-defaults)
"Load a user init-file.
@ -1032,124 +1035,94 @@ is non-nil.
This function sets `user-init-file' to the name of the loaded
init-file, or to a default value if loading is not possible."
(let ((debug-on-error-from-init-file nil)
(debug-on-error-should-be-set nil)
(debug-on-error-initial
(if (eq init-file-debug t)
'startup--witness ;Dummy but recognizable non-nil value.
init-file-debug))
(d-i-e-from-init-file nil)
(d-i-e-initial
;; Use (startup--witness) instead of nil, so we can detect when the
;; init files set `debug-ignored-errors' to nil.
(if init-file-debug '(startup--witness) debug-ignored-errors))
(d-i-e-standard debug-ignored-errors)
;; The init file might contain byte-code with embedded NULs,
;; which can cause problems when read back, so disable nul
;; byte detection. (Bug#52554)
(inhibit-null-byte-detection t))
(let ((debug-on-error debug-on-error-initial)
;; If they specified --debug-init, enter the debugger
;; on any error whatsoever.
(debug-ignored-errors d-i-e-initial))
(condition-case-unless-debug error
(when init-file-user
(let ((init-file-name (funcall filename-function)))
;; The init file might contain byte-code with embedded NULs,
;; which can cause problems when read back, so disable nul
;; byte detection. (Bug#52554)
(let ((inhibit-null-byte-detection t)
(body
(lambda ()
(condition-case-unless-debug error
(when init-file-user
(let ((init-file-name (funcall filename-function)))
;; If `user-init-file' is t, then `load' will store
;; the name of the file that it loads into
;; `user-init-file'.
(setq user-init-file t)
(when init-file-name
(load (if (equal (file-name-extension init-file-name)
"el")
(file-name-sans-extension init-file-name)
init-file-name)
'noerror 'nomessage))
;; If `user-init-file' is t, then `load' will store
;; the name of the file that it loads into
;; `user-init-file'.
(setq user-init-file t)
(when init-file-name
(load (if (equal (file-name-extension init-file-name)
"el")
(file-name-sans-extension init-file-name)
init-file-name)
'noerror 'nomessage))
(when (and (eq user-init-file t) alternate-filename-function)
(let ((alt-file (funcall alternate-filename-function)))
(unless init-file-name
(setq init-file-name alt-file))
(and (equal (file-name-extension alt-file) "el")
(setq alt-file (file-name-sans-extension alt-file)))
(load alt-file 'noerror 'nomessage)))
(when (and (eq user-init-file t) alternate-filename-function)
(let ((alt-file (funcall alternate-filename-function)))
(unless init-file-name
(setq init-file-name alt-file))
(and (equal (file-name-extension alt-file) "el")
(setq alt-file (file-name-sans-extension alt-file)))
(load alt-file 'noerror 'nomessage)))
;; If we did not find the user's init file, set
;; user-init-file conclusively. Don't let it be
;; set from default.el.
(when (eq user-init-file t)
(setq user-init-file init-file-name)))
;; If we did not find the user's init file, set
;; user-init-file conclusively. Don't let it be
;; set from default.el.
(when (eq user-init-file t)
(setq user-init-file init-file-name)))
;; If we loaded a compiled file, set `user-init-file' to
;; the source version if that exists.
(if (equal (file-name-extension user-init-file) "elc")
(let* ((source (file-name-sans-extension user-init-file))
(alt (concat source ".el")))
(setq source (cond ((file-exists-p alt) alt)
((file-exists-p source) source)
(t nil)))
(when source
(when (file-newer-than-file-p source user-init-file)
(message "Warning: %s is newer than %s"
source user-init-file)
(sit-for 1))
(setq user-init-file source)))
;; Else, perhaps the user init file was compiled
(when (and (equal (file-name-extension user-init-file) "eln")
;; The next test is for builds without native
;; compilation support or builds with unexec.
(boundp 'comp-eln-to-el-h))
(if-let (source (gethash (file-name-nondirectory user-init-file)
comp-eln-to-el-h))
;; source exists or the .eln file would not load
(setq user-init-file source)
(message "Warning: unknown source file for init file %S"
user-init-file)
(sit-for 1))))
;; If we loaded a compiled file, set `user-init-file' to
;; the source version if that exists.
(if (equal (file-name-extension user-init-file) "elc")
(let* ((source (file-name-sans-extension user-init-file))
(alt (concat source ".el")))
(setq source (cond ((file-exists-p alt) alt)
((file-exists-p source) source)
(t nil)))
(when source
(when (file-newer-than-file-p source user-init-file)
(message "Warning: %s is newer than %s"
source user-init-file)
(sit-for 1))
(setq user-init-file source)))
;; Else, perhaps the user init file was compiled
(when (and (equal (file-name-extension user-init-file) "eln")
;; The next test is for builds without native
;; compilation support or builds with unexec.
(boundp 'comp-eln-to-el-h))
(if-let (source (gethash (file-name-nondirectory
user-init-file)
comp-eln-to-el-h))
;; source exists or the .eln file would not load
(setq user-init-file source)
(message "Warning: unknown source file for init file %S"
user-init-file)
(sit-for 1))))
(when (and load-defaults
(not inhibit-default-init))
;; Prevent default.el from changing the value of
;; `inhibit-startup-screen'.
(let ((inhibit-startup-screen nil))
(load "default" 'noerror 'nomessage))))
(error
(display-warning
'initialization
(format-message "\
(when (and load-defaults
(not inhibit-default-init))
;; Prevent default.el from changing the value of
;; `inhibit-startup-screen'.
(let ((inhibit-startup-screen nil))
(load "default" 'noerror 'nomessage))))
(error
(display-warning
'initialization
(format-message "\
An error occurred while loading `%s':\n\n%s%s%s\n\n\
To ensure normal operation, you should investigate and remove the
cause of the error in your initialization file. Start Emacs with
the `--debug-init' option to view a complete error backtrace."
user-init-file
(get (car error) 'error-message)
(if (cdr error) ": " "")
(mapconcat (lambda (s) (prin1-to-string s t))
(cdr error) ", "))
:warning)
(setq init-file-had-error t)))
;; If we can tell that the init file altered debug-on-error,
;; arrange to preserve the value that it set up.
(unless (eq debug-ignored-errors d-i-e-initial)
(if (memq 'startup--witness debug-ignored-errors)
;; The init file wants to add errors to the standard
;; value, so we need to emulate that.
(setq d-i-e-from-init-file
(list (append d-i-e-standard
(remq 'startup--witness
debug-ignored-errors))))
;; The init file _replaces_ the standard value.
(setq d-i-e-from-init-file (list debug-ignored-errors))))
(or (eq debug-on-error debug-on-error-initial)
(setq debug-on-error-should-be-set t
debug-on-error-from-init-file debug-on-error)))
(when d-i-e-from-init-file
(setq debug-ignored-errors (car d-i-e-from-init-file)))
(when debug-on-error-should-be-set
(setq debug-on-error debug-on-error-from-init-file))))
user-init-file
(get (car error) 'error-message)
(if (cdr error) ": " "")
(mapconcat (lambda (s) (prin1-to-string s t))
(cdr error) ", "))
:warning)
(setq init-file-had-error t))))))
(if (eq init-file-debug t)
(handler-bind ((error #'startup--debug))
(funcall body))
(funcall body))))
(defvar lisp-directory nil
"Directory where Emacs's own *.el and *.elc Lisp files are installed.")
@ -1445,7 +1418,7 @@ please check its value")
(error
(princ
(if (eq (car error) 'error)
(apply 'concat (cdr error))
(apply #'concat (cdr error))
(if (memq 'file-error (get (car error) 'error-conditions))
(format "%s: %s"
(nth 1 error)
@ -1897,10 +1870,10 @@ Each element in the list should be a list of strings or pairs
(let ((map (make-sparse-keymap)))
(suppress-keymap map)
(set-keymap-parent map button-buffer-map)
(define-key map "\C-?" 'scroll-down-command)
(define-key map [?\S-\ ] 'scroll-down-command)
(define-key map " " 'scroll-up-command)
(define-key map "q" 'exit-splash-screen)
(define-key map "\C-?" #'scroll-down-command)
(define-key map [?\S-\ ] #'scroll-down-command)
(define-key map " " #'scroll-up-command)
(define-key map "q" #'exit-splash-screen)
map)
"Keymap for splash screen buffer.")
@ -2338,7 +2311,7 @@ To quit a partially entered command, type Control-g.\n")
;; If C-h can't be invoked, temporarily disable its
;; binding, so where-is uses alternative bindings.
(let ((map (make-sparse-keymap)))
(define-key map [?\C-h] 'undefined)
(define-key map [?\C-h] #'undefined)
map))
minor-mode-overriding-map-alist)))
@ -2530,8 +2503,8 @@ A fancy display is used on graphic displays, normal otherwise."
(fancy-about-screen)
(normal-splash-screen nil)))
(defalias 'about-emacs 'display-about-screen)
(defalias 'display-splash-screen 'display-startup-screen)
(defalias 'about-emacs #'display-about-screen)
(defalias 'display-splash-screen #'display-startup-screen)
;; This avoids byte-compiler warning in the unexec build.
(declare-function pdumper-stats "pdumper.c" ())

22
lisp/subr.el
View file

@ -7497,6 +7497,28 @@ predicate conditions in CONDITION."
(push buf bufs)))
bufs))
(defmacro handler-bind (handlers &rest body)
"Setup error HANDLERS around execution of BODY.
HANDLERS is a list of (CONDITIONS HANDLER) where
CONDITIONS should be a list of condition names (symbols) or
a single condition name, and HANDLER is a form whose evaluation
returns a function.
When an error is signaled during execution of BODY, if that
error matches CONDITIONS, then the associated HANDLER
function is called with the error object as argument.
HANDLERs can either transfer the control via a non-local exit,
or return normally. If a handler returns normally, the search for an
error handler continues from where it left off."
;; FIXME: Completion support as in `condition-case'?
(declare (indent 1) (debug ((&rest (sexp form)) body)))
(let ((args '()))
(dolist (cond+handler handlers)
(let ((handler (car (cdr cond+handler)))
(conds (car cond+handler)))
(push `',(ensure-list conds) args)
(push handler args)))
`(handler-bind-1 (lambda () ,@body) ,@(nreverse args))))
(defmacro with-memoization (place &rest code)
"Return the value of CODE and stash it in PLACE.
If PLACE's value is non-nil, then don't bother evaluating CODE

295
src/eval.c
View file

@ -57,12 +57,6 @@ Lisp_Object Vrun_hooks;
/* FIXME: We should probably get rid of this! */
Lisp_Object Vsignaling_function;
/* The handler structure which will catch errors in Lisp hooks called
from redisplay. We do not use it for this; we compare it with the
handler which is about to be used in signal_or_quit, and if it
matches, cause a backtrace to be generated. */
static struct handler *redisplay_deep_handler;
/* These would ordinarily be static, but they need to be visible to GDB. */
bool backtrace_p (union specbinding *) EXTERNALLY_VISIBLE;
Lisp_Object *backtrace_args (union specbinding *) EXTERNALLY_VISIBLE;
@ -212,7 +206,6 @@ void
init_eval_once (void)
{
/* Don't forget to update docs (lispref node "Eval"). */
max_lisp_eval_depth = 1600;
Vrun_hooks = Qnil;
pdumper_do_now_and_after_load (init_eval_once_for_pdumper);
}
@ -245,25 +238,31 @@ init_eval (void)
lisp_eval_depth = 0;
/* This is less than the initial value of num_nonmacro_input_events. */
when_entered_debugger = -1;
redisplay_deep_handler = NULL;
}
/* Ensure that *M is at least A + B if possible, or is its maximum
value otherwise. */
static void
max_ensure_room (intmax_t *m, intmax_t a, intmax_t b)
{
intmax_t sum = ckd_add (&sum, a, b) ? INTMAX_MAX : sum;
*m = max (*m, sum);
}
/* Unwind-protect function used by call_debugger. */
static void
restore_stack_limits (Lisp_Object data)
{
integer_to_intmax (data, &max_lisp_eval_depth);
intmax_t old_depth;
integer_to_intmax (data, &old_depth);
lisp_eval_depth_reserve += max_lisp_eval_depth - old_depth;
max_lisp_eval_depth = old_depth;
}
/* Try and ensure that we have at least B dpeth available. */
static void
max_ensure_room (intmax_t b)
{
intmax_t sum = ckd_add (&sum, lisp_eval_depth, b) ? INTMAX_MAX : sum;
intmax_t diff = min (sum - max_lisp_eval_depth, lisp_eval_depth_reserve);
if (diff <= 0)
return;
intmax_t old_depth = max_lisp_eval_depth;
max_lisp_eval_depth += diff;
lisp_eval_depth_reserve -= diff;
/* Restore limits after leaving the debugger. */
record_unwind_protect (restore_stack_limits, make_int (old_depth));
}
/* Call the Lisp debugger, giving it argument ARG. */
@ -274,16 +273,12 @@ call_debugger (Lisp_Object arg)
bool debug_while_redisplaying;
specpdl_ref count = SPECPDL_INDEX ();
Lisp_Object val;
intmax_t old_depth = max_lisp_eval_depth;
/* The previous value of 40 is too small now that the debugger
prints using cl-prin1 instead of prin1. Printing lists nested 8
deep (which is the value of print-level used in the debugger)
currently requires 77 additional frames. See bug#31919. */
max_ensure_room (&max_lisp_eval_depth, lisp_eval_depth, 100);
/* Restore limits after leaving the debugger. */
record_unwind_protect (restore_stack_limits, make_int (old_depth));
max_ensure_room (100);
#ifdef HAVE_WINDOW_SYSTEM
if (display_hourglass_p)
@ -317,6 +312,7 @@ call_debugger (Lisp_Object arg)
/* Interrupting redisplay and resuming it later is not safe under
all circumstances. So, when the debugger returns, abort the
interrupted redisplay by going back to the top-level. */
/* FIXME: Move this to the redisplay code? */
if (debug_while_redisplaying
&& !EQ (Vdebugger, Qdebug_early))
Ftop_level ();
@ -1198,6 +1194,12 @@ usage: (catch TAG BODY...) */)
#define clobbered_eassert(E) verify (sizeof (E) != 0)
void
pop_handler (void)
{
handlerlist = handlerlist->next;
}
/* Set up a catch, then call C function FUNC on argument ARG.
FUNC should return a Lisp_Object.
This is how catches are done from within C code. */
@ -1361,6 +1363,49 @@ usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
return internal_lisp_condition_case (var, bodyform, handlers);
}
void
push_handler_bind (Lisp_Object conditions, Lisp_Object handler, int skip)
{
if (!CONSP (conditions))
conditions = Fcons (conditions, Qnil);
struct handler *c = push_handler (conditions, HANDLER_BIND);
c->val = handler;
c->bytecode_dest = skip;
}
DEFUN ("handler-bind-1", Fhandler_bind_1, Shandler_bind_1, 1, MANY, 0,
doc: /* Setup error handlers around execution of BODYFUN.
BODYFUN be a function and it is called with no arguments.
CONDITIONS should be a list of condition names (symbols).
When an error is signaled during executon of BODYFUN, if that
error matches one of CONDITIONS, then the associated HANDLER is
called with the error as argument.
HANDLER should either transfer the control via a non-local exit,
or return normally.
If it returns normally, the search for an error handler continues
from where it left off.
usage: (handler-bind BODYFUN [CONDITIONS HANDLER]...) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
eassert (nargs >= 1);
Lisp_Object bodyfun = args[0];
int count = 0;
if (nargs % 2 == 0)
error ("Trailing CONDITIONS withount HANDLER in `handler-bind`");
for (ptrdiff_t i = nargs - 2; i > 0; i -= 2)
{
Lisp_Object conditions = args[i], handler = args[i + 1];
if (NILP (conditions))
continue;
push_handler_bind (conditions, handler, count++);
}
Lisp_Object ret = call0 (bodyfun);
for (; count > 0; count--)
pop_handler ();
return ret;
}
/* Like Fcondition_case, but the args are separate
rather than passed in a list. Used by Fbyte_code. */
@ -1559,16 +1604,12 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *),
ptrdiff_t nargs,
Lisp_Object *args))
{
struct handler *old_deep = redisplay_deep_handler;
struct handler *c = push_handler (handlers, CONDITION_CASE);
if (redisplaying_p)
redisplay_deep_handler = c;
if (sys_setjmp (c->jmp))
{
Lisp_Object val = handlerlist->val;
clobbered_eassert (handlerlist == c);
handlerlist = handlerlist->next;
redisplay_deep_handler = old_deep;
return hfun (val, nargs, args);
}
else
@ -1576,7 +1617,6 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *),
Lisp_Object val = bfun (nargs, args);
eassert (handlerlist == c);
handlerlist = c->next;
redisplay_deep_handler = old_deep;
return val;
}
}
@ -1654,8 +1694,7 @@ push_handler_nosignal (Lisp_Object tag_ch_val, enum handlertype handlertype)
static Lisp_Object signal_or_quit (Lisp_Object, Lisp_Object, bool);
static Lisp_Object find_handler_clause (Lisp_Object, Lisp_Object);
static bool maybe_call_debugger (Lisp_Object conditions, Lisp_Object sig,
Lisp_Object data);
static bool maybe_call_debugger (Lisp_Object conditions, Lisp_Object error);
static void
process_quit_flag (void)
@ -1715,28 +1754,29 @@ quit (void)
return signal_or_quit (Qquit, Qnil, true);
}
/* Has an error in redisplay giving rise to a backtrace occurred as
yet in the current command? This gets reset in the command
loop. */
bool backtrace_yet = false;
/* Signal an error, or quit. ERROR_SYMBOL and DATA are as with Fsignal.
If KEYBOARD_QUIT, this is a quit; ERROR_SYMBOL should be
Qquit and DATA should be Qnil, and this function may return.
If CONTINUABLE, the caller allows this function to return
(presumably after calling the debugger);
Otherwise this function is like Fsignal and does not return. */
static Lisp_Object
signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool continuable)
{
/* When memory is full, ERROR-SYMBOL is nil,
and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
That is a special case--don't do this in other situations. */
bool oom = NILP (error_symbol);
Lisp_Object error /* The error object. */
= oom ? data
: (!SYMBOLP (error_symbol) && NILP (data)) ? error_symbol
: Fcons (error_symbol, data);
Lisp_Object conditions;
Lisp_Object string;
Lisp_Object real_error_symbol
= (NILP (error_symbol) ? Fcar (data) : error_symbol);
= CONSP (error) ? XCAR (error) : error_symbol;
Lisp_Object clause = Qnil;
struct handler *h;
int skip;
if (gc_in_progress || waiting_for_input)
emacs_abort ();
@ -1751,15 +1791,15 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
/* This hook is used by edebug. */
if (! NILP (Vsignal_hook_function)
&& ! NILP (error_symbol)
/* Don't try to call a lisp function if we've already overflowed
the specpdl stack. */
&& specpdl_ptr < specpdl_end)
&& !oom)
{
/* Edebug takes care of restoring these variables when it exits. */
max_ensure_room (&max_lisp_eval_depth, lisp_eval_depth, 20);
specpdl_ref count = SPECPDL_INDEX ();
max_ensure_room (20);
/* FIXME: 'handler-bind' makes `signal-hook-function' obsolete? */
/* FIXME: Here we still "split" the error object
into its error-symbol and its error-data? */
call2 (Vsignal_hook_function, error_symbol, data);
unbind_to (count, Qnil);
}
conditions = Fget (real_error_symbol, Qerror_conditions);
@ -1769,7 +1809,7 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
too. Don't do this when ERROR_SYMBOL is nil, because that
is a memory-full error. */
Vsignaling_function = Qnil;
if (!NILP (error_symbol))
if (!oom)
{
union specbinding *pdl = backtrace_next (backtrace_top ());
if (backtrace_p (pdl) && EQ (backtrace_function (pdl), Qerror))
@ -1778,16 +1818,42 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
Vsignaling_function = backtrace_function (pdl);
}
for (h = handlerlist; h; h = h->next)
for (skip = 0, h = handlerlist; h; skip++, h = h->next)
{
if (h->type == CATCHER_ALL)
switch (h->type)
{
case CATCHER_ALL:
clause = Qt;
break;
}
if (h->type != CONDITION_CASE)
continue;
clause = find_handler_clause (h->tag_or_ch, conditions);
case CATCHER:
continue;
case CONDITION_CASE:
clause = find_handler_clause (h->tag_or_ch, conditions);
break;
case HANDLER_BIND:
{
if (!NILP (find_handler_clause (h->tag_or_ch, conditions)))
{
specpdl_ref count = SPECPDL_INDEX ();
max_ensure_room (20);
push_handler (make_fixnum (skip + h->bytecode_dest),
SKIP_CONDITIONS);
call1 (h->val, error);
unbind_to (count, Qnil);
pop_handler ();
}
continue;
}
case SKIP_CONDITIONS:
{
int toskip = XFIXNUM (h->tag_or_ch);
while (toskip-- >= 0)
h = h->next;
continue;
}
default:
abort ();
}
if (!NILP (clause))
break;
}
@ -1795,7 +1861,7 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
bool debugger_called = false;
if (/* Don't run the debugger for a memory-full error.
(There is no room in memory to do that!) */
!NILP (error_symbol)
!oom
&& (!NILP (Vdebug_on_signal)
/* If no handler is present now, try to run the debugger. */
|| NILP (clause)
@ -1804,85 +1870,25 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
|| (CONSP (clause) && !NILP (Fmemq (Qdebug, clause)))
/* Special handler that means "print a message and run debugger
if requested". */
|| EQ (h->tag_or_ch, Qerror)))
|| EQ (clause, Qerror)))
{
debugger_called
= maybe_call_debugger (conditions, error_symbol, data);
= maybe_call_debugger (conditions, error);
/* We can't return values to code which signaled an error, but we
can continue code which has signaled a quit. */
if (keyboard_quit && debugger_called && EQ (real_error_symbol, Qquit))
if (continuable && debugger_called)
return Qnil;
}
/* If we're in batch mode, print a backtrace unconditionally to help
with debugging. Make sure to use `debug-early' unconditionally
to not interfere with ERT or other packages that install custom
debuggers. */
if (!debugger_called && !NILP (error_symbol)
&& (NILP (clause) || EQ (h->tag_or_ch, Qerror))
&& noninteractive && backtrace_on_error_noninteractive
&& NILP (Vinhibit_debugger)
&& !NILP (Ffboundp (Qdebug_early)))
{
max_ensure_room (&max_lisp_eval_depth, lisp_eval_depth, 100);
specpdl_ref count = SPECPDL_INDEX ();
specbind (Qdebugger, Qdebug_early);
call_debugger (list2 (Qerror, Fcons (error_symbol, data)));
unbind_to (count, Qnil);
}
/* If an error is signaled during a Lisp hook in redisplay, write a
backtrace into the buffer *Redisplay-trace*. */
if (!debugger_called && !NILP (error_symbol)
&& backtrace_on_redisplay_error
&& (NILP (clause) || h == redisplay_deep_handler)
&& NILP (Vinhibit_debugger)
&& !NILP (Ffboundp (Qdebug_early)))
{
max_ensure_room (&max_lisp_eval_depth, lisp_eval_depth, 100);
specpdl_ref count = SPECPDL_INDEX ();
AUTO_STRING (redisplay_trace, "*Redisplay-trace*");
Lisp_Object redisplay_trace_buffer;
AUTO_STRING (gap, "\n\n\n\n"); /* Separates things in *Redisplay-trace* */
Lisp_Object delayed_warning;
redisplay_trace_buffer = Fget_buffer_create (redisplay_trace, Qnil);
current_buffer = XBUFFER (redisplay_trace_buffer);
if (!backtrace_yet) /* Are we on the first backtrace of the command? */
Ferase_buffer ();
else
Finsert (1, &gap);
backtrace_yet = true;
specbind (Qstandard_output, redisplay_trace_buffer);
specbind (Qdebugger, Qdebug_early);
call_debugger (list2 (Qerror, Fcons (error_symbol, data)));
unbind_to (count, Qnil);
delayed_warning = make_string
("Error in a redisplay Lisp hook. See buffer *Redisplay-trace*", 61);
Vdelayed_warnings_list = Fcons (list2 (Qerror, delayed_warning),
Vdelayed_warnings_list);
}
if (!NILP (clause))
{
Lisp_Object unwind_data
= (NILP (error_symbol) ? data : Fcons (error_symbol, data));
unwind_to_catch (h, NONLOCAL_EXIT_SIGNAL, error);
else if (handlerlist != handlerlist_sentinel)
/* FIXME: This will come right back here if there's no `top-level'
catcher. A better solution would be to abort here, and instead
add a catch-all condition handler so we never come here. */
Fthrow (Qtop_level, Qt);
unwind_to_catch (h, NONLOCAL_EXIT_SIGNAL, unwind_data);
}
else
{
if (handlerlist != handlerlist_sentinel)
/* FIXME: This will come right back here if there's no `top-level'
catcher. A better solution would be to abort here, and instead
add a catch-all condition handler so we never come here. */
Fthrow (Qtop_level, Qt);
}
if (! NILP (error_symbol))
data = Fcons (error_symbol, data);
string = Ferror_message_string (data);
string = Ferror_message_string (error);
fatal ("%s", SDATA (string));
}
@ -2007,14 +2013,15 @@ skip_debugger (Lisp_Object conditions, Lisp_Object data)
return 0;
}
/* Say whether SIGNAL is a `quit' symbol (or inherits from it). */
/* Say whether SIGNAL is a `quit' error (or inherits from it). */
bool
signal_quit_p (Lisp_Object signal)
signal_quit_p (Lisp_Object error)
{
Lisp_Object signal = CONSP (error) ? XCAR (error) : Qnil;
Lisp_Object list;
return EQ (signal, Qquit)
|| (!NILP (Fsymbolp (signal))
|| (SYMBOLP (signal)
&& CONSP (list = Fget (signal, Qerror_conditions))
&& !NILP (Fmemq (Qquit, list)));
}
@ -2025,27 +2032,23 @@ signal_quit_p (Lisp_Object signal)
= SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
This is for memory-full errors only. */
static bool
maybe_call_debugger (Lisp_Object conditions, Lisp_Object sig, Lisp_Object data)
maybe_call_debugger (Lisp_Object conditions, Lisp_Object error)
{
Lisp_Object combined_data;
combined_data = Fcons (sig, data);
if (
/* Don't try to run the debugger with interrupts blocked.
The editing loop would return anyway. */
! input_blocked_p ()
&& NILP (Vinhibit_debugger)
/* Does user want to enter debugger for this kind of error? */
&& (signal_quit_p (sig)
&& (signal_quit_p (error)
? debug_on_quit
: wants_debugger (Vdebug_on_error, conditions))
&& ! skip_debugger (conditions, combined_data)
&& ! skip_debugger (conditions, error)
/* See commentary on definition of
`internal-when-entered-debugger'. */
&& when_entered_debugger < num_nonmacro_input_events)
{
call_debugger (list2 (Qerror, combined_data));
call_debugger (list2 (Qerror, error));
return 1;
}
@ -2058,13 +2061,10 @@ find_handler_clause (Lisp_Object handlers, Lisp_Object conditions)
register Lisp_Object h;
/* t is used by handlers for all conditions, set up by C code. */
if (EQ (handlers, Qt))
return Qt;
/* error is used similarly, but means print an error message
and run the debugger if that is enabled. */
if (EQ (handlers, Qerror))
return Qt;
if (!CONSP (handlers))
return handlers;
for (h = handlers; CONSP (h); h = XCDR (h))
{
@ -4286,6 +4286,13 @@ actual stack overflow in C, which would be fatal for Emacs.
You can safely make it considerably larger than its default value,
if that proves inconveniently small. However, if you increase it too far,
Emacs could overflow the real C stack, and crash. */);
max_lisp_eval_depth = 1600;
DEFVAR_INT ("lisp-eval-depth-reserve", lisp_eval_depth_reserve,
doc: /* Extra depth that can be allocated to handle errors.
This is the max depth that the system will add to `max-lisp-eval-depth'
when calling debuggers or `handler-bind' handlers. */);
lisp_eval_depth_reserve = 200;
DEFVAR_LISP ("quit-flag", Vquit_flag,
doc: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
@ -4322,6 +4329,7 @@ before making `inhibit-quit' nil. */);
DEFSYM (QCdocumentation, ":documentation");
DEFSYM (Qdebug, "debug");
DEFSYM (Qdebug_early, "debug-early");
DEFSYM (Qdebug_early__handler, "debug-early--handler");
DEFVAR_LISP ("inhibit-debugger", Vinhibit_debugger,
doc: /* Non-nil means never enter the debugger.
@ -4494,6 +4502,7 @@ alist of active lexical bindings. */);
defsubr (&Sthrow);
defsubr (&Sunwind_protect);
defsubr (&Scondition_case);
defsubr (&Shandler_bind_1);
DEFSYM (QCsuccess, ":success");
defsubr (&Ssignal);
defsubr (&Scommandp);

18
src/keyboard.c
View file

@ -1026,7 +1026,7 @@ cmd_error_internal (Lisp_Object data, const char *context)
{
/* The immediate context is not interesting for Quits,
since they are asynchronous. */
if (signal_quit_p (XCAR (data)))
if (signal_quit_p (data))
Vsignaling_function = Qnil;
Vquit_flag = Qnil;
@ -1163,7 +1163,18 @@ command_loop_2 (Lisp_Object handlers)
static Lisp_Object
top_level_2 (void)
{
return Feval (Vtop_level, Qnil);
/* If we're in batch mode, print a backtrace unconditionally when
encountering an error, to help with debugging. */
bool setup_handler = noninteractive;
if (setup_handler)
/* FIXME: Should we (re)use `list_of_error` from `xdisp.c`? */
push_handler_bind (list1 (Qerror), Qdebug_early__handler, 0);
Lisp_Object res = Feval (Vtop_level, Qt);
if (setup_handler)
pop_handler ();
return res;
}
static Lisp_Object
@ -1355,7 +1366,6 @@ command_loop_1 (void)
display_malloc_warning ();
Vdeactivate_mark = Qnil;
backtrace_yet = false;
/* Don't ignore mouse movements for more than a single command
loop. (This flag is set in xdisp.c whenever the tool bar is
@ -8609,7 +8619,7 @@ menu_item_eval_property_1 (Lisp_Object arg)
{
/* If we got a quit from within the menu computation,
quit all the way out of it. This takes care of C-] in the debugger. */
if (CONSP (arg) && signal_quit_p (XCAR (arg)))
if (signal_quit_p (arg))
quit ();
return Qnil;

42
src/lisp.h
View file

@ -3543,7 +3543,8 @@ record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs)
}
/* This structure helps implement the `catch/throw' and `condition-case/signal'
control structures. A struct handler contains all the information needed to
control structures as well as 'handler-bind'.
A struct handler contains all the information needed to
restore the state of the interpreter after a non-local jump.
Handler structures are chained together in a doubly linked list; the `next'
@ -3564,9 +3565,41 @@ record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs)
state.
Members are volatile if their values need to survive _longjmp when
a 'struct handler' is a local variable. */
a 'struct handler' is a local variable.
enum handlertype { CATCHER, CONDITION_CASE, CATCHER_ALL };
When running the HANDLER of a 'handler-bind', we need to
temporarily "mute" the CONDITION_CASEs and HANDLERs that are "below"
the current handler, but without hiding any CATCHERs. We do that by
installing a SKIP_CONDITIONS which tells the search to skip the
N next conditions. */
enum handlertype {
CATCHER, /* Entry for 'catch'.
'tag_or_ch' holds the catch's tag.
'val' holds the retval during longjmp. */
CONDITION_CASE, /* Entry for 'condition-case'.
'tag_or_ch' holds the list of conditions.
'val' holds the retval during longjmp. */
CATCHER_ALL, /* Wildcard which catches all 'throw's.
'tag_or_ch' is unused.
'val' holds the retval during longjmp. */
HANDLER_BIND, /* Entry for 'handler-bind'.
'tag_or_ch' holds the list of conditions.
'val' holds the handler function.
The rest of the handler is unused,
except for 'bytecode_dest' that holds
the number of preceding HANDLER_BIND
entries which belong to the same
'handler-bind' (and hence need to
be muted together). */
SKIP_CONDITIONS /* Mask out the N preceding entries.
Used while running the handler of
a HANDLER_BIND to hides the condition
handlers underneath (and including)
the 'handler-bind'.
'tag_or_ch' holds that number, the rest
is unused. */
};
enum nonlocal_exit
{
@ -4496,7 +4529,6 @@ extern Lisp_Object Vrun_hooks;
extern Lisp_Object Vsignaling_function;
extern Lisp_Object inhibit_lisp_code;
extern bool signal_quit_p (Lisp_Object);
extern bool backtrace_yet;
/* To run a normal hook, use the appropriate function from the list below.
The calling convention:
@ -4537,6 +4569,8 @@ extern Lisp_Object internal_condition_case_n
extern Lisp_Object internal_catch_all (Lisp_Object (*) (void *), void *, Lisp_Object (*) (enum nonlocal_exit, Lisp_Object));
extern struct handler *push_handler (Lisp_Object, enum handlertype)
ATTRIBUTE_RETURNS_NONNULL;
extern void pop_handler (void);
extern void push_handler_bind (Lisp_Object, Lisp_Object, int);
extern struct handler *push_handler_nosignal (Lisp_Object, enum handlertype);
extern void specbind (Lisp_Object, Lisp_Object);
extern void record_unwind_protect (void (*) (Lisp_Object), Lisp_Object);

20
src/xdisp.c
View file

@ -3072,10 +3072,24 @@ dsafe__call (bool inhibit_quit, Lisp_Object (f) (ptrdiff_t, Lisp_Object *),
return val;
}
static Lisp_Object
funcall_with_backtraces (ptrdiff_t nargs, Lisp_Object *args)
{
/* If an error is signaled during a Lisp hook in redisplay, write a
backtrace into the buffer *Redisplay-trace*. */
push_handler_bind (list_of_error, Qdebug_early__muted, 0);
Lisp_Object res = Ffuncall (nargs, args);
pop_handler ();
return res;
}
#define SAFE_CALLMANY(inhibit_quit, f, array) \
dsafe__call ((inhibit_quit), f, ARRAYELTS (array), array)
#define dsafe_calln(inhibit_quit, ...) \
SAFE_CALLMANY ((inhibit_quit), Ffuncall, ((Lisp_Object []) {__VA_ARGS__}))
#define dsafe_calln(inhibit_quit, ...) \
SAFE_CALLMANY ((inhibit_quit), \
backtrace_on_redisplay_error \
? funcall_with_backtraces : Ffuncall, \
((Lisp_Object []) {__VA_ARGS__}))
static Lisp_Object
dsafe_call1 (Lisp_Object f, Lisp_Object arg)
@ -37753,6 +37767,8 @@ cursor shapes. */);
DEFSYM (Qthin_space, "thin-space");
DEFSYM (Qzero_width, "zero-width");
DEFSYM (Qdebug_early__muted, "debug-early--muted");
DEFVAR_LISP ("pre-redisplay-function", Vpre_redisplay_function,
doc: /* Function run just before redisplay.
It is called with one argument, which is the set of windows that are to

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

@ -2087,18 +2087,12 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode python-mode)) \
(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))
(letrec ((handler (lambda (e)
(throw 'bytecomp-tests--backtrace
(cons e (cadr (backtrace-get-frames handler)))))))
(catch 'bytecomp-tests--backtrace
(apply fun args))))
(handler-bind ((error handler))
(apply fun args)))))
(defconst bytecomp-tests--byte-op-error-cases
'(((car a) (wrong-type-argument listp a))
@ -2143,7 +2137,7 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode python-mode)) \
`(lambda ,formals (,fun-sym ,@formals)))))))
(error-frame (bytecomp-tests--error-frame fun actuals)))
(should (consp error-frame))
(should (equal (car error-frame) (list 'error expected-error)))
(should (equal (car error-frame) expected-error))
(let ((frame (cdr error-frame)))
(should (equal (type-of frame) 'backtrace-frame))
(should (equal (cons (backtrace-frame-fun frame)

41
test/lisp/emacs-lisp/ert-tests.el
View file

@ -1,6 +1,6 @@
;;; ert-tests.el --- ERT's self-tests -*- lexical-binding: t -*-
;; Copyright (C) 2007-2008, 2010-2024 Free Software Foundation, Inc.
;; Copyright (C) 2007-2024 Free Software Foundation, Inc.
;; Author: Christian Ohler <ohler@gnu.org>
@ -93,16 +93,6 @@ failed or if there was a problem."
'(ert-test-failed "failure message"))
t))))
(ert-deftest ert-test-fail-debug-with-condition-case ()
(let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
(condition-case condition
(progn
(let ((ert-debug-on-error t))
(ert-run-test test))
(cl-assert nil))
((error)
(cl-assert (equal condition '(ert-test-failed "failure message")) t)))))
(ert-deftest ert-test-fail-debug-with-debugger-1 ()
(let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
(let ((debugger (lambda (&rest _args)
@ -146,16 +136,6 @@ failed or if there was a problem."
'(error "Error message"))
t))))
(ert-deftest ert-test-error-debug ()
(let ((test (make-ert-test :body (lambda () (error "Error message")))))
(condition-case condition
(progn
(let ((ert-debug-on-error t))
(ert-run-test test))
(cl-assert nil))
((error)
(cl-assert (equal condition '(error "Error message")) t)))))
;;; Test that `should' works.
(ert-deftest ert-test-should ()
@ -359,14 +339,10 @@ This macro is used to test if macroexpansion in `should' works."
(,(lambda () (let ((_x t)) (should (error "Foo"))))
(error "Foo")))
do
(let ((test (make-ert-test :body body)))
(condition-case actual-condition
(progn
(let ((ert-debug-on-error t))
(ert-run-test test))
(cl-assert nil))
((error)
(should (equal actual-condition expected-condition)))))))
(let* ((test (make-ert-test :body body))
(result (ert-run-test test)))
(should (ert-test-failed-p result))
(should (equal (ert-test-failed-condition result) expected-condition)))))
(defun ert-test--which-file ()
"Dummy function to help test `symbol-file' for tests.")
@ -392,9 +368,9 @@ This macro is used to test if macroexpansion in `should' works."
(result (ert-run-test test)))
(should (ert-test-failed-p result))
(should (memq (backtrace-frame-fun (car (ert-test-failed-backtrace result)))
;;; This is `ert-fail' on nativecomp and `signal'
;;; otherwise. It's not clear whether that's a bug
;;; or not (bug#51308).
;; This is `ert-fail' on nativecomp and `signal'
;; otherwise. It's not clear whether that's a bug
;; or not (bug#51308).
'(ert-fail signal)))))
(ert-deftest ert-test-messages ()
@ -880,7 +856,6 @@ This macro is used to test if macroexpansion in `should' works."
(ert-deftest ert-test-with-demoted-errors ()
"Check that ERT correctly handles `with-demoted-errors'."
:expected-result :failed ;; FIXME! Bug#11218
(should-not (with-demoted-errors "FOO: %S" (error "Foo"))))
(ert-deftest ert-test-fail-inside-should ()

13
test/src/emacs-module-tests.el
View file

@ -114,15 +114,14 @@ changes."
(ert-deftest mod-test-non-local-exit-signal-test ()
(should-error (mod-test-signal))
(let (debugger-args backtrace)
(let (handler-err backtrace)
(should-error
(let ((debugger (lambda (&rest args)
(setq debugger-args args
backtrace (with-output-to-string (backtrace)))
(cl-incf num-nonmacro-input-events)))
(debug-on-signal t))
(handler-bind
((error (lambda (err)
(setq handler-err err
backtrace (with-output-to-string (backtrace))))))
(mod-test-signal)))
(should (equal debugger-args '(error (error . 56))))
(should (equal handler-err '(error . 56)))
(should (string-match-p
(rx bol " mod-test-signal()" eol)
backtrace))))

47
test/src/eval-tests.el
View file

@ -303,4 +303,51 @@ expressions works for identifiers starting with period."
(should (eq 'bar (default-value 'eval-tests/buffer-local-var)))
(should (eq 'bar eval-tests/buffer-local-var)))))
(ert-deftest eval-tests--handler-bind ()
;; A `handler-bind' has no effect if no error is signaled.
(should (equal (catch 'tag
(handler-bind ((error (lambda (_err) (throw 'tag 'wow))))
'noerror))
'noerror))
;; The handler is called from within the dynamic extent where the
;; error is signaled, unlike `condition-case'.
(should (equal (catch 'tag
(handler-bind ((error (lambda (_err) (throw 'tag 'err))))
(list 'inner-catch
(catch 'tag
(user-error "hello")))))
'(inner-catch err)))
;; But inner condition handlers are temporarily muted.
(should (equal (condition-case nil
(handler-bind
((error (lambda (_err)
(signal 'wrong-type-argument nil))))
(list 'result
(condition-case nil
(user-error "hello")
(wrong-type-argument 'inner-handler))))
(wrong-type-argument 'wrong-type-argument))
'wrong-type-argument))
;; Handlers do not apply to the code run within the handlers.
(should (equal (condition-case nil
(handler-bind
((error (lambda (_err)
(signal 'wrong-type-argument nil)))
(wrong-type-argument
(lambda (_err) (user-error "wrong-type-argument"))))
(user-error "hello"))
(wrong-type-argument 'wrong-type-argument)
(error 'plain-error))
'wrong-type-argument)))
(ert-deftest eval-tests--error-id ()
(let* (inner-error
(outer-error
(condition-case err
(handler-bind ((error (lambda (err) (setq inner-error err))))
(car 1))
(error err))))
(should (eq inner-error outer-error))))
;;; eval-tests.el ends here