[Ada] Implement AI12-0290 (Simple_Barriers restriction)

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

gcc/ada/

	* sem_ch13.ads: Export new function
	All_Membership_Choices_Static.
	* sem_ch13.adb: Implement new function
	All_Membership_Choices_Static.  This involves moving the
	functions Is_Static_Choice and All_Membership_Choices_Static,
	which were previously declared within the function
	Is_Predicate_Static, out to library level so that they can be
	called by the new function. The already-exisiting code in
	Is_Predicate_Static which became the body of
	All_Membership_Choices_Static is replaced with a call to the new
	function in order to avoid duplication.
	* exp_ch9.adb (Is_Pure_Barrier): Several changes needed to
	implement rules of AI12-0290 and RM D.7's definition of
	"pure-barrier-eligible". These changes include adding a call to
	the new function Sem_13.All_Membership_Choices_Static, as per
	the "see 4.9" in RM D.7(1.6/5).

diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index fb53bbd4ff3e4644e187e5a9db287dfe35914207..36baf6f74e58d8ed0faa4d60605451863f866d64 100644 (file)
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -53,6 +53,7 @@ with Sem_Ch6;  use Sem_Ch6;
 with Sem_Ch8;  use Sem_Ch8;
 with Sem_Ch9;  use Sem_Ch9;
 with Sem_Ch11; use Sem_Ch11;
+with Sem_Ch13; use Sem_Ch13;
 with Sem_Elab; use Sem_Elab;
 with Sem_Eval; use Sem_Eval;
 with Sem_Prag; use Sem_Prag;
@@ -6236,28 +6237,37 @@ package body Exp_Ch9 is
             when N_Expanded_Name
                | N_Identifier
             =>
+
+               --  Because of N_Expanded_Name case, return Skip instead of OK.
+
                if No (Entity (N)) then
                   return Abandon;
 
                elsif Is_Universal_Numeric_Type (Entity (N)) then
-                  return OK;
+                  return Skip;
                end if;
 
                case Ekind (Entity (N)) is
                   when E_Constant
                      | E_Discriminant
-                     | E_Enumeration_Literal
+                  =>
+                     return Skip;
+
+                  when E_Enumeration_Literal
                      | E_Named_Integer
                      | E_Named_Real
                   =>
-                     return OK;
+                     if not Is_OK_Static_Expression (N) then
+                        return Abandon;
+                     end if;
+                     return Skip;
 
                   when E_Component =>
-                     return OK;
+                     return Skip;
 
                   when E_Variable =>
                      if Is_Simple_Barrier_Name (N) then
-                        return OK;
+                        return Skip;
                      end if;
 
                   when E_Function =>
@@ -6268,7 +6278,7 @@ package body Exp_Ch9 is
                      if Is_RTE (Entity (N), RE_Protected_Count)
                        or else Is_RTE (Entity (N), RE_Protected_Count_Entry)
                      then
-                        return OK;
+                        return Skip;
                      end if;
 
                   when others =>
@@ -6295,14 +6305,31 @@ package body Exp_Ch9 is
                   return OK;
                end if;
 
-            when N_Short_Circuit =>
+            when N_Short_Circuit
+              | N_If_Expression
+              | N_Case_Expression
+            =>
                return OK;
 
-            when N_Indexed_Component
-               | N_Selected_Component
-            =>
-               if not Is_Access_Type (Etype (Prefix (N))) then
-                  return OK;
+            when N_Case_Expression_Alternative =>
+               --  do not traverse Discrete_Choices subtree
+               if Is_Pure_Barrier (Expression (N)) /= Abandon then
+                  return Skip;
+               end if;
+
+            when N_Expression_With_Actions =>
+               --  this may occur in the case of a Count attribute reference
+               if Original_Node (N) /= N
+                 and then Is_Pure_Barrier (Original_Node (N)) /= Abandon
+               then
+                  return Skip;
+               end if;
+
+            when N_Membership_Test =>
+               if Is_Pure_Barrier (Left_Opnd (N)) /= Abandon
+                 and then All_Membership_Choices_Static (N)
+               then
+                  return Skip;
                end if;
 
             when N_Type_Conversion =>

diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index b0b673fe230fe457055177fc05c85c69a23cd674..0fc8d0e65fe4cfa0f8f554fff501e94566776fae 100644 (file)
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -91,6 +91,13 @@ package body Sem_Ch13 is
    --  type whose inherited alignment is no longer appropriate for the new
    --  size value. In this case, we reset the Alignment to unknown.
 
