(cl-deftype): Precompute the predicate function

Always define a `cl-deftype-satisfies` predicate (if possible), so
we only need `cl-typep` to "interpret" a type specifier when we use
a compound type but never for the atomic types (e.g. never
in `cl-types-of`).

* lisp/emacs-lisp/cl-macs.el (cl-typep): Test `cl-deftype-satisfies` first.
Don't handle `real` here any more.
(base-char, character, command, keyword, natnum, real): Define with
`c-deftype`.
(cl-deftype): Precompute the predicate for the atomic derived type,
if applicable.

* lisp/emacs-lisp/cl-preloaded.el (cl--define-derived-type):
Add argument for the precomputed predicate function.

* lisp/emacs-lisp/cl-extra.el (cl-types-of): Use `cl-deftype-satisfies`
instead of `cl-type-p`.

(cherry picked from commit 777da8c3f9ea73077c00957d48d8e6b317b9657d)

diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 6f396bdbf0ca3d101fb307c22e369af446ce7b69..5569ec3d752a8c5ddd97f4b2845874c2d040d5f1 100644 (file)
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -1036,20 +1036,22 @@ TYPES is an internal argument."
   (let* ((found nil))
     ;; Build a list of all types OBJECT belongs to.
     (dolist (type (or types cl--derived-type-list))
-      (and
-       ;; If OBJECT is of type, add type to the matching list.
-       (if types
-           ;; For method dispatch, we don't need to filter out errors,
-           ;; since we can presume that method dispatch is used only on
-           ;; sanely-defined types.
-           (cl-typep object type)
-         (condition-case-unless-debug e
-             (cl-typep object type)
-           (error (setq cl--derived-type-list (delq type cl--derived-type-list))
-                  (warn  "cl-types-of %S: %s"
-                         type (error-message-string e))
-                  nil)))
-       (push type found)))
+      (let ((pred (get type 'cl-deftype-satisfies)))
+        (and
+         ;; If OBJECT is of type, add type to the matching list.
+         (if types
+             ;; For method dispatch, we don't need to filter out errors,
+             ;; since we can presume that method dispatch is used only on
+             ;; sanely-defined types.
+             (funcall pred object)
+           (condition-case-unless-debug e
+               (funcall pred object)
+             (error (setq cl--derived-type-list
+                          (delq type cl--derived-type-list))
+                    (warn  "cl-types-of %S: %s"
+                           type (error-message-string e))
+                    nil)))
+         (push type found))))
     (push (cl-type-of object) found)
     ;; Return the list of types OBJECT belongs to, which is also the list
     ;; of specifiers for OBJECT. This memoization has two purposes:

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 7cdf373d54c8282bdb00f47d05d4829848221a4b..221af7dfa69bcf6c7720bab3b95466574e5390c6 100644 (file)
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -3502,32 +3502,20 @@ Of course, we really can't know that for sure, so it's just a heuristic."
            (or (cdr (assq sym byte-compile-function-environment))
                (cdr (assq sym macroexpand-all-environment))))))
 
