defgeneric-method-combination-nconc.lsp 7.74 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 NCONC

(in-package :cl-test)

(declaim (special *x*))

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

12 13
(deftest defgeneric-method-combination.nconc.1
  (let ((*x* nil)
sds's avatar
sds committed
14 15 16 17 18 19 20 21 22 23 24
        (fn
         (eval '(defgeneric dg-mc.fun.nconc.1 (x)
                  (:method-combination nconc)
                  (:method nconc ((x integer))
                           (copy-list (car (push '(d) *x*))))
                  (:method nconc ((x rational))
                           (copy-list (car (push '(c) *x*))))
                  (:method nconc ((x number))
                           (copy-list (car (push '(b) *x*))))
                  (:method nconc ((x t))
                           (copy-list (car (push '(a) *x*))))))))
25
    (declare (type generic-function fn))
26
    (flet ((%f (y)
sds's avatar
sds committed
27 28
               (let ((*x* nil))
                 (list (funcall fn y) *x*))))
29 30 31 32 33 34 35 36
    (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.nconc.2
  (let ((*x* nil)
sds's avatar
sds committed
37 38 39 40 41 42 43 44 45 46 47
        (fn
         (eval '(defgeneric dg-mc.fun.nconc.2 (x)
                  (:method-combination nconc :most-specific-first)
                  (:method nconc ((x integer))
                           (copy-list (car (push '(d) *x*))))
                  (:method nconc ((x rational))
                           (copy-list (car (push '(c) *x*))))
                  (:method nconc ((x number))
                           (copy-list (car (push '(b) *x*))))
                  (:method nconc ((x t))
                           (copy-list (car (push '(a) *x*))))))))
48
    (declare (type generic-function fn))
49
    (flet ((%f (y)
sds's avatar
sds committed
50 51
               (let ((*x* nil))
                 (list (funcall fn y) *x*))))
52 53 54 55 56 57 58 59
    (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.nconc.3
  (let ((*x* nil)
sds's avatar
sds committed
60 61 62 63 64 65 66 67 68 69 70
        (fn
         (eval '(defgeneric dg-mc.fun.nconc.3 (x)
                  (:method-combination nconc :most-specific-last)
                  (:method nconc ((x integer))
                           (copy-list (car (push '(d) *x*))))
                  (:method nconc ((x rational))
                           (copy-list (car (push '(c) *x*))))
                  (:method nconc ((x number))
                           (copy-list (car (push '(b) *x*))))
                  (:method nconc ((x t))
                           (copy-list (car (push '(a) *x*))))))))
71
    (declare (type generic-function fn))
72
    (flet ((%f (y)
sds's avatar
sds committed
73 74
               (let ((*x* nil))
                 (list (funcall fn y) *x*))))
75 76 77 78 79 80 81 82
    (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.nconc.4
  (let ((fn
sds's avatar
sds committed
83 84 85 86 87 88 89
         (eval '(defgeneric dg-mc.fun.nconc.4 (x)
                  (:method-combination nconc)
                  (:method nconc ((x integer)) (list 'a 'b))
                  (:method :around ((x rational)) 'foo)
                  (:method nconc ((x number)) (list 'c 'd))
                  (:method nconc ((x symbol)) (list 'e 'f))
                  (:method nconc ((x t)) (list 'g 'h))))))
90
    (declare (type generic-function fn))
91 92 93 94 95 96 97 98 99 100
    (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.nconc.5
  (let ((fn
sds's avatar
sds committed
101 102 103 104 105 106 107 108
         (eval '(defgeneric dg-mc.fun.nconc.5 (x)
                  (:method-combination nconc)
                  (:method nconc ((x integer)) (list 'a))
                  (:method :around ((x rational))
                           (list 'foo (call-next-method)))
                  (:method nconc ((x number)) (list 'b))
                  (:method nconc ((x symbol)) (list 'c))
                  (:method nconc ((x t)) (cons 'd 'e))))))
109
    (declare (type generic-function fn))
110 111 112 113 114 115 116 117 118 119
    (values
     (funcall fn 0)
     (funcall fn 4/3)
     (funcall fn 1.54)
     (funcall fn 'x)
     (funcall fn '(a b c))))
  (foo (a b d . e)) (foo (b d . e)) (b d . e) (c d . e) (d . e))

(deftest defgeneric-method-combination.nconc.6
  (let ((fn
sds's avatar
sds committed
120 121 122 123 124 125 126 127 128 129
         (eval '(defgeneric dg-mc.fun.nconc.6 (x)
                  (:method-combination nconc)
                  (:method nconc ((x integer)) (list 'a))
                  (:method :around ((x rational))
                           (list 'foo (call-next-method)))
                  (:method :around ((x real))
                           (list 'bar (call-next-method)))
                  (:method nconc ((x number)) (list 'b))
                  (:method nconc ((x symbol)) (list 'c))
                  (:method nconc ((x t)) (list 'd))))))
130
    (declare (type generic-function fn))
131 132 133 134 135 136 137 138 139 140 141
    (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.nconc.7
  (let ((fn
sds's avatar
sds committed
142 143 144 145 146 147
         (eval '(defgeneric dg-mc.fun.nconc.7 (x)
                  (:method-combination nconc)
                  (:method nconc ((x dgmc-class-04)) (list 'a))
                  (:method nconc ((x dgmc-class-03)) (list 'b))
                  (:method nconc ((x dgmc-class-02)) (list 'c))
                  (:method nconc ((x dgmc-class-01)) (list 'd))))))
148
    (declare (type generic-function fn))
149 150 151 152 153 154 155 156 157 158 159 160
    (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.nconc.8
  (let ((fn
sds's avatar
sds committed
161 162 163 164 165 166 167 168
         (eval '(defgeneric dg-mc.nconc.8 (x)
                  (:method-combination nconc)
                  (:method nconc ((x (eql 1000))) (list '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 nconc ((x t)) (list 'b))))))
169
    (declare (type generic-function fn))
170 171 172 173 174 175 176
    (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)))

177 178 179
(deftest defgeneric-method-combination.nconc.9
  (handler-case
   (let ((fn (eval '(defgeneric dg-mc.nconc.9 (x)
sds's avatar
sds committed
180
                      (:method-combination nconc)))))
181
     (declare (type generic-function fn))
182 183 184 185 186
     (funcall fn (list 'a)))
   (error () :error))
  :error)

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

(deftest defgeneric-method-combination.nconc.11
197 198
  (progn
    (eval '(defgeneric dg-mc.nconc.11 (x)
sds's avatar
sds committed
199 200
            (:method-combination nconc)
            (:method nonsense ((x t)) (list 'a))))
201 202 203
    (handler-case
     (dg-mc.nconc.11 0)
     (error () :error)))
204 205 206 207
  :error)

(deftest defgeneric-method-combination.nconc.12
  (let ((fn (eval '(defgeneric dg-mc.nconc.12 (x)
sds's avatar
sds committed
208 209 210
                     (:method-combination nconc)
                     (:method :around ((x t)) (list 'a))
                     (:method nconc ((x integer)) x)))))
211
    (declare (type generic-function fn))
212
    (handler-case (funcall fn (list 'b))
sds's avatar
sds committed
213
                  (error () :error)))
214
  :error)