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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 149 jeremybenn
-- C761005.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 deriving abstract types from the types in Ada.Finalization
28
--      does not negatively impact the implicit operations.
29
--      Check that an object of a controlled type is finalized when the
30
--      enclosing master is complete.
31
--      Check that finalization occurs in the case where the master is
32
--      left by a transfer of control.
33
--      Check this for controlled types where the derived type has a
34
--      discriminant.
35
--      Check this for cases where the type is defined as private,
36
--      and the full type is derived from the types in Ada.Finalization.
37
--
38
--      Check that finalization of controlled objects is
39
--      performed in the correct order.  In particular, check that if
40
--      multiple objects of controlled types are declared immediately
41
--      within the same declarative part then type are finalized in the
42
--      reverse order of their creation.
43
--
44
-- TEST DESCRIPTION:
45
--      This test checks these conditions for subprograms and
46
--      block statements; both variables and constants of controlled
47
--      types; cases of a controlled component of a record type, as
48
--      well as an array with controlled components.
49
--
50
--      The base controlled types used for the test are defined
51
--      with a character discriminant.  The initialize procedure for
52
--      the types will record the order of creation in a globally
53
--      accessible array, the finalize procedure for the types will call
54
--      TCTouch with that tag character.  The test can then check that
55
--      the order of finalization is indeed the reverse of the order of
56
--      creation (assuming that the implementation calls Initialize in
57
--      the order that the objects are created).
58
--
59
--
60
-- CHANGE HISTORY:
61
--      06 Dec 94   SAIC    ACVC 2.0
62
--      10 Oct 95   SAIC    Fixed bugs for ACVC 2.0.1
63
--
64
--!
65
 
66
package C761005_Support is
67
 
68
  function Pick_Char return Character;
69
  procedure Validate(Initcount: Natural; Testnumber:Natural);
70
 
71
  Inits_Order  : String(1..255);
72
  Inits_Called : Natural := 0;
73
 
74
end C761005_Support;
75
 
76
with Report;
77
with TCTouch;
78
package body C761005_Support is
79
  type Pick_Rotation is mod 52;
80
  type Pick_String is array(Pick_Rotation) of Character;
81
 
82
  From : constant Pick_String  := "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
83
                                & "abcdefghijklmnopqrstuvwxyz";
84
  Recent_Pick : Pick_Rotation := Pick_Rotation'Last;
85
 
86
  function Pick_Char return Character is
87
  begin
88
    Recent_Pick := Recent_Pick +1;
89
    return From(Recent_Pick);
90
  end Pick_Char;
91
 
92
  function Invert(S:String) return String is
