diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c4/c460006.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c4/c460006.a | 378 |
1 files changed, 0 insertions, 378 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460006.a b/gcc/testsuite/ada/acats/tests/c4/c460006.a deleted file mode 100644 index 99968847b9b..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c460006.a +++ /dev/null @@ -1,378 +0,0 @@ --- C460006.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 a view conversion to a tagged type is permitted in the --- prefix of a selected component, an object renaming declaration, and --- (if the operand is a variable) on the left side of an assignment --- statement. Check that such a renaming or assignment does not change --- the tag of the operand. --- --- Check that, for a view conversion of a tagged type, each --- nondiscriminant component of the new view denotes the matching --- component of the operand object. Check that reading the value of the --- view yields the result of converting the value of the operand object --- to the target subtype. --- --- TEST DESCRIPTION: --- The fact that the tag of an object is not changed is verified by --- making calls to primitive operations which in turn make (re)dispatching --- calls, and confirming that the proper bodies are executed. --- --- Selected components are checked in three contexts: as the object name --- in an object renaming declaration, as the left operand of an inequality --- operation, and as the left side of an assignment statement. --- --- View conversions of an object of a 2nd level type extension are --- renamed as objects of an ancestor type and of a class-wide type. In --- one case the operand of the conversion is itself a renaming of an --- object. --- --- View conversions of an object of a 2nd level type extension are --- checked for equality with record aggregates of various ancestor types. --- In one case, the view conversion is to a class-wide type, and it is --- checked for equality with the result of a class-wide function with --- the following structure: --- --- function F return T'Class is --- A : DDT := Expected_Value; --- X : T'Class := T(A); --- begin --- return X; --- --- end F; --- --- ... --- --- Var : DDT := Expected_Value; --- --- if (T'Class(Var) /= F) then -- Condition should yield FALSE. --- FAIL; --- end if; --- --- The view conversion to which X is initialized does not affect the --- value or tag of the operand; the tag of X is that of type DDT (not T), --- and the components are those of A. The result of this function --- should equal the value of an object of type DDT initialized to the --- same value as F.A. --- --- To check that assignment to a view conversion does not change the tag --- of the operand, an assignment is made to a conversion of an object, --- and the object is then passed as an actual to a dispatching operation. --- Conversions to both specific and class-wide types are checked. --- --- --- CHANGE HISTORY: --- 20 Jul 95 SAIC Initial prerelease version. --- 24 Apr 96 SAIC Added type conversions. --- ---! - -package C460006_0 is - - type Call_ID_Kind is (None, Parent_Outer, Parent_Inner, - Child_Outer, Child_Inner, - Grandchild_Outer, Grandchild_Inner); - - type Root_Type is abstract tagged record - First_Call : Call_ID_Kind := None; - Second_Call : Call_ID_Kind := None; - end record; - - procedure Inner_Proc (X : in out Root_Type) is abstract; - procedure Outer_Proc (X : in out Root_Type) is abstract; - -end C460006_0; - - - --==================================================================-- - - -package C460006_0.C460006_1 is - - type Parent_Type is new Root_Type with record - C1 : Integer := 0; - end record; - - procedure Inner_Proc (X : in out Parent_Type); - procedure Outer_Proc (X : in out Parent_Type); - -end C460006_0.C460006_1; - - - --==================================================================-- - - -package body C460006_0.C460006_1 is - - procedure Inner_Proc (X : in out Parent_Type) is - begin - X.Second_Call := Parent_Inner; - end Inner_Proc; - - ------------------------------------------------- - procedure Outer_Proc (X : in out Parent_Type) is - begin - X.First_Call := Parent_Outer; - Inner_Proc ( Parent_Type'Class(X) ); - end Outer_Proc; - -end C460006_0.C460006_1; - - - --==================================================================-- - - -package C460006_0.C460006_1.C460006_2 is - - type Child_Type is new Parent_Type with record - C2 : String(1 .. 5) := "-----"; - end record; - - procedure Inner_Proc (X : in out Child_Type); - procedure Outer_Proc (X : in out Child_Type); - -end C460006_0.C460006_1.C460006_2; - - - --==================================================================-- - - -package body C460006_0.C460006_1.C460006_2 is - - procedure Inner_Proc (X : in out Child_Type) is - begin - X.Second_Call := Child_Inner; - end Inner_Proc; - - ------------------------------------------------- - procedure Outer_Proc (X : in out Child_Type) is - begin - X.First_Call := Child_Outer; - Inner_Proc ( Parent_Type'Class(X) ); - end Outer_Proc; - -end C460006_0.C460006_1.C460006_2; - - - --==================================================================-- - - -package C460006_0.C460006_1.C460006_2.C460006_3 is - - type Grandchild_Type is new Child_Type with record - C3: String(1 .. 5) := "-----"; - end record; - - procedure Inner_Proc (X : in out Grandchild_Type); - procedure Outer_Proc (X : in out Grandchild_Type); - - - function ClassWide_Func return Parent_Type'Class; - - - Grandchild_Value : constant Grandchild_Type := (First_Call => None, - Second_Call => None, - C1 => 15, - C2 => "Hello", - C3 => "World"); - -end C460006_0.C460006_1.C460006_2.C460006_3; - - - --==================================================================-- - - -package body C460006_0.C460006_1.C460006_2.C460006_3 is - - procedure Inner_Proc (X : in out Grandchild_Type) is - begin - X.Second_Call := Grandchild_Inner; - end Inner_Proc; - - ------------------------------------------------- - procedure Outer_Proc (X : in out Grandchild_Type) is - begin - X.First_Call := Grandchild_Outer; - Inner_Proc ( Parent_Type'Class(X) ); - end Outer_Proc; - - ------------------------------------------------- - function ClassWide_Func return Parent_Type'Class is - A : Grandchild_Type := Grandchild_Value; - X : Parent_Type'Class := Parent_Type(A); -- Value of X is still that of A. - begin - return X; - end ClassWide_Func; - -end C460006_0.C460006_1.C460006_2.C460006_3; - - - --==================================================================-- - - -with C460006_0.C460006_1.C460006_2.C460006_3; - -with Report; -procedure C460006 is - - package Root_Package renames C460006_0; - package Parent_Package renames C460006_0.C460006_1; - package Child_Package renames C460006_0.C460006_1.C460006_2; - package Grandchild_Package renames C460006_0.C460006_1.C460006_2.C460006_3; - -begin - Report.Test ("C460006", "Check that a view conversion to a tagged type " & - "is permitted in the prefix of a selected component, an " & - "object renaming declaration, and (if the operand is a " & - "variable) on the left side of an assignment statement. " & - "Check that such a renaming or assignment does not change " & - " the tag of the operand"); - - - -- - -- Check conversion as prefix of selected component: - -- - - Selected_Component_Subtest: - declare - use Root_Package, Parent_Package, Child_Package, Grandchild_Package; - - Var : Grandchild_Type := Grandchild_Value; - CW_Var : Parent_Type'Class := Var; - - Ren : Integer renames Parent_Type(Var).C1; - - begin - if Ren /= 15 then - Report.Failed ("Wrong value: selected component in renaming"); - end if; - - if Child_Type(Var).C2 /= "Hello" then - Report.Failed ("Wrong value: selected component in IF"); - end if; - - Grandchild_Type(CW_Var).C3(2..4) := "eir"; - if CW_Var /= Parent_Type'Class - (Grandchild_Type'(None, None, 15, "Hello", "Weird")) - then - Report.Failed ("Wrong value: selected component in assignment"); - end if; - end Selected_Component_Subtest; - - - -- - -- Check conversion in object renaming: - -- - - Object_Renaming_Subtest: - declare - use Root_Package, Parent_Package, Child_Package, Grandchild_Package; - - Var : Grandchild_Type := Grandchild_Value; - Ren1 : Parent_Type renames Parent_Type(Var); - Ren2 : Child_Type renames Child_Type(Var); - Ren3 : Parent_Type'Class renames Parent_Type'Class(Var); - Ren4 : Parent_Type renames Parent_Type(Ren2); -- Rename of rename. - begin - Outer_Proc (Ren1); - if Ren1 /= (Parent_Outer, Grandchild_Inner, 15) then - Report.Failed ("Value or tag not preserved by object renaming: Ren1"); - end if; - - Outer_Proc (Ren2); - if Ren2 /= (Child_Outer, Grandchild_Inner, 15, "Hello") then - Report.Failed ("Value or tag not preserved by object renaming: Ren2"); - end if; - - Outer_Proc (Ren3); - if Ren3 /= Parent_Type'Class - (Grandchild_Type'(Grandchild_Outer, - Grandchild_Inner, - 15, - "Hello", - "World")) - then - Report.Failed ("Value or tag not preserved by object renaming: Ren3"); - end if; - - Outer_Proc (Ren4); - if Ren4 /= (Parent_Outer, Grandchild_Inner, 15) then - Report.Failed ("Value or tag not preserved by object renaming: Ren4"); - end if; - end Object_Renaming_Subtest; - - - -- - -- Check reading view conversion, and conversion as left side of assignment: - -- - - View_Conversion_Subtest: - declare - use Root_Package, Parent_Package, Child_Package, Grandchild_Package; - - Var : Grandchild_Type := Grandchild_Value; - Specific : Child_Type; - ClassWide : Parent_Type'Class := Var; -- Grandchild_Type tag. - begin - if Parent_Type(Var) /= (None, None, 15) then - Report.Failed ("View has wrong value: #1"); - end if; - - if Child_Type(Var) /= (None, None, 15, "Hello") then - Report.Failed ("View has wrong value: #2"); - end if; - - if Parent_Type'Class(Var) /= ClassWide_Func then - Report.Failed ("Upward view conversion did not preserve " & - "extension's components"); - end if; - - - Parent_Type(Specific) := (None, None, 26); -- Assign to view. - Outer_Proc (Specific); -- Call dispatching op. - - if Specific /= (Child_Outer, Child_Inner, 26, "-----") then - Report.Failed ("Value or tag not preserved by assignment: Specific"); - end if; - - - Parent_Type(ClassWide) := (None, None, 44); -- Assign to view. - Outer_Proc (ClassWide); -- Call dispatching op. - - if ClassWide /= Parent_Type'Class - (Grandchild_Type'(Grandchild_Outer, - Grandchild_Inner, - 44, - "Hello", - "World")) - then - Report.Failed ("Value or tag not preserved by assignment: ClassWide"); - end if; - end View_Conversion_Subtest; - - Report.Result; - -end C460006; |