Fix PR ada/18819

[Eric Botcazou <ebotcazou at adacore dot com>]

This is a long-standing bad interaction between the Tree-SRA pass and the way 
the front-end builds some aggregates, responsible for the failure of ACATS 
cdd2a02 at -O2 on most platforms.

When a discriminant of an untagged discriminated derived type constrains more
than one discriminant of the parent, these constrained discriminants are fully
hidden from visibility, but they are still part of the layout of any subtype.
They must appear in the list of components to ensure that the compiler builds 
a proper constructor for objects of the subtype.

This patch scans the list of constraints and the list of discriminants of the
derived type, and introduces into the subtype the required shadow 
discriminants.

These are given internal names to prevent visibility conflicts with the 
visible discriminants of the derived type.

Bootstrapped/regtested on i586-suse-linux, applied to mainline and 4.2 
branch.


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-21  Eric Botcazou  <ebotcazou@adacore.com>

	* gnat.dg/derived_aggregate.adb: New test.


-- 
Eric Botcazou

Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 122195)
+++ sem_ch3.adb	(working copy)
@@ -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)

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