diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c460006.a')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c460006.a | 378 |
1 files changed, 378 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c460006.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c460006.a new file mode 100644 index 000000000..99968847b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c460006.a @@ -0,0 +1,378 @@ +-- 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; |