source: trunk/source/tests/ansi-tests/reinitialize-instance.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: 3.4 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Mon Apr 28 21:56:47 2003
4;;;; Contains: Tests for REINITIALIZE-INSTANCE
5
6(in-package :cl-test)
7
8;;; Many of the classes used here are defined in defclass-??.lsp
9
10(deftest reinitialize-instance.1
11  (let* ((obj (make-instance 'class-01))
12         (obj2 (reinitialize-instance obj)))
13    (values
14     (eqt obj obj2)
15     (map-slot-boundp* obj '(s1 s2 s3))))
16  t (nil nil nil))
17
18
19(deftest reinitialize-instance.2
20  (let* ((obj (make-instance 'class-01))
21         (obj2 (reinitialize-instance obj :allow-other-keys nil)))
22    (values
23     (eqt obj obj2)
24     (map-slot-boundp* obj '(s1 s2 s3))))
25  t (nil nil nil))
26
27(deftest reinitialize-instance.3
28  (let* ((obj (make-instance 'class-01))
29         (obj2 (reinitialize-instance obj :allow-other-keys t)))
30    (values
31     (eqt obj obj2)
32     (map-slot-boundp* obj '(s1 s2 s3))))
33  t (nil nil nil))
34
35(deftest reinitialize-instance.4
36  (let* ((obj (make-instance 'class-01))
37         (obj2 (reinitialize-instance obj :allow-other-keys t
38                                      :allow-other-keys nil)))
39    (values
40     (eqt obj obj2)
41     (map-slot-boundp* obj '(s1 s2 s3))))
42  t (nil nil nil))
43
44(deftest reinitialize-instance.5
45  (let* ((obj (make-instance 'class-07))
46         (obj2 (reinitialize-instance obj :s1a 'a :s2 'b :s1a 'bad
47                                      :s2 'bad2  :s1b 'bad3)))
48    (values
49     (eqt obj obj2)
50     (map-slot-value obj '(s1 s2))))
51  t (a b))
52
53(deftest reinitialize-instance.6
54  (let* ((obj (make-instance 'class-07 :s1a 'a))
55         (obj2 (reinitialize-instance obj :s1b 'b)))
56    (values
57     (eqt obj obj2)
58     (slot-value obj 's1)
59     (slot-boundp* obj 's2)))
60  t b nil)
61
62(deftest reinitialize-instance.7
63  (let* ((obj (make-instance 'class-07 :s1a 'a))
64         (obj2 (reinitialize-instance obj :s2 'b)))
65    (values
66     (eqt obj obj2)
67     (slot-value obj 's1)
68     (slot-value obj 's2)))
69  t a b)
70
71
72;;; Tests of user-defined methods
73
74(defclass reinit-class-01 ()
75  ((a :initarg :a) (b :initarg :b)))
76
77(defmethod reinitialize-instance :after ((instance reinit-class-01)
78                                         &rest initargs
79                                         &key (x nil x-p))
80  (declare (ignore initargs))
81  (when x-p (setf (slot-value instance 'a) x))
82  instance)
83
84(deftest reinitialize-instance.8
85  (let* ((obj (make-instance 'reinit-class-01))
86         (obj2 (reinitialize-instance obj :a 1 :b 3)))
87    (values
88     (eqt obj obj2)
89     (map-slot-value obj2 '(a b))))
90  t (1 3))
91
92(deftest reinitialize-instance.9
93  (let* ((obj (make-instance 'reinit-class-01 :a 10 :b 20))
94         (obj2 (reinitialize-instance obj :x 3)))
95    (values
96     (eqt obj obj2)
97     (map-slot-value obj2 '(a b))))
98  t (3 20))
99
100(deftest reinitialize-instance.10
101  (let* ((obj (make-instance 'reinit-class-01 :a 10 :b 20))
102         (obj2 (reinitialize-instance obj :x 3 :x 100)))
103    (values
104     (eqt obj obj2)
105     (map-slot-value obj2 '(a b))))
106  t (3 20))
107
108;;; Order of evaluation tests
109
110(deftest reinitialize-instance.order.1
111  (let* ((obj (make-instance 'reinit-class-01))
112         (i 0) x y z w
113         (obj2 (reinitialize-instance
114                (progn (setf x (incf i)) obj)
115                :b (setf y (incf i))
116                :a (setf z (incf i))
117                :b (setf w (incf i)))))
118    (values
119     (eqt obj obj2)
120     (map-slot-value obj2 '(a b))
121     i x y z w))
122  t (3 2) 4 1 2 3 4)
123
124;;; Error cases
125
126(deftest reinitialize-instance.error.1
127  (handler-case
128   (eval '(reinitialize-instance (make-instance 'class-01) :garbage t))
129   (error () :good))
130  :good)
131
132(deftest reinitialize-instance.error.2
133  (signals-error (reinitialize-instance) program-error)
134  t)
Note: See TracBrowser for help on using the repository browser.