From: Ed Schonberg Date: Tue, 26 May 2020 19:39:38 +0000 (-0400) Subject: [Ada] Part of implementation of AI12-0212: container aggregates X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=745f56989ead5d32b4016e39bf2656f23e2b16e7;p=gcc.git [Ada] Part of implementation of AI12-0212: container aggregates gcc/ada/ * aspects.ads: Add Aspect_Aggregate. * exp_aggr.adb (Expand_Container_Aggregate): Expand positional container aggregates into separate initialization and insertion operations. * sem_aggr.ads (Resolve_Container_Aggregate): New subprogram. * sem_aggr.adb (Resolve_Container_Aggregate): Parse aspect aggregate, establish element types and key types if present, and resolve aggregate components. * sem_ch13.ads (Parse_Aspect_Aggregate): Public subprogram used in validation, resolution and expansion of container aggregates * sem_ch13.adb (Parse_Aspect_Aggregate): Retrieve names of primitives specified in aspect specification. (Validate_Aspect_Aggregate): Check legality of specified operations given in aspect specification, before nane resolution. (Resolve_Aspect_Aggregate): At freeze point resolve operations and verify that given operations have the required profile. * sem_res.adb (Resolve): Call Resolve_Aspect_Aggregate if aspect is present for type. * snames.ads-tmpl: Add names used in aspect Aggregate: Empty, Add_Named, Add_Unnamed, New_Indexed, Assign_Indexed. --- diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index a418957c57c..4e517d1fb5b 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -76,6 +76,7 @@ package Aspects is (No_Aspect, -- Dummy entry for no aspect Aspect_Abstract_State, -- GNAT Aspect_Address, + Aspect_Aggregate, Aspect_Alignment, Aspect_Annotate, -- GNAT Aspect_Async_Readers, -- GNAT @@ -300,6 +301,7 @@ package Aspects is Aspect_Iterator_Element => True, Aspect_Iterable => True, Aspect_Variable_Indexing => True, + Aspect_Aggregate => True, others => False); -- The following array indicates aspects for which multiple occurrences of @@ -345,6 +347,7 @@ package Aspects is (No_Aspect => Optional_Expression, Aspect_Abstract_State => Expression, Aspect_Address => Expression, + Aspect_Aggregate => Expression, Aspect_Alignment => Expression, Aspect_Annotate => Expression, Aspect_Async_Readers => Optional_Expression, @@ -442,6 +445,7 @@ package Aspects is (No_Aspect => False, Aspect_Abstract_State => False, Aspect_Address => True, + Aspect_Aggregate => False, Aspect_Alignment => True, Aspect_Annotate => False, Aspect_Async_Readers => False, @@ -580,6 +584,7 @@ package Aspects is (No_Aspect => No_Name, Aspect_Abstract_State => Name_Abstract_State, Aspect_Address => Name_Address, + Aspect_Aggregate => Name_Aggregate, Aspect_Alignment => Name_Alignment, Aspect_All_Calls_Remote => Name_All_Calls_Remote, Aspect_Annotate => Name_Annotate, @@ -828,6 +833,7 @@ package Aspects is Aspect_Delay : constant array (Aspect_Id) of Delay_Type := (No_Aspect => Always_Delay, Aspect_Address => Always_Delay, + Aspect_Aggregate => Always_Delay, Aspect_All_Calls_Remote => Always_Delay, Aspect_Asynchronous => Always_Delay, Aspect_Attach_Handler => Always_Delay, diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 884c0ee434b..eb5cc29e44f 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; @@ -52,6 +53,7 @@ with Sem; use Sem; with Sem_Aggr; use Sem_Aggr; with Sem_Aux; use Sem_Aux; with Sem_Ch3; use Sem_Ch3; +with Sem_Ch13; use Sem_Ch13; with Sem_Eval; use Sem_Eval; with Sem_Mech; use Sem_Mech; with Sem_Res; use Sem_Res; @@ -86,6 +88,7 @@ package body Exp_Aggr is procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id); procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id); + procedure Expand_Container_Aggregate (N : Node_Id); function Get_Base_Object (N : Node_Id) return Entity_Id; -- Return the base object, i.e. the outermost prefix object, that N refers @@ -6740,6 +6743,9 @@ package body Exp_Aggr is if Is_Record_Type (Etype (N)) then Expand_Record_Aggregate (N); + elsif Has_Aspect (Etype (N), Aspect_Aggregate) then + Expand_Container_Aggregate (N); + -- Array aggregate case else @@ -6839,6 +6845,73 @@ package body Exp_Aggr is return; end Expand_N_Aggregate; + -------------------------------- + -- Expand_Container_Aggregate -- + -------------------------------- + + procedure Expand_Container_Aggregate (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Asp : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Aggregate); + + Empty_Subp : Node_Id := Empty; + Add_Named_Subp : Node_Id := Empty; + Add_Unnamed_Subp : Node_Id := Empty; + New_Indexed_Subp : Node_Id := Empty; + Assign_Indexed_Subp : Node_Id := Empty; + + Aggr_Code : constant List_Id := New_List; + Temp : constant Entity_Id := Make_Temporary (Loc, 'C', N); + + Decl : Node_Id; + Init_Stat : Node_Id; + begin + Parse_Aspect_Aggregate (Asp, + Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp, + New_Indexed_Subp, Assign_Indexed_Subp); + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Occurrence_Of (Typ, Loc)); + + Insert_Action (N, Decl); + if Ekind (Entity (Empty_Subp)) = E_Constant then + Init_Stat := Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Temp, Loc), + Expression => Make_Function_Call (Loc, + Name => New_Occurrence_Of (Entity (Empty_Subp), Loc))); + else + Init_Stat := Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Temp, Loc), + Expression => New_Occurrence_Of (Entity (Empty_Subp), Loc)); + end if; + Append (Init_Stat, Aggr_Code); + + -- First case : positional aggregate. + + 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; + Insert_Actions (N, Aggr_Code); + Rewrite (N, New_Occurrence_Of (Temp, Loc)); + Analyze_And_Resolve (N, Typ); + end Expand_Container_Aggregate; + ------------------------------ -- Expand_N_Delta_Aggregate -- ------------------------------ diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 63cb7143c38..ffe2ae66a77 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -2639,6 +2639,57 @@ package body Sem_Aggr is return Success; end Resolve_Array_Aggregate; + --------------------------------- + -- Resolve_Container_Aggregate -- + --------------------------------- + + procedure Resolve_Container_Aggregate (N : Node_Id; Typ : Entity_Id) is + Asp : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Aggregate); + + Empty_Subp : Node_Id := Empty; + Add_Named_Subp : Node_Id := Empty; + Add_Unnamed_Subp : Node_Id := Empty; + New_Indexed_Subp : Node_Id := Empty; + Assign_Indexed_Subp : Node_Id := Empty; + + 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); + + 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; + else + + -- Empty aggregate, to be replaced by Empty during + -- expansion. + null; + end if; + end; + else + Error_Msg_N ("indexed aggregates are forthcoming", N); + end if; + end if; + end Resolve_Container_Aggregate; + ----------------------------- -- Resolve_Delta_Aggregate -- ----------------------------- diff --git a/gcc/ada/sem_aggr.ads b/gcc/ada/sem_aggr.ads index cc169d89ca5..b0b4e147fe5 100644 --- a/gcc/ada/sem_aggr.ads +++ b/gcc/ada/sem_aggr.ads @@ -33,6 +33,7 @@ package Sem_Aggr is procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id); procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id); procedure Resolve_Extension_Aggregate (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Container_Aggregate (N : Node_Id; Typ : Entity_Id); function Is_Others_Aggregate (Aggr : Node_Id) return Boolean; -- Returns True is aggregate Aggr consists of a single OTHERS choice diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 3fb9f61da9d..c6a177d21b3 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -242,6 +242,16 @@ package body Sem_Ch13 is -- Register a check for the address clause N. The rest of the parameters -- are in keeping with the components of Address_Clause_Check_Record below. + procedure Validate_Aspect_Aggregate (N : Node_Id); + -- Check legality of operations given in the Ada_2020 Aggregate aspect + -- for containers. + + procedure Resolve_Aspect_Aggregate + (Typ : Entity_Id; + Expr : Node_Id); + -- Resolve each one of the operations specified in the specification of + -- Aspect_Aggregate. + procedure Resolve_Iterable_Operation (N : Node_Id; Cursor : Entity_Id; @@ -1471,6 +1481,9 @@ package body Sem_Ch13 is when Aspect_Iterable => Validate_Iterable_Aspect (E, ASN); + when Aspect_Aggregate => + null; + when others => null; end case; @@ -4043,6 +4056,11 @@ package body Sem_Ch13 is Aitem := Empty; + when Aspect_Aggregate => + Validate_Aspect_Aggregate (Expr); + Record_Rep_Item (E, Aspect); + return; + when Aspect_Integer_Literal | Aspect_Real_Literal | Aspect_String_Literal @@ -5193,8 +5211,9 @@ package body Sem_Ch13 is Indexing_Found : Boolean := False; procedure Check_Inherited_Indexing; - -- For a derived type, check that no indexing aspect is specified - -- for the type if it is also inherited + -- For a derived type, check tha for a derived type a specification + -- of an indexing aspect can only be confirming, i.e. uses the + -- the same name as in the parent type. -- AI12-0160: verify that an indexing cannot be specified for -- a derived type unless it is specified for the parent. @@ -6613,6 +6632,7 @@ package body Sem_Ch13 is or else not Is_Type (Entity (Expr)) then Error_Msg_N ("aspect Iterator_Element must be a type", Expr); + return; end if; ------------------- @@ -10542,6 +10562,10 @@ package body Sem_Ch13 is return; + when Aspect_Aggregate => + Resolve_Aspect_Aggregate (Entity (ASN), Expr); + return; + -- Invariant/Predicate take boolean expressions when Aspect_Dynamic_Predicate @@ -14329,6 +14353,9 @@ package body Sem_Ch13 is begin case A_Id is + when Aspect_Aggregate => + Resolve_Aspect_Aggregate (Entity (ASN), Expr); + -- For now we only deal with aspects that do not generate -- subprograms, or that may mention current instances of -- types. These will require special handling (???TBD). @@ -14642,6 +14669,92 @@ package body Sem_Ch13 is end if; end Same_Representation; + ---------------------------- + -- Parse_Aspect_Aggregate -- + ---------------------------- + + procedure Parse_Aspect_Aggregate + (N : Node_Id; + Empty_Subp : in out Node_Id; + Add_Named_Subp : in out Node_Id; + Add_Unnamed_Subp : in out Node_Id; + New_Indexed_Subp : in out Node_Id; + Assign_Indexed_Subp : in out Node_Id) + is + Assoc : Node_Id := First (Component_Associations (N)); + Op_Name : Name_Id; + Subp : Node_Id; + + begin + while Present (Assoc) loop + Subp := Expression (Assoc); + Op_Name := Chars (First (Choices (Assoc))); + if Op_Name = Name_Empty then + Empty_Subp := Subp; + + elsif Op_Name = Name_Add_Named then + Add_Named_Subp := Subp; + + elsif Op_Name = Name_Add_Unnamed then + Add_Unnamed_Subp := Subp; + + elsif Op_Name = Name_New_Indexed then + New_Indexed_Subp := Subp; + + elsif Op_Name = Name_Assign_Indexed then + Assign_Indexed_Subp := Subp; + end if; + + Next (Assoc); + end loop; + end Parse_Aspect_Aggregate; + + ------------------------------- + -- Validate_Aspect_Aggregate -- + ------------------------------- + + procedure Validate_Aspect_Aggregate (N : Node_Id) is + Empty_Subp : Node_Id := Empty; + Add_Named_Subp : Node_Id := Empty; + Add_Unnamed_Subp : Node_Id := Empty; + New_Indexed_Subp : Node_Id := Empty; + Assign_Indexed_Subp : Node_Id := Empty; + + begin + if Ada_Version < Ada_2020 then + Error_Msg_N ("Aspect Aggregate is an Ada_2020 feature", N); + + elsif Nkind (N) /= N_Aggregate + or else Present (Expressions (N)) + or else No (Component_Associations (N)) + then + Error_Msg_N ("Aspect Aggregate requires an aggregate " + & "with component associations", N); + return; + end if; + + Parse_Aspect_Aggregate (N, + Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp, + New_Indexed_Subp, Assign_Indexed_Subp); + + if No (Empty_Subp) then + Error_Msg_N ("missing specification for Empty in aggregate", N); + end if; + + if Present (Add_Named_Subp) then + if Present (Add_Unnamed_Subp) + or else Present (Assign_Indexed_Subp) + then + Error_Msg_N + ("conflicting operations for aggregate (RM 4.3.5)", N); + return; + end if; + + elsif Present (New_Indexed_Subp) /= Present (Assign_Indexed_Subp) then + Error_Msg_N ("incomplete specification for indexed aggregate", N); + end if; + end Validate_Aspect_Aggregate; + -------------------------------- -- Resolve_Iterable_Operation -- -------------------------------- @@ -14803,6 +14916,189 @@ package body Sem_Ch13 is end if; end Resolve_Iterable_Operation; + ------------------------------ + -- Resolve_Aspect_Aggregate -- + ------------------------------ + + procedure Resolve_Aspect_Aggregate + (Typ : Entity_Id; + Expr : Node_Id) + is + -- Predicates that establish the legality of each possible + -- operation in an Aggregate aspect. + + function Valid_Empty (E : Entity_Id) return Boolean; + function Valid_Add_Named (E : Entity_Id) return Boolean; + function Valid_Add_Unnamed (E : Entity_Id) return Boolean; + function Valid_New_Indexed (E : Entity_Id) return Boolean; + + -- Note : the leglity rules for Assign_Indexed are the same + -- as for Add_Named. + + generic + with function Pred (Id : Node_Id) return Boolean; + procedure Resolve_Operation (Subp_Id : Node_Id); + -- Common processing to resolve each aggregate operation. + + ----------------- + -- Valid_Emoty -- + ----------------- + + function Valid_Empty (E : Entity_Id) return Boolean is + begin + if Etype (E) /= Typ or else Scope (E) /= Scope (Typ) then + return False; + + elsif Ekind (E) = E_Constant then + return True; + + elsif Ekind (E) = E_Function then + return No (First_Formal (E)) + or else + (Is_Integer_Type (Etype (First_Formal (E))) + and then No (Next_Formal (First_Formal (E)))); + else + return False; + end if; + end Valid_Empty; + + --------------------- + -- Valid_Add_Named -- + --------------------- + + function Valid_Add_Named (E : Entity_Id) return Boolean is + F2, F3 : Entity_Id; + begin + if Ekind (E) = E_Procedure + and then Scope (E) = Scope (Typ) + and then Number_Formals (E) = 3 + and then Etype (First_Formal (E)) = Typ + and then Ekind (First_Formal (E)) = E_In_Out_Parameter + then + F2 := Next_Formal (First_Formal (E)); + F3 := Next_Formal (F2); + return Ekind (F2) = E_In_Parameter + and then Ekind (F3) = E_In_Parameter + and then not Is_Limited_Type (Etype (F2)) + and then not Is_Limited_Type (Etype (F3)); + else + return False; + end if; + end Valid_Add_Named; + + ----------------------- + -- Valid_Add_Unnamed -- + ----------------------- + + function Valid_Add_Unnamed (E : Entity_Id) return Boolean is + begin + return Ekind (E) = E_Procedure + and then Scope (E) = Scope (Typ) + and then Number_Formals (E) = 2 + and then Etype (First_Formal (E)) = Typ + and then Ekind (First_Formal (E)) = E_In_Out_Parameter + and then + not Is_Limited_Type (Etype (Next_Formal (First_Formal (E)))); + end Valid_Add_Unnamed; + + ----------------------- + -- Valid_Nmw_Indexed -- + ----------------------- + + function Valid_New_Indexed (E : Entity_Id) return Boolean is + begin + return Ekind (E) = E_Function + and then Scope (E) = Scope (Typ) + and then Etype (E) = Typ + and then Number_Formals (E) = 2 + and then Is_Discrete_Type (Etype (First_Formal (E))) + and then Etype (First_Formal (E)) = + Etype (Next_Formal (First_Formal (E))); + end Valid_New_Indexed; + + ----------------------- + -- Resolve_Operation -- + ----------------------- + + procedure Resolve_Operation (Subp_Id : Node_Id) is + Subp : Entity_Id; + + I : Interp_Index; + It : Interp; + + begin + if not Is_Overloaded (Subp_Id) then + Subp := Entity (Subp_Id); + if not Pred (Subp) then + Error_Msg_NE + ("improper aggregate operation for&", Subp_Id, Typ); + end if; + + else + Set_Entity (Subp_Id, Empty); + Get_First_Interp (Subp_Id, I, It); + while Present (It.Nam) loop + if Pred (It.Nam) then + Set_Is_Overloaded (Subp_Id, False); + Set_Entity (Subp_Id, It.Nam); + exit; + end if; + + Get_Next_Interp (I, It); + end loop; + + if No (Entity (Subp_Id)) then + Error_Msg_NE + ("improper aggregate operation for&", Subp_Id, Typ); + end if; + end if; + end Resolve_Operation; + + Assoc : Node_Id; + Op_Name : Name_Id; + Subp_Id : Node_Id; + + procedure Resolve_Empty is new Resolve_Operation (Valid_Empty); + procedure Resolve_Unnamed is new Resolve_Operation (Valid_Add_Unnamed); + procedure Resolve_Named is new Resolve_Operation (Valid_Add_Named); + procedure Resolve_Indexed is new Resolve_Operation (Valid_New_Indexed); + procedure Resolve_Assign_Indexed + is new Resolve_Operation (Valid_Add_Named); + begin + Assoc := First (Component_Associations (Expr)); + + while Present (Assoc) loop + Op_Name := Chars (First (Choices (Assoc))); + + -- When verifying the consistency of aspects between + -- the freeze point and the end of declarqtions, we + -- use a copy which is not analyzed yet, so do it now. + + Subp_Id := Expression (Assoc); + if No (Etype (Subp_Id)) then + Analyze (Subp_Id); + end if; + + if Op_Name = Name_Empty then + Resolve_Empty (Subp_Id); + + elsif Op_Name = Name_Add_Named then + Resolve_Named (Subp_Id); + + elsif Op_Name = Name_Add_Unnamed then + Resolve_Unnamed (Subp_Id); + + elsif Op_Name = Name_New_Indexed then + Resolve_Indexed (Subp_Id); + + elsif Op_Name = Name_Assign_Indexed then + Resolve_Assign_Indexed (Subp_Id); + end if; + + Next (Assoc); + end loop; + end Resolve_Aspect_Aggregate; + ---------------- -- Set_Biased -- ---------------- diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index 85063a621b8..a08a1f4b6bf 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -128,6 +128,17 @@ package Sem_Ch13 is -- If the size is too small, and an error message is given, then both -- Esize and RM_Size are reset to the allowed minimum value in T. + procedure Parse_Aspect_Aggregate + (N : Node_Id; + Empty_Subp : in out Node_Id; + Add_Named_Subp : in out Node_Id; + Add_Unnamed_Subp : in out Node_Id; + New_Indexed_Subp : in out Node_Id; + Assign_Indexed_Subp : in out Node_Id); + -- Utility to unpack the subprogramz in an occurrence of asoect Aggregate, + -- used to verify the structure of the asoect, and resolve and expand an + -- aggregate for a container type that carries the asoect. + function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean; -- Called at start of processing a representation clause/pragma. Used to -- check that the representation item is not being applied to an incomplete diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 0e6acf7d3a1..f76366d944b 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -2776,6 +2776,17 @@ package body Sem_Res is elsif Nkind (N) = N_Aggregate and then Etype (N) = Any_Composite then + if Ada_Version >= Ada_2020 + and then Has_Aspect (Typ, Aspect_Aggregate) + then + Resolve_Container_Aggregate (N, Typ); + + if Expander_Active then + Expand (N); + end if; + return; + end if; + -- Disable expansion in any case. If there is a type mismatch -- it may be fatal to try to expand the aggregate. The flag -- would otherwise be set to false when the error is posted. diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 0e807b057c9..c26ac32f7a2 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -1550,6 +1550,15 @@ package Snames is Name_Reference_Control_Type : constant Name_Id := N + $; Name_Get_Element_Access : constant Name_Id := N + $; + -- Names for Ada2020 Aggregate aspect. Nmme_Aggregate is already + -- present for gprbuild. + + Name_Empty : constant Name_Id := N + $; + Name_Add_Named : constant Name_Id := N + $; + Name_Add_Unnamed : constant Name_Id := N + $; + Name_New_Indexed : constant Name_Id := N + $; + Name_Assign_Indexed : constant Name_Id := N + $; + -- Ada 2005 reserved words First_2005_Reserved_Word : constant Name_Id := N + $;