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