c650001.a

来自「用于进行gcc测试」· A 代码 · 共 413 行

-- C650001.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, for a function result type that is a return-by-reference
--      type, Program_Error is raised if the return expression is a name that
--      denotes an object view whose accessibility level is deeper than that
--      of the master that elaborated the function body.
--      
--      Check for cases where the result type is:
--         (a) A tagged limited type.
--         (b) A task type.
--         (c) A protected type.
--         (d) A composite type with a subcomponent of a
--             return-by-reference type (task type).
--      
-- TEST DESCRIPTION:
--      The accessibility level of the master that elaborates the body of a
--      return-by-reference function will always be less deep than that of
--      the function (which is itself a master). 
--
--      Thus, the return object may not be any of the following, since each
--      has an accessibility level at least as deep as that of the function:
--
--         (1) An object declared local to the function. 
--         (2) The result of a local function.           
--         (3) A parameter of the function.              
--
--      Verify that Program_Error is raised within the return-by-reference
--      function if the return object is any of (1)-(3) above, for various
--      subsets of the return types (a)-(d) above. Include cases where (1)-(3)
--      are operands of parenthesized expressions.
--
--      Verify that no exception is raised if the return object is any of the
--      following:
--
--         (4) An object declared at a less deep level than that of the
--             master that elaborated the function body.
--         (5) The result of a function declared at the same level as the
--             original function (assuming the new function is also legal).
--         (6) A parameter of the master that elaborated the function body.
--
--      For (5), pass the new function as an actual via an access-to-
--      subprogram parameter of the original function. Check for cases where
--      the new function does and does not raise an exception.
--
--      Since the functions to be tested cannot be part of an assignment
--      statement (since they return values of a limited type), pass each
--      function result as an actual parameter to a dummy procedure, e.g.,
--
--         Dummy_Proc ( Function_Call );
--
--
-- CHANGE HISTORY:
--      03 May 95   SAIC    Initial prerelease version.
--      08 Feb 99   RLB     Removed subcase with two errors.
--
--!

package C650001_0 is

   type Tagged_Limited is tagged limited record
      C: String (1 .. 10);
   end record;

   task type Task_Type;

   protected type Protected_Type is
      procedure Op;
   end Protected_Type;

   type Task_Array is array (1 .. 10) of Task_Type;

   type Variant_Record (Toggle: Boolean) is record
      case Toggle is
         when True  =>
            T: Task_Type;  -- Return-by-reference component.
         when False =>
            I: Integer;    -- Non-return-by-reference component.
      end case;
   end record;

   -- Limited type even though variant contains no limited components:
   type Non_Task_Variant is new Variant_Record (Toggle => False);

end C650001_0;


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


package body C650001_0 is

   task body Task_Type is
   begin
      null;
   end Task_Type;

   protected body Protected_Type is
      procedure Op is
      begin
         null;
      end Op;
   end Protected_Type;

end C650001_0;


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


with C650001_0;
package C650001_1 is

   type TC_Result_Kind is (OK, P_E, O_E);

   procedure TC_Display_Results (Actual  : in TC_Result_Kind;
                                 Expected: in TC_Result_Kind;
                                 Message : in String);

   -- Dummy procedures:

   procedure Check_Tagged    (P: C650001_0.Tagged_Limited);
   procedure Check_Task      (P: C650001_0.Task_Type);
   procedure Check_Protected (P: C650001_0.Protected_Type);
   procedure Check_Composite (P: C650001_0.Non_Task_Variant);

end C650001_1;


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


with Report;
package body C650001_1 is

   procedure TC_Display_Results (Actual  : in TC_Result_Kind;
                                 Expected: in TC_Result_Kind;
                                 Message : in String) is
   begin
      if Actual /= Expected then
         case Actual is
            when OK  =>
               Report.Failed ("No exception raised: "         & Message);
            when P_E =>
               Report.Failed ("Program_Error raised: "        & Message);
            when O_E =>
               Report.Failed ("Unexpected exception raised: " & Message);
         end case;
      end if;
   end TC_Display_Results;


   procedure Check_Tagged (P: C650001_0.Tagged_Limited) is
   begin
      null;
   end;

   procedure Check_Task (P: C650001_0.Task_Type) is
   begin
      null;
   end;

   procedure Check_Protected (P: C650001_0.Protected_Type) is
   begin
      null;
   end;

   procedure Check_Composite (P: C650001_0.Non_Task_Variant) is
   begin
      null;
   end;

end C650001_1;



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


with C650001_0;
with C650001_1;

