--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/testsuite/ada/acats/tests/c3/c390004.a	Fri Oct 27 22:46:09 2017 +0900
@@ -0,0 +1,404 @@
+-- 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;