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`.
This commit is contained in:
Stefan Monnier
parent
945af4d9d1
commit
bd017175d4
4 changed files with 49 additions and 154 deletions
|
|
@ -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'."
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue