[Ada] Implement AI12-0369

2020-06-12  Steve Baird  <baird@adacore.com>

gcc/ada/

	* sem_util.ads, sem_util.adb: Define 3 new Boolean-valued
	functions - Statically_Denotes_Entity,
	Statically_Denotes_Object, and Statically_Names_Object. The
	first two were taken from sem_attr.adb. The term "statically
	names" is defined in the Ada RM and the new function
	Statically_Names_Object is intended to reflect that definition,
	or more precisely, as described in a comment in the code, to
	reflect the expected future definition of that term.
	* sem_attr.adb: Delete functions Statically_Denotes_Object and
	Statically_Denotes_Entity; these two functions have been moved
	to package Sem_Util. Replace call to Statically_Denotes_Object
	with a call to Statically_Names_Object as per AI12-0217 (a
	binding interpretation, so no Ada_Version check).
	* exp_ch9.adb (Expand_Entry_Barrier.Is_Simple_Barrier): Change
	name of function (it was previously Is_Simple_Barrier_Name)
	because the function should return True in the case of a static
	expression; implement this requirement.  Change function to
	include a call to Statically_Names_Object so that, for Ada_2020
	and later, it will return True for appropriate subcomponent
	names.
	(Expand_Entry_Barrier.Is_Pure_Barrier): Handle
	N_Indexed_Component and N_Selected_Component cases by calling
	Statically_Names_Object.
	(Expand_Entry_Barrier): Reorganize to treat Simple_Barriers and
	Pure_Barriers more uniformly.  Prevent cascaded errors.

4 files changed, 205 insertions, 127 deletions

diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 8371711..5162118 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -5961,12 +5961,12 @@ package body Exp_Ch9 is
       --  If so, barrier may not be properly synchronized.
 
       function Is_Pure_Barrier (N : Node_Id) return Traverse_Result;
-      --  Check whether N follows the Pure_Barriers restriction. Return OK if
+      --  Check whether N meets the Pure_Barriers restriction. Return OK if
       --  so.
 
-      function Is_Simple_Barrier_Name (N : Node_Id) return Boolean;
-      --  Check whether entity name N denotes a component of the protected
-      --  object. This is used to check the Simple_Barrier restriction.
+      function Is_Simple_Barrier (N : Node_Id) return Boolean;
+      --  Check whether N meets the Simple_Barriers restriction. Return OK if
+      --  so.
 
       ----------------------
       -- Is_Global_Entity --
@@ -6018,14 +6018,25 @@ package body Exp_Ch9 is
       procedure Check_Unprotected_Barrier is
         new Traverse_Proc (Is_Global_Entity);
 
-      ----------------------------
-      -- Is_Simple_Barrier_Name --
-      ----------------------------
+      -----------------------
+      -- Is_Simple_Barrier --
+      -----------------------
 
-      function Is_Simple_Barrier_Name (N : Node_Id) return Boolean is
+      function Is_Simple_Barrier (N : Node_Id) return Boolean is
          Renamed : Node_Id;
 
       begin
+         if Is_Static_Expression (N) then
+            return True;
+         elsif Ada_Version >= Ada_2020
+           and then Nkind_In (N, N_Selected_Component, N_Indexed_Component)
+           and then Statically_Names_Object (N)
+         then
+            --  Restriction relaxed in Ada2020 to allow statically named
+            --  subcomponents.
+            return Is_Simple_Barrier (Prefix (N));
+         end if;
+
          --  Check if the name is a component of the protected object. If
          --  the expander is active, the component has been transformed into a
          --  renaming of _object.all.component. Original_Node is needed in case
@@ -6048,10 +6059,12 @@ package body Exp_Ch9 is
               Present (Renamed)
                 and then Nkind (Renamed) = N_Selected_Component
                 and then Chars (Prefix (Prefix (Renamed))) = Name_uObject;
+         elsif not Is_Entity_Name (N) then
+            return False;
          else
             return Is_Protected_Component (Entity (N));
          end if;
-      end Is_Simple_Barrier_Name;
+      end Is_Simple_Barrier;
 
       ---------------------
       -- Is_Pure_Barrier --
@@ -6092,7 +6105,7 @@ package body Exp_Ch9 is
                      return Skip;
 
                   when E_Variable =>
-                     if Is_Simple_Barrier_Name (N) then
+                     if Is_Simple_Barrier (N) then
                         return Skip;
                      end if;
 
@@ -6137,6 +6150,13 @@ package body Exp_Ch9 is
             =>
                return OK;
 
