3 -- Grant of Unlimited Rights
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.
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.
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)).
36 -- 30 JUL 2001 PHL Initial version.
37 -- 5 DEC 2001 RLB Reformatted for ACATS.
48 Input_Output_Error
: exception;
50 type Int
is range 1 .. 1000;
51 type Str
is array (Int
range <>) of Character;
53 procedure Read
(Stream
: access Root_Stream_Type
'Class;
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);
59 for Int
'Read use Read
;
60 for Int
'Write use Write
;
61 for Int
'Input use Input
;
62 for Int
'Output use Output
;
65 type Parent
(D1
, D2
: Int
; B
: Boolean) is tagged
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
);
81 for Parent
'Read use Read
;
82 for Parent
'Write use Write
;
83 for Parent
'Input use Input
;
84 for Parent
'Output use Output
;
88 (Stream
: access Root_Stream_Type
'Class; Item
: out Int
) is
90 Integer'Read (Stream
, Integer (Item
));
93 procedure Actual_Write
94 (Stream
: access Root_Stream_Type
'Class; Item
: Int
) is
96 Integer'Write (Stream
, Integer (Item
));
99 function Actual_Input
(Stream
: access Root_Stream_Type
'Class) return Int
is
101 return Int
(Integer'Input (Stream
));
104 procedure Actual_Output
105 (Stream
: access Root_Stream_Type
'Class; Item
: Int
) is
107 Integer'Output (Stream
, Integer (Item
));
111 procedure Actual_Read
112 (Stream
: access Root_Stream_Type
'Class; Item
: out Parent
) is
118 Float'Read (Stream
, Item
.C2
);
120 Str
'Read (Stream
, Item
.S
);
123 procedure Actual_Write
124 (Stream
: access Root_Stream_Type
'Class; Item
: Parent
) is
128 null; -- Don't write C1
130 Float'Write (Stream
, Item
.C2
);
132 Str
'Write (Stream
, Item
.S
);
135 function Actual_Input
136 (Stream
: access Root_Stream_Type
'Class) return Parent
is
137 X
: Parent
(1, 1, True);
139 raise Input_Output_Error
;
143 procedure Actual_Output
144 (Stream
: access Root_Stream_Type
'Class; Item
: Parent
) is
146 raise Input_Output_Error
;
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
);
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
);
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
;
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
;
180 type Derived1
is new Parent
with
185 type Derived2
(D
: Int
) is new Parent
(D1
=> D
,
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");
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,
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));
217 X1
.S
:= Str
(Ident_Str
("bcde"));
218 X1
.C2
:= Float (Ident_Int
(4));
219 X1
.C3
:= Int
(Ident_Int
(99));
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");
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");
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");
236 if Parent_Ops
.Get_Counts
/=
237 (Read
=> 1, Write
=> 1, Input
=> 0, Output
=> 0) then
238 Failed
("Didn't call inherited Read - 1");
244 S
=> Str
(Ident_Str
("bcde")),
245 C2
=> Float (Ident_Int
(4)),
246 C3
=> Int
(Ident_Int
(99))) then
248 ("Inherited Read and Write are not inverses of each other - 1");
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");
257 if Parent_Ops
.Get_Counts
/=
258 (Read
=> 1, Write
=> 2, Input
=> 0, Output
=> 0) then
259 Failed
("Didn't call inherited Write - 2");
262 when Input_Output_Error
=>
263 Failed
("Did call inherited Output - 2");
268 Y2
: Derived1
:= Derived1
'Input (S
'Access);
270 if Int_Ops
.Get_Counts
/=
271 (Read
=> 4, Write
=> 4, Input
=> 0, Output
=> 0) then
272 Failed
("Error reading extension components - 2");
274 if Parent_Ops
.Get_Counts
/=
275 (Read
=> 2, Write
=> 2, Input
=> 0, Output
=> 0) then
276 Failed
("Didn't call inherited Read - 2");
281 S
=> Str
(Ident_Str
("3456")),
283 C3
=> Int
(Ident_Int
(88))) then
285 ("Input and Output are not inverses of each other - 2");
289 when Input_Output_Error
=>
290 Failed
("Did call inherited Input - 2");
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)));
305 X1
.S
:= Str
(Ident_Str
("g"));
306 X1
.C1
:= Ident_Int
(4);
307 X1
.C3
:= Int
(Ident_Int
(666));
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");
314 if Parent_Ops
.Get_Counts
/=
315 (Read
=> 2, Write
=> 3, Input
=> 0, Output
=> 0) then
316 Failed
("Didn't call inherited Write - 3");
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");
324 if Parent_Ops
.Get_Counts
/=
325 (Read
=> 3, Write
=> 3, Input
=> 0, Output
=> 0) then
326 Failed
("Didn't call inherited Read - 3");
330 S
=> Str
(Ident_Str
("g")),
332 C3
=> Int
(Ident_Int
(666))) then
333 Failed
("Read and Write are not inverses of each other - 3");
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");
342 if Parent_Ops
.Get_Counts
/=
343 (Read
=> 3, Write
=> 4, Input
=> 0, Output
=> 0) then
344 Failed
("Didn't call inherited Write - 4");
347 when Input_Output_Error
=>
348 Failed
("Did call inherited Output - 4");
353 Y2
: Derived2
:= Derived2
'Input (S
'Access);
355 if Int_Ops
.Get_Counts
/=
356 (Read
=> 7, Write
=> 7, Input
=> 0, Output
=> 0) then
357 Failed
("Error reading extension components - 4");
359 if Parent_Ops
.Get_Counts
/=
360 (Read
=> 4, Write
=> 4, Input
=> 0, Output
=> 0) then
361 Failed
("Didn't call inherited Read - 4");
364 S
=> Str
(Ident_Str
("8")),
366 C3
=> Int
(Ident_Int
(77))) then
368 ("Input and Output are not inverses of each other - 4");
372 when Input_Output_Error
=>
373 Failed
("Did call inherited Input - 4");