diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 108 | ||||
| -rw-r--r-- | gcc/ada/exp_spark.adb | 53 | ||||
| -rw-r--r-- | gcc/ada/par-ch4.adb | 120 | ||||
| -rw-r--r-- | gcc/ada/par.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/sem_aggr.adb | 288 | ||||
| -rw-r--r-- | gcc/ada/sem_aggr.ads | 14 |
6 files changed, 522 insertions, 66 deletions
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 319254d..a6a54e8 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -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; diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb index c344dc1..c19aa20 100644 --- a/gcc/ada/exp_spark.adb +++ b/gcc/ada/exp_spark.adb @@ -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); diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 52f2b02..2ff6e00 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -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 diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 5206899..180ec08 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -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 -- -------------------- diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 36db798..c1d2540 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -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 -- --------------------------------- diff --git a/gcc/ada/sem_aggr.ads b/gcc/ada/sem_aggr.ads index 46d28ae..386a161 100644 --- a/gcc/ada/sem_aggr.ads +++ b/gcc/ada/sem_aggr.ads @@ -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; |