source: trunk/source/tests/ansi-tests/make-instance.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.2 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Mon May 12 21:19:36 2003
4;;;; Contains: Tests of MAKE-INSTANCE
5
6(in-package :cl-test)
7
8;;; MAKE-INSTANCE is used in many other tests as well
9
10(deftest make-instance.error.1
11  (signals-error (make-instance) program-error)
12  t)
13
14(defclass make-instance-class-01 ()
15  ((a :initarg :a) (b :initarg :b)))
16
17(deftest make-instance.error.2
18  (signals-error (make-instance 'make-instance-class-01 :a)
19                 program-error)
20  t)
21
22(deftest make-instance.error.3
23  (handler-case (progn (eval '(make-instance 'make-instance-class-01 :z 1))
24                       t)
25                (error () :good))
26  :good)
27
28(deftest make-instance.error.4
29  (handler-case (progn (eval '(make-instance
30                               (find-class 'make-instance-class-01)
31                               :z 1))
32                       t)
33                (error () :good))
34  :good)
35
36(deftest make-instance.error.5
37  (signals-error (let () (make-instance) nil)
38                 program-error)
39  t)
40
41(deftest make-instance.error.6
42  (loop for cl in *built-in-classes*
43        unless (eval `(signals-error (make-instance ',cl) error))
44        collect cl)
45  nil)
46
47;; Definitions of methods
48
49(defmethod make-instance ((x make-instance-class-01)
50                          &rest initargs &key &allow-other-keys)
51  initargs)
52
53(deftest make-instance.1
54  (make-instance (make-instance 'make-instance-class-01))
55  nil)
56
57(deftest make-instance.2
58  (make-instance (make-instance 'make-instance-class-01) :a 1 :b 2)
59  (:a 1 :b 2))
60
61#|
62(when *can-define-metaclasses*
63 
64  (defclass make-instance-class-02 ()
65    (a b c)
66    (:metaclass substandard-class))
67 
68  (defmethod make-instance ((class (eql (find-class 'make-instance-class-02)))
69                            &rest initargs &key (x nil) (y nil) (z nil)
70                            &allow-other-keys)
71    (declare (ignore initargs))
72    (let ((obj (allocate-instance class)))
73      (setf (slot-value obj 'a) x
74            (slot-value obj 'b) y
75            (slot-value obj 'c) z)
76      obj))
77 
78  (deftest make-instance.3
79    (let ((obj (make-instance 'make-instance-class-02)))
80      (values
81       (eqt (class-of obj) (find-class 'make-instance-class-02))
82       (slot-value obj 'a)
83       (slot-value obj 'b)
84       (slot-value obj 'c)))
85    t nil nil nil)
86 
87  (deftest make-instance.4
88    (let ((obj (make-instance 'make-instance-class-02 :z 10 :y 45 :x 'd)))
89      (values
90       (eqt (class-of obj) (find-class 'make-instance-class-02))
91       (slot-value obj 'a)
92       (slot-value obj 'b)
93       (slot-value obj 'c)))
94    t d 45 10)
95 
96 
97  (deftest make-instance.5
98    (let ((obj (make-instance (find-class 'make-instance-class-02) :y 'g)))
99      (values
100       (eqt (class-of obj) (find-class 'make-instance-class-02))
101       (slot-value obj 'a)
102       (slot-value obj 'b)
103       (slot-value obj 'c)))
104    t nil g nil)
105 
106  (deftest make-instance.6
107    (eq (make-instance 'make-instance-class-02)
108        (make-instance 'make-instance-class-02))
109    nil)
110
111  ;; Customization of make-instance
112 
113  (defclass make-instance-class-03 ()
114    ((a :initform 1) (b :initarg :b) c)
115    (:metaclass substandard-class))
116
117  (defmethod make-instance ((class (eql (find-class 'make-instance-class-03)))
118                            &rest initargs
119                            &key (x nil x-p) (y nil y-p) (z nil z-p)
120                            &allow-other-keys)
121    (declare (ignore initargs))
122    (let ((obj (allocate-instance (find-class 'make-instance-class-03))))
123      (when x-p (setf (slot-value obj 'a) x))
124      (when y-p (setf (slot-value obj 'b) y))
125      (when z-p (setf (slot-value obj 'c) z))
126      obj))
127 
128  (deftest make-instance.7
129    (let ((obj (make-instance 'make-instance-class-03)))
130      (values
131       (eqt (class-of obj)
132            (find-class 'make-instance-class-03))
133       (map-slot-boundp* obj '(a b c))))
134    t (nil nil nil))
135 
136  (deftest make-instance.8
137    (let* ((class (find-class 'make-instance-class-03))
138           (obj (make-instance class :b 10)))
139      (values
140       (eqt (class-of obj) class)
141       (map-slot-boundp* obj '(a b c))))
142    t (nil nil nil))
143 
144  (deftest make-instance.9
145    (let* ((class (find-class 'make-instance-class-03))
146           (obj (make-instance class :x 'g :z 'i :y 'k :foo t :x 'bad)))
147      (values
148       (eqt (class-of obj) class)
149       (map-slot-boundp* obj '(a b c))
150       (map-slot-value obj '(a b c))))
151    t (t t t) (g k i))
152
153  ;; After method combination
154
155  (defparameter *make-instance-class-04-var* 0)
156
157  (defclass make-instance-class-04 ()
158    ((a :initform *make-instance-class-04-var*))
159    (:metaclass substandard-class))
160
161  (defmethod make-instance :after
162    ((class (eql (find-class 'make-instance-class-04)))
163     &rest initargs &key &allow-other-keys)
164    (declare (ignore initargs))
165    (incf *make-instance-class-04-var* 10))
166 
167  (deftest make-instance.10
168    (let* ((*make-instance-class-04-var* 0)
169           (obj (make-instance 'make-instance-class-04)))
170      (values
171       (slot-value obj 'a)
172       *make-instance-class-04-var*))
173    0 10)
174 
175  ;; Around method combination
176
177  (defclass make-instance-class-05 ()
178    ((a :initarg :a) (b :initarg :b :initform 'foo) c)
179    (:metaclass substandard-class))
180
181  (defmethod make-instance :around
182    ((class (eql (find-class 'make-instance-class-05)))
183     &rest initargs &key &allow-other-keys)
184    (declare (ignore initargs))
185    (let ((obj (call-next-method)))
186      (setf (slot-value obj 'c) 'bar)
187      obj))
188 
189  (deftest make-instance.11
190    (let ((obj (make-instance 'make-instance-class-05)))
191      (values
192       (map-slot-boundp* obj '(a b c))
193       (map-slot-value obj '(b c))))
194    (nil t t)
195    (foo bar))
196  )
197|#
198
199;;; Order of argument evaluation
200
201(deftest make-instance.order.1
202  (let* ((i 0) x y
203         (obj (make-instance 'make-instance-class-01
204                             :a (setf x (incf i))
205                             :b (setf y (incf i)))))
206    (values
207     (map-slot-value obj '(a b))
208     i x y))
209  (1 2) 2 1 2)
210
211(deftest make-instance.order.2
212  (let* ((i 0) x y z w
213         (obj (make-instance 'make-instance-class-01
214                             :a (setf x (incf i))
215                             :b (setf y (incf i))
216                             :b (setf z (incf i))
217                             :a (setf w (incf i)))))
218    (values
219     (map-slot-value obj '(a b))
220     i x y z w))
221  (1 2) 4 1 2 3 4)
222
223(deftest make-instance.order.3
224  (let* ((i 0) u x y z w
225         (obj (make-instance (prog1 'make-instance-class-01
226                                    (setf u (incf i)))
227                             :a (setf x (incf i))
228                             :b (setf y (incf i))
229                             :b (setf z (incf i))
230                             :a (setf w (incf i)))))
231    (values
232     (map-slot-value obj '(a b))
233     i u x y z w))
234  (2 3) 5 1 2 3 4 5)
Note: See TracBrowser for help on using the repository browser.