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/] [c7/] [c761002.a] - Blame information for rev 816

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 149 jeremybenn
-- C761002.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 objects of a controlled type that are created
28
--      by an allocator are finalized at the appropriate time.  In
29
--      particular, check that such objects are not finalized due to
30
--      completion of the master in which they were allocated if the
31
--      corresponding access type is declared outside of that master.
32
--
33
--      Check that Unchecked_Deallocation of a controlled
34
--      object causes finalization of that object.
35
--
36
-- TEST DESCRIPTION:
37
--      This test derives a type from Ada.Finalization.Controlled, and
38
--      declares access types to that type in various scope scenarios.
39
--      The dispatching procedure Finalize is redefined for the derived
40
--      type to perform a check that it has been called at the
41
--      correct time.  This is accomplished using a global variable
42
--      which indicates what state the software is currently
43
--      executing.  The test utilizes the TCTouch facilities to
44
--      verify that Finalize is called the correct number of times, at
45
--      the correct times.  Several calls are made to validate passing
46
--      the null string to check that Finalize has NOT been called at
47
--      that point.
48
--
49
--
50
-- CHANGE HISTORY:
51
--      06 Dec 94   SAIC    ACVC 2.0
52
--
53
--!
54
 
55
with Ada.Finalization;
56
package C761002_0 is
57
  type Global is new Ada.Finalization.Controlled with null record;
58
  procedure Finalize( It: in out Global );
59
 
60
  type Second is new Ada.Finalization.Limited_Controlled with null record;
61
  procedure Finalize( It: in out Second );
62
end C761002_0;
63
 
64
with Report;
65
with TCTouch;
66
package body C761002_0 is
67
 
68
  procedure Finalize( It: in out Global ) is
69
  begin
70
    TCTouch.Touch('F');  ------------------------------------------------- F
71
  end Finalize;
72
 
73
  procedure Finalize( It: in out Second ) is
74
  begin
75
    TCTouch.Touch('S');  ------------------------------------------------- S
76
  end Finalize;
77
end C761002_0;
78
 
79
with Report;
80
with TCTouch;
81
with C761002_0;
82
with Unchecked_Deallocation;
83
procedure C761002 is
84
 
85
  -- check the straightforward case
86
  procedure Subtest_1 is
87
    type Access_1 is access C761002_0.Global;
88
    V1 : Access_1;
89
    procedure Allocate is
90
      V2 : Access_1;
91
    begin
92
      V2 := new C761002_0.Global;
93
      V1 := V2;  -- "dead" assignment must not be optimized away due to
94
                 -- finalization "side effects", many more of these follow
95
    end Allocate;
96
  begin
97
    Allocate;
98
    -- no calls to Finalize should have occurred at this point
99
    TCTouch.Validate("","Allocated nested, retained");
100
  end Subtest_1;
101
 
102
  -- check Unchecked_Deallocation
103
  procedure Subtest_2 is
104
    type Access_2 is access C761002_0.Global;
105
    procedure Free is
106
              new Unchecked_Deallocation(C761002_0.Global, Access_2);
107
    V1 : Access_2;
108
    V2 : Access_2;
109
 
110
    procedure Allocate is
111
    begin
112
      V1 := new C761002_0.Global;
113
      V2 := new C761002_0.Global;
114
    end Allocate;
115
 
116
  begin
117
    Allocate;
118
    -- no calls to Finalize should have occurred at this point.
119
    TCTouch.Validate("","Allocated nested, non-local");
120
 
121
    Free(V1); -- instance of Unchecked_Deallocation
122
    -- should cause the finalization of V1.all
123
    TCTouch.Validate("F","Unchecked Deallocation");
124
  end Subtest_2; -- leaving this scope should cause the finalization of V2.all
125
 
126
  -- check various master-exit scenarios
127
  -- the "Fake" parameters are used to avoid unwanted optimizations
128
  procedure Subtest_3 is
129
    procedure With_Local_Block is
