[Ada] Factor out code for deciding statically known Constrained attributes
diff mbox series

Message ID 20190918083944.GA145091@adacore.com
State New
Headers show
Series
  • [Ada] Factor out code for deciding statically known Constrained attributes
Related show

Commit Message

Pierre-Marie de Rodat Sept. 18, 2019, 8:39 a.m. UTC
Create a separate routine in Exp_Util for deciding the value of the
Constrained attribute when it is statically known. This routine is used
in Exp_Attr and will be reused in the backend of GNATprove.

There is no impact on compilation and hence no test.

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

2019-09-18  Claire Dross  <dross@adacore.com>

gcc/ada/

	* exp_attr.adb (Expand_N_Attribute_Reference): Call routine from
	Exp_Util to know the value of the Constrained attribute in the
	static case.
	* exp_spark.adb (Expand_SPARK_N_Attribute_Reference): Make
	implicit dereferences inside the Constrained attribute explicit.
	* exp_util.ads, exp_util.adb
	(Attribute_Constrained_Static_Value): New routine to compute the
	value of a statically known reference to the Constrained
	attribute.

Patch
diff mbox series

--- gcc/ada/exp_attr.adb
+++ gcc/ada/exp_attr.adb
@@ -2770,40 +2770,6 @@  package body Exp_Attr is
       when Attribute_Constrained => Constrained : declare
          Formal_Ent : constant Entity_Id := Param_Entity (Pref);
 
-         function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean;
-         --  Ada 2005 (AI-363): Returns True if the object name Obj denotes a
-         --  view of an aliased object whose subtype is constrained.
-
-         ---------------------------------
-         -- Is_Constrained_Aliased_View --
-         ---------------------------------
-
-         function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is
-            E : Entity_Id;
-
-         begin
-            if Is_Entity_Name (Obj) then
-               E := Entity (Obj);
-
-               if Present (Renamed_Object (E)) then
-                  return Is_Constrained_Aliased_View (Renamed_Object (E));
-               else
-                  return Is_Aliased (E) and then Is_Constrained (Etype (E));
-               end if;
-
-            else
-               return Is_Aliased_View (Obj)
-                        and then
-                      (Is_Constrained (Etype (Obj))
-                         or else
-                           (Nkind (Obj) = N_Explicit_Dereference
-                              and then
-                                not Object_Type_Has_Constrained_Partial_View
-                                      (Typ  => Base_Type (Etype (Obj)),
-                                       Scop => Current_Scope)));
-            end if;
-         end Is_Constrained_Aliased_View;
-
       --  Start of processing for Constrained
 
       begin
@@ -2844,115 +2810,23 @@  package body Exp_Attr is
               New_Occurrence_Of
                 (Extra_Constrained (Entity (Pref)), Sloc (N)));
 
-         --  For all other entity names, we can tell at compile time
+         --  For all other cases, we can tell at compile time
 
