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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- C760010.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 explicit calls to Initialize, Adjust and Finalize
28
--      procedures that raise exceptions propagate the exception raised,
29
--      not Program_Error.  Check this for both a user defined exception
30
--      and a language defined exception.  Check that implicit calls to
31
--      initialize procedures that raise an exception propagate the
32
--      exception raised, not Program_Error;
33
--
34
--      Check that the utilization of a controlled type as the actual for
35
--      a generic formal tagged private parameter supports the correct
36
--      behavior in the instantiated software.
37
--
38
-- TEST DESCRIPTION:
39
--      Declares a generic package instantiated to check that controlled
40
--      types are not impacted by the "generic boundary."
41
--      This instance is then used to perform the tests of various calls to
42
--      the procedures.  After each operation in the main program that should
43
--      cause implicit calls where an exception is raised, the program handles
44
--      Program_Error.  After each explicit call, the program handles the
45
--      Expected_Error.  Handlers for the opposite exception are provided to
46
--      catch the obvious failure modes.  The predefined exception
47
--      Tasking_Error is used to be certain that some other reason has not
48
--      raised a predefined exception.
49
--
50
--
51
-- DATA STRUCTURES
52
--
53
--      C760010_1.Simple_Control is derived from
54
--        Ada.Finalization.Controlled
55
--
56
--      C760010_2.Embedded_Derived is derived from C760010_1.Simple_Control
57
--        by way of generic instantiation
58
--
59
--
60
-- CHANGE HISTORY:
61
--      01 MAY 95   SAIC    Initial version
62
--      23 APR 96   SAIC    Fix visibility problem for 2.1
63
--      14 NOV 96   SAIC    Revisit for 2.1 release
64
--      26 JUN 98   EDS     Added pragma Elaborate_Body to
65
--                          package C760010_0.Check_Formal_Tagged
66
--                          to avoid possible instantiation error
67
--!
68
 
69
---------------------------------------------------------------- C760010_0
70
 
71
package C760010_0 is
72
 
73
  User_Defined_Exception : exception;
74
 
75
  type Actions is ( No_Action,
76
                    Init_Raise_User_Defined, Init_Raise_Standard,
77
                    Adj_Raise_User_Defined,  Adj_Raise_Standard,
78
                    Fin_Raise_User_Defined,  Fin_Raise_Standard );
79
 
80
  Action : Actions := No_Action;
81
 
82
  function Unique return Natural;
83
 
84
end C760010_0;
85
 
86
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
87
 
88
package body C760010_0 is
89
 
90
  Value : Natural := 101;
91
 
92
  function Unique return Natural is
93
  begin
94
    Value := Value +1;
95
    return Value;
96
  end Unique;
97
 
98
end C760010_0;
99
 
100
---------------------------------------------------------------- C760010_0
101
------------------------------------------------------ Check_Formal_Tagged
102
 
103
generic
104
 
105
  type Formal_Tagged is tagged private;
106
 
107
package C760010_0.Check_Formal_Tagged is
108
 
109
  pragma Elaborate_Body;
110
 
111
  type Embedded_Derived is new Formal_Tagged with record
112
    TC_Meaningless_Value : Natural := Unique;
113
  end record;
114
 
115
  procedure Initialize( ED: in out Embedded_Derived );
116
  procedure Adjust    ( ED: in out Embedded_Derived );
117
  procedure Finalize  ( ED: in out Embedded_Derived );
118
 
119
end C760010_0.Check_Formal_Tagged;
120
 
121
 
122
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
123
 
124
with Report;
125
package body C760010_0.Check_Formal_Tagged is
126
 
127
 
128
  procedure Initialize( ED: in out Embedded_Derived ) is
129
  begin
130
    ED.TC_Meaningless_Value := Unique;
131
    case Action is
132
      when Init_Raise_User_Defined => raise User_Defined_Exception;
133
      when Init_Raise_Standard     => raise Tasking_Error;
134
      when others                  => null;
135
    end case;
136
  end Initialize;
137
 
138
  procedure Adjust    ( ED: in out Embedded_Derived ) is
139
  begin
140
    ED.TC_Meaningless_Value := Unique;
141
    case Action is
142
      when Adj_Raise_User_Defined => raise User_Defined_Exception;
143
      when Adj_Raise_Standard     => raise Tasking_Error;
144
      when others                 => null;
145
    end case;
146
  end Adjust;
147
 
148
  procedure Finalize  ( ED: in out Embedded_Derived ) is
149
  begin
150
    ED.TC_Meaningless_Value := Unique;
151
    case Action is
152
      when Fin_Raise_User_Defined => raise User_Defined_Exception;
153
      when Fin_Raise_Standard     => raise Tasking_Error;
154
      when others                 => null;
155
    end case;
156
  end Finalize;
157
 
158
end C760010_0.Check_Formal_Tagged;
159
 
160
---------------------------------------------------------------- C760010_1
161
 
162
with Ada.Finalization;
163
package C760010_1 is
164
 
