c760010.a

来自「linux下编程用 编译软件」· A 代码 · 共 419 行

-- C760010.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 explicit calls to Initialize, Adjust and Finalize
--      procedures that raise exceptions propagate the exception raised,
--      not Program_Error.  Check this for both a user defined exception
--      and a language defined exception.  Check that implicit calls to
--      initialize procedures that raise an exception propagate the
--      exception raised, not Program_Error;
--
--      Check that the utilization of a controlled type as the actual for
--      a generic formal tagged private parameter supports the correct
--      behavior in the instantiated software.
--
-- TEST DESCRIPTION:
--      Declares a generic package instantiated to check that controlled
--      types are not impacted by the "generic boundary."
--      This instance is then used to perform the tests of various calls to
--      the procedures.  After each operation in the main program that should
--      cause implicit calls where an exception is raised, the program handles
--      Program_Error.  After each explicit call, the program handles the
--      Expected_Error.  Handlers for the opposite exception are provided to
--      catch the obvious failure modes.  The predefined exception
--      Tasking_Error is used to be certain that some other reason has not
--      raised a predefined exception.
--
--     
-- DATA STRUCTURES
--
--      C760010_1.Simple_Control is derived from
--        Ada.Finalization.Controlled
--
--      C760010_2.Embedded_Derived is derived from C760010_1.Simple_Control
--        by way of generic instantiation
--
--
-- CHANGE HISTORY:
--      01 MAY 95   SAIC    Initial version
--      23 APR 96   SAIC    Fix visibility problem for 2.1
--      14 NOV 96   SAIC    Revisit for 2.1 release
--      26 JUN 98   EDS     Added pragma Elaborate_Body to
--                          package C760010_0.Check_Formal_Tagged
--                          to avoid possible instantiation error
--!

---------------------------------------------------------------- C760010_0

package C760010_0 is

  User_Defined_Exception : exception;

  type Actions is ( No_Action,
                    Init_Raise_User_Defined, Init_Raise_Standard,
                    Adj_Raise_User_Defined,  Adj_Raise_Standard,
                    Fin_Raise_User_Defined,  Fin_Raise_Standard );

  Action : Actions := No_Action;

  function Unique return Natural;

end C760010_0;

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

package body C760010_0 is

  Value : Natural := 101;

  function Unique return Natural is
  begin
    Value := Value +1;
    return Value;
  end Unique;

end C760010_0;

---------------------------------------------------------------- C760010_0
------------------------------------------------------ Check_Formal_Tagged

generic

  type Formal_Tagged is tagged private;

package C760010_0.Check_Formal_Tagged is

  pragma Elaborate_Body;

  type Embedded_Derived is new Formal_Tagged with record
    TC_Meaningless_Value : Natural := Unique;
  end record;

  procedure Initialize( ED: in out Embedded_Derived );
  procedure Adjust    ( ED: in out Embedded_Derived );
  procedure Finalize  ( ED: in out Embedded_Derived );

end C760010_0.Check_Formal_Tagged;


-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

with Report;
package body C760010_0.Check_Formal_Tagged is


  procedure Initialize( ED: in out Embedded_Derived ) is
  begin
    ED.TC_Meaningless_Value := Unique;
    case Action is
      when Init_Raise_User_Defined => raise User_Defined_Exception;
      when Init_Raise_Standard     => raise Tasking_Error;
      when others                  => null;
    end case;
  end Initialize;

  procedure Adjust    ( ED: in out Embedded_Derived ) is
  begin
    ED.TC_Meaningless_Value := Unique;
    case Action is
      when Adj_Raise_User_Defined => raise User_Defined_Exception;
      when Adj_Raise_Standard     => raise Tasking_Error;
      when others                 => null;
    end case;
  end Adjust;

  procedure Finalize  ( ED: in out Embedded_Derived ) is
  begin
    ED.TC_Meaningless_Value := Unique;
    case Action is
      when Fin_Raise_User_Defined => raise User_Defined_Exception;
      when Fin_Raise_Standard     => raise Tasking_Error;
      when others                 => null;
    end case;
  end Finalize;

end C760010_0.Check_Formal_Tagged;
 
---------------------------------------------------------------- C760010_1

