Skip to content

R
riscv-gcc-1
Commit 01aef5ad by Gary Dismukes Committed by Arnaud Charlet
Options

exp_attr.adb (Enclosing_Object): New function local to handling of access attributes... 

2008-07-31  Gary Dismukes  <dismukes@adacore.com>

	* exp_attr.adb (Enclosing_Object): New function local to handling of
	access attributes,
	for retrieving the innermost enclosing object prefix of a compound name.
	(Expand_N_Attribute_Reference, N_Attribute_Access): In the case where an
	Access attribute has a prefix that is a dereference of an access
	parameter (or the prefix is a subcomponent selected from such a
	dereference), apply an accessibility check to the access parameter.
	Replaces code that rewrote the prefix as a type conversion (and that
	didn't handle subcomponent cases).
	Also, this is now only applied in the case of 'Access.
	
	* exp_ch6.adb (Expand_Call): Add handling for the case of an access
	discriminant passed as an actual to an access formal, passing the
	Object_Access_Level of the object containing the access discriminant.

From-SVN: r138388
parent 1d06f67e
Showing with 90 additions and 52 deletions
gcc/ada/exp_attr.adb
......@@ -651,6 +651,37 @@ package body Exp_Attr is
Btyp_DDT : constant Entity_Id := Directly_Designated_Type (Btyp);
Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
function Enclosing_Object (N : Node_Id) return Node_Id;
-- If N denotes a compound name (selected component, indexed
-- component, or slice), returns the name of the outermost
-- such enclosing object. Otherwise returns N. If the object
-- is a renaming, then the renamed object is returned.
----------------------
-- Enclosing_Object --
----------------------
function Enclosing_Object (N : Node_Id) return Node_Id is
Obj_Name : Node_Id;
begin
Obj_Name := N;
while Nkind_In (Obj_Name, N_Selected_Component,
N_Indexed_Component,
N_Slice)
loop
Obj_Name := Prefix (Obj_Name);
end loop;
return Get_Referenced_Object (Obj_Name);
end Enclosing_Object;
-- Local declarations
Enc_Object : constant Node_Id := Enclosing_Object (Ref_Object);
-- Start of processing for Access_Cases
begin
-- In order to improve the text of error messages, the designated
-- type of access-to-subprogram itypes is set by the semantics as
......@@ -800,35 +831,28 @@ package body Exp_Attr is
end;
-- If the prefix of an Access attribute is a dereference of an
-- access parameter (or a renaming of such a dereference) and
-- the context is a general access type (but not an anonymous
-- access type), then rewrite the attribute as a conversion of
-- the access parameter to the context access type. This will
-- result in an accessibility check being performed, if needed.
-- (X.all'Access => Acc_Type (X))
-- Note: Limit the expansion of an attribute applied to a
-- dereference of an access parameter so that it's only done
-- for 'Access. This fixes a problem with 'Unrestricted_Access
-- that leads to errors in the case where the attribute type
-- is access-to-variable and the access parameter is
-- access-to-constant. The conversion is only done to get
-- accessibility checks, so it makes sense to limit it to
-- 'Access.
elsif Nkind (Ref_Object) = N_Explicit_Dereference
and then Is_Entity_Name (Prefix (Ref_Object))
-- access parameter (or a renaming of such a dereference, or a
-- subcomponent of such a dereference) and the context is a
-- general access type (but not an anonymous access type), then
-- apply an accessibility check to the access parameter. We used
-- to rewrite the access parameter as a type conversion, but that
-- could only be done if the immediate prefix of the Access
-- attribute was the dereference, and didn't handle cases where
-- the attribute is applied to a subcomponent of the dereference,
-- since there's generally no available, appropriate access type
-- to convert to in that case.
elsif Id = Attribute_Access
and then Nkind (Enc_Object) = N_Explicit_Dereference
and then Is_Entity_Name (Prefix (Enc_Object))
and then Ekind (Btyp) = E_General_Access_Type
and then Ekind (Entity (Prefix (Ref_Object))) in Formal_Kind
and then Ekind (Etype (Entity (Prefix (Ref_Object))))
and then Ekind (Entity (Prefix (Enc_Object))) in Formal_Kind
and then Ekind (Etype (Entity (Prefix (Enc_Object))))
= E_Anonymous_Access_Type
and then Present (Extra_Accessibility
(Entity (Prefix (Ref_Object))))
(Entity (Prefix (Enc_Object))))
then
Rewrite (N,
Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object))));
Analyze_And_Resolve (N, Typ);
Apply_Accessibility_Check (Prefix (Enc_Object), Typ);
-- Ada 2005 (AI-251): If the designated type is an interface we
-- add an implicit conversion to force the displacement of the
......
gcc/ada/exp_ch6.adb
-----------------------------------------------------------------------------
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
......@@ -2070,16 +2070,16 @@ package body Exp_Ch6 is
if Ekind (Etype (Prev)) in Private_Kind
and then not Has_Discriminants (Base_Type (Etype (Prev)))
then
Add_Extra_Actual (
New_Occurrence_Of (Standard_False, Loc),
Extra_Constrained (Formal));
Add_Extra_Actual
(New_Occurrence_Of (Standard_False, Loc),
Extra_Constrained (Formal));
elsif Is_Constrained (Etype (Formal))
or else not Has_Discriminants (Etype (Prev))
then
Add_Extra_Actual (
New_Occurrence_Of (Standard_True, Loc),
Extra_Constrained (Formal));
Add_Extra_Actual
(New_Occurrence_Of (Standard_True, Loc),
Extra_Constrained (Formal));
-- Do not produce extra actuals for Unchecked_Union parameters.
-- Jump directly to the end of the loop.
......@@ -2220,7 +2220,7 @@ package body Exp_Ch6 is
else
Add_Extra_Actual
(Make_Integer_Literal (Loc,
Intval => Scope_Depth (Standard_Standard)),
Intval => Scope_Depth (Standard_Standard)),
Extra_Accessibility (Formal));
end if;
end;
......@@ -2231,11 +2231,25 @@ package body Exp_Ch6 is
else
Add_Extra_Actual
(Make_Integer_Literal (Loc,
Intval => Type_Access_Level (Etype (Prev_Orig))),
Intval => Type_Access_Level (Etype (Prev_Orig))),
Extra_Accessibility (Formal));
end if;
-- All cases other than thunks
-- If the actual is an access discriminant, then pass the level
-- of the enclosing object (RM05-3.10.2(12.4/2)).
elsif Nkind (Prev_Orig) = N_Selected_Component
and then Ekind (Entity (Selector_Name (Prev_Orig))) =
E_Discriminant
and then Ekind (Etype (Entity (Selector_Name (Prev_Orig)))) =
E_Anonymous_Access_Type
then
Add_Extra_Actual
(Make_Integer_Literal (Loc,
Intval => Object_Access_Level (Prefix (Prev_Orig))),
Extra_Accessibility (Formal));
-- All other cases
else
case Nkind (Prev_Orig) is
......@@ -2246,20 +2260,20 @@ package body Exp_Ch6 is
-- For X'Access, pass on the level of the prefix X
when Attribute_Access =>
Add_Extra_Actual (
Make_Integer_Literal (Loc,
Intval =>
Object_Access_Level (Prefix (Prev_Orig))),
Extra_Accessibility (Formal));
Add_Extra_Actual
(Make_Integer_Literal (Loc,
Intval =>
Object_Access_Level (Prefix (Prev_Orig))),
Extra_Accessibility (Formal));
-- Treat the unchecked attributes as library-level
when Attribute_Unchecked_Access |
Attribute_Unrestricted_Access =>
Add_Extra_Actual (
Make_Integer_Literal (Loc,
Intval => Scope_Depth (Standard_Standard)),
Extra_Accessibility (Formal));
Add_Extra_Actual
(Make_Integer_Literal (Loc,
Intval => Scope_Depth (Standard_Standard)),
Extra_Accessibility (Formal));
-- No other cases of attributes returning access
-- values that can be passed to access parameters
......@@ -2274,19 +2288,19 @@ package body Exp_Ch6 is
-- current scope level.
when N_Allocator =>
Add_Extra_Actual (
Make_Integer_Literal (Loc,
Scope_Depth (Current_Scope) + 1),
Extra_Accessibility (Formal));
Add_Extra_Actual
(Make_Integer_Literal (Loc,
Intval => Scope_Depth (Current_Scope) + 1),
Extra_Accessibility (Formal));
-- For other cases we simply pass the level of the
-- actual's access type.
when others =>
Add_Extra_Actual (
Make_Integer_Literal (Loc,
Intval => Type_Access_Level (Etype (Prev_Orig))),
Extra_Accessibility (Formal));
Add_Extra_Actual
(Make_Integer_Literal (Loc,
Intval => Type_Access_Level (Etype (Prev_Orig))),
Extra_Accessibility (Formal));
end case;
end if;
......
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