(cl-type-of): New function to return more precise types (bug#69739)

* src/data.c (Fcl_type_of): New function, extracted from `Ftype_of`.
Make it return more precise types for symbols, integers, and subrs.
(Ftype_of): Use it.
(syms_of_data): Define the corresponding new symbols and defsubr
the new function.

* doc/lispref/objects.texi (Type Predicates): Document it.

* src/comp.c (emit_limple_insn): Use `Fcl_type_of`.

* lisp/emacs-lisp/cl-preloaded.el (subr): Demote it to `atom`.
(subr-native-elisp, subr-primitive): Add `compiled-function` as
parent instead.
(special-form): New type.

* lisp/obsolete/eieio-core.el (cl--generic-struct-tag):
* lisp/emacs-lisp/cl-generic.el (cl--generic-typeof-generalizer):
Use `cl-type-of`.
cl--generic--unreachable-types): Update accordingly.

test/src/data-tests.el (data-tests--cl-type-of): New test.

1 files changed, 37 insertions, 0 deletions

diff --git a/test/src/data-tests.el b/test/src/data-tests.el
index ad3b2071254..9d76c58224d 100644
--- a/test/src/data-tests.el
+++ b/test/src/data-tests.el
@@ -838,4 +838,41 @@ comparing the subr with a much slower Lisp implementation."
     (dolist (sym (list nil t 'xyzzy (make-symbol "")))
       (should (eq sym (bare-symbol (position-symbol sym 0)))))))
 
+(require 'cl-extra)                     ;For `cl--class-children'.
+
+(ert-deftest data-tests--cl-type-of ()
+  ;; Make sure that `cl-type-of' returns the most precise type.
+  ;; Note: This doesn't work for list/vector structs since those types
+  ;; are too difficult/unreliable to detect (so `cl-type-of' only says
+  ;; it's a `cons' or a `vector').
+  (dolist (val (list -2 10 (expt 2 128) nil t 'car
+                     (symbol-function 'car)
+                     (symbol-function 'progn)
+                     (position-symbol 'car 7)))
+    (let* ((type (cl-type-of val))
+           (class (cl-find-class type))
+           (alltypes (cl--class-allparents class))
+           ;; FIXME: Our type DAG is affected by `symbols-with-pos-enabled'.
+           ;; (e.g. `symbolp' returns nil on a sympos if that var is nil).
+           (symbols-with-pos-enabled t))
+      (dolist (parent alltypes)
+        (should (cl-typep val parent))
+        (dolist (subtype (cl--class-children (cl-find-class parent)))
+          (unless (memq subtype alltypes)
+            (unless (memq subtype
+                          ;; FIXME: Some types don't have any associated
+                          ;; predicate,
+                          '( font-spec font-entity font-object
+                             finalizer condvar terminal
+                             native-comp-unit interpreted-function
+                             tree-sitter-compiled-query
+                             tree-sitter-node tree-sitter-parser
+                             ;; `functionp' also matches things of type
+                             ;; `symbol' and `cons'.
+                             ;; FIXME: `subr-primitive-p' also matches
+                             ;; special-forms.
+                             function subr-primitive))
+              (should-not (cl-typep val subtype)))))))))
+
+
 ;;; data-tests.el ends here