Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c4/c460004.a @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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 -- C460004.A
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 --
26 -- OBJECTIVE:
27 -- Check that if the operand type of a type conversion is class-wide,
28 -- Constraint_Error is raised if the tag of the operand does not
29 -- identify a specific type that is covered by or descended from the
30 -- target type.
31 --
32 -- TEST DESCRIPTION:
33 -- View conversions of class-wide operands to specific types are
34 -- placed on the right and left sides of assignment statements, and
35 -- conversions of class-wide operands to class-wide types are used
36 -- as actual parameters to dispatching operations. In all cases, a
37 -- check is made that Constraint_Error is raised if the tag of the
38 -- operand does not identify a specific type covered by or descended
39 -- from the target type, and not raised otherwise.
40 --
41 -- A specific type is descended from itself and from those types it is
42 -- directly or indirectly derived from. A specific type is covered by
43 -- itself and each class-wide type to whose class it belongs.
44 --
45 -- A class-wide type T'Class is descended from T and those types which
46 -- T is descended from. A class-wide type is covered by each class-wide
47 -- type to whose class it belongs.
48 --
49 --
50 -- CHANGE HISTORY:
51 -- 19 Jul 95 SAIC Initial prerelease version.
52 -- 18 Apr 96 SAIC ACVC 2.1: Added a check for correct tag.
53 --
54 --!
55 package C460004_0 is
56
57 type Tag_Type is tagged record
58 C1 : Natural;
59 end record;
60
61 procedure Proc (X : in out Tag_Type);
62
63
64 type DTag_Type is new Tag_Type with record
65 C2 : String (1 .. 5);
66 end record;
67
68 procedure Proc (X : in out DTag_Type);
69
70
71 type DDTag_Type is new DTag_Type with record
72 C3 : String (1 .. 5);
73 end record;
74
75 procedure Proc (X : in out DDTag_Type);
76
77 procedure NewProc (X : in DDTag_Type);
78
79 function CWFunc (X : Tag_Type'Class) return Tag_Type'Class;
80
81 end C460004_0;
82
83
84 --==================================================================--
85
86 with Report;
87 package body C460004_0 is
88
89 procedure Proc (X : in out Tag_Type) is
90 begin
91 X.C1 := 25;
92 end Proc;
93
94 -----------------------------------------
95 procedure Proc (X : in out DTag_Type) is
96 begin
97 Proc ( Tag_Type(X) );
98 X.C2 := "Earth";
99 end Proc;
100
101 -----------------------------------------
102 procedure Proc (X : in out DDTag_Type) is
103 begin
104 Proc ( DTag_Type(X) );
105 X.C3 := "Orbit";
106 end Proc;
107
108 -----------------------------------------
109 procedure NewProc (X : in DDTag_Type) is
110 Y : DDTag_Type := X;
111 begin
112 Proc (Y);
113 exception
114 when others =>
115 Report.Failed ("Unexpected exception in NewProc");
116 end NewProc;
117
118 -----------------------------------------
119 function CWFunc (X : Tag_Type'Class) return Tag_Type'Class is
120 Y : Tag_Type'Class := X;
121 begin
122 Proc (Y);
123 return Y;
124 end CWFunc;
125
126 end C460004_0;
127
128
129 --==================================================================--
130
131
132 with C460004_0;
133 use C460004_0;
134
135 with Report;
136 procedure C460004 is
137
138 Tag_Type_Init : constant Tag_Type := (C1 => 0);
139 DTag_Type_Init : constant DTag_Type := (Tag_Type_Init with "Hello");
140 DDTag_Type_Init : constant DDTag_Type := (DTag_Type_Init with "World");
141
142 Tag_Type_Value : constant Tag_Type := (C1 => 25);
143 DTag_Type_Value : constant DTag_Type := (Tag_Type_Value with "Earth");
144 DDTag_Type_Value : constant DDTag_Type := (DTag_Type_Value with "Orbit");
145
146 begin
147
148 Report.Test ("C460004", "Check that for a view conversion of a " &
149 "class-wide operand, Constraint_Error is raised if the " &
150 "tag of the operand does not identify a specific type " &
151 "covered by or descended from the target type");
152
153 --
154 -- View conversion to specific type:
155 --
156
157 declare
158 procedure CW_Proc (P : Tag_Type'Class) is
159 Target : Tag_Type := Tag_Type_Init;
160 begin
161 Target := Tag_Type(P);
162 if (Target /= Tag_Type_Value) then
163 Report.Failed ("Target has wrong value: #01");
164 end if;
165 exception
166 when Constraint_Error =>
167 Report.Failed ("Constraint_Error raised: #01");
168 when others =>
169 Report.Failed ("Unexpected exception: #01");
170 end CW_Proc;
171
172 begin
173 CW_Proc (DDTag_Type_Value);
174 end;
175
176 ----------------------------------------------------------------------
177
178 declare
179 Target : DTag_Type := DTag_Type_Init;
180 begin
181 Target := DTag_Type(CWFunc(DDTag_Type_Value));
182 if (Target /= DTag_Type_Value) then
183 Report.Failed ("Target has wrong value: #02");
184 end if;
185 exception
186 when Constraint_Error => Report.Failed ("Constraint_Error raised: #02");
187 when others => Report.Failed ("Unexpected exception: #02");
188 end;
189
190 ----------------------------------------------------------------------
191
192 declare
193 Target : DDTag_Type;
194 begin
195 Target := DDTag_Type(CWFunc(Tag_Type_Value));
196 -- CWFunc returns a Tag_Type; its tag is preserved through
197 -- the view conversion. Constraint_Error should be raised.
198
199 Report.Failed ("Constraint_Error not raised: #03");
200
201 exception
202 when Constraint_Error => null; -- expected exception
203 when others => Report.Failed ("Unexpected exception: #03");
204 end;
205
206 ----------------------------------------------------------------------
207
208 declare
209 procedure CW_Proc (P : Tag_Type'Class) is
210 begin
211 NewProc (DDTag_Type(P));
212 Report.Failed ("Constraint_Error not raised: #04");
213
214 exception
215 when Constraint_Error => null; -- expected exception
216 when others => Report.Failed ("Unexpected exception: #04");
217 end CW_Proc;
218
219 begin
220 CW_Proc (DTag_Type_Value);
221 end;
222
223 ----------------------------------------------------------------------
224
225 declare
226 procedure CW_Proc (P : Tag_Type'Class) is
227 Target : DDTag_Type := DDTag_Type_Init;
228 begin
229 Target := DDTag_Type(P);
230 if (Target /= DDTag_Type_Value) then
231 Report.Failed ("Target has wrong value: #05");
232 end if;
233
234 exception
235 when Constraint_Error =>
236 Report.Failed ("Constraint_Error raised: #05");
237 when others
238 => Report.Failed ("Unexpected exception: #05");
239 end CW_Proc;
240
241 begin
242 CW_Proc (DDTag_Type_Value);
243 end;
244
245
246 --
247 -- View conversion to class-wide type:
248 --
249
250 declare
251 procedure CW_Proc (P : Tag_Type'Class) is
252 Operand : Tag_Type'Class := P;
253 begin
254 Proc( DTag_Type'Class(Operand) );
255 Report.Failed ("Constraint_Error not raised: #06");
256
257 exception
258 when Constraint_Error => null; -- expected exception
259 when others => Report.Failed ("Unexpected exception: #06");
260 end CW_Proc;
261
262 begin
263 CW_Proc (Tag_Type_Init);
264 end;
265
266 ----------------------------------------------------------------------
267
268 declare
269 procedure CW_Proc (P : Tag_Type'Class) is
270 Operand : Tag_Type'Class := P;
271 begin
272 Proc( DDTag_Type'Class(Operand) );
273 Report.Failed ("Constraint_Error not raised: #07");
274
275 exception
276 when Constraint_Error => null; -- expected exception
277 when others => Report.Failed ("Unexpected exception: #07");
278 end CW_Proc;
279
280 begin
281 CW_Proc (Tag_Type_Init);
282 end;
283
284 ----------------------------------------------------------------------
285
286 declare
287 procedure CW_Proc (P : Tag_Type'Class) is
288 Operand : Tag_Type'Class := P;
289 begin
290 Proc( DTag_Type'Class(Operand) );
291 if Operand not in DTag_Type then
292 Report.Failed ("Operand has wrong tag: #08");
293 elsif (Operand /= Tag_Type'Class (DTag_Type_Value)) then
294 Report.Failed ("Operand has wrong value: #08");
295 end if;
296
297 exception
298 when Constraint_Error =>
299 Report.Failed ("Constraint_Error raised: #08");
300 when others =>
301 Report.Failed ("Unexpected exception: #08");
302 end CW_Proc;
303
304 begin
305 CW_Proc (DTag_Type_Init);
306 end;
307
308 ----------------------------------------------------------------------
309
310 declare
311 procedure CW_Proc (P : Tag_Type'Class) is
312 Operand : Tag_Type'Class := P;
313 begin
314 Proc( Tag_Type'Class(Operand) );
315 if Operand not in DDTag_Type then
316 Report.Failed ("Operand has wrong tag: #09");
317 elsif (Operand /= Tag_Type'Class (DDTag_Type_Value)) then
318 Report.Failed ("Operand has wrong value: #09");
319 end if;
320
321 exception
322 when Constraint_Error =>
323 Report.Failed ("Constraint_Error raised: #09");
324 when others =>
325 Report.Failed ("Unexpected exception: #09");
326 end CW_Proc;
327
328 begin
329 CW_Proc (DDTag_Type_Init);
330 end;
331
332
333 Report.Result;
334
335 end C460004;