← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to ansi-tests/defgeneric.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
ansi-tests/defgeneric.lsp
 
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))