path: root/gcc/testsuite/ada/acats/tests/c7/c761006.a

-- C761006.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 Program_Error is raised when:
--        * an exception is raised if Finalize invoked as part of an
--          assignment operation; or
--        * an exception is raised if Adjust invoked as part of an assignment
--          operation, after any other adjustment due to be performed are
--          performed; or
--        * an exception is raised if Finalize invoked as part of a call on
--          Unchecked_Deallocation, after any other finalizations to be
--          performed are performed.
--
-- TEST DESCRIPTION:
--      This test defines these four controlled types:
--        Good
--        Bad_Initialize
--        Bad_Adjust
--        Bad_Finalize
--      The type name conveys the associated failure.  The operations in type
--      good will "touch" the boolean array indicating correct path
--      utilization for the purposes of checking "other <operations> are
--      performed", where <operations> ::= initialization, adjusting, and
--      finalization
--
--
--
-- CHANGE HISTORY:
--      12 APR 94   SAIC   Initial version
--      02 MAY 96   SAIC   Visibility fixed for 2.1
--      13 FEB 97   PWB.CTA Corrected value of Events_Occurring at line 286
--      01 DEC 97   EDS    Made correction wrt RM 7.6(21)
--      16 MAR 01   RLB    Corrected Adjust cases to avoid problems with
--                         RM 7.6.1(16/1) from Technical Corrigendum 1.
--
--!

------------------------------------------------------------- C761006_Support

package C761006_Support is

  type Events is ( Good_Initialize, Good_Adjust, Good_Finalize );

  type Event_Array is array(Events) of Boolean;

  Events_Occurring : Event_Array := (others => False);

  Propagating_Exception : exception;

  procedure Raise_Propagating_Exception(Do_It: Boolean);

  function Unique_Value return Natural;

end C761006_Support;

------------------------------------------------------------- C761006_Support

with Report;
package body C761006_Support is

  procedure Raise_Propagating_Exception(Do_It: Boolean) is
  begin
     if Report.Ident_Bool(Do_It) then
       raise Propagating_Exception;
     end if;
  end Raise_Propagating_Exception;

  Seed : Natural := 0;

  function Unique_Value return Natural is
  begin
    Seed := Seed +1;
    return Seed;
  end Unique_Value;

end C761006_Support;

------------------------------------------------------------------- C761006_0

with Ada.Finalization;
with C761006_Support;
package C761006_0 is

  type Good is new Ada.Finalization.Controlled
    with record
      Initialized : Boolean := False;
      Adjusted    : Boolean := False;
      Unique      : Natural := C761006_Support.Unique_Value;
    end record;

  procedure Initialize( It: in out Good );
  procedure Adjust    ( It: in out Good );
  procedure Finalize  ( It: in out Good );

  type Bad_Initialize is private;

  type Bad_Adjust     is private;

  type Bad_Finalize   is private;

  Inits_Order  : String(1..255);
  Inits_Called : Natural := 0;
private
  type Bad_Initialize is new Ada.Finalization.Controlled
                                             with null record;
  procedure Initialize( It: in out Bad_Initialize );

  type Bad_Adjust is new Ada.Finalization.Controlled
                                         with null record;
  procedure Adjust    ( It: in out Bad_Adjust );

  type Bad_Finalize is
       new Ada.Finalization.Controlled with null record;
  procedure Finalize  ( It: in out Bad_Finalize );
end C761006_0;

------------------------------------------------------------------- C761006_1

with Ada.Finalization;
with C761006_0;
package C761006_1 is

  type Init_Check_Root is new Ada.Finalization.Controlled with record
    Good_Component : C761006_0.Good;
    Init_Fails     : C761006_0.Bad_Initialize;
  end record;

  type Adj_Check_Root is new Ada.Finalization.Controlled with record
    Good_Component : C761006_0.Good;
    Adj_Fails      : C761006_0.Bad_Adjust;
  end record;

  type Fin_Check_Root is new Ada.Finalization.Controlled with record
    Good_Component : C761006_0.Good;
    Fin_Fails      : C761006_0.Bad_Finalize;
  end record;

