X-Git-Url: https://git.libre-soc.org/?a=blobdiff_plain;f=gcc%2Fada%2Fsem_aggr.adb;h=3f96139e3225d2789101f3b73426301309ab8102;hb=02fb12801b18c9d3cfe1c29b5be9f33d2dc77e21;hp=3ff5cea71665fdb957244455f850c2255181fbae;hpb=c7c7dd3a1ded3f8bcdbfb352277246a521108710;p=gcc.git diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 3ff5cea7166..3f96139e322 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -48,6 +48,7 @@ with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; +with Sem_Ch5; use Sem_Ch5; with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; with Sem_Dim; use Sem_Dim; @@ -451,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 @@ -784,12 +785,39 @@ 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 -- which is the subtype of the context in which the aggregate was found. + Others_Box : Boolean := False; + -- Set to True if N represents a simple aggregate with only + -- (others => <>), not nested as part of another aggregate. + + function Within_Aggregate (N : Node_Id) return Boolean; + -- Return True if N is part of an N_Aggregate + + ---------------------- + -- Within_Aggregate -- + ---------------------- + + function Within_Aggregate (N : Node_Id) return Boolean is + P : Node_Id := Parent (N); + begin + while Present (P) loop + if Nkind (P) = N_Aggregate then + return True; + end if; + + P := Parent (P); + end loop; + + return False; + end Within_Aggregate; + + -- Start of processing for Resolve_Aggregate + begin -- Ignore junk empty aggregate resulting from parser error @@ -810,16 +838,26 @@ package body Sem_Aggr is and then Present (Component_Associations (N)) then declare - Comp : Node_Id; + Comp : Node_Id; + First_Comp : Boolean := True; begin Comp := First (Component_Associations (N)); while Present (Comp) loop if Box_Present (Comp) then + if First_Comp + and then No (Expressions (N)) + and then Nkind (First (Choices (Comp))) = N_Others_Choice + and then not Within_Aggregate (N) + then + Others_Box := True; + end if; + Insert_Actions (N, Freeze_Entity (Typ, N)); exit; end if; + First_Comp := False; Next (Comp); end loop; end; @@ -863,6 +901,12 @@ package body Sem_Aggr is elsif Is_Array_Type (Typ) and then Null_Record_Present (N) then Error_Msg_N ("null record forbidden in array aggregate", N); + 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); + elsif Is_Record_Type (Typ) then Resolve_Record_Aggregate (N, Typ); @@ -1044,6 +1088,13 @@ package body Sem_Aggr is Set_Analyzed (N); end if; + if Warn_On_No_Value_Assigned + and then Others_Box + and then not Is_Fully_Initialized_Type (Etype (N)) + then + Error_Msg_N ("?v?aggregate not fully initialized", N); + end if; + Check_Function_Writable_Actuals (N); end Resolve_Aggregate; @@ -1539,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 @@ -1592,35 +1670,36 @@ package body Sem_Aggr is Set_Etype (Ent, Standard_Void_Type); Set_Parent (Ent, Parent (N)); Push_Scope (Ent); - Id := - Make_Defining_Identifier (Loc, - Chars => Chars (Defining_Identifier (N))); -- Insert and decorate the index variable in the current scope. -- The expression has to be analyzed once the index variable is - -- directly visible. Mark the variable as referenced to prevent - -- spurious warnings, given that subsequent uses of its name in the - -- expression will reference the internal (synonym) loop variable. + -- directly visible. Enter_Name (Id); Set_Etype (Id, Index_Typ); Set_Ekind (Id, E_Variable); Set_Scope (Id, Ent); - Set_Referenced (Id); - -- 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 := New_Copy_Tree (Expression (N)); - Dummy := Resolve_Aggr_Expr (Expr, False); + Expr := Expression (N); + + Expander_Mode_Save_And_Set (False); + Dummy := Resolve_Aggr_Expr (Expr, Single_Elmt => False); + Expander_Mode_Restore; + + 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)); @@ -1793,7 +1872,7 @@ package body Sem_Aggr is if Others_Present and then not Others_Allowed then Error_Msg_N ("OTHERS choice not allowed here", - First (Choices (First (Component_Associations (N))))); + First (Choice_List (First (Component_Associations (N))))); return Failure; end if; @@ -2009,8 +2088,13 @@ package body Sem_Aggr is return Failure; end if; + -- ??? Checks for dynamically tagged expressions below will + -- be only applied to iterated_component_association after + -- expansion; in particular, errors might not be reported when + -- -gnatc switch is used. + elsif Nkind (Assoc) = N_Iterated_Component_Association then - null; -- handled above, in a loop context. + null; -- handled above, in a loop context elsif not Resolve_Aggr_Expr (Expression (Assoc), Single_Elmt => Single_Choice) @@ -2522,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 := @@ -2646,11 +2730,12 @@ package body Sem_Aggr is --------------------------------- procedure Resolve_Container_Aggregate (N : Node_Id; Typ : Entity_Id) is - procedure Resolve_Iterated_Component_Association + procedure Resolve_Iterated_Association (Comp : Node_Id; Key_Type : Entity_Id; Elmt_Type : Entity_Id); - -- Resolve choices and expression in an iterated component association. + -- Resolve choices and expression in an iterated component association + -- or an iterated element association, which has a key_expression. -- This is similar but not identical to the handling of this construct -- in an array aggregate. -- For a named container, the type of each choice must be compatible @@ -2666,25 +2751,54 @@ package body Sem_Aggr is New_Indexed_Subp : Node_Id := Empty; Assign_Indexed_Subp : Node_Id := Empty; - -------------------------------------------- - -- Resolve_Iterated_Component_Association -- - -------------------------------------------- + ---------------------------------- + -- Resolve_Iterated_Association -- + ---------------------------------- - procedure Resolve_Iterated_Component_Association + procedure Resolve_Iterated_Association (Comp : Node_Id; Key_Type : Entity_Id; Elmt_Type : Entity_Id) is - Choice : Node_Id; - Ent : Entity_Id; - Expr : Node_Id; - Id : Entity_Id; - Iter : Node_Id; - Typ : Entity_Id := Empty; + Choice : Node_Id; + Ent : Entity_Id; + Expr : Node_Id; + Key_Expr : Node_Id; + Id : Entity_Id; + Id_Name : Name_Id; + Iter : Node_Id; + Typ : Entity_Id := Empty; begin - if Present (Iterator_Specification (Comp)) then - Iter := Copy_Separate_Tree (Iterator_Specification (Comp)); + -- If this is an Iterated_Element_Association then either a + -- an Iterator_Specification or a Loop_Parameter specification + -- is present. In both cases a Key_Expression is present. + + if Nkind (Comp) = N_Iterated_Element_Association then + if Present (Loop_Parameter_Specification (Comp)) then + Analyze_Loop_Parameter_Specification + (Loop_Parameter_Specification (Comp)); + Id_Name := Chars (Defining_Identifier + (Loop_Parameter_Specification (Comp))); + else + Iter := Copy_Separate_Tree (Iterator_Specification (Comp)); + Analyze (Iter); + Typ := Etype (Defining_Identifier (Iter)); + Id_Name := Chars (Defining_Identifier + (Iterator_Specification (Comp))); + end if; + + -- Key expression must have the type of the key. We analyze + -- a copy of the original expression, because it will be + -- reanalyzed and copied as needed during expansion of the + -- corresponding loop. + + Key_Expr := Key_Expression (Comp); + Analyze_And_Resolve (New_Copy_Tree (Key_Expr), Key_Type); + + elsif Present (Iterator_Specification (Comp)) then + Iter := Copy_Separate_Tree (Iterator_Specification (Comp)); + Id_Name := Chars (Defining_Identifier (Comp)); Analyze (Iter); Typ := Etype (Defining_Identifier (Iter)); @@ -2711,19 +2825,19 @@ package body Sem_Aggr is Next (Choice); end loop; + + Id_Name := Chars (Defining_Identifier (Comp)); end if; -- Create a scope in which to introduce an index, which is usually -- visible in the expression for the component, and needed for its -- analysis. + Id := Make_Defining_Identifier (Sloc (Comp), Id_Name); Ent := New_Internal_Entity (E_Loop, Current_Scope, Sloc (Comp), 'L'); Set_Etype (Ent, Standard_Void_Type); Set_Parent (Ent, Parent (Comp)); Push_Scope (Ent); - Id := - Make_Defining_Identifier (Sloc (Comp), - Chars => Chars (Defining_Identifier (Comp))); -- Insert and decorate the loop variable in the current scope. -- The expression has to be analyzed once the loop variable is @@ -2752,7 +2866,8 @@ package body Sem_Aggr is Expr := New_Copy_Tree (Expression (Comp)); Preanalyze_And_Resolve (Expr, Elmt_Type); End_Scope; - end Resolve_Iterated_Component_Association; + + end Resolve_Iterated_Association; begin pragma Assert (Nkind (Asp) = N_Aggregate); @@ -2797,7 +2912,7 @@ package body Sem_Aggr is & "for unnamed container aggregate", Comp); return; else - Resolve_Iterated_Component_Association + Resolve_Iterated_Association (Comp, Empty, Elmt_Type); end if; @@ -2837,8 +2952,11 @@ package body Sem_Aggr is Analyze_And_Resolve (Expression (Comp), Elmt_Type); - elsif Nkind (Comp) = N_Iterated_Component_Association then - Resolve_Iterated_Component_Association + elsif Nkind (Comp) in + N_Iterated_Component_Association | + N_Iterated_Element_Association + then + Resolve_Iterated_Association (Comp, Key_Type, Elmt_Type); end if; @@ -2847,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 := @@ -2870,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 @@ -2883,8 +3007,11 @@ package body Sem_Aggr is Analyze_And_Resolve (Expression (Comp), Comp_Type); - elsif Nkind (Comp) = N_Iterated_Component_Association then - Resolve_Iterated_Component_Association + elsif Nkind (Comp) in + N_Iterated_Component_Association | + N_Iterated_Element_Association + then + Resolve_Iterated_Association (Comp, Index_Type, Comp_Type); end if; @@ -2933,6 +3060,7 @@ package body Sem_Aggr is Assoc : Node_Id; Choice : Node_Id; + Expr : Node_Id; begin Assoc := First (Deltas); @@ -2960,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; @@ -2993,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 @@ -3365,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); @@ -3967,7 +4112,7 @@ package body Sem_Aggr is -- Copy the expression so that it is resolved -- independently for each component, This is needed - -- for accessibility checks on compoents of anonymous + -- for accessibility checks on components of anonymous -- access types, even in compile_only mode. if not Inside_A_Generic then @@ -5033,16 +5178,28 @@ package body Sem_Aggr is end if; -- Ada 2012: If component is scalar with default value, use it + -- by converting it to Ctyp, so that subtype constraints are + -- checked. elsif Is_Scalar_Type (Ctyp) and then Has_Default_Aspect (Ctyp) then - Add_Association - (Component => Component, - Expr => - Default_Aspect_Value - (First_Subtype (Underlying_Type (Ctyp))), - Assoc_List => New_Assoc_List); + declare + Conv : constant Node_Id := + Convert_To + (Typ => Ctyp, + Expr => + New_Copy_Tree + (Default_Aspect_Value + (First_Subtype (Underlying_Type (Ctyp))))); + + begin + Analyze_And_Resolve (Conv, Ctyp); + Add_Association + (Component => Component, + Expr => Conv, + Assoc_List => New_Assoc_List); + end; elsif Has_Non_Null_Base_Init_Proc (Ctyp) or else not Expander_Active