-         elsif Is_Entity_Name (Pref) then
-            declare
-               Ent : constant Entity_Id   := Entity (Pref);
-               Res : Boolean;
-
-            begin
-               --  (RM J.4) obsolescent cases
-
-               if Is_Type (Ent) then
-
-                  --  Private type
-
-                  if Is_Private_Type (Ent) then
-                     Res := not Has_Discriminants (Ent)
-                              or else Is_Constrained (Ent);
-
-                  --  It not a private type, must be a generic actual type
-                  --  that corresponded to a private type. We know that this
-                  --  correspondence holds, since otherwise the reference
-                  --  within the generic template would have been illegal.
-
-                  else
-                     if Is_Composite_Type (Underlying_Type (Ent)) then
-                        Res := Is_Constrained (Ent);
-                     else
-                        Res := True;
-                     end if;
-                  end if;
-
-               else
-                  --  For access type, apply access check as needed
-
-                  if Is_Access_Type (Ptyp) then
-                     Apply_Access_Check (N);
-                  end if;
-
-                  --  If the prefix is not a variable or is aliased, then
-                  --  definitely true; if it's a formal parameter without an
-                  --  associated extra formal, then treat it as constrained.
-
-                  --  Ada 2005 (AI-363): An aliased prefix must be known to be
-                  --  constrained in order to set the attribute to True.
-
-                  if not Is_Variable (Pref)
-                    or else Present (Formal_Ent)
-                    or else (Ada_Version < Ada_2005
-                              and then Is_Aliased_View (Pref))
-                    or else (Ada_Version >= Ada_2005
-                              and then Is_Constrained_Aliased_View (Pref))
-                  then
-                     Res := True;
-
-                  --  Variable case, look at type to see if it is constrained.
-                  --  Note that the one case where this is not accurate (the
-                  --  procedure formal case), has been handled above.
-
-                  --  We use the Underlying_Type here (and below) in case the
-                  --  type is private without discriminants, but the full type
-                  --  has discriminants. This case is illegal, but we generate
-                  --  it internally for passing to the Extra_Constrained
-                  --  parameter.
-
-                  else
-                     --  In Ada 2012, test for case of a limited tagged type,
-                     --  in which case the attribute is always required to
-                     --  return True. The underlying type is tested, to make
-                     --  sure we also return True for cases where there is an
-                     --  unconstrained object with an untagged limited partial
-                     --  view which has defaulted discriminants (such objects
-                     --  always produce a False in earlier versions of
-                     --  Ada). (Ada 2012: AI05-0214)
-
-                     Res :=
-                       Is_Constrained (Underlying_Type (Etype (Ent)))
-                         or else
-                           (Ada_Version >= Ada_2012
-                             and then Is_Tagged_Type (Underlying_Type (Ptyp))
-                             and then Is_Limited_Type (Ptyp));
-                  end if;
-               end if;
-
-               Rewrite (N, New_Occurrence_Of (Boolean_Literals (Res), Loc));
-            end;
+         else
+            --  For access type, apply access check as needed
 
-         --  Prefix is not an entity name. These are also cases where we can
-         --  always tell at compile time by looking at the form and type of the
-         --  prefix. If an explicit dereference of an object with constrained
-         --  partial view, this is unconstrained (Ada 2005: AI95-0363). If the
-         --  underlying type is a limited tagged type, then Constrained is
-         --  required to always return True (Ada 2012: AI05-0214).
+            if Is_Entity_Name (Pref)
+              and then not Is_Type (Entity (Pref))
+              and then Is_Access_Type (Ptyp)
+            then
+               Apply_Access_Check (N);
+            end if;
 
-         else
             Rewrite (N,
-              New_Occurrence_Of (
-                Boolean_Literals (
-                  not Is_Variable (Pref)
-                    or else
-                     (Nkind (Pref) = N_Explicit_Dereference
-                       and then
-                         not Object_Type_Has_Constrained_Partial_View
-                               (Typ  => Base_Type (Ptyp),
-                                Scop => Current_Scope))
-                    or else Is_Constrained (Underlying_Type (Ptyp))
-                    or else (Ada_Version >= Ada_2012
-                              and then Is_Tagged_Type (Underlying_Type (Ptyp))
-                              and then Is_Limited_Type (Ptyp))),
-                Loc));
+              New_Occurrence_Of
+                (Boolean_Literals
+                   (Exp_Util.Attribute_Constrained_Static_Value
+                      (Pref)), Sloc (N)));
          end if;
 
          Analyze_And_Resolve (N, Standard_Boolean);

--- gcc/ada/exp_spark.adb
+++ gcc/ada/exp_spark.adb
@@ -176,6 +176,7 @@  package body Exp_SPARK is
       Aname   : constant Name_Id      := Attribute_Name (N);
       Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
       Loc     : constant Source_Ptr   := Sloc (N);
+      Pref    : constant Node_Id      := Prefix (N);
       Typ     : constant Entity_Id    := Etype (N);
       Expr    : Node_Id;
 
