From: Ed Schonberg Date: Sun, 31 May 2020 20:01:41 +0000 (-0400) Subject: [Ada] Ongoing work for unnamed and named container aggregates X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=4f6ebe2a519e26ff881cf0ff26eac4dae807e613;p=gcc.git [Ada] Ongoing work for unnamed and named container aggregates gcc/ada/ * sem_aggr.adb (Resolve_Iterated_Component_Association): New procedure, internal to Resolve_Container_Aggregate, to complete semantic analysis of Iterated_Component_Associations. * exp_aggr.adb (Expand_Iterated_Component): New procedure, internal to Expand_Container_Aggregate, to expand the construct into an implicit loop that performs individual insertions into the target aggregate. --- diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 47a080814f5..bd3a10b17b0 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -6889,12 +6889,69 @@ package body Exp_Aggr is New_Indexed_Subp : Node_Id := Empty; Assign_Indexed_Subp : Node_Id := Empty; + procedure Expand_Iterated_Component (Comp : Node_Id); + Aggr_Code : constant List_Id := New_List; Temp : constant Entity_Id := Make_Temporary (Loc, 'C', N); + Comp : Node_Id; Decl : Node_Id; Init_Stat : Node_Id; + ------------------------------- + -- Expand_Iterated_Component -- + ------------------------------- + + procedure Expand_Iterated_Component (Comp : Node_Id) is + Expr : constant Node_Id := Expression (Comp); + Loop_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier (Comp))); + + L_Range : Node_Id; + L_Iteration_Scheme : Node_Id; + Loop_Stat : Node_Id; + Stats : List_Id; + + begin + L_Range := Relocate_Node (First (Discrete_Choices (Comp))); + L_Iteration_Scheme := + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Loop_Id, + Discrete_Subtype_Definition => L_Range)); + + -- Build insertion statement. for a positional aggregate only + -- the expression is needed. For a named aggregate the loop + -- variable, whose type is that of the key, is an additional + -- parameter for the insertion operation. + + if Present (Add_Unnamed_Subp) then + Stats := New_List + (Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Entity (Add_Unnamed_Subp), Loc), + Parameter_Associations => + New_List (New_Occurrence_Of (Temp, Loc), + New_Copy_Tree (Expr)))); + else + Stats := New_List + (Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Entity (Add_Named_Subp), Loc), + Parameter_Associations => + New_List (New_Occurrence_Of (Temp, Loc), + New_Occurrence_Of (Loop_Id, Loc), + New_Copy_Tree (Expr)))); + end if; + + Loop_Stat := Make_Implicit_Loop_Statement + (Node => N, + Identifier => Empty, + Iteration_Scheme => L_Iteration_Scheme, + Statements => Stats); + Append (Loop_Stat, Aggr_Code); + end Expand_Iterated_Component; + begin Parse_Aspect_Aggregate (Asp, Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp, @@ -6905,7 +6962,7 @@ package body Exp_Aggr is Object_Definition => New_Occurrence_Of (Typ, Loc)); Insert_Action (N, Decl); - if Ekind (Entity (Empty_Subp)) = E_Constant then + if Ekind (Entity (Empty_Subp)) = E_Function then Init_Stat := Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Temp, Loc), Expression => Make_Function_Call (Loc, @@ -6919,24 +6976,70 @@ package body Exp_Aggr is -- First case: positional aggregate - if Present (Expressions (N)) then + if Present (Add_Unnamed_Subp) then + if Present (Expressions (N)) then + declare + Insert : constant Entity_Id := Entity (Add_Unnamed_Subp); + Comp : Node_Id; + Stat : Node_Id; + + begin + Comp := First (Expressions (N)); + while Present (Comp) loop + Stat := Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Insert, Loc), + Parameter_Associations => + New_List (New_Occurrence_Of (Temp, Loc), + New_Copy_Tree (Comp))); + Append (Stat, Aggr_Code); + Next (Comp); + end loop; + end; + end if; + + -- iterated component associations may be present. + + Comp := First (Component_Associations (N)); + while Present (Comp) loop + Expand_Iterated_Component (Comp); + Next (Comp); + end loop; + + elsif Present (Add_Named_Subp) then declare - Insert : constant Entity_Id := Entity (Add_Unnamed_Subp); - Comp : Node_Id; + Insert : constant Entity_Id := Entity (Add_Named_Subp); Stat : Node_Id; + Key : Node_Id; begin - Comp := First (Expressions (N)); + Comp := First (Component_Associations (N)); + + -- Each component association may contain several choices, + -- generate an insertion statement for each. + while Present (Comp) loop - Stat := Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Insert, Loc), - Parameter_Associations => - New_List (New_Occurrence_Of (Temp, Loc), - New_Copy_Tree (Comp))); - Append (Stat, Aggr_Code); + if Nkind (Comp) = N_Iterated_Component_Association then + Expand_Iterated_Component (Comp); + else + Key := First (Choices (Comp)); + + while Present (Key) loop + Stat := Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Insert, Loc), + Parameter_Associations => + New_List (New_Occurrence_Of (Temp, Loc), + New_Copy_Tree (Key), + New_Copy_Tree (Expression (Comp)))); + Append (Stat, Aggr_Code); + + Next (Key); + end loop; + end if; + Next (Comp); end loop; end; end if; + Insert_Actions (N, Aggr_Code); Rewrite (N, New_Occurrence_Of (Temp, Loc)); Analyze_And_Resolve (N, Typ); diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 2e728464dff..b3c04eb7989 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -2644,6 +2644,18 @@ package body Sem_Aggr is --------------------------------- procedure Resolve_Container_Aggregate (N : Node_Id; Typ : Entity_Id) is + procedure Resolve_Iterated_Component_Association + (Comp : Node_Id; + Key_Type : Entity_Id; + Elmt_Type : Entity_Id); + -- Resolve choices and expression in an iterated component + -- association. 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 + -- with the key type. For a positional container the choice must be + -- a subtype indication or an iterator specification that determines + -- an element type. + Asp : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Aggregate); Empty_Subp : Node_Id := Empty; @@ -2652,41 +2664,176 @@ package body Sem_Aggr is New_Indexed_Subp : Node_Id := Empty; Assign_Indexed_Subp : Node_Id := Empty; + -------------------------------------------- + -- Resolve_Iterated_Component_Association -- + -------------------------------------------- + + procedure Resolve_Iterated_Component_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; + Typ : Entity_Id; + + begin + if Present (Iterator_Specification (Comp)) then + Error_Msg_N ("element iterator ins aggregate Forthcoming", N); + return; + end if; + + Choice := First (Discrete_Choices (Comp)); + + while Present (Choice) loop + Analyze (Choice); + + -- Choice can be a subtype name, a range, or an expression + + if Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + and then Base_Type (Entity (Choice)) = Base_Type (Key_Type) + then + null; + + elsif Present (Key_Type) then + Analyze_And_Resolve (Choice, Key_Type); + + else + Typ := Etype (Choice); -- assume unique for now + end if; + + Next (Choice); + end loop; + + -- Create a scope in which to introduce an index, which is usually + -- visible in the expression for the component, and needed for its + -- analysis. + + 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 + -- 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. + + Enter_Name (Id); + if No (Key_Type) then + Set_Etype (Id, Typ); + else + Set_Etype (Id, Key_Type); + end if; + + 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. + + Expr := New_Copy_Tree (Expression (Comp)); + Preanalyze_And_Resolve (Expr, Elmt_Type); + End_Scope; + end Resolve_Iterated_Component_Association; + begin - if Nkind (Asp) /= N_Aggregate then - pragma Assert (False); - return; - else - Set_Etype (N, Typ); - Parse_Aspect_Aggregate (Asp, - Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp, - New_Indexed_Subp, Assign_Indexed_Subp); + pragma Assert (Nkind (Asp) = N_Aggregate); - if Present (Add_Unnamed_Subp) then - declare - Elmt_Type : constant Entity_Id := - Etype (Next_Formal - (First_Formal (Entity (Add_Unnamed_Subp)))); - Comp : Node_Id; - begin - if Present (Expressions (N)) then - -- positional aggregate + Set_Etype (N, Typ); + Parse_Aspect_Aggregate (Asp, + Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp, + New_Indexed_Subp, Assign_Indexed_Subp); - Comp := First (Expressions (N)); + if Present (Add_Unnamed_Subp) then + declare + Elmt_Type : constant Entity_Id := + Etype (Next_Formal + (First_Formal (Entity (Add_Unnamed_Subp)))); + Comp : Node_Id; + + begin + if Present (Expressions (N)) then + -- positional aggregate + + Comp := First (Expressions (N)); + while Present (Comp) loop + Analyze_And_Resolve (Comp, Elmt_Type); + Next (Comp); + end loop; + end if; + + -- Empty aggregate, to be replaced by Empty during + -- expansion, or iterated component association. + + if Present (Component_Associations (N)) then + declare + Comp : Node_Id := First (Component_Associations (N)); + begin while Present (Comp) loop - Analyze_And_Resolve (Comp, Elmt_Type); + if Nkind (Comp) /= + N_Iterated_Component_Association + then + Error_Msg_N ("illegal component association " + & "for unnamed container aggregate", Comp); + return; + else + Resolve_Iterated_Component_Association + (Comp, Empty, Elmt_Type); + end if; + Next (Comp); end loop; - else + end; + end if; + end; - -- Empty aggregate, to be replaced by Empty during - -- expansion. - null; + elsif Present (Add_Named_Subp) then + declare + -- Retrieves types of container, key, and element from the + -- specified insertion procedure. + + Container : constant Entity_Id := + First_Formal (Entity (Add_Named_Subp)); + Key_Type : constant Entity_Id := Etype (Next_Formal (Container)); + Elmt_Type : constant Entity_Id := + Etype (Next_Formal (Next_Formal (Container))); + Comp : Node_Id; + Choice : Node_Id; + + begin + Comp := First (Component_Associations (N)); + while Present (Comp) loop + if Nkind (Comp) = N_Component_Association then + Choice := First (Choices (Comp)); + + while Present (Choice) loop + Analyze_And_Resolve (Choice, Key_Type); + Next (Choice); + end loop; + + Analyze_And_Resolve (Expression (Comp), Elmt_Type); + + elsif Nkind (Comp) = N_Iterated_Component_Association then + Resolve_Iterated_Component_Association + (Comp, Key_Type, Elmt_Type); end if; - end; - else - Error_Msg_N ("indexed aggregates are forthcoming", N); - end if; + + Next (Comp); + end loop; + end; + else + Error_Msg_N ("indexed aggregates are forthcoming", N); end if; end Resolve_Container_Aggregate;