gcc/testsuite/ada/acats/tests/c9/c980001.a

   1 -- C980001.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25 --
  26 -- OBJECTIVE:
  27 --      Check that when a construct is aborted the execution of an Initialize
  28 --      procedure as the last step of the default initialization of a
  29 --      controlled object is abort-deferred.
  30 --
  31 --      Check that when a construct is aborted the execution of a Finalize
  32 --      procedure as part of the finalization of a controlled object is
  33 --      abort-deferred.
  34 --
  35 --      Check that an assignment operation to an object with a controlled
  36 --      part is an abort-deferred operation.
  37 --
  38 -- TEST DESCRIPTION:
  39 --      The controlled operations which are being tested call a subprogram
  40 --      which guarantees that the enclosing operation becomes aborted.
  41 --
  42 --      Each object is created with a unique value to prevent optimizations
  43 --      due to the values being the same.
  44 --
  45 --      Two protected objects are utilized to warrant that the operations
  46 --      are delayed in their execution until such time that the abort is
  47 --      processed.  The object Hold_Up is used to hold the targeted
  48 --      operation in execution, the object Progress is used to communicate
  49 --      to the driver software that progress is indeed being made.
  50 --
  51 --
  52 -- CHANGE HISTORY:
  53 --      01 MAY 95   SAIC    Initial version
  54 --      01 MAY 96   SAIC    Revised for 2.1
  55 --      11 DEC 96   SAIC    Final revision for 2.1
  56 --      02 DEC 97   EDS     Remove 2 calls to C980001_0.Hold_Up.Lock
  57 --!
  58
  59 ---------------------------------------------------------------- C980001_0
  60
  61 with Impdef;
  62 with Ada.Finalization;
  63 package C980001_0 is
  64
  65   A_Little_While : constant Duration := Impdef.Switch_To_New_Task * 2.0;
  66   Enough_Time_For_The_Controlled_Operation_To_Happen : constant Duration
  67    := Impdef.Switch_To_New_Task * 4.0;
  68
  69   function TC_Unique return Integer;
  70
  71   type Sticks_In_Initialize is new Ada.Finalization.Controlled with record
  72     Item: Integer := TC_Unique;
  73   end record;
  74   procedure Initialize( AV: in out Sticks_In_Initialize );
  75
  76   type Sticks_In_Adjust is new Ada.Finalization.Controlled with record
  77     Item: Integer := TC_Unique;
  78   end record;
  79   procedure Adjust    ( AV: in out Sticks_In_Adjust );
  80
  81   type Sticks_In_Finalize is new Ada.Finalization.Controlled with record
  82     Item: Integer := TC_Unique;
  83   end record;
  84   procedure Finalize  ( AV: in out Sticks_In_Finalize );
  85
  86   Initialize_Called : Boolean := False;
  87   Adjust_Called     : Boolean := False;
  88   Finalize_Called   : Boolean := False;
  89
  90   protected type Sticker is
  91     entry Lock;
  92     procedure Unlock;
  93     function Is_Locked return Boolean;
  94   private
  95     Locked : Boolean := False;
  96   end Sticker;
  97
  98   Hold_Up  : Sticker;
  99   Progress : Sticker;
 100
 101   procedure Fail_And_Clear( Message : String );
 102
 103
 104 end C980001_0;
 105
 106 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 107
 108 with Report;
 109 with TCTouch;
 110 package body C980001_0 is
 111
 112   TC_Master_Value : Integer := 0;
 113
 114
 115   function TC_Unique return Integer is  -- make all values unique.
 116   begin
 117     TC_Master_Value := TC_Master_Value +1;
 118     return TC_Master_Value;
 119   end TC_Unique;
 120
 121   protected body Sticker is
 122
 123     entry Lock when not Locked is
 124     begin
 125       Locked := True;
 126     end Lock;
 127
 128     procedure Unlock is
 129     begin
 130       Locked := False;
 131     end Unlock;
 132
 133     function Is_Locked return Boolean is
 134     begin
 135       return Locked;
 136     end Is_Locked;
 137
 138   end Sticker;
 139
 140   procedure Initialize( AV: in out Sticks_In_Initialize ) is
 141   begin
 142     TCTouch.Touch('I');  -------------------------------------------------- I
 143     Hold_Up.Unlock;               -- cause the select to abort
 144     Initialize_Called := True;
 145     AV.Item := TC_Unique;
 146     TCTouch.Touch('i');  -------------------------------------------------- i
 147     Progress.Unlock;              -- allows Wait_Your_Turn to continue
 148   end Initialize;
 149
 150   procedure Adjust    ( AV: in out Sticks_In_Adjust ) is
 151   begin
 152     TCTouch.Touch('A');  -------------------------------------------------- A
 153     Hold_Up.Unlock;               -- cause the select to abort
 154     Adjust_Called := True;
 155     AV.Item := TC_Unique;
 156     TCTouch.Touch('a');  -------------------------------------------------- a
 157     Progress.Unlock;
 158   end Adjust;
 159
 160   procedure Finalize  ( AV: in out Sticks_In_Finalize ) is
 161   begin
 162     TCTouch.Touch('F');  -------------------------------------------------- F
 163     Hold_Up.Unlock;               -- cause the select to abort
 164     Finalize_Called := True;
 165     AV.Item := TC_Unique;
 166     TCTouch.Touch('f');  -------------------------------------------------- f
 167     Progress.Unlock;
 168   end Finalize;
 169
 170   procedure Fail_And_Clear( Message : String ) is
 171   begin
 172     Report.Failed(Message);
 173     Hold_Up.Unlock;
 174     Progress.Unlock;
 175   end Fail_And_Clear;
 176
 177 end C980001_0;
 178
 179 ---------------------------------------------------------------------------
 180
 181 with Report;
 182 with TCTouch;
 183 with Impdef;
 184 with C980001_0;
 185 procedure C980001 is
 186
 187   procedure Check_Initialize_Conditions is
 188   begin
 189     if not C980001_0.Initialize_Called then
 190       C980001_0.Fail_And_Clear("Initialize did not correctly complete");
 191     end if;
 192     TCTouch.Validate("Ii", "Initialization Sequence");
 193   end Check_Initialize_Conditions;
 194
 195   procedure Check_Adjust_Conditions is
 196   begin
 197     if not C980001_0.Adjust_Called then
 198       C980001_0.Fail_And_Clear("Adjust did not correctly complete");
 199     end if;
 200     TCTouch.Validate("Aa", "Adjust Sequence");
 201   end Check_Adjust_Conditions;
 202
 203   procedure Check_Finalize_Conditions is
 204   begin
 205     if not C980001_0.Finalize_Called then
 206       C980001_0.Fail_And_Clear("Finalize did not correctly complete");
 207     end if;
 208     TCTouch.Validate("FfFfFf", "Finalization Sequence",
 209                      Order_Meaningful => False);
 210   end Check_Finalize_Conditions;
 211
 212   procedure Wait_Your_Turn is
 213     Overrun : Natural := 0;
 214   begin
 215     while C980001_0.Progress.Is_Locked loop  -- and waits
 216       delay C980001_0.A_Little_While;
 217       Overrun := Overrun +1;
 218       if Overrun > 10 then
 219         C980001_0.Fail_And_Clear("Overrun expired lock");
 220       end if;
 221     end loop;
 222   end Wait_Your_Turn;
 223
 224 begin  -- Main test procedure.
 225
 226   Report.Test ("C980001", "Check the interaction between asynchronous " &
 227                           "transfer of control and controlled types" );
 228
 229   C980001_0.Progress.Lock;
 230   C980001_0.Hold_Up.Lock;
 231
 232   select
 233     C980001_0.Hold_Up.Lock;  -- Init will unlock
 234
 235     Wait_Your_Turn;  -- abortable part is stuck in Initialize
 236     Check_Initialize_Conditions;
 237
 238   then abort
 239     declare
 240       Object : C980001_0.Sticks_In_Initialize;
 241     begin
 242       delay Impdef.Minimum_Task_Switch;
 243       if Report.Ident_Int( Object.Item ) /= Object.Item then
 244         Report.Failed("Optimization foil caused failure");
 245       end if;
 246       C980001_0.Fail_And_Clear(
 247                            "Initialize test executed beyond expected region");
 248     end;
 249   end select;
 250
 251   C980001_0.Progress.Lock;
 252
 253   select
 254     C980001_0.Hold_Up.Lock;  -- Adjust will unlock
 255
 256     Wait_Your_Turn;  -- abortable part is stuck in Adjust
 257     Check_Adjust_Conditions;
 258
 259   then abort
 260     declare
 261       Object1 : C980001_0.Sticks_In_Adjust;
 262       Object2 : C980001_0.Sticks_In_Adjust;
 263     begin
 264       Object1 := Object2;
 265       delay Impdef.Minimum_Task_Switch;
 266       if Report.Ident_Int( Object2.Item )
 267          /= Report.Ident_Int( Object1.Item ) then
 268         Report.Failed("Optimization foil 1 caused failure");
 269       end if;
 270       C980001_0.Fail_And_Clear("Adjust test executed beyond expected region");
 271     end;
 272   end select;
 273
 274   C980001_0.Progress.Lock;
 275
 276   select
 277     C980001_0.Hold_Up.Lock;  -- Finalize will unlock
 278
 279     Wait_Your_Turn;  -- abortable part is stuck in Finalize
 280     Check_Finalize_Conditions;
 281
 282   then abort
 283     declare
 284       Object1 : C980001_0.Sticks_In_Finalize;
 285       Object2 : C980001_0.Sticks_In_Finalize;
 286     begin
 287       Object1 := Object2;  -- cause a finalize call
 288       delay Impdef.Minimum_Task_Switch;
 289       if Report.Ident_Int( Object2.Item )
 290          /= Report.Ident_Int( Object1.Item ) then
 291         Report.Failed("Optimization foil 2 caused failure");
 292       end if;
 293       C980001_0.Fail_And_Clear(
 294                              "Finalize test executed beyond expected region");
 295     end;
 296   end select;
 297
 298   Report.Result;
 299
 300 exception
 301   when others => C980001_0.Fail_And_Clear("Exception in main");
 302                  Report.Result;
 303 end C980001;