source: trunk/source/tests/ansi-tests/defclass-02.lsp @ 8991

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

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

File size: 15.5 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Fri Apr 25 07:16:57 2003
4;;;; Contains: Tests of DEFCLASS with simple inheritance
5
6(in-package :cl-test)
7
8;;;
9
10(defclass class-0201 ()
11  ((a :initform 'x) (b :allocation :instance) (c :reader class-0201-c)))
12
13(defclass class-0202 (class-0201)
14  (d (e :initform 'y) (f :allocation :instance)))
15
16(deftest class-0201.1
17  (let ((c (make-instance 'class-0201)))
18    (values (map-slot-boundp* c '(a b c))
19            (map-slot-exists-p* c '(a b c))
20            (slot-value c 'a)
21            (map-typep* c (list 'class-0201 'class-0202
22                                (find-class 'class-0201)
23                                (find-class 'class-0202)))
24            (class-name (class-of c))
25            ))
26  (t nil nil)
27  (t t t)
28  x
29  (t nil t nil)
30  class-0201)
31
32(deftest class-0202.1
33  (let ((c (make-instance 'class-0202)))
34    (values (map-slot-boundp* c '(a b c d e f))
35            (map-slot-value c '(a e))
36            (map-typep* c (list 'class-0201 'class-0202
37                                (find-class 'class-0201)
38                                (find-class 'class-0202)))
39            (class-name (class-of c))
40            ))
41  (t nil nil nil t nil)
42  (x y)
43  (t t t t)
44  class-0202)
45
46;;;
47
48
49(defclass class-0203 ()
50  ((a :allocation :class) (b :allocation :instance)))
51
52(defclass class-0204 (class-0203)
53  (c d))
54
55(deftest class-0203.1
56  (let ((c1 (make-instance 'class-0203))
57        (c2 (make-instance 'class-0204)))
58    (values
59     (map-slot-boundp* c1 '(a b))
60     (map-slot-boundp* c2 '(a b c d))
61     (setf (slot-value c1 'a) 'x)
62     (map-slot-boundp* c1 '(a b))
63     (map-slot-boundp* c2 '(a b c d))
64     (slot-value c1 'a)
65     (slot-value c2 'a)
66     (eqt (slot-makunbound c1 'a) c1)
67     (map-slot-boundp* c1 '(a b))
68     (map-slot-boundp* c2 '(a b c d))))
69  (nil nil)
70  (nil nil nil nil)
71  x
72  (t nil)
73  (t nil nil nil)
74  x x
75  t
76  (nil nil)
77  (nil nil nil nil))
78
79 
80(deftest class-0203.2
81  (let ((c1 (make-instance 'class-0203))
82        (c2 (make-instance 'class-0204)))
83    (values
84     (map-slot-boundp* c1 '(a b))
85     (map-slot-boundp* c2 '(a b c d))
86     (setf (slot-value c1 'a) 'x)
87     (map-slot-boundp* c1 '(a b))
88     (map-slot-boundp* c2 '(a b c d))
89     (slot-value c1 'a)
90     (slot-value c2 'a)
91     (eqt (slot-makunbound c2 'a) c2)
92     (map-slot-boundp* c1 '(a b))
93     (map-slot-boundp* c2 '(a b c d))))
94  (nil nil)
95  (nil nil nil nil)
96  x
97  (t nil)
98  (t nil nil nil)
99  x x
100  t
101  (nil nil)
102  (nil nil nil nil))
103
104;;;
105
106(defclass class-0205a ()
107  ((a :initform 'x)
108   (b :initform 'y)
109   c))
110
111(defclass class-0205b (class-0205a)
112  ((a :initform 'z)
113   b
114   (c :initform 'w)))
115
116(deftest class-0205a.1
117  (let ((c (make-instance 'class-0205a)))
118    (values
119     (slot-value c 'a)
120     (slot-value c 'b)
121     (slot-boundp c 'c)))
122  x y nil)
123
124(deftest class-0205b.1
125  (let ((c (make-instance 'class-0205b)))
126    (map-slot-value c '(a b c)))
127  (z y w))
128
129;;;
130
131(defclass class-0206a ()
132  ((a :allocation :instance)
133   (b :allocation :class)))
134
135(defclass class-0206b (class-0206a)
136  ((a :allocation :class)
137   (b :allocation :instance)))
138
139(deftest class-0206.1
140  (let ((c1 (make-instance 'class-0206a))       
141        (c2 (make-instance 'class-0206b)))
142    (values
143     (map-slot-boundp* c1 '(a b))
144     (map-slot-boundp* c2 '(a b))
145     (setf (slot-value c1 'a) 'x)
146     (setf (slot-value c1 'b) 'y)
147     (map-slot-boundp* c1 '(a b))
148     (map-slot-boundp* c2 '(a b))
149     (map-slot-value c1 '(a b))
150     (progn (slot-makunbound c1 'a)
151            (slot-makunbound c1 'b)
152            (setf (slot-value c2 'a) 'x))
153     (setf (slot-value c2 'b) 'y)
154     (map-slot-boundp* c1 '(a b))
155     (map-slot-boundp* c2 '(a b))
156     (map-slot-value c2 '(a b))
157     (progn (slot-makunbound c2 'a)
158            (slot-makunbound c2 'b)
159            nil)))
160  (nil nil) (nil nil)
161  x y
162  (t t) (nil nil)
163  (x y)
164  x y
165  (nil nil) (t t)
166  (x y)
167  nil)
168
169;;;
170
171;;; Show shadowing of slots by :allocation
172
173(defclass class-0207a ()
174  ((a :allocation :class)))
175
176(defclass class-0207b (class-0207a)
177  ((a :allocation :instance)))
178
179(defclass class-0207c (class-0207b)
180  ((a :allocation :class)))
181
182(deftest class-0207.1
183  (let ((c1 (make-instance 'class-0207a))
184        (c2 (make-instance 'class-0207b))
185        (c3 (make-instance 'class-0207c)))
186    (slot-makunbound c1 'a)
187    (slot-makunbound c2 'a)
188    (slot-makunbound c3 'a)
189    (values
190     (setf (slot-value c1 'a) 'x)
191     (slot-boundp* c1 'a)
192     (slot-boundp* c2 'a)
193     (slot-boundp* c3 'a)
194     (slot-value c1 'a)
195     (setf (slot-value c2 'a) 'y)
196     (slot-boundp* c1 'a)
197     (slot-boundp* c2 'a)
198     (slot-boundp* c3 'a)
199     (slot-value c1 'a)
200     (slot-value c2 'a)
201     (setf (slot-value c3 'a) 'z)
202     (slot-boundp* c1 'a)
203     (slot-boundp* c2 'a)
204     (slot-boundp* c3 'a)
205     (slot-value c1 'a)
206     (slot-value c2 'a)
207     (slot-value c3 'a)))
208  x
209  t nil nil
210  x
211  y
212  t t nil
213  x y
214  z
215  t t t
216  x y z)
217
218;;;
219
220;;; Initforms are inherited even if :allocation changes
221
222(defclass class-0208a ()
223  ((a :allocation :class :initform 'x)))
224
225(defclass class-0208b (class-0208a)
226  ((a :allocation :instance)))
227
228(deftest class-0208.1
229  (values
230   (slot-value (make-instance 'class-0208a) 'a)
231   (slot-value (make-instance 'class-0208b) 'a))
232  x x)
233
234;;;
235
236;;; That was failing when things were reloaded.
237;;; Try a test that redefines it
238
239(deftest class-redefinition.1
240  (let*
241    ((cobj1 (eval '(defclass class-0209a ()
242                     ((a :allocation :class :initform 'x)))))
243     (cobj2 (eval '(defclass class-0209b (class-0209a)
244                     ((a :allocation :instance)))))
245     (cobj3 (eval '(defclass class-0209a ()
246                     ((a :allocation :class :initform 'x)))))
247     (cobj4 (eval '(defclass class-0209b (class-0209a)
248                     ((a :allocation :instance))))))
249    (values
250     (eqt cobj1 cobj3)
251     (eqt cobj2 cobj4)
252     (class-name cobj1)
253     (class-name cobj2)
254     (slot-value (make-instance 'class-0209a) 'a)
255     (slot-value (make-instance 'class-0209b) 'a)))
256  t t
257  class-0209a
258  class-0209b
259  x x)
260
261(deftest class-redefinition.2
262  (let*
263      (
264       (cobj1 (eval '(defclass class-0210a ()
265                       ((a :allocation :class)))))
266       (cobj2 (eval '(defclass class-0210b (class-0210a)
267                       ((a :allocation :instance)))))
268       (cobj3 (eval '(defclass class-0210c (class-0210b)
269                       ((a :allocation :class)))))
270       (dummy (progn
271                (setf (slot-value (make-instance 'class-0210a) 'a) :bad1)
272                (make-instance 'class-0210b)
273                (make-instance 'class-0210c)
274                nil))
275       (cobj4 (eval '(defclass class-0210a ()
276                       ((a :allocation :class)))))
277       (cobj5 (eval '(defclass class-0210b (class-0210a)
278                       ((a :allocation :instance)))))
279       (cobj6 (eval '(defclass class-0210c (class-0210b)
280                       ((a :allocation :class))))))
281    (list
282     (eqt cobj1 cobj4)
283     (eqt cobj2 cobj5)
284     (eqt cobj3 cobj6)
285     (class-name cobj1)
286     (class-name cobj2)
287     (class-name cobj3)
288     (let ((c1 (make-instance 'class-0210a))
289           (c2 (make-instance 'class-0210b))
290           (c3 (make-instance 'class-0210c)))
291       (slot-makunbound c1 'a)
292       (slot-makunbound c2 'a)
293       (slot-makunbound c3 'a)
294       (list
295        (setf (slot-value c1 'a) 'x)
296        (and (slot-boundp* c1 'a) (slot-value c1 'a))
297        (slot-boundp* c2 'a)
298        (slot-boundp* c3 'a)
299        (setf (slot-value c2 'a) 'y)
300        (and (slot-boundp* c1 'a) (slot-value c1 'a))
301        (and (slot-boundp* c2 'a) (slot-value c2 'a))
302        (slot-boundp* c3 'a)
303        (setf (slot-value c3 'a) 'z)
304        (and (slot-boundp* c1 'a) (slot-value c1 'a))
305        (and (slot-boundp* c2 'a) (slot-value c2 'a))
306        (and (slot-boundp* c3 'a) (slot-value c3 'a))))))
307  (t t t
308     class-0210a
309     class-0210b
310     class-0210c
311     (x
312      x nil nil
313      y
314      x y nil
315      z
316      x y z)))
317
318;;; Same as class-redefinition.1, but reverse the order in which
319;;; the classes are redefined.
320(deftest class-redefinition.3
321  (let*
322    ((cobj1 (eval '(defclass class-redef-03a ()
323                     ((a :allocation :class :initform 'x)))))
324     (cobj2 (eval '(defclass class-redef-03b (class-redef-03a)
325                     ((a :allocation :instance)))))
326     (cobj4 (eval '(defclass class-redef-03b (class-redef-03a)
327                     ((a :allocation :instance)))))
328     (cobj3 (eval '(defclass class-redef-03a ()
329                     ((a :allocation :class :initform 'x))))))
330    (values
331     (eqt cobj1 cobj3)
332     (eqt cobj2 cobj4)
333     (class-name cobj1)
334     (class-name cobj2)
335     (slot-value (make-instance 'class-redef-03a) 'a)
336     (slot-value (make-instance 'class-redef-03b) 'a)))
337  t t
338  class-redef-03a
339  class-redef-03b
340  x x)
341
342;;; Initforms are inherited even if :allocation changes
343
344(defclass class-0211a ()
345  ((a :allocation :instance :initform 'x)))
346
347(defclass class-0211b (class-0211a)
348  ((a :allocation :class)))
349
350(deftest class-0211.1
351  (values
352   (slot-value (make-instance 'class-0211a) 'a)
353   (slot-value (make-instance 'class-0211b) 'a))
354  x x)
355
356;;;
357
358;;; Inheritance of :initargs
359
360(defclass class-0212a ()
361  ((a :initarg :a1)))
362
363(defclass class-0212b (class-0212a)
364  ((a :initarg :a2)
365   (b :initarg :b)))
366
367(deftest class-0212.1
368  (let ((c (make-instance 'class-0212a :a1 'x)))
369    (values
370     (typep* c 'class-0212a)
371     (typep* c 'class-0212b)
372     (slot-value c 'a)
373     (slot-exists-p c 'b)))
374  t nil x nil)
375
376(deftest class-0212.2
377  (let ((c (make-instance 'class-0212b :a1 'x)))
378    (values
379     (typep* c 'class-0212a)
380     (typep* c 'class-0212b)
381     (slot-value c 'a)
382     (slot-boundp* c 'b)))
383  t t x nil)
384
385(deftest class-0212.3
386  (let ((c (make-instance 'class-0212b :a2 'x :b 'y)))
387    (values
388     (typep* c 'class-0212a)
389     (typep* c 'class-0212b)
390     (slot-value c 'a)
391     (slot-value c 'b)))
392  t t x y)
393
394(deftest class-0212.4
395  (let ((c (make-instance 'class-0212b :a1 'z :a2 'x :b 'y)))
396    (values
397     (typep* c 'class-0212a)
398     (typep* c 'class-0212b)
399     (slot-value c 'a)
400     (slot-value c 'b)))
401  t t z y)
402
403(deftest class-0212.5
404  (let ((c (make-instance 'class-0212b :a2 'x :b 'y :a1 'z)))
405    (values
406     (typep* c 'class-0212a)
407     (typep* c 'class-0212b)
408     (slot-value c 'a)
409     (slot-value c 'b)))
410  t t x y)
411
412;;;
413
414(defclass class-0213a ()
415  ((a :initarg :a1)))
416
417(defclass class-0213b (class-0213a)
418  (b))
419
420(deftest class-0213.1
421  (let ((c (make-instance 'class-0213a :a1 'x)))
422    (values
423     (typep* c 'class-0213a)
424     (typep* c 'class-0213b)
425     (slot-value c 'a)
426     (slot-exists-p c 'b)))
427  t nil x nil)
428
429(deftest class-0213.2
430  (let ((c (make-instance 'class-0213b :a1 'x)))
431    (values
432     (typep* c 'class-0213a)
433     (typep* c 'class-0213b)
434     (slot-value c 'a)
435     (slot-boundp* c 'b)))
436  t t x nil)
437
438;;;
439
440(defclass class-0214a ()
441  ((a :initarg :a1 :allocation :class)))
442
443(defclass class-0214b (class-0214a)
444  (b))
445
446(deftest class-0214.1
447  (let ((c (make-instance 'class-0214a :a1 'x)))
448    (values
449     (typep* c 'class-0214a)
450     (typep* c 'class-0214b)
451     (slot-value c 'a)
452     (slot-exists-p c 'b)))
453  t nil x nil)
454
455(deftest class-0214.2
456  (let ((c (make-instance 'class-0214b :a1 'y)))
457    (values
458     (typep* c 'class-0214a)
459     (typep* c 'class-0214b)
460     (slot-value c 'a)
461     (slot-boundp* c 'b)))
462  t t y nil)
463
464;;;
465
466(defclass class-0215a ()
467  ((a :initarg :a1 :allocation :instance)))
468
469(defclass class-0215b (class-0215a)
470  ((a :allocation :class)))
471
472(deftest class-0215.1
473  (let ((c (make-instance 'class-0215a :a1 'x)))
474    (values
475     (typep* c 'class-0215a)
476     (typep* c 'class-0215b)
477     (slot-value c 'a)))
478  t nil x)
479
480(deftest class-0215.2
481  (let ((c (make-instance 'class-0215b :a1 'y)))
482    (values
483     (typep* c 'class-0215a)
484     (typep* c 'class-0215b)
485     (slot-value c 'a)))
486  t t y)
487
488
489;;; Tests of defaulted initargs
490
491(defclass class-0216a ()
492  ((a :initarg :a1)
493   (b :initarg :b1)))
494
495(defclass class-0216b (class-0216a)
496  ()
497  (:default-initargs :a1 'x))
498
499(deftest class-0216.1
500  (let ((c (make-instance 'class-0216a)))
501    (values
502     (typep* c 'class-0216a)
503     (typep* c 'class-0216b)
504     (slot-boundp c 'a)
505     (slot-boundp c 'b)))
506  t nil nil nil)
507
508(deftest class-0216.2
509  (let ((c (make-instance 'class-0216b)))
510    (values
511     (typep* c 'class-0216a)
512     (typep* c 'class-0216b)
513     (slot-value c 'a)
514     (slot-boundp c 'b)))
515  t t x nil)
516
517;;;
518
519(defclass class-0217a ()
520  ((a :initarg :a1)
521   (b :initarg :b1)
522   (c :initarg :c1)
523   (d :initarg :d1))
524  (:default-initargs :a1 10 :b1 20))
525
526(defclass class-0217b (class-0217a)
527  ()
528  (:default-initargs :a1 30 :c1 40))
529
530(deftest class-0217.1
531  (let ((c (make-instance 'class-0217a)))
532    (values
533     (map-slot-boundp* c '(a b c d))
534     (map-slot-value c '(a b))))
535  (t t nil nil)
536  (10 20))
537
538(deftest class-0217.2
539  (let ((c (make-instance 'class-0217a :a1 'x :c1 'y)))
540    (values
541     (map-slot-boundp* c '(a b c d))
542     (map-slot-value c '(a b c))))
543  (t t t nil)
544  (x 20 y))
545
546(deftest class-0217.3
547  (let ((c (make-instance 'class-0217b)))
548    (values
549     (map-slot-boundp* c '(a b c d))
550     (map-slot-value c '(a b c))))
551  (t t t nil)
552  (30 20 40))
553
554(deftest class-0217.4
555  (let ((c (make-instance 'class-0217b :a1 'x :d1 'y)))
556    (values
557     (map-slot-boundp* c '(a b c d))
558     (map-slot-value c '(a b c d))))
559  (t t t t)
560  (x 20 40 y))
561
562;;;
563
564(defclass class-0218a ()
565  ((a :initarg :a1))
566  (:default-initargs :a1 'x))
567
568(defclass class-0218b (class-0218a)
569  ((a :initform 'y)))
570
571(deftest class-0218.1
572  (let ((c (make-instance 'class-0218a)))
573     (slot-value c 'a))
574  x)
575
576(deftest class-0218.2
577  (let ((c (make-instance 'class-0218b)))
578     (slot-value c 'a))
579  x)
580
581;;;
582
583(declaim (special *class-0219-a-1* *class-0219-a-2*))
584
585(defclass class-0219a ()
586  ((a :initarg :a1))
587  (:default-initargs :a1 (setf *class-0219-a-1* 'x)))
588
589(defclass class-0219b ()
590  ((a :initarg :a1))
591  (:default-initargs :a1 (setf *class-0219-a-2* 'y)))
592
593(deftest class-0219.1
594  (let ((*class-0219-a-1* nil))
595    (values
596     (slot-value (make-instance 'class-0219a) 'a)
597     *class-0219-a-1*))
598  x x)
599
600(deftest class-0219.2
601  (let ((*class-0219-a-1* nil)
602        (*class-0219-a-2* nil))
603    (values
604     (slot-value (make-instance 'class-0219b) 'a)
605     *class-0219-a-1*
606     *class-0219-a-2*))
607  y nil y)
608
609;;;
610
611(defclass class-0220a ()
612  ((a :type (integer 0 10) :initarg :a)))
613
614(defclass class-0220b (class-0220a)
615  ((a :type (integer -5 5))))
616
617(deftest class-0220.1
618  (slot-value (make-instance 'class-0220a :a 10) 'a)
619  10)
620
621(deftest class-0220.2
622  (slot-value (make-instance 'class-0220a :a 0) 'a)
623  0)
624
625(deftest class-0220.3
626  (slot-value (make-instance 'class-0220b :a 0) 'a)
627  0)
628
629(deftest class-0220.4
630  (slot-value (make-instance 'class-0220b :a 5) 'a)
631  5)
632
633;;;
634
635(defclass class-0221a ()
636  (a b c)
637  (:documentation "This is class class-0221a"))
638
639(defclass class-0221b (class-0221a)
640  ())
641
642(defclass class-0221c (class-0221a)
643  ()
644  (:documentation "This is class class-0221c"))
645
646(deftest class-0221.1
647  (let* ((cl (find-class 'class-0221a))
648         (doc (documentation cl t)))
649    (or (null doc)
650        (equalt doc "This is class class-0221a")))
651  t)
652
653(deftest class-0221.2
654  (let* ((cl (find-class 'class-0221b))
655         (doc (documentation cl t)))
656    doc)
657  nil)
658
659(deftest class-0221.3
660  (let* ((cl (find-class 'class-0221c))
661         (doc (documentation cl t)))
662    (or (null doc)
663        (equalt doc "This is class class-0221c")))
664  t)
665
666;;;
667
668(defclass class-0222a ()
669  ((s1 :reader s1-r :writer s1-w :accessor s1-acc)))
670
671(defclass class-0222b (class-0222a)
672  ())
673
674(deftest class-0222.1
675  (let ((c (make-instance 'class-0222a)))
676    (values
677     (s1-w 'x c)
678     (s1-r c)
679     (s1-acc c)
680     (setf (s1-acc c) 'y)
681     (s1-r c)))
682  x x x y y)
683
684(deftest class-0222.2
685  (let ((c (make-instance 'class-0222b)))
686    (values
687     (s1-w 'x c)
688     (s1-r c)
689     (s1-acc c)
690     (setf (s1-acc c) 'y)
691     (s1-r c)))
692  x x x y y)
693
694;;;
695
696(defclass class-0223a ()
697  ((s1 :reader s-r :writer s-w :accessor s-acc)))
698
699(defclass class-0223b (class-0223a)
700  ((s2 :reader s-r :writer s-w :accessor s-acc)))
701
702(deftest class-0223.1
703  (let ((c (make-instance 'class-0223b)))
704    (values
705     (setf (slot-value c 's1) 'x)
706     (setf (slot-value c 's2) 'y)
707     (s-r c)
708     (s-acc c)
709     (s-w 'z c)
710     (slot-value c 's1)
711     (slot-value c 's2)
712     (s-r c)
713     (s-acc c)))
714  x y y y z x z z z)
715
Note: See TracBrowser for help on using the repository browser.