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

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c7/] [c761006.a] - Blame information for rev 294

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C761006.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 Program_Error is raised when:
28
--        * an exception is raised if Finalize invoked as part of an
29
--          assignment operation; or
30
--        * an exception is raised if Adjust invoked as part of an assignment
31
--          operation, after any other adjustment due to be performed are
32
--          performed; or
33
--        * an exception is raised if Finalize invoked as part of a call on
34
--          Unchecked_Deallocation, after any other finalizations to be
35
--          performed are performed.
36
--
37
-- TEST DESCRIPTION:
38
--      This test defines these four controlled types:
39
--        Good
40
--        Bad_Initialize
41
--        Bad_Adjust
42
--        Bad_Finalize
43
--      The type name conveys the associated failure.  The operations in type
44
--      good will "touch" the boolean array indicating correct path
45
--      utilization for the purposes of checking "other  are
46
--      performed", where  ::= initialization, adjusting, and
47
--      finalization
48
--
49
--
50
--
51
-- CHANGE HISTORY:
52
--      12 APR 94   SAIC   Initial version
53
--      02 MAY 96   SAIC   Visibility fixed for 2.1
54
--      13 FEB 97   PWB.CTA Corrected value of Events_Occurring at line 286
55
--      01 DEC 97   EDS    Made correction wrt RM 7.6(21)
56
--      16 MAR 01   RLB    Corrected Adjust cases to avoid problems with
57
--                         RM 7.6.1(16/1) from Technical Corrigendum 1.
58
--
59
--!
60
 
61
------------------------------------------------------------- C761006_Support
62
 
63
package C761006_Support is
64
 
65
  type Events is ( Good_Initialize, Good_Adjust, Good_Finalize );
66
 
67
  type Event_Array is array(Events) of Boolean;
68
 
69
  Events_Occurring : Event_Array := (others => False);
70
 
71
  Propagating_Exception : exception;
72
 
73
  procedure Raise_Propagating_Exception(Do_It: Boolean);
74
 
75
  function Unique_Value return Natural;
76
 
77
end C761006_Support;
78
 
79
------------------------------------------------------------- C761006_Support
80
 
81
with Report;
82
package body C761006_Support is
83
 
84
  procedure Raise_Propagating_Exception(Do_It: Boolean) is
85
  begin
86
     if Report.Ident_Bool(Do_It) then
87
       raise Propagating_Exception;
88
     end if;
89
  end Raise_Propagating_Exception;
90
 
91
  Seed : Natural := 0;
92
 
93
  function Unique_Value return Natural is
94
  begin
95
    Seed := Seed +1;
96
    return Seed;
97
  end Unique_Value;
98
 
99
end C761006_Support;
100
 
101
------------------------------------------------------------------- C761006_0
102
 
103
with Ada.Finalization;
104
with C761006_Support;
105
package C761006_0 is
106
 
107
  type Good is new Ada.Finalization.Controlled
108
    with record
109
      Initialized : Boolean := False;
110
      Adjusted    : Boolean := False;
111
      Unique      : Natural := C761006_Support.Unique_Value;
112
    end record;
113
 
114
  procedure Initialize( It: in out Good );
115
  procedure Adjust    ( It: in out Good );
116
  procedure Finalize  ( It: in out Good );
117
 
118
  type Bad_Initialize is private;
119
 
120
  type Bad_Adjust     is private;
121
 
122
  type Bad_Finalize   is private;
123
 
124
  Inits_Order  : String(1..255);
125
  Inits_Called : Natural := 0;
126
private
127
  type Bad_Initialize is new Ada.Finalization.Controlled
128
                                             with null record;
129
  procedure Initialize( It: in out Bad_Initialize );
130
 
131
  type Bad_Adjust is new Ada.Finalization.Controlled
132
                                         with null record;
133
  procedure Adjust    ( It: in out Bad_Adjust );
134
 
135
  type Bad_Finalize is
136
       new Ada.Finalization.Controlled with null record;
137
  procedure Finalize  ( It: in out Bad_Finalize );
138
end C761006_0;
139
 
140
------------------------------------------------------------------- C761006_1
141
 
142
with Ada.Finalization;
143
with C761006_0;
144
package C761006_1 is
145
 
146
  type Init_Check_Root is new Ada.Finalization.Controlled with record
147
    Good_Component : C761006_0.Good;
148
    Init_Fails     : C761006_0.Bad_Initialize;
149
  end record;
150
 
151
  type Adj_Check_Root is new Ada.Finalization.Controlled with record
152
    Good_Component : C761006_0.Good;
153
    Adj_Fails      : C761006_0.Bad_Adjust;
154
  end record;
155
 
156
  type Fin_Check_Root is new Ada.Finalization.Controlled with record
157
    Good_Component : C761006_0.Good;
158
    Fin_Fails      : C761006_0.Bad_Finalize;
159
  end record;
160
 
161
end C761006_1;
162
 
