path: root/gcc/testsuite/ada/acats/tests/c4/c460a02.a

-- C460A02.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 declared inside the instance or is the anonymous
--      access type of an access parameter or access discriminant.
--
-- 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 component of a
--      generic formal object, a stand-alone object, and an access parameter.
--
--      The test declares three generic units, each containing an access
--      type conversion in which the target type is a formal type:
--
--         (1) A generic package in which the operand type is the anonymous
--             access type of an access discriminant, and the conversion
--             occurs within the declarative part of the body.
--
--         (2) A generic package in which the operand type is declared within
--             the specification, and the conversion occurs within the
--             sequence of statements of the body.
--
--         (3) A generic procedure in which the operand type is the anonymous
--             access type of an access parameter, and the conversion occurs
--             within the sequence of statements.
--
--      The test verifies the following:
--
--         For (1), Program_Error is raised when the package is instantiated
--         if the actual passed through the formal object 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 (2), Program_Error is raised when the package is instantiated
--         if the package is instantiated at a level deeper than that of the
--         target type passed as an actual, and that no exception is raised
--         otherwise. The exception is handled within the package body.
--
--         For (3), Program_Error is raised when the instance procedure is
--         called if the actual passed through the access parameter 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 handled within the instance procedure.
--
-- TEST FILES:
--      The following files comprise this test:
--
--         F460A00.A
--      => C460A02.A
--
--
-- CHANGE HISTORY:
--      10 May 95   SAIC    Initial prerelease version.
--      24 Apr 96   SAIC    Changed the target type formal to be 
--                          access-to-constant; Modified code to avoid dead 
--                          variable optimization.
--
--!

with F460A00;
generic
   type Target_Type is access all F460A00.Tagged_Type;
   FObj: in out F460A00.Composite_Type;
package C460A02_0 is
   procedure Dummy; -- Needed to allow package body.
end C460A02_0;


     --==================================================================--

with Report;
package body C460A02_0 is
   Ptr: Target_Type := Target_Type(FObj.D);

   procedure Dummy is
   begin
      null;
   end Dummy;

begin
   -- Avoid optimization (dead variable removal of Ptr):
   if not Report.Equal (Ptr.C, Ptr.C) then                  -- Always false.
      Report.Failed ("Unexpected error in C460A02_0 instance");
   end if;

end C460A02_0;


     --==================================================================--


with F460A00;
generic
   type Designated_Type is private;
   type Target_Type is access all Designated_Type;
   FObj : in out Target_Type;
   FRes : in out F460A00.TC_Result_Kind;
package C460A02_1 is
   type Operand_Type is access Designated_Type;
   Ptr : Operand_Type := new Designated_Type;

   procedure Dummy; -- Needed to allow package body.
end C460A02_1;


     --==================================================================--


package body C460A02_1 is
   procedure Dummy is
   begin
      null;
   end Dummy;
begin
   FRes := F460A00.UN_Init;
   FObj := Target_Type(Ptr);
   FRes := F460A00.OK;
exception
   when Program_Error => FRes := F460A00.PE_Exception;
   when others        => FRes := F460A00.Others_Exception;
end C460A02_1;


     --==================================================================--


with F460A00;
generic
   type Designated_Type is new F460A00.Tagged_Type with private;
   type Target_Type is access constant Designated_Type;
procedure C460A02_2 (P   : access Designated_Type'Class;
                     Res : out    F460A00.TC_Result_Kind);


     --==================================================================--


with Report;
procedure C460A02_2 (P   : access Designated_Type'Class;
                     Res : out    F460A00.TC_Result_Kind) is
   Ptr : Target_Type;
begin
   Res := F460A00.UN_Init;
   Ptr := Target_Type(P);

   -- Avoid optimization (dead variable removal of Ptr):
   if not Report.Equal (Ptr.C, Ptr.C) then                  -- Always false.
      Report.Failed ("Unexpected error in C460A02_2 instance");
   end if;
   Res := F460A00.OK;
exception
   when Program_Error => Res := F460A00.PE_Exception;
   when others        => Res := F460A00.Others_Exception;
end C460A02_2;


     --==================================================================--


with F460A00;
with C460A02_0;
with C460A02_1;
with C460A02_2;

