Skip to content

R
riscv-gcc-1
Commit d2880e69 by Claire Dross Committed by Pierre-Marie de Rodat
Options

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

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.

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.

From-SVN: r275848
parent 209a0094
Showing with 208 additions and 139 deletions
gcc/ada/ChangeLog
2019-09-18 Claire Dross <dross@adacore.com>
* 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.
2019-09-18 Vadim Godunko <godunko@adacore.com> 2019-09-18 Vadim Godunko <godunko@adacore.com>
* libgnat/g-expect.adb (Expect_Internal): Don't include invalid * libgnat/g-expect.adb (Expect_Internal): Don't include invalid
......
gcc/ada/exp_attr.adb
...@@ -2770,40 +2770,6 @@ package body Exp_Attr is ...@@ -2770,40 +2770,6 @@ package body Exp_Attr is
when Attribute_Constrained => Constrained : declare when Attribute_Constrained => Constrained : declare
Formal_Ent : constant Entity_Id := Param_Entity (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 Constrained -- Start of processing for Constrained
begin begin
...@@ -2844,115 +2810,23 @@ package body Exp_Attr is ...@@ -2844,115 +2810,23 @@ package body Exp_Attr is
New_Occurrence_Of New_Occurrence_Of
(Extra_Constrained (Entity (Pref)), Sloc (N))); (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 else
declare -- For access type, apply access check as needed
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;
-- Prefix is not an entity name. These are also cases where we can if Is_Entity_Name (Pref)
-- always tell at compile time by looking at the form and type of the and then not Is_Type (Entity (Pref))
-- prefix. If an explicit dereference of an object with constrained and then Is_Access_Type (Ptyp)
-- partial view, this is unconstrained (Ada 2005: AI95-0363). If the then
-- underlying type is a limited tagged type, then Constrained is Apply_Access_Check (N);
-- required to always return True (Ada 2012: AI05-0214). end if;
else
Rewrite (N, Rewrite (N,
New_Occurrence_Of ( New_Occurrence_Of
Boolean_Literals ( (Boolean_Literals
not Is_Variable (Pref) (Exp_Util.Attribute_Constrained_Static_Value
or else (Pref)), Sloc (N)));
(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));
end if; end if;
Analyze_And_Resolve (N, Standard_Boolean); Analyze_And_Resolve (N, Standard_Boolean);
......
gcc/ada/exp_spark.adb
...@@ -176,6 +176,7 @@ package body Exp_SPARK is ...@@ -176,6 +176,7 @@ package body Exp_SPARK is
Aname : constant Name_Id := Attribute_Name (N); Aname : constant Name_Id := Attribute_Name (N);
Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname); Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Pref : constant Node_Id := Prefix (N);
Typ : constant Entity_Id := Etype (N); Typ : constant Entity_Id := Etype (N);
Expr : Node_Id; Expr : Node_Id;
...@@ -302,6 +303,20 @@ package body Exp_SPARK is ...@@ -302,6 +303,20 @@ package body Exp_SPARK is
Set_Do_Overflow_Check (N); Set_Do_Overflow_Check (N);
end if; end if;
end; 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 if;
end Expand_SPARK_N_Attribute_Reference; end Expand_SPARK_N_Attribute_Reference;
......
gcc/ada/exp_util.adb
...@@ -32,6 +32,7 @@ with Einfo; use Einfo; ...@@ -32,6 +32,7 @@ with Einfo; use Einfo;
with Elists; use Elists; with Elists; use Elists;
with Errout; use Errout; with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr; with Exp_Aggr; use Exp_Aggr;
with Exp_Ch2; use Exp_Ch2;
with Exp_Ch6; use Exp_Ch6; with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7; with Exp_Ch7; use Exp_Ch7;
with Exp_Ch11; use Exp_Ch11; with Exp_Ch11; use Exp_Ch11;
...@@ -472,6 +473,169 @@ package body Exp_Util is ...@@ -472,6 +473,169 @@ package body Exp_Util is
end if; end if;
end Append_Freeze_Actions; 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 -- -- Build_Allocate_Deallocate_Proc --
------------------------------------ ------------------------------------
......
gcc/ada/exp_util.ads
...@@ -240,6 +240,10 @@ package Exp_Util is ...@@ -240,6 +240,10 @@ package Exp_Util is
-- Note that the added nodes are not analyzed. The analyze call is found in -- Note that the added nodes are not analyzed. The analyze call is found in
-- Exp_Ch13.Expand_N_Freeze_Entity. -- 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 procedure Build_Allocate_Deallocate_Proc
(N : Node_Id; (N : Node_Id;
Is_Allocate : Boolean); Is_Allocate : Boolean);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment