scratch/object-type 41184670fd4 2/3: (primitive-function): New type

[Stefan Monnier]

branch: scratch/object-type
commit 41184670fd4b720350da58f6051212e5cb3ea7a7
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    (primitive-function): New type
    
    The type hierarchy and `cl-type-of` code assumed that `subr-primitive`
    only applies to functions, but since it also accepts special-forms it makes
    it an unsuitable choice since it can't be a subtype of `compiled-function`.
    So, use a new type `primitive-function` instead.
    
    * lisp/subr.el (subr-primitive-p): Fix docstring (bug#69832).
    (primitive-function-p): New function.
    
    * lisp/emacs-lisp/cl-preloaded.el (primitive-function): Rename
    from `subr-primitive` since `subr-primitive-p` means something else.
    
    * src/data.c (Fcl_type_of): Return `primitive-function` instead
    of `subr-primitive` for C functions.
    (syms_of_data): Adjust accordingly.
    
    * test/src/data-tests.el (data-tests--cl-type-of): Remove workaround.
---
 etc/NEWS                        | 4 ++++
 lisp/emacs-lisp/cl-preloaded.el | 2 +-
 lisp/subr.el                    | 9 ++++++++-
 src/data.c                      | 4 ++--
 test/src/data-tests.el          | 4 +---
 5 files changed, 16 insertions(+), 7 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index b522fbd338b..69e61d91b0e 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1652,6 +1652,10 @@ This function is like 'type-of' except that it sometimes 
returns
 a more precise type.  For example, for nil and t it returns 'null'
 and 'boolean' respectively, instead of just 'symbol'.
 
+** New function `primitive-function-p`.
+This is like `subr-primitive-p` except that it returns t only if the
+argument is a function rather than a special-form.
+
 ** Built-in types have now corresponding classes.
 At the Lisp level, this means that things like (cl-find-class 'integer)
 will now return a class object, and at the UI level it means that
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 3e89afea452..d11c97a3e3a 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -436,7 +436,7 @@ For this build of Emacs it's %dbit."
   "Type of the core syntactic elements of the Emacs Lisp language.")
 (cl--define-built-in-type subr-native-elisp (subr compiled-function)
   "Type of functions that have been compiled by the native compiler.")
-(cl--define-built-in-type subr-primitive (subr compiled-function)
+(cl--define-built-in-type primitive-function (subr compiled-function)
   "Type of functions hand written in C.")
 
 (unless (cl--class-parents (cl--find-class 'cl-structure-object))
diff --git a/lisp/subr.el b/lisp/subr.el
index 38a3f6edb34..9e63e409349 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -312,11 +312,18 @@ value of last one, or nil if there are none."
                               cond '(empty-body unless) t)))
 
 (defsubst subr-primitive-p (object)
-  "Return t if OBJECT is a built-in primitive function."
+  "Return t if OBJECT is a built-in primitive written in C."
   (declare (side-effect-free error-free))
   (and (subrp object)
        (not (subr-native-elisp-p object))))
 
+(defsubst primitive-function-p (object)
+  "Return t if OBJECT is a built-in primitive function."
+  (declare (side-effect-free error-free))
+  (and (subrp object)
+       (not (or (subr-native-elisp-p object)
+                (eq (cdr (subr-arity object)) 'unevalled)))))
+
 (defsubst xor (cond1 cond2)
   "Return the boolean exclusive-or of COND1 and COND2.
 If only one of the arguments is non-nil, return it; otherwise
diff --git a/src/data.c b/src/data.c
index a961dd3108c..fe631b27ccc 100644
--- a/src/data.c
+++ b/src/data.c
@@ -248,7 +248,7 @@ a fixed set of types.  */)
         case PVEC_SUBR:
           return XSUBR (object)->max_args == UNEVALLED ? Qspecial_form
                  : SUBR_NATIVE_COMPILEDP (object) ? Qsubr_native_elisp
-                 : Qsubr_primitive;
+                 : Qprimitive_function;
         case PVEC_COMPILED: return Qcompiled_function;
         case PVEC_BUFFER: return Qbuffer;
         case PVEC_CHAR_TABLE: return Qchar_table;
@@ -4245,7 +4245,7 @@ syms_of_data (void)
   DEFSYM (Qwindow, "window");
   DEFSYM (Qsubr, "subr");
   DEFSYM (Qspecial_form, "special-form");
-  DEFSYM (Qsubr_primitive, "subr-primitive");
+  DEFSYM (Qprimitive_function, "primitive-function");
   DEFSYM (Qsubr_native_elisp, "subr-native-elisp");
   DEFSYM (Qcompiled_function, "compiled-function");
   DEFSYM (Qbuffer, "buffer");
diff --git a/test/src/data-tests.el b/test/src/data-tests.el
index 9d76c58224d..daa49e671b5 100644
--- a/test/src/data-tests.el
+++ b/test/src/data-tests.el
@@ -869,9 +869,7 @@ comparing the subr with a much slower Lisp implementation."
                              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))
+                             function))
               (should-not (cl-typep val subtype)))))))))