Subject: bug#77725: 31.0.50; Add support for types accepted by `cl-typep' to cl-generic?

From: David Ponce <[email-masked]>
Date: Fri, 2 May 2025 11:24:24 +0200

> 
> Please find attached a version of cl-types.el with my first try at
> implementing something related to your idea above to populate a
> `cl--type-dispatch-list' from `cl-generic-generalizers'.

See attached my current local changes as a diff w.r.t. the `scratch/cl-types` branch.
And a possible change log:

2025-05-02  David Ponce  <[email-masked]>
	    Stefan Monnier <[email-masked]>

	* lisp/emacs-lisp/cl-types.el (cl--type-list): Doc string.
	(cl--type-dispatch-list): New variable.
	(cl--type-parents): Make it a plain defun.
	(cl--type-children, cl--type-dag): Remove.
	(cl--type-undefine): Remove duplicate test for `cl--type-p'.  Use
	`cl--class-children'.  Clear `cl--type-flag' instead of
	`cl--type-error'.  Also remove type from the dispatch list.
	(cl--type-deftype): Doc string.  Remove useless safeguard of
	data on error.  Fix some error messages.  Clear `cl--type-flag'
	when a type is (re)defined.  Just push new types on
	`cl--type-list'.
	(cl--type-error): Set `cl--type-flag' to the symbol `error'.
	(cl-types-of): Doc string.  Remove useless check for
	`cl-type-class-p'.  Skip types which we are sure will not match.
	Simplify creation of the DAG.
	(cl--type-generalizer): In the tagcode-function, check only types
	that can be dispatched.
	(cl-generic-generalizers): Populate the dispatch list.

Thanks!
David

diff --git a/lisp/emacs-lisp/cl-types.el b/lisp/emacs-lisp/cl-types.el
index c10ce4a24fb..987e38ab880 100644
--- a/lisp/emacs-lisp/cl-types.el
+++ b/lisp/emacs-lisp/cl-types.el
@@ -20,7 +20,10 @@
 ;; - `cl-types-of', that returns the types an object belongs to.
 
 (defvar cl--type-list nil
-  "List of defined types to lookup for method dispatching.")
+  "Precedence list of the defined cl-types.")
+
+(defvar cl--type-dispatch-list nil
+  "List of types that need to be checked during dispatch.")
 
 ;; FIXME: The `cl-deftype-handler' property should arguably be turned
 ;; into a field of this struct (but it has performance and
@@ -48,83 +51,71 @@
 That is, a type defined by `cl-deftype', of class `cl-type-class'."
   (and (symbolp object) (cl-type-class-p (cl--find-class object))))
 
