[Emacs-diffs] master 483c98a: * lisp/emacs-lisp/eieio-core.el: Provide support for cl-generic.

[Stefan Monnier]

branch: master
commit 483c98a00d02197dd912d490daf9e521399d16a7
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>

    * 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.
---
 lisp/ChangeLog                            |   11 ++++
 lisp/emacs-lisp/cl-generic.el             |    8 ++--
 lisp/emacs-lisp/eieio-core.el             |   26 ++++++++++-
 test/ChangeLog                            |    7 +++
 test/automated/eieio-test-methodinvoke.el |   72 +++++++++++++++++-----------
 5 files changed, 91 insertions(+), 33 deletions(-)

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index e0fb3cc..b7a38af 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,14 @@
+2015-01-15  Stefan Monnier  <address@hidden>
+
+       * 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  <address@hidden>
 
        * emacs-lisp/cl-generic.el: New file.
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 19e4ce0..d94e4f1 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 0f2da63..bfa922b 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 211a06c..a33ec87 100644
--- a/test/ChangeLog
+++ b/test/ChangeLog
@@ -1,3 +1,10 @@
+2015-01-15  Stefan Monnier  <address@hidden>
+
+       * 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  <address@hidden>
 
        * automated/cl-generic-tests.el: New file.
diff --git a/test/automated/eieio-test-methodinvoke.el 
b/test/automated/eieio-test-methodinvoke.el
index 2de836c..6362fc5 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))))