5 files changed, 73 insertions, 49 deletions

diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi
index 4bceddb8196..a1246b11a8a 100644
--- a/doc/misc/cl.texi
+++ b/doc/misc/cl.texi
@@ -888,8 +888,12 @@ floats.  In all other circumstances, @code{cl-coerce} signals an
 error.
 @end defun
 
-@defmac cl-deftype name arglist forms@dots{}
-This macro defines a new type called @var{name}.  It is similar
+@node Derived types
+@subsection Derived types
+
+@defmac cl-deftype name arglist [docstring] [decls] forms@dots{}
+This macro defines a new type called @var{name}.
+Types defined this way are called @dfn{derived types}.  It is similar
 to @code{defmacro} in many ways; when @var{name} is encountered
 as a type name, the body @var{forms} are evaluated and should
 return a type specifier that is equivalent to the type.  The
@@ -923,6 +927,26 @@ The @code{cl-typecase} (@pxref{Conditionals}) and @code{cl-check-type}
 @code{cl-concatenate}, and @code{cl-merge} functions take type-name
 arguments to specify the type of sequence to return.  @xref{Sequences}.
 
+Contrary to Common Lisp, CL-Lib supports the use of derived types
+as method specializers.  This comes with a significant caveat: derived
+types are much too flexible for Emacs to be able to automatically find
+out which type is a subtype of another, so the ordering of
+methods is not well-defined when several methods are applicable for
+a given argument value and the specializer of one or more of those
+methods is a derived type.  To make the order more well-defined, a derived type
+definition can explicitly state that it is a subtype of others using the
+@var{decls} argument:
+
+@example
+(cl-deftype unsigned-byte (&optional bits)
+  (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))
+@end example
+
 @node Equality Predicates
 @section Equality Predicates
 
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index f232f06718e..b3886b5bde3 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -965,7 +965,7 @@ Outputs to the current buffer."
       (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold))
       (mapc #'cl--describe-class-slot cslots))))
 
-;;;; Method dispatch on `cl-deftype' types.
+;;;; Method dispatch on `cl-deftype' types (a.k.a "derived types").
 
 ;; Extend `cl-deftype' to define data types which are also valid
 ;; argument types for dispatching generic function methods (see also
@@ -978,8 +978,8 @@ Outputs to the current buffer."
 ;; - `cl-types-of', that returns the types an object belongs to.
 
 ;; Ensure each type satisfies `eql'.
-(defvar cl--type-unique (make-hash-table :test 'equal)
-  "Record an unique value of each type.")
+(defvar cl--types-of-memo (make-hash-table :test 'equal)
+  "Memoization table used in `cl-types-of'.")
 
 ;; 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
@@ -1007,9 +1007,12 @@ Outputs to the current buffer."
 ;; 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
+;; have a method that dispatches on a derived type, compared to
 ;; those that don't.
 ;;
+;; As a simple optimization, the method dispatch tests only those
+;; derived types which have been used as a specialize in a method.
+;;
 ;; A possible further improvement:
 ;;
 ;; - based on the PARENTS declaration, create a map from builtin-type
@@ -1019,19 +1022,18 @@ Outputs to the current buffer."
 ;;   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 &optional types)
-  "Return the types OBJECT belongs to.
+  "Return the atomic types OBJECT belongs to.
 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))
     ;; Build a list of all types OBJECT belongs to.
