source: trunk/source/tests/ansi-tests/remove-method.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 6.8 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sun May 11 19:53:37 2003
4;;;; Contains: Tests of REMOVE-METHOD
5
6(in-package :cl-test)
7
8(defparameter *remove-meth-gf-01*
9  (defgeneric remove-meth-gf-01 (x)))
10
11(defparameter *remove-meth-gf-01-method-t*
12  (defmethod remove-meth-gf-01 ((x t)) x))
13
14(defparameter *remove-meth-gf-02*
15  (defgeneric remove-meth-gf-02 (x)))
16
17(defparameter *remove-meth-gf-02-method-t*
18  (defmethod remove-meth-gf-02 ((x t)) x))
19
20;;; remove method must not signal an error if the method
21;;; does not belong to the generic function
22
23(deftest remove-method.1
24  (and
25   (eqt (remove-method *remove-meth-gf-01* *remove-meth-gf-02-method-t*)
26        *remove-meth-gf-01*)
27   (remove-meth-gf-01 :good))
28  :good)
29
30;;; Add, then remove, a method
31
32(deftest remove-method.2
33  (let (meth)
34    (values
35     (remove-meth-gf-01 10)
36     (progn (setf meth (eval '(defmethod remove-meth-gf-01 ((x integer))
37                                (1+ x))))
38            nil)
39     (remove-meth-gf-01 10)
40     (eqt *remove-meth-gf-01*
41          (remove-method *remove-meth-gf-01* meth))
42     (remove-meth-gf-01 10)))
43  10 nil 11 t 10)
44
45;;; Add two disjoint methods, then remove
46
47(deftest remove-method.3
48  (let (meth1 meth2)
49    (values
50     (mapcar #'remove-meth-gf-01 '(19 a))
51     (progn
52       (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x symbol))
53                            (list x))))
54
55       (mapcar #'remove-meth-gf-01 '(19 a)))
56     (progn
57       (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x number))
58                            (1+ x))))
59
60       (mapcar #'remove-meth-gf-01 '(19 a)))
61     (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1))
62     (mapcar #'remove-meth-gf-01 '(19 a))
63     (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2))
64     (mapcar #'remove-meth-gf-01 '(19 a))))
65  (19 a) (19 (a)) (20 (a)) t (20 a) t (19 a))
66
67;;; Remove in the other order
68
69(deftest remove-method.4
70  (let (meth1 meth2)
71    (values
72     (mapcar #'remove-meth-gf-01 '(19 a))
73     (progn
74       (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x symbol))
75                            (list x))))
76
77       (mapcar #'remove-meth-gf-01 '(19 a)))
78     (progn
79       (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x number))
80                            (1+ x))))
81
82       (mapcar #'remove-meth-gf-01 '(19 a)))
83     (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2))
84     (mapcar #'remove-meth-gf-01 '(19 a))
85     (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1))
86     (mapcar #'remove-meth-gf-01 '(19 a))))
87  (19 a) (19 (a)) (20 (a)) t (19 (a)) t (19 a))
88
89;;; Now methods that shadow one another
90
91(deftest remove-method.5
92  (let (meth1 meth2)
93    (values
94     (mapcar #'remove-meth-gf-01 '(10 20.0))
95     (progn
96       (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x integer))
97                            (1- x))))
98
99       (mapcar #'remove-meth-gf-01 '(10 20.0)))
100     (progn
101       (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x number))
102                            (1+ x))))
103
104       (mapcar #'remove-meth-gf-01 '(10 20.0)))
105     (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1))
106     (mapcar #'remove-meth-gf-01 '(10 20.0))
107     (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2))
108     (mapcar #'remove-meth-gf-01 '(10 20.0))))
109  (10 20.0) (9 20.0) (9 21.0) t (11 21.0) t (10 20.0))
110
111(deftest remove-method.6
112  (let (meth1 meth2)
113    (values
114     (mapcar #'remove-meth-gf-01 '(10 20.0))
115     (progn
116       (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x integer))
117                            (1- x))))
118
119       (mapcar #'remove-meth-gf-01 '(10 20.0)))
120     (progn
121       (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x number))
122                            (1+ x))))
123
124       (mapcar #'remove-meth-gf-01 '(10 20.0)))
125     (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2))
126     (mapcar #'remove-meth-gf-01 '(10 20.0))
127     (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1))
128     (mapcar #'remove-meth-gf-01 '(10 20.0))))
129  (10 20.0) (9 20.0) (9 21.0) t (9 20.0) t (10 20.0))
130
131(deftest remove-method.7
132  (let (meth1 meth2)
133    (values
134     (mapcar #'remove-meth-gf-01 '(10 20.0))
135     (progn
136       (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x number))
137                            (1+ x))))
138
139       (mapcar #'remove-meth-gf-01 '(10 20.0)))
140     (progn
141       (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x integer))
142                            (1- x))))
143
144       (mapcar #'remove-meth-gf-01 '(10 20.0)))
145     (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1))
146     (mapcar #'remove-meth-gf-01 '(10 20.0))
147     (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2))
148     (mapcar #'remove-meth-gf-01 '(10 20.0))))
149  (10 20.0) (11 21.0) (9 21.0) t (9 20.0) t (10 20.0))
150
151(deftest remove-method.8
152  (let (meth1 meth2)
153    (values
154     (mapcar #'remove-meth-gf-01 '(10 20.0))
155     (progn
156       (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x number))
157                            (1+ x))))
158
159       (mapcar #'remove-meth-gf-01 '(10 20.0)))
160     (progn
161       (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x integer))
162                            (1- x))))
163
164       (mapcar #'remove-meth-gf-01 '(10 20.0)))
165     (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2))
166     (mapcar #'remove-meth-gf-01 '(10 20.0))
167     (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1))
168     (mapcar #'remove-meth-gf-01 '(10 20.0))))
169  (10 20.0) (11 21.0) (9 21.0) t (11 21.0) t (10 20.0))
170
171;;; Adding and removing auxiliary methods
172
173(declaim (special *rmgf-03-var*))
174
175(defparameter *remove-meth-gf-03*
176  (defgeneric remove-meth-gf-03 (x)))
177
178(defparameter *remove-meth-gf-03-method-t*
179  (defmethod remove-meth-gf-03 ((x t)) (list *rmgf-03-var* x)))
180
181(deftest remove-method.9
182  (let (meth (*rmgf-03-var* 0))
183    (values
184     (mapcar #'remove-meth-gf-03 '(5 a))
185     (progn
186       (setf meth (eval '(defmethod remove-meth-gf-03 :before ((x number))
187                           (incf *rmgf-03-var*))))
188       (mapcar #'remove-meth-gf-03 '(5 a)))
189     (eqt *remove-meth-gf-03* (remove-method *remove-meth-gf-03* meth))
190     (mapcar #'remove-meth-gf-03 '(5 a))))
191  ((0 5) (0 a))
192  ((1 5) (1 a))
193  t
194  ((1 5) (1 a)))
195
196(deftest remove-method.10
197  (let (meth (*rmgf-03-var* 0))
198    (values
199     (mapcar #'remove-meth-gf-03 '(5 a))
200     (progn
201       (setf meth (eval '(defmethod remove-meth-gf-03 :after ((x number))
202                           (incf *rmgf-03-var*))))
203       (mapcar #'remove-meth-gf-03 '(5 a)))
204     (eqt *remove-meth-gf-03* (remove-method *remove-meth-gf-03* meth))
205     (mapcar #'remove-meth-gf-03 '(5 a))))
206  ((0 5) (0 a))
207  ((0 5) (1 a))
208  t
209  ((1 5) (1 a)))
210
211(deftest remove-method.11
212  (let (meth (*rmgf-03-var* 0))
213    (values
214     (mapcar #'remove-meth-gf-03 '(5 a))
215     (progn
216       (setf meth (eval '(defmethod remove-meth-gf-03 :around ((x number))
217                           (incf *rmgf-03-var*)
218                           (prog1 (call-next-method)
219                             (decf *rmgf-03-var*)))))
220       (mapcar #'remove-meth-gf-03 '(5 a)))
221     (eqt *remove-meth-gf-03* (remove-method *remove-meth-gf-03* meth))
222     (mapcar #'remove-meth-gf-03 '(5 a))))
223  ((0 5) (0 a))
224  ((1 5) (0 a))
225  t
226  ((0 5) (0 a)))
227
228;;; Must add tests for nonstandard method combinations
Note: See TracBrowser for help on using the repository browser.