diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 22 | ||||
| -rw-r--r-- | gcc/ada/inline.adb | 290 | ||||
| -rw-r--r-- | gcc/ada/namet.adb | 32 | ||||
| -rw-r--r-- | gcc/ada/namet.ads | 17 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 50 |
6 files changed, 269 insertions, 158 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 549ee1a..a0f6f81 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,27 @@ 2017-01-13 Yannick Moy <moy@adacore.com> + * 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 <schonberg@adacore.com> + + * 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 <moy@adacore.com> + * inline.adb, inline.ads (Call_Can_Be_Inlined_In_GNATprove_Mode): New function to detect when a call may be inlined or not in GNATprove mode. diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index bf0f705..7389105 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 520ce6a..1fdc37c 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 8806364..9c25b4f 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 ec0080b..142ac8e 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 ab1e8c0..24ac69f 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. |