merge master

3 files changed, 188 insertions, 28 deletions

diff --git a/test/ChangeLog b/test/ChangeLog
index 83bb8bf00c7..a33ec8793f4 100644
--- a/test/ChangeLog
+++ b/test/ChangeLog
@@ -1,3 +1,14 @@
+2015-01-15  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+        * 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  <monnier@iro.umontreal.ca>
+
+        * automated/cl-generic-tests.el: New file.
+
 2015-01-08  Stefan Monnier  <monnier@iro.umontreal.ca>
 
         * automated/eieio-tests.el (eieio-test-23-inheritance-check): Don't use
diff --git a/test/automated/cl-generic-tests.el b/test/automated/cl-generic-tests.el
new file mode 100644
index 00000000000..17bce6a3157
--- /dev/null
+++ b/test/automated/cl-generic-tests.el
@@ -0,0 +1,133 @@
+;;; cl-generic-tests.el --- Tests for cl-generic.el functionality  -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2015 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ert)
+(require 'cl-lib)
+
+(cl-defgeneric cl--generic-1 (x y))
+(cl-defgeneric (setf cl--generic-1) (v y z) "My generic doc.")
+
+(ert-deftest cl-generic-test-0 ()
+  (cl-defgeneric cl--generic-1 (x y))
+  (cl-defmethod cl--generic-1 ((x t) y) (cons x y))
+  (should (equal (cl--generic-1 'a 'b) '(a . b))))
+
+(ert-deftest cl-generic-test-1-eql ()
+  (cl-defgeneric cl--generic-1 (x y))
+  (cl-defmethod cl--generic-1 ((x t) y) (cons x y))
+  (cl-defmethod cl--generic-1 ((_x (eql 4)) _y)
+    (cons "quatre" (cl-call-next-method)))
+  (cl-defmethod cl--generic-1 ((_x (eql 5)) _y)
+    (cons "cinq" (cl-call-next-method)))
+  (cl-defmethod cl--generic-1 ((_x (eql 6)) y)
+    (cons "six" (cl-call-next-method 'a y)))
+  (should (equal (cl--generic-1 'a nil) '(a)))
+  (should (equal (cl--generic-1 4 nil) '("quatre" 4)))
+  (should (equal (cl--generic-1 5 nil) '("cinq" 5)))
+  (should (equal (cl--generic-1 6 nil) '("six" a))))
+
+(cl-defstruct cl-generic-struct-parent a b)
+(cl-defstruct (cl-generic-struct-child1 (:include cl-generic-struct-parent)) c)
+(cl-defstruct (cl-generic-struct-child11 (:include cl-generic-struct-child1)) d)
+(cl-defstruct (cl-generic-struct-child2 (:include cl-generic-struct-parent)) e)
+
+(ert-deftest cl-generic-test-2-struct ()
+  (cl-defgeneric cl--generic-1 (x y) "My doc.")
+  (cl-defmethod cl--generic-1 ((x t) y) "Doc 1." (cons x y))
+  (cl-defmethod cl--generic-1 ((_x cl-generic-struct-parent) y)
+    "Doc 2." (cons "parent" (cl-call-next-method 'a y)))
+  (cl-defmethod cl--generic-1 ((_x cl-generic-struct-child1) _y)
+    (cons "child1" (cl-call-next-method)))
+  (cl-defmethod cl--generic-1 :around ((_x t) _y)
+    (cons "around" (cl-call-next-method)))
+  (cl-defmethod cl--generic-1 :around ((_x cl-generic-struct-child11) _y)
+    (cons "child11" (cl-call-next-method)))
+  (cl-defmethod cl--generic-1 ((_x cl-generic-struct-child2) _y)
+    (cons "child2" (cl-call-next-method)))
+  (should (equal (cl--generic-1 (make-cl-generic-struct-child1) nil)
+                 '("around" "child1" "parent" a)))
+  (should (equal (cl--generic-1 (make-cl-generic-struct-child2) nil)
+                 '("around""child2" "parent" a)))
+  (should (equal (cl--generic-1 (make-cl-generic-struct-child11) nil)
+                 '("child11" "around""child1" "parent" a))))
+
+(ert-deftest cl-generic-test-3-setf ()
+  (cl-defmethod (setf cl--generic-1) (v (y t) z) (list v y z))
+  (cl-defmethod (setf cl--generic-1) (v (_y (eql 4)) z) (list v "four" z))
+  (should (equal (setf (cl--generic-1 'a 'b) 'v) '(v a b)))
+  (should (equal (setf (cl--generic-1 4 'b) 'v) '(v "four" b)))
+  (let ((x ()))
+    (should (equal (setf (cl--generic-1 (progn (push 1 x) 'a)
+                                        (progn (push 2 x) 'b))
+                         (progn (push 3 x) 'v))
+                   '(v a b)))
+    (should (equal x '(3 2 1)))))
+
+(ert-deftest cl-generic-test-4-overlapping-tagcodes ()
+  (cl-defgeneric cl--generic-1 (x y) "My doc.")
+  (cl-defmethod cl--generic-1 ((y t) z) (list y z))
+  (cl-defmethod cl--generic-1 ((_y (eql 4)) _z)
+                (cons "four" (cl-call-next-method)))
+  (cl-defmethod cl--generic-1 ((_y integer) _z)
+                (cons "integer" (cl-call-next-method)))
+  (cl-defmethod cl--generic-1 ((_y number) _z)
+                (cons "number" (cl-call-next-method)))
+  (should (equal (cl--generic-1 'a 'b) '(a b)))
+  (should (equal (cl--generic-1 1 'b) '("integer" "number" 1 b)))
+  (should (equal (cl--generic-1 4 'b) '("four" "integer" "number" 4 b))))
+
+(ert-deftest cl-generic-test-5-alias ()
+  (cl-defgeneric cl--generic-1 (x y) "My doc.")
+  (defalias 'cl--generic-2 #'cl--generic-1)
+  (cl-defmethod cl--generic-1 ((y t) z) (list y z))
+  (cl-defmethod cl--generic-2 ((_y (eql 4)) _z)
+                (cons "four" (cl-call-next-method)))
+  (should (equal (cl--generic-1 4 'b) '("four" 4 b))))
+
+(ert-deftest cl-generic-test-6-multiple-dispatch ()
+  (cl-defgeneric cl--generic-1 (x y) "My doc.")
+  (cl-defmethod cl--generic-1 (x y) (list x y))
+  (cl-defmethod cl--generic-1 (_x (_y integer))
+    (cons "y-int" (cl-call-next-method)))
+  (cl-defmethod cl--generic-1 ((_x integer) _y)
+    (cons "x-int" (cl-call-next-method)))
+  (cl-defmethod cl--generic-1 ((_x integer) (_y integer))
+    (cons "x&y-int" (cl-call-next-method)))
+  (should (equal (cl--generic-1 1 2) '("x&y-int" "x-int" "y-int" 1 2))))
+
+(ert-deftest cl-generic-test-7-apo ()
+  (cl-defgeneric cl--generic-1 (x y)
+    (:documentation "My doc.") (:argument-precedence-order y x))
+  (cl-defmethod cl--generic-1 (x y) (list x y))
+  (cl-defmethod cl--generic-1 (_x (_y integer))
+    (cons "y-int" (cl-call-next-method)))
+  (cl-defmethod cl--generic-1 ((_x integer) _y)
+    (cons "x-int" (cl-call-next-method)))
+  (cl-defmethod cl--generic-1 ((_x integer) (_y integer))
+    (cons "x&y-int" (cl-call-next-method)))
+  (should (equal (cl--generic-1 1 2) '("x&y-int" "y-int" "x-int" 1 2))))
+
+(provide 'cl-generic-tests)
+;;; cl-generic-tests.el ends here
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))))