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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C760009.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 for an extension_aggregate whose ancestor_part is a
28
--      subtype_mark (i.e. Typemark'( Subtype with Field => x, etc.) )
29
--      Initialize is called on all controlled subcomponents of the
30
--      ancestor part; if the type of the ancestor part is itself controlled,
31
--      the Initialize procedure of the ancestor type is called, unless that
32
--      Initialize procedure is abstract.
33
--
34
--      Check that the utilization of a controlled type for a generic actual
35
--      parameter supports the correct behavior in the instantiated package.
36
--
37
-- TEST DESCRIPTION:
38
--      Declares a generic package instantiated to check that controlled
39
--      types are not impacted by the "generic boundary."
40
--      This instance is then used to perform the tests of various
41
--      aggregate formations of the controlled type.  After each operation
42
--      in the main program that should cause implicit calls, the "state" of
43
--      the software is checked.  The "state" of the software is maintained in
44
--      several variables which count the calls to the Initialize, Adjust and
45
--      Finalize procedures in each context.  Given the nature of the
46
--      language rules, the test specifies a minimum number of times that
47
--      these subprograms should have been called.  The test also checks cases
48
--      where the subprograms should not have been called.
49
--
50
--      As per the example in AARM 7.6(11a..d);6.0, the distinctions between
51
--      the presence/absence of default values is tested.
52
--
53
-- DATA STRUCTURES
54
--
55
--      C760009_3.Master_Control is derived from
56
--        C760009_2.Control is derived from
57
--          Ada.Finalization.Controlled
58
--
59
--      C760009_1.Simple_Control is derived from
60
--        Ada.Finalization.Controlled
61
--
62
--      C760009_3.Master_Control contains
63
--        Standard.Integer
64
--
65
--      C760009_2.Control contains
66
--        C760009_1.Simple_Control (default value)
67
--        C760009_1.Simple_Control (default initialized)
68
--
69
--
70
-- CHANGE HISTORY:
71
--      01 MAY 95   SAIC    Initial version
72
--      19 FEB 96   SAIC    Fixed elaboration Initialize count
73
--      14 NOV 96   SAIC    Allowed for 7.6(21) optimizations
74
--      13 FEB 97   PWB.CTA Initialized counters at lines 127-129
75
--      26 JUN 98   EDS     Added pragma Elaborate_Body to C760009_0
76
--                          to avoid possible instantiation error
77
--!
78
 
79
---------------------------------------------------------------- C760009_0
80
 
81
with Ada.Finalization;
82
generic
83
 
84
  type Private_Formal is private;
85
 
86
  with procedure TC_Validate( APF: in out Private_Formal );
87
 
88
package C760009_0 is -- Check_1
89
 
90
  pragma Elaborate_Body;
91
  procedure TC_Check_1( APF: in     Private_Formal );
92
  procedure TC_Check_2( APF:    out Private_Formal );
93
  procedure TC_Check_3( APF: in out Private_Formal );
94
 
95
end C760009_0;
96
 
97
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
98
 
99
with Report;
100
package body C760009_0 is -- Check_1
101
 
102
    procedure TC_Check_1( APF: in     Private_Formal ) is
103
      Local : Private_Formal;
104
    begin
105
      Local := APF;
106
      TC_Validate( Local );
107
    end TC_Check_1;
108
 
109
    procedure TC_Check_2( APF:    out Private_Formal ) is
110
      Local : Private_Formal;  -- initialized by virtue of actual being
111
                               -- Controlled
112
    begin
113
      APF := Local;
114
      TC_Validate( APF );
115
    end TC_Check_2;
116
 
117
    procedure TC_Check_3( APF: in out Private_Formal ) is
118
      Local : Private_Formal;
119
    begin
120
      Local := APF;
121
      TC_Validate( Local );
122
    end TC_Check_3;
123
 
124
end C760009_0;
125
 
126
---------------------------------------------------------------- C760009_1
127
 
128
with Ada.Finalization;
129
package C760009_1 is
130
 
131
  Initialize_Called : Natural := 0;
132
  Adjust_Called     : Natural := 0;
133
  Finalize_Called   : Natural := 0;
134
 
135
  procedure Reset_Counters;
136
 
137
  type Simple_Control is new Ada.Finalization.Controlled with private;
138
 
139
  procedure Initialize( AV: in out Simple_Control );
140
  procedure Adjust    ( AV: in out Simple_Control );
141
  procedure Finalize  ( AV: in out Simple_Control );
142
  procedure Validate  ( AV: in out Simple_Control );
143
 
144
  function Item( AV: Simple_Control'Class ) return String;
145
 
146
  Empty : constant Simple_Control;
147
 
148
  procedure TC_Trace( Message: String );
149
 
150
private
151
  type Simple_Control is new Ada.Finalization.Controlled with record
152
    Item: Natural;
153
  end record;
154
 
155
  Empty : constant Simple_Control := ( Ada.Finalization.Controlled with 0 );
156
 
157
end C760009_1;
158
 
159
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
160
 
161
with Report;
162
package body C760009_1 is
163
 
164
  -- Maintenance_Mode and TC_Trace are for the test writers and compiler
165
  -- developers to get more information from this test as it executes.
166
  -- Maintenance_Mode is always False for validation purposes.
167
 
168
  Maintenance_Mode : constant Boolean := False;
169
 
170
  procedure TC_Trace( Message: String ) is
171
  begin
172
    if Maintenance_Mode then
173
      Report.Comment( Message );
174
    end if;
175
  end TC_Trace;
176
 
177
  procedure Reset_Counters is
178
  begin
179
    Initialize_Called := 0;
180
    Adjust_Called     := 0;
181
    Finalize_Called   := 0;
182
  end Reset_Counters;
183
 
184
  Master_Count : Natural := 100;  -- Help distinguish values
185
 
186
  procedure Initialize( AV: in out Simple_Control ) is
187
  begin
188
    Initialize_Called := Initialize_Called +1;
189
    AV.Item := Master_Count;
190
    Master_Count := Master_Count +100;
191
    TC_Trace( "Initialize _1.Simple_Control" );
192
  end Initialize;
193
 
194
  procedure Adjust    ( AV: in out Simple_Control ) is
195
  begin
196
    Adjust_Called := Adjust_Called +1;
197
    AV.Item := AV.Item +1;
198
    TC_Trace( "Adjust _1.Simple_Control" );
199
  end Adjust;
200
 
201
  procedure Finalize  ( AV: in out Simple_Control ) is
202
  begin
203
    Finalize_Called := Finalize_Called +1;
204
    AV.Item := AV.Item +1;
205
    TC_Trace( "Finalize _1.Simple_Control" );
206
  end Finalize;
207
 
208
  procedure Validate  ( AV: in out Simple_Control ) is
209
  begin
210
    Report.Failed("Attempt to Validate at Simple_Control level");
211
  end Validate;
212
 
213
  function Item( AV: Simple_Control'Class ) return String is
214
  begin
215
    return Natural'Image(AV.Item);
216
  end Item;
217
 
218
end C760009_1;
219
 
220
---------------------------------------------------------------- C760009_2
221
 
222
with C760009_1;
223
with Ada.Finalization;
224
package C760009_2 is
225
 
226
  type Control is new Ada.Finalization.Controlled with record
227
    Element_1 : C760009_1.Simple_Control;
228
    Element_2 : C760009_1.Simple_Control := C760009_1.Empty;
229
  end record;
230
 
231
  procedure Initialize( AV: in out Control );
232
  procedure Finalize  ( AV: in out Control );
233
 
234
  Initialized : Natural := 0;
235
  Finalized   : Natural := 0;
236
 
237
end C760009_2;
238
 
239
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
240
 
241
package body C760009_2 is
242
 
243
  procedure Initialize( AV: in out Control ) is
244
  begin
245
    Initialized := Initialized +1;
246
    C760009_1.TC_Trace( "Initialize _2.Control" );
247
  end Initialize;
248
 
249
  procedure Finalize  ( AV: in out Control ) is
250
  begin
251
    Finalized := Finalized +1;
252
    C760009_1.TC_Trace( "Finalize _2.Control" );
253
  end Finalize;
254
 
255
end C760009_2;
256
 
257
---------------------------------------------------------------- C760009_3
258
 
259
with C760009_0;
260
with C760009_2;
261
package C760009_3 is
262
 
263
  type Master_Control is new C760009_2.Control with record
264
    Data: Integer;
265
  end record;
266
 
267
  procedure Initialize( AC: in out Master_Control );
268
  -- calls C760009_2.Initialize
269
  -- embedded data causes 1 call to C760009_1.Initialize
270
 
271
  -- Adjusting operation will
272
  -- make 1 call to C760009_2.Adjust
273
  -- make 2 call to C760009_1.Adjust
274
 
275
  -- Finalize operation will
276
  -- make 1 call to C760009_2.Finalize
277
  -- make 2 call to C760009_1.Finalize
278
 
279
  procedure Validate( AC: in out Master_Control );
280
 
281
  package Check_1 is
282
    new C760009_0(Master_Control, Validate);
283
 
284
end C760009_3;
285
 
286
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
287
 
288
with Report;
289
with C760009_1;
290
package body C760009_3 is
291
 
292
  procedure Initialize( AC: in out Master_Control ) is
293
  begin
294
    AC.Data := 42;
295
    C760009_2.Initialize(C760009_2.Control(AC));
296
    C760009_1.TC_Trace( "Initialize Master_Control" );
297
  end Initialize;
298
 
299
  procedure Validate( AC: in out Master_Control ) is
300
  begin
301
    if AC.Data not in 0..1000 then
302
      Report.Failed("C760009_3.Control did not Initialize" );
303
    end if;
304
  end Validate;
305
 
306
end C760009_3;
307
 
308
--------------------------------------------------------------------- C760009
309
 
310
with Report;
311
with C760009_1;
312
with C760009_2;
313
with C760009_3;
314
procedure C760009 is
315
 
316
  -- Comment following declaration indicates expected calls in the order:
317
  -- Initialize of a C760009_2 value
318
  -- Finalize   of a C760009_2 value
319
  -- Initialize of a C760009_1 value
320
  -- Adjust     of a C760009_1 value
321
  -- Finalize   of a C760009_1 value
322
 
323
  Global_Control : C760009_3.Master_Control;
324
  -- 1, 0, 1, 1, 0
325
 
326
  Parent_Control : C760009_2.Control;
327
  -- 1, 0, 1, 1, 0
328
 
329
  -- Global_Control is a derived tagged type, the parent type
330
  --   of Master_Control, Control, is derived from Controlled, and contains
331
  --   two components of a Controlled type, Simple_Control.  One of these
332
  --   components has a default value, the other does not.
333
 
334
  procedure Fail( Which: String; Expect, Got: Natural ) is
335
  begin
336
    Report.Failed(Which & " Expected" & Natural'Image(Expect)
337
                        & " got" & Natural'Image(Got) );
338
  end Fail;
339
 
340
  procedure Master_Assertion( Layer_2_Inits   : Natural;
341
                              Layer_2_Finals  : Natural;
342
                              Layer_1_Inits   : Natural;
343
                              Layer_1_Adjs    : Natural;
344
                              Layer_1_Finals  : Natural;
345
                              Failing_Message : String ) is
346
 
347
  begin
348
 
349
 
350
 
351
   if C760009_2.Initialized /= Layer_2_Inits then
352
     Fail("C760009_2.Initialize " & Failing_Message,
353
          Layer_2_Inits, C760009_2.Initialized );
354
   end if;
355
 
356
   if C760009_2.Finalized not in Layer_2_Finals..Layer_2_Finals*2 then
357
     Fail("C760009_2.Finalize " & Failing_Message,
358
           Layer_2_Finals, C760009_2.Finalized );
359
   end if;
360
 
361
   if C760009_1.Initialize_Called /= Layer_1_Inits then
362
     Fail("C760009_1.Initialize " & Failing_Message,
363
           Layer_1_Inits,
364
          C760009_1.Initialize_Called );
365
   end if;
366
 
367
   if C760009_1.Adjust_Called not in Layer_1_Adjs..Layer_1_Adjs*2 then
368
     Fail("C760009_1.Adjust " & Failing_Message,
369
           Layer_1_Adjs, C760009_1.Adjust_Called );
370
   end if;
371
 
372
   if C760009_1.Finalize_Called not in Layer_1_Finals..Layer_1_Finals*2 then
373
     Fail("C760009_1.Finalize " & Failing_Message,
374
           Layer_1_Finals, C760009_1.Finalize_Called );
375
   end if;
376
 
377
   C760009_1.Reset_Counters;
378
   C760009_2.Initialized := 0;
379
   C760009_2.Finalized   := 0;
380
 
381
  end Master_Assertion;
382
 
383
  procedure Lesser_Assertion( Layer_2_Inits   : Natural;
384
                              Layer_2_Finals  : Natural;
385
                              Layer_1_Inits   : Natural;
386
                              Layer_1_Adjs    : Natural;
387
                              Layer_1_Finals  : Natural;
388
                              Failing_Message : String ) is
389
  begin
390
 
391
 
392
   if C760009_2.Initialized > Layer_2_Inits then
393
     Fail("C760009_2.Initialize " & Failing_Message,
394
           Layer_2_Inits, C760009_2.Initialized );
395
   end if;
396
 
397
   if C760009_2.Finalized < Layer_2_Inits
398
      or C760009_2.Finalized > Layer_2_Finals*2 then
399
     Fail("C760009_2.Finalize " & Failing_Message,
400
           Layer_2_Finals, C760009_2.Finalized );
401
   end if;
402
 
403
   if C760009_1.Initialize_Called > Layer_1_Inits then
404
     Fail("C760009_1.Initialize " & Failing_Message,
405
           Layer_1_Inits,
406
          C760009_1.Initialize_Called );
407
   end if;
408
 
409
   if C760009_1.Adjust_Called > Layer_1_Adjs*2 then
410
     Fail("C760009_1.Adjust " & Failing_Message,
411
           Layer_1_Adjs, C760009_1.Adjust_Called );
412
   end if;
413
 
414
   if C760009_1.Finalize_Called < Layer_1_Inits
415
      or C760009_1.Finalize_Called > Layer_1_Finals*2 then
416
     Fail("C760009_1.Finalize " & Failing_Message,
417
           Layer_1_Finals, C760009_1.Finalize_Called );
418
   end if;
419
 
420
   C760009_1.Reset_Counters;
421
   C760009_2.Initialized := 0;
422
   C760009_2.Finalized   := 0;
423
 
424
  end Lesser_Assertion;
425
 
426
begin  -- Main test procedure.
427
 
428
  Report.Test ("C760009", "Check that for an extension_aggregate whose " &
429
                          "ancestor_part is a subtype_mark, Initialize " &
430
                          "is called on all controlled subcomponents of " &
431
                          "the ancestor part.  Also check that the " &
432
                          "utilization of a controlled type for a generic " &
433
                          "actual parameter supports the correct behavior " &
434
                          "in the instantiated software" );
435
 
436
  C760009_1.TC_Trace( "=====> Case 0 <=====" );
437
 
438
  C760009_1.Reset_Counters;
439
  C760009_2.Initialized := 0;
440
  C760009_2.Finalized   := 0;
441
 
442
  C760009_3.Validate( Global_Control ); -- check that it Initialized correctly
443
 
444
  C760009_1.TC_Trace( "=====> Case 1 <=====" );
445
 
446
  C760009_3.Check_1.TC_Check_1( ( C760009_2.Control with Data => 1 ) );
447
  Lesser_Assertion( 2, 3, 2, 3, 6, "Check_1.TC_Check_1" );
448
  --                |  |  |  |  + Finalize 2 embedded in aggregate
449
  --                |  |  |  |  + Finalize 2 at assignment in TC_Check_1
450
  --                |  |  |  |  + Finalize 2 embedded in local variable
451
  --                |  |  |  + Adjust 2 caused by assignment in TC_Check_1
452
  --                |  |  |  + Adjust at declaration in TC_Check_1
453
  --                |  |  + Initialize at declaration in TC_Check_1
454
  --                |  |  + Initialize of aggregate object
455
  --                |  + Finalize of assignment target
456
  --                |  + Finalize of local variable
457
  --                |  + Finalize of aggregate object
458
  --               + Initialize of aggregate object
459
  --               + Initialize of local variable
460
 
461
 
462
  C760009_1.TC_Trace( "=====> Case 2 <=====" );
463
 
464
  C760009_3.Check_1.TC_Check_2( Global_Control );
465
  Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_2" );
466
  --                |  |  |  |  + Finalize 2 at assignment in TC_Check_2
467
  --                |  |  |  |  + Finalize 2 embedded in local variable
468
  --                |  |  |  + Adjust 2 caused by assignment in TC_Check_2
469
  --                |  |  |  + Adjust at declaration in TC_Check_2
470
  --                |  |  + Initialize at declaration in TC_Check_2
471
  --                |  + Finalize of assignment target
472
  --                |  + Finalize of local variable
473
  --               + Initialize of local variable
474
 
475
 
476
  C760009_1.TC_Trace( "=====> Case 3 <=====" );
477
 
478
  Global_Control := ( C760009_2.Control with Data => 2 );
479
  Lesser_Assertion( 1, 1, 1, 3, 2, "Aggregate -> object" );
480
  --                |  |  |  |  + Finalize 2 by assignment
481
  --                |  |  |  + Adjust 2 caused by assignment
482
  --                |  |  |  + Adjust in aggregate creation
483
  --                |  |  + Initialize of aggregate object
484
  --                |  + Finalize of assignment target
485
  --               + Initialize of aggregate object
486
 
487
 
488
  C760009_1.TC_Trace( "=====> Case 4 <=====" );
489
 
490
  C760009_3.Check_1.TC_Check_3( Global_Control );
491
  Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_3" );
492
  --                |  |  |  |  + Finalize 2 at assignment in TC_Check_3
493
  --                |  |  |  |  + Finalize 2 embedded in local variable
494
  --                |  |  |  + Adjust 2 at assignment in TC_Check_3
495
  --                |  |  |  + Adjust in local variable creation
496
  --                |  |  + Initialize of local variable in TC_Check_3
497
  --                |  + Finalize of assignment target
498
  --                |  + Finalize of local variable
499
  --               + Initialize of local variable
500
 
501
 
502
  C760009_1.TC_Trace( "=====> Case 5 <=====" );
503
 
504
  Global_Control := ( Parent_Control with Data => 3 );
505
  Lesser_Assertion( 1, 1, 1, 3, 2, "Object Aggregate -> object" );
506
  --                |  |  |  |  + Finalize 2 by assignment
507
  --                |  |  |  + Adjust 2 caused by assignment
508
  --                |  |  |  + Adjust in aggregate creation
509
  --                |  |  + Initialize of aggregate object
510
  --                |  + Finalize of assignment target
511
  --               + Initialize of aggregate object
512
 
513
 
514
 
515
  C760009_1.TC_Trace( "=====> Case 6 <=====" );
516
 
517
  -- perform this check a second time to make sure nothing is "remembered"
518
 
519
  C760009_3.Check_1.TC_Check_3( Global_Control );
520
  Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_3 second time" );
521
  --                |  |  |  |  + Finalize 2 at assignment in TC_Check_3
522
  --                |  |  |  |  + Finalize 2 embedded in local variable
523
  --                |  |  |  + Adjust 2 at assignment in TC_Check_3
524
  --                |  |  |  + Adjust in local variable creation
525
  --                |  |  + Initialize of local variable in TC_Check_3
526
  --                |  + Finalize of assignment target
527
  --                |  + Finalize of local variable
528
  --               + Initialize of local variable
529
 
530
 
531
  Report.Result;
532
 
533
end C760009;

powered by: WebSVN 2.1.0

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