-    (dolist (type (or types cl--type-list))
+    (dolist (type (or types cl--derived-type-list))
       (and
        ;; If OBJECT is of type, add type to the matching list.
        (if types
@@ -1041,25 +1043,28 @@ TYPES is an internal argument."
            (cl-typep object type)
          (condition-case-unless-debug e
              (cl-typep object type)
-           (error (setq cl--type-list (delq type cl--type-list))
+           (error (setq cl--derived-type-list (delq type cl--derived-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,
-    ;; which is also the list of specifiers for OBJECT.
-    (with-memoization (gethash found cl--type-unique)
+    ;; Return the list of types OBJECT belongs to, which is also the list
+    ;; of specifiers for OBJECT. This memoization has two purposes:
+    ;; - Speed up computation.
+    ;; - Make sure we always return the same (eq) object, so that the
+    ;;   method dispatch's own caching works as it should.
+    (with-memoization (gethash found cl--types-of-memo)
       ;; Compute an ordered list of types from the DAG.
       (let (dag)
         (dolist (type found)
           (push (cl--class-allparents (cl--find-class type)) dag))
         (merge-ordered-lists dag)))))
 
-(defvar cl--type-dispatch-list nil
+(defvar cl--derived-type-dispatch-list nil
   "List of types that need to be checked during dispatch.")
 
-(cl-generic-define-generalizer cl--type-generalizer
+(cl-generic-define-generalizer cl--derived-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
@@ -1070,22 +1075,22 @@ TYPES is an internal argument."
   ;; 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 _) `(cl-types-of ,obj cl--type-dispatch-list))
+  (lambda (obj &rest _) `(cl-types-of ,obj cl--derived-type-dispatch-list))
   (lambda (tag &rest _) (if (consp tag) tag)))
 
 ;;;###autoload
-(defun cl--type-generalizers (type)
+(defun cl--derived-type-generalizers (type)
   ;; Add a new dispatch type to the dispatch list, then
-  ;; synchronize with `cl--type-list' so that both lists follow
+  ;; synchronize with `cl--derived-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
-                            (cons type cl--type-dispatch-list))))
-  (list cl--type-generalizer))
+  (unless (memq type cl--derived-type-dispatch-list)
+    (setq cl--derived-type-dispatch-list
+          (seq-intersection cl--derived-type-list
+                            (cons type cl--derived-type-dispatch-list))))
+  (list cl--derived-type-generalizer))
 
 ;;;; Trailer
 
diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index 2de81311380..7d013dfca5f 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -566,14 +566,14 @@ If ALIST is non-nil, the new pairs are prepended to it."
     ;; Also, there is no mechanism to autoload methods, so this can't be
     ;; moved to `cl-extra.el'.
     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))
+  (declare-function cl--derived-type-generalizers "cl-extra" (type))
+  (cl-defmethod cl-generic-generalizers :extra "derived-types" (type)
+    "Support for dispatch on derived types, i.e. defined with `cl-deftype'."
+    (if (and (symbolp type) (cl-derived-type-class-p (cl--find-class type))
              ;; Make sure this derived type can be used without arguments.
              (let ((expander (get type 'cl-deftype-handler)))
-               (and expander (ignore-errors (funcall expander)))))
-        (cl--type-generalizers type)
+               (and expander (with-demoted-errors "%S" (funcall expander)))))
+        (cl--derived-type-generalizers type)
       (cl-call-next-method))))
 
 (defun cl--old-struct-type-of (orig-fun object)
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 424ebe2c7ad..0fc791890aa 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -3785,7 +3785,7 @@ macro that returns its `&whole' argument."
 
 ;;;###autoload
 (defmacro cl-deftype (name arglist &rest body)
-  "Define NAME as a new data type.
+  "Define NAME as a new, so-called derived type.
 The type NAME can then be used in `cl-typecase', `cl-check-type',
 etc., and to some extent, as method specializer.
 
@@ -3816,20 +3816,15 @@ If PARENTS is non-nil, ARGLIST must be nil."
         (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)
+    `(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))))))
 
-(static-if (not (fboundp 'cl--type-deftype))
+(static-if (not (fboundp 'cl--define-derived-type))
     nil ;; Can't define it yet!
   (cl-deftype extended-char () '(and character (not base-char))))
 
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 0447191bbc7..7dac0519681 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -467,18 +467,18 @@ The fields are used as follows:
 
 ;;;; Support for `cl-deftype'.
 
-(defvar cl--type-list nil
+(defvar cl--derived-type-list nil
   "Precedence list of the defined cl-types.")
 
 ;; 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
+    (cl-derived-type-class
      (:include cl--class)
      (:noinline t)
      (:constructor nil)
-     (:constructor cl--type-class-make
+     (:constructor cl--derived-type-class-make
                    (name
                     docstring
                     parent-types
@@ -489,15 +489,15 @@ The fields are used as follows:
                                  (error "Unknown type: %S" type)))
                            parent-types))))
      (:copier nil))
-  "Type descriptors for types defined by `cl-deftype'.")
+  "Type descriptors for derived types, i.e. defined by `cl-deftype'.")
 
-(defun cl--type-deftype (name parents arglist &optional docstring)
-  "Register cl-type with NAME for method dispatching.
+(defun cl--define-derived-type (name parents arglist &optional docstring)
+  "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."
   (let* ((class (cl--find-class name)))
     (when class
-      (or (cl-type-class-p class)
+      (or (cl-derived-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
@@ -505,11 +505,11 @@ 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--type-class-make name docstring parents))
+          (cl--derived-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').
+    ;; the `cl--derived-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
@@ -524,11 +524,11 @@ DOCSTRING is an optional documentation string."
     ;; `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)
+    (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)))
-        (push name cl--type-list))))
+        (push name cl--derived-type-list))))
 
 ;; Make sure functions defined with cl-defsubst can be inlined even in
 ;; packages which do not require CL.  We don't put an autoload cookie