gcc/testsuite/ada/acats/tests/c3/c390003.a

   1 -- C390003.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 for a subtype S of a tagged type T, S'Class denotes a
  28 --     class-wide subtype.  Check that T'Tag denotes the tag of the type T,
  29 --     and that, for a class-wide tagged type X, X'Tag denotes the tag of X.
  30 --     Check that the tags of stand alone objects, record and array
  31 --     components, aggregates, and formal parameters identify their type.
  32 --     Check that the tag of a value of a formal parameter is that of the
  33 --     actual parameter, even if the actual is passed by a view conversion.
  34 --
  35 -- TEST DESCRIPTION:
  36 --     This test defines a class hierarchy (based on C390002) and
  37 --     uses it to determine the correctness of the resulting tag
  38 --     information generated by the compiler.  A type is defined in the
  39 --     class which contains components of the class as part of its
  40 --     definition.  This is to reduce the overall number of types
  41 --     required, and to achieve the required nesting to accomplish
  42 --     this test.  The model is that of a car carrier truck; both car
  43 --     and truck being in the class of Vehicle.
  44 --
  45 --      Class Hierarchy:
  46 --                         Vehicle - - - - - - - (Bicycle)
  47 --                        /   |   \               /      \
  48 --                   Truck   Car   Q_Machine   Tandem  Motorcycle
  49 --                     |
  50 --                Auto_Carrier
  51 --      Contains:
  52 --                Auto_Carrier( Car )
  53 --                Q_Machine( Car, Motorcycle )
  54 --
  55 --
  56 --
  57 -- CHANGE HISTORY:
  58 --      06 Dec 94   SAIC    ACVC 2.0
  59 --      19 Dec 94   SAIC    Removed ARM references from objective text.
  60 --      20 Dec 94   SAIC    Replaced three unnecessary extension
  61 --                          aggregates with simple aggregates.
  62 --      16 Oct 95   SAIC    Fixed bugs for ACVC 2.0.1
  63 --
  64 --!
  65
  66 ----------------------------------------------------------------- C390003_1
  67
  68 with Ada.Tags;
  69 package C390003_1 is -- Vehicle
  70
  71   type TC_Keys is (Veh, MC, Tand, Car, Q, Truk, Heavy);
  72   type States  is (Good, Flat, Worn);
  73
  74   type Wheel_List is array(Positive range <>) of States;
  75
  76   type Object(Wheels: Positive) is tagged record
  77     Wheel_State : Wheel_List(1..Wheels);
  78   end record;
  79
  80   procedure TC_Validate( It: Object; Key: TC_Keys );
  81   procedure TC_Validate( It: Object'Class; The_Tag: Ada.Tags.Tag );
  82
  83   procedure Create( The_Vehicle : in out Object; Tyres : in States );
  84   procedure Rotate( The_Vehicle : in out Object );
  85   function  Wheels( The_Vehicle : Object ) return Positive;
  86
  87 end C390003_1; -- Vehicle;
  88
  89 ----------------------------------------------------------------- C390003_2
  90
  91 with C390003_1;
  92 package C390003_2 is -- Motivators
  93
  94   package Vehicle renames C390003_1;
  95   subtype Bicycle is Vehicle.Object(2);  -- constrained subtype
  96
  97   type Motorcycle is new Bicycle with record
  98     Displacement : Natural;
  99   end record;
 100   procedure TC_Validate( It: Motorcycle; Key: Vehicle.TC_Keys );
 101
 102   type Tandem is new Bicycle with null record;
 103   procedure TC_Validate( It: Tandem; Key: Vehicle.TC_Keys );
 104
 105   type Car is new Vehicle.Object(4) with  -- extended, constrained
 106     record
 107       Displacement : Natural;
 108     end record;
 109   procedure TC_Validate( It: Car; Key: Vehicle.TC_Keys );
 110
 111   type Truck is new Vehicle.Object with  -- extended, unconstrained
 112     record
 113       Tare : Natural;
 114     end record;
 115   procedure TC_Validate( It: Truck; Key: Vehicle.TC_Keys );
 116
 117 end C390003_2; -- Motivators;
 118
 119 ----------------------------------------------------------------- C390003_3
 120
 121 with C390003_1;
 122 with C390003_2;
 123 package C390003_3 is -- Special_Trucks
 124   package Vehicle    renames C390003_1;
 125   package Motivators renames C390003_2;
 126   Max_Cars_On_Vehicle : constant := 6;
 127   type Cargo_Index is range 0..Max_Cars_On_Vehicle;
 128   type Cargo is array(Cargo_Index range 1..Max_Cars_On_Vehicle)
 129                 of Motivators.Car;
 130   type Auto_Carrier is new Motivators.Truck(18) with
 131     record
 132       Load_Count : Cargo_Index := 0;
 133       Payload    : Cargo;
 134     end record;
 135   procedure TC_Validate( It: Auto_Carrier; Key: Vehicle.TC_Keys );
 136   procedure Load  ( The_Car : in     Motivators.Car;
 137                     Onto    : in out Auto_Carrier);
 138   procedure Unload( The_Car :    out Motivators.Car;
 139                     Off_of   : in out Auto_Carrier);
 140 end C390003_3;
 141
 142 ----------------------------------------------------------------- C390003_4
 143
 144 with C390003_1;
 145 with C390003_2;
 146 package C390003_4 is -- James_Bond
 147
 148   package Vehicle   renames C390003_1;
 149   package Motivators renames C390003_2;
 150
 151   type Q_Machine is new Vehicle.Object(4) with record
 152     Car_Part  : Motivators.Car;
 153     Bike_Part : Motivators.Motorcycle;
 154   end record;
 155   procedure TC_Validate( It: Q_Machine; Key: Vehicle.TC_Keys );
 156
 157 end C390003_4;
 158
 159 ----------------------------------------------------------------- C390003_1
 160
 161 with Report;
 162 with Ada.Tags;
 163 package body C390003_1 is -- Vehicle
 164
 165   function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."=";
 166
 167   procedure TC_Validate( It: Object; Key: TC_Keys ) is
 168   begin
 169     if Key /= Veh then
 170       Report.Failed("Expected Veh Key");
 171     end if;
 172   end TC_Validate;
 173
 174   procedure TC_Validate( It: Object'Class; The_Tag: Ada.Tags.Tag ) is
 175   begin
 176     if It'Tag /= The_Tag then
 177       Report.Failed("Unexpected Tag for classwide formal");
 178     end if;
 179   end TC_Validate;
 180
 181   procedure Create( The_Vehicle : in out Object; Tyres : in States ) is
 182   begin
 183     The_Vehicle.Wheel_State := ( others => Tyres );
 184   end Create;
 185
 186   function  Wheels( The_Vehicle : Object ) return Positive is
 187   begin
 188     return The_Vehicle.Wheels;
 189   end Wheels;
 190
 191   procedure Rotate( The_Vehicle : in out Object ) is
 192     Push : States;
 193     Pulled : States
 194          := The_Vehicle.Wheel_State(The_Vehicle.Wheel_State'Last);
 195   begin
 196     for Finger in
 197         The_Vehicle.Wheel_State'First..The_Vehicle.Wheel_State'Last loop
 198       Push := The_Vehicle.Wheel_State(Finger);
 199       The_Vehicle.Wheel_State(Finger) := Pulled;
 200       Pulled := Push;
 201     end loop;
 202   end Rotate;
 203
 204 end C390003_1; -- Vehicle;
 205
 206 ----------------------------------------------------------------- C390003_2
 207
 208 with Ada.Tags;
 209 with Report;
 210 package body C390003_2 is -- Motivators
 211
 212   function "="(A,B: Ada.Tags.Tag)    return Boolean renames Ada.Tags."=";
 213   function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."=";
 214
 215   procedure TC_Validate( It: Motorcycle; Key: Vehicle.TC_Keys ) is
 216   begin
 217     if Key /= Vehicle.MC then
 218       Report.Failed("Expected MC Key");
 219     end if;
 220   end TC_Validate;
 221
 222   procedure TC_Validate( It: Tandem; Key: Vehicle.TC_Keys ) is
 223   begin
 224     if Key /= Vehicle.Tand then
 225       Report.Failed("Expected Tand Key");
 226     end if;
 227   end TC_Validate;
 228
 229   procedure TC_Validate( It: Car; Key: Vehicle.TC_Keys ) is
 230   begin
 231     if Key /= Vehicle.Car then
 232       Report.Failed("Expected Car Key");
 233     end if;
 234   end TC_Validate;
 235
 236   procedure TC_Validate( It: Truck; Key: Vehicle.TC_Keys ) is
 237   begin
 238     if Key /= Vehicle.Truk then
 239       Report.Failed("Expected Truk Key");
 240     end if;
 241   end TC_Validate;
 242 end C390003_2; -- Motivators;
 243
 244 ----------------------------------------------------------------- C390003_3
 245
 246 with Ada.Tags;
 247 with Report;
 248 package body C390003_3 is -- Special_Trucks
 249
 250   function "="(A,B: Ada.Tags.Tag)    return Boolean renames Ada.Tags."=";
 251   function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."=";
 252
 253   procedure TC_Validate( It: Auto_Carrier; Key: Vehicle.TC_Keys ) is
 254   begin
 255     if Key /= Vehicle.Heavy then
 256       Report.Failed("Expected Heavy Key");
 257     end if;
 258   end TC_Validate;
 259
 260   procedure Load  ( The_Car : in     Motivators.Car;
 261                     Onto    : in out Auto_Carrier) is
 262   begin
 263     Onto.Load_Count := Onto.Load_Count +1;
 264     Onto.Payload(Onto.Load_Count) := The_Car;
 265   end Load;
 266   procedure Unload( The_Car :    out Motivators.Car;
 267                     Off_of   : in out Auto_Carrier) is
 268   begin
 269     The_Car := Off_of.Payload(Off_of.Load_Count);
 270     Off_of.Load_Count := Off_of.Load_Count -1;
 271   end Unload;
 272
 273 end C390003_3;
 274
 275 ----------------------------------------------------------------- C390003_4
 276
 277 with Report, Ada.Tags;
 278 package body C390003_4 is -- James_Bond
 279
 280   function "="(A,B: Ada.Tags.Tag)    return Boolean renames Ada.Tags."=";
 281   function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."=";
 282
 283   procedure TC_Validate( It: Q_Machine; Key: Vehicle.TC_Keys ) is
 284   begin
 285     if Key /= Vehicle.Q then
 286       Report.Failed("Expected Q Key");
 287     end if;
 288   end TC_Validate;
 289
 290 end C390003_4;
 291
 292 ------------------------------------------------------------------- C390003
 293
 294 with Report;
 295 with C390003_1;
 296 with C390003_2;
 297 with C390003_3;
 298 with C390003_4;
 299 procedure C390003 is
 300
 301   package Vehicle        renames C390003_1;  use Vehicle;
 302   package Motivators     renames C390003_2;
 303   package Special_Trucks renames C390003_3;
 304   package James_Bond     renames C390003_4;
 305
 306   -- The cast, in order of complexity:
 307
 308   Pennys_Bike : Motivators.Bicycle;
 309   Weekender   : Motivators.Tandem;
 310   Qs_Moped    : Motivators.Motorcycle;
 311   Ms_Limo     : Motivators.Car;
 312   Yard_Van    : Motivators.Truck(8);
 313   Specter_X   : Special_Trucks.Auto_Carrier;
 314   Gen_II      : James_Bond.Q_Machine;
 315
 316
 317   -- Check compatibility with the corresponding class wide type.
 318
 319   procedure Vehicle_Shop( It  : in out Vehicle.Object'Class;
 320                           Key : in     Vehicle.TC_Keys ) is
 321
 322     -- Check that Subtype'Class is defined for tagged subtypes.
 323     procedure Bike_Shop( Bike: in out Motivators.Bicycle'Class ) is
 324     begin
 325         -- Dispatch to appropriate TC_Validate
 326       Vehicle.TC_Validate( Bike, Key );
 327     end Bike_Shop;
 328
 329   begin
 330     Vehicle.TC_Validate( It, Key );
 331     if Vehicle.Wheels( It ) = 2 then
 332       Bike_Shop( It );  -- only call Bike_Shop when It has 2 wheels
 333     end if;
 334   end Vehicle_Shop;
 335
 336 begin  -- Main test procedure.
 337
 338   Report.Test ("C390003", "Check that for a subtype S of a tagged type " &
 339                "T, S'Class denotes a class-wide subtype.  Check that " &
 340                "T'Tag denotes the tag of the type T, and that, for a " &
 341                "class-wide tagged type X, X'Tag denotes the tag of X.  " &
 342                "Check that the tags of stand alone objects, record and " &
 343                "array components, aggregates, and formal parameters " &
 344                "identify their type. Check that the tag of a value of a " &
 345                "formal parameter is that of the actual parameter, even " &
 346                "if the actual is passed by a view conversion" );
 347
 348 --     Check that the tags of stand alone objects, record and array
 349 --     components, aggregates, and formal parameters identify their type.
 350 --     Check that the tag of a value of a formal parameter is that of the
 351 --     actual parameter, even if the actual is passed by a view conversion.
 352
 353   Vehicle_Shop( Pennys_Bike,          Veh );
 354   Vehicle_Shop( Weekender,            Tand );
 355   Vehicle_Shop( Qs_Moped,             MC );
 356   Vehicle_Shop( Ms_Limo,              Car );
 357   Vehicle_Shop( Yard_Van,             Truk );
 358   Vehicle_Shop( Specter_X,            Heavy );
 359   Vehicle_Shop( Specter_X.Payload(1), Car );
 360   Vehicle_Shop( Gen_II,               Q );
 361   Vehicle_Shop( Gen_II.Car_Part,      Car );
 362   Vehicle_Shop( Gen_II.Bike_Part,     MC );
 363
 364   Vehicle.TC_Validate( Pennys_Bike, Vehicle.Object'Tag );
 365   Vehicle.TC_Validate( Weekender,   Motivators.Tandem'Tag );
 366   Vehicle.TC_Validate( Qs_Moped,    Motivators.Motorcycle'Tag );
 367   Vehicle.TC_Validate( Ms_Limo,     Motivators.Car'Tag );
 368   Vehicle.TC_Validate( Yard_Van,    Motivators.Truck'Tag );
 369   Vehicle.TC_Validate( Specter_X,   Special_Trucks.Auto_Carrier'Tag );
 370   Vehicle.TC_Validate( Specter_X.Payload(1), Motivators.Car'Tag );
 371   Vehicle.TC_Validate( Gen_II,              James_Bond.Q_Machine'Tag );
 372   Vehicle.TC_Validate( Gen_II.Car_Part,     Motivators.Car'Tag );
 373   Vehicle.TC_Validate( Gen_II.Bike_Part,    Motivators.Motorcycle'Tag );
 374
 375 -- Check the tag generated for an aggregate.
 376
 377   Rentals: declare
 378     Mikes_Rental : Vehicle.Object'Class :=
 379                      Vehicle.Object'( 3, (Good, Flat, Worn));
 380     Diannes_Car  : Vehicle.Object'Class :=
 381                       Motivators.Tandem'( Wheels      => 2,
 382                                           Wheel_State => (Good, Good) );
 383     Jims_Bike    : Vehicle.Object'Class :=
 384                       Motivators.Motorcycle'( Pennys_Bike
 385                                               with Displacement => 350 );
 386     Bills_Limo   : Vehicle.Object'Class :=
 387                       Motivators.Car'( Wheels       => 4,
 388                                        Wheel_State  => (others => Good),
 389                                        Displacement => 282 );
 390     Alans_Car    : Vehicle.Object'Class :=
 391                       Motivators.Truck'( 18, (others => Worn),
 392                                          Tare => 5_500 );
 393     Pats_Truck   : Vehicle.Object'Class := Specter_X;
 394     Keiths_Car   : Vehicle.Object'Class := Gen_II;
 395     Isaacs_Bus   : Vehicle.Object'Class := Keiths_Car;
 396
 397   begin
 398     Vehicle.TC_Validate( Mikes_Rental, Vehicle.Object'Tag );
 399     Vehicle.TC_Validate( Diannes_Car,  Motivators.Tandem'Tag );
 400     Vehicle.TC_Validate( Jims_Bike,    Motivators.Motorcycle'Tag );
 401     Vehicle.TC_Validate( Bills_Limo,   Motivators.Car'Tag );
 402     Vehicle.TC_Validate( Alans_Car,    Motivators.Truck'Tag );
 403     Vehicle.TC_Validate( Pats_Truck,   Special_Trucks.Auto_Carrier'Tag );
 404     Vehicle.TC_Validate( Keiths_Car,   James_Bond.Q_Machine'Tag );
 405   end Rentals;
 406
 407 -- Check the tag of parameters.
 408 -- Check that the tag is not affected by view conversion.
 409
 410   Vehicle.TC_Validate( Vehicle.Object( Gen_II  ), James_Bond.Q_Machine'Tag );
 411   Vehicle.TC_Validate( Vehicle.Object( Ms_Limo ), Motivators.Car'Tag );
 412   Vehicle.TC_Validate( Motivators.Bicycle( Weekender ),
 413                        Motivators.Tandem'Tag );
 414   Vehicle.TC_Validate( Motivators.Bicycle( Gen_II.Bike_Part ),
 415                        Motivators.Motorcycle'Tag );
 416
 417   Report.Result;
 418
 419 end C390003;