+            when N_Indexed_Component | N_Selected_Component =>
+               if Statically_Names_Object (N) then
+                  return Is_Pure_Barrier (Prefix (N));
+               else
+                  return Abandon;
+               end if;
+
             when N_Case_Expression_Alternative =>
                --  do not traverse Discrete_Choices subtree
                if Is_Pure_Barrier (Expression (N)) /= Abandon then
@@ -6195,6 +6215,12 @@ package body Exp_Ch9 is
          return;
       end if;
 
+      --  Prevent cascaded errors
+
+      if Nkind (Cond) = N_Error then
+         return;
+      end if;
+
       --  The body of the entry barrier must be analyzed in the context of the
       --  protected object, but its scope is external to it, just as any other
       --  unprotected version of a protected operation. The specification has
@@ -6224,22 +6250,25 @@ package body Exp_Ch9 is
          Analyze_And_Resolve (Cond, Any_Boolean);
       end if;
 
-      --  Check Pure_Barriers restriction
+      --  Check Simple_Barriers and Pure_Barriers restrictions.
+      --  Note that it is safe to be calling Check_Restriction from here, even
+      --  though this is part of the expander, since Expand_Entry_Barrier is
+      --  called from Sem_Ch9 even in -gnatc mode.
 
-      if Check_Pure_Barriers (Cond) = Abandon then
-         Check_Restriction (Pure_Barriers, Cond);
+      if not Is_Simple_Barrier (Cond) then
+         --  flag restriction violation
+         Check_Restriction (Simple_Barriers, Cond);
       end if;
 
-      --  The Ravenscar profile restricts barriers to simple variables declared
-      --  within the protected object. We also allow Boolean constants, since
-      --  these appear in several published examples and are also allowed by
-      --  other compilers.
+      if Check_Pure_Barriers (Cond) = Abandon then
+         --  flag restriction violation
+         Check_Restriction (Pure_Barriers, Cond);
 
-      --  Note that after analysis variables in this context will be replaced
-      --  by the corresponding prival, that is to say a renaming of a selected
-      --  component of the form _Object.Var. If expansion is disabled, as
-      --  within a generic, we check that the entity appears in the current
-      --  scope.
+         --  Emit warning if barrier contains global entities and is thus
+         --  potentially unsynchronized (if Pure_Barriers restrictions
+         --  are met then no need to check for this).
+         Check_Unprotected_Barrier (Cond);
+      end if;
 
       if Is_Entity_Name (Cond) then
          Cond_Id := Entity (Cond);
@@ -6260,25 +6289,12 @@ package body Exp_Ch9 is
             Set_Declarations (Func_Body, Empty_List);
          end if;
 
-         if Cond_Id = Standard_False or else Cond_Id = Standard_True then
-            return;
-
-         elsif Is_Simple_Barrier_Name (Cond) then
-            return;
-         end if;
+         --  Note that after analysis variables in this context will be
+         --  replaced by the corresponding prival, that is to say a renaming
+         --  of a selected component of the form _Object.Var. If expansion is
+         --  disabled, as within a generic, we check that the entity appears in
+         --  the current scope.
       end if;
-
-      --  It is not a boolean variable or literal, so check the restriction.
-      --  Note that it is safe to be calling Check_Restriction from here, even
-      --  though this is part of the expander, since Expand_Entry_Barrier is
-      --  called from Sem_Ch9 even in -gnatc mode.
-
-      Check_Restriction (Simple_Barriers, Cond);
-
-      --  Emit warning if barrier contains global entities and is thus
-      --  potentially unsynchronized.
-
-      Check_Unprotected_Barrier (Cond);
    end Expand_Entry_Barrier;
 
    ------------------------------
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index ce57b30..86772d6 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -220,15 +220,6 @@ package body Sem_Attr is
    --  Standard_True, depending on the value of the parameter B. The
    --  result is marked as a static expression.
 
-   function Statically_Denotes_Object (N : Node_Id) return Boolean;
-   --  Predicate used to check the legality of the prefix to 'Loop_Entry and
-   --  'Old, when the prefix is not an entity name. Current RM specfies that
-   --  the prefix must be a direct or expanded name, but it has been proposed
-   --  that the prefix be allowed to be a selected component that does not
-   --  depend on a discriminant, or an indexed component with static indices.
-   --  Current code for this predicate implements this more permissive
-   --  implementation.
-
    -----------------------
    -- Analyze_Attribute --
    -----------------------
@@ -2790,7 +2781,7 @@ package body Sem_Attr is
             when 'E' =>
                Error_Attr_P
                  ("prefix of attribute % that is potentially "
-                  & "unevaluated must denote an entity");
+                  & "unevaluated must statically name an entity");
 
             when 'W' =>
                Error_Msg_Name_1 := Aname;