with Ada.Finalization;
package C760010_1 is

  procedure Check_Counters(Init,Adj,Fin : Natural; Message: String);
  procedure Reset_Counters;

  type Simple_Control is new Ada.Finalization.Controlled with record
    Item: Integer;
  end record;
  procedure Initialize( AV: in out Simple_Control );
  procedure Adjust    ( AV: in out Simple_Control );
  procedure Finalize  ( AV: in out Simple_Control );

end C760010_1;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

with Report;
package body C760010_1 is

  Initialize_Called : Natural;
  Adjust_Called     : Natural;
  Finalize_Called   : Natural;

  procedure Check_Counters(Init,Adj,Fin : Natural; Message: String) is
  begin
    if Init /= Initialize_Called then
      Report.Failed("Initialize mismatch " & Message);
    end if;
    if Adj /= Adjust_Called then
      Report.Failed("Adjust mismatch " & Message);
    end if;
    if Fin /= Finalize_Called then
      Report.Failed("Finalize mismatch " & Message);
    end if;
  end Check_Counters;

  procedure Reset_Counters is
  begin
    Initialize_Called := 0;
    Adjust_Called     := 0;
    Finalize_Called   := 0;
  end Reset_Counters;

  procedure Initialize( AV: in out Simple_Control ) is
  begin
    Initialize_Called := Initialize_Called +1;
    AV.Item := 0;
  end Initialize;

  procedure Adjust    ( AV: in out Simple_Control ) is
  begin
    Adjust_Called := Adjust_Called +1;
    AV.Item := AV.Item +1;
  end Adjust;

  procedure Finalize  ( AV: in out Simple_Control ) is
  begin
    Finalize_Called := Finalize_Called +1;
    AV.Item := AV.Item +1;
  end Finalize;

end C760010_1;
 
---------------------------------------------------------------- C760010_2

with C760010_0.Check_Formal_Tagged;
with C760010_1;
package C760010_2 is
  new C760010_0.Check_Formal_Tagged(C760010_1.Simple_Control);
 
---------------------------------------------------------------------------

