diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/cl-generic.el | 67 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-preloaded.el | 30 | ||||
| -rw-r--r-- | lisp/emacs-lisp/comp-cstr.el | 55 | ||||
| -rw-r--r-- | 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 |