← Back to branch summary

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

« back to all changes in this revision

Viewing changes to ansi-tests/defclass-03.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/defclass-03.lsp
 
1
;-*- Mode:     Lisp -*-
 
2
;;;; Author:   Paul Dietz
 
3
;;;; Created:  Sun Apr 27 16:23:59 2003
 
4
;;;; Contains: Tests of DEFCLASS with more involved inheritance
 
5
 
 
6
(in-package :cl-test)
 
7
 
 
8
;;;
 
9
 
 
10
(defclass class-0301a ()
 
11
  (a b))
 
12
 
 
13
(defclass class-0301b ()
 
14
  (a c))
 
15
 
 
16
(defclass class-0301c (class-0301a class-0301b)
 
17
  (d))
 
18
 
 
19
(deftest class-0301.1
 
20
  (let ((c (make-instance 'class-0301c)))
 
21
    (values
 
22
     (typep* c 'class-0301a)
 
23
     (typep* c 'class-0301b)
 
24
     (typep* c 'class-0301c)
 
25
     (typep* c (find-class 'class-0301a))
 
26
     (typep* c (find-class 'class-0301b))
 
27
     (typep* c (find-class 'class-0301c))
 
28
     (map-slot-boundp* c '(a b c d))
 
29
     (setf (slot-value c 'a) 'w)
 
30
     (setf (slot-value c 'b) 'x)
 
31
     (setf (slot-value c 'c) 'y)
 
32
     (setf (slot-value c 'd) 'z)
 
33
     (map-slot-boundp* c '(a b c d))
 
34
     (map-slot-value c '(a b c d))))
 
35
  t t t
 
36
  t t t
 
37
  (nil nil nil nil)
 
38
  w x y z
 
39
  (t t t t)
 
40
  (w x y z))
 
41
 
 
42
;;;
 
43
 
 
44
(defclass class-0302a ()
 
45
  ((a :initform 'x) b (c :initform 'w)))
 
46
 
 
47
(defclass class-0302b ()
 
48
  ((a :initform 'y) (b :initform 'z)))
 
49
 
 
50
(defclass class-0302c (class-0302a class-0302b)
 
51
  (a b (c :initform 'v) d))
 
52
 
 
53
(deftest class-0302.1
 
54
  (let ((c (make-instance 'class-0302c)))
 
55
    (values
 
56
     (map-slot-boundp* c '(a b c d))
 
57
     (map-slot-value c '(a b c))))
 
58
  (t t t nil)
 
59
  (x z v))
 
60
 
 
61
;;;
 
62
 
 
63
(defclass class-0303a ()
 
64
  ((a :allocation :class) b))
 
65
 
 
66
(defclass class-0303b ()
 
67
  (a (b :allocation :class)))
 
68
 
 
69
(defclass class-0303c (class-0303a class-0303b) ())
 
70
 
 
71
(deftest class-0303.1
 
72
  (let ((c1 (make-instance 'class-0303a))
 
73
        (c2 (make-instance 'class-0303b))
 
74
        (c3 (make-instance 'class-0303c)))
 
75
    (slot-makunbound c1 'a)
 
76
    (slot-makunbound c2 'b)
 
77
    (values
 
78
     (loop for c in (list c1 c2 c3)
 
79
           collect (map-slot-boundp* c '(a b)))
 
80
     (list (setf (slot-value c1 'a) 'x1)
 
81
           (slot-boundp* c2 'a)
 
82
           (slot-value c3 'a))
 
83
     (list (setf (slot-value c2 'a) 'x2)
 
84
           (slot-value c1 'a)
 
85
           (slot-value c2 'a)
 
86
           (slot-value c3 'a))
 
87
     (list (setf (slot-value c3 'a) 'x3)
 
88
           (slot-value c1 'a)
 
89
           (slot-value c2 'a)
 
90
           (slot-value c3 'a))
 
91
     ;;;
 
92
     (list (setf (slot-value c1 'b) 'y1)
 
93
           (slot-value c1 'b)
 
94
           (slot-boundp* c2 'b)
 
95
           (slot-boundp* c3 'b))
 
96
     (list (setf (slot-value c2 'b) 'y2)
 
97
           (slot-value c1 'b)
 
98
           (slot-value c2 'b)
 
99
           (slot-boundp c3 'b))
 
100
     (list (setf (slot-value c3 'b) 'y3)
 
101
           (slot-value c1 'b)
 
102
           (slot-value c2 'b)
 
103
           (slot-value c3 'b))))
 
104
  ((nil nil) (nil nil) (nil nil))
 
105
  (x1 nil x1)
 
106
  (x2 x1 x2 x1)
 
107
  (x3 x3 x2 x3)
 
108
  ;;
 
109
  (y1 y1 nil nil)
 
110
  (y2 y1 y2 nil)
 
111
  (y3 y1 y2 y3))
 
112
 
 
113
;;;
 
114
 
 
115
(defclass class-0304a ()
 
116
  ((a :initform 'x)))
 
117
 
 
118
(defclass class-0304b (class-0304a) ())
 
119
 
 
120
(defclass class-0304c (class-0304a)
 
121
  ((a :initform 'y)))
 
122
 
 
123
(defclass class-0304d (class-0304b class-0304c)
 
124
  ())
 
125
 
 
126
(deftest class-0304.1
 
127
  (slot-value (make-instance 'class-0304d) 'a)
 
128
  y)
 
129
 
 
130
;;;
 
131
 
 
132
(defclass class-0305a ()
 
133
  ((a :initarg :a))
 
134
  (:default-initargs :a 'x))
 
135
 
 
136
(defclass class-0305b (class-0305a) ())
 
137
 
 
138
(defclass class-0305c (class-0305a)
 
139
  ()
 
140
  (:default-initargs :a 'y))
 
141
 
 
142
(defclass class-0305d (class-0305b class-0305c)
 
143
  ())
 
144
 
 
145
(deftest class-0305.1
 
146
  (slot-value (make-instance 'class-0305d) 'a)
 
147
  y)
 
148
 
 
149
 
 
150
;;; A test showing nonmonotonicity in the CLOS CPL algorithm
 
151
 
 
152
(defclass class-0306a () ((a :initform nil :reader a-slot)))
 
153
(defclass class-0306b (class-0306a) ((a :initform 'x)))
 
154
(defclass class-0306c (class-0306a) ((a :initform 'y)))
 
155
(defclass class-0306d (class-0306b) ())
 
156
(defclass class-0306e (class-0306b) ())
 
157
(defclass class-0306f (class-0306d class-0306c) ())
 
158
(defclass class-0306g (class-0306e) ())
 
159
(defclass class-0306h (class-0306f class-0306g) ())
 
160
 
 
161
;;; Class class-0306c should precede class-0306b in the
 
162
;;; CPL for class-0306h, even though it follows it in the CPLs
 
163
;;; for the direct superclasses of class-0306h.
 
164
 
 
165
(deftest class-0306.1
 
166
  (loop for obj in
 
167
        (mapcar #'make-instance
 
168
             '(class-0306a class-0306b class-0306c class-0306d
 
169
               class-0306e class-0306f class-0306g class-0306h))
 
170
        collect (slot-value obj 'a))
 
171
  (nil x y x x x x y))
 
172
 
 
173
(deftest class-0306.2
 
174
  (loop for obj in
 
175
        (mapcar #'make-instance
 
176
             '(class-0306a class-0306b class-0306c class-0306d
 
177
               class-0306e class-0306f class-0306g class-0306h))
 
178
        collect (a-slot obj))
 
179
  (nil x y x x x x y))
 
180
 
 
181
;;; A class redefinition test that came up in cmucl
 
182
 
 
183
(deftest class-0307.1
 
184
  (progn
 
185
    (setf (find-class 'class-0307a) nil
 
186
          (find-class 'class-0307b) nil)
 
187
    (eval '(defclass class-0307a () ()))
 
188
    (eval '(defclass class-0307b (class-0307a) (a)))
 
189
    (eval '(defclass class-0307a () ((a :initform nil))))
 
190
    (eval '(defclass class-0307b (class-0307a) ((a :initform 'x))))
 
191
    (slot-value (make-instance 'class-0307b) 'a))
 
192
  x)
 
193
 
 
194
(deftest class-0308.1
 
195
  (progn
 
196
    (setf (find-class 'class-0308a) nil
 
197
          (find-class 'class-0308b) nil)
 
198
    (eval '(defclass class-0308a () ()))
 
199
    (eval '(defclass class-0308b (class-0308a) (a)))
 
200
    (eval '(defclass class-0308a () ((a :initarg :a))))
 
201
    (eval '(defclass class-0308b (class-0308a) ()))
 
202
    (slot-value (make-instance 'class-0308b :a 'x) 'a))
 
203
  x)
 
204
 
 
205
;;; More class redefinition tests
 
206
 
 
207
(deftest class-0309.1
 
208
  (progn
 
209
    (setf (find-class 'class-0309) nil)
 
210
    (let* ((class1 (eval '(defclass class-0309 () ((a) (b) (c)))))
 
211
           (obj1 (make-instance 'class-0309)))
 
212
      (setf (class-name class1) nil)
 
213
      (let ((class2 (eval '(defclass class-0309 () ((a) (b) (c))))))
 
214
        (values
 
215
         (eqt (class-of obj1) class1)
 
216
         (eqt class1 class2)
 
217
         (typep* obj1 class1)
 
218
         (typep* obj1 class2)))))
 
219
  t nil t nil)
 
220
 
 
221
(deftest class-0310.1
 
222
  (progn
 
223
    (setf (find-class 'class-0310a) nil
 
224
          (find-class 'class-0310b) nil)
 
225
    (let* ((class1 (eval '(defclass class-0310a () ((a) (b) (c)))))
 
226
           (obj1 (make-instance 'class-0310a)))
 
227
      (setf (class-name class1) 'class-0310b)
 
228
      (let ((class2 (eval '(defclass class-0310a () ((a) (b) (c))))))
 
229
        (values
 
230
         (eqt (class-of obj1) class1)
 
231
         (eqt class1 class2)
 
232
         (typep* obj1 class1)
 
233
         (typep* obj1 class2)
 
234
         (class-name class1)
 
235
         (class-name class2)))))
 
236
  t nil t nil class-0310b class-0310a)
 
237
 
 
238
(deftest class-0311.1
 
239
  (progn
 
240
    (setf (find-class 'class-0311) nil)
 
241
    (let* ((class1 (eval '(defclass class-0311 () ((a) (b) (c)))))
 
242
           (obj1 (make-instance 'class-0311)))
 
243
      (setf (find-class 'class-0311) nil)
 
244
      (let ((class2 (eval '(defclass class-0311 () ((a) (b) (c))))))
 
245
        (values
 
246
         (eqt (class-of obj1) class1)
 
247
         (eqt class1 class2)
 
248
         (typep* obj1 class1)
 
249
         (typep* obj1 class2)
 
250
         (class-name class1)
 
251
         (class-name class2)
 
252
         (eqt (find-class 'class-0311) class1)
 
253
         (eqt (find-class 'class-0311) class2)))))
 
254
  t nil t nil class-0311 class-0311 nil t)