bug#72212: 31.0.50; API for condition objects

[Stefan Monnier via "Bug reports for GNU Emacs, the Swiss army knife of text editors" <bug-gnu-emacs@gnu.org>]

[-- Attachment #1: Type: text/plain, Size: 1261 bytes --]

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



[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: condition.patch --]
[-- Type: text/x-diff, Size: 20409 bytes --]

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