[multiple changes]

2010-06-17  Ed Schonberg  <schonberg@adacore.com>

	* sinfo.ads, sinfo.adb (Inherited_Discriminant): New flag on
	N_Component_Association nodes, to indicate that a component association
	of an extension aggregate denotes the value of a discriminant of an
	ancestor type that has been constrained by the derivation.
	* sem_aggr.adb (Discr_Present): use Inherited_Discriminant to prevent a
	double expansion of the aggregate appearing in a context that delays
	expansion, to prevent double insertion of discriminant values when the
	aggregate is reanalyzed.

2010-06-17  Arnaud Charlet  <charlet@adacore.com>

	* exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Do not use
	Allocator as the Related_Node of Return_Obj_Access in call to
	Make_Temporary below as this would create a sort of infinite
	"recursion".

From-SVN: r160914

5 files changed, 76 insertions, 5 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index b5944ee..bc50025 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,21 @@
+2010-06-17  Ed Schonberg  <schonberg@adacore.com>
+
+	* sinfo.ads, sinfo.adb (Inherited_Discriminant): New flag on
+	N_Component_Association nodes, to indicate that a component association
+	of an extension aggregate denotes the value of a discriminant of an
+	ancestor type that has been constrained by the derivation.
+	* sem_aggr.adb (Discr_Present): use Inherited_Discriminant to prevent a
+	double expansion of the aggregate appearing in a context that delays
+	expansion, to prevent double insertion of discriminant values when the
+	aggregate is reanalyzed.
+
+2010-06-17  Arnaud Charlet  <charlet@adacore.com>
+
+	* exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Do not use
+	Allocator as the Related_Node of Return_Obj_Access in call to
+	Make_Temporary below as this would create a sort of infinite
+	"recursion".
+
 2010-06-17  Ben Brosgol  <brosgol@adacore.com>
 
 	* gnat_ugn.texi: Update gnatcheck doc.
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 39e62d5..d1a56e2 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -5095,9 +5095,11 @@ package body Exp_Ch6 is
          Rewrite (Allocator, New_Allocator);
 
          --  Create a new access object and initialize it to the result of the
-         --  new uninitialized allocator.
+         --  new uninitialized allocator. Do not use Allocator as the
+         --  Related_Node of Return_Obj_Access in call to Make_Temporary below
+         --  as this would create a sort of infinite "recursion".
 
