1 ;;; cl-generic-tests.el --- Tests for cl-generic.el functionality -*- lexical-binding: t; -*-
3 ;; Copyright (C) 2015 Free Software Foundation, Inc.
5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software: you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
26 (eval-when-compile (require 'ert
)) ;Don't indirectly require cl-lib at run-time.
29 (cl-defgeneric cl--generic-1
(x y
))
30 (cl-defgeneric (setf cl--generic-1
) (v y z
) "My generic doc.")
32 (ert-deftest cl-generic-test-00
()
33 (cl-defgeneric cl--generic-1
(x y
))
34 (cl-defmethod cl--generic-1 ((x t
) y
) (cons x y
))
35 (should (equal (cl--generic-1 'a
'b
) '(a . b
))))
37 (ert-deftest cl-generic-test-01-eql
()
38 (cl-defgeneric cl--generic-1
(x y
))
39 (cl-defmethod cl--generic-1 ((x t
) y
) (cons x y
))
40 (cl-defmethod cl--generic-1 ((_x (eql 4)) _y
)
41 (cons "quatre" (cl-call-next-method)))
42 (cl-defmethod cl--generic-1 ((_x (eql 5)) _y
)
43 (cons "cinq" (cl-call-next-method)))
44 (cl-defmethod cl--generic-1 ((_x (eql 6)) y
)
45 (cons "six" (cl-call-next-method 'a y
)))
46 (should (equal (cl--generic-1 'a nil
) '(a)))
47 (should (equal (cl--generic-1 4 nil
) '("quatre" 4)))
48 (should (equal (cl--generic-1 5 nil
) '("cinq" 5)))
49 (should (equal (cl--generic-1 6 nil
) '("six" a
))))
51 (cl-defstruct cl-generic-struct-parent a b
)
52 (cl-defstruct (cl-generic-struct-child1 (:include cl-generic-struct-parent
)) c
)
53 (cl-defstruct (cl-generic-struct-child11 (:include cl-generic-struct-child1
)) d
)
54 (cl-defstruct (cl-generic-struct-child2 (:include cl-generic-struct-parent
)) e
)
56 (ert-deftest cl-generic-test-02-struct
()
57 (cl-defgeneric cl--generic-1
(x y
) "My doc.")
58 (cl-defmethod cl--generic-1 ((x t
) y
) "Doc 1." (cons x y
))
59 (cl-defmethod cl--generic-1 ((_x cl-generic-struct-parent
) y
)
60 "Doc 2." (cons "parent" (cl-call-next-method 'a y
)))
61 (cl-defmethod cl--generic-1 ((_x cl-generic-struct-child1
) _y
)
62 (cons "child1" (cl-call-next-method)))
63 (cl-defmethod cl--generic-1 :around
((_x t
) _y
)
64 (cons "around" (cl-call-next-method)))
65 (cl-defmethod cl--generic-1 :around
((_x cl-generic-struct-child11
) _y
)
66 (cons "child11" (cl-call-next-method)))
67 (cl-defmethod cl--generic-1 ((_x cl-generic-struct-child2
) _y
)
68 (cons "child2" (cl-call-next-method)))
69 (should (equal (cl--generic-1 (make-cl-generic-struct-child1) nil
)
70 '("around" "child1" "parent" a
)))
71 (should (equal (cl--generic-1 (make-cl-generic-struct-child2) nil
)
72 '("around""child2" "parent" a
)))
73 (should (equal (cl--generic-1 (make-cl-generic-struct-child11) nil
)
74 '("child11" "around""child1" "parent" a
))))
76 ;; I don't know how to put this inside an `ert-test'. This tests that `setf'
77 ;; can be used directly inside the body of the setf method.
78 (cl-defmethod (setf cl--generic-2
) (v (y integer
) z
)
79 (setf (cl--generic-2 (nth y z
) z
) v
))
81 (ert-deftest cl-generic-test-03-setf
()
82 (cl-defmethod (setf cl--generic-1
) (v (y t
) z
) (list v y z
))
83 (cl-defmethod (setf cl--generic-1
) (v (_y (eql 4)) z
) (list v
"four" z
))
84 (should (equal (setf (cl--generic-1 'a
'b
) 'v
) '(v a b
)))
85 (should (equal (setf (cl--generic-1 4 'b
) 'v
) '(v "four" b
)))
87 (should (equal (setf (cl--generic-1 (progn (push 1 x
) 'a
)
88 (progn (push 2 x
) 'b
))
89 (progn (push 3 x
) 'v
))
91 (should (equal x
'(3 2 1)))))
93 (ert-deftest cl-generic-test-04-overlapping-tagcodes
()
94 (cl-defgeneric cl--generic-1
(x y
) "My doc.")
95 (cl-defmethod cl--generic-1 ((y t
) z
) (list y z
))
96 (cl-defmethod cl--generic-1 ((_y (eql 4)) _z
)
97 (cons "four" (cl-call-next-method)))
98 (cl-defmethod cl--generic-1 ((_y integer
) _z
)
99 (cons "integer" (cl-call-next-method)))
100 (cl-defmethod cl--generic-1 ((_y number
) _z
)
101 (cons "number" (cl-call-next-method)))
102 (should (equal (cl--generic-1 'a
'b
) '(a b
)))
103 (should (equal (cl--generic-1 1 'b
) '("integer" "number" 1 b
)))
104 (should (equal (cl--generic-1 4 'b
) '("four" "integer" "number" 4 b
))))
106 (ert-deftest cl-generic-test-05-alias
()
107 (cl-defgeneric cl--generic-1
(x y
) "My doc.")
108 (defalias 'cl--generic-2
#'cl--generic-1
)
109 (cl-defmethod cl--generic-1 ((y t
) z
) (list y z
))
110 (cl-defmethod cl--generic-2 ((_y (eql 4)) _z
)
111 (cons "four" (cl-call-next-method)))
112 (should (equal (cl--generic-1 4 'b
) '("four" 4 b
))))
114 (ert-deftest cl-generic-test-06-multiple-dispatch
()
115 (cl-defgeneric cl--generic-1
(x y
) "My doc.")
116 (cl-defmethod cl--generic-1 (x y
) (list x y
))
117 (cl-defmethod cl--generic-1 (_x (_y integer
))
118 (cons "y-int" (cl-call-next-method)))
119 (cl-defmethod cl--generic-1 ((_x integer
) _y
)
120 (cons "x-int" (cl-call-next-method)))
121 (cl-defmethod cl--generic-1 ((_x integer
) (_y integer
))
122 (cons "x&y-int" (cl-call-next-method)))
123 (should (equal (cl--generic-1 1 2) '("x&y-int" "x-int" "y-int" 1 2))))
125 (ert-deftest cl-generic-test-07-apo
()
126 (cl-defgeneric cl--generic-1
(x y
)
127 (:documentation
"My doc.") (:argument-precedence-order y x
))
128 (cl-defmethod cl--generic-1 (x y
) (list x y
))
129 (cl-defmethod cl--generic-1 (_x (_y integer
))
130 (cons "y-int" (cl-call-next-method)))
131 (cl-defmethod cl--generic-1 ((_x integer
) _y
)
132 (cons "x-int" (cl-call-next-method)))
133 (cl-defmethod cl--generic-1 ((_x integer
) (_y integer
))
134 (cons "x&y-int" (cl-call-next-method)))
135 (should (equal (cl--generic-1 1 2) '("x&y-int" "y-int" "x-int" 1 2))))
137 (ert-deftest cl-generic-test-08-after
/before
()
139 (cl-defgeneric cl--generic-1
(x y
))
140 (cl-defmethod cl--generic-1 ((_x t
) y
) (cons y log
))
141 (cl-defmethod cl--generic-1 ((_x (eql 4)) _y
)
142 (cons "quatre" (cl-call-next-method)))
143 (cl-defmethod cl--generic-1 :after
(x _y
)
144 (push (list :after x
) log
))
145 (cl-defmethod cl--generic-1 :before
(x _y
)
146 (push (list :before x
) log
))
147 (should (equal (cl--generic-1 4 6) '("quatre" 6 (:before
4))))
148 (should (equal log
'((:after
4) (:before
4))))))
150 (defun cl--generic-test-advice (&rest args
) (cons "advice" (apply args
)))
152 (ert-deftest cl-generic-test-09-advice
()
153 (cl-defgeneric cl--generic-1
(x y
) "My doc.")
154 (cl-defmethod cl--generic-1 (x y
) (list x y
))
155 (advice-add 'cl--generic-1
:around
#'cl--generic-test-advice
)
156 (should (equal (cl--generic-1 4 5) '("advice" 4 5)))
157 (cl-defmethod cl--generic-1 ((_x integer
) _y
)
158 (cons "integer" (cl-call-next-method)))
159 (should (equal (cl--generic-1 4 5) '("advice" "integer" 4 5)))
160 (advice-remove 'cl--generic-1
#'cl--generic-test-advice
)
161 (should (equal (cl--generic-1 4 5) '("integer" 4 5))))
163 (ert-deftest cl-generic-test-10-weird
()
164 (cl-defgeneric cl--generic-1
(x &rest r
) "My doc.")
165 (cl-defmethod cl--generic-1 (x &rest r
) (cons x r
))
166 ;; This kind of definition is not valid according to CLHS, but it does show
167 ;; up in EIEIO's tests for no-next-method, so we should either
168 ;; detect it and signal an error or do something meaningful with it.
169 (cl-defmethod cl--generic-1 (x (y integer
) &rest r
)
170 `("integer" ,y
,x
,@r
))
171 (should (equal (cl--generic-1 'a
'b
) '(a b
)))
172 (should (equal (cl--generic-1 1 2) '("integer" 2 1))))
174 (ert-deftest cl-generic-test-11-next-method-p
()
175 (cl-defgeneric cl--generic-1
(x y
))
176 (cl-defmethod cl--generic-1 ((x t
) y
)
177 (list x y
(cl-next-method-p)))
178 (cl-defmethod cl--generic-1 ((_x (eql 4)) _y
)
179 (cl-list* "quatre" (cl-next-method-p) (cl-call-next-method)))
180 (should (equal (cl--generic-1 4 5) '("quatre" t
4 5 nil
))))
182 (provide 'cl-generic-tests
)
183 ;;; cl-generic-tests.el ends here