[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 9de21d6a49c0fcab501261f842dc2e22257f2da9..539cc043894c65a1d52dd31ec1f6102b0c2cf120 100644 (file)
--- 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 9ceae921db5d16b73a1cc3cae257721e1af705de..26fb58fdf525a5ba0fd488e2b223fee422cc0b0f 100644 (file)
--- 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 cce8d37083b7240d11289d6502953d0b497a9387..f7a85c8d8169e55fe5d596fc710707bd58435b4c 100644 (file)
--- 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 3ff200191b580624b897870cb02739be70a1261c..b389464ceefd11bfba2910bcbb1ce8e10d7000e9 100644 (file)
--- 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 872112d03ebae615be3646bd8aa3e33e12d6eea0..68b4c40bb3b8fa09dff702bd48b003642bf978f8 100644 (file)
--- 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 b765c9f122bb8871a74c033578d73ea4630235f6..d10d00de38e39dfeaad3293d0cbc8abaedbde64b 100644 (file)
--- 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;