source: trunk/tests/ansi-tests/add-method.lsp @ 14368

Last change on this file since 14368 was 14368, checked in by gz, 9 years ago

Don't muffle warnings when running test, as that affects the return values from compile-file. Tweak tests to not cause warnings

File size: 3.9 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Wed Jun  4 19:12:25 2003
4;;;; Contains: Tests for ADD-METHOD
5
6(in-package :cl-test)
7
8(defgeneric add-method-gf-01 (x)
9  (:method ((x t)) 'a))
10
11(defgeneric add-method-gf-02 (x))
12
13;;; Cannot add a method that's already in another method
14
15(deftest add-method.error.1
16  (let ((method (find-method #'add-method-gf-01 nil (list (find-class t)))))
17    (handler-case
18     (add-method #'add-method-gf-02 method)
19     (error () :error)))
20  :error)
21
22;;; The lambda lists must be congruent
23
24(deftest add-method.error.2
25  (let* ((gf (eval '(defgeneric add-method-gf-03 (x)
26                      (:method ((x t)) 'a))))
27         (method (find-method #'add-method-gf-03 nil (list (find-class t))))
28         (gf2 (eval '(defgeneric add-method-gf-04 (x y)))))
29    (handler-case
30     (add-method gf2 method)
31     (error () :error)))
32  :error)
33
34(deftest add-method.error.3
35  (let* ((gf (eval '(defgeneric add-method-gf-05 (x &optional y)
36                      (:method ((x t) &optional y) y 'a))))
37         (method (find-method #'add-method-gf-05 nil (list (find-class t))))
38         (gf2 (eval '(defgeneric add-method-gf-06 (x y)))))
39    (handler-case
40     (add-method gf2 method)
41     (error () :error)))
42  :error)
43
44(deftest add-method.error.4
45  (signals-error (add-method) program-error)
46  t)
47
48(deftest add-method.error.5
49  (signals-error (add-method #'add-method-gf-01) program-error)
50  t)
51
52(deftest add-method.error.6
53  (signals-error
54   (let* ((gf (eval '(defgeneric add-method-gf-07 (x)
55                       (:method ((x t)) 'a))))
56          (method (find-method #'add-method-gf-07 nil (list (find-class t))))
57          (gf2 (eval '(defgeneric add-method-gf-08 (x)))))
58     (remove-method gf method)
59     (add-method gf2 method nil))
60   program-error)
61  t)
62
63(deftest add-method.error.7
64  (let* ((gf (eval '(defgeneric add-method-gf-09 (x y)
65                      (:method ((x t) (y t)) 'a))))
66         (method (find-method #'add-method-gf-09 nil (list (find-class t)
67                                                           (find-class t))))
68         (gf2 (eval '(defgeneric add-method-gf-10 (x &optional y)))))
69     (remove-method gf method)
70     (handler-case
71      (add-method gf2 method)
72      (error () :error)))
73  :error)
74
75(deftest add-method.error.8
76  (let* ((gf (eval '(defgeneric add-method-gf-11 (x &key y)
77                      (:method ((x t) &key y) y 'a))))
78         (method (find-method #'add-method-gf-11 nil (list (find-class t))))
79         (gf2 (eval '(defgeneric add-method-gf-12 (x)))))
80    (remove-method gf method)
81    (handler-case
82     (add-method gf2 method)
83     (error () :error)))
84  :error)
85
86
87;;; Non-error tests
88
89(deftest add-method.1
90  (let* ((gf (eval '(defgeneric add-method-gf-13 (x)
91                      (:method ((x integer)) 'a)
92                      (:method ((x t)) 'b))))
93         (method (find-method #'add-method-gf-13
94                              nil (list (find-class 'integer))))
95         (gf2 (eval '(defgeneric add-method-gf-14 (x)))))
96    (declare (type generic-function gf gf2))
97    (values
98     (funcall gf 0)
99     (funcall gf 'x)
100     (eqt gf (remove-method gf method))
101     (eqt gf2 (add-method gf2 method))
102     (funcall gf 0)
103     (funcall gf 'x)
104     (funcall gf2 0)))
105  a b t t b b a)
106
107;;; An existing method is replaced.
108
109(deftest add-method.2
110  (let* ((specializers (list (find-class 'integer)))
111         (gf (eval '(defgeneric add-method-gf-15 (x)
112                      (:method ((x integer)) 'a)
113                      (:method ((x t)) 'b))))
114         (method (find-method gf nil specializers))
115         (gf2 (eval '(defgeneric add-method-gf-16 (x)
116                       (:method ((x integer)) 'c)
117                       (:method ((x t)) 'd))))
118         (method2 (find-method gf2 nil specializers)))
119    (declare (type generic-function gf gf2))
120    (values
121     (funcall gf 0)
122     (funcall gf 'x)
123     (funcall gf2 0)
124     (funcall gf2 'x)
125     (eqt gf (remove-method gf method))
126     (eqt gf2 (add-method gf2 method))
127     (eqt method (find-method gf2 nil specializers))
128     (eqt method2 (find-method gf2 nil specializers))
129     (funcall gf 0)
130     (funcall gf 'x)
131     (funcall gf2 0)
132     (funcall gf2 'x)))
133  a b c d t t t nil b b a d)
134
135;;; Must add tests for: :around methods, :before methods, :after methods,
136;;; nonstandard method combinations
Note: See TracBrowser for help on using the repository browser.