Cleanup some type predicates

Use the new `cl--define-built-in-type` to reduce the manually
maintained list of built-in type predicates.
Also tweak docstrings to use "supertype" rather than "super type",
since it seems to be what we use elsewhere.

* lisp/subr.el (special-form-p): Remove redundant `fboundp` test.
(compiled-function-p): Don'Return nil for subrs that aren't functions.

* lisp/emacs-lisp/cl-macs.el (type predicates): Trim down the list.

* lisp/emacs-lisp/cl-preloaded.el (cl--define-built-in-type):
Register the corresponding predicate if applicable.
(atom, null): Specify the predicate name explicitly.

(cherry picked from commit 8df673907781bce8b080b91b056cb9987587387c)

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index be477b7a6df6b341e4970462e2537b0dcd924dda..129b83c61b90b423f55e530a908f1df714d3686e 100644 (file)
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -3463,45 +3463,12 @@ Of course, we really can't know that for sure, so it's just a heuristic."
 ;; Please keep it in sync with `comp-known-predicates'.
 (pcase-dolist (`(,type . ,pred)
                ;; Mostly kept in alphabetical order.
-               '((array                . arrayp)
-                 (atom         . atom)
-                 (base-char    . characterp)
-                 (bignum       . bignump)
-                 (boolean      . booleanp)
-                 (bool-vector  . bool-vector-p)
-                 (buffer       . bufferp)
-                 (byte-code-function . byte-code-function-p)
-                 (character    . natnump)
-                 (char-table   . char-table-p)
-                 (command      . commandp)
-                 (compiled-function . compiled-function-p)
-                 (hash-table   . hash-table-p)
-                 (cons         . consp)
-                 (fixnum       . fixnump)
-                 (float                . floatp)
-                 (frame                . framep)
-                 (function     . functionp)
-                 (integer      . integerp)
-                 (keyword      . keywordp)
-                 (list         . listp)
-                 (marker       . markerp)
-                 (natnum       . natnump)
-                 (number       . numberp)
-                 (null         . null)
-                 (obarray      . obarrayp)
-                 (overlay      . overlayp)
-                 (process      . processp)
-                 (real         . numberp)
-                 (sequence     . sequencep)
-                 (subr         . subrp)
-                 (string       . stringp)
-                 (symbol       . symbolp)
-                 (symbol-with-pos . symbol-with-pos-p)
-                 (vector       . vectorp)
-                 (window       . windowp)
-                 ;; FIXME: Do we really want to consider these types?
-                 (number-or-marker . number-or-marker-p)
-                 (integer-or-marker . integer-or-marker-p)
+               ;; These aren't defined via `cl--define-built-in-type'.
+               '((base-char    . characterp) ;Could be subtype of `fixnum'.
+                 (character    . natnump)    ;Could be subtype of `fixnum'.
+                 (command      . commandp)   ;Subtype of closure & subr.
+                 (natnum       . natnump)    ;Subtype of fixnum & bignum.
+                 (real         . numberp)    ;Not clear where it would fit.
                  ))
   (put type 'cl-deftype-satisfies pred))
 

diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 5743684fa89cb37b08f745491e7478ad42cd660c..515aa99549dfd04efb0b721624dbe0deacf05ef2 100644 (file)
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -308,7 +308,7 @@
                (:copier nil))
   )
 
-(defmacro cl--define-built-in-type (name parents &optional docstring &rest _slots)
+(defmacro cl--define-built-in-type (name parents &optional docstring &rest slots)
   ;; `slots' is currently unused, but we could make it take
   ;; a list of "slot like properties" together with the corresponding
   ;; accessor, and then we could maybe even make `slot-value' work
@@ -317,15 +317,26 @@
   (unless (listp parents) (setq parents (list parents)))
   (unless (or parents (eq name t))
     (error "Missing parents for %S: %S" name parents))
-  `(progn
-     (put ',name 'cl--class
-          (built-in-class--make ',name ,docstring
-                                (mapcar (lambda (type)
-                                          (let ((class (get type 'cl--class)))
-                                            (unless class
-                                              (error "Unknown type: %S" type))
-                                            class))
-                                        ',parents)))))
+  (let ((predicate (intern-soft (format
+                                 (if (string-match "-" (symbol-name name))
+                                     "%s-p" "%sp")
+                                 name))))
+    (unless (fboundp predicate) (setq predicate nil))
+    (while (keywordp (car slots))
+      (let ((kw (pop slots)) (val (pop slots)))
+        (pcase kw
+          (:predicate (setq predicate val))
+          (_ (error "Unknown keyword arg: %S" kw)))))
+    `(progn
+       ,(if predicate `(put ',name 'cl-deftype-satisfies #',predicate))
+       (put ',name 'cl--class
+            (built-in-class--make ',name ,docstring
+                                  (mapcar (lambda (type)
+                                            (let ((class (get type 'cl--class)))
+                                              (unless class
+                                                (error "Unknown type: %S" type))
+                                              class))
+                                          ',parents))))))
 
 ;; FIXME: Our type DAG has various quirks:
 ;; - `subr' says it's a `compiled-function' but that's not true
@@ -336,8 +347,9 @@
 ;;   so the DAG of OClosure types is "orthogonal" to the distinction
 ;;   between interpreted and compiled functions.
 
-(cl--define-built-in-type t nil "The type of everything.")
-(cl--define-built-in-type atom t "The type of anything but cons cells.")
+(cl--define-built-in-type t nil "Abstract supertype of everything.")
+(cl--define-built-in-type atom t "Abstract supertype of anything but cons cells."
+                          :predicate atom)
 
 (cl--define-built-in-type tree-sitter-compiled-query atom)
 (cl--define-built-in-type tree-sitter-node atom)
@@ -358,7 +370,7 @@
 (cl--define-built-in-type window-configuration atom)
 (cl--define-built-in-type overlay atom)
 (cl--define-built-in-type number-or-marker atom
-  "Abstract super type of both `number's and `marker's.")
+  "Abstract supertype of both `number's and `marker's.")
 (cl--define-built-in-type symbol atom
   "Type of symbols."
   ;; Example of slots we could document.  It would be desirable to
@@ -373,14 +385,14 @@
 (cl--define-built-in-type obarray atom)
 (cl--define-built-in-type native-comp-unit atom)
 
-(cl--define-built-in-type sequence t "Abstract super type of sequences.")
+(cl--define-built-in-type sequence t "Abstract supertype of sequences.")
 (cl--define-built-in-type list sequence)
-(cl--define-built-in-type array (sequence atom) "Abstract super type of arrays.")
+(cl--define-built-in-type array (sequence atom) "Abstract supertype of arrays.")
 (cl--define-built-in-type number (number-or-marker)
-  "Abstract super type of numbers.")
+  "Abstract supertype of numbers.")
 (cl--define-built-in-type float (number))
 (cl--define-built-in-type integer-or-marker (number-or-marker)
-  "Abstract super type of both `integer's and `marker's.")
+  "Abstract supertype of both `integer's and `marker's.")
 (cl--define-built-in-type integer (number integer-or-marker))
 (cl--define-built-in-type marker (integer-or-marker))
 (cl--define-built-in-type bignum (integer)
@@ -404,13 +416,14 @@ For this build of Emacs it's %dbit."
   "Type of special arrays that are indexed by characters.")
 (cl--define-built-in-type string (array))
 (cl--define-built-in-type null (boolean list) ;FIXME: `atom' comes before `list'?
-  "Type of the nil value.")
+  "Type of the nil value."
+  :predicate null)
 (cl--define-built-in-type cons (list)
   "Type of cons cells."
   ;; Example of slots we could document.
   (car car) (cdr cdr))
 (cl--define-built-in-type function (atom)
-  "Abstract super type of function values.")
+  "Abstract supertype of function values.")
 (cl--define-built-in-type compiled-function (function)
   "Abstract type of functions that have been compiled.")
 (cl--define-built-in-type byte-code-function (compiled-function)

diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
index 977d5735171d5e507abe9feaf21035ac7895c081..4da8e61aaa7fda3f01179ecc874532fb4eebf056 100644 (file)
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -437,7 +437,7 @@ This has 2 uses:
 - For compiled code, this is used as a marker which cconv uses to check that
   immutable fields are indeed not mutated."
   (if (byte-code-function-p oclosure)
-      ;; Actually, this should never happen since the `cconv.el' should have
+      ;; Actually, this should never happen since `cconv.el' should have
       ;; optimized away the call to this function.
       oclosure
     ;; For byte-coded functions, we store the type as a symbol in the docstring

diff --git a/lisp/subr.el b/lisp/subr.el
index 66c7a929a8a9c81683374ace283f0073d69bdd83..dd149210fd0e84e3d6660c1581ee0d3ec6933645 100644 (file)
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -4498,8 +4498,7 @@ Otherwise, return nil."
 (defun special-form-p (object)
   "Non-nil if and only if OBJECT is a special form."
   (declare (side-effect-free error-free))
-  (if (and (symbolp object) (fboundp object))
-      (setq object (indirect-function object)))
+  (if (symbolp object) (setq object (indirect-function object)))
   (and (subrp object) (eq (cdr (subr-arity object)) 'unevalled)))
 
 (defun plistp (object)
@@ -4521,7 +4520,8 @@ Otherwise, return nil."
 Does not distinguish between functions implemented in machine code
 or byte-code."
   (declare (side-effect-free error-free))
-  (or (subrp object) (byte-code-function-p object)))
+  (or (and (subrp object) (not (eq 'unevalled (cdr (subr-arity object)))))
+      (byte-code-function-p object)))
 
 (defun field-at-pos (pos)
   "Return the field at position POS, taking stickiness etc into account."