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
61with Impdef;
62with Ada.Finalization;
63package 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
104end C980001_0;
105
106-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
107
108with Report;
109with TCTouch;
110package 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
177end C980001_0;
178
179---------------------------------------------------------------------------
180
181with Report;
182with TCTouch;
183with Impdef;
184with C980001_0;
185procedure 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
224begin  -- 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
300exception
301  when others => C980001_0.Fail_And_Clear("Exception in main");
302                 Report.Result;
303end C980001;
304