diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 20 | ||||
| -rw-r--r-- | gcc/ada/sem_aux.adb | 26 | ||||
| -rw-r--r-- | gcc/ada/sem_aux.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 37 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 49 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 6 |
6 files changed, 111 insertions, 34 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 566b7a4..113cbca 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,23 @@ +2017-09-08 Yannick Moy <moy@adacore.com> + + * sem_aux.adb, sem_aux.ads (Get_Called_Entity): New function to + return the entity associated with the call. + * sem_util.adb, sem_util.ads (Check_Function_Writable_Actuals): + Replace the internal Get_Function_Id with the new + Sem_Aux.Get_Called_Entity. + (Iterate_Call_Parameters): New + procedure to iterate on formals and actuals at the same time. + * sem_ch12.adb (Analyze_Subprogram_Instantiation): + Set SPARK_Mode from spec when set, for analysis + of instance. Restore after analysis of instance. + (Instantiate_Subprogram_Body): Set SPARK_Mode from body when + set, for analysis of body instance. Restored automatically at + the end of the subprogram. + * gnat1drv.adb (Adjust_Global_Switches): Set + Check_Validity_Of_Parameters to False in GNATprove mode. + * opt.ads (Check_Validity_Of_Parameters): Document switch to + set option. + 2017-09-08 Eric Botcazou <ebotcazou@adacore.com> * sem_util.adb (NCT_Tables_In_Use): Move to library level from... diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 82548bd..4f60f41 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -459,6 +459,32 @@ package body Sem_Aux is end case; end Get_Binary_Nkind; + ----------------------- + -- Get_Called_Entity -- + ----------------------- + + function Get_Called_Entity (Call : Node_Id) return Entity_Id is + Nam : constant Node_Id := Name (Call); + Id : Entity_Id; + + begin + if Nkind (Nam) = N_Explicit_Dereference then + Id := Etype (Nam); + pragma Assert (Ekind (Id) = E_Subprogram_Type); + + elsif Nkind (Nam) = N_Selected_Component then + Id := Entity (Selector_Name (Nam)); + + elsif Nkind (Nam) = N_Indexed_Component then + Id := Entity (Selector_Name (Prefix (Nam))); + + else + Id := Entity (Nam); + end if; + + return Id; + end Get_Called_Entity; + ------------------- -- Get_Low_Bound -- ------------------- diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index 97a4f14..a1e38ee 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -161,8 +161,11 @@ package Sem_Aux is -- referencing this entity. It is an error to call this function if Ekind -- (Op) /= E_Operator. + function Get_Called_Entity (Call : Node_Id) return Entity_Id; + -- Returns the entity associated with the call + function Get_Low_Bound (E : Entity_Id) return Node_Id; - -- For an index subtype or string literal subtype, return its low bound + -- For an index subtype or string literal subtype, returns its low bound function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind; -- Op must be an entity with an Ekind of E_Operator. This function returns diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 324ba4d..86d2808 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -5445,8 +5445,30 @@ package body Sem_Ch12 is Ignore_SPARK_Mode_Pragmas_In_Instance := True; end if; + -- If the context of an instance is not subject to SPARK_Mode "off", + -- and the generic spec is subject to an explicit SPARK_Mode pragma, + -- the latter should be the one applicable to the instance. + + if not Ignore_SPARK_Mode_Pragmas_In_Instance + and then Saved_SM /= Off + and then Present (SPARK_Pragma (Gen_Unit)) + then + Set_SPARK_Mode (Gen_Unit); + end if; + Analyze_Instance_And_Renamings; + -- Restore SPARK_Mode from the context after analysis of the package + -- declaration, so that the SPARK_Mode on the generic spec does not + -- apply to the pending instance for the instance body. + + if not Ignore_SPARK_Mode_Pragmas_In_Instance + and then Saved_SM /= Off + and then Present (SPARK_Pragma (Gen_Unit)) + then + Restore_SPARK_Mode (Saved_SM, Saved_SMP); + end if; + -- If the generic is marked Import (Intrinsic), then so is the -- instance. This indicates that there is no body to instantiate. If -- generic is marked inline, so it the instance, and the anonymous @@ -11511,7 +11533,9 @@ package body Sem_Ch12 is Opt.Ada_Version_Pragma := Body_Info.Version_Pragma; Restore_Warnings (Body_Info.Warnings); - -- Install the SPARK mode which applies to the subprogram body + -- Install the SPARK mode which applies to the subprogram body from the + -- instantiation context. This may be refined further if an explicit + -- SPARK_Mode pragma applies to the generic body. Install_SPARK_Mode (Body_Info.SPARK_Mode, Body_Info.SPARK_Mode_Pragma); @@ -11573,6 +11597,17 @@ package body Sem_Ch12 is Ignore_SPARK_Mode_Pragmas_In_Instance := True; end if; + -- If the context of an instance is not subject to SPARK_Mode "off", + -- and the generic body is subject to an explicit SPARK_Mode pragma, + -- the latter should be the one applicable to the instance. + + if not Ignore_SPARK_Mode_Pragmas_In_Instance + and then SPARK_Mode /= Off + and then Present (SPARK_Pragma (Gen_Body_Id)) + then + Set_SPARK_Mode (Gen_Body_Id); + end if; + Current_Sem_Unit := Body_Info.Current_Sem_Unit; Create_Instantiation_Source (Inst_Node, diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 228a1d5..fcb9453 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2122,9 +2122,6 @@ package body Sem_Util is -- second occurrence, the error is reported, and the tree traversal -- is abandoned. - function Get_Function_Id (Call : Node_Id) return Entity_Id; - -- Return the entity associated with the function call - procedure Preanalyze_Without_Errors (N : Node_Id); -- Preanalyze N without reporting errors. Very dubious, you can't just -- go analyzing things more than once??? @@ -2212,7 +2209,7 @@ package body Sem_Util is Formal : Node_Id; begin - Id := Get_Function_Id (Call); + Id := Get_Called_Entity (Call); -- In case of previous error, no check is possible @@ -2358,32 +2355,6 @@ package body Sem_Util is Do_Traversal (N); end Collect_Identifiers; - --------------------- - -- Get_Function_Id -- - --------------------- - - function Get_Function_Id (Call : Node_Id) return Entity_Id is - Nam : constant Node_Id := Name (Call); - Id : Entity_Id; - - begin - if Nkind (Nam) = N_Explicit_Dereference then - Id := Etype (Nam); - pragma Assert (Ekind (Id) = E_Subprogram_Type); - - elsif Nkind (Nam) = N_Selected_Component then - Id := Entity (Selector_Name (Nam)); - - elsif Nkind (Nam) = N_Indexed_Component then - Id := Entity (Selector_Name (Prefix (Nam))); - - else - Id := Entity (Nam); - end if; - - return Id; - end Get_Function_Id; - ------------------------------- -- Preanalyze_Without_Errors -- ------------------------------- @@ -2523,7 +2494,7 @@ package body Sem_Util is | N_Subprogram_Call => declare - Id : constant Entity_Id := Get_Function_Id (N); + Id : constant Entity_Id := Get_Called_Entity (N); Formal : Node_Id; Actual : Node_Id; @@ -16391,6 +16362,22 @@ package body Sem_Util is end if; end Is_Volatile_Object; + ----------------------------- + -- Iterate_Call_Parameters -- + ----------------------------- + + procedure Iterate_Call_Parameters (Call : Node_Id) is + Formal : Entity_Id := First_Formal (Get_Called_Entity (Call)); + Actual : Node_Id := First_Actual (Call); + + begin + while Present (Formal) and then Present (Actual) loop + Handle_Parameter (Formal, Actual); + Formal := Next_Formal (Formal); + Actual := Next_Actual (Actual); + end loop; + end Iterate_Call_Parameters; + --------------------------- -- Itype_Has_Declaration -- --------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index fab85f0..40325bf 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1943,6 +1943,12 @@ package Sem_Util is -- for something actually declared as volatile, not for an object that gets -- treated as volatile (see Einfo.Treat_As_Volatile). + generic + with procedure Handle_Parameter (Formal : Entity_Id; Actual : Node_Id); + procedure Iterate_Call_Parameters (Call : Node_Id); + -- Calls Handle_Parameter for each pair of formal and actual parameters of + -- a function, procedure, or entry call. + function Itype_Has_Declaration (Id : Entity_Id) return Boolean; -- Applies to Itypes. True if the Itype is attached to a declaration for -- the type through its Parent field, which may or not be present in the |