summaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/c7/c760010.a
blob: 08fe62b9fa48567e393e8951f9603db4178b0356 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
-- C760010.A
--
--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
--     this public release, the Government intends to confer upon all 
--     recipients unlimited rights  equal to those held by the Government.  
--     These rights include rights to use, duplicate, release or disclose the 
--     released technical data and computer software in whole or in part, in 
--     any manner and for any purpose whatsoever, and to have or permit others 
--     to do so.
--
--                                    DISCLAIMER
--
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--     PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
--      Check that explicit calls to Initialize, Adjust and Finalize
--      procedures that raise exceptions propagate the exception raised,
--      not Program_Error.  Check this for both a user defined exception
--      and a language defined exception.  Check that implicit calls to
--      initialize procedures that raise an exception propagate the
--      exception raised, not Program_Error;
--
--      Check that the utilization of a controlled type as the actual for
--      a generic formal tagged private parameter supports the correct
--      behavior in the instantiated software.
--
-- TEST DESCRIPTION:
--      Declares a generic package instantiated to check that controlled
--      types are not impacted by the "generic boundary."
--      This instance is then used to perform the tests of various calls to
--      the procedures.  After each operation in the main program that should
--      cause implicit calls where an exception is raised, the program handles
--      Program_Error.  After each explicit call, the program handles the
--      Expected_Error.  Handlers for the opposite exception are provided to
--      catch the obvious failure modes.  The predefined exception
--      Tasking_Error is used to be certain that some other reason has not
--      raised a predefined exception.
--
--     
-- DATA STRUCTURES
--
--      C760010_1.Simple_Control is derived from
--        Ada.Finalization.Controlled
--
--      C760010_2.Embedded_Derived is derived from C760010_1.Simple_Control
--        by way of generic instantiation
--
--
-- CHANGE HISTORY:
--      01 MAY 95   SAIC    Initial version
--      23 APR 96   SAIC    Fix visibility problem for 2.1
--      14 NOV 96   SAIC    Revisit for 2.1 release
--      26 JUN 98   EDS     Added pragma Elaborate_Body to
--                          package C760010_0.Check_Formal_Tagged
--                          to avoid possible instantiation error
--!

---------------------------------------------------------------- C760010_0

package C760010_0 is

  User_Defined_Exception : exception;

  type Actions is ( No_Action,
                    Init_Raise_User_Defined, Init_Raise_Standard,
                    Adj_Raise_User_Defined,  Adj_Raise_Standard,
                    Fin_Raise_User_Defined,  Fin_Raise_Standard );

  Action : Actions := No_Action;

  function Unique return Natural;

end C760010_0;

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

package body C760010_0 is

  Value : Natural := 101;

  function Unique return Natural is
  begin
    Value := Value +1;
    return Value;
  end Unique;

end C760010_0;

---------------------------------------------------------------- C760010_0
------------------------------------------------------ Check_Formal_Tagged

generic

  type Formal_Tagged is tagged private;

package C760010_0.Check_Formal_Tagged is

  pragma Elaborate_Body;

  type Embedded_Derived is new Formal_Tagged with record
    TC_Meaningless_Value : Natural := Unique;
  end record;

  procedure Initialize( ED: in out Embedded_Derived );
  procedure Adjust    ( ED: in out Embedded_Derived );
  procedure Finalize  ( ED: in out Embedded_Derived );

end C760010_0.Check_Formal_Tagged;


-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

with Report;
package body C760010_0.Check_Formal_Tagged is


  procedure Initialize( ED: in out Embedded_Derived ) is
  begin
    ED.TC_Meaningless_Value := Unique;
    case Action is
      when Init_Raise_User_Defined => raise User_Defined_Exception;
      when Init_Raise_Standard     => raise Tasking_Error;
      when others                  => null;
    end case;
  end Initialize;

  procedure Adjust    ( ED: in out Embedded_Derived ) is
  begin
    ED.TC_Meaningless_Value := Unique;
    case Action is
      when Adj_Raise_User_Defined => raise User_Defined_Exception;
      when Adj_Raise_Standard     => raise Tasking_Error;
      when others                 => null;
    end case;
  end Adjust;

  procedure Finalize  ( ED: in out Embedded_Derived ) is
  begin
    ED.TC_Meaningless_Value := Unique;
    case Action is
      when Fin_Raise_User_Defined => raise User_Defined_Exception;
      when Fin_Raise_Standard     => raise Tasking_Error;
      when others                 => null;
    end case;
  end Finalize;

