From: Steve Baird Date: Tue, 23 Jun 2020 23:12:36 +0000 (-0700) Subject: [Ada] Get finalization right when a function returns a function call X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=8861bdd59a95b32ad6000157418c808317421bfe;p=gcc.git [Ada] Get finalization right when a function returns a function call gcc/ada/ * checks.adb (Apply_Predicate_Check): Generate "infinite recursion" warning message even if run-time predicate checking is disabled. * exp_ch6.adb (Expand_Simple_Function_Return): In testing whether the returned expression is a function call, look for the case where the call has been transformed into a dereference of an access value that designates the result of a function call. * sem_ch3.adb (Analyze_Object_Declaration): Legality checking for a static expression is unaffected by assertion policy (and, in particular, enabling/disabling of subtype predicates. To get the right legality checking, we need to call Check_Expression_Against_Static_Predicate for a static expression even if predicate checking is disabled for the given predicate-bearing subtype. On the other hand, we don't want to call Make_Predicate_Check unless predicate checking is enabled. * sem_ch7.adb (Uninstall_Declarations.Preserve_Full_Attributes): Preserve the Predicates_Ignored attribute. * sem_eval.adb (Check_Expression_Against_Static_Predicate): Previously callers ensured that this procedure was only called if predicate checking was enabled; that is no longer the case, so predicates-disabled case must be handled. * sem_prag.adb (Analyze_Pragma): Fix bug in setting Predicates_Ignored attribute in Predicate pragma case. --- diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 9de21d6a49c..539cc043894 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -2744,13 +2744,9 @@ package body Checks is Par : Node_Id; S : Entity_Id; + Check_Disabled : constant Boolean := (not Predicate_Enabled (Typ)) + or else not Predicate_Check_In_Scope (N); begin - if not Predicate_Enabled (Typ) - or else not Predicate_Check_In_Scope (N) - then - return; - end if; - S := Current_Scope; while Present (S) and then not Is_Subprogram (S) loop S := Scope (S); @@ -2759,7 +2755,9 @@ package body Checks is -- If the check appears within the predicate function itself, it means -- that the user specified a check whose formal is the predicated -- subtype itself, rather than some covering type. This is likely to be - -- a common error, and thus deserves a warning. + -- a common error, and thus deserves a warning. We want to emit this + -- warning even if predicate checking is disabled (in which case the + -- warning is still useful even if it is not strictly accurate). if Present (S) and then S = Predicate_Function (Typ) then Error_Msg_NE @@ -2774,9 +2772,15 @@ package body Checks is Parent (N), Typ); end if; - Insert_Action (N, - Make_Raise_Storage_Error (Sloc (N), - Reason => SE_Infinite_Recursion)); + if not Check_Disabled then + Insert_Action (N, + Make_Raise_Storage_Error (Sloc (N), + Reason => SE_Infinite_Recursion)); + return; + end if; + end if; + + if Check_Disabled then return; end if; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 9ceae921db5..26fb58fdf52 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -7318,6 +7318,13 @@ package body Exp_Ch6 is Exp : Node_Id := Expression (N); pragma Assert (Present (Exp)); + Exp_Is_Function_Call : constant Boolean := + Nkind (Exp) = N_Function_Call + or else (Nkind (Exp) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Exp)) + and then Ekind (Entity (Prefix (Exp))) = E_Constant + and then Is_Related_To_Func_Return (Entity (Prefix (Exp)))); + Exp_Typ : constant Entity_Id := Etype (Exp); -- The type of the expression (not necessarily the same as R_Type) @@ -7533,7 +7540,7 @@ package body Exp_Ch6 is Decl : Node_Id; Ent : Entity_Id; begin - if Nkind (Exp) /= N_Function_Call + if not Exp_Is_Function_Call and then Has_Discriminants (Ubt) and then not Is_Constrained (Ubt) and then not Has_Unchecked_Union (Ubt) @@ -7570,7 +7577,7 @@ package body Exp_Ch6 is (not Is_Array_Type (Exp_Typ) or else Is_Constrained (Exp_Typ) = Is_Constrained (R_Type) or else CW_Or_Has_Controlled_Part (Utyp)) - and then Nkind (Exp) = N_Function_Call + and then Exp_Is_Function_Call then Set_By_Ref (N); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index cce8d37083b..f7a85c8d816 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4423,7 +4423,7 @@ package body Sem_Ch3 is -- the predicate still applies. if not Suppress_Assignment_Checks (N) - and then Predicate_Enabled (T) + and then (Predicate_Enabled (T) or else Has_Static_Predicate (T)) and then (not No_Initialization (N) or else (Present (E) and then Nkind (E) = N_Aggregate)) @@ -4434,15 +4434,23 @@ package body Sem_Ch3 is then -- If the type has a static predicate and the expression is known at -- compile time, see if the expression satisfies the predicate. + -- In the case of a static expression, this must be done even if + -- the predicate is not enabled (as per static expression rules). if Present (E) then Check_Expression_Against_Static_Predicate (E, T); end if; + -- Do not perform further predicate-related checks unless + -- predicates are enabled for the subtype. + + if not Predicate_Enabled (T) then + null; + -- If the type is a null record and there is no explicit initial -- expression, no predicate check applies. - if No (E) and then Is_Null_Record_Type (T) then + elsif No (E) and then Is_Null_Record_Type (T) then null; -- Do not generate a predicate check if the initialization expression diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 3ff200191b5..b389464ceef 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -2725,6 +2725,7 @@ package body Sem_Ch7 is Set_Has_Pragma_Unreferenced_Objects (Priv, Has_Pragma_Unreferenced_Objects (Full)); + Set_Predicates_Ignored (Priv, Predicates_Ignored (Full)); if Is_Unchecked_Union (Full) then Set_Is_Unchecked_Union (Base_Type (Priv)); end if; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 872112d03eb..68b4c40bb3b 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -445,9 +445,11 @@ package body Sem_Eval is -- is folded, and since this is definitely a failure, extra checks -- are OK. - Insert_Action (Expr, - Make_Predicate_Check - (Typ, Duplicate_Subexpr (Expr)), Suppress => All_Checks); + if Predicate_Enabled (Typ) then + Insert_Action (Expr, + Make_Predicate_Check + (Typ, Duplicate_Subexpr (Expr)), Suppress => All_Checks); + end if; end if; end Check_Expression_Against_Static_Predicate; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index b765c9f122b..d10d00de38e 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -21201,9 +21201,7 @@ package body Sem_Prag is Set_Has_Delayed_Freeze (Typ); Set_Predicates_Ignored (Typ, - Present (Check_Policy_List) - and then - Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore); + Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore); Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); end Predicate;