| -- 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; |