@@ -5056,7 +5047,7 @@ package body Sem_Attr is
             --  is potentially unevaluated (6.1.1 (27/3)).
 
             if Is_Potentially_Unevaluated (N)
-              and then not Statically_Denotes_Object (P)
+              and then not Statically_Names_Object (P)
             then
                Uneval_Old_Msg;
 
@@ -7324,10 +7315,6 @@ package body Sem_Attr is
       --  Static is reset to False if the type or index type is not statically
       --  constrained.
 
-      function Statically_Denotes_Entity (N : Node_Id) return Boolean;
-      --  Verify that the prefix of a potentially static array attribute
-      --  satisfies the conditions of 4.9 (14).
-
       -----------------------------------
       -- Check_Concurrent_Discriminant --
       -----------------------------------
@@ -7604,25 +7591,6 @@ package body Sem_Attr is
          end if;
       end Set_Bounds;
 
-      -------------------------------
-      -- Statically_Denotes_Entity --
-      -------------------------------
-
-      function Statically_Denotes_Entity (N : Node_Id) return Boolean is
-         E : Entity_Id;
-
-      begin
-         if not Is_Entity_Name (N) then
-            return False;
-         else
-            E := Entity (N);
-         end if;
-
-         return
-           Nkind (Parent (E)) /= N_Object_Renaming_Declaration
-             or else Statically_Denotes_Entity (Renamed_Object (E));
-      end Statically_Denotes_Entity;
-
    --  Start of processing for Eval_Attribute
 
    begin
@@ -12066,59 +12034,6 @@ package body Sem_Attr is
       end if;
    end Set_Boolean_Result;
 
-   -------------------------------
-   -- Statically_Denotes_Object --
-   -------------------------------
-
-   function Statically_Denotes_Object (N : Node_Id) return Boolean is
-      Indx : Node_Id;
-
-   begin
-      if Is_Entity_Name (N) then
-         return True;
-
-      elsif Nkind (N) = N_Selected_Component
-        and then Statically_Denotes_Object (Prefix (N))
-        and then Present (Entity (Selector_Name (N)))
-      then
-         declare
-            Sel_Id    : constant Entity_Id := Entity (Selector_Name (N));
-            Comp_Decl : constant Node_Id   := Parent (Sel_Id);
-
-         begin
-            if Depends_On_Discriminant (Sel_Id) then
-               return False;
-
-            elsif Nkind (Parent (Parent (Comp_Decl))) = N_Variant then
-               return False;
-
-            else
-               return True;
-            end if;
-         end;
-
-      elsif Nkind (N) = N_Indexed_Component
-        and then Statically_Denotes_Object (Prefix (N))
-        and then Is_Constrained (Etype (Prefix (N)))
-      then
-         Indx := First (Expressions (N));
-         while Present (Indx) loop
-            if not Compile_Time_Known_Value (Indx)
-              or else Do_Range_Check (Indx)
-            then
-               return False;
-            end if;
-
-            Next (Indx);
-         end loop;
-
-         return True;
-
-      else
-         return False;
-      end if;
-   end Statically_Denotes_Object;
-
    --------------------------------
    -- Stream_Attribute_Available --
    --------------------------------
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 2661517..76afdb0 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -26439,6 +26439,34 @@ package body Sem_Util is
       end if;
    end Static_Integer;
 
+   -------------------------------
+   -- Statically_Denotes_Entity --
+   -------------------------------
+   function Statically_Denotes_Entity (N : Node_Id) return Boolean is
+      E : Entity_Id;
+   begin
+      if not Is_Entity_Name (N) then
+         return False;
+      else
+         E := Entity (N);
+      end if;
+
+      return
+        Nkind (Parent (E)) /= N_Object_Renaming_Declaration
+          or else Is_Prival (E)
+          or else Statically_Denotes_Entity (Renamed_Object (E));
+   end Statically_Denotes_Entity;
+
+   -------------------------------
+   -- Statically_Denotes_Object --
+   -------------------------------
+
+   function Statically_Denotes_Object (N : Node_Id) return Boolean is
+   begin
+      return Statically_Denotes_Entity (N)
+         and then Is_Object_Reference (N);
+   end Statically_Denotes_Object;
+
    --------------------------
    -- Statically_Different --
    --------------------------
@@ -26454,6 +26482,116 @@ package body Sem_Util is
         and then not Is_Formal (Entity (R2));
    end Statically_Different;
 
