1-- CC40001.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 on the value of a constant object created
28--      by the evaluation of a generic association for a formal object of
29--      mode in.
30--
31--      Check that those values are also subsequently finalized.
32--
33-- TEST DESCRIPTION:
34--      Create a backdrop of a controlled type sufficient to check that the
35--      correct operations get called at appropriate times.  Create a generic
36--      unit that takes a formal parameter of a formal type.  Create instances
37--      of this generic using various "levels" of the controlled type.  Check
38--      the same case for a generic child unit.
39--
40--      The cases tested are where the type of the formal object is:
41--        a visible classwide type  : CC40001_2
42--        a formal private type     : CC40001_3
43--        a formal tagged type      : CC40001_4
44--
45--      To more fully take advantage of the features of the language, and
46--      present a test which is "user oriented" this test utilizes multiple
47--      aspects of the language in combination.  Using Ada.Strings.Unbounded
48--      in combination with Ada.Finalization and Ada.Calendar to build layers
49--      of an object oriented system will likely be very common in actual
50--      practice.  A common paradigm in the language will also be the use of
51--      a parent package defining "basic" tagged types, and child packages
52--      will expand on those types via derivation.  The model used in this
53--      test is a simple type containing a character identity (used in the
54--      identity).  The next level of type add a timestamp.  Further levels
55--      might add location information, etc. however for the purposes of this
56--      test we stop at the second layer, as it is sufficient to test the
57--      stated objective.
58--
59--
60-- CHANGE HISTORY:
61--      06 FEB 96   SAIC   Initial version
62--      30 APR 96   SAIC   Added finalization checks for 2.1
63--      13 FEB 97   PWB.CTA  Moved global objects into bodies, after Initialize
64--                         body is elaborated; counted finalizations correctly.
65--!
66
67----------------------------------------------------------------- CC40001_0
68
69with Ada.Finalization;
70with Ada.Strings.Unbounded;
71package CC40001_0 is
72
73  type States is ( Erroneous, Defaulted, Initialized, Reset, Adjusted );
74
75  type Simple_Object(ID: Character) is
76    new Ada.Finalization.Controlled with
77      record
78        TC_Current_State : States := Defaulted;
79        Name : Ada.Strings.Unbounded.Unbounded_String;
80      end record;
81
82  procedure User_Operation( COB: in out Simple_Object; Name : String );
83  procedure Initialize( COB: in out Simple_Object );
84  procedure Adjust    ( COB: in out Simple_Object );
85  procedure Finalize  ( COB: in out Simple_Object );
86
87  Finalization_Count : Natural;
88
89end CC40001_0;
90
91-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
92
93with Report;
94with TCTouch;
95package body CC40001_0 is
96
97  procedure User_Operation( COB: in out Simple_Object; Name : String ) is
98  begin
99    COB.Name := Ada.Strings.Unbounded.To_Unbounded_String(Name);
100  end User_Operation;
101
102  procedure Initialize( COB: in out Simple_Object ) is
103  begin
104    COB.TC_Current_State := Initialized;
105  end Initialize;
106
107  procedure Adjust    ( COB: in out Simple_Object ) is
108  begin
109    COB.TC_Current_State := Adjusted;
110    TCTouch.Touch('A');  -------------------------------------------------- A
111    TCTouch.Touch(COB.ID); ------------------------------------------------ ID
112    -- note that the calls to touch will not be directly validated, it is
113    -- expected that some number > 0 of calls will be made to this procedure,
114    -- the subtests then clear (Flush) the Touch buffer and perform actions
115    -- where an incorrect implementation might call this procedure.  Such a
116    -- call will fail on the attempt to "Validate" the null string.
117  end Adjust;
118
119  procedure Finalize  ( COB: in out Simple_Object ) is
120  begin
121    COB.TC_Current_State := Erroneous;
122    Finalization_Count := Finalization_Count +1;
123  end Finalize;
124
125  TC_Global_Object : Simple_Object('G');
126
127end CC40001_0;
128
129----------------------------------------------------------------- CC40001_1
130
131with Ada.Calendar;
132package CC40001_0.CC40001_1 is
133
134  type Object_In_Time(ID: Character) is
135    new Simple_Object(ID) with
136      record
137        Birth : Ada.Calendar.Time;
138        Activity : Ada.Calendar.Time;
139      end record;
140
141  procedure User_Operation( COB: in out Object_In_Time;
142                           Name: String );
143
144  procedure Initialize( COB: in out Object_In_Time );
145  procedure Adjust    ( COB: in out Object_In_Time );
146  procedure Finalize  ( COB: in out Object_In_Time );
147
148end CC40001_0.CC40001_1;
149
150-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
151
152with Report;
153with TCTouch;
154package body CC40001_0.CC40001_1 is
155
156  procedure Initialize( COB: in out Object_In_Time ) is
157  begin
158    COB.TC_Current_State := Initialized;
159    COB.Birth := Ada.Calendar.Clock;
160  end Initialize;
161
162  procedure Adjust    ( COB: in out Object_In_Time ) is
163  begin
164    COB.TC_Current_State := Adjusted;
165    TCTouch.Touch('a');    ------------------------------------------------ a
166    TCTouch.Touch(COB.ID); ------------------------------------------------ ID
167  end Adjust;
168
169  procedure Finalize  ( COB: in out Object_In_Time ) is
170  begin
171    COB.TC_Current_State := Erroneous;
172    Finalization_Count := Finalization_Count +1;
173  end Finalize;
174
175  procedure User_Operation( COB: in out Object_In_Time;
176                           Name: String ) is
177  begin
178    CC40001_0.User_Operation( Simple_Object(COB), Name );
179    COB.Activity := Ada.Calendar.Clock;
180    COB.TC_Current_State := Reset;
181  end User_Operation;
182
183  TC_Time_Object  : Object_In_Time('g');
184
185end CC40001_0.CC40001_1;
186
187----------------------------------------------------------------- CC40001_2
188
189generic
190  TC_Check_Object : in CC40001_0.Simple_Object'Class;
191package CC40001_0.CC40001_2 is
192  procedure TC_Verify_State;
193end CC40001_0.CC40001_2;
194
195-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
196
197with Report;
198package body CC40001_0.CC40001_2 is
199
200  procedure TC_Verify_State is
201  begin
202    if TC_Check_Object.TC_Current_State /= Adjusted then
203      Report.Failed( "CC40001_2 : Formal Object not adjusted" );
204    end if;
205  end TC_Verify_State;
206
207end CC40001_0.CC40001_2;
208
209----------------------------------------------------------------- CC40001_3
210
211generic
212  type Formal_Private(<>) is private;
213  TC_Check_Object : in Formal_Private;
214  with function Bad_Status( O: Formal_Private ) return Boolean;
215package CC40001_0.CC40001_3 is
216  procedure TC_Verify_State;
217end CC40001_0.CC40001_3;
218
219-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
220
221with Report;
222package body CC40001_0.CC40001_3 is
223
224  procedure TC_Verify_State is
225  begin
226    if Bad_Status( TC_Check_Object ) then
227      Report.Failed( "CC40001_3 : Formal Object not adjusted" );
228    end if;
229  end TC_Verify_State;
230
231end CC40001_0.CC40001_3;
232
233----------------------------------------------------------------- CC40001_4
234
235generic
236  type Formal_Tagged_Private(<>) is tagged private;
237  TC_Check_Object : in Formal_Tagged_Private;
238  with function Bad_Status( O: Formal_Tagged_Private ) return Boolean;
239package CC40001_0.CC40001_4 is
240  procedure TC_Verify_State;
241end CC40001_0.CC40001_4;
242
243-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
244
245with Report;
246package body CC40001_0.CC40001_4 is
247
248  procedure TC_Verify_State is
249  begin
250    if Bad_Status( TC_Check_Object ) then
251      Report.Failed( "CC40001_4 : Formal Object not adjusted" );
252    end if;
253  end TC_Verify_State;
254
255end CC40001_0.CC40001_4;
256
257------------------------------------------------------------------- CC40001
258
259with Report;
260with TCTouch;
261with CC40001_0.CC40001_1;
262with CC40001_0.CC40001_2;
263with CC40001_0.CC40001_3;
264with CC40001_0.CC40001_4;
265procedure CC40001 is
266
267  function Not_Adjusted( CO : CC40001_0.Simple_Object )
268    return Boolean is
269     use type CC40001_0.States;
270  begin
271    return CO.TC_Current_State /= CC40001_0.Adjusted;
272  end Not_Adjusted;
273
274  function Not_Adjusted( CO : CC40001_0.CC40001_1.Object_In_Time )
275    return Boolean is
276     use type CC40001_0.States;
277  begin
278    return CO.TC_Current_State /= CC40001_0.Adjusted;
279  end Not_Adjusted;
280
281   -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Subtest 1
282
283  procedure Subtest_1 is
284    Object_0 : CC40001_0.Simple_Object('T');
285    Object_1 : CC40001_0.CC40001_1.Object_In_Time('t');
286
287    package Subtest_1_1 is
288      new CC40001_0.CC40001_2( Object_0 ); -- classwide generic formal object
289
290    package Subtest_1_2 is
291      new CC40001_0.CC40001_2( Object_1 ); -- classwide generic formal object
292  begin
293    TCTouch.Flush;  -- clear out all "A" and "T" entries, no further calls
294                    -- to Touch should occur before the call to Validate
295
296    -- set the objects TC_Current_State to "Reset"
297    CC40001_0.User_Operation( Object_0, "Subtest 1" );
298    CC40001_0.CC40001_1.User_Operation( Object_1, "Subtest 1" );
299
300    -- check that the objects TC_Current_State is "Adjusted"
301    Subtest_1_1.TC_Verify_State;
302    Subtest_1_2.TC_Verify_State;
303
304    TCTouch.Validate( "", "No actions should occur here, subtest 1" );
305
306  end Subtest_1;
307
308   -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Subtest 2
309
310  procedure Subtest_2 is
311    Object_0 : CC40001_0.Simple_Object('T');
312    Object_1 : CC40001_0.CC40001_1.Object_In_Time('t');
313
314    package Subtest_2_1 is -- generic formal object is discriminated private
315      new CC40001_0.CC40001_3( CC40001_0.Simple_Object,
316                               Object_0,
317                               Not_Adjusted );
318
319    package Subtest_2_2 is -- generic formal object is discriminated private
320      new CC40001_0.CC40001_3( CC40001_0.CC40001_1.Object_In_Time,
321                               Object_1,
322                               Not_Adjusted );
323
324  begin
325    TCTouch.Flush;  -- clear out all "A" and "T" entries
326
327    -- set the objects state to "Reset"
328    CC40001_0.User_Operation( Object_0, "Subtest 2" );
329    CC40001_0.CC40001_1.User_Operation( Object_1, "Subtest 2" );
330
331    Subtest_2_1.TC_Verify_State;
332    Subtest_2_2.TC_Verify_State;
333
334    TCTouch.Validate( "", "No actions should occur here, subtest 2" );
335
336  end Subtest_2;
337
338   -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Subtest 3
339
340  procedure Subtest_3 is
341    Object_0 : CC40001_0.Simple_Object('T');
342    Object_1 : CC40001_0.CC40001_1.Object_In_Time('t');
343
344    package Subtest_3_1 is -- generic formal object is discriminated tagged
345      new CC40001_0.CC40001_4( CC40001_0.Simple_Object,
346                               Object_0,
347                               Not_Adjusted );
348
349    package Subtest_3_2 is -- generic formal object is discriminated tagged
350      new CC40001_0.CC40001_4( CC40001_0.CC40001_1.Object_In_Time,
351                               Object_1,
352                               Not_Adjusted );
353  begin
354    TCTouch.Flush;  -- clear out all "A" and "T" entries
355
356    -- set the objects state to "Reset"
357    CC40001_0.User_Operation( Object_0, "Subtest 3" );
358    CC40001_0.CC40001_1.User_Operation( Object_1, "Subtest 3" );
359
360    Subtest_3_1.TC_Verify_State;
361    Subtest_3_2.TC_Verify_State;
362
363    TCTouch.Validate( "", "No actions should occur here, subtest 3" );
364
365  end Subtest_3;
366
367begin  -- Main test procedure.
368
369  Report.Test ("CC40001", "Check that adjust and finalize are called on " &
370                          "the constant object created by the " &
371                          "evaluation of a generic association for a " &
372                          "formal object of mode in" );
373
374  -- check that the created constant objects are properly adjusted
375  -- and subsequently finalized
376
377  CC40001_0.Finalization_Count := 0;
378
379  Subtest_1;
380
381  if CC40001_0.Finalization_Count < 4 then
382    Report.Failed("Insufficient Finalizations for Subtest 1");
383  end if;
384
385  CC40001_0.Finalization_Count := 0;
386
387  Subtest_2;
388
389  if CC40001_0.Finalization_Count < 4 then
390    Report.Failed("Insufficient Finalizations for Subtest 2");
391  end if;
392
393  CC40001_0.Finalization_Count := 0;
394
395  Subtest_3;
396
397  if CC40001_0.Finalization_Count < 4 then
398    Report.Failed("Insufficient Finalizations for Subtest 3");
399  end if;
400
401  Report.Result;
402
403end CC40001;
404