Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/cd/cdd2a01.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 -- CDD2A01.A
2 --
3 -- Grant of Unlimited Rights
4 --
5 -- The Ada Conformity Assessment Authority (ACAA) holds unlimited
6 -- rights in the software and documentation contained herein. Unlimited
7 -- rights are the same as those granted by the U.S. Government for older
8 -- parts of the Ada Conformity Assessment Test Suite, and are defined
9 -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
10 -- intends to confer upon all recipients unlimited rights equal to those
11 -- held by the ACAA. These rights include rights to use, duplicate,
12 -- release or disclose the released technical data and computer software
13 -- in whole or in part, in any manner and for any purpose whatsoever, and
14 -- to have or permit others 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 the Read and Write attributes for a type extension are created
28 -- from the parent type's attribute (which may be user-defined) and those
29 -- for the extension components. Also check that the default Input and
30 -- Output attributes are used for a type extension, even if the parent
31 -- type's attribute is user-defined. (Defect Report 8652/0040,
32 -- as reflected in Technical Corrigendum 1, penultimate sentence of
33 -- 13.13.2(9/1) and 13.13.2(25/1)).
34 --
35 -- CHANGE HISTORY:
36 -- 30 JUL 2001 PHL Initial version.
37 -- 5 DEC 2001 RLB Reformatted for ACATS.
38 --
39 --!
40 with Ada.Streams;
41 use Ada.Streams;
42 with FDD2A00;
43 use FDD2A00;
44 with Report;
45 use Report;
46 procedure CDD2A01 is
47
48 Input_Output_Error : exception;
49
50 type Int is range 1 .. 1000;
51 type Str is array (Int range <>) of Character;
52
53 procedure Read (Stream : access Root_Stream_Type'Class;
54 Item : out Int'Base);
55 procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base);
56 function Input (Stream : access Root_Stream_Type'Class) return Int'Base;
57 procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base);
58
59 for Int'Read use Read;
60 for Int'Write use Write;
61 for Int'Input use Input;
62 for Int'Output use Output;
63
64
65 type Parent (D1, D2 : Int; B : Boolean) is tagged
66 record
67 S : Str (D1 .. D2);
68 case B is
69 when False =>
70 C1 : Integer;
71 when True =>
72 C2 : Float;
73 end case;
74 end record;
75
76 procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent);
77 procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent);
78 function Input (Stream : access Root_Stream_Type'Class) return Parent;
79 procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent);
80
81 for Parent'Read use Read;
82 for Parent'Write use Write;
83 for Parent'Input use Input;
84 for Parent'Output use Output;
85
86
87 procedure Actual_Read
88 (Stream : access Root_Stream_Type'Class; Item : out Int) is
89 begin
90 Integer'Read (Stream, Integer (Item));
91 end Actual_Read;
92
93 procedure Actual_Write
94 (Stream : access Root_Stream_Type'Class; Item : Int) is
95 begin
96 Integer'Write (Stream, Integer (Item));
97 end Actual_Write;
98
99 function Actual_Input (Stream : access Root_Stream_Type'Class) return Int is
100 begin
101 return Int (Integer'Input (Stream));
102 end Actual_Input;
103
104 procedure Actual_Output
105 (Stream : access Root_Stream_Type'Class; Item : Int) is
106 begin
107 Integer'Output (Stream, Integer (Item));
108 end Actual_Output;
109
110
111 procedure Actual_Read
112 (Stream : access Root_Stream_Type'Class; Item : out Parent) is
113 begin
114 case Item.B is
115 when False =>
116 Item.C1 := 7;
117 when True =>
118 Float'Read (Stream, Item.C2);
119 end case;
120 Str'Read (Stream, Item.S);
121 end Actual_Read;
122
123 procedure Actual_Write
124 (Stream : access Root_Stream_Type'Class; Item : Parent) is
125 begin
126 case Item.B is
127 when False =>
128 null; -- Don't write C1
129 when True =>
130 Float'Write (Stream, Item.C2);
131 end case;
132 Str'Write (Stream, Item.S);
133 end Actual_Write;
134
135 function Actual_Input
136 (Stream : access Root_Stream_Type'Class) return Parent is
137 X : Parent (1, 1, True);
138 begin
139 raise Input_Output_Error;
140 return X;
141 end Actual_Input;
142
143 procedure Actual_Output
144 (Stream : access Root_Stream_Type'Class; Item : Parent) is
145 begin
146 raise Input_Output_Error;
147 end Actual_Output;
148
149 package Int_Ops is new Counting_Stream_Ops (T => Int'Base,
150 Actual_Write => Actual_Write,
151 Actual_Input => Actual_Input,
152 Actual_Read => Actual_Read,
153 Actual_Output => Actual_Output);
154
155 package Parent_Ops is
156 new Counting_Stream_Ops (T => Parent,
157 Actual_Write => Actual_Write,
158 Actual_Input => Actual_Input,
159 Actual_Read => Actual_Read,
160 Actual_Output => Actual_Output);
161
162 procedure Read (Stream : access Root_Stream_Type'Class; Item : out Int'Base)
163 renames Int_Ops.Read;
164 procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base)
165 renames Int_Ops.Write;
166 function Input (Stream : access Root_Stream_Type'Class) return Int'Base
167 renames Int_Ops.Input;
168 procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base)
169 renames Int_Ops.Output;
170
171 procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent)
172 renames Parent_Ops.Read;
173 procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent)
174 renames Parent_Ops.Write;
175 function Input (Stream : access Root_Stream_Type'Class) return Parent
176 renames Parent_Ops.Input;
177 procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent)
178 renames Parent_Ops.Output;
179
180 type Derived1 is new Parent with
181 record
182 C3 : Int;
183 end record;
184
185 type Derived2 (D : Int) is new Parent (D1 => D,
186 D2 => D,
187 B => False) with
188 record
189 C3 : Int;
190 end record;
191
192 begin
193 Test ("CDD2A01",
194 "Check that the Read and Write attributes for a type " &
195 "extension are created from the parent type's " &
196 "attribute (which may be user-defined) and those for the " &
197 "extension components; also check that the default input " &
198 "and output attributes are used for a type extension, even " &
199 "if the parent type's attribute is user-defined");
200
201 Test1:
202 declare
203 S : aliased My_Stream (1000);
204 X1 : Derived1 (D1 => Int (Ident_Int (2)),
205 D2 => Int (Ident_Int (5)),
206 B => Ident_Bool (True));
207 Y1 : Derived1 := (D1 => 3,
208 D2 => 6,
209 B => False,
210 S => Str (Ident_Str ("3456")),
211 C1 => Ident_Int (100),
212 C3 => Int (Ident_Int (88)));
213 X2 : Derived1 (D1 => Int (Ident_Int (2)),
214 D2 => Int (Ident_Int (5)),
215 B => Ident_Bool (True));
216 begin
217 X1.S := Str (Ident_Str ("bcde"));
218 X1.C2 := Float (Ident_Int (4));
219 X1.C3 := Int (Ident_Int (99));
220
221 Derived1'Write (S'Access, X1);
222 if Int_Ops.Get_Counts /=
223 (Read => 0, Write => 1, Input => 0, Output => 0) then
224 Failed ("Error writing extension components - 1");
225 end if;
226 if Parent_Ops.Get_Counts /=
227 (Read => 0, Write => 1, Input => 0, Output => 0) then
228 Failed ("Didn't call parent type's Write - 1");
229 end if;
230
231 Derived1'Read (S'Access, X2);
232 if Int_Ops.Get_Counts /=
233 (Read => 1, Write => 1, Input => 0, Output => 0) then
234 Failed ("Error reading extension components - 1");
235 end if;
236 if Parent_Ops.Get_Counts /=
237 (Read => 1, Write => 1, Input => 0, Output => 0) then
238 Failed ("Didn't call inherited Read - 1");
239 end if;
240
241 if X2 /= (D1 => 2,
242 D2 => 5,
243 B => True,
244 S => Str (Ident_Str ("bcde")),
245 C2 => Float (Ident_Int (4)),
246 C3 => Int (Ident_Int (99))) then
247 Failed
248 ("Inherited Read and Write are not inverses of each other - 1");
249 end if;
250
251 begin
252 Derived1'Output (S'Access, Y1);
253 if Int_Ops.Get_Counts /=
254 (Read => 1, Write => 4, Input => 0, Output => 0) then
255 Failed ("Error writing extension components - 2");
256 end if;
257 if Parent_Ops.Get_Counts /=
258 (Read => 1, Write => 2, Input => 0, Output => 0) then
259 Failed ("Didn't call inherited Write - 2");
260 end if;
261 exception
262 when Input_Output_Error =>
263 Failed ("Did call inherited Output - 2");
264 end;
265
266 begin
267 declare
268 Y2 : Derived1 := Derived1'Input (S'Access);
269 begin
270 if Int_Ops.Get_Counts /=
271 (Read => 4, Write => 4, Input => 0, Output => 0) then
272 Failed ("Error reading extension components - 2");
273 end if;
274 if Parent_Ops.Get_Counts /=
275 (Read => 2, Write => 2, Input => 0, Output => 0) then
276 Failed ("Didn't call inherited Read - 2");
277 end if;
278 if Y2 /= (D1 => 3,
279 D2 => 6,
280 B => False,
281 S => Str (Ident_Str ("3456")),
282 C1 => Ident_Int (7),
283 C3 => Int (Ident_Int (88))) then
284 Failed
285 ("Input and Output are not inverses of each other - 2");
286 end if;
287 end;
288 exception
289 when Input_Output_Error =>
290 Failed ("Did call inherited Input - 2");
291 end;
292
293 end Test1;
294
295 Test2:
296 declare
297 S : aliased My_Stream (1000);
298 X1 : Derived2 (D => Int (Ident_Int (7)));
299 Y1 : Derived2 := (D => 8,
300 S => Str (Ident_Str ("8")),
301 C1 => Ident_Int (200),
302 C3 => Int (Ident_Int (77)));
303 X2 : Derived2 (D => Int (Ident_Int (7)));
304 begin
305 X1.S := Str (Ident_Str ("g"));
306 X1.C1 := Ident_Int (4);
307 X1.C3 := Int (Ident_Int (666));
308
309 Derived2'Write (S'Access, X1);
310 if Int_Ops.Get_Counts /=
311 (Read => 4, Write => 5, Input => 0, Output => 0) then
312 Failed ("Error writing extension components - 3");
313 end if;
314 if Parent_Ops.Get_Counts /=
315 (Read => 2, Write => 3, Input => 0, Output => 0) then
316 Failed ("Didn't call inherited Write - 3");
317 end if;
318
319 Derived2'Read (S'Access, X2);
320 if Int_Ops.Get_Counts /=
321 (Read => 5, Write => 5, Input => 0, Output => 0) then
322 Failed ("Error reading extension components - 3");
323 end if;
324 if Parent_Ops.Get_Counts /=
325 (Read => 3, Write => 3, Input => 0, Output => 0) then
326 Failed ("Didn't call inherited Read - 3");
327 end if;
328
329 if X2 /= (D => 7,
330 S => Str (Ident_Str ("g")),
331 C1 => Ident_Int (7),
332 C3 => Int (Ident_Int (666))) then
333 Failed ("Read and Write are not inverses of each other - 3");
334 end if;
335
336 begin
337 Derived2'Output (S'Access, Y1);
338 if Int_Ops.Get_Counts /=
339 (Read => 5, Write => 7, Input => 0, Output => 0) then
340 Failed ("Error writing extension components - 4");
341 end if;
342 if Parent_Ops.Get_Counts /=
343 (Read => 3, Write => 4, Input => 0, Output => 0) then
344 Failed ("Didn't call inherited Write - 4");
345 end if;
346 exception
347 when Input_Output_Error =>
348 Failed ("Did call inherited Output - 4");
349 end;
350
351 begin
352 declare
353 Y2 : Derived2 := Derived2'Input (S'Access);
354 begin
355 if Int_Ops.Get_Counts /=
356 (Read => 7, Write => 7, Input => 0, Output => 0) then
357 Failed ("Error reading extension components - 4");
358 end if;
359 if Parent_Ops.Get_Counts /=
360 (Read => 4, Write => 4, Input => 0, Output => 0) then
361 Failed ("Didn't call inherited Read - 4");
362 end if;
363 if Y2 /= (D => 8,
364 S => Str (Ident_Str ("8")),
365 C1 => Ident_Int (7),
366 C3 => Int (Ident_Int (77))) then
367 Failed
368 ("Input and Output are not inverses of each other - 4");
369 end if;
370 end;
371 exception
372 when Input_Output_Error =>
373 Failed ("Did call inherited Input - 4");
374 end;
375
376 end Test2;
377
378 Result;
379 end CDD2A01;