Subversion Repositories openrisc_2011-10-31

-- C390004.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 the tags of allocated objects correctly identify the

--     type of the allocated object.  Check that the tag corresponds

--     correctly to the value resulting from both normal and view

--     conversion.  Check that the tags of accessed values designating

--     aliased objects correctly identify the type of the object.  Check

--     that the tag of a function result correctly evaluates.  Check this

--     for class-wide functions.  The tag of a class-wide function result

--     should be the tag appropriate to the actual value returned, not the

--     tag of the ancestor type.

--

-- TEST DESCRIPTION:

--     This test defines a class hierarchy of types, with reference

--     semantics (an access type to the class-wide type).  Similar in

--     structure to C392005, this test checks that dynamic allocation does

--     not adversely impact the tagging of types.

--

--

-- CHANGE HISTORY:

--      06 Dec 94   SAIC    ACVC 2.0

--

--!

package C390004_1 is -- DMV

  type Equipment is ( T_Veh, T_Car, T_Con, T_Jep );

  type Vehicle is tagged record

    Wheels : Natural := 4;

    Parked : Boolean := False;

  end record;

  function  Wheels    ( It: Vehicle ) return Natural;

  procedure Park      ( It: in out Vehicle );

  procedure UnPark    ( It: in out Vehicle );

  procedure Set_Wheels( It: in out Vehicle; To_Count: in Natural );

  procedure TC_Check  ( It: in Vehicle; To_Equip: in Equipment );

  type Car is new Vehicle with record

    Passengers : Natural := 0;

  end record;

  function  Passengers     ( It: Car ) return Natural;

  procedure Load_Passengers( It: in out Car; To_Count: in Natural );

  procedure Park           ( It: in out Car );

  procedure TC_Check       ( It: in Car; To_Equip: in Equipment );

  type Convertible is new Car with record

    Top_Up : Boolean := True;

  end record;

  function  Top_Up   ( It: Convertible ) return Boolean;

  procedure Lower_Top( It: in out Convertible );

  procedure Park     ( It: in out Convertible );

  procedure Raise_Top( It: in out Convertible );

  procedure TC_Check ( It: in Convertible; To_Equip: in Equipment );

  type Jeep is new Convertible with record

    Windshield_Up : Boolean := True;

  end record;

  function  Windshield_Up   ( It: Jeep ) return Boolean;

  procedure Lower_Windshield( It: in out Jeep );

  procedure Park            ( It: in out Jeep );

  procedure Raise_Windshield( It: in out Jeep );

  procedure TC_Check        ( It: in Jeep; To_Equip: in Equipment );

end C390004_1;

with Report;

