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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C760001.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 Initialize is called for objects and components of
28
--      a controlled type when the objects and components are not
29
--      assigned explicit initial values.  Check this for "simple" controlled
30
--      objects, controlled record components and arrays with controlled
31
--      components.
32
--
33
--      Check that if an explicit initial value is assigned to an object
34
--      or component of a controlled type then Initialize is not called.
35
--
36
-- TEST DESCRIPTION:
37
--      This test derives a type for Ada.Finalization.Controlled, and
38
--      overrides the Initialize and Adjust operations for the type.  The
39
--      intent of the type is that it should carry incremental values
40
--      indicating the ordering of events with respect to these (and default
41
--      initialization) operations.  The body of the test uses these values
42
--      to determine that the implicit calls to these subprograms happen
43
--      (or don't) at the appropriate times.
44
--
45
--      The test further derives types from this "root" type, which are the
46
--      actual types used in the test.  One of the types is "simply" derived
47
--      from the "root" type, the other contains a component of the first
48
--      type, thus nesting a controlled object as a record component in
49
--      controlled objects.
50
--
51
--      The main program declares objects of these types and checks the
52
--      values of the components to ascertain that they have been touched
53
--      as expected.
54
--
55
--      Note that Finalization procedures are provided.  This test does not
56
--      test that the calls to Finalization are made correctly.  The
57
--      Finalization procedures are provided to catch an implementation that
58
--      calls Finalization at an incorrect time.
59
--
60
--
61
-- CHANGE HISTORY:
62
--      06 Dec 94   SAIC    ACVC 2.0
63
--      10 Oct 95   SAIC    Update and repair for ACVC 2.0.1
64
--
65
--!
66
 
67
---------------------------------------------------------------- C760001_0
68
 
69
with Ada.Finalization;
70
package C760001_0 is
71
  subtype Unique_ID is Natural;
72
  function Unique_Value return Unique_ID;
73
  -- increments each time it's called
74
 
75
  function Most_Recent_Unique_Value return Unique_ID;
76
  -- returns the same value as the most recent call to Unique_Value
77
 
78
  type Root_Controlled is new Ada.Finalization.Controlled with record
79
    My_ID      : Unique_ID := Unique_Value;
80
    My_Init_ID : Unique_ID := Unique_ID'First;
81
    My_Adj_ID  : Unique_ID := Unique_ID'First;
82
  end record;
83
 
84
  procedure Initialize( R: in out Root_Controlled );
85
  procedure Adjust    ( R: in out Root_Controlled );
86
 
87
  TC_Initialize_Calls_Is_Failing : Boolean := False;
88
 
89
end C760001_0;
90
 
91
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
92
 
93
with Report;
94
package body C760001_0 is
95
 
96
  Global_Unique_Counter : Unique_ID := 0;
97
 
98
  function Unique_Value return Unique_ID is
99
  begin
100
    Global_Unique_Counter := Global_Unique_Counter +1;
101
    return Global_Unique_Counter;
102
  end Unique_Value;
103
 
104
  function Most_Recent_Unique_Value return Unique_ID is
105
  begin
106
    return Global_Unique_Counter;
107
  end Most_Recent_Unique_Value;
108
 
109
  procedure Initialize( R: in out Root_Controlled ) is
110
  begin
111
    if TC_Initialize_Calls_Is_Failing then
112
      Report.Failed("Initialized incorrectly called");
113
    end if;
114
    R.My_Init_ID := Unique_Value;
115
  end Initialize;
116
 
117
  procedure Adjust( R: in out Root_Controlled ) is
118
  begin
119
    R.My_Adj_ID := Unique_Value;
120
  end Adjust;
121
 
122
end C760001_0;
123
 
124
---------------------------------------------------------------- C760001_1
125
 
126
with Ada.Finalization;
127
with C760001_0;
128
package C760001_1 is
129
 
130
  type Proc_ID is (None, Init, Adj, Fin);
131
 
132
  type Test_Controlled is new C760001_0.Root_Controlled with record
133
    Last_Proc_Called: Proc_ID := None;
134
  end record;
135
 
136
  procedure Initialize( TC: in out Test_Controlled );
137
  procedure Adjust    ( TC: in out Test_Controlled );
138
  procedure Finalize  ( TC: in out Test_Controlled );
139
 
140
  type Nested_Controlled is new C760001_0.Root_Controlled with record
141
    Nested : C760001_0.Root_Controlled;
142
    Last_Proc_Called: Proc_ID := None;
143
  end record;
144
 
145
  procedure Initialize( TC: in out Nested_Controlled );
146
  procedure Adjust    ( TC: in out Nested_Controlled );
147
  procedure Finalize  ( TC: in out Nested_Controlled );
148
 
149
end C760001_1;
150
 
151
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
152
 
153
with Report;
154
package body C760001_1 is
155
 
156
  procedure Initialize( TC: in out Test_Controlled ) is
157
  begin
158
    if TC.Last_Proc_Called /= None then
159
      Report.Failed("Initialize for Test_Controlled");
160
    end if;
161
    TC.Last_Proc_Called := Init;
162
    C760001_0.Initialize(C760001_0.Root_Controlled(TC));
163
  end Initialize;
164
 
165
  procedure Adjust    ( TC: in out Test_Controlled ) is
166
  begin
167
    TC.Last_Proc_Called := Adj;
168
    C760001_0.Adjust(C760001_0.Root_Controlled(TC));
169
  end Adjust;
170
 
171
  procedure Finalize  ( TC: in out Test_Controlled ) is
172
  begin
173
    TC.Last_Proc_Called := Fin;
174
  end Finalize;
175
 
176
  procedure Initialize( TC: in out Nested_Controlled ) is
177
  begin
178
    if TC.Last_Proc_Called /= None then
179
      Report.Failed("Initialize for Nested_Controlled");
180
    end if;
181
    TC.Last_Proc_Called := Init;
182
    C760001_0.Initialize(C760001_0.Root_Controlled(TC));
183
  end Initialize;
184
 
185
  procedure Adjust    ( TC: in out Nested_Controlled ) is
186
  begin
187
    TC.Last_Proc_Called := Adj;
188
    C760001_0.Adjust(C760001_0.Root_Controlled(TC));
189
  end Adjust;
190
 
191
  procedure Finalize  ( TC: in out Nested_Controlled ) is
192
  begin
193
    TC.Last_Proc_Called := Fin;
194
  end Finalize;
195
 
196
end C760001_1;
197
 
198
---------------------------------------------------------------- C760001
199
 
200
with Report;
201
with TCTouch;
202
with C760001_0;
203
with C760001_1;
204
with Ada.Finalization;
205
procedure C760001 is
206
 
207
  use type C760001_1.Proc_ID;
208
 
209
  -- in the first test, test the simple case.  Check that a controlled object
210
  -- causes a call to the procedure Initialize.
211
  -- Also check that assignment causes a call to Adjust.
212
 
213
  procedure Check_Simple_Objects is
214
    S,T : C760001_1.Test_Controlled;
215
  begin
216
    TCTouch.Assert(S.My_ID < S.My_Init_ID,"Default before dispatch");
217
    TCTouch.Assert((S.Last_Proc_Called = C760001_1.Init) and
218
                                        (T.Last_Proc_Called = C760001_1.Init),
219
                   "Initialize for simple object");
220
    S := T;
221
    TCTouch.Assert((S.Last_Proc_Called = C760001_1.Adj),
222
                   "Adjust for simple object");
223
    TCTouch.Assert((S.My_ID = T.My_ID),
224
                   "Simple object My_ID's don't match");
225
    TCTouch.Assert((S.My_Init_ID = T.My_Init_ID),
226
                   "Simple object My_Init_ID's don't match");
227
    TCTouch.Assert((S.My_Adj_ID > T.My_Adj_ID),
228
                   "Simple object My_Adj_ID's in wrong order");
229
  end Check_Simple_Objects;
230
 
231
  -- in the second test, test a more complex case, check that a controlled
232
  -- component of a controlled object gets processed correctly
233
 
234
  procedure Check_Nested_Objects is
235
    NO1 : C760001_1.Nested_Controlled;
236
  begin
237
    TCTouch.Assert((NO1.My_ID < NO1.My_Init_Id),
238
                   "Default value order incorrect");
239
    TCTouch.Assert((NO1.My_Init_Id > NO1.Nested.My_Init_ID),
240
                   "Initialization call order incorrect");
241
  end Check_Nested_Objects;
242
 
243
  -- check that objects assigned an initial value at declaration are Adjusted
244
  -- and NOT Initialized
245
 
246
  procedure Check_Objects_With_Initial_Values is
247
 
248
    TC_Now : constant C760001_0.Unique_ID := C760001_0.Unique_Value;
249
 
250
    A: C760001_1.Test_Controlled :=
251
      ( Ada.Finalization.Controlled
252
        with TC_Now,
253
             TC_Now,
254
             TC_Now,
255
             C760001_1.None);
256
 
257
    B: C760001_1.Nested_Controlled :=
258
      ( Ada.Finalization.Controlled
259
        with TC_Now,
260
             TC_Now,
261
             TC_Now,
262
             C760001_0.Root_Controlled(A),
263
             C760001_1.None);
264
 
265
  begin
266
    -- the implementation may or may not call Adjust for the values
267
    -- assigned into A and B,
268
    -- but should NOT call Initialize.
269
    -- if the value used in the aggregate is overwritten by Initialize,
270
    -- this indicates failure
271
    TCTouch.Assert(A.My_Init_Id = TC_Now,
272
                   "Initialize was called for A with initial value");
273
    TCTouch.Assert(B.My_Init_Id = TC_Now,
274
                   "Initialize was called for B with initial value");
275
    TCTouch.Assert(B.Nested.My_Init_ID = TC_Now,
276
                   "Initialize was called for B.Nested initial value");
277
  end Check_Objects_With_Initial_Values;
278
 
279
  procedure Check_Array_Case is
280
    type Array_Simple is array(1..4) of C760001_1.Test_Controlled;
281
    type Array_Nested is array(1..4) of C760001_1.Nested_Controlled;
282
 
283
    Simple_Array_Default : Array_Simple;
284
 
285
    Nested_Array_Default : Array_Nested;
286
 
287
    TC_A_Bit_Later : C760001_0.Unique_ID;
288
 
289
  begin
290
    TC_A_Bit_Later := C760001_0.Unique_Value;
291
    for N in 1..4 loop
292
      TCTouch.Assert(Simple_Array_Default(N).Last_Proc_Called
293
                     = C760001_1.Init,
294
                     "Initialize for array initial value");
295
 
296
      TCTouch.Assert( (Simple_Array_Default(N).My_Init_ID
297
                       > C760001_0.Unique_ID'First)
298
                      and (Simple_Array_Default(N).My_Init_ID
299
                       < TC_A_Bit_Later),
300
                     "Initialize timing for simple array");
301
 
302
      TCTouch.Assert( (Nested_Array_Default(N).My_Init_ID
303
                       > C760001_0.Unique_ID'First)
304
                      and (Nested_Array_Default(N).My_Init_ID
305
                       < TC_A_Bit_Later),
306
                     "Initialize timing for container array");
307
 
308
      TCTouch.Assert(Nested_Array_Default(N).Last_Proc_Called
309
                     = C760001_1.Init,
310
                     "Initialize for nested array (outer) initial value");
311
 
312
      TCTouch.Assert( (Nested_Array_Default(N).Nested.My_Init_ID
313
                       > C760001_0.Unique_ID'First)
314
                      and (Nested_Array_Default(N).Nested.My_Init_ID
315
                       < Nested_Array_Default(N).My_Init_ID),
316
                     "Initialize timing for array content");
317
    end loop;
318
  end Check_Array_Case;
319
 
320
  procedure Check_Array_Case_With_Initial_Values is
321
 
322
    TC_Now : constant C760001_0.Unique_ID := C760001_0.Unique_Value;
323
 
324
    type Array_Simple is array(1..4) of C760001_1.Test_Controlled;
325
    type Array_Nested is array(1..4) of C760001_1.Nested_Controlled;
326
 
327
    Simple_Array_Explicit : Array_Simple := ( 1..4 => (
328
        Ada.Finalization.Controlled
329
        with TC_Now,
330
             TC_Now,
331
             TC_Now,
332
             C760001_1.None                 )         );
333
 
334
    A : constant C760001_0.Root_Controlled :=
335
      ( Ada.Finalization.Controlled
336
        with others => TC_Now);
337
 
338
    Nested_Array_Explicit : Array_Nested := ( 1..4 => (
339
        Ada.Finalization.Controlled
340
        with TC_Now,
341
             TC_Now,
342
             TC_Now,
343
             A,
344
             C760001_1.None                 )         );
345
 
346
  begin
347
    -- the implementation may or may not call Adjust for the values
348
    -- assigned into Simple_Array_Explicit and Nested_Array_Explicit,
349
    -- but should NOT call Initialize.
350
    -- if the value used in the aggregate is overwritten by Initialize,
351
    -- this indicates failure
352
    for N in 1..4 loop
353
      TCTouch.Assert(Simple_Array_Explicit(N).My_Init_ID
354
                     = TC_Now,
355
                     "Initialize was called for array with initial value");
356
      TCTouch.Assert(Nested_Array_Explicit(N).My_Init_ID
357
                     = TC_Now,
358
        "Initialize was called for nested array (outer) with initial value");
359
      TCTouch.Assert(Nested_Array_Explicit(N).Nested.My_Init_ID = TC_Now,
360
        "Initialize was called for nested array (inner) with initial value");
361
    end loop;
362
  end Check_Array_Case_With_Initial_Values;
363
 
364
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
365
 
366
begin  -- Main test procedure.
367
 
368
  Report.Test ("C760001", "Check that Initialize is called for objects " &
369
                          "and components of a controlled type when the " &
370
                          "objects and components are not assigned " &
371
                          "explicit initial values.  Check that if an " &
372
                          "explicit initial value is assigned to an " &
373
                          "object or component of a controlled type " &
374
                          "then Initialize is not called" );
375
 
376
  Check_Simple_Objects;
377
 
378
  Check_Nested_Objects;
379
 
380
  Check_Array_Case;
381
 
382
  C760001_0.TC_Initialize_Calls_Is_Failing := True;
383
 
384
  Check_Objects_With_Initial_Values;
385
 
386
  Check_Array_Case_With_Initial_Values;
387
 
388
  Report.Result;
389
 
390
end C760001;

powered by: WebSVN 2.1.0

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