source: trunk/source/tests/ansi-tests/defgeneric.lsp @ 8991

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

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

File size: 22.4 KB
RevLine 
[8991]1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat May 17 20:55:50 2003
4;;;; Contains: Tests of DEFGENERIC
5
6(in-package :cl-test)
7
8;;; Various error cases
9
10(defun defgeneric-testfn-01 (x) x)
11
12(deftest defgeneric.error.1
13  ;; Cannot make ordinary functions generic
14  (let* ((name 'defgeneric-testfn-01)
15         (fn (symbol-function name)))
16    (if (not (typep fn 'generic-function))
17        (handler-case
18         (progn (eval `(defgeneric ,name ())) :bad)
19         (program-error () :good))
20      :good))
21  :good)
22
23(defmacro defgeneric-testmacro-02 (x) x)
24
25(deftest defgeneric.error.2
26  ;; Cannot make macros generic
27  (let* ((name 'defgeneric-testmacro-02))
28    (handler-case
29     (progn (eval `(defgeneric ,name ())) :bad)
30     (program-error () :good)))
31  :good)
32
33(deftest defgeneric.error.3
34  ;; Cannot make special operators generic
35  (loop for name in *cl-special-operator-symbols*
36        for result =
37        (handler-case
38         (progn (eval `(defgeneric ,name ())) t)
39         (program-error () nil))
40        when result collect name)
41  nil)
42
43(deftest defgeneric.error.4
44  (signals-error (defgeneric defgeneric-error-fn.4 (x y)
45                    (:argument-precedence-order x y x))
46                 program-error)
47  t)
48
49(deftest defgeneric.error.5
50  (signals-error (defgeneric defgeneric-error-fn.5 (x)
51                    (:documentation "some documentation")
52                    (:documentation "illegally repeated documentation"))
53                 program-error)
54  t)
55
56(deftest defgeneric.error.6
57  (signals-error (defgeneric defgeneric-error-fn.6 (x)
58                    (unknown-option nil))
59                 program-error)
60  t)
61
62(deftest defgeneric.error.7
63  (handler-case
64   (progn
65     (eval '(defgeneric defgeneric-error-fn.7 (x y)
66              (:method ((x t)) x)))
67     :bad)
68   (error () :good))
69  :good)
70
71(deftest defgeneric.error.8
72  (signals-error (defgeneric defgeneric-error-fn.8 (x y)
73                    (:argument-precedence-order x))
74                 program-error)
75  t)
76
77
78;;; Non-congruent methods cause defgeneric to signal an error
79
80(deftest defgeneric.error.9
81  (handler-case
82   (progn
83     (eval '(defgeneric defgeneric-error-fn.9 (x)
84              (:method ((x t)(y t)) t)))
85     :bad)
86   (error () :good))
87  :good)
88
89
90(deftest defgeneric.error.10
91  (handler-case
92   (progn
93     (eval '(defgeneric defgeneric-error-fn.10 (x &optional y)
94              (:method ((x t)) t)))
95     :bad)
96   (error () :good))
97  :good)
98
99(deftest defgeneric.error.11
100  (handler-case
101   (progn
102     (eval '(defgeneric defgeneric-error-fn.11 (x &optional y)
103              (:method (x &optional y z) t)))
104     :bad)
105   (error () :good))
106  :good)
107
108(deftest defgeneric.error.12
109  (handler-case
110   (progn
111     (eval '(defgeneric defgeneric-error-fn.12 (x &rest y)
112              (:method (x) t)))
113     :bad)
114   (error () :good))
115  :good)
116
117(deftest defgeneric.error.13
118  (handler-case
119   (progn
120     (eval '(defgeneric defgeneric-error-fn.13 (x)
121              (:method (x &rest y) t)))
122     :bad)
123   (error () :good))
124  :good)
125
126(deftest defgeneric.error.14
127  (handler-case
128   (progn
129     (eval '(defgeneric defgeneric-error-fn.14 (x &key)
130              (:method (x) t)))
131     :bad)
132   (error () :good))
133  :good)
134
135(deftest defgeneric.error.15
136  (handler-case
137   (progn
138     (eval '(defgeneric defgeneric-error-fn.15 (x &key y)
139              (:method (x) t)))
140     :bad)
141   (error () :good))
142  :good)
143
144(deftest defgeneric.error.16
145  (handler-case
146   (progn
147     (eval '(defgeneric defgeneric-error-fn.16 (x)
148              (:method (x &key) t)))
149     :bad)
150   (error () :good))
151  :good)
152
153(deftest defgeneric.error.17
154  (handler-case
155   (progn
156     (eval '(defgeneric defgeneric-error-fn.17 (x)
157              (:method (x &key foo) t)))
158     :bad)
159   (error () :good))
160  :good)
161
162(deftest defgeneric.error.18
163  (handler-case
164   (progn
165     (eval '(defgeneric defgeneric-error-fn.18 (x &key foo)
166              (:method (x &key) t)))
167     :bad)
168   (error () :good))
169  :good)
170
171(deftest defgeneric.error.19
172  (handler-case
173   (progn
174     (eval '(defgeneric defgeneric-error-fn.19 (x &key foo)
175              (:method (x &key bar) t)))
176     :bad)
177   (error () :good))
178  :good)
179
180;;; A close reading of the rules for keyword arguments to
181;;; generic functions convinced me that the following two
182;;; error tests are necessary.  See sections 7.6.5 of the CLHS.
183
184(deftest defgeneric.error.20
185  (signals-error
186   (let ((fn (defgeneric defgeneric-error-fn.20 (x &key)
187               (:method ((x number) &key foo) (list x foo))
188               (:method ((x symbol) &key bar) (list x bar)))))
189     (funcall fn 1 :bar 'a))
190   program-error)
191  t)
192
193(deftest defgeneric.error.21
194  (signals-error
195   (let ((fn (defgeneric defgeneric-error-fn.21 (x &key)
196               (:method ((x number) &key foo &allow-other-keys) (list x foo))
197               (:method ((x symbol) &key bar) (list x bar)))))
198     (funcall fn 'x :foo 'a))
199   program-error)
200  t)
201
202;;;
203
204(deftest defgeneric.error.22
205  (progn
206    (defgeneric defgeneric-error-fn.22 (x))
207    (defmethod defgeneric-error-fn.22 ((x t)) nil)
208    (handler-case
209     (eval '(defgeneric defgeneric-error-fn.22 (x y)))
210     (error () :good)))
211  :good)
212
213
214;;; Non error cases
215
216(deftest defgeneric.1
217  (let ((fn (eval '(defgeneric defgeneric.fun.1 (x y z)
218                     (:method ((x t) (y t) (z t)) (list x y z))))))
219    (declare (type function fn))
220    (values
221     (typep* fn 'generic-function)
222     (typep* fn 'standard-generic-function)
223     (funcall fn 'a 'b 'c)
224     (apply fn 1 2 3 nil)
225     (apply fn (list 4 5 6))
226     (mapcar fn '(1 2) '(3 4) '(5 6))
227     (defgeneric.fun.1 'd 'e 'f)))
228  t t (a b c) (1 2 3) (4 5 6) ((1 3 5) (2 4 6)) (d e f))
229
230(deftest defgeneric.2
231  (let ((fn (eval '(defgeneric defgeneric.fun.2 (x y z)
232                     (:documentation "boo!")
233                     (:method ((x t) (y t) (z t)) (vector x y z))))))
234    (declare (type function fn))
235    (values
236     (typep* fn 'generic-function)
237     (typep* fn 'standard-generic-function)
238     (funcall fn 'a 'b 'c)
239     (defgeneric.fun.2 'd 'e 'f)
240     (let ((doc (documentation fn t)))
241       (or (not doc)
242           (and (stringp doc) (string=t doc "boo!"))))
243     (let ((doc (documentation fn 'function)))
244       (or (not doc)
245           (and (stringp doc) (string=t doc "boo!"))))
246     (setf (documentation fn t) "foo")
247     (let ((doc (documentation fn t)))
248       (or (not doc)
249           (and (stringp doc) (string=t doc "foo"))))
250     (setf (documentation fn 'function) "bar")
251     (let ((doc (documentation fn t)))
252       (or (not doc)
253           (and (stringp doc) (string=t doc "bar"))))))
254     
255  t t #(a b c) #(d e f) t t "foo" t "bar" t)
256
257(deftest defgeneric.3
258  (let ((fn (eval '(defgeneric defgeneric.fun.3 (x y)
259                     (:method ((x t) (y symbol)) (list x y))
260                     (:method ((x symbol) (y t)) (list y x))))))
261    (declare (type function fn))
262    (values
263     (typep* fn 'generic-function)
264     (typep* fn 'standard-generic-function)
265     (funcall fn 1 'a)
266     (funcall fn 'b 2)
267     (funcall fn 'a 'b)))
268  t t
269  (1 a)
270  (2 b)
271  (b a))
272
273(deftest defgeneric.4
274  (let ((fn (eval '(defgeneric defgeneric.fun.4 (x y)
275                     (:argument-precedence-order y x)
276                     (:method ((x t) (y symbol)) (list x y))
277                     (:method ((x symbol) (y t)) (list y x))))))
278    (declare (type function fn))
279    (values
280     (typep* fn 'generic-function)
281     (typep* fn 'standard-generic-function)
282     (funcall fn 1 'a)
283     (funcall fn 'b 2)
284     (funcall fn 'a 'b)))
285  t t
286  (1 a)
287  (2 b)
288  (a b))
289
290(deftest defgeneric.5
291  (let ((fn (eval '(defgeneric defgeneric.fun.5 ()
292                     (:method () (values))))))
293    (declare (type function fn))
294    (values
295     (typep* fn 'generic-function)
296     (typep* fn 'standard-generic-function)
297     (multiple-value-list (funcall fn))
298     (multiple-value-list (defgeneric.fun.5))
299     (multiple-value-list (apply fn nil))))
300  t t nil nil nil)
301
302(deftest defgeneric.6
303  (let ((fn (eval '(defgeneric defgeneric.fun.6 ()
304                     (:method () (values 'a 'b 'c))))))
305    (declare (type function fn))
306    (values
307     (typep* fn 'generic-function)
308     (typep* fn 'standard-generic-function)
309     (multiple-value-list (funcall fn))
310     (multiple-value-list (defgeneric.fun.6))
311     (multiple-value-list (apply fn nil))))
312  t t (a b c) (a b c) (a b c))
313
314(deftest defgeneric.7
315  (let ((fn (eval '(defgeneric defgeneric.fun.7 ()
316                     (:method () (return-from defgeneric.fun.7 'a) 'b)))))
317    (declare (type function fn))
318    (values
319     (typep* fn 'generic-function)
320     (typep* fn 'standard-generic-function)
321     (multiple-value-list (funcall fn))
322     (multiple-value-list (defgeneric.fun.7))
323     (multiple-value-list (apply fn nil))))
324  t t (a) (a) (a))
325
326(deftest defgeneric.8
327  (let ((fn (eval '(defgeneric defgeneric.fun.8 (x &optional y z)
328                     (:method ((x number) &optional y z)
329                              (list x y z))
330                     (:method ((p symbol) &optional q r)
331                              (list r q p))))))
332    (declare (type function fn))
333    (values
334     (typep* fn 'generic-function)
335     (typep* fn 'standard-generic-function)
336     (multiple-value-list (funcall fn 1))
337     (multiple-value-list (funcall fn 1 2))
338     (multiple-value-list (funcall fn 1 2 3))
339     (multiple-value-list (defgeneric.fun.8 'a))
340     (multiple-value-list (defgeneric.fun.8 'a 'b))
341     (multiple-value-list (defgeneric.fun.8 'a 'b 'c))
342     (multiple-value-list (apply fn '(x y z)))))
343  t t
344  ((1 nil nil))
345  ((1 2 nil))
346  ((1 2 3))
347  ((nil nil a))
348  ((nil b a))
349  ((c b a))
350  ((z y x)))
351
352(deftest defgeneric.9
353  (let ((fn (eval '(defgeneric defgeneric.fun.9 (x &optional y z)
354                     (:method ((x number) &optional (y 10) (z 20))
355                              (list x y z))
356                     (:method ((p symbol) &optional (q 's) (r 't))
357                              (list r q p))))))
358    (declare (type function fn))
359    (values
360     (funcall fn 1)
361     (funcall fn 1 2)
362     (funcall fn 1 2 3)
363     (funcall fn 'a)
364     (funcall fn 'a 'b)
365     (funcall fn 'a 'b 'c)))
366  (1 10 20)
367  (1 2 20)
368  (1 2 3)
369  (t s a)
370  (t b a)
371  (c b a))
372
373 (deftest defgeneric.10
374   (let ((fn (eval '(defgeneric defgeneric.fun.10 (x &rest y)
375                      (:method ((x number) &key foo) (list x foo))))))
376     (declare (type function fn))
377     (values
378      (funcall fn 1)
379      (funcall fn 1 :foo 'a)
380      (defgeneric.fun.10 5/3 :foo 'x :foo 'y)
381      (defgeneric.fun.10 10 :bar t :allow-other-keys t)
382      (defgeneric.fun.10 20 :allow-other-keys nil :foo 'x)))
383   (1 nil)
384   (1 a)
385   (5/3 x)
386   (10 nil)
387   (20 x))
388
389 (deftest defgeneric.11
390   (let ((fn (eval '(defgeneric defgeneric.fun.11 (x &key)
391                      (:method ((x number) &key foo) (list x foo))))))
392     (declare (type function fn))
393     (values
394      (funcall fn 1)
395      (funcall fn 1 :foo 'a)
396      (defgeneric.fun.11 5/3 :foo 'x :foo 'y)
397      (defgeneric.fun.11 11 :bar t :allow-other-keys t)
398      (defgeneric.fun.11 20 :allow-other-keys nil :foo 'x)))
399   (1 nil)
400   (1 a)
401   (5/3 x)
402   (11 nil)
403   (20 x))
404
405 (deftest defgeneric.12
406   (let ((fn (eval '(defgeneric defgeneric.fun.12 (x &key foo bar baz)
407                      (:method ((x number) &rest y) (list x y))))))
408     (declare (type function fn))
409     (values
410      (funcall fn 1)
411      (funcall fn 1 :foo 'a)
412      (defgeneric.fun.12 5/3 :foo 'x :foo 'y :bar 'z)
413      (defgeneric.fun.12 11 :zzz t :allow-other-keys t)
414      (defgeneric.fun.12 20 :allow-other-keys nil :foo 'x)))
415   (1 nil)
416   (1 (:foo a))
417   (5/3 (:foo x :foo y :bar z))
418   (11 (:zzz t :allow-other-keys t))
419   (20 (:allow-other-keys nil :foo x)))
420
421 (deftest defgeneric.13
422   (let ((fn (eval '(defgeneric defgeneric.fun.13 (x &key)
423                      (:method ((x number) &key foo) (list x foo))
424                      (:method ((x symbol) &key bar) (list x bar))))))
425     (declare (type function fn))
426     (values
427      (funcall fn 1)
428      (funcall fn 'a)
429      (funcall fn 1 :foo 2)
430      ;; (funcall fn 1 :foo 2 :bar 3)
431      ;; (funcall fn 1 :bar 4)
432      ;; (funcall fn 'a :foo 'b)
433      (funcall fn 'a :bar 'b)
434      ;; (funcall fn 'a :foo 'c :bar 'b)
435      ))
436   (1 nil)
437   (a nil)
438   (1 2)
439   ;; (1 2)
440   ;; (1 nil)
441   ;; (a nil)
442   (a b)
443   ;; (a b)
444   )
445
446 (deftest defgeneric.14
447   (let ((fn (eval '(defgeneric defgeneric.fun.14 (x &key &allow-other-keys)
448                      (:method ((x number) &key foo) (list x foo))
449                      (:method ((x symbol) &key bar) (list x bar))))))
450     (declare (type function fn))
451     (values
452      (funcall fn 1)
453      (funcall fn 'a)
454      (funcall fn 1 :foo 2)
455      (funcall fn 1 :foo 2 :bar 3)
456      (funcall fn 1 :bar 4)
457      (funcall fn 'a :foo 'b)
458      (funcall fn 'a :bar 'b)
459      (funcall fn 'a :foo 'c :bar 'b)
460      (funcall fn 1 :baz 10)
461      (funcall fn 'a :baz 10)
462      (funcall fn 1 :allow-other-keys nil :baz 'a)
463      (funcall fn 'a :allow-other-keys nil :baz 'b)
464      ))
465   (1 nil)
466   (a nil)
467   (1 2)
468   (1 2)
469   (1 nil)
470   (a nil)
471   (a b)
472   (a b)
473   (1 nil)
474   (a nil)
475   (1 nil)
476   (a nil))
477
478 (deftest defgeneric.15
479   (let ((fn (eval '(defgeneric defgeneric.fun.15 (x &key)
480                      (:method ((x number) &key foo &allow-other-keys)
481                               (list x foo))
482                      (:method ((x symbol) &key bar) (list x bar))))))
483     (declare (type function fn))
484     (values
485      (funcall fn 1)
486      (funcall fn 'a)
487      (funcall fn 1 :foo 2)
488      (funcall fn 1 :foo 2 :bar 3)
489      (funcall fn 1 :bar 4)
490      (funcall fn 'a :allow-other-keys t :foo 'b)
491      (funcall fn 'a :bar 'b)
492      (funcall fn 'a :foo 'c :bar 'b :allow-other-keys t)
493      (funcall fn 1 :baz 10)
494      ;; (funcall fn 'a :baz 10)
495      (funcall fn 1 :allow-other-keys nil :baz 'a)
496      ;; (funcall fn 'a :allow-other-keys nil :baz 'b)
497      ))
498   (1 nil)
499   (a nil)
500   (1 2)
501   (1 2)
502   (1 nil)
503   (a nil)
504   (a b)
505   (a b)
506   (1 nil)
507   ;; (a nil)
508   (1 nil)
509   ;; (a nil)
510   )
511
512 (deftest defgeneric.16
513   (let ((fn (eval '(defgeneric defgeneric.fun.16 (x &key)
514                      (:method ((x number) &key (foo 'a))
515                               (list x foo))
516                      (:method ((x symbol) &key foo)
517                               (list x foo))))))
518     (declare (type function fn))
519     (values
520      (funcall fn 1)
521      (funcall fn 1 :foo nil)
522      (funcall fn 1 :foo 2)
523      (funcall fn 'x)
524      (funcall fn 'x :foo nil)
525      (funcall fn 'x :foo 'y)))
526   (1 a)
527   (1 nil)
528   (1 2)
529   (x nil)
530   (x nil)
531   (x y))
532
533 (deftest defgeneric.17
534   (let ((fn (eval '(defgeneric defgeneric.fun.17 (x &key)
535                      (:method ((x number) &key (foo 'a foo-p))
536                               (list x foo (notnot foo-p)))
537                      (:method ((x symbol) &key foo)
538                               (list x foo))))))
539     (declare (type function fn))
540     (values
541      (funcall fn 1)
542      (funcall fn 1 :foo nil)
543      (funcall fn 1 :foo 2)
544      (funcall fn 'x)
545      (funcall fn 'x :foo nil)
546      (funcall fn 'x :foo 'y)))
547   (1 a nil)
548   (1 nil t)
549   (1 2 t)
550   (x nil)
551   (x nil)
552   (x y))
553
554(deftest defgeneric.18
555   (let ((fn (eval '(defgeneric defgeneric.fun.18 (x &optional y)
556                      (:method ((x number) &optional (y 'a))
557                               (list x y))
558                      (:method ((x symbol) &optional (z nil z-p))
559                               (list x z (notnot z-p)))))))
560     (declare (type function fn))
561     (values
562      (funcall fn 1)
563      (funcall fn 1 nil)
564      (funcall fn 1 2)
565      (funcall fn 'x)
566      (funcall fn 'x nil)
567      (funcall fn 'x 'y)))
568   (1 a)
569   (1 nil)
570   (1 2)
571   (x nil nil)
572   (x nil t)
573   (x y t))
574
575 (deftest defgeneric.19
576   (let ((fn (eval '(defgeneric defgeneric.fun.19 (x &key)
577                      (:method ((x number) &key ((:bar foo) 'a foo-p))
578                               (list x foo (notnot foo-p)))))))
579     (declare (type function fn))
580     (values
581      (funcall fn 1)
582      (funcall fn 1 :bar nil)
583      (funcall fn 1 :bar 2)))
584   (1 a nil)
585   (1 nil t)
586   (1 2 t))
587
588(deftest defgeneric.20
589   (let ((fn (eval '(defgeneric defgeneric.fun.20 (x &optional y z)
590                      (:method ((x number)
591                                &optional (y (1+ x) y-p)
592                                          (z (if y-p (1+ y) (+ x 10))
593                                             z-p))
594                               (list x y (notnot y-p) z (notnot z-p)))))))
595     (declare (type function fn))
596     (values
597      (funcall fn 1)
598      (funcall fn 1 5)
599      (funcall fn 1 5 9)))
600   (1 2 nil 11 nil)
601   (1 5 t 6 nil)
602   (1 5 t 9 t))
603
604(deftest defgeneric.21
605   (let ((fn (eval '(defgeneric defgeneric.fun.21 (x &key)
606                      (:method ((x number)
607                                &key (y (1+ x) y-p)
608                                (z (if y-p (1+ y) (+ x 10))
609                                   z-p))
610                               (list x y (notnot y-p) z (notnot z-p)))))))
611     (declare (type function fn))
612     (values
613      (funcall fn 1)
614      (funcall fn 1 :y 5)
615      (funcall fn 1 :y 5 :z 9)
616      (funcall fn 1 :z 8)
617      (funcall fn 1 :z 8 :y 4)))
618   (1 2 nil 11 nil)
619   (1 5 t 6 nil)
620   (1 5 t 9 t)
621   (1 2 nil 8 t)
622   (1 4 t 8 t))
623
624(deftest defgeneric.22
625   (let ((fn (eval '(defgeneric defgeneric.fun.22 (x &key)
626                      (:method ((x number) &key ((:allow-other-keys y)))
627                               (list x y))))))
628     (declare (type function fn))
629     (values
630      (funcall fn 1)
631      (funcall fn 1 :allow-other-keys nil)
632      (funcall fn 1 :allow-other-keys t)
633      (funcall fn 1 :foo 'x :allow-other-keys t :bar 'y)
634      (funcall fn 1 :allow-other-keys t :foo 'x)
635      (funcall fn 1 :allow-other-keys nil :allow-other-keys t)
636      (funcall fn 1 :foo 'x :allow-other-keys t :allow-other-keys nil)
637      (funcall fn 1 :allow-other-keys t 'foo 'y :allow-other-keys nil)
638      (funcall fn 1 :allow-other-keys t :allow-other-keys nil '#:foo 'z)))
639   (1 nil)
640   (1 nil)
641   (1 t)
642   (1 t)
643   (1 t)
644   (1 nil)
645   (1 t)
646   (1 t)
647   (1 t))
648
649(deftest defgeneric.23
650   (let ((fn (eval '(defgeneric defgeneric.fun.23 (x)
651                      (:method ((x number) &aux (y (1+ x))) (list x y))
652                      (:method ((x symbol) &aux (z (list x))) (list x z))))))
653     (declare (type function fn))
654     (values
655      (funcall fn 1)
656      (funcall fn 'a)))
657   (1 2) (a (a)))
658
659
660(deftest defgeneric.24
661   (let ((fn (eval '(defgeneric defgeneric.fun.24 (x)
662                      (:method ((x number) &aux (y (1+ x)) (z (1+ y)))
663                               (list x y z))
664                      (:method ((x symbol) &aux (y (list x)) (z (list x y)))
665                               (list x y z))))))
666     (values
667      (funcall fn 1)
668      (funcall fn 'a)))
669   (1 2 3)
670   (a (a) (a (a))))
671
672(deftest defgeneric.25
673  (let ((fn (eval '(defgeneric defgeneric.fun.25 (x &optional y &key)
674                      (:method ((x symbol) &optional (y 'd y-p)
675                                &key ((:foo bar) (list x y) bar-p)
676                                &aux (z (list x y (notnot y-p)
677                                              bar (notnot bar-p))))
678                               z)))))
679    (declare (type function fn))
680    (values
681     (funcall fn 'a)
682     (funcall fn 'a 'b)
683     (funcall fn 'a 'b :foo 'c)))
684  (a d nil (a d) nil)
685  (a b t (a b) nil)
686  (a b t c t))
687
688(deftest defgeneric.26
689  (let ((fn (eval '(defgeneric defgeneric.fun.26 (x)
690                     (declare (optimize (safety 3)))
691                     (:method ((x symbol)) x)
692                     (declare (optimize (debug 3)))))))
693    (declare (type function fn))
694    (funcall fn 'a))
695  a)
696
697#|
698(when (subtypep (class-of (find-class 'standard-method))
699                'standard-class)
700  (defclass substandard-method (standard-method) ())
701  (deftest defgeneric.27
702    (let ((fn (eval '(defgeneric defgeneric.fun.27 (x y)
703                       (:method-class substandard-method)
704                       (:method ((x number) (y number)) (+ x y))
705                       (:method ((x string) (y string))
706                                (concatenate 'string x y))))))
707      (declare (type function fn))
708      (values
709       (funcall fn 1 2)
710       (funcall fn "1" "2")))
711    3 "12"))
712|#
713
714(deftest defgeneric.28
715  (let ((fn (eval '(defgeneric defgeneric.fun.28 (x &key)
716                     (:method ((x integer) &key foo) (list x foo))
717                     (:method ((x number) &key bar) (list x bar))
718                     (:method ((x t) &key baz) (list x baz))))))
719    (declare (type function fn))
720    (values
721     
722     (funcall fn 1)
723     (funcall fn 1 :foo 'a)
724     (funcall fn 1 :bar 'b)
725     (funcall fn 1 :baz 'c)
726     (funcall fn 1 :bar 'b :baz 'c)
727     (funcall fn 1 :foo 'a :bar 'b)
728     (funcall fn 1 :foo 'a :baz 'c)
729     (funcall fn 1 :foo 'a :bar 'b :baz 'c)
730     
731     (funcall fn 5/3)
732     (funcall fn 5/3 :bar 'b)
733     (funcall fn 5/3 :baz 'c)
734     (funcall fn 5/3 :bar 'b :baz 'c)
735     
736     (funcall fn 'x)
737     (funcall fn 'x :baz 'c)
738     
739     ))
740
741  (1 nil) (1 a) (1 nil) (1 nil)
742  (1 nil) (1 a) (1 a)   (1 a)
743
744  (5/3 nil) (5/3 b)   (5/3 nil) (5/3 b)
745
746  (x nil) (x c))
747
748(defclass defgeneric.29.class.1 () ())
749(defclass defgeneric.29.class.2 () ())
750(defclass defgeneric.29.class.3
751  (defgeneric.29.class.1 defgeneric.29.class.2)
752  ())
753
754(deftest defgeneric.29
755  (let ((fn
756         (eval '(defgeneric defgeneric.fun.29 (x &key)
757                  (:method ((x defgeneric.29.class.1) &key foo) foo)
758                  (:method ((x defgeneric.29.class.2) &key bar) bar)))))
759    (declare (type function fn))
760    (let ((x (make-instance 'defgeneric.29.class.3)))
761      (values
762       (funcall fn x)
763       (funcall fn x :foo 'a)
764       (funcall fn x :bar 'b)
765       (funcall fn x :foo 'a :bar 'b)
766       (funcall fn x :bar 'b :foo 'a))))
767  nil a nil a a)
768
769;;; I'm not sure this one is proper
770;;; Added :metaclass at prompting of Martin Simmons
771(when (subtypep (class-of (find-class 'standard-generic-function))
772                'standard-class)
773  (defclass substandard-generic-function (standard-generic-function) ()
774    (:metaclass #.(class-name (class-of
775                               (find-class 'standard-generic-function)))))
776  (deftest defgeneric.30
777    (let ((fn
778           (eval '(defgeneric defgeneric.fun.29 (x)
779                    (:generic-function-class substandard-generic-function)
780                    (:method ((x symbol)) 1)
781                    (:method ((x integer)) 2)))))
782      (declare (type function fn))
783      (values
784       (typep* fn 'substandard-generic-function)
785       (typep* fn 'standard-generic-function)
786       (typep* fn 'generic-function)
787       (typep* fn 'function)
788       (funcall fn 'a)
789       (funcall fn 1)
790       (defgeneric.fun.29 'x)
791       (defgeneric.fun.29 12345678901234567890)))
792    t t t t 1 2 1 2))
793
794(deftest defgeneric.31
795  (progn
796    (defgeneric defgeneric.fun.31 (x) (:method ((x t)) t))
797    (defgeneric defgeneric.fun.31 (x y) (:method ((x t) (y t)) (list x y)))
798    (defgeneric.fun.31 'a 'b))
799  (a b))
800
801(deftest defgeneric.32
802  (progn
803    (defgeneric defgeneric.fun.32 (x) (:method ((x symbol)) :bad))
804    (defgeneric defgeneric.fun.32 (x) (:method ((x t)) :good))
805    (defgeneric.fun.32 'x))
806  :good)
807
808(deftest defgeneric.33
809  (let ((fn
810         (eval
811          '(defgeneric (setf defgeneric.fun.33) (x y &rest args)
812             (:method (x (y cons) &rest args)
813                      (assert (null args)) (setf (car y) x))
814             (:method (x (y array) &rest args)
815                      (setf (apply #'aref y args) x))))))
816    (declare (type function fn))
817    (values
818     (let ((z (list 'a 'b)))
819       (list
820        (setf (defgeneric.fun.33 z) 'c)
821        z))
822     (let ((a (make-array '(10) :initial-element nil)))
823       (list
824        (setf (defgeneric.fun.33 a 5) 'd)
825        a))))
826  (c (c b))
827  (d #(nil nil nil nil nil d nil nil nil nil)))
828
829(deftest defgeneric.34
830  (let ((fn (eval '(defgeneric #:defgeneric.fun.34 (x)
831                     (:method ((x t)) (list x :good))))))
832    (funcall fn 10))
833  (10 :good))
834
835(deftest defgeneric.35
836  (let ((fn (eval '(defgeneric defgeneric.fun.35 (x)
837                     (:method ((x (eql 'a)))
838                              (declare (optimize (speed 0)))
839                              "FOO"
840                              (declare (optimize (safety 3)))
841                              x)))))
842    (declare (type function fn))
843    (values
844     (funcall fn 'a)
845     (let ((method (first (compute-applicable-methods fn '(a)))))
846       (and method
847            (let ((doc (documentation method t)))
848              (list
849               (or (null doc) (equalt doc "FOO"))
850               (setf (documentation method t) "BAR")
851               (let ((doc (documentation method t)))
852                 (or (null doc) (equalt doc "BAR")))
853               ))))))
854  a (t "BAR" t))
Note: See TracBrowser for help on using the repository browser.