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

From: Stefan Monnier <[email-masked]>
Date: Tue, 22 Apr 2025 17:34:17 -0400

>> Yes, as you've seen, the placement can be tricky.  There are bootstrap
>> constraints as well as "general design" desires, and they all kind
>> of pull in different directions.
>> I'll take a closer look and come back with a proposal.
> Great. Thank you!

Sorry for the delay, here's what I came up with.

I added a FIXME about the recursion-breaker which I have a feeling might
not work.

There's also some stylistic problems with the tests:

- We shouldn't test the return value of `cl-deftype`: I don't think it's
  documented anywhere and I don't think it's good practice to pay
  attention to the return value of declarations.
- They use `eval` too much.

        Stefan

diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 6390d17a5b7..eb2ad605c8e 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -577,8 +577,8 @@ cl-subseq
 			,new)))))
   (seq-subseq seq start end))
 
-;;; This isn't a defalias because autoloading defaliases doesn't work
-;;; very well.
+;; This isn't a defalias because autoloading defaliases doesn't work
+;; very well.
 
 ;;;###autoload
 (defun cl-concatenate (type &rest sequences)
@@ -731,6 +731,213 @@ cl-prettyexpand
       (cl-prettyprint form)
     (message "")))
 
+;;; CL type defined via `deftype'.
+
+(defvar cl--type-list nil
+  "List of defined types to lookup for method dispatching.")
+
+;; 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 used defined type.
+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)
+  "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)
+  "Get children of the type with NAME.
+NAME is a symbol representing a type.
+Return a possibly empty list of types."
+  (cl-check-type name (satisfies cl--type-p))
+  (let (children)
+    (dolist (elt cl--type-list)
+      (or (eq name elt)
+          (if (memq name (cl--type-parents elt))
+              (push elt children))))
+    children))
+
+;; Keep it for now, for testing.
+(defun cl--type-undefine (name)
+  "Remove the definitions of type with NAME.
+NAME is an unquoted symbol representing a type.
+Signal an error if other types inherit from NAME."
+  (declare-function cl-remprop "cl-extra" (symbol propname))
+  (cl-check-type name (satisfies cl--type-p))
+  (when-let* ((children (and (cl--type-p name)
+                             (cl--type-children name))))
+    (error "Type has children: %S" children))
+  (cl-remprop name 'cl--class)
+  (cl-remprop name 'cl-deftype-handler)
+  (setq cl--type-list (delq name cl--type-list)))
+
+;;;###autoload
+(defun cl--type-deftype (name parents &optional docstring)
+  "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."
+  (let ((oldplist (copy-sequence (symbol-plist name))))
+    (condition-case err
+        (let* ((class (cl--find-class name))
+               (recorded (memq name cl--type-list)))
+          (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)
+                (error "Type in another class: %S" (type-of class))))
+          (if (memq name parents)
+              (error "Type in parents: %S" parents))
+          ;; Setup a type descriptor for NAME.
+          (setf (cl--find-class name)
+                (cl--type-class-make name docstring parents))
+          ;; `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.
+          (setq cl--type-list
+                (merge-ordered-lists
+                 (mapcar (lambda (type)
+                           (cl--class-allparents (cl--find-class type)))
+                         (if recorded
+                             cl--type-list
+                           (cons name cl--type-list)))
+                 (lambda (_) (error "Invalid dependency graph")))))
+      (error
+       ;; On error restore previous data.
+       (setf (symbol-plist name) oldplist)
+       (error (format "Define %S failed: %s"
+                      name (error-message-string err)))))))
+
+(defvar cl--type-object (make-symbol "void"))
+;; 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)
+  "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."
+  ;; Ignore recursive call on the same OBJECT, which can legitimately
+  ;; occur when a parent type is checking whether an object's type is
+  ;; that of one of its children.
+  ;; FIXME: Does this even work?  Won't `cl--type-object' be rebound to
+  ;; the other object before we get here?  IOW wouldn't we need a list
+  ;; of objects that are in the process of being checked?  And while
+  ;; returning nil breaks the recursion, won't it return a bogus result?
+  (unless (eq object cl--type-object)
+    (let ((cl--type-object object)
+          (found (list (cl--type-parents (cl-type-of object)))))
+      ;; Build a DAG of all types OBJECT belongs to.
+      (dolist (type cl--type-list)
+        (and
+         ;; 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))
+         ;; If OBJECT is of type, add type and parents to the DAG.
+         (cl-typep object type)
+         ;; (dolist (p (cl--type-parents type))
+         ;;   (push (cl--type-parents p) found))
+         ;; Equivalent to the `dolist' above, but faster: avoid to
+         ;; recompute several lists of parents we already know.
+         (let ((pl (cl--type-parents type)))
+           (while pl
+             (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))))
+
+(cl-deftype extended-char () '(and character (not base-char)))
+
+;;;; Method dispatching
+
+(cl-generic-define-generalizer cl--type-generalizer
+  20 ;; "typeof" < "cl-types-of" < "head" priority
+  (lambda (obj &rest _) `(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 types."
+  (if (cl--type-p type)
+      (list cl--type-generalizer)
+    (cl-call-next-method)))
+
 ;;; Integration into the online help system.
 
 (eval-when-compile (require 'cl-macs))  ;Explicitly, for cl--find-class.
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 8de45626bf0..af38f432e84 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -582,6 +582,7 @@ cl-defmethod
          (,'declare-function ,name "")
          ;; We use #' to quote `name' so as to trigger an
          ;; obsolescence warning when applicable.
+         ;; FIXME: Eval `eql'and `head' thingies!
          (cl-generic-define-method #',name ',(nreverse qualifiers) ',args
                                    ',call-con ,fun)))))
 
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index a966ec5eaf6..1bd3ab55519 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -3786,15 +3786,46 @@ cl--compiler-macro-get
 ;;;###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."
+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-deftype unsigned-byte (&optional bits)
+    \"Unsigned integer.\"
+    (list \\='integer 0 (if (eq bits \\='*) bits (1- (ash 1 bits)))))
+
+  (cl-deftype 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."
   (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)))))
