source: trunk/source/tests/ansi-tests/ensure-generic-function.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 6.0 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Thu Mar 27 21:29:53 2003
4;;;; Contains: Tests for ENSURE-GENERIC-FUNCTION
5
6(in-package :cl-test)
7
8(deftest ensure-generic-function.1
9  (if (typep #'car 'generic-function)
10      t
11    (signals-error (ensure-generic-function 'car) error))
12  t)
13
14(deftest ensure-generic-function.2
15  (signals-error (ensure-generic-function 'defclass) error)
16  t)
17
18(deftest ensure-generic-function.3
19  (signals-error (ensure-generic-function 'tagbody) error)
20  t)
21
22(deftest ensure-generic-function.4
23  (let ((f 'egf-fun-4))
24    (when (fboundp f) (fmakunbound f))
25    (values
26     (fboundp f)
27     (notnot-mv (typep (ensure-generic-function f) 'generic-function))
28     (notnot-mv (typep (ensure-generic-function f) 'generic-function))
29     (notnot-mv (typep (symbol-function f) 'generic-function))))
30  nil t t t)
31
32(deftest ensure-generic-function.5
33  (let ((f 'egf-fun-5))
34    (when (fboundp f) (fmakunbound f))
35    (values
36     (fboundp f)
37     (notnot-mv (typep (ensure-generic-function f :lambda-list '(a b c))
38                       'generic-function))
39     ;; Test of incongruent generic function lambda list when no
40     ;; methods exist
41     (notnot-mv (typep (ensure-generic-function f :lambda-list '(x y))
42                       'generic-function))
43     (notnot-mv (typep (symbol-function f) 'generic-function))))
44  nil t t t)
45
46(deftest ensure-generic-function.6
47  (let ((f 'egf-fun-6))
48    (when (fboundp f) (fmakunbound f))
49    (values
50     (fboundp f)
51     (notnot-mv (typep (ensure-generic-function f :lambda-list '(a b c))
52                       'generic-function))
53     (notnot-mv (eval `(defmethod ,f ((a t)(b t)(c t)) (list a b c))))
54     ;; Test of incongruent generic function lambda list when no
55     ;; methods exist
56     (eval
57      `(signals-error (ensure-generic-function ',f :lambda-list '(x y))
58                      error))))
59  nil t t t)
60
61(deftest ensure-generic-function.7
62  (let ((f 'egf-fun-7))
63    (when (fboundp f) (fmakunbound f))
64    (let ((fn (eval `(defgeneric ,f (x)
65                       (:method ((x symbol)) (list x :a))
66                       (:method ((x integer)) (list x :b))
67                       (:method ((x t)) (list x :c))))))
68      (values
69       (mapcar fn '(x 2 3/2))
70       (eqlt fn (ensure-generic-function f :lambda-list '(x)))
71       (mapcar fn '(x 2 3/2)))))
72  ((x :a) (2 :b) (3/2 :c))
73  t
74  ((x :a) (2 :b) (3/2 :c)))
75
76(deftest ensure-generic-function.8
77  (let ((f 'egf-fun-8))
78    (when (fboundp f) (fmakunbound f))
79    (let ((fn (eval `(defgeneric ,f (x y)
80                       (:method ((x t) (y symbol)) 1)
81                       (:method ((x symbol) (y t)) 2)))))
82      (values
83       (mapcar fn '(a a 3) '(b 4 b))
84       (eqlt fn (ensure-generic-function f :lambda-list '(x y)
85                                         :argument-precedence-order '(y x)))
86       (mapcar fn '(a a 3) '(b 4 b)))))
87  (2 2 1)
88  t
89  (1 2 1))
90
91(deftest ensure-generic-function.9
92  (let ((f 'egf-fun-9))
93    (when (fboundp f) (fmakunbound f))
94    (let ((fn (eval `(defgeneric ,f (x)
95                       (:method-combination +)
96                       (:method + ((x t)) 1)
97                       (:method + ((x symbol)) 2)
98                       (:method + ((x (eql nil))) 4)))))
99      (values
100       (mapcar fn '(3/2 a nil))
101       (eqlt fn (ensure-generic-function f :lambda-list '(x)
102                                         :method-class 'standard-method))
103       (mapcar fn '(3/2 a nil))
104       (eqlt fn (ensure-generic-function f :lambda-list '(x)
105                                         :method-class
106                                         (find-class 'standard-method)))
107       (mapcar fn '(3/2 a nil)))))
108       
109       
110  (1 3 7)
111  t
112  (1 3 7)
113  t
114  (1 3 7))
115
116(deftest ensure-generic-function.10
117  (let ((f 'egf-fun-10))
118    (when (fboundp f) (fmakunbound f))
119    (let ((fn (eval `(defgeneric ,f (x)
120                       (:method ((x t)) 1)))))
121      (values
122       (funcall fn 'a)
123       (eqlt fn (ensure-generic-function f :lambda-list '(x)
124                                         :generic-function-class
125                                         'standard-generic-function))
126       (funcall fn 'a)
127       (eqlt fn (ensure-generic-function f :lambda-list '(x)
128                                         :generic-function-class
129                                         (find-class 'standard-generic-function)))
130       (funcall fn 'a))))
131  1 t 1 t 1)
132
133(deftest ensure-generic-function.11
134  (let ((f 'egf-fun-11))
135    (when (fboundp f) (fmakunbound f))
136    (let ((fn (eval `(defgeneric ,f (x)
137                       (:method ((x t)) 1)))))
138      (values
139       (funcall fn 'a)
140       (eqlt fn (eval `(macrolet ((%m (&environment env)
141                                      (ensure-generic-function ',f :lambda-list '(x)
142                                                               :environment env)))
143                         (%m))))
144       (funcall fn 'a))))
145  1 t 1)
146
147(deftest ensure-generic-function.12
148  (let ((f 'egf-fun-12))
149    (when (fboundp f) (fmakunbound f))
150    (let ((fn (eval `(defgeneric ,f (x)
151                       (:documentation "foo")
152                       (:method ((x t)) 1)))))
153      (values
154       (funcall fn 'a)
155       (or (documentation f 'function) "foo")
156       (eqlt fn (ensure-generic-function f :lambda-list '(x) :documentation "bar"))
157       (or (documentation f 'function) "bar")
158       (funcall fn 'a))))
159  1 "foo" t "bar" 1)
160
161(deftest ensure-generic-function.13
162  (let ((f 'egf-fun-13))
163    (when (fboundp f) (fmakunbound f))
164    (let ((fn (eval `(defgeneric ,f (x y)
165                       (declare (optimize safety (speed 0) (debug 0) (space 0)))
166                       (:method ((x t) (y t)) (list x y))))))
167      (values
168       (funcall fn 'a 'b)
169       (eqlt fn (ensure-generic-function f :lambda-list '(x y)
170                                         :declare '((optimize (safety 0) (debug 2) speed (space 1)))))
171       (funcall fn 'a 1))))
172  (a b) t (a 1))
173
174(deftest ensure-generic-function.14
175  (let ((f '(setf egf-fun-14)))
176    (when (fboundp f) (fmakunbound f))
177    (let ((fn (eval `(defgeneric ,f (val x)
178                       (:method ((val t) (x cons)) (setf (car x) val))))))
179      (values
180       (let ((z (cons 'a 'b)))
181         (list (setf (egf-fun-14 z) 'c) z))
182       (eqlt fn (ensure-generic-function f :lambda-list '(val x)))
183       (let ((z (cons 'a 'b)))
184         (list (setf (egf-fun-14 z) 'c) z)))))
185  (c (c . b)) t (c (c . b)))       
186                       
187;;; Many more tests are needed for other combinations of keyword parameters
188
189(deftest ensure-generic-function.error.1
190  (signals-error (ensure-generic-function) program-error)
191  t)
192
193(deftest ensure-generic-function.error.2
194  (signals-error (ensure-generic-function (gensym) :lambda-list) program-error)
195  t)
Note: See TracBrowser for help on using the repository browser.