From: Arnaud Charlet Date: Mon, 23 Jan 2017 12:07:34 +0000 (+0100) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=9eb8d5b4e9cfb5771f333abe0bfdd9667e56537b;p=gcc.git [multiple changes] 2017-01-23 Ed Schonberg * par-ch4.adb (P_Aggregate_Or_Parent_Expr): Recognize delta aggregate construct. (P_Record_Or_Array_Component_Association): An array aggregate can start with an Iterated_Component_Association. * scng.adb: Modify error message on improper use of @ in earlier versions of the language. * sinfo.ads: New node kind N_Delta_Aggregate. * sinfo.adb: An N_Delta_Aggregate has component associations and an expression. * sem_res.adb (Resolve): Call Resolve_Delta_Aggregate. * sem_aggr.ads, sem_aggr.adb (Resolve_Iterated_Component_Association): Create a new index for each one of the choices in the association, to prevent spurious homonyms in the scope. (Resolve_Delta_Aggregate): New. * sem.adb: An N_Delta_Aggregate is analyzed like an aggregate. * exp_util.adb (Insert_Actions): Take into account N_Delta_Aggregate. * exp_aggr.ads: New procedure Expand_N_Delta_Aggregate. * exp_aggr.adb: New procedure Expand_N_Delta_Aggregate, and local procedures Expand_Delta_Array_Aggregate and expand_Delta_Record_Aggregate. * sprint.adb: Handle N_Delta_Aggregate. 2017-01-23 Hristian Kirtchev * exp_ch11.adb (Expand_N_Exception_Declaration): Generate an empty name when the exception declaration is subject to pragma Discard_Names. (Null_String): New routine. 2017-01-23 Hristian Kirtchev * par-ch9.adb (P_Protected_Definition): Parse any optional and potentially illegal pragmas which appear in a protected operation declaration list. (P_Task_Items): Parse any optional and potentially illegal pragmas which appear in a task item list. From-SVN: r244794 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 10a61b88759..8a8c290cad9 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,44 @@ +2017-01-23 Ed Schonberg + + * par-ch4.adb (P_Aggregate_Or_Parent_Expr): Recognize delta + aggregate construct. + (P_Record_Or_Array_Component_Association): An array aggregate + can start with an Iterated_Component_Association. + * scng.adb: Modify error message on improper use of @ in earlier + versions of the language. + * sinfo.ads: New node kind N_Delta_Aggregate. + * sinfo.adb: An N_Delta_Aggregate has component associations and + an expression. + * sem_res.adb (Resolve): Call Resolve_Delta_Aggregate. + * sem_aggr.ads, sem_aggr.adb (Resolve_Iterated_Component_Association): + Create a new index for each one of the choices in the association, + to prevent spurious homonyms in the scope. + (Resolve_Delta_Aggregate): New. + * sem.adb: An N_Delta_Aggregate is analyzed like an aggregate. + * exp_util.adb (Insert_Actions): Take into account + N_Delta_Aggregate. + * exp_aggr.ads: New procedure Expand_N_Delta_Aggregate. + * exp_aggr.adb: New procedure Expand_N_Delta_Aggregate, + and local procedures Expand_Delta_Array_Aggregate and + expand_Delta_Record_Aggregate. + * sprint.adb: Handle N_Delta_Aggregate. + +2017-01-23 Hristian Kirtchev + + * exp_ch11.adb (Expand_N_Exception_Declaration): Generate an + empty name when the exception declaration is subject to pragma + Discard_Names. + (Null_String): New routine. + +2017-01-23 Hristian Kirtchev + + * par-ch9.adb (P_Protected_Definition): Parse + any optional and potentially illegal pragmas which appear in + a protected operation declaration list. + (P_Task_Items): Parse + any optional and potentially illegal pragmas which appear in a + task item list. + 2017-01-23 Pascal Obry * s-taprop-mingw.adb (Enter_Task): Initialize the Thread handle which diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 9da35ddb9c2..a41bfa08aed 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -84,6 +84,9 @@ package body Exp_Aggr is -- expression with actions, which becomes the Initialization_Statements for -- Obj. + procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id); + procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id); + function Has_Default_Init_Comps (N : Node_Id) return Boolean; -- N is an aggregate (record or array). Checks the presence of default -- initialization (<>) in any component (Ada 2005: AI-287). @@ -6436,6 +6439,151 @@ package body Exp_Aggr is return; end Expand_N_Aggregate; + ------------------------------ + -- Expand_N_Delta_Aggregate -- + ------------------------------ + + procedure Expand_N_Delta_Aggregate (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Temp : constant Entity_Id := Make_Temporary (Loc, 'T'); + Typ : constant Entity_Id := Etype (N); + Decl : Node_Id; + + begin + Decl := Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => New_Copy_Tree (Expression (N))); + + if Is_Array_Type (Etype (N)) then + Expand_Delta_Array_Aggregate (N, New_List (Decl)); + else + Expand_Delta_Record_Aggregate (N, New_List (Decl)); + end if; + end Expand_N_Delta_Aggregate; + + ---------------------------------- + -- Expand_Delta_Array_Aggregate -- + ---------------------------------- + + procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id) is + Loc : constant Source_Ptr := Sloc (N); + Temp : constant Entity_Id := Defining_Identifier (First (Deltas)); + Assoc : Node_Id; + Choice : Node_Id; + function Generate_Loop (C : Node_Id) return Node_Id; + -- Generate a loop containing individual component assignments for + -- choices that are ranges, subtype indications, subtype names, and + -- iterated component associations. + + function Generate_Loop (C : Node_Id) return Node_Id is + Sl : constant Source_Ptr := Sloc (C); + Ix : Entity_Id; + + begin + if Nkind (Parent (C)) = N_Iterated_Component_Association then + Ix := + Make_Defining_Identifier (Loc, + Chars => (Chars (Defining_Identifier (Parent (C))))); + else + Ix := Make_Temporary (Sl, 'I'); + end if; + + return + Make_Loop_Statement (Loc, + Iteration_Scheme => Make_Iteration_Scheme (Sl, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Sl, + Defining_Identifier => Ix, + Discrete_Subtype_Definition => New_Copy_Tree (C))), + End_Label => Empty, + Statements => + New_List ( + Make_Assignment_Statement (Sl, + Name => Make_Indexed_Component (Sl, + Prefix => New_Occurrence_Of (Temp, Sl), + Expressions => New_List (New_Occurrence_Of (Ix, Sl))), + Expression => New_Copy_Tree (Expression (Assoc))))); + end Generate_Loop; + + begin + Assoc := First (Component_Associations (N)); + while Present (Assoc) loop + Choice := First (Choice_List (Assoc)); + if Nkind (Assoc) = N_Iterated_Component_Association then + while Present (Choice) loop + Append_To (Deltas, Generate_Loop (Choice)); + Next (Choice); + end loop; + + else + while Present (Choice) loop + + -- Choice can be given by a range, a subtype indication, a + -- subtype name, a scalar value, or an entity. + + if Nkind (Choice) = N_Range + or else (Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice))) + then + Append_To (Deltas, Generate_Loop (Choice)); + + elsif Nkind (Choice) = N_Subtype_Indication then + Append_To (Deltas, + Generate_Loop (Range_Expression (Constraint (Choice)))); + + else + Append_To (Deltas, + Make_Assignment_Statement (Sloc (Choice), + Name => Make_Indexed_Component (Sloc (Choice), + Prefix => New_Occurrence_Of (Temp, Loc), + Expressions => New_List (New_Copy_Tree (Choice))), + Expression => New_Copy_Tree (Expression (Assoc)))); + end if; + + Next (Choice); + end loop; + end if; + + Next (Assoc); + end loop; + + Insert_Actions (N, Deltas); + Rewrite (N, New_Occurrence_Of (Temp, Loc)); + end Expand_Delta_Array_Aggregate; + + ----------------------------------- + -- Expand_Delta_Record_Aggregate -- + ----------------------------------- + + procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id) is + Loc : constant Source_Ptr := Sloc (N); + Temp : constant Entity_Id := Defining_Identifier (First (Deltas)); + Assoc : Node_Id; + Choice : Node_Id; + + begin + Assoc := First (Component_Associations (N)); + + while Present (Assoc) loop + Choice := First (Choice_List (Assoc)); + while Present (Choice) loop + Append_To (Deltas, + Make_Assignment_Statement (Sloc (Choice), + Name => Make_Selected_Component (Sloc (Choice), + Prefix => New_Occurrence_Of (Temp, Loc), + Selector_Name => Make_Identifier (Loc, Chars (Choice))), + Expression => New_Copy_Tree (Expression (Assoc)))); + Next (Choice); + end loop; + + Next (Assoc); + end loop; + + Insert_Actions (N, Deltas); + Rewrite (N, New_Occurrence_Of (Temp, Loc)); + end Expand_Delta_Record_Aggregate; + ---------------------------------- -- Expand_N_Extension_Aggregate -- ---------------------------------- diff --git a/gcc/ada/exp_aggr.ads b/gcc/ada/exp_aggr.ads index 912f5465870..b9441fde4c0 100644 --- a/gcc/ada/exp_aggr.ads +++ b/gcc/ada/exp_aggr.ads @@ -28,6 +28,7 @@ with Types; use Types; package Exp_Aggr is procedure Expand_N_Aggregate (N : Node_Id); + procedure Expand_N_Delta_Aggregate (N : Node_Id); procedure Expand_N_Extension_Aggregate (N : Node_Id); function Is_Delayed_Aggregate (N : Node_Id) return Boolean; diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 4e37a50becd..8711c89d0eb 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1171,11 +1171,8 @@ package body Exp_Ch11 is -- end if; procedure Expand_N_Exception_Declaration (N : Node_Id) is - Id : constant Entity_Id := Defining_Identifier (N); - Loc : constant Source_Ptr := Sloc (N); - Ex_Id : Entity_Id; - Flag_Id : Entity_Id; - L : List_Id; + Id : constant Entity_Id := Defining_Identifier (N); + Loc : constant Source_Ptr := Sloc (N); procedure Force_Static_Allocation_Of_Referenced_Objects (Aggregate : Node_Id); @@ -1205,6 +1202,9 @@ package body Exp_Ch11 is -- references to other local (non-hoisted) objects (e.g., in the initial -- value expression). + function Null_String return String_Id; + -- Build a null-terminated empty string + --------------------------------------------------- -- Force_Static_Allocation_Of_Referenced_Objects -- --------------------------------------------------- @@ -1248,6 +1248,24 @@ package body Exp_Ch11 is Fixup_Tree (Aggregate); end Force_Static_Allocation_Of_Referenced_Objects; + ----------------- + -- Null_String -- + ----------------- + + function Null_String return String_Id is + begin + Start_String; + Store_String_Char (Get_Char_Code (ASCII.NUL)); + return End_String; + end Null_String; + + -- Local variables + + Ex_Id : Entity_Id; + Ex_Val : String_Id; + Flag_Id : Entity_Id; + L : List_Id; + -- Start of processing for Expand_N_Exception_Declaration begin @@ -1262,14 +1280,25 @@ package body Exp_Ch11 is Ex_Id := Make_Defining_Identifier (Loc, New_External_Name (Chars (Id), 'E')); + -- Do not generate an external name if the exception declaration is + -- subject to pragma Discard_Names. Use a null-terminated empty name + -- to ensure that Ada.Exceptions.Exception_Name functions properly. + + if Global_Discard_Names or else Discard_Names (Ex_Id) then + Ex_Val := Null_String; + + -- Otherwise generate the fully qualified name of the exception + + else + Ex_Val := Fully_Qualified_Name_String (Id); + end if; + Insert_Action (N, Make_Object_Declaration (Loc, Defining_Identifier => Ex_Id, Constant_Present => True, Object_Definition => New_Occurrence_Of (Standard_String, Loc), - Expression => - Make_String_Literal (Loc, - Strval => Fully_Qualified_Name_String (Id)))); + Expression => Make_String_Literal (Loc, Ex_Val))); Set_Is_Statically_Allocated (Ex_Id); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index a0b0edad191..3a1d98587c7 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -5831,6 +5831,7 @@ package body Exp_Util is | N_Defining_Operator_Symbol | N_Defining_Program_Unit_Name | N_Delay_Alternative + | N_Delta_Aggregate | N_Delta_Constraint | N_Derived_Type_Definition | N_Designator diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 776b2284b5d..e9a3a23b3fb 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -1381,7 +1381,7 @@ package body Ch4 is Expr_Node := P_Expression_Or_Range_Attribute_If_OK; end if; - -- Extension aggregate + -- Extension or Delta aggregate if Token = Tok_With then if Nkind (Expr_Node) = N_Attribute_Reference @@ -1395,9 +1395,18 @@ package body Ch4 is Error_Msg_SC ("(Ada 83) extension aggregate not allowed"); end if; - Aggregate_Node := New_Node (N_Extension_Aggregate, Lparen_Sloc); - Set_Ancestor_Part (Aggregate_Node, Expr_Node); Scan; -- past WITH + if Token = Tok_Delta then + Scan; -- past DELTA + Aggregate_Node := New_Node (N_Delta_Aggregate, Lparen_Sloc); + Set_Expression (Aggregate_Node, Expr_Node); + Expr_Node := Empty; + goto Aggregate; + + else + Aggregate_Node := New_Node (N_Extension_Aggregate, Lparen_Sloc); + Set_Ancestor_Part (Aggregate_Node, Expr_Node); + end if; -- Deal with WITH NULL RECORD case @@ -1586,7 +1595,11 @@ package body Ch4 is -- All component associations (positional and named) have been scanned T_Right_Paren; - Set_Expressions (Aggregate_Node, Expr_List); + + if Nkind (Aggregate_Node) /= N_Delta_Aggregate then + Set_Expressions (Aggregate_Node, Expr_List); + end if; + Set_Component_Associations (Aggregate_Node, Assoc_List); return Aggregate_Node; end P_Aggregate_Or_Paren_Expr; @@ -1622,6 +1635,10 @@ package body Ch4 is Assoc_Node : Node_Id; begin + if Token = Tok_For then + return P_Iterated_Component_Association; + end if; + Assoc_Node := New_Node (N_Component_Association, Token_Ptr); Set_Choices (Assoc_Node, P_Discrete_Choice_List); Set_Sloc (Assoc_Node, Token_Ptr); diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb index 1137823133e..11b6542e54d 100644 --- a/gcc/ada/par-ch9.adb +++ b/gcc/ada/par-ch9.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -338,10 +338,10 @@ package body Ch9 is Decl_Sloc := Token_Ptr; if Token = Tok_Pragma then - Append (P_Pragma, Items); + P_Pragmas_Opt (Items); - -- Ada 2005 (AI-397): Reserved words NOT and OVERRIDING - -- may begin an entry declaration. + -- Ada 2005 (AI-397): Reserved words NOT and OVERRIDING may begin an + -- entry declaration. elsif Token = Tok_Entry or else Token = Tok_Not @@ -350,8 +350,9 @@ package body Ch9 is Append (P_Entry_Declaration, Items); elsif Token = Tok_For then - -- Representation clause in task declaration. The only rep - -- clause which is legal in a protected is an address clause, + + -- Representation clause in task declaration. The only rep clause + -- which is legal in a protected declaration is an address clause, -- so that is what we try to scan out. Item_Node := P_Representation_Clause; @@ -617,8 +618,10 @@ package body Ch9 is -- Error recovery: cannot raise Error_Resync function P_Protected_Definition return Node_Id is - Def_Node : Node_Id; - Item_Node : Node_Id; + Def_Node : Node_Id; + Item_Node : Node_Id; + Priv_Decls : List_Id; + Vis_Decls : List_Id; begin Def_Node := New_Node (N_Protected_Definition, Token_Ptr); @@ -631,33 +634,63 @@ package body Ch9 is -- Loop to scan visible declarations (protected operation declarations) - Set_Visible_Declarations (Def_Node, New_List); + Vis_Decls := New_List; + Set_Visible_Declarations (Def_Node, Vis_Decls); + + -- Flag and discard all pragmas which cannot appear in the protected + -- definition. Note that certain pragmas are still allowed as long as + -- they apply to entries, entry families, or protected subprograms. + + P_Pragmas_Opt (Vis_Decls); loop Item_Node := P_Protected_Operation_Declaration_Opt; + + if Present (Item_Node) then + Append (Item_Node, Vis_Decls); + end if; + + P_Pragmas_Opt (Vis_Decls); + exit when No (Item_Node); - Append (Item_Node, Visible_Declarations (Def_Node)); end loop; -- Deal with PRIVATE part (including graceful handling of multiple -- PRIVATE parts). Private_Loop : while Token = Tok_Private loop - if No (Private_Declarations (Def_Node)) then - Set_Private_Declarations (Def_Node, New_List); - else + Priv_Decls := Private_Declarations (Def_Node); + + if Present (Priv_Decls) then Error_Msg_SC ("duplicate private part"); + else + Priv_Decls := New_List; + Set_Private_Declarations (Def_Node, Priv_Decls); end if; Scan; -- past PRIVATE + -- Flag and discard all pragmas which cannot appear in the protected + -- definition. Note that certain pragmas are still allowed as long as + -- they apply to entries, entry families, or protected subprograms. + + P_Pragmas_Opt (Priv_Decls); + Declaration_Loop : loop if Token = Tok_Identifier then - P_Component_Items (Private_Declarations (Def_Node)); + P_Component_Items (Priv_Decls); + P_Pragmas_Opt (Priv_Decls); + else Item_Node := P_Protected_Operation_Declaration_Opt; + + if Present (Item_Node) then + Append (Item_Node, Priv_Decls); + end if; + + P_Pragmas_Opt (Priv_Decls); + exit Declaration_Loop when No (Item_Node); - Append (Item_Node, Private_Declarations (Def_Node)); end if; end loop Declaration_Loop; end loop Private_Loop; diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index ba3c9502b93..ae09cc8e43b 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -1613,7 +1613,7 @@ package body Scng is when '@' => if Ada_Version < Ada_2020 then - Error_Illegal_Character; + Error_Msg ("target_name is an Ada2020 feature", Scan_Ptr); Scan_Ptr := Scan_Ptr + 1; else diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 36b561e79c9..bae89ad5ad1 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -196,6 +196,9 @@ package body Sem is when N_Delay_Relative_Statement => Analyze_Delay_Relative (N); + when N_Delta_Aggregate => + Analyze_Aggregate (N); + when N_Delay_Until_Statement => Analyze_Delay_Until (N); diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 6ca9d181b3d..65d586da32a 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -1678,10 +1678,16 @@ package body Sem_Aggr is Set_Etype (Ent, Standard_Void_Type); Set_Parent (Ent, Parent (N)); - Enter_Name (Id); - Set_Etype (Id, Index_Typ); - Set_Ekind (Id, E_Variable); - Set_Scope (Id, Ent); + -- Decorate the index variable in the current scope. The association + -- may have several choices, each one leading to a loop, so we create + -- this variable only once to prevent homonyms in this scope. + + if No (Scope (Id)) then + Enter_Name (Id); + Set_Etype (Id, Index_Typ); + Set_Ekind (Id, E_Variable); + Set_Scope (Id, Ent); + end if; Push_Scope (Ent); Dummy := Resolve_Aggr_Expr (Expression (N), False); @@ -2082,6 +2088,9 @@ package body Sem_Aggr is return Failure; end if; + elsif Nkind (Assoc) = N_Iterated_Component_Association then + null; -- handled above, in a loop context. + elsif not Resolve_Aggr_Expr (Expression (Assoc), Single_Elmt => Single_Choice) then @@ -2726,6 +2735,143 @@ package body Sem_Aggr is return Success; end Resolve_Array_Aggregate; + ----------------------------- + -- Resolve_Delta_Aggregate -- + ----------------------------- + + procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id) is + Base : constant Node_Id := Expression (N); + Deltas : constant List_Id := Component_Associations (N); + Assoc : Node_Id; + Choice : Node_Id; + Comp_Type : Entity_Id; + Index_Type : Entity_Id; + + function Get_Component_Type (Nam : Node_Id) return Entity_Id; + + ------------------------ + -- Get_Component_Type -- + ------------------------ + + function Get_Component_Type (Nam : Node_Id) return Entity_Id is + Comp : Entity_Id; + + begin + Comp := First_Entity (Typ); + + while Present (Comp) loop + if Chars (Comp) = Chars (Nam) then + if Ekind (Comp) = E_Discriminant then + Error_Msg_N ("delta cannot apply to discriminant", Nam); + end if; + + return Etype (Comp); + end if; + + Comp := Next_Entity (Comp); + end loop; + + Error_Msg_NE ("type& has no component with this name", Nam, Typ); + return Any_Type; + end Get_Component_Type; + + begin + if not Is_Composite_Type (Typ) then + Error_Msg_N ("not a composite type", N); + end if; + + Analyze_And_Resolve (Base, Typ); + if Is_Array_Type (Typ) then + Index_Type := Etype (First_Index (Typ)); + Assoc := First (Deltas); + while Present (Assoc) loop + if Nkind (Assoc) = N_Iterated_Component_Association then + Choice := First (Choice_List (Assoc)); + while Present (Choice) loop + if Nkind (Choice) = N_Others_Choice then + Error_Msg_N + ("others not allowed in delta aggregate", Choice); + + else + Analyze_And_Resolve (Choice, Index_Type); + end if; + + Next (Choice); + end loop; + + declare + Id : constant Entity_Id := Defining_Identifier (Assoc); + Ent : constant Entity_Id := + New_Internal_Entity + (E_Loop, Current_Scope, Sloc (Assoc), 'L'); + + begin + Set_Etype (Ent, Standard_Void_Type); + Set_Parent (Ent, Assoc); + + if No (Scope (Id)) then + Enter_Name (Id); + Set_Etype (Id, Index_Type); + Set_Ekind (Id, E_Variable); + Set_Scope (Id, Ent); + end if; + + Push_Scope (Ent); + Analyze_And_Resolve + (New_Copy_Tree (Expression (Assoc)), Component_Type (Typ)); + End_Scope; + end; + + else + Choice := First (Choice_List (Assoc)); + while Present (Choice) loop + if Nkind (Choice) = N_Others_Choice then + Error_Msg_N + ("others not allowed in delta aggregate", Choice); + + else + Analyze (Choice); + if Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + then + -- Choice covers a range of values. + if Base_Type (Entity (Choice)) /= + Base_Type (Index_Type) + then + Error_Msg_NE ("choice does mat match index type of", + Choice, Typ); + end if; + else + Resolve (Choice, Index_Type); + end if; + end if; + + Next (Choice); + end loop; + + Analyze_And_Resolve (Expression (Assoc), Component_Type (Typ)); + end if; + + Next (Assoc); + end loop; + + else + Assoc := First (Deltas); + while Present (Assoc) loop + Choice := First (Choice_List (Assoc)); + while Present (Choice) loop + Comp_Type := Get_Component_Type (Choice); + Next (Choice); + end loop; + + Analyze_And_Resolve (Expression (Assoc), Comp_Type); + Next (Assoc); + end loop; + end if; + + Set_Etype (N, Typ); + end Resolve_Delta_Aggregate; + --------------------------------- -- Resolve_Extension_Aggregate -- --------------------------------- diff --git a/gcc/ada/sem_aggr.ads b/gcc/ada/sem_aggr.ads index a0c1620cd38..8e795291c36 100644 --- a/gcc/ada/sem_aggr.ads +++ b/gcc/ada/sem_aggr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -30,6 +30,7 @@ with Types; use Types; 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); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 33d3b60c619..3d6c39583c8 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -2870,6 +2870,9 @@ package body Sem_Res is when N_Character_Literal => Resolve_Character_Literal (N, Ctx_Type); + when N_Delta_Aggregate => + Resolve_Delta_Aggregate (N, Ctx_Type); + when N_Expanded_Name => Resolve_Entity_Name (N, Ctx_Type); diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index d52c43c17d8..fc88da8e012 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -466,6 +466,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Aggregate + or else NT (N).Nkind = N_Delta_Aggregate or else NT (N).Nkind = N_Extension_Aggregate); return List2 (N); end Component_Associations; @@ -1265,6 +1266,7 @@ package body Sinfo is or else NT (N).Nkind = N_Component_Declaration or else NT (N).Nkind = N_Delay_Relative_Statement or else NT (N).Nkind = N_Delay_Until_Statement + or else NT (N).Nkind = N_Delta_Aggregate or else NT (N).Nkind = N_Discriminant_Association or else NT (N).Nkind = N_Discriminant_Specification or else NT (N).Nkind = N_Exception_Declaration @@ -3775,6 +3777,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Aggregate + or else NT (N).Nkind = N_Delta_Aggregate or else NT (N).Nkind = N_Extension_Aggregate); Set_List2_With_Parent (N, Val); end Set_Component_Associations; @@ -4565,6 +4568,7 @@ package body Sinfo is or else NT (N).Nkind = N_Component_Declaration or else NT (N).Nkind = N_Delay_Relative_Statement or else NT (N).Nkind = N_Delay_Until_Statement + or else NT (N).Nkind = N_Delta_Aggregate or else NT (N).Nkind = N_Discriminant_Association or else NT (N).Nkind = N_Discriminant_Specification or else NT (N).Nkind = N_Exception_Declaration diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 4ff8fb1da9f..69f283759b5 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -4133,6 +4133,15 @@ package Sinfo is -- Note that Box_Present is always False, but it is intentionally added -- for completeness. + ---------------------------- + -- 4.3.4 Delta Aggregate -- + ---------------------------- + + -- N_Delta_Aggregate + -- Sloc points to left parenthesis + -- Expression (Node3) + -- Component_Associations (List2) + -------------------------------------------------- -- 4.4 Expression/Relation/Term/Factor/Primary -- -------------------------------------------------- @@ -8475,6 +8484,7 @@ package Sinfo is N_Aggregate, N_Allocator, N_Case_Expression, + N_Delta_Aggregate, N_Extension_Aggregate, N_Raise_Expression, N_Range, @@ -11524,6 +11534,13 @@ package Sinfo is 4 => True, -- Discrete_Choices (List4) 5 => False), -- unused + N_Delta_Aggregate => + (1 => False, -- Expressions (List1) + 2 => True, -- Component_Associations (List2) + 3 => True, -- Expression (Node3) + 4 => False, -- Unused + 5 => False), -- Etype (Node5-Sem) + N_Extension_Aggregate => (1 => True, -- Expressions (List1) 2 => True, -- Component_Associations (List2) diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index bed39b52df4..f10ff039f8d 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -1775,6 +1775,13 @@ package body Sprint is Write_Indent_Str (";"); end if; + when N_Delta_Aggregate => + Write_Str_With_Col_Check_Sloc ("("); + Sprint_Node (Expression (Node)); + Write_Str_With_Col_Check (" with delta "); + Sprint_Comma_List (Component_Associations (Node)); + Write_Char (')'); + when N_Extension_Aggregate => Write_Str_With_Col_Check_Sloc ("("); Sprint_Node (Ancestor_Part (Node));