path: root/gcc/testsuite/ada/acats/tests/c3/c390003.a

-- C390003.A
--
--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
--     this public release, the Government intends to confer upon all 
--     recipients unlimited rights  equal to those held by the Government.  
--     These rights include rights to use, duplicate, release or disclose the 
--     released technical data and computer software in whole or in part, in 
--     any manner and for any purpose whatsoever, and to have or permit others 
--     to do so.
--
--                                    DISCLAIMER
--
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--     PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
--     Check that for a subtype S of a tagged type T, S'Class denotes a
--     class-wide subtype.  Check that T'Tag denotes the tag of the type T,
--     and that, for a class-wide tagged type X, X'Tag denotes the tag of X.
--     Check that the tags of stand alone objects, record and array
--     components, aggregates, and formal parameters identify their type.
--     Check that the tag of a value of a formal parameter is that of the
--     actual parameter, even if the actual is passed by a view conversion.
--
-- TEST DESCRIPTION:
--     This test defines a class hierarchy (based on C390002) and
--     uses it to determine the correctness of the resulting tag
--     information generated by the compiler.  A type is defined in the
--     class which contains components of the class as part of its
--     definition.  This is to reduce the overall number of types
--     required, and to achieve the required nesting to accomplish
--     this test.  The model is that of a car carrier truck; both car
--     and truck being in the class of Vehicle.
--
--      Class Hierarchy:
--                         Vehicle - - - - - - - (Bicycle)
--                        /   |   \               /      \
--                   Truck   Car   Q_Machine   Tandem  Motorcycle
--                     |
--                Auto_Carrier
--      Contains:
--                Auto_Carrier( Car )
--                Q_Machine( Car, Motorcycle )
--
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      19 Dec 94   SAIC    Removed ARM references from objective text.
--      20 Dec 94   SAIC    Replaced three unnecessary extension
--                          aggregates with simple aggregates.
--      16 Oct 95   SAIC    Fixed bugs for ACVC 2.0.1
--
--!

----------------------------------------------------------------- C390003_1

