← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to ansi-tests/make-instance.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
ansi-tests/make-instance.lsp
 
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
;; Definitions of methods
 
42
 
 
43
(defmethod make-instance ((x make-instance-class-01)
 
44
                          &rest initargs &key &allow-other-keys)
 
45
  initargs)
 
46
 
 
47
(deftest make-instance.1
 
48
  (make-instance (make-instance 'make-instance-class-01))
 
49
  nil)
 
50
 
 
51
(deftest make-instance.2
 
52
  (make-instance (make-instance 'make-instance-class-01) :a 1 :b 2)
 
53
  (:a 1 :b 2))
 
54
 
 
55
#|
 
56
(when *can-define-metaclasses*
 
57
  
 
58
  (defclass make-instance-class-02 ()
 
59
    (a b c)
 
60
    (:metaclass substandard-class))
 
61
  
 
62
  (defmethod make-instance ((class (eql (find-class 'make-instance-class-02)))
 
63
                            &rest initargs &key (x nil) (y nil) (z nil)
 
64
                            &allow-other-keys)
 
65
    (declare (ignore initargs))
 
66
    (let ((obj (allocate-instance class)))
 
67
      (setf (slot-value obj 'a) x
 
68
            (slot-value obj 'b) y
 
69
            (slot-value obj 'c) z)
 
70
      obj))
 
71
  
 
72
  (deftest make-instance.3
 
73
    (let ((obj (make-instance 'make-instance-class-02)))
 
74
      (values
 
75
       (eqt (class-of obj) (find-class 'make-instance-class-02))
 
76
       (slot-value obj 'a)
 
77
       (slot-value obj 'b)
 
78
       (slot-value obj 'c)))
 
79
    t nil nil nil)
 
80
  
 
81
  (deftest make-instance.4
 
82
    (let ((obj (make-instance 'make-instance-class-02 :z 10 :y 45 :x 'd)))
 
83
      (values
 
84
       (eqt (class-of obj) (find-class 'make-instance-class-02))
 
85
       (slot-value obj 'a)
 
86
       (slot-value obj 'b)
 
87
       (slot-value obj 'c)))
 
88
    t d 45 10)
 
89
  
 
90
  
 
91
  (deftest make-instance.5
 
92
    (let ((obj (make-instance (find-class 'make-instance-class-02) :y 'g)))
 
93
      (values
 
94
       (eqt (class-of obj) (find-class 'make-instance-class-02))
 
95
       (slot-value obj 'a)
 
96
       (slot-value obj 'b)
 
97
       (slot-value obj 'c)))
 
98
    t nil g nil)
 
99
  
 
100
  (deftest make-instance.6
 
101
    (eq (make-instance 'make-instance-class-02)
 
102
        (make-instance 'make-instance-class-02))
 
103
    nil)
 
104
 
 
105
  ;; Customization of make-instance
 
106
  
 
107
  (defclass make-instance-class-03 ()
 
108
    ((a :initform 1) (b :initarg :b) c)
 
109
    (:metaclass substandard-class))
 
110
 
 
111
  (defmethod make-instance ((class (eql (find-class 'make-instance-class-03)))
 
112
                            &rest initargs
 
113
                            &key (x nil x-p) (y nil y-p) (z nil z-p)
 
114
                            &allow-other-keys)
 
115
    (declare (ignore initargs))
 
116
    (let ((obj (allocate-instance (find-class 'make-instance-class-03))))
 
117
      (when x-p (setf (slot-value obj 'a) x))
 
118
      (when y-p (setf (slot-value obj 'b) y))
 
119
      (when z-p (setf (slot-value obj 'c) z))
 
120
      obj))
 
121
  
 
122
  (deftest make-instance.7
 
123
    (let ((obj (make-instance 'make-instance-class-03)))
 
124
      (values
 
125
       (eqt (class-of obj)
 
126
            (find-class 'make-instance-class-03))
 
127
       (map-slot-boundp* obj '(a b c))))
 
128
    t (nil nil nil))
 
129
  
 
130
  (deftest make-instance.8
 
131
    (let* ((class (find-class 'make-instance-class-03))
 
132
           (obj (make-instance class :b 10)))
 
133
      (values
 
134
       (eqt (class-of obj) class)
 
135
       (map-slot-boundp* obj '(a b c))))
 
136
    t (nil nil nil))
 
137
  
 
138
  (deftest make-instance.9
 
139
    (let* ((class (find-class 'make-instance-class-03))
 
140
           (obj (make-instance class :x 'g :z 'i :y 'k :foo t :x 'bad)))
 
141
      (values
 
142
       (eqt (class-of obj) class)
 
143
       (map-slot-boundp* obj '(a b c))
 
144
       (map-slot-value obj '(a b c))))
 
145
    t (t t t) (g k i))
 
146
 
 
147
  ;; After method combination
 
148
 
 
149
  (defparameter *make-instance-class-04-var* 0)
 
150
 
 
151
  (defclass make-instance-class-04 ()
 
152
    ((a :initform *make-instance-class-04-var*))
 
153
    (:metaclass substandard-class))
 
154
 
 
155
  (defmethod make-instance :after
 
156
    ((class (eql (find-class 'make-instance-class-04)))
 
157
     &rest initargs &key &allow-other-keys)
 
158
    (declare (ignore initargs))
 
159
    (incf *make-instance-class-04-var* 10))
 
160
  
 
161
  (deftest make-instance.10
 
162
    (let* ((*make-instance-class-04-var* 0)
 
163
           (obj (make-instance 'make-instance-class-04)))
 
164
      (values
 
165
       (slot-value obj 'a)
 
166
       *make-instance-class-04-var*))
 
167
    0 10)
 
168
  
 
169
  ;; Around method combination
 
170
 
 
171
  (defclass make-instance-class-05 ()
 
172
    ((a :initarg :a) (b :initarg :b :initform 'foo) c)
 
173
    (:metaclass substandard-class))
 
174
 
 
175
  (defmethod make-instance :around
 
176
    ((class (eql (find-class 'make-instance-class-05)))
 
177
     &rest initargs &key &allow-other-keys)
 
178
    (declare (ignore initargs))
 
179
    (let ((obj (call-next-method)))
 
180
      (setf (slot-value obj 'c) 'bar)
 
181
      obj))
 
182
  
 
183
  (deftest make-instance.11
 
184
    (let ((obj (make-instance 'make-instance-class-05)))
 
185
      (values
 
186
       (map-slot-boundp* obj '(a b c))
 
187
       (map-slot-value obj '(b c))))
 
188
    (nil t t)
 
189
    (foo bar))
 
190
  )
 
191
|#
 
192
 
 
193
;;; Order of argument evaluation
 
194
 
 
195
(deftest make-instance.order.1
 
196
  (let* ((i 0) x y
 
197
         (obj (make-instance 'make-instance-class-01
 
198
                             :a (setf x (incf i))
 
199
                             :b (setf y (incf i)))))
 
200
    (values
 
201
     (map-slot-value obj '(a b))
 
202
     i x y))
 
203
  (1 2) 2 1 2)
 
204
 
 
205
(deftest make-instance.order.2
 
206
  (let* ((i 0) x y z w
 
207
         (obj (make-instance 'make-instance-class-01
 
208
                             :a (setf x (incf i))
 
209
                             :b (setf y (incf i))
 
210
                             :b (setf z (incf i))
 
211
                             :a (setf w (incf i)))))
 
212
    (values
 
213
     (map-slot-value obj '(a b))
 
214
     i x y z w))
 
215
  (1 2) 4 1 2 3 4)
 
216
 
 
217
(deftest make-instance.order.3
 
218
  (let* ((i 0) u x y z w
 
219
         (obj (make-instance (prog1 'make-instance-class-01
 
220
                                    (setf u (incf i)))
 
221
                             :a (setf x (incf i))
 
222
                             :b (setf y (incf i))
 
223
                             :b (setf z (incf i))
 
224
                             :a (setf w (incf i)))))
 
225
    (values
 
226
     (map-slot-value obj '(a b))
 
227
     i u x y z w))
 
228
  (2 3) 5 1 2 3 4 5)