--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/testsuite/ada/acats/tests/c4/c460006.a	Fri Oct 27 22:46:09 2017 +0900
@@ -0,0 +1,378 @@
+-- C460006.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 a view conversion to a tagged type is permitted in the 
+--      prefix of a selected component, an object renaming declaration, and 
+--      (if the operand is a variable) on the left side of an assignment 
+--      statement. Check that such a renaming or assignment does not change 
+--      the tag of the operand.
+--
+--      Check that, for a view conversion of a tagged type, each
+--      nondiscriminant component of the new view denotes the matching
+--      component of the operand object. Check that reading the value of the
+--      view yields the result of converting the value of the operand object
+--      to the target subtype.
+--
+-- TEST DESCRIPTION:
+--      The fact that the tag of an object is not changed is verified by
+--      making calls to primitive operations which in turn make (re)dispatching
+--      calls, and confirming that the proper bodies are executed.
+--
+--      Selected components are checked in three contexts: as the object name
+--      in an object renaming declaration, as the left operand of an inequality
+--      operation, and as the left side of an assignment statement.
+--
+--      View conversions of an object of a 2nd level type extension are
+--      renamed as objects of an ancestor type and of a class-wide type. In
+--      one case the operand of the conversion is itself a renaming of an
+--      object.
+--
+--      View conversions of an object of a 2nd level type extension are
+--      checked for equality with record aggregates of various ancestor types.
+--      In one case, the view conversion is to a class-wide type, and it is
+--      checked for equality with the result of a class-wide function with
+--      the following structure:
+--
+--         function F return T'Class is
+--            A : DDT     := Expected_Value;
+--            X : T'Class := T(A);
+--         begin
+--            return X;
+--
+--         end F;
+--
+--         ...
+--
+--         Var : DDT := Expected_Value;
+--
+--         if (T'Class(Var) /= F) then    -- Condition should yield FALSE.
+--            FAIL;
+--         end if;
+--
+--      The view conversion to which X is initialized does not affect the
+--      value or tag of the operand; the tag of X is that of type DDT (not T),
+--      and the components are those of A. The result of this function
+--      should equal the value of an object of type DDT initialized to the
+--      same value as F.A.
+--
+--      To check that assignment to a view conversion does not change the tag
+--      of the operand, an assignment is made to a conversion of an object,
+--      and the object is then passed as an actual to a dispatching operation.
+--      Conversions to both specific and class-wide types are checked.
+--
+--
+-- CHANGE HISTORY:
+--      20 Jul 95   SAIC    Initial prerelease version.
+--      24 Apr 96   SAIC    Added type conversions.
+--
+--!
+
+package C460006_0 is
+
+   type Call_ID_Kind is (None, Parent_Outer,     Parent_Inner,
+                               Child_Outer,      Child_Inner,
+                               Grandchild_Outer, Grandchild_Inner);
+
+   type Root_Type is abstract tagged record
+      First_Call  : Call_ID_Kind := None;
+      Second_Call : Call_ID_Kind := None;
+   end record;
+
+   procedure Inner_Proc (X : in out Root_Type) is abstract;
+   procedure Outer_Proc (X : in out Root_Type) is abstract;
+
+end C460006_0;
+
+
+     --==================================================================--
+
+
+package C460006_0.C460006_1 is
+
+   type Parent_Type is new Root_Type with record
+      C1 : Integer := 0;
+   end record;
+
+   procedure Inner_Proc (X : in out Parent_Type);
+   procedure Outer_Proc (X : in out Parent_Type);
+
+end C460006_0.C460006_1;
+
+
+     --==================================================================--
+
+
+package body C460006_0.C460006_1 is
+
+   procedure Inner_Proc (X : in out Parent_Type) is
+   begin
+      X.Second_Call := Parent_Inner;
+   end Inner_Proc;
+
+   -------------------------------------------------
+   procedure Outer_Proc (X : in out Parent_Type) is
+   begin
+      X.First_Call := Parent_Outer;
+      Inner_Proc ( Parent_Type'Class(X) );
+   end Outer_Proc;
+
+end C460006_0.C460006_1;
+
+
+     --==================================================================--
+
+
+package C460006_0.C460006_1.C460006_2 is
+
+   type Child_Type is new Parent_Type with record
+      C2 : String(1 .. 5) := "-----";
+   end record;
+
+   procedure Inner_Proc (X : in out Child_Type);
+   procedure Outer_Proc (X : in out Child_Type);
+
+end C460006_0.C460006_1.C460006_2;
+
+
+     --==================================================================--
+
+
+package body C460006_0.C460006_1.C460006_2 is
+
+   procedure Inner_Proc (X : in out Child_Type) is
+   begin
+      X.Second_Call := Child_Inner;
+   end Inner_Proc;
+
+   -------------------------------------------------
+   procedure Outer_Proc (X : in out Child_Type) is
+   begin
+      X.First_Call := Child_Outer;
+      Inner_Proc ( Parent_Type'Class(X) );
+   end Outer_Proc;
+
+end C460006_0.C460006_1.C460006_2;
+
+
+     --==================================================================--
+
+
+package C460006_0.C460006_1.C460006_2.C460006_3 is
+
+   type Grandchild_Type is new Child_Type with record
+      C3: String(1 .. 5) := "-----";
+   end record;
+
+   procedure Inner_Proc (X : in out Grandchild_Type);
+   procedure Outer_Proc (X : in out Grandchild_Type);
+
+
+   function ClassWide_Func return Parent_Type'Class;
+
+
+   Grandchild_Value : constant Grandchild_Type := (First_Call  => None,
+                                                   Second_Call => None,
+                                                   C1          => 15,
+                                                   C2          => "Hello",
+                                                   C3          => "World");
+
+end C460006_0.C460006_1.C460006_2.C460006_3;
+
+
+     --==================================================================--
+
+
+package body C460006_0.C460006_1.C460006_2.C460006_3 is
+
+   procedure Inner_Proc (X : in out Grandchild_Type) is
+   begin
+      X.Second_Call := Grandchild_Inner;
+   end Inner_Proc;
+
+   -------------------------------------------------
+   procedure Outer_Proc (X : in out Grandchild_Type) is
+   begin
+      X.First_Call := Grandchild_Outer;
+      Inner_Proc ( Parent_Type'Class(X) );
+   end Outer_Proc;
+
+   -------------------------------------------------
+   function ClassWide_Func return Parent_Type'Class is
+      A : Grandchild_Type   := Grandchild_Value;
+      X : Parent_Type'Class := Parent_Type(A); -- Value of X is still that of A.
+   begin
+      return X;
+   end ClassWide_Func;
+
+end C460006_0.C460006_1.C460006_2.C460006_3;
+
+
+     --==================================================================--
+
+
+with C460006_0.C460006_1.C460006_2.C460006_3;
+
+with Report;
+procedure C460006 is
+
+   package Root_Package       renames C460006_0;
+   package Parent_Package     renames C460006_0.C460006_1;
+   package Child_Package      renames C460006_0.C460006_1.C460006_2;
+   package Grandchild_Package renames C460006_0.C460006_1.C460006_2.C460006_3;
+
+begin
+   Report.Test ("C460006", "Check that a view conversion to a tagged type " &
+                "is permitted in the prefix of a selected component, an "   &
+                "object renaming declaration, and (if the operand is a "    &
+                "variable) on the left side of an assignment statement.  "  &
+                "Check that such a renaming or assignment does not change " &
+                " the tag of the operand");
+
+
+   --
+   -- Check conversion as prefix of selected component:
+   --
+
+   Selected_Component_Subtest:
+   declare
+      use Root_Package, Parent_Package, Child_Package, Grandchild_Package;
+
+      Var    : Grandchild_Type   := Grandchild_Value;
+      CW_Var : Parent_Type'Class := Var;
+
+      Ren    : Integer renames Parent_Type(Var).C1;
+
+   begin
+      if Ren /= 15 then
+         Report.Failed ("Wrong value: selected component in renaming");
+      end if;
+
+      if Child_Type(Var).C2 /= "Hello" then
+         Report.Failed ("Wrong value: selected component in IF");
+      end if;
+
+      Grandchild_Type(CW_Var).C3(2..4) := "eir";
+      if CW_Var /= Parent_Type'Class
+                   (Grandchild_Type'(None, None, 15, "Hello", "Weird"))
+      then
+         Report.Failed ("Wrong value: selected component in assignment");
+      end if;
+   end Selected_Component_Subtest;
+
+
+   --
+   -- Check conversion in object renaming:
+   --
+
+   Object_Renaming_Subtest:
+   declare
+      use Root_Package, Parent_Package, Child_Package, Grandchild_Package;
+
+      Var : Grandchild_Type := Grandchild_Value;
+      Ren1 : Parent_Type       renames Parent_Type(Var);
+      Ren2 : Child_Type        renames Child_Type(Var);
+      Ren3 : Parent_Type'Class renames Parent_Type'Class(Var);
+      Ren4 : Parent_Type       renames Parent_Type(Ren2); -- Rename of rename.
+   begin
+      Outer_Proc (Ren1);
+      if Ren1 /= (Parent_Outer, Grandchild_Inner, 15) then
+         Report.Failed ("Value or tag not preserved by object renaming: Ren1");
+      end if;
+
+      Outer_Proc (Ren2);
+      if Ren2 /= (Child_Outer, Grandchild_Inner, 15, "Hello") then
+         Report.Failed ("Value or tag not preserved by object renaming: Ren2");
+      end if;
+
+      Outer_Proc (Ren3);
+      if Ren3 /= Parent_Type'Class
+                 (Grandchild_Type'(Grandchild_Outer,
+                                   Grandchild_Inner,
+                                   15,
+                                   "Hello",
+                                   "World"))
+      then
+         Report.Failed ("Value or tag not preserved by object renaming: Ren3");
+      end if;
+
+      Outer_Proc (Ren4);
+      if Ren4 /= (Parent_Outer, Grandchild_Inner, 15) then
+         Report.Failed ("Value or tag not preserved by object renaming: Ren4");
+      end if;
+   end Object_Renaming_Subtest;
+
+
+   --
+   -- Check reading view conversion, and conversion as left side of assignment:
+   --
+
+   View_Conversion_Subtest:
+   declare
+      use Root_Package, Parent_Package, Child_Package, Grandchild_Package;
+
+      Var : Grandchild_Type := Grandchild_Value;
+      Specific  : Child_Type;
+      ClassWide : Parent_Type'Class := Var;   -- Grandchild_Type tag.
+   begin
+      if Parent_Type(Var) /= (None, None, 15) then
+         Report.Failed ("View has wrong value: #1");
+      end if;
+
+      if Child_Type(Var) /= (None, None, 15, "Hello") then
+         Report.Failed ("View has wrong value: #2");
+      end if;
+
+      if Parent_Type'Class(Var) /= ClassWide_Func then
+         Report.Failed ("Upward view conversion did not preserve " &
+                        "extension's components");
+      end if;
+
+
+      Parent_Type(Specific) := (None, None, 26); -- Assign to view.
+      Outer_Proc (Specific);                     -- Call dispatching op.
+
+      if Specific /= (Child_Outer, Child_Inner, 26, "-----") then
+         Report.Failed ("Value or tag not preserved by assignment: Specific");
+      end if;
+
+
+      Parent_Type(ClassWide) := (None, None, 44); -- Assign to view.
+      Outer_Proc (ClassWide);                     -- Call dispatching op.
+
+      if ClassWide /= Parent_Type'Class
+                      (Grandchild_Type'(Grandchild_Outer,
+                                        Grandchild_Inner,
+                                        44,
+                                        "Hello",
+                                        "World"))
+      then
+         Report.Failed ("Value or tag not preserved by assignment: ClassWide");
+      end if;
+   end View_Conversion_Subtest;
+
+   Report.Result;
+
+end C460006;