93
    T: String(1..S'Length);
94
    TI: Positive := 1;
95
  begin
96
    for SI in reverse S'Range loop
97
      T(TI) := S(SI);
98
      TI := TI +1;
99
    end loop;
100
    return T;
101
  end Invert;
102
 
103
  procedure Validate(Initcount: Natural; Testnumber:Natural) is
104
    Number : constant String := Natural'Image(Testnumber);
105
  begin
106
    if Inits_Called /= Initcount then
107
      Report.Failed("Wrong number of inits, Subtest " & Number);
108
    else
109
      TCTouch.Validate(
110
        Invert(Inits_Order(1..Inits_Called)),
111
               "Subtest " & Number, True);
112
    end if;
113
    Inits_Called := 0;
114
  end Validate;
115
 
116
end C761005_Support;
117
 
118
-----------------------------------------------------------------------------
119
with Ada.Finalization;
120
package C761005_0 is
121
  type Final_Root(Tag: Character) is private;
122
 
123
  type Ltd_Final_Root(Tag: Character) is limited private;
124
 
125
  Inits_Order  : String(1..255);
126
  Inits_Called : Natural := 0;
127
private
128
  type Final_Root(Tag: Character) is new Ada.Finalization.Controlled
129
    with null record;
130
  procedure Initialize( It: in out Final_Root );
131
  procedure Finalize  ( It: in out Final_Root );
132
 
133
  type Ltd_Final_Root(Tag: Character) is new
134
Ada.Finalization.Limited_Controlled
135
    with null record;
136
  procedure Initialize( It: in out Ltd_Final_Root );
137
  procedure Finalize  ( It: in out Ltd_Final_Root );
138
end C761005_0;
139
 
140
-----------------------------------------------------------------------------
141
with Ada.Finalization;
142
package C761005_1 is
143
  type Final_Abstract is abstract tagged private;
144
 
145
  type Ltd_Final_Abstract_Child is abstract tagged limited private;
146
 
147
  Inits_Order  : String(1..255);
148
  Inits_Called : Natural := 0;
149
 
150
private
151
  type Final_Abstract is abstract new Ada.Finalization.Controlled with record
152
    Tag: Character;
153
  end record;
154
  procedure Initialize( It: in out Final_Abstract );
155
  procedure Finalize  ( It: in out Final_Abstract );
156
 
157
  type Ltd_Final_Abstract_Child is
158
       abstract new Ada.Finalization.Limited_Controlled with record
159
    Tag: Character;
160
  end record;
161
  procedure Initialize( It: in out Ltd_Final_Abstract_Child );
162
  procedure Finalize  ( It: in out Ltd_Final_Abstract_Child );
163
 
164
end C761005_1;
165
 
166
-----------------------------------------------------------------------------
167
with C761005_1;
168
package C761005_2 is
169
 
170
  type Final_Child is new C761005_1.Final_Abstract with null record;
171
  type Ltd_Final_Child is
172
       new C761005_1.Ltd_Final_Abstract_Child with null record;
173
 
174
end C761005_2;
175
 
176
-----------------------------------------------------------------------------
177
with Report;
178
with TCTouch;
179
with C761005_Support;
180
package body C761005_0 is
181
 
182
  package Sup renames C761005_Support;
183
 
184
  procedure Initialize( It: in out Final_Root ) is
185
  begin
186
    Sup.Inits_Called := Sup.Inits_Called +1;
187
    Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
188
  end Initialize;
189
 
190
  procedure Finalize( It: in out Final_Root ) is
191
  begin
192
    TCTouch.Touch(It.Tag);
193
  end Finalize;
194
 
195
  procedure Initialize( It: in out Ltd_Final_Root ) is
196
  begin
197
    Sup.Inits_Called := Sup.Inits_Called +1;
198
    Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
199
  end Initialize;
200
 
201
  procedure Finalize( It: in out Ltd_Final_Root ) is
202
  begin
203
    TCTouch.Touch(It.Tag);
204
  end Finalize;
205
end C761005_0;
206
 
207
-----------------------------------------------------------------------------
208
with Report;
209
with TCTouch;
210
with C761005_Support;
211
package body C761005_1 is
212
 
213
  package Sup renames C761005_Support;
214
 
215
  procedure Initialize( It: in out Final_Abstract ) is
216
  begin
217
    Sup.Inits_Called := Sup.Inits_Called +1;
218
    It.Tag := Sup.Pick_Char;
219
    Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
220
  end Initialize;
221
 
222
  procedure Finalize( It: in out Final_Abstract ) is
223
  begin
224
    TCTouch.Touch(It.Tag);
225
  end Finalize;
226
 
227
  procedure Initialize( It: in out Ltd_Final_Abstract_Child ) is
228
  begin
229
    Sup.Inits_Called := Sup.Inits_Called +1;
230
    It.Tag := Sup.Pick_Char;
231
    Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
232
  end Initialize;
233
 
234
  procedure Finalize( It: in out Ltd_Final_Abstract_Child ) is
235
  begin
236
    TCTouch.Touch(It.Tag);
237
  end Finalize;
238
end C761005_1;
239
 
240
-----------------------------------------------------------------------------
241
with Report;
242
with TCTouch;
243
with C761005_0;
244
with C761005_2;
245
with C761005_Support;
246
procedure C761005 is
247
 
248
  package Sup renames C761005_Support;
249
 
250
  Subtest_1_Inits_Expected : constant := 4;
251
  procedure Subtest_1 is
252
    Item_1 : C761005_0.Final_Root(Sup.Pick_Char);
253
    Item_2, Item_3 : C761005_0.Final_Root(Sup.Pick_Char);
254
    Item_4 : C761005_0.Ltd_Final_Root(Sup.Pick_Char);
255
  begin
256
    -- check that nothing has happened yet!
257
    TCTouch.Validate("","Subtest 1 body");
258
  end Subtest_1;
259
 
260
  -- These declarations should cause calls to initialize and
261
  -- finalize.  The expected operations are the subprograms associated
262
  -- with the abstract types.
263
  Subtest_2_Inits_Expected : constant := 4;
264
  procedure Subtest_2 is
265
    Item_1 : C761005_2.Final_Child;
266
    Item_2, Item_3 : C761005_2.Final_Child;
267
    Item_4 : C761005_2.Ltd_Final_Child;
268
  begin
269
    -- check that nothing has happened yet!
270
    TCTouch.Validate("","Subtest 2 body");
271
  end Subtest_2;
272
 
273
begin  -- Main test procedure.
274
 
275
  Report.Test ("C761005", "Check that an object of a controlled type "
276
                        & "is finalized when the enclosing master is "
277
                        & "complete, left by a transfer of control, "
278
                        & "and performed in the correct order" );
279
 
280
  Subtest_1;
281
  Sup.Validate(Subtest_1_Inits_Expected,1);
282
 
283
  Subtest_2;
284
  Sup.Validate(Subtest_2_Inits_Expected,2);
285
 
286
  Report.Result;
287
 
288
end C761005;

powered by: WebSVN 2.1.0

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