OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c9/] [c980001.a] - Blame information for rev 867

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 149 jeremybenn
-- 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;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.