diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 16 | ||||
| -rw-r--r-- | gcc/ada/sem_disp.adb | 28 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 23 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 3 |
5 files changed, 63 insertions, 13 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7c37bef..02ab369 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2016-04-19 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve_Entry_Call): If the entry has + preconditions it is rewritten by means of a wrapper that + incorporates the original call. Before rewriting generate a + reference to the entry being called to prevent spurious warnings + and provide correct cross-reference information. + +2016-04-19 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_disp.adb (Check_Dispatching_Context): Code cleanup. Add + local constant Scop. Ignore any internally generated loops when + performing the check concerning an abstract subprogram call + without a controlling argument. + * sem_util.ads, sem_util.adb (Current_Scope_No_Loops): New routine. + 2016-04-19 Bob Duff <duff@adacore.com> * sem_elab.adb (Check_A_Call): There are cases where we have No diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 2d9a746..4d8ef3f 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -510,7 +510,6 @@ package body Sem_Disp is procedure Check_Dispatching_Context (Call : Node_Id) is Subp : constant Entity_Id := Entity (Name (Call)); - Typ : constant Entity_Id := Etype (Subp); procedure Abstract_Context_Error; -- Error for abstract call dispatching on result is not dispatching @@ -530,14 +529,15 @@ package body Sem_Disp is else Error_Msg_N - ("call to abstract procedure must be dispatching", - N); + ("call to abstract procedure must be dispatching", N); end if; end Abstract_Context_Error; -- Local variables - Par : Node_Id; + Scop : constant Entity_Id := Current_Scope_No_Loops; + Typ : constant Entity_Id := Etype (Subp); + Par : Node_Id; -- Start of processing for Check_Dispatching_Context @@ -568,18 +568,20 @@ package body Sem_Disp is -- but will be legal in overridings of the operation. elsif In_Spec_Expression - and then (Is_Subprogram (Current_Scope) - or else Chars (Current_Scope) = Name_Postcondition) and then - ((Nkind (Parent (Current_Scope)) = N_Procedure_Specification - and then Null_Present (Parent (Current_Scope))) - or else Is_Abstract_Subprogram (Current_Scope)) + (Is_Subprogram (Scop) + or else Chars (Scop) = Name_Postcondition) + and then + (Is_Abstract_Subprogram (Scop) + or else + (Nkind (Parent (Scop)) = N_Procedure_Specification + and then Null_Present (Parent (Scop)))) then null; elsif Ekind (Current_Scope) = E_Function - and then Nkind (Unit_Declaration_Node (Current_Scope)) = - N_Generic_Subprogram_Declaration + and then Nkind (Unit_Declaration_Node (Scop)) = + N_Generic_Subprogram_Declaration then null; @@ -969,8 +971,8 @@ package body Sem_Disp is -- if the associated tagged type is already frozen. Has_Dispatching_Parent := - Present (Alias (Subp)) - and then Is_Dispatching_Operation (Alias (Subp)); + Present (Alias (Subp)) + and then Is_Dispatching_Operation (Alias (Subp)); if No (Tagged_Type) then diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 5a6d392..d6b9069 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -7614,6 +7614,12 @@ package body Sem_Res is and then Present (Contract_Wrapper (Nam)) and then Current_Scope /= Contract_Wrapper (Nam) then + + -- Note the entity being called before rewriting the call, so that + -- it appears used at this point. + + Generate_Reference (Nam, Entry_Name, 'r'); + -- Rewrite as call to the precondition wrapper, adding the task -- object to the list of actuals. If the call is to a member of an -- entry family, include the index as well. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index e57cd93..393ff73 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -5143,6 +5143,29 @@ package body Sem_Util is end if; end Current_Scope; + ---------------------------- + -- Current_Scope_No_Loops -- + ---------------------------- + + function Current_Scope_No_Loops return Entity_Id is + S : Entity_Id; + + begin + -- Examine the scope stack starting from the current scope and skip any + -- internally generated loops. + + S := Current_Scope; + while Present (S) and then S /= Standard_Standard loop + if Ekind (S) = E_Loop and then not Comes_From_Source (S) then + S := Scope (S); + else + exit; + end if; + end loop; + + return S; + end Current_Scope_No_Loops; + ------------------------ -- Current_Subprogram -- ------------------------ diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 494a9e4..df475cc 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -449,6 +449,9 @@ package Sem_Util is function Current_Scope return Entity_Id; -- Get entity representing current scope + function Current_Scope_No_Loops return Entity_Id; + -- Return the current scope ignoring internally generated loops + function Current_Subprogram return Entity_Id; -- Returns current enclosing subprogram. If Current_Scope is a subprogram, -- then that is what is returned, otherwise the Enclosing_Subprogram of the |