master bd017175d45 6/6: Simplify type hierarchy operations

[Stefan Monnier]

branch: master
commit bd017175d4571e24ef1fdf84676136af1d36002d
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    Simplify type hierarchy operations
    
    Now that built-in types have classes that describe their
    relationships exactly like struct/eieio/oclosure classes,
    we can the code that navigates that DAG.
    
    * lisp/emacs-lisp/cl-generic.el (cl--generic-struct-tag): Move to
    `eieio-core.el`.
    (cl--generic-type-specializers): Rename from
    `cl--generic-struct-specializers`.  Make it work for any class.
    (cl--generic-typeof-generalizer, cl--generic-oclosure-generalizer): Use it.
    (cl--generic-struct-generalizer): Delete generalizer.
    (cl-generic-generalizers :extra "cl-struct"): Delete method.
    (prefill 0 cl--generic-generalizer): Move to after the typeof.
    (cl-generic-generalizers :extra "typeof"): Rewrite to use
    classes rather than `cl--all-builtin-types`.
    (cl-generic--oclosure-specializers): Delete function.
    
    * lisp/emacs-lisp/cl-preloaded.el (cl--direct-supertypes-of-type)
    (cl--typeof-types, cl--all-builtin-types): Delete constants.
    
    * lisp/emacs-lisp/comp-cstr.el (comp--typeof-builtin-types):
    Delete constant.
    (comp--cl-class-hierarchy): Simplify.
    (comp--compute-typeof-types): Simplify now that
    `comp--cl-class-hierarchy` and `comp--all-classes` work for built-in
    types as well.
    (comp--direct-supertypes): Just use `cl--class-parents`.
    (comp-supertypes): Simplify since typeof-types should now be complete.
    
    * lisp/emacs-lisp/eieio-core.el (eieio-defclass-autoload):
    Use `superclasses` argument, so we can find parents before it's loaded.
    (eieio--class-precedence-c3, eieio--class-precedence-dfs):
    Don't add a `eieio-default-superclass` parent any more.
    (eieio--class/struct-parents): Delete function.
    (eieio--class-precedence-bfs): Use `eieio--class-parents` instead.
    Don't stop when reaching `eieio-default-superclass`.
    (cl--generic-struct-tag): Move from `cl-generic.el`.
---
 lisp/emacs-lisp/cl-generic.el   | 67 ++++++++++-------------------------------
 lisp/emacs-lisp/cl-preloaded.el | 30 ------------------
 lisp/emacs-lisp/comp-cstr.el    | 55 +++++----------------------------
 lisp/emacs-lisp/eieio-core.el   | 51 +++++++++++++++----------------
 4 files changed, 49 insertions(+), 154 deletions(-)

diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index f439a97f88c..84eb800ec24 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -1330,62 +1330,31 @@ These match if the argument is `eql' to VAL."
 (cl--generic-prefill-dispatchers (terminal-parameter nil 'xterm--set-selection)
                                  (eql nil))
 
-;;; Support for cl-defstructs specializers.
+;;; Dispatch on "normal types".
 
-(defun cl--generic-struct-tag (name &rest _)
-  ;; Use exactly the same code as for `typeof'.
-  `(if ,name (type-of ,name) 'null))
-
-(defun cl--generic-struct-specializers (tag &rest _)
+(defun cl--generic-type-specializers (tag &rest _)
   (and (symbolp tag)
-       (let ((class (get tag 'cl--class)))
-         (when (cl-typep class 'cl-structure-class)
+       (let ((class (cl--find-class tag)))
+         (when class
            (cl--class-allparents class)))))
 
-(cl-generic-define-generalizer cl--generic-struct-generalizer
-  50 #'cl--generic-struct-tag
-  #'cl--generic-struct-specializers)
-
-(cl-defmethod cl-generic-generalizers :extra "cl-struct" (type)
-  "Support for dispatch on types defined by `cl-defstruct'."
-  (or
-   (when (symbolp type)
-     ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than
-     ;; the "cl-struct-*" variants which aren't inlined, so that dispatch can
-     ;; take place without requiring cl-lib.
-     (let ((class (cl--find-class type)))
-       (and (cl-typep class 'cl-structure-class)
-            (or (null (cl--struct-class-type class))
-               (error "Can't dispatch on cl-struct %S: type is %S"
-                     type (cl--struct-class-type class)))
-            (progn (cl-assert (null (cl--struct-class-named class))) t)
-            (list cl--generic-struct-generalizer))))
-   (cl-call-next-method)))
-
-(cl--generic-prefill-dispatchers 0 cl--generic-generalizer)
-
-;;; Dispatch on "system types".
-
 (cl-generic-define-generalizer cl--generic-typeof-generalizer
   ;; FIXME: We could also change `type-of' to return `null' for nil.
   10 (lambda (name &rest _) `(if ,name (type-of ,name) 'null))
-  (lambda (tag &rest _)
-    (and (symbolp tag) (assq tag cl--typeof-types))))
+  #'cl--generic-type-specializers)
 
 (cl-defmethod cl-generic-generalizers :extra "typeof" (type)
-  "Support for dispatch on builtin types.
-See the full list and their hierarchy in `cl--typeof-types'."
+  "Support for dispatch on types.
+This currently works for built-in types and types built on top of records."
   ;; FIXME: Add support for other types accepted by `cl-typep' such
   ;; as `character', `face', `function', ...
   (or
-   (and (memq type cl--all-builtin-types)
-        (progn
-          ;; FIXME: While this wrinkle in the semantics can be occasionally
-          ;; problematic, this warning is more often annoying than helpful.
-          ;;(if (memq type '(vector array sequence))
-          ;;    (message "`%S' also matches CL structs and EIEIO classes"
-          ;;             type))
-          (list cl--generic-typeof-generalizer)))
+   (and (symbolp type)
+        (not (eq type t)) ;; Handled by the `t-generalizer'.
+        (let ((class (cl--find-class type)))
+          (memq (type-of class)
+                '(built-in-class cl-structure-class eieio--class)))
+        (list cl--generic-typeof-generalizer))
    (cl-call-next-method)))
 
 (cl--generic-prefill-dispatchers 0 integer)
@@ -1393,6 +1362,8 @@ See the full list and their hierarchy in 
`cl--typeof-types'."
 (cl--generic-prefill-dispatchers 0 cl--generic-generalizer integer)
 (cl--generic-prefill-dispatchers 0 (eql 'x) integer)
 
+(cl--generic-prefill-dispatchers 0 cl--generic-generalizer)
+
 ;;; Dispatch on major mode.
 
 ;; Two parts:
@@ -1430,19 +1401,13 @@ Used internally for the (major-mode MODE) context 
specializers."
 (defun cl--generic-oclosure-tag (name &rest _)
   `(oclosure-type ,name))
 
-(defun cl-generic--oclosure-specializers (tag &rest _)
-  (and (symbolp tag)
-       (let ((class (cl--find-class tag)))
-         (when (cl-typep class 'oclosure--class)
-           (oclosure--class-allparents class)))))
-
 (cl-generic-define-generalizer cl--generic-oclosure-generalizer
   ;; Give slightly higher priority than the struct specializer, so that
   ;; for a generic function with methods dispatching structs and on OClosures,
   ;; we first try `oclosure-type' before `type-of' since `type-of' will return
   ;; non-nil for an OClosure as well.
   51 #'cl--generic-oclosure-tag
-  #'cl-generic--oclosure-specializers)
+  #'cl--generic-type-specializers)
 
 (cl-defmethod cl-generic-generalizers :extra "oclosure-struct" (type)
   "Support for dispatch on types defined by `oclosure-define'."
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 1b330e7f761..5743684fa89 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -433,36 +433,6 @@ For this build of Emacs it's %dbit."
   (setf (cl--class-parents (cl--find-class 'cl-structure-object))
       (list (cl--find-class 'record))))
 
-(defconst cl--direct-supertypes-of-type
-  ;; Please run `sycdoc-update-type-hierarchy' in
-  ;; `admin/syncdoc-type-hierarchy.el' each time this is modified to
-  ;; reflect the change in the documentation.
-  (let ((table (make-hash-table :test #'eq)))
-    (mapatoms
-     (lambda (type)
-       (let ((class (get type 'cl--class)))
-        (when (built-in-class-p class)
-          (puthash type (mapcar #'cl--class-name (cl--class-parents class))
-           table)))))
-    table)
-  "Hash table TYPE -> SUPERTYPES.")
-
-(defconst cl--typeof-types
-  (letrec ((alist nil))
-    (maphash (lambda (type _)
-               (let ((class (get type 'cl--class)))
-                 ;; FIXME: Can't remember why `t' is excluded.
-                 (push (remq t (cl--class-allparents class)) alist)))
-             cl--direct-supertypes-of-type)
-    alist)
-  "Alist of supertypes.
-Each element has the form (TYPE . SUPERTYPES) where TYPE is one of
-the symbols returned by `type-of', and SUPERTYPES is the list of its
-supertypes from the most specific to least specific.")
-
-(defconst cl--all-builtin-types
-  (delete-dups (copy-sequence (apply #'append cl--typeof-types))))
-
 ;; 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
 ;; directly on that function, since those cookies only go to cl-loaddefs.
diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index 1c6acaa6385..5922a8caf12 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -38,12 +38,6 @@
 (require 'cl-lib)
 (require 'cl-extra) ;HACK: For `cl-find-class' when `cl-loaddefs' is missing.
 
-(defconst comp--typeof-builtin-types (mapcar (lambda (x)
-                                               (append x '(t)))
-                                             cl--typeof-types)
-  ;; TODO can we just add t in `cl--typeof-types'?
-  "Like `cl--typeof-types' but with t as common supertype.")
-
 (cl-defstruct (comp-cstr (:constructor comp--type-to-cstr
                                        (type &aux
                                             (null (eq type 'null))
@@ -89,15 +83,7 @@ Integer values are handled in the `range' slot.")
 
 (defun comp--cl-class-hierarchy (x)
   "Given a class name `x' return its hierarchy."
-  (let ((parents (cl--class-allparents (cl--struct-get-class x))))
-    (if (memq t parents)
-        parents
-      `(,@parents
-        ;; FIXME: AFAICT, `comp--all-classes' will also find those struct types
-        ;; which use :type and can thus be either `vector' or `cons' (the 
latter
-        ;; isn't `atom').
-        atom
-        t))))
+  (cl--class-allparents (cl--find-class x)))
 
 (defun comp--all-classes ()
   "Return all non built-in type names currently defined."
@@ -109,8 +95,7 @@ Integer values are handled in the `range' slot.")
     res))
 
 (defun comp--compute-typeof-types ()
-  (append comp--typeof-builtin-types
-          (mapcar #'comp--cl-class-hierarchy (comp--all-classes))))
+  (mapcar #'comp--cl-class-hierarchy (comp--all-classes)))
 
 (defun comp--compute--pred-type-h ()
   (cl-loop with h = (make-hash-table :test #'eq)
@@ -275,19 +260,10 @@ Return them as multiple value."
                 (symbol-name y)))
 
 (defun comp--direct-supertypes (type)
-  (or
-   (gethash type cl--direct-supertypes-of-type)
-   (let ((supers (comp-supertypes type)))
-     (cl-assert (eq type (car supers)))
-     (cl-loop
-      with notdirect = nil
-      with direct = nil
-      for parent in (cdr supers)
-      unless (memq parent notdirect)
-        do (progn
-             (push parent direct)
-             (setq notdirect (append notdirect (comp-supertypes parent))))
-      finally return direct))))
+  (when (symbolp type) ;; FIXME: Can this test ever fail?
+    (let* ((class (cl--find-class type))
+           (parents (if class (cl--class-parents class))))
+      (mapcar #'cl--class-name parents))))
 
 (defsubst comp-subtype-p (type1 type2)
   "Return t if TYPE1 is a subtype of TYPE2 or nil otherwise."
@@ -359,23 +335,8 @@ Return them as multiple value."
 
 (defun comp-supertypes (type)
   "Return the ordered list of supertypes of TYPE."
-  ;; FIXME: We should probably keep the results in
-  ;; `comp-cstr-ctxt-typeof-types' (or maybe even precompute them
-  ;; and maybe turn `comp-cstr-ctxt-typeof-types' into a hash-table).
-  ;; Or maybe we shouldn't keep structs and defclasses in it,
-  ;; and just use `cl--class-allparents' when needed (and refuse to
-  ;; compute their direct subtypes since we can't know them).
-  (cl-loop
-   named loop
-   with above
-   for lane in (comp-cstr-ctxt-typeof-types comp-ctxt)
-   do (let ((x (memq type lane)))
-        (cond
-         ((null x) nil)
-         ((eq x lane) (cl-return-from loop x)) ;A base type: easy case.
-         (t (setq above
-                  (if above (comp--intersection x above) x)))))
-   finally return above))
+  (or (assq type (comp-cstr-ctxt-typeof-types comp-ctxt))
+      (error "Type %S missing from typeof-types!" type)))
 
 (defun comp-union-typesets (&rest typesets)
   "Union types present into TYPESETS."
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index 9945e19c65c..5418f53be35 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -191,7 +191,7 @@ Abstract classes cannot be instantiated."
 
 ;; We autoload this because it's used in `make-autoload'.
 ;;;###autoload
-(defun eieio-defclass-autoload (cname _superclasses filename doc)
+(defun eieio-defclass-autoload (cname superclasses filename doc)
   "Create autoload symbols for the EIEIO class CNAME.
 SUPERCLASSES are the superclasses that CNAME inherits from.
 DOC is the docstring for CNAME.
@@ -199,15 +199,9 @@ This function creates a mock-class for CNAME and adds it 
into
 SUPERCLASSES as children.
 It creates an autoload function for CNAME's constructor."
   ;; Assume we've already debugged inputs.
-
-  ;; We used to store the list of superclasses in the `parent' slot (as a list
-  ;; of class names).  But now this slot holds a list of class objects, and
-  ;; those parents may not exist yet, so the corresponding class objects may
-  ;; simply not exist yet.  So instead we just don't store the list of parents
-  ;; here in eieio-defclass-autoload at all, since it seems that they're just
-  ;; not needed before the class is actually loaded.
   (let* ((oldc (cl--find-class cname))
-        (newc (eieio--class-make cname)))
+        (newc (eieio--class-make cname))
+        (parents (mapcar #'cl-find-class superclasses)))
     (if (eieio--class-p oldc)
        nil ;; Do nothing if we already have this class.
 
@@ -218,6 +212,12 @@ It creates an autoload function for CNAME's constructor."
 use '%s or turn off `eieio-backward-compatibility' instead" cname)
                                 "25.1"))
 
+      (when (memq nil parents)
+        ;; If some parents aren't yet fully defined, just ignore them for now.
+        (setq parents (delq nil parents)))
+      (unless parents
+       (setq parents (list (cl--find-class 'eieio-default-superclass))))
+      (setf (cl--class-parents newc) parents)
       (setf (cl--find-class cname) newc)
 
       ;; Create an autoload on top of our constructor function.
@@ -958,19 +958,13 @@ need be... May remove that later...)"
        (cdr tuple)
       nil)))
 
-(defsubst eieio--class/struct-parents (class)
-  (or (eieio--class-parents class)
-      `(,eieio-default-superclass)))
-
 (defun eieio--class-precedence-c3 (class)
   "Return all parents of CLASS in c3 order."
   (let ((parents (eieio--class-parents class)))
     (cons class
           (merge-ordered-lists
            (append
-            (or
-             (mapcar #'eieio--class-precedence-c3 parents)
-             `((,eieio-default-superclass)))
+            (mapcar #'eieio--class-precedence-c3 parents)
             (list parents))
            (lambda (remaining-inputs)
             (signal 'inconsistent-class-hierarchy
@@ -984,13 +978,11 @@ need be... May remove that later...)"
         (classes (copy-sequence
                   (apply #'append
                          (list class)
-                         (or
-                          (mapcar
-                           (lambda (parent)
-                             (cons parent
-                                   (eieio--class-precedence-dfs parent)))
-                           parents)
-                          `((,eieio-default-superclass))))))
+                         (mapcar
+                          (lambda (parent)
+                            (cons parent
+                                  (eieio--class-precedence-dfs parent)))
+                          parents))))
         (tail classes))
     ;; Remove duplicates.
     (while tail
@@ -1003,13 +995,12 @@ need be... May remove that later...)"
 (defun eieio--class-precedence-bfs (class)
   "Return all parents of CLASS in breadth-first order."
   (let* ((result)
-         (queue (eieio--class/struct-parents class)))
+         (queue (eieio--class-parents class)))
     (while queue
       (let ((head (pop queue)))
        (unless (member head result)
          (push head result)
-         (unless (eq head eieio-default-superclass)
-           (setq queue (append queue (eieio--class/struct-parents head)))))))
+         (setq queue (append queue (eieio--class-parents head))))))
     (cons class (nreverse result)))
   )
 
@@ -1049,6 +1040,14 @@ method invocation orders of the involved classes."
 
 ;;;; General support to dispatch based on the type of the argument.
 
+;; FIXME: We could almost use the typeof-generalizer (i.e. the same as
+;; used for cl-structs), except that that generalizer doesn't support
+;; `:method-invocation-order' :-(
+
+(defun cl--generic-struct-tag (name &rest _)
+  ;; Use exactly the same code as for `typeof'.
+  `(if ,name (type-of ,name) 'null))
+
 (cl-generic-define-generalizer eieio--generic-generalizer
   ;; Use the exact same tagcode as for cl-struct, so that methods
   ;; that dispatch on both kinds of objects get to share this