|
111
|
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;
|
