ensure-generic-function.lsp 6.63 KB
Newer Older
1 2 3 4 5 6 7 8
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Thu Mar 27 21:29:53 2003
;;;; Contains: Tests for ENSURE-GENERIC-FUNCTION

(in-package :cl-test)

(deftest ensure-generic-function.1
9 10 11
  (if (typep #'car 'generic-function)
      t
    (signals-error (ensure-generic-function 'car) error))
12
  t)
13 14

(deftest ensure-generic-function.2
15 16
  (signals-error (ensure-generic-function 'defclass) error)
  t)
17 18

(deftest ensure-generic-function.3
19 20
  (signals-error (ensure-generic-function 'tagbody) error)
  t)
21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37

(deftest ensure-generic-function.4
  (let ((f 'egf-fun-4))
    (when (fboundp f) (fmakunbound f))
    (values
     (fboundp f)
     (notnot-mv (typep (ensure-generic-function f) 'generic-function))
     (notnot-mv (typep (ensure-generic-function f) 'generic-function))
     (notnot-mv (typep (symbol-function f) 'generic-function))))
  nil t t t)

(deftest ensure-generic-function.5
  (let ((f 'egf-fun-5))
    (when (fboundp f) (fmakunbound f))
    (values
     (fboundp f)
     (notnot-mv (typep (ensure-generic-function f :lambda-list '(a b c))
sds's avatar
sds committed
38
                       'generic-function))
39 40 41
     ;; Test of incongruent generic function lambda list when no
     ;; methods exist
     (notnot-mv (typep (ensure-generic-function f :lambda-list '(x y))
sds's avatar
sds committed
42
                       'generic-function))
43 44 45 46 47 48 49 50 51
     (notnot-mv (typep (symbol-function f) 'generic-function))))
  nil t t t)

(deftest ensure-generic-function.6
  (let ((f 'egf-fun-6))
    (when (fboundp f) (fmakunbound f))
    (values
     (fboundp f)
     (notnot-mv (typep (ensure-generic-function f :lambda-list '(a b c))
sds's avatar
sds committed
52
                       'generic-function))
53 54 55
     (notnot-mv (eval `(defmethod ,f ((a t)(b t)(c t)) (list a b c))))
     ;; Test of incongruent generic function lambda list when no
     ;; methods exist
56 57
     (eval
      `(signals-error (ensure-generic-function ',f :lambda-list '(x y))
sds's avatar
sds committed
58
                      error))))
59 60
  nil t t t)

61 62 63 64
(deftest ensure-generic-function.7
  (let ((f 'egf-fun-7))
    (when (fboundp f) (fmakunbound f))
    (let ((fn (eval `(defgeneric ,f (x)
sds's avatar
sds committed
65 66 67
                       (:method ((x symbol)) (list x :a))
                       (:method ((x integer)) (list x :b))
                       (:method ((x t)) (list x :c))))))
68 69 70 71 72 73 74 75 76 77 78 79
      (values
       (mapcar fn '(x 2 3/2))
       (eqlt fn (ensure-generic-function f :lambda-list '(x)))
       (mapcar fn '(x 2 3/2)))))
  ((x :a) (2 :b) (3/2 :c))
  t
  ((x :a) (2 :b) (3/2 :c)))

(deftest ensure-generic-function.8
  (let ((f 'egf-fun-8))
    (when (fboundp f) (fmakunbound f))
    (let ((fn (eval `(defgeneric ,f (x y)
sds's avatar
sds committed
80 81
                       (:method ((x t) (y symbol)) 1)
                       (:method ((x symbol) (y t)) 2)))))
82 83 84
      (values
       (mapcar fn '(a a 3) '(b 4 b))
       (eqlt fn (ensure-generic-function f :lambda-list '(x y)
sds's avatar
sds committed
85
                                         :argument-precedence-order '(y x)))
86 87 88 89 90 91 92 93 94
       (mapcar fn '(a a 3) '(b 4 b)))))
  (2 2 1)
  t
  (1 2 1))

(deftest ensure-generic-function.9
  (let ((f 'egf-fun-9))
    (when (fboundp f) (fmakunbound f))
    (let ((fn (eval `(defgeneric ,f (x)
sds's avatar
sds committed
95 96 97 98
                       (:method-combination +)
                       (:method + ((x t)) 1)
                       (:method + ((x symbol)) 2)
                       (:method + ((x (eql nil))) 4)))))
99 100 101
      (values
       (mapcar fn '(3/2 a nil))
       (eqlt fn (ensure-generic-function f :lambda-list '(x)
sds's avatar
sds committed
102
                                         :method-class 'standard-method))
103 104
       (mapcar fn '(3/2 a nil))
       (eqlt fn (ensure-generic-function f :lambda-list '(x)
sds's avatar
sds committed
105 106
                                         :method-class
                                         (find-class 'standard-method)))
107
       (mapcar fn '(3/2 a nil)))))
sds's avatar
sds committed
108 109


110 111 112 113 114 115 116 117 118 119
  (1 3 7)
  t
  (1 3 7)
  t
  (1 3 7))

(deftest ensure-generic-function.10
  (let ((f 'egf-fun-10))
    (when (fboundp f) (fmakunbound f))
    (let ((fn (eval `(defgeneric ,f (x)
sds's avatar
sds committed
120
                       (:method ((x t)) 1)))))
121 122 123
      (values
       (funcall fn 'a)
       (eqlt fn (ensure-generic-function f :lambda-list '(x)
sds's avatar
sds committed
124 125
                                         :generic-function-class
                                         'standard-generic-function))
126 127
       (funcall fn 'a)
       (eqlt fn (ensure-generic-function f :lambda-list '(x)
sds's avatar
sds committed
128 129
                                         :generic-function-class
                                         (find-class 'standard-generic-function)))
130 131 132
       (funcall fn 'a))))
  1 t 1 t 1)

133 134 135 136
(deftest ensure-generic-function.11
  (let ((f 'egf-fun-11))
    (when (fboundp f) (fmakunbound f))
    (let ((fn (eval `(defgeneric ,f (x)
sds's avatar
sds committed
137
                       (:method ((x t)) 1)))))
138 139 140
      (values
       (funcall fn 'a)
       (eqlt fn (eval `(macrolet ((%m (&environment env)
sds's avatar
sds committed
141 142 143
                                      (ensure-generic-function ',f :lambda-list '(x)
                                                               :environment env)))
                         (%m))))
144 145 146 147 148 149 150
       (funcall fn 'a))))
  1 t 1)

(deftest ensure-generic-function.12
  (let ((f 'egf-fun-12))
    (when (fboundp f) (fmakunbound f))
    (let ((fn (eval `(defgeneric ,f (x)
sds's avatar
sds committed
151 152
                       (:documentation "foo")
                       (:method ((x t)) 1)))))
153 154 155 156 157 158 159 160 161 162 163 164
      (values
       (funcall fn 'a)
       (or (documentation f 'function) "foo")
       (eqlt fn (ensure-generic-function f :lambda-list '(x) :documentation "bar"))
       (or (documentation f 'function) "bar")
       (funcall fn 'a))))
  1 "foo" t "bar" 1)

(deftest ensure-generic-function.13
  (let ((f 'egf-fun-13))
    (when (fboundp f) (fmakunbound f))
    (let ((fn (eval `(defgeneric ,f (x y)
sds's avatar
sds committed
165 166
                       (declare (optimize safety (speed 0) (debug 0) (space 0)))
                       (:method ((x t) (y t)) (list x y))))))
167 168 169
      (values
       (funcall fn 'a 'b)
       (eqlt fn (ensure-generic-function f :lambda-list '(x y)
sds's avatar
sds committed
170
                                         :declare '((optimize (safety 0) (debug 2) speed (space 1)))))
171 172
       (funcall fn 'a 1))))
  (a b) t (a 1))
173

174 175 176 177
(deftest ensure-generic-function.14
  (let ((f '(setf egf-fun-14)))
    (when (fboundp f) (fmakunbound f))
    (let ((fn (eval `(defgeneric ,f (val x)
sds's avatar
sds committed
178
                       (:method ((val t) (x cons)) (setf (car x) val))))))
179 180
      (values
       (let ((z (cons 'a 'b)))
sds's avatar
sds committed
181
         (list (setf (egf-fun-14 z) 'c) z))
182 183
       (eqlt fn (ensure-generic-function f :lambda-list '(val x)))
       (let ((z (cons 'a 'b)))
sds's avatar
sds committed
184 185 186
         (list (setf (egf-fun-14 z) 'c) z)))))
  (c (c . b)) t (c (c . b)))

187 188 189
;;; Many more tests are needed for other combinations of keyword parameters

(deftest ensure-generic-function.error.1
190 191
  (signals-error (ensure-generic-function) program-error)
  t)
192 193

(deftest ensure-generic-function.error.2
194 195
  (signals-error (ensure-generic-function (gensym) :lambda-list) program-error)
  t)