163
------------------------------------------------------------------- C761006_2
164
 
165
with C761006_1;
166
package C761006_2 is
167
 
168
  type Init_Check is new C761006_1.Init_Check_Root with null record;
169
  type Adj_Check is  new C761006_1.Adj_Check_Root  with null record;
170
  type Fin_Check is  new C761006_1.Fin_Check_Root  with null record;
171
 
172
end C761006_2;
173
 
174
------------------------------------------------------------------- C761006_0
175
 
176
with Report;
177
with C761006_Support;
178
package body C761006_0 is
179
 
180
  package Sup renames C761006_Support;
181
 
182
  procedure Initialize( It: in out Good ) is
183
  begin
184
    Sup.Events_Occurring( Sup.Good_Initialize ) := True;
185
    It.Initialized := True;
186
  end Initialize;
187
 
188
  procedure Adjust    ( It: in out Good ) is
189
  begin
190
    Sup.Events_Occurring( Sup.Good_Adjust ) := True;
191
    It.Adjusted := True;
192
    It.Unique := C761006_Support.Unique_Value;
193
  end Adjust;
194
 
195
  procedure Finalize  ( It: in out Good ) is
196
  begin
197
    Sup.Events_Occurring( Sup.Good_Finalize ) := True;
198
  end Finalize;
199
 
200
  procedure Initialize( It: in out Bad_Initialize ) is
201
  begin
202
    Sup.Raise_Propagating_Exception(Report.Ident_Bool(True));
203
  end Initialize;
204
 
205
  procedure Adjust( It: in out Bad_Adjust ) is
206
  begin
207
    Sup.Raise_Propagating_Exception(Report.Ident_Bool(True));
208
  end Adjust;
209
 
210
  procedure Finalize( It: in out Bad_Finalize ) is
211
  begin
212
    Sup.Raise_Propagating_Exception(Report.Ident_Bool(True));
213
  end Finalize;
214
 
215
end C761006_0;
216
 
217
--------------------------------------------------------------------- C761006
218
 
219
with Report;
220
with C761006_0;
221
with C761006_2;
222
with C761006_Support;
223
with Ada.Exceptions;
224
with Ada.Finalization;
225
with Unchecked_Deallocation;
226
procedure C761006 is
227
 
228
  package Sup renames C761006_Support;
229
  use type Sup.Event_Array;
230
 
231
  type Procedure_Handle is access procedure;
232
 
233
  type Test_ID is ( Simple, Initialize, Adjust, Finalize );
234
 
235
  Sub_Tests : array(Test_ID) of Procedure_Handle;
236
 
237
  procedure Simple_Test is
238
    A_Good_Object : C761006_0.Good; -- should call Initialize
239
  begin
240
    if not A_Good_Object.Initialized then
241
      Report.Failed("Good object not initialized");
242
    end if;
243
 
244
    -- should call Adjust
245
    A_Good_Object := ( Ada.Finalization.Controlled
246
                       with Unique => 0, others => False );
247
    if not A_Good_Object.Adjusted then
248
      Report.Failed("Good object not adjusted");
249
    end if;
250
 
251
    -- should call Finalize before end of scope
252
  end Simple_Test;
253
 
254
  procedure Initialize_Test is
255
  begin
256
    declare
257
      This_Object_Fails_In_Initialize : C761006_2.Init_Check;
258
    begin
259
      Report.Failed("Exception in Initialize did not occur");
260
    exception
261
      when others =>
262
        Report.Failed("Initialize caused exception at wrong lex");
263
    end;
264
 
265
    Report.Failed("Error in execution sequence");
266
 
267
  exception
268
    when Sup.Propagating_Exception => -- this is correct
269
      if not Sup.Events_Occurring(Sup.Good_Initialize) then
270
        Report.Failed("Initialization of Good Component did not occur");
271
      end if;
272
  end Initialize_Test;
273
 
274
  procedure Adjust_Test is
275
    This_Object_OK     : C761006_2.Adj_Check;
276
    This_Object_Target : C761006_2.Adj_Check;
277
  begin
278
 
279
    Check_Adjust_Due_To_Assignment: begin
280
      This_Object_Target := This_Object_OK;
281
      Report.Failed("Adjust did not propagate any exception");
282
    exception
283
      when Program_Error =>  -- expected case
284
             if not This_Object_Target.Good_Component.Adjusted then
285
               Report.Failed("other adjustment not performed");
286
             end if;
287
      when others =>
288
             Report.Failed("Adjust propagated wrong exception");
289
    end Check_Adjust_Due_To_Assignment;
290
 
291
    C761006_Support.Events_Occurring := (True, False, False);
292
 
293
    Check_Adjust_Due_To_Initial_Assignment: declare
294
      Another_Target : C761006_2.Adj_Check := This_Object_OK;
295
    begin
296
      Report.Failed("Adjust did not propagate any exception");
297
    exception
