@@ -5243,7 +5243,7 @@ package body Exp_Aggr is
-- The bounds of the aggregate for this dimension
Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim);
- -- The index type for this dimension.xxx
+ -- The index type for this dimension.
Cond : Node_Id;
Assoc : Node_Id;
@@ -7344,6 +7344,12 @@ package body Exp_Aggr is
-- choices that are ranges, subtype indications, subtype names, and
-- iterated component associations.
+ function Make_Array_Delta_Assignment_LHS
+ (Choice : Node_Id; Temp : Entity_Id) return Node_Id;
+ -- Generate the LHS for the assignment associated with one
+ -- component association. This can be more complex than just an
+ -- indexed component in the case of a deep delta aggregate.
+
-------------------
-- Generate_Loop --
-------------------
@@ -7380,6 +7386,60 @@ package body Exp_Aggr is
End_Label => Empty);
end Generate_Loop;
+ function Make_Array_Delta_Assignment_LHS
+ (Choice : Node_Id; Temp : Entity_Id) return Node_Id
+ is
+ function Make_Delta_Choice_LHS
+ (Choice : Node_Id;
+ Deep_Choice : Boolean) return Node_Id;
+ -- Recursively (but recursion only in deep delta aggregate case)
+ -- build up the LHS by successively applying selectors.
+
+ ---------------------------
+ -- Make_Delta_Choice_LHS --
+ ---------------------------
+
+ function Make_Delta_Choice_LHS
+ (Choice : Node_Id;
+ Deep_Choice : Boolean) return Node_Id
+ is
+ begin
+ if not Deep_Choice
+ or else Is_Root_Prefix_Of_Deep_Choice (Choice)
+ then
+ return Make_Indexed_Component (Sloc (Choice),
+ Prefix => New_Occurrence_Of (Temp, Loc),
+ Expressions => New_List (New_Copy_Tree (Choice)));
+
+ else
+ -- a deep delta aggregate choice
+ pragma Assert (All_Extensions_Allowed);
+
+ declare
+ -- recursively get name for prefix
+ LHS_Prefix : constant Node_Id
+ := Make_Delta_Choice_LHS (Prefix (Choice), Deep_Choice);
+ begin
+ if Nkind (Choice) = N_Indexed_Component then
+ return Make_Indexed_Component (Sloc (Choice),
+ Prefix => LHS_Prefix,
+ Expressions => New_Copy_List (Expressions (Choice)));
+ else
+ return Make_Selected_Component (Sloc (Choice),
+ Prefix => LHS_Prefix,
+ Selector_Name =>
+ Make_Identifier
+ (Sloc (Choice),
+ Chars (Selector_Name (Choice))));
+ end if;
+ end;
+ end if;
+ end Make_Delta_Choice_LHS;
+ begin
+ return Make_Delta_Choice_LHS
+ (Choice, Is_Deep_Choice (Choice, Etype (N)));
+ end Make_Array_Delta_Assignment_LHS;
+
-- Local variables
Choice : Node_Id;
@@ -7416,9 +7476,7 @@ package body Exp_Aggr is
Append_To (Deltas,
Make_Assignment_Statement (Sloc (Choice),
Name =>
- Make_Indexed_Component (Sloc (Choice),
- Prefix => New_Occurrence_Of (Temp, Loc),
- Expressions => New_List (New_Copy_Tree (Choice))),
+ Make_Array_Delta_Assignment_LHS (Choice, Temp),
Expression => New_Copy_Tree (Expression (Assoc))));
end if;
@@ -7443,6 +7501,43 @@ package body Exp_Aggr is
Assoc : Node_Id;
Choice : Node_Id;
+ function Make_Record_Delta_Assignment_LHS
+ (Selector : Node_Id) return Node_Id;
+ -- Generate the LHS for an assignment to a component (or subcomponent
+ -- if -gnatX specified) of the result object.
+
+ --------------------------------------
+ -- Make_Record_Delta_Assignment_LHS --
+ --------------------------------------
+
+ function Make_Record_Delta_Assignment_LHS
+ (Selector : Node_Id) return Node_Id
+ is
+ begin
+ if Nkind (Selector) = N_Selected_Component then
+ -- a deep delta aggregate, requires -gnatX0
+ return
+ Make_Selected_Component
+ (Sloc (Choice),
+ Prefix => Make_Record_Delta_Assignment_LHS
+ (Prefix (Selector)),
+ Selector_Name =>
+ Make_Identifier (Loc, Chars (Selector_Name (Selector))));
+ elsif Nkind (Selector) = N_Indexed_Component then
+ -- a deep delta aggregate, requires -gnatX0
+ return
+ Make_Indexed_Component
+ (Sloc (Choice),
+ Prefix => Make_Record_Delta_Assignment_LHS
+ (Prefix (Selector)),
+ Expressions => Expressions (Selector));
+ else
+ return Make_Selected_Component
+ (Sloc (Choice),
+ Prefix => New_Occurrence_Of (Temp, Loc),
+ Selector_Name => Make_Identifier (Loc, Chars (Selector)));
+ end if;
+ end Make_Record_Delta_Assignment_LHS;
begin
Assoc := First (Component_Associations (N));
@@ -7451,10 +7546,7 @@ package body Exp_Aggr is
while Present (Choice) loop
Append_To (Deltas,
Make_Assignment_Statement (Sloc (Choice),
- Name =>
- Make_Selected_Component (Sloc (Choice),
- Prefix => New_Occurrence_Of (Temp, Loc),
- Selector_Name => Make_Identifier (Loc, Chars (Choice))),
+ Name => Make_Record_Delta_Assignment_LHS (Choice),
Expression => New_Copy_Tree (Expression (Assoc))));
Next (Choice);
end loop;
@@ -43,6 +43,7 @@ with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aggr; use Sem_Aggr;
with Sem_Aux; use Sem_Aux;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
@@ -186,15 +187,47 @@ package body Exp_SPARK is
(Typ : Entity_Id;
Aggr : Node_Id)
is
+ procedure Apply_Range_Checks (Choice : Node_Id);
+ -- Apply range checks on indexes from a deep choice
+
+ ------------------------
+ -- Apply_Range_Checks --
+ ------------------------
+
+ procedure Apply_Range_Checks (Choice : Node_Id) is
+ Pref : Node_Id := Choice;
+ Index : N_Subexpr_Id;
+ begin
+ loop
+ if Nkind (Pref) = N_Indexed_Component then
+ Index := First (Expressions (Choice));
+ Apply_Scalar_Range_Check (Index, Etype (Index));
+
+ elsif Is_Array_Type (Typ)
+ and then Is_Root_Prefix_Of_Deep_Choice (Pref)
+ then
+ Index := Pref;
+ Apply_Scalar_Range_Check (Index, Etype (Index));
+ end if;
+
+ exit when Is_Root_Prefix_Of_Deep_Choice (Pref);
+
+ Pref := Prefix (Pref);
+ end loop;
+ end Apply_Range_Checks;
+
+ -- Local variables
+
Assoc : Node_Id;
Comp : Node_Id;
- Comp_Id : Entity_Id;
Comp_Type : Entity_Id;
Expr : Node_Id;
Index : Node_Id;
Index_Typ : Entity_Id;
New_Assoc : Node_Id;
+ -- Start of processing for Expand_SPARK_Delta_Or_Update
+
begin
-- Apply scalar range checks on the updated components, if needed
@@ -277,6 +310,9 @@ package body Exp_SPARK is
if Nkind (Index) in N_Range | N_Subtype_Indication then
null;
+ elsif Is_Deep_Choice (Index, Typ) then
+ Apply_Range_Checks (Index);
+
-- Otherwise the index denotes a single expression where
-- range checks need to be applied or a subtype name
-- (without range constraints) where applying checks is
@@ -346,15 +382,16 @@ package body Exp_SPARK is
Comp := First (Choices (Assoc));
while Present (Comp) loop
- Comp_Id := Entity (Comp);
- Comp_Type := Etype (Comp_Id);
+ if Is_Deep_Choice (Comp, Typ) then
+ Comp_Type := Etype (Comp);
+ else
+ Comp_Type := Etype (Entity (Comp));
+ end if;
New_Assoc :=
Make_Component_Association
(Sloc => Sloc (Assoc),
- Choices =>
- New_List
- (New_Occurrence_Of (Comp_Id, Sloc (Comp))),
+ Choices => New_List (New_Copy_Tree (Comp)),
Expression => New_Copy_Tree (Expr));
-- New association must be attached to the aggregate before we
@@ -364,6 +401,10 @@ package body Exp_SPARK is
Analyze_And_Resolve (Expression (New_Assoc), Comp_Type);
+ if Is_Deep_Choice (Comp, Typ) then
+ Apply_Range_Checks (First (Choices (New_Assoc)));
+ end if;
+
if Is_Scalar_Type (Comp_Type) then
Apply_Scalar_Range_Check
(Expression (New_Assoc), Comp_Type);
@@ -1393,6 +1393,8 @@ package body Ch4 is
Start_Token : constant Token_Type := Token;
-- Used to prevent mismatches (...] and [...)
+ Saved_Delta_Aggregate_Flag : constant Boolean := Inside_Delta_Aggregate;
+
-- Start of processing for P_Aggregate_Or_Paren_Expr
begin
@@ -1497,6 +1499,7 @@ package body Ch4 is
Scan; -- past WITH
if Token = Tok_Delta then
Scan; -- past DELTA
+ Inside_Delta_Aggregate := True;
Aggregate_Node := New_Node (N_Delta_Aggregate, Lparen_Sloc);
Set_Expression (Aggregate_Node, Expr_Node);
Expr_Node := Empty;
@@ -1707,6 +1710,16 @@ package body Ch4 is
end if;
Set_Component_Associations (Aggregate_Node, Assoc_List);
+
+ -- Inside_Delta_Aggregate is only tested if Serious_Errors = 0, so
+ -- it is ok if we fail to restore the saved I_D_A value in an error
+ -- path. In particular, it is ok that we do not restore it if
+ -- Error_Resync is propagated. Earlier return statements (which return
+ -- without restoring the saved I_D_A value) should either be in error
+ -- paths or in paths where I_D_A could not have been modified.
+
+ Inside_Delta_Aggregate := Saved_Delta_Aggregate_Flag;
+
return Aggregate_Node;
end P_Aggregate_Or_Paren_Expr;
@@ -2519,6 +2532,109 @@ package body Ch4 is
Expr_Form := EF_Simple;
end if;
+ -- If all extensions are enabled and we have a deep delta aggregate
+ -- whose type is an array type with an element type that is a
+ -- record type, then we can encounter legal things like
+ -- with delta (Some_Index_Expression).Some_Component
+ -- where a parenthesized expression precedes a dot.
+ -- Similarly, if the element type is an array type then we can see
+ -- with delta (Some_Index_Expression)(Another_Index_Expression)
+ -- where a parenthesized expression precedes a left parenthesis.
+
+ if Token in Tok_Dot | Tok_Left_Paren
+ and then Prev_Token = Tok_Right_Paren
+ and then Serious_Errors_Detected = 0
+ and then Inside_Delta_Aggregate
+ and then All_Extensions_Allowed
+ then
+ if Token = Tok_Dot then
+ Node2 := New_Node (N_Selected_Component, Token_Ptr);
+ Scan; -- past dot
+ declare
+ Tail : constant Node_Id := P_Simple_Expression;
+ -- remaining selectors occurring after the dot
+
+ Rover : Node_Id := Tail;
+ Prev : Node_Id := Empty;
+ begin
+ -- If Tail already has a prefix, then we want to prepend
+ -- Node1 onto that prefix and then return Tail.
+ -- Otherwise, Tail should simply be an identifier so
+ -- we want to build a Selected_Component with Tail as the
+ -- selector name and return that.
+
+ Set_Prefix (Node2, Node1);
+
+ while Nkind (Rover)
+ in N_Indexed_Component | N_Selected_Component loop
+ Prev := Rover;
+ Rover := Prefix (Rover);
+ end loop;
+
+ case Nkind (Prev) is
+ when N_Selected_Component | N_Indexed_Component =>
+ -- We've scanned a dot, so an identifier should follow
+ if Nkind (Prefix (Prev)) = N_Identifier then
+ Set_Selector_Name (Node2, Prefix (Prev));
+ Set_Prefix (Prev, Node2);
+ return Tail;
+ end if;
+
+ when N_Empty =>
+ -- We've scanned a dot, so an identifier should follow
+ if Nkind (Tail) = N_Identifier then
+ Set_Selector_Name (Node2, Tail);
+ return Node2;
+ end if;
+
+ when others =>
+ null;
+ end case;
+
+ -- fall through to error case
+ end;
+ else
+ Node2 := New_Node (N_Indexed_Component, Token_Ptr);
+ declare
+ Tail : constant Node_Id := P_Simple_Expression;
+ -- remaining selectors
+
+ Rover : Node_Id := Tail;
+ Prev : Node_Id := Empty;
+ begin
+ -- If Tail already has a prefix, then we want to prepend
+ -- Node1 onto that prefix and then return Tail.
+ -- Otherwise, Tail should be an index expression and
+ -- we want to build an Indexed_Component with Tail as the
+ -- index value and return that.
+
+ Set_Prefix (Node2, Node1);
+
+ while Nkind (Rover)
+ in N_Indexed_Component | N_Selected_Component loop
+ Prev := Rover;
+ Rover := Prefix (Rover);
+ end loop;
+
+ case Nkind (Prev) is
+ when N_Selected_Component | N_Indexed_Component =>
+ Set_Expressions (Node2, New_List (Prefix (Prev)));
+ Set_Prefix (Prev, Node2);
+ return Tail;
+
+ when N_Empty =>
+ Set_Expressions (Node2, New_List (Tail));
+ return Node2;
+
+ when others =>
+ null;
+ end case;
+
+ -- fall through to error case
+ end;
+ end if;
+ end if;
+
-- Come here at end of simple expression, where we do a couple of
-- special checks to improve error recovery.
@@ -2529,8 +2645,8 @@ package body Ch4 is
if Token = Tok_Dot then
Error_Msg_SC ("prefix for selection is not a name");
- -- If qualified expression, comment and continue, otherwise something
- -- is pretty nasty so do an Error_Resync call.
+ -- If qualified expression, comment and continue, otherwise
+ -- something is pretty nasty so do an Error_Resync call.
if Ada_Version < Ada_2012
and then Nkind (Node1) = N_Qualified_Expression
@@ -76,6 +76,11 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- Variable used to save values of config switches while we parse the
-- new unit, to be restored on exit for proper recursive behavior.
+ Inside_Delta_Aggregate : Boolean := False;
+ -- True within a delta aggregate (but only after the "delta" token has
+ -- been scanned). Used to distinguish syntax errors from syntactically
+ -- correct "deep" delta aggregates (enabled via -gnatX0).
+
--------------------
-- Error Recovery --
--------------------
@@ -27,7 +27,6 @@ with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
-with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
@@ -423,6 +422,9 @@ package body Sem_Aggr is
procedure Resolve_Delta_Array_Aggregate (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Delta_Record_Aggregate (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Deep_Delta_Assoc (N : Node_Id; Typ : Entity_Id);
+ -- Resolve the names/expressions in a component association for
+ -- a deep delta aggregate. Typ is the type of the enclosing object.
------------------------
-- Array_Aggr_Subtype --
@@ -759,6 +761,28 @@ package body Sem_Aggr is
end if;
end Check_Expr_OK_In_Limited_Aggregate;
+ --------------------
+ -- Is_Deep_Choice --
+ --------------------
+
+ function Is_Deep_Choice
+ (Choice : Node_Id;
+ Aggr_Type : Type_Kind_Id) return Boolean
+ is
+ Pref : Node_Id := Choice;
+ begin
+ while not Is_Root_Prefix_Of_Deep_Choice (Pref) loop
+ Pref := Prefix (Pref);
+ end loop;
+
+ if Is_Array_Type (Aggr_Type) then
+ return Paren_Count (Pref) > 0
+ and then Pref /= Choice;
+ else
+ return Pref /= Choice;
+ end if;
+ end Is_Deep_Choice;
+
-------------------------
-- Is_Others_Aggregate --
-------------------------
@@ -771,6 +795,17 @@ package body Sem_Aggr is
and then Nkind (First (Choice_List (First (Assoc)))) = N_Others_Choice;
end Is_Others_Aggregate;
+ -----------------------------------
+ -- Is_Root_Prefix_Of_Deep_Choice --
+ -----------------------------------
+
+ function Is_Root_Prefix_Of_Deep_Choice (Pref : Node_Id) return Boolean is
+ begin
+ return Paren_Count (Pref) > 0
+ or else Nkind (Pref) not in N_Indexed_Component
+ | N_Selected_Component;
+ end Is_Root_Prefix_Of_Deep_Choice;
+
-------------------------
-- Is_Single_Aggregate --
-------------------------
@@ -3713,31 +3748,38 @@ package body Sem_Aggr is
else
Choice := First (Choice_List (Assoc));
while Present (Choice) loop
- Analyze (Choice);
+ if Is_Deep_Choice (Choice, Typ) then
+ pragma Assert (All_Extensions_Allowed);
- if Nkind (Choice) = N_Others_Choice then
- Error_Msg_N
- ("OTHERS not allowed in delta aggregate", Choice);
+ -- a deep delta aggregate
+ Resolve_Deep_Delta_Assoc (Assoc, Typ);
+ else
+ Analyze (Choice);
- elsif Is_Entity_Name (Choice)
- and then Is_Type (Entity (Choice))
- then
- -- Choice covers a range of values
+ if Nkind (Choice) = N_Others_Choice then
+ Error_Msg_N
+ ("OTHERS not allowed in delta aggregate", Choice);
- if Base_Type (Entity (Choice)) /=
- Base_Type (Index_Type)
+ elsif Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))
then
- Error_Msg_NE
- ("choice does not match index type of &",
- Choice, Typ);
- end if;
+ -- Choice covers a range of values
- elsif Nkind (Choice) = N_Subtype_Indication then
- Resolve_Discrete_Subtype_Indication
- (Choice, Base_Type (Index_Type));
+ if Base_Type (Entity (Choice)) /=
+ Base_Type (Index_Type)
+ then
+ Error_Msg_NE
+ ("choice does not match index type of &",
+ Choice, Typ);
+ end if;
- else
- Resolve (Choice, Index_Type);
+ elsif Nkind (Choice) = N_Subtype_Indication then
+ Resolve_Discrete_Subtype_Indication
+ (Choice, Base_Type (Index_Type));
+
+ else
+ Resolve (Choice, Index_Type);
+ end if;
end if;
Next (Choice);
@@ -3773,14 +3815,15 @@ package body Sem_Aggr is
Comp_Ref : Entity_Id := Empty; -- init to avoid warning
Variant : Node_Id;
- procedure Check_Variant (Id : Entity_Id);
+ procedure Check_Variant (Id : Node_Id);
-- If a given component of the delta aggregate appears in a variant
-- part, verify that it is within the same variant as that of previous
-- specified variant components of the delta.
- function Get_Component (Nam : Node_Id) return Entity_Id;
- -- Locate component with a given name and return it. If none found then
- -- report error and return Empty.
+ function Get_Component_Type
+ (Selector : Node_Id; Enclosing_Type : Entity_Id) return Entity_Id;
+ -- Locate component with a given name and return its type.
+ -- If none found then report error and return Empty.
function Nested_In (V1 : Node_Id; V2 : Node_Id) return Boolean;
-- Determine whether variant V1 is within variant V2
@@ -3792,7 +3835,7 @@ package body Sem_Aggr is
-- Check_Variant --
--------------------
- procedure Check_Variant (Id : Entity_Id) is
+ procedure Check_Variant (Id : Node_Id) is
Comp : Entity_Id;
Comp_Variant : Node_Id;
@@ -3843,30 +3886,80 @@ package body Sem_Aggr is
end if;
end Check_Variant;
- -------------------
- -- Get_Component --
- -------------------
+ ------------------------
+ -- Get_Component_Type --
+ ------------------------
- function Get_Component (Nam : Node_Id) return Entity_Id is
+ function Get_Component_Type
+ (Selector : Node_Id; Enclosing_Type : Entity_Id) return Entity_Id
+ is
Comp : Entity_Id;
-
begin
- Comp := First_Entity (Typ);
+ case Nkind (Selector) is
+ when N_Selected_Component | N_Indexed_Component =>
+ -- a deep delta aggregate choice
+
+ declare
+ Prefix_Type : constant Entity_Id :=
+ Get_Component_Type (Prefix (Selector), Enclosing_Type);
+ begin
+ if not Present (Prefix_Type) then
+ pragma Assert (Serious_Errors_Detected > 0);
+ return Empty;
+ end if;
+
+ -- Set the type of the prefix for GNATprove
+
+ Set_Etype (Prefix (Selector), Prefix_Type);
+
+ if Nkind (Selector) = N_Selected_Component then
+ return Get_Component_Type
+ (Selector_Name (Selector),
+ Enclosing_Type => Prefix_Type);
+ elsif not Is_Array_Type (Prefix_Type) then
+ Error_Msg_NE
+ ("type& is not an array type",
+ Selector, Prefix_Type);
+ elsif Number_Dimensions (Prefix_Type) /= 1 then
+ Error_Msg_NE
+ ("array type& not one-dimensional",
+ Selector, Prefix_Type);
+ elsif List_Length (Expressions (Selector)) /= 1 then
+ Error_Msg_NE
+ ("wrong number of indices for array type&",
+ Selector, Prefix_Type);
+ else
+ Analyze_And_Resolve
+ (First (Expressions (Selector)),
+ Etype (First_Index (Prefix_Type)));
+ return Component_Type (Prefix_Type);
+ end if;
+ end;
+
+ when others =>
+ null;
+ end case;
+
+ Comp := First_Entity (Enclosing_Type);
while Present (Comp) loop
- if Chars (Comp) = Chars (Nam) then
+ if Chars (Comp) = Chars (Selector) then
if Ekind (Comp) = E_Discriminant then
- Error_Msg_N ("delta cannot apply to discriminant", Nam);
+ Error_Msg_N ("delta cannot apply to discriminant", Selector);
end if;
- return Comp;
+ Set_Entity (Selector, Comp);
+ Set_Etype (Selector, Etype (Comp));
+
+ return Etype (Comp);
end if;
Next_Entity (Comp);
end loop;
- Error_Msg_NE ("type& has no component with this name", Nam, Typ);
+ Error_Msg_NE
+ ("type& has no component with this name", Selector, Enclosing_Type);
return Empty;
- end Get_Component;
+ end Get_Component_Type;
---------------
-- Nested_In --
@@ -3911,10 +4004,10 @@ package body Sem_Aggr is
Deltas : constant List_Id := Component_Associations (N);
- Assoc : Node_Id;
- Choice : Node_Id;
- Comp : Entity_Id;
- Comp_Type : Entity_Id := Empty; -- init to avoid warning
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Comp_Type : Entity_Id := Empty; -- init to avoid warning
+ Deep_Choice : Boolean;
-- Start of processing for Resolve_Delta_Record_Aggregate
@@ -3925,19 +4018,27 @@ package body Sem_Aggr is
while Present (Assoc) loop
Choice := First (Choice_List (Assoc));
while Present (Choice) loop
- Comp := Get_Component (Choice);
+ Deep_Choice := Nkind (Choice) /= N_Identifier;
+ if Deep_Choice then
+ Error_Msg_GNAT_Extension
+ ("deep delta aggregate", Sloc (Choice));
+ end if;
- if Present (Comp) then
- Check_Variant (Choice);
+ Comp_Type := Get_Component_Type
+ (Selector => Choice, Enclosing_Type => Typ);
- Comp_Type := Etype (Comp);
+ -- Set the type of the choice for GNATprove
- -- Decorate the component reference by setting its entity and
- -- type, as otherwise backends like GNATprove would have to
- -- rediscover this information by themselves.
+ if Deep_Choice then
+ Set_Etype (Choice, Comp_Type);
+ end if;
- Set_Entity (Choice, Comp);
- Set_Etype (Choice, Comp_Type);
+ if Present (Comp_Type) then
+ if not Deep_Choice then
+ -- ??? Not clear yet how RM 4.3.1(17.7) applies to a
+ -- deep delta aggregate.
+ Check_Variant (Choice);
+ end if;
else
Comp_Type := Any_Type;
end if;
@@ -3973,6 +4074,95 @@ package body Sem_Aggr is
end loop;
end Resolve_Delta_Record_Aggregate;
+ ------------------------------
+ -- Resolve_Deep_Delta_Assoc --
+ ------------------------------
+
+ procedure Resolve_Deep_Delta_Assoc (N : Node_Id; Typ : Entity_Id) is
+ Choice : constant Node_Id := First (Choice_List (N));
+ Enclosing_Type : Entity_Id := Typ;
+
+ procedure Resolve_Choice_Prefix
+ (Choice_Prefix : Node_Id; Enclosing_Type : in out Entity_Id);
+ -- Recursively analyze selectors. Enclosing_Type is set to
+ -- type of the last component.
+
+ ---------------------------
+ -- Resolve_Choice_Prefix --
+ ---------------------------
+
+ procedure Resolve_Choice_Prefix
+ (Choice_Prefix : Node_Id; Enclosing_Type : in out Entity_Id)
+ is
+ Selector : Node_Id := Choice_Prefix;
+ begin
+ if not Is_Root_Prefix_Of_Deep_Choice (Choice_Prefix) then
+ Resolve_Choice_Prefix (Prefix (Choice_Prefix), Enclosing_Type);
+
+ if Nkind (Choice_Prefix) = N_Selected_Component then
+ Selector := Selector_Name (Choice_Prefix);
+ else
+ pragma Assert (Nkind (Choice_Prefix) = N_Indexed_Component);
+ Selector := First (Expressions (Choice_Prefix));
+ end if;
+ end if;
+
+ if Is_Array_Type (Enclosing_Type) then
+ Analyze_And_Resolve (Selector,
+ Etype (First_Index (Enclosing_Type)));
+ Enclosing_Type := Component_Type (Enclosing_Type);
+ else
+ declare
+ Comp : Entity_Id := First_Entity (Enclosing_Type);
+ Found : Boolean := False;
+ begin
+ while Present (Comp) and not Found loop
+ if Chars (Comp) = Chars (Selector) then
+ if Ekind (Comp) = E_Discriminant then
+ Error_Msg_N ("delta cannot apply to discriminant",
+ Selector);
+ end if;
+ Found := True;
+ Set_Entity (Selector, Comp);
+ Set_Etype (Selector, Etype (Comp));
+ Set_Analyzed (Selector);
+ Enclosing_Type := Etype (Comp);
+ else
+ Next_Entity (Comp);
+ end if;
+ end loop;
+ if not Found then
+ Error_Msg_NE
+ ("type& has no component with this name",
+ Selector, Enclosing_Type);
+ end if;
+ end;
+ end if;
+
+ -- Set the type of the prefix for GNATprove, except for the root
+ -- prefix, whose type is already the expected one for a record
+ -- delta aggregate, or the type of the array index for an
+ -- array delta aggregate (the only case here really since
+ -- Resolve_Deep_Delta_Assoc is only called for array delta
+ -- aggregates).
+
+ if Selector /= Choice_Prefix then
+ Set_Etype (Choice_Prefix, Enclosing_Type);
+ end if;
+ end Resolve_Choice_Prefix;
+ begin
+ declare
+ Unimplemented : exception; -- TEMPORARY
+ begin
+ if Present (Next (Choice)) then
+ raise Unimplemented;
+ end if;
+ end;
+
+ Resolve_Choice_Prefix (Choice, Enclosing_Type);
+ Analyze_And_Resolve (Expression (N), Enclosing_Type);
+ end Resolve_Deep_Delta_Assoc;
+
---------------------------------
-- Resolve_Extension_Aggregate --
---------------------------------
@@ -26,7 +26,8 @@
-- This package contains the resolution code for aggregates. It is logically
-- part of Sem_Res, but is split off since the aggregate code is so complex.
-with Types; use Types;
+with Einfo.Entities; use Einfo.Entities;
+with Types; use Types;
package Sem_Aggr is
@@ -50,4 +51,15 @@ package Sem_Aggr is
function Is_Null_Array_Aggregate_High_Bound (N : Node_Id) return Boolean;
-- Returns True for the high bound of a null array aggregate.
+ function Is_Deep_Choice
+ (Choice : Node_Id;
+ Aggr_Type : Type_Kind_Id) return Boolean;
+ -- Returns whether Choice from a delta aggregate of type Aggr_Type is a
+ -- deep choice.
+
+ function Is_Root_Prefix_Of_Deep_Choice (Pref : Node_Id) return Boolean;
+ -- Returns whether prefix Pref of a deep choice is its root prefix. Except
+ -- for its use in Is_Deep_Choice, this function should only be called on
+ -- prefixes of a deep choice as identified by Is_Deep_Choice.
+
end Sem_Aggr;