From: Ed Schonberg Date: Tue, 25 Apr 2017 09:36:51 +0000 (+0000) Subject: sem_ch3.adb (Check_Entry_Contract): Call Preanalyze_Spec_Expression so that resolutio... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=0c85534d6f996d7ef5430c77b0e508ddc6f130ef;p=gcc.git sem_ch3.adb (Check_Entry_Contract): Call Preanalyze_Spec_Expression so that resolution takes place as well. 2017-04-25 Ed Schonberg * sem_ch3.adb (Check_Entry_Contract): Call Preanalyze_Spec_Expression so that resolution takes place as well. * sem_util.adb (Check_Internal_Protected_Use): Reject properly internal calls that appear in preconditions of protected operations, in default values for same, and in contract guards for contract cases in SPARK. From-SVN: r247163 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c3a8ba48598..b856420480a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2017-04-25 Ed Schonberg + + * sem_ch3.adb (Check_Entry_Contract): Call + Preanalyze_Spec_Expression so that resolution takes place as well. + * sem_util.adb (Check_Internal_Protected_Use): Reject properly + internal calls that appear in preconditions of protected + operations, in default values for same, and in contract guards + for contract cases in SPARK. + 2017-04-25 Eric Botcazou * a-numaux.ads: Fix description of a-numaux-darwin diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 6b8a4535313..26e531dd7f8 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2326,9 +2326,7 @@ package body Sem_Ch3 is (First (Pragma_Argument_Associations (ASN)))); Set_Parent (Exp, ASN); - -- ??? why not Preanalyze_Assert_Expression - - Preanalyze (Exp); + Preanalyze_Assert_Expression (Exp, Standard_Boolean); end if; ASN := Next_Pragma (ASN); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index ff3ee6e17b0..f9477ab8564 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2834,10 +2834,12 @@ package body Sem_Util is Prot : Entity_Id; begin + Prot := Empty; + S := Current_Scope; while Present (S) loop if S = Standard_Standard then - return; + exit; elsif Ekind (S) = E_Function and then Ekind (Scope (S)) = E_Protected_Type @@ -2849,28 +2851,30 @@ package body Sem_Util is S := Scope (S); end loop; - if Scope (Nam) = Prot and then Ekind (Nam) /= E_Function then - + if Present (Prot) + and then Scope (Nam) = Prot + and then Ekind (Nam) /= E_Function + then -- An indirect function call (e.g. a callback within a protected -- function body) is not statically illegal. If the access type is -- anonymous and is the type of an access parameter, the scope of Nam -- will be the protected type, but it is not a protected operation. if Ekind (Nam) = E_Subprogram_Type - and then - Nkind (Associated_Node_For_Itype (Nam)) = N_Function_Specification + and then Nkind (Associated_Node_For_Itype (Nam)) = + N_Function_Specification then null; elsif Nkind (N) = N_Subprogram_Renaming_Declaration then Error_Msg_N - ("within protected function cannot use protected " - & "procedure in renaming or as generic actual", N); + ("within protected function cannot use protected procedure in " + & "renaming or as generic actual", N); elsif Nkind (N) = N_Attribute_Reference then Error_Msg_N - ("within protected function cannot take access of " - & " protected procedure", N); + ("within protected function cannot take access of protected " + & "procedure", N); else Error_Msg_N @@ -2879,6 +2883,67 @@ package body Sem_Util is ("\cannot call operation that may modify it", N); end if; end if; + + -- Verify that an internal call does not appear within a precondition + -- of a protected operation. This implements AI12-0166. + -- The precondition aspect has been rewritten as a pragma Precondition + -- and we check whether the scope of the called subprogram is the same + -- as that of the entity to which the aspect applies. + + if Convention (Nam) = Convention_Protected then + declare + P : Node_Id; + + begin + P := Parent (N); + while Present (P) loop + if Nkind (P) = N_Pragma + and then Chars (Pragma_Identifier (P)) = Name_Precondition + and then From_Aspect_Specification (P) + and then + Scope (Entity (Corresponding_Aspect (P))) = Scope (Nam) + then + Error_Msg_N + ("internal call cannot appear in precondition of " + & "protected operation", N); + return; + + elsif Nkind (P) = N_Pragma + and then Chars (Pragma_Identifier (P)) = Name_Contract_Cases + then + -- Check whether call is in a case guard. It is legal in a + -- consequence. + + P := N; + while Present (P) loop + if Nkind (Parent (P)) = N_Component_Association + and then P /= Expression (Parent (P)) + then + Error_Msg_N + ("internal call cannot appear in case guard in a " + & "contract case", N); + end if; + + P := Parent (P); + end loop; + + return; + + elsif Nkind (P) = N_Parameter_Specification + and then Scope (Current_Scope) = Scope (Nam) + and then Nkind_In (Parent (P), N_Entry_Declaration, + N_Subprogram_Declaration) + then + Error_Msg_N + ("internal call cannot appear in default for formal of " + & "protected operation", N); + return; + end if; + + P := Parent (P); + end loop; + end; + end if; end Check_Internal_Protected_Use; --------------------------------------- @@ -20648,21 +20713,24 @@ package body Sem_Util is -- correct Current_Source_File. Result : constant Boolean := - Get_Name_Table_Boolean3 (Prag_Name) - and then not Is_Internal_File_Name (File_Name (Current_Source_File)); + Get_Name_Table_Boolean3 (Prag_Name) + and then not Is_Internal_File_Name + (File_Name (Current_Source_File)); begin return Result; end Should_Ignore_Pragma_Par; - -------------------------- + ------------------------------ -- Should_Ignore_Pragma_Sem -- - -------------------------- + ------------------------------ function Should_Ignore_Pragma_Sem (N : Node_Id) return Boolean is pragma Assert (Compiler_State = Analyzing); Prag_Name : constant Name_Id := Pragma_Name (N); - Result : constant Boolean := - Get_Name_Table_Boolean3 (Prag_Name) and then not In_Internal_Unit (N); + Result : constant Boolean := + Get_Name_Table_Boolean3 (Prag_Name) + and then not In_Internal_Unit (N); + begin return Result; end Should_Ignore_Pragma_Sem;