From: Arnaud Charlet Date: Fri, 23 Oct 2015 10:55:10 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=90e7b5582418912fbd80b0421f8aee92642ad7c2;p=gcc.git [multiple changes] 2015-10-23 Arnaud Charlet * exp_unst.adb (Unnest_Subprogram): Complete previous change and update comments. 2015-10-23 Ed Schonberg * sem_util.ads, sem_util.adb (Check_Function_With_Address_Parameter): A subprogram that has an Address parameter and is declared in a Pure package is not considered Pure, because the parameter may be used as a pointer and the referenced data may change even if the address value itself does not. * freeze.adb (Freeze_Subprogram): use it. * exp_ch6.adb (Expand_N_Subprogram_Body): Use it. From-SVN: r229234 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b811165802b..8fa3e22a038 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,18 @@ +2015-10-23 Arnaud Charlet + + * exp_unst.adb (Unnest_Subprogram): Complete previous + change and update comments. + +2015-10-23 Ed Schonberg + + * sem_util.ads, sem_util.adb (Check_Function_With_Address_Parameter): + A subprogram that has an Address parameter and is declared in a Pure + package is not considered Pure, because the parameter may be used as a + pointer and the referenced data may change even if the address value + itself does not. + * freeze.adb (Freeze_Subprogram): use it. + * exp_ch6.adb (Expand_N_Subprogram_Body): Use it. + 2015-10-23 Olivier Hainque * tracebak.c: Fallback to generic unwinder for gcc-sjlj on x86 & diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 31267a50bae..407ecef7b1e 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -5035,6 +5035,23 @@ package body Exp_Ch6 is Spec_Id := Body_Id; end if; + -- If this is a Pure function which has any parameters whose root type + -- is System.Address, reset the Pure indication. + -- This check is also performed when the subprogram is frozen, but we + -- repeat it on the body so that the indication is consistent, and so + -- it applies as well to bodies without separate specifications. + + if Is_Pure (Spec_Id) + and then Is_Subprogram (Spec_Id) + and then not Has_Pragma_Pure_Function (Spec_Id) + then + Check_Function_With_Address_Parameter (Spec_Id); + + if Spec_Id /= Body_Id then + Set_Is_Pure (Body_Id, Is_Pure (Spec_Id)); + end if; + end if; + -- The subprogram body is Ghost when it is stand alone and subject to -- pragma Ghost or the corresponding spec is Ghost. To accomodate both -- cases, set the mode now to ensure that any nodes generated during @@ -5113,51 +5130,6 @@ package body Exp_Ch6 is end if; end if; - -- If this is a Pure function which has any parameters whose root type - -- is System.Address, reset the Pure indication, since it will likely - -- cause incorrect code to be generated as the parameter is probably - -- a pointer, and the fact that the same pointer is passed does not mean - -- that the same value is being referenced. - - -- Note that if the programmer gave an explicit Pure_Function pragma, - -- then we believe the programmer, and leave the subprogram Pure. - - -- This code should probably be at the freeze point, so that it happens - -- even on a -gnatc (or more importantly -gnatt) compile, so that the - -- semantic tree has Is_Pure set properly ??? - - if Is_Pure (Spec_Id) - and then Is_Subprogram (Spec_Id) - and then not Has_Pragma_Pure_Function (Spec_Id) - then - declare - F : Entity_Id; - - begin - F := First_Formal (Spec_Id); - while Present (F) loop - if Is_Descendent_Of_Address (Etype (F)) - - -- Note that this test is being made in the body of the - -- subprogram, not the spec, so we are testing the full - -- type for being limited here, as required. - - or else Is_Limited_Type (Etype (F)) - then - Set_Is_Pure (Spec_Id, False); - - if Spec_Id /= Body_Id then - Set_Is_Pure (Body_Id, False); - end if; - - exit; - end if; - - Next_Formal (F); - end loop; - end; - end if; - -- Initialize any scalar OUT args if Initialize/Normalize_Scalars if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index 238261e6422..bbd11f97295 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -1261,15 +1261,20 @@ package body Exp_Unst is Push_Scope (STJ.Ent); Analyze (Decl_ARECnT, Suppress => All_Checks); + + -- Note that we need to call Set_Suppress_Initialization + -- after Decl_ARECnT has been analyzed, but before + -- analyzing Decl_ARECnP so that the flag is properly + -- taking into account. + + Set_Suppress_Initialization (STJ.ARECnT); + Analyze (Decl_ARECnPT, Suppress => All_Checks); Analyze (Decl_ARECn, Suppress => All_Checks); Analyze (Decl_ARECnP, Suppress => All_Checks); - Set_Suppress_Initialization - (Defining_Identifier (Decl_ARECnT)); - if Present (Decl_Assign) then - Analyze (Decl_Assign, Suppress => All_Checks); + Analyze (Decl_Assign, Suppress => All_Checks); end if; Pop_Scope; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index ee8a23e5f1c..91ff7a0eaae 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -36,6 +36,7 @@ with Exp_Disp; use Exp_Disp; with Exp_Pakd; use Exp_Pakd; with Exp_Util; use Exp_Util; with Exp_Tss; use Exp_Tss; +with Fname; use Fname; with Ghost; use Ghost; with Layout; use Layout; with Lib; use Lib; @@ -7610,6 +7611,22 @@ package body Freeze is Set_Is_Pure (E, False); end if; + -- We also reset the Pure indication on a subprogram with an Address + -- parameter, because the parameter may be used as a pointer and the + -- referenced data may change even if the address value does not. + + -- Note that if the programmer gave an explicit Pure_Function pragma, + -- then we believe the programmer, and leave the subprogram Pure. + -- We also suppress this check on run-time files. + + if Is_Pure (E) + and then Is_Subprogram (E) + and then not Has_Pragma_Pure_Function (E) + and then not Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)) + then + Check_Function_With_Address_Parameter (E); + end if; + -- For non-foreign convention subprograms, this is where we create -- the extra formals (for accessibility level and constrained bit -- information). We delay this till the freeze point precisely so diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 35b32697d25..476802ebb2b 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2091,6 +2091,34 @@ package body Sem_Util is end if; end Check_Fully_Declared; + ------------------------------------------- + -- Check_Function_With_Address_Parameter -- + ------------------------------------------- + + procedure Check_Function_With_Address_Parameter (Subp_Id : Entity_Id) is + F : Entity_Id; + T : Entity_Id; + + begin + F := First_Formal (Subp_Id); + while Present (F) loop + T := Etype (F); + + if Is_Private_Type (T) and then Present (Full_View (T)) then + T := Full_View (T); + end if; + + if Is_Descendent_Of_Address (T) + or else Is_Limited_Type (T) + then + Set_Is_Pure (Subp_Id, False); + exit; + end if; + + Next_Formal (F); + end loop; + end Check_Function_With_Address_Parameter; + ------------------------------------- -- Check_Function_Writable_Actuals -- ------------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 9d77c7f10a9..d05c42b9bca 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -322,6 +322,14 @@ package Sem_Util is -- N is one of the statement forms that is a potentially blocking -- operation. If it appears within a protected action, emit warning. + procedure Check_Function_With_Address_Parameter (Subp_Id : Entity_Id); + -- A subprogram that has an Address parameter and is declared in a Pure + -- package is not considered Pure, because the parameter may be used as a + -- pointer and the referenced data may change even if the address value + -- itself does not. + -- If the programmer gave an explicit Pure_Function pragma, then we respect + -- the pragma and leave the subprogram Pure. + procedure Check_Result_And_Post_State (Subp_Id : Entity_Id); -- Determine whether the contract of subprogram Subp_Id mentions attribute -- 'Result and it contains an expression that evaluates differently in pre-