source: trunk/source/tests/ansi-tests/defclass-01.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: 19.6 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sun Apr 20 20:58:54 2003
4;;;; Contains: Tests for DEFCLASS, part 01
5
6
7(in-package :cl-test)
8
9;;; I've decided to write some 'manual' tests, then refactor these back
10;;; to the automatic mechanisms I'll put into defclass-aux.lsp after
11;;; I have a better understanding of the object system
12
13(defclass class-01 () (s1 s2 s3))
14
15(deftest class-01.1
16  (notnot-mv (typep (make-instance 'class-01) 'class-01))
17  t)
18
19(deftest class-01.2
20  (notnot-mv (typep (make-instance (find-class 'class-01)) 'class-01))
21  t)
22
23(deftest class-01.3
24  (let ((c (make-instance 'class-01)))
25    (values
26     (setf (slot-value c 's1) 12)
27     (setf (slot-value c 's2) 18)
28     (setf (slot-value c 's3) 27)
29     (loop for s in '(s1 s2 s3) collect (slot-value c s))))
30  12 18 27
31  (12 18 27))
32
33;;;;
34
35(defclass class-02 () ((s1) (s2) (s3)))
36 
37(deftest class-02.1
38  (notnot-mv (typep (make-instance 'class-02) 'class-02))
39  t)
40
41(deftest class-02.2
42  (notnot-mv (typep (make-instance (find-class 'class-02)) 'class-02))
43  t)
44
45(deftest class-02.3
46  (let ((c (make-instance 'class-02)))
47    (values
48     (setf (slot-value c 's1) 12)
49     (setf (slot-value c 's2) 18)
50     (setf (slot-value c 's3) 27)
51     (loop for s in '(s1 s2 s3) collect (slot-value c s))))
52  12 18 27
53  (12 18 27))
54
55;;;;
56
57(defclass class-03 () ((s1 :type integer) (s2 :type t) (s3 :type fixnum)))
58 
59(deftest class-03.1
60  (notnot-mv (typep (make-instance 'class-03) 'class-03))
61  t)
62
63(deftest class-03.2
64  (notnot-mv (typep (make-instance (find-class 'class-03)) 'class-03))
65  t)
66
67(deftest class-03.3
68  (let ((c (make-instance 'class-03)))
69    (values
70     (setf (slot-value c 's1) 12)
71     (setf (slot-value c 's2) 'a)
72     (setf (slot-value c 's3) 27)
73     (loop for s in '(s1 s2 s3) collect (slot-value c s))))
74  12 a 27
75  (12 a 27))
76
77;;;;
78
79(defclass class-04 ()
80  ((s1 :reader s1-r) (s2 :writer s2-w) (s3 :accessor s3-a)))
81
82;;; Readers, writers, and accessors
83(deftest class-04.1
84  (let ((c (make-instance 'class-04)))
85    (values
86     (setf (slot-value c 's1) 'a)
87     (setf (slot-value c 's2) 'b)
88     (setf (slot-value c 's3) 'c)
89     (s1-r c)
90     (slot-value c 's2)
91     (s2-w 'd c)
92     (slot-value c 's2)
93     (s3-a c)
94     (setf (s3-a c) 'e)
95     (slot-value c 's3)
96     (s3-a c)))
97  a b c a b d d c e e e)
98
99(deftest class-04.2
100  (notnot-mv (typep #'s1-r 'generic-function))
101  t)
102
103(deftest class-04.3
104  (notnot-mv (typep #'s2-w 'generic-function))
105  t)
106
107(deftest class-04.4
108  (notnot-mv (typep #'s3-a 'generic-function))
109  t)
110
111(deftest class-04.5
112  (notnot-mv (typep #'(setf s3-a) 'generic-function))
113  t)
114
115;;;;
116
117(defclass class-05 () (s1 (s2 :allocation :instance) (s3 :allocation :class)))
118 
119(deftest class-05.1
120  (let ((c1 (make-instance 'class-05))
121        (c2 (make-instance 'class-05)))
122    (values
123     (not (eql c1 c2))
124     (list
125      (setf (slot-value c1 's1) 12)
126      (setf (slot-value c2 's1) 17)
127      (slot-value c1 's1)
128      (slot-value c2 's1))
129     (list
130      (setf (slot-value c1 's2) 'a)
131      (setf (slot-value c2 's2) 'b)
132      (slot-value c1 's2)
133      (slot-value c2 's2))
134     (list
135      (setf (slot-value c1 's3) 'x)
136      (slot-value c1 's3)
137      (slot-value c2 's3)
138      (setf (slot-value c2 's3) 'y)
139      (slot-value c1 's3)
140      (slot-value c2 's3)
141      (setf (slot-value c1 's3) 'z)
142      (slot-value c1 's3)
143      (slot-value c2 's3))
144     (slot-value (make-instance 'class-05) 's3)))
145  t
146  (12 17 12 17)
147  (a b a b)
148  (x x x y y y z z z)
149  z)
150
151;;;;
152
153(defclass class-06 () ((s1 :reader s1-r1 :reader s1-r2 :writer s1-w1 :writer s1-w2)))
154(defclass class-06a () ((s1 :reader s1-r1) s3))
155
156(deftest class-06.1
157  (let ((c (make-instance 'class-06)))
158    (values
159     (setf (slot-value c 's1) 'x)
160     (slot-value c 's1)
161     (s1-r1 c)
162     (s1-r2 c)
163     (s1-w1 'y c)
164     (slot-value c 's1)
165     (s1-r1 c)
166     (s1-r2 c)
167     (s1-w2 'z c)
168     (slot-value c 's1)
169     (s1-r1 c)
170     (s1-r2 c)))
171  x x x x y y y y z z z z)
172
173(deftest class-06.2
174  (let ((c1 (make-instance 'class-06))
175        (c2 (make-instance 'class-06a)))
176    (values
177     (setf (slot-value c1 's1) 'x)
178     (setf (slot-value c2 's1) 'y)
179     (mapcar #'s1-r1 (list c1 c2))))
180  x y (x y))
181
182;;;;
183
184(defclass class-07 () ((s1 :initarg :s1a :initarg :s1b :reader s1)
185                       (s2 :initarg :s2 :reader s2)))
186
187(deftest class-07.1
188  (let ((c (make-instance 'class-07)))
189    (values
190     (slot-boundp c 's1)
191     (slot-boundp c 's2)))
192  nil nil)
193
194(deftest class-07.2
195  (let ((c (make-instance 'class-07 :s1a 'x)))
196    (values
197     (notnot (slot-boundp c 's1))
198     (s1 c)
199     (slot-boundp c 's2)))
200  t x nil)
201
202(deftest class-07.3
203  (let ((c (make-instance 'class-07 :s1b 'x)))
204    (values
205     (notnot (slot-boundp c 's1))
206     (s1 c)
207     (slot-boundp c 's2)))
208  t x nil)
209
210(deftest class-07.4
211  (let ((c (make-instance 'class-07 :s1a 'y :s1b 'x)))
212    (values
213     (notnot (slot-boundp c 's1))
214     (s1 c)
215     (slot-boundp c 's2)))
216  t y nil)
217
218
219(deftest class-07.5
220  (let ((c (make-instance 'class-07 :s1b 'y :s1a 'x)))
221    (values
222     (notnot (slot-boundp c 's1))
223     (s1 c)
224     (slot-boundp c 's2)))
225  t y nil)
226
227(deftest class-07.6
228  (let ((c (make-instance 'class-07 :s1a 'y :s1a 'x)))
229    (values
230     (notnot (slot-boundp c 's1))
231     (s1 c)
232     (slot-boundp c 's2)))
233  t y nil)
234
235(deftest class-07.7
236  (let ((c (make-instance 'class-07 :s2 'a :s1a 'b)))
237    (values
238     (notnot (slot-boundp c 's1))
239     (notnot (slot-boundp c 's2))
240     (s1 c)
241     (s2 c)))
242  t t b a)
243
244(deftest class-07.8
245  (let ((c (make-instance 'class-07 :s2 'a :s1a 'b :s2 'x :s1a 'y :s1b 'z)))
246    (values
247     (notnot (slot-boundp c 's1))
248     (notnot (slot-boundp c 's2))
249     (s1 c)
250     (s2 c)))
251  t t b a)
252
253(deftest class-07.9
254  (let ((c (make-instance 'class-07 :s1b 'x :s1a 'y)))
255    (values
256     (notnot (slot-boundp c 's1))
257     (slot-boundp c 's2)
258     (s1 c)))
259  t nil x)
260
261(deftest class-07.10
262  (let ((c (make-instance 'class-07 :s1a 'x :s2 'y :allow-other-keys nil)))
263    (values (s1 c) (s2 c)))
264  x y)
265
266(deftest class-07.11
267  (let ((c (make-instance 'class-07 :s1a 'a :s2 'b :garbage 'z
268                          :allow-other-keys t)))
269    (values (s1 c) (s2 c)))
270  a b)
271
272(deftest class-07.12
273  (let ((c (make-instance 'class-07 :s1a 'd :s2 'c :garbage 'z
274                          :allow-other-keys t
275                          :allow-other-keys nil)))
276    (values (s1 c) (s2 c)))
277  d c)
278
279
280;;;;
281
282(declaim (special *class-08-s2-initvar*))
283
284(defclass class-08 ()
285  ((s1 :initform 0) (s2 :initform *class-08-s2-initvar*)))
286
287(deftest class-08.1
288  (let* ((*class-08-s2-initvar* 'x)
289         (c (make-instance 'class-08)))
290    (values
291     (slot-value c 's1)
292     (slot-value c 's2)))
293  0 x)
294
295;;;;
296
297(declaim (special *class-09-s2-initvar*))
298
299(defclass class-09 ()
300  ((s1 :initform 0 :initarg :s1)
301   (s2 :initform *class-09-s2-initvar* :initarg :s2)))
302
303(deftest class-09.1
304  (let* ((*class-09-s2-initvar* 'x)
305         (c (make-instance 'class-09)))
306    (values
307     (slot-value c 's1)
308     (slot-value c 's2)))
309  0 x)
310
311(deftest class-09.2
312  (let* ((*class-09-s2-initvar* 'x)
313         (c (make-instance 'class-09 :s1 1)))
314    (values
315     (slot-value c 's1)
316     (slot-value c 's2)))
317  1 x)
318
319(deftest class-09.3
320  (let* ((c (make-instance 'class-09 :s2 'a)))
321    (values
322     (slot-value c 's1)
323     (slot-value c 's2)))
324  0 a)
325
326(deftest class-09.4
327  (let* ((c (make-instance 'class-09 :s2 'a :s1 10 :s1 'bad :s2 'bad)))
328    (values
329     (slot-value c 's1)
330     (slot-value c 's2)))
331  10 a)
332
333;;;;
334
335(declaim (special *class-10-s1-initvar*))
336
337(defclass class-10 ()
338  ((s1 :initform (incf *class-10-s1-initvar*) :initarg :s1)))
339
340(deftest class-10.1
341  (let* ((*class-10-s1-initvar* 0)
342         (c (make-instance 'class-10)))
343    (values
344     *class-10-s1-initvar*
345     (slot-value c 's1)))
346  1 1)
347
348(deftest class-10.2
349  (let* ((*class-10-s1-initvar* 0)
350         (c (make-instance 'class-10 :s1 10)))
351    (values
352     *class-10-s1-initvar*
353     (slot-value c 's1)))
354  0 10)
355
356;;;;
357
358(let ((x 7))
359  (defclass class-11 ()
360    ((s1 :initform x :initarg :s1))))
361
362(deftest class-11.1
363  (slot-value (make-instance 'class-11) 's1)
364  7)
365
366(deftest class-11.2
367  (slot-value (make-instance 'class-11 :s1 100) 's1)
368  100)
369
370;;;
371
372(flet ((%f () 'x))
373  (defclass class-12 ()
374    ((s1 :initform (%f) :initarg :s1))))
375
376(deftest class-12.1
377  (slot-value (make-instance 'class-12) 's1)
378  x)
379
380(deftest class-12.2
381  (slot-value (make-instance 'class-12 :s1 'y) 's1)
382  y)
383
384;;;
385
386(defclass class-13 ()
387  ((s1 :allocation :class :initarg :s1)))
388
389(deftest class-13.1
390  (let ((c1 (make-instance 'class-13))
391        (c2 (make-instance 'class-13 :s1 'foo)))
392    (values
393     (slot-value c1 's1)
394     (slot-value c2 's1)))
395  foo foo)
396
397;;;
398
399(defclass class-14 ()
400  ((s1 :initarg nil :reader s1)))
401
402(deftest class-14.1
403  (let ((c (make-instance 'class-14 nil 'x)))
404    (s1 c))
405  x)
406
407;;;
408
409(defclass class-15 ()
410  ((s1 :initarg :allow-other-keys :reader s1)))
411
412;;; Dicussion on comp.lang.lisp convinced me this test was bogus.
413;;; The default value of :allow-other-keys specified in 7.1.2 is not
414;;; the same as the default value forms, specified by :default-initargs,
415;;; that are used to produce the defaulted initialization argument list.
416
417;;; (deftest class-15.1
418;;;  (let ((c (make-instance 'class-15)))
419;;;    (s1 c))
420;;;  nil)
421
422(deftest class-15.2
423  (let ((c (make-instance 'class-15 :allow-other-keys nil)))
424    (s1 c))
425  nil)
426
427(deftest class-15.3
428  (let ((c (make-instance 'class-15 :allow-other-keys t)))
429    (s1 c))
430  t)
431
432(deftest class-15.4
433  (let ((c (make-instance 'class-15 :allow-other-keys t
434                          :allow-other-keys nil)))
435    (s1 c))
436  t)
437
438(deftest class-15.5
439  (let ((c (make-instance 'class-15 :allow-other-keys nil
440                          :allow-other-keys t)))
441    (s1 c))
442  nil)
443
444(deftest class-15.6
445  (let ((c (make-instance 'class-15 :allow-other-keys t
446                          :foo 'bar)))
447    (s1 c))
448  t)
449
450(deftest class-15.7
451  (let ((c (make-instance 'class-15 :allow-other-keys t
452                          :allow-other-keys nil
453                          :foo 'bar)))
454    (s1 c))
455  t)
456
457;;; Tests of :default-initargs
458
459(defclass class-16 ()
460  ((s1 :initarg :s1))
461  (:default-initargs :s1 'x))
462
463(deftest class-16.1
464  (let ((c (make-instance 'class-16)))
465    (slot-value c 's1))
466  x)
467
468(deftest class-16.2
469  (let ((c (make-instance 'class-16 :s1 'y)))
470    (slot-value c 's1))
471  y)
472
473(deftest class-16.3
474  (let ((c (make-instance 'class-16 :s1 nil)))
475    (slot-value c 's1))
476  nil)
477
478;;;
479
480(defclass class-17 ()
481  ((s1 :initarg :s1 :initform 'foo))
482  (:default-initargs :s1 'bar))
483
484(deftest class-17.1
485  (let ((c (make-instance 'class-17)))
486    (slot-value c 's1))
487  bar)
488
489(deftest class-17.2
490  (let ((c (make-instance 'class-17 :s1 'z)))
491    (slot-value c 's1))
492  z)
493
494(deftest class-17.3
495  (let ((c (make-instance 'class-17 :s1 nil)))
496    (slot-value c 's1))
497  nil)
498
499;;;
500
501(defclass class-18 ()
502  ((s1 :initarg :s1 :initarg :s1b))
503  (:default-initargs :s1 'x :s1b 'y))
504
505(deftest class-18.1
506  (let ((c (make-instance 'class-18)))
507    (slot-value c 's1))
508  x)
509
510(deftest class-18.2
511  (let ((c (make-instance 'class-18 :s1 'z)))
512    (slot-value c 's1))
513  z)
514
515(deftest class-18.3
516  (let ((c (make-instance 'class-18 :s1 nil)))
517    (slot-value c 's1))
518  nil)
519
520(deftest class-18.4
521  (let ((c (make-instance 'class-18 :s1b 'z)))
522    (slot-value c 's1))
523  z)
524
525(deftest class-18.5
526  (let ((c (make-instance 'class-18 :s1b nil)))
527    (slot-value c 's1))
528  nil)
529
530;;;
531
532(declaim (special *class-19-s1-initvar*))
533
534(defclass class-19 ()
535  ((s1 :initarg :s1))
536  (:default-initargs :s1 (setf *class-19-s1-initvar* 'a)))
537
538(deftest class-19.1
539  (let* ((*class-19-s1-initvar* nil)
540         (c (make-instance 'class-19)))
541    (declare (special *class-19-s1-initvar*))
542    (values
543     (slot-value c 's1)
544     *class-19-s1-initvar*))
545  a a)
546
547(deftest class-19.2
548  (let* ((*class-19-s1-initvar* nil)
549         (c (make-instance 'class-19 :s1 nil)))
550    (declare (special *class-19-s1-initvar*))
551    (values
552     (slot-value c 's1)
553     *class-19-s1-initvar*))
554  nil nil)
555
556(deftest class-19.3
557  (let* ((*class-19-s1-initvar* nil)
558         (c (make-instance 'class-19 :s1 'x)))
559    (declare (special *class-19-s1-initvar*))
560    (values
561     (slot-value c 's1)
562     *class-19-s1-initvar*))
563  x nil)
564
565;;;
566
567(declaim (special *class-20-s1-initvar-1* *class-20-s1-initvar-2*))
568
569(defclass class-20 ()
570  ((s1 :initarg :s1 :initarg :s1b))
571  (:default-initargs :s1 (setf *class-20-s1-initvar-1* 'a)
572                     :s1b (setf *class-20-s1-initvar-2* 'b)))
573
574(deftest class-20.1
575  (let* (*class-20-s1-initvar-1*
576         *class-20-s1-initvar-2*
577         (c (make-instance 'class-20)))
578    (declare (special *class-20-s1-initvar-1*
579                      *class-20-s1-initvar-2*))
580    (values
581     (slot-value c 's1)
582     *class-20-s1-initvar-1*
583     *class-20-s1-initvar-2*))
584  a a b)
585
586(deftest class-20.2
587  (let* (*class-20-s1-initvar-1*
588         *class-20-s1-initvar-2*
589         (c (make-instance 'class-20 :s1 'x)))
590    (declare (special *class-20-s1-initvar-1*
591                      *class-20-s1-initvar-2*))
592    (values
593     (slot-value c 's1)
594     *class-20-s1-initvar-1*
595     *class-20-s1-initvar-2*))
596  x nil b)
597
598(deftest class-20.3
599  (let* (*class-20-s1-initvar-1*
600         *class-20-s1-initvar-2*
601         (c (make-instance 'class-20 :s1b 'y)))
602    (declare (special *class-20-s1-initvar-1*
603                      *class-20-s1-initvar-2*))
604    (values
605     (slot-value c 's1)
606     *class-20-s1-initvar-1*
607     *class-20-s1-initvar-2*))
608  y a nil)
609
610;;;
611
612(declaim (special *class-21-s1-initvar-1* *class-21-s1-initvar-2*))
613
614(let ((*class-21-s1-initvar-1* 0)
615      (*class-21-s1-initvar-2* 0))
616  (defclass class-21 ()
617    ((s1 :initarg :s1  :initarg :s1b)
618     (s2 :initarg :s1b :initarg :s2))
619    (:default-initargs :s1  (incf *class-21-s1-initvar-1*)
620                       :s1b (incf *class-21-s1-initvar-2*))))
621
622(deftest class-21.1
623  (let* ((*class-21-s1-initvar-1* 10)
624         (*class-21-s1-initvar-2* 20)
625         (c (make-instance 'class-21)))
626    (declare (special *class-21-s1-initvar-1*
627                      *class-21-s1-initvar-2*))
628    (values
629     (slot-value c 's1)
630     (slot-value c 's2)
631     *class-21-s1-initvar-1*
632     *class-21-s1-initvar-2*))
633  11 21 11 21)
634
635(deftest class-21.2
636  (let* ((*class-21-s1-initvar-1* 10)
637         (*class-21-s1-initvar-2* 20)
638         (c (make-instance 'class-21 :s1 'x)))
639    (declare (special *class-21-s1-initvar-1*
640                      *class-21-s1-initvar-2*))
641    (values
642     (slot-value c 's1)
643     (slot-value c 's2)
644     *class-21-s1-initvar-1*
645     *class-21-s1-initvar-2*))
646  x 21 10 21)
647
648(deftest class-21.3
649  (let* ((*class-21-s1-initvar-1* 10)
650         (*class-21-s1-initvar-2* 20)
651         (c (make-instance 'class-21 :s1 'x :s1b 'y)))
652    (declare (special *class-21-s1-initvar-1*
653                      *class-21-s1-initvar-2*))
654    (values
655     (slot-value c 's1)
656     (slot-value c 's2)
657     *class-21-s1-initvar-1*
658     *class-21-s1-initvar-2*))
659  x y 10 20)
660
661(deftest class-21.4
662  (let* ((*class-21-s1-initvar-1* 10)
663         (*class-21-s1-initvar-2* 20)
664         (c (make-instance 'class-21 :s1b 'y)))
665    (declare (special *class-21-s1-initvar-1*
666                      *class-21-s1-initvar-2*))
667    (values
668     (slot-value c 's1)
669     (slot-value c 's2)
670     *class-21-s1-initvar-1*
671     *class-21-s1-initvar-2*))
672  y y 11 20)
673
674(deftest class-21.5
675  (let* ((*class-21-s1-initvar-1* 10)
676         (*class-21-s1-initvar-2* 20)
677         (c (make-instance 'class-21 :s2 'y)))
678    (declare (special *class-21-s1-initvar-1*
679                      *class-21-s1-initvar-2*))
680    (values
681     (slot-value c 's1)
682     (slot-value c 's2)
683     *class-21-s1-initvar-1*
684     *class-21-s1-initvar-2*))
685  11 y 11 21)
686
687;;; Documentation strings
688
689(defclass class-22 ()
690  ((s1 :documentation "This is slot s1 in class class-22")))
691
692(deftest class-22.1
693  (notnot-mv (typep (make-instance 'class-22) 'class-22))
694  t)
695
696;;; We can't portably get at the docstring of slots
697
698;;;
699
700(defclass class-23 ()
701  (s1 s2 s3)
702  (:documentation "This is class-23 in ansi-tests"))
703
704(deftest class-23.1
705  (notnot-mv (typep (make-instance 'class-23) 'class-23))
706  t)
707
708(deftest class-23.2
709  (let ((doc (documentation 'class-23 'type)))
710    (or (null doc)
711        (equalt doc "This is class-23 in ansi-tests")))
712  t)
713
714(deftest class-23.3
715  (let ((doc (documentation (find-class 'class-23) 'type)))
716    (or (null doc)
717        (equalt doc "This is class-23 in ansi-tests")))
718  t)
719
720(deftest class-23.4
721  (let ((doc (documentation (find-class 'class-23) t)))
722    (or (null doc)
723        (equalt doc "This is class-23 in ansi-tests")))
724  t)
725
726;;;
727
728(defclass class-24 ()
729  ((s1 :initarg :allow-other-keys :reader s1))
730  (:default-initargs :allow-other-keys t))
731
732(deftest class-24.1
733  (s1 (make-instance 'class-24))
734  t)
735
736(deftest class-24.2
737  (s1 (make-instance 'class-24 :nonsense t))
738  t)
739
740(deftest class-24.3
741  (s1 (make-instance 'class-24 :allow-other-keys nil))
742  nil)
743
744(deftest class-24.4
745  (s1 (make-instance 'class-24 :allow-other-keys 'a :foo t))
746  a)
747
748;;;
749
750(defclass class-25 ()
751  ((s1 :initarg :allow-other-keys :reader s1))
752  (:default-initargs :allow-other-keys nil))
753
754(deftest class-25.1
755  (s1 (make-instance 'class-25))
756  nil)
757
758(deftest class-25.2
759  (s1 (make-instance 'class-25 :allow-other-keys t))
760  t)
761
762(deftest class-25.3
763  (s1 (make-instance 'class-25 :allow-other-keys t :foo nil))
764  t)
765
766(deftest class-25.4
767  (s1 (make-instance 'class-25 :allow-other-keys t :allow-other-keys nil))
768  t)
769
770(deftest class-25.5
771  (s1 (make-instance 'class-25 :allow-other-keys t :allow-other-keys nil
772                     :foo t))
773  t)
774
775(deftest class-25.6
776  (s1 (make-instance 'class-25 :allow-other-keys 'foo :allow-other-keys 'bar))
777  foo)
778
779;;;
780
781(defclass class-26 ()
782  ((s1-26 :writer (setf s1-26))))
783
784(deftest class-26.1
785  (let ((c (make-instance 'class-26)))
786    (values
787     (slot-boundp c 's1-26)
788     (setf (s1-26 c) 'x)
789     (slot-value c 's1-26)
790     (typep* #'(setf s1-26) 'generic-function)))
791  nil x x t)
792
793;;;
794
795(defclass class-27 ()
796  (a (b :initform 10) (c :initarg :c) (d :initarg :d))
797  (:metaclass standard-class)
798  (:default-initargs :d 17))
799
800(deftest class-27.1
801  (let ((class (find-class 'class-27)))
802    (values
803     (subtypep* 'class-27 'standard-object)
804     (subtypep* 'class-27 t)
805     (subtypep* 'class-27 (find-class 'standard-object))
806     (subtypep* 'class-27 (find-class t))
807     (subtypep* class 'standard-object)
808     (subtypep* class t)
809     (subtypep* class (find-class 'standard-object))
810     (subtypep* class (find-class t))))
811  t t t t t t t t)
812
813(deftest class-27.2
814  (let ((c (make-instance 'class-27)))
815    (values
816     (slot-boundp* c 'a)
817     (slot-value c 'b)
818     (slot-boundp* c 'c)
819     (slot-value c 'd)))
820  nil 10 nil 17)
821
822(deftest class-27.3
823  (let ((c (make-instance 'class-27 :c 26 :d 43)))
824    (values
825     (slot-boundp* c 'a)
826     (slot-value c 'b)
827     (slot-value c 'c)
828     (slot-value c 'd)))
829  nil 10 26 43)
830
831;;;
832
833(declaim (special *class-28-reset-fn*
834                  *class-28-query-fn*))
835
836(declaim (type function *class-28-reset-fn* *class-28-query-fn*))
837
838(let ((x 0) (y 0))
839  (flet ((%reset (a b) (setf x a y b))
840         (%query () (list x y)))
841    (setf *class-28-reset-fn* #'%reset
842          *class-28-query-fn* #'%query)
843    (defclass class-28 ()
844      ((s1 :initform (incf x) :initarg :s1)
845       (s2 :initarg :s2))
846      (:default-initargs :s2 (incf y)))))
847
848(deftest class-28.1
849  (let ((class (find-class 'class-28)))
850    (funcall *class-28-reset-fn* 5 10)
851    (list
852     (funcall *class-28-query-fn*)
853     (let ((obj (make-instance 'class-28)))
854       (list
855        (typep* obj 'class-28)
856        (typep* obj class)
857        (eqt (class-of obj) class)
858        (map-slot-value obj '(s1 s2))
859        (funcall *class-28-query-fn*)))))
860  ((5 10)
861   (t t t (6 11) (6 11))))
862
863(deftest class-28.2
864  (let ((class (find-class 'class-28)))
865    (funcall *class-28-reset-fn* 5 10)
866    (list
867     (funcall *class-28-query-fn*)
868     (let ((obj (make-instance 'class-28 :s1 17)))
869       (list
870        (typep* obj 'class-28)
871        (typep* obj class)
872        (eqt (class-of obj) class)
873        (map-slot-value obj '(s1 s2))
874        (funcall *class-28-query-fn*)))))
875  ((5 10)
876   (t t t (17 11) (5 11))))
877
878
879(deftest class-28.3
880  (let ((class (find-class 'class-28)))
881    (funcall *class-28-reset-fn* 5 10)
882    (list
883     (funcall *class-28-query-fn*)
884     (let ((obj (make-instance 'class-28 :s2 17)))
885       (list
886        (typep* obj 'class-28)
887        (typep* obj class)
888        (eqt (class-of obj) class)
889        (map-slot-value obj '(s1 s2))
890        (funcall *class-28-query-fn*)))))
891  ((5 10)
892   (t t t (6 17) (6 10))))
893
894
895     
896     
Note: See TracBrowser for help on using the repository browser.