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

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