[elpa] externals/compat 6254608c2e 1/4: compat-macs: Improve error checking

[ELPA Syncer]

branch: externals/compat
commit 6254608c2e2da008deab6aabf69b23e66fb52433
Author: Daniel Mendler <mail@daniel-mendler.de>
Commit: Daniel Mendler <mail@daniel-mendler.de>

    compat-macs: Improve error checking
---
 compat-29.el    |  2 +-
 compat-macs.el  | 67 +++++++++++++++++++++++++++++++--------------------------
 compat-tests.el | 10 ++++++---
 3 files changed, 44 insertions(+), 35 deletions(-)

diff --git a/compat-29.el b/compat-29.el
index 495ede7e90..ed9e3f936c 100644
--- a/compat-29.el
+++ b/compat-29.el
@@ -171,7 +171,7 @@ This function does not move point.  Also see 
`line-end-position'."
 
 ;;;; Defined in subr.el
 
-(defun readablep (object)
+(compat-defun readablep (object)
   "Say whether OBJECT has a readable syntax.
 This means that OBJECT can be printed out and then read back
 again by the Lisp reader.  This function returns nil if OBJECT is
diff --git a/compat-macs.el b/compat-macs.el
index addef5ecd1..ca5c800214 100644
--- a/compat-macs.el
+++ b/compat-macs.el
@@ -53,25 +53,28 @@ If this is not documented on yourself system, you can check 
\
       (fill-region (point-min) (point-max)))
     (buffer-string)))
 
-(defun compat--check-attributes (attrs allowed)
-  "Check ATTRS for ALLOWED keys and return rest."
+(defun compat--check-attributes (attrs preds)
+  "Check ATTRS given PREDS predicate plist and return rest."
   (while (keywordp (car attrs))
-    (unless (memq (car attrs) allowed)
-      (error "Invalid attribute %s" (car attrs)))
     (unless (cdr attrs)
       (error "Odd number of element in attribute list"))
+    (let ((pred (plist-get preds (car attrs))))
+      (unless (and pred (or (eq pred t) (funcall pred (cadr attrs))))
+        (error "Invalid attribute %s" (car attrs))))
     (setq attrs (cddr attrs)))
   attrs)
 
-(defun compat--guard (attrs args fun)
+(defun compat--guard (attrs preds fun)
   "Guard compatibility definition generation.
-The version constraints specified by ATTRS are checked.
-ARGS is a list of keywords which are looked up and passed to FUN."
+The version constraints specified by ATTRS are checked.  PREDS is
+a plist of predicates for arguments which are passed to FUN."
   (declare (indent 2))
-  (let* ((body (compat--check-attributes attrs `(,@args :when :feature)))
+  (let* ((body (compat--check-attributes
+                attrs `(,@preds :when t :feature symbolp)))
          (feature (plist-get attrs :feature))
          (attrs `(:body ,body ,@attrs))
-         (when (plist-get attrs :when)))
+         (when (plist-get attrs :when))
+         args)
     ;; Require feature at compile time
     (when feature
       (when (eq feature 'subr-x)
@@ -83,7 +86,10 @@ ARGS is a list of keywords which are looked up and passed to 
FUN."
             ;; The current Emacs must be older than the current declared Compat
             ;; version, see `compat-declare-version'.
             (version< emacs-version compat--version))
-      (setq body (apply fun (mapcar (lambda (x) (plist-get attrs x)) args)))
+      (while preds
+        (push (plist-get attrs (car preds)) args)
+        (setq preds (cddr preds)))
+      (setq body (apply fun (nreverse args)))
       (when body
         (if feature
             `(with-eval-after-load ',feature ,@body)
@@ -92,7 +98,9 @@ ARGS is a list of keywords which are looked up and passed to 
FUN."
 (defun compat--guard-defun (type name arglist docstring rest)
   "Define function NAME of TYPE with ARGLIST and DOCSTRING.
 REST are attributes and the function BODY."
-  (compat--guard rest '(:explicit :obsolete :body)
+  (compat--guard rest `(:explicit booleanp
+                        :obsolete ,(lambda (x) (or (booleanp x) (stringp x)))
+                        :body t)
     (lambda (explicit obsolete body)
       ;; Remove unsupported declares.  It might be possible to set these
       ;; properties otherwise.  That should be looked into and implemented
@@ -142,7 +150,7 @@ definition is generated.
   part of the :when expression."
   (declare (debug ([&rest keywordp sexp] def-body))
            (indent 1))
-  (compat--guard rest '(:body)
+  (compat--guard rest '(:body t)
     (lambda (body)
       (if (eq cond t)
           body
@@ -153,11 +161,11 @@ definition is generated.
 ATTRS is a plist of attributes, which specify the conditions
 under which the definition is generated.
 
-- :obsolete :: Mark the alias as obsolete if non-nil.
+- :obsolete :: Mark the alias as obsolete if t.
 
 - :feature and :when :: See `compat-guard'."
   (declare (debug (name symbolp [&rest keywordp sexp])))
-  (compat--guard attrs '(:obsolete)
+  (compat--guard attrs '(:obsolete booleanp)
     (lambda (obsolete)
       ;; The fboundp check is performed at runtime to make sure that we never
       ;; redefine an existing definition if Compat is loaded on a newer Emacs
@@ -181,7 +189,7 @@ specify the conditions under which the definition is 
generated.
   functions which changed their calling convention or their
   behavior.
 
-- :obsolete :: Mark the function as obsolete if non-nil, can be a
+- :obsolete :: Mark the function as obsolete if t, can be a
   string describing the obsoletion.
 
 - :feature and :when :: See `compat-guard'."
@@ -206,20 +214,23 @@ The variable must be documented in DOCSTRING.  ATTRS is a 
plist
 of attributes, which specify the conditions under which the
 definition is generated.
 
-- :constant :: Mark the variable as constant if non-nil.
+- :constant :: Mark the variable as constant if t.
 
-- :local :: Make the variable permanently local if the value is
-  `permanent'.  For other non-nil values make the variable
-  buffer-local.
+- :local :: Make the variable buffer-local if t.  If the value is
+  `permanent' make the variable additionally permanently local.
 
-- :obsolete :: Mark the variable as obsolete if non-nil, can be a
+- :obsolete :: Mark the variable as obsolete if t, can be a
   string describing the obsoletion.
 
 - :feature and :when :: See `compat-guard'."
   (declare (debug (name form stringp [&rest keywordp sexp]))
            (doc-string 3) (indent 2))
-  (compat--guard attrs '(:local :constant :obsolete)
-    (lambda (local constant obsolete)
+  (compat--guard attrs `(:constant booleanp
+                         :local ,(lambda (x) (memq x '(nil t permanent)))
+                         :obsolete ,(lambda (x) (or (booleanp x) (stringp x))))
+    (lambda (constant local obsolete)
+      (when (and constant local)
+        (error ":constant and :local cannot be specified together"))
       ;; The boundp check is performed at runtime to make sure that we never
       ;; redefine an existing definition if Compat is loaded on a newer Emacs
       ;; version.
@@ -230,15 +241,9 @@ definition is generated.
           ,@(when obsolete
               `((make-obsolete-variable
                  ',name ,(if (stringp obsolete) obsolete "No substitute")
-                 ,compat--version)))
-          ,@(cond
-             ((eq local 'permanent)
-              `((put ',name 'permanent-local t)))
-             ((eq local t)
-              `((make-variable-buffer-local ',name)))
-             ((not local)
-              nil)
-             (t (error "Invalid value for :local"))))))))
+                 ,compat--version))))
+        ,@(and local `((make-variable-buffer-local ',name)))
+        ,@(and (eq local 'permanent) `((put ',name 'permanent-local t)))))))
 
 (provide 'compat-macs)
 ;;; compat-macs.el ends here
diff --git a/compat-tests.el b/compat-tests.el
index e98d1fc94a..bb22dbc0ad 100644
--- a/compat-tests.el
+++ b/compat-tests.el
@@ -2811,16 +2811,20 @@
 
 (ert-deftest major-mode-suspend ()
   (with-temp-buffer
+    (should (local-variable-if-set-p 'major-mode--suspended))
+    (should (get 'major-mode--suspended 'permanent-local))
     (text-mode)
     (should sentence-end-double-space)
     (setq-local sentence-end-double-space nil)
     (major-mode-suspend)
-    (should-not line-spacing)
+    (should-equal major-mode--suspended #'text-mode)
+    (should sentence-end-double-space)
     (prog-mode)
-    (should-equal major-mode 'prog-mode)
+    (should-equal major-mode #'prog-mode)
     (major-mode-restore)
+    (should-not major-mode--suspended)
     (should sentence-end-double-space)
-    (should-equal major-mode 'text-mode)))
+    (should-equal major-mode #'text-mode)))
 
 (provide 'compat-tests)
 ;;; compat-tests.el ends here