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.

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 8fdafe18c5035ca1323ba8aa8e30016af9795f1e..6590b1baa1e15ce3e301d8da4fba62349d1c0524 100644 (file)
--- 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 5235be52996de8a8c8f0c104d5d77fc532975760..f410270d3402ac46d66604a6ce337444d85837bb 100644 (file)
--- 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 d4200c16c190a33c21dd388fbd2d34b4bb9ead92..869b061916033107a263a30cd5869e1ad429b54a 100644 (file)
--- 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