From: Stefan Monnier <monnier@iro.umontreal.ca>
Date: Wed, 7 May 2025 17:54:47 +0000 (-0400)
Subject: (cl-deftype): Don't set `cl-deftype-handler` directly
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=66584b1950b83f33fa56bdbb6b3ee41bd1c10c01;p=emacs.git

(cl-deftype): Don't set `cl-deftype-handler` directly

In order to make it easier to change that in the future, let
`cl--define-derived-type` take care of storing the derived
type's function into `cl-deftype-handler`.

* lisp/emacs-lisp/cl-preloaded.el (cl--define-derived-type):
Change calling convention.  Set `cl-deftype-handler`.
* lisp/emacs-lisp/cl-macs.el (cl-deftype): Don't set `cl-deftype-handler`,
instead pass the function to `cl--define-derived-type`.

(cherry picked from commit 9f50fdf1e75040d7feaa1edb235377a33da94781)
---

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index cebecd382cc..7cdf373d54c 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -3753,9 +3753,6 @@ If PARENTS is non-nil, ARGLIST must be nil."
   (declare (debug cl-defmacro) (doc-string 3) (indent 2))
   (pcase-let*
       ((`(,decls . ,forms) (macroexp-parse-body body))
-       (docstring (if (stringp (car decls))
-                      (car decls)
-                      (cadr (assq :documentation decls))))
        (declares (assq 'declare decls))
        (parent-decl (assq 'parents (cdr declares)))
        (parents (cdr parent-decl)))
@@ -3767,12 +3764,10 @@ If PARENTS is non-nil, ARGLIST must be nil."
     (and parents arglist
          (error "Parents specified, but arglist not empty"))
     `(eval-and-compile
-       (cl--define-derived-type ',name ',parents ',arglist ,docstring)
-       (define-symbol-prop ',name 'cl-deftype-handler
-                           (cl-function
-                            (lambda (&cl-defs ('*) ,@arglist)
-                              ,@decls
-                              ,@forms))))))
+       (cl--define-derived-type
+        ',name
+        (cl-function (lambda (&cl-defs ('*) ,@arglist) ,@decls ,@forms))
+        ',parents))))
 
 (static-if (not (fboundp 'cl--define-derived-type))
     nil ;; Can't define it yet!
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 7dac0519681..8956245f24c 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -491,10 +491,11 @@ The fields are used as follows:
      (:copier nil))
   "Type descriptors for derived types, i.e. defined by `cl-deftype'.")
 
-(defun cl--define-derived-type (name parents arglist &optional docstring)
+(defun cl--define-derived-type (name expander &optional parents)
   "Register derived 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."
+EXPANDER is the function that computes the type specifier from
+the arguments passed to the derived type.
+PARENTS is a list of types NAME is a subtype of, or nil."
   (let* ((class (cl--find-class name)))
     (when class
       (or (cl-derived-type-class-p class)
@@ -505,7 +506,9 @@ DOCSTRING is an optional documentation string."
           (error "Type in another class: %S" (type-of class))))
     ;; Setup a type descriptor for NAME.
     (setf (cl--find-class name)
-          (cl--derived-type-class-make name docstring parents))
+          (cl--derived-type-class-make name (function-documentation expander)
+                                       parents))
+    (define-symbol-prop name 'cl-deftype-handler expander)
     ;; 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
@@ -527,7 +530,7 @@ DOCSTRING is an optional documentation string."
     (or (memq name cl--derived-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)))
+        (not (ignore-errors (funcall expander)))
         (push name cl--derived-type-list))))
 
 ;; Make sure functions defined with cl-defsubst can be inlined even in