When a function returns a function call, we want to avoid making an
unnecessary copy. This is particularly important because of a bug
which had the effect that when a copy was generated, the copied
object was never finalized. If, as in the case of the example for this
ticket, finalization was being used to reclaim storage, then this
lack of finalization introduced a storage leak. Other bugs uncovered
and fixed along the way included incorrect computation of the
Predicates_Ignored attribute (incorrect in two different ways) and
an incorrect implementation of the RM rule that, roughly speaking,
assertion policies are to be ignored in checking the legality of
a static expression.
Tested on x86_64-pc-linux-gnu, committed on trunk
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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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;
