mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-01-03 10:31:37 -08:00
Code Issues Projects Releases Wiki Activity

* Fix 'cl--typeof-types' computation

Browse source 
* 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.
This commit is contained in:
Andrea Corallo 2024-03-03 16:33:53 +01:00
parent 7f8717c6fd
commit 8d11b7e427
1 changed files with 17 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

27
lisp/emacs-lisp/cl-preloaded.el
View file

@ -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 the symbols returned by `type-of', and SUPERTYPES is the list of its
supertypes from the most specific to least specific.") 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) (defun cl--supertypes-for-typeof-types (type)
(cl-loop with agenda = (list type) (let (cl--supertypes-lane cl--supertypes-lanes-res)
while agenda (cl--supertypes-for-typeof-types-rec type)
for element = (car agenda) (merge-ordered-lists cl--supertypes-lanes-res)))
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)))
(maphash (lambda (type _) (maphash (lambda (type _)
(push (cl--supertypes-for-typeof-types type) cl--typeof-types)) (push (cl--supertypes-for-typeof-types type) cl--typeof-types))