end C760010_0.Check_Formal_Tagged;
 
---------------------------------------------------------------- C760010_1

with Ada.Finalization;
package C760010_1 is

  procedure Check_Counters(Init,Adj,Fin : Natural; Message: String);
  procedure Reset_Counters;

  type Simple_Control is new Ada.Finalization.Controlled with record
    Item: Integer;
  end record;
  procedure Initialize( AV: in out Simple_Control );
  procedure Adjust    ( AV: in out Simple_Control );
  procedure Finalize  ( AV: in out Simple_Control );

end C760010_1;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

with Report;
package body C760010_1 is

  Initialize_Called : Natural;
  Adjust_Called     : Natural;
  Finalize_Called   : Natural;

  procedure Check_Counters(Init,Adj,Fin : Natural; Message: String) is
  begin
    if Init /= Initialize_Called then
      Report.Failed("Initialize mismatch " & Message);
    end if;
    if Adj /= Adjust_Called then
      Report.Failed("Adjust mismatch " & Message);
    end if;
    if Fin /= Finalize_Called then
      Report.Failed("Finalize mismatch " & Message);
    end if;
  end Check_Counters;

  procedure Reset_Counters is
  begin
    Initialize_Called := 0;
    Adjust_Called     := 0;
    Finalize_Called   := 0;
  end Reset_Counters;

  procedure Initialize( AV: in out Simple_Control ) is
  begin
    Initialize_Called := Initialize_Called +1;
    AV.Item := 0;
  end Initialize;

  procedure Adjust    ( AV: in out Simple_Control ) is
  begin
    Adjust_Called := Adjust_Called +1;
    AV.Item := AV.Item +1;
  end Adjust;

  procedure Finalize  ( AV: in out Simple_Control ) is
  begin
    Finalize_Called := Finalize_Called +1;
    AV.Item := AV.Item +1;
  end Finalize;

end C760010_1;
 
---------------------------------------------------------------- C760010_2

with C760010_0.Check_Formal_Tagged;
with C760010_1;
package C760010_2 is
  new C760010_0.Check_Formal_Tagged(C760010_1.Simple_Control);
 
---------------------------------------------------------------------------