with Ada.Tags;
package C390003_1 is -- Vehicle

  type TC_Keys is (Veh, MC, Tand, Car, Q, Truk, Heavy);
  type States  is (Good, Flat, Worn);

  type Wheel_List is array(Positive range <>) of States;

  type Object(Wheels: Positive) is tagged record
    Wheel_State : Wheel_List(1..Wheels);
  end record;

  procedure TC_Validate( It: Object; Key: TC_Keys );
  procedure TC_Validate( It: Object'Class; The_Tag: Ada.Tags.Tag );

  procedure Create( The_Vehicle : in out Object; Tyres : in States );
  procedure Rotate( The_Vehicle : in out Object );
  function  Wheels( The_Vehicle : Object ) return Positive;

end C390003_1; -- Vehicle;

----------------------------------------------------------------- C390003_2

with C390003_1;
package C390003_2 is -- Motivators

  package Vehicle renames C390003_1;
  subtype Bicycle is Vehicle.Object(2);  -- constrained subtype

  type Motorcycle is new Bicycle with record
    Displacement : Natural;
  end record;
  procedure TC_Validate( It: Motorcycle; Key: Vehicle.TC_Keys );

  type Tandem is new Bicycle with null record;
  procedure TC_Validate( It: Tandem; Key: Vehicle.TC_Keys );

  type Car is new Vehicle.Object(4) with  -- extended, constrained
    record
      Displacement : Natural;
    end record;
  procedure TC_Validate( It: Car; Key: Vehicle.TC_Keys );

  type Truck is new Vehicle.Object with  -- extended, unconstrained
    record
      Tare : Natural;
    end record;
  procedure TC_Validate( It: Truck; Key: Vehicle.TC_Keys );

end C390003_2; -- Motivators;

----------------------------------------------------------------- C390003_3

with C390003_1;
with C390003_2;
package C390003_3 is -- Special_Trucks
  package Vehicle    renames C390003_1;
  package Motivators renames C390003_2;
  Max_Cars_On_Vehicle : constant := 6;
  type Cargo_Index is range 0..Max_Cars_On_Vehicle;
  type Cargo is array(Cargo_Index range 1..Max_Cars_On_Vehicle)
                of Motivators.Car;
  type Auto_Carrier is new Motivators.Truck(18) with
    record
      Load_Count : Cargo_Index := 0;
      Payload    : Cargo;
    end record;
  procedure TC_Validate( It: Auto_Carrier; Key: Vehicle.TC_Keys );
  procedure Load  ( The_Car : in     Motivators.Car;
                    Onto    : in out Auto_Carrier);
  procedure Unload( The_Car :    out Motivators.Car;
                    Off_of   : in out Auto_Carrier);
end C390003_3;

----------------------------------------------------------------- C390003_4

with C390003_1;
with C390003_2;
package C390003_4 is -- James_Bond

  package Vehicle   renames C390003_1;
  package Motivators renames C390003_2;

  type Q_Machine is new Vehicle.Object(4) with record
    Car_Part  : Motivators.Car;
    Bike_Part : Motivators.Motorcycle;
  end record;
  procedure TC_Validate( It: Q_Machine; Key: Vehicle.TC_Keys );

end C390003_4;

----------------------------------------------------------------- C390003_1

with Report;
with Ada.Tags;
package body C390003_1 is -- Vehicle

  function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."=";

  procedure TC_Validate( It: Object; Key: TC_Keys ) is
  begin
    if Key /= Veh then
      Report.Failed("Expected Veh Key");
    end if;
  end TC_Validate;

  procedure TC_Validate( It: Object'Class; The_Tag: Ada.Tags.Tag ) is
  begin
    if It'Tag /= The_Tag then
      Report.Failed("Unexpected Tag for classwide formal");
    end if;
  end TC_Validate;

  procedure Create( The_Vehicle : in out Object; Tyres : in States ) is
  begin
    The_Vehicle.Wheel_State := ( others => Tyres );
  end Create;

  function  Wheels( The_Vehicle : Object ) return Positive is
  begin
    return The_Vehicle.Wheels;
  end Wheels;

  procedure Rotate( The_Vehicle : in out Object ) is
    Push : States;
    Pulled : States
         := The_Vehicle.Wheel_State(The_Vehicle.Wheel_State'Last);
  begin
    for Finger in
        The_Vehicle.Wheel_State'First..The_Vehicle.Wheel_State'Last loop
      Push := The_Vehicle.Wheel_State(Finger);
      The_Vehicle.Wheel_State(Finger) := Pulled;
      Pulled := Push;
    end loop;
  end Rotate;

end C390003_1; -- Vehicle;

----------------------------------------------------------------- C390003_2

with Ada.Tags;
with Report;
package body C390003_2 is -- Motivators

  function "="(A,B: Ada.Tags.Tag)    return Boolean renames Ada.Tags."=";
  function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."=";

  procedure TC_Validate( It: Motorcycle; Key: Vehicle.TC_Keys ) is
  begin
    if Key /= Vehicle.MC then
      Report.Failed("Expected MC Key");
    end if;
  end TC_Validate;

  procedure TC_Validate( It: Tandem; Key: Vehicle.TC_Keys ) is
  begin
    if Key /= Vehicle.Tand then
      Report.Failed("Expected Tand Key");
    end if;
  end TC_Validate;

  procedure TC_Validate( It: Car; Key: Vehicle.TC_Keys ) is
  begin
    if Key /= Vehicle.Car then
      Report.Failed("Expected Car Key");
    end if;
  end TC_Validate;

  procedure TC_Validate( It: Truck; Key: Vehicle.TC_Keys ) is
  begin
    if Key /= Vehicle.Truk then
      Report.Failed("Expected Truk Key");
    end if;
  end TC_Validate;
end C390003_2; -- Motivators;

----------------------------------------------------------------- C390003_3

with Ada.Tags;
with Report;
package body C390003_3 is -- Special_Trucks

  function "="(A,B: Ada.Tags.Tag)    return Boolean renames Ada.Tags."=";
  function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."=";

  procedure TC_Validate( It: Auto_Carrier; Key: Vehicle.TC_Keys ) is
  begin
    if Key /= Vehicle.Heavy then
      Report.Failed("Expected Heavy Key");
    end if;
  end TC_Validate;

  procedure Load  ( The_Car : in     Motivators.Car;
                    Onto    : in out Auto_Carrier) is
  begin
    Onto.Load_Count := Onto.Load_Count +1;
    Onto.Payload(Onto.Load_Count) := The_Car;
  end Load;
  procedure Unload( The_Car :    out Motivators.Car;
                    Off_of   : in out Auto_Carrier) is
  begin
    The_Car := Off_of.Payload(Off_of.Load_Count);
    Off_of.Load_Count := Off_of.Load_Count -1;
  end Unload;

end C390003_3;

----------------------------------------------------------------- C390003_4

with Report, Ada.Tags;
package body C390003_4 is -- James_Bond

  function "="(A,B: Ada.Tags.Tag)    return Boolean renames Ada.Tags."=";
  function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."=";

  procedure TC_Validate( It: Q_Machine; Key: Vehicle.TC_Keys ) is
  begin
    if Key /= Vehicle.Q then
      Report.Failed("Expected Q Key");
    end if;
  end TC_Validate;

end C390003_4;

------------------------------------------------------------------- C390003

with Report;
with C390003_1;
with C390003_2;
with C390003_3;
with C390003_4;
procedure C390003 is

  package Vehicle        renames C390003_1;  use Vehicle;
  package Motivators     renames C390003_2;
  package Special_Trucks renames C390003_3;
  package James_Bond     renames C390003_4;

  -- The cast, in order of complexity:

  Pennys_Bike : Motivators.Bicycle;
  Weekender   : Motivators.Tandem;
  Qs_Moped    : Motivators.Motorcycle;
  Ms_Limo     : Motivators.Car;
  Yard_Van    : Motivators.Truck(8);
  Specter_X   : Special_Trucks.Auto_Carrier;
  Gen_II      : James_Bond.Q_Machine;


  -- Check compatibility with the corresponding class wide type.

  procedure Vehicle_Shop( It  : in out Vehicle.Object'Class;
                          Key : in     Vehicle.TC_Keys ) is

    -- Check that Subtype'Class is defined for tagged subtypes.
    procedure Bike_Shop( Bike: in out Motivators.Bicycle'Class ) is
    begin
        -- Dispatch to appropriate TC_Validate
      Vehicle.TC_Validate( Bike, Key );
    end Bike_Shop;

  begin
    Vehicle.TC_Validate( It, Key );
    if Vehicle.Wheels( It ) = 2 then
      Bike_Shop( It );  -- only call Bike_Shop when It has 2 wheels
    end if;
  end Vehicle_Shop;

begin  -- Main test procedure.

  Report.Test ("C390003", "Check that for a subtype S of a tagged type " &
               "T, S'Class denotes a class-wide subtype.  Check that " &
               "T'Tag denotes the tag of the type T, and that, for a " &
               "class-wide tagged type X, X'Tag denotes the tag of X.  " &
               "Check that the tags of stand alone objects, record and " &
               "array components, aggregates, and formal parameters " &
               "identify their type. Check that the tag of a value of a " &
               "formal parameter is that of the actual parameter, even " &
               "if the actual is passed by a view conversion" );

--     Check that the tags of stand alone objects, record and array
--     components, aggregates, and formal parameters identify their type.
--     Check that the tag of a value of a formal parameter is that of the
--     actual parameter, even if the actual is passed by a view conversion.

  Vehicle_Shop( Pennys_Bike,          Veh );
  Vehicle_Shop( Weekender,            Tand );
  Vehicle_Shop( Qs_Moped,             MC );
  Vehicle_Shop( Ms_Limo,              Car );
  Vehicle_Shop( Yard_Van,             Truk );
  Vehicle_Shop( Specter_X,            Heavy );
  Vehicle_Shop( Specter_X.Payload(1), Car );
  Vehicle_Shop( Gen_II,               Q );
  Vehicle_Shop( Gen_II.Car_Part,      Car );
  Vehicle_Shop( Gen_II.Bike_Part,     MC );

  Vehicle.TC_Validate( Pennys_Bike, Vehicle.Object'Tag );
  Vehicle.TC_Validate( Weekender,   Motivators.Tandem'Tag );
  Vehicle.TC_Validate( Qs_Moped,    Motivators.Motorcycle'Tag );
  Vehicle.TC_Validate( Ms_Limo,     Motivators.Car'Tag );
  Vehicle.TC_Validate( Yard_Van,    Motivators.Truck'Tag );
  Vehicle.TC_Validate( Specter_X,   Special_Trucks.Auto_Carrier'Tag );
  Vehicle.TC_Validate( Specter_X.Payload(1), Motivators.Car'Tag );
  Vehicle.TC_Validate( Gen_II,              James_Bond.Q_Machine'Tag );
  Vehicle.TC_Validate( Gen_II.Car_Part,     Motivators.Car'Tag );
  Vehicle.TC_Validate( Gen_II.Bike_Part,    Motivators.Motorcycle'Tag );

-- Check the tag generated for an aggregate.

  Rentals: declare
    Mikes_Rental : Vehicle.Object'Class :=
                     Vehicle.Object'( 3, (Good, Flat, Worn));
    Diannes_Car  : Vehicle.Object'Class :=
                      Motivators.Tandem'( Wheels      => 2, 
                                          Wheel_State => (Good, Good) );
    Jims_Bike    : Vehicle.Object'Class :=
                      Motivators.Motorcycle'( Pennys_Bike
                                              with Displacement => 350 );
    Bills_Limo   : Vehicle.Object'Class :=
                      Motivators.Car'( Wheels       => 4,
                                       Wheel_State  => (others => Good),
                                       Displacement => 282 );
    Alans_Car    : Vehicle.Object'Class :=
                      Motivators.Truck'( 18, (others => Worn),
                                         Tare => 5_500 );
    Pats_Truck   : Vehicle.Object'Class := Specter_X;
    Keiths_Car   : Vehicle.Object'Class := Gen_II;
    Isaacs_Bus   : Vehicle.Object'Class := Keiths_Car;

  begin
    Vehicle.TC_Validate( Mikes_Rental, Vehicle.Object'Tag );
    Vehicle.TC_Validate( Diannes_Car,  Motivators.Tandem'Tag );
    Vehicle.TC_Validate( Jims_Bike,    Motivators.Motorcycle'Tag );
    Vehicle.TC_Validate( Bills_Limo,   Motivators.Car'Tag );
    Vehicle.TC_Validate( Alans_Car,    Motivators.Truck'Tag );
    Vehicle.TC_Validate( Pats_Truck,   Special_Trucks.Auto_Carrier'Tag );
    Vehicle.TC_Validate( Keiths_Car,   James_Bond.Q_Machine'Tag );
  end Rentals;

-- Check the tag of parameters.
-- Check that the tag is not affected by view conversion.

  Vehicle.TC_Validate( Vehicle.Object( Gen_II  ), James_Bond.Q_Machine'Tag );
  Vehicle.TC_Validate( Vehicle.Object( Ms_Limo ), Motivators.Car'Tag );
  Vehicle.TC_Validate( Motivators.Bicycle( Weekender ),
                       Motivators.Tandem'Tag );
  Vehicle.TC_Validate( Motivators.Bicycle( Gen_II.Bike_Part ),
                       Motivators.Motorcycle'Tag );

  Report.Result;

end C390003;