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

From: Stefan Monnier <[email-masked]>
Date: Mon, 05 May 2025 14:59:28 -0400

>> Thanks, pushed to the branch.  I think the code is looking pretty good now.
> Thank you, that's great!

I just pushed to the branch a further patch (see attached) which tries
to simplify the code a bit more.

        Stefan
commit 68a50324a70bd794d7f3228290310093f1515f7b
Author: Stefan Monnier <[email-masked]>
Date:   Mon May 5 14:57:05 2025 -0400

    cl-types: Simplify a bit further
    
    Mostly, get rid of `cl--type-flag` and rely only on the presence/absence
    of the type on `cl--types-list` to "flag" erroring-types.
    Also, don't try and catch errors during dispatch.
    
    * lisp/emacs-lisp/cl-types.el (cl--type-dispatch-list): Move to the
    relevant section.
    (cl--type-parents): Inline into sole caller.
    (cl--type-deftype): Add `arglist` argument.
    Don't signal an error if the type already existed but wasn't in
    `cl--type-list` since that's normal and we can fix it.
    Don't touch `cl--type-flag` any more.
    Don't add to `cl--type-list` if it can't be used without arguments.
    (cl-deftype2): Adjust call accordingly.
    (cl--type-error): Inline into sole caller.
    (cl-types-of): Be more careful to preserve ordering of types
    before passing them to `merge-ordered-lists`.
    Add `types` argument for use by dispatch.
    Don't bother skipping the `root-type` since that's a built-in type,
    so it should never happen anyway.
    Don't catch errors if called from dispatch.
    Don't bother with `cl--type-flag`.
    (cl--type-generalizer): Use new arg of `cl-types-of` instead of
    let-binding `cl--type-list`, in case `cl-types-of` ends up (auto)loading
    a file or some such thing which needs to use/modify `cl--type-list`.
    (cl--type-undefine): Move to end of file.
    
    * test/lisp/emacs-lisp/cl-types-tests.el (cl-types-test): Remove DAG
    test since we don't detect such errors any more.
    Relax ordering test when the order is not guaranteed
    by parent-relationships.

diff --git a/lisp/emacs-lisp/cl-types.el b/lisp/emacs-lisp/cl-types.el
index b7816ca3a84..a466c309a33 100644
--- a/lisp/emacs-lisp/cl-types.el
+++ b/lisp/emacs-lisp/cl-types.el
@@ -22,9 +22,6 @@
 (defvar cl--type-list nil
   "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
 ;; compatibility implications, so let's not make that change for now).
@@ -51,71 +48,44 @@ cl--type-p
 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-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)))
-
-;; 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--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?
+(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."
-  (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))))))
+  (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)
@@ -170,7 +140,7 @@ cl-deftype2
        ;; '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 ,docstring)
+       (cl--type-deftype ',name ',parents ',arglist ,docstring)
        (define-symbol-prop ',name 'cl-deftype-handler
                            (cl-function
                             (lambda (&cl-defs ('*) ,@arglist)
@@ -181,17 +151,6 @@ cl-deftype2
 (defvar cl--type-unique (make-hash-table :test 'equal)
   "Record an unique value of each type.")
 
-(defun cl--type-error (type error)
-  "Mark TYPE as in-error, and report the produced ERROR value."
-  ;; Temporarily raise the recursion limit to avoid another recursion
-  ;; error while reporting ERROR.
-  (let ((max-lisp-eval-depth (+ 800 max-lisp-eval-depth)))
-    ;; Mark TYPE as in-error and remove it from the dispatch list.
-    (put type 'cl--type-flag 'error)
-    (setq cl--type-dispatch-list (delq type cl--type-dispatch-list))
-    (warn  "cl-types-of %s, %s" type (error-message-string error)))
-  nil)
-
 ;; 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
@@ -234,59 +193,54 @@ cl--type-error
 ;; - 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)
-"Return the types OBJECT belongs to.
+(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."
-(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)))
+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
-       ;; Skip type, if it previously produced an error.
-       (not (eq flag 'error))
-       ;; 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
+       (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)
-         (error (cl--type-error type e)))
-       (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)))))
+         (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
 ;;
 
-;; 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.
+(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 _) `(let ((cl--type-list cl--type-dispatch-list))
-                           (cl-types-of ,obj)))
+  (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)
@@ -296,6 +250,9 @@ cl-generic-generalizers
         ;; 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
@@ -303,6 +260,21 @@ cl-generic-generalizers
         (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)
 
 ;;; cl-types.el ends here
diff --git a/test/lisp/emacs-lisp/cl-types-tests.el b/test/lisp/emacs-lisp/cl-types-tests.el
index f247ddd89d9..746270578e7 100644
--- a/test/lisp/emacs-lisp/cl-types-tests.el
+++ b/test/lisp/emacs-lisp/cl-types-tests.el
@@ -48,14 +48,15 @@ cl-types-test
   "Test types definition, cl-types-of and method dispatching."
 
   ;; Invalid DAG error
-  (should-error
-   (eval
-    '(cl-deftype2 unsigned-16bits ()
-       "Unsigned 16-bits integer."
-       (declare (parents unsigned-8bits))
-       '(unsigned-byte 16))
-    lexical-binding
-    ))
+  ;; 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 ...)
@@ -70,8 +71,10 @@ cl-types-test
     (should (equal '(multiples-of-3 multiples-of-2)
 		   (seq-intersection (cl-types-of 6) types)))
 
-    (should (equal '(multiples-of-3 multiples-of-4 multiples-of-2)
-		   (seq-intersection (cl-types-of 12) 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)))