Subversion Repositories openrisc_2011-10-31

-- 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;