re PR ada/18819 (ACATS cdd2a02 fail at runtime)

	PR ada/18819
	* sem_ch3.adb (Create_Constrained_Components): for a subtype of an
	untagged derived type, add hidden components to keep discriminant
	layout consistent, when a given discriminant of the derived type
	constraints several discriminants of the parent type.

From-SVN: r122208

4 files changed, 135 insertions, 6 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 493a41e..6b7cc45 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,11 @@
+2007-02-21  Ed Schonberg  <schonberg@adacore.com>
+
+	PR ada/18819
+	* sem_ch3.adb (Create_Constrained_Components): for a subtype of an
+	untagged derived type, add hidden components to keep discriminant
+	layout consistent, when a given discriminant of the derived type
+	constraints several discriminants of the parent type.
+
 2007-02-16  Eric Botcazou  <ebotcazou@adacore.com>
             Sandra Loosemore  <sandra@codesourcery.com>
 
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index f4c5ba6..29efc4d 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -9835,6 +9835,18 @@ package body Sem_Ch3 is
          New_Compon : constant Entity_Id := New_Copy (Old_Compon);
 
       begin
+         if Ekind (Old_Compon) = E_Discriminant
+           and then Is_Completely_Hidden (Old_Compon)
+         then
+
+            --  This is a shadow discriminant created for a discriminant of
+            --  the parent type that is one of several renamed by the same
+            --  new discriminant. Give the shadow discriminant an internal
+            --  name that cannot conflict with that of visible components.
+
+            Set_Chars (New_Compon, New_Internal_Name ('C'));
+         end if;
+
          --  Set the parent so we have a proper link for freezing etc. This is
          --  not a real parent pointer, since of course our parent does not own
          --  up to us and reference us, we are an illegitimate child of the
@@ -9915,12 +9927,85 @@ package body Sem_Ch3 is
 
       --  Inherit the discriminants of the parent type
 
-      Old_C := First_Discriminant (Typ);
-      while Present (Old_C) loop
-         New_C := Create_Component (Old_C);
-         Set_Is_Public (New_C, Is_Public (Subt));
-         Next_Discriminant (Old_C);
-      end loop;
+      Add_Discriminants : declare
+         Num_Disc : Int;
+         Num_Gird : Int;
+
+      begin
+         Num_Disc := 0;
+         Old_C := First_Discriminant (Typ);
+
+         while Present (Old_C) loop
+            Num_Disc := Num_Disc + 1;
+            New_C := Create_Component (Old_C);
+            Set_Is_Public (New_C, Is_Public (Subt));
+            Next_Discriminant (Old_C);
+         end loop;
+
+         --  For an untagged derived subtype, the number of discriminants may
+         --  be smaller than the number of inherited discriminants, because
+         --  several of them may be renamed by a single new discriminant.
+         --  In this case, add the hidden discriminants back into the subtype,
+         --  because otherwise the size of the subtype is computed incorrectly
+         --  in GCC 4.1.
+
+         Num_Gird := 0;
+
+         if Is_Derived_Type (Typ)
+           and then not Is_Tagged_Type (Typ)
+         then
+            Old_C := First_Stored_Discriminant (Typ);
+
+            while Present (Old_C) loop
+               Num_Gird := Num_Gird + 1;
+               Next_Stored_Discriminant (Old_C);
+            end loop;
+         end if;
+
+         if Num_Gird > Num_Disc then
+
+            --  Find out multiple uses of new discriminants, and add hidden
+            --  components for the extra renamed discriminants. We recognize
+            --  multiple uses through the Corresponding_Discriminant of a
+            --  new discriminant: if it constrains several old discriminants,
+            --  this field points to the last one in the parent type. The
+            --  stored discriminants of the derived type have the same name
+            --  as those of the parent.
+
+            declare
+               Constr    : Elmt_Id;
+               New_Discr : Entity_Id;
+               Old_Discr : Entity_Id;
+
+            begin
+               Constr    := First_Elmt (Stored_Constraint (Typ));
+               Old_Discr := First_Stored_Discriminant (Typ);
+
+               while Present (Constr) loop
+                  if Is_Entity_Name (Node (Constr))
+                    and then Ekind (Entity (Node (Constr))) = E_Discriminant
+                  then
+                     New_Discr := Entity (Node (Constr));
+
+                     if Chars (Corresponding_Discriminant (New_Discr))
+                         /= Chars (Old_Discr)
+                     then
+
+                        --  The new discriminant has been used to rename
+                        --  a subsequent old discriminant. Introduce a shadow
+                        --  component for the current old discriminant.
+
+                        New_C := Create_Component (Old_Discr);
+                        Set_Original_Record_Component  (New_C, Old_Discr);
+                     end if;
+                  end if;
+
+                  Next_Elmt (Constr);
+                  Next_Stored_Discriminant (Old_Discr);
+               end loop;
+            end;
+         end if;
+      end Add_Discriminants;
 
       if Is_Static
         and then Is_Variant_Record (Typ)
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index b0c6a20..acf266d 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2007-02-21  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gnat.dg/derived_aggregate.adb: New test.
+
 2007-02-21  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
 
 	* gcc.dg/torture/builtin-ldexp-1.c: Use -fno-finite-math-only on
diff --git a/gcc/testsuite/gnat.dg/derived_aggregate.adb b/gcc/testsuite/gnat.dg/derived_aggregate.adb
new file mode 100644
index 0000000..29dad78
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/derived_aggregate.adb
@@ -0,0 +1,32 @@
+-- { dg-do run }
+-- { dg-options "-O2" }
+
+procedure Derived_Aggregate is
+  type Int is range 1 .. 10;
+  type Str is array (Int range <>) of Character;
+
+  type Parent (D1, D2 : Int; B : Boolean) is
+    record
+      S : Str (D1 .. D2);
+      case B is
+        when False => C1 : Integer;
+        when True =>  C2 : Float;
+      end case;
+    end record;
+
+  for Parent'Alignment use 8;
+
+  type Derived (D : Int) is new Parent (D1 => D, D2 => D, B => False);
+
+  function Ident (I : Integer) return integer is
+  begin
+     return I;
+  end;
+
+  Y : Derived := (D => 7, S => "b", C1 => Ident (32));
+
+begin
+  if Parent(Y).D1 /= 7 then
+    raise Program_Error;
+  end if;
+end;