-;; Please keep it in sync with `comp-known-predicates'.
-(pcase-dolist (`(,type . ,pred)
-               ;; Mostly kept in alphabetical order.
-               ;; 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.
-                 (keyword      . keywordp)   ;Would need `keyword-with-pos`.
-                 (natnum       . natnump)    ;Subtype of fixnum & bignum.
-                 (real         . numberp)    ;Not clear where it would fit.
-                 ;; This one is redundant, but we keep it to silence a
-                 ;; warning during the early bootstrap when `cl-seq.el' gets
-                 ;; loaded before `cl-preloaded.el' is defined.
-                 (list         . listp)
-                 ))
-  (put type 'cl-deftype-satisfies pred))
-
 ;;;###autoload
 (define-inline cl-typep (val type)
   "Return t if VAL is of type TYPE, nil otherwise."
   (inline-letevals (val)
     (pcase (inline-const-val type)
+      ((and (or (and type (pred symbolp)) `(,type))
+            (guard (get type 'cl-deftype-satisfies)))
+       (inline-quote (funcall #',(get type 'cl-deftype-satisfies) ,val)))
       ((and `(,name . ,args) (guard (get name 'cl-deftype-handler)))
        (inline-quote
         (cl-typep ,val ',(apply (get name 'cl-deftype-handler) args))))
-      (`(,(and name (or 'integer 'float 'real 'number))
+      ;; FIXME: Move this to a `cl-deftype'.  The problem being that these
+      ;; types are hybrid "built-in and derived".
+      (`(,(and name (or 'integer 'float 'number))
          . ,(or `(,min ,max) pcase--dontcare))
        (inline-quote
         (and (cl-typep ,val ',name)
@@ -3561,8 +3549,6 @@ Of course, we really can't know that for sure, so it's just a heuristic."
       ((and (pred symbolp) type (guard (get type 'cl-deftype-handler)))
        (inline-quote
         (cl-typep ,val ',(funcall (get type 'cl-deftype-handler)))))
-      ((and (pred symbolp) type (guard (get type 'cl-deftype-satisfies)))
-       (inline-quote (funcall #',(get type 'cl-deftype-satisfies) ,val)))
       ((and (or 'nil 't) type) (inline-quote ',type))
       ((and (pred symbolp) type)
        (macroexp-warn-and-return
@@ -3763,18 +3749,58 @@ If PARENTS is non-nil, ARGLIST must be nil."
         (cl-callf (lambda (x) (delq declares x)) decls)))
     (and parents arglist
          (error "Parents specified, but arglist not empty"))
-    `(eval-and-compile
-       (cl--define-derived-type
-        ',name
-        (cl-function (lambda (&cl-defs ('*) ,@arglist) ,@decls ,@forms))
-        ',parents))))
+    (let* ((expander
+            `(cl-function (lambda (&cl-defs ('*) ,@arglist) ,@decls ,@forms)))
+           ;; FIXME: Pass a better lexical context.
+           (specifier (ignore-errors (funcall (eval expander t))))
+           (predicate
+            (pcase specifier
+              (`(satisfies ,f) `#',f)
+              ('nil nil)
+              (type `(lambda (x) (cl-typep x ',type))))))
+      `(eval-and-compile
+         (cl--define-derived-type
+          ',name ,expander ,predicate ',parents)))))
 
 (static-if (not (fboundp 'cl--define-derived-type))
-    nil ;; Can't define it yet!
-  (cl-deftype extended-char () '(and character (not base-char))))
-
-;;; Additional functions that we can now define because we've defined
-;;; `cl-defsubst' and `cl-typep'.
+    nil ;; Can't define them yet!
+  (cl-deftype natnum () (declare (parents integer)) '(satisfies natnump))
+  (cl-deftype character () (declare (parents fixnum natnum))
+               '(and fixnum natnum))
+  (cl-deftype base-char () (declare (parents character))
+              '(satisfies characterp))
+  (cl-deftype extended-char () (declare (parents character))
+              '(and character (not base-char)))
+  (cl-deftype keyword () (declare (parents symbol)) '(satisfies keywordp))
+  (cl-deftype command ()
+    ;; FIXME: Can't use `function' as parent because of arrays as
+    ;; keyboard macros, which are redundant since `kmacro.el'!!
+    ;;(declare (parents function))
+    '(satisfies commandp))
+  ;; This one is redundant, but we keep it to silence a
+  ;; warning during the early bootstrap when `cl-seq.el' gets
+  ;; loaded before `cl-preloaded.el' is defined.
+  (put 'list 'cl-deftype-satisfies #'listp)
+
+  (eval-when-compile
+    (defmacro cl--defnumtype (type base)
+      `(cl-deftype ,type (&optional min max)
+         (list 'and ',base
+               (if (memq min '(* nil)) t
+                 (if (consp min)
+                     `(satisfies . ,(lambda (val) (> val (car min))))
+                   `(satisfies . ,(lambda (val) (>= val min)))))
+               (if (memq max '(* nil)) t
+                 (if (consp max)
+                     `(satisfies . ,(lambda (val) (< val (car max))))
+                   `(satisfies . ,(lambda (val) (<= val max)))))))))
+  ;;(cl--defnumtype integer ??)
+  ;;(cl--defnumtype float ??)
+  ;;(cl--defnumtype number ??)
+  (cl--defnumtype real number))
+
+;; Additional functions that we can now define because we've defined
+;; `cl-defsubst' and `cl-typep'.
 
 (define-inline cl-struct-slot-value (struct-type slot-name inst)
   "Return the value of slot SLOT-NAME in INST of STRUCT-TYPE.

diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 8956245f24c369375d2a2d0663b2cd33dd3f6920..e4b467ceb2422c0cfa223183d3487d5c57dd37d5 100644 (file)
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -491,10 +491,12 @@ The fields are used as follows:
      (:copier nil))
   "Type descriptors for derived types, i.e. defined by `cl-deftype'.")
 
-(defun cl--define-derived-type (name expander &optional parents)
+(defun cl--define-derived-type (name expander predicate &optional parents)
   "Register derived type with NAME for method dispatching.
 EXPANDER is the function that computes the type specifier from
 the arguments passed to the derived type.
+PREDICATE is the precomputed function to test this type when used as an
+atomic type, or nil if it cannot be used as an atomic type.
 PARENTS is a list of types NAME is a subtype of, or nil."
   (let* ((class (cl--find-class name)))
     (when class
@@ -509,6 +511,8 @@ PARENTS is a list of types NAME is a subtype of, or nil."
           (cl--derived-type-class-make name (function-documentation expander)
                                        parents))
     (define-symbol-prop name 'cl-deftype-handler expander)
+    (when predicate
+      (define-symbol-prop name 'cl-deftype-satisfies predicate))
     ;; Record new type.  The constructor of the class
     ;; `cl-type-class' already ensures that parent types must be
     ;; defined before their "child" types (i.e. already added to
@@ -530,7 +534,7 @@ PARENTS is a list of types NAME is a subtype of, or nil."
     (or (memq name cl--derived-type-list)
         ;; Exclude types that can't be used without arguments.
         ;; They'd signal errors in `cl-types-of'!
-        (not (ignore-errors (funcall expander)))
+        (not predicate)
         (push name cl--derived-type-list))))
 
 ;; Make sure functions defined with cl-defsubst can be inlined even in