From patchwork Wed Jul 15 13:45:18 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 1329526 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=sourceware.org; envelope-from=gcc-patches-bounces@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Received: from sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 4B6JYf2rBpz9sTQ for ; Wed, 15 Jul 2020 23:45:42 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id E5CBC3840C2C; Wed, 15 Jul 2020 13:45:22 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from rock.gnat.com (rock.gnat.com [205.232.38.15]) by sourceware.org (Postfix) with ESMTP id C7139387090F for ; Wed, 15 Jul 2020 13:45:18 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org C7139387090F Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=derodat@adacore.com Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 91F4E56002; Wed, 15 Jul 2020 09:45:18 -0400 (EDT) X-Virus-Scanned: Debian amavisd-new at gnat.com Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id 4yEI1AgLIAFQ; Wed, 15 Jul 2020 09:45:18 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [IPv6:2620:20:4000:0:46a8:42ff:fe0e:e294]) by rock.gnat.com (Postfix) with ESMTP id 7EEE8117F79; Wed, 15 Jul 2020 09:45:18 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id 79164A2; Wed, 15 Jul 2020 09:45:18 -0400 (EDT) Date: Wed, 15 Jul 2020 09:45:18 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Subject: [Ada] Ongoing work for unnamed and named container aggregates Message-ID: <20200715134518.GA23561@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-Spam-Status: No, score=-8.4 required=5.0 tests=BAYES_00, GIT_PATCH_0, KAM_ASCII_DIVIDERS, KAM_DMARC_STATUS, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Cc: Ed Schonberg Errors-To: gcc-patches-bounces@gcc.gnu.org Sender: "Gcc-patches" This implements additional functionality for the Ada 202x container aggregates, in particular the use of iterated_component_association in both Unnamed (positional) and Named (keyed) aggregates for types for which the Aspect Aggregate is defined. Tested on x86_64-pc-linux-gnu, committed on trunk 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 --- 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 --- 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;