end C761006_1;

------------------------------------------------------------------- C761006_2

with C761006_1;
package C761006_2 is

  type Init_Check is new C761006_1.Init_Check_Root with null record;
  type Adj_Check is  new C761006_1.Adj_Check_Root  with null record;
  type Fin_Check is  new C761006_1.Fin_Check_Root  with null record;

end C761006_2;

------------------------------------------------------------------- C761006_0

with Report;
with C761006_Support;
package body C761006_0 is

  package Sup renames C761006_Support;

  procedure Initialize( It: in out Good ) is
  begin
    Sup.Events_Occurring( Sup.Good_Initialize ) := True;
    It.Initialized := True;
  end Initialize;

  procedure Adjust    ( It: in out Good ) is
  begin
    Sup.Events_Occurring( Sup.Good_Adjust ) := True;
    It.Adjusted := True;
    It.Unique := C761006_Support.Unique_Value;
  end Adjust;

  procedure Finalize  ( It: in out Good ) is
  begin
    Sup.Events_Occurring( Sup.Good_Finalize ) := True;
  end Finalize;

  procedure Initialize( It: in out Bad_Initialize ) is
  begin
    Sup.Raise_Propagating_Exception(Report.Ident_Bool(True));
  end Initialize;

  procedure Adjust( It: in out Bad_Adjust ) is
  begin
    Sup.Raise_Propagating_Exception(Report.Ident_Bool(True));
  end Adjust;

  procedure Finalize( It: in out Bad_Finalize ) is
  begin
    Sup.Raise_Propagating_Exception(Report.Ident_Bool(True));
  end Finalize;

end C761006_0;

--------------------------------------------------------------------- C761006