-
-(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.
+  (pcase-let*
+      ((`(,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))))))
+    (and parents arglist
+         (error "Parents specified, but arglist not empty"))
+    (if docstring (setq forms (cons docstring forms)))
+    `(cl-eval-when (compile load eval)
+       (cl--type-deftype ',name ',parents ,docstring)
+       (define-symbol-prop ',name 'cl-deftype-handler
+                           (cl-function
+                            (lambda (&cl-defs ('*) ,@arglist)
+                              ,@forms))))))
 
 ;;; Additional functions that we can now define because we've defined
 ;;; `cl-defsubst' and `cl-typep'.
diff --git a/test/lisp/emacs-lisp/cl-extra-tests.el b/test/lisp/emacs-lisp/cl-extra-tests.el
index 20d1e532a6f..08198faf28c 100644
--- a/test/lisp/emacs-lisp/cl-extra-tests.el
+++ b/test/lisp/emacs-lisp/cl-extra-tests.el
@@ -348,4 +348,156 @@ cl-extra-test-tailp
     (should (cl-tailp l l))
     (should (not (cl-tailp '(4 5) l)))))
 
+(ert-deftest cl-types-test-1 ()
+  "Test types definition and cl-types-of."
+
+  (should
+   (functionp
+    (eval
+     '(cl-deftype multiples-of (&optional m)
+        (let ((multiplep (if (eq m '*)
+                             #'ignore
+                           (lambda (n) (= 0 (% n m))))))
+          `(and integer (satisfies ,multiplep))))
+     t)))
+
+  (should
+   (functionp
+    (eval
+     '(cl-deftype multiples-of-2 ()
+        '(multiples-of 2))
+     t)))
+
+  (should
+   (functionp
+    (eval
+     '(cl-deftype multiples-of-3 ()
+        '(multiples-of 3))
+     t)))
+
+  (should
+   (functionp
+    (eval
+     '(cl-deftype multiples-of-4 ()
+        (declare (parents multiples-of-2))
+        '(and multiples-of-2 (multiples-of 4)))
+     t)))
+
+  ;; 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 ...)
+  (should
+   (equal
+    (cl-types-of 2)
+    '( multiples-of-2 fixnum integer number integer-or-marker
+       number-or-marker atom t)))
+
+  (should
+   (equal
+    (cl-types-of 4)
+    '( multiples-of-4 multiples-of-2 fixnum integer number
+       integer-or-marker number-or-marker atom t)
+    ))
+
+  (should
+   (equal
+    (cl-types-of 6)
+    '( multiples-of-3 multiples-of-2 fixnum integer number
+       integer-or-marker number-or-marker atom t)
+    ))
+
+  (should
+   (equal
+    (cl-types-of 12)
+    '( multiples-of-3 multiples-of-4 multiples-of-2 fixnum integer
+       number integer-or-marker number-or-marker atom t)
+    ))
+
+  (should
+   (equal
+    (cl-types-of 5)
+    '(fixnum integer number integer-or-marker number-or-marker atom t)
+    ))
+
+  ;; Cleanup
+  (mapc #'cl--type-undefine cl--type-list)
+
+  )
+
+(ert-deftest cl-types-test-2 ()
+  "Test types definition and dispatch."
+
+  (should
+   (functionp
+    (eval
+     '(cl-deftype unsigned-byte (&optional bits)
+        "Unsigned integer."
+        `(integer 0 ,(if (eq bits '*) bits (1- (ash 1 bits)))))
+     t)))
+
+  (should
+   (functionp
+    (eval
+     '(cl-deftype unsigned-16bits ()
+        "Unsigned 16-bits integer."
+        (declare (parents unsigned-byte))
+        '(unsigned-byte 16))
+     t)))
+
+  (should
+   (functionp
+    (eval
+     '(cl-deftype unsigned-8bits ()
+        "Unsigned 8-bits integer."
+        (declare (parents unsigned-16bits))
+        '(unsigned-byte 8))
+     t)))
+
+  ;; Invalid DAG error
+  (should-error
+   (eval
+    '(cl-deftype unsigned-16bits ()
+       "Unsigned 16-bits integer."
+       (declare (parents unsigned-8bits))
+       '(unsigned-byte 16))
+    t))
+
+  (eval
+   '(cl-defmethod my-foo ((_n unsigned-byte))
+      (format "unsigned"))
+   t)
+
+  (eval
+   '(cl-defmethod my-foo ((_n unsigned-16bits))
+      (format "unsigned 16bits - also %s"
+              (cl-call-next-method)))
+   t)
+
+  (eval
+   '(cl-defmethod my-foo ((_n unsigned-8bits))
+      (format "unsigned 8bits - also %s"
+              (cl-call-next-method)))
+   t)
+
+  (should
+   (equal
+    (my-foo 100)
+    "unsigned 8bits - also unsigned 16bits - also unsigned"
+    ))
+
+  (should
+   (equal
+    (my-foo 256)
+    "unsigned 16bits - also unsigned"
+    ))
+
+  (should
+   (equal
+    (my-foo most-positive-fixnum)
+    "unsigned"
+    ))
+  ;; Cleanup
+  (mapc #'cl--type-undefine cl--type-list)
+  )
+
 ;;; cl-extra-tests.el ends here