+   function All_Static_Choices (L : List_Id) return Boolean;
+   --  Returns true if all elements of the list are OK static choices
+   --  as defined below for Is_Static_Choice. Used for case expression
+   --  alternatives and for the right operand of a membership test. An
+   --  others_choice is static if the corresponding expression is static.
+   --  The staticness of the bounds is checked separately.
+
    procedure Build_Discrete_Static_Predicate
      (Typ  : Entity_Id;
       Expr : Node_Id;
@@ -154,6 +161,15 @@ package body Sem_Ch13 is
    --  that do not specify a representation characteristic are operational
    --  attributes.
 
+   function Is_Static_Choice (N : Node_Id) return Boolean;
+   --  Returns True if N represents a static choice (static subtype, or
+   --  static subtype indication, or static expression, or static range).
+   --
+   --  Note that this is a bit more inclusive than we actually need
+   --  (in particular membership tests do not allow the use of subtype
+   --  indications). But that doesn't matter, we have already checked
+   --  that the construct is legal to get this far.
+
    function Is_Type_Related_Rep_Item (N : Node_Id) return Boolean;
    --  Returns True for a representation clause/pragma that specifies a
    --  type-related representation (as opposed to operational) aspect.
@@ -820,6 +836,38 @@ package body Sem_Ch13 is
       end if;
    end Alignment_Check_For_Size_Change;
 
+   function All_Membership_Choices_Static (Expr : Node_Id)
+     return Boolean
+   is
+      pragma Assert (Nkind (Expr) in N_Membership_Test);
+   begin
+      return ((Present (Right_Opnd (Expr))
+              and then Is_Static_Choice (Right_Opnd (Expr)))
+            or else
+              (Present (Alternatives (Expr))
+              and then All_Static_Choices (Alternatives (Expr))));
+   end All_Membership_Choices_Static;
+
+   ------------------------
+   -- All_Static_Choices --
+   ------------------------
+
+   function All_Static_Choices (L : List_Id) return Boolean is
+      N : Node_Id;
+
+   begin
+      N := First (L);
+      while Present (N) loop
+         if not Is_Static_Choice (N) then
+            return False;
+         end if;
+
+         Next (N);
+      end loop;
+
+      return True;
+   end All_Static_Choices;
+
    -------------------------------------
    -- Analyze_Aspects_At_Freeze_Point --
    -------------------------------------
@@ -12163,22 +12211,6 @@ package body Sem_Ch13 is
       --  the alternatives are static (have all static choices, and a static
       --  expression).
 
-      function All_Static_Choices (L : List_Id) return Boolean;
-      --  Returns true if all elements of the list are OK static choices
-      --  as defined below for Is_Static_Choice. Used for case expression
-      --  alternatives and for the right operand of a membership test. An
-      --  others_choice is static if the corresponding expression is static.
-      --  The staticness of the bounds is checked separately.
-
-      function Is_Static_Choice (N : Node_Id) return Boolean;
-      --  Returns True if N represents a static choice (static subtype, or
-      --  static subtype indication, or static expression, or static range).
-      --
-      --  Note that this is a bit more inclusive than we actually need
-      --  (in particular membership tests do not allow the use of subtype
-      --  indications). But that doesn't matter, we have already checked
-      --  that the construct is legal to get this far.
-
       function Is_Type_Ref (N : Node_Id) return Boolean;
       pragma Inline (Is_Type_Ref);
       --  Returns True if N is a reference to the type for the predicate in the
@@ -12214,41 +12246,6 @@ package body Sem_Ch13 is
          return True;
       end All_Static_Case_Alternatives;
 
-      ------------------------
-      -- All_Static_Choices --
-      ------------------------
-
-      function All_Static_Choices (L : List_Id) return Boolean is
-         N : Node_Id;
-
-      begin
-         N := First (L);
-         while Present (N) loop
-            if not Is_Static_Choice (N) then
-               return False;
-            end if;
-
-            Next (N);
-         end loop;
-
-         return True;
-      end All_Static_Choices;
-
-      ----------------------
-      -- Is_Static_Choice --
-      ----------------------
-
-      function Is_Static_Choice (N : Node_Id) return Boolean is
-      begin
-         return Nkind (N) = N_Others_Choice
-           or else Is_OK_Static_Expression (N)
-           or else (Is_Entity_Name (N) and then Is_Type (Entity (N))
-                     and then Is_OK_Static_Subtype (Entity (N)))
-           or else (Nkind (N) = N_Subtype_Indication
-                     and then Is_OK_Static_Subtype (Entity (N)))
-           or else (Nkind (N) = N_Range and then Is_OK_Static_Range (N));
-      end Is_Static_Choice;
-
       -----------------
       -- Is_Type_Ref --
       -----------------
@@ -12277,11 +12274,7 @@ package body Sem_Ch13 is
       --  for a static membership test.
 
       elsif Nkind (Expr) in N_Membership_Test
-        and then ((Present (Right_Opnd (Expr))
-                    and then Is_Static_Choice (Right_Opnd (Expr)))
-                  or else
-                    (Present (Alternatives (Expr))
-                      and then All_Static_Choices (Alternatives (Expr))))
+        and then All_Membership_Choices_Static (Expr)
       then
          return True;
 
@@ -12384,6 +12377,21 @@ package body Sem_Ch13 is
       end if;
    end Is_Predicate_Static;
 
+   ----------------------
+   -- Is_Static_Choice --
+   ----------------------
+
+   function Is_Static_Choice (N : Node_Id) return Boolean is
+   begin
+      return Nkind (N) = N_Others_Choice
+        or else Is_OK_Static_Expression (N)
+        or else (Is_Entity_Name (N) and then Is_Type (Entity (N))
+                  and then Is_OK_Static_Subtype (Entity (N)))
+        or else (Nkind (N) = N_Subtype_Indication
+                  and then Is_OK_Static_Subtype (Entity (N)))
+        or else (Nkind (N) = N_Range and then Is_OK_Static_Range (N));
+   end Is_Static_Choice;
+
    ------------------------------
    -- Is_Type_Related_Rep_Item --
    ------------------------------

diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads
index 9a922ea63815a9a1ee9d530212d5638c3c8ac87a..4c26473edc7dcc270ed18e1586b27f5464c92eb6 100644 (file)
--- a/gcc/ada/sem_ch13.ads
+++ b/gcc/ada/sem_ch13.ads
@@ -28,6 +28,9 @@ with Types; use Types;
 with Uintp; use Uintp;
 
 package Sem_Ch13 is
+   function All_Membership_Choices_Static (Expr : Node_Id) return Boolean;
+   --  Given a membership test, returns True iff all choices are static.
+
    procedure Analyze_At_Clause                          (N : Node_Id);
    procedure Analyze_Attribute_Definition_Clause        (N : Node_Id);
    procedure Analyze_Enumeration_Representation_Clause  (N : Node_Id);