diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c3/c390007.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c3/c390007.a | 374 |
1 files changed, 374 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390007.a b/gcc/testsuite/ada/acats/tests/c3/c390007.a new file mode 100644 index 000000000..46f59f66c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c390007.a @@ -0,0 +1,374 @@ +-- C390007.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 tag of an object of a tagged type is preserved by +-- type conversion and parameter passing. +-- +-- TEST DESCRIPTION: +-- The fact that the tag of an object is not changed is verified by +-- making dispatching calls to primitive operations, and confirming that +-- the proper body is executed. Objects of both specific and class-wide +-- types are checked. +-- +-- The dispatching calls are made in two contexts. The first is a +-- straightforward dispatching call made from within a class-wide +-- operation. The second is a redispatch from within a primitive +-- operation. +-- +-- For the parameter passing case, the initial class-wide and specific +-- objects are passed directly in calls to the class-wide and primitive +-- operations. The redispatch is accomplished by initializing a local +-- class-wide object in the primitive operation to the value of the +-- formal parameter, and using the local object as the actual in the +-- (re)dispatching call. +-- +-- For the type conversion case, the initial class-wide object is assigned +-- a view conversion of an object of a specific type: +-- +-- type T is tagged ... +-- type DT is new T with ... +-- +-- A : DT; +-- B : T'Class := T(A); -- Despite conversion, tag of B is that of DT. +-- +-- The class-wide object is then passed directly in calls to the +-- class-wide and primitive operations. For the initial object of a +-- specific type, however, a view conversion of the object is passed, +-- forcing a non-dispatching call in the primitive operation case. Within +-- the primitive operation, a view conversion of the formal parameter to +-- a class-wide type is then used to force a (re)dispatching call. +-- +-- For the type conversion and parameter passing case, a combining of +-- view conversion and parameter passing of initial specific objects are +-- called directly to the class-wide and primitive operations. +-- +-- +-- CHANGE HISTORY: +-- 28 Jun 95 SAIC Initial prerelease version. +-- 23 Apr 96 SAIC Added use C390007_0 in the main. +-- +--! + +package C390007_0 is + + type Call_ID_Kind is (None, Parent_Outer, Parent_Inner, + Derived_Outer, Derived_Inner); + + type Root_Type is abstract tagged null record; + + procedure Outer_Proc (X : in out Root_Type) is abstract; + procedure Inner_Proc (X : in out Root_Type) is abstract; + + procedure ClassWide_Proc (X : in out Root_Type'Class); + +end C390007_0; + + + --==================================================================-- + + +package body C390007_0 is + + procedure ClassWide_Proc (X : in out Root_Type'Class) is + begin + Inner_Proc (X); + end ClassWide_Proc; + +end C390007_0; + + + --==================================================================-- + + +package C390007_0.C390007_1 is + + type Param_Parent_Type is new Root_Type with record + Last_Call : Call_ID_Kind := None; + end record; + + procedure Outer_Proc (X : in out Param_Parent_Type); + procedure Inner_Proc (X : in out Param_Parent_Type); + +end C390007_0.C390007_1; + + + --==================================================================-- + + +package body C390007_0.C390007_1 is + + procedure Outer_Proc (X : in out Param_Parent_Type) is + begin + X.Last_Call := Parent_Outer; + end Outer_Proc; + + procedure Inner_Proc (X : in out Param_Parent_Type) is + begin + X.Last_Call := Parent_Inner; + end Inner_Proc; + +end C390007_0.C390007_1; + + + --==================================================================-- + + +package C390007_0.C390007_1.C390007_2 is + + type Param_Derived_Type is new Param_Parent_Type with null record; + + procedure Outer_Proc (X : in out Param_Derived_Type); + procedure Inner_Proc (X : in out Param_Derived_Type); + +end C390007_0.C390007_1.C390007_2; + + + --==================================================================-- + + +package body C390007_0.C390007_1.C390007_2 is + + procedure Outer_Proc (X : in out Param_Derived_Type) is + Y : Root_Type'Class := X; + begin + Inner_Proc (Y); -- Redispatch. + Root_Type'Class (X) := Y; + end Outer_Proc; + + procedure Inner_Proc (X : in out Param_Derived_Type) is + begin + X.Last_Call := Derived_Inner; + end Inner_Proc; + +end C390007_0.C390007_1.C390007_2; + + + --==================================================================-- + + +package C390007_0.C390007_3 is + + type Convert_Parent_Type is new Root_Type with record + First_Call : Call_ID_Kind := None; + Second_Call : Call_ID_Kind := None; + end record; + + procedure Outer_Proc (X : in out Convert_Parent_Type); + procedure Inner_Proc (X : in out Convert_Parent_Type); + +end C390007_0.C390007_3; + + + --==================================================================-- + + +package body C390007_0.C390007_3 is + + procedure Outer_Proc (X : in out Convert_Parent_Type) is + begin + X.First_Call := Parent_Outer; + Inner_Proc (Root_Type'Class(X)); -- Redispatch. + end Outer_Proc; + + procedure Inner_Proc (X : in out Convert_Parent_Type) is + begin + X.Second_Call := Parent_Inner; + end Inner_Proc; + +end C390007_0.C390007_3; + + + --==================================================================-- + + +package C390007_0.C390007_3.C390007_4 is + + type Convert_Derived_Type is new Convert_Parent_Type with null record; + + procedure Outer_Proc (X : in out Convert_Derived_Type); + procedure Inner_Proc (X : in out Convert_Derived_Type); + +end C390007_0.C390007_3.C390007_4; + + + --==================================================================-- + + +package body C390007_0.C390007_3.C390007_4 is + + procedure Outer_Proc (X : in out Convert_Derived_Type) is + begin + X.First_Call := Derived_Outer; + Inner_Proc (Root_Type'Class(X)); -- Redispatch. + end Outer_Proc; + + procedure Inner_Proc (X : in out Convert_Derived_Type) is + begin + X.Second_Call := Derived_Inner; + end Inner_Proc; + +end C390007_0.C390007_3.C390007_4; + + + --==================================================================-- + + +with C390007_0.C390007_1.C390007_2; +with C390007_0.C390007_3.C390007_4; +use C390007_0; + +with Report; +procedure C390007 is +begin + Report.Test ("C390007", "Check that the tag of an object of a tagged " & + "type is preserved by type conversion and parameter passing"); + + + -- + -- Check that tags are preserved by parameter passing: + -- + + Parameter_Passing_Subtest: + declare + Specific_A : C390007_0.C390007_1.C390007_2.Param_Derived_Type; + Specific_B : C390007_0.C390007_1.C390007_2.Param_Derived_Type; + + ClassWide_A : C390007_0.C390007_1.Param_Parent_Type'Class := Specific_A; + ClassWide_B : C390007_0.C390007_1.Param_Parent_Type'Class := Specific_B; + + use C390007_0.C390007_1; + use C390007_0.C390007_1.C390007_2; + begin + + Outer_Proc (Specific_A); + if Specific_A.Last_Call /= Derived_Inner then + Report.Failed ("Parameter passing: tag not preserved in call to " & + "primitive operation with specific operand"); + end if; + + C390007_0.ClassWide_Proc (Specific_B); + if Specific_B.Last_Call /= Derived_Inner then + Report.Failed ("Parameter passing: tag not preserved in call to " & + "class-wide operation with specific operand"); + end if; + + Outer_Proc (ClassWide_A); + if ClassWide_A.Last_Call /= Derived_Inner then + Report.Failed ("Parameter passing: tag not preserved in call to " & + "primitive operation with class-wide operand"); + end if; + + C390007_0.ClassWide_Proc (ClassWide_B); + if ClassWide_B.Last_Call /= Derived_Inner then + Report.Failed ("Parameter passing: tag not preserved in call to " & + "class-wide operation with class-wide operand"); + end if; + + end Parameter_Passing_Subtest; + + + -- + -- Check that tags are preserved by type conversion: + -- + + Type_Conversion_Subtest: + declare + Specific_A : C390007_0.C390007_3.C390007_4.Convert_Derived_Type; + Specific_B : C390007_0.C390007_3.C390007_4.Convert_Derived_Type; + + ClassWide_A : C390007_0.C390007_3.Convert_Parent_Type'Class := + C390007_0.C390007_3.Convert_Parent_Type(Specific_A); + ClassWide_B : C390007_0.C390007_3.Convert_Parent_Type'Class := + C390007_0.C390007_3.Convert_Parent_Type(Specific_B); + + use C390007_0.C390007_3; + use C390007_0.C390007_3.C390007_4; + begin + + Outer_Proc (Convert_Parent_Type(Specific_A)); + if (Specific_A.First_Call /= Parent_Outer) or + (Specific_A.Second_Call /= Derived_Inner) + then + Report.Failed ("Type conversion: tag not preserved in call to " & + "primitive operation with specific operand"); + end if; + + Outer_Proc (ClassWide_A); + if (ClassWide_A.First_Call /= Derived_Outer) or + (ClassWide_A.Second_Call /= Derived_Inner) + then + Report.Failed ("Type conversion: tag not preserved in call to " & + "primitive operation with class-wide operand"); + end if; + + C390007_0.ClassWide_Proc (Convert_Parent_Type(Specific_B)); + if (Specific_B.Second_Call /= Derived_Inner) then + Report.Failed ("Type conversion: tag not preserved in call to " & + "class-wide operation with specific operand"); + end if; + + C390007_0.ClassWide_Proc (ClassWide_B); + if (ClassWide_A.Second_Call /= Derived_Inner) then + Report.Failed ("Type conversion: tag not preserved in call to " & + "class-wide operation with class-wide operand"); + end if; + + end Type_Conversion_Subtest; + + + -- + -- Check that tags are preserved by type conversion and parameter passing: + -- + + Type_Conversion_And_Parameter_Passing_Subtest: + declare + Specific_A : C390007_0.C390007_1.C390007_2.Param_Derived_Type; + Specific_B : C390007_0.C390007_1.C390007_2.Param_Derived_Type; + + use C390007_0.C390007_1; + use C390007_0.C390007_1.C390007_2; + begin + + Outer_Proc (Param_Parent_Type (Specific_A)); + if Specific_A.Last_Call /= Parent_Outer then + Report.Failed ("Type conversion and parameter passing: tag not " & + "preserved in call to primitive operation with " & + "specific operand"); + end if; + + C390007_0.ClassWide_Proc (Param_Parent_Type (Specific_B)); + if Specific_B.Last_Call /= Derived_Inner then + Report.Failed ("Type conversion and parameter passing: tag not " & + "preserved in call to class-wide operation with " & + "specific operand"); + end if; + + end Type_Conversion_And_Parameter_Passing_Subtest; + + + Report.Result; + +end C390007; |