with Report;
procedure C460A02 is
begin -- C460A02.                                              -- [ Level = 1 ]

   Report.Test ("C460A02", "Run-time accessibility checks: instance " &
                "bodies. Operand type of access type conversion is "  &
                "declared inside instance or is anonymous");


   SUBTEST1:
   declare                                                     -- [ Level = 2 ]
      type AccTag_L2 is access all F460A00.Tagged_Type;
      PTag_L2    : AccTag_L2 := new F460A00.Tagged_Type;
      Operand_L2 : F460A00.Composite_Type(PTag_L2);

      Result     : F460A00.TC_Result_Kind := F460A00.UN_Init;
   begin -- SUBTEST1.

      begin                                                    -- [ Level = 3 ]
         declare                                               -- [ Level = 4 ]
            -- The accessibility level of the actual passed as the target type
            -- in Pack_OK is 2. The accessibility level of the composite actual
            -- (and thus, the level of the anonymous type of the access
            -- discriminant, which is the same as that of the containing 
            -- object) is also 2. Therefore, the access type conversion in 
            -- Pack_OK does not raise an exception upon instantiation:

            package Pack_OK is new C460A02_0 
              (Target_Type => AccTag_L2, FObj => Operand_L2);
         begin
            Result := F460A00.OK;                           -- Expected result.
         end;
      exception
         when Program_Error => Result := F460A00.PE_Exception;
         when others        => Result := F460A00.Others_Exception;
      end;

      F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #1");

   end SUBTEST1;



   SUBTEST2:
   declare                                                     -- [ Level = 2 ]
      type AccTag_L2 is access all F460A00.Tagged_Type;
      PTag_L2 : AccTag_L2 := new F460A00.Tagged_Type;

      Result  : F460A00.TC_Result_Kind := F460A00.UN_Init;
   begin -- SUBTEST2.

      declare                                                  -- [ Level = 3 ]
         Operand_L3 : F460A00.Composite_Type(PTag_L2);
      begin
         declare                                               -- [ Level = 4 ]
            -- The accessibility level of the actual passed as the target type
            -- in Pack_PE is 2. The accessibility level of the composite actual
            -- (and thus, the level of the anonymous type of the access
            -- discriminant, which is the same as that of the containing 
            -- object) is 3. Therefore, the access type conversion in Pack_PE 
            -- propagates Program_Error upon instantiation:

            package Pack_PE is new C460A02_0 (AccTag_L2, Operand_L3);
         begin
            Result := F460A00.OK;
         end;
      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 #2");

   end SUBTEST2;



   SUBTEST3:
   declare                                                     -- [ Level = 2 ]
      Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
   begin -- SUBTEST3.

      declare                                                  -- [ Level = 3 ]
         type AccArr_L3 is access all F460A00.Array_Type;
         Target: AccArr_L3;

         -- The accessibility level of the actual passed as the target type
         -- in Pack_OK is 3. The accessibility level of the operand type is
         -- that of the instance, which is also 3. Therefore, the access type
         -- conversion in Pack_OK does not raise an exception upon
         -- instantiation. If an exception is (incorrectly) raised, it is 
         -- handled within the instance:

         package Pack_OK is new C460A02_1
           (Designated_Type => F460A00.Array_Type,
            Target_Type     => AccArr_L3,
            FObj            => Target,
            FRes            => Result);
      begin
         null;
      end;

      F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #3");

   exception
      when Program_Error =>
         Report.Failed ("SUBTEST #3: Program_Error incorrectly propagated");
      when others        =>
         Report.Failed ("SUBTEST #3: Unexpected exception propagated");
   end SUBTEST3;



   SUBTEST4:
   declare                                                     -- [ Level = 2 ]
      Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
   begin -- SUBTEST4.

      declare                                                  -- [ Level = 3 ]
         Target: F460A00.AccArr_L0;

         -- The accessibility level of the actual passed as the target type
         -- in Pack_PE is 0. The accessibility level of the operand type is
         -- that of the instance, which is 3. Therefore, the access type
         -- conversion in Pack_PE raises Program_Error upon instantiation.
         -- The exception is handled within the instance:

         package Pack_PE is new C460A02_1
           (Designated_Type => F460A00.Array_Type,
            Target_Type     => F460A00.AccArr_L0,
            FObj            => Target,
            FRes            => Result);
      begin
         null;
      end;

      F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "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 ]
         -- The instantiation of C460A02_2 should NOT result in any
         -- exceptions.

         procedure Proc is new C460A02_2 (F460A00.Tagged_Type,
                                          F460A00.AccTag_L0);
      begin
         -- The accessibility level of the actual passed to Proc is 0. The
         -- accessibility level of the actual passed as the target type is
         -- also 0. Therefore, the access type conversion in Proc does not
         -- raise an exception when the subprogram is called. If an exception
         -- is (incorrectly) raised, it is handled within the subprogram:

         Proc (F460A00.PTagClass_L0, Result);
      end;

      F460A00.TC_Check_Results (Result, F460A00.OK, "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;



   SUBTEST6:
   declare                                                     -- [ Level = 2 ]
      Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
   begin -- SUBTEST6.

      declare                                                  -- [ Level = 3 ]
         -- The instantiation of C460A02_2 should NOT result in any
         -- exceptions.

         procedure Proc is new C460A02_2 (F460A00.Tagged_Type,
                                          F460A00.AccTag_L0);
      begin
         -- In the call to (instantiated) procedure Proc, the first actual
         -- parameter is an allocator. Its accessibility level is that of 
         -- the level of execution of Proc, which is 3. The accessibility 
         -- level of the actual passed as the target type is 0.  Therefore, 
         -- the access type conversion in Proc raises Program_Error when the
         -- subprogram is called. The exception is handled within the
         -- subprogram:

         Proc (new F460A00.Tagged_Type, Result);
      end;

      F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #6");

   exception
      when Program_Error =>
         Report.Failed ("SUBTEST #6: Program_Error incorrectly raised");
      when others        =>
         Report.Failed ("SUBTEST #6: Unexpected exception raised");
   end SUBTEST6;

   Report.Result;

end C460A02;