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

[Stefan Monnier]

> I quite like this approach, where it's not `cl-types-of', but each type
> that bears responsibility for its implementation.

Usually, I like to solve a problem centrally so it's done once and for
all, but here the problem is that breaking recursion is tricky business
which may need to be done in different ways in different cases, and on
top of that it's a fairly rare need, so I think in this case dumping the
responsibility onto those rare users of circularity in types is the
right tradeoff.

> So, if I understand correctly, your recommendation is to not try to solve
> recursion (or other) problems in `cl-types-of' at all, but rather at the
> level of each type's definition, and to let ill-defined types possibly
> cause errors?

Basically, yes.

> The only point that still bothers me is not protecting `cl-types-of' from
> errors due to ill-defined types.  This is particularly true because this
> can impact the entire Emacs session if certain methods are prevented from
> working, such as those involved in the display process (I use such methods
> based on `cl-deftype' for example, in my own alternative implementation of
> icons and tab-line).

Fair enough.

I pushed your new code to the `scratch/cl-types` branch in `emacs.git`.
I haven't integrated it into the other CL-Lib files yet.
See patch below for comments on your code.


        Stefan

diff --git a/lisp/emacs-lisp/cl-types.el b/lisp/emacs-lisp/cl-types.el
index 0a384e09d79..830acb1ff0c 100644
--- a/lisp/emacs-lisp/cl-types.el
+++ b/lisp/emacs-lisp/cl-types.el
@@ -46,12 +46,13 @@ cl--type-p
 That is, a type of class `cl-type-class'."
   (and (symbolp object) (cl-type-class-p (cl--find-class object))))
 
-(defmacro cl--type-parents (name)
+(defmacro cl--type-parents (name) ;FIXME: Make it a `defun' or `defsubst'!
   "Get parents of type with NAME.
 NAME is a symbol representing a type."
   `(cl--class-allparents (cl--find-class ,name)))
 
 (defun cl--type-children (name)
+  ;; FIXME: Isn't that he same as `cl--class-children'?
   "Get children of the type with NAME.
 NAME is a symbol representing a type.
 Return a possibly empty list of types."
@@ -82,6 +83,7 @@ cl--type-undefine
   (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 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."
@@ -95,8 +97,13 @@ cl--type-deftype
                   (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))))
           (if (memq name parents)
+              ;; FIXME: This test should be performed in the macro not here.
               (error "Type in parents: %S" parents))
           ;; Setup a type descriptor for NAME.
           (setf (cl--find-class name)
@@ -110,12 +117,21 @@ cl--type-deftype
           ;; 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)
                  (lambda (_) (error "Invalid dependency graph")))))
       (error
        ;; On error restore previous data.
+       ;; FIXME: `cl--type-list' has not been changed yet at this point, AFAIK,
+       ;; so restoring with `oldtlist' is always redundant.
        (setq cl--type-list oldtlist)
        (setf (symbol-plist name) oldplist)
        (error (format "Define %S failed: %s"
@@ -155,16 +171,27 @@ cl-deftype2
       ((`(,decls . ,forms) (macroexp-parse-body body))
        (docstring (if (stringp (car decls))
                       (car decls)
-                    (cadr (assq :documentation decls))))
-       (parents (cdr (assq 'parents (cdr (assq 'declare 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"))
-    (if docstring (setq forms (cons docstring forms)))
     `(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 ,docstring)
        (define-symbol-prop ',name 'cl-deftype-handler
                            (cl-function
                             (lambda (&cl-defs ('*) ,@arglist)
+                              ,@decls
                               ,@forms))))))
 
 ;; Ensure each type satisfies `eql'.
@@ -226,6 +253,9 @@ cl-types-of
   "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."
+  ;; FIXME: The current implementation of `cl--type-parents' is
+  ;; moderately expensive, so we should probably avoid calling it
+  ;; before we do the `gethash'.
   (let ((found (list (cl--type-parents (cl-type-of object)))))
     ;; Build a DAG of all types OBJECT belongs to.
     (dolist (type cl--type-list)
@@ -242,6 +272,9 @@ cl-types-of
        ;; will be faster than `cl-typep'.
        (null (assq type found))
        ;; If OBJECT is of type, add type and its parents to the DAG.
+       ;; FIXME: This `condition-case' will make it harder to get a backtrace
+       ;; to debug the error in the type definition.  So maybe
+       ;; use `condition-case-unless-debug'.
        (condition-case e
            (cl-typep object type)
          (error (cl--type-error type e)))
@@ -254,11 +287,10 @@ cl-types-of
            (push pl found)
            (setq pl (cdr pl))))))
     ;; Compute an ordered list of types from the collected DAG.
-    (setq found (merge-ordered-lists found))
     ;; Return an unique value of this list of types, which is also the
     ;; list of specifiers for this type.
     (with-memoization (gethash found cl--type-unique)
-      found)))
+      (merge-ordered-lists found))))
 
 ;;; Method dispatching
 ;;