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, 0 insertions, 374 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390007.a b/gcc/testsuite/ada/acats/tests/c3/c390007.a deleted file mode 100644 index 46f59f66c56..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c390007.a +++ /dev/null @@ -1,374 +0,0 @@ --- 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; |