old-autovect-branch/gcc/testsuite/ada/acats/tests/c3/c3a0013.a

   1 -- C3A0013.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 a general access type object may reference allocated
  28 --      pool objects as well as aliased objects. (3,4)
  29 --      Check that formal parameters of tagged types are implicitly
  30 --      defined as aliased; check that the 'Access of these formal
  31 --      parameters designates the correct object with the correct
  32 --      tag. (5)
  33 --      Check that the current instance of a limited type is defined as
  34 --      aliased. (5)
  35 --
  36 -- TEST DESCRIPTION:
  37 --      This test takes from the hierarchy defined in C390003; making
  38 --      the root type Vehicle limited private.  It also shifts the
  39 --      abstraction to include the notion of a transmission, an object
  40 --      which is contained within any vehicle.  Using an access
  41 --      discriminant, any subprogram which operates on a transmission
  42 --      may also reference the vehicle in which it is installed.
  43 --
  44 --      Class Hierarchy:
  45 --              Vehicle         Transmission
  46 --               /   \
  47 --           Truck    Car
  48 --
  49 --      Contains:
  50 --                Vehicle( Transmission )
  51 --
  52 --
  53 --
  54 -- CHANGE HISTORY:
  55 --      06 Dec 94   SAIC    ACVC 2.0
  56 --      16 Dec 94   SAIC    Fixed accessibility problems
  57 --
  58 --!
  59
  60 package C3A0013_1 is
  61   type Vehicle is tagged limited private;
  62   type Vehicle_ID is access all Vehicle'Class;
  63
  64   -- Constructors
  65   procedure Create     ( It : in out Vehicle;
  66                          Wheels : Natural := 4 );
  67   -- Modifiers
  68   procedure Accelerate ( It : in out Vehicle );
  69   procedure Decelerate ( It : in out Vehicle );
  70   procedure Up_Shift   ( It : in out Vehicle );
  71   procedure Stop       ( It : in out Vehicle );
  72
  73   -- Selectors
  74   function  Speed      ( It : Vehicle ) return Natural;
  75   function  Wheels     ( It : Vehicle ) return Natural;
  76   function  Gear_Factor( It : Vehicle ) return Natural;
  77
  78   -- TC_Ops
  79   procedure TC_Validate( It : in out Vehicle; Speed_Trap : Natural );
  80
  81   -- dispatching procedure used to check tag correctness
  82   procedure TC_Validate( It     : Vehicle;
  83                          TC_ID  : Character);
  84
  85 private
  86
  87   type Transmission(Within: access Vehicle'Class) is limited record
  88     Engaged : Boolean := False;
  89     Gear    : Integer range -1..5 := 0;
  90   end record;
  91
  92   -- Current instance of a limited type is defined as aliased
  93
  94   type Vehicle is tagged limited record
  95     Wheels: Natural;
  96     Speed : Natural;
  97     Power_Train: Transmission( Vehicle'Access );
  98   end record;
  99 end C3A0013_1;
 100
 101 with C3A0013_1;
 102 package C3A0013_2 is
 103   type Car is new C3A0013_1.Vehicle with private;
 104   procedure TC_Validate( It     : Car;
 105                          TC_ID  : Character);
 106   function  Gear_Factor( It : Car ) return Natural;
 107 private
 108   type Car is new C3A0013_1.Vehicle with record
 109     Displacement : Natural;
 110   end record;
 111 end C3A0013_2;
 112
 113 with C3A0013_1;
 114 package C3A0013_3 is
 115   type Truck is new C3A0013_1.Vehicle with private;
 116   procedure TC_Validate( It     : Truck;
 117                          TC_ID  : Character);
 118   function  Gear_Factor( It : Truck ) return Natural;
 119 private
 120   type Truck is new C3A0013_1.Vehicle with record
 121     Displacement : Natural;
 122   end record;
 123 end C3A0013_3;
 124
 125 with Report;
 126 package body C3A0013_1 is
 127
 128   procedure Create    ( It : in out Vehicle;
 129                         Wheels : Natural := 4 ) is
 130   begin
 131     It.Wheels   := Wheels;
 132     It.Speed    := 0;
 133   end Create;
 134
 135   procedure Accelerate( It : in out Vehicle ) is
 136   begin
 137     It.Speed := It.Speed + Gear_Factor( It.Power_Train.Within.all );
 138   end Accelerate;
 139
 140   procedure Decelerate( It : in out Vehicle ) is
 141   begin
 142     It.Speed := It.Speed - Gear_Factor( It.Power_Train.Within.all );
 143   end Decelerate;
 144
 145   procedure Stop      ( It : in out Vehicle ) is
 146   begin
 147     It.Speed := 0;
 148     It.Power_Train.Engaged := False;
 149   end Stop;
 150
 151   function  Gear_Factor( It : Vehicle ) return Natural is
 152   begin
 153     return It.Power_Train.Gear;
 154   end Gear_Factor;
 155
 156   function  Speed     ( It : Vehicle ) return Natural is
 157   begin
 158     return It.Speed;
 159   end Speed;
 160
 161   function  Wheels     ( It : Vehicle ) return Natural is
 162   begin
 163     return It.Wheels;
 164   end Wheels;
 165
 166   -- formal tagged parameters are implicitly aliased
 167
 168   procedure TC_Validate( It : in out Vehicle; Speed_Trap : Natural ) is
 169     License: Vehicle_ID := It'Unchecked_Access;
 170   begin
 171     if Speed( License.all ) /= Speed_Trap then
 172       Report.Failed("Speed Trap: expected: " & Natural'Image(Speed_Trap));
 173     end if;
 174   end TC_Validate;
 175
 176   procedure TC_Validate( It     : Vehicle;
 177                          TC_ID  : Character) is
 178   begin
 179     if TC_ID /= 'V' then
 180       Report.Failed("Dispatched to Vehicle");
 181     end if;
 182     if Wheels( It ) /= 1 then
 183       Report.Failed("Not a Vehicle");
 184     end if;
 185   end TC_Validate;
 186
 187   procedure Up_Shift( It: in out Vehicle ) is
 188   begin
 189     It.Power_Train.Gear    := It.Power_Train.Gear +1;
 190     It.Power_Train.Engaged := True;
 191     Accelerate( It );
 192   end Up_Shift;
 193 end C3A0013_1;
 194
 195 with Report;
 196 package body C3A0013_2 is
 197
 198   procedure TC_Validate( It     : Car;
 199                          TC_ID  : Character ) is
 200   begin
 201     if TC_ID /= 'C' then
 202       Report.Failed("Dispatched to Car");
 203     end if;
 204     if Wheels( It ) /= 4 then
 205       Report.Failed("Not a Car");
 206     end if;
 207   end TC_Validate;
 208
 209   function  Gear_Factor( It : Car ) return Natural is
 210   begin
 211     return C3A0013_1.Gear_Factor( C3A0013_1.Vehicle( It ) )*2;
 212   end Gear_Factor;
 213
 214 end C3A0013_2;
 215
 216 with Report;
 217 package body C3A0013_3 is
 218
 219   procedure TC_Validate( It     : Truck;
 220                          TC_ID  : Character) is
 221   begin
 222     if TC_ID /= 'T' then
 223       Report.Failed("Dispatched to Truck");
 224     end if;
 225     if Wheels( It ) /= 3 then
 226       Report.Failed("Not a Truck");
 227     end if;
 228   end TC_Validate;
 229
 230   function  Gear_Factor( It : Truck ) return Natural is
 231   begin
 232     return C3A0013_1.Gear_Factor( C3A0013_1.Vehicle( It ) )*3;
 233   end Gear_Factor;
 234
 235 end C3A0013_3;
 236
 237 package C3A0013_4 is
 238   procedure Perform_Tests;
 239 end C3A0013_4;
 240
 241 with Report;
 242 with C3A0013_1;
 243 with C3A0013_2;
 244 with C3A0013_3;
 245 package body C3A0013_4 is
 246   package Root   renames C3A0013_1;
 247   package Cars   renames C3A0013_2;
 248   package Trucks renames C3A0013_3;
 249
 250   type Car_Pool is array(1..4) of aliased Cars.Car;
 251   Commuters : Car_Pool;
 252
 253   My_Car      : aliased Cars.Car;
 254   Company_Car : Root.Vehicle_ID;
 255   Repair_Shop : Root.Vehicle_ID;
 256
 257   The_Vehicle : Root.Vehicle;
 258   The_Car     : Cars.Car;
 259   The_Truck   : Trucks.Truck;
 260
 261   procedure TC_Dispatch( Ptr   : Root.Vehicle_ID;
 262                          Char  : Character ) is
 263   begin
 264     Root.TC_Validate( Ptr.all, Char );
 265   end TC_Dispatch;
 266
 267   procedure TC_Check_Formal_Access( Item: in out Root.Vehicle'Class;
 268                                     Char: Character) is
 269   begin
 270     TC_Dispatch( Item'Unchecked_Access, Char );
 271   end TC_Check_Formal_Access;
 272
 273   procedure Perform_Tests is
 274   begin  -- Main test procedure.
 275
 276   for Lane in Commuters'Range loop
 277     Cars.Create( Commuters(Lane) );
 278     for Excitement in 1..Lane loop
 279       Cars.Up_Shift( Commuters(Lane) );
 280     end loop;
 281   end loop;
 282
 283   Cars.Create( My_Car );
 284   Cars.Up_Shift( My_Car );
 285   Cars.TC_Validate( My_Car, 2 );
 286
 287   Root.Create( The_Vehicle, 1 );
 288   Cars.Create( The_Car    , 4 );
 289   Trucks.Create( The_Truck, 3 );
 290
 291   TC_Check_Formal_Access( The_Vehicle, 'V' );
 292   TC_Check_Formal_Access( The_Car,     'C' );
 293   TC_Check_Formal_Access( The_Truck,   'T' );
 294
 295   Root.Up_Shift( The_Vehicle );
 296   Cars.Up_Shift( The_Car );
 297   Trucks.Up_Shift( The_Truck );
 298
 299   Root.TC_Validate( The_Vehicle, 1 );
 300   Cars.TC_Validate( The_Car, 2 );
 301   Trucks.TC_Validate( The_Truck, 3 );
 302
 303   --  general access type may reference allocated objects
 304
 305   Company_Car := new Cars.Car;
 306   Root.Create( Company_Car.all );
 307   Root.Up_Shift( Company_Car.all );
 308   Root.Up_Shift( Company_Car.all );
 309   Root.TC_Validate( Company_Car.all, 6 );
 310
 311   --  general access type may reference aliased objects
 312
 313   Repair_Shop := My_Car'Access;
 314   Root.TC_Validate( Repair_Shop.all, 2 );
 315
 316   --  general access type may reference aliased objects
 317
 318   Construction: declare
 319     type Speed_List is array(Commuters'Range) of Natural;
 320     Accelerations : constant Speed_List := (2, 6, 12, 20);
 321   begin
 322     for Rotation in Commuters'Range loop
 323       Repair_Shop := Commuters(Rotation)'Access;
 324       Root.TC_Validate( Repair_Shop.all, Accelerations(Rotation) );
 325     end loop;
 326   end Construction;
 327
 328 end Perform_Tests;
 329
 330 end C3A0013_4;
 331
 332 with C3A0013_4;
 333 with Report;
 334 procedure C3A0013 is
 335 begin
 336
 337   Report.Test ("C3A0013", "Check general access types.  Check aliased "
 338                         & "nature of formal tagged type parameters.  "
 339                         & "Check aliased nature of the current "
 340                         & "instance of a limited type.  Check the "
 341                         & "constraining of actual subtypes for "
 342                         & "discriminated objects" );
 343
 344   C3A0013_4.Perform_Tests;
 345
 346   Report.Result;
 347 end C3A0013;