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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c7/] [c761007.a] - Blame information for rev 720

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- C761007.A
2
--
3
--
4
--                             Grant of Unlimited Rights
5
--
6
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
7
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
8
--     unlimited rights in the software and documentation contained herein.
9
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
10
--     this public release, the Government intends to confer upon all
11
--     recipients unlimited rights  equal to those held by the Government.
12
--     These rights include rights to use, duplicate, release or disclose the
13
--     released technical data and computer software in whole or in part, in
14
--     any manner and for any purpose whatsoever, and to have or permit others
15
--     to do so.
16
--
17
--                                    DISCLAIMER
18
--
19
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
20
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
21
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
22
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
23
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
24
--     PARTICULAR PURPOSE OF SAID MATERIAL.
25
--*
26
--
27
-- OBJECTIVE:
28
--      Check that if a finalize procedure invoked by a transfer of control
29
--      due to selection of a terminate alternative attempts to propagate an
30
--      exception, the exception is ignored, but any other finalizations due
31
--      to be performed are performed.
32
--
33
--
34
-- TEST DESCRIPTION:
35
--      This test declares a nested controlled data type, and embeds an object
36
--      of that type within a protected type.  Objects of the protected type
37
--      are created and destroyed, and the actions of the embedded controlled
38
--      object are checked.  The container controlled type causes an exception
39
--      as the last part of it's finalization operation.
40
--
41
--      This test utilizes several tasks to accomplish the objective.  The
42
--      tasks contain delays to ensure that the expected order of processing
43
--      is indeed accomplished.
44
--
45
--      Subtest 1:
46
--        local task object runs to normal completion
47
--
48
--      Subtest 2:
49
--        local task aborts a nested task to cause finalization
50
--
51
--      Subtest 3:
52
--        local task sleeps long enough to allow procedure started
53
--        asynchronously to go into infinite loop.  Procedure is then aborted
54
--        via ATC, causing finalization of objects.
55
--
56
--      Subtest 4:
57
--        local task object takes terminate alternative, causing finalization
58
--
59
--
60
-- CHANGE HISTORY:
61
--      06 JUN 95   SAIC    Initial version
62
--      05 APR 96   SAIC    Documentation changes
63
--      03 MAR 97   PWB.CTA Allowed two finalization orders for ATC test
64
--      02 DEC 97   EDS     Remove duplicate characters from check string.
65
--!
66
 
67
---------------------------------------------------------------- C761007_0
68
 
69
with Ada.Finalization;
70
package C761007_0 is
71
 
72
  type Internal is new Ada.Finalization.Controlled
73
    with record
74
      Effect : Character;
75
    end record;
76
 
77
  procedure Finalize( I: in out Internal );
78
 
79
  Side_Effect : String(1..80);  -- way bigger than needed
80
  Side_Effect_Finger : Natural := 0;
81
 
82
end C761007_0;
83
 
84
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
85
 
86
with TCTouch;
87
package body C761007_0 is
88
 
89
  procedure Finalize( I : in out Internal ) is
90
    Previous_Side_Effect : Boolean := False;
91
  begin
92
    -- look to see if this character has been finalized yet
93
    for SEI in 1..Side_Effect_Finger loop
94
      Previous_Side_Effect := Previous_Side_Effect
95
                              or Side_Effect(Side_Effect_Finger) = I.Effect;
96
    end loop;
97
 
98
    -- if not, then tack it on to the string, and touch the character
99
    if not Previous_Side_Effect then
100
      Side_Effect_Finger := Side_Effect_Finger +1;
101
      Side_Effect(Side_Effect_Finger) := I.Effect;
102
      TCTouch.Touch(I.Effect);
103
    end if;
104
 
105
  end Finalize;
106
 
107
end C761007_0;
108
 
109
---------------------------------------------------------------- C761007_1
110
 
111
with C761007_0;
112
with Ada.Finalization;
113
package C761007_1 is
114
 
115
  type Container is new Ada.Finalization.Controlled
116
    with record
117
      Effect   : Character;
118
      Content  : C761007_0.Internal;
119
    end record;
120
 
121
  procedure Finalize( C: in out Container );
122
 
123
  Side_Effect : String(1..80);  -- way bigger than needed
124
  Side_Effect_Finger : Natural := 0;
125
 
126
  This_Exception_Is_Supposed_To_Be_Ignored : exception;
127
 
128
end C761007_1;
129
 
130
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
131
 
132
with TCTouch;
133
package body C761007_1 is
134
 
135
  procedure Finalize( C: in out Container ) is
136
    Previous_Side_Effect : Boolean := False;
137
  begin
138
    -- look to see if this character has been finalized yet
139
    for SEI in 1..Side_Effect_Finger loop
140
      Previous_Side_Effect := Previous_Side_Effect
