From: Steve Baird <baird@adacore.com>
Date: Mon, 4 Oct 2021 22:33:18 +0000 (-0700)
Subject: [Ada] Incorrect Dynamic_Predicate results for static arguments
X-Git-Tag: upstream/12.2.0~4386
X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=2ad5d5e3d5d40f220df7239b54d5017259dc4d1d;p=platform%2Fupstream%2Fgcc.git

[Ada] Incorrect Dynamic_Predicate results for static arguments

gcc/ada/

	* exp_ch6.adb (Can_Fold_Predicate_Call): Do not attempt folding
	if there is more than one predicate involved. Recall that
	predicate aspect specification are additive, not overriding, and
	that there are three different predicate
	aspects (Dynamic_Predicate, Static_Predicate, and the
	GNAT-defined Predicate aspect). These various ways of
	introducing multiple predicates are all checked for.  A new
	nested function, Augments_Other_Dynamic_Predicate, is
	introduced.
	* sem_ch4.adb
	(Analyze_Indexed_Component_Form.Process_Function_Call): When
	determining whether a name like "X (Some_Discrete_Type)" might
	be interpreted as a slice, the answer should be "no" if the
	type/subtype name denotes the current instance of type/subtype.
---

diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index ce0bb80..3f83685 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -3143,6 +3143,13 @@ package body Exp_Ch6 is
       function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean is
          Actual : Node_Id;
 
+         function Augments_Other_Dynamic_Predicate (DP_Aspect_Spec : Node_Id)
+           return Boolean;
+         --  Given a Dynamic_Predicate aspect aspecification for a
+         --  discrete type, returns True iff another DP specification
+         --  applies (indirectly, via a subtype type or a derived type)
+         --  to the same entity that this aspect spec applies to.
+
          function May_Fold (N : Node_Id) return Traverse_Result;
          --  The predicate expression is foldable if it only contains operators
          --  and literals. During this check, we also replace occurrences of
@@ -3150,6 +3157,36 @@ package body Exp_Ch6 is
          --  value of the actual. This is done on a copy of the analyzed
          --  expression for the predicate.
 
+         --------------------------------------
+         -- Augments_Other_Dynamic_Predicate --
+         --------------------------------------
+
+         function Augments_Other_Dynamic_Predicate (DP_Aspect_Spec : Node_Id)
+           return Boolean
+         is
+            Aspect_Bearer : Entity_Id := Entity (DP_Aspect_Spec);
+         begin
+            loop
+               Aspect_Bearer := Nearest_Ancestor (Aspect_Bearer);
+
+               if not Present (Aspect_Bearer) then
+                  return False;
+               end if;
+
+               declare
+                  Aspect_Spec : constant Node_Id :=
+                    Find_Aspect (Aspect_Bearer, Aspect_Dynamic_Predicate);
+               begin
+                  if Present (Aspect_Spec)
+                    and then Aspect_Spec /= DP_Aspect_Spec
+                  then
+                     --  Found another Dynamic_Predicate aspect spec
+                     return True;
+                  end if;
+               end;
+            end loop;
+         end Augments_Other_Dynamic_Predicate;
+
          --------------
          -- May_Fold --
          --------------
@@ -3192,7 +3229,7 @@ package body Exp_Ch6 is
 
          function Try_Fold is new Traverse_Func (May_Fold);
 
-         --  Other lLocal variables
+         --  Other Local variables
 
          Subt   : constant Entity_Id := Etype (First_Entity (P));
          Aspect : Node_Id;
@@ -3220,6 +3257,11 @@ package body Exp_Ch6 is
            or else Nkind (Actual) /= N_Integer_Literal
            or else not Has_Dynamic_Predicate_Aspect (Subt)
            or else No (Aspect)
+
+           --  Do not fold if multiple applicable predicate aspects
+           or else Present (Find_Aspect (Subt, Aspect_Static_Predicate))
+           or else Present (Find_Aspect (Subt, Aspect_Predicate))
+           or else Augments_Other_Dynamic_Predicate (Aspect)
            or else CodePeer_Mode
          then
             return False;
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index dda244c..169b01b 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -2534,6 +2534,7 @@ package body Sem_Ch4 is
               and then Is_Entity_Name (Actual)
               and then Is_Type (Entity (Actual))
               and then Is_Discrete_Type (Entity (Actual))
+              and then not Is_Current_Instance (Actual)
             then
                Replace (N,
                  Make_Slice (Loc,