diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/cxa/cxacc01.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cxa/cxacc01.a | 299 |
1 files changed, 0 insertions, 299 deletions
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxacc01.a b/gcc/testsuite/ada/acats/tests/cxa/cxacc01.a deleted file mode 100644 index 3ab88f40e6d..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxacc01.a +++ /dev/null @@ -1,299 +0,0 @@ --- CXACC01.A --- --- Grant of Unlimited Rights --- --- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, --- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained --- unlimited rights in the software and documentation contained herein. --- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making --- this public release, the Government intends to confer upon all --- recipients unlimited rights equal to those held by the Government. --- These rights include rights to use, duplicate, release or disclose the --- released technical data and computer software in whole or in part, in --- any manner and for any purpose whatsoever, and to have or permit others --- to do so. --- --- DISCLAIMER --- --- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR --- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED --- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE --- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE --- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A --- PARTICULAR PURPOSE OF SAID MATERIAL. ---* --- --- OBJECTIVE: --- Check that the use of 'Class'Output and 'Class'Input allow stream --- manipulation of objects of non-limited class-wide types. --- --- TEST DESCRIPTION: --- This test demonstrates the uses of 'Class'Output and 'Class'Input --- in moving objects of a particular class to and from a stream file. --- A procedure uses a class-wide parameter to move objects of specific --- types in the class to the stream, using the 'Class'Output attribute --- of the root type of the class. A function returns a class-wide object, --- using the 'Class'Input attribute of the root type of the class to --- extract the object from the stream. --- A field-by-field comparison of record objects is performed to validate --- the data read from the stream. Operator precedence rules are used --- in the comparison rather than parentheses. --- --- APPLICABILITY CRITERIA: --- This test is applicable to all implementations capable of supporting --- external Stream_IO files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 14 Nov 95 SAIC Corrected prefix of 'Tag attribute for ACVC 2.0.1. --- 24 Aug 96 SAIC Changed a call to "Create" to "Reset". --- 26 Feb 97 CTA.PWB Allowed for non-support of some IO operations. ---! - -with FXACC00, Ada.Streams.Stream_IO, Ada.Tags, Report; - -procedure CXACC01 is - - Order_File : Ada.Streams.Stream_IO.File_Type; - Order_Stream : Ada.Streams.Stream_IO.Stream_Access; - Order_Filename : constant String := - Report.Legal_File_Name ( Nam => "CXACC01" ); - Incomplete : exception; - -begin - - Report.Test ("CXACC01", "Check that the use of 'Class'Output " & - "and 'Class'Input allow stream manipulation " & - "of objects of non-limited class-wide types"); - - Test_for_Stream_IO_Support: - begin - - -- If an implementation does not support Stream_IO in a particular - -- environment, the exception Use_Error or Name_Error will be raised on - -- calls to various Stream_IO operations. This block statement - -- encloses a call to Create, which should produce an exception in a - -- non-supportive environment. These exceptions will be handled to - -- produce a Not_Applicable result. - - Ada.Streams.Stream_IO.Create (Order_File, - Ada.Streams.Stream_IO.Out_File, - Order_Filename); - - exception - - when Ada.Streams.Stream_IO.Use_Error | Ada.Streams.Stream_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create as Out_File for Stream_IO" ); - raise Incomplete; - - end Test_for_Stream_IO_Support; - - Operational_Test_Block: - declare - - -- Store tag values associated with objects of tagged types. - - TC_Box_Office_Tag : constant String := - Ada.Tags.External_Tag(FXACC00.Ticket_Request'Tag); - - TC_Summer_Tag : constant String := - Ada.Tags.External_Tag(FXACC00.Subscriber_Request'Tag); - - TC_Mayoral_Tag : constant String := - Ada.Tags.External_Tag(FXACC00.VIP_Request'Tag); - - TC_Late_Tag : constant String := - Ada.Tags.External_Tag(FXACC00.Last_Minute_Request'Tag); - - -- The following procedure will take an object of the Ticket_Request - -- class and output it to the stream. Objects of any extended type - -- in the class can be output to the stream with this procedure. - - procedure Order_Entry (Order : FXACC00.Ticket_Request'Class) is - begin - FXACC00.Ticket_Request'Class'Output (Order_Stream, Order); - end Order_Entry; - - - -- The following function will retrieve from the stream an object of - -- the Ticket_Request class. - - function Order_Retrieval return FXACC00.Ticket_Request'Class is - begin - return FXACC00.Ticket_Request'Class'Input (Order_Stream); - end Order_Retrieval; - - begin - - Order_Stream := Ada.Streams.Stream_IO.Stream (Order_File); - - -- Store the data objects in the stream. - -- Each of the objects is of a different type within the class. - - Order_Entry (FXACC00.Box_Office_Request); -- Object of root type - Order_Entry (FXACC00.Summer_Subscription); -- Obj. of extended type - Order_Entry (FXACC00.Mayoral_Ticket_Request); -- Obj. of extended type - Order_Entry (FXACC00.Late_Request); -- Object of twice - -- extended type. - - -- Reset mode of stream to In_File prior to reading data from it. - Reset1: - begin - Ada.Streams.Stream_IO.Reset (Order_File, - Ada.Streams.Stream_IO.In_File); - exception - when Ada.Streams.Stream_IO.Use_Error => - Report.Not_Applicable - ( "Reset to In_File not supported for Stream_IO - 1" ); - raise Incomplete; - end Reset1; - - Process_Order_Block: - declare - - use FXACC00; - - -- Declare variables of the root type class, - -- and initialize them with class-wide objects returned from - -- the stream as function result. - - Order_1 : Ticket_Request'Class := Order_Retrieval; - Order_2 : Ticket_Request'Class := Order_Retrieval; - Order_3 : Ticket_Request'Class := Order_Retrieval; - Order_4 : Ticket_Request'Class := Order_Retrieval; - - -- Declare objects of the specific types from within the class - -- that correspond to the types of the data written to the - -- stream. Perform a type conversion on the class-wide objects. - - Ticket_Order : Ticket_Request := - Ticket_Request(Order_1); - Subscriber_Order : Subscriber_Request := - Subscriber_Request(Order_2); - VIP_Order : VIP_Request := - VIP_Request(Order_3); - Last_Minute_Order : Last_Minute_Request := - Last_Minute_Request(Order_4); - - begin - - -- Perform a field-by-field comparison of all the class-wide - -- objects input from the stream with specific type objects - -- originally written to the stream. - - if Ticket_Order.Location /= - Box_Office_Request.Location or - Ticket_Order.Number_Of_Tickets /= - Box_Office_Request.Number_Of_Tickets - then - Report.Failed ("Ticket_Request object validation failure"); - end if; - - if Subscriber_Order.Location /= - Summer_Subscription.Location or - Subscriber_Order.Number_Of_Tickets /= - Summer_Subscription.Number_Of_Tickets or - Subscriber_Order.Subscription_Number /= - Summer_Subscription.Subscription_Number - then - Report.Failed ("Subscriber_Request object validation failure"); - end if; - - if VIP_Order.Location /= - Mayoral_Ticket_Request.Location or - VIP_Order.Number_Of_Tickets /= - Mayoral_Ticket_Request.Number_Of_Tickets or - VIP_Order.Rank /= - Mayoral_Ticket_Request.Rank - then - Report.Failed ("VIP_Request object validation failure"); - end if; - - if Last_Minute_Order.Location /= - Late_Request.Location or - Last_Minute_Order.Number_Of_Tickets /= - Late_Request.Number_Of_Tickets or - Last_Minute_Order.Rank /= - Late_Request.Rank or - Last_Minute_Order.Special_Consideration /= - Late_Request.Special_Consideration or - Last_Minute_Order.Donation /= - Late_Request.Donation - then - Report.Failed ("Last_Minute_Request object validation failure"); - end if; - - -- Verify tag values from before and after processing. - -- The 'Tag attribute is used with objects of a class-wide type. - - if TC_Box_Office_Tag /= - Ada.Tags.External_Tag(Order_1'Tag) - then - Report.Failed("Failed tag comparison - 1"); - end if; - - if TC_Summer_Tag /= - Ada.Tags.External_Tag(Order_2'Tag) - then - Report.Failed("Failed tag comparison - 2"); - end if; - - if TC_Mayoral_Tag /= - Ada.Tags.External_Tag(Order_3'Tag) - then - Report.Failed("Failed tag comparison - 3"); - end if; - - if TC_Late_Tag /= - Ada.Tags.External_Tag(Order_4'Tag) - then - Report.Failed("Failed tag comparison - 4"); - end if; - - end Process_Order_Block; - - -- After all the data has been correctly extracted, the file - -- should be empty. - - if not Ada.Streams.Stream_IO.End_Of_File (Order_File) then - Report.Failed ("Stream file not empty"); - end if; - - exception - when Incomplete => - raise; - when Constraint_Error => - Report.Failed ("Constraint_Error raised in Operational Block"); - when others => - Report.Failed ("Exception raised in Operational Test Block"); - end Operational_Test_Block; - - Deletion: - begin - if Ada.Streams.Stream_IO.Is_Open (Order_File) then - Ada.Streams.Stream_IO.Delete (Order_File); - else - Ada.Streams.Stream_IO.Open (Order_File, - Ada.Streams.Stream_IO.Out_File, - Order_Filename); - Ada.Streams.Stream_IO.Delete (Order_File); - end if; - exception - when others => - Report.Failed - ( "Delete not properly implemented for Stream_IO" ); - end Deletion; - - Report.Result; - -exception - - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXACC01; |