From: Arnaud Charlet Date: Fri, 6 Jan 2017 10:33:48 +0000 (+0100) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=442d1abbc4915d78e2309392b126443fe54c6b37;p=gcc.git [multiple changes] 2017-01-06 Tristan Gingold * ada.ads, a-unccon.ads: Add pragma No_Elaboration_Code_All. 2017-01-06 Hristian Kirtchev * sem_case.adb: Minor reformatting. 2017-01-06 Thomas Quinot * g-socthi-mingw.adb: Remove now extraneous USE TYPE clause 2017-01-06 Justin Squirek * aspects.adb: Register aspect in Canonical_Aspect. * aspects.ads: Associate qualities of Aspect_Max_Queue_Length into respective tables. * einfo.ads, einfo.adb: Add a new attribute for handling the parameters for Pragma_Max_Entry_Queue (Entry_Max_Queue_Lengths_Array) in E_Protected_Type. Subprograms for accessing and setting were added as well. * par-prag.adb (Prag): Register Pramga_Max_Entry_Queue. * exp_ch9.adb (Expand_N_Protected_Type_Declaration): Emit declaration for pramga arguments and store them in the protected type node. (Make_Initialize_Protection): Pass a reference to the Entry_Max_Queue_Lengths_Array in the protected type node to the runtime. * rtsfind.adb: Minor grammar fix. * rtsfind.ads: Register new types taken from the runtime libraries RE_Protected_Entry_Queue_Max and RE_Protected_Entry_Queue_Max_Array * s-tposen.adb, s-tpoben.adb (Initialize_Protection_Entry/Initialize_Protection_Entries): Add extra parameter and add assignment to local object. * s-tposen.ads, s-tpoben.ads: Add new types to store entry queue maximums and a field to the entry object record. * sem_ch13.adb (Analyze_Aspect_Specifications): Add case statement for Aspect_Max_Queue_Length. (Check_Aspect_At_Freeze_Point): Add aspect to list of aspects that don't require delayed analysis. * sem_prag.adb (Analyze_Pragma): Add case statement for Pragma_Max_Queue_Length, check semantics, and register arugments in the respective entry nodes. * sem_util.adb, sem_util.ads Add functions Get_Max_Queue_Length and Has_Max_Queue_Length * snames.ads-tmpl: Add constant for the new aspect-name Name_Max_Queue_Length and corrasponding pragma. 2017-01-06 Hristian Kirtchev * exp_util.adb (Is_Controlled_Function_Call): Reimplemented. Consider any node which has an entity as the function call may appear in various ways. From-SVN: r244126 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7150bc26d0b..beabccb874e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,58 @@ +2017-01-06 Tristan Gingold + + * ada.ads, a-unccon.ads: Add pragma No_Elaboration_Code_All. + +2017-01-06 Hristian Kirtchev + + * sem_case.adb: Minor reformatting. + +2017-01-06 Thomas Quinot + + * g-socthi-mingw.adb: Remove now extraneous USE TYPE clause + +2017-01-06 Justin Squirek + + * aspects.adb: Register aspect in Canonical_Aspect. + * aspects.ads: Associate qualities of Aspect_Max_Queue_Length + into respective tables. + * einfo.ads, einfo.adb: Add a new attribute for + handling the parameters for Pragma_Max_Entry_Queue + (Entry_Max_Queue_Lengths_Array) in E_Protected_Type. Subprograms + for accessing and setting were added as well. + * par-prag.adb (Prag): Register Pramga_Max_Entry_Queue. + * exp_ch9.adb (Expand_N_Protected_Type_Declaration): Emit + declaration for pramga arguments and store them in the protected + type node. + (Make_Initialize_Protection): Pass a reference to + the Entry_Max_Queue_Lengths_Array in the protected type node to + the runtime. + * rtsfind.adb: Minor grammar fix. + * rtsfind.ads: Register new types taken from the + runtime libraries RE_Protected_Entry_Queue_Max and + RE_Protected_Entry_Queue_Max_Array + * s-tposen.adb, s-tpoben.adb + (Initialize_Protection_Entry/Initialize_Protection_Entries): + Add extra parameter and add assignment to local object. + * s-tposen.ads, s-tpoben.ads: Add new types to + store entry queue maximums and a field to the entry object record. + * sem_ch13.adb (Analyze_Aspect_Specifications): Add case statement + for Aspect_Max_Queue_Length. + (Check_Aspect_At_Freeze_Point): + Add aspect to list of aspects that don't require delayed analysis. + * sem_prag.adb (Analyze_Pragma): Add case statement for + Pragma_Max_Queue_Length, check semantics, and register arugments + in the respective entry nodes. + * sem_util.adb, sem_util.ads Add functions Get_Max_Queue_Length + and Has_Max_Queue_Length + * snames.ads-tmpl: Add constant for the new aspect-name + Name_Max_Queue_Length and corrasponding pragma. + +2017-01-06 Hristian Kirtchev + + * exp_util.adb (Is_Controlled_Function_Call): + Reimplemented. Consider any node which has an entity as the + function call may appear in various ways. + 2017-01-06 Hristian Kirtchev * exp_attr.adb (Rewrite_Stream_Proc_Call): Use diff --git a/gcc/ada/a-unccon.ads b/gcc/ada/a-unccon.ads index ffa84d9fad2..a3b4318d1c4 100644 --- a/gcc/ada/a-unccon.ads +++ b/gcc/ada/a-unccon.ads @@ -19,5 +19,6 @@ generic function Ada.Unchecked_Conversion (S : Source) return Target; +pragma No_Elaboration_Code_All (Unchecked_Conversion); pragma Pure (Unchecked_Conversion); pragma Import (Intrinsic, Unchecked_Conversion); diff --git a/gcc/ada/ada.ads b/gcc/ada/ada.ads index 8c860110f92..4c2a3d00e50 100644 --- a/gcc/ada/ada.ads +++ b/gcc/ada/ada.ads @@ -14,6 +14,7 @@ ------------------------------------------------------------------------------ package Ada is + pragma No_Elaboration_Code_All; pragma Pure; end Ada; diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 4398f922805..0da6b812c97 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-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- -- @@ -568,6 +568,7 @@ package body Aspects is Aspect_Linker_Section => Aspect_Linker_Section, Aspect_Lock_Free => Aspect_Lock_Free, Aspect_Machine_Radix => Aspect_Machine_Radix, + Aspect_Max_Queue_Length => Aspect_Max_Queue_Length, Aspect_No_Elaboration_Code_All => Aspect_No_Elaboration_Code_All, Aspect_No_Return => Aspect_No_Return, Aspect_No_Tagged_Streams => Aspect_No_Tagged_Streams, diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index fe13b304369..5de6539b0a5 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -116,6 +116,7 @@ package Aspects is Aspect_Link_Name, Aspect_Linker_Section, -- GNAT Aspect_Machine_Radix, + Aspect_Max_Queue_Length, -- GNAT Aspect_Object_Size, -- GNAT Aspect_Obsolescent, -- GNAT Aspect_Output, @@ -247,6 +248,7 @@ package Aspects is Aspect_Inline_Always => True, Aspect_Invariant => True, Aspect_Lock_Free => True, + Aspect_Max_Queue_Length => True, Aspect_Object_Size => True, Aspect_Persistent_BSS => True, Aspect_Predicate => True, @@ -353,6 +355,7 @@ package Aspects is Aspect_Link_Name => Expression, Aspect_Linker_Section => Expression, Aspect_Machine_Radix => Expression, + Aspect_Max_Queue_Length => Expression, Aspect_Object_Size => Expression, Aspect_Obsolescent => Optional_Expression, Aspect_Output => Name, @@ -460,6 +463,7 @@ package Aspects is Aspect_Linker_Section => Name_Linker_Section, Aspect_Lock_Free => Name_Lock_Free, Aspect_Machine_Radix => Name_Machine_Radix, + Aspect_Max_Queue_Length => Name_Max_Queue_Length, Aspect_No_Elaboration_Code_All => Name_No_Elaboration_Code_All, Aspect_No_Return => Name_No_Return, Aspect_No_Tagged_Streams => Name_No_Tagged_Streams, @@ -731,6 +735,7 @@ package Aspects is Aspect_Import => Never_Delay, Aspect_Initial_Condition => Never_Delay, Aspect_Initializes => Never_Delay, + Aspect_Max_Queue_Length => Never_Delay, Aspect_No_Elaboration_Code_All => Never_Delay, Aspect_No_Tagged_Streams => Never_Delay, Aspect_Obsolescent => Never_Delay, diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 2cfb3325f46..4b78eca25e5 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -267,6 +267,7 @@ package body Einfo is -- Contract Node34 -- Anonymous_Designated_Type Node35 + -- Entry_Max_Queue_Lengths_Array Node35 -- Import_Pragma Node35 -- Class_Wide_Preconds List38 @@ -1221,6 +1222,12 @@ package body Einfo is return Node18 (Id); end Entry_Index_Constant; + function Entry_Max_Queue_Lengths_Array (Id : E) return N is + begin + pragma Assert (Ekind (Id) = E_Protected_Type); + return Node35 (Id); + end Entry_Max_Queue_Lengths_Array; + function Contains_Ignored_Ghost_Code (Id : E) return B is begin pragma Assert @@ -4286,6 +4293,12 @@ package body Einfo is Set_Node18 (Id, V); end Set_Entry_Index_Constant; + procedure Set_Entry_Max_Queue_Lengths_Array (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Protected_Type); + Set_Node35 (Id, V); + end Set_Entry_Max_Queue_Lengths_Array; + procedure Set_Entry_Parameters_Type (Id : E; V : E) is begin Set_Node15 (Id, V); @@ -10738,6 +10751,10 @@ package body Einfo is when E_Variable => Write_Str ("Anonymous_Designated_Type"); + when E_Entry | + E_Entry_Family => + Write_Str ("Entry_Max_Queue_Lenghts_Array"); + when Subprogram_Kind => Write_Str ("Import_Pragma"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index c5534559d5f..e5ab85aef42 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1154,6 +1154,11 @@ package Einfo is -- accept statement for a member of the family, and in the prefix of -- 'COUNT when it applies to a family member. +-- Entry_Max_Queue_Lengths_Array (Node35) +-- Defined in protected types for which Has_Entries is true. Contains the +-- defining identifier for the array of naturals used by the runtime to +-- limit the queue size of each entry individually. + -- Entry_Parameters_Type (Node15) -- Defined in entries. Points to the access-to-record type that is -- constructed by the expander to hold a reference to the parameter @@ -6381,6 +6386,7 @@ package Einfo is -- Stored_Constraint (Elist23) -- Anonymous_Object (Node30) -- Contract (Node34) + -- Entry_Max_Queue_Lengths_Array (Node35) -- SPARK_Pragma (Node40) -- SPARK_Aux_Pragma (Node41) -- Sec_Stack_Needed_For_Return (Flag167) ??? @@ -6928,6 +6934,7 @@ package Einfo is function Entry_Formal (Id : E) return E; function Entry_Index_Constant (Id : E) return E; function Entry_Index_Type (Id : E) return E; + function Entry_Max_Queue_Lengths_Array (Id : E) return E; function Entry_Parameters_Type (Id : E) return E; function Enum_Pos_To_Rep (Id : E) return E; function Enumeration_Pos (Id : E) return U; @@ -7608,6 +7615,7 @@ package Einfo is procedure Set_Entry_Component (Id : E; V : E); procedure Set_Entry_Formal (Id : E; V : E); procedure Set_Entry_Index_Constant (Id : E; V : E); + procedure Set_Entry_Max_Queue_Lengths_Array (Id : E; V : E); procedure Set_Entry_Parameters_Type (Id : E; V : E); procedure Set_Enum_Pos_To_Rep (Id : E; V : E); procedure Set_Enumeration_Pos (Id : E; V : U); @@ -8921,6 +8929,7 @@ package Einfo is pragma Inline (Set_Entry_Cancel_Parameter); pragma Inline (Set_Entry_Component); pragma Inline (Set_Entry_Formal); + pragma Inline (Set_Entry_Max_Queue_Lengths_Array); pragma Inline (Set_Entry_Parameters_Type); pragma Inline (Set_Enum_Pos_To_Rep); pragma Inline (Set_Enumeration_Pos); diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index dd812cc9e92..54000a0f304 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -9045,7 +9045,7 @@ package body Exp_Ch9 is -- the specs refer to this type. procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is - Discr_Map : constant Elist_Id := New_Elmt_List; + Discr_Map : constant Elist_Id := New_Elmt_List; Loc : constant Source_Ptr := Sloc (N); Prot_Typ : constant Entity_Id := Defining_Identifier (N); @@ -9055,17 +9055,9 @@ package body Exp_Ch9 is Pdef : constant Node_Id := Protected_Definition (N); -- This contains two lists; one for visible and one for private decls - Body_Arr : Node_Id; - Body_Id : Entity_Id; - Cdecls : List_Id; - Comp : Node_Id; Current_Node : Node_Id := N; E_Count : Int; Entries_Aggr : Node_Id; - New_Priv : Node_Id; - Object_Comp : Node_Id; - Priv : Node_Id; - Rec_Decl : Node_Id; procedure Check_Inlining (Subp : Entity_Id); -- If the original operation has a pragma Inline, propagate the flag @@ -9295,7 +9287,17 @@ package body Exp_Ch9 is -- Local variables - Sub : Node_Id; + Body_Arr : Node_Id; + Body_Id : Entity_Id; + Cdecls : List_Id; + Comp : Node_Id; + Expr : Node_Id; + New_Priv : Node_Id; + Obj_Def : Node_Id; + Object_Comp : Node_Id; + Priv : Node_Id; + Rec_Decl : Node_Id; + Sub : Node_Id; -- Start of processing for Expand_N_Protected_Type_Declaration @@ -9760,6 +9762,96 @@ package body Exp_Ch9 is end loop; end if; + -- Create the declaration of an array object which contains the values + -- of aspect/pragma Max_Queue_Length for all entries of the protected + -- type. This object is later passed to the appropriate protected object + -- initialization routine. + + declare + Maxs : constant List_Id := New_List; + Count : Int; + Item : Entity_Id; + Maxs_Id : Entity_Id; + Max_Vals : Node_Id; + + begin + if Has_Entries (Prot_Typ) then + + -- Gather the Max_Queue_Length values of all entries in a list. A + -- value of zero indicates that the entry has no limitation on its + -- queue length. + + Count := 0; + Item := First_Entity (Prot_Typ); + while Present (Item) loop + if Is_Entry (Item) then + Count := Count + 1; + + Append_To (Maxs, + Make_Integer_Literal (Loc, + Intval => Get_Max_Queue_Length (Item))); + end if; + + Next_Entity (Item); + end loop; + + -- Create the declaration of the array object. Generate: + + -- Maxs_Id : aliased Protected_Entry_Queue_Max_Array + -- (1 .. Count) := (..., ...); + -- or + -- Maxs_Id : aliased Protected_Entry_Queue_Max := ; + + Maxs_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Prot_Typ), 'B')); + + case Corresponding_Runtime_Package (Prot_Typ) is + when System_Tasking_Protected_Objects_Entries => + Expr := Make_Aggregate (Loc, Maxs); + + Obj_Def := + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of + (RTE (RE_Protected_Entry_Queue_Max_Array), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Make_Integer_Literal (Loc, 1), + Make_Integer_Literal (Loc, Count))))); + + when System_Tasking_Protected_Objects_Single_Entry => + Expr := Make_Integer_Literal (Loc, Intval (First (Maxs))); + + Obj_Def := + New_Occurrence_Of + (RTE (RE_Protected_Entry_Queue_Max), Loc); + + when others => + raise Program_Error; + end case; + + Max_Vals := + Make_Object_Declaration (Loc, + Defining_Identifier => Maxs_Id, + Aliased_Present => True, + Object_Definition => Obj_Def, + Expression => Expr); + + -- A pointer to this array will be placed in the corresponding + -- record by its initialization procedure so this needs to be + -- analyzed here. + + Insert_After (Current_Node, Max_Vals); + Current_Node := Max_Vals; + Analyze (Max_Vals); + + Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxs_Id); + end if; + end; + -- Emit declaration for Entry_Bodies_Array, now that the addresses of -- all protected subprograms have been collected. @@ -9770,37 +9862,34 @@ package body Exp_Ch9 is case Corresponding_Runtime_Package (Prot_Typ) is when System_Tasking_Protected_Objects_Entries => - Body_Arr := - Make_Object_Declaration (Loc, - Defining_Identifier => Body_Id, - Aliased_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of - (RTE (RE_Protected_Entry_Body_Array), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Range (Loc, - Make_Integer_Literal (Loc, 1), - Make_Integer_Literal (Loc, E_Count))))), - Expression => Entries_Aggr); + Expr := Entries_Aggr; + Obj_Def := + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of + (RTE (RE_Protected_Entry_Body_Array), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Make_Integer_Literal (Loc, 1), + Make_Integer_Literal (Loc, E_Count))))); when System_Tasking_Protected_Objects_Single_Entry => - Body_Arr := - Make_Object_Declaration (Loc, - Defining_Identifier => Body_Id, - Aliased_Present => True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Entry_Body), Loc), - Expression => - Remove_Head (Expressions (Entries_Aggr))); + Expr := Remove_Head (Expressions (Entries_Aggr)); + Obj_Def := New_Occurrence_Of (RTE (RE_Entry_Body), Loc); when others => raise Program_Error; end case; + Body_Arr := + Make_Object_Declaration (Loc, + Defining_Identifier => Body_Id, + Aliased_Present => True, + Object_Definition => Obj_Def, + Expression => Expr); + -- A pointer to this array will be placed in the corresponding record -- by its initialization procedure so this needs to be analyzed here. @@ -9821,6 +9910,7 @@ package body Exp_Ch9 is Sub := Make_Subprogram_Declaration (Loc, Specification => Build_Find_Body_Index_Spec (Prot_Typ)); + Insert_After (Current_Node, Sub); Analyze (Sub); end if; @@ -14107,6 +14197,27 @@ package body Exp_Ch9 is raise Program_Error; end case; + -- Entry_Queue_Maxs parameter. This is a pointer to an array of + -- naturals representing the entry queue maximums for each entry + -- in the protected type. Zero represents no max. + + if Has_Entry then + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Entry_Max_Queue_Lengths_Array (Ptyp), Loc), + Attribute_Name => Name_Unrestricted_Access)); + + -- Edge cases exist where entry initialization functions are + -- called, but no entries exist, so null is appended. + + elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry + or else Pkg_Id = System_Tasking_Protected_Objects_Entries + then + Append_To (Args, Make_Null (Loc)); + end if; + -- Entry_Bodies parameter. This is a pointer to an array of -- pointers to the entry body procedures and barrier functions of -- the object. If the protected type has no entries this object diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 6d6d7546597..05dbf8f1cfa 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -4912,35 +4912,28 @@ package body Exp_Util is -- Obj.Func (Formal => Actual) N_Function_Call, whose Name is an -- N_Selected_Component - case Nkind (Expr) is - when N_Function_Call => + loop + if Nkind (Expr) = N_Function_Call then Expr := Name (Expr); - -- Check for "Obj.Func (Formal => Actual)" case - - if Nkind (Expr) = N_Selected_Component then - Expr := Selector_Name (Expr); - end if; - -- "Obj.Func (Actual)" case - when N_Indexed_Component => + elsif Nkind (Expr) = N_Indexed_Component then Expr := Prefix (Expr); - if Nkind (Expr) = N_Selected_Component then - Expr := Selector_Name (Expr); - end if; - - -- "Obj.Func" case + -- "Obj.Func" or "Obj.Func (Formal => Actual) case - when N_Selected_Component => + elsif Nkind (Expr) = N_Selected_Component then Expr := Selector_Name (Expr); - when others => null; - end case; + else + exit; + end if; + end loop; return - Nkind_In (Expr, N_Expanded_Name, N_Identifier) + Nkind (Expr) in N_Has_Entity + and then Present (Entity (Expr)) and then Ekind (Entity (Expr)) = E_Function and then Needs_Finalization (Etype (Entity (Expr))); end Is_Controlled_Function_Call; diff --git a/gcc/ada/g-socthi-mingw.adb b/gcc/ada/g-socthi-mingw.adb index e8ee6dcc630..f35239c28e6 100644 --- a/gcc/ada/g-socthi-mingw.adb +++ b/gcc/ada/g-socthi-mingw.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2014, AdaCore -- +-- Copyright (C) 2001-2016, AdaCore -- -- -- -- 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- -- @@ -43,7 +43,6 @@ with System.Storage_Elements; use System.Storage_Elements; package body GNAT.Sockets.Thin is use type C.unsigned; - use type C.int; WSAData_Dummy : array (1 .. 512) of C.int; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 900d96a866f..16a9c44ccad 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1396,6 +1396,7 @@ begin Pragma_Machine_Attribute | Pragma_Main | Pragma_Main_Storage | + Pragma_Max_Queue_Length | Pragma_Memory_Size | Pragma_No_Body | Pragma_No_Elaboration_Code_All | diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 6e94ccbd942..db0d9d31bdf 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -1351,7 +1351,7 @@ package body Rtsfind is -- is System. If so, return the value from the already compiled -- declaration and otherwise do a regular find. - -- Not pleasant, but these kinds of annoying recursion when + -- Not pleasant, but these kinds of annoying recursion senarios when -- writing an Ada compiler in Ada have to be broken somewhere. if Present (Main_Unit_Entity) diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 6163f0bf27c..1fbca38332a 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -1684,6 +1684,7 @@ package Rtsfind is RE_Protected_Entry_Body_Array, -- Tasking.Protected_Objects.Entries RE_Protected_Entry_Names_Array, -- Tasking.Protected_Objects.Entries + RE_Protected_Entry_Queue_Max_Array, -- Tasking.Protected_Objects.Entries RE_Protection_Entries, -- Tasking.Protected_Objects.Entries RE_Protection_Entries_Access, -- Tasking.Protected_Objects.Entries RE_Initialize_Protection_Entries, -- Tasking.Protected_Objects.Entries @@ -1716,6 +1717,7 @@ package Rtsfind is RE_Service_Entry, -- Protected_Objects.Single_Entry RE_Exceptional_Complete_Single_Entry_Body, RE_Protected_Count_Entry, -- Protected_Objects.Single_Entry + RE_Protected_Entry_Queue_Max, -- Protected_Objects.Single_Entry RE_Protected_Single_Entry_Caller, -- Protected_Objects.Single_Entry RE_Protected_Entry_Index, -- System.Tasking.Protected_Objects @@ -2927,6 +2929,8 @@ package Rtsfind is System_Tasking_Protected_Objects_Entries, RE_Protected_Entry_Names_Array => System_Tasking_Protected_Objects_Entries, + RE_Protected_Entry_Queue_Max_Array => + System_Tasking_Protected_Objects_Entries, RE_Protection_Entries => System_Tasking_Protected_Objects_Entries, RE_Protection_Entries_Access => @@ -2989,6 +2993,8 @@ package Rtsfind is System_Tasking_Protected_Objects_Single_Entry, RE_Protected_Count_Entry => System_Tasking_Protected_Objects_Single_Entry, + RE_Protected_Entry_Queue_Max => + System_Tasking_Protected_Objects_Single_Entry, RE_Protected_Single_Entry_Caller => System_Tasking_Protected_Objects_Single_Entry, diff --git a/gcc/ada/s-tpoben.adb b/gcc/ada/s-tpoben.adb index 9131f8c07b9..aecc7db4bc5 100644 --- a/gcc/ada/s-tpoben.adb +++ b/gcc/ada/s-tpoben.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2016, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -174,6 +174,7 @@ package body System.Tasking.Protected_Objects.Entries is (Object : Protection_Entries_Access; Ceiling_Priority : Integer; Compiler_Info : System.Address; + Entry_Queue_Maxs : Protected_Entry_Queue_Max_Access; Entry_Bodies : Protected_Entry_Body_Access; Find_Body_Index : Find_Body_Index_Access) is @@ -211,6 +212,7 @@ package body System.Tasking.Protected_Objects.Entries is Object.Compiler_Info := Compiler_Info; Object.Pending_Action := False; Object.Call_In_Progress := null; + Object.Entry_Queue_Maxs := Entry_Queue_Maxs; Object.Entry_Bodies := Entry_Bodies; Object.Find_Body_Index := Find_Body_Index; diff --git a/gcc/ada/s-tpoben.ads b/gcc/ada/s-tpoben.ads index 8a91bbb03e1..79c9c4407c4 100644 --- a/gcc/ada/s-tpoben.ads +++ b/gcc/ada/s-tpoben.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -66,6 +66,12 @@ package System.Tasking.Protected_Objects.Entries is type Protected_Entry_Queue_Array is array (Protected_Entry_Index range <>) of Entry_Queue; + type Protected_Entry_Queue_Max_Array is + array (Positive_Protected_Entry_Index range <>) of Natural; + + type Protected_Entry_Queue_Max_Access is + access all Protected_Entry_Queue_Max_Array; + -- The following declarations define an array that contains the string -- names of entries and entry family members, together with an associated -- access type. @@ -144,6 +150,10 @@ package System.Tasking.Protected_Objects.Entries is Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries); + Entry_Queue_Maxs : Protected_Entry_Queue_Max_Access; + -- Access to an array of naturals representing the max value for + -- each entry's queue length. A value of 0 signifies no max. + Entry_Names : Protected_Entry_Names_Access := null; -- An array of string names which denotes entry [family member] names. -- The structure is indexed by protected entry index and contains Num_ @@ -178,6 +188,7 @@ package System.Tasking.Protected_Objects.Entries is (Object : Protection_Entries_Access; Ceiling_Priority : Integer; Compiler_Info : System.Address; + Entry_Queue_Maxs : Protected_Entry_Queue_Max_Access; Entry_Bodies : Protected_Entry_Body_Access; Find_Body_Index : Find_Body_Index_Access); -- Initialize the Object parameter so that it can be used by the runtime diff --git a/gcc/ada/s-tposen.adb b/gcc/ada/s-tposen.adb index 4487c5eee2c..59d9e912ea1 100644 --- a/gcc/ada/s-tposen.adb +++ b/gcc/ada/s-tposen.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2016, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -218,6 +218,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is (Object : Protection_Entry_Access; Ceiling_Priority : Integer; Compiler_Info : System.Address; + Entry_Queue_Max : Protected_Entry_Queue_Max_Access; Entry_Body : Entry_Body_Access) is begin @@ -226,6 +227,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is Object.Compiler_Info := Compiler_Info; Object.Call_In_Progress := null; Object.Entry_Body := Entry_Body; + Object.Entry_Queue_Max := Entry_Queue_Max; Object.Entry_Queue := null; end Initialize_Protection_Entry; diff --git a/gcc/ada/s-tposen.ads b/gcc/ada/s-tposen.ads index 3bb0aa8e6d1..bfd82bf0e95 100644 --- a/gcc/ada/s-tposen.ads +++ b/gcc/ada/s-tposen.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, 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- -- @@ -182,10 +182,16 @@ package System.Tasking.Protected_Objects.Single_Entry is type Protection_Entry_Access is access all Protection_Entry; + type Protected_Entry_Queue_Max is new Natural; + + type Protected_Entry_Queue_Max_Access is + access all Protected_Entry_Queue_Max; + procedure Initialize_Protection_Entry (Object : Protection_Entry_Access; Ceiling_Priority : Integer; Compiler_Info : System.Address; + Entry_Queue_Max : Protected_Entry_Queue_Max_Access; Entry_Body : Entry_Body_Access); -- Initialize the Object parameter so that it can be used by the run time -- to keep track of the runtime state of a protected object. @@ -270,6 +276,10 @@ private Entry_Queue : Entry_Call_Link; -- Place to store the waiting entry call (if any) + + Entry_Queue_Max : Protected_Entry_Queue_Max_Access; + -- Access to a natural representing the max value for the single + -- entry's queue length. A value of 0 signifies no max. end record; end System.Tasking.Protected_Objects.Single_Entry; diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 9a220bb6bb4..3b3820e46b9 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -1369,9 +1369,9 @@ package body Sem_Case is Lo : Node_Id; Hi : Node_Id); -- If the type of the alternative has predicates, we must examine - -- each subset of the predicate rather than the bounds of the - -- type itself. This is relevant when the choice is a subtype mark - -- or a subtype indication. + -- each subset of the predicate rather than the bounds of the type + -- itself. This is relevant when the choice is a subtype mark or a + -- subtype indication. ----------- -- Check -- @@ -1509,8 +1509,8 @@ package body Sem_Case is P := First (Static_Discrete_Predicate (Typ)); while Present (P) loop - -- Check that part of the predicate choice is included in - -- the given bounds. + -- Check that part of the predicate choice is included in the + -- given bounds. if Expr_Value (High_Bound (P)) >= Expr_Value (Lo) and then Expr_Value (Low_Bound (P)) <= Expr_Value (Hi) @@ -1643,8 +1643,8 @@ package body Sem_Case is & "predicate as case alternative", Choice, E, Suggest_Static => True); - -- Static predicate case. The bounds are - -- those of the given subtype. + -- Static predicate case. The bounds are those of + -- the given subtype. else Handle_Static_Predicate (E, @@ -1702,11 +1702,10 @@ package body Sem_Case is end if; end if; - if Has_Static_Predicate (E) then - -- Check applicable predicate values within the -- bounds of the given range. + if Has_Static_Predicate (E) then Handle_Static_Predicate (E, L, H); else diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index bff49e6430b..262728856ed 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -2823,6 +2823,19 @@ package body Sem_Ch13 is goto Continue; end Initializes; + -- Max_Queue_Length + + when Aspect_Max_Queue_Length => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Max_Queue_Length); + + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); + goto Continue; + -- Obsolescent when Aspect_Obsolescent => declare @@ -9251,6 +9264,7 @@ package body Sem_Ch13 is Aspect_Implicit_Dereference | Aspect_Initial_Condition | Aspect_Initializes | + Aspect_Max_Queue_Length | Aspect_Obsolescent | Aspect_Part_Of | Aspect_Post | diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 3e4fe0a62ff..f2002caeb22 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -17659,6 +17659,86 @@ package body Sem_Prag is end loop; end Main_Storage; + ---------------------- + -- Max_Queue_Length -- + ---------------------- + + -- pragma Max_Queue_Length (static_integer_EXPRESSION); + + when Pragma_Max_Queue_Length => Max_Queue_Length : declare + Arg : Node_Id; + Entry_Decl : Node_Id; + Entry_Id : Entity_Id; + Val : Uint; + + begin + GNAT_Pragma; + Check_Arg_Count (1); + + Entry_Decl := + Find_Related_Declaration_Or_Body (N, Do_Checks => True); + + -- Entry declaration + + if Nkind (Entry_Decl) = N_Entry_Declaration then + + -- Entry illegally within a task + + if Nkind (Parent (N)) = N_Task_Definition then + Error_Pragma ("pragma % cannot apply to task entries"); + return; + end if; + + Entry_Id := Unique_Defining_Entity (Entry_Decl); + + -- Pragma illegally applied to an entry family + + if Ekind (Entry_Id) = E_Entry_Family then + Error_Pragma ("pragma % cannot apply to entry families"); + return; + end if; + + -- Otherwise the pragma is associated with an illegal construct + + else + Error_Pragma ("pragma % must apply to a protected entry"); + return; + end if; + + -- Mark the pragma as Ghost if the related subprogram is also + -- Ghost. This also ensures that any expansion performed further + -- below will produce Ghost nodes. + + Mark_Pragma_As_Ghost (N, Entry_Id); + + -- Analyze the Integer expression + + Arg := Get_Pragma_Arg (Arg1); + Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer); + + Val := Expr_Value (Arg); + + if Val <= 0 then + Error_Pragma_Arg + ("argument for pragma% must be positive", Arg1); + + elsif not UI_Is_In_Int_Range (Val) then + Error_Pragma_Arg + ("argument for pragma% out of range of Integer", Arg1); + + end if; + + -- Manually subsitute the expression value of the pragma argument + -- if it not an integer literally because this is not taken care + -- of automatically elsewhere. + + if Nkind (Arg) /= N_Integer_Literal then + Rewrite (Arg, Make_Integer_Literal (Sloc (Arg), Val)); + end if; + + Record_Rep_Item (Entry_Id, N); + end Max_Queue_Length; + ----------------- -- Memory_Size -- ----------------- @@ -28642,6 +28722,7 @@ package body Sem_Prag is Pragma_Machine_Attribute => -1, Pragma_Main => -1, Pragma_Main_Storage => -1, + Pragma_Max_Queue_Length => 0, Pragma_Memory_Size => 0, Pragma_No_Return => 0, Pragma_No_Body => 0, diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index e8a22fa64e1..e02e7325e95 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -8351,6 +8351,24 @@ package body Sem_Util is pragma Assert (Name_Buffer (Name_Len + 1) = ' '); end Get_Library_Unit_Name_String; + -------------------------- + -- Get_Max_Queue_Length -- + -------------------------- + + function Get_Max_Queue_Length (Id : Entity_Id) return Uint is + Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length); + + begin + -- A value of 0 represents no maximum specified and entries and entry + -- families with no Max_Queue_Length aspect or pragma defaults to it. + + if not Has_Max_Queue_Length (Id) or else not Present (Prag) then + return Uint_0; + end if; + + return Intval (Expression (First (Pragma_Argument_Associations (Prag)))); + end Get_Max_Queue_Length; + ------------------------ -- Get_Name_Entity_Id -- ------------------------ @@ -9648,15 +9666,25 @@ package body Sem_Util is return False; end Has_Interfaces; + -------------------------- + -- Has_Max_Queue_Length -- + -------------------------- + + function Has_Max_Queue_Length (Id : Entity_Id) return Boolean is + begin + return + Ekind (Id) = E_Entry + and then Present (Get_Pragma (Id, Pragma_Max_Queue_Length)); + end Has_Max_Queue_Length; + --------------------------------- -- Has_No_Obvious_Side_Effects -- --------------------------------- function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is begin - -- For now, just handle literals, constants, and non-volatile - -- variables and expressions combining these with operators or - -- short circuit forms. + -- For now handle literals, constants, and non-volatile variables and + -- expressions combining these with operators or short circuit forms. if Nkind (N) in N_Numeric_Or_String_Literal then return True; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 711c321e132..f768c0fdb4e 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -931,6 +931,10 @@ package Sem_Util is -- Retrieve the fully expanded name of the library unit declared by -- Decl_Node into the name buffer. + function Get_Max_Queue_Length (Id : Entity_Id) return Uint; + -- Return the argument of pragma Max_Queue_Length or zero if the annotation + -- is not present. It is assumed that Id denotes an entry. + function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id; pragma Inline (Get_Name_Entity_Id); -- An entity value is associated with each name in the name table. The @@ -1104,6 +1108,10 @@ package Sem_Util is -- Use_Full_View controls if the check is done using its full view (if -- available). + function Has_Max_Queue_Length (Id : Entity_Id) return Boolean; + -- Determine whether Id is subject to pragma Max_Queue_Length. It is + -- assumed that Id denotes an entry. + function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean; -- This is a simple minded function for determining whether an expression -- has no obvious side effects. It is used only for determining whether diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 920b24ef12e..e183915e333 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -575,6 +575,7 @@ package Snames is Name_Machine_Attribute : constant Name_Id := N + $; -- GNAT Name_Main : constant Name_Id := N + $; -- GNAT Name_Main_Storage : constant Name_Id := N + $; -- GNAT + Name_Max_Queue_Length : constant Name_Id := N + $; -- GNAT Name_Memory_Size : constant Name_Id := N + $; -- Ada 83 Name_No_Body : constant Name_Id := N + $; -- GNAT Name_No_Elaboration_Code_All : constant Name_Id := N + $; -- GNAT @@ -1904,6 +1905,7 @@ package Snames is Pragma_Machine_Attribute, Pragma_Main, Pragma_Main_Storage, + Pragma_Max_Queue_Length, Pragma_Memory_Size, Pragma_No_Body, Pragma_No_Elaboration_Code_All,