From 92ccb6ba83076a40f3bfc7906913346a5b3a7a92 Mon Sep 17 00:00:00 2001
From: Andrea Corallo <akrl@sdf.org>
Date: Wed, 24 Aug 2022 18:08:37 +0200
Subject: [PATCH] comp: Account non builtin types in type hierarchy

* lisp/emacs-lisp/cl-macs.el (cl--struct-all-parents): Add comment.

* lisp/emacs-lisp/cl-preloaded.el (cl--struct-get-class): Likewise.

* lisp/emacs-lisp/comp-cstr.el (comp--cl-class-hierarchy)
(comp--all-classes): New functions.
(comp-cstr-ctxt): Add `typeof-types' field.

* lisp/emacs-lisp/comp-cstr.el (comp-supertypes)
(comp-union-typesets): Update to use non builtin types.
---
 lisp/emacs-lisp/cl-macs.el      |  1 +
 lisp/emacs-lisp/cl-preloaded.el |  1 +
 lisp/emacs-lisp/comp-cstr.el    | 24 ++++++++++++++++++++++--
 3 files changed, 24 insertions(+), 2 deletions(-)

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 8fdafe18c50..6590b1baa1e 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -3249,6 +3249,7 @@ To see the documentation for a defined struct type, use
 
 ;;; Add cl-struct support to pcase
 
+;;In use by comp.el
 (defun cl--struct-all-parents (class)
   (when (cl--struct-class-p class)
     (let ((res ())
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 5235be52996..f410270d340 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -113,6 +113,7 @@ supertypes from the most specific to least specific.")
         (record 'cl-slot-descriptor
                 name initform type props)))
 
+;; In use by comp.el
 (defun cl--struct-get-class (name)
   (or (if (not (symbolp name)) name)
       (cl--find-class name)
diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index d4200c16c19..869b0619160 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -86,7 +86,27 @@ Integer values are handled in the `range' slot.")
   (ret nil :type (or comp-cstr comp-cstr-f)
        :documentation "Returned value."))
 
+(defun comp--cl-class-hierarchy (x)
+  "Given a class name `x' return its hierarchy."
+  `(,@(mapcar #'cl--struct-class-name (cl--struct-all-parents
+                                       (cl--struct-get-class x)))
+    atom
+    t))
+
+(defun comp--all-classes ()
+  "Return all non built-in type names currently defined."
+  (let (res)
+    (mapatoms (lambda (x)
+                (when (cl-find-class x)
+                  (push x res)))
+              obarray)
+    res))
+
 (cl-defstruct comp-cstr-ctxt
+  (typeof-types (append comp--typeof-builtin-types
+                        (mapcar #'comp--cl-class-hierarchy (comp--all-classes)))
+                :type list
+                :documentation "Type hierarchy.")
   (union-typesets-mem (make-hash-table :test #'equal) :type hash-table
                       :documentation "Serve memoization for
 `comp-union-typesets'.")
@@ -230,7 +250,7 @@ Return them as multiple value."
   (cl-loop
    named outer
    with found = nil
-   for l in comp--typeof-builtin-types
+   for l in (comp-cstr-ctxt-typeof-types comp-ctxt)
    do (cl-loop
        for x in l
        for i from (length l) downto 0
@@ -273,7 +293,7 @@ Return them as multiple value."
                (cl-loop
                 with types = (apply #'append typesets)
                 with res = '()
-                for lane in comp--typeof-builtin-types
+                for lane in (comp-cstr-ctxt-typeof-types comp-ctxt)
                 do (cl-loop
                     with last = nil
                     for x in lane
-- 
2.39.2