From: Arnaud Charlet Date: Fri, 13 Jan 2017 10:24:28 +0000 (+0100) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=da9683f4dbc85066c290798a14d1158f804f92a2;p=gcc.git [multiple changes] 2017-01-13 Yannick Moy * inline.adb (Remove_Aspects_And_Pragmas): Add Unused to the list of pragmas to remove. Remove pragmas from the list of statements in the body to inline. * namet.adb, namet.ads (Nam_In): New version with 12 parameters. 2017-01-13 Ed Schonberg * sem_ch3.adb (Resolve_Aspects): New procedure, subsidiary of Analyze_Declarations, to analyze and resolve the expressions of aspect specifications in the current declarative list, so that the expressions have proper entity and type info. This is needed for ASIS when there is no subsequent expansion to generate this semantic information. * sem_ch13.adb (Check_Aspect_At_End_Of_Declarations): Use Etype of original expression, to suppress cascaded errors when expression has been constant-folded. (Resolve_Aspect_Expressions, Resolve_Name): Preserve entities in ASIS mode, because there is no subsequent expansion to decorate the tree. From-SVN: r244409 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 549ee1ab08b..a0f6f81c122 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,25 @@ +2017-01-13 Yannick Moy + + * inline.adb (Remove_Aspects_And_Pragmas): Add Unused to the + list of pragmas to remove. Remove pragmas from the list of + statements in the body to inline. + * namet.adb, namet.ads (Nam_In): New version with 12 parameters. + +2017-01-13 Ed Schonberg + + * sem_ch3.adb (Resolve_Aspects): New procedure, subsidiary of + Analyze_Declarations, to analyze and resolve the expressions of + aspect specifications in the current declarative list, so that + the expressions have proper entity and type info. This is needed + for ASIS when there is no subsequent expansion to generate this + semantic information. + * sem_ch13.adb (Check_Aspect_At_End_Of_Declarations): Use Etype of + original expression, to suppress cascaded errors when expression + has been constant-folded. + (Resolve_Aspect_Expressions, Resolve_Name): Preserve entities in + ASIS mode, because there is no subsequent expansion to decorate + the tree. + 2017-01-13 Yannick Moy * inline.adb, inline.ads (Call_Can_Be_Inlined_In_GNATprove_Mode): diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index bf0f705f428..7389105966a 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -1223,7 +1223,7 @@ package body Inline is and then not Same_Type (Etype (F), Etype (A)) and then (Is_By_Reference_Type (Etype (A)) - or else Is_Limited_Type (Etype (A))) + or else Is_Limited_Type (Etype (A))) then return False; end if; @@ -1235,139 +1235,6 @@ package body Inline is return True; end Call_Can_Be_Inlined_In_GNATprove_Mode; - ------------------- - -- Cannot_Inline -- - ------------------- - - procedure Cannot_Inline - (Msg : String; - N : Node_Id; - Subp : Entity_Id; - Is_Serious : Boolean := False) - is - begin - -- In GNATprove mode, inlining is the technical means by which the - -- higher-level goal of contextual analysis is reached, so issue - -- messages about failure to apply contextual analysis to a - -- subprogram, rather than failure to inline it. - - if GNATprove_Mode - and then Msg (Msg'First .. Msg'First + 12) = "cannot inline" - then - declare - Len1 : constant Positive := - String (String'("cannot inline"))'Length; - Len2 : constant Positive := - String (String'("info: no contextual analysis of"))'Length; - - New_Msg : String (1 .. Msg'Length + Len2 - Len1); - - begin - New_Msg (1 .. Len2) := "info: no contextual analysis of"; - New_Msg (Len2 + 1 .. Msg'Length + Len2 - Len1) := - Msg (Msg'First + Len1 .. Msg'Last); - Cannot_Inline (New_Msg, N, Subp, Is_Serious); - return; - end; - end if; - - pragma Assert (Msg (Msg'Last) = '?'); - - -- Legacy front end inlining model - - if not Back_End_Inlining then - - -- Do not emit warning if this is a predefined unit which is not - -- the main unit. With validity checks enabled, some predefined - -- subprograms may contain nested subprograms and become ineligible - -- for inlining. - - if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp))) - and then not In_Extended_Main_Source_Unit (Subp) - then - null; - - -- In GNATprove mode, issue a warning, and indicate that the - -- subprogram is not always inlined by setting flag Is_Inlined_Always - -- to False. - - elsif GNATprove_Mode then - Set_Is_Inlined_Always (Subp, False); - Error_Msg_NE (Msg & "p?", N, Subp); - - elsif Has_Pragma_Inline_Always (Subp) then - - -- Remove last character (question mark) to make this into an - -- error, because the Inline_Always pragma cannot be obeyed. - - Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp); - - elsif Ineffective_Inline_Warnings then - Error_Msg_NE (Msg & "p?", N, Subp); - end if; - - -- New semantics relying on back end inlining - - elsif Is_Serious then - - -- Remove last character (question mark) to make this into an error. - - Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp); - - -- In GNATprove mode, issue a warning, and indicate that the subprogram - -- is not always inlined by setting flag Is_Inlined_Always to False. - - elsif GNATprove_Mode then - Set_Is_Inlined_Always (Subp, False); - Error_Msg_NE (Msg & "p?", N, Subp); - - else - - -- Do not emit warning if this is a predefined unit which is not - -- the main unit. This behavior is currently provided for backward - -- compatibility but it will be removed when we enforce the - -- strictness of the new rules. - - if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp))) - and then not In_Extended_Main_Source_Unit (Subp) - then - null; - - elsif Has_Pragma_Inline_Always (Subp) then - - -- Emit a warning if this is a call to a runtime subprogram - -- which is located inside a generic. Previously this call - -- was silently skipped. - - if Is_Generic_Instance (Subp) then - declare - Gen_P : constant Entity_Id := Generic_Parent (Parent (Subp)); - begin - if Is_Predefined_File_Name - (Unit_File_Name (Get_Source_Unit (Gen_P))) - then - Set_Is_Inlined (Subp, False); - Error_Msg_NE (Msg & "p?", N, Subp); - return; - end if; - end; - end if; - - -- Remove last character (question mark) to make this into an - -- error, because the Inline_Always pragma cannot be obeyed. - - Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp); - - else - Set_Is_Inlined (Subp, False); - - if Ineffective_Inline_Warnings then - Error_Msg_NE (Msg & "p?", N, Subp); - end if; - end if; - end if; - end Cannot_Inline; - -------------------------------------- -- Can_Be_Inlined_In_GNATprove_Mode -- -------------------------------------- @@ -1521,7 +1388,8 @@ package body Inline is -- Local declarations - Id : Entity_Id; -- Procedure or function entity for the subprogram + Id : Entity_Id; + -- Procedure or function entity for the subprogram -- Start of processing for Can_Be_Inlined_In_GNATprove_Mode @@ -1624,6 +1492,139 @@ package body Inline is end if; end Can_Be_Inlined_In_GNATprove_Mode; + ------------------- + -- Cannot_Inline -- + ------------------- + + procedure Cannot_Inline + (Msg : String; + N : Node_Id; + Subp : Entity_Id; + Is_Serious : Boolean := False) + is + begin + -- In GNATprove mode, inlining is the technical means by which the + -- higher-level goal of contextual analysis is reached, so issue + -- messages about failure to apply contextual analysis to a + -- subprogram, rather than failure to inline it. + + if GNATprove_Mode + and then Msg (Msg'First .. Msg'First + 12) = "cannot inline" + then + declare + Len1 : constant Positive := + String (String'("cannot inline"))'Length; + Len2 : constant Positive := + String (String'("info: no contextual analysis of"))'Length; + + New_Msg : String (1 .. Msg'Length + Len2 - Len1); + + begin + New_Msg (1 .. Len2) := "info: no contextual analysis of"; + New_Msg (Len2 + 1 .. Msg'Length + Len2 - Len1) := + Msg (Msg'First + Len1 .. Msg'Last); + Cannot_Inline (New_Msg, N, Subp, Is_Serious); + return; + end; + end if; + + pragma Assert (Msg (Msg'Last) = '?'); + + -- Legacy front end inlining model + + if not Back_End_Inlining then + + -- Do not emit warning if this is a predefined unit which is not + -- the main unit. With validity checks enabled, some predefined + -- subprograms may contain nested subprograms and become ineligible + -- for inlining. + + if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp))) + and then not In_Extended_Main_Source_Unit (Subp) + then + null; + + -- In GNATprove mode, issue a warning, and indicate that the + -- subprogram is not always inlined by setting flag Is_Inlined_Always + -- to False. + + elsif GNATprove_Mode then + Set_Is_Inlined_Always (Subp, False); + Error_Msg_NE (Msg & "p?", N, Subp); + + elsif Has_Pragma_Inline_Always (Subp) then + + -- Remove last character (question mark) to make this into an + -- error, because the Inline_Always pragma cannot be obeyed. + + Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp); + + elsif Ineffective_Inline_Warnings then + Error_Msg_NE (Msg & "p?", N, Subp); + end if; + + -- New semantics relying on back end inlining + + elsif Is_Serious then + + -- Remove last character (question mark) to make this into an error. + + Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp); + + -- In GNATprove mode, issue a warning, and indicate that the subprogram + -- is not always inlined by setting flag Is_Inlined_Always to False. + + elsif GNATprove_Mode then + Set_Is_Inlined_Always (Subp, False); + Error_Msg_NE (Msg & "p?", N, Subp); + + else + + -- Do not emit warning if this is a predefined unit which is not + -- the main unit. This behavior is currently provided for backward + -- compatibility but it will be removed when we enforce the + -- strictness of the new rules. + + if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp))) + and then not In_Extended_Main_Source_Unit (Subp) + then + null; + + elsif Has_Pragma_Inline_Always (Subp) then + + -- Emit a warning if this is a call to a runtime subprogram + -- which is located inside a generic. Previously this call + -- was silently skipped. + + if Is_Generic_Instance (Subp) then + declare + Gen_P : constant Entity_Id := Generic_Parent (Parent (Subp)); + begin + if Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Gen_P))) + then + Set_Is_Inlined (Subp, False); + Error_Msg_NE (Msg & "p?", N, Subp); + return; + end if; + end; + end if; + + -- Remove last character (question mark) to make this into an + -- error, because the Inline_Always pragma cannot be obeyed. + + Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp); + + else + Set_Is_Inlined (Subp, False); + + if Ineffective_Inline_Warnings then + Error_Msg_NE (Msg & "p?", N, Subp); + end if; + end if; + end if; + end Cannot_Inline; + -------------------------------------------- -- Check_And_Split_Unconstrained_Function -- -------------------------------------------- @@ -3102,8 +3103,8 @@ package body Inline is if (Is_Entity_Name (A) and then - (not Is_Scalar_Type (Etype (A)) - or else Ekind (Entity (A)) = E_Enumeration_Literal) + (not Is_Scalar_Type (Etype (A)) + or else Ekind (Entity (A)) = E_Enumeration_Literal) and then not GNATprove_Mode) -- When the actual is an identifier and the corresponding formal is @@ -3112,9 +3113,10 @@ package body Inline is -- GNATprove mode, to make sure any check on a type conversion -- will be issued. - or else (Nkind (A) = N_Identifier - and then Formal_Is_Used_Once (F) - and then not GNATprove_Mode) + or else + (Nkind (A) = N_Identifier + and then Formal_Is_Used_Once (F) + and then not GNATprove_Mode) or else (Nkind_In (A, N_Real_Literal, @@ -4210,7 +4212,8 @@ package body Inline is Name_Refined_Post, Name_Test_Case, Name_Unmodified, - Name_Unreferenced) + Name_Unreferenced, + Name_Unused) then Remove (Item); end if; @@ -4224,6 +4227,11 @@ package body Inline is begin Remove_Items (Aspect_Specifications (Body_Decl)); Remove_Items (Declarations (Body_Decl)); + + -- Pragmas Unmodified, Unreferenced and Unused may additionally appear + -- in the body of the subprogram. + + Remove_Items (Statements (Handled_Statement_Sequence (Body_Decl))); end Remove_Aspects_And_Pragmas; -------------------------- diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index 520ce6a244f..1fdc37ca731 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.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- -- @@ -1435,6 +1435,36 @@ package body Namet is T = V11; end Nam_In; + function Nam_In + (T : Name_Id; + V1 : Name_Id; + V2 : Name_Id; + V3 : Name_Id; + V4 : Name_Id; + V5 : Name_Id; + V6 : Name_Id; + V7 : Name_Id; + V8 : Name_Id; + V9 : Name_Id; + V10 : Name_Id; + V11 : Name_Id; + V12 : Name_Id) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4 or else + T = V5 or else + T = V6 or else + T = V7 or else + T = V8 or else + T = V9 or else + T = V10 or else + T = V11 or else + T = V12; + end Nam_In; + ----------------- -- Name_Equals -- ----------------- diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index 88063644070..9c25b4f7854 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- 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- -- @@ -311,6 +311,21 @@ package Namet is V10 : Name_Id; V11 : Name_Id) return Boolean; + function Nam_In + (T : Name_Id; + V1 : Name_Id; + V2 : Name_Id; + V3 : Name_Id; + V4 : Name_Id; + V5 : Name_Id; + V6 : Name_Id; + V7 : Name_Id; + V8 : Name_Id; + V9 : Name_Id; + V10 : Name_Id; + V11 : Name_Id; + V12 : Name_Id) return Boolean; + pragma Inline (Nam_In); -- Inline all above functions diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index ec0080bbc43..142ac8eeadf 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -8963,10 +8963,12 @@ package body Sem_Ch13 is -- Expression to be analyzed at end of declarations Freeze_Expr : constant Node_Id := Expression (ASN); - -- Expression from call to Check_Aspect_At_Freeze_Point + -- Expression from call to Check_Aspect_At_Freeze_Point. We use - T : constant Entity_Id := Etype (Freeze_Expr); - -- Type required for preanalyze call + T : constant Entity_Id := Etype (Original_Node (Freeze_Expr)); + -- Type required for preanalyze call. We use the originsl + -- expression to get the proper type, to prevent cascaded errors + -- when the expression is constant-folded. Err : Boolean; -- Set False if error @@ -12681,6 +12683,9 @@ package body Sem_Ch13 is -- introduce a local identifier that would require proper expansion to -- handle properly. + -- In ASIS_Mode we preserve the entity in the source because there is + -- no subsequent expansion to decorate the tree. + ------------------ -- Resolve_Name -- ------------------ @@ -12698,7 +12703,10 @@ package body Sem_Ch13 is elsif Nkind (N) = N_Identifier and then Chars (N) /= Chars (E) then Find_Direct_Name (N); - Set_Entity (N, Empty); + + if not ASIS_Mode then + Set_Entity (N, Empty); + end if; elsif Nkind (N) = N_Quantified_Expression then return Skip; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index ab1e8c04fa9..24ac69fd923 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2178,6 +2178,10 @@ package body Sem_Ch3 is -- If the states have visible refinement, remove the visibility of each -- constituent at the end of the package body declaration. + procedure Resolve_Aspects; + -- Utility to resolve the expressions of aspects at the end of a list of + -- declarations. + ----------------- -- Adjust_Decl -- ----------------- @@ -2369,6 +2373,21 @@ package body Sem_Ch3 is end if; end Remove_Visible_Refinements; + --------------------- + -- Resolve_Aspects -- + --------------------- + + procedure Resolve_Aspects is + E : Entity_Id; + + begin + E := First_Entity (Current_Scope); + while Present (E) loop + Resolve_Aspect_Expressions (E); + Next_Entity (E); + end loop; + end Resolve_Aspects; + -- Local variables Context : Node_Id := Empty; @@ -2451,13 +2470,31 @@ package body Sem_Ch3 is and then not Is_Child_Unit (Current_Scope) and then No (Generic_Parent (Parent (L))) then - null; + -- This is needed in all cases to catch visibility errors in + -- aspect expressions, but several large user tests are now + -- rejected. Pending notification we restrict this call to + -- ASIS mode. + + if ASIS_Mode then + Resolve_Aspects; + end if; elsif L /= Visible_Declarations (Parent (L)) or else No (Private_Declarations (Parent (L))) or else Is_Empty_List (Private_Declarations (Parent (L))) then Adjust_Decl; + + -- In compilation mode the expansion of freeze node takes care + -- of resolving expressions of all aspects in the list. In ASIS + -- mode this must be done explicitly. + + if ASIS_Mode + and then Scope (Current_Scope) = Standard_Standard + then + Resolve_Aspects; + end if; + Freeze_All (First_Entity (Current_Scope), Decl); Freeze_From := Last_Entity (Current_Scope); @@ -2473,16 +2510,7 @@ package body Sem_Ch3 is -- pragmas do not appear in the original generic tree. elsif Serious_Errors_Detected = 0 then - declare - E : Entity_Id; - - begin - E := First_Entity (Current_Scope); - while Present (E) loop - Resolve_Aspect_Expressions (E); - Next_Entity (E); - end loop; - end; + Resolve_Aspects; end if; -- If next node is a body then freeze all types before the body.