summaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/c7/c760002.a
blob: 4601873be04fa45e2a71cd677f830780039af15f (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
-- C760002.A
--
--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
--     this public release, the Government intends to confer upon all 
--     recipients unlimited rights  equal to those held by the Government.  
--     These rights include rights to use, duplicate, release or disclose the 
--     released technical data and computer software in whole or in part, in 
--     any manner and for any purpose whatsoever, and to have or permit others 
--     to do so.
--
--                                    DISCLAIMER
--
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--     PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
--      Check that assignment to an object of a (non-limited) controlled
--      type causes the Adjust operation of the type to be called.
--      Check that Adjust is called after copying the value of the
--      source expression to the target object.
--
--      Check that Adjust is called for all controlled components when
--      the containing object is assigned.  (Test this for the cases
--      where the type of the containing object is controlled and
--      noncontrolled; test this for initialization as well as
--      assignment statements.)
--
--      Check that for an object of a controlled type with controlled
--      components, Adjust for each of the components is called before
--      the containing object is adjusted.
--
--      Check that an Adjust procedure for a Limited_Controlled type is
--      not called by the implementation.
--
-- TEST DESCRIPTION:
--      This test is loosely "derived" from C760001.
--
--      Visit Tags:
--        D - Default value at declaration
--        d - Default value at declaration, limited root
--        I - initialize at root controlled
--        i - initialize at root limited controlled
--        A - adjust at root controlled
--        X,Y,Z,x,y,z - used in test body
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      19 Dec 94   SAIC    Correct test assertion logic for Sinister case
--
--!

---------------------------------------------------------------- C760002_0

with Ada.Finalization;
package C760002_0 is
  subtype Unique_ID is Natural;
  function Unique_Value return Unique_ID;
  -- increments each time it's called

  function Most_Recent_Unique_Value return Unique_ID;
  -- returns the same value as the most recent call to Unique_Value

  type Root is tagged record
    My_ID      : Unique_ID := Unique_Value;
    Visit_Tag  : Character := 'D';  -- Default
  end record;

  procedure Initialize( R: in out Root );
  procedure Adjust    ( R: in out Root );

  type Root_Controlled is new Ada.Finalization.Controlled with record
    My_ID      : Unique_ID := Unique_Value;
    Visit_Tag  : Character := 'D'; ---------------------------------------- D
  end record;

  procedure Initialize( R: in out Root_Controlled );
  procedure Adjust    ( R: in out Root_Controlled );

  type Root_Limited_Controlled is
       new Ada.Finalization.Limited_Controlled with record
    My_ID      : Unique_ID := Unique_Value;
    Visit_Tag  : Character := 'd'; ---------------------------------------- d
  end record;

  procedure Initialize( R: in out Root_Limited_Controlled );
  procedure Adjust    ( R: in out Root_Limited_Controlled );

end C760002_0;

with Report;
package body C760002_0 is

  Global_Unique_Counter : Unique_ID := 0;
  
  function Unique_Value return Unique_ID is
  begin
    Global_Unique_Counter := Global_Unique_Counter +1;
    return Global_Unique_Counter;
  end Unique_Value;
  
  function Most_Recent_Unique_Value return Unique_ID is
  begin
    return Global_Unique_Counter;
  end Most_Recent_Unique_Value;

  procedure Initialize( R: in out Root ) is
  begin
    Report.Failed("Initialize called for Non_Controlled type");
  end Initialize;

  procedure Adjust    ( R: in out Root ) is
  begin
    Report.Failed("Adjust called for Non_Controlled type");
  end Adjust;

  procedure Initialize( R: in out Root_Controlled ) is
  begin
    R.Visit_Tag := 'I'; --------------------------------------------------- I
  end Initialize;

  procedure Adjust( R: in out Root_Controlled ) is
  begin
    R.Visit_Tag := 'A'; --------------------------------------------------- A
  end Adjust;

  procedure Initialize( R: in out Root_Limited_Controlled ) is
  begin
    R.Visit_Tag := 'i'; --------------------------------------------------- i
  end Initialize;

  procedure Adjust( R: in out Root_Limited_Controlled ) is
  begin
    Report.Failed("Adjust called for Limited_Controlled type");
  end Adjust;

end C760002_0;

---------------------------------------------------------------- C760002_1

with Ada.Finalization;
with C760002_0;
package C760002_1 is

  type Proc_ID is (None, Init, Adj, Fin);

  type Test_Controlled is new C760002_0.Root_Controlled with record
    Last_Proc_Called: Proc_ID := None;
  end record;

  procedure Initialize( TC: in out Test_Controlled );
  procedure Adjust    ( TC: in out Test_Controlled );
  procedure Finalize  ( TC: in out Test_Controlled );

  type Nested_Controlled is new C760002_0.Root_Controlled with record
    Nested : C760002_0.Root_Controlled;
    Last_Proc_Called: Proc_ID := None;
  end record;

  procedure Initialize( TC: in out Nested_Controlled );
  procedure Adjust    ( TC: in out Nested_Controlled );
  procedure Finalize  ( TC: in out Nested_Controlled );

  type Test_Limited_Controlled is
       new C760002_0.Root_Limited_Controlled with record
    Last_Proc_Called: Proc_ID := None;
  end record;

  procedure Initialize( TC: in out Test_Limited_Controlled );
  procedure Adjust    ( TC: in out Test_Limited_Controlled );
  procedure Finalize  ( TC: in out Test_Limited_Controlled );

  type Nested_Limited_Controlled is
       new C760002_0.Root_Limited_Controlled with record
    Nested : C760002_0.Root_Limited_Controlled;
    Last_Proc_Called: Proc_ID := None;
  end record;

  procedure Initialize( TC: in out Nested_Limited_Controlled );
  procedure Adjust    ( TC: in out Nested_Limited_Controlled );
  procedure Finalize  ( TC: in out Nested_Limited_Controlled );

end C760002_1;

with Report;
package body C760002_1 is

  procedure Initialize( TC: in out Test_Controlled ) is
  begin
    TC.Last_Proc_Called := Init;
    C760002_0.Initialize(C760002_0.Root_Controlled(TC));
  end Initialize;

  procedure Adjust    ( TC: in out Test_Controlled ) is
  begin
    TC.Last_Proc_Called := Adj;
    C760002_0.Adjust(C760002_0.Root_Controlled(TC));
  end Adjust;

  procedure Finalize  ( TC: in out Test_Controlled ) is
  begin
    TC.Last_Proc_Called := Fin;
  end Finalize;

  procedure Initialize( TC: in out Nested_Controlled ) is
  begin
    TC.Last_Proc_Called := Init;
    C760002_0.Initialize(C760002_0.Root_Controlled(TC));
  end Initialize;

  procedure Adjust    ( TC: in out Nested_Controlled ) is
  begin
    TC.Last_Proc_Called := Adj;
    C760002_0.Adjust(C760002_0.Root_Controlled(TC));
  end Adjust;

  procedure Finalize  ( TC: in out Nested_Controlled ) is
  begin
    TC.Last_Proc_Called := Fin;
  end Finalize;

  procedure Initialize( TC: in out Test_Limited_Controlled ) is
  begin
    TC.Last_Proc_Called := Init;
    C760002_0.Initialize(C760002_0.Root_Limited_Controlled(TC));
  end Initialize;

  procedure Adjust    ( TC: in out Test_Limited_Controlled ) is
  begin
    Report.Failed("Adjust called for Test_Limited_Controlled");
  end Adjust;

  procedure Finalize  ( TC: in out Test_Limited_Controlled ) is
  begin
    TC.Last_Proc_Called := Fin;
  end Finalize;

  procedure Initialize( TC: in out Nested_Limited_Controlled ) is
  begin
    TC.Last_Proc_Called := Init;
    C760002_0.Initialize(C760002_0.Root_Limited_Controlled(TC));
  end Initialize;

  procedure Adjust    ( TC: in out Nested_Limited_Controlled ) is
  begin
    Report.Failed("Adjust called for Nested_Limited_Controlled");
  end Adjust;

  procedure Finalize  ( TC: in out Nested_Limited_Controlled ) is
  begin
    TC.Last_Proc_Called := Fin;
  end Finalize;

end C760002_1;

---------------------------------------------------------------- C760002

with Report;
with TCTouch;
with C760002_0;
with C760002_1;
with Ada.Finalization;
procedure C760002 is

  use type C760002_1.Proc_ID;

  -- in the first test, test the simple cases.
  -- Also check that assignment causes a call to Adjust for a controlled
  -- object.  Check that assignment of a non-controlled object does not call
  -- an Adjust procedure.

  procedure Check_Simple_Objects is

    A,B : C760002_0.Root;
    S,T : C760002_1.Test_Controlled;
    Q   : C760002_1.Test_Limited_Controlled;  -- Adjust call shouldn't happen
  begin

    S := T;

    TCTouch.Assert((S.Last_Proc_Called = C760002_1.Adj),
                   "Adjust for simple object");
    TCTouch.Assert((S.My_ID = T.My_ID),
                   "Assignment failed for simple object");

    -- Check that adjust was called
    TCTouch.Assert((S.Visit_Tag = 'A'), "Adjust timing incorrect");

    -- Check that Adjust has not been called
    TCTouch.Assert_Not((T.Visit_Tag = 'A'), "Adjust incorrectly called");

    -- Check that Adjust does not get called
    A.My_ID := A.My_ID +1;
    B := A;  -- see: Adjust: Report.Failed

  end Check_Simple_Objects;

  -- in the second test, test a more complex case, check that a controlled
  -- component of a controlled object gets processed correctly

  procedure Check_Nested_Objects is
    NO1 : C760002_1.Nested_Controlled;
    NO2 : C760002_1.Nested_Controlled := NO1;

  begin

    -- NO2 should be flagged with adjust markers
    TCTouch.Assert((NO2.Last_Proc_Called = C760002_1.Adj),
                   "Adjust not called for NO2 enclosure declaration");
    TCTouch.Assert((NO2.Nested.Visit_Tag = 'A'),
                   "Adjust not called for NO2 enclosed declaration");

    NO2.Visit_Tag := 'x';
    NO2.Nested.Visit_Tag := 'y';

    NO1 := NO2;

    -- NO1 should be flagged with adjust markers
    TCTouch.Assert((NO1.Visit_Tag = 'A'),
                   "Adjust not called for NO1 enclosure declaration");
    TCTouch.Assert((NO1.Nested.Visit_Tag = 'A'),
                   "Adjust not called for NO1 enclosed declaration");

  end Check_Nested_Objects;

  procedure Check_Array_Case is
    type Array_Simple is array(1..4) of C760002_1.Test_Controlled;
    type Array_Nested is array(1..4) of C760002_1.Nested_Controlled;

    Left,Right      : Array_Simple;
    Overlap         : Array_Simple := Left;

    Sinister,Dexter : Array_Nested;
    Underlap        : Array_Nested := Sinister;

    Now : Natural;

  begin

    -- get a current unique value since initializations
    Now := C760002_0.Unique_Value;

    -- check results of declarations
    for N in 1..4 loop
      TCTouch.Assert(Left(N).My_Id < Now,
                     "Initialize for array initial value");
      TCTouch.Assert(Overlap(N).My_Id < Now,
                     "Adjust for nested array (outer) initial value");
      TCTouch.Assert(Sinister(N).Nested.My_Id < Now,
                     "Initialize for nested array (inner) initial value");
      TCTouch.Assert(Sinister(N).My_Id < Sinister(N).Nested.My_Id,
                     "Initialize for enclosure should be after enclosed");
      TCTouch.Assert(Overlap(N).Visit_Tag = 'A',"Adjust at declaration");
      TCTouch.Assert(Underlap(N).Nested.Visit_Tag = 'A',
                     "Adjust at declaration, nested object");
    end loop;

    -- set visit tags
    for O in 1..4 loop
      Overlap(O).Visit_Tag         := 'X';
      Underlap(O).Visit_Tag        := 'Y';
      Underlap(O).Nested.Visit_Tag := 'y';
    end loop;

    -- check that overlapping assignments don't cause odd grief
    Overlap(1..3)  := Overlap(2..4);
    Underlap(2..4) := Underlap(1..3);

    for M in 2..3 loop
      TCTouch.Assert(Overlap(M).Last_Proc_Called = C760002_1.Adj,
                     "Adjust for overlap");
      TCTouch.Assert(Overlap(M).Visit_Tag = 'A',
                     "Adjust for overlap ID");
      TCTouch.Assert(Underlap(M).Last_Proc_Called = C760002_1.Adj,
                     "Adjust for Underlap");
      TCTouch.Assert(Underlap(M).Nested.Visit_Tag = 'A',
                     "Adjust for Underlaps nested ID");
    end loop;

  end Check_Array_Case;

  procedure Check_Access_Case is
    type TC_Ref is access C760002_1.Test_Controlled;
    type NC_Ref is access C760002_1.Nested_Controlled;
    type TL_Ref is access C760002_1.Test_Limited_Controlled;
    type NL_Ref is access C760002_1.Nested_Limited_Controlled;

    A,B : TC_Ref;
    C,D : NC_Ref;
    E   : TL_Ref;
    F   : NL_Ref;

  begin

    A := new C760002_1.Test_Controlled;
    B := new C760002_1.Test_Controlled'( A.all );

    C := new C760002_1.Nested_Controlled;
    D := new C760002_1.Nested_Controlled'( C.all );

    E := new C760002_1.Test_Limited_Controlled;
    F := new C760002_1.Nested_Limited_Controlled;

    TCTouch.Assert(A.Visit_Tag = 'I',"TC Allocation");
    TCTouch.Assert(B.Visit_Tag = 'A',"TC Allocation, with value");

    TCTouch.Assert(C.Visit_Tag = 'I',"NC Allocation");
    TCTouch.Assert(C.Nested.Visit_Tag = 'I',"NC Allocation, Nested");
    TCTouch.Assert(D.Visit_Tag = 'A',"NC Allocation, with value");
    TCTouch.Assert(D.Nested.Visit_Tag = 'A',
                   "NC Allocation, Nested, with value");

    TCTouch.Assert(E.Visit_Tag = 'i',"TL Allocation");
    TCTouch.Assert(F.Visit_Tag = 'i',"NL Allocation");

    A.all := B.all;
    C.all := D.all;

    TCTouch.Assert(A.Visit_Tag = 'A',"TC Assignment");
    TCTouch.Assert(C.Visit_Tag = 'A',"NC Assignment");
    TCTouch.Assert(C.Nested.Visit_Tag = 'A',"NC Assignment, Nested");

  end Check_Access_Case;

  procedure Check_Access_Limited_Array_Case is
    type Array_Simple is array(1..4) of C760002_1.Test_Limited_Controlled;
    type AS_Ref is access Array_Simple;
    type Array_Nested is array(1..4) of C760002_1.Nested_Limited_Controlled;
    type AN_Ref is access Array_Nested;

    Simple_Array_Limited : AS_Ref;

    Nested_Array_Limited : AN_Ref;

  begin

    Simple_Array_Limited := new Array_Simple;

    Nested_Array_Limited := new Array_Nested;
    
    for N in 1..4 loop
      TCTouch.Assert(Simple_Array_Limited(N).Last_Proc_Called
                     = C760002_1.Init,  
                     "Initialize for array initial value");
      TCTouch.Assert(Nested_Array_Limited(N).Last_Proc_Called
                     = C760002_1.Init,
                     "Initialize for nested array (outer) initial value");
      TCTouch.Assert(Nested_Array_Limited(N).Nested.Visit_Tag = 'i',
                     "Initialize for nested array (inner) initial value");
    end loop;
  end Check_Access_Limited_Array_Case;

begin  -- Main test procedure.

  Report.Test ("C760002", "Check that assignment causes the Adjust " &
                          "operation of the type to be called.  Check " &
                          "that Adjust is called after copying the " &
                          "value of the source expression to the target " &
                          "object.  Check that Adjust is called for all " &
                          "controlled components when the containing " &
                          "object is assigned.  Check that Adjust is " &
                          "called for components before the containing " &
                          "object is adjusted.  Check that Adjust is not " &
                          "called for a Limited_Controlled type by the " &
                          "implementation" );

  Check_Simple_Objects;

  Check_Nested_Objects;

  Check_Array_Case;

  Check_Access_Case;

  Check_Access_Limited_Array_Case;

  Report.Result;

end C760002;