===================================================================
@@ -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;
===================================================================
@@ -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
===================================================================
@@ -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);
An extension aggregate is converted into a regular aggregate by collecting the inherited components and discriminants from ancestors and adding the components specified in the extension. If the type extension inherits discriminants from some ancestor, the corresponding values must be obtained before analyzing other components, in order to create the proper subtype for the aggregate. Thus the process of adding associations for those discriminants takes place during analysis even though it is properly an expansion activity. If the aggregate appears in a context that delays its expansion, such as an enclosing aggregate or an allocator, it is eventually reanalyzed and expanded. The re-analysis must not add again the values of inherited discriminants to prevent spurious semantic errors. The following must compile and execute quietly: -- with Ref1; use Ref1; procedure Try is It : Grand_Child; Ptr : Acc := Init (It); begin if Ptr.D /= 1234 then raise Program_Error; end if; end; --- package Ref1 is type Root (D : Integer) is tagged null record; type Child is new Root (1234) with null record; type Grand_Child is new Child with null record; type Acc is access all Grand_Child; function Init (X : Grand_Child) return Acc; end Ref1; --- package body Ref1 is function Init (X : Grand_Child) return Acc is Res : Acc := new Grand_Child'(Child (X) with null record); begin return Res; end Init; end Ref1; Tested on x86_64-pc-linux-gnu, committed on trunk 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.