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
Attribute_Unchecked_Access |
Attribute_Unrestricted_Access =>
if Is_Access_Protected_Subprogram_Type (Btyp) then
Expand_Access_To_Protected_Op (N, Pref, Typ);
Access_Cases : declare
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
-- instance of the type, within its initialization procedure.
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);
begin
if Is_Access_Protected_Subprogram_Type (Btyp) then
Expand_Access_To_Protected_Op (N, Pref, Typ);
-- The expression must appear in a default expression, (which
-- in the initialization procedure is the right-hand side of an
-- assignment), and not in a discriminant constraint.
-- If prefix is a type name, this is a reference to the current
-- instance of the type, within its initialization procedure.
else
Par := Parent (N);
while Present (Par) loop
exit when Nkind (Par) = N_Assignment_Statement;
elsif Is_Entity_Name (Pref)
and then Is_Type (Entity (Pref))
then
declare
Par : Node_Id;
Formal : Entity_Id;
if Nkind (Par) = N_Component_Declaration then
return;
end if;
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;
Par := Parent (Par);
end loop;
pragma Assert (Present (Formal));
if Present (Par) then
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Attribute_Name => Attribute_Name (N)));
Unchecked_Convert_To (Typ,
New_Occurrence_Of (Formal, Loc)));
Set_Etype (N, Typ);
Analyze_And_Resolve (N, Typ);
end if;
end if;
end;
-- The expression must appear in a default expression,
-- (which in the initialization procedure is the
-- right-hand side of an assignment), and not in a
-- discriminant constraint.
-- The following handles cases involving interfaces and when the
-- prefix of an access attribute is an explicit dereference. In the
-- case where the access attribute is specifically Attribute_Access,
-- we only do this when the context type is E_General_Access_Type,
-- 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;
else
Par := Parent (N);
while Present (Par) loop
exit when Nkind (Par) = N_Assignment_Statement;
begin
-- 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 (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 Nkind (Par) = N_Component_Declaration then
return;
end if;
if Ekind (Parm_Ent) in Formal_Kind
and then Ekind (Etype (Parm_Ent)) = E_Anonymous_Access_Type
and then Present (Extra_Accessibility (Parm_Ent))
then
Conversion :=
Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object)));
Par := Parent (Par);
end loop;
Rewrite (N, Conversion);
Analyze_And_Resolve (N, Typ);
if Present (Par) then
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;
-- Ada 2005 (AI-251): If the designated type is an interface,
-- then rewrite the referenced object as a conversion, to force
-- the displacement of the pointer to the secondary dispatch
-- table.
-- 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))
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
-- the dereference's prefix.
elsif Is_Interface (Btyp_DDT)
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
Conversion :=
Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object)));
-- No implicit conversion required if types match
-- It seems rather bizarre that we generate a conversion of
-- a tagged object to an access type, since such conversions
-- are not normally permitted, but Expand_N_Type_Conversion
-- (actually Expand_Interface_Conversion) is designed to
-- handle them in the interface case. Do we really want to
-- create such odd conversions???
if Btyp_DDT /= Etype (Ref_Object) then
Rewrite (Prefix (N),
Convert_To (Directly_Designated_Type (Typ),
New_Copy_Tree (Prefix (N))));
else
Conversion :=
Convert_To (Typ, New_Copy_Tree (Ref_Object));
Analyze_And_Resolve (Prefix (N),
Directly_Designated_Type (Typ));
end if;
Rewrite (N, Conversion);
Analyze_And_Resolve (N, Typ);
-- When the object is an explicit dereference, convert the
-- 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;
end if;
end if;
end Access_Cases;
--------------
-- Adjacent --
......
gcc/ada/exp_disp.adb
......@@ -1011,7 +1011,6 @@ package body Exp_Disp is
------------------------------
procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
Loc : constant Source_Ptr := Sloc (Call_Node);
Actual : Node_Id;
Actual_Dup : Node_Id;
Actual_Typ : Entity_Id;
......@@ -1020,7 +1019,6 @@ package body Exp_Disp is
Formal : Entity_Id;
Formal_Typ : Entity_Id;
Subp : Entity_Id;
Nam : Name_Id;
Formal_DDT : Entity_Id;
Actual_DDT : Entity_Id;
......@@ -1106,18 +1104,13 @@ package body Exp_Disp is
(Attribute_Name (Actual) = Name_Access
or else Attribute_Name (Actual) = Name_Unchecked_Access)
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));
Rewrite (Actual, Conversion);
Analyze_And_Resolve (Actual, Formal_DDT);
Rewrite (Actual,
Unchecked_Convert_To (Formal_Typ,
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Actual),
Attribute_Name => Nam)));
Analyze_And_Resolve (Actual, Formal_Typ);
pragma Assert (Base_Type (Etype (Prefix (Actual)))
= Base_Type (Formal_DDT));
null;
-- No need to displace the pointer if the type of the actual
-- 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