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

From: David Ponce <[email-masked]>
Date: Tue, 6 May 2025 18:54:01 +0200

On 2025-05-06 17:55, Stefan Monnier wrote:
>>   Debugger entered--Lisp error: (void-function kmacro-register-p)
>>    kmacro-register-p(2)
>>    cl-typep(2 (satisfies kmacro-register-p))
>>    cl-typep(2 kmacro-register)
>>    cl-types-of(2)
>>    (seq-intersection (cl-types-of 2) types)
>>    [...]
> 
> That's an incorrect `cl-deftype` call.  AFAIK this was in `register.el`
> but I actually removed it from there with:
> 
>      commit b1407b41a16c4a3ec15c88be91ba0ae1e65c212e
>      Author: Stefan Monnier <[email-masked]>
>      Date:   Tue Apr 29 16:04:54 2025 -0400
>      
>          register.el: Remove bogus deftypes and fix associated methods
>          
>          * lisp/register.el (frame-register, kmacro-register): Remove bogus deftypes.
>          (register--type) <oclosure>: Fix kmacro method and generalize it to
>          any OClosure.
>          (register--type) <frameset-register>: Fix method and move it to ...
>          * lisp/frameset.el (register--type) <frameset-register>: ... here,
>          where `frameset-register` is defined.
> 
> I guess I need to rebase the `cl-types` branch.  🙂

I also see a similar error with type `frame-register':

"cl-types-of frame-register: Symbol’s function definition is void: frameset-register-p"

> 
>>>> (cl-types-of 'button) => button match `icon' type, so the `cl--type-flag'
>>>> of `icon' is set to `symbol' (cl-type-of or root-type of `button')
>>>>
>>>> (cl-types-of 12) => `root-type' of 12 is `fixnum', so cl-types-of doesn't
>>>> waste time checking if 12 if of type `icon', because we are sure it cannot
>>>> match (their root-types are different).  An so on with other types whose
>>>> root-type is known.
>>> That makes a lot of sense, indeed.
>>> But ... does it work for:
>>>      (cl-deftype my-pair ()
>>>        `(and number (satisfies ,(lambda (x) (zerop (logand x 1))))))
>>> (cl-types-of (expt 2 128)) => (expt 2 128) matches `my-pair` type, so
>>> the `cl--type-flag` of `my-pair` is set to `bignum`.  Now when I try
>>> (cl-types-of 4) won't it skip `my-pair` because (cl-type-of 4) is not
>>> `bignum`?  What am I missing?
>>
>> Good point! The problem is that the type returned by `cl-type-of' is too
>> specific. If I instead use `type-of' to map a set of cl-types to a
>> built-in type, your example above works as expected, as do other
>> categories I've tested, like symbol, cons, string, etc.
>> Using `type-of' to determine a set of cl-types seems like a good
>> compromise to me. WDYT?
> 
> That just solves some occurrences, but not all:
> 
>       (cl-deftype my-pair-length ()
>         `(and sequence (satisfies ,(lambda (x) (zerop (logand (length x) 1))))))
> 
> and now (cl-types-of [1 2]) will set `cl--type-flag` to
> `vector` so (cl-types-of "ab") will miss `my-pair-length`!
> 
> If you want more cases, think of
> 
>      (cl-deftype my-foo ()
>        '(or TYPE1 TYPE2))

Of course, you are right ;-)

I guess a general solution is much more complex than what I thought.  And maybe
risk to be more costly than the current implementation without set of cl-types.

Please find attached a patch proposal for the branch.  Mainly to
ensure that types not suitable for cl-defmethod (erroneous type or
type with arguments) will signal an "Unknown specializer" error when
trying to use them as argument type in cl-defmethod.  Also to improve
handling of errors with recursive types that can lead to error in the
error handler in `cl-types-of', because the maximum recursion limit is
reached.

2025-05-06  David Ponce  <[email-masked]>

	* lisp/emacs-lisp/cl-lib.el (cl-generic-generalizers :extra
	"cl-types-of"): Fix indentation.

	* lisp/emacs-lisp/cl-macs.el (cl-deftype): Don't register types
	that can't be used without arguments, so they are not valid types
	for method arguments.

	* lisp/emacs-lisp/cl-extra.el (cl--type-dispatch-list): Move
	definition before first use.
	(cl-types-of): Temporarily raise the recursion limit in error
	handler.  Remove the type in error from valid specializers.

	* lisp/emacs-lisp/cl-preloaded.el (cl--type-deftype): Remove the
	ARGLIST argument, no more used.  Don't exclude here types that
	can't be used without arguments.

Thanks!

diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index bd7bb96dd6a..1a628358b52 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -981,6 +981,9 @@ cl--describe-class-slots
 (defvar cl--type-unique (make-hash-table :test 'equal)
   "Record an unique value of each type.")
 
+(defvar cl--type-dispatch-list nil
+  "List of types that need to be checked during dispatch.")
+
 ;; 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
@@ -1029,21 +1032,28 @@ cl-types-of
 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))
+  (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.
+           ;; 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)))))
+           (error
+            ;; Temporarily raise the recursion limit to avoid
+            ;; another recursion error while processing error.
+            (let ((max-lisp-eval-depth (+ 800 max-lisp-eval-depth)))
+              ;; Remove the type in error from valid specializers.
+              (cl-remprop type 'cl--class)
+              (setq cl--type-dispatch-list (delq type cl--type-dispatch-list))
+              (setq cl--type-list (delq type cl--type-list))
+              (warn  "cl-types-of %S: %s" type (error-message-string e))
+              nil))))
        (push type found)))
     (push (cl-type-of object) found)
     ;; Return an unique value of the list of types OBJECT belongs to,
@@ -1054,9 +1064,6 @@ cl-types-of
        (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),
diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index ff014965eb9..118dc72658c 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -568,10 +568,10 @@ cl-pairlis
     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))))
+    "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)
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 424ebe2c7ad..09bcfa80b77 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -3816,18 +3816,22 @@ cl-deftype
         (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))))))
+    ;; Don't register types that can't be used without arguments for
+    ;; dispatch.  They'd signal errors in `cl-types-of'!
+    (let ((noarg (memq (car arglist) '(nil &rest &optional &keys))))
+      ;;(or noarg (message "Can't dispatch type with argument, `%S'" name))
+      `(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.
+         ,@(if noarg `((cl--type-deftype ',name ',parents ,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!
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 0447191bbc7..f4ea4756d0c 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -491,7 +491,7 @@ cl--type-list
      (:copier nil))
   "Type descriptors for types defined by `cl-deftype'.")
 
-(defun cl--type-deftype (name parents arglist &optional docstring)
+(defun cl--type-deftype (name parents &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."
@@ -525,9 +525,6 @@ cl--type-deftype
     ;; 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