master 80b081a0ac7 07/14: startup.el: Use `handler-bind` to implement `--debug-init`

[Stefan Monnier]

branch: master
commit 80b081a0ac72a5a9e459af6c96f5b0226a79894f
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    startup.el: Use `handler-bind` to implement `--debug-init`
    
    This provides a more reliable fix for bug#65267 since we don't
    touch `debug-on-error` nor `debug-ignore-errors` any more.
    
    * lisp/startup.el (startup--debug): New function.
    (startup--load-user-init-file): Use it and `handler-bind` instead of
    let-binding `debug-on-error`.
---
 lisp/startup.el | 221 +++++++++++++++++++++++++-------------------------------
 1 file changed, 97 insertions(+), 124 deletions(-)

diff --git a/lisp/startup.el b/lisp/startup.el
index 1abbb260e30..4040d5d3774 100644
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -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)))
-
-              ;; 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)))
-
-              ;; 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))))
-
-            (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 "\
+  ;; 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))
+
+                   (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 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 "\
 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" ())