with Report;
procedure C650001 is
begin

   Report.Test ("C650001", "Check that, for a function result type that " &
                "is a return-by-reference type, Program_Error is raised " &
                "if the return expression is a name that denotes an "     &
                "object view whose accessibility level is deeper than "   &
                "that of the master that elaborated the function body");



   SUBTEST1:
   declare

      Result: C650001_1.TC_Result_Kind;
      PO    : C650001_0.Protected_Type;

      function Return_Prot (P: C650001_0.Protected_Type)
        return C650001_0.Protected_Type is
      begin
         Result := C650001_1.OK;
         return P;                                     -- Formal parameter (3).
      exception
         when Program_Error =>
            Result := C650001_1.P_E;                        -- Expected result.
            return PO;
         when others        =>
            Result := C650001_1.O_E;
            return PO;
      end Return_Prot;

   begin  -- SUBTEST1.
      C650001_1.Check_Protected ( Return_Prot(PO) );
      C650001_1.TC_Display_Results (Result, C650001_1.P_E, "SUBTEST #1");
   exception
      when others =>
         Report.Failed ("SUBTEST #1: Unexpected exception in outer block");
   end SUBTEST1;



   SUBTEST2:
   declare

      Result: C650001_1.TC_Result_Kind;
      Comp  : C650001_0.Non_Task_Variant;

      function Return_Composite return C650001_0.Non_Task_Variant is
         Local: C650001_0.Non_Task_Variant;
      begin
         Result := C650001_1.OK;
         return (Local);                     -- Parenthesized local object (1).
      exception
         when Program_Error =>
            Result := C650001_1.P_E;                        -- Expected result.
            return Comp;
         when others        =>
            Result := C650001_1.O_E;
            return Comp;
      end Return_Composite;

   begin -- SUBTEST2.
      C650001_1.Check_Composite ( Return_Composite );
      C650001_1.TC_Display_Results (Result, C650001_1.P_E, "SUBTEST #2");
   exception
      when others =>
         Report.Failed ("SUBTEST #2: Unexpected exception in outer block");
   end SUBTEST2;



   SUBTEST3:
   declare

      Result: C650001_1.TC_Result_Kind;
      Tsk   : C650001_0.Task_Type;
      TskArr: C650001_0.Task_Array;

      function Return_Task (P: C650001_0.Task_Array)
        return C650001_0.Task_Type is

         function Inner return C650001_0.Task_Type is
         begin
            return P(P'First);           -- OK: should not raise exception (6).
         exception
            when Program_Error =>
               Report.Failed ("SUBTEST #3: Program_Error incorrectly " &
                              "raised within function Inner");
               return Tsk;
            when others        =>
               Report.Failed ("SUBTEST #3: Unexpected exception " &
                              "raised within function Inner");
               return Tsk;
         end Inner;

      begin -- Return_Task.
         Result := C650001_1.OK;
         return Inner;                           -- Call to local function (2).
      exception
         when Program_Error =>
            Result := C650001_1.P_E;                        -- Expected result.
            return Tsk;
         when others        =>
            Result := C650001_1.O_E;
            return Tsk;
      end Return_Task;

   begin -- SUBTEST3.
      C650001_1.Check_Task ( Return_Task(TskArr) );
      C650001_1.TC_Display_Results (Result, C650001_1.P_E, "SUBTEST #3");
   exception
      when others =>
         Report.Failed ("SUBTEST #3: Unexpected exception in outer block");
   end SUBTEST3;



   SUBTEST4:
   declare

      Result: C650001_1.TC_Result_Kind;
      TagLim: C650001_0.Tagged_Limited;

      function Return_TagLim (P: C650001_0.Tagged_Limited'Class)
        return C650001_0.Tagged_Limited is
      begin
         Result := C650001_1.OK;
         return C650001_0.Tagged_Limited(P); -- Conversion of formal param (3).
      exception
         when Program_Error =>
            Result := C650001_1.P_E;                        -- Expected result.
            return TagLim;
         when others        =>
            Result := C650001_1.O_E;
            return TagLim;
      end Return_TagLim;

   begin -- SUBTEST4.
      C650001_1.Check_Tagged ( Return_TagLim(TagLim) );
      C650001_1.TC_Display_Results (Result, C650001_1.P_E,
                                    "SUBTEST #4 (root type)");
   exception
      when others =>
         Report.Failed ("SUBTEST #4: Unexpected exception in outer block");
   end SUBTEST4;



   SUBTEST5:
   declare
      Tsk : C650001_0.Task_Type;
   begin  -- SUBTEST5.

      declare
         Result: C650001_1.TC_Result_Kind;

         type AccToFunc is access function return C650001_0.Task_Type;

         function Return_Global return C650001_0.Task_Type is
         begin
            return Tsk;                  -- OK: should not raise exception (4).
         end Return_Global;

         function Return_Local return C650001_0.Task_Type is
            Local : C650001_0.Task_Type;
         begin
            return Local;                           -- Propagate Program_Error.
         end Return_Local;


         function Return_Func (P: AccToFunc) return C650001_0.Task_Type is
         begin
            Result := C650001_1.OK;
            return P.all;                                 -- Function call (5).
         exception
            when Program_Error =>
               Result := C650001_1.P_E;
               return Tsk;
            when others        =>
               Result := C650001_1.O_E;
               return Tsk;
         end Return_Func;

         RG : AccToFunc := Return_Global'Access;
         RL : AccToFunc := Return_Local'Access;

      begin
         C650001_1.Check_Task ( Return_Func(RG) );
         C650001_1.TC_Display_Results (Result, C650001_1.OK,
                                       "SUBTEST #5 (global task)");

         C650001_1.Check_Task ( Return_Func(RL) );
         C650001_1.TC_Display_Results (Result, C650001_1.P_E,
                                       "SUBTEST #5 (local task)");
      exception
         when others =>
            Report.Failed ("SUBTEST #5: Unexpected exception in outer block");
      end;

   end SUBTEST5;



   Report.Result;

end C650001;