with Report;
with C761006_0;
with C761006_2;
with C761006_Support;
with Ada.Exceptions;
with Ada.Finalization;
with Unchecked_Deallocation;
procedure C761006 is

  package Sup renames C761006_Support;
  use type Sup.Event_Array;

  type Procedure_Handle is access procedure;

  type Test_ID is ( Simple, Initialize, Adjust, Finalize );

  Sub_Tests : array(Test_ID) of Procedure_Handle;

  procedure Simple_Test is
    A_Good_Object : C761006_0.Good; -- should call Initialize
  begin
    if not A_Good_Object.Initialized then
      Report.Failed("Good object not initialized");
    end if;

    -- should call Adjust
    A_Good_Object := ( Ada.Finalization.Controlled
                       with Unique => 0, others => False );
    if not A_Good_Object.Adjusted then
      Report.Failed("Good object not adjusted");
    end if;

    -- should call Finalize before end of scope
  end Simple_Test;

  procedure Initialize_Test is
  begin
    declare
      This_Object_Fails_In_Initialize : C761006_2.Init_Check;
    begin
      Report.Failed("Exception in Initialize did not occur");
    exception
      when others =>
        Report.Failed("Initialize caused exception at wrong lex");
    end;

    Report.Failed("Error in execution sequence");

  exception
    when Sup.Propagating_Exception => -- this is correct
      if not Sup.Events_Occurring(Sup.Good_Initialize) then
        Report.Failed("Initialization of Good Component did not occur");
      end if;
  end Initialize_Test;

  procedure Adjust_Test is
    This_Object_OK     : C761006_2.Adj_Check;
    This_Object_Target : C761006_2.Adj_Check;
  begin

    Check_Adjust_Due_To_Assignment: begin
      This_Object_Target := This_Object_OK;
      Report.Failed("Adjust did not propagate any exception");
    exception
      when Program_Error =>  -- expected case
             if not This_Object_Target.Good_Component.Adjusted then
               Report.Failed("other adjustment not performed");
             end if;
      when others =>
             Report.Failed("Adjust propagated wrong exception");
    end Check_Adjust_Due_To_Assignment;

    C761006_Support.Events_Occurring := (True, False, False);

    Check_Adjust_Due_To_Initial_Assignment: declare
      Another_Target : C761006_2.Adj_Check := This_Object_OK;
    begin
      Report.Failed("Adjust did not propagate any exception");
    exception
      when others => Report.Failed("Adjust caused exception at wrong lex");
    end Check_Adjust_Due_To_Initial_Assignment;

  exception
    when Program_Error =>  -- expected case
           if Sup.Events_Occurring(Sup.Good_Finalize) /=
              Sup.Events_Occurring(Sup.Good_Adjust) then
              -- RM 7.6.1(16/1) says that the good Adjust may or may not
              -- be performed; but if it is, then the Finalize must be
              -- performed; and if it is not, then the Finalize must not
              -- performed.
              if Sup.Events_Occurring(Sup.Good_Finalize) then
                 Report.Failed("Good adjust not performed with bad adjust, " &
                               "but good finalize was");
              else
                 Report.Failed("Good adjust performed with bad adjust, " &
                               "but good finalize was not");
              end if;
           end if;
    when others =>
           Report.Failed("Adjust propagated wrong exception");
  end Adjust_Test;

  procedure Finalize_Test is

    Fin_Not_Perf : constant String := "other finalizations not performed";

    procedure Finalize_15 is
      Item   : C761006_2.Fin_Check;
      Target : C761006_2.Fin_Check;
    begin

      Item := Target;
      -- finalization of Item should cause PE
      -- ARM7.6:21 allows the implementation to omit the assignment of the
      -- value into an anonymous object, which is the point at which Adjust
      -- is normally called.  However, this would result in Program_Error's
      -- being raised before the call to Adjust, with the consequence that
      -- Adjust is never called.

    exception
      when Program_Error => -- expected case
             if not Sup.Events_Occurring(Sup.Good_Finalize) then
               Report.Failed("Assignment: " & Fin_Not_Perf);
             end if;
      when others =>
             Report.Failed("Other exception in Finalize_15");

    -- finalization of Item/Target should cause PE
    end Finalize_15;

  -- check failure in finalize due to Unchecked_Deallocation

  type Shark is access C761006_2.Fin_Check;

  procedure Catch is
    new Unchecked_Deallocation( C761006_2.Fin_Check, Shark );

  procedure Finalize_17 is
    White : Shark := new C761006_2.Fin_Check;
  begin
    Catch( White );
  exception
    when Program_Error =>
           if not Sup.Events_Occurring(Sup.Good_Finalize) then
             Report.Failed("Unchecked_Deallocation: " & Fin_Not_Perf);
           end if;
  end Finalize_17;

  begin

    Exception_In_Finalization: begin
      Finalize_15;
    exception
      when Program_Error => null; -- anticipated
    end Exception_In_Finalization;

    Use_Of_Unchecked_Deallocation: begin
      Finalize_17;
    exception
      when others =>
        Report.Failed("Unchecked_Deallocation check, unwanted exception");
    end Use_Of_Unchecked_Deallocation;

  end Finalize_Test;

begin  -- Main test procedure.

  Report.Test ("C761006", "Check that exceptions raised in Initialize, " &
                          "Adjust and Finalize are processed correctly" );

  Sub_Tests := (Simple_Test'Access, Initialize_Test'Access,
                Adjust_Test'Access, Finalize_Test'Access);

  for Test in Sub_Tests'Range loop
    begin

      Sup.Events_Occurring := (others => False);

      Sub_Tests(Test).all;

      case Test is
        when Simple | Adjust =>
          if Sup.Events_Occurring /= Sup.Event_Array ' ( others => True ) then
            Report.Failed ( "Other operation missing in " &
                            Test_ID'Image ( Test ) );
          end if;
        when  Initialize =>
          null;
        when Finalize  =>
          -- Note that for Good_Adjust, we may get either True or False
          if Sup.Events_Occurring ( Sup.Good_Initialize ) = False or
             Sup.Events_Occurring ( Sup.Good_Finalize ) = False
          then
            Report.Failed ( "Other operation missing in " &
                            Test_ID'Image ( Test ) );
          end if;
      end case;

    exception
       when How: others => Report.Failed( Ada.Exceptions.Exception_Name( How )
                                        & " from " & Test_ID'Image( Test ) );
    end;
  end loop;

  Report.Result;

end C761006;