298
      when others => Report.Failed("Adjust caused exception at wrong lex");
299
    end Check_Adjust_Due_To_Initial_Assignment;
300
 
301
  exception
302
    when Program_Error =>  -- expected case
303
           if Sup.Events_Occurring(Sup.Good_Finalize) /=
304
              Sup.Events_Occurring(Sup.Good_Adjust) then
305
              -- RM 7.6.1(16/1) says that the good Adjust may or may not
306
              -- be performed; but if it is, then the Finalize must be
307
              -- performed; and if it is not, then the Finalize must not
308
              -- performed.
309
              if Sup.Events_Occurring(Sup.Good_Finalize) then
310
                 Report.Failed("Good adjust not performed with bad adjust, " &
311
                               "but good finalize was");
312
              else
313
                 Report.Failed("Good adjust performed with bad adjust, " &
314
                               "but good finalize was not");
315
              end if;
316
           end if;
317
    when others =>
318
           Report.Failed("Adjust propagated wrong exception");
319
  end Adjust_Test;
320
 
321
  procedure Finalize_Test is
322
 
323
    Fin_Not_Perf : constant String := "other finalizations not performed";
324
 
325
    procedure Finalize_15 is
326
      Item   : C761006_2.Fin_Check;
327
      Target : C761006_2.Fin_Check;
328
    begin
329
 
330
      Item := Target;
331
      -- finalization of Item should cause PE
332
      -- ARM7.6:21 allows the implementation to omit the assignment of the
333
      -- value into an anonymous object, which is the point at which Adjust
334
      -- is normally called.  However, this would result in Program_Error's
335
      -- being raised before the call to Adjust, with the consequence that
336
      -- Adjust is never called.
337
 
338
    exception
339
      when Program_Error => -- expected case
340
             if not Sup.Events_Occurring(Sup.Good_Finalize) then
341
               Report.Failed("Assignment: " & Fin_Not_Perf);
342
             end if;
343
      when others =>
344
             Report.Failed("Other exception in Finalize_15");
345
 
346
    -- finalization of Item/Target should cause PE
347
    end Finalize_15;
348
 
349
  -- check failure in finalize due to Unchecked_Deallocation
350
 
351
  type Shark is access C761006_2.Fin_Check;
352
 
353
  procedure Catch is
354
    new Unchecked_Deallocation( C761006_2.Fin_Check, Shark );
355
 
356
  procedure Finalize_17 is
357
    White : Shark := new C761006_2.Fin_Check;
358
  begin
359
    Catch( White );
360
  exception
361
    when Program_Error =>
362
           if not Sup.Events_Occurring(Sup.Good_Finalize) then
363
             Report.Failed("Unchecked_Deallocation: " & Fin_Not_Perf);
364
           end if;
365
  end Finalize_17;
366
 
367
  begin
368
 
369
    Exception_In_Finalization: begin
370
      Finalize_15;
371
    exception
372
      when Program_Error => null; -- anticipated
373
    end Exception_In_Finalization;
374
 
375
    Use_Of_Unchecked_Deallocation: begin
376
      Finalize_17;
377
    exception
378
      when others =>
379
        Report.Failed("Unchecked_Deallocation check, unwanted exception");
380
    end Use_Of_Unchecked_Deallocation;
381
 
382
  end Finalize_Test;
383
 
384
begin  -- Main test procedure.
385
 
386
  Report.Test ("C761006", "Check that exceptions raised in Initialize, " &
387
                          "Adjust and Finalize are processed correctly" );
388
 
389
  Sub_Tests := (Simple_Test'Access, Initialize_Test'Access,
390
                Adjust_Test'Access, Finalize_Test'Access);
391
 
392
  for Test in Sub_Tests'Range loop
393
    begin
394
 
395
      Sup.Events_Occurring := (others => False);
396
 
397
      Sub_Tests(Test).all;
398
 
399
      case Test is
400
        when Simple | Adjust =>
401
          if Sup.Events_Occurring /= Sup.Event_Array ' ( others => True ) then
402
            Report.Failed ( "Other operation missing in " &
403
                            Test_ID'Image ( Test ) );
404
          end if;
405
        when  Initialize =>
406
          null;
407
        when Finalize  =>
408
          -- Note that for Good_Adjust, we may get either True or False
409
          if Sup.Events_Occurring ( Sup.Good_Initialize ) = False or
410
             Sup.Events_Occurring ( Sup.Good_Finalize ) = False
411
          then
412
            Report.Failed ( "Other operation missing in " &
413
                            Test_ID'Image ( Test ) );
414
          end if;
415
      end case;
416
 
417
    exception
418
       when How: others => Report.Failed( Ada.Exceptions.Exception_Name( How )
419
                                        & " from " & Test_ID'Image( Test ) );
420
    end;
421
  end loop;
422
 
423
  Report.Result;
424
 
425
end C761006;

powered by: WebSVN 2.1.0

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