defgeneric-method-combination-or.lsp 6.6 KB
Newer Older
1 2 3 4 5 6 7 8 9
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat May 24 21:31:55 2003
;;;; Contains: Tests of DEFGENERIC with :method-combination OR

(in-package :cl-test)

(declaim (special *x*))

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

12 13
(deftest defgeneric-method-combination.or.1
  (let ((*x* nil)
sds's avatar
sds committed
14 15 16 17 18 19 20
        (fn
         (eval '(defgeneric dg-mc.fun.or.1 (x)
                  (:method-combination or)
                  (:method or ((x integer)) (push 4 *x*) nil)
                  (:method or ((x rational)) (push 3 *x*) nil)
                  (:method or ((x number)) (push 2 *x*) nil)
                  (:method or ((x t)) (push 1 *x*) 'a)))))
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))))
  (a (1 2 3 4))
  (a (1 2 3))
  (a (1 2))
  (a (1)))

(deftest defgeneric-method-combination.or.2
  (let ((*x* nil)
sds's avatar
sds committed
33 34 35 36 37 38 39
        (fn
         (eval '(defgeneric dg-mc.fun.or.2 (x)
                  (:method-combination or :most-specific-first)
                  (:method or ((x integer)) (push 4 *x*) nil)
                  (:method or ((x rational)) (push 3 *x*) 'a)
                  (:method or ((x number)) (push 2 *x*) nil)
                  (:method or ((x t)) (push 1 *x*) 'b)))))
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
    (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a))))
  (a (3 4)) (a (3)) (b (1 2)) (b (1)))

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

(deftest defgeneric-method-combination.or.4
  (let ((fn
sds's avatar
sds committed
65 66 67 68 69 70 71
         (eval '(defgeneric dg-mc.or.4 (x)
                  (:method-combination or)
                  (:method or ((x integer)) nil)
                  (:method :around ((x rational)) 'foo)
                  (:method or ((x number)) 'b)
                  (:method or ((x symbol)) nil)
                  (:method or ((x t)) 'a)))))
72
    (declare (type generic-function fn))
73 74 75 76 77 78 79 80 81 82
    (values
     (funcall fn 0)
     (funcall fn 4/3)
     (funcall fn 1.54)
     (funcall fn 'x)
     (funcall fn '(a b c))))
  foo foo b a a)

(deftest defgeneric-method-combination.or.5
  (let ((fn
sds's avatar
sds committed
83 84 85 86 87 88 89 90
         (eval '(defgeneric dg-mc.or.5 (x)
                  (:method-combination or)
                  (:method or ((x integer)) 'a)
                  (:method :around ((x rational))
                           (list 'foo (call-next-method)))
                  (:method or ((x number)) nil)
                  (:method or ((x symbol)) 'b)
                  (:method or ((x t)) 'c)))))
91
    (declare (type generic-function fn))
92 93 94 95 96 97 98 99 100 101
    (values
     (funcall fn 0)
     (funcall fn 4/3)
     (funcall fn 1.54)
     (funcall fn 'x)
     (funcall fn '(a b c))))
  (foo a) (foo c) c b c)

(deftest defgeneric-method-combination.or.6
  (let ((fn
sds's avatar
sds committed
102 103 104 105 106 107 108 109 110 111
         (eval '(defgeneric dg-mc.or.6 (x)
                  (:method-combination or)
                  (:method or ((x integer)) 'a)
                  (:method :around ((x rational))
                           (list 'foo (call-next-method)))
                  (:method :around ((x real))
                           (list 'bar (call-next-method)))
                  (:method or ((x number)) 'b)
                  (:method or ((x symbol)) 'c)
                  (:method or ((x t)) 'd)))))
112
    (declare (type generic-function fn))
113 114 115 116 117 118 119 120 121 122 123
    (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)) (foo (bar b)) (bar b) b c d)

(deftest defgeneric-method-combination.or.7
  (let ((fn
sds's avatar
sds committed
124 125 126 127 128 129
         (eval '(defgeneric dg-mc.or.7 (x)
                  (:method-combination or)
                  (:method or ((x dgmc-class-04)) nil)
                  (:method or ((x dgmc-class-03)) nil)
                  (:method or ((x dgmc-class-02)) 'b)
                  (:method or ((x dgmc-class-01)) 'c)))))
130
    (declare (type generic-function fn))
131 132 133 134 135 136
    (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))))
  c b c b)
sds's avatar
sds committed
137

138 139
(deftest defgeneric-method-combination.or.8
  (let ((fn
sds's avatar
sds committed
140 141 142 143 144 145 146 147
         (eval '(defgeneric dg-mc.or.8 (x)
                  (:method-combination or)
                  (:method or ((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 or ((x t)) 'b)))))
148
    (declare (type generic-function fn))
149 150 151 152 153 154
    (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))
155 156 157 158

(deftest defgeneric-method-combination.or.9
  (handler-case
   (let ((fn (eval '(defgeneric dg-mc.or.9 (x)
sds's avatar
sds committed
159
                      (:method-combination or)))))
160
     (declare (type generic-function fn))
161 162 163 164 165
     (funcall fn (list 'a)))
   (error () :error))
  :error)

(deftest defgeneric-method-combination.or.10
166 167
  (progn
    (eval '(defgeneric dg-mc.or.10 (x)
sds's avatar
sds committed
168 169
             (:method-combination or)
             (:method ((x t)) 0)))
170 171 172
    (handler-case
     (dg-mc.or.10 'a)
     (error () :error)))
173 174 175
  :error)

(deftest defgeneric-method-combination.or.11
176 177
  (progn
    (eval '(defgeneric dg-mc.or.11 (x)
sds's avatar
sds committed
178 179
             (:method-combination or)
             (:method nonsense ((x t)) 0)))
180 181 182
    (handler-case
     (dg-mc.or.11 0)
     (error () :error)))
183 184 185 186
  :error)

(deftest defgeneric-method-combination.or.12
  (let ((fn (eval '(defgeneric dg-mc.or.12 (x)
sds's avatar
sds committed
187 188 189
                     (:method-combination or)
                     (:method :around ((x t)) t)
                     (:method or ((x integer)) x)))))
190
    (declare (type generic-function fn))
191
    (handler-case (funcall fn 'a)
sds's avatar
sds committed
192
                  (error () :error)))
193
  :error)