130
      type Access_3 is access C761002_0.Global;
131
      V1 : Access_3;
132
    begin
133
      declare
134
        V2 : Access_3 := new C761002_0.Global;
135
      begin
136
        V1 := V2;
137
      end;
138
      TCTouch.Validate("","Local Block, normal exit");
139
      -- the allocated object should be finalized on leaving this scope
140
    end With_Local_Block;
141
 
142
    procedure With_Local_Block_Return(Fake: Integer) is
143
      type Access_4 is access C761002_0.Global;
144
      V1 : Access_4 := new C761002_0.Global;
145
    begin
146
      if Fake = 0 then
147
        declare
148
          V2 : Access_4;
149
        begin
150
          V2 := new C761002_0.Global;
151
          return; -- the two allocated objects should be finalized
152
        end;      -- upon leaving this scope
153
      else
154
        V1 := null;
155
      end if;
156
    end With_Local_Block_Return;
157
 
158
    procedure With_Goto(Fake: Integer) is
159
      type Access_5 is access C761002_0.Global;
160
      V1 : Access_5 := new C761002_0.Global;
161
      V2 : Access_5;
162
      V3 : Access_5;
163
    begin
164
      if Fake = 0 then
165
        declare
166
          type Access_6 is access C761002_0.Second;
167
          V6 : Access_6;
168
        begin
169
          V6 := new C761002_0.Second;
170
          goto check;
171
        end;
172
      else
173
        V2 := V1;
174
      end if;
175
      V3 := V2;
176
<>
177
      TCTouch.Validate("S","goto past master end");
178
     end With_Goto;
179
 
180
  begin
181
    With_Local_Block;
182
    TCTouch.Validate("F","Local Block, normal exit, after master");
183
 
184
    With_Local_Block_Return( Report.Ident_Int(0) );
185
    TCTouch.Validate("FF","Local Block, return from block");
186
 
187
    With_Goto( Report.Ident_Int(0) );
188
    TCTouch.Validate("F","With Goto");
189
 
190
  end Subtest_3;
191
 
192
  procedure Subtest_4 is
193
 
194
    Oops : exception;
195
 
196
    procedure Alley( Fake: Integer ) is
197
      type Access_1 is access C761002_0.Global;
198
      V1 : Access_1;
199
    begin
200
      V1 := new C761002_0.Global;
201
      if Fake = 1 then
202
        raise Oops;
203
      end if;
204
      V1 := null;
205
    end Alley;
206
 
207
  begin
208
    Catch: begin
209
      Alley( Report.Ident_Int(1) );
210
    exception
211
      when Oops   => TCTouch.Validate("F","leaving via exception");
212
      when others => Report.Failed("Wrong exception");
213
    end Catch;
214
  end Subtest_4;
215
 
216
begin  -- Main test procedure.
217
 
218
  Report.Test ("C761002", "Check that objects of a controlled type created "
219
                        & "by an allocator are finalized appropriately. "
220
                        & "Check that Unchecked_Deallocation of a "
221
                        & "controlled object causes finalization "
222
                        & "of that object" );
223
 
224
  Subtest_1;
225
  -- leaving the scope of the access type should finalize the
226
  -- collection
227
  TCTouch.Validate("F","Allocated nested, Subtest 1");
228
 
229
  Subtest_2;
230
  -- Unchecked_Deallocation already finalized one of the two
231
  -- objects allocated, the other should be the only one finalized
232
  -- at leaving the scope of the access type.
233
  TCTouch.Validate("F","Allocated non-local");
234
 
235
  Subtest_3;
236
  -- there should be no remaining finalizations from this subtest
237
  TCTouch.Validate("","Localized objects");
238
 
239
  Subtest_4;
240
  -- there should be no remaining finalizations from this subtest
241
  TCTouch.Validate("","Exception testing");
242
 
243
  Report.Result;
244
 
245
end C761002;

powered by: WebSVN 2.1.0

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