From: Andrea Corallo <acorallo@gnu.org>
Date: Sun, 3 Mar 2024 15:33:53 +0000 (+0100)
Subject: * Fix 'cl--typeof-types' computation
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=c8d910006e64b5ca0e553d3347c75d60a3bbc94c;p=emacs.git

* Fix 'cl--typeof-types' computation

* lisp/emacs-lisp/cl-preloaded.el (cl--supertypes-lane)
(cl--supertypes-lanes-res): Define vars.
(cl--supertypes-for-typeof-types-rec): Define function.
(cl--supertypes-for-typeof-types): Reimplement.

(cherry picked from commit 8d11b7e4275affdf66f28ec4a719fc8124252a3d)
---

diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index e64302ef414..b4525b7e4f6 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -98,17 +98,24 @@ 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.")
 
+(defvar cl--supertypes-lane nil)
+(defvar cl--supertypes-lanes-res nil)
+
+(defun cl--supertypes-for-typeof-types-rec (type)
+  ;; Walk recursively the DAG upwards, when the top is reached collect
+  ;; the current lane in `cl--supertypes-lanes-res'.
+  (push type cl--supertypes-lane)
+  (if-let ((parents (gethash type cl--direct-supertypes-of-type)))
+      (dolist (parent parents)
+        (cl--supertypes-for-typeof-types-rec parent))
+    (push (reverse (cdr cl--supertypes-lane)) ;; Don't include `t'.
+          cl--supertypes-lanes-res ))
+  (pop cl--supertypes-lane))
+
 (defun cl--supertypes-for-typeof-types (type)
-  (cl-loop with agenda = (list type)
-           while agenda
-           for element = (car agenda)
-           unless (or (eq element t) ;; no t in `cl--typeof-types'.
-                      (memq element res))
-             append (list element) into res
-           do (cl-loop for c in (gethash element cl--direct-supertypes-of-type)
-                       do (setq agenda (append agenda (list c))))
-           do (setq agenda (cdr agenda))
-           finally (cl-return res)))
+  (let (cl--supertypes-lane cl--supertypes-lanes-res)
+    (cl--supertypes-for-typeof-types-rec type)
+    (merge-ordered-lists cl--supertypes-lanes-res)))
 
 (maphash (lambda (type _)
            (push (cl--supertypes-for-typeof-types type) cl--typeof-types))