X-Git-Url: https://git.libre-soc.org/?a=blobdiff_plain;f=gcc%2Fada%2Fsem_aggr.adb;h=3f96139e3225d2789101f3b73426301309ab8102;hb=02fb12801b18c9d3cfe1c29b5be9f33d2dc77e21;hp=9285c1cae3cdaf057c0d215d46c7d22f607cab09;hpb=ed9a428d02a5e3cd191aec9421808c5ce8ab7db3;p=gcc.git diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 9285c1cae3c..3f96139e322 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -452,7 +452,7 @@ package body Sem_Aggr is This_Range : constant Node_Id := Aggregate_Bounds (N); -- The aggregate range node of this specific sub-aggregate - This_Low : constant Node_Id := Low_Bound (Aggregate_Bounds (N)); + This_Low : constant Node_Id := Low_Bound (Aggregate_Bounds (N)); This_High : constant Node_Id := High_Bound (Aggregate_Bounds (N)); -- The aggregate bounds of this specific sub-aggregate @@ -785,7 +785,7 @@ package body Sem_Aggr is ----------------------- procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); + Loc : constant Source_Ptr := Sloc (N); Aggr_Subtyp : Entity_Id; -- The actual aggregate subtype. This is not necessarily the same as Typ @@ -816,6 +816,8 @@ package body Sem_Aggr is return False; end Within_Aggregate; + -- Start of processing for Resolve_Aggregate + begin -- Ignore junk empty aggregate resulting from parser error @@ -901,6 +903,7 @@ package body Sem_Aggr is elsif Present (Find_Aspect (Typ, Aspect_Aggregate)) and then Ekind (Typ) /= E_Record_Type + and then Ada_Version >= Ada_2020 then Resolve_Container_Aggregate (N, Typ); @@ -1587,12 +1590,39 @@ package body Sem_Aggr is Index_Typ : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); + Id : constant Entity_Id := Defining_Identifier (N); + + ----------------------- + -- Remove_References -- + ----------------------- + + function Remove_Ref (N : Node_Id) return Traverse_Result; + -- Remove references to the entity Id after analysis, so it can be + -- properly reanalyzed after construct is expanded into a loop. + + function Remove_Ref (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Identifier + and then Present (Entity (N)) + and then Entity (N) = Id + then + Set_Entity (N, Empty); + Set_Etype (N, Empty); + end if; + Set_Analyzed (N, False); + return OK; + end Remove_Ref; + + procedure Remove_References is new Traverse_Proc (Remove_Ref); + + -- Local variables Choice : Node_Id; Dummy : Boolean; Ent : Entity_Id; Expr : Node_Id; - Id : Entity_Id; + + -- Start of processing for Resolve_Iterated_Component_Association begin -- An element iterator specification cannot appear in @@ -1645,26 +1675,31 @@ package body Sem_Aggr is -- The expression has to be analyzed once the index variable is -- directly visible. - Id := Defining_Identifier (N); Enter_Name (Id); Set_Etype (Id, Index_Typ); Set_Ekind (Id, E_Variable); Set_Scope (Id, Ent); - -- Analyze a copy of the expression, to verify legality. We use - -- a copy because the expression will be analyzed anew when the - -- enclosing aggregate is expanded, and the construct is rewritten - -- as a loop with a new index variable. + -- Analyze expression without expansion, to verify legality. + -- When generating code, we then remove references to the index + -- variable, because the expression will be analyzed anew after + -- rewritting as a loop with a new index variable; when not + -- generating code we leave the analyzed expression as it is. + + Expr := Expression (N); + + Expander_Mode_Save_And_Set (False); + Dummy := Resolve_Aggr_Expr (Expr, Single_Elmt => False); + Expander_Mode_Restore; - Expr := New_Copy_Tree (Expression (N)); - Set_Parent (Expr, N); - Dummy := Resolve_Aggr_Expr (Expr, False); + if Operating_Mode /= Check_Semantics then + Remove_References (Expr); + end if; -- An iterated_component_association may appear in a nested -- aggregate for a multidimensional structure: preserve the bounds -- computed for the expression, as well as the anonymous array -- type generated for it; both are needed during array expansion. - -- This does not work for more than two levels of nesting. ??? if Nkind (Expr) = N_Aggregate then Set_Aggregate_Bounds (Expression (N), Aggregate_Bounds (Expr)); @@ -2571,7 +2606,7 @@ package body Sem_Aggr is -- In order to diagnose the semantic error we create a duplicate -- tree to analyze it and perform the check. - else + elsif Nkind (Assoc) /= N_Iterated_Component_Association then declare Save_Analysis : constant Boolean := Full_Analysis; Expr : constant Node_Id := @@ -2930,9 +2965,9 @@ package body Sem_Aggr is end; else - -- Indexed Aggregate. Both positional and indexed component - -- can be present. Choices must be static values or ranges - -- with static bounds. + -- Indexed Aggregate. Positional or indexed component + -- can be present, but not both. Choices must be static + -- values or ranges with static bounds. declare Container : constant Entity_Id := @@ -2953,6 +2988,12 @@ package body Sem_Aggr is end if; if Present (Component_Associations (N)) then + if Present (Expressions (N)) then + Error_Msg_N ("Container aggregate cannot be " + & "both positional and named", N); + return; + end if; + Comp := First (Expressions (N)); while Present (Comp) loop @@ -3019,6 +3060,7 @@ package body Sem_Aggr is Assoc : Node_Id; Choice : Node_Id; + Expr : Node_Id; begin Assoc := First (Deltas); @@ -3046,17 +3088,21 @@ package body Sem_Aggr is begin Set_Etype (Ent, Standard_Void_Type); Set_Parent (Ent, Assoc); + Push_Scope (Ent); if No (Scope (Id)) then - Enter_Name (Id); Set_Etype (Id, Index_Type); Set_Ekind (Id, E_Variable); Set_Scope (Id, Ent); end if; + Enter_Name (Id); - Push_Scope (Ent); - Analyze_And_Resolve - (New_Copy_Tree (Expression (Assoc)), Component_Type (Typ)); + -- Resolve a copy of the expression, after setting + -- its parent properly to preserve its context. + + Expr := New_Copy_Tree (Expression (Assoc)); + Set_Parent (Expr, Assoc); + Analyze_And_Resolve (Expr, Component_Type (Typ)); End_Scope; end; @@ -3079,7 +3125,7 @@ package body Sem_Aggr is Base_Type (Index_Type) then Error_Msg_NE - ("choice does mat match index type of", + ("choice does not match index type of &", Choice, Typ); end if; else @@ -3451,10 +3497,23 @@ package body Sem_Aggr is if Is_Entity_Name (A) and then Is_Type (Entity (A)) then - -- AI05-0115: if the ancestor part is a subtype mark, the ancestor - -- must not have unknown discriminants. - - if Has_Unknown_Discriminants (Entity (A)) then + -- AI05-0115: If the ancestor part is a subtype mark, the ancestor + -- must not have unknown discriminants. To catch cases where the + -- aggregate occurs at a place where the full view of the ancestor + -- type is visible and doesn't have unknown discriminants, but the + -- aggregate type was derived from a partial view that has unknown + -- discriminants, we check whether the aggregate type has unknown + -- discriminants (unknown discriminants were inherited), along + -- with checking that the partial view of the ancestor has unknown + -- discriminants. (It might be sufficient to replace the entire + -- condition with Has_Unknown_Discriminants (Typ), but that might + -- miss some cases, not clear, and causes error changes in some tests + -- such as class-wide cases, that aren't clearly improvements. ???) + + if Has_Unknown_Discriminants (Entity (A)) + or else (Has_Unknown_Discriminants (Typ) + and then Partial_View_Has_Unknown_Discr (Entity (A))) + then Error_Msg_NE ("aggregate not available for type& whose ancestor " & "has unknown discriminants", N, Typ);