-(defsubst cl--type-parents (name)
+(defun cl--type-parents (name)
   "Get parents of type with NAME.
 NAME is a symbol representing a type.
 Return a possibly empty list of types."
   (cl--class-allparents (cl--find-class name)))
 
-(defsubst cl--type-children (name)
-  "Get children of the type with NAME.
-NAME is a symbol representing a type.
-Return a possibly empty list of types."
-  (cl--class-children (cl--find-class name)))
-
-(defsubst cl--type-dag (types)
-  "Return a DAG from the list of TYPES."
-  (mapcar #'cl--type-parents types))
-
 ;; 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 (and (cl--type-p name)
-                             (cl--type-children name))))
+  (when-let* ((children (cl--class-children (cl--find-class name))))
     (error "Type has children: %S" children))
-  (cl-remprop name 'cl--type-error)
+  (cl-remprop name 'cl--type-flag)
   (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)))
 
 (defun cl--type-deftype (name parents &optional docstring)
   ;; FIXME: Should we also receive the arglist?
-  "Generalize cl-type with NAME for method dispatching.
+  "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 ((typelist cl--type-list)
-        (oldplist (copy-sequence (symbol-plist name))))
-    (condition-case err
-        (let* ((class (cl--find-class name))
-               (recorded (memq name typelist)))
-          (if (null class)
-              (or (null recorded)
-                  (error "Type generalized, but doesn't exist"))
-            (or recorded (error "Type exists, but not generalized"))
-            (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))
-          (if recorded
-              ;; Clear any previous error mark.
-              (cl-remprop name 'cl--type-error)
-            ;; Record new type to include its dependency in the DAG.
-            (push name typelist))
-          ;; `cl-types-of' iterates through all known types to collect
-          ;; all those an object belongs to, sorted from the most
-          ;; specific type to the more general type.  So, keep the
-          ;; global list in this order.
-          ;; FIXME: This global operation is a bit worrisome, because it
-          ;; scales poorly with the number of types.  I guess it's OK
-          ;; for now because `cl-deftype' is not very popular, but it'll
-          ;; probably need to be replaced at some point.  Maybe we
-          ;; should simply require that the parents be defined already,
-          ;; then we can just `push' the new type, knowing it's in
-          ;; topological order by construction.
-          (setq cl--type-list
-                (merge-ordered-lists
-                 (cl--type-dag typelist)
-                 (lambda (_) (error "Invalid dependency graph")))))
-      (error
-       (setf (symbol-plist name) oldplist)
-       (error (format "Define %S failed: %s"
-                      name (error-message-string err)))))))
+  (condition-case err
+      (let* ((class (cl--find-class name))
+             (recorded (memq name cl--type-list)))
+        (if (null class)
+            (or (null recorded)
+                (error "Type registered, but doesn't exist"))
+          (or recorded (error "Type exists, but not registered"))
+          (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))
+        ;; Reset NAME as a newly defined type.
+        (cl-remprop name 'cl--type-flag)
+        ;; 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 recorded (push name cl--type-list)))
+    (error
+     (error (format "Define %S failed: %s"
+                    name (error-message-string err))))))
 
 ;;;###autoload
 (defmacro cl-deftype2 (name arglist &rest body)
@@ -192,7 +183,7 @@ If PARENTS is non-nil, ARGLIST must be nil."
 
 (defun cl--type-error (type error)
   "Mark TYPE as in-error, and report the produced ERROR value."
-  (put type 'cl--type-error error) ;; Mark TYPE as in-error.
+  (put type 'cl--type-error 'error) ;; Mark TYPE as in-error.
   ;; Temporarily raise the recursion limit to avoid another recursion
   ;; error while reporting ERROR.
   (let ((max-lisp-eval-depth (+ 800 max-lisp-eval-depth)))
@@ -242,55 +233,72 @@ If PARENTS is non-nil, ARGLIST must be nil."
 ;;   to find which cl-types may need to be checked.
 ;;
 (defun cl-types-of (object)
-  "Return the types OBJECT belongs to.
+"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."
-  (let (found)
-    ;; Build a list of all types OBJECT belongs to.
-    (dolist (type cl--type-list)
+(let* ((root-type (cl-type-of object))
+       (found (list root-type)))
+  ;; Build a list of all types OBJECT belongs to.
+  (dolist (type cl--type-list)
+    (let ((flag (get type 'cl--type-flag)))
       (and
        ;; Skip type, if it previously produced an error.
        (null (get type 'cl--type-error))
-       ;; Skip type not defined by `cl-deftype'.
-       (cl-type-class-p (cl--find-class type))
-       ;; If BAR is declared as a parent of FOO and `cl-types-of' has
-       ;; already decided that the value is of type FOO, then we
-       ;; already know BAR will be in the output anyway and there's no
-       ;; point testing BAR.  So, skip type already selected as parent
-       ;; of another type, assuming that, most of the time, `assq'
-       ;; will be faster than `cl-typep'.
-       (null (assq type found))
+       ;; Skip type which we are sure will not match.
+       (or (null flag) (eq flag root-type))
        ;; If OBJECT is of type, add type to the matching list.
        (condition-case-unless-debug e
            (cl-typep object type)
          (error (cl--type-error type e)))
-       (push type 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 a DAG from the collected matching types.
-      (let (dag)
-        (dolist (type found)
-          (let ((pl (cl--type-parents type)))
-            (while pl
-              (push pl dag)
-              (setq pl (cdr pl)))))
-        ;; Compute an ordered list of types from the DAG.
-        (merge-ordered-lists
-         (nreverse (cons (cl--type-parents (cl-type-of object))
-                         dag)))))))
+       (or flag (put type 'cl--type-flag root-type))
+       (push type 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 #'cl--type-parents found)))))
 
 ;;; Method dispatching
 ;;
+
+;; For a declaration like
+;;
+;;   (cl-deftype list-of (elem-type)
+;;     `(and list
+;;           (satisfies ,(lambda (list)
+;;                         (cl-every (lambda (elem)
+;;                                     (cl-typep elem elem-type))
+;;                                   list)))))
+;;
+;; we add the type to `cl--type-list' even though it's unusable there
+;; (the `cl-typep` call in `cl-types-of' will always signal an error
+;; because the type can't be used without argument).
+;;
+;; One way to solve this (and even open up the possibility to
+;; dispatch on complex types like `(list-of FOO)') is to populate
+;; `cl--type-dispatch-list' (i.e. the list of types that need to
+;; be checked during dispatch) from `cl-generic-generalizers' so it
+;; includes only those types for which there's a method, rather than
+;; all defined types.
+
 (cl-generic-define-generalizer cl--type-generalizer
   20 ;; "typeof" < "cl-types-of" < "head" priority
-  (lambda (obj &rest _) `(cl-types-of ,obj))
+  (lambda (obj &rest _) `(let ((cl--type-list cl--type-dispatch-list))
+                           (cl-types-of ,obj)))
   (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)
-      (list cl--type-generalizer)
+      (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.
+        (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)))
 
 (provide 'cl-types)