From: Stefan Monnier Date: Thu, 15 Jan 2015 05:19:44 +0000 (-0500) Subject: * lisp/emacs-lisp/eieio-core.el: Provide support for cl-generic. X-Git-Tag: emacs-25.0.90~2603^2~1 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=483c98a00d02197dd912d490daf9e521399d16a7;p=emacs.git * lisp/emacs-lisp/eieio-core.el: Provide support for cl-generic. (eieio--generic-tagcode): New function. (cl-generic-tagcode-function): Use it. (eieio--generic-tag-types): New function. (cl-generic-tag-types-function): Use it. (eieio-object-p): Tighten up the test. * lisp/emacs-lisp/cl-generic.el (cl-generic-define-method): Fix paren typo. * test/automated/eieio-test-methodinvoke.el (eieio-test-method-store): Add keysym arg instead of relying on internal var eieio--generic-call-key. Update all callers. (eieio-test-cl-generic-1): New tests. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index e0fb3cced0c..b7a38af9609 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,14 @@ +2015-01-15 Stefan Monnier + + * emacs-lisp/eieio-core.el: Provide support for cl-generic. + (eieio--generic-tagcode): New function. + (cl-generic-tagcode-function): Use it. + (eieio--generic-tag-types): New function. + (cl-generic-tag-types-function): Use it. + (eieio-object-p): Tighten up the test. + + * emacs-lisp/cl-generic.el (cl-generic-define-method): Fix paren typo. + 2015-01-14 Stefan Monnier * emacs-lisp/cl-generic.el: New file. diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 19e4ce0fbef..d94e4f103ae 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -305,10 +305,10 @@ which case this method will be invoked when the argument is `eql' to VAL. (setq i (1+ i)))) (if me (setcdr me (cons uses-cnm function)) (setf (cl--generic-method-table generic) - (cons `(,key ,uses-cnm . ,function) mt)) - ;; For aliases, cl--generic-name gives us the actual name. - (defalias (cl--generic-name generic) - (cl--generic-make-function generic))))) + (cons `(,key ,uses-cnm . ,function) mt))) + ;; For aliases, cl--generic-name gives us the actual name. + (defalias (cl--generic-name generic) + (cl--generic-make-function generic)))) (defmacro cl--generic-with-memoization (place &rest code) (declare (indent 1) (debug t)) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 0f2da634ff3..bfa922bade6 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -264,7 +264,7 @@ Return nil if that option doesn't exist." (defsubst eieio-object-p (obj) "Return non-nil if OBJ is an EIEIO object." - (and (arrayp obj) + (and (vectorp obj) (condition-case nil (eq (aref (eieio--object-class-object obj) 0) 'defclass) (error nil)))) @@ -1303,10 +1303,34 @@ method invocation orders of the involved classes." (define-error 'unbound-slot "Unbound slot") (define-error 'inconsistent-class-hierarchy "Inconsistent class hierarchy") +;;; Hooking into cl-generic. + +(require 'cl-generic) + +(add-function :before-until cl-generic-tagcode-function + #'eieio--generic-tagcode) +(defun eieio--generic-tagcode (type name) + ;; CLHS says: + ;; A class must be defined before it can be used as a parameter + ;; specializer in a defmethod form. + ;; So we can ignore types that are not known to denote classes. + (and (class-p type) + ;; Prefer (aref ,name 0) over (eieio--class-tag ,name) so that + ;; the tagcode is identical to the tagcode used for cl-struct. + `(50 . (and (vectorp ,name) (aref ,name 0))))) + +(add-function :before-until cl-generic-tag-types-function + #'eieio--generic-tag-types) +(defun eieio--generic-tag-types (tag) + (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag)) + (mapcar #'eieio--class-symbol + (eieio--class-precedence-list (symbol-value tag))))) + ;;; Backward compatibility functions ;; To support .elc files compiled for older versions of EIEIO. (defun eieio-defclass (cname superclasses slots options) + (declare (obsolete eieio-defclass-internal "25.1")) (eval `(defclass ,cname ,superclasses ,slots ,@options))) diff --git a/test/ChangeLog b/test/ChangeLog index 211a06c2cbd..a33ec8793f4 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,3 +1,10 @@ +2015-01-15 Stefan Monnier + + * automated/eieio-test-methodinvoke.el (eieio-test-method-store): Add + keysym arg instead of relying on internal var eieio--generic-call-key. + Update all callers. + (eieio-test-cl-generic-1): New tests. + 2015-01-14 Stefan Monnier * automated/cl-generic-tests.el: New file. diff --git a/test/automated/eieio-test-methodinvoke.el b/test/automated/eieio-test-methodinvoke.el index 2de836ceda5..6362fc5a8d9 100644 --- a/test/automated/eieio-test-methodinvoke.el +++ b/test/automated/eieio-test-methodinvoke.el @@ -58,12 +58,10 @@ (defvar eieio-test-method-order-list nil "List of symbols stored during method invocation.") -(defun eieio-test-method-store () +(defun eieio-test-method-store (keysym) "Store current invocation class symbol in the invocation order list." - (let* ((keysym (aref [ :STATIC :BEFORE :PRIMARY :AFTER ] - (or eieio--generic-call-key 0))) - ;; FIXME: Don't depend on `eieio--scoped-class'! - (c (list keysym (eieio--class-symbol (eieio--scoped-class))))) + ;; FIXME: Don't depend on `eieio--scoped-class'! + (let* ((c (list keysym (eieio--class-symbol (eieio--scoped-class))))) (push c eieio-test-method-order-list))) (defun eieio-test-match (rightanswer) @@ -88,36 +86,36 @@ (defclass eitest-B (eitest-B-base1 eitest-B-base2) ()) (defmethod eitest-F :BEFORE ((p eitest-B-base1)) - (eieio-test-method-store)) + (eieio-test-method-store :BEFORE)) (defmethod eitest-F :BEFORE ((p eitest-B-base2)) - (eieio-test-method-store)) + (eieio-test-method-store :BEFORE)) (defmethod eitest-F :BEFORE ((p eitest-B)) - (eieio-test-method-store)) + (eieio-test-method-store :BEFORE)) (defmethod eitest-F ((p eitest-B)) - (eieio-test-method-store) + (eieio-test-method-store :PRIMARY) (call-next-method)) (defmethod eitest-F ((p eitest-B-base1)) - (eieio-test-method-store) + (eieio-test-method-store :PRIMARY) (call-next-method)) (defmethod eitest-F ((p eitest-B-base2)) - (eieio-test-method-store) + (eieio-test-method-store :PRIMARY) (when (next-method-p) (call-next-method)) ) (defmethod eitest-F :AFTER ((p eitest-B-base1)) - (eieio-test-method-store)) + (eieio-test-method-store :AFTER)) (defmethod eitest-F :AFTER ((p eitest-B-base2)) - (eieio-test-method-store)) + (eieio-test-method-store :AFTER)) (defmethod eitest-F :AFTER ((p eitest-B)) - (eieio-test-method-store)) + (eieio-test-method-store :AFTER)) (ert-deftest eieio-test-method-order-list-3 () (let ((eieio-test-method-order-list nil) @@ -152,15 +150,15 @@ ;;; Return value from :PRIMARY ;; (defmethod eitest-I :BEFORE ((a eitest-A)) - (eieio-test-method-store) + (eieio-test-method-store :BEFORE) ":before") (defmethod eitest-I :PRIMARY ((a eitest-A)) - (eieio-test-method-store) + (eieio-test-method-store :PRIMARY) ":primary") (defmethod eitest-I :AFTER ((a eitest-A)) - (eieio-test-method-store) + (eieio-test-method-store :AFTER) ":after") (ert-deftest eieio-test-method-order-list-5 () @@ -179,17 +177,17 @@ ;; Just use the obsolete name once, to make sure it also works. (defmethod constructor :STATIC ((p C-base1) &rest args) - (eieio-test-method-store) + (eieio-test-method-store :STATIC) (if (next-method-p) (call-next-method)) ) (defmethod eieio-constructor :STATIC ((p C-base2) &rest args) - (eieio-test-method-store) + (eieio-test-method-store :STATIC) (if (next-method-p) (call-next-method)) ) (defmethod eieio-constructor :STATIC ((p C) &rest args) - (eieio-test-method-store) + (eieio-test-method-store :STATIC) (call-next-method) ) @@ -216,24 +214,24 @@ (defmethod eitest-F ((p D)) "D" - (eieio-test-method-store) + (eieio-test-method-store :PRIMARY) (call-next-method)) (defmethod eitest-F ((p D-base0)) "D-base0" - (eieio-test-method-store) + (eieio-test-method-store :PRIMARY) ;; This should have no next ;; (when (next-method-p) (call-next-method)) ) (defmethod eitest-F ((p D-base1)) "D-base1" - (eieio-test-method-store) + (eieio-test-method-store :PRIMARY) (call-next-method)) (defmethod eitest-F ((p D-base2)) "D-base2" - (eieio-test-method-store) + (eieio-test-method-store :PRIMARY) (when (next-method-p) (call-next-method)) ) @@ -258,21 +256,21 @@ (defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first) (defmethod eitest-F ((p E)) - (eieio-test-method-store) + (eieio-test-method-store :PRIMARY) (call-next-method)) (defmethod eitest-F ((p E-base0)) - (eieio-test-method-store) + (eieio-test-method-store :PRIMARY) ;; This should have no next ;; (when (next-method-p) (call-next-method)) ) (defmethod eitest-F ((p E-base1)) - (eieio-test-method-store) + (eieio-test-method-store :PRIMARY) (call-next-method)) (defmethod eitest-F ((p E-base2)) - (eieio-test-method-store) + (eieio-test-method-store :PRIMARY) (when (next-method-p) (call-next-method)) ) @@ -380,3 +378,21 @@ '(CNM-1-1 CNM-2 INIT))) (should (equal (eieio-test-arguments-for 'CNM-2) '(INIT))))) + +;;; Check cl-generic integration. + +(cl-defgeneric eieio-test--1 (x y)) + +(ert-deftest eieio-test-cl-generic-1 () + (cl-defmethod eieio-test--1 (x y) (list x y)) + (cl-defmethod eieio-test--1 ((_x CNM-0) y) + (cons "CNM-0" (cl-call-next-method 7 y))) + (cl-defmethod eieio-test--1 ((_x CNM-1-1) _y) + (cons "CNM-1-1" (cl-call-next-method))) + (cl-defmethod eieio-test--1 ((_x CNM-1-2) y) + (cons "CNM-1-2" (cl-call-next-method))) + (should (equal (eieio-test--1 4 5) '(4 5))) + (should (equal (eieio-test--1 (make-instance 'CNM-0) 5) + '("CNM-0" 7 5))) + (should (equal (eieio-test--1 (make-instance 'CNM-2) 5) + '("CNM-1-1" "CNM-1-2" "CNM-0" 7 5))))