Re: master bd017175d45 6/6: Simplify type hierarchy operations

[Philip Kaludercic <philipk@posteo.net>]

The below commit appears to be causing an error when compiling Emacs:

--8<---------------cut here---------------start------------->8---
  [all well until here]
  ELC+ELN  ../lisp/button.elc

Error: error ("../lisp/button.el" "Type or missing from typeof-types!")
  signal(error ("../lisp/button.el" "Type or missing from typeof-types!"))
  comp--native-compile("../lisp/button.el")
  batch-native-compile()
  batch-byte+native-compile()
  funcall(batch-byte+native-compile)
  ...
--8<---------------cut here---------------end--------------->8---


Stefan Monnier via Mailing list for Emacs changes <emacs-diffs@gnu.org>
writes:

> branch: master
> commit bd017175d4571e24ef1fdf84676136af1d36002d
> Author: Stefan Monnier <monnier@iro.umontreal.ca>
> Commit: Stefan Monnier <monnier@iro.umontreal.ca>
>
>     Simplify type hierarchy operations
>     
>     Now that built-in types have classes that describe their
>     relationships exactly like struct/eieio/oclosure classes,
>     we can the code that navigates that DAG.
>     
>     * lisp/emacs-lisp/cl-generic.el (cl--generic-struct-tag): Move to
>     `eieio-core.el`.
>     (cl--generic-type-specializers): Rename from
>     `cl--generic-struct-specializers`.  Make it work for any class.
>     (cl--generic-typeof-generalizer, cl--generic-oclosure-generalizer): Use it.
>     (cl--generic-struct-generalizer): Delete generalizer.
>     (cl-generic-generalizers :extra "cl-struct"): Delete method.
>     (prefill 0 cl--generic-generalizer): Move to after the typeof.
>     (cl-generic-generalizers :extra "typeof"): Rewrite to use
>     classes rather than `cl--all-builtin-types`.
>     (cl-generic--oclosure-specializers): Delete function.
>     
>     * lisp/emacs-lisp/cl-preloaded.el (cl--direct-supertypes-of-type)
>     (cl--typeof-types, cl--all-builtin-types): Delete constants.
>     
>     * lisp/emacs-lisp/comp-cstr.el (comp--typeof-builtin-types):
>     Delete constant.
>     (comp--cl-class-hierarchy): Simplify.
>     (comp--compute-typeof-types): Simplify now that
>     `comp--cl-class-hierarchy` and `comp--all-classes` work for built-in
>     types as well.
>     (comp--direct-supertypes): Just use `cl--class-parents`.
>     (comp-supertypes): Simplify since typeof-types should now be complete.
>     
>     * lisp/emacs-lisp/eieio-core.el (eieio-defclass-autoload):
>     Use `superclasses` argument, so we can find parents before it's loaded.
>     (eieio--class-precedence-c3, eieio--class-precedence-dfs):
>     Don't add a `eieio-default-superclass` parent any more.
>     (eieio--class/struct-parents): Delete function.
>     (eieio--class-precedence-bfs): Use `eieio--class-parents` instead.
>     Don't stop when reaching `eieio-default-superclass`.
>     (cl--generic-struct-tag): Move from `cl-generic.el`.
> ---
>  lisp/emacs-lisp/cl-generic.el   | 67 ++++++++++-------------------------------
>  lisp/emacs-lisp/cl-preloaded.el | 30 ------------------
>  lisp/emacs-lisp/comp-cstr.el    | 55 +++++----------------------------
>  lisp/emacs-lisp/eieio-core.el   | 51 +++++++++++++++----------------
>  4 files changed, 49 insertions(+), 154 deletions(-)
>
> diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
> index f439a97f88c..84eb800ec24 100644
> --- a/lisp/emacs-lisp/cl-generic.el
> +++ b/lisp/emacs-lisp/cl-generic.el
> @@ -1330,62 +1330,31 @@ These match if the argument is `eql' to VAL."
>  (cl--generic-prefill-dispatchers (terminal-parameter nil 'xterm--set-selection)
>                                   (eql nil))
>  
> -;;; Support for cl-defstructs specializers.
> +;;; Dispatch on "normal types".
>  
> -(defun cl--generic-struct-tag (name &rest _)
> -  ;; Use exactly the same code as for `typeof'.
> -  `(if ,name (type-of ,name) 'null))
> -
> -(defun cl--generic-struct-specializers (tag &rest _)
> +(defun cl--generic-type-specializers (tag &rest _)
>    (and (symbolp tag)
> -       (let ((class (get tag 'cl--class)))
> -         (when (cl-typep class 'cl-structure-class)
> +       (let ((class (cl--find-class tag)))
> +         (when class
>             (cl--class-allparents class)))))
>  
> -(cl-generic-define-generalizer cl--generic-struct-generalizer
> -  50 #'cl--generic-struct-tag
> -  #'cl--generic-struct-specializers)
> -
> -(cl-defmethod cl-generic-generalizers :extra "cl-struct" (type)
> -  "Support for dispatch on types defined by `cl-defstruct'."
> -  (or
> -   (when (symbolp type)
> -     ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than
> -     ;; the "cl-struct-*" variants which aren't inlined, so that dispatch can
> -     ;; take place without requiring cl-lib.
> -     (let ((class (cl--find-class type)))
> -       (and (cl-typep class 'cl-structure-class)
> -            (or (null (cl--struct-class-type class))
> -		(error "Can't dispatch on cl-struct %S: type is %S"
> -                     type (cl--struct-class-type class)))
> -            (progn (cl-assert (null (cl--struct-class-named class))) t)
> -            (list cl--generic-struct-generalizer))))
> -   (cl-call-next-method)))
> -
> -(cl--generic-prefill-dispatchers 0 cl--generic-generalizer)
> -
> -;;; Dispatch on "system types".
> -
>  (cl-generic-define-generalizer cl--generic-typeof-generalizer
>    ;; FIXME: We could also change `type-of' to return `null' for nil.
>    10 (lambda (name &rest _) `(if ,name (type-of ,name) 'null))
> -  (lambda (tag &rest _)
> -    (and (symbolp tag) (assq tag cl--typeof-types))))
> +  #'cl--generic-type-specializers)
>  
>  (cl-defmethod cl-generic-generalizers :extra "typeof" (type)
> -  "Support for dispatch on builtin types.
> -See the full list and their hierarchy in `cl--typeof-types'."
> +  "Support for dispatch on types.
> +This currently works for built-in types and types built on top of records."
>    ;; FIXME: Add support for other types accepted by `cl-typep' such
>    ;; as `character', `face', `function', ...
>    (or
> -   (and (memq type cl--all-builtin-types)
> -        (progn
> -          ;; FIXME: While this wrinkle in the semantics can be occasionally
> -          ;; problematic, this warning is more often annoying than helpful.
> -          ;;(if (memq type '(vector array sequence))
> -          ;;    (message "`%S' also matches CL structs and EIEIO classes"
> -          ;;             type))
> -          (list cl--generic-typeof-generalizer)))
> +   (and (symbolp type)
> +        (not (eq type t)) ;; Handled by the `t-generalizer'.
> +        (let ((class (cl--find-class type)))
> +          (memq (type-of class)
> +                '(built-in-class cl-structure-class eieio--class)))
> +        (list cl--generic-typeof-generalizer))
>     (cl-call-next-method)))
>  
>  (cl--generic-prefill-dispatchers 0 integer)
> @@ -1393,6 +1362,8 @@ See the full list and their hierarchy in `cl--typeof-types'."
>  (cl--generic-prefill-dispatchers 0 cl--generic-generalizer integer)
>  (cl--generic-prefill-dispatchers 0 (eql 'x) integer)
>  
> +(cl--generic-prefill-dispatchers 0 cl--generic-generalizer)
> +
>  ;;; Dispatch on major mode.
>  
>  ;; Two parts:
> @@ -1430,19 +1401,13 @@ Used internally for the (major-mode MODE) context specializers."
>  (defun cl--generic-oclosure-tag (name &rest _)
>    `(oclosure-type ,name))
>  
> -(defun cl-generic--oclosure-specializers (tag &rest _)
> -  (and (symbolp tag)
> -       (let ((class (cl--find-class tag)))
> -         (when (cl-typep class 'oclosure--class)
> -           (oclosure--class-allparents class)))))
> -
>  (cl-generic-define-generalizer cl--generic-oclosure-generalizer
>    ;; Give slightly higher priority than the struct specializer, so that
>    ;; for a generic function with methods dispatching structs and on OClosures,
>    ;; we first try `oclosure-type' before `type-of' since `type-of' will return
>    ;; non-nil for an OClosure as well.
>    51 #'cl--generic-oclosure-tag
> -  #'cl-generic--oclosure-specializers)
> +  #'cl--generic-type-specializers)
>  
>  (cl-defmethod cl-generic-generalizers :extra "oclosure-struct" (type)
>    "Support for dispatch on types defined by `oclosure-define'."
> diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
> index 1b330e7f761..5743684fa89 100644
> --- a/lisp/emacs-lisp/cl-preloaded.el
> +++ b/lisp/emacs-lisp/cl-preloaded.el
> @@ -433,36 +433,6 @@ For this build of Emacs it's %dbit."
>    (setf (cl--class-parents (cl--find-class 'cl-structure-object))
>        (list (cl--find-class 'record))))
>  
> -(defconst cl--direct-supertypes-of-type
> -  ;; Please run `sycdoc-update-type-hierarchy' in
> -  ;; `admin/syncdoc-type-hierarchy.el' each time this is modified to
> -  ;; reflect the change in the documentation.
> -  (let ((table (make-hash-table :test #'eq)))
> -    (mapatoms
> -     (lambda (type)
> -       (let ((class (get type 'cl--class)))
> -        (when (built-in-class-p class)
> -          (puthash type (mapcar #'cl--class-name (cl--class-parents class))
> -           table)))))
> -    table)
> -  "Hash table TYPE -> SUPERTYPES.")
> -
> -(defconst cl--typeof-types
> -  (letrec ((alist nil))
> -    (maphash (lambda (type _)
> -               (let ((class (get type 'cl--class)))
> -                 ;; FIXME: Can't remember why `t' is excluded.
> -                 (push (remq t (cl--class-allparents class)) 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.")
> -
> -(defconst cl--all-builtin-types
> -  (delete-dups (copy-sequence (apply #'append cl--typeof-types))))
> -
>  ;; Make sure functions defined with cl-defsubst can be inlined even in
>  ;; packages which do not require CL.  We don't put an autoload cookie
>  ;; directly on that function, since those cookies only go to cl-loaddefs.
> diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
> index 1c6acaa6385..5922a8caf12 100644
> --- a/lisp/emacs-lisp/comp-cstr.el
> +++ b/lisp/emacs-lisp/comp-cstr.el
> @@ -38,12 +38,6 @@
>  (require 'cl-lib)
>  (require 'cl-extra) ;HACK: For `cl-find-class' when `cl-loaddefs' is missing.
>  
> -(defconst comp--typeof-builtin-types (mapcar (lambda (x)
> -                                               (append x '(t)))
> -                                             cl--typeof-types)
> -  ;; TODO can we just add t in `cl--typeof-types'?
> -  "Like `cl--typeof-types' but with t as common supertype.")
> -
>  (cl-defstruct (comp-cstr (:constructor comp--type-to-cstr
>                                         (type &aux
>  					     (null (eq type 'null))
> @@ -89,15 +83,7 @@ Integer values are handled in the `range' slot.")
>  
>  (defun comp--cl-class-hierarchy (x)
>    "Given a class name `x' return its hierarchy."
> -  (let ((parents (cl--class-allparents (cl--struct-get-class x))))
> -    (if (memq t parents)
> -        parents
> -      `(,@parents
> -        ;; FIXME: AFAICT, `comp--all-classes' will also find those struct types
> -        ;; which use :type and can thus be either `vector' or `cons' (the latter
> -        ;; isn't `atom').
> -        atom
> -        t))))
> +  (cl--class-allparents (cl--find-class x)))
>  
>  (defun comp--all-classes ()
>    "Return all non built-in type names currently defined."
> @@ -109,8 +95,7 @@ Integer values are handled in the `range' slot.")
>      res))
>  
>  (defun comp--compute-typeof-types ()
> -  (append comp--typeof-builtin-types
> -          (mapcar #'comp--cl-class-hierarchy (comp--all-classes))))
> +  (mapcar #'comp--cl-class-hierarchy (comp--all-classes)))
>  
>  (defun comp--compute--pred-type-h ()
>    (cl-loop with h = (make-hash-table :test #'eq)
> @@ -275,19 +260,10 @@ Return them as multiple value."
>                  (symbol-name y)))
>  
>  (defun comp--direct-supertypes (type)
> -  (or
> -   (gethash type cl--direct-supertypes-of-type)
> -   (let ((supers (comp-supertypes type)))
> -     (cl-assert (eq type (car supers)))
> -     (cl-loop
> -      with notdirect = nil
> -      with direct = nil
> -      for parent in (cdr supers)
> -      unless (memq parent notdirect)
> -        do (progn
> -             (push parent direct)
> -             (setq notdirect (append notdirect (comp-supertypes parent))))
> -      finally return direct))))
> +  (when (symbolp type) ;; FIXME: Can this test ever fail?
> +    (let* ((class (cl--find-class type))
> +           (parents (if class (cl--class-parents class))))
> +      (mapcar #'cl--class-name parents))))
>  
>  (defsubst comp-subtype-p (type1 type2)
>    "Return t if TYPE1 is a subtype of TYPE2 or nil otherwise."
> @@ -359,23 +335,8 @@ Return them as multiple value."
>  
>  (defun comp-supertypes (type)
>    "Return the ordered list of supertypes of TYPE."
> -  ;; FIXME: We should probably keep the results in
> -  ;; `comp-cstr-ctxt-typeof-types' (or maybe even precompute them
> -  ;; and maybe turn `comp-cstr-ctxt-typeof-types' into a hash-table).
> -  ;; Or maybe we shouldn't keep structs and defclasses in it,
> -  ;; and just use `cl--class-allparents' when needed (and refuse to
> -  ;; compute their direct subtypes since we can't know them).
> -  (cl-loop
> -   named loop
> -   with above
> -   for lane in (comp-cstr-ctxt-typeof-types comp-ctxt)
> -   do (let ((x (memq type lane)))
> -        (cond
> -         ((null x) nil)
> -         ((eq x lane) (cl-return-from loop x)) ;A base type: easy case.
> -         (t (setq above
> -                  (if above (comp--intersection x above) x)))))
> -   finally return above))
> +  (or (assq type (comp-cstr-ctxt-typeof-types comp-ctxt))
> +      (error "Type %S missing from typeof-types!" type)))
>  
>  (defun comp-union-typesets (&rest typesets)
>    "Union types present into TYPESETS."
> diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
> index 9945e19c65c..5418f53be35 100644
> --- a/lisp/emacs-lisp/eieio-core.el
> +++ b/lisp/emacs-lisp/eieio-core.el
> @@ -191,7 +191,7 @@ Abstract classes cannot be instantiated."
>  
>  ;; We autoload this because it's used in `make-autoload'.
>  ;;;###autoload
> -(defun eieio-defclass-autoload (cname _superclasses filename doc)
> +(defun eieio-defclass-autoload (cname superclasses filename doc)
>    "Create autoload symbols for the EIEIO class CNAME.
>  SUPERCLASSES are the superclasses that CNAME inherits from.
>  DOC is the docstring for CNAME.
> @@ -199,15 +199,9 @@ This function creates a mock-class for CNAME and adds it into
>  SUPERCLASSES as children.
>  It creates an autoload function for CNAME's constructor."
>    ;; Assume we've already debugged inputs.
> -
> -  ;; We used to store the list of superclasses in the `parent' slot (as a list
> -  ;; of class names).  But now this slot holds a list of class objects, and
> -  ;; those parents may not exist yet, so the corresponding class objects may
> -  ;; simply not exist yet.  So instead we just don't store the list of parents
> -  ;; here in eieio-defclass-autoload at all, since it seems that they're just
> -  ;; not needed before the class is actually loaded.
>    (let* ((oldc (cl--find-class cname))
> -	 (newc (eieio--class-make cname)))
> +	 (newc (eieio--class-make cname))
> +	 (parents (mapcar #'cl-find-class superclasses)))
>      (if (eieio--class-p oldc)
>  	nil ;; Do nothing if we already have this class.
>  
> @@ -218,6 +212,12 @@ It creates an autoload function for CNAME's constructor."
>  use '%s or turn off `eieio-backward-compatibility' instead" cname)
>                                  "25.1"))
>  
> +      (when (memq nil parents)
> +        ;; If some parents aren't yet fully defined, just ignore them for now.
> +        (setq parents (delq nil parents)))
> +      (unless parents
> +       (setq parents (list (cl--find-class 'eieio-default-superclass))))
> +      (setf (cl--class-parents newc) parents)
>        (setf (cl--find-class cname) newc)
>  
>        ;; Create an autoload on top of our constructor function.
> @@ -958,19 +958,13 @@ need be... May remove that later...)"
>  	(cdr tuple)
>        nil)))
>  
> -(defsubst eieio--class/struct-parents (class)
> -  (or (eieio--class-parents class)
> -      `(,eieio-default-superclass)))
> -
>  (defun eieio--class-precedence-c3 (class)
>    "Return all parents of CLASS in c3 order."
>    (let ((parents (eieio--class-parents class)))
>      (cons class
>            (merge-ordered-lists
>             (append
> -            (or
> -             (mapcar #'eieio--class-precedence-c3 parents)
> -             `((,eieio-default-superclass)))
> +            (mapcar #'eieio--class-precedence-c3 parents)
>              (list parents))
>             (lambda (remaining-inputs)
>              (signal 'inconsistent-class-hierarchy
> @@ -984,13 +978,11 @@ need be... May remove that later...)"
>  	 (classes (copy-sequence
>  		   (apply #'append
>  			  (list class)
> -			  (or
> -			   (mapcar
> -			    (lambda (parent)
> -			      (cons parent
> -				    (eieio--class-precedence-dfs parent)))
> -			    parents)
> -			   `((,eieio-default-superclass))))))
> +			  (mapcar
> +			   (lambda (parent)
> +			     (cons parent
> +				   (eieio--class-precedence-dfs parent)))
> +			   parents))))
>  	 (tail classes))
>      ;; Remove duplicates.
>      (while tail
> @@ -1003,13 +995,12 @@ need be... May remove that later...)"
>  (defun eieio--class-precedence-bfs (class)
>    "Return all parents of CLASS in breadth-first order."
>    (let* ((result)
> -         (queue (eieio--class/struct-parents class)))
> +         (queue (eieio--class-parents class)))
>      (while queue
>        (let ((head (pop queue)))
>  	(unless (member head result)
>  	  (push head result)
> -	  (unless (eq head eieio-default-superclass)
> -	    (setq queue (append queue (eieio--class/struct-parents head)))))))
> +	  (setq queue (append queue (eieio--class-parents head))))))
>      (cons class (nreverse result)))
>    )
>  
> @@ -1049,6 +1040,14 @@ method invocation orders of the involved classes."
>  
>  ;;;; General support to dispatch based on the type of the argument.
>  
> +;; FIXME: We could almost use the typeof-generalizer (i.e. the same as
> +;; used for cl-structs), except that that generalizer doesn't support
> +;; `:method-invocation-order' :-(
> +
> +(defun cl--generic-struct-tag (name &rest _)
> +  ;; Use exactly the same code as for `typeof'.
> +  `(if ,name (type-of ,name) 'null))
> +
>  (cl-generic-define-generalizer eieio--generic-generalizer
>    ;; Use the exact same tagcode as for cl-struct, so that methods
>    ;; that dispatch on both kinds of objects get to share this
>
>

-- 
	Philip Kaludercic on peregrine