defgeneric-method-combination-list.lsp 6.98 KB
Newer Older
1 2 3 4 5
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat May 24 21:31:55 2003
;;;; Contains: Tests of DEFGENERIC with :method-combination LIST

6

7 8 9

(declaim (special *x*))

10 11
(compile-and-load "defgeneric-method-combination-aux.lsp")

12 13
(deftest defgeneric-method-combination.list.1
  (let ((*x* nil)
sds's avatar
sds committed
14 15 16 17 18 19 20
        (fn
         (eval '(defgeneric dg-mc.fun.list.1 (x)
                  (:method-combination list)
                  (:method list ((x integer)) (car (push 'd *x*)))
                  (:method list ((x rational)) (car (push 'c *x*)))
                  (:method list ((x number)) (car (push 'b *x*)))
                  (:method list ((x t)) (car (push 'a *x*)))))))
21
    (declare (type generic-function fn))
22
    (flet ((%f (y)
sds's avatar
sds committed
23 24
               (let ((*x* nil))
                 (list (funcall fn y) *x*))))
25 26 27 28 29 30 31 32
    (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a))))
  ((d c b a) (a b c d))
  ((c b a) (a b c))
  ((b a) (a b))
  ((a) (a)))

(deftest defgeneric-method-combination.list.2
  (let ((*x* nil)
sds's avatar
sds committed
33 34 35 36 37 38 39
        (fn
         (eval '(defgeneric dg-mc.fun.list.2 (x)
                  (:method-combination list :most-specific-first)
                  (:method list ((x integer)) (car (push 'd *x*)))
                  (:method list ((x rational)) (car (push 'c *x*)))
                  (:method list ((x number)) (car (push 'b *x*)))
                  (:method list ((x t)) (car (push 'a *x*)))))))
40
    (declare (type generic-function fn))
41
    (flet ((%f (y)
sds's avatar
sds committed
42 43
               (let ((*x* nil))
                 (list (funcall fn y) *x*))))
44 45 46 47 48 49 50 51
    (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a))))
  ((d c b a) (a b c d))
  ((c b a) (a b c))
  ((b a) (a b))
  ((a) (a)))

(deftest defgeneric-method-combination.list.3
  (let ((*x* nil)
sds's avatar
sds committed
52 53 54 55 56 57 58
        (fn
         (eval '(defgeneric dg-mc.fun.list.3 (x)
                  (:method-combination list :most-specific-last)
                  (:method list ((x integer)) (car (push 'd *x*)))
                  (:method list ((x rational)) (car (push 'c *x*)))
                  (:method list ((x number)) (car (push 'b *x*)))
                  (:method list ((x t)) (car (push 'a *x*)))))))
59
    (declare (type generic-function fn))
60
    (flet ((%f (y)
sds's avatar
sds committed
61 62
               (let ((*x* nil))
                 (list (funcall fn y) *x*))))
63 64 65 66 67 68 69 70
    (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a))))
  ((a b c d) (d c b a))
  ((a b c) (c b a))
  ((a b) (b a))
  ((a) (a)))

(deftest defgeneric-method-combination.list.4
  (let ((fn
sds's avatar
sds committed
71 72 73 74 75 76 77
         (eval '(defgeneric dg-mc.fun.list.4 (x)
                  (:method-combination list)
                  (:method list ((x integer)) '(a b))
                  (:method :around ((x rational)) 'foo)
                  (:method list ((x number)) '(c d))
                  (:method list ((x symbol)) '(e f))
                  (:method list ((x t)) '(g h))))))
78
    (declare (type generic-function fn))
79 80 81 82 83 84 85 86 87 88
    (values
     (funcall fn 0)
     (funcall fn 4/3)
     (funcall fn 1.54)
     (funcall fn 'x)
     (funcall fn '(a b c))))
  foo foo ((c d) (g h)) ((e f) (g h)) ((g h)))

(deftest defgeneric-method-combination.list.5
  (let ((fn
sds's avatar
sds committed
89 90 91 92 93 94 95 96
         (eval '(defgeneric dg-mc.fun.list.5 (x)
                  (:method-combination list)
                  (:method list ((x integer)) 'a)
                  (:method :around ((x rational))
                           (list 'foo (call-next-method)))
                  (:method list ((x number)) 'b)
                  (:method list ((x symbol)) 'c)
                  (:method list ((x t)) 'd)))))
97
    (declare (type generic-function fn))
98 99 100 101 102 103 104 105 106 107
    (values
     (funcall fn 0)
     (funcall fn 4/3)
     (funcall fn 1.54)
     (funcall fn 'x)
     (funcall fn '(a b c))))
  (foo (a b d)) (foo (b d)) (b d) (c d) (d))

(deftest defgeneric-method-combination.list.6
  (let ((fn
sds's avatar
sds committed
108 109 110 111 112 113 114 115 116 117
         (eval '(defgeneric dg-mc.fun.list.6 (x)
                  (:method-combination list)
                  (:method list ((x integer)) 'a)
                  (:method :around ((x rational))
                           (list 'foo (call-next-method)))
                  (:method :around ((x real))
                           (list 'bar (call-next-method)))
                  (:method list ((x number)) 'b)
                  (:method list ((x symbol)) 'c)
                  (:method list ((x t)) 'd)))))
118
    (declare (type generic-function fn))
119 120 121 122 123 124 125 126 127 128 129
    (values
     (funcall fn 0)
     (funcall fn 4/3)
     (funcall fn 1.54)
     (funcall fn #c(1.0 2.0))
     (funcall fn 'x)
     (funcall fn '(a b c))))
  (foo (bar (a b d))) (foo (bar (b d))) (bar (b d)) (b d) (c d) (d))

(deftest defgeneric-method-combination.list.7
  (let ((fn
sds's avatar
sds committed
130 131 132 133 134 135
         (eval '(defgeneric dg-mc.fun.list.7 (x)
                  (:method-combination list)
                  (:method list ((x dgmc-class-04)) 'a)
                  (:method list ((x dgmc-class-03)) 'b)
                  (:method list ((x dgmc-class-02)) 'c)
                  (:method list ((x dgmc-class-01)) 'd)))))
136
    (declare (type generic-function fn))
137 138 139 140 141 142 143 144 145 146 147 148
    (values
     (funcall fn (make-instance 'dgmc-class-01))
     (funcall fn (make-instance 'dgmc-class-02))
     (funcall fn (make-instance 'dgmc-class-03))
     (funcall fn (make-instance 'dgmc-class-04))))
  (d)
  (c d)
  (b d)
  (a c b d))

(deftest defgeneric-method-combination.list.8
  (let ((fn
sds's avatar
sds committed
149 150 151 152 153 154 155 156
         (eval '(defgeneric dg-mc.list.8 (x)
                  (:method-combination list)
                  (:method list ((x (eql 1000))) 'a)
                  (:method :around ((x symbol)) (values))
                  (:method :around ((x integer)) (values 'a 'b 'c))
                  (:method :around ((x complex)) (call-next-method))
                  (:method :around ((x number)) (values 1 2 3 4 5 6))
                  (:method list ((x t)) 'b)))))
157
    (declare (type generic-function fn))
158 159 160 161 162 163
    (values
     (multiple-value-list (funcall fn 'a))
     (multiple-value-list (funcall fn 10))
     (multiple-value-list (funcall fn #c(9 8)))
     (multiple-value-list (funcall fn '(a b c)))))
  () (a b c) (1 2 3 4 5 6) ((b)))
164 165 166 167

(deftest defgeneric-method-combination.list.9
  (handler-case
   (let ((fn (eval '(defgeneric dg-mc.list.9 (x)
sds's avatar
sds committed
168
                      (:method-combination list)))))
169
     (declare (type generic-function fn))
170 171 172 173 174
     (funcall fn (list 'a)))
   (error () :error))
  :error)

(deftest defgeneric-method-combination.list.10
175 176
  (progn
    (eval '(defgeneric dg-mc.list.10 (x)
sds's avatar
sds committed
177 178
             (:method-combination list)
             (:method ((x t)) (list 'a))))
179 180 181
    (handler-case
     (dg-mc.list.10 'a)
     (error () :error)))
182 183 184
  :error)

(deftest defgeneric-method-combination.list.11
185 186
  (progn
    (eval '(defgeneric dg-mc.list.11 (x)
sds's avatar
sds committed
187 188
             (:method-combination list)
             (:method nonsense ((x t)) (list 'a))))
189 190 191
    (handler-case
     (dg-mc.list.11 0)
     (error () :error)))
192 193 194 195
  :error)

(deftest defgeneric-method-combination.list.12
  (let ((fn (eval '(defgeneric dg-mc.list.12 (x)
sds's avatar
sds committed
196 197 198
                     (:method-combination list)
                     (:method :around ((x t)) (list 'a))
                     (:method list ((x integer)) x)))))
199
    (declare (type generic-function fn))
200
    (handler-case (funcall fn (list 'b))
sds's avatar
sds committed
201
                  (error () :error)))
202
  :error)