1-- C760007.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 Adjust is called for the execution of a return
28--      statement for a function returning a result of a (non-limited)
29--      controlled type.
30--
31--      Check that Adjust is called when evaluating an aggregate
32--      component association for a controlled component.
33--
34--      Check that Adjust is called for the assignment of the ancestor
35--      expression of an extension aggregate when the type of the
36--      aggregate is controlled.
37--
38-- TEST DESCRIPTION:
39--      A type is derived from Ada.Finalization.Controlled; the dispatching
40--      procedure Adjust is defined for the new type.  Structures and
41--      subprograms to model the test objectives are used to check that
42--      Adjust is called at the right time.  For the sake of simplicity,
43--      globally accessible data is used to check that the calls are made.
44--
45--
46-- CHANGE HISTORY:
47--      06 DEC 94   SAIC    ACVC 2.0
48--      14 OCT 95   SAIC    Update and repair for ACVC 2.0.1
49--      05 APR 96   SAIC    Add RM reference
50--      06 NOV 96   SAIC    Reduce adjust requirement
51--      25 NOV 97   EDS     Allowed zero calls to adjust at line 144
52--!
53
54---------------------------------------------------------------- C760007_0
55
56with Ada.Finalization;
57package C760007_0 is
58
59  type Controlled is new Ada.Finalization.Controlled with record
60    TC_ID : Natural := Natural'Last;
61  end record;
62  procedure Adjust( Object: in out Controlled );
63
64  type Structure is record
65    Controlled_Component : Controlled;
66  end record;
67
68  type Child is new Controlled with record
69    TC_XX : Natural := Natural'Last;
70  end record;
71  procedure Adjust( Object: in out Child );
72
73  Adjust_Count       : Natural := 0;
74  Child_Adjust_Count : Natural := 0;
75
76end C760007_0;
77
78package body C760007_0 is
79
80  procedure Adjust( Object: in out Controlled ) is
81  begin
82    Adjust_Count := Adjust_Count +1;
83  end Adjust;
84
85  procedure Adjust( Object: in out Child ) is
86  begin
87    Child_Adjust_Count := Child_Adjust_Count +1;
88  end Adjust;
89
90end C760007_0;
91
92------------------------------------------------------------------ C760007
93
94with Report;
95with C760007_0;
96procedure C760007 is
97
98  procedure Check_Adjust_Count(Message: String;
99                               Min: Natural := 1;
100                               Max: Natural := 2) is
101  begin
102
103     -- in order to allow for the anonymous objects referred to in
104     -- the reference manual, the check for calls to Adjust must be
105     -- in a range.  This number must then be further adjusted
106     -- to allow for the optimization that does not call for an adjust
107     -- of an aggregate initial value built directly in the object
108
109     if C760007_0.Adjust_Count not in Min..Max then
110       Report.Failed(Message
111                   & " = " & Natural'Image(C760007_0.Adjust_Count));
112     end if;
113     C760007_0.Adjust_Count := 0;
114  end Check_Adjust_Count;
115
116  procedure Check_Child_Adjust_Count(Message: String;
117                                     Min: Natural := 1;
118                                     Max: Natural := 2) is
119  begin
120     -- ditto above
121
122     if C760007_0.Child_Adjust_Count not in Min..Max then
123       Report.Failed(Message
124                   & " = " & Natural'Image(C760007_0.Child_Adjust_Count));
125     end if;
126     C760007_0.Child_Adjust_Count := 0;
127  end Check_Child_Adjust_Count;
128
129  Object : C760007_0.Controlled;
130
131--      Check that Adjust is called for the execution of a return
132--      statement for a function returning a result of a (non-limited)
133--      controlled type or a result of a noncontrolled type with
134--      controlled components.
135
136  procedure Subtest_1 is
137    function Create return C760007_0.Controlled is
138      New_Object : C760007_0.Controlled;
139    begin
140      return New_Object;
141    end Create;
142
143    procedure Examine( Thing : in C760007_0.Controlled ) is
144    begin
145      Check_Adjust_Count("Function call passed as parameter",0);
146    end Examine;
147
148  begin
149    -- this assignment must call Adjust:
150    --   1: on the value resulting from the function
151    --      ** unless this is optimized out by building the result directly
152    --         in the target object.
153    --   2: on Object once it's been assigned
154    -- may call adjust
155    --   1: for a anonymous object created in the evaluation of the function
156    --   2: for a anonymous object created in the assignment operation
157
158    Object := Create;
159
160    Check_Adjust_Count("Function call",1,4);
161
162    Examine( Create );
163
164  end Subtest_1;
165
166--      Check that Adjust is called when evaluating an aggregate
167--      component association for a controlled component.
168
169  procedure Subtest_2 is
170    S : C760007_0.Structure;
171
172    procedure Examine( Thing : in C760007_0.Structure ) is
173    begin
174      Check_Adjust_Count("Aggregate passed as parameter");
175    end Examine;
176
177  begin
178    -- this assignment must call Adjust:
179    --   1: on the value resulting from the aggregate
180    --      ** unless this is optimized out by building the result directly
181    --         in the target object.
182    --   2: on Object once it's been assigned
183    -- may call adjust
184    --   1: for a anonymous object created in the evaluation of the aggregate
185    --   2: for a anonymous object created in the assignment operation
186    S := ( Controlled_Component => Object );
187    Check_Adjust_Count("Aggregate and Assignment", 1, 4);
188
189    Examine( C760007_0.Structure'(Controlled_Component => Object) );
190  end Subtest_2;
191
192--      Check that Adjust is called for the assignment of the ancestor
193--      expression of an extension aggregate when the type of the
194--      aggregate is controlled.
195
196  procedure Subtest_3 is
197    Bambino : C760007_0.Child;
198
199    procedure Examine( Thing : in C760007_0.Child ) is
200    begin
201      Check_Adjust_Count("Extension aggregate as parameter (ancestor)", 0, 2);
202      Check_Child_Adjust_Count("Extension aggregate as parameter", 0, 4);
203    end Examine;
204
205  begin
206    -- implementation permissions make all of the following calls to adjust
207    -- optional:
208    -- these assignments may call Adjust:
209    --   1: on the value resulting from the aggregate
210    --   2: on Object once it's been assigned
211    --   3: for a anonymous object created in the evaluation of the aggregate
212    --   4: for a anonymous object created in the assignment operation
213    Bambino := ( Object with TC_XX => 10 );
214    Check_Adjust_Count("Ancestor (expression) part of aggregate", 0, 2);
215    Check_Child_Adjust_Count("Child aggregate assignment 1", 0, 4 );
216
217    Bambino := ( C760007_0.Controlled with TC_XX => 11 );
218    Check_Adjust_Count("Ancestor (subtype_mark) part of aggregate", 0, 2);
219    Check_Child_Adjust_Count("Child aggregate assignment 2", 0, 4 );
220
221    Examine( ( Object with TC_XX => 21 ) );
222
223    Examine( ( C760007_0.Controlled with TC_XX => 37 ) );
224
225  end Subtest_3;
226
227begin  -- Main test procedure.
228
229  Report.Test ("C760007", "Check that Adjust is called for the " &
230                          "execution of a return statement for a " &
231                          "function returning a result containing a " &
232                          "controlled type.  Check that Adjust is " &
233                          "called when evaluating an aggregate " &
234                          "component association for a controlled " &
235                          "component.  " &
236                          "Check that Adjust is called for the " &
237                          "assignment of the ancestor expression of an " &
238                          "extension aggregate when the type of the " &
239                          "aggregate is controlled" );
240
241  Subtest_1;
242  Subtest_2;
243  Subtest_3;
244
245  Report.Result;
246
247end C760007;
248