From 90fc1c439227cde522d363b8474b76638bbfd25a Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sun, 3 Mar 2024 18:08:50 -0500 Subject: [PATCH] (cl--typeof-types): Rework to fix some regressions Initialize the variables directly in their declaration, so there no time where they exist but aren't yet initialized. This also allows us to mark `cl--typeof-types` as a `defconst` again. More importantly, specify the DAG by direct supertypes rather than direct subtypes. This is slightly less compact, but it's necessary to let us specify the *order* of the supertypes, which is necessary for example to preserve the desired ordering of methods when several methods can be applied. Fix a few more regressions, such as removing `atom` from the parents of `function` since some lists are considered as functions, adding `number-or-marker` as supertype of `integer-or-marker`, and re-adding `native-comp-unit`. I carefully compared all elements of `cl--typeof-types` to make sure they are the same as before (with one exception for `null`). * lisp/emacs-lisp/cl-preloaded.el (cl--type-hierarchy): Delete var. (cl--direct-supertypes-of-type, cl--typeof-types): Initialize directly in the declaration. (cl--supertypes-lane, cl--supertypes-lanes-res): Delete vars. (cl--supertypes-for-typeof-types-rec) (cl--supertypes-for-typeof-types): Delete functions. (cherry picked from commit 1d9d07fb00e6b62641c07af68f986e700b5f6cee) --- lisp/emacs-lisp/cl-preloaded.el | 117 +++++++++++++++----------------- 1 file changed, 54 insertions(+), 63 deletions(-) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index b4525b7e4f6..a4ddc55b257 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -50,77 +50,68 @@ (apply #'error string (append sargs args)) (signal 'cl-assertion-failed `(,form ,@sargs))))) - -(defconst cl--type-hierarchy - ;; Please run `sycdoc-update-type-hierarchy' in - ;; etc/syncdoc-type-hierarchy.el each time this is updated to - ;; reflect in the documentation. - '((t sequence atom) - (sequence list array) - (atom - class structure tree-sitter-compiled-query tree-sitter-node - tree-sitter-parser user-ptr font-object font-entity font-spec - condvar mutex thread terminal hash-table frame buffer function - window process window-configuration overlay integer-or-marker - number-or-marker symbol array) - (number float integer) - (number-or-marker marker number) - (integer bignum fixnum) - (symbol keyword boolean symbol-with-pos) - (array vector bool-vector char-table string) - (list null cons) - (integer-or-marker integer marker) - (compiled-function byte-code-function) - (function subr module-function compiled-function) - (boolean null) - (subr subr-native-elisp subr-primitive) - (symbol-with-pos keyword)) - "List of lists describing all the edges of the builtin type -hierarchy. -Each sublist is in the form (TYPE . DIRECT_SUBTYPES)" - ;; Given type hierarchy is a DAG (but mostly a tree) I believe this - ;; is the most compact way to express it. - ) - (defconst cl--direct-supertypes-of-type - (make-hash-table :test #'eq) + (let ((table (make-hash-table :test #'eq))) + (dolist (x '((sequence t) + (atom t) + (list sequence) + (array sequence atom) + (float number) + (integer number integer-or-marker) + (marker integer-or-marker number-or-marker) + (integer-or-marker number-or-marker) + (number number-or-marker) + (bignum integer) + (fixnum integer) + (keyword symbol) + (boolean symbol) + (symbol-with-pos symbol) + (vector array) + (bool-vector array) + (char-table array) + (string array) + ;; FIXME: This results in `atom' coming before `list' :-( + (null boolean list) + (cons list) + (byte-code-function compiled-function) + (subr compiled-function) + (module-function function atom) + (compiled-function function atom) + (subr-native-elisp subr) + (subr-primitive subr))) + (puthash (car x) (cdr x) table)) + ;; And here's the flat part of the hierarchy. + (dolist (atom '( tree-sitter-compiled-query tree-sitter-node + tree-sitter-parser user-ptr + font-object font-entity font-spec + condvar mutex thread terminal hash-table frame + ;; function ;; FIXME: can be a list as well. + buffer window process window-configuration + overlay number-or-marker + symbol obarray native-comp-unit)) + (cl-assert (null (gethash atom table))) + (puthash atom '(atom) table)) + table) "Hash table TYPE -> SUPERTYPES.") -(cl-loop - for (parent . children) in cl--type-hierarchy - do (cl-loop - for child in children - do (cl-pushnew parent (gethash child cl--direct-supertypes-of-type)))) - -(defvar cl--typeof-types nil +(defconst cl--typeof-types + (letrec ((alist nil) + (allparents + (lambda (type) + ;; FIXME: copy&pasted from `cl--class-allparents'. + (let ((parents (gethash type cl--direct-supertypes-of-type))) + (cons type + (merge-ordered-lists + (mapcar allparents (remq t parents)))))))) + (maphash (lambda (type _) + (push (funcall allparents type) 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.") -(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) - (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)) - cl--direct-supertypes-of-type) - (defconst cl--all-builtin-types (delete-dups (copy-sequence (apply #'append cl--typeof-types)))) -- 2.39.5