Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/cxa/cxacc01.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 -- CXACC01.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 the use of 'Class'Output and 'Class'Input allow stream
28 -- manipulation of objects of non-limited class-wide types.
29 --
30 -- TEST DESCRIPTION:
31 -- This test demonstrates the uses of 'Class'Output and 'Class'Input
32 -- in moving objects of a particular class to and from a stream file.
33 -- A procedure uses a class-wide parameter to move objects of specific
34 -- types in the class to the stream, using the 'Class'Output attribute
35 -- of the root type of the class. A function returns a class-wide object,
36 -- using the 'Class'Input attribute of the root type of the class to
37 -- extract the object from the stream.
38 -- A field-by-field comparison of record objects is performed to validate
39 -- the data read from the stream. Operator precedence rules are used
40 -- in the comparison rather than parentheses.
41 --
42 -- APPLICABILITY CRITERIA:
43 -- This test is applicable to all implementations capable of supporting
44 -- external Stream_IO files.
45 --
46 --
47 -- CHANGE HISTORY:
48 -- 06 Dec 94 SAIC ACVC 2.0
49 -- 14 Nov 95 SAIC Corrected prefix of 'Tag attribute for ACVC 2.0.1.
50 -- 24 Aug 96 SAIC Changed a call to "Create" to "Reset".
51 -- 26 Feb 97 CTA.PWB Allowed for non-support of some IO operations.
52 --!
53
54 with FXACC00, Ada.Streams.Stream_IO, Ada.Tags, Report;
55
56 procedure CXACC01 is
57
58 Order_File : Ada.Streams.Stream_IO.File_Type;
59 Order_Stream : Ada.Streams.Stream_IO.Stream_Access;
60 Order_Filename : constant String :=
61 Report.Legal_File_Name ( Nam => "CXACC01" );
62 Incomplete : exception;
63
64 begin
65
66 Report.Test ("CXACC01", "Check that the use of 'Class'Output " &
67 "and 'Class'Input allow stream manipulation " &
68 "of objects of non-limited class-wide types");
69
70 Test_for_Stream_IO_Support:
71 begin
72
73 -- If an implementation does not support Stream_IO in a particular
74 -- environment, the exception Use_Error or Name_Error will be raised on
75 -- calls to various Stream_IO operations. This block statement
76 -- encloses a call to Create, which should produce an exception in a
77 -- non-supportive environment. These exceptions will be handled to
78 -- produce a Not_Applicable result.
79
80 Ada.Streams.Stream_IO.Create (Order_File,
81 Ada.Streams.Stream_IO.Out_File,
82 Order_Filename);
83
84 exception
85
86 when Ada.Streams.Stream_IO.Use_Error | Ada.Streams.Stream_IO.Name_Error =>
87 Report.Not_Applicable
88 ( "Files not supported - Create as Out_File for Stream_IO" );
89 raise Incomplete;
90
91 end Test_for_Stream_IO_Support;
92
93 Operational_Test_Block:
94 declare
95
96 -- Store tag values associated with objects of tagged types.
97
98 TC_Box_Office_Tag : constant String :=
99 Ada.Tags.External_Tag(FXACC00.Ticket_Request'Tag);
100
101 TC_Summer_Tag : constant String :=
102 Ada.Tags.External_Tag(FXACC00.Subscriber_Request'Tag);
103
104 TC_Mayoral_Tag : constant String :=
105 Ada.Tags.External_Tag(FXACC00.VIP_Request'Tag);
106
107 TC_Late_Tag : constant String :=
108 Ada.Tags.External_Tag(FXACC00.Last_Minute_Request'Tag);
109
110 -- The following procedure will take an object of the Ticket_Request
111 -- class and output it to the stream. Objects of any extended type
112 -- in the class can be output to the stream with this procedure.
113
114 procedure Order_Entry (Order : FXACC00.Ticket_Request'Class) is
115 begin
116 FXACC00.Ticket_Request'Class'Output (Order_Stream, Order);
117 end Order_Entry;
118
119
120 -- The following function will retrieve from the stream an object of
121 -- the Ticket_Request class.
122
123 function Order_Retrieval return FXACC00.Ticket_Request'Class is
124 begin
125 return FXACC00.Ticket_Request'Class'Input (Order_Stream);
126 end Order_Retrieval;
127
128 begin
129
130 Order_Stream := Ada.Streams.Stream_IO.Stream (Order_File);
131
132 -- Store the data objects in the stream.
133 -- Each of the objects is of a different type within the class.
134
135 Order_Entry (FXACC00.Box_Office_Request); -- Object of root type
136 Order_Entry (FXACC00.Summer_Subscription); -- Obj. of extended type
137 Order_Entry (FXACC00.Mayoral_Ticket_Request); -- Obj. of extended type
138 Order_Entry (FXACC00.Late_Request); -- Object of twice
139 -- extended type.
140
141 -- Reset mode of stream to In_File prior to reading data from it.
142 Reset1:
143 begin
144 Ada.Streams.Stream_IO.Reset (Order_File,
145 Ada.Streams.Stream_IO.In_File);
146 exception
147 when Ada.Streams.Stream_IO.Use_Error =>
148 Report.Not_Applicable
149 ( "Reset to In_File not supported for Stream_IO - 1" );
150 raise Incomplete;
151 end Reset1;
152
153 Process_Order_Block:
154 declare
155
156 use FXACC00;
157
158 -- Declare variables of the root type class,
159 -- and initialize them with class-wide objects returned from
160 -- the stream as function result.
161
162 Order_1 : Ticket_Request'Class := Order_Retrieval;
163 Order_2 : Ticket_Request'Class := Order_Retrieval;
164 Order_3 : Ticket_Request'Class := Order_Retrieval;
165 Order_4 : Ticket_Request'Class := Order_Retrieval;
166
167 -- Declare objects of the specific types from within the class
168 -- that correspond to the types of the data written to the
169 -- stream. Perform a type conversion on the class-wide objects.
170
171 Ticket_Order : Ticket_Request :=
172 Ticket_Request(Order_1);
173 Subscriber_Order : Subscriber_Request :=
174 Subscriber_Request(Order_2);
175 VIP_Order : VIP_Request :=
176 VIP_Request(Order_3);
177 Last_Minute_Order : Last_Minute_Request :=
178 Last_Minute_Request(Order_4);
179
180 begin
181
182 -- Perform a field-by-field comparison of all the class-wide
183 -- objects input from the stream with specific type objects
184 -- originally written to the stream.
185
186 if Ticket_Order.Location /=
187 Box_Office_Request.Location or
188 Ticket_Order.Number_Of_Tickets /=
189 Box_Office_Request.Number_Of_Tickets
190 then
191 Report.Failed ("Ticket_Request object validation failure");
192 end if;
193
194 if Subscriber_Order.Location /=
195 Summer_Subscription.Location or
196 Subscriber_Order.Number_Of_Tickets /=
197 Summer_Subscription.Number_Of_Tickets or
198 Subscriber_Order.Subscription_Number /=
199 Summer_Subscription.Subscription_Number
200 then
201 Report.Failed ("Subscriber_Request object validation failure");
202 end if;
203
204 if VIP_Order.Location /=
205 Mayoral_Ticket_Request.Location or
206 VIP_Order.Number_Of_Tickets /=
207 Mayoral_Ticket_Request.Number_Of_Tickets or
208 VIP_Order.Rank /=
209 Mayoral_Ticket_Request.Rank
210 then
211 Report.Failed ("VIP_Request object validation failure");
212 end if;
213
214 if Last_Minute_Order.Location /=
215 Late_Request.Location or
216 Last_Minute_Order.Number_Of_Tickets /=
217 Late_Request.Number_Of_Tickets or
218 Last_Minute_Order.Rank /=
219 Late_Request.Rank or
220 Last_Minute_Order.Special_Consideration /=
221 Late_Request.Special_Consideration or
222 Last_Minute_Order.Donation /=
223 Late_Request.Donation
224 then
225 Report.Failed ("Last_Minute_Request object validation failure");
226 end if;
227
228 -- Verify tag values from before and after processing.
229 -- The 'Tag attribute is used with objects of a class-wide type.
230
231 if TC_Box_Office_Tag /=
232 Ada.Tags.External_Tag(Order_1'Tag)
233 then
234 Report.Failed("Failed tag comparison - 1");
235 end if;
236
237 if TC_Summer_Tag /=
238 Ada.Tags.External_Tag(Order_2'Tag)
239 then
240 Report.Failed("Failed tag comparison - 2");
241 end if;
242
243 if TC_Mayoral_Tag /=
244 Ada.Tags.External_Tag(Order_3'Tag)
245 then
246 Report.Failed("Failed tag comparison - 3");
247 end if;
248
249 if TC_Late_Tag /=
250 Ada.Tags.External_Tag(Order_4'Tag)
251 then
252 Report.Failed("Failed tag comparison - 4");
253 end if;
254
255 end Process_Order_Block;
256
257 -- After all the data has been correctly extracted, the file
258 -- should be empty.
259
260 if not Ada.Streams.Stream_IO.End_Of_File (Order_File) then
261 Report.Failed ("Stream file not empty");
262 end if;
263
264 exception
265 when Incomplete =>
266 raise;
267 when Constraint_Error =>
268 Report.Failed ("Constraint_Error raised in Operational Block");
269 when others =>
270 Report.Failed ("Exception raised in Operational Test Block");
271 end Operational_Test_Block;
272
273 Deletion:
274 begin
275 if Ada.Streams.Stream_IO.Is_Open (Order_File) then
276 Ada.Streams.Stream_IO.Delete (Order_File);
277 else
278 Ada.Streams.Stream_IO.Open (Order_File,
279 Ada.Streams.Stream_IO.Out_File,
280 Order_Filename);
281 Ada.Streams.Stream_IO.Delete (Order_File);
282 end if;
283 exception
284 when others =>
285 Report.Failed
286 ( "Delete not properly implemented for Stream_IO" );
287 end Deletion;
288
289 Report.Result;
290
291 exception
292
293 when Incomplete =>
294 Report.Result;
295 when others =>
296 Report.Failed ( "Unexpected exception" );
297 Report.Result;
298
299 end CXACC01;