@@ -302,6 +303,20 @@  package body Exp_SPARK is
                Set_Do_Overflow_Check (N);
             end if;
          end;
+
+      elsif Attr_Id = Attribute_Constrained then
+
+         --  If the prefix is an access to object, the attribute applies to
+         --  the designated object, so rewrite with an explicit dereference.
+
+         if Is_Access_Type (Etype (Pref))
+           and then
+             (not Is_Entity_Name (Pref) or else Is_Object (Entity (Pref)))
+         then
+            Rewrite (Pref,
+                     Make_Explicit_Dereference (Loc, Relocate_Node (Pref)));
+            Analyze_And_Resolve (N, Standard_Boolean);
+         end if;
       end if;
    end Expand_SPARK_N_Attribute_Reference;
 

--- gcc/ada/exp_util.adb
+++ gcc/ada/exp_util.adb
@@ -32,6 +32,7 @@  with Einfo;    use Einfo;
 with Elists;   use Elists;
 with Errout;   use Errout;
 with Exp_Aggr; use Exp_Aggr;
+with Exp_Ch2;  use Exp_Ch2;
 with Exp_Ch6;  use Exp_Ch6;
 with Exp_Ch7;  use Exp_Ch7;
 with Exp_Ch11; use Exp_Ch11;
@@ -472,6 +473,169 @@  package body Exp_Util is
       end if;
    end Append_Freeze_Actions;
 
