master 004f2493a54: cl-preloaded.el: Fix the type lattice

[Stefan Monnier]

branch: master
commit 004f2493a542dd0b804a30e97fc612884ca440f4
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    cl-preloaded.el: Fix the type lattice
    
    We generally want types to form not just a DAG but a lattice.
    If objects can be both `keyword` and `symbol-with-pos`, this
    means there should be a more precise type describing this intersection.
    If we ever find the need for such a refinement, we could add
    such a `keyword-with-pos` type, but here I took the simpler
    route of treating `keyword` not as a proper built-in type but
    as a second-class type like `natnum`.
    
    While fixing this problem, also fix the problem we had where
    `functionp` was not quite adequate to characterize objects of type
    `function`, by introducing a new predicate `cl-functionp` for that.
    
    * lisp/emacs-lisp/cl-preloaded.el (cl-functionp): New function.
    (function): Use it.
    (keyword): Don't declare it as a built-in type.
    (user-ptrp): Remove redundant declaration.
    
    * lisp/emacs-lisp/cl-generic.el (cl--generic--unreachable-types):
    Delete constant.
    (cl-generic-generalizers): Remove corresponding test.
    
    * lisp/emacs-lisp/cl-macs.el (cl-deftype-satisfies): Add entry for
    `keyword` type.
    
    * lisp/emacs-lisp/comp.el (comp-known-predicates): Fix type for
    negative result of `characterp`.  Remove duplicate `numberp` entry.
    Fix types for `keywordp` now that `keyword` is not a built-in type any more.
    
    * test/src/data-tests.el (data-tests--cl-type-of): Add a few cases.
    Remove workaround for `function`.
---
 etc/NEWS                        |  8 +++++---
 lisp/emacs-lisp/cl-generic.el   | 11 ++---------
 lisp/emacs-lisp/cl-macs.el      |  1 +
 lisp/emacs-lisp/cl-preloaded.el | 17 +++++++++++------
 lisp/emacs-lisp/comp.el         |  6 +++---
 test/src/data-tests.el          | 30 +++++++++++++++---------------
 6 files changed, 37 insertions(+), 36 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index 73af6ab773e..25c4efa590f 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1700,9 +1700,11 @@ 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.