141
                              or Side_Effect(Side_Effect_Finger) = C.Effect;
142
    end loop;
143
 
144
    -- if not, then tack it on to the string, and touch the character
145
    if not Previous_Side_Effect then
146
      Side_Effect_Finger := Side_Effect_Finger +1;
147
      Side_Effect(Side_Effect_Finger) := C.Effect;
148
      TCTouch.Touch(C.Effect);
149
    end if;
150
 
151
    raise This_Exception_Is_Supposed_To_Be_Ignored;
152
 
153
  end Finalize;
154
 
155
end C761007_1;
156
 
157
---------------------------------------------------------------- C761007_2
158
with C761007_1;
159
package C761007_2 is
160
 
161
  protected type Prot_W_Fin_Obj is
162
    procedure Set_Effects( Container, Filling: Character );
163
  private
164
    The_Data_Under_Test : C761007_1.Container;
165
    -- finalization for this will occur when the Prot_W_Fin_Obj object
166
    --  "goes out of existence" for whatever reason.
167
  end Prot_W_Fin_Obj;
168
 
169
end C761007_2;
170
 
171
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
172
 
173
package body C761007_2 is
174
 
175
  protected body Prot_W_Fin_Obj is
176
    procedure Set_Effects( Container, Filling: Character ) is
177
    begin
178
      The_Data_Under_Test.Effect := Container;           -- A, etc.
179
      The_Data_Under_Test.Content.Effect := Filling;     -- B, etc.
180
    end Set_Effects;
181
  end Prot_W_Fin_Obj;
182
 
183
end C761007_2;
184
 
185
------------------------------------------------------------------ C761007
186
 
187
with Report;
188
with Impdef;
189
with TCTouch;
190
with C761007_0;
191
with C761007_1;
192
with C761007_2;
193
procedure C761007 is
194
 
195
  task type Subtests( Outer, Inner : Character) is
196
    entry Ready;
197
    entry Complete;
198
  end Subtests;
199
 
200
  task body Subtests is
201
    Local_Prot_W_Fin_Obj : C761007_2.Prot_W_Fin_Obj;
202
  begin
203
    Local_Prot_W_Fin_Obj.Set_Effects( Outer, Inner );
204
 
205
    accept Ready;
206
 
207
    select
208
      accept Complete;
209
    or terminate;       -- used in Subtest 4
210
    end select;
211
  exception
212
    -- the exception caused by the finalization of Local_Prot_W_Fin_Obj
213
    --  should never be visible to this scope.
214
    when others => Report.Failed("Exception in a Subtest object "
215
                                 & Outer & Inner);
216
  end Subtests;
217
 
218
  procedure Subtest_1 is
219
    -- check the case where "nothing special" happens.
220
 
221
    This_Subtest : Subtests( 'A', 'B' );
222
  begin
223
 
224
    This_Subtest.Ready;
225
    This_Subtest.Complete;
226
 
227
    while not This_Subtest'Terminated loop -- wait for finalization
228
      delay Impdef.Clear_Ready_Queue;
229
    end loop;
230
 
231
    -- in the finalization of This_Subtest, the controlled object embedded in
232
    -- the Prot_W_Fin_Obj will finalize.  An exception is raised in the
233
    -- container object, after "touching" it's tag character.
234
    -- The finalization of the contained controlled object must be performed.
235
 
236
 
237
    TCTouch.Validate( "AB", "Item embedded in task" );
238
 
239
 
240
  exception
241
    when others => Report.Failed("Undesirable exception in Subtest_1");
242
 
243
  end Subtest_1;
244
 
245
  procedure Subtest_2 is
246
    -- check for explicit abort
247
 
248
    task Subtest_Task is
249
      entry Complete;
250
    end Subtest_Task;
251
 
252
    task body Subtest_Task is
253
 
254
      task Nesting;
255
      task body Nesting is
256
        Deep_Nesting : Subtests( 'E', 'F' );
257
      begin
258
        if Report.Ident_Bool( True ) then
259
          -- controlled objects have been created in the elaboration of
260
          -- Deep_Nesting.  Deep_Nesting must call the Set_Effects operation
261
          -- in the Prot_W_Fin_Obj, and then hang waiting for the Complete
262
          -- entry call.
263
          Deep_Nesting.Ready;
264
          abort Deep_Nesting;
265
        else
266
          Report.Failed("Dead code in Nesting");
267
        end if;
268
      exception
269
        when others => Report.Failed("Exception in Subtest_Task.Nesting");
270
      end Nesting;
271
 
272
      Local_2 : C761007_2.Prot_W_Fin_Obj;
273
 
274
    begin
275
      -- Nesting has activated at this point, which implies the activation
276
      -- of Deep_Nesting as well.
277
 