+   --------------------------------------
+   -- Attr_Constrained_Statically_True --
+   --------------------------------------
+
+   function Attribute_Constrained_Static_Value (Pref : Node_Id) return Boolean
+   is
+      Ptyp       : constant Entity_Id := Etype (Pref);
+      Formal_Ent : constant Entity_Id := Param_Entity (Pref);
+
+      function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean;
+      --  Ada 2005 (AI-363): Returns True if the object name Obj denotes a
+      --  view of an aliased object whose subtype is constrained.
+
+      ---------------------------------
+      -- Is_Constrained_Aliased_View --
+      ---------------------------------
+
+      function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is
+         E : Entity_Id;
+
+      begin
+         if Is_Entity_Name (Obj) then
+            E := Entity (Obj);
+
+            if Present (Renamed_Object (E)) then
+               return Is_Constrained_Aliased_View (Renamed_Object (E));
+            else
+               return Is_Aliased (E) and then Is_Constrained (Etype (E));
+            end if;
+
+         else
+            return Is_Aliased_View (Obj)
+              and then
+                (Is_Constrained (Etype (Obj))
+                 or else
+                   (Nkind (Obj) = N_Explicit_Dereference
+                    and then
+                      not Object_Type_Has_Constrained_Partial_View
+                        (Typ  => Base_Type (Etype (Obj)),
+                         Scop => Current_Scope)));
+         end if;
+      end Is_Constrained_Aliased_View;
+
+   --  Start of processing for Attribute_Constrained_Static_Value
+
+   begin
+      --  We are in a case where the attribute is known statically, and
+      --  implicit dereferences have been rewritten.
+
+      pragma Assert
+        (not (Present (Formal_Ent)
+              and then Ekind (Formal_Ent) /= E_Constant
+              and then Present (Extra_Constrained (Formal_Ent)))
+         and then
+           not (Is_Access_Type (Etype (Pref))
+                and then (not Is_Entity_Name (Pref)
+                          or else Is_Object (Entity (Pref))))
+         and then
+           not (Nkind (Pref) = N_Identifier
+                and then Ekind (Entity (Pref)) = E_Variable
+                and then Present (Extra_Constrained (Entity (Pref)))));
+
+      if Is_Entity_Name (Pref) then
+         declare
+            Ent : constant Entity_Id   := Entity (Pref);
+            Res : Boolean;
+
+         begin
+            --  (RM J.4) obsolescent cases
+
+            if Is_Type (Ent) then
+
+               --  Private type
+
+               if Is_Private_Type (Ent) then
+                  Res := not Has_Discriminants (Ent)
+                    or else Is_Constrained (Ent);
+
+               --  It not a private type, must be a generic actual type
+               --  that corresponded to a private type. We know that this
+               --  correspondence holds, since otherwise the reference
+               --  within the generic template would have been illegal.
+
+               else
+                  if Is_Composite_Type (Underlying_Type (Ent)) then
+                     Res := Is_Constrained (Ent);
+                  else
+                     Res := True;
+                  end if;
+               end if;
+
+            else
+
+               --  If the prefix is not a variable or is aliased, then
+               --  definitely true; if it's a formal parameter without an
+               --  associated extra formal, then treat it as constrained.
+
+               --  Ada 2005 (AI-363): An aliased prefix must be known to be
+               --  constrained in order to set the attribute to True.
+
+               if not Is_Variable (Pref)
+                 or else Present (Formal_Ent)
+                 or else (Ada_Version < Ada_2005
+                          and then Is_Aliased_View (Pref))
+                 or else (Ada_Version >= Ada_2005
+                          and then Is_Constrained_Aliased_View (Pref))
+               then
+                  Res := True;
+
+               --  Variable case, look at type to see if it is constrained.
+               --  Note that the one case where this is not accurate (the
+               --  procedure formal case), has been handled above.
+
+               --  We use the Underlying_Type here (and below) in case the
+               --  type is private without discriminants, but the full type
+               --  has discriminants. This case is illegal, but we generate
+               --  it internally for passing to the Extra_Constrained
+               --  parameter.
+
+               else
+                  --  In Ada 2012, test for case of a limited tagged type,
+                  --  in which case the attribute is always required to
+                  --  return True. The underlying type is tested, to make
+                  --  sure we also return True for cases where there is an
+                  --  unconstrained object with an untagged limited partial
+                  --  view which has defaulted discriminants (such objects
+                  --  always produce a False in earlier versions of
+                  --  Ada). (Ada 2012: AI05-0214)
+
+                  Res :=
+                    Is_Constrained (Underlying_Type (Etype (Ent)))
+                    or else
+                      (Ada_Version >= Ada_2012
+                       and then Is_Tagged_Type (Underlying_Type (Ptyp))
+                       and then Is_Limited_Type (Ptyp));
+               end if;
+            end if;
+
+            return Res;
+         end;
+
+      --  Prefix is not an entity name. These are also cases where we can
+      --  always tell at compile time by looking at the form and type of the
+      --  prefix. If an explicit dereference of an object with constrained
+      --  partial view, this is unconstrained (Ada 2005: AI95-0363). If the
+      --  underlying type is a limited tagged type, then Constrained is
+      --  required to always return True (Ada 2012: AI05-0214).
+
+      else
+         return not Is_Variable (Pref)
+           or else
+             (Nkind (Pref) = N_Explicit_Dereference
+              and then
+                not Object_Type_Has_Constrained_Partial_View
+                  (Typ  => Base_Type (Ptyp),
+                   Scop => Current_Scope))
+           or else Is_Constrained (Underlying_Type (Ptyp))
+           or else (Ada_Version >= Ada_2012
+                    and then Is_Tagged_Type (Underlying_Type (Ptyp))
+                    and then Is_Limited_Type (Ptyp));
+      end if;
+   end Attribute_Constrained_Static_Value;
+
    ------------------------------------
    -- Build_Allocate_Deallocate_Proc --
    ------------------------------------

--- gcc/ada/exp_util.ads
+++ gcc/ada/exp_util.ads
@@ -240,6 +240,10 @@  package Exp_Util is
    --  Note that the added nodes are not analyzed. The analyze call is found in
    --  Exp_Ch13.Expand_N_Freeze_Entity.
 
+   function Attribute_Constrained_Static_Value (Pref : Node_Id) return Boolean;
+   --  Return the static value of a statically known attribute reference
+   --  Pref'Constrained.
+
    procedure Build_Allocate_Deallocate_Proc
      (N           : Node_Id;
       Is_Allocate : Boolean);