diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c3/c390004.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c3/c390004.a | 404 |
1 files changed, 0 insertions, 404 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390004.a b/gcc/testsuite/ada/acats/tests/c3/c390004.a deleted file mode 100644 index 2c120bab92b..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c390004.a +++ /dev/null @@ -1,404 +0,0 @@ --- C390004.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 tags of allocated objects correctly identify the --- type of the allocated object. Check that the tag corresponds --- correctly to the value resulting from both normal and view --- conversion. Check that the tags of accessed values designating --- aliased objects correctly identify the type of the object. Check --- that the tag of a function result correctly evaluates. Check this --- for class-wide functions. The tag of a class-wide function result --- should be the tag appropriate to the actual value returned, not the --- tag of the ancestor type. --- --- TEST DESCRIPTION: --- This test defines a class hierarchy of types, with reference --- semantics (an access type to the class-wide type). Similar in --- structure to C392005, this test checks that dynamic allocation does --- not adversely impact the tagging of types. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -package C390004_1 is -- DMV - type Equipment is ( T_Veh, T_Car, T_Con, T_Jep ); - - type Vehicle is tagged record - Wheels : Natural := 4; - Parked : Boolean := False; - end record; - - function Wheels ( It: Vehicle ) return Natural; - procedure Park ( It: in out Vehicle ); - procedure UnPark ( It: in out Vehicle ); - procedure Set_Wheels( It: in out Vehicle; To_Count: in Natural ); - procedure TC_Check ( It: in Vehicle; To_Equip: in Equipment ); - - type Car is new Vehicle with record - Passengers : Natural := 0; - end record; - - function Passengers ( It: Car ) return Natural; - procedure Load_Passengers( It: in out Car; To_Count: in Natural ); - procedure Park ( It: in out Car ); - procedure TC_Check ( It: in Car; To_Equip: in Equipment ); - - type Convertible is new Car with record - Top_Up : Boolean := True; - end record; - - function Top_Up ( It: Convertible ) return Boolean; - procedure Lower_Top( It: in out Convertible ); - procedure Park ( It: in out Convertible ); - procedure Raise_Top( It: in out Convertible ); - procedure TC_Check ( It: in Convertible; To_Equip: in Equipment ); - - type Jeep is new Convertible with record - Windshield_Up : Boolean := True; - end record; - - function Windshield_Up ( It: Jeep ) return Boolean; - procedure Lower_Windshield( It: in out Jeep ); - procedure Park ( It: in out Jeep ); - procedure Raise_Windshield( It: in out Jeep ); - procedure TC_Check ( It: in Jeep; To_Equip: in Equipment ); - -end C390004_1; - -with Report; -package body C390004_1 is - - procedure Set_Wheels( It: in out Vehicle; To_Count: in Natural ) is - begin - It.Wheels := To_Count; - end Set_Wheels; - - function Wheels( It: Vehicle ) return Natural is - begin - return It.Wheels; - end Wheels; - - procedure Park ( It: in out Vehicle ) is - begin - It.Parked := True; - end Park; - - procedure UnPark ( It: in out Vehicle ) is - begin - It.Parked := False; - end UnPark; - - procedure TC_Check ( It: in Vehicle; To_Equip: in Equipment ) is - begin - if To_Equip /= T_Veh then - Report.Failed ("Failed, called Vehicle for " - & Equipment'Image(To_Equip)); - end if; - end TC_Check; - - procedure TC_Check ( It: in Car; To_Equip: in Equipment ) is - begin - if To_Equip /= T_Car then - Report.Failed ("Failed, called Car for " - & Equipment'Image(To_Equip)); - end if; - end TC_Check; - - procedure TC_Check ( It: in Convertible; To_Equip: in Equipment ) is - begin - if To_Equip /= T_Con then - Report.Failed ("Failed, called Convertible for " - & Equipment'Image(To_Equip)); - end if; - end TC_Check; - - procedure TC_Check ( It: in Jeep; To_Equip: in Equipment ) is - begin - if To_Equip /= T_Jep then - Report.Failed ("Failed, called Jeep for " - & Equipment'Image(To_Equip)); - end if; - end TC_Check; - - procedure Load_Passengers( It: in out Car; To_Count: in Natural ) is - begin - It.Passengers := To_Count; - UnPark( It ); - end Load_Passengers; - - procedure Park( It: in out Car ) is - begin - It.Passengers := 0; - Park( Vehicle( It ) ); - end Park; - - function Passengers( It: Car ) return Natural is - begin - return It.Passengers; - end Passengers; - - procedure Raise_Top( It: in out Convertible ) is - begin - It.Top_Up := True; - end Raise_Top; - - procedure Lower_Top( It: in out Convertible ) is - begin - It.Top_Up := False; - end Lower_Top; - - function Top_Up ( It: Convertible ) return Boolean is - begin - return It.Top_Up; - end Top_Up; - - procedure Park ( It: in out Convertible ) is - begin - It.Top_Up := True; - Park( Car( It ) ); - end Park; - - procedure Raise_Windshield( It: in out Jeep ) is - begin - It.Windshield_Up := True; - end Raise_Windshield; - - procedure Lower_Windshield( It: in out Jeep ) is - begin - It.Windshield_Up := False; - end Lower_Windshield; - - function Windshield_Up( It: Jeep ) return Boolean is - begin - return It.Windshield_Up; - end Windshield_Up; - - procedure Park( It: in out Jeep ) is - begin - It.Windshield_Up := True; - Park( Convertible( It ) ); - end Park; -end C390004_1; - -with Report; -with Ada.Tags; -with C390004_1; -procedure C390004 is - package DMV renames C390004_1; - - The_Vehicle : aliased DMV.Vehicle; - The_Car : aliased DMV.Car; - The_Convertible : aliased DMV.Convertible; - The_Jeep : aliased DMV.Jeep; - - type C_Reference is access all DMV.Car'Class; - type V_Reference is access all DMV.Vehicle'Class; - - Designator : V_Reference; - Storage : Natural; - - procedure Valet( It: in out DMV.Vehicle'Class ) is - begin - DMV.Park( It ); - end Valet; - - procedure TC_Match( Object: DMV.Vehicle'Class; - Taglet: Ada.Tags.Tag; - Where : String ) is - use Ada.Tags; - begin - if Object'Tag /= Taglet then - Report.Failed("Tag mismatch: " & Where); - end if; - end TC_Match; - - procedure Parking_Validation( It: DMV.Vehicle; TC_Message: String ) is - begin - if DMV.Wheels( It ) /= 1 or not It.Parked then - Report.Failed ("Failed Vehicle " & TC_Message); - end if; - end Parking_Validation; - - procedure Parking_Validation( It: DMV.Car; TC_Message: String ) is - begin - if DMV.Wheels( It ) /= 2 or DMV.Passengers( It ) /= 0 - or not It.Parked then - Report.Failed ("Failed Car " & TC_Message); - end if; - end Parking_Validation; - - procedure Parking_Validation( It: DMV.Convertible; - TC_Message: String ) is - begin - if DMV.Wheels( It ) /= 3 or DMV.Passengers( It ) /= 0 - or not DMV.Top_Up( It ) or not It.Parked then - Report.Failed ("Failed Convertible " & TC_Message); - end if; - end Parking_Validation; - - procedure Parking_Validation( It: DMV.Jeep; TC_Message: String ) is - begin - if DMV.Wheels( It ) /= 4 or DMV.Passengers( It ) /= 0 - or not DMV.Top_Up( It ) or not DMV.Windshield_Up( It ) - or not It.Parked then - Report.Failed ("Failed Jeep " & TC_Message); - end if; - end Parking_Validation; - - function Wash( It: V_Reference; TC_Expect : Ada.Tags.Tag ) - return DMV.Vehicle'Class is - This_Machine : DMV.Vehicle'Class := It.all; - begin - TC_Match( It.all, TC_Expect, "Class-wide object in Wash" ); - Storage := DMV.Wheels( This_Machine ); - return This_Machine; - end Wash; - - function Wash( It: C_Reference; TC_Expect : Ada.Tags.Tag ) - return DMV.Car'Class is - This_Machine : DMV.Car'Class := It.all; - begin - TC_Match( It.all, TC_Expect, "Class-wide object in Wash" ); - Storage := DMV.Wheels( This_Machine ); - return This_Machine; - end Wash; - -begin - - Report.Test( "C390004", "Check that the tags of allocated objects " - & "correctly identify the type of the allocated " - & "object. Check that tags resulting from " - & "normal and view conversions. Check tags of " - & "accessed values designating aliased objects. " - & "Check function result tags" ); - - DMV.Set_Wheels( The_Vehicle, 1 ); - DMV.Set_Wheels( The_Car, 2 ); - DMV.Set_Wheels( The_Convertible, 3 ); - DMV.Set_Wheels( The_Jeep, 4 ); - - Valet( The_Vehicle ); - Valet( The_Car ); - Valet( The_Convertible ); - Valet( The_Jeep ); - - Parking_Validation( The_Vehicle, "setup" ); - Parking_Validation( The_Car, "setup" ); - Parking_Validation( The_Convertible, "setup" ); - Parking_Validation( The_Jeep, "setup" ); - --- Check that the tags of allocated objects correctly identify the type --- of the allocated object. - - Designator := new DMV.Vehicle; - DMV.TC_Check( Designator.all, DMV.T_Veh ); - TC_Match( Designator.all, DMV.Vehicle'Tag, "allocated Vehicle" ); - - Designator := new DMV.Car; - DMV.TC_Check( Designator.all, DMV.T_Car ); - TC_Match( Designator.all, DMV.Car'Tag, "allocated Car"); - - Designator := new DMV.Convertible; - DMV.TC_Check( Designator.all, DMV.T_Con ); - TC_Match( Designator.all, DMV.Convertible'Tag, "allocated Convertible" ); - - Designator := new DMV.Jeep; - DMV.TC_Check( Designator.all, DMV.T_Jep ); - TC_Match( Designator.all, DMV.Jeep'Tag, "allocated Jeep" ); - --- Check that view conversion causes the correct dispatch - DMV.TC_Check( DMV.Vehicle( The_Jeep ), DMV.T_Veh ); - DMV.TC_Check( DMV.Car( The_Jeep ), DMV.T_Car ); - DMV.TC_Check( DMV.Convertible( The_Jeep ), DMV.T_Con ); - --- And that view conversion does not change the tag - TC_Match( DMV.Vehicle( The_Jeep ), DMV.Jeep'Tag, "View Conv Veh" ); - TC_Match( DMV.Car( The_Jeep ), DMV.Jeep'Tag, "View Conv Car" ); - TC_Match( DMV.Convertible( The_Jeep ), DMV.Jeep'Tag, "View Conv Jep" ); - --- Check that the tags of accessed values designating aliased objects --- correctly identify the type of the object. - Designator := The_Vehicle'Access; - DMV.TC_Check( Designator.all, DMV.T_Veh ); - TC_Match( Designator.all, DMV.Vehicle'Tag, "aliased Vehicle" ); - - Designator := The_Car'Access; - DMV.TC_Check( Designator.all, DMV.T_Car ); - TC_Match( Designator.all, DMV.Car'Tag, "aliased Car" ); - - Designator := The_Convertible'Access; - DMV.TC_Check( Designator.all, DMV.T_Con ); - TC_Match( Designator.all, DMV.Convertible'Tag, "aliased Convertible" ); - - Designator := The_Jeep'Access; - DMV.TC_Check( Designator.all, DMV.T_Jep ); - TC_Match( Designator.all, DMV.Jeep'Tag, "aliased Jeep" ); - --- Check that the tag of a function result correctly evaluates. --- Check this for class-wide functions. The tag of a class-wide --- function result should be the tag appropriate to the actual value --- returned, not the tag of the ancestor type. - Function_Check: declare - A_Vehicle : V_Reference := new DMV.Vehicle'( The_Vehicle ); - A_Car : C_Reference := new DMV.Car'( The_Car ); - A_Convertible : C_Reference := new DMV.Convertible'( The_Convertible ); - A_Jeep : C_Reference := new DMV.Jeep'( The_Jeep ); - begin - DMV.Unpark( A_Vehicle.all ); - DMV.Load_Passengers( A_Car.all, 5 ); - DMV.Load_Passengers( A_Convertible.all, 6 ); - DMV.Load_Passengers( A_Jeep.all, 7 ); - DMV.Lower_Top( DMV.Convertible(A_Convertible.all) ); - DMV.Lower_Top( DMV.Jeep(A_Jeep.all) ); - DMV.Lower_Windshield( DMV.Jeep(A_Jeep.all) ); - - if DMV.Wheels( Wash( A_Jeep, DMV.Jeep'Tag ) ) /= 4 - or Storage /= 4 then - Report.Failed("Did not correctly wash Jeep"); - end if; - - if DMV.Wheels( Wash( A_Convertible, DMV.Convertible'Tag ) ) /= 3 - or Storage /= 3 then - Report.Failed("Did not correctly wash Convertible"); - end if; - - if DMV.Wheels( Wash( A_Car, DMV.Car'Tag ) ) /= 2 - or Storage /= 2 then - Report.Failed("Did not correctly wash Car"); - end if; - - if DMV.Wheels( Wash( A_Vehicle, DMV.Vehicle'Tag ) ) /= 1 - or Storage /= 1 then - Report.Failed("Did not correctly wash Vehicle"); - end if; - - end Function_Check; - - Report.Result; -end C390004; |