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".



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160914 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 23 insertions, 3 deletions

diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 3b0bda0753a..bdc2be0b1af 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;