path: root/gcc/testsuite/ada/acats/tests/c9/c980003.a

-- C980003.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.
--*
--
-- TEST OBJECTIVE:
--      Check that aborts are deferred during the execution of an 
--      Initialize procedure (as the last step of the default 
--      initialization of a controlled object), during the execution 
--      of a Finalize procedure (as part of the finalization of a 
--      controlled object), and during an assignment operation to an
--      object with a controlled part.
--
-- TEST DESCRIPTION:
--      A controlled type is created with Initialize, Adjust, and 
--      Finalize operations.  These operations note in a protected
--      object when the operation starts and completes.  This change
--      in state of the protected object will open the barrier for
--      the entry in the protected object.
--      The test contains declarations of objects of the controlled
--      type.  An asynchronous select is used to attempt to abort
--      the operations on the controlled type.  The asynchronous select
--      makes use of the state change to the protected object to 
--      trigger the abort.
--
--
-- CHANGE HISTORY:
--      11 Jan 96   SAIC    Initial Release for 2.1
--       5 May 96   SAIC    Incorporated Reviewer comments.
--      10 Oct 96   SAIC    Addressed issue where assignment statement
--                          can be 2 assignment operations.
--
--!

with Ada.Finalization;
package C980003_0 is
    Verbose : constant Boolean := False;

    -- the following flag is set true whenever the
    -- Initialize operation is called.
    Init_Occurred : Boolean;

    type Is_Controlled is new Ada.Finalization.Controlled with
         record
             Id : Integer;
         end record;

     procedure Initialize (Object : in out Is_Controlled);
     procedure Finalize   (Object : in out Is_Controlled);
     procedure Adjust     (Object : in out Is_Controlled);

     type States is (Unknown,
                     Start_Init,   Finished_Init, 
                     Start_Adjust, Finished_Adjust,
                     Start_Final,  Finished_Final);

     protected State_Manager is
        procedure Reset;
        procedure Set (New_State : States);
        function Current return States;
        entry Wait_For_Change;
     private
        Current_State : States := Unknown;
        Changed : Boolean := False;
     end State_Manager;

end C980003_0;


with Report;
with ImpDef;
package body C980003_0 is
     protected body State_Manager is
         procedure Reset is
         begin
             Current_State := Unknown;
             Changed := False;
         end Reset;

         procedure Set (New_State : States) is
         begin
             Changed := True;
             Current_State := New_State;
         end Set;

         function Current return States is
         begin
             return Current_State;
         end Current;

         entry Wait_For_Change when Changed is
         begin
             Changed := False;
         end Wait_For_Change;
     end State_Manager;

     procedure Initialize (Object : in out Is_Controlled) is
     begin
        if Verbose then
            Report.Comment ("starting initialize");
        end if;
        State_Manager.Set (Start_Init);
        if Verbose then
            Report.Comment ("in initialize");
        end if;
        delay ImpDef.Switch_To_New_Task;  -- tempting place for abort
        State_Manager.Set (Finished_Init);
        if Verbose then
            Report.Comment ("finished initialize");
        end if;
        Init_Occurred := True;
     end Initialize;

     procedure Finalize   (Object : in out Is_Controlled) is
     begin
        if Verbose then
            Report.Comment ("starting finalize");
        end if;
        State_Manager.Set (Start_Final);
        if Verbose then
            Report.Comment ("in finalize");
        end if;
        delay ImpDef.Switch_To_New_Task; -- tempting place for abort
        State_Manager.Set (Finished_Final);
        if Verbose then
            Report.Comment ("finished finalize");
        end if;
     end Finalize;

     procedure Adjust     (Object : in out Is_Controlled) is
     begin
        if Verbose then
            Report.Comment ("starting adjust");
        end if;
        State_Manager.Set (Start_Adjust);
        if Verbose then
            Report.Comment ("in adjust");
        end if;
        delay ImpDef.Switch_To_New_Task; -- tempting place for abort
        State_Manager.Set (Finished_Adjust);
        if Verbose then
            Report.Comment ("finished adjust");
        end if;
     end Adjust;
