| -- C460A01.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 if the target type of a type conversion is a general |
| -- access type, Program_Error is raised if the accessibility level of |
| -- the operand type is deeper than that of the target type. Check for |
| -- cases where the type conversion occurs in an instance body, and |
| -- the operand type is passed as an actual during instantiation. |
| -- |
| -- TEST DESCRIPTION: |
| -- In order to satisfy accessibility requirements, the operand type must |
| -- be at the same or a less deep nesting level than the target type -- the |
| -- operand type must "live" as long as the target type. Nesting levels |
| -- are the run-time nestings of masters: block statements; subprogram, |
| -- task, and entry bodies; and accept statements. Packages are invisible |
| -- to accessibility rules. |
| -- |
| -- This test checks for cases where the operand is a subprogram formal |
| -- parameter. |
| -- |
| -- The test declares three generic packages, each containing an access |
| -- type conversion in which the operand type is a formal type: |
| -- |
| -- (1) One in which the target type is declared within the |
| -- specification, and the conversion occurs within a nested |
| -- function. |
| -- |
| -- (2) One in which the target type is also a formal type, and |
| -- the conversion occurs within a nested function. |
| -- |
| -- (3) One in which the target type is declared outside the |
| -- generic, and the conversion occurs within a nested |
| -- procedure. |
| -- |
| -- The test verifies the following: |
| -- |
| -- For (1), Program_Error is not raised when the nested function is |
| -- called. Since the actual corresponding to the formal operand type |
| -- must always have the same or a less deep level than the target |
| -- type declared within the instance, the access type conversion is |
| -- always safe. |
| -- |
| -- For (2), Program_Error is raised when the nested function is |
| -- called if the operand type passed as an actual during instantiation |
| -- has an accessibility level deeper than that of the target type |
| -- passed as an actual, and that no exception is raised otherwise. |
| -- The exception is propagated to the innermost enclosing master. |
| -- |
| -- For (3), Program_Error is raised when the nested procedure is |
| -- called if the operand type passed as an actual during instantiation |
| -- has an accessibility level deeper than that of the target type. |
| -- The exception is handled within the nested procedure. |
| -- |
| -- TEST FILES: |
| -- The following files comprise this test: |
| -- |
| -- F460A00.A |
| -- => C460A01.A |
| -- |
| -- |
| -- CHANGE HISTORY: |
| -- 09 May 95 SAIC Initial prerelease version. |
| -- 24 Apr 96 SAIC Added code to avoid dead variable optimization. |
| -- 13 Feb 97 PWB.CTA Removed 'Class from qual expression at line 342. |
| --! |
| |
| generic |
| type Designated_Type is tagged private; |
| type Operand_Type is access Designated_Type; |
| package C460A01_0 is |
| type Target_Type is access all Designated_Type; |
| function Convert (P : Operand_Type) return Target_Type; |
| end C460A01_0; |
| |
| |
| --==================================================================-- |
| |
| |
| package body C460A01_0 is |
| function Convert (P : Operand_Type) return Target_Type is |
| begin |
| return Target_Type(P); -- Never fails. |
| end Convert; |
| end C460A01_0; |
| |
| |
| --==================================================================-- |
| |
| |
| generic |
| type Designated_Type is tagged private; |
| type Operand_Type is access all Designated_Type; |
| type Target_Type is access all Designated_Type; |
| package C460A01_1 is |
| function Convert (P : Operand_Type) return Target_Type; |
| end C460A01_1; |
| |
| |
| --==================================================================-- |
| |
| |
| package body C460A01_1 is |
| function Convert (P : Operand_Type) return Target_Type is |
| begin |
| return Target_Type(P); |
| end Convert; |
| end C460A01_1; |
| |
| |
| --==================================================================-- |
| |
| |
| with F460A00; |
| generic |
| type Designated_Type (<>) is new F460A00.Tagged_Type with private; |
| type Operand_Type is access Designated_Type; |
| package C460A01_2 is |
| procedure Proc (P : Operand_Type; |
| Res : out F460A00.TC_Result_Kind); |
| end C460A01_2; |
| |
| |
| --==================================================================-- |
| |
| with Report; |
| package body C460A01_2 is |
| procedure Proc (P : Operand_Type; |
| Res : out F460A00.TC_Result_Kind) is |
| Ptr : F460A00.AccTag_L0; |
| begin |
| Ptr := F460A00.AccTag_L0(P); |
| |
| -- Avoid optimization (dead variable removal of Ptr): |
| if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. |
| Report.Failed ("Unexpected error in C460A01_2 instance"); |
| end if; |
| |
| Res := F460A00.OK; |
| exception |
| when Program_Error => Res := F460A00.PE_Exception; |
| when others => Res := F460A00.Others_Exception; |
| end Proc; |
| end C460A01_2; |
| |
| |
| --==================================================================-- |
| |
| |
| with F460A00; |
| with C460A01_0; |
| with C460A01_1; |
| with C460A01_2; |
| |
| with Report; |
| procedure C460A01 is |
| begin -- C460A01. -- [ Level = 1 ] |
| |
| Report.Test ("C460A01", "Run-time accessibility checks: instance " & |
| "bodies. Operand type of access type conversion is " & |
| "passed as actual to instance"); |
| |
| |
| SUBTEST1: |
| declare -- [ Level = 2 ] |
| type AccTag_L2 is access all F460A00.Tagged_Type; |
| Operand: AccTag_L2 := new F460A00.Tagged_Type; |
| |
| Result : F460A00.TC_Result_Kind := F460A00.UN_Init; |
| begin -- SUBTEST1. |
| |
| declare -- [ Level = 3 ] |
| -- The instantiation of C460A01_0 should NOT result in any |
| -- exceptions. |
| |
| package Pack_OK is new C460A01_0 (F460A00.Tagged_Type, AccTag_L2); |
| Target : Pack_OK.Target_Type; |
| begin |
| -- The accessibility level of Pack_OK.Target_Type will always be at |
| -- least as deep as the operand type passed as an actual. Thus, |
| -- a call to Pack_OK.Convert does not propagate an exception: |
| |
| Target := Pack_OK.Convert(Operand); |
| |
| -- Avoid optimization (dead variable removal of Target): |
| if not Report.Equal (Target.C, Target.C) then -- Always false. |
| Report.Failed ("Unexpected error in SUBTEST #1"); |
| end if; |
| |
| Result := F460A00.OK; -- Expected result. |
| exception |
| when Program_Error => Result := F460A00.PE_Exception; |
| when others => Result := F460A00.Others_Exception; |
| end; |
| |
| F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #1"); |
| |
| exception |
| when Program_Error => |
| Report.Failed ("SUBTEST #1: Program_Error incorrectly raised"); |
| when others => |
| Report.Failed ("SUBTEST #1: Unexpected exception raised"); |
| end SUBTEST1; |
| |
| |
| |
| SUBTEST2: |
| declare -- [ Level = 2 ] |
| type AccTag_L2 is access all F460A00.Tagged_Type; |
| Operand : AccTag_L2 := new F460A00.Tagged_Type; |
| |
| Result : F460A00.TC_Result_Kind := F460A00.UN_Init; |
| begin -- SUBTEST2. |
| |
| declare -- [ Level = 3 ] |
| |
| type AccTag_L3 is access all F460A00.Tagged_Type; |
| Target : AccTag_L3; |
| |
| -- The instantiation of C460A01_1 should NOT result in any |
| -- exceptions. |
| |
| package Pack_OK is new C460A01_1 |
| (Designated_Type => F460A00.Tagged_Type, |
| Operand_Type => AccTag_L2, |
| Target_Type => AccTag_L3); |
| begin |
| -- The accessibility level of the actual passed as the operand type |
| -- in Pack_OK is 2. The accessibility level of the actual passed as |
| -- the target type is 3. Therefore, the access type conversion in |
| -- Pack_OK.Convert does not raise an exception when the subprogram is |
| -- called. If an exception is (incorrectly) raised, it is propagated |
| -- to the innermost enclosing master: |
| |
| Target := Pack_OK.Convert(Operand); |
| |
| -- Avoid optimization (dead variable removal of Target): |
| if not Report.Equal (Target.C, Target.C) then -- Always false. |
| Report.Failed ("Unexpected error in SUBTEST #2"); |
| end if; |
| |
| Result := F460A00.OK; -- Expected result. |
| exception |
| when Program_Error => Result := F460A00.PE_Exception; |
| when others => Result := F460A00.Others_Exception; |
| end; |
| |
| F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #2"); |
| |
| exception |
| when Program_Error => |
| Report.Failed ("SUBTEST #2: Program_Error incorrectly raised"); |
| when others => |
| Report.Failed ("SUBTEST #2: Unexpected exception raised"); |
| end SUBTEST2; |
| |
| |
| |
| SUBTEST3: |
| declare -- [ Level = 2 ] |
| type AccTag_L2 is access all F460A00.Tagged_Type; |
| Target : AccTag_L2; |
| |
| Result : F460A00.TC_Result_Kind := F460A00.UN_Init; |
| begin -- SUBTEST3. |
| |
| declare -- [ Level = 3 ] |
| |
| type AccTag_L3 is access all F460A00.Tagged_Type; |
| Operand : AccTag_L3 := new F460A00.Tagged_Type; |
| |
| -- The instantiation of C460A01_1 should NOT result in any |
| -- exceptions. |
| |
| package Pack_PE is new C460A01_1 |
| (Designated_Type => F460A00.Tagged_Type, |
| Operand_Type => AccTag_L3, |
| Target_Type => AccTag_L2); |
| begin |
| -- The accessibility level of the actual passed as the operand type |
| -- in Pack_PE is 3. The accessibility level of the actual passed as |
| -- the target type is 2. Therefore, the access type conversion in |
| -- Pack_PE.Convert raises Program_Error when the subprogram is |
| -- called. The exception is propagated to the innermost enclosing |
| -- master: |
| |
| Target := Pack_PE.Convert(Operand); |
| |
| -- Avoid optimization (dead variable removal of Target): |
| if not Report.Equal (Target.C, Target.C) then -- Always false. |
| Report.Failed ("Unexpected error in SUBTEST #3"); |
| end if; |
| |
| Result := F460A00.OK; |
| exception |
| when Program_Error => Result := F460A00.PE_Exception; |
| -- Expected result. |
| when others => Result := F460A00.Others_Exception; |
| end; |
| |
| F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #3"); |
| |
| exception |
| when Program_Error => |
| Report.Failed ("SUBTEST #3: Program_Error incorrectly raised"); |
| when others => |
| Report.Failed ("SUBTEST #3: Unexpected exception raised"); |
| end SUBTEST3; |
| |
| |
| |
| SUBTEST4: |
| declare -- [ Level = 2 ] |
| Result : F460A00.TC_Result_Kind := F460A00.UN_Init; |
| begin -- SUBTEST4. |
| |
| declare -- [ Level = 3 ] |
| |
| TType : F460A00.Tagged_Type; |
| Operand : F460A00.AccTagClass_L0 |
| := new F460A00.Tagged_Type'(TType); |
| |
| -- The instantiation of C460A01_2 should NOT result in any |
| -- exceptions. |
| |
| package Pack_OK is new C460A01_2 (F460A00.Tagged_Type'Class, |
| F460A00.AccTagClass_L0); |
| begin |
| -- The accessibility level of the actual passed as the operand type |
| -- in Pack_OK is 0. The accessibility level of the target type |
| -- (F460A00.AccTag_L0) is also 0. Therefore, the access type |
| -- conversion in Pack_OK.Proc does not raise an exception when the |
| -- subprogram is called. If an exception is (incorrectly) raised, |
| -- it is handled within the subprogram: |
| |
| Pack_OK.Proc(Operand, Result); |
| end; |
| |
| F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #4"); |
| |
| exception |
| when Program_Error => |
| Report.Failed ("SUBTEST #4: Program_Error incorrectly raised"); |
| when others => |
| Report.Failed ("SUBTEST #4: Unexpected exception raised"); |
| end SUBTEST4; |
| |
| |
| |
| SUBTEST5: |
| declare -- [ Level = 2 ] |
| Result : F460A00.TC_Result_Kind := F460A00.UN_Init; |
| begin -- SUBTEST5. |
| |
| declare -- [ Level = 3 ] |
| |
| type AccDerTag_L3 is access all F460A00.Derived_Tagged_Type; |
| Operand : AccDerTag_L3 := new F460A00.Derived_Tagged_Type; |
| |
| -- The instantiation of C460A01_2 should NOT result in any |
| -- exceptions. |
| |
| package Pack_PE is new C460A01_2 (F460A00.Derived_Tagged_Type, |
| AccDerTag_L3); |
| begin |
| -- The accessibility level of the actual passed as the operand type |
| -- in Pack_PE is 3. The accessibility level of the target type |
| -- (F460A00.AccTag_L0) is 0. Therefore, the access type conversion |
| -- in Pack_PE.Proc raises Program_Error when the subprogram is |
| -- called. The exception is handled within the subprogram: |
| |
| Pack_PE.Proc(Operand, Result); |
| end; |
| |
| F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #5"); |
| |
| exception |
| when Program_Error => |
| Report.Failed ("SUBTEST #5: Program_Error incorrectly raised"); |
| when others => |
| Report.Failed ("SUBTEST #5: Unexpected exception raised"); |
| end SUBTEST5; |
| |
| Report.Result; |
| |
| end C460A01; |
