From 2a253c5bba9ecf4f09242253bf8efd05c9cce9de Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 27 Apr 2016 12:58:41 +0200 Subject: [PATCH] [multiple changes] 2016-04-27 Hristian Kirtchev * sem_elab.adb (Check_Internal_Call): Do not consider a call when it appears within pragma Initial_Condition since the pragma is part of the elaboration statements of a package body and may only call external subprograms or subprograms whose body is already available. (Within_Initial_Condition): New routine. 2016-04-27 Ed Schonberg * exp_util.adb (Build_Procedure_Form): Prevent double generation of the procedure form when dealing with an expression function whose return type is an array. * sem_ch3.adb: Fix out-of order Has_Predicates setting. * exp_ch6.adb: Proper conversion for inherited operation in C. * sem_ch6.adb: Code cleanup. 2016-04-27 Hristian Kirtchev * lib-xref.ads, sem_ch10.adb: minor style fix in comment * g-socket.adb: Minor reformatting. * sinfo.ads: Minor comment correction. * sem_warn.ads: minor grammar fix in comment From-SVN: r235482 --- gcc/ada/ChangeLog | 25 +++++++++++ gcc/ada/exp_ch6.adb | 5 ++- gcc/ada/exp_util.adb | 12 ++++- gcc/ada/g-socket.adb | 7 ++- gcc/ada/lib-xref.ads | 4 +- gcc/ada/sem_ch10.adb | 2 +- gcc/ada/sem_ch3.adb | 4 +- gcc/ada/sem_ch6.adb | 4 +- gcc/ada/sem_elab.adb | 101 ++++++++++++++++++++++++++++++++++++------- gcc/ada/sem_warn.ads | 4 +- gcc/ada/sinfo.ads | 4 +- 11 files changed, 141 insertions(+), 31 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 8d418bf89b9..8971b75a27a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,28 @@ +2016-04-27 Hristian Kirtchev + + * sem_elab.adb (Check_Internal_Call): Do not + consider a call when it appears within pragma Initial_Condition + since the pragma is part of the elaboration statements of a + package body and may only call external subprograms or subprograms + whose body is already available. + (Within_Initial_Condition): New routine. + +2016-04-27 Ed Schonberg + + * exp_util.adb (Build_Procedure_Form): Prevent double generation + of the procedure form when dealing with an expression function + whose return type is an array. + * sem_ch3.adb: Fix out-of order Has_Predicates setting. + * exp_ch6.adb: Proper conversion for inherited operation in C. + * sem_ch6.adb: Code cleanup. + +2016-04-27 Hristian Kirtchev + + * lib-xref.ads, sem_ch10.adb: minor style fix in comment + * g-socket.adb: Minor reformatting. + * sinfo.ads: Minor comment correction. + * sem_warn.ads: minor grammar fix in comment + 2016-04-27 Eric Botcazou * gcc-interface/gigi.h (gnat_to_gnu_entity): Adjust prototype. diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 613f2b42ab6..4e996a16411 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -8477,7 +8477,10 @@ package body Exp_Ch6 is if not Comes_From_Source (Orig_Func) and then Etype (Orig_Func) /= Etype (Func_Id) then - Last_Actual := Unchecked_Convert_To (Etype (Func_Id), Last_Actual); + Last_Actual := + Make_Type_Conversion (Loc, + New_Occurrence_Of (Etype (Func_Id), Loc), + Last_Actual); end if; Append_To (Actuals, diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 190a1dcd6b0..6090ab93b7d 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -932,8 +932,8 @@ package body Exp_Util is Proc_Decl : Node_Id; begin - -- No action needed if this transformation was already done or in case - -- of subprogram renaming declarations + -- No action needed if this transformation was already done, or in case + -- of subprogram renaming declarations. if Nkind (Specification (N)) = N_Procedure_Specification or else Nkind (N) = N_Subprogram_Renaming_Declaration @@ -941,6 +941,14 @@ package body Exp_Util is return; end if; + -- Ditto when dealing with an expression function, where both the + -- original expression and the generated declaration end up being + -- expanded here. + + if Rewritten_For_C (Subp) then + return; + end if; + Proc_Formals := New_List; -- Create a list of formal parameters with the same types as the diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index 477150de573..6a61a810e39 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -1703,9 +1703,12 @@ package body GNAT.Sockets is procedure Raise_Host_Error (H_Error : Integer; Name : String) is function Dedot (Value : String) return String is - (if Value /= "" and then Value (Value'Last) = '.' - then Value (Value'First .. Value'Last - 1) else Value); + (if Value /= "" and then Value (Value'Last) = '.' then + Value (Value'First .. Value'Last - 1) + else + Value); -- Removes dot at the end of error message + begin raise Host_Error with Err_Code_Image (H_Error) diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads index 33e20ee2ae2..4b5edb8eda7 100644 --- a/gcc/ada/lib-xref.ads +++ b/gcc/ada/lib-xref.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2015, 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- -- @@ -611,7 +611,7 @@ package Lib.Xref is Table_Name => "Name_Deferred_References"); procedure Process_Deferred_References; - -- This procedure is called from Frontend to process these table entries. + -- This procedure is called from Frontend to process these table entries ----------------------------- -- SPARK Xrefs Information -- diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index c872abed6ae..9855c9e818e 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -693,7 +693,7 @@ package body Sem_Ch10 is if Nkind (Unit_Node) = N_Package_Body then -- If no Lib_Unit, then there was a serious previous error, so just - -- ignore the entire analysis effort + -- ignore the entire analysis effort. if No (Lib_Unit) then Check_Error_Detected; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index bbb10ac4edf..63704fba139 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -20057,11 +20057,11 @@ package body Sem_Ch3 is -- built. Still it is a cheap check and seems safer to make it. if Has_Predicates (Priv_T) then + Set_Has_Predicates (Full_T); + if Present (Predicate_Function (Priv_T)) then Set_Predicate_Function (Full_T, Predicate_Function (Priv_T)); end if; - - Set_Has_Predicates (Full_T); end if; end Process_Full_View; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 6c5e56a666c..a6f22b1744b 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -3306,12 +3306,14 @@ package body Sem_Ch6 is -- has already been created. We reuse the source body of the function, -- because in an instance it may contain global references that cannot -- be reanalyzed. The source function itself is not used any further, - -- so we mark it as having a completion. + -- so we mark it as having a completion. If the subprogram is a stub the + -- transformation is done later, when the proper body is analyzed. if Expander_Active and then Modify_Tree_For_C and then Present (Spec_Id) and then Ekind (Spec_Id) = E_Function + and then Nkind (N) /= N_Subprogram_Body_Stub and then Rewritten_For_C (Spec_Id) then Set_Has_Completion (Spec_Id); diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index bdc88c148d6..2b2747e02c0 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-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- -- @@ -91,16 +91,16 @@ package body Sem_Elab is Table_Increment => 100, Table_Name => "Elab_Visited"); - -- This table stores calls to Check_Internal_Call that are delayed - -- until all generics are instantiated, and in particular that all - -- generic bodies have been inserted. We need to delay, because we - -- need to be able to look through the inserted bodies. + -- This table stores calls to Check_Internal_Call that are delayed until + -- all generics are instantiated and in particular until after all generic + -- bodies have been inserted. We need to delay, because we need to be able + -- to look through the inserted bodies. type Delay_Element is record N : Node_Id; - -- The parameter N from the call to Check_Internal_Call. Note that - -- this node may get rewritten over the delay period by expansion - -- in the call case (but not in the instantiation case). + -- The parameter N from the call to Check_Internal_Call. Note that this + -- node may get rewritten over the delay period by expansion in the call + -- case (but not in the instantiation case). E : Entity_Id; -- The parameter E from the call to Check_Internal_Call @@ -109,8 +109,8 @@ package body Sem_Elab is -- The parameter Orig_Ent from the call to Check_Internal_Call Curscop : Entity_Id; - -- The current scope of the call. This is restored when we complete - -- the delayed call, so that we do this in the right scope. + -- The current scope of the call. This is restored when we complete the + -- delayed call, so that we do this in the right scope. From_Elab_Code : Boolean; -- Save indication of whether this call is from elaboration code @@ -2032,24 +2032,85 @@ package body Sem_Elab is Outer_Scope : Entity_Id; Orig_Ent : Entity_Id) is + function Within_Initial_Condition (Call : Node_Id) return Boolean; + -- Determine whether call Call occurs within pragma Initial_Condition or + -- pragma Check with check_kind set to Initial_Condition. + + ------------------------------ + -- Within_Initial_Condition -- + ------------------------------ + + function Within_Initial_Condition (Call : Node_Id) return Boolean is + Args : List_Id; + Nam : Name_Id; + Par : Node_Id; + + begin + -- Traverse the parent chain looking for an enclosing pragma + + Par := Call; + while Present (Par) loop + if Nkind (Par) = N_Pragma then + Nam := Pragma_Name (Par); + + -- Pragma Initial_Condition appears in its alternative from as + -- Check (Initial_Condition, ...). + + if Nam = Name_Check then + Args := Pragma_Argument_Associations (Par); + + -- Pragma Check should have at least two arguments + + pragma Assert (Present (Args)); + + return + Chars (Expression (First (Args))) = Name_Initial_Condition; + + -- Direct match + + elsif Nam = Name_Initial_Condition then + return True; + + -- Since pragmas are never nested within other pragmas, stop + -- the traversal. + + else + return False; + end if; + + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (Par) then + exit; + end if; + + Par := Parent (Par); + end loop; + + return False; + end Within_Initial_Condition; + + -- Local variables + Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; + -- Start of processing for Check_Internal_Call + begin -- For P'Access, we want to warn if the -gnatw.f switch is set, and the -- node comes from source. - if Nkind (N) = N_Attribute_Reference and then - (not Warn_On_Elab_Access or else not Comes_From_Source (N)) + if Nkind (N) = N_Attribute_Reference + and then (not Warn_On_Elab_Access or else not Comes_From_Source (N)) then return; -- If not function or procedure call, instantiation, or 'Access, then -- ignore call (this happens in some error cases and rewriting cases). - elsif not Nkind_In - (N, N_Function_Call, - N_Procedure_Call_Statement, - N_Attribute_Reference) + elsif not Nkind_In (N, N_Attribute_Reference, + N_Function_Call, + N_Procedure_Call_Statement) and then not Inst_Case then return; @@ -2091,6 +2152,14 @@ package body Sem_Elab is elsif Inside_A_Generic then return; + + -- Nothing to do when the call appears within pragma Initial_Condition. + -- The pragma is part of the elaboration statements of a package body + -- and may only call external subprograms or subprograms whose body is + -- already available. + + elsif Within_Initial_Condition (N) then + return; end if; -- Delay this call if we are still delaying calls diff --git a/gcc/ada/sem_warn.ads b/gcc/ada/sem_warn.ads index b1f2af22da1..cd71e3466b8 100644 --- a/gcc/ada/sem_warn.ads +++ b/gcc/ada/sem_warn.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-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- -- @@ -238,7 +238,7 @@ package Sem_Warn is -- should only be made if at least one of the flags Warn_On_Modified_Unread -- or Warn_On_All_Unread_Out_Parameters is True, and if Ent is in the -- extended main source unit. N is Empty for the end of block call - -- (warning message says value unreferenced), or the it is the node for + -- (warning message says value unreferenced), or it is the node for -- an overwriting assignment (warning message points to this assignment). procedure Warn_On_Useless_Assignments (E : Entity_Id); diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 561c112bebe..d27cb734fe2 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.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- -- @@ -2754,7 +2754,7 @@ package Sinfo is -- Note: aliased is not permitted in Ada 83 mode - -- The N_Object_Declaration node is only for the first two cases. + -- The N_Object_Declaration node is only for the first three cases. -- Single task declaration is handled by P_Task (9.1) -- Single protected declaration is handled by P_protected (9.5)