with Report;
with C760010_0;
with C760010_1;
with C760010_2;
procedure C760010 is

  use type C760010_0.Actions;

  procedure Case_Failure(Message: String) is
  begin
    Report.Failed(Message & " for case "
                  & C760010_0.Actions'Image(C760010_0.Action) );
  end Case_Failure;

  procedure Check_Implicit_Initialize is
    Item   : C760010_2.Embedded_Derived;  -- exception here propagates to
    Gadget : C760010_2.Embedded_Derived;  -- caller
  begin
    if C760010_0.Action
       in C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard
    then
      Case_Failure("Anticipated exception at implicit init");
    end if;
    begin
      Item := Gadget;                     -- exception here handled locally
      if C760010_0.Action in C760010_0.Adj_Raise_User_Defined
                                   .. C760010_0.Fin_Raise_Standard then
        Case_Failure ("Anticipated exception at assignment");
      end if;
    exception
      when Program_Error =>
        if C760010_0.Action not in C760010_0.Adj_Raise_User_Defined
                                   .. C760010_0.Fin_Raise_Standard then
          Report.Failed("Program_Error in Check_Implicit_Initialize");
        end if;
      when Tasking_Error =>
        Report.Failed("Tasking_Error in Check_Implicit_Initialize");
      when C760010_0.User_Defined_Exception =>
        Report.Failed("User_Error in Check_Implicit_Initialize");
      when others =>
        Report.Failed("Wrong exception Check_Implicit_Initialize");
    end;
  end Check_Implicit_Initialize;

---------------------------------------------------------------------------

  Global_Item : C760010_2.Embedded_Derived;

---------------------------------------------------------------------------

  procedure Check_Explicit_Initialize is
  begin
    begin
      C760010_2.Initialize( Global_Item );
    if C760010_0.Action
       in C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard
    then
      Case_Failure("Anticipated exception at explicit init");
    end if;
    exception
      when Program_Error =>
        Report.Failed("Program_Error in Check_Explicit_Initialize");
      when Tasking_Error =>
        if C760010_0.Action /= C760010_0.Init_Raise_Standard then
          Report.Failed("Tasking_Error in Check_Explicit_Initialize");
        end if;
      when C760010_0.User_Defined_Exception =>
        if C760010_0.Action /= C760010_0.Init_Raise_User_Defined then
          Report.Failed("User_Error in Check_Explicit_Initialize");
        end if;
      when others =>
        Report.Failed("Wrong exception in Check_Explicit_Initialize");
    end;
  end Check_Explicit_Initialize;

---------------------------------------------------------------------------

  procedure Check_Explicit_Adjust is
  begin
    begin
      C760010_2.Adjust( Global_Item );
    if C760010_0.Action
       in C760010_0.Adj_Raise_User_Defined..C760010_0.Adj_Raise_Standard
    then
      Case_Failure("Anticipated exception at explicit Adjust");
    end if;
    exception
      when Program_Error =>
        Report.Failed("Program_Error in Check_Explicit_Adjust");
      when Tasking_Error =>
        if C760010_0.Action /= C760010_0.Adj_Raise_Standard then
          Report.Failed("Tasking_Error in Check_Explicit_Adjust");
        end if;
      when C760010_0.User_Defined_Exception =>
        if C760010_0.Action /= C760010_0.Adj_Raise_User_Defined then
          Report.Failed("User_Error in Check_Explicit_Adjust");
        end if;
      when others =>
        Report.Failed("Wrong exception in Check_Explicit_Adjust");
    end;
  end Check_Explicit_Adjust;

---------------------------------------------------------------------------

  procedure Check_Explicit_Finalize is
  begin
    begin
      C760010_2.Finalize( Global_Item );
    if C760010_0.Action
       in C760010_0.Fin_Raise_User_Defined..C760010_0.Fin_Raise_Standard
    then
      Case_Failure("Anticipated exception at explicit Finalize");
    end if;
    exception
      when Program_Error =>
        Report.Failed("Program_Error in Check_Explicit_Finalize");
      when Tasking_Error =>
        if C760010_0.Action /= C760010_0.Fin_Raise_Standard then
          Report.Failed("Tasking_Error in Check_Explicit_Finalize");
        end if;
      when C760010_0.User_Defined_Exception =>
        if C760010_0.Action /= C760010_0.Fin_Raise_User_Defined then
          Report.Failed("User_Error in Check_Explicit_Finalize");
        end if;
      when others =>
        Report.Failed("Wrong exception in Check_Explicit_Finalize");
    end;
  end Check_Explicit_Finalize;

---------------------------------------------------------------------------

begin  -- Main test procedure.

  Report.Test ("C760010", "Check that explicit calls to finalization " &
                          "procedures that raise exceptions propagate " &
                          "the exception raised.  Check the utilization " &
                          "of a controlled type as the actual for a " &
                          "generic formal tagged private parameter" );

  for Act in C760010_0.Actions loop
    C760010_1.Reset_Counters;
    C760010_0.Action := Act;

    begin
      Check_Implicit_Initialize;
      if Act in
         C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard then
        Case_Failure("No exception at Check_Implicit_Initialize");
      end if;
    exception
      when Tasking_Error =>
        if Act /= C760010_0.Init_Raise_Standard then
          Case_Failure("Tasking_Error at Check_Implicit_Initialize");
        end if;
      when C760010_0.User_Defined_Exception =>
        if Act /= C760010_0.Init_Raise_User_Defined then
          Case_Failure("User_Error at Check_Implicit_Initialize");
        end if;
      when Program_Error =>
         -- If finalize raises an exception, all other object are finalized
         -- first and Program_Error is raised upon leaving the master scope.
         -- 7.6.1:14
         if Act not in C760010_0.Fin_Raise_User_Defined..
                       C760010_0.Fin_Raise_Standard then
            Case_Failure("Program_Error at Check_Implicit_Initialize");
         end if;
      when others =>
        Case_Failure("Wrong exception at Check_Implicit_Initialize");
    end;

    Check_Explicit_Initialize;
    Check_Explicit_Adjust;
    Check_Explicit_Finalize;

    C760010_1.Check_Counters(0,0,0, C760010_0.Actions'Image(Act));

  end loop;

  -- Set to No_Action to avoid exception in finalizing Global_Item
  C760010_0.Action := C760010_0.No_Action;

  Report.Result;

end C760010;