278
      Local_2.Set_Effects( 'C', 'D' );
279
 
280
      -- wait for Nesting to terminate
281
 
282
      while not Nesting'Terminated loop
283
        delay Impdef.Clear_Ready_Queue;
284
      end loop;
285
 
286
      accept Complete;
287
 
288
    exception
289
      when others => Report.Failed("Exception in Subtest_Task");
290
    end Subtest_Task;
291
 
292
  begin
293
 
294
    -- wait for everything in Subtest_Task to happen
295
    Subtest_Task.Complete;
296
 
297
    while not Subtest_Task'Terminated loop -- wait for finalization
298
      delay Impdef.Clear_Ready_Queue;
299
    end loop;
300
 
301
    TCTouch.Validate( "EFCD", "Aborted nested task" );
302
 
303
  exception
304
    when others => Report.Failed("Undesirable exception in Subtest_2");
305
  end Subtest_2;
306
 
307
  procedure Subtest_3 is
308
    -- check abort caused by asynchronous transfer of control
309
 
310
    task Subtest_3_Task is
311
      entry Complete;
312
    end Subtest_3_Task;
313
 
314
    procedure Check_Atc_Operation is
315
      Check_Atc : C761007_2.Prot_W_Fin_Obj;
316
    begin
317
 
318
      Check_Atc.Set_Effects( 'G', 'H' );
319
 
320
 
321
      while Report.Ident_Bool( True ) loop -- wait to be aborted
322
        if Report.Ident_Bool( True ) then
323
          Impdef.Exceed_Time_Slice;
324
          delay Impdef.Switch_To_New_Task;
325
        else
326
          Report.Failed("Optimization prevention");
327
        end if;
328
      end loop;
329
 
330
      Report.Failed("Check_Atc_Operation loop completed");
331
 
332
    end Check_Atc_Operation;
333
 
334
    task body Subtest_3_Task is
335
      task Nesting is
336
        entry Complete;
337
      end Nesting;
338
 
339
      task body Nesting is
340
        Nesting_3 : C761007_2.Prot_W_Fin_Obj;
341
      begin
342
        Nesting_3.Set_Effects( 'G', 'H' );
343
 
344
        -- give Check_Atc_Operation sufficient time to perform it's
345
        -- Set_Effects on it's local Prot_W_Fin_Obj object
346
        delay Impdef.Clear_Ready_Queue;
347
 
348
        accept Complete;
349
      exception
350
        when others => Report.Failed("Exception in Subtest_3_Task.Nesting");
351
      end Nesting;
352
 
353
      Local_3 : C761007_2.Prot_W_Fin_Obj;
354
 
355
    begin -- Subtest_3_Task
356
 
357
      Local_3.Set_Effects( 'I', 'J' );
358
 
359
      select
360
        Nesting.Complete;
361
      then abort ---------------------------------------------------- cause KL
362
        Check_ATC_Operation;
363
      end select;
364
 
365
      accept Complete;
366
 
367
    exception
368
      when others => Report.Failed("Exception in Subtest_3_Task");
369
    end Subtest_3_Task;
370
 
371
  begin -- Subtest_3
372
    Subtest_3_Task.Complete;
373
 
374
    while not Subtest_3_Task'Terminated loop -- wait for finalization
375
      delay Impdef.Clear_Ready_Queue;
376
    end loop;
377
 
378
    TCTouch.Validate( "GHIJ", "Asynchronously aborted operation" );
379
 
380
  exception
381
    when others => Report.Failed("Undesirable exception in Subtest_3");
382
  end Subtest_3;
383
 
384
  procedure Subtest_4 is
385
    -- check the case where transfer is caused by terminate alternative
386
    -- highly similar to Subtest_1
387
 
388
    This_Subtest : Subtests( 'M', 'N' );
389
  begin
390
 
391
    This_Subtest.Ready;
392
    -- don't call This_Subtest.Complete;
393
 
394
  exception
395
    when others => Report.Failed("Undesirable exception in Subtest_4");
396
 
397
  end Subtest_4;
398
 
399
begin  -- Main test procedure.
400
 
401
  Report.Test ("C761007", "Check that if a finalize procedure invoked by " &
402
                          "a transfer of control or selection of a " &
403
                          "terminate alternative attempts to propagate " &
404
                          "an exception, the exception is ignored, but " &
405
                          "any other finalizations due to be performed " &
406
                          "are performed" );
407
 
408
  Subtest_1;  -- checks internal
409
 
410
  Subtest_2;  -- checks internal
411
 
412
  Subtest_3;  -- checks internal
413
 
414
  Subtest_4;
415
  TCTouch.Validate( "MN", "transfer due to terminate alternative" );
416
 
417
  Report.Result;
418
 
419
end C761007;

powered by: WebSVN 2.1.0

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