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`.
(cherry picked from commit
bd017175d4571e24ef1fdf84676136af1d36002d)
(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)
(cl--generic-prefill-dispatchers 1 integer)
(cl--generic-prefill-dispatchers 0 cl--generic-generalizer integer)
+(cl--generic-prefill-dispatchers 0 cl--generic-generalizer)
+
;;; Dispatch on major mode.
;; Two parts:
(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'."
(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.
(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))
(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."
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)
(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."
(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."
;; 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.
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.
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.
(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
(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
(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)))
)
;;;; 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
projects / emacs.git / commitdiff