+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.
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,
-- 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;
Loc : Source_Ptr;
Ancestor : Node_Id;
+ Comp_Assoc : Node_Id;
Discr_Expr : Node_Id;
Ancestor_Typ : Entity_Id;
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);
end if;
Resolve_Aggr_Expr (Discr_Expr, Discr);
+ Set_Inherited_Discriminant (Last (New_Assoc_List));
return False;
end if;
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
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
-- 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
-- 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
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
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
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);
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);
projects / platform / upstream / gcc.git / commitdiff