1 | ;-*- Mode: Lisp -*- |
---|
2 | ;;;; Author: Paul Dietz |
---|
3 | ;;;; Created: Sat May 24 21:31:55 2003 |
---|
4 | ;;;; Contains: Tests of DEFGENERIC with :method-combination NCONC |
---|
5 | |
---|
6 | (in-package :cl-test) |
---|
7 | |
---|
8 | (declaim (special *x*)) |
---|
9 | |
---|
10 | (compile-and-load "defgeneric-method-combination-aux.lsp") |
---|
11 | |
---|
12 | (deftest defgeneric-method-combination.nconc.1 |
---|
13 | (let ((*x* nil) |
---|
14 | (fn |
---|
15 | (eval '(defgeneric dg-mc.fun.nconc.1 (x) |
---|
16 | (:method-combination nconc) |
---|
17 | (:method nconc ((x integer)) |
---|
18 | (copy-list (car (push '(d) *x*)))) |
---|
19 | (:method nconc ((x rational)) |
---|
20 | (copy-list (car (push '(c) *x*)))) |
---|
21 | (:method nconc ((x number)) |
---|
22 | (copy-list (car (push '(b) *x*)))) |
---|
23 | (:method nconc ((x t)) |
---|
24 | (copy-list (car (push '(a) *x*)))))))) |
---|
25 | (declare (type generic-function fn)) |
---|
26 | (flet ((%f (y) |
---|
27 | (let ((*x* nil)) |
---|
28 | (list (funcall fn y) *x*)))) |
---|
29 | (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) |
---|
30 | ((d c b a) ((a) (b) (c) (d))) |
---|
31 | ((c b a) ((a) (b) (c))) |
---|
32 | ((b a) ((a) (b))) |
---|
33 | ((a) ((a)))) |
---|
34 | |
---|
35 | (deftest defgeneric-method-combination.nconc.2 |
---|
36 | (let ((*x* nil) |
---|
37 | (fn |
---|
38 | (eval '(defgeneric dg-mc.fun.nconc.2 (x) |
---|
39 | (:method-combination nconc :most-specific-first) |
---|
40 | (:method nconc ((x integer)) |
---|
41 | (copy-list (car (push '(d) *x*)))) |
---|
42 | (:method nconc ((x rational)) |
---|
43 | (copy-list (car (push '(c) *x*)))) |
---|
44 | (:method nconc ((x number)) |
---|
45 | (copy-list (car (push '(b) *x*)))) |
---|
46 | (:method nconc ((x t)) |
---|
47 | (copy-list (car (push '(a) *x*)))))))) |
---|
48 | (declare (type generic-function fn)) |
---|
49 | (flet ((%f (y) |
---|
50 | (let ((*x* nil)) |
---|
51 | (list (funcall fn y) *x*)))) |
---|
52 | (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) |
---|
53 | ((d c b a) ((a) (b) (c) (d))) |
---|
54 | ((c b a) ((a) (b) (c))) |
---|
55 | ((b a) ((a) (b))) |
---|
56 | ((a) ((a)))) |
---|
57 | |
---|
58 | (deftest defgeneric-method-combination.nconc.3 |
---|
59 | (let ((*x* nil) |
---|
60 | (fn |
---|
61 | (eval '(defgeneric dg-mc.fun.nconc.3 (x) |
---|
62 | (:method-combination nconc :most-specific-last) |
---|
63 | (:method nconc ((x integer)) |
---|
64 | (copy-list (car (push '(d) *x*)))) |
---|
65 | (:method nconc ((x rational)) |
---|
66 | (copy-list (car (push '(c) *x*)))) |
---|
67 | (:method nconc ((x number)) |
---|
68 | (copy-list (car (push '(b) *x*)))) |
---|
69 | (:method nconc ((x t)) |
---|
70 | (copy-list (car (push '(a) *x*)))))))) |
---|
71 | (declare (type generic-function fn)) |
---|
72 | (flet ((%f (y) |
---|
73 | (let ((*x* nil)) |
---|
74 | (list (funcall fn y) *x*)))) |
---|
75 | (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) |
---|
76 | ((a b c d) ((d) (c) (b) (a))) |
---|
77 | ((a b c) ((c) (b) (a))) |
---|
78 | ((a b) ((b) (a))) |
---|
79 | ((a) ((a)))) |
---|
80 | |
---|
81 | (deftest defgeneric-method-combination.nconc.4 |
---|
82 | (let ((fn |
---|
83 | (eval '(defgeneric dg-mc.fun.nconc.4 (x) |
---|
84 | (:method-combination nconc) |
---|
85 | (:method nconc ((x integer)) (list 'a 'b)) |
---|
86 | (:method :around ((x rational)) 'foo) |
---|
87 | (:method nconc ((x number)) (list 'c 'd)) |
---|
88 | (:method nconc ((x symbol)) (list 'e 'f)) |
---|
89 | (:method nconc ((x t)) (list 'g 'h)))))) |
---|
90 | (declare (type generic-function fn)) |
---|
91 | (values |
---|
92 | (funcall fn 0) |
---|
93 | (funcall fn 4/3) |
---|
94 | (funcall fn 1.54) |
---|
95 | (funcall fn 'x) |
---|
96 | (funcall fn '(a b c)))) |
---|
97 | foo foo (c d g h) (e f g h) (g h)) |
---|
98 | |
---|
99 | (deftest defgeneric-method-combination.nconc.5 |
---|
100 | (let ((fn |
---|
101 | (eval '(defgeneric dg-mc.fun.nconc.5 (x) |
---|
102 | (:method-combination nconc) |
---|
103 | (:method nconc ((x integer)) (list 'a)) |
---|
104 | (:method :around ((x rational)) |
---|
105 | (list 'foo (call-next-method))) |
---|
106 | (:method nconc ((x number)) (list 'b)) |
---|
107 | (:method nconc ((x symbol)) (list 'c)) |
---|
108 | (:method nconc ((x t)) (cons 'd 'e)))))) |
---|
109 | (declare (type generic-function fn)) |
---|
110 | (values |
---|
111 | (funcall fn 0) |
---|
112 | (funcall fn 4/3) |
---|
113 | (funcall fn 1.54) |
---|
114 | (funcall fn 'x) |
---|
115 | (funcall fn '(a b c)))) |
---|
116 | (foo (a b d . e)) (foo (b d . e)) (b d . e) (c d . e) (d . e)) |
---|
117 | |
---|
118 | (deftest defgeneric-method-combination.nconc.6 |
---|
119 | (let ((fn |
---|
120 | (eval '(defgeneric dg-mc.fun.nconc.6 (x) |
---|
121 | (:method-combination nconc) |
---|
122 | (:method nconc ((x integer)) (list 'a)) |
---|
123 | (:method :around ((x rational)) |
---|
124 | (list 'foo (call-next-method))) |
---|
125 | (:method :around ((x real)) |
---|
126 | (list 'bar (call-next-method))) |
---|
127 | (:method nconc ((x number)) (list 'b)) |
---|
128 | (:method nconc ((x symbol)) (list 'c)) |
---|
129 | (:method nconc ((x t)) (list 'd)))))) |
---|
130 | (declare (type generic-function fn)) |
---|
131 | (values |
---|
132 | (funcall fn 0) |
---|
133 | (funcall fn 4/3) |
---|
134 | (funcall fn 1.54) |
---|
135 | (funcall fn #c(1.0 2.0)) |
---|
136 | (funcall fn 'x) |
---|
137 | (funcall fn '(a b c)))) |
---|
138 | (foo (bar (a b d))) (foo (bar (b d))) (bar (b d)) (b d) (c d) (d)) |
---|
139 | |
---|
140 | (deftest defgeneric-method-combination.nconc.7 |
---|
141 | (let ((fn |
---|
142 | (eval '(defgeneric dg-mc.fun.nconc.7 (x) |
---|
143 | (:method-combination nconc) |
---|
144 | (:method nconc ((x dgmc-class-04)) (list 'a)) |
---|
145 | (:method nconc ((x dgmc-class-03)) (list 'b)) |
---|
146 | (:method nconc ((x dgmc-class-02)) (list 'c)) |
---|
147 | (:method nconc ((x dgmc-class-01)) (list 'd)))))) |
---|
148 | (declare (type generic-function fn)) |
---|
149 | (values |
---|
150 | (funcall fn (make-instance 'dgmc-class-01)) |
---|
151 | (funcall fn (make-instance 'dgmc-class-02)) |
---|
152 | (funcall fn (make-instance 'dgmc-class-03)) |
---|
153 | (funcall fn (make-instance 'dgmc-class-04)))) |
---|
154 | (d) |
---|
155 | (c d) |
---|
156 | (b d) |
---|
157 | (a c b d)) |
---|
158 | |
---|
159 | (deftest defgeneric-method-combination.nconc.8 |
---|
160 | (let ((fn |
---|
161 | (eval '(defgeneric dg-mc.nconc.8 (x) |
---|
162 | (:method-combination nconc) |
---|
163 | (:method nconc ((x (eql 1000))) (list 'a)) |
---|
164 | (:method :around ((x symbol)) (values)) |
---|
165 | (:method :around ((x integer)) (values 'a 'b 'c)) |
---|
166 | (:method :around ((x complex)) (call-next-method)) |
---|
167 | (:method :around ((x number)) (values 1 2 3 4 5 6)) |
---|
168 | (:method nconc ((x t)) (list 'b)))))) |
---|
169 | (declare (type generic-function fn)) |
---|
170 | (values |
---|
171 | (multiple-value-list (funcall fn 'a)) |
---|
172 | (multiple-value-list (funcall fn 10)) |
---|
173 | (multiple-value-list (funcall fn #c(9 8))) |
---|
174 | (multiple-value-list (funcall fn '(a b c))))) |
---|
175 | () (a b c) (1 2 3 4 5 6) ((b))) |
---|
176 | |
---|
177 | (deftest defgeneric-method-combination.nconc.9 |
---|
178 | (handler-case |
---|
179 | (let ((fn (eval '(defgeneric dg-mc.nconc.9 (x) |
---|
180 | (:method-combination nconc))))) |
---|
181 | (declare (type generic-function fn)) |
---|
182 | (funcall fn (list 'a))) |
---|
183 | (error () :error)) |
---|
184 | :error) |
---|
185 | |
---|
186 | (deftest defgeneric-method-combination.nconc.10 |
---|
187 | (progn |
---|
188 | (eval '(defgeneric dg-mc.nconc.10 (x) |
---|
189 | (:method-combination nconc) |
---|
190 | (:method ((x t)) (list 'a)))) |
---|
191 | (handler-case |
---|
192 | (dg-mc.nconc.10 'a) |
---|
193 | (error () :error))) |
---|
194 | :error) |
---|
195 | |
---|
196 | (deftest defgeneric-method-combination.nconc.11 |
---|
197 | (progn |
---|
198 | (eval '(defgeneric dg-mc.nconc.11 (x) |
---|
199 | (:method-combination nconc) |
---|
200 | (:method nonsense ((x t)) (list 'a)))) |
---|
201 | (handler-case |
---|
202 | (dg-mc.nconc.11 0) |
---|
203 | (error () :error))) |
---|
204 | :error) |
---|
205 | |
---|
206 | (deftest defgeneric-method-combination.nconc.12 |
---|
207 | (let ((fn (eval '(defgeneric dg-mc.nconc.12 (x) |
---|
208 | (:method-combination nconc) |
---|
209 | (:method :around ((x t)) (list 'a)) |
---|
210 | (:method nconc ((x integer)) x))))) |
---|
211 | (declare (type generic-function fn)) |
---|
212 | (handler-case (funcall fn (list 'b)) |
---|
213 | (error () :error))) |
---|
214 | :error) |
---|