old-autovect-branch/gcc/testsuite/ada/acats/tests/cc/cc40001.a

   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
  69 with Ada.Finalization;
  70 with Ada.Strings.Unbounded;
  71 package 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
  89 end CC40001_0;
  90
  91 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
  92
  93 with Report;
  94 with TCTouch;
  95 package 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
 127 end CC40001_0;
 128
 129 ----------------------------------------------------------------- CC40001_1
 130
 131 with Ada.Calendar;
 132 package 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
 148 end CC40001_0.CC40001_1;
 149
 150 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 151
 152 with Report;
 153 with TCTouch;
 154 package 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
 185 end CC40001_0.CC40001_1;
 186
 187 ----------------------------------------------------------------- CC40001_2
 188
 189 generic
 190   TC_Check_Object : in CC40001_0.Simple_Object'Class;
 191 package CC40001_0.CC40001_2 is
 192   procedure TC_Verify_State;
 193 end CC40001_0.CC40001_2;
 194
 195 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 196
 197 with Report;
 198 package 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
 207 end CC40001_0.CC40001_2;
 208
 209 ----------------------------------------------------------------- CC40001_3
 210
 211 generic
 212   type Formal_Private(<>) is private;
 213   TC_Check_Object : in Formal_Private;
 214   with function Bad_Status( O: Formal_Private ) return Boolean;
 215 package CC40001_0.CC40001_3 is
 216   procedure TC_Verify_State;
 217 end CC40001_0.CC40001_3;
 218
 219 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 220
 221 with Report;
 222 package 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
 231 end CC40001_0.CC40001_3;
 232
 233 ----------------------------------------------------------------- CC40001_4
 234
 235 generic
 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;
 239 package CC40001_0.CC40001_4 is
 240   procedure TC_Verify_State;
 241 end CC40001_0.CC40001_4;
 242
 243 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 244
 245 with Report;
 246 package 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
 255 end CC40001_0.CC40001_4;
 256
 257 ------------------------------------------------------------------- CC40001
 258
 259 with Report;
 260 with TCTouch;
 261 with CC40001_0.CC40001_1;
 262 with CC40001_0.CC40001_2;
 263 with CC40001_0.CC40001_3;
 264 with CC40001_0.CC40001_4;
 265 procedure 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
 367 begin  -- 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
 403 end CC40001;