165
  procedure Check_Counters(Init,Adj,Fin : Natural; Message: String);
166
  procedure Reset_Counters;
167
 
168
  type Simple_Control is new Ada.Finalization.Controlled with record
169
    Item: Integer;
170
  end record;
171
  procedure Initialize( AV: in out Simple_Control );
172
  procedure Adjust    ( AV: in out Simple_Control );
173
  procedure Finalize  ( AV: in out Simple_Control );
174
 
175
end C760010_1;
176
 
177
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
178
 
179
with Report;
180
package body C760010_1 is
181
 
182
  Initialize_Called : Natural;
183
  Adjust_Called     : Natural;
184
  Finalize_Called   : Natural;
185
 
186
  procedure Check_Counters(Init,Adj,Fin : Natural; Message: String) is
187
  begin
188
    if Init /= Initialize_Called then
189
      Report.Failed("Initialize mismatch " & Message);
190
    end if;
191
    if Adj /= Adjust_Called then
192
      Report.Failed("Adjust mismatch " & Message);
193
    end if;
194
    if Fin /= Finalize_Called then
195
      Report.Failed("Finalize mismatch " & Message);
196
    end if;
197
  end Check_Counters;
198
 
199
  procedure Reset_Counters is
200
  begin
201
    Initialize_Called := 0;
202
    Adjust_Called     := 0;
203
    Finalize_Called   := 0;
204
  end Reset_Counters;
205
 
206
  procedure Initialize( AV: in out Simple_Control ) is
207
  begin
208
    Initialize_Called := Initialize_Called +1;
209
    AV.Item := 0;
210
  end Initialize;
211
 
212
  procedure Adjust    ( AV: in out Simple_Control ) is
213
  begin
214
    Adjust_Called := Adjust_Called +1;
215
    AV.Item := AV.Item +1;
216
  end Adjust;
217
 
218
  procedure Finalize  ( AV: in out Simple_Control ) is
219
  begin
220
    Finalize_Called := Finalize_Called +1;
221
    AV.Item := AV.Item +1;
222
  end Finalize;
223
 
224
end C760010_1;
225
 
226
---------------------------------------------------------------- C760010_2
227
 
228
with C760010_0.Check_Formal_Tagged;
229
with C760010_1;
230
package C760010_2 is
231
  new C760010_0.Check_Formal_Tagged(C760010_1.Simple_Control);
232
 
233
---------------------------------------------------------------------------
234
 
235
with Report;
236
with C760010_0;
237
with C760010_1;
238
with C760010_2;
239
procedure C760010 is
240
 
241
  use type C760010_0.Actions;
242
 
243
  procedure Case_Failure(Message: String) is
244
  begin
