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.

1 files changed, 32 insertions, 19 deletions

diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 5743684fa89..515aa99549d 100644
--- 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)