From: Arnaud Charlet Date: Mon, 26 Oct 2015 11:29:13 +0000 (+0100) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=ca7e6c2640e197797b544a7238d1e362f85c2921;p=gcc.git [multiple changes] 2015-10-26 Hristian Kirtchev * inline.adb: Minor reformatting. 2015-10-26 Yannick Moy * get_spark_xrefs.adb (get_SPARK_Xrefs): Remove obsolete assertion. * lib-xref-spark_specific.adb (Traverse_Declaration_Or_Statement): New procedure to factor duplicated code and add treatment of protected entries. (Add_SPARK_Scope, Traverse_Declarations_Or_Statements): Call the new procedure Traverse_Declaration_Or_Statement. Use same character used in normal xrefs for SPARK xrefs, for a given entity used as scope. * spark_xrefs.ads Document character used for entries. * sem_prag.adb (Check_Loop_Pragma_Placement): Account for possible introduction of declarations and statements by the expansion, between two otherwise consecutive loop pragmas. * sem_util.ads, sem_util.adb (Is_Suspension_Object): Lifted from nested function. (Is_Descendant_Of_Suspension_Object): nested function lifted. 2015-10-26 Hristian Kirtchev * sem_attr.adb (Eval_Attribute): Attribute 'Enum_Rep can be folded when its prefix denotes a constant, an enumeration literal or an enumeration type. Use the expression of the attribute in the enumeration type form, otherwise use the prefix to fold. From-SVN: r229334 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ae7c1a460ae..81c2c0b407b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,32 @@ +2015-10-26 Hristian Kirtchev + + * inline.adb: Minor reformatting. + +2015-10-26 Yannick Moy + + * get_spark_xrefs.adb (get_SPARK_Xrefs): Remove obsolete + assertion. + * lib-xref-spark_specific.adb (Traverse_Declaration_Or_Statement): + New procedure to factor duplicated code and add + treatment of protected entries. + (Add_SPARK_Scope, Traverse_Declarations_Or_Statements): Call the new + procedure Traverse_Declaration_Or_Statement. Use same character used in + normal xrefs for SPARK xrefs, for a given entity used as scope. + * spark_xrefs.ads Document character used for entries. + * sem_prag.adb (Check_Loop_Pragma_Placement): Account for possible + introduction of declarations and statements by the expansion, between + two otherwise consecutive loop pragmas. + * sem_util.ads, sem_util.adb (Is_Suspension_Object): Lifted from nested + function. + (Is_Descendant_Of_Suspension_Object): nested function lifted. + +2015-10-26 Hristian Kirtchev + + * sem_attr.adb (Eval_Attribute): Attribute 'Enum_Rep can be folded + when its prefix denotes a constant, an enumeration literal or + an enumeration type. Use the expression of the attribute in the + enumeration type form, otherwise use the prefix to fold. + 2015-10-26 Hristian Kirtchev * aspects.adb Add an entry for entry bodies in table diff --git a/gcc/ada/get_spark_xrefs.adb b/gcc/ada/get_spark_xrefs.adb index ea1f1b45a0b..e0b58ce35dd 100644 --- a/gcc/ada/get_spark_xrefs.adb +++ b/gcc/ada/get_spark_xrefs.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, 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- -- @@ -293,9 +293,6 @@ begin Col := Get_Nat; pragma Assert (Scope = Cur_Scope); - pragma Assert (Typ = 'K' - or else Typ = 'V' - or else Typ = 'U'); -- Scan out scope entity name diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 2bee1927c2d..99b536c72d3 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -3462,14 +3462,12 @@ package body Inline is if Nkind (D) = N_Package_Declaration then Cannot_Inline - ("cannot inline & (nested package declaration)?", - D, Subp); + ("cannot inline & (nested package declaration)?", D, Subp); return True; elsif Nkind (D) = N_Package_Instantiation then Cannot_Inline - ("cannot inline & (nested package instantiation)?", - D, Subp); + ("cannot inline & (nested package instantiation)?", D, Subp); return True; end if; @@ -3482,8 +3480,7 @@ package body Inline is or else Nkind (D) = N_Single_Task_Declaration then Cannot_Inline - ("cannot inline & (nested task type declaration)?", - D, Subp); + ("cannot inline & (nested task type declaration)?", D, Subp); return True; elsif Nkind (D) = N_Protected_Type_Declaration @@ -3496,22 +3493,19 @@ package body Inline is elsif Nkind (D) = N_Subprogram_Body then Cannot_Inline - ("cannot inline & (nested subprogram)?", - D, Subp); + ("cannot inline & (nested subprogram)?", D, Subp); return True; elsif Nkind (D) = N_Function_Instantiation and then not Is_Unchecked_Conversion (D) then Cannot_Inline - ("cannot inline & (nested function instantiation)?", - D, Subp); + ("cannot inline & (nested function instantiation)?", D, Subp); return True; elsif Nkind (D) = N_Procedure_Instantiation then Cannot_Inline - ("cannot inline & (nested procedure instantiation)?", - D, Subp); + ("cannot inline & (nested procedure instantiation)?", D, Subp); return True; -- Subtype declarations with predicates will generate predicate @@ -3535,9 +3529,8 @@ package body Inline is or else A_Id = Aspect_Dynamic_Predicate then Cannot_Inline - ("cannot inline & " - & "(subtype declaration with predicate)?", - D, Subp); + ("cannot inline & (subtype declaration with " + & "predicate)?", D, Subp); return True; end if; diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb index 8d7615979fe..7ed6f7b9101 100644 --- a/gcc/ada/lib-xref-spark_specific.adb +++ b/gcc/ada/lib-xref-spark_specific.adb @@ -104,6 +104,10 @@ package body SPARK_Specific is function Entity_Hash (E : Entity_Id) return Entity_Hashed_Range; -- Hash function for hash table + procedure Traverse_Declaration_Or_Statement + (N : Node_Id; + Process : Node_Processing; + Inside_Stubs : Boolean); procedure Traverse_Declarations_Or_Statements (L : List_Id; Process : Node_Processing; @@ -243,6 +247,11 @@ package body SPARK_Specific is procedure Add_SPARK_Scope (N : Node_Id) is E : constant Entity_Id := Defining_Entity (N); Loc : constant Source_Ptr := Sloc (E); + + -- The character describing the kind of scope is chosen to be the same + -- as the one describing the corresponding entity in cross references, + -- see Xref_Entity_Letters in lib-xrefs.ads + Typ : Character; begin @@ -253,39 +262,25 @@ package body SPARK_Specific is end if; case Ekind (E) is - when E_Function | E_Generic_Function => - Typ := 'V'; - - when E_Procedure | E_Generic_Procedure => - Typ := 'U'; - - when E_Subprogram_Body => - declare - Spec : Node_Id; - - begin - Spec := Parent (E); - - if Nkind (Spec) = N_Defining_Program_Unit_Name then - Spec := Parent (Spec); - end if; - - if Nkind (Spec) = N_Function_Specification then - Typ := 'V'; - else - pragma Assert - (Nkind (Spec) = N_Procedure_Specification); - Typ := 'U'; - end if; - end; - - when E_Package | E_Package_Body | E_Generic_Package => - Typ := 'K'; + when E_Entry + | E_Function + | E_Generic_Function + | E_Generic_Package + | E_Generic_Procedure + | E_Package + | E_Procedure + => + Typ := Xref_Entity_Letters (Ekind (E)); + + when E_Package_Body + | E_Subprogram_Body + => + Typ := Xref_Entity_Letters (Ekind (Unique_Entity (E))); when E_Void => - -- Compilation of prj-attr.adb with -gnatn creates a node with - -- entity E_Void for the package defined at a-charac.ads16:13 + -- Compilation of prj-attr.adb with -gnatn creates a node with + -- entity E_Void for the package defined at a-charac.ads16:13. -- ??? TBD return; @@ -968,11 +963,14 @@ package body SPARK_Specific is procedure Detect_And_Add_SPARK_Scope (N : Node_Id) is begin - if Nkind_In (N, N_Subprogram_Declaration, + if Nkind_In (N, N_Entry_Body, + N_Entry_Declaration, + N_Package_Body, + N_Package_Body_Stub, + N_Package_Declaration, N_Subprogram_Body, N_Subprogram_Body_Stub, - N_Package_Declaration, - N_Package_Body) + N_Subprogram_Declaration) then Add_SPARK_Scope (N); end if; @@ -1193,230 +1191,203 @@ package body SPARK_Specific is -- Traverse the unit - if Nkind (Lu) = N_Subprogram_Body then - Traverse_Subprogram_Body (Lu, Process, Inside_Stubs); - - elsif Nkind (Lu) = N_Subprogram_Declaration then - null; - - elsif Nkind (Lu) = N_Package_Declaration then - Traverse_Package_Declaration (Lu, Process, Inside_Stubs); - - elsif Nkind (Lu) = N_Package_Body then - Traverse_Package_Body (Lu, Process, Inside_Stubs); - - elsif Nkind (Lu) = N_Protected_Body then - Traverse_Protected_Body (Lu, Process, Inside_Stubs); - - -- All other cases of compilation units (e.g. renamings), are not - -- declarations, or else generic declarations which are ignored. - - else - null; - end if; + Traverse_Declaration_Or_Statement (Lu, Process, Inside_Stubs); end Traverse_Compilation_Unit; - ----------------------------------------- - -- Traverse_Declarations_Or_Statements -- - ----------------------------------------- + --------------------------------------- + -- Traverse_Declaration_Or_Statement -- + --------------------------------------- - procedure Traverse_Declarations_Or_Statements - (L : List_Id; + procedure Traverse_Declaration_Or_Statement + (N : Node_Id; Process : Node_Processing; Inside_Stubs : Boolean) is - N : Node_Id; - begin - -- Loop through statements or declarations - - N := First (L); - while Present (N) loop - -- Call Process on all declarations - - if Nkind (N) in N_Declaration - or else - Nkind (N) in N_Later_Decl_Item - then - Process (N); - end if; - - case Nkind (N) is - - -- Package declaration - - when N_Package_Declaration => - Traverse_Package_Declaration (N, Process, Inside_Stubs); - - -- Package body - - when N_Package_Body => - if Ekind (Defining_Entity (N)) /= E_Generic_Package then - Traverse_Package_Body (N, Process, Inside_Stubs); - end if; + case Nkind (N) is + when N_Package_Declaration => + Traverse_Package_Declaration (N, Process, Inside_Stubs); - when N_Package_Body_Stub => - if Present (Library_Unit (N)) then - declare - Body_N : constant Node_Id := Get_Body_From_Stub (N); - begin - if Inside_Stubs - and then - Ekind (Defining_Entity (Body_N)) /= E_Generic_Package - then - Traverse_Package_Body (Body_N, Process, Inside_Stubs); - end if; - end; - end if; - - -- Subprogram declaration + when N_Package_Body => + if Ekind (Defining_Entity (N)) /= E_Generic_Package then + Traverse_Package_Body (N, Process, Inside_Stubs); + end if; - when N_Subprogram_Declaration => - null; + when N_Package_Body_Stub => + if Present (Library_Unit (N)) then + declare + Body_N : constant Node_Id := Get_Body_From_Stub (N); + begin + if Inside_Stubs + and then + Ekind (Defining_Entity (Body_N)) /= E_Generic_Package + then + Traverse_Package_Body (Body_N, Process, Inside_Stubs); + end if; + end; + end if; - -- Subprogram body + when N_Subprogram_Declaration => + null; - when N_Subprogram_Body => - if not Is_Generic_Subprogram (Defining_Entity (N)) then - Traverse_Subprogram_Body (N, Process, Inside_Stubs); - end if; + when N_Entry_Body + | N_Subprogram_Body + => + if not Is_Generic_Subprogram (Defining_Entity (N)) then + Traverse_Subprogram_Body (N, Process, Inside_Stubs); + end if; - when N_Subprogram_Body_Stub => - if Present (Library_Unit (N)) then - declare - Body_N : constant Node_Id := Get_Body_From_Stub (N); - begin - if Inside_Stubs - and then - not Is_Generic_Subprogram (Defining_Entity (Body_N)) - then - Traverse_Subprogram_Body - (Body_N, Process, Inside_Stubs); - end if; - end; - end if; + when N_Subprogram_Body_Stub => + if Present (Library_Unit (N)) then + declare + Body_N : constant Node_Id := Get_Body_From_Stub (N); + begin + if Inside_Stubs + and then + not Is_Generic_Subprogram (Defining_Entity (Body_N)) + then + Traverse_Subprogram_Body (Body_N, Process, Inside_Stubs); + end if; + end; + end if; - -- Protected unit + when N_Protected_Definition => + Traverse_Declarations_Or_Statements + (Visible_Declarations (N), Process, Inside_Stubs); + Traverse_Declarations_Or_Statements + (Private_Declarations (N), Process, Inside_Stubs); - when N_Protected_Definition => - Traverse_Declarations_Or_Statements - (Visible_Declarations (N), Process, Inside_Stubs); - Traverse_Declarations_Or_Statements - (Private_Declarations (N), Process, Inside_Stubs); + when N_Protected_Body => + Traverse_Protected_Body (N, Process, Inside_Stubs); - when N_Protected_Body => - Traverse_Protected_Body (N, Process, Inside_Stubs); + when N_Protected_Body_Stub => + if Present (Library_Unit (N)) then + declare + Body_N : constant Node_Id := Get_Body_From_Stub (N); + begin + if Inside_Stubs then + Traverse_Declarations_Or_Statements + (Declarations (Body_N), Process, Inside_Stubs); + end if; + end; + end if; - when N_Protected_Body_Stub => - if Present (Library_Unit (N)) then - declare - Body_N : constant Node_Id := Get_Body_From_Stub (N); - begin - if Inside_Stubs then - Traverse_Declarations_Or_Statements - (Declarations (Body_N), Process, Inside_Stubs); - end if; - end; - end if; + when N_Task_Definition => + Traverse_Declarations_Or_Statements + (Visible_Declarations (N), Process, Inside_Stubs); + Traverse_Declarations_Or_Statements + (Private_Declarations (N), Process, Inside_Stubs); - -- Task unit + when N_Task_Body => + Traverse_Declarations_Or_Statements + (Declarations (N), Process, Inside_Stubs); + Traverse_Handled_Statement_Sequence + (Handled_Statement_Sequence (N), Process, Inside_Stubs); - when N_Task_Definition => - Traverse_Declarations_Or_Statements - (Visible_Declarations (N), Process, Inside_Stubs); - Traverse_Declarations_Or_Statements - (Private_Declarations (N), Process, Inside_Stubs); + when N_Task_Body_Stub => + if Present (Library_Unit (N)) then + declare + Body_N : constant Node_Id := Get_Body_From_Stub (N); + begin + if Inside_Stubs then + Traverse_Declarations_Or_Statements + (Declarations (Body_N), Process, Inside_Stubs); + Traverse_Handled_Statement_Sequence + (Handled_Statement_Sequence (Body_N), Process, + Inside_Stubs); + end if; + end; + end if; - when N_Task_Body => - Traverse_Declarations_Or_Statements - (Declarations (N), Process, Inside_Stubs); - Traverse_Handled_Statement_Sequence - (Handled_Statement_Sequence (N), Process, Inside_Stubs); + when N_Block_Statement => + Traverse_Declarations_Or_Statements + (Declarations (N), Process, Inside_Stubs); + Traverse_Handled_Statement_Sequence + (Handled_Statement_Sequence (N), Process, Inside_Stubs); - when N_Task_Body_Stub => - if Present (Library_Unit (N)) then - declare - Body_N : constant Node_Id := Get_Body_From_Stub (N); - begin - if Inside_Stubs then - Traverse_Declarations_Or_Statements - (Declarations (Body_N), Process, Inside_Stubs); - Traverse_Handled_Statement_Sequence - (Handled_Statement_Sequence (Body_N), Process, - Inside_Stubs); - end if; - end; - end if; + when N_If_Statement => - -- Block statement + -- Traverse the statements in the THEN part - when N_Block_Statement => - Traverse_Declarations_Or_Statements - (Declarations (N), Process, Inside_Stubs); - Traverse_Handled_Statement_Sequence - (Handled_Statement_Sequence (N), Process, Inside_Stubs); + Traverse_Declarations_Or_Statements + (Then_Statements (N), Process, Inside_Stubs); - when N_If_Statement => + -- Loop through ELSIF parts if present - -- Traverse the statements in the THEN part + if Present (Elsif_Parts (N)) then + declare + Elif : Node_Id := First (Elsif_Parts (N)); - Traverse_Declarations_Or_Statements - (Then_Statements (N), Process, Inside_Stubs); + begin + while Present (Elif) loop + Traverse_Declarations_Or_Statements + (Then_Statements (Elif), Process, Inside_Stubs); + Next (Elif); + end loop; + end; + end if; - -- Loop through ELSIF parts if present + -- Finally traverse the ELSE statements if present - if Present (Elsif_Parts (N)) then - declare - Elif : Node_Id := First (Elsif_Parts (N)); + Traverse_Declarations_Or_Statements + (Else_Statements (N), Process, Inside_Stubs); - begin - while Present (Elif) loop - Traverse_Declarations_Or_Statements - (Then_Statements (Elif), Process, Inside_Stubs); - Next (Elif); - end loop; - end; - end if; + when N_Case_Statement => - -- Finally traverse the ELSE statements if present + -- Process case branches - Traverse_Declarations_Or_Statements - (Else_Statements (N), Process, Inside_Stubs); + declare + Alt : Node_Id; + begin + Alt := First (Alternatives (N)); + while Present (Alt) loop + Traverse_Declarations_Or_Statements + (Statements (Alt), Process, Inside_Stubs); + Next (Alt); + end loop; + end; - -- Case statement + when N_Extended_Return_Statement => + Traverse_Handled_Statement_Sequence + (Handled_Statement_Sequence (N), Process, Inside_Stubs); - when N_Case_Statement => + when N_Loop_Statement => + Traverse_Declarations_Or_Statements + (Statements (N), Process, Inside_Stubs); - -- Process case branches + -- Generic declarations are ignored - declare - Alt : Node_Id; - begin - Alt := First (Alternatives (N)); - while Present (Alt) loop - Traverse_Declarations_Or_Statements - (Statements (Alt), Process, Inside_Stubs); - Next (Alt); - end loop; - end; + when others => + null; + end case; + end Traverse_Declaration_Or_Statement; - -- Extended return statement + ----------------------------------------- + -- Traverse_Declarations_Or_Statements -- + ----------------------------------------- - when N_Extended_Return_Statement => - Traverse_Handled_Statement_Sequence - (Handled_Statement_Sequence (N), Process, Inside_Stubs); + procedure Traverse_Declarations_Or_Statements + (L : List_Id; + Process : Node_Processing; + Inside_Stubs : Boolean) + is + N : Node_Id; - -- Loop + begin + -- Loop through statements or declarations - when N_Loop_Statement => - Traverse_Declarations_Or_Statements - (Statements (N), Process, Inside_Stubs); + N := First (L); + while Present (N) loop + -- Call Process on all declarations - -- Generic declarations are ignored + if Nkind (N) in N_Declaration + or else + Nkind (N) in N_Later_Decl_Item + then + Process (N); + end if; - when others => - null; - end case; + Traverse_Declaration_Or_Statement (N, Process, Inside_Stubs); Next (N); end loop; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index e08709fd2ac..df4c5ceeda5 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -7265,20 +7265,58 @@ package body Sem_Attr is return; end if; - -- Special processing for cases where the prefix is an object. For - -- this purpose, a string literal counts as an object (attributes - -- of string literals can only appear in generated code). + -- Special processing for cases where the prefix is an object. For this + -- purpose, a string literal counts as an object (attributes of string + -- literals can only appear in generated code). if Is_Object_Reference (P) or else Nkind (P) = N_String_Literal then -- For Component_Size, the prefix is an array object, and we apply - -- the attribute to the type of the object. This is allowed for - -- both unconstrained and constrained arrays, since the bounds - -- have no influence on the value of this attribute. + -- the attribute to the type of the object. This is allowed for both + -- unconstrained and constrained arrays, since the bounds have no + -- influence on the value of this attribute. if Id = Attribute_Component_Size then P_Entity := Etype (P); + -- For Enum_Rep, evaluation depends on the nature of the prefix and + -- the optional argument. + + elsif Id = Attribute_Enum_Rep then + if Is_Entity_Name (P) then + + -- The prefix denotes a constant or an enumeration literal, the + -- attribute can be folded. + + if Ekind_In (Entity (P), E_Constant, E_Enumeration_Literal) then + P_Entity := Etype (P); + + -- The prefix denotes an enumeration type. Folding can occur + -- when the argument is a constant or an enumeration literal. + + elsif Is_Enumeration_Type (Entity (P)) + and then Present (E1) + and then Is_Entity_Name (E1) + and then Ekind_In (Entity (E1), E_Constant, + E_Enumeration_Literal) + then + P_Entity := Etype (P); + + -- Otherwise the attribute must be expanded into a conversion + -- and evaluated at runtime. + + else + Check_Expressions; + return; + end if; + + -- Otherwise the attribute is illegal, do not attempt to perform + -- any kind of folding. + + else + return; + end if; + -- For First and Last, the prefix is an array object, and we apply -- the attribute to the type of the array, but we need a constrained -- type for this, so we use the actual subtype if available. @@ -7971,7 +8009,26 @@ package body Sem_Attr is -- Enum_Rep -- -------------- - when Attribute_Enum_Rep => + when Attribute_Enum_Rep => Enum_Rep : declare + Val : Node_Id; + + begin + -- The attribute appears in the form + + -- Enum_Typ'Enum_Rep (Const) + -- Enum_Typ'Enum_Rep (Enum_Lit) + + if Present (E1) then + Val := E1; + + -- Otherwise the prefix denotes a constant or enumeration literal + + -- Const'Enum_Rep + -- Enum_Lit'Enum_Rep + + else + Val := P; + end if; -- For an enumeration type with a non-standard representation use -- the Enumeration_Rep field of the proper constant. Note that this @@ -7983,15 +8040,16 @@ package body Sem_Attr is if Is_Enumeration_Type (P_Type) and then Has_Non_Standard_Rep (P_Type) then - Fold_Uint (N, Enumeration_Rep (Expr_Value_E (E1)), Static); + Fold_Uint (N, Enumeration_Rep (Expr_Value_E (Val)), Static); - -- For enumeration types with standard representations and all - -- other cases (i.e. all integer and modular types), Enum_Rep - -- is equivalent to Pos. + -- For enumeration types with standard representations and all other + -- cases (i.e. all integer and modular types), Enum_Rep is equivalent + -- to Pos. else - Fold_Uint (N, Expr_Value (E1), Static); + Fold_Uint (N, Expr_Value (Val), Static); end if; + end Enum_Rep; -------------- -- Enum_Val -- diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index cbefd3898a7..defb21a8858 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -4833,6 +4833,12 @@ package body Sem_Prag is elsif Is_Loop_Pragma (Stmt) then Prag := Stmt; + -- Skip declarations and statements generated by + -- the compiler during expansion. + + elsif not Comes_From_Source (Stmt) then + null; + -- A non-pragma is separating the group from the -- current pragma, the placement is illegal. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index de8472af9a4..2332bb32ab7 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -11309,40 +11309,9 @@ package body Sem_Util is function Is_Descendant_Of_Suspension_Object (Typ : Entity_Id) return Boolean is - function Is_Suspension_Object (Id : Entity_Id) return Boolean; - -- Determine whether arbitrary entity Id denotes Suspension_Object - -- defined in Ada.Synchronous_Task_Control. - - -------------------------- - -- Is_Suspension_Object -- - -------------------------- - - function Is_Suspension_Object (Id : Entity_Id) return Boolean is - begin - -- This approach does an exact name match rather than to rely on - -- RTSfind. Routine Is_Effectively_Volatile is used by clients of - -- the front end at point where all auxiliary tables are locked - -- and any modifications to them are treated as violations. Do not - -- tamper with the tables, instead examine the Chars fields of all - -- the scopes of Id. - - return - Chars (Id) = Name_Suspension_Object - and then Present (Scope (Id)) - and then Chars (Scope (Id)) = Name_Synchronous_Task_Control - and then Present (Scope (Scope (Id))) - and then Chars (Scope (Scope (Id))) = Name_Ada - and then Present (Scope (Scope (Scope (Id)))) - and then Scope (Scope (Scope (Id))) = Standard_Standard; - end Is_Suspension_Object; - - -- Local variables - Cur_Typ : Entity_Id; Par_Typ : Entity_Id; - -- Start of processing for Is_Descendant_Of_Suspension_Object - begin -- Climb the type derivation chain checking each parent type against -- Suspension_Object. @@ -13161,6 +13130,28 @@ package body Sem_Util is and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body; end Is_Subprogram_Stub_Without_Prior_Declaration; + -------------------------- + -- Is_Suspension_Object -- + -------------------------- + + function Is_Suspension_Object (Id : Entity_Id) return Boolean is + begin + -- This approach does an exact name match rather than to rely on + -- RTSfind. Routine Is_Effectively_Volatile is used by clients of the + -- front end at point where all auxiliary tables are locked and any + -- modifications to them are treated as violations. Do not tamper with + -- the tables, instead examine the Chars fields of all the scopes of Id. + + return + Chars (Id) = Name_Suspension_Object + and then Present (Scope (Id)) + and then Chars (Scope (Id)) = Name_Synchronous_Task_Control + and then Present (Scope (Scope (Id))) + and then Chars (Scope (Scope (Id))) = Name_Ada + and then Present (Scope (Scope (Scope (Id)))) + and then Scope (Scope (Scope (Id))) = Standard_Standard; + end Is_Suspension_Object; + --------------------------------- -- Is_Synchronized_Tagged_Type -- --------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 867aa00dbb0..973cb7df326 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1503,6 +1503,10 @@ package Sem_Util is -- Return True if N is a subprogram stub with no prior subprogram -- declaration. + function Is_Suspension_Object (Id : Entity_Id) return Boolean; + -- Determine whether arbitrary entity Id denotes Suspension_Object defined + -- in Ada.Synchronous_Task_Control. + function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean; -- Returns True if E is a synchronized tagged type (AARM 3.9.4 (6/2)) diff --git a/gcc/ada/spark_xrefs.ads b/gcc/ada/spark_xrefs.ads index 41719ea3aec..ff5fb26c2ec 100644 --- a/gcc/ada/spark_xrefs.ads +++ b/gcc/ada/spark_xrefs.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, 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- -- @@ -111,9 +111,10 @@ package SPARK_Xrefs is -- type is a single letter identifying the type of the entity, using -- the same code as in cross-references: - -- K = package - -- V = function - -- U = procedure + -- K = package (k = generic package) + -- V = function (v = generic function) + -- U = procedure (u = generic procedure) + -- Y = entry -- col is the column number of the scope entity