Mercurial > hg > CbC > CbC_gcc
comparison gcc/testsuite/ada/acats/tests/c4/c48006b.ada @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
1 -- C48006B.ADA | |
2 | |
3 -- Grant of Unlimited Rights | |
4 -- | |
5 -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, | |
6 -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained | |
7 -- unlimited rights in the software and documentation contained herein. | |
8 -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making | |
9 -- this public release, the Government intends to confer upon all | |
10 -- recipients unlimited rights equal to those held by the Government. | |
11 -- These rights include rights to use, duplicate, release or disclose the | |
12 -- released technical data and computer software in whole or in part, in | |
13 -- any manner and for any purpose whatsoever, and to have or permit others | |
14 -- to do so. | |
15 -- | |
16 -- DISCLAIMER | |
17 -- | |
18 -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR | |
19 -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED | |
20 -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE | |
21 -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE | |
22 -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A | |
23 -- PARTICULAR PURPOSE OF SAID MATERIAL. | |
24 --* | |
25 -- CHECK THAT AN ALLOCATOR OF THE FORM "NEW T'(X)" ALLOCATES A NEW | |
26 -- OBJECT EACH TIME IT IS EXECUTED AND THAT IF T IS A RECORD, ARRAY, OR | |
27 -- PRIVATE TYPE (CONSTRAINED OR UNCONSTRAINED), THE ALLOCATED OBJECT HAS | |
28 -- THE VALUE OF (X). | |
29 | |
30 -- RM 01/14/80 | |
31 -- RM 01/O1/82 | |
32 -- SPS 10/27/82 | |
33 -- EG 07/05/84 | |
34 -- JBG 11/08/85 AVOID CONFLICT WITH AI-7 OR AI-275 | |
35 | |
36 WITH REPORT; | |
37 | |
38 PROCEDURE C48006B IS | |
39 | |
40 USE REPORT ; | |
41 | |
42 BEGIN | |
43 | |
44 TEST("C48006B","CHECK THAT THE FORM 'NEW T'(X)' " & | |
45 "ALLOCATES A NEW OBJECT " & | |
46 "AND THAT IF T IS A RECORD, ARRAY, OR PRIVATE " & | |
47 "TYPE, THE ALLOCATED OBJECT HAS THE VALUE (X)"); | |
48 | |
49 -- RECORD OR ARRAY TYPE (CONSTRAINED OR UNCONSTRAINED) | |
50 | |
51 DECLARE | |
52 | |
53 TYPE TB0( A , B : INTEGER ) IS | |
54 RECORD | |
55 C : INTEGER := 7 ; | |
56 END RECORD; | |
57 SUBTYPE TB IS TB0( 2 , 3 ); | |
58 TYPE ATB IS ACCESS TB ; | |
59 TYPE ATB0 IS ACCESS TB0 ; | |
60 VB1 , VB2 : ATB ; | |
61 VB01 , VB02 : ATB0 ; | |
62 | |
63 TYPE ARR0 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ; | |
64 SUBTYPE ARR IS ARR0( 1..4 ); | |
65 TYPE A_ARR IS ACCESS ARR ; | |
66 TYPE A_ARR0 IS ACCESS ARR0 ; | |
67 VARR1 , VARR2 : A_ARR ; | |
68 VARR01 , VARR02 : A_ARR0 ; | |
69 | |
70 BEGIN | |
71 | |
72 VB1 := NEW TB'( 2 , 3 , 5 ); | |
73 IF ( VB1.A /=IDENT_INT( 2) OR | |
74 VB1.B /=IDENT_INT( 3) OR | |
75 VB1.C /=IDENT_INT( 5) ) | |
76 THEN FAILED( "WRONG VALUES - B1 1" ); | |
77 END IF; | |
78 | |
79 VB2 := NEW TB'( IDENT_INT(2), IDENT_INT(3), IDENT_INT(6)); | |
80 IF ( VB2.A /= 2 OR | |
81 VB2.B /= 3 OR | |
82 VB2.C /= 6 OR | |
83 VB1.A /= 2 OR | |
84 VB1.B /= 3 OR | |
85 VB1.C /= 5 ) | |
86 THEN FAILED( "WRONG VALUES - B1 2" ); | |
87 END IF; | |
88 | |
89 VB01 := NEW TB0'( 1 , 2 , 3 ); | |
90 IF ( VB01.A /=IDENT_INT( 1) OR | |
91 VB01.B /=IDENT_INT( 2) OR | |
92 VB01.C /=IDENT_INT( 3) ) | |
93 THEN FAILED( "WRONG VALUES - B2 1" ); | |
94 END IF; | |
95 | |
96 VB02 := NEW TB0'( IDENT_INT(4) , IDENT_INT(5) , | |
97 IDENT_INT(6) ); | |
98 IF ( VB02.A /=IDENT_INT( 4) OR | |
99 VB02.B /=IDENT_INT( 5) OR | |
100 VB02.C /=IDENT_INT( 6) OR | |
101 VB01.A /=IDENT_INT( 1) OR | |
102 VB01.B /=IDENT_INT( 2) OR | |
103 VB01.C /=IDENT_INT( 3) ) | |
104 THEN FAILED( "WRONG VALUES - B2 2" ); | |
105 END IF; | |
106 | |
107 VARR1 := NEW ARR'( 5 , 6 , 7 , 8 ); | |
108 IF ( VARR1(1) /=IDENT_INT( 5) OR | |
109 VARR1(2) /=IDENT_INT( 6) OR | |
110 VARR1(3) /=IDENT_INT( 7) OR | |
111 VARR1(4) /=IDENT_INT( 8) ) | |
112 THEN FAILED( "WRONG VALUES - B3 1" ); | |
113 END IF ; | |
114 | |
115 VARR2 := NEW ARR'( IDENT_INT(1) , IDENT_INT(2) , IDENT_INT(3), | |
116 IDENT_INT(4) ); | |
117 IF ( VARR2(1) /= 1 OR | |
118 VARR2(2) /= 2 OR | |
119 VARR2(3) /= 3 OR | |
120 VARR2(4) /= 4 OR | |
121 VARR1(1) /= 5 OR | |
122 VARR1(2) /= 6 OR | |
123 VARR1(3) /= 7 OR | |
124 VARR1(4) /= 8 ) | |
125 THEN FAILED( "WRONG VALUES - B3 2" ); | |
126 END IF ; | |
127 | |
128 VARR01 := NEW ARR0'( 11 , 12 , 13 ); | |
129 IF ( VARR01(INTEGER'FIRST) /= IDENT_INT(11) OR | |
130 VARR01(INTEGER'FIRST + 1) /= IDENT_INT(12) OR | |
131 VARR01(INTEGER'FIRST + 2) /= IDENT_INT(13) ) | |
132 THEN FAILED( "WRONG VALUES - B4 1" ); | |
133 END IF ; | |
134 IF ( VARR01.ALL'FIRST /= IDENT_INT( INTEGER'FIRST ) OR | |
135 VARR01.ALL'LAST /= IDENT_INT( INTEGER'FIRST + 2 ) ) | |
136 THEN FAILED( "WRONG VALUES - B4 2" ); | |
137 END IF ; | |
138 | |
139 VARR02 := NEW ARR0'( 1 => IDENT_INT(14) , 2 => IDENT_INT(15)); | |
140 IF ( VARR02(1) /= 14 OR | |
141 VARR02(2) /= 15 OR | |
142 VARR01(INTEGER'FIRST) /= 11 OR | |
143 VARR01(INTEGER'FIRST + 1) /= 12 OR | |
144 VARR01(INTEGER'FIRST + 2) /= 13 ) | |
145 THEN FAILED( "WRONG VALUES - B4 3" ); | |
146 END IF ; | |
147 | |
148 END ; | |
149 | |
150 -- PRIVATE TYPE (CONSTRAINED OR UNCONSTRAINED) | |
151 | |
152 DECLARE | |
153 | |
154 PACKAGE P IS | |
155 TYPE UP(A, B : INTEGER) IS PRIVATE; | |
156 -- SUBTYPE CP IS UP(1, 2); | |
157 -- TYPE A_CP IS ACCESS CP; | |
158 TYPE A_UP IS ACCESS UP; | |
159 CONS1_UP : CONSTANT UP; | |
160 CONS2_UP : CONSTANT UP; | |
161 CONS3_UP : CONSTANT UP; | |
162 CONS4_UP : CONSTANT UP; | |
163 -- PROCEDURE CHECK1 (X : A_CP); | |
164 -- PROCEDURE CHECK2 (X, Y : A_CP); | |
165 PROCEDURE CHECK3 (X : A_UP); | |
166 PROCEDURE CHECK4 (X, Y : A_UP); | |
167 PRIVATE | |
168 TYPE UP(A, B : INTEGER) IS | |
169 RECORD | |
170 C : INTEGER; | |
171 END RECORD; | |
172 CONS1_UP : CONSTANT UP := (1, 2, 3); | |
173 CONS2_UP : CONSTANT UP := (IDENT_INT(1), IDENT_INT(2), | |
174 IDENT_INT(4)); | |
175 CONS3_UP : CONSTANT UP := (7, 8, 9); | |
176 CONS4_UP : CONSTANT UP := (IDENT_INT(10), IDENT_INT(11), | |
177 IDENT_INT(12)); | |
178 END P; | |
179 | |
180 USE P; | |
181 | |
182 -- V_A_CP1, V_A_CP2 : A_CP; | |
183 V_A_UP1, V_A_UP2 : A_UP; | |
184 | |
185 PACKAGE BODY P IS | |
186 -- PROCEDURE CHECK1 (X : A_CP) IS | |
187 -- BEGIN | |
188 -- IF (X.A /= IDENT_INT(1) OR | |
189 -- X.B /= IDENT_INT(2) OR | |
190 -- X.C /= IDENT_INT(3)) THEN | |
191 -- FAILED ("WRONG VALUES - CP1"); | |
192 -- END IF; | |
193 -- END CHECK1; | |
194 -- PROCEDURE CHECK2 (X, Y : A_CP) IS | |
195 -- BEGIN | |
196 -- IF (X.A /= 1 OR X.B /= 2 OR X.C /= 3 OR | |
197 -- Y.A /= 1 OR Y.B /= 2 OR Y.C /= 4) THEN | |
198 -- FAILED ("WRONG VALUES - CP2"); | |
199 -- END IF; | |
200 -- END CHECK2; | |
201 PROCEDURE CHECK3 (X : A_UP) IS | |
202 BEGIN | |
203 IF (X.A /= IDENT_INT(7) OR | |
204 X.B /= IDENT_INT(8) OR | |
205 X.C /= IDENT_INT(9)) THEN | |
206 FAILED ("WRONG VALUES - UP1"); | |
207 END IF; | |
208 END CHECK3; | |
209 PROCEDURE CHECK4 (X, Y : A_UP) IS | |
210 BEGIN | |
211 IF (X.A /= 7 OR X.B /= 8 OR X.C /= 9 OR | |
212 Y.A /= 10 OR Y.B /= 11 OR Y.C /= 12) THEN | |
213 FAILED ("WRONG VALUES - UP2"); | |
214 END IF; | |
215 END CHECK4; | |
216 END P; | |
217 | |
218 BEGIN | |
219 | |
220 -- V_A_CP1 := NEW CP'(CONS1_UP); | |
221 -- CHECK1(V_A_CP1); | |
222 | |
223 -- V_A_CP2 := NEW CP'(CONS2_UP); | |
224 -- CHECK2(V_A_CP1, V_A_CP2); | |
225 | |
226 V_A_UP1 := NEW P.UP'(CONS3_UP); | |
227 CHECK3(V_A_UP1); | |
228 | |
229 V_A_UP2 := NEW P.UP'(CONS4_UP); | |
230 CHECK4(V_A_UP1, V_A_UP2); | |
231 | |
232 END; | |
233 | |
234 RESULT; | |
235 | |
236 END C48006B; |