Package: emacs;
Reported by: Stefan Monnier <monnier <at> iro.umontreal.ca>
Date: Sat, 20 Jul 2024 15:48:02 UTC
Severity: normal
Found in version 31.0.50
View this message in rfc822 format
From: Stefan Monnier <monnier <at> iro.umontreal.ca> To: 72212 <at> debbugs.gnu.org Subject: bug#72212: 31.0.50; API for condition objects Date: Mon, 19 Aug 2024 09:09:09 -0400
Wow, I did not expect such wild reactions!
Stefan
Stefan Monnier [2024-07-20 11:47:37] wrote:
> Package: Emacs
> Version: 31.0.50
>
>
> I think we should clean up our use of "condition objects", i.e. those
> objects created (internally) by `signal` and then passed back to ELisp
> via the VAR argument of `condition-case`.
>
> I manually re-ordered the patch so that it starts with `subr.el` where
> you can see the new definitions I suggest, and then the rest of the
> patch illustrates how they'd be used.
>
> The patch is not intended to be installed as-is because it changes some
> files which need to preserve backward compatibility with Emacsen without
> the new API.
>
> Also the patch lacks the "main" change which would be to replace the
> (almost 100) occurrences of
>
> (signal (car FOO) (cdr FOO))
>
> with
>
> (condition-resignal FOO)
>
> Beside whether we want to do this or not, there is another question
> about naming: currently we use "condition" in some places (e.g. in
> `condition-case`) but we use "error" in others (e.g. `define-error` and
> `error-message-string`). I chose to use "condition" in the patch below,
> but I don't have a strong opinion on that choice, so I could go with
> "error" if that's what other prefer. If we keep "condition" there's the
> subsidiary question whether we should add aliases for `define-error` and
> `error-message-string`.
>
>
> Stefan
>
>
> diff --git a/lisp/subr.el b/lisp/subr.el
> index 8c20fc5e9d4..cec6747dfcc 100644
> --- a/lisp/subr.el
> +++ b/lisp/subr.el
> @@ -503,6 +503,7 @@ user-error
> the `command-error-function' variable."
> (signal 'user-error (list (apply #'format-message format args))))
>
> +;; FIXME: Arguably, this should be called `define-condition'.
> (defun define-error (name message &optional parent)
> "Define NAME as a new error signal.
> MESSAGE is a string that will be output to the echo area if such an error
> @@ -523,6 +524,50 @@ define-error
> (delete-dups (copy-sequence (cons name conditions))))
> (when message (put name 'error-message message))))
>
> +(defun condition-resignal (condition)
> + "Re-signal the CONDITION.
> +CONDITION should be an object like those constructed by `signal' and
> +captured in the VAR of `condition-case'. This will signal the condition
> +again, like `signal' would do, but preserves the identity of CONDITION
> +instead of constructing a new object."
> + (unless (and (car-safe condition) (symbolp (car condition)))
> + (error "Not a condition object: %S" condition))
> + ;; `signal' happens to have an undocumented calling convention
> + ;; that does just what we need.
> + (signal condition nil))
> +
> +(defalias 'condition-type #'car
> + "Return the symbol which represents the type of CONDITION.
> +
> +(fn CONDITION)")
> +
> +(defalias 'condition-data #'cdr
> + "Return the slots attached to CONDITION, as a list.
> +
> +(fn CONDITION)")
> +
> +(defun condition-hastype-p (condition type)
> + "Return non-nil if CONDITION is of type TYPE (or a subtype of it)."
> + (memq type (get (car condition) 'error-conditions)))
> +
> +(defun condition-type-p (symbol)
> + "Return non-nil if SYMBOL is a condition type."
> + ;; FIXME: Should we also test `error-message'?
> + (get (car condition) 'error-conditions))
> +
> +(defun conditionp (object)
> + "Return non-nil if OBJECT is a condition."
> + (let ((type (car-safe object)))
> + (condition-type-p type)))
> +
> +(defalias 'condition-slot-value #'elt
> + "Access the SLOT of object CONDITION.
> +
> +(fn CONDITION SLOT)")
> +
> +;; FIXME: Make it more flexible!
> +(defalias 'condition-message-string #'error-message-string)
> +
> ;; We put this here instead of in frame.el so that it's defined even on
> ;; systems where frame.el isn't loaded.
> (defun frame-configuration-p (object)
> diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
> index 88167fc7ebd..e6578c8d42f 100644
> --- a/lisp/emacs-lisp/bytecomp.el
> +++ b/lisp/emacs-lisp/bytecomp.el
> @@ -4986,9 +4986,9 @@ byte-compile-condition-case
> (unless (and c (symbolp c))
> (byte-compile-warn-x
> c "`%S' is not a condition name (in condition-case)" c))
> - ;; In reality, the `error-conditions' property is only required
> + ;; In reality, the `error-conditions' property is required only
> ;; for the argument to `signal', not to `condition-case'.
> - ;;(unless (consp (get c 'error-conditions))
> + ;;(unless (condition-type-p c)
> ;; (byte-compile-warn
> ;; "`%s' is not a known condition name (in condition-case)"
> ;; c))
> @@ -5729,6 +5729,8 @@ batch-byte-compile-file
> (condition-case err
> (byte-compile-file file)
> (file-error
> + ;; FIXME: We should either `prin1' the whole ERR object
> + ;; or use `error-message-string' rather than this half-way thing.
> (message (if (cdr err)
> ">>Error occurred processing %s: %s (%s)"
> ">>Error occurred processing %s: %s")
> diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el
> index ec947c1215d..08ecf50e82f 100644
> --- a/lisp/emacs-lisp/debug.el
> +++ b/lisp/emacs-lisp/debug.el
> @@ -563,9 +563,7 @@ debugger-eval-expression
> (condition-case err
> (backtrace-eval exp nframe base)
> (error (setq errored
> - (format "%s: %s"
> - (get (car err) 'error-message)
> - (car (cdr err)))))))))
> + (error-message-string err)))))))
> (if errored
> (progn
> (message "Error: %s" errored)
> diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
> index deebe5109bd..ebc33731b75 100644
> --- a/lisp/emacs-lisp/edebug.el
> +++ b/lisp/emacs-lisp/edebug.el
> @@ -3701,9 +3701,7 @@ edebug-safe-eval
> ;; If there is an error, a string is returned describing the error.
> (condition-case edebug-err
> (edebug-eval expr)
> - (error (edebug-format "%s: %s" ;; could
> - (get (car edebug-err) 'error-message)
> - (car (cdr edebug-err))))))
> + (error (error-message-string edebug-err))))
>
> ;;; Printing
>
> @@ -3711,14 +3709,7 @@ edebug-safe-eval
> (defun edebug-report-error (value)
> ;; Print an error message like command level does.
> ;; This also prints the error name if it has no error-message.
> - (message "%s: %s"
> - (or (get (car value) 'error-message)
> - (format "peculiar error (%s)" (car value)))
> - (mapconcat (lambda (edebug-arg)
> - ;; continuing after an error may
> - ;; complain about edebug-arg. why??
> - (prin1-to-string edebug-arg))
> - (cdr value) ", ")))
> + (message "%s" (error-message-string value)))
>
> ;; Alternatively, we could change the definition of
> ;; edebug-safe-prin1-to-string to only use these if defined.
> @@ -3767,10 +3758,7 @@ edebug-eval-expression
> (condition-case err
> (edebug-eval expr)
> (error
> - (setq errored
> - (format "%s: %s"
> - (get (car err) 'error-message)
> - (car (cdr err)))))))))
> + (setq errored (error-message-string err)))))))
> (result
> (unless errored
> (values--store-value value)
> diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el
> index 27c169cc657..7d26346c6da 100644
> --- a/lisp/emacs-lisp/elint.el
> +++ b/lisp/emacs-lisp/elint.el
> @@ -146,6 +146,8 @@ elint-unknown-builtin-args
> "Those built-ins for which we can't find arguments, if any.")
>
> (defvar elint-extra-errors '(file-locked file-supersession ftp-error)
> + ;; FIXME: We should define these conditions properly to make
> + ;; `elint-extra-errors' obsolete.
> "Errors without `error-message' or `error-conditions' properties.")
>
> (defconst elint-preloaded-skip-re
> @@ -453,6 +456,7 @@ elint-init-form
> (setq elint-env (elint-env-add-macro elint-env (cadr form)
> (cons 'lambda (cddr form)))
> elint-env (elint-env-add-func elint-env (cadr form) (nth 2 form))))
> + ;; FIXME: Recognize `define-error' instead!
> ((and (eq (car form) 'put)
> (= 4 (length form))
> (eq (car-safe (cadr form)) 'quote)
> @@ -877,8 +881,7 @@ elint-check-condition-case-form
> (dolist (err (nthcdr 3 form))
> (setq errlist (car err))
> (mapc (lambda (s)
> - (or (get s 'error-conditions)
> - (get s 'error-message)
> + (or (condition-type-p s)
> (memq s elint-extra-errors)
> (elint-warning
> "Not an error symbol in error handler: %s" s)))
> diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
> index 6a665c8181d..81a7e8ca62e 100644
> --- a/lisp/emacs-lisp/ert.el
> +++ b/lisp/emacs-lisp/ert.el
> @@ -396,12 +396,12 @@ ert--should-error-handle-error
>
> Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES,
> and aborts the current test as failed if it doesn't."
> - (let ((signaled-conditions (get (car condition) 'error-conditions))
> - (handled-conditions (pcase-exhaustive type
> + (let ((handled-conditions (pcase-exhaustive type
> ((pred listp) type)
> ((pred symbolp) (list type)))))
> - (cl-assert signaled-conditions)
> - (unless (cl-intersection signaled-conditions handled-conditions)
> + (cl-assert (conditionp condition))
> + (unless (cl-some (lambda (hc) (condition-hastype-p condition hc))
> + handled-conditions)
> (ert-fail (append
> (funcall form-description-fn)
> (list
> diff --git a/lisp/epa-file.el b/lisp/epa-file.el
> index 90cc91e99a0..7e1224e0c70 100644
> --- a/lisp/epa-file.el
> +++ b/lisp/epa-file.el
> @@ -117,10 +117,10 @@ epa-file--find-file-not-found-function
> (let ((error epa-file-error))
> (save-window-excursion
> (kill-buffer))
> - (if (nth 3 error)
> - (user-error "Wrong passphrase: %s" (nth 3 error))
> + (if (condition-slot-value error 3)
> + (user-error "Wrong passphrase: %s" (condition-slot-value error 3))
> (signal 'file-missing
> - (cons "Opening input file" (cdr error))))))
> + (cons "Opening input file" (condition-data error))))))
>
> (defun epa--wrong-password-p (context)
> "Return whether a wrong password caused the error in CONTEXT."
> @@ -171,23 +171,25 @@ epa-file-insert-file-contents
> ;; signal that as a non-file error
> ;; so that find-file-noselect-1 won't handle it.
> ;; Borrowed from jka-compr.el.
> - (if (and (memq 'file-error (get (car error) 'error-conditions))
> - (equal (cadr error) "Searching for program"))
> + (if (and (condition-hastype-p error 'file-error)
> + (equal (condition-slot-value error 1)
> + "Searching for program"))
> (error "Decryption program `%s' not found"
> - (nth 3 error)))
> + (condition-slot-value error 3)))
> (let ((exists (file-exists-p local-file)))
> (when exists
> (if-let ((wrong-password (epa--wrong-password-p context)))
> ;; Don't display the *error* buffer if we just
> ;; have a wrong password; let the later error
> ;; handler notify the user.
> - (setq error (append error (list wrong-password)))
> + (setf (cdr error) ;FIXME: `condition-data'!
> + (append (cdr error) (list wrong-password)))
> (epa-display-error context))
> ;; When the .gpg file isn't an encrypted file (e.g.,
> ;; it's a keyring.gpg file instead), then gpg will
> ;; say "Unexpected exit" as the error message. In
> ;; that case, just display the bytes.
> - (if (equal (caddr error) "Unexpected; Exit")
> + (if (equal (condition-slot-value error 2) "Unexpected; Exit")
> (setq string (with-temp-buffer
> (insert-file-contents-literally local-file)
> (buffer-string)))
> @@ -197,10 +199,10 @@ epa-file-insert-file-contents
> ;; `find-file-noselect-1'.
> (setq-local epa-file-error error)
> (add-hook 'find-file-not-found-functions
> - 'epa-file--find-file-not-found-function
> + #'epa-file--find-file-not-found-function
> nil t)))
> (signal (if exists 'file-error 'file-missing)
> - (cons "Opening input file" (cdr error))))))
> + (cons "Opening input file" (condition-data error))))))
> (set-buffer buf) ;In case timer/filter changed/killed it (bug#16029)!
> (setq-local epa-file-encrypt-to
> (mapcar #'car (epg-context-result-for
> diff --git a/lisp/jka-compr.el b/lisp/jka-compr.el
> index 0a14f0ab2b7..d0b75d7e3be 100644
> --- a/lisp/jka-compr.el
> +++ b/lisp/jka-compr.el
> @@ -471,22 +471,21 @@ jka-compr-insert-file-contents
> ;; If the file we wanted to uncompress does not exist,
> ;; handle that according to VISIT as `insert-file-contents'
> ;; would, maybe signaling the same error it normally would.
> - (if (and (eq (car error-code) 'file-missing)
> - (eq (nth 3 error-code) local-file))
> + (if (and (condition-hastype-p error-code 'file-missing)
> + (eq (condition-slot-value error-code 3) local-file))
> (if visit
> (setq notfound error-code)
> - (signal 'file-missing
> - (cons "Opening input file"
> - (nthcdr 2 error-code))))
> + (setf (condition-slot-value error-code 1)
> + "Opening input file")
> + (condition-resignal error-code))
> ;; If the uncompression program can't be found,
> ;; signal that as a non-file error
> ;; so that find-file-noselect-1 won't handle it.
> - (if (and (memq 'file-error (get (car error-code)
> - 'error-conditions))
> + (if (and (condition-hastype-p error-code 'file-error)
> (equal (cadr error-code) "Searching for program"))
> (error "Uncompression program `%s' not found"
> - (nth 3 error-code)))
> - (signal (car error-code) (cdr error-code)))))))
> + (nth 3 error-code))
> + (condition-resignal error-code)))))))
>
> (and
> local-copy
> diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el
> index eb3d94475b9..79fabb42a0d 100644
> --- a/lisp/net/sasl.el
> +++ b/lisp/net/sasl.el
> @@ -50,8 +50,7 @@ sasl-mechanism-alist
>
> (defvar sasl-unique-id-function #'sasl-unique-id-function)
>
> -(put 'sasl-error 'error-message "SASL error")
> -(put 'sasl-error 'error-conditions '(sasl-error error))
> +(define-error 'sasl-error "SASL error")
>
> (defun sasl-error (datum)
> (signal 'sasl-error (list datum)))
> diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el
> index de04d58ed18..41f9e254de2 100644
> --- a/lisp/net/soap-client.el
> +++ b/lisp/net/soap-client.el
> @@ -2886,7 +2886,7 @@ soap-decode-array
>
> ;;;; Soap Envelope parsing
>
> -(if (fboundp 'define-error)
> +(if (fboundp 'define-error) ;Emacs-24.4
> (define-error 'soap-error "SOAP error")
> ;; Support Emacs<24.4 that do not have define-error, so
> ;; that soap-client can remain unchanged in GNU ELPA.
> diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el
> index 8781230c00c..4fae2ae73c0 100644
> --- a/lisp/net/tramp-compat.el
> +++ b/lisp/net/tramp-compat.el
> @@ -247,12 +247,12 @@ 'tramp-compat-always
>
> ;; `permission-denied' is introduced in Emacs 29.1.
> (defconst tramp-permission-denied
> - (if (get 'permission-denied 'error-conditions) 'permission-denied 'file-error)
> + (if (condition-type-p 'permission-denied) 'permission-denied 'file-error)
> "The error symbol for the `permission-denied' error.")
>
> (defsubst tramp-compat-permission-denied (vec file)
> "Emit the `permission-denied' error."
> - (if (get 'permission-denied 'error-conditions)
> + (if (condition-type-p 'permission-denied)
> (tramp-error vec tramp-permission-denied file)
> (tramp-error vec tramp-permission-denied "Permission denied: %s" file)))
>
> diff --git a/lisp/net/tramp-message.el b/lisp/net/tramp-message.el
> index 36079c8844c..de6ba65037c 100644
> --- a/lisp/net/tramp-message.el
> +++ b/lisp/net/tramp-message.el
> @@ -380,8 +380,12 @@ tramp-error
> vec-or-proc 1 "%s"
> (error-message-string
> (list signal
> + ;; FIXME: Looks redundant since `error-message-string'
> + ;; already uses the `error-message' property of `signal'!
> (get signal 'error-message)
> (apply #'format-message fmt-string arguments))))
> + ;; FIXME: This doesn't look right: ELisp code should be able to rely on
> + ;; the "shape" of the list based on the type of the signal.
> (signal signal (list (substring-no-properties
> (apply #'format-message fmt-string arguments))))))
>
> diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el
> index 9bf6f9217c8..2e2da3ca103 100644
> --- a/lisp/progmodes/elisp-mode.el
> +++ b/lisp/progmodes/elisp-mode.el
> @@ -703,8 +703,7 @@ elisp-completion-at-point
> ;; specific completion table in more cases.
> (is-ignore-error
> (list t (elisp--completion-local-symbols)
> - :predicate (lambda (sym)
> - (get sym 'error-conditions))))
> + :predicate #'condition-type-p))
> ((elisp--expect-function-p beg)
> (list nil (elisp--completion-local-symbols)
> :predicate
> @@ -778,12 +777,11 @@ elisp-completion-at-point
> (forward-sexp 2)
> (< (point) beg)))))
> (list t (elisp--completion-local-symbols)
> - :predicate (lambda (sym) (get sym 'error-conditions))))
> + :predicate #'condition-type-p))
> ;; `ignore-error' with a list CONDITION parameter.
> ('ignore-error
> (list t (elisp--completion-local-symbols)
> - :predicate (lambda (sym)
> - (get sym 'error-conditions))))
> + :predicate #'condition-type-p))
> ((and (or ?\( 'let 'let*)
> (guard (save-excursion
> (goto-char (1- beg))
> diff --git a/lisp/simple.el b/lisp/simple.el
> index 5961afa20e9..28a6553892d 100644
> --- a/lisp/simple.el
> +++ b/lisp/simple.el
> @@ -3364,7 +3364,7 @@ minibuffer-error-function
> The same as `command-error-default-function' but display error messages
> at the end of the minibuffer using `minibuffer-message' to not obscure
> the minibuffer contents."
> - (if (memq 'minibuffer-quit (get (car data) 'error-conditions))
> + (if (condition-hastype-p data 'minibuffer-quit)
> (ding t)
> (discard-input)
> (ding))
> diff --git a/lisp/startup.el b/lisp/startup.el
> index f18795ae6ac..ee04f5ca3ae 100644
> --- a/lisp/startup.el
> +++ b/lisp/startup.el
> @@ -1124,15 +1124,12 @@ startup--load-user-init-file
> (display-warning
> 'initialization
> (format-message "\
> -An error occurred while loading `%s':\n\n%s%s%s\n\n\
> +An error occurred while loading `%s':\n\n%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) ", "))
> + (error-message-string error))
> :warning)
> (setq init-file-had-error t))))))
>
> @@ -1431,15 +1428,12 @@ command-line
> (princ
> (if (eq (car error) 'error)
> (apply #'concat (cdr error))
> - (if (memq 'file-error (get (car error) 'error-conditions))
> + (if (condition-hastype-p error 'file-error)
> (format "%s: %s"
> (nth 1 error)
> (mapconcat (lambda (obj) (prin1-to-string obj t))
> (cdr (cdr error)) ", "))
> - (format "%s: %s"
> - (get (car error) 'error-message)
> - (mapconcat (lambda (obj) (prin1-to-string obj t))
> - (cdr error) ", "))))
> + (error-message-string error)))
> 'external-debugging-output)
> (terpri 'external-debugging-output)
> (setq initial-window-system nil)
> diff --git a/lisp/type-break.el b/lisp/type-break.el
> index 182f4656b16..bf32c69434e 100644
> --- a/lisp/type-break.el
> +++ b/lisp/type-break.el
> @@ -1025,7 +1025,7 @@ type-break-demo-life
> (setq continue nil)
> (and (get-buffer "*Life*")
> (kill-buffer "*Life*"))
> - (condition-case ()
> + (condition-case err
> (progn
> (life 3)
> ;; wait for user to return
> @@ -1033,7 +1033,7 @@ type-break-demo-life
> (type-break-catch-up-event)
> (kill-buffer "*Life*"))
> (life-extinct
> - (message "%s" (get 'life-extinct 'error-message))
> + (message "%s" (error-message-string err))
> ;; restart demo
> (setq continue t))
> (quit
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.