+   -----------------------------
+   -- Statically_Names_Object --
+   -----------------------------
+   function Statically_Names_Object (N : Node_Id) return Boolean is
+   begin
+      if Statically_Denotes_Object (N) then
+         return True;
+      elsif Is_Entity_Name (N) then
+         declare
+            E : constant Entity_Id := Entity (N);
+         begin
+            return Nkind (Parent (E)) = N_Object_Renaming_Declaration
+              and then Statically_Names_Object (Renamed_Object (E));
+         end;
+      end if;
+
+      case Nkind (N) is
+         when N_Indexed_Component =>
+            if Is_Access_Type (Etype (Prefix (N))) then
+               --  treat implicit dereference same as explicit
+               return False;
+            end if;
+
+            if not Is_Constrained (Etype (Prefix (N))) then
+               return False;
+            end if;
+
+            declare
+               Indx : Node_Id := First_Index (Etype (Prefix (N)));
+               Expr : Node_Id := First (Expressions (N));
+               Index_Subtype : Node_Id;
+            begin
+               loop
+                  Index_Subtype := Etype (Indx);
+
+                  if not Is_Static_Subtype (Index_Subtype) then
+                     return False;
+                  end if;
+                  if not Is_OK_Static_Expression (Expr) then
+                     return False;
+                  end if;
+
+                  declare
+                     Index_Value : constant Uint := Expr_Value (Expr);
+                     Low_Value   : constant Uint :=
+                       Expr_Value (Type_Low_Bound (Index_Subtype));
+                     High_Value   : constant Uint :=
+                       Expr_Value (Type_High_Bound (Index_Subtype));
+                  begin
+                     if (Index_Value < Low_Value)
+                       or (Index_Value > High_Value)
+                     then
+                        return False;
+                     end if;
+                  end;
+
+                  Next_Index (Indx);
+                  Expr := Next (Expr);
+                  pragma Assert ((Present (Indx) = Present (Expr))
+                    or else (Serious_Errors_Detected > 0));
+                  exit when not (Present (Indx) and Present (Expr));
+               end loop;
+            end;
+
+         when N_Selected_Component =>
+            if Is_Access_Type (Etype (Prefix (N))) then
+               --  treat implicit dereference same as explicit
+               return False;
+            end if;
+
+            if not Ekind_In (Entity (Selector_Name (N)), E_Component,
+                                                         E_Discriminant)
+            then
+               return False;
+            end if;
+            declare
+               Comp : constant Entity_Id :=
+                 Original_Record_Component (Entity (Selector_Name (N)));
+            begin
+              --  In not calling Has_Discriminant_Dependent_Constraint here,
+              --  we are anticipating a language definition fixup. The
+              --  current definition of "statically names" includes the
+              --  wording "the selector_name names a component that does
+              --  not depend on a discriminant", which suggests that this
+              --  call should not be commented out. But it appears likely
+              --  that this wording will be updated to only apply to a
+              --  component declared in a variant part. There is no need
+              --  to disallow something like
+              --    with Post => ... and then
+              --       Some_Record.Some_Discrim_Dep_Array_Component'Old (I)
+              --  since the evaluation of the 'Old prefix cannot raise an
+              --  exception. If the language is not updated, then the call
+              --  below to H_D_C_C will need to be uncommented.
+
+               if Is_Declared_Within_Variant (Comp)
+                  --  or else Has_Discriminant_Dependent_Constraint (Comp)
+               then
+                  return False;
+               end if;
+            end;
+
+         when others => -- includes N_Slice, N_Explicit_Dereference
+            return False;
+      end case;
+
+      pragma Assert (Present (Prefix (N)));
+
+      return Statically_Names_Object (Prefix (N));
+   end Statically_Names_Object;
+
    --------------------------------------
    -- Subject_To_Loop_Entry_Attributes --
    --------------------------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 34379f9..c096170 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -2909,10 +2909,19 @@ package Sem_Util is
    --  universal expression is returned, otherwise an error message is output
    --  and a value of No_Uint is returned.
 
+   function Statically_Denotes_Entity (N : Node_Id) return Boolean;
+   --  Return True iff N is a name that "statically denotes" an entity.
+
+   function Statically_Denotes_Object (N : Node_Id) return Boolean;
+   --  Return True iff N is a name that "statically denotes" an object.
+
    function Statically_Different (E1, E2 : Node_Id) return Boolean;
    --  Return True if it can be statically determined that the Expressions
    --  E1 and E2 refer to different objects
 
+   function Statically_Names_Object (N : Node_Id) return Boolean;
+   --  Return True iff N is a name that "statically names" an object.
+
    function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean;
    --  Determine whether node N is a loop statement subject to at least one
    --  'Loop_Entry attribute.