source: trunk/source/tests/ansi-tests/shared-initialize.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: 17.9 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Tue Apr 29 04:09:06 2003
4;;;; Contains: Tests of SHARED-INITIALIZE
5
6(in-package :cl-test)
7
8(defclass shared-init-class-01 ()
9  ((a :initform 'x :initarg :a)
10   (b :initform 'y :initarg :b)
11   (c :initarg :c)
12   d))
13
14(deftest shared-initialize.1.1
15  (let ((obj (allocate-instance (find-class 'shared-init-class-01))))
16    (values
17     (map-slot-boundp* obj '(a b c d))
18     (eqt obj (shared-initialize obj nil :a 1 :b 3 :c 14))
19     (map-slot-boundp* obj '(a b c d))
20     (map-slot-value obj '(a b c))))
21  (nil nil nil nil)
22  t
23  (t t t nil)
24  (1 3 14))
25
26(deftest shared-initialize.1.2
27  (let ((obj (allocate-instance (find-class 'shared-init-class-01))))
28    (values
29     (map-slot-boundp* obj '(a b c d))
30     (eqt obj (shared-initialize obj nil))
31     (map-slot-boundp* obj '(a b c d))))
32  (nil nil nil nil)
33  t
34  (nil nil nil nil))
35
36(deftest shared-initialize.1.3
37  (let ((obj (allocate-instance (find-class 'shared-init-class-01))))
38    (values
39     (map-slot-boundp* obj '(a b c d))
40     (eqt obj (shared-initialize obj nil :a 1 :a 2))
41     (map-slot-boundp* obj '(a b c d))
42     (slot-value obj 'a)))
43  (nil nil nil nil)
44  t
45  (t nil nil nil)
46  1)
47
48(deftest shared-initialize.1.4
49  (let ((obj (allocate-instance (find-class 'shared-init-class-01))))
50    (values
51     (map-slot-boundp* obj '(a b c d))
52     (eqt obj (shared-initialize obj nil :a 1 :a 2 :allow-other-keys nil))
53     (map-slot-boundp* obj '(a b c d))
54     (slot-value obj 'a)))
55  (nil nil nil nil)
56  t
57  (t nil nil nil)
58  1)
59
60(deftest shared-initialize.1.5
61  (let ((obj (allocate-instance (find-class 'shared-init-class-01))))
62    (values
63     (map-slot-boundp* obj '(a b c d))
64     (eqt obj (shared-initialize obj '(a) :a 1))
65     (map-slot-boundp* obj '(a b c d))
66     (slot-value obj 'a)))
67  (nil nil nil nil)
68  t
69  (t nil nil nil)
70  1)
71
72(deftest shared-initialize.1.6
73  (let ((obj (allocate-instance (find-class 'shared-init-class-01))))
74    (values
75     (map-slot-boundp* obj '(a b c d))
76     (eqt obj (shared-initialize obj '(a)))
77     (map-slot-boundp* obj '(a b c d))
78     (slot-value obj 'a)))
79  (nil nil nil nil)
80  t
81  (t nil nil nil)
82  x)
83
84(deftest shared-initialize.1.7
85  (let ((obj (allocate-instance (find-class 'shared-init-class-01))))
86    (values
87     (map-slot-boundp* obj '(a b c d))
88     (eqt obj (shared-initialize obj t))
89     (map-slot-boundp* obj '(a b c d))
90     (slot-value obj 'a)
91     (slot-value obj 'b)))
92  (nil nil nil nil)
93  t
94  (t t nil nil)
95  x y)
96
97(deftest shared-initialize.1.8
98  (let ((obj (allocate-instance (find-class 'shared-init-class-01))))
99    (values
100     (map-slot-boundp* obj '(a b c d))
101     (eqt obj (shared-initialize obj t :b 10 :c 100))
102     (map-slot-boundp* obj '(a b c d))
103     (slot-value obj 'a)
104     (slot-value obj 'b)
105     (slot-value obj 'c)))
106  (nil nil nil nil)
107  t
108  (t t t nil)
109  x 10 100)
110
111(deftest shared-initialize.1.9
112  (let ((obj (allocate-instance (find-class 'shared-init-class-01))))
113    (values
114     (map-slot-boundp* obj '(a b c d))
115     (eqt obj (shared-initialize obj nil :a 1 :b 10 :c 100))
116     (eqt obj (shared-initialize obj nil :a 5 :b 37 :c 213))
117     (map-slot-boundp* obj '(a b c d))
118     (slot-value obj 'a)
119     (slot-value obj 'b)
120     (slot-value obj 'c)))
121  (nil nil nil nil)
122  t t
123  (t t t nil)
124  5 37 213)
125
126(deftest shared-initialize.1.10
127  (let ((obj (allocate-instance (find-class 'shared-init-class-01))))
128    (setf (slot-value obj 'a) 1000)
129    (values
130     (map-slot-boundp* obj '(a b c d))
131     (eqt obj (shared-initialize obj '(a)))
132     (map-slot-boundp* obj '(a b c d))
133     (slot-value obj 'a)))
134  (t nil nil nil)
135  t
136  (t nil nil nil)
137  1000)
138
139;;; Initforms in the lexical environment of the defclass
140
141(declaim (special *shared-init-var-02-init*
142                  *shared-init-var-02-query*))
143
144(declaim (type function *shared-init-var-02-init* *shared-init-var-02-query*))
145
146(let ((ainit 0) (binit 0))
147  (flet ((%init (a b) (setf ainit a binit b))
148         (%query () (list ainit binit)))
149    (setf *shared-init-var-02-init* #'%init
150          *shared-init-var-02-query* #'%query)
151    (defclass shared-init-class-02 ()
152      ((a :initform (incf ainit) :initarg :a)
153       (b :initform (incf binit) :initarg :b)
154       (c :initarg :c)
155       (d))
156      (:default-initargs :c 100))))
157
158(deftest shared-initialize.2.1
159  (progn
160    (funcall *shared-init-var-02-init* 5 10)
161    (let ((obj (allocate-instance (find-class 'shared-init-class-02))))
162      (values
163       (funcall *shared-init-var-02-query*)
164       (eqt obj (shared-initialize obj t))
165       (slot-value obj 'a)
166       (slot-value obj 'b)
167       (map-slot-boundp* obj '(a b c d))
168       (funcall *shared-init-var-02-query*))))
169  (5 10)
170  t
171  6 11
172  (t t nil nil)
173  (6 11))
174
175(deftest shared-initialize.2.2
176  (progn
177    (funcall *shared-init-var-02-init* 5 10)
178    (let ((obj (allocate-instance (find-class 'shared-init-class-02))))
179      (values
180       (funcall *shared-init-var-02-query*)
181       (eqt obj (shared-initialize obj nil))
182       (map-slot-boundp* obj '(a b c d))
183       (funcall *shared-init-var-02-query*))))
184  (5 10)
185  t
186  (nil nil nil nil)
187  (5 10))
188
189(deftest shared-initialize.2.3
190  (progn
191    (funcall *shared-init-var-02-init* 5 10)
192    (let ((obj (allocate-instance (find-class 'shared-init-class-02))))
193      (values
194       (funcall *shared-init-var-02-query*)
195       (eqt obj (shared-initialize obj '(a)))
196       (slot-value obj 'a)
197       (map-slot-boundp* obj '(a b c d))
198       (funcall *shared-init-var-02-query*))))
199  (5 10)
200  t
201  6
202  (t nil nil nil)
203  (6 10))
204
205(deftest shared-initialize.2.4
206  (progn
207    (funcall *shared-init-var-02-init* 5 10)
208    (let ((obj (allocate-instance (find-class 'shared-init-class-02))))
209      (values
210       (funcall *shared-init-var-02-query*)
211       (eqt obj (shared-initialize obj '(b)))
212       (slot-value obj 'b)
213       (map-slot-boundp* obj '(a b c d))
214       (funcall *shared-init-var-02-query*))))
215  (5 10)
216  t
217  11
218  (nil t nil nil)
219  (5 11))
220
221(deftest shared-initialize.2.5
222  (progn
223    (funcall *shared-init-var-02-init* 5 10)
224    (let ((obj (allocate-instance (find-class 'shared-init-class-02))))
225      (values
226       (funcall *shared-init-var-02-query*)
227       (eqt obj (shared-initialize obj t :a 34 :b 49))
228       (map-slot-value obj '(a b))
229       (map-slot-boundp* obj '(a b c d))
230       (funcall *shared-init-var-02-query*))))
231  (5 10)
232  t
233  (34 49)
234  (t t nil nil)
235  (5 10))
236
237(deftest shared-initialize.2.6
238  (progn
239    (funcall *shared-init-var-02-init* 5 10)
240    (let ((obj (allocate-instance (find-class 'shared-init-class-02))))
241      (values
242       (funcall *shared-init-var-02-query*)
243       (eqt obj (shared-initialize obj '(a b c d) :a 34 :b 49))
244       (map-slot-value obj '(a b))
245       (map-slot-boundp* obj '(a b c d))
246       (funcall *shared-init-var-02-query*))))
247  (5 10)
248  t
249  (34 49)
250  (t t nil nil)
251  (5 10))
252
253;;; Defining new methods on shared-initialize
254
255(defstruct shared-init-class-03
256  a b c)
257
258(defmethod shared-initialize ((obj shared-init-class-03)
259                              slots-to-init
260                              &key
261                              (a nil a-p)
262                              (b nil b-p)
263                              (c nil c-p)
264                              &allow-other-keys)
265  (declare (ignore slots-to-init))
266;;  (when a-p (setf (slot-value obj 'a) a))
267;;  (when b-p (setf (slot-value obj 'b) b))
268;;  (when c-p (setf (slot-value obj 'c) c))
269  (when a-p (setf (shared-init-class-03-a obj) a))
270  (when b-p (setf (shared-init-class-03-b obj) b))
271  (when c-p (setf (shared-init-class-03-c obj) c))
272  obj)
273
274(deftest shared-initialize.3.1
275  (let ((obj (make-shared-init-class-03)))
276    (values
277     (eqt obj (shared-initialize obj nil :a 1 :b 5 :c 19))
278     (shared-init-class-03-a obj)
279     (shared-init-class-03-b obj)
280     (shared-init-class-03-c obj)))
281  t 1 5 19)
282
283
284;;; Inheritance
285
286(defclass shared-init-class-04a ()
287  ((a :initform 4 :initarg :a)
288   (b :initform 8 :initarg :b)))
289
290(defclass shared-init-class-04b (shared-init-class-04a)
291  ((c :initform 17 :initarg :c) d)
292  (:default-initargs :a 1))
293
294(deftest shared-initialize.4.1
295  (let ((obj (allocate-instance (find-class 'shared-init-class-04b))))
296    (values
297     (eqt obj (shared-initialize obj nil :a 'x))
298     (map-slot-boundp* obj '(a b c d))
299     (slot-value obj 'a)))
300  t
301  (t nil nil nil)
302  x)
303
304(deftest shared-initialize.4.2
305  (let ((obj (allocate-instance (find-class 'shared-init-class-04b))))
306    (values
307     (eqt obj (shared-initialize obj nil))
308     (map-slot-boundp* obj '(a b c d))))
309  t
310  (nil nil nil nil))
311
312(deftest shared-initialize.4.3
313  (let ((obj (allocate-instance (find-class 'shared-init-class-04b))))
314    (values
315     (eqt obj (shared-initialize obj t))
316     (map-slot-boundp* obj '(a b c d))
317     (map-slot-value obj '(a b c))))
318  t
319  (t t t nil)
320  (4 8 17))
321
322(deftest shared-initialize.4.4
323  (let ((obj (allocate-instance (find-class 'shared-init-class-04b))))
324    (values
325     (eqt obj (shared-initialize obj '(a c)))
326     (map-slot-boundp* obj '(a b c d))
327     (map-slot-value obj '(a c))))
328  t
329  (t nil t nil)
330  (4 17))
331
332(deftest shared-initialize.4.5
333  (let ((obj (allocate-instance (find-class 'shared-init-class-04b))))
334    (values
335     (eqt obj (shared-initialize obj '(a c) :c 81))
336     (map-slot-boundp* obj '(a b c d))
337     (map-slot-value obj '(a c))))
338  t
339  (t nil t nil)
340  (4 81))
341
342(deftest shared-initialize.4.6
343  (let ((obj (allocate-instance (find-class 'shared-init-class-04b))))
344    (values
345     (eqt obj (shared-initialize obj '(a c) :a 91))
346     (map-slot-boundp* obj '(a b c d))
347     (map-slot-value obj '(a c))))
348  t
349  (t nil t nil)
350  (91 17))
351
352(deftest shared-initialize.4.7
353  (let ((obj (allocate-instance (find-class 'shared-init-class-04b))))
354    (values
355     (eqt obj (shared-initialize obj '(c)))
356     (map-slot-boundp* obj '(a b c d))
357     (slot-value obj 'c)))
358  t
359  (nil nil t nil)
360  17)
361
362;;; shared-initialize and class slots
363
364(defclass shared-init-class-05 ()
365  ((a :initarg :a :allocation :class)
366   (b :initarg :b :initform 'foo :allocation :class)))
367
368(deftest shared-initialize.5.1
369  (let* ((class (find-class 'shared-init-class-05))
370         (obj (allocate-instance class)))
371    (slot-makunbound obj 'a)
372    (slot-makunbound obj 'b)
373    (values
374     (eqt obj (shared-initialize obj t))
375     (map-slot-boundp* obj '(a b))
376     (slot-value obj 'b)))
377  t
378  (nil t)
379  foo)
380
381(deftest shared-initialize.5.2
382  (let* ((class (find-class 'shared-init-class-05))
383         (obj (allocate-instance class)))
384    (slot-makunbound obj 'a)
385    (slot-makunbound obj 'b)
386    (values
387     (eqt obj (shared-initialize obj '(b)))
388     (map-slot-boundp* obj '(a b))
389     (slot-value obj 'b)))
390  t
391  (nil t)
392  foo)
393
394(deftest shared-initialize.5.3
395  (let* ((class (find-class 'shared-init-class-05))
396         (obj (allocate-instance class))
397         (obj2 (allocate-instance class)))
398    (slot-makunbound obj 'a)
399    (slot-makunbound obj 'b)
400    (values
401     (eqt obj (shared-initialize obj t :a 117))
402     (map-slot-boundp* obj '(a b))
403     (map-slot-value obj '(a b))
404     (map-slot-value obj2 '(a b))))
405  t
406  (t t)
407  (117 foo)
408  (117 foo))
409
410(deftest shared-initialize.5.4
411  (let* ((class (find-class 'shared-init-class-05))
412         (obj (allocate-instance class))
413         (obj2 (allocate-instance class)))
414    (slot-makunbound obj 'a)
415    (values
416     (setf (slot-value obj 'b) 'bar)
417     (eqt obj (shared-initialize obj t :a 117))
418     (map-slot-boundp* obj '(a b))
419     (map-slot-value obj '(a b))
420     (map-slot-value obj2 '(a b))))
421  bar
422  t
423  (t t)
424  (117 bar)
425  (117 bar))
426
427;;; Shared initargs
428
429(defclass shared-init-class-06 ()
430  ((a :initarg :i1 :initarg :i2 :initform 'x)
431   (b :initarg :i2 :initarg :i3 :initform 'y)))
432
433(deftest shared-initialize.6.1
434  (let* ((class (find-class 'shared-init-class-06))
435         (obj (allocate-instance class)))
436    (values
437     (map-slot-boundp* obj '(a b))
438     (eqt obj (shared-initialize obj nil))
439     (map-slot-boundp* obj '(a b))))
440  (nil nil)
441  t
442  (nil nil))
443
444(deftest shared-initialize.6.2
445  (let* ((class (find-class 'shared-init-class-06))
446         (obj (allocate-instance class)))
447    (values
448     (map-slot-boundp* obj '(a b))
449     (eqt obj (shared-initialize obj t))
450     (map-slot-boundp* obj '(a b))
451     (slot-value obj 'a)
452     (slot-value obj 'b)))
453  (nil nil)
454  t
455  (t t)
456  x y)
457
458(deftest shared-initialize.6.3
459  (let* ((class (find-class 'shared-init-class-06))
460         (obj (allocate-instance class)))
461    (values
462     (map-slot-boundp* obj '(a b))
463     (eqt obj (shared-initialize obj nil :i1 'z))
464     (map-slot-boundp* obj '(a b))
465     (slot-value obj 'a)))
466  (nil nil)
467  t
468  (t nil)
469  z)
470
471(deftest shared-initialize.6.4
472  (let* ((class (find-class 'shared-init-class-06))
473         (obj (allocate-instance class)))
474    (values
475     (map-slot-boundp* obj '(a b))
476     (eqt obj (shared-initialize obj nil :i2 'z))
477     (map-slot-boundp* obj '(a b))
478     (slot-value obj 'a)
479     (slot-value obj 'b)))
480  (nil nil)
481  t
482  (t t)
483  z z)
484
485(deftest shared-initialize.6.5
486  (let* ((class (find-class 'shared-init-class-06))
487         (obj (allocate-instance class)))
488    (values
489     (map-slot-boundp* obj '(a b))
490     (eqt obj (shared-initialize obj nil :i1 'w :i2 'z))
491     (map-slot-boundp* obj '(a b))
492     (slot-value obj 'a)
493     (slot-value obj 'b)))
494  (nil nil)
495  t
496  (t t)
497  w z)
498
499(deftest shared-initialize.6.6
500  (let* ((class (find-class 'shared-init-class-06))
501         (obj (allocate-instance class)))
502    (values
503     (map-slot-boundp* obj '(a b))
504     (eqt obj (shared-initialize obj nil :i2 'z :i1 'w))
505     (map-slot-boundp* obj '(a b))
506     (slot-value obj 'a)
507     (slot-value obj 'b)))
508  (nil nil)
509  t
510  (t t)
511  z z)
512
513(deftest shared-initialize.6.7
514  (let* ((class (find-class 'shared-init-class-06))
515         (obj (allocate-instance class)))
516    (values
517     (map-slot-boundp* obj '(a b))
518     (eqt obj (shared-initialize obj nil :i2 'z :i2 'w))
519     (map-slot-boundp* obj '(a b))
520     (slot-value obj 'a)
521     (slot-value obj 'b)))
522  (nil nil)
523  t
524  (t t)
525  z z)
526
527
528(deftest shared-initialize.6.8
529  (let* ((class (find-class 'shared-init-class-06))
530         (obj (allocate-instance class)))
531    (values
532     (map-slot-boundp* obj '(a b))
533     (eqt obj (shared-initialize obj nil :i2 'z :i2 'w :foo t))
534     (map-slot-boundp* obj '(a b))
535     (slot-value obj 'a)
536     (slot-value obj 'b)))
537  (nil nil)
538  t
539  (t t)
540  z z)
541
542
543(deftest shared-initialize.6.9
544  (let* ((class (find-class 'shared-init-class-06))
545         (obj (allocate-instance class)))
546    (values
547     (map-slot-boundp* obj '(a b))
548     (eqt obj (shared-initialize obj nil :allow-other-keys nil
549                                 :i2 'z :i2 'w :foo t))
550     (map-slot-boundp* obj '(a b))
551     (slot-value obj 'a)
552     (slot-value obj 'b)))
553  (nil nil)
554  t
555  (t t)
556  z z)
557
558;;; Before methods fill in slots before the default system method
559
560(defclass shared-init-class-07 ()
561  ((a :initform 'x)
562   (b :initform 'y)))
563
564(defmethod shared-initialize :before ((obj shared-init-class-07) slot-names &rest args)
565  (declare (ignore args slot-names))
566  (setf (slot-value obj 'a) 'foo)
567  obj)
568
569(deftest shared-initialize.7.1
570  (let* ((class (find-class 'shared-init-class-07))
571         (obj (allocate-instance class)))
572    (values
573     (map-slot-boundp* obj '(a b))
574     (eqt obj (shared-initialize obj nil))
575     (map-slot-boundp* obj '(a b))
576     (slot-value obj 'a)))
577  (nil nil) t (t nil) foo)
578
579(deftest shared-initialize.7.2
580  (let* ((class (find-class 'shared-init-class-07))
581         (obj (allocate-instance class)))
582    (values
583     (map-slot-boundp* obj '(a b))
584     (eqt obj (shared-initialize obj t))
585     (map-slot-boundp* obj '(a b))
586     (slot-value obj 'a)
587     (slot-value obj 'b)))
588  (nil nil) t (t t) foo y)
589
590;;; :around method tests
591
592(defclass shared-init-class-08 ()
593  ((a :initform 'x)
594   (b :initform 'y)))
595
596(defmethod shared-initialize :around ((obj shared-init-class-08) slot-names
597                                      &rest args &key only &allow-other-keys)
598  (declare (ignore slot-names args))
599  (setf (slot-value obj 'a) 'foo)
600  (if only obj (call-next-method)))
601
602(deftest shared-initialize.8.1
603  (let* ((class (find-class 'shared-init-class-08))
604         (obj (allocate-instance class)))
605    (values
606     (map-slot-boundp* obj '(a b))
607     (eqt obj (shared-initialize obj nil))
608     (map-slot-boundp* obj '(a b))
609     (slot-value obj 'a)))
610  (nil nil)
611  t
612  (t nil)
613  foo)
614
615(deftest shared-initialize.8.2
616  (let* ((class (find-class 'shared-init-class-08))
617         (obj (allocate-instance class)))
618    (values
619     (map-slot-boundp* obj '(a b))
620     (eqt obj (shared-initialize obj t))
621     (map-slot-boundp* obj '(a b))
622     (slot-value obj 'a)
623     (slot-value obj 'b)))
624  (nil nil)
625  t
626  (t t)
627  foo y)
628
629(deftest shared-initialize.8.3
630  (let* ((class (find-class 'shared-init-class-08))
631         (obj (allocate-instance class)))
632    (values
633     (map-slot-boundp* obj '(a b))
634     (eqt obj (shared-initialize obj t :only t))
635     (map-slot-boundp* obj '(a b))
636     (slot-value obj 'a)))
637  (nil nil)
638  t
639  (t nil)
640  foo)
641
642;;;
643
644(defclass shared-init-class-09 ()
645  ((a :allocation :class :initform 'x)
646   (b :initform 'y)))
647
648(deftest shared-initialize.9.1
649  (let* ((class (find-class 'shared-init-class-09))
650         (obj (allocate-instance class)))
651    (slot-makunbound obj 'a)
652    (values
653     (map-slot-boundp* obj '(a b))
654     (eqt obj (shared-initialize obj '(b)))
655     (map-slot-boundp* obj '(a b))
656     (slot-value obj 'b)))
657  (nil nil)
658  t
659  (nil t)
660  y)
661
662;;; Order of evaluation tests
663
664(deftest shared-initialize.order.1
665  (let ((obj (allocate-instance (find-class 'shared-init-class-01)))
666        (i 0) x r y z w q)
667    (values
668     (eqt obj
669          (shared-initialize (progn (setf x (incf i)) obj)
670                             (progn (setf r (incf i)) nil)
671                             :b (setf y (incf i))
672                             :a (setf z (incf i))
673                             :b (setf w (incf i))
674                             :c (setf q (incf i))))
675     (map-slot-value obj '(a b c))
676     i x r y z w q))
677  t (4 3 6)
678  6 1 2 3 4 5 6)
679
680;;; Error tests
681
682(deftest shared-initialize.error.1
683  (signals-error (shared-initialize) program-error)
684  t)
685
686(deftest shared-initialize.error.2
687  (signals-error (let ((obj (allocate-instance
688                              (find-class 'shared-init-class-01))))
689                    (shared-initialize obj))
690                 program-error)
691  t)
692
693(deftest shared-initialize.error.3
694  (signals-error (let ((obj (allocate-instance
695                              (find-class 'shared-init-class-01))))
696                    (shared-initialize obj nil :a))
697                 program-error)
698  t)
699
700(deftest shared-initialize.error.4
701  (signals-error (let ((obj (allocate-instance
702                              (find-class 'shared-init-class-01))))
703                    (shared-initialize obj nil '(a b c) nil))
704                 program-error)
705  t)
Note: See TracBrowser for help on using the repository browser.