package body C390004_1 is

  procedure Set_Wheels( It: in out Vehicle; To_Count: in Natural ) is

  begin

    It.Wheels := To_Count;

  end Set_Wheels;

  function  Wheels( It: Vehicle ) return Natural is

  begin

    return It.Wheels;

  end Wheels;

  procedure Park      ( It: in out Vehicle ) is

  begin

    It.Parked := True;

  end Park;

  procedure UnPark    ( It: in out Vehicle ) is

  begin

    It.Parked := False;

  end UnPark;

  procedure TC_Check  ( It: in Vehicle; To_Equip: in Equipment ) is

  begin

    if To_Equip /= T_Veh then

      Report.Failed ("Failed, called Vehicle for "

                     & Equipment'Image(To_Equip));

    end if;

  end TC_Check;

  procedure TC_Check  ( It: in Car; To_Equip: in Equipment ) is

  begin

    if To_Equip /= T_Car then

      Report.Failed ("Failed, called Car for "

                     & Equipment'Image(To_Equip));

    end if;

  end TC_Check;

  procedure TC_Check  ( It: in Convertible; To_Equip: in Equipment ) is

  begin

    if To_Equip /= T_Con then

      Report.Failed ("Failed, called Convertible for "

                     & Equipment'Image(To_Equip));

    end if;

  end TC_Check;

  procedure TC_Check  ( It: in Jeep; To_Equip: in Equipment ) is

  begin

    if To_Equip /= T_Jep then

      Report.Failed ("Failed, called Jeep for "

                     & Equipment'Image(To_Equip));

    end if;

  end TC_Check;

  procedure Load_Passengers( It: in out Car; To_Count: in Natural ) is

  begin

    It.Passengers := To_Count;

    UnPark( It );

  end Load_Passengers;

  procedure Park( It: in out Car ) is

  begin

    It.Passengers := 0;

    Park( Vehicle( It ) );

  end Park;

  function  Passengers( It: Car ) return Natural is

  begin

    return It.Passengers;

  end Passengers;

  procedure Raise_Top( It: in out Convertible ) is

  begin

    It.Top_Up := True;

  end Raise_Top;

  procedure Lower_Top( It: in out Convertible ) is

  begin

    It.Top_Up := False;

  end Lower_Top;

  function  Top_Up   ( It: Convertible ) return Boolean is

  begin

    return It.Top_Up;

  end Top_Up;

  procedure Park     ( It: in out Convertible ) is

  begin

    It.Top_Up := True;

    Park( Car( It ) );

  end Park;

  procedure Raise_Windshield( It: in out Jeep ) is

  begin

    It.Windshield_Up := True;

  end Raise_Windshield;

  procedure Lower_Windshield( It: in out Jeep ) is

  begin

    It.Windshield_Up := False;

  end Lower_Windshield;

  function  Windshield_Up( It: Jeep ) return Boolean is

  begin

    return It.Windshield_Up;

  end Windshield_Up;

  procedure Park( It: in out Jeep ) is

  begin

    It.Windshield_Up := True;

    Park( Convertible( It ) );

  end Park;

end C390004_1;

with Report;

with Ada.Tags;

with C390004_1;

procedure C390004 is

  package DMV renames C390004_1;

  The_Vehicle     : aliased DMV.Vehicle;

  The_Car         : aliased DMV.Car;

  The_Convertible : aliased DMV.Convertible;

  The_Jeep        : aliased DMV.Jeep;

  type C_Reference is access all DMV.Car'Class;

  type V_Reference is access all DMV.Vehicle'Class;

  Designator : V_Reference;

  Storage    : Natural;

  procedure Valet( It: in out DMV.Vehicle'Class ) is

  begin

    DMV.Park( It );

  end Valet;

  procedure TC_Match( Object: DMV.Vehicle'Class;

                      Taglet: Ada.Tags.Tag;

                      Where : String ) is

    use Ada.Tags;

  begin

    if Object'Tag /= Taglet then

      Report.Failed("Tag mismatch: " & Where);

    end if;

  end TC_Match;

  procedure Parking_Validation( It: DMV.Vehicle; TC_Message: String ) is

  begin

    if DMV.Wheels( It ) /= 1  or not It.Parked then

      Report.Failed ("Failed Vehicle " & TC_Message);

    end if;

  end Parking_Validation;

  procedure Parking_Validation( It: DMV.Car; TC_Message: String ) is

  begin

    if DMV.Wheels( It ) /= 2 or DMV.Passengers( It ) /= 0

       or not It.Parked then

      Report.Failed ("Failed Car " & TC_Message);

    end if;

  end Parking_Validation;

  procedure Parking_Validation( It: DMV.Convertible;

                                TC_Message: String ) is

  begin

    if DMV.Wheels( It ) /= 3 or DMV.Passengers( It ) /= 0

       or not DMV.Top_Up( It ) or not It.Parked then

      Report.Failed ("Failed Convertible " & TC_Message);

    end if;

  end Parking_Validation;

  procedure Parking_Validation( It: DMV.Jeep; TC_Message: String ) is

  begin

    if DMV.Wheels( It ) /= 4 or DMV.Passengers( It ) /= 0

       or not DMV.Top_Up( It ) or not DMV.Windshield_Up( It )

       or not It.Parked then

      Report.Failed ("Failed Jeep " & TC_Message);

    end if;

  end Parking_Validation;

  function Wash( It: V_Reference; TC_Expect : Ada.Tags.Tag )

                                    return DMV.Vehicle'Class is

    This_Machine : DMV.Vehicle'Class := It.all;

  begin

    TC_Match( It.all, TC_Expect, "Class-wide object in Wash" );

    Storage := DMV.Wheels( This_Machine );

    return This_Machine;

  end Wash;

  function Wash( It: C_Reference; TC_Expect : Ada.Tags.Tag )

                                    return DMV.Car'Class is

    This_Machine : DMV.Car'Class := It.all;

  begin

    TC_Match( It.all, TC_Expect, "Class-wide object in Wash" );

    Storage := DMV.Wheels( This_Machine );

    return This_Machine;

  end Wash;

begin

  Report.Test( "C390004", "Check that the tags of allocated objects "

                        & "correctly identify the type of the allocated "

                        & "object.  Check that tags resulting from "

                        & "normal and view conversions.  Check tags of "

                        & "accessed values designating aliased objects. "

                        & "Check function result tags" );

  DMV.Set_Wheels( The_Vehicle, 1 );

  DMV.Set_Wheels( The_Car, 2 );

  DMV.Set_Wheels( The_Convertible, 3 );

  DMV.Set_Wheels( The_Jeep, 4 );

  Valet( The_Vehicle );

  Valet( The_Car );

  Valet( The_Convertible );

  Valet( The_Jeep );

  Parking_Validation( The_Vehicle,     "setup" );

  Parking_Validation( The_Car,         "setup" );

  Parking_Validation( The_Convertible, "setup" );

  Parking_Validation( The_Jeep,        "setup" );

-- Check that the tags of allocated objects correctly identify the type

-- of the allocated object.

  Designator := new DMV.Vehicle;

  DMV.TC_Check( Designator.all, DMV.T_Veh );

  TC_Match( Designator.all, DMV.Vehicle'Tag, "allocated Vehicle" );

  Designator := new DMV.Car;

  DMV.TC_Check( Designator.all, DMV.T_Car );

  TC_Match( Designator.all, DMV.Car'Tag, "allocated Car");

  Designator := new DMV.Convertible;

  DMV.TC_Check( Designator.all, DMV.T_Con );

  TC_Match( Designator.all, DMV.Convertible'Tag, "allocated Convertible" );

  Designator := new DMV.Jeep;

  DMV.TC_Check( Designator.all, DMV.T_Jep );

  TC_Match( Designator.all, DMV.Jeep'Tag, "allocated Jeep" );

-- Check that view conversion causes the correct dispatch

  DMV.TC_Check( DMV.Vehicle( The_Jeep ),     DMV.T_Veh );

  DMV.TC_Check( DMV.Car( The_Jeep ),         DMV.T_Car );

  DMV.TC_Check( DMV.Convertible( The_Jeep ), DMV.T_Con );

-- And that view conversion does not change the tag

  TC_Match( DMV.Vehicle( The_Jeep ),     DMV.Jeep'Tag, "View Conv Veh" );

  TC_Match( DMV.Car( The_Jeep ),         DMV.Jeep'Tag, "View Conv Car" );

  TC_Match( DMV.Convertible( The_Jeep ), DMV.Jeep'Tag, "View Conv Jep" );

-- Check that the tags of accessed values designating aliased objects

-- correctly identify the type of the object.

  Designator := The_Vehicle'Access;

  DMV.TC_Check( Designator.all, DMV.T_Veh );

  TC_Match( Designator.all, DMV.Vehicle'Tag, "aliased Vehicle" );

  Designator := The_Car'Access;

  DMV.TC_Check( Designator.all, DMV.T_Car );

  TC_Match( Designator.all, DMV.Car'Tag, "aliased Car" );

  Designator := The_Convertible'Access;

  DMV.TC_Check( Designator.all, DMV.T_Con );

  TC_Match( Designator.all, DMV.Convertible'Tag, "aliased Convertible" );

  Designator := The_Jeep'Access;

  DMV.TC_Check( Designator.all, DMV.T_Jep );

  TC_Match( Designator.all, DMV.Jeep'Tag, "aliased Jeep" );

-- Check that the tag of a function result correctly evaluates.

-- Check this for class-wide functions.  The tag of a class-wide

-- function result should be the tag appropriate to the actual value

-- returned, not the tag of the ancestor type.

  Function_Check: declare

    A_Vehicle     : V_Reference := new DMV.Vehicle'( The_Vehicle );

    A_Car         : C_Reference := new DMV.Car'( The_Car );

    A_Convertible : C_Reference := new DMV.Convertible'( The_Convertible );

    A_Jeep        : C_Reference := new DMV.Jeep'( The_Jeep );

  begin

    DMV.Unpark( A_Vehicle.all );

    DMV.Load_Passengers( A_Car.all, 5 );

    DMV.Load_Passengers( A_Convertible.all, 6 );

    DMV.Load_Passengers( A_Jeep.all, 7 );

    DMV.Lower_Top( DMV.Convertible(A_Convertible.all) );

    DMV.Lower_Top( DMV.Jeep(A_Jeep.all) );

    DMV.Lower_Windshield( DMV.Jeep(A_Jeep.all) );

    if DMV.Wheels( Wash( A_Jeep, DMV.Jeep'Tag ) ) /= 4

       or Storage /= 4 then

      Report.Failed("Did not correctly wash Jeep");

    end if;

    if DMV.Wheels( Wash( A_Convertible, DMV.Convertible'Tag ) ) /= 3

       or Storage /= 3 then

      Report.Failed("Did not correctly wash Convertible");

    end if;

    if DMV.Wheels( Wash( A_Car, DMV.Car'Tag ) ) /= 2

       or Storage /= 2 then

      Report.Failed("Did not correctly wash Car");

    end if;

    if DMV.Wheels( Wash( A_Vehicle, DMV.Vehicle'Tag ) ) /= 1

       or Storage /= 1 then

      Report.Failed("Did not correctly wash Vehicle");

    end if;

  end Function_Check;

  Report.Result;

end C390004;