with Report;
with C760010_0;
with C760010_1;
with C760010_2;
procedure C760010 is

  use type C760010_0.Actions;

  procedure Case_Failure(Message: String) is
  begin
    Report.Failed(Message & " for case "
                  & C760010_0.Actions'Image(C760010_0.Action) );
  end Case_Failure;

  procedure Check_Implicit_Initialize is
    Item   : C760010_2.Embedded_Derived;  -- exception here propagates to
    Gadget : C760010_2.Embedded_Derived;  -- caller
  begin
    if C760010_0.Action
       in C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard
    then
      Case_Failure("Anticipated exception at implicit init");
    end if;
    begin
      Item := Gadget;                     -- exception here handled locally
      if C760010_0.Action in C760010_0.Adj_Raise_User_Defined
                                   .. C760010_0.Fin_Raise_Standard then
        Case_Failure ("Anticipated exception at assignment");
      end if;
    exception
      when Program_Error =>
        if C760010_0.Action not in C760010_0.Adj_Raise_User_Defined
                                   .. C760010_0.Fin_Raise_Standard then
          Report.Failed("Program_Error in Check_Implicit_Initialize");
        end if;
      when Tasking_Error =>
        Report.Failed("Tasking_Error in Check_Implicit_Initialize");
      when C760010_0.User_Defined_Exception =>
        Report.Failed("User_Error in Check_Implicit_Initialize");
      when others =>
        Report.Failed("Wrong exception Check_Implicit_Initialize");
    end;
  end Check_Implicit_Initialize;

---------------------------------------------------------------------------

  Global_Item : C760010_2.Embedded_Derived;

---------------------------------------------------------------------------

  procedure Check_Explicit_Initialize is
  begin
    begin
      C760010_2.Initialize( Global_Item );
    if C760010_0.Action
       in C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard
    then
      Case_Failure("Anticipated exception at explicit init");
    end if;
    exception
      when Program_Error =>
        Report.Failed("Program_Error in Check_Explicit_Initialize");
      when Tasking_Error =>
        if C760010_0.Action /= C760010_0.Init_Raise_Standard then
          Report.Failed("Tasking_Error in Check_Explicit_Initialize");
        end if;
      when C760010_0.User_Defined_Exception =>
        if C760010_0.Action /= C760010_0.Init_Raise_User_Defined then
          Report.Failed("User_Error in Check_Explicit_Initialize");
        end if;
      when others =>
        Report.Failed("Wrong exception in Check_Explicit_Initialize");
    end;
  end Check_Explicit_Initialize;

---------------------------------------------------------------------------

  procedure Check_Explicit_Adjust is
  begin
    begin
      C760010_2.Adjust( Global_Item );
    if C760010_0.Action
       in C760010_0.Adj_Raise_User_Defined..C760010_0.Adj_Raise_Standard
    then
      Case_Failure("Anticipated exception at explicit Adjust");
    end if;
    exception
      when Program_Error =>
        Report.Failed("Program_Error in Check_Explicit_Adjust");
      when Tasking_Error =>
        if C760010_0.Action /= C760010_0.Adj_Raise_Standard then
          Report.Failed("Tasking_Error in Check_Explicit_Adjust");
        end if;
      when C760010_0.User_Defined_Exception =>
        if C760010_0.Action /= C760010_0.Adj_Raise_User_Defined then
          Report.Failed("User_Error in Check_Explicit_Adjust");
        end if;
      when others =>
        Report.Failed("Wrong exception in Check_Explicit_Adjust");
    end;
  end Check_Explicit_Adjust;

---------------------------------------------------------------------------

  procedure Check_Explicit_Finalize is
  begin
    begin
      C760010_2.Finalize( Global_Item );
    if C760010_0.Action
       in C760010_0.Fin_Raise_User_Defined..C760010_0.Fin_Raise_Standard
    then
      Case_Failure("Anticipated exception at explicit Finalize");
    end if;
    exception
      when Program_Error =>
        Report.Failed("Program_Error in Check_Explicit_Finalize");
      when Tasking_Error =>
        if C760010_0.Action /= C760010_0.Fin_Raise_Standard then
          Report.Failed("Tasking_Error in Check_Explicit_Finalize");
        end if;
      when C760010_0.User_Defined_Exception =>
        if C760010_0.Action /= C760010_0.Fin_Raise_User_Defined then
          Report.Failed("User_Error in Check_Explicit_Finalize");
        end if;
      when others =>
        Report.Failed("Wrong exception in Check_Explicit_Finalize");
    end;
  end Check_Explicit_Finalize;

---------------------------------------------------------------------------

begin  -- Main test procedure.

  Report.Test ("C760010", "Check that explicit calls to finalization " &
                          "procedures that raise exceptions propagate " &
                          "the exception raised.  Check the utilization " &
                          "of a controlled type as the actual for a " &
                          "generic formal tagged private parameter" );

  for Act in C760010_0.Actions loop
    C760010_1.Reset_Counters;
    C760010_0.Action := Act;

    begin
      Check_Implicit_Initialize;
      if Act in
         C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard then
        Case_Failure("No exception at Check_Implicit_Initialize");
      end if;
    exception
      when Tasking_Error =>
        if Act /= C760010_0.Init_Raise_Standard then
          Case_Failure("Tasking_Error at Check_Implicit_Initialize");
        end if;
      when C760010_0.User_Defined_Exception =>
        if Act /= C760010_0.Init_Raise_User_Defined then
          Case_Failure("User_Error at Check_Implicit_Initialize");
        end if;
      when Program_Error =>
         -- If finalize raises an exception, all other object are finalized
         -- first and Program_Error is raised upon leaving the master scope.
         -- 7.6.1:14
         if Act not in C760010_0.Fin_Raise_User_Defined..
                       C760010_0.Fin_Raise_Standard then
            Case_Failure("Program_Error at Check_Implicit_Initialize");
         end if;
      when others =>
        Case_Failure("Wrong exception at Check_Implicit_Initialize");
    end;

    Check_Explicit_Initialize;
    Check_Explicit_Adjust;
    Check_Explicit_Finalize;

    C760010_1.Check_Counters(0,0,0, C760010_0.Actions'Image(Act));

  end loop;

  -- Set to No_Action to avoid exception in finalizing Global_Item
  C760010_0.Action := C760010_0.No_Action;

  Report.Result;

end C760010;