[Ada] Move Has_Inferable_Discriminants to Sem_Util

Message ID 20210507093821.GA140557@adacore.com
State New
Headers show
Series
  • [Ada] Move Has_Inferable_Discriminants to Sem_Util
Related show

Commit Message

Pierre-Marie de Rodat May 7, 2021, 9:38 a.m.
Move the Has_Inferable_Discriminants utility to Sem_Util so that it can
be reused inside GNATprove.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

	* exp_ch4.adb (Has_Inferable_Discriminants): Moved to Sem_Util.
	* sem_util.ads, sem_util.adb (Has_Inferable_Discriminants):
	Moved from Exp_Ch4.

Patch

diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -176,17 +176,6 @@  package body Exp_Ch4 is
    --  Return the size of a small signed integer type covering Lo .. Hi, the
    --  main goal being to return a size lower than that of standard types.
 
-   function Has_Inferable_Discriminants (N : Node_Id) return Boolean;
-   --  Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
-   --  discriminants if it has a constrained nominal type, unless the object
-   --  is a component of an enclosing Unchecked_Union object that is subject
-   --  to a per-object constraint and the enclosing object lacks inferable
-   --  discriminants.
-   --
-   --  An expression of an Unchecked_Union type has inferable discriminants
-   --  if it is either a name of an object with inferable discriminants or a
-   --  qualified expression whose subtype mark denotes a constrained subtype.
-
    procedure Insert_Dereference_Action (N : Node_Id);
    --  N is an expression whose type is an access. When the type of the
    --  associated storage pool is derived from Checked_Pool, generate a
@@ -13358,84 +13347,6 @@  package body Exp_Ch4 is
       end if;
    end Get_Size_For_Range;
 
-   ---------------------------------
-   -- Has_Inferable_Discriminants --
-   ---------------------------------
-
-   function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
-
-      function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
-      --  Determines whether the left-most prefix of a selected component is a
-      --  formal parameter in a subprogram. Assumes N is a selected component.
-
-      --------------------------------
-      -- Prefix_Is_Formal_Parameter --
-      --------------------------------
-
-      function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
-         Sel_Comp : Node_Id;
-
-      begin
-         --  Move to the left-most prefix by climbing up the tree
-
-         Sel_Comp := N;
-         while Present (Parent (Sel_Comp))
-           and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
-         loop
-            Sel_Comp := Parent (Sel_Comp);
-         end loop;
-
-         return Is_Formal (Entity (Prefix (Sel_Comp)));
-      end Prefix_Is_Formal_Parameter;
-
-   --  Start of processing for Has_Inferable_Discriminants
-
-   begin
-      --  For selected components, the subtype of the selector must be a
-      --  constrained Unchecked_Union. If the component is subject to a
-      --  per-object constraint, then the enclosing object must have inferable
-      --  discriminants.
-
-      if Nkind (N) = N_Selected_Component then
-         if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
-
-            --  A small hack. If we have a per-object constrained selected
-            --  component of a formal parameter, return True since we do not
-            --  know the actual parameter association yet.
-
-            if Prefix_Is_Formal_Parameter (N) then
-               return True;
-
-            --  Otherwise, check the enclosing object and the selector
-
-            else
-               return Has_Inferable_Discriminants (Prefix (N))
-                 and then Has_Inferable_Discriminants (Selector_Name (N));
-            end if;
-
-         --  The call to Has_Inferable_Discriminants will determine whether
-         --  the selector has a constrained Unchecked_Union nominal type.
-
-         else
-            return Has_Inferable_Discriminants (Selector_Name (N));
-         end if;
-
-      --  A qualified expression has inferable discriminants if its subtype
-      --  mark is a constrained Unchecked_Union subtype.
-
-      elsif Nkind (N) = N_Qualified_Expression then
-         return Is_Unchecked_Union (Etype (Subtype_Mark (N)))
-           and then Is_Constrained (Etype (Subtype_Mark (N)));
-
-      --  For all other names, it is sufficient to have a constrained
-      --  Unchecked_Union nominal subtype.
-
-      else
-         return Is_Unchecked_Union (Base_Type (Etype (N)))
-           and then Is_Constrained (Etype (N));
-      end if;
-   end Has_Inferable_Discriminants;
-
    -------------------------------
    -- Insert_Dereference_Action --
    -------------------------------


diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -12435,6 +12435,84 @@  package body Sem_Util is
       return False;
    end Has_Fully_Default_Initializing_DIC_Pragma;
 
+   ---------------------------------
+   -- Has_Inferable_Discriminants --
+   ---------------------------------
+
+   function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
+
+      function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
+      --  Determines whether the left-most prefix of a selected component is a
+      --  formal parameter in a subprogram. Assumes N is a selected component.
+
+      --------------------------------
+      -- Prefix_Is_Formal_Parameter --
+      --------------------------------
+
+      function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
+         Sel_Comp : Node_Id;
+
+      begin
+         --  Move to the left-most prefix by climbing up the tree
+
+         Sel_Comp := N;
+         while Present (Parent (Sel_Comp))
+           and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
+         loop
+            Sel_Comp := Parent (Sel_Comp);
+         end loop;
+
+         return Is_Formal (Entity (Prefix (Sel_Comp)));
+      end Prefix_Is_Formal_Parameter;
+
+   --  Start of processing for Has_Inferable_Discriminants
+
+   begin
+      --  For selected components, the subtype of the selector must be a
+      --  constrained Unchecked_Union. If the component is subject to a
+      --  per-object constraint, then the enclosing object must have inferable
+      --  discriminants.
+
+      if Nkind (N) = N_Selected_Component then
+         if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
+
+            --  A small hack. If we have a per-object constrained selected
+            --  component of a formal parameter, return True since we do not
+            --  know the actual parameter association yet.
+
+            if Prefix_Is_Formal_Parameter (N) then
+               return True;
+
+            --  Otherwise, check the enclosing object and the selector
+
+            else
+               return Has_Inferable_Discriminants (Prefix (N))
+                 and then Has_Inferable_Discriminants (Selector_Name (N));
+            end if;
+
+         --  The call to Has_Inferable_Discriminants will determine whether
+         --  the selector has a constrained Unchecked_Union nominal type.
+
+         else
+            return Has_Inferable_Discriminants (Selector_Name (N));
+         end if;
+
+      --  A qualified expression has inferable discriminants if its subtype
+      --  mark is a constrained Unchecked_Union subtype.
+
+      elsif Nkind (N) = N_Qualified_Expression then
+         return Is_Unchecked_Union (Etype (Subtype_Mark (N)))
+           and then Is_Constrained (Etype (Subtype_Mark (N)));
+
+      --  For all other names, it is sufficient to have a constrained
+      --  Unchecked_Union nominal subtype.
+
+      else
+         return Is_Unchecked_Union (Base_Type (Etype (N)))
+           and then Is_Constrained (Etype (N));
+      end if;
+   end Has_Inferable_Discriminants;
+
    --------------------
    -- Has_Infinities --
    --------------------


diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1388,6 +1388,17 @@  package Sem_Util is
    --  Determine whether type Typ has a suitable Default_Initial_Condition
    --  pragma which provides the full default initialization of the type.
 
+   function Has_Inferable_Discriminants (N : Node_Id) return Boolean;
+   --  Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
+   --  discriminants if it has a constrained nominal type, unless the object
+   --  is a component of an enclosing Unchecked_Union object that is subject
+   --  to a per-object constraint and the enclosing object lacks inferable
+   --  discriminants.
+   --
+   --  An expression of an Unchecked_Union type has inferable discriminants
+   --  if it is either a name of an object with inferable discriminants or a
+   --  qualified expression whose subtype mark denotes a constrained subtype.
+
    function Has_Infinities (E : Entity_Id) return Boolean;
    --  Determines if the range of the floating-point type E includes
    --  infinities. Returns False if E is not a floating-point type.