end C980003_0;


with Report;
with ImpDef;
with C980003_0;  use C980003_0;
with Ada.Unchecked_Deallocation;
procedure C980003 is

    procedure Check_State (Should_Be : States;
                           Msg       : String) is
        Cur : States := State_Manager.Current;
    begin
        if Cur /= Should_Be then
            Report.Failed (Msg);
            Report.Comment ("expected: " & States'Image (Should_Be) &
                            "  found: " & States'Image (Cur));
        elsif Verbose then
            Report.Comment ("passed: " & Msg);
        end if;
    end Check_State;

begin
 
    Report.Test ("C980003", "Check that aborts are deferred during" &
                            " initialization, finalization, and assignment" &
                            " operations on controlled objects");

    Check_State (Unknown, "initial condition");

    -- check that initialization and finalization take place
    Init_Occurred := False;
    select
        State_Manager.Wait_For_Change;
    then abort
        declare
            My_Controlled_Obj : Is_Controlled;
        begin
            delay 0.0;   -- abort completion point
            Report.Failed ("state change did not occur");
        end; 
    end select;
    if not Init_Occurred then
        Report.Failed ("Initialize did not complete");
    end if;
    Check_State (Finished_Final, "init/final for declared item");

    -- check adjust
    State_Manager.Reset;
    declare
        Source, Dest : Is_Controlled;
    begin
        Check_State (Finished_Init, "adjust initial state");
        Source.Id := 3;
        Dest.Id := 4;
        State_Manager.Reset;  -- so we will wait for change
        select
            State_Manager.Wait_For_Change;
        then abort
            Dest := Source;
        end select;

        -- there are two implementation methods for the 
        -- assignment statement:
        --   1.  no temporary was used in the assignment statement 
        --        thus the entire
        --        assignment statement is abort deferred.  
        --   2.  a temporary was used in the assignment statement so
        --        there are two assignment operations.  An abort may
        --        occur between the assignment operations
        -- Various optimizations are allowed by 7.6 that can affect
        -- how many times Adjust and Finalize are called. 
        -- Depending upon the implementation, the state can be either
        -- Finished_Adjust or Finished_Finalize.   If it is any other
        -- state then the abort took place at the wrong time.

        case State_Manager.Current is
        when Finished_Adjust =>
            if Verbose then
                Report.Comment ("assignment aborted after adjust");
            end if;
        when Finished_Final =>
            if Verbose then
                Report.Comment ("assignment aborted after finalize");
            end if;
        when Start_Adjust =>
            Report.Failed ("assignment aborted in adjust");
        when Start_Final =>
            Report.Failed ("assignment aborted in finalize");
        when Start_Init =>
            Report.Failed ("assignment aborted in initialize");
        when Finished_Init =>
            Report.Failed ("assignment aborted after initialize");
        when Unknown =>
            Report.Failed ("assignment aborted in unknown state");
        end case;


        if Dest.Id /= 3 then
            if Verbose then
                Report.Comment ("assignment not performed");
            end if;
        end if;
    end;


     -- check dynamically allocated objects
    State_Manager.Reset;
    declare
        type Pointer_Type is access Is_Controlled;
        procedure Free is new Ada.Unchecked_Deallocation (
              Is_Controlled, Pointer_Type);
        Ptr : Pointer_Type;
    begin
      -- make sure initialize is done when object is allocated
      Ptr := new Is_Controlled;
      Check_State (Finished_Init, "init when item allocated");
      -- now try aborting the finalize
      State_Manager.Reset;
      select
             State_Manager.Wait_For_Change;
      then abort
             Free (Ptr);
      end select;
      Check_State (Finished_Final, "finalization in dealloc");
    end;

    Report.Result;
 
end C980003;