+** New functions `primitive-function-p` and `cl-functionp`.
+`primitive-function-p` is like `subr-primitive-p` except that it returns
+t only if the argument is a function rather than a special-form,
+and `cl-functionp` is like `functionp` except it return nil
+for lists and symbols.
 
 ** Built-in types have now corresponding classes.
 At the Lisp level, this means that things like (cl-find-class 'integer)
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 62abe8d1589..8bda857afdd 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -1332,11 +1332,6 @@ These match if the argument is `eql' to VAL."
 
 ;;; Dispatch on "normal types".
 
-(defconst cl--generic--unreachable-types
-  ;; FIXME: Try to make that list empty?
-  '(keyword)
-  "Built-in classes on which we cannot dispatch for technical reasons.")
-
 (defun cl--generic-type-specializers (tag &rest _)
   (and (symbolp tag)
        (let ((class (cl--find-class tag)))
@@ -1350,14 +1345,12 @@ These match if the argument is `eql' to VAL."
 (cl-defmethod cl-generic-generalizers :extra "typeof" (type)
   "Support for dispatch on types.
 This currently works for built-in types and types built on top of records."
-  ;; FIXME: Add support for other types accepted by `cl-typep' such
-  ;; as `character', `face', `function', ...
+  ;; FIXME: Add support for other "types" accepted by `cl-typep' such
+  ;; as `character', `face', `keyword', ...?
   (or
    (and (symbolp type)
         (not (eq type t)) ;; Handled by the `t-generalizer'.
         (let ((class (cl--find-class type)))
-          (when (memq type cl--generic--unreachable-types)
-            (error "Dispatch on %S is currently not supported" type))
           (memq (type-of class)
                 '(built-in-class cl-structure-class eieio--class)))
         (list cl--generic-typeof-generalizer))
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index ab31946d8ab..051cd992fc1 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -3467,6 +3467,7 @@ Of course, we really can't know that for sure, so it's 
just a heuristic."
                '((base-char    . characterp) ;Could be subtype of `fixnum'.
                  (character    . natnump)    ;Could be subtype of `fixnum'.
                  (command      . commandp)   ;Subtype of closure & subr.
+                 (keyword      . keywordp)   ;Would need `keyword-with-pos`.
                  (natnum       . natnump)    ;Subtype of fixnum & bignum.
                  (real         . numberp)    ;Not clear where it would fit.
                  ))
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 35a8d79a1cd..6128db05c61 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -349,6 +349,14 @@ The `slots' (and hence `index-table') are currently 
unused."
 ;;   so the DAG of OClosure types is "orthogonal" to the distinction
 ;;   between interpreted and compiled functions.
 
+(defun cl-functionp (object)
+  "Return non-nil if OBJECT is a member of type `function'.
+This is like `functionp' except that it returns nil for all lists and symbols,
+regardless if `funcall' would accept to call them."
+  (memq (cl-type-of object)
+        '(primitive-function subr-native-elisp module-function
+          interpreted-function byte-code-function)))
+
 (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)
@@ -356,11 +364,9 @@ The `slots' (and hence `index-table') are currently 
unused."
 (cl--define-built-in-type tree-sitter-compiled-query atom)
 (cl--define-built-in-type tree-sitter-node atom)
 (cl--define-built-in-type tree-sitter-parser atom)
-(declare-function user-ptrp "data.c")
 (when (fboundp 'user-ptrp)
   (cl--define-built-in-type user-ptr atom nil
-                            ;; FIXME: Shouldn't it be called
-                            ;; `user-ptr-p'?
+                            ;; FIXME: Shouldn't it be called `user-ptr-p'?
                             :predicate user-ptrp))
 (cl--define-built-in-type font-object atom)
 (cl--define-built-in-type font-entity atom)
@@ -410,8 +416,6 @@ The `slots' (and hence `index-table') are currently unused."
 The size depends on the Emacs version and compilation options.
 For this build of Emacs it's %dbit."
           (1+ (logb (1+ most-positive-fixnum)))))
-(cl--define-built-in-type keyword (symbol)
-  "Type of those symbols whose first char is `:'.")
 (cl--define-built-in-type boolean (symbol)
   "Type of the canonical boolean values, i.e. either nil or t.")
 (cl--define-built-in-type symbol-with-pos (symbol)
@@ -431,7 +435,8 @@ For this build of Emacs it's %dbit."
   ;; Example of slots we could document.
   (car car) (cdr cdr))
 (cl--define-built-in-type function (atom)
-  "Abstract supertype of function values.")
+  "Abstract supertype of function values."
+  :predicate cl-functionp)
 (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/comp.el b/lisp/emacs-lisp/comp.el
index 9976a58f893..2544be85bb2 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -193,13 +193,14 @@ Useful to hook into pass checkers.")
 ;; cl-macs.el. We can't use `cl-deftype-satisfies' directly as the
 ;; relation type <-> predicate is not bijective (bug#45576).
 (defconst comp-known-predicates
+  ;; FIXME: Auto-generate (most of) it from `cl-deftype-satifies'?
   '((arrayp              array)
     (atom               atom)
     (bool-vector-p       bool-vector)
     (booleanp            boolean)
     (bufferp             buffer)
     (char-table-p       char-table)
-    (characterp          fixnum)
+    (characterp          fixnum t)
     (consp               cons)
     (floatp              float)
     (framep              frame)
@@ -207,14 +208,13 @@ Useful to hook into pass checkers.")
     (hash-table-p       hash-table)
     (integer-or-marker-p integer-or-marker)
     (integerp            integer)
-    (keywordp            keyword)
+    (keywordp            symbol t)
     (listp               list)
     (markerp             marker)
     (natnump             (integer 0 *))
     (null               null)
     (number-or-marker-p  number-or-marker)
     (numberp             number)
-    (numberp             number)
     (obarrayp            obarray)
     (overlayp            overlay)
     (processp            process)
diff --git a/test/src/data-tests.el b/test/src/data-tests.el
index daa49e671b5..753d74c02ec 100644
--- a/test/src/data-tests.el
+++ b/test/src/data-tests.el
@@ -845,10 +845,12 @@ comparing the subr with a much slower Lisp 
implementation."
   ;; 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
+  (dolist (val (list -2 10 (expt 2 128) nil t 'car :car
                      (symbol-function 'car)
                      (symbol-function 'progn)
-                     (position-symbol 'car 7)))
+                     (eval '(lambda (x) (+ x 1)) t)
+                     (position-symbol 'car 7)
+                     (position-symbol :car 7)))
     (let* ((type (cl-type-of val))
            (class (cl-find-class type))
            (alltypes (cl--class-allparents class))
@@ -858,19 +860,17 @@ comparing the subr with a much slower Lisp 
implementation."
       (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'.
-                             function))
-              (should-not (cl-typep val subtype)))))))))
+          (when (and (not (memq subtype alltypes))
+                     (built-in-class-p (cl-find-class subtype))
+                     (not (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))))
+            (should-not (cl-typep val subtype))))))))
 
 
 ;;; data-tests.el ends here