defgeneric.lsp 24.4 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat May 17 20:55:50 2003
;;;; Contains: Tests of DEFGENERIC

(in-package :cl-test)

;;; Various error cases

(defun defgeneric-testfn-01 (x) x)

(deftest defgeneric.error.1
  ;; Cannot make ordinary functions generic
  (let* ((name 'defgeneric-testfn-01)
sds's avatar
sds committed
15
         (fn (symbol-function name)))
16
    (if (not (typep fn 'generic-function))
sds's avatar
sds committed
17 18 19
        (handler-case
         (progn (eval `(defgeneric ,name ())) :bad)
         (program-error () :good))
20 21 22 23 24 25 26 27 28 29
      :good))
  :good)

(defmacro defgeneric-testmacro-02 (x) x)

(deftest defgeneric.error.2
  ;; Cannot make macros generic
  (let* ((name 'defgeneric-testmacro-02))
    (handler-case
     (progn (eval `(defgeneric ,name ())) :bad)
pfdietz's avatar
pfdietz committed
30
     (program-error () :good)))
31 32
  :good)

pfdietz's avatar
pfdietz committed
33 34 35
(deftest defgeneric.error.3
  ;; Cannot make special operators generic
  (loop for name in *cl-special-operator-symbols*
sds's avatar
sds committed
36 37 38 39 40
        for result =
        (handler-case
         (progn (eval `(defgeneric ,name ())) t)
         (program-error () nil))
        when result collect name)
pfdietz's avatar
pfdietz committed
41 42 43
  nil)

(deftest defgeneric.error.4
44
  (signals-error (defgeneric defgeneric-error-fn.4 (x y)
sds's avatar
sds committed
45 46
                    (:argument-precedence-order x y x))
                 program-error)
47
  t)
pfdietz's avatar
pfdietz committed
48 49

(deftest defgeneric.error.5
50
  (signals-error (defgeneric defgeneric-error-fn.5 (x)
sds's avatar
sds committed
51 52 53
                    (:documentation "some documentation")
                    (:documentation "illegally repeated documentation"))
                 program-error)
54
  t)
pfdietz's avatar
pfdietz committed
55 56

(deftest defgeneric.error.6
57
  (signals-error (defgeneric defgeneric-error-fn.6 (x)
sds's avatar
sds committed
58 59
                    (unknown-option nil))
                 program-error)
60
  t)
pfdietz's avatar
pfdietz committed
61 62 63 64 65

(deftest defgeneric.error.7
  (handler-case
   (progn
     (eval '(defgeneric defgeneric-error-fn.7 (x y)
sds's avatar
sds committed
66
              (:method ((x t)) x)))
pfdietz's avatar
pfdietz committed
67 68 69 70
     :bad)
   (error () :good))
  :good)

71
(deftest defgeneric.error.8
72
  (signals-error (defgeneric defgeneric-error-fn.8 (x y)
sds's avatar
sds committed
73 74
                    (:argument-precedence-order x))
                 program-error)
75
  t)
76 77


78 79 80 81 82 83
;;; Non-congruent methods cause defgeneric to signal an error

(deftest defgeneric.error.9
  (handler-case
   (progn
     (eval '(defgeneric defgeneric-error-fn.9 (x)
sds's avatar
sds committed
84
              (:method ((x t)(y t)) t)))
85 86 87 88 89 90 91 92 93
     :bad)
   (error () :good))
  :good)


(deftest defgeneric.error.10
  (handler-case
   (progn
     (eval '(defgeneric defgeneric-error-fn.10 (x &optional y)
sds's avatar
sds committed
94
              (:method ((x t)) t)))
95 96 97 98 99 100 101 102
     :bad)
   (error () :good))
  :good)

(deftest defgeneric.error.11
  (handler-case
   (progn
     (eval '(defgeneric defgeneric-error-fn.11 (x &optional y)
sds's avatar
sds committed
103
              (:method (x &optional y z) t)))
104 105 106 107 108 109 110 111
     :bad)
   (error () :good))
  :good)

(deftest defgeneric.error.12
  (handler-case
   (progn
     (eval '(defgeneric defgeneric-error-fn.12 (x &rest y)
sds's avatar
sds committed
112
              (:method (x) t)))
113 114 115 116 117 118 119 120
     :bad)
   (error () :good))
  :good)

(deftest defgeneric.error.13
  (handler-case
   (progn
     (eval '(defgeneric defgeneric-error-fn.13 (x)
sds's avatar
sds committed
121
              (:method (x &rest y) t)))
122 123 124 125 126 127 128 129
     :bad)
   (error () :good))
  :good)

(deftest defgeneric.error.14
  (handler-case
   (progn
     (eval '(defgeneric defgeneric-error-fn.14 (x &key)
sds's avatar
sds committed
130
              (:method (x) t)))
131 132 133 134 135 136 137 138
     :bad)
   (error () :good))
  :good)

(deftest defgeneric.error.15
  (handler-case
   (progn
     (eval '(defgeneric defgeneric-error-fn.15 (x &key y)
sds's avatar
sds committed
139
              (:method (x) t)))
140 141 142 143 144 145 146 147
     :bad)
   (error () :good))
  :good)

(deftest defgeneric.error.16
  (handler-case
   (progn
     (eval '(defgeneric defgeneric-error-fn.16 (x)
sds's avatar
sds committed
148
              (:method (x &key) t)))
149 150 151 152 153 154 155 156
     :bad)
   (error () :good))
  :good)

(deftest defgeneric.error.17
  (handler-case
   (progn
     (eval '(defgeneric defgeneric-error-fn.17 (x)
sds's avatar
sds committed
157
              (:method (x &key foo) t)))
158 159 160 161 162 163 164 165
     :bad)
   (error () :good))
  :good)

(deftest defgeneric.error.18
  (handler-case
   (progn
     (eval '(defgeneric defgeneric-error-fn.18 (x &key foo)
sds's avatar
sds committed
166
              (:method (x &key) t)))
167 168 169 170 171 172 173 174
     :bad)
   (error () :good))
  :good)

(deftest defgeneric.error.19
  (handler-case
   (progn
     (eval '(defgeneric defgeneric-error-fn.19 (x &key foo)
sds's avatar
sds committed
175
              (:method (x &key bar) t)))
176 177 178 179
     :bad)
   (error () :good))
  :good)

180 181 182 183 184
;;; A close reading of the rules for keyword arguments to
;;; generic functions convinced me that the following two
;;; error tests are necessary.  See sections 7.6.5 of the CLHS.

(deftest defgeneric.error.20
185
  (signals-error
186
   (let ((fn (defgeneric defgeneric-error-fn.20 (x &key)
sds's avatar
sds committed
187 188
               (:method ((x number) &key foo) (list x foo))
               (:method ((x symbol) &key bar) (list x bar)))))
189 190 191
     (funcall fn 1 :bar 'a))
   program-error)
  t)
192 193

(deftest defgeneric.error.21
194
  (signals-error
195
   (let ((fn (defgeneric defgeneric-error-fn.21 (x &key)
sds's avatar
sds committed
196 197
               (:method ((x number) &key foo &allow-other-keys) (list x foo))
               (:method ((x symbol) &key bar) (list x bar)))))
198 199 200
     (funcall fn 'x :foo 'a))
   program-error)
  t)
201

202 203 204 205 206 207 208 209 210 211 212 213
;;;

(deftest defgeneric.error.22
  (progn
    (defgeneric defgeneric-error-fn.22 (x))
    (defmethod defgeneric-error-fn.22 ((x t)) nil)
    (handler-case
     (eval '(defgeneric defgeneric-error-fn.22 (x y)))
     (error () :good)))
  :good)


214 215 216 217
;;; Non error cases

(deftest defgeneric.1
  (let ((fn (eval '(defgeneric defgeneric.fun.1 (x y z)
sds's avatar
sds committed
218
                     (:method ((x t) (y t) (z t)) (list x y z))))))
219
    (declare (type function fn))
220 221
    (values
     (typep* fn 'generic-function)
pfdietz's avatar
pfdietz committed
222
     (typep* fn 'standard-generic-function)
223
     (funcall fn 'a 'b 'c)
pfdietz's avatar
pfdietz committed
224 225 226
     (apply fn 1 2 3 nil)
     (apply fn (list 4 5 6))
     (mapcar fn '(1 2) '(3 4) '(5 6))
227
     (defgeneric.fun.1 'd 'e 'f)))
pfdietz's avatar
pfdietz committed
228
  t t (a b c) (1 2 3) (4 5 6) ((1 3 5) (2 4 6)) (d e f))
229 230 231

(deftest defgeneric.2
  (let ((fn (eval '(defgeneric defgeneric.fun.2 (x y z)
sds's avatar
sds committed
232 233
                     (:documentation "boo!")
                     (:method ((x t) (y t) (z t)) (vector x y z))))))
234
    (declare (type function fn))
235 236
    (values
     (typep* fn 'generic-function)
pfdietz's avatar
pfdietz committed
237
     (typep* fn 'standard-generic-function)
238 239 240 241
     (funcall fn 'a 'b 'c)
     (defgeneric.fun.2 'd 'e 'f)
     (let ((doc (documentation fn t)))
       (or (not doc)
sds's avatar
sds committed
242
           (and (stringp doc) (string=t doc "boo!"))))
243 244
     (let ((doc (documentation fn 'function)))
       (or (not doc)
sds's avatar
sds committed
245
           (and (stringp doc) (string=t doc "boo!"))))
246 247 248
     (setf (documentation fn t) "foo")
     (let ((doc (documentation fn t)))
       (or (not doc)
sds's avatar
sds committed
249
           (and (stringp doc) (string=t doc "foo"))))
250 251 252
     (setf (documentation fn 'function) "bar")
     (let ((doc (documentation fn t)))
       (or (not doc)
sds's avatar
sds committed
253 254
           (and (stringp doc) (string=t doc "bar"))))))

255
  t t #(a b c) #(d e f) t t "foo" t "bar" t)
256 257 258

(deftest defgeneric.3
  (let ((fn (eval '(defgeneric defgeneric.fun.3 (x y)
sds's avatar
sds committed
259 260
                     (:method ((x t) (y symbol)) (list x y))
                     (:method ((x symbol) (y t)) (list y x))))))
261
    (declare (type function fn))
262 263
    (values
     (typep* fn 'generic-function)
pfdietz's avatar
pfdietz committed
264
     (typep* fn 'standard-generic-function)
265 266 267
     (funcall fn 1 'a)
     (funcall fn 'b 2)
     (funcall fn 'a 'b)))
pfdietz's avatar
pfdietz committed
268
  t t
269 270 271 272 273 274
  (1 a)
  (2 b)
  (b a))

(deftest defgeneric.4
  (let ((fn (eval '(defgeneric defgeneric.fun.4 (x y)
sds's avatar
sds committed
275 276 277
                     (:argument-precedence-order y x)
                     (:method ((x t) (y symbol)) (list x y))
                     (:method ((x symbol) (y t)) (list y x))))))
278
    (declare (type function fn))
279 280
    (values
     (typep* fn 'generic-function)
pfdietz's avatar
pfdietz committed
281
     (typep* fn 'standard-generic-function)
282 283 284
     (funcall fn 1 'a)
     (funcall fn 'b 2)
     (funcall fn 'a 'b)))
pfdietz's avatar
pfdietz committed
285
  t t
286 287 288
  (1 a)
  (2 b)
  (a b))
pfdietz's avatar
pfdietz committed
289 290 291

(deftest defgeneric.5
  (let ((fn (eval '(defgeneric defgeneric.fun.5 ()
sds's avatar
sds committed
292
                     (:method () (values))))))
293
    (declare (type function fn))
pfdietz's avatar
pfdietz committed
294 295 296 297 298 299 300 301 302 303
    (values
     (typep* fn 'generic-function)
     (typep* fn 'standard-generic-function)
     (multiple-value-list (funcall fn))
     (multiple-value-list (defgeneric.fun.5))
     (multiple-value-list (apply fn nil))))
  t t nil nil nil)

(deftest defgeneric.6
  (let ((fn (eval '(defgeneric defgeneric.fun.6 ()
sds's avatar
sds committed
304
                     (:method () (values 'a 'b 'c))))))
305
    (declare (type function fn))
pfdietz's avatar
pfdietz committed
306 307 308 309 310 311 312 313 314 315
    (values
     (typep* fn 'generic-function)
     (typep* fn 'standard-generic-function)
     (multiple-value-list (funcall fn))
     (multiple-value-list (defgeneric.fun.6))
     (multiple-value-list (apply fn nil))))
  t t (a b c) (a b c) (a b c))

(deftest defgeneric.7
  (let ((fn (eval '(defgeneric defgeneric.fun.7 ()
sds's avatar
sds committed
316
                     (:method () (return-from defgeneric.fun.7 'a) 'b)))))
317
    (declare (type function fn))
pfdietz's avatar
pfdietz committed
318 319 320 321 322 323 324 325
    (values
     (typep* fn 'generic-function)
     (typep* fn 'standard-generic-function)
     (multiple-value-list (funcall fn))
     (multiple-value-list (defgeneric.fun.7))
     (multiple-value-list (apply fn nil))))
  t t (a) (a) (a))

326 327
(deftest defgeneric.8
  (let ((fn (eval '(defgeneric defgeneric.fun.8 (x &optional y z)
sds's avatar
sds committed
328 329 330 331
                     (:method ((x number) &optional y z)
                              (list x y z))
                     (:method ((p symbol) &optional q r)
                              (list r q p))))))
332
    (declare (type function fn))
333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351
    (values
     (typep* fn 'generic-function)
     (typep* fn 'standard-generic-function)
     (multiple-value-list (funcall fn 1))
     (multiple-value-list (funcall fn 1 2))
     (multiple-value-list (funcall fn 1 2 3))
     (multiple-value-list (defgeneric.fun.8 'a))
     (multiple-value-list (defgeneric.fun.8 'a 'b))
     (multiple-value-list (defgeneric.fun.8 'a 'b 'c))
     (multiple-value-list (apply fn '(x y z)))))
  t t
  ((1 nil nil))
  ((1 2 nil))
  ((1 2 3))
  ((nil nil a))
  ((nil b a))
  ((c b a))
  ((z y x)))

352 353
(deftest defgeneric.9
  (let ((fn (eval '(defgeneric defgeneric.fun.9 (x &optional y z)
sds's avatar
sds committed
354 355 356 357
                     (:method ((x number) &optional (y 10) (z 20))
                              (list x y z))
                     (:method ((p symbol) &optional (q 's) (r 't))
                              (list r q p))))))
358
    (declare (type function fn))
359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374
    (values
     (funcall fn 1)
     (funcall fn 1 2)
     (funcall fn 1 2 3)
     (funcall fn 'a)
     (funcall fn 'a 'b)
     (funcall fn 'a 'b 'c)))
  (1 10 20)
  (1 2 20)
  (1 2 3)
  (t s a)
  (t b a)
  (c b a))

 (deftest defgeneric.10
   (let ((fn (eval '(defgeneric defgeneric.fun.10 (x &rest y)
sds's avatar
sds committed
375
                      (:method ((x number) &key foo) (list x foo))))))
376
     (declare (type function fn))
377 378 379 380 381 382 383 384 385 386 387 388 389 390
     (values
      (funcall fn 1)
      (funcall fn 1 :foo 'a)
      (defgeneric.fun.10 5/3 :foo 'x :foo 'y)
      (defgeneric.fun.10 10 :bar t :allow-other-keys t)
      (defgeneric.fun.10 20 :allow-other-keys nil :foo 'x)))
   (1 nil)
   (1 a)
   (5/3 x)
   (10 nil)
   (20 x))

 (deftest defgeneric.11
   (let ((fn (eval '(defgeneric defgeneric.fun.11 (x &key)
sds's avatar
sds committed
391
                      (:method ((x number) &key foo) (list x foo))))))
392
     (declare (type function fn))
393 394 395 396 397 398 399 400 401 402 403 404 405 406
     (values
      (funcall fn 1)
      (funcall fn 1 :foo 'a)
      (defgeneric.fun.11 5/3 :foo 'x :foo 'y)
      (defgeneric.fun.11 11 :bar t :allow-other-keys t)
      (defgeneric.fun.11 20 :allow-other-keys nil :foo 'x)))
   (1 nil)
   (1 a)
   (5/3 x)
   (11 nil)
   (20 x))

 (deftest defgeneric.12
   (let ((fn (eval '(defgeneric defgeneric.fun.12 (x &key foo bar baz)
sds's avatar
sds committed
407
                      (:method ((x number) &rest y) (list x y))))))
408
     (declare (type function fn))
409 410 411 412 413 414 415 416 417 418 419 420 421 422
     (values
      (funcall fn 1)
      (funcall fn 1 :foo 'a)
      (defgeneric.fun.12 5/3 :foo 'x :foo 'y :bar 'z)
      (defgeneric.fun.12 11 :zzz t :allow-other-keys t)
      (defgeneric.fun.12 20 :allow-other-keys nil :foo 'x)))
   (1 nil)
   (1 (:foo a))
   (5/3 (:foo x :foo y :bar z))
   (11 (:zzz t :allow-other-keys t))
   (20 (:allow-other-keys nil :foo x)))

 (deftest defgeneric.13
   (let ((fn (eval '(defgeneric defgeneric.fun.13 (x &key)
sds's avatar
sds committed
423 424
                      (:method ((x number) &key foo) (list x foo))
                      (:method ((x symbol) &key bar) (list x bar))))))
425
     (declare (type function fn))
426 427 428 429
     (values
      (funcall fn 1)
      (funcall fn 'a)
      (funcall fn 1 :foo 2)
430 431 432
      ;; (funcall fn 1 :foo 2 :bar 3)
      ;; (funcall fn 1 :bar 4)
      ;; (funcall fn 'a :foo 'b)
433
      (funcall fn 'a :bar 'b)
434 435
      ;; (funcall fn 'a :foo 'c :bar 'b)
      ))
436 437 438
   (1 nil)
   (a nil)
   (1 2)
439 440 441
   ;; (1 2)
   ;; (1 nil)
   ;; (a nil)
442
   (a b)
443 444
   ;; (a b)
   )
445 446 447

 (deftest defgeneric.14
   (let ((fn (eval '(defgeneric defgeneric.fun.14 (x &key &allow-other-keys)
sds's avatar
sds committed
448 449
                      (:method ((x number) &key foo) (list x foo))
                      (:method ((x symbol) &key bar) (list x bar))))))
450
     (declare (type function fn))
451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477
     (values
      (funcall fn 1)
      (funcall fn 'a)
      (funcall fn 1 :foo 2)
      (funcall fn 1 :foo 2 :bar 3)
      (funcall fn 1 :bar 4)
      (funcall fn 'a :foo 'b)
      (funcall fn 'a :bar 'b)
      (funcall fn 'a :foo 'c :bar 'b)
      (funcall fn 1 :baz 10)
      (funcall fn 'a :baz 10)
      (funcall fn 1 :allow-other-keys nil :baz 'a)
      (funcall fn 'a :allow-other-keys nil :baz 'b)
      ))
   (1 nil)
   (a nil)
   (1 2)
   (1 2)
   (1 nil)
   (a nil)
   (a b)
   (a b)
   (1 nil)
   (a nil)
   (1 nil)
   (a nil))

478 479
 (deftest defgeneric.15
   (let ((fn (eval '(defgeneric defgeneric.fun.15 (x &key)
sds's avatar
sds committed
480 481 482
                      (:method ((x number) &key foo &allow-other-keys)
                               (list x foo))
                      (:method ((x symbol) &key bar) (list x bar))))))
483
     (declare (type function fn))
484 485 486 487 488 489
     (values
      (funcall fn 1)
      (funcall fn 'a)
      (funcall fn 1 :foo 2)
      (funcall fn 1 :foo 2 :bar 3)
      (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 499 500 501 502 503 504 505 506
      ))
   (1 nil)
   (a nil)
   (1 2)
   (1 2)
   (1 nil)
   (a nil)
   (a b)
   (a b)
   (1 nil)
507
   ;; (a nil)
508
   (1 nil)
509 510
   ;; (a nil)
   )
511 512 513

 (deftest defgeneric.16
   (let ((fn (eval '(defgeneric defgeneric.fun.16 (x &key)
sds's avatar
sds committed
514 515 516 517
                      (:method ((x number) &key (foo 'a))
                               (list x foo))
                      (:method ((x symbol) &key foo)
                               (list x foo))))))
518
     (declare (type function fn))
519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534
     (values
      (funcall fn 1)
      (funcall fn 1 :foo nil)
      (funcall fn 1 :foo 2)
      (funcall fn 'x)
      (funcall fn 'x :foo nil)
      (funcall fn 'x :foo 'y)))
   (1 a)
   (1 nil)
   (1 2)
   (x nil)
   (x nil)
   (x y))

 (deftest defgeneric.17
   (let ((fn (eval '(defgeneric defgeneric.fun.17 (x &key)
sds's avatar
sds committed
535 536 537 538
                      (:method ((x number) &key (foo 'a foo-p))
                               (list x foo (notnot foo-p)))
                      (:method ((x symbol) &key foo)
                               (list x foo))))))
539
     (declare (type function fn))
540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555
     (values
      (funcall fn 1)
      (funcall fn 1 :foo nil)
      (funcall fn 1 :foo 2)
      (funcall fn 'x)
      (funcall fn 'x :foo nil)
      (funcall fn 'x :foo 'y)))
   (1 a nil)
   (1 nil t)
   (1 2 t)
   (x nil)
   (x nil)
   (x y))

(deftest defgeneric.18
   (let ((fn (eval '(defgeneric defgeneric.fun.18 (x &optional y)
sds's avatar
sds committed
556 557 558 559
                      (:method ((x number) &optional (y 'a))
                               (list x y))
                      (:method ((x symbol) &optional (z nil z-p))
                               (list x z (notnot z-p)))))))
560
     (declare (type function fn))
561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576
     (values
      (funcall fn 1)
      (funcall fn 1 nil)
      (funcall fn 1 2)
      (funcall fn 'x)
      (funcall fn 'x nil)
      (funcall fn 'x 'y)))
   (1 a)
   (1 nil)
   (1 2)
   (x nil nil)
   (x nil t)
   (x y t))

 (deftest defgeneric.19
   (let ((fn (eval '(defgeneric defgeneric.fun.19 (x &key)
sds's avatar
sds committed
577 578
                      (:method ((x number) &key ((:bar foo) 'a foo-p))
                               (list x foo (notnot foo-p)))))))
579
     (declare (type function fn))
580 581 582 583 584 585 586 587 588 589
     (values
      (funcall fn 1)
      (funcall fn 1 :bar nil)
      (funcall fn 1 :bar 2)))
   (1 a nil)
   (1 nil t)
   (1 2 t))

(deftest defgeneric.20
   (let ((fn (eval '(defgeneric defgeneric.fun.20 (x &optional y z)
sds's avatar
sds committed
590 591 592 593 594
                      (:method ((x number)
                                &optional (y (1+ x) y-p)
                                          (z (if y-p (1+ y) (+ x 10))
                                             z-p))
                               (list x y (notnot y-p) z (notnot z-p)))))))
595
     (declare (type function fn))
596 597 598 599 600 601 602 603
     (values
      (funcall fn 1)
      (funcall fn 1 5)
      (funcall fn 1 5 9)))
   (1 2 nil 11 nil)
   (1 5 t 6 nil)
   (1 5 t 9 t))

604 605
(deftest defgeneric.21
   (let ((fn (eval '(defgeneric defgeneric.fun.21 (x &key)
sds's avatar
sds committed
606 607 608 609 610
                      (:method ((x number)
                                &key (y (1+ x) y-p)
                                (z (if y-p (1+ y) (+ x 10))
                                   z-p))
                               (list x y (notnot y-p) z (notnot z-p)))))))
611
     (declare (type function fn))
612 613 614 615 616 617 618 619 620 621 622 623 624 625
     (values
      (funcall fn 1)
      (funcall fn 1 :y 5)
      (funcall fn 1 :y 5 :z 9)
      (funcall fn 1 :z 8)
      (funcall fn 1 :z 8 :y 4)))
   (1 2 nil 11 nil)
   (1 5 t 6 nil)
   (1 5 t 9 t)
   (1 2 nil 8 t)
   (1 4 t 8 t))

(deftest defgeneric.22
   (let ((fn (eval '(defgeneric defgeneric.fun.22 (x &key)
sds's avatar
sds committed
626 627
                      (:method ((x number) &key ((:allow-other-keys y)))
                               (list x y))))))
628
     (declare (type function fn))
629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650
     (values
      (funcall fn 1)
      (funcall fn 1 :allow-other-keys nil)
      (funcall fn 1 :allow-other-keys t)
      (funcall fn 1 :foo 'x :allow-other-keys t :bar 'y)
      (funcall fn 1 :allow-other-keys t :foo 'x)
      (funcall fn 1 :allow-other-keys nil :allow-other-keys t)
      (funcall fn 1 :foo 'x :allow-other-keys t :allow-other-keys nil)
      (funcall fn 1 :allow-other-keys t 'foo 'y :allow-other-keys nil)
      (funcall fn 1 :allow-other-keys t :allow-other-keys nil '#:foo 'z)))
   (1 nil)
   (1 nil)
   (1 t)
   (1 t)
   (1 t)
   (1 nil)
   (1 t)
   (1 t)
   (1 t))

(deftest defgeneric.23
   (let ((fn (eval '(defgeneric defgeneric.fun.23 (x)
sds's avatar
sds committed
651 652
                      (:method ((x number) &aux (y (1+ x))) (list x y))
                      (:method ((x symbol) &aux (z (list x))) (list x z))))))
653
     (declare (type function fn))
654 655 656 657 658
     (values
      (funcall fn 1)
      (funcall fn 'a)))
   (1 2) (a (a)))

659

660 661
(deftest defgeneric.24
   (let ((fn (eval '(defgeneric defgeneric.fun.24 (x)
sds's avatar
sds committed
662 663 664 665
                      (:method ((x number) &aux (y (1+ x)) (z (1+ y)))
                               (list x y z))
                      (:method ((x symbol) &aux (y (list x)) (z (list x y)))
                               (list x y z))))))
666 667 668 669 670 671 672 673
     (values
      (funcall fn 1)
      (funcall fn 'a)))
   (1 2 3)
   (a (a) (a (a))))

(deftest defgeneric.25
  (let ((fn (eval '(defgeneric defgeneric.fun.25 (x &optional y &key)
sds's avatar
sds committed
674 675 676 677 678
                      (:method ((x symbol) &optional (y 'd y-p)
                                &key ((:foo bar) (list x y) bar-p)
                                &aux (z (list x y (notnot y-p)
                                              bar (notnot bar-p))))
                               z)))))
679
    (declare (type function fn))
680 681 682 683 684 685 686 687 688 689
    (values
     (funcall fn 'a)
     (funcall fn 'a 'b)
     (funcall fn 'a 'b :foo 'c)))
  (a d nil (a d) nil)
  (a b t (a b) nil)
  (a b t c t))

(deftest defgeneric.26
  (let ((fn (eval '(defgeneric defgeneric.fun.26 (x)
sds's avatar
sds committed
690 691 692
                     (declare (optimize (safety 3)))
                     (:method ((x symbol)) x)
                     (declare (optimize (debug 3)))))))
693
    (declare (type function fn))
694 695 696
    (funcall fn 'a))
  a)

697
#|
698
(when (subtypep (class-of (find-class 'standard-method))
sds's avatar
sds committed
699
                'standard-class)
700 701 702
  (defclass substandard-method (standard-method) ())
  (deftest defgeneric.27
    (let ((fn (eval '(defgeneric defgeneric.fun.27 (x y)
sds's avatar
sds committed
703 704 705 706
                       (:method-class substandard-method)
                       (:method ((x number) (y number)) (+ x y))
                       (:method ((x string) (y string))
                                (concatenate 'string x y))))))
707
      (declare (type function fn))
708 709 710 711
      (values
       (funcall fn 1 2)
       (funcall fn "1" "2")))
    3 "12"))
712
|#
713 714 715

(deftest defgeneric.28
  (let ((fn (eval '(defgeneric defgeneric.fun.28 (x &key)
sds's avatar
sds committed
716 717 718
                     (:method ((x integer) &key foo) (list x foo))
                     (:method ((x number) &key bar) (list x bar))
                     (:method ((x t) &key baz) (list x baz))))))
719
    (declare (type function fn))
720
    (values
sds's avatar
sds committed
721

722 723 724 725 726 727 728 729
     (funcall fn 1)
     (funcall fn 1 :foo 'a)
     (funcall fn 1 :bar 'b)
     (funcall fn 1 :baz 'c)
     (funcall fn 1 :bar 'b :baz 'c)
     (funcall fn 1 :foo 'a :bar 'b)
     (funcall fn 1 :foo 'a :baz 'c)
     (funcall fn 1 :foo 'a :bar 'b :baz 'c)
sds's avatar
sds committed
730

731 732 733 734
     (funcall fn 5/3)
     (funcall fn 5/3 :bar 'b)
     (funcall fn 5/3 :baz 'c)
     (funcall fn 5/3 :bar 'b :baz 'c)
sds's avatar
sds committed
735

736 737
     (funcall fn 'x)
     (funcall fn 'x :baz 'c)
sds's avatar
sds committed
738

739 740 741 742 743 744 745 746 747
     ))

  (1 nil) (1 a) (1 nil) (1 nil)
  (1 nil) (1 a) (1 a)   (1 a)

  (5/3 nil) (5/3 b)   (5/3 nil) (5/3 b)

  (x nil) (x c))

748 749 750 751 752 753 754 755
(defclass defgeneric.29.class.1 () ())
(defclass defgeneric.29.class.2 () ())
(defclass defgeneric.29.class.3
  (defgeneric.29.class.1 defgeneric.29.class.2)
  ())

(deftest defgeneric.29
  (let ((fn
sds's avatar
sds committed
756 757 758
         (eval '(defgeneric defgeneric.fun.29 (x &key)
                  (:method ((x defgeneric.29.class.1) &key foo) foo)
                  (:method ((x defgeneric.29.class.2) &key bar) bar)))))
759
    (declare (type function fn))
760 761 762 763 764 765 766 767 768
    (let ((x (make-instance 'defgeneric.29.class.3)))
      (values
       (funcall fn x)
       (funcall fn x :foo 'a)
       (funcall fn x :bar 'b)
       (funcall fn x :foo 'a :bar 'b)
       (funcall fn x :bar 'b :foo 'a))))
  nil a nil a a)

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))
sds's avatar
sds committed
772
                'standard-class)
773 774
  (defclass substandard-generic-function (standard-generic-function) ()
    (:metaclass #.(class-name (class-of
sds's avatar
sds committed
775
                               (find-class 'standard-generic-function)))))
776 777
  (deftest defgeneric.30
    (let ((fn
sds's avatar
sds committed
778 779 780 781
           (eval '(defgeneric defgeneric.fun.29 (x)
                    (:generic-function-class substandard-generic-function)
                    (:method ((x symbol)) 1)
                    (:method ((x integer)) 2)))))
782
      (declare (type function fn))
783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800
      (values
       (typep* fn 'substandard-generic-function)
       (typep* fn 'standard-generic-function)
       (typep* fn 'generic-function)
       (typep* fn 'function)
       (funcall fn 'a)
       (funcall fn 1)
       (defgeneric.fun.29 'x)
       (defgeneric.fun.29 12345678901234567890)))
    t t t t 1 2 1 2))

(deftest defgeneric.31
  (progn
    (defgeneric defgeneric.fun.31 (x) (:method ((x t)) t))
    (defgeneric defgeneric.fun.31 (x y) (:method ((x t) (y t)) (list x y)))
    (defgeneric.fun.31 'a 'b))
  (a b))

801 802 803 804 805 806 807 808 809
(deftest defgeneric.32
  (progn
    (defgeneric defgeneric.fun.32 (x) (:method ((x symbol)) :bad))
    (defgeneric defgeneric.fun.32 (x) (:method ((x t)) :good))
    (defgeneric.fun.32 'x))
  :good)

(deftest defgeneric.33
  (let ((fn
sds's avatar
sds committed
810 811 812 813 814 815
         (eval
          '(defgeneric (setf defgeneric.fun.33) (x y &rest args)
             (:method (x (y cons) &rest args)
                      (assert (null args)) (setf (car y) x))
             (:method (x (y array) &rest args)
                      (setf (apply #'aref y args) x))))))
816
    (declare (type function fn))
817 818 819
    (values
     (let ((z (list 'a 'b)))
       (list
sds's avatar
sds committed
820 821
        (setf (defgeneric.fun.33 z) 'c)
        z))
822 823
     (let ((a (make-array '(10) :initial-element nil)))
       (list
sds's avatar
sds committed
824 825
        (setf (defgeneric.fun.33 a 5) 'd)
        a))))
826 827 828 829 830
  (c (c b))
  (d #(nil nil nil nil nil d nil nil nil nil)))

(deftest defgeneric.34
  (let ((fn (eval '(defgeneric #:defgeneric.fun.34 (x)
sds's avatar
sds committed
831
                     (:method ((x t)) (list x :good))))))
832 833
    (funcall fn 10))
  (10 :good))
834

835 836
(deftest defgeneric.35
  (let ((fn (eval '(defgeneric defgeneric.fun.35 (x)
sds's avatar
sds committed
837 838 839 840 841
                     (:method ((x (eql 'a)))
                              (declare (optimize (speed 0)))
                              "FOO"
                              (declare (optimize (safety 3)))
                              x)))))
842
    (declare (type function fn))
843 844 845 846
    (values
     (funcall fn 'a)
     (let ((method (first (compute-applicable-methods fn '(a)))))
       (and method
sds's avatar
sds committed
847 848 849 850 851 852 853
            (let ((doc (documentation method t)))
              (list
               (or (null doc) (equalt doc "FOO"))
               (setf (documentation method t) "BAR")
               (let ((doc (documentation method t)))
                 (or (null doc) (equalt doc "BAR")))
               ))))))
854
  a (t "BAR" t))