Skip to content

R
riscv-gcc-1
Commit 3192631e by Javier Miranda Committed by Arnaud Charlet
Options

exp_attr.adb (Expand_N_Attribute_Reference): Case Access, Unchecked_Access, and… 

exp_attr.adb (Expand_N_Attribute_Reference): Case Access, Unchecked_Access, and Unrestricted_Access.

2007-10-15  Javier Miranda  <miranda@adacore.com>

	* exp_attr.adb (Expand_N_Attribute_Reference): Case Access,
	Unchecked_Access, and Unrestricted_Access. Cleanup code that takes
	care of access to class-wide interface types plus removal of bizarre
	conversion of tagged object to access type (reported by Gary
	Dismukes). After this patch there is no need to perform any
	additional management on these nodes in Expand_Interface_Actuals.

	* exp_disp.adb (Expand_Interface_Actuals): Code cleanup. Remove code
	that handles use of 'Access and 'Unchecked_Access applied to
	actuals covering interface types. Such code is now
	centralized in Expand_N_Attribute_Reference.

From-SVN: r129322
parent a8ee4645
Showing with 132 additions and 139 deletions
gcc/ada/exp_attr.adb
...@@ -606,155 +606,155 @@ package body Exp_Attr is ...@@ -606,155 +606,155 @@ package body Exp_Attr is
Attribute_Unchecked_Access | Attribute_Unchecked_Access |
Attribute_Unrestricted_Access => Attribute_Unrestricted_Access =>
if Is_Access_Protected_Subprogram_Type (Btyp) then Access_Cases : declare
Expand_Access_To_Protected_Op (N, Pref, Typ); Btyp_DDT : constant Entity_Id := Directly_Designated_Type (Btyp);
Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
-- If the prefix is a type name, this is a reference to the current begin
-- instance of the type, within its initialization procedure. if Is_Access_Protected_Subprogram_Type (Btyp) then
Expand_Access_To_Protected_Op (N, Pref, Typ);
elsif Is_Entity_Name (Pref)
and then Is_Type (Entity (Pref))
then
declare
Par : Node_Id;
Formal : Entity_Id;
begin
-- If the current instance name denotes a task type, then the
-- access attribute is rewritten to be the name of the "_task"
-- parameter associated with the task type's task procedure.
-- An unchecked conversion is applied to ensure a type match in
-- cases of expander-generated calls (e.g., init procs).
if Is_Task_Type (Entity (Pref)) then
Formal :=
First_Entity (Get_Task_Body_Procedure (Entity (Pref)));
while Present (Formal) loop
exit when Chars (Formal) = Name_uTask;
Next_Entity (Formal);
end loop;
pragma Assert (Present (Formal));
Rewrite (N,
Unchecked_Convert_To (Typ,
New_Occurrence_Of (Formal, Loc)));
Set_Etype (N, Typ);
-- The expression must appear in a default expression, (which -- If prefix is a type name, this is a reference to the current
-- in the initialization procedure is the right-hand side of an -- instance of the type, within its initialization procedure.
-- assignment), and not in a discriminant constraint.
else elsif Is_Entity_Name (Pref)
Par := Parent (N); and then Is_Type (Entity (Pref))
while Present (Par) loop then
exit when Nkind (Par) = N_Assignment_Statement; declare
Par : Node_Id;
Formal : Entity_Id;
if Nkind (Par) = N_Component_Declaration then begin
return; -- If the current instance name denotes a task type, then
end if; -- the access attribute is rewritten to be the name of the
-- "_task" parameter associated with the task type's task
-- procedure. An unchecked conversion is applied to ensure
-- a type match in cases of expander-generated calls (e.g.
-- init procs).
if Is_Task_Type (Entity (Pref)) then
Formal :=
First_Entity (Get_Task_Body_Procedure (Entity (Pref)));
while Present (Formal) loop
exit when Chars (Formal) = Name_uTask;
Next_Entity (Formal);
end loop;
Par := Parent (Par); pragma Assert (Present (Formal));
end loop;
if Present (Par) then
Rewrite (N, Rewrite (N,
Make_Attribute_Reference (Loc, Unchecked_Convert_To (Typ,
Prefix => Make_Identifier (Loc, Name_uInit), New_Occurrence_Of (Formal, Loc)));
Attribute_Name => Attribute_Name (N))); Set_Etype (N, Typ);
Analyze_And_Resolve (N, Typ); -- The expression must appear in a default expression,
end if; -- (which in the initialization procedure is the
end if; -- right-hand side of an assignment), and not in a
end; -- discriminant constraint.
-- The following handles cases involving interfaces and when the else
-- prefix of an access attribute is an explicit dereference. In the Par := Parent (N);
-- case where the access attribute is specifically Attribute_Access, while Present (Par) loop
-- we only do this when the context type is E_General_Access_Type, exit when Nkind (Par) = N_Assignment_Statement;
-- and not for anonymous access types. It seems that this code should
-- be used for anonymous contexts as well, but that causes various
-- regressions, such as on prefix-notation calls to dispatching
-- operations and back-end errors on access type conversions. ???
elsif Id /= Attribute_Access
or else Ekind (Btyp) = E_General_Access_Type
then
declare
Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
Parm_Ent : Entity_Id;
Conversion : Node_Id;
begin if Nkind (Par) = N_Component_Declaration then
-- If the prefix of an Access attribute is a dereference of an return;
-- access parameter (or a renaming of such a dereference) and end if;
-- 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 (and consistent with existing comment).
if Nkind (Ref_Object) = N_Explicit_Dereference
and then Is_Entity_Name (Prefix (Ref_Object))
and then Id = Attribute_Access
then
Parm_Ent := Entity (Prefix (Ref_Object));
if Ekind (Parm_Ent) in Formal_Kind Par := Parent (Par);
and then Ekind (Etype (Parm_Ent)) = E_Anonymous_Access_Type end loop;
and then Present (Extra_Accessibility (Parm_Ent))
then
Conversion :=
Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object)));
Rewrite (N, Conversion); if Present (Par) then
Analyze_And_Resolve (N, Typ); Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Attribute_Name => Attribute_Name (N)));
return; Analyze_And_Resolve (N, Typ);
end if;
end if; end if;
end if; end;
-- Ada 2005 (AI-251): If the designated type is an interface, -- If the prefix of an Access attribute is a dereference of an
-- then rewrite the referenced object as a conversion, to force -- access parameter (or a renaming of such a dereference) and
-- the displacement of the pointer to the secondary dispatch -- the context is a general access type (but not an anonymous
-- table. -- 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))
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))))
= E_Anonymous_Access_Type
and then Present (Extra_Accessibility
(Entity (Prefix (Ref_Object))))
then
Rewrite (N,
Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object))));
Analyze_And_Resolve (N, Typ);
if Is_Interface (Directly_Designated_Type (Btyp)) then -- Ada 2005 (AI-251): If the designated type is an interface we
-- add an implicit conversion to force the displacement of the
-- pointer to reference the secondary dispatch table.
-- When the object is an explicit dereference, just convert elsif Is_Interface (Btyp_DDT)
-- the dereference's prefix. and then (Comes_From_Source (N)
or else Comes_From_Source (Ref_Object)
or else (Nkind (Ref_Object) in N_Has_Chars
and then Chars (Ref_Object) = Name_uInit))
then
if Nkind (Ref_Object) /= N_Explicit_Dereference then
if Nkind (Ref_Object) = N_Explicit_Dereference then -- No implicit conversion required if types match
Conversion :=
Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object)));
-- It seems rather bizarre that we generate a conversion of if Btyp_DDT /= Etype (Ref_Object) then
-- a tagged object to an access type, since such conversions Rewrite (Prefix (N),
-- are not normally permitted, but Expand_N_Type_Conversion Convert_To (Directly_Designated_Type (Typ),
-- (actually Expand_Interface_Conversion) is designed to New_Copy_Tree (Prefix (N))));
-- handle them in the interface case. Do we really want to
-- create such odd conversions???
else Analyze_And_Resolve (Prefix (N),
Conversion := Directly_Designated_Type (Typ));
Convert_To (Typ, New_Copy_Tree (Ref_Object));
end if; end if;
Rewrite (N, Conversion); -- When the object is an explicit dereference, convert the
Analyze_And_Resolve (N, Typ); -- dereference's prefix.
else
declare
Obj_DDT : constant Entity_Id :=
Base_Type
(Directly_Designated_Type
(Etype (Prefix (Ref_Object))));
begin
-- No implicit conversion required if designated types
-- match.
if Obj_DDT /= Btyp_DDT
and then not (Is_Class_Wide_Type (Obj_DDT)
and then Etype (Obj_DDT) = Btyp_DDT)
then
Rewrite (N,
Convert_To (Typ,
New_Copy_Tree (Prefix (Ref_Object))));
Analyze_And_Resolve (N, Typ);
end if;
end;
end if; end if;
end; end if;
end if; end Access_Cases;
-------------- --------------
-- Adjacent -- -- Adjacent --
......
gcc/ada/exp_disp.adb
...@@ -1011,7 +1011,6 @@ package body Exp_Disp is ...@@ -1011,7 +1011,6 @@ package body Exp_Disp is
------------------------------ ------------------------------
procedure Expand_Interface_Actuals (Call_Node : Node_Id) is procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
Loc : constant Source_Ptr := Sloc (Call_Node);
Actual : Node_Id; Actual : Node_Id;
Actual_Dup : Node_Id; Actual_Dup : Node_Id;
Actual_Typ : Entity_Id; Actual_Typ : Entity_Id;
...@@ -1020,7 +1019,6 @@ package body Exp_Disp is ...@@ -1020,7 +1019,6 @@ package body Exp_Disp is
Formal : Entity_Id; Formal : Entity_Id;
Formal_Typ : Entity_Id; Formal_Typ : Entity_Id;
Subp : Entity_Id; Subp : Entity_Id;
Nam : Name_Id;
Formal_DDT : Entity_Id; Formal_DDT : Entity_Id;
Actual_DDT : Entity_Id; Actual_DDT : Entity_Id;
...@@ -1106,18 +1104,13 @@ package body Exp_Disp is ...@@ -1106,18 +1104,13 @@ package body Exp_Disp is
(Attribute_Name (Actual) = Name_Access (Attribute_Name (Actual) = Name_Access
or else Attribute_Name (Actual) = Name_Unchecked_Access) or else Attribute_Name (Actual) = Name_Unchecked_Access)
then then
Nam := Attribute_Name (Actual); -- This case must have been handled by the analysis and
-- expansion of 'Access. The only exception is when types
-- match and no further expansion is required.
Conversion := Convert_To (Formal_DDT, Prefix (Actual)); pragma Assert (Base_Type (Etype (Prefix (Actual)))
Rewrite (Actual, Conversion); = Base_Type (Formal_DDT));
Analyze_And_Resolve (Actual, Formal_DDT); null;
Rewrite (Actual,
Unchecked_Convert_To (Formal_Typ,
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Actual),
Attribute_Name => Nam)));
Analyze_And_Resolve (Actual, Formal_Typ);
-- No need to displace the pointer if the type of the actual -- No need to displace the pointer if the type of the actual
-- coincides with the type of the formal. -- coincides with the type of the formal.
......
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