245
    Report.Failed(Message & " for case "
246
                  & C760010_0.Actions'Image(C760010_0.Action) );
247
  end Case_Failure;
248
 
249
  procedure Check_Implicit_Initialize is
250
    Item   : C760010_2.Embedded_Derived;  -- exception here propagates to
251
    Gadget : C760010_2.Embedded_Derived;  -- caller
252
  begin
253
    if C760010_0.Action
254
       in C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard
255
    then
256
      Case_Failure("Anticipated exception at implicit init");
257
    end if;
258
    begin
259
      Item := Gadget;                     -- exception here handled locally
260
      if C760010_0.Action in C760010_0.Adj_Raise_User_Defined
261
                                   .. C760010_0.Fin_Raise_Standard then
262
        Case_Failure ("Anticipated exception at assignment");
263
      end if;
264
    exception
265
      when Program_Error =>
266
        if C760010_0.Action not in C760010_0.Adj_Raise_User_Defined
267
                                   .. C760010_0.Fin_Raise_Standard then
268
          Report.Failed("Program_Error in Check_Implicit_Initialize");
269
        end if;
270
      when Tasking_Error =>
271
        Report.Failed("Tasking_Error in Check_Implicit_Initialize");
272
      when C760010_0.User_Defined_Exception =>
273
        Report.Failed("User_Error in Check_Implicit_Initialize");
274
      when others =>
275
        Report.Failed("Wrong exception Check_Implicit_Initialize");
276
    end;
277
  end Check_Implicit_Initialize;
278
 
279
---------------------------------------------------------------------------
280
 
281
  Global_Item : C760010_2.Embedded_Derived;
282
 
283
---------------------------------------------------------------------------
284
 
285
  procedure Check_Explicit_Initialize is
286
  begin
287
    begin
288
      C760010_2.Initialize( Global_Item );
289
    if C760010_0.Action
290
       in C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard
291
    then
292
      Case_Failure("Anticipated exception at explicit init");
293
    end if;
294
    exception
295
      when Program_Error =>
296
        Report.Failed("Program_Error in Check_Explicit_Initialize");
297
      when Tasking_Error =>
298
        if C760010_0.Action /= C760010_0.Init_Raise_Standard then
299
          Report.Failed("Tasking_Error in Check_Explicit_Initialize");
300
        end if;
301
      when C760010_0.User_Defined_Exception =>
302
        if C760010_0.Action /= C760010_0.Init_Raise_User_Defined then
303
          Report.Failed("User_Error in Check_Explicit_Initialize");
304
        end if;
305
      when others =>
306
        Report.Failed("Wrong exception in Check_Explicit_Initialize");
307
    end;
308
  end Check_Explicit_Initialize;
309
 
310
---------------------------------------------------------------------------
311
 
312
  procedure Check_Explicit_Adjust is
313
  begin
314
    begin
315
      C760010_2.Adjust( Global_Item );
316
    if C760010_0.Action
317
       in C760010_0.Adj_Raise_User_Defined..C760010_0.Adj_Raise_Standard
318
    then
319
      Case_Failure("Anticipated exception at explicit Adjust");
320
    end if;
321
    exception
322
      when Program_Error =>
323
        Report.Failed("Program_Error in Check_Explicit_Adjust");
324
      when Tasking_Error =>
325
        if C760010_0.Action /= C760010_0.Adj_Raise_Standard then
326
          Report.Failed("Tasking_Error in Check_Explicit_Adjust");
327
        end if;
328
      when C760010_0.User_Defined_Exception =>
329
        if C760010_0.Action /= C760010_0.Adj_Raise_User_Defined then
330
          Report.Failed("User_Error in Check_Explicit_Adjust");
331
        end if;
332
      when others =>
333
        Report.Failed("Wrong exception in Check_Explicit_Adjust");
334
    end;
335
  end Check_Explicit_Adjust;
336
 
337
---------------------------------------------------------------------------
338
 
339
  procedure Check_Explicit_Finalize is
340
  begin
341
    begin
342
      C760010_2.Finalize( Global_Item );
343
    if C760010_0.Action
344
       in C760010_0.Fin_Raise_User_Defined..C760010_0.Fin_Raise_Standard
345
    then
346
      Case_Failure("Anticipated exception at explicit Finalize");
347
    end if;
348
    exception
349
      when Program_Error =>
350
        Report.Failed("Program_Error in Check_Explicit_Finalize");
351
      when Tasking_Error =>
352
        if C760010_0.Action /= C760010_0.Fin_Raise_Standard then
353
          Report.Failed("Tasking_Error in Check_Explicit_Finalize");
354
        end if;
355
      when C760010_0.User_Defined_Exception =>
356
        if C760010_0.Action /= C760010_0.Fin_Raise_User_Defined then
357
          Report.Failed("User_Error in Check_Explicit_Finalize");
358
        end if;
359
      when others =>
360
        Report.Failed("Wrong exception in Check_Explicit_Finalize");
361
    end;
362
  end Check_Explicit_Finalize;
363
 
364
---------------------------------------------------------------------------
365
 
366
begin  -- Main test procedure.
367
 
368
  Report.Test ("C760010", "Check that explicit calls to finalization " &
369
                          "procedures that raise exceptions propagate " &
370
                          "the exception raised.  Check the utilization " &
371
                          "of a controlled type as the actual for a " &
372
                          "generic formal tagged private parameter" );
373
 
374
  for Act in C760010_0.Actions loop
375
    C760010_1.Reset_Counters;
376
    C760010_0.Action := Act;
377
 
378
    begin
379
      Check_Implicit_Initialize;
380
      if Act in
381
         C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard then
382
        Case_Failure("No exception at Check_Implicit_Initialize");
383
      end if;
384
    exception
385
      when Tasking_Error =>
386
        if Act /= C760010_0.Init_Raise_Standard then
387
          Case_Failure("Tasking_Error at Check_Implicit_Initialize");
388
        end if;
389
      when C760010_0.User_Defined_Exception =>
390
        if Act /= C760010_0.Init_Raise_User_Defined then
391
          Case_Failure("User_Error at Check_Implicit_Initialize");
392
        end if;
393
      when Program_Error =>
394
         -- If finalize raises an exception, all other object are finalized
395
         -- first and Program_Error is raised upon leaving the master scope.
396
         -- 7.6.1:14
397
         if Act not in C760010_0.Fin_Raise_User_Defined..
398
                       C760010_0.Fin_Raise_Standard then
399
            Case_Failure("Program_Error at Check_Implicit_Initialize");
400
         end if;
401
      when others =>
402
        Case_Failure("Wrong exception at Check_Implicit_Initialize");
403
    end;
404
 
405
    Check_Explicit_Initialize;
406
    Check_Explicit_Adjust;
407
    Check_Explicit_Finalize;
408
 
409
    C760010_1.Check_Counters(0,0,0, C760010_0.Actions'Image(Act));
410
 
411
  end loop;
412
 
413
  -- Set to No_Action to avoid exception in finalizing Global_Item
414
  C760010_0.Action := C760010_0.No_Action;
415
 
416
  Report.Result;
417
 
418
end C760010;

powered by: WebSVN 2.1.0

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