-         Return_Obj_Access := Make_Temporary (Loc, 'R', Allocator);
+         Return_Obj_Access := Make_Temporary (Loc, 'R');
          Set_Etype (Return_Obj_Access, Acc_Type);
 
          Insert_Action (Allocator,
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 3b0bda0..bdc2be0 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -2488,10 +2488,14 @@ package body Sem_Aggr is
       --  whose value may already have been specified by N's ancestor part.
       --  This routine checks whether this is indeed the case and if so returns
       --  False, signaling that no value for Discr should appear in N's
-      --  aggregate part. Also, in this case, the routine appends
-      --  New_Assoc_List Discr the discriminant value specified in the ancestor
+      --  aggregate part. Also, in this case, the routine appends to
+      --  New_Assoc_List the discriminant value specified in the ancestor
       --  part.
-      --  Can't parse previous sentence, appends what where???
+      --  If the aggregate is in a context with expansion delayed, it will be
+      --  reanalyzed, The inherited discriminant values must not be reinserted
+      --  in the component list to prevent spurious errors, but it must be
+      --  present on first analysis to build the proper subtype indications.
+      --  The flag Inherited_Discriminant is used to prevent the re-insertion.
 
       function Get_Value
         (Compon                 : Node_Id;
@@ -2556,6 +2560,7 @@ package body Sem_Aggr is
          Loc : Source_Ptr;
 
          Ancestor     : Node_Id;
+         Comp_Assoc   : Node_Id;
          Discr_Expr   : Node_Id;
 
          Ancestor_Typ : Entity_Id;
@@ -2570,6 +2575,20 @@ package body Sem_Aggr is
             return True;
          end if;
 
+         --  Check whether inherited discriminant values have already been
+         --  inserted in the aggregate. This will be the case if we are
+         --  re-analyzing an aggregate whose expansion was delayed.
+
+         if Present (Component_Associations (N)) then
+            Comp_Assoc := First (Component_Associations (N));
+            while Present (Comp_Assoc) loop
+               if Inherited_Discriminant (Comp_Assoc) then
+                  return True;
+               end if;
+               Next (Comp_Assoc);
+            end loop;
+         end if;
+
          Ancestor     := Ancestor_Part (N);
          Ancestor_Typ := Etype (Ancestor);
          Loc          := Sloc (Ancestor);
@@ -2627,6 +2646,7 @@ package body Sem_Aggr is
                end if;
 
                Resolve_Aggr_Expr (Discr_Expr, Discr);
+               Set_Inherited_Discriminant (Last (New_Assoc_List));
                return False;
             end if;
 
diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb
index 57f8f93..8a5c6bc 100644
--- a/gcc/ada/sinfo.adb
+++ b/gcc/ada/sinfo.adb
@@ -1572,6 +1572,14 @@ package body Sinfo is
       return Flag11 (N);
    end Includes_Infinities;
 
+   function Inherited_Discriminant
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_Association);
+      return Flag13 (N);
+   end Inherited_Discriminant;
+
    function Instance_Spec
       (N : Node_Id) return Node_Id is
    begin
@@ -4466,6 +4474,14 @@ package body Sinfo is
       Set_Flag11 (N, Val);
    end Set_Includes_Infinities;
 
+   procedure Set_Inherited_Discriminant
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_Association);
+      Set_Flag13 (N, Val);
+   end Set_Inherited_Discriminant;
+
    procedure Set_Instance_Spec
       (N : Node_Id; Val : Node_Id) is
    begin
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 31f555b..9a95b13 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -1180,6 +1180,12 @@ package Sinfo is
    --    range is given by the programmer, even if that range is identical to
    --    the range for Float.
 
+   --  Inherited_Discriminant (Flag13-Sem)
+   --    This flag is present in N_Component_Association nodes. It indicates
+   --    that a given component association in an extension aggregate is the
+   --    value obtained from a constraint on an ancestor. Used to prevent
+   --    double expansion when the aggregate has expansion delayed.
+
    --  Instance_Spec (Node5-Sem)
    --    This field is present in generic instantiation nodes, and also in
    --    formal package declaration nodes (formal package declarations are
@@ -3340,6 +3346,7 @@ package Sinfo is
       --  Loop_Actions (List2-Sem)
       --  Expression (Node3)
       --  Box_Present (Flag15)
+      --  Inherited_Discriminant (Flag13)
 
       --  Note: this structure is used for both record component associations
       --  and array component associations, since the two cases aren't always
@@ -8117,6 +8124,9 @@ package Sinfo is
    function Includes_Infinities
      (N : Node_Id) return Boolean;    -- Flag11
 
+   function Inherited_Discriminant
+     (N : Node_Id) return Boolean;    -- Flag13
+
    function Instance_Spec
      (N : Node_Id) return Node_Id;    -- Node5
 
@@ -9041,6 +9051,9 @@ package Sinfo is
    procedure Set_Includes_Infinities
      (N : Node_Id; Val : Boolean := True);    -- Flag11
 
+   procedure Set_Inherited_Discriminant
+     (N : Node_Id; Val : Boolean := True);    -- Flag13
+
    procedure Set_Instance_Spec
      (N : Node_Id; Val : Node_Id);            -- Node5
 
@@ -11332,6 +11345,7 @@ package Sinfo is
    pragma Inline (Interface_Present);
    pragma Inline (Includes_Infinities);
    pragma Inline (In_Present);
+   pragma Inline (Inherited_Discriminant);
    pragma Inline (Instance_Spec);
    pragma Inline (Intval);
    pragma Inline (Is_Accessibility_Actual);
@@ -11636,6 +11650,7 @@ package Sinfo is
    pragma Inline (Set_Interface_List);
    pragma Inline (Set_Interface_Present);
    pragma Inline (Set_In_Present);
+   pragma Inline (Set_Inherited_Discriminant);
    pragma Inline (Set_Instance_Spec);
    pragma Inline (Set_Intval);
    pragma Inline (Set_Is_Accessibility_Actual);