1-- C760011.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 the anonymous objects of a controlled type associated with
28--      function results and aggregates are finalized no later than the
29--      end of the innermost enclosing declarative_item or statement.  Also
30--      check this for function calls and aggregates of a noncontrolled type
31--      with controlled components.
32--
33-- TEST DESCRIPTION:
34--      This test defines a controlled type with a discriminant, the
35--      discriminant is use as an index into a global table to indicate that
36--      the object has been finalized.  The controlled type is used as the
37--      component of a non-controlled type, and the non-controlled type is
38--      used for the same set of tests.  Following is a table of the tests
39--      performed and their associated tag character.
40--
41--      7.6(21) allows for the optimizations that remove these temporary
42--      objects from ever existing.  As such this test checks that in the
43--      case the object was initialized (the only access we have to
44--      determining if it ever existed) it must subsequently be finalized.
45--
46-- CASE TABLE:
47--      A - aggregate test, controlled
48--      B - aggregate test, controlled
49--      C - aggregate test, non_controlled
50--      D - function test, controlled
51--      E - function test, non_controlled
52--      F - formal parameter function test, controlled
53--      G - formal parameter aggregate test, controlled
54--      H - formal parameter function test, non_controlled
55--      I - formal parameter aggregate test, non_controlled
56--
57--      X - scratch object, not consequential to the objective
58--      Y - scratch object, not consequential to the objective
59--      Z - scratch object, not consequential to the objective
60--
61--
62-- CHANGE HISTORY:
63--      22 MAY 95   SAIC    Initial version
64--      24 APR 96   SAIC    Minor doc fixes, visibility patch
65--      14 NOV 96   SAIC    Revised for release 2.1
66--
67--!
68
69------------------------------------------------------------------- C760011_0
70
71with Ada.Finalization;
72package C760011_0 is
73  type Tracking_Array is array(Character range 'A'..'Z') of Boolean;
74
75  Initialized : Tracking_Array := (others => False);
76  Finalized   : Tracking_Array := (others => False);
77
78  type Controlled_Type(Tag : Character) is
79    new Ada.Finalization.Controlled with record
80      TC_Component : String(1..4) := "ACVC";
81    end record;
82  procedure Initialize( It: in out Controlled_Type );
83  procedure Finalize  ( It: in out Controlled_Type );
84  function Create(With_Tag: Character) return Controlled_Type;
85
86  type Non_Controlled(Tag : Character := 'Y') is record
87    Controlled_Component : Controlled_Type(Tag);
88  end record;
89  procedure Initialize( It: in out Non_Controlled );
90  procedure Finalize  ( It: in out Non_Controlled );
91  function Create(With_Tag: Character) return Non_Controlled;
92
93  Under_Debug : constant Boolean := False;  -- construction lines
94
95end C760011_0;
96
97-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
98
99with Report;
100package body C760011_0 is
101
102  procedure Initialize( It: in out Controlled_Type ) is
103  begin
104    It.TC_Component := (others => It.Tag);
105    if It.Tag in Tracking_Array'Range then
106      Initialized(It.Tag) := True;
107    end if;
108    if Under_Debug then
109      Report.Comment("Initializing Tag: " & It.Tag );
110    end if;
111  end Initialize;
112
113  procedure Finalize( It: in out Controlled_Type ) is
114  begin
115    if Under_Debug then
116      Report.Comment("Finalizing for Tag: " & It.Tag );
117    end if;
118    if It.Tag in Finalized'Range then
119      Finalized(It.Tag) := True;
120    end if;
121  end Finalize;
122
123  function Create(With_Tag: Character) return Controlled_Type is
124  begin
125    return Controlled_Type'(Ada.Finalization.Controlled
126                            with Tag          => With_Tag,
127                                 TC_Component => "*CON" );
128  end Create;
129
130  procedure Initialize( It: in out Non_Controlled ) is
131  begin
132    Report.Failed("Called Initialize for Non_Controlled");
133  end Initialize;
134
135  procedure Finalize( It: in out Non_Controlled ) is
136  begin
137    Report.Failed("Called Finalize for Non_Controlled");
138  end Finalize;
139
140  function Create(With_Tag: Character) return Non_Controlled is
141  begin
142    return Non_Controlled'(Tag => With_Tag, Controlled_Component => (
143                                  Ada.Finalization.Controlled
144                                    with Tag          => With_Tag,
145                                         TC_Component => "#NON" ) );
146  end Create;
147
148end C760011_0;
149
150--------------------------------------------------------------------- C760011
151
152with Report;
153with TCTouch;
154with C760011_0;
155with Ada.Finalization; -- needed to be able to create extension aggregates
156procedure C760011 is
157
158  use type C760011_0.Controlled_Type;
159  use type C760011_0.Controlled_Type'Class;
160  use type C760011_0.Non_Controlled;
161
162  subtype AFC is Ada.Finalization.Controlled;
163
164  procedure Check_Result( Tag : Character; Message : String ) is
165  -- make allowance for 7.6(21) optimizations
166  begin
167    if C760011_0.Initialized(Tag) then
168      TCTouch.Assert(C760011_0.Finalized(Tag),Message);
169    elsif C760011_0.Under_Debug then
170      Report.Comment("Optimized away: " & Tag );
171    end if;
172  end Check_Result;
173
174  procedure Subtest_1 is
175
176
177    procedure Subtest_1_Local_1 is
178      An_Object : C760011_0.Controlled_Type'Class
179                := C760011_0.Controlled_Type'(AFC with 'X', "ONE*");
180                   -- initialize An_Object
181    begin
182      if C760011_0.Controlled_Type(An_Object)
183         = C760011_0.Controlled_Type'(AFC with 'A', "ONE*") then
184        Report.Failed("Comparison bad");  -- A = X !!!
185      end if;
186    end Subtest_1_Local_1;
187    -- An_Object must be Finalized by this point.
188
189    procedure Subtest_1_Local_2 is
190      An_Object : C760011_0.Controlled_Type('B');
191    begin
192      An_Object := (AFC with 'B',  "TWO!" );
193      if Report.Ident_Char(An_Object.Tag) /= 'B' then
194        Report.Failed("Subtest_1_Local_2 Optimization Foil: Bad Data!");
195      end if;
196    exception
197      when others => Report.Failed("Bad controlled assignment");
198    end Subtest_1_Local_2;
199    -- An_Object must be Finalized by this point.
200
201    procedure Subtest_1_Local_3 is
202      An_Object : C760011_0.Non_Controlled('C');
203    begin
204      TCTouch.Assert_Not(C760011_0.Finalized('C'),
205                           "Non_Controlled declaration C");
206      An_Object := C760011_0.Non_Controlled'('C', Controlled_Component
207                                     => (AFC with 'C', "TEE!"));
208      if Report.Ident_Char(An_Object.Tag) /= 'C' then
209        Report.Failed("Subtest_1_Local_3 Optimization Foil: Bad Data!");
210      end if;
211    end Subtest_1_Local_3;
212    -- Only controlled components of An_Object must be finalized; it is an
213    -- error to call Finalize for An_Object
214
215  begin
216    Subtest_1_Local_1;
217    Check_Result( 'A', "Aggregate in subprogram 1" );
218
219    Subtest_1_Local_2;
220    Check_Result( 'B', "Aggregate in subprogram 2" );
221
222    Subtest_1_Local_3;
223    Check_Result( 'C', "Embedded aggregate in subprogram 3" );
224  end Subtest_1;
225
226
227  procedure Subtest_2 is
228    -- using 'Z' for both evades order issues
229    Con_Object : C760011_0.Controlled_Type('Z');
230    Non_Object : C760011_0.Non_Controlled('Z');
231  begin
232    if Report.Ident_Bool( Con_Object = C760011_0.Create('D') ) then
233      Report.Failed("Con_Object catastrophe");
234    end if;
235     -- Controlled function result should be finalized by now
236    Check_Result( 'D', "Function Result" );
237
238    if Report.Ident_Bool( Non_Object = C760011_0.Create('E') ) then
239      Report.Failed("Non_Object catastrophe");
240    end if;
241     -- Controlled component of function result should be finalized by now
242    Check_Result( 'E', "Function Result" );
243  end Subtest_2;
244
245
246  procedure Subtest_3(Con : in C760011_0.Controlled_Type) is
247  begin
248    if Con.Tag not in 'F'..'G' then
249      Report.Failed("Bad value passed to subtest 3 " & Con.Tag & ' '
250                    & Report.Ident_Str(Con.TC_Component));
251    end if;
252  end Subtest_3;
253
254
255  procedure Subtest_4(Non : in C760011_0.Non_Controlled) is
256  begin
257    if Non.Tag not in 'H'..'I' then
258      Report.Failed("Bad value passed to subtest 4 "
259                   & Non.Tag & ' '
260                   & Report.Ident_Str(Non.Controlled_Component.TC_Component));
261    end if;
262  end Subtest_4;
263
264
265begin  -- Main test procedure.
266
267  Report.Test ("C760011", "Check that anonymous objects of controlled " &
268                          "types or types containing controlled types " &
269                          "are finalized no later than the end of the " &
270                          "innermost enclosing declarative_item or " &
271                          "statement" );
272
273  Subtest_1;
274
275  Subtest_2;
276
277  Subtest_3(C760011_0.Create('F'));
278  Check_Result( 'F', "Function as formal F" );
279
280  Subtest_3(C760011_0.Controlled_Type'(AFC with 'G',"GIGI"));
281  Check_Result( 'G', "Aggregate as formal G" );
282
283  Subtest_4(C760011_0.Create('H'));
284  Check_Result( 'H', "Function as formal H" );
285
286  Subtest_4(C760011_0.Non_Controlled'('I', (AFC with 'I',"IAGO")));
287  Check_Result( 'I', "Aggregate as formal I" );
288
289  Report.Result;
290
291end C760011;
292