From 96df3ff4bd3b0f2ce63f519955f20f7d93612929 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 4 Jul 2016 12:09:04 +0200 Subject: [PATCH] [multiple changes] 2016-07-04 Bob Duff * xref_lib.adb (Parse_X_Filename, Parse_Identifier_Info): Ignore unknown files. Check that File_Nr is in the range of files we know about. The previous code was checking the lower bound, but not the upper bound. 2016-07-04 Arnaud Charlet * tracebak.c: Minor reformatting. 2016-07-04 Yannick Moy * sem_ch12.adb, sem_ch12.ads Update calls to Create_Instantiation_Source to use default argument. (Adjust_Inherited_Pragma_Sloc): New function to adjust sloc of inherited pragma. (Set_Copied_Sloc_For_Inherited_Pragma): New function that wraps call to Create_Instantiation_Source for copying an inherited pragma. (Set_Copied_Sloc_For_Inlined_Body): Update call to Create_Instantiation_Source with new arguments. * sem_prag.adb (Build_Pragma_Check_Equivalent): In the case of inherited pragmas, use the generic machinery to get chained locations for the pragma and its sub-expressions. * sinput-c.adb: Adapt to new type Source_File_Record. * sinput-l.adb, sinput-l.ads (Create_Instantiation_Source): Add parameter Inherited_Pragma and make parameter Inlined_Body optional. * sinput.adb, sinput.ads (Comes_From_Inherited_Pragma): New function to return when a location comes from an inherited pragma. (Inherited_Pragma): New function to detect when a location comes from an inherited pragma. (Source_File_Record): New component Inherited_Pragma. 2016-07-04 Yannick Moy * sem_elab.adb: Register existence of quickfix for error message. 2016-07-04 Ed Schonberg * sem_ch4.adb (Resolve_One_Call): In the context of a predicate function the formal and the actual in a call may have different views of the same type, because of the delayed analysis of predicates aspects. Extend the patch that handles this potential discrepancy to handle private and full views as well. * sem_ch8.adb (Find_Selected_Component): Refine predicate that produces additional error when an illegal selected component looks like a prefixed call whose first formal is untagged. From-SVN: r237963 --- gcc/ada/ChangeLog | 50 ++++++++++++++++++++++++++++++++++++++++++++ gcc/ada/freeze.adb | 6 ++++-- gcc/ada/sem_ch12.adb | 38 ++++++++++++++++++++++++++------- gcc/ada/sem_ch12.ads | 28 ++++++++++++++++++++++++- gcc/ada/sem_ch4.adb | 12 +++++++++-- gcc/ada/sem_ch8.adb | 6 +++--- gcc/ada/sem_elab.adb | 3 ++- gcc/ada/sem_prag.adb | 29 ++++++++++++++++++------- gcc/ada/sem_prag.ads | 21 ++++++++++++------- gcc/ada/sinput-c.adb | 3 ++- gcc/ada/sinput-l.adb | 27 +++++++++++++++--------- gcc/ada/sinput-l.ads | 19 ++++++++++------- gcc/ada/sinput.adb | 18 +++++++++++++++- gcc/ada/sinput.ads | 18 +++++++++++++++- gcc/ada/xref_lib.adb | 16 ++++++++++---- 15 files changed, 238 insertions(+), 56 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index bbd98c4229a..697352834df 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,53 @@ +2016-07-04 Bob Duff + + * xref_lib.adb (Parse_X_Filename, Parse_Identifier_Info): Ignore + unknown files. Check that File_Nr is in the range of files we + know about. The previous code was checking the lower bound, + but not the upper bound. + +2016-07-04 Arnaud Charlet + + * tracebak.c: Minor reformatting. + +2016-07-04 Yannick Moy + + * sem_ch12.adb, sem_ch12.ads Update calls to + Create_Instantiation_Source to use default argument. + (Adjust_Inherited_Pragma_Sloc): New function to adjust sloc + of inherited pragma. + (Set_Copied_Sloc_For_Inherited_Pragma): + New function that wraps call to Create_Instantiation_Source for + copying an inherited pragma. + (Set_Copied_Sloc_For_Inlined_Body): Update call to + Create_Instantiation_Source with new arguments. + * sem_prag.adb (Build_Pragma_Check_Equivalent): In the case + of inherited pragmas, use the generic machinery to get chained + locations for the pragma and its sub-expressions. + * sinput-c.adb: Adapt to new type Source_File_Record. + * sinput-l.adb, sinput-l.ads (Create_Instantiation_Source): + Add parameter Inherited_Pragma and make parameter Inlined_Body + optional. + * sinput.adb, sinput.ads (Comes_From_Inherited_Pragma): New + function to return when a location comes from an inherited pragma. + (Inherited_Pragma): New function to detect when a location comes + from an inherited pragma. + (Source_File_Record): New component Inherited_Pragma. + +2016-07-04 Yannick Moy + + * sem_elab.adb: Register existence of quickfix for error message. + +2016-07-04 Ed Schonberg + + * sem_ch4.adb (Resolve_One_Call): In the context of a predicate + function the formal and the actual in a call may have different + views of the same type, because of the delayed analysis of + predicates aspects. Extend the patch that handles this potential + discrepancy to handle private and full views as well. + * sem_ch8.adb (Find_Selected_Component): Refine predicate that + produces additional error when an illegal selected component + looks like a prefixed call whose first formal is untagged. + 2016-07-04 Justin Squirek * einfo.adb (Has_Pragma_Unused): Create this function as a setter diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 6596d53371a..3850ca5371e 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1440,13 +1440,15 @@ package body Freeze is A_Pre := Find_Aspect (Par_Prim, Aspect_Pre); if Present (A_Pre) and then Class_Present (A_Pre) then - Build_Classwide_Expression (Expression (A_Pre), Prim); + Build_Classwide_Expression (Expression (A_Pre), Prim, + Adjust_Sloc => False); end if; A_Post := Find_Aspect (Par_Prim, Aspect_Post); if Present (A_Post) and then Class_Present (A_Post) then - Build_Classwide_Expression (Expression (A_Post), Prim); + Build_Classwide_Expression (Expression (A_Post), Prim, + Adjust_Sloc => False); end if; end if; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index f62c30f1aec..8e38db0280b 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -1052,6 +1052,15 @@ package body Sem_Ch12 is SPARK_Mode_Pragma => SPARK_Mode_Pragma)); end Add_Pending_Instantiation; + ---------------------------------- + -- Adjust_Inherited_Pragma_Sloc -- + ---------------------------------- + + procedure Adjust_Inherited_Pragma_Sloc (N : Node_Id) is + begin + Adjust_Instantiation_Sloc (N, S_Adjustment); + end Adjust_Inherited_Pragma_Sloc; + -------------------------- -- Analyze_Associations -- -------------------------- @@ -2641,7 +2650,7 @@ package body Sem_Ch12 is end if; Formal := New_Copy (Pack_Id); - Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment); + Create_Instantiation_Source (N, Gen_Unit, S_Adjustment); -- Make local generic without formals. The formals will be replaced with -- internal declarations. @@ -3786,7 +3795,7 @@ package body Sem_Ch12 is -- validate an actual package, the instantiation environment is that -- of the enclosing instance. - Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment); + Create_Instantiation_Source (N, Gen_Unit, S_Adjustment); -- Copy original generic tree, to produce text for instantiation @@ -5138,7 +5147,7 @@ package body Sem_Ch12 is Generic_Renamings.Set_Last (0); Generic_Renamings_HTable.Reset; - Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment); + Create_Instantiation_Source (N, Gen_Unit, S_Adjustment); -- Copy original generic tree, to produce text for instantiation @@ -7646,7 +7655,6 @@ package body Sem_Ch12 is Create_Instantiation_Source (Instantiation_Node, Defining_Entity (N), - False, S_Adjustment); end if; @@ -10888,7 +10896,7 @@ package body Sem_Ch12 is Gen_Body := Unit_Declaration_Node (Gen_Body_Id); Create_Instantiation_Source - (Inst_Node, Gen_Body_Id, False, S_Adjustment); + (Inst_Node, Gen_Body_Id, S_Adjustment); Act_Body := Copy_Generic_Node @@ -11229,7 +11237,6 @@ package body Sem_Ch12 is Create_Instantiation_Source (Inst_Node, Gen_Body_Id, - False, S_Adjustment); Act_Body := @@ -15139,13 +15146,30 @@ package body Sem_Ch12 is end loop; end Save_Global_References_In_Aspects; + ------------------------------------------ + -- Set_Copied_Sloc_For_Inherited_Pragma -- + ------------------------------------------ + + procedure Set_Copied_Sloc_For_Inherited_Pragma + (N : Node_Id; + E : Entity_Id) is + begin + Create_Instantiation_Source (N, E, + Inlined_Body => False, + Inherited_Pragma => True, + A => S_Adjustment); + end Set_Copied_Sloc_For_Inherited_Pragma; + -------------------------------------- -- Set_Copied_Sloc_For_Inlined_Body -- -------------------------------------- procedure Set_Copied_Sloc_For_Inlined_Body (N : Node_Id; E : Entity_Id) is begin - Create_Instantiation_Source (N, E, True, S_Adjustment); + Create_Instantiation_Source (N, E, + Inlined_Body => True, + Inherited_Pragma => False, + A => S_Adjustment); end Set_Copied_Sloc_For_Inlined_Body; --------------------- diff --git a/gcc/ada/sem_ch12.ads b/gcc/ada/sem_ch12.ads index c95396a35e6..8365ac482c3 100644 --- a/gcc/ada/sem_ch12.ads +++ b/gcc/ada/sem_ch12.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- -- @@ -172,6 +172,32 @@ package Sem_Ch12 is -- saved as part of the internal state of the Sem_Ch12 package for use -- in subsequent calls to copy nodes. + procedure Set_Copied_Sloc_For_Inherited_Pragma + (N : Node_Id; + E : Entity_Id); + -- This procedure is used when a class-wide pre- or postcondition is + -- inherited. This process shares the same circuitry as the creation of + -- an instantiated copy of a generic template. The call to this procedure + -- establishes a new source file entry representing the inherited pragma + -- as an instantiation, marked as an inherited pragma (so that errout can + -- distinguish cases for generating error messages, otherwise the treatment + -- is identical). In this call N is the subprogram declaration from + -- which the pragma is inherited and E is the defining identifier of + -- the overridding subprogram (when the subprogram is redefined) or the + -- defining identifier of the extension type (when the subprogram is + -- inherited). The resulting Sloc adjustment factor is saved as part of the + -- internal state of the Sem_Ch12 package for use in subsequent calls to + -- copy nodes. + + procedure Adjust_Inherited_Pragma_Sloc (N : Node_Id); + -- This procedure is used when a class-wide pre- or postcondition + -- is inherited. It is called on each node of the pragma expression + -- to adjust its sloc. These call should be preceded by a call to + -- Set_Copied_Sloc_For_Inherited_Pragma that sets the required sloc + -- adjustment. This is done directly, instead of using Copy_Generic_Node + -- to copy nodes and adjust slocs, as Copy_Generic_Node expects a specific + -- structure to be in place, which is not the case for inherited pragmas. + procedure Save_Env (Gen_Unit : Entity_Id; Act_Unit : Entity_Id); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 66a2acf6ca0..6b1e5de63b9 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -3413,9 +3413,17 @@ package body Sem_Ch4 is -- an incomplete type, while resolution of the corresponding -- predicate function may see the full view, as a consequence -- of the delayed resolution of the corresponding expressions. + -- This can occur in the body of a predicate function, or in + -- a call to such. - elsif Ekind (Etype (Formal)) = E_Incomplete_Type - and then Full_View (Etype (Formal)) = Etype (Actual) + elsif ((Ekind (Current_Scope) = E_Function + and then Is_Predicate_Function (Current_Scope)) + or else (Ekind (Nam) = E_Function + and then Is_Predicate_Function (Nam))) + and then + (Base_Type (Underlying_Type (Etype (Formal))) = + Base_Type (Underlying_Type (Etype (Actual)))) + and then Serious_Errors_Detected = 0 then Set_Etype (Formal, Etype (Actual)); Next_Actual (Actual); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 0f43ecf4d75..e4aa9084300 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -6983,7 +6983,8 @@ package body Sem_Ch8 is elsif Nkind (P) /= N_Attribute_Reference then -- This may have been meant as a prefixed call to a primitive - -- of an untagged type. + -- of an untagged type. If it is a function call check type of + -- its first formal and add explanation. declare F : constant Entity_Id := @@ -6992,8 +6993,7 @@ package body Sem_Ch8 is if Present (F) and then Is_Overloadable (F) and then Present (First_Entity (F)) - and then Etype (First_Entity (F)) = Etype (P) - and then not Is_Tagged_Type (Etype (P)) + and then not Is_Tagged_Type (Etype (First_Entity (F))) then Error_Msg_N ("prefixed call is only allowed for objects " diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 1b3015aaf42..d963def7980 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -1097,7 +1097,8 @@ package body Sem_Elab is -- is an error, so give an error message. if Issue_In_SPARK then - Error_Msg_NE ("\Elaborate_All pragma required for&", N, W_Scope); + Error_Msg_NE -- CODEFIX + ("\Elaborate_All pragma required for&", N, W_Scope); -- Otherwise we generate an implicit pragma. For a subprogram -- instantiation, Elaborate is good enough, since no transitive diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 999ae352de4..8cda6c75bb2 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -26395,7 +26395,11 @@ package body Sem_Prag is -- Build_Classwide_Expression -- -------------------------------- - procedure Build_Classwide_Expression (Prag : Node_Id; Subp : Entity_Id) is + procedure Build_Classwide_Expression + (Prag : Node_Id; + Subp : Entity_Id; + Adjust_Sloc : Boolean) + is function Replace_Entity (N : Node_Id) return Traverse_Result; -- Replace reference to formal of inherited operation or to primitive -- operation of root type, with corresponding entity for derived type, @@ -26410,6 +26414,10 @@ package body Sem_Prag is New_E : Entity_Id; begin + if Adjust_Sloc then + Adjust_Inherited_Pragma_Sloc (N); + end if; + if Nkind (N) = N_Identifier and then Present (Entity (N)) and then @@ -26576,15 +26584,22 @@ package body Sem_Prag is Next_Formal (Inher_Formal); Next_Formal (Subp_Formal); end loop; - end if; - -- Copy the original pragma while performing substitutions (if - -- applicable). + -- Use generic machinery to copy inherited pragma, as if it were an + -- instantiation, resetting source locations appropriately, so that + -- expressions inside the inherited pragma use chained locations. + -- This is used in particular in GNATprove to locate precisely + -- messages on a given inherited pragma. - Check_Prag := New_Copy_Tree (Source => Prag); + Set_Copied_Sloc_For_Inherited_Pragma + (Unit_Declaration_Node (Subp_Id), Inher_Id); + Check_Prag := New_Copy_Tree (Source => Prag); + Build_Classwide_Expression (Check_Prag, Subp_Id, Adjust_Sloc => True); - if Present (Inher_Id) then - Build_Classwide_Expression (Check_Prag, Subp_Id); + -- Otherwise simply copy the original pragma + + else + Check_Prag := New_Copy_Tree (Source => Prag); end if; -- Mark the pragma as being internally generated and reset the Analyzed diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads index db7bcbb8b85..9a951ffe247 100644 --- a/gcc/ada/sem_prag.ads +++ b/gcc/ada/sem_prag.ads @@ -244,16 +244,21 @@ package Sem_Prag is procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id); -- Perform preanalysis of pragma Test_Case - procedure Build_Classwide_Expression (Prag : Node_Id; Subp : Entity_Id); + procedure Build_Classwide_Expression + (Prag : Node_Id; + Subp : Entity_Id; + Adjust_Sloc : Boolean); -- Build the expression for an inherited classwide condition. Prag is -- the pragma constructed from the corresponding aspect of the parent - -- subprogram, and Subp is the overridding operation. - -- The routine is also called to check whether an inherited operation - -- that is not overridden but has inherited conditions need a wrapper, - -- because the inherited condition includes calls to other primitives that - -- have been overridden. In that case the first argument is the expression - -- of the original classwide aspect. In SPARK_Mode, such operation which - -- are just inherited but have modified pre/postconditions are illegal. + -- subprogram, and Subp is the overridding operation. Adjust_Sloc is True + -- when the sloc of nodes traversed should be adjusted for the inherited + -- pragma. The routine is also called to check whether an inherited + -- operation that is not overridden but has inherited conditions need + -- a wrapper, because the inherited condition includes calls to other + -- primitives that have been overridden. In that case the first argument + -- is the expression of the original classwide aspect. In SPARK_Mode, such + -- operation which are just inherited but have modified pre/postconditions + -- are illegal. function Build_Pragma_Check_Equivalent (Prag : Node_Id; diff --git a/gcc/ada/sinput-c.adb b/gcc/ada/sinput-c.adb index 6c3d58254fe..3ef0f5af35b 100644 --- a/gcc/ada/sinput-c.adb +++ b/gcc/ada/sinput-c.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, 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- -- @@ -183,6 +183,7 @@ package body Sinput.C is Identifier_Casing => Unknown, Inlined_Call => No_Location, Inlined_Body => False, + Inherited_Pragma => False, Keyword_Casing => Unknown, Last_Source_Line => 1, License => Unknown, diff --git a/gcc/ada/sinput-l.adb b/gcc/ada/sinput-l.adb index c084555cd93..32c2ac2e835 100644 --- a/gcc/ada/sinput-l.adb +++ b/gcc/ada/sinput-l.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, 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- -- @@ -121,10 +121,11 @@ package body Sinput.L is --------------------------------- procedure Create_Instantiation_Source - (Inst_Node : Entity_Id; - Template_Id : Entity_Id; - Inlined_Body : Boolean; - A : out Sloc_Adjustment) + (Inst_Node : Entity_Id; + Template_Id : Entity_Id; + A : out Sloc_Adjustment; + Inlined_Body : Boolean := False; + Inherited_Pragma : Boolean := False) is Dnod : constant Node_Id := Declaration_Node (Template_Id); Xold : Source_File_Index; @@ -145,16 +146,21 @@ package body Sinput.L is Inst_Spec : Node_Id; begin - Snew.Inlined_Body := Inlined_Body; - Snew.Template := Xold; + Snew.Inlined_Body := Inlined_Body; + Snew.Inherited_Pragma := Inherited_Pragma; + Snew.Template := Xold; - -- For a genuine generic instantiation, assign new instance id. - -- For inlined bodies, we retain that of the template, but we - -- save the call location. + -- For a genuine generic instantiation, assign new instance id. For + -- inlined bodies, we retain that of the template, but we save the + -- call location. For inherited pragmas, we simply retain that of + -- the template. if Inlined_Body then Snew.Inlined_Call := Sloc (Inst_Node); + elsif Inherited_Pragma then + null; + else -- If the spec has been instantiated already, and we are now -- creating the instance source for the corresponding body now, @@ -509,6 +515,7 @@ package body Sinput.L is Identifier_Casing => Unknown, Inlined_Call => No_Location, Inlined_Body => False, + Inherited_Pragma => False, Keyword_Casing => Unknown, Last_Source_Line => 1, License => Unknown, diff --git a/gcc/ada/sinput-l.ads b/gcc/ada/sinput-l.ads index 9cb29482f61..1b0aacbe988 100644 --- a/gcc/ada/sinput-l.ads +++ b/gcc/ada/sinput-l.ads @@ -83,19 +83,22 @@ package Sinput.L is -- calls to Adjust_Instantiation_Sloc. procedure Create_Instantiation_Source - (Inst_Node : Entity_Id; - Template_Id : Entity_Id; - Inlined_Body : Boolean; - A : out Sloc_Adjustment); + (Inst_Node : Entity_Id; + Template_Id : Entity_Id; + A : out Sloc_Adjustment; + Inlined_Body : Boolean := False; + Inherited_Pragma : Boolean := False); -- This procedure creates the source table entry for an instantiation. -- Inst_Node is the instantiation node, and Template_Id is the defining -- identifier of the generic declaration or body unit as appropriate. -- A is set to an adjustment factor to be used in subsequent calls to -- Adjust_Instantiation_Sloc. The instantiation mechanism is also used - -- for inlined function and procedure calls. The parameter Inlined_Body - -- is set to True in such cases, and False for a generic instantiation. - -- This is used for generating error messages that distinguish these - -- two cases, otherwise the two cases are handled identically. + -- for inlined function and procedure calls. The parameter Inlined_Body is + -- set to True in such cases. This is used for generating error messages + -- that distinguish these two cases, otherwise the two cases are handled + -- identically. Similarly, the instantiation mechanism is also used + -- for inherited class-wide pre- and postconditions. The parameter + -- Inherited_Pragma is set to True in such cases. procedure Adjust_Instantiation_Sloc (N : Node_Id; A : Sloc_Adjustment); -- The instantiation tree is created by copying the tree of the generic diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb index 0800f3196a6..0105b2c4618 100644 --- a/gcc/ada/sinput.adb +++ b/gcc/ada/sinput.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- -- @@ -300,6 +300,17 @@ package body Sinput is end case; end Check_For_BOM; + --------------------------------- + -- Comes_From_Inherited_Pragma -- + --------------------------------- + + function Comes_From_Inherited_Pragma (S : Source_Ptr) return Boolean is + SIE : Source_File_Record renames + Source_File.Table (Get_Source_File_Index (S)); + begin + return SIE.Inherited_Pragma; + end Comes_From_Inherited_Pragma; + ----------------------------- -- Comes_From_Inlined_Body -- ----------------------------- @@ -1190,6 +1201,11 @@ package body Sinput is return Source_File.Table (S).Identifier_Casing; end Identifier_Casing; + function Inherited_Pragma (S : SFI) return Boolean is + begin + return Source_File.Table (S).Inherited_Pragma; + end Inherited_Pragma; + function Inlined_Body (S : SFI) return Boolean is begin return Source_File.Table (S).Inlined_Body; diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads index 24f1a68cf31..21f16f20174 100644 --- a/gcc/ada/sinput.ads +++ b/gcc/ada/sinput.ads @@ -269,6 +269,11 @@ package Sinput is -- an instance of an inlined body. -- ??? Redundant, always equal to (Inlined_Call /= No_Location) + -- Inherited_Pragma : Boolean; + -- This can only be set True if Instantiation has a value other than + -- No_Location. If true it indicates that the instantiation is actually + -- an inherited class-wide pre- or postcondition. + -- Template : Source_File_Index; (read-only) -- Source file index of the source file containing the template if this -- is a generic instantiation. Set to No_Source_File for the normal case @@ -298,6 +303,7 @@ package Sinput is function Full_Ref_Name (S : SFI) return File_Name_Type; function Identifier_Casing (S : SFI) return Casing_Type; function Inlined_Body (S : SFI) return Boolean; + function Inherited_Pragma (S : SFI) return Boolean; function Inlined_Call (S : SFI) return Source_Ptr; function Instance (S : SFI) return Instance_Id; function Keyword_Casing (S : SFI) return Casing_Type; @@ -644,6 +650,13 @@ package Sinput is -- from instantiation of generics, since Instantiation_Location returns a -- valid location in both cases. + function Comes_From_Inherited_Pragma (S : Source_Ptr) return Boolean; + pragma Inline (Comes_From_Inherited_Pragma); + -- Given a source pointer S, returns whether it comes from an inherited + -- pragma. This allows distinguishing these source pointers from those + -- that come from instantiation of generics, since Instantiation_Location + -- returns a valid location in both cases. + function Top_Level_Location (S : Source_Ptr) return Source_Ptr; -- Given a source pointer S, returns the argument unchanged if it is -- not in an instantiation. If S is in an instantiation, then it returns @@ -759,6 +772,7 @@ private pragma Inline (Identifier_Casing); pragma Inline (Inlined_Call); pragma Inline (Inlined_Body); + pragma Inline (Inherited_Pragma); pragma Inline (Template); pragma Inline (Unit); @@ -824,6 +838,7 @@ private File_Type : Type_Of_File; Inlined_Call : Source_Ptr; Inlined_Body : Boolean; + Inherited_Pragma : Boolean; License : License_Type; Keyword_Casing : Casing_Type; Identifier_Casing : Casing_Type; @@ -881,7 +896,8 @@ private Time_Stamp at 60 range 0 .. 8 * Time_Stamp_Length - 1; File_Type at 74 range 0 .. 7; Inlined_Call at 88 range 0 .. 31; - Inlined_Body at 75 range 0 .. 7; + Inlined_Body at 75 range 0 .. 0; + Inherited_Pragma at 75 range 1 .. 1; License at 76 range 0 .. 7; Keyword_Casing at 77 range 0 .. 7; Identifier_Casing at 78 range 0 .. 15; diff --git a/gcc/ada/xref_lib.adb b/gcc/ada/xref_lib.adb index 2afec821079..7cb7f105d56 100644 --- a/gcc/ada/xref_lib.adb +++ b/gcc/ada/xref_lib.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. -- -- -- -- 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- -- @@ -890,8 +890,12 @@ package body Xref_Lib is Parse_Token (Ali, Ptr, E_Name); - -- Exit if the symbol does not match - -- or if we have a local symbol and we do not want it + -- Exit if the symbol does not match or if we have a local + -- symbol and we do not want it or if the file is unknown. + + if File.X_File = Empty_File then + return; + end if; if (not Local_Symbols and not E_Global) or else (Pattern.Initialized @@ -1261,8 +1265,12 @@ package body Xref_Lib is Ptr := Ptr + 1; Parse_Number (Ali, Ptr, File_Nr); - if File_Nr > 0 then + -- If the referenced file is unknown, we simply ignore it + + if File_Nr in Dependencies_Tables.First .. Last (File.Dep) then File.X_File := File.Dep.Table (File_Nr); + else + File.X_File := Empty_File; end if; Parse_EOL (Ali, Ptr);