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 54with FXACC00, Ada.Streams.Stream_IO, Ada.Tags, Report; 55 56procedure 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 64begin 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 291exception 292 293 when Incomplete => 294 Report.Result; 295 when others => 296 Report.Failed ( "Unexpected exception" ); 297 Report.Result; 298 299end CXACC01; 300