cl-types: Integrate into CL-Lib

* lisp/emacs-lisp/cl-extra.el (cl--type-unique, cl-types-of)
(cl--type-dispatch-list, cl--type-generalizer): Move to `cl-extra.el`.
(cl--type-generalizers): New function extracted from "cl-types-of"
method of `cl-generic-generalizers`.

* lisp/emacs-lisp/cl-lib.el (cl-generic-generalizers): New method to
dispatch on derived types.  Use `cl--type-generalizers`.

* lisp/emacs-lisp/cl-macs.el (cl-deftype): Move from `cl-types.el`
and rename from `cl-deftype2`.
(extended-char): Tweak definition to fix bootstrapping issues.

* lisp/emacs-lisp/cl-preloaded.el (cl--type-list, cl-type-class)
(cl--type-deftype): Move from `cl-types.el`.

* lisp/emacs-lisp/oclosure.el (oclosure): Don't abuse `cl-deftype` to
register the predicate function.

* test/lisp/emacs-lisp/cl-extra-tests.el: Move tests from
`cl-type-tests.el`.

8 files changed, 373 insertions, 368 deletions

diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 6390d17a5b7..bd7bb96dd6a 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -965,6 +965,127 @@ Outputs to the current buffer."
       (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold))
       (mapc #'cl--describe-class-slot cslots))))
 
+;;;; Method dispatch on `cl-deftype' types.
+
+;; Extend `cl-deftype' to define data types which are also valid
+;; argument types for dispatching generic function methods (see also
+;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=77725>).
+;;
+;; The main entry points are:
+;;
+;; - `cl-deftype', that defines new data types.
+;;
+;; - `cl-types-of', that returns the types an object belongs to.
+
+;; Ensure each type satisfies `eql'.
+(defvar cl--type-unique (make-hash-table :test 'equal)
+  "Record an unique value of each type.")
+
+;; FIXME: `cl-types-of' CPU cost is proportional to the number of types
+;; defined with `cl-deftype', so the more popular it gets, the slower
+;; it becomes.  And of course, the cost of each type check is
+;; unbounded, so a single "expensive" type can slow everything down
+;; further.
+;;
+;; The usual dispatch is
+;;
+;;   (lambda (arg &rest args)
+;;     (let ((f (gethash (cl-typeof arg) precomputed-methods-table)))
+;;       (if f
+;;           (apply f arg args)
+;;         ;; Slow case when encountering a new type
+;;         ...)))
+;;
+;; where often the most expensive part is `&rest' (which has to
+;; allocate a list for those remaining arguments),
+;;
+;; So we're talking about replacing
+;;
+;;   &rest + cl-type-of + gethash + if + apply
+;;
+;; with a function that loops over N types, calling `cl-typep' on each
+;; one of them (`cl-typep' itself being a recursive function that
+;; basically interprets the type language).  This is going to slow
+;; down dispatch very significantly for those generic functions that
+;; have a method that dispatches on a user defined type, compared to
+;; those that don't.
+;;
+;; A possible further improvement:
+;;
+;; - based on the PARENTS declaration, create a map from builtin-type
+;;   to the set of cl-types that have that builtin-type among their
+;;   parents.  That presumes some PARENTS include some builtin-types,
+;;   obviously otherwise the map will be trivial with all cl-types
+;;   associated with the `t' "dummy parent".  [ We could even go crazy
+;;   and try and guess PARENTS when not provided, by analyzing the
+;;   type's definition. ]
+;;
+;; - in `cl-types-of' start by calling `cl-type-of', then use the map
+;;   to find which cl-types may need to be checked.
+;;
+;;;###autoload
+(defun cl-types-of (object &optional types)
+  "Return the types OBJECT belongs to.
+Return an unique list of types OBJECT belongs to, ordered from the
+most specific type to the most general.
+TYPES is an internal argument."
+  (let* ((found nil))
+    ;; Build a list of all types OBJECT belongs to.
+    (dolist (type (or types cl--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--type-list (delq type cl--type-list))
+                  (warn  "cl-types-of %S: %s"
+                         type (error-message-string e)))))
+       (push type found)))
+    (push (cl-type-of object) found)
+    ;; Return an unique value of the list of types OBJECT belongs to,
+    ;; which is also the list of specifiers for OBJECT.
+    (with-memoization (gethash found cl--type-unique)
+      ;; Compute an ordered list of types from the DAG.
+      (merge-ordered-lists
+       (mapcar (lambda (type) (cl--class-allparents (cl--find-class type)))
+               (nreverse found))))))
+
+(defvar cl--type-dispatch-list nil
+  "List of types that need to be checked during dispatch.")
+
+(cl-generic-define-generalizer cl--type-generalizer
+  ;; FIXME: This priority can't be always right.  :-(
+  ;; E.g. a method dispatching on a type like (or number function),
+  ;; should take precedence over a method on `t' but not over a method
+  ;; on `number'.  Similarly a method dispatching on a type like
+  ;; (satisfies (lambda (x) (equal x '(A . B)))) should take precedence
+  ;; over a method on (head 'A).
+  ;; Fixing this 100% is impossible so this generalizer is condemned to
+  ;; suffer from "undefined method ordering" problems, unless/until we
+  ;; restrict it somehow to a subset that we can handle reliably.
+  20 ;; "typeof" < "cl-types-of" < "head" priority
+  (lambda (obj &rest _) `(cl-types-of ,obj cl--type-dispatch-list))
+  (lambda (tag &rest _) (if (consp tag) tag)))
+
+;;;###autoload
+(defun cl--type-generalizers (type)
+  ;; Add a new dispatch type to the dispatch list, then
+  ;; synchronize with `cl--type-list' so that both lists follow
+  ;; the same type precedence order.
+  ;; The `merge-ordered-lists' is `cl-types-of' should we make this
+  ;; ordering unnecessary, but it's still handy for all those types
+  ;; that don't declare their parents.
+  (unless (memq type cl--type-dispatch-list)
+    (setq cl--type-dispatch-list
+          (seq-intersection cl--type-list
+                            (cons type cl--type-dispatch-list))))
+  (list cl--type-generalizer))
+
+;;;; Trailer
 
 (make-obsolete-variable 'cl-extra-load-hook
                         "use `with-eval-after-load' instead." "28.1")
diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index 4645b4dffb1..ff014965eb9 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -560,6 +560,19 @@ If ALIST is non-nil, the new pairs are prepended to it."
   ;; those rare places where we do need it.
   )
 
+(static-if (not (fboundp 'cl-defmethod))
+    ;; `cl-generic' requires `cl-lib' at compile-time, so `cl-lib' can't
+    ;; use `cl-defmethod' before `cl-generic' has been compiled.
+    ;; Also, there is no mechanism to autoload methods, so this can't be
+    ;; moved to `cl-extra.el'.
+    nil
+  (declare-function cl--type-generalizers "cl-extra" (type))
+  (cl-defmethod cl-generic-generalizers :extra "cl-types-of" (type)
+  "Support for dispatch on cl-types."
+  (if (and (symbolp type) (cl-type-class-p (cl--find-class type)))
+      (cl--type-generalizers type)
+    (cl-call-next-method))))
+
 (defun cl--old-struct-type-of (orig-fun object)
   (or (and (vectorp object) (> (length object) 0)
            (let ((tag (aref object 0)))
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index a966ec5eaf6..424ebe2c7ad 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -3786,15 +3786,52 @@ macro that returns its `&whole' argument."
 ;;;###autoload
 (defmacro cl-deftype (name arglist &rest body)
   "Define NAME as a new data type.
-The type name can then be used in `cl-typecase', `cl-check-type', etc."
-  (declare (debug cl-defmacro) (doc-string 3) (indent 2))
-  `(cl-eval-when (compile load eval)
-     (define-symbol-prop ',name 'cl-deftype-handler
-                         (cl-function (lambda (&cl-defs ('*) ,@arglist) ,@body)))))
+The type NAME can then be used in `cl-typecase', `cl-check-type',
+etc., and to some extent, as method specializer.
+
+ARGLIST is a Common Lisp argument list of the sort accepted by
+`cl-defmacro'.  BODY forms should return a type specifier that is equivalent
+to the type (see the Info node `(cl)Type Predicates').
 
-(cl-deftype extended-char () '(and character (not base-char)))
-;; Define fixnum so `cl-typep' recognize it and the type check emitted
-;; by `cl-the' is effective.
+If there is a `declare' form in BODY, the spec (parents . PARENTS)
+can specify a list of types NAME is a subtype of.
+The list of PARENTS types determines the order of methods invocation,
+and missing PARENTS may cause incorrect ordering of methods, while
+extraneous PARENTS may cause use of extraneous methods.
+
+If PARENTS is non-nil, ARGLIST must be nil."
+  (declare (debug cl-defmacro) (doc-string 3) (indent 2))
+  (pcase-let*
+      ((`(,decls . ,forms) (macroexp-parse-body body))
+       (docstring (if (stringp (car decls))
+                      (car decls)
+                      (cadr (assq :documentation decls))))
+       (declares (assq 'declare decls))
+       (parent-decl (assq 'parents (cdr declares)))
+       (parents (cdr parent-decl)))
+    (when parent-decl
+      ;; "Consume" the `parents' declaration.
+      (cl-callf (lambda (x) (delq parent-decl x)) (cdr declares))
+      (when (equal declares '(declare))
+        (cl-callf (lambda (x) (delq declares x)) decls)))
+    (and parents arglist
+         (error "Parents specified, but arglist not empty"))
+    `(eval-and-compile ;;cl-eval-when (compile load eval)
+       ;; FIXME: Where should `cl--type-deftype' go?  Currently, code
+       ;; using `cl-deftype' can use (eval-when-compile (require
+       ;; 'cl-lib)), so `cl--type-deftype' needs to go either to
+       ;; `cl-preloaded.el' or it should be autoloaded even when
+       ;; `cl-lib' is not loaded.
+       (cl--type-deftype ',name ',parents ',arglist ,docstring)
+       (define-symbol-prop ',name 'cl-deftype-handler
+                           (cl-function
+                            (lambda (&cl-defs ('*) ,@arglist)
+                              ,@decls
+                              ,@forms))))))
+
+(static-if (not (fboundp 'cl--type-deftype))
+    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'.
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index dfea8d6c8e3..0447191bbc7 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -465,6 +465,71 @@ The fields are used as follows:
   (setf (cl--class-parents (cl--find-class 'cl-structure-object))
       (list (cl--find-class 'record))))
 
+;;;; Support for `cl-deftype'.
+
+(defvar cl--type-list nil
+  "Precedence list of the defined cl-types.")
+
+;; FIXME: The `cl-deftype-handler' property should arguably be turned
+;; into a field of this struct (but it has performance and
+;; compatibility implications, so let's not make that change for now).
+(cl-defstruct
+    (cl-type-class
+     (:include cl--class)
+     (:noinline t)
+     (:constructor nil)
+     (:constructor cl--type-class-make
+                   (name
+                    docstring
+                    parent-types
+                    &aux (parents
+                          (mapcar
+                           (lambda (type)
+                             (or (cl--find-class type)
+                                 (error "Unknown type: %S" type)))
+                           parent-types))))
+     (:copier nil))
+  "Type descriptors for types defined by `cl-deftype'.")
+
+(defun cl--type-deftype (name parents arglist &optional docstring)
+  "Register cl-type with NAME for method dispatching.
+PARENTS is a list of types NAME is a subtype of, or nil.
+DOCSTRING is an optional documentation string."
+  (let* ((class (cl--find-class name)))
+    (when class
+      (or (cl-type-class-p class)
+          ;; FIXME: We have some uses `cl-deftype' in Emacs that
+          ;; "complement" another declaration of the same type,
+          ;; so maybe we should turn this into a warning (and
+          ;; not overwrite the `cl--find-class' in that case)?
+          (error "Type in another class: %S" (type-of class))))
+    ;; Setup a type descriptor for NAME.
+    (setf (cl--find-class name)
+          (cl--type-class-make name docstring parents))
+    ;; 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
+    ;; the `cl--type-list' for types defined with `cl-deftype').
+    ;; So it is enough to simply push a new type at the beginning
+    ;; of the list.
+    ;; Redefinition is more complicated, because child types may
+    ;; be in the list, so moving the type to the head can be
+    ;; incorrect.  The "cheap" solution is to leave the list
+    ;; unchanged (and hope the redefinition doesn't change the
+    ;; hierarchy too much).
+    ;; Side note: Redefinitions introduce other problems as well
+    ;; because the class object's `parents` slot contains
+    ;; references to `cl--class` objects, so after a redefinition
+    ;; via (setf (cl--find-class FOO) ...), the children's
+    ;; `parents` slots point to the old class object.  That's a
+    ;; problem that affects all types and that we don't really try
+    ;; to solve currently.
+    (or (memq name cl--type-list)
+        ;; Exclude types that can't be used without arguments.
+        ;; They'd signal errors in `cl-types-of'!
+        (not (memq (car arglist) '(nil &rest &optional &keys)))
+        (push name cl--type-list))))
+
 ;; Make sure functions defined with cl-defsubst can be inlined even in
 ;; packages which do not require CL.  We don't put an autoload cookie
 ;; directly on that function, since those cookies only go to cl-loaddefs.
diff --git a/lisp/emacs-lisp/cl-types.el b/lisp/emacs-lisp/cl-types.el
index a466c309a33..c265e50f0f2 100644
--- a/lisp/emacs-lisp/cl-types.el
+++ b/lisp/emacs-lisp/cl-types.el
@@ -1,5 +1,41 @@
 ;; -*- lexical-binding: t; -*-
 
+;;; Old Sizes:
+
+;; % (cd lisp/emacs-lisp/; l cl-*.elc)
+;; -rw-r--r-- 1 monnier monnier  68920  5 mai 13:49 cl-generic.elc
+;; -rw-r--r-- 1 monnier monnier  41841  5 mai 13:49 cl-preloaded.elc
+;; -rw-r--r-- 1 monnier monnier  23037  5 mai 13:58 cl-lib.elc
+;; -rw-r--r-- 1 monnier monnier  32664  5 mai 14:14 cl-extra.elc
+;; -rw-r--r-- 1 monnier monnier  53769  5 mai 14:14 cl-loaddefs.elc
+;; -rw-r--r-- 1 monnier monnier  17921  5 mai 14:14 cl-indent.elc
+;; -rw-r--r-- 1 monnier monnier  18295  5 mai 14:14 cl-print.elc
+;; -rw-r--r-- 1 monnier monnier 101608  5 mai 14:14 cl-macs.elc
+;; -rw-r--r-- 1 monnier monnier  43849  5 mai 14:14 cl-seq.elc
+;; -rw-r--r-- 1 monnier monnier   8691  5 mai 18:53 cl-types.elc
+;; %
+
+;;; After the move:
+
+;; % (cd lisp/emacs-lisp/; l cl-*.elc)
+;; -rw-r--r-- 1 monnier monnier  46390  5 mai 23:04 cl-preloaded.elc
+;; -rw-r--r-- 1 monnier monnier  68920  5 mai 23:04 cl-generic.elc
+;; -rw-r--r-- 1 monnier monnier  23620  5 mai 23:05 cl-lib.elc
+;; -rw-r--r-- 1 monnier monnier  54752  5 mai 23:15 cl-loaddefs.elc
+;; -rw-r--r-- 1 monnier monnier  17921  5 mai 23:05 cl-indent.elc
+;; -rw-r--r-- 1 monnier monnier  34065  5 mai 23:05 cl-extra.elc
+;; -rw-r--r-- 1 monnier monnier  18295  5 mai 23:05 cl-print.elc
+;; -rw-r--r-- 1 monnier monnier 102581  5 mai 23:05 cl-macs.elc
+;; -rw-r--r-- 1 monnier monnier    159  5 mai 23:05 cl-types.elc
+;; -rw-r--r-- 1 monnier monnier  43849  5 mai 23:05 cl-seq.elc
+;; %
+
+;; cl-preloaded:  +4549    41841 => 46390
+;; cl-lib:        + 583    23037 => 23620
+;; cl-macs:       + 973   101608 => 102581
+;; cl-extra       +1401    32664 => 34065
+;; cl-loaddefs:   + 983    53769 => 54752
+
 ;; Data types defined by `cl-deftype' are now recognized as argument
 ;; types for dispatching generic functions methods.
 
@@ -9,271 +45,8 @@
 (declare-function cl-remprop "cl-extra" (symbol propname))
 (declare-function cl--class-children "cl-extra" (class))
 
-;; Extend `cl-deftype' to define data types which are also valid
-;; argument types for dispatching generic function methods (see also
-;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=77725>).
-;;
-;; The main entry points are:
-;;
-;; - `cl-deftype', that defines new data types.
-;;
-;; - `cl-types-of', that returns the types an object belongs to.
-
-(defvar cl--type-list nil
-  "Precedence list of the defined cl-types.")
-
-;; FIXME: The `cl-deftype-handler' property should arguably be turned
-;; into a field of this struct (but it has performance and
-;; compatibility implications, so let's not make that change for now).
-(cl-defstruct
-    (cl-type-class
-     (:include cl--class)
-     (:noinline t)
-     (:constructor nil)
-     (:constructor cl--type-class-make
-                   (name
-                    docstring
-                    parent-types
-                    &aux (parents
-                          (mapcar
-                           (lambda (type)
-                             (or (cl--find-class type)
-                                 (error "Unknown type: %S" type)))
-                           parent-types))))
-     (:copier nil))
-  "Type descriptors for types defined by `cl-deftype'.")
-
-(defun cl--type-p (object)
-  "Return non-nil if OBJECT is a cl-type.
-That is, a type defined by `cl-deftype', of class `cl-type-class'."
-  (and (symbolp object) (cl-type-class-p (cl--find-class object))))
-
-(defun cl--type-deftype (name parents arglist &optional docstring)
-  "Register cl-type with NAME for method dispatching.
-PARENTS is a list of types NAME is a subtype of, or nil.
-DOCSTRING is an optional documentation string."
-  (let* ((class (cl--find-class name)))
-    (when class
-      (or (cl-type-class-p class)
-          ;; FIXME: We have some uses `cl-deftype' in Emacs that
-          ;; "complement" another declaration of the same type,
-          ;; so maybe we should turn this into a warning (and
-          ;; not overwrite the `cl--find-class' in that case)?
-          (error "Type in another class: %S" (type-of class))))
-    ;; Setup a type descriptor for NAME.
-    (setf (cl--find-class name)
-          (cl--type-class-make name docstring parents))
-    ;; 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
-    ;; the `cl--type-list' for types defined with `cl-deftype').
-    ;; So it is enough to simply push a new type at the beginning
-    ;; of the list.
-    ;; Redefinition is more complicated, because child types may
-    ;; be in the list, so moving the type to the head can be
-    ;; incorrect.  The "cheap" solution is to leave the list
-    ;; unchanged (and hope the redefinition doesn't change the
-    ;; hierarchy too much).
-    ;; Side note: Redefinitions introduce other problems as well
-    ;; because the class object's `parents` slot contains
-    ;; references to `cl--class` objects, so after a redefinition
-    ;; via (setf (cl--find-class FOO) ...), the children's
-    ;; `parents` slots point to the old class object.  That's a
-    ;; problem that affects all types and that we don't really try
-    ;; to solve currently.
-    (or (memq name cl--type-list)
-        ;; Exclude types that can't be used without arguments.
-        ;; They'd signal errors in `cl-types-of'!
-        (not (memq (car arglist) '(nil &rest &optional &keys)))
-        (push name cl--type-list))))
-
-;;;###autoload
-(defmacro cl-deftype2 (name arglist &rest body)
-  "Define NAME as a new data type.
-The type NAME can then be used in `cl-typecase', `cl-check-type',
-etc., and as argument type for dispatching generic function methods.
-
-ARGLIST is a Common Lisp argument list of the sort accepted by
-`cl-defmacro'.  BODY forms are evaluated and should return a type
-specifier that is equivalent to the type (see the Info node `(cl) Type
-Predicates' in the GNU Emacs Common Lisp Emulation manual).
-
-If there is a `declare' form in BODY, the spec (parents PARENTS) is
-recognized to specify a list of types NAME is a subtype of.  For
-instance:
-
-  (cl-deftype2 unsigned-byte (&optional bits)
-    \"Unsigned integer.\"
-    (list \\='integer 0 (if (eq bits \\='*) bits (1- (ash 1 bits)))))
-
-  (cl-deftype2 unsigned-8bits ()
-    \"Unsigned 8-bits integer.\"
-    (declare (parents unsigned-byte))
-    \\='(unsigned-byte 8))
-
-The list of PARENTS types determines the order of methods invocation,
-and missing PARENTS may cause incorrect ordering of methods, while
-extraneous PARENTS may cause use of extraneous methods.
-
-If PARENTS is non-nil, ARGLIST must be nil."
-  (declare (debug cl-defmacro) (doc-string 3) (indent 2))
-  (pcase-let*
-      ((`(,decls . ,forms) (macroexp-parse-body body))
-       (docstring (if (stringp (car decls))
-                      (car decls)
-                      (cadr (assq :documentation decls))))
-       (declares (assq 'declare decls))
-       (parent-decl (assq 'parents (cdr declares)))
-       (parents (cdr parent-decl)))
-    (when parent-decl
-      ;; "Consume" the `parents' declaration.
-      (cl-callf (lambda (x) (delq parent-decl x)) (cdr declares))
-      (when (equal declares '(declare))
-        (cl-callf (lambda (x) (delq declares x)) decls)))
-    (if (memq name parents)
-        (error "Type in parents: %S" parents))
-    (and parents arglist
-         (error "Parents specified, but arglist not empty"))
-    `(eval-and-compile ;;cl-eval-when (compile load eval)
-       ;; FIXME: Where should `cl--type-deftype' go?  Currently, code
-       ;; using `cl-deftype' can use (eval-when-compile (require
-       ;; 'cl-lib)), so `cl--type-deftype' needs to go either to
-       ;; `cl-preloaded.el' or it should be autoloaded even when
-       ;; `cl-lib' is not loaded.
-       (cl--type-deftype ',name ',parents ',arglist ,docstring)
-       (define-symbol-prop ',name 'cl-deftype-handler
-                           (cl-function
-                            (lambda (&cl-defs ('*) ,@arglist)
-                              ,@decls
-                              ,@forms))))))
-
-;; Ensure each type satisfies `eql'.
-(defvar cl--type-unique (make-hash-table :test 'equal)
-  "Record an unique value of each type.")
-
-;; FIXME: `cl-types-of' CPU cost is proportional to the number of types
-;; defined with `cl-deftype', so the more popular it gets, the slower
-;; it becomes.  And of course, the cost of each type check is
-;; unbounded, so a single "expensive" type can slow everything down
-;; further.
-;;
-;; The usual dispatch is
-;;
-;;   (lambda (arg &rest args)
-;;     (let ((f (gethash (cl-typeof arg) precomputed-methods-table)))
-;;       (if f
-;;           (apply f arg args)
-;;         ;; Slow case when encountering a new type
-;;         ...)))
-;;
-;; where often the most expensive part is `&rest' (which has to
-;; allocate a list for those remaining arguments),
-;;
-;; So we're talking about replacing
-;;
-;;   &rest + cl-type-of + gethash + if + apply
-;;
-;; with a function that loops over N types, calling `cl-typep' on each
-;; one of them (`cl-typep' itself being a recursive function that
-;; basically interprets the type language).  This is going to slow
-;; down dispatch very significantly for those generic functions that
-;; have a method that dispatches on a user defined type, compared to
-;; those that don't.
-;;
-;; A possible further improvement:
-;;
-;; - based on the PARENTS declaration, create a map from builtin-type
-;;   to the set of cl-types that have that builtin-type among their
-;;   parents.  That presumes some PARENTS include some builtin-types,
-;;   obviously otherwise the map will be trivial with all cl-types
-;;   associated with the `t' "dummy parent".  [ We could even go crazy
-;;   and try and guess PARENTS when not provided, by analyzing the
-;;   type's definition. ]
-;;
-;; - in `cl-types-of' start by calling `cl-type-of', then use the map
-;;   to find which cl-types may need to be checked.
-;;
-(defun cl-types-of (object &optional types)
-  "Return the types OBJECT belongs to.
-Return an unique list of types OBJECT belongs to, ordered from the
-most specific type to the most general.
-TYPES is an internal argument."
-  (let* ((found nil))
-    ;; Build a list of all types OBJECT belongs to.
-    (dolist (type (or types cl--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--type-list (delq type cl--type-list))
-                  (warn  "cl-types-of %S: %s"
-                         type (error-message-string e)))))
-       (push type found)))
-    (push (cl-type-of object) found)
-    ;; Return an unique value of the list of types OBJECT belongs to,
-    ;; which is also the list of specifiers for OBJECT.
-    (with-memoization (gethash found cl--type-unique)
-      ;; Compute an ordered list of types from the DAG.
-      (merge-ordered-lists
-       (mapcar (lambda (type) (cl--class-allparents (cl--find-class type)))
-               (nreverse found))))))
-
-;;; Method dispatching
-;;
-
-(defvar cl--type-dispatch-list nil
-  "List of types that need to be checked during dispatch.")
-
-(cl-generic-define-generalizer cl--type-generalizer
-  ;; FIXME: This priority can't be always right.  :-(
-  ;; E.g. a method dispatching on a type like (or number function),
-  ;; should take precedence over a method on `t' but not over a method
-  ;; on `number'.  Similarly a method dispatching on a type like
-  ;; (satisfies (lambda (x) (equal x '(A . B)))) should take precedence
-  ;; over a method on (head 'A).
-  ;; Fixing this 100% is impossible so this generalizer is condemned to
-  ;; suffer from "undefined method ordering" problems, unless/until we
-  ;; restrict it somehow to a subset that we can handle reliably.
-  20 ;; "typeof" < "cl-types-of" < "head" priority
-  (lambda (obj &rest _) `(cl-types-of ,obj cl--type-dispatch-list))
-  (lambda (tag &rest _) (if (consp tag) tag)))
-
-(cl-defmethod cl-generic-generalizers :extra "cl-types-of" (type)
-  "Support for dispatch on cl-types."
-  (if (cl--type-p type)
-      (progn
-        ;; Add a new dispatch type to the dispatch list, then
-        ;; synchronize with `cl--type-list' so that both lists follow
-        ;; the same type precedence order.
-        ;; The `merge-ordered-lists' is `cl-types-of' should we make this
-        ;; ordering unnecessary, but it's still handy for all those types
-        ;; that don't declare their parents.
-        (unless (memq type cl--type-dispatch-list)
-          (setq cl--type-dispatch-list
-                (seq-intersection cl--type-list
-                                  (cons type cl--type-dispatch-list))))
-        (list cl--type-generalizer))
-    (cl-call-next-method)))
 
-;;; Support for unloading.
 
-;; Keep it for now, for testing.
-(defun cl--type-undefine (name)
-  "Remove the definition of cl-type with NAME.
-NAME is an unquoted symbol representing a cl-type.
-Signal an error if NAME has subtypes."
-  (cl-check-type name (satisfies cl--type-p))
-  (when-let* ((children (cl--class-children (cl--find-class name))))
-    (error "Type has children: %S" children))
-  (cl-remprop name 'cl--class)
-  (cl-remprop name 'cl-deftype-handler)
-  (setq cl--type-dispatch-list (delq name cl--type-dispatch-list))
-  (setq cl--type-list (delq name cl--type-list)))
 
 (provide 'cl-types)
 
diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
index d38429648e6..19823f44d4c 100644
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -151,7 +151,7 @@
 (defun oclosure--p (oclosure)
   (not (not (oclosure-type oclosure))))
 
-(cl-deftype oclosure () '(satisfies oclosure--p))
+(define-symbol-prop 'oclosure 'cl-deftype-satisfies #'oclosure--p)
 
 (defun oclosure--slot-mutable-p (slotdesc)
   (not (alist-get :read-only (cl--slot-descriptor-props slotdesc))))
diff --git a/test/lisp/emacs-lisp/cl-extra-tests.el b/test/lisp/emacs-lisp/cl-extra-tests.el
index 20d1e532a6f..1f94d71e567 100644
--- a/test/lisp/emacs-lisp/cl-extra-tests.el
+++ b/test/lisp/emacs-lisp/cl-extra-tests.el
@@ -348,4 +348,96 @@
     (should (cl-tailp l l))
     (should (not (cl-tailp '(4 5) l)))))
 
+;;;; Method dispatch for derived types.
+
+(cl-deftype multiples-of (&optional m)
+  (let ((multiplep (if (eq m '*)
+                       #'ignore
+                     (lambda (n) (= 0 (% n m))))))
+    `(and integer (satisfies ,multiplep))))
+
+(cl-deftype multiples-of-2 ()
+  '(multiples-of 2))
+
+(cl-deftype multiples-of-3 ()
+  '(multiples-of 3))
+
+(cl-deftype multiples-of-4 ()
+  (declare (parents multiples-of-2))
+  '(and multiples-of-2 (multiples-of 4)))
+
+(cl-deftype unsigned-byte (&optional bits)
+  "Unsigned integer."
+  `(integer 0 ,(if (eq bits '*) bits (1- (ash 1 bits)))))
+
+(cl-deftype unsigned-16bits ()
+  "Unsigned 16-bits integer."
+  (declare (parents unsigned-byte))
+  '(unsigned-byte 16))
+
+(cl-deftype unsigned-8bits ()
+  "Unsigned 8-bits integer."
+  (declare (parents unsigned-16bits))
+  '(unsigned-byte 8))
+
+(cl-defmethod my-foo ((_n unsigned-byte))
+  (format "unsigned"))
+
+(cl-defmethod my-foo ((_n unsigned-16bits))
+  (format "unsigned 16bits - also %s"
+          (cl-call-next-method)))
+
+(cl-defmethod my-foo ((_n unsigned-8bits))
+  (format "unsigned 8bits - also %s"
+          (cl-call-next-method)))
+
+(ert-deftest cl-types-test ()
+  "Test types definition, cl-types-of and method dispatching."
+
+  ;; Invalid DAG error
+  ;; FIXME: We don't test that any more.
+  ;; (should-error
+  ;;  (eval
+  ;;   '(cl-deftype unsigned-16bits ()
+  ;;      "Unsigned 16-bits integer."
+  ;;      (declare (parents unsigned-8bits))
+  ;;      '(unsigned-byte 16))
+  ;;   lexical-binding
+  ;;   ))
+
+  ;; Test that (cl-types-of 4) is (multiples-of-4 multiples-of-2 ...)
+  ;; Test that (cl-types-of 6) is (multiples-of-3 multiples-of-2 ...)
+  ;; Test that (cl-types-of 12) is (multiples-of-4 multiples-of-3 multiples-of-2 ...)
+  (let ((types '(multiples-of-2 multiples-of-3 multiples-of-4)))
+    (should (equal '(multiples-of-2)
+                   (seq-intersection (cl-types-of 2) types)))
+
+    (should (equal '(multiples-of-4 multiples-of-2)
+                   (seq-intersection (cl-types-of 4) types)))
+
+    (should (equal '(multiples-of-3 multiples-of-2)
+                   (seq-intersection (cl-types-of 6) types)))
+
+    (should (member (seq-intersection (cl-types-of 12) types)
+                    ;; Order between 3 and 4/2 is undefined.
+                    '((multiples-of-3 multiples-of-4 multiples-of-2)
+                      (multiples-of-4 multiples-of-2 multiples-of-3))))
+
+    (should (equal '()
+                   (seq-intersection (cl-types-of 5) types)))
+    )
+
+  ;;; Method dispatching.
+  (should (equal "unsigned 8bits - also unsigned 16bits - also unsigned"
+                 (my-foo 100)))
+
+  (should (equal "unsigned 16bits - also unsigned"
+                 (my-foo 256)))
+
+  (should (equal "unsigned"
+                 (my-foo most-positive-fixnum)))
+  )
+
+
+
 ;;; cl-extra-tests.el ends here
diff --git a/test/lisp/emacs-lisp/cl-types-tests.el b/test/lisp/emacs-lisp/cl-types-tests.el
deleted file mode 100644
index 746270578e7..00000000000
--- a/test/lisp/emacs-lisp/cl-types-tests.el
+++ /dev/null
@@ -1,96 +0,0 @@
-;;; Test `cl-typedef' -*- lexical-binding: t; -*-
-;;
-(require 'ert)
-(require 'cl-types)
-
-(cl-deftype2 multiples-of (&optional m)
-  (let ((multiplep (if (eq m '*)
-                       #'ignore
-                     (lambda (n) (= 0 (% n m))))))
-    `(and integer (satisfies ,multiplep))))
-
-(cl-deftype2 multiples-of-2 ()
-  '(multiples-of 2))
-
-(cl-deftype2 multiples-of-3 ()
-  '(multiples-of 3))
-
-(cl-deftype2 multiples-of-4 ()
-  (declare (parents multiples-of-2))
-  '(and multiples-of-2 (multiples-of 4)))
-
-(cl-deftype2 unsigned-byte (&optional bits)
-  "Unsigned integer."
-  `(integer 0 ,(if (eq bits '*) bits (1- (ash 1 bits)))))
-
-(cl-deftype2 unsigned-16bits ()
-  "Unsigned 16-bits integer."
-  (declare (parents unsigned-byte))
-  '(unsigned-byte 16))
-
-(cl-deftype2 unsigned-8bits ()
-  "Unsigned 8-bits integer."
-  (declare (parents unsigned-16bits))
-  '(unsigned-byte 8))
-
-(cl-defmethod my-foo ((_n unsigned-byte))
-  (format "unsigned"))
-
-(cl-defmethod my-foo ((_n unsigned-16bits))
-  (format "unsigned 16bits - also %s"
-          (cl-call-next-method)))
-
-(cl-defmethod my-foo ((_n unsigned-8bits))
-  (format "unsigned 8bits - also %s"
-          (cl-call-next-method)))
-
-(ert-deftest cl-types-test ()
-  "Test types definition, cl-types-of and method dispatching."
-
-  ;; Invalid DAG error
-  ;; FIXME: We don't test that any more.
-  ;; (should-error
-  ;;  (eval
-  ;;   '(cl-deftype2 unsigned-16bits ()
-  ;;      "Unsigned 16-bits integer."
-  ;;      (declare (parents unsigned-8bits))
-  ;;      '(unsigned-byte 16))
-  ;;   lexical-binding
-  ;;   ))
-
-  ;; Test that (cl-types-of 4) is (multiples-of-4 multiples-of-2 ...)
-  ;; Test that (cl-types-of 6) is (multiples-of-3 multiples-of-2 ...)
-  ;; Test that (cl-types-of 12) is (multiples-of-4 multiples-of-3 multiples-of-2 ...)
-  (let ((types '(multiples-of-2 multiples-of-3 multiples-of-4)))
-    (should (equal '(multiples-of-2)
-                   (seq-intersection (cl-types-of 2) types)))
-
-    (should (equal '(multiples-of-4 multiples-of-2)
-                   (seq-intersection (cl-types-of 4) types)))
-
-    (should (equal '(multiples-of-3 multiples-of-2)
-                   (seq-intersection (cl-types-of 6) types)))
-
-    (should (member (seq-intersection (cl-types-of 12) types)
-                    ;; Order between 3 and 4/2 is undefined.
-                    '((multiples-of-3 multiples-of-4 multiples-of-2)
-                      (multiples-of-4 multiples-of-2 multiples-of-3))))
-
-    (should (equal '()
-                   (seq-intersection (cl-types-of 5) types)))
-    )
-
-  ;;; Method dispatching.
-  (should (equal "unsigned 8bits - also unsigned 16bits - also unsigned"
-                 (my-foo 100)))
-
-  (should (equal "unsigned 16bits - also unsigned"
-                 (my-foo 256)))
-
-  (should (equal "unsigned"
-                 (my-foo most-positive-fixnum)))
-  )
-
-(provide 'cl-types-tests)
-
-;;; cl-types-tests.el ends here