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