[Ada] Fix some "current instance" bugs
gcc/ada/ * exp_ch3.adb (Build_Record_Init_Proc.Build_Assignment): When building the assignment statement corresponding to the default expression for a component, we make a copy of the expression. When making that copy (and if we have seen a component that requires late initialization), pass a Map parameter into the call to New_Copy_Tree to redirect references to the type to instead refer to the _Init formal parameter of the init proc. This includes hoisting the declaration of Has_Late_Init_Comp out one level so that it becomes available to Build_Assignment. (Find_Current_Instance): Return True for other kinds of current instance references, instead of just access-valued attribute references such as T'Access. * sem_util.adb (Is_Aliased_View): Return True for the _Init formal parameter of an init procedure. The changes in exp_ch3.adb can have the effect of replacing a "T'Access" attribute reference in an init procedure with an "_Init'Access" attribute reference. We want such an attribute reference to be legal. However, we do not simply mark the formal parameter as being aliased because that might impact callers. (Is_Object_Image): Return True if Is_Current_Instance returns True for the prefix of an Image (or related attribute) attribute reference.
This commit is contained in:
parent
6cf7cc8ccf
commit
77630ba95a
|
@ -1926,6 +1926,7 @@ package body Exp_Ch3 is
|
||||||
Proc_Id : Entity_Id;
|
Proc_Id : Entity_Id;
|
||||||
Rec_Type : Entity_Id;
|
Rec_Type : Entity_Id;
|
||||||
Set_Tag : Entity_Id := Empty;
|
Set_Tag : Entity_Id := Empty;
|
||||||
|
Has_Late_Init_Comp : Boolean := False; -- set in Build_Init_Statements
|
||||||
|
|
||||||
function Build_Assignment
|
function Build_Assignment
|
||||||
(Id : Entity_Id;
|
(Id : Entity_Id;
|
||||||
|
@ -2021,35 +2022,27 @@ package body Exp_Ch3 is
|
||||||
Selector_Name => New_Occurrence_Of (Id, Default_Loc));
|
Selector_Name => New_Occurrence_Of (Id, Default_Loc));
|
||||||
Set_Assignment_OK (Lhs);
|
Set_Assignment_OK (Lhs);
|
||||||
|
|
||||||
-- Case of an access attribute applied to the current instance.
|
|
||||||
-- Replace the reference to the type by a reference to the actual
|
|
||||||
-- object. (Note that this handles the case of the top level of
|
|
||||||
-- the expression being given by such an attribute, but does not
|
|
||||||
-- cover uses nested within an initial value expression. Nested
|
|
||||||
-- uses are unlikely to occur in practice, but are theoretically
|
|
||||||
-- possible.) It is not clear how to handle them without fully
|
|
||||||
-- traversing the expression. ???
|
|
||||||
|
|
||||||
if Kind = N_Attribute_Reference
|
|
||||||
and then Attribute_Name (Default) in Name_Unchecked_Access
|
|
||||||
| Name_Unrestricted_Access
|
|
||||||
and then Is_Entity_Name (Prefix (Default))
|
|
||||||
and then Is_Type (Entity (Prefix (Default)))
|
|
||||||
and then Entity (Prefix (Default)) = Rec_Type
|
|
||||||
then
|
|
||||||
Exp :=
|
|
||||||
Make_Attribute_Reference (Default_Loc,
|
|
||||||
Prefix =>
|
|
||||||
Make_Identifier (Default_Loc, Name_uInit),
|
|
||||||
Attribute_Name => Name_Unrestricted_Access);
|
|
||||||
end if;
|
|
||||||
|
|
||||||
-- Take a copy of Exp to ensure that later copies of this component
|
-- Take a copy of Exp to ensure that later copies of this component
|
||||||
-- declaration in derived types see the original tree, not a node
|
-- declaration in derived types see the original tree, not a node
|
||||||
-- rewritten during expansion of the init_proc. If the copy contains
|
-- rewritten during expansion of the init_proc. If the copy contains
|
||||||
-- itypes, the scope of the new itypes is the init_proc being built.
|
-- itypes, the scope of the new itypes is the init_proc being built.
|
||||||
|
|
||||||
Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id);
|
declare
|
||||||
|
Map : Elist_Id := No_Elist;
|
||||||
|
begin
|
||||||
|
if Has_Late_Init_Comp then
|
||||||
|
-- Map the type to the _Init parameter in order to
|
||||||
|
-- handle "current instance" references.
|
||||||
|
|
||||||
|
Map := New_Elmt_List
|
||||||
|
(Elmt1 => Rec_Type,
|
||||||
|
Elmt2 => Defining_Identifier (First
|
||||||
|
(Parameter_Specifications
|
||||||
|
(Parent (Proc_Id)))));
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id, Map => Map);
|
||||||
|
end;
|
||||||
|
|
||||||
Res := New_List (
|
Res := New_List (
|
||||||
Make_Assignment_Statement (Loc,
|
Make_Assignment_Statement (Loc,
|
||||||
|
@ -2981,7 +2974,6 @@ package body Exp_Ch3 is
|
||||||
Counter_Id : Entity_Id := Empty;
|
Counter_Id : Entity_Id := Empty;
|
||||||
Comp_Loc : Source_Ptr;
|
Comp_Loc : Source_Ptr;
|
||||||
Decl : Node_Id;
|
Decl : Node_Id;
|
||||||
Has_Late_Init_Comp : Boolean;
|
|
||||||
Id : Entity_Id;
|
Id : Entity_Id;
|
||||||
Parent_Stmts : List_Id;
|
Parent_Stmts : List_Id;
|
||||||
Stmts : List_Id;
|
Stmts : List_Id;
|
||||||
|
@ -3097,10 +3089,9 @@ package body Exp_Ch3 is
|
||||||
function Find_Current_Instance
|
function Find_Current_Instance
|
||||||
(N : Node_Id) return Traverse_Result is
|
(N : Node_Id) return Traverse_Result is
|
||||||
begin
|
begin
|
||||||
if Nkind (N) = N_Attribute_Reference
|
if Is_Entity_Name (N)
|
||||||
and then Is_Access_Type (Etype (N))
|
and then Present (Entity (N))
|
||||||
and then Is_Entity_Name (Prefix (N))
|
and then Is_Current_Instance (N)
|
||||||
and then Is_Type (Entity (Prefix (N)))
|
|
||||||
then
|
then
|
||||||
References_Current_Instance := True;
|
References_Current_Instance := True;
|
||||||
return Abandon;
|
return Abandon;
|
||||||
|
@ -3255,8 +3246,6 @@ package body Exp_Ch3 is
|
||||||
-- step deals with regular components. The second step deals with
|
-- step deals with regular components. The second step deals with
|
||||||
-- components that require late initialization.
|
-- components that require late initialization.
|
||||||
|
|
||||||
Has_Late_Init_Comp := False;
|
|
||||||
|
|
||||||
-- First pass : regular components
|
-- First pass : regular components
|
||||||
|
|
||||||
Decl := First_Non_Pragma (Component_Items (Comp_List));
|
Decl := First_Non_Pragma (Component_Items (Comp_List));
|
||||||
|
|
|
@ -15691,6 +15691,15 @@ package body Sem_Util is
|
||||||
-- statement is aliased if its type is immutably limited.
|
-- statement is aliased if its type is immutably limited.
|
||||||
|
|
||||||
or else (Is_Return_Object (E)
|
or else (Is_Return_Object (E)
|
||||||
|
and then Is_Limited_View (Etype (E)))
|
||||||
|
|
||||||
|
-- The current instance of a limited type is aliased, so
|
||||||
|
-- we want to allow uses of T'Access in the init proc for
|
||||||
|
-- a limited type T. However, we don't want to mark the formal
|
||||||
|
-- parameter as being aliased since that could impact callers.
|
||||||
|
|
||||||
|
or else (Is_Formal (E)
|
||||||
|
and then Chars (E) = Name_uInit
|
||||||
and then Is_Limited_View (Etype (E)));
|
and then Is_Limited_View (Etype (E)));
|
||||||
|
|
||||||
elsif Nkind (Obj) = N_Selected_Component then
|
elsif Nkind (Obj) = N_Selected_Component then
|
||||||
|
@ -18838,7 +18847,9 @@ package body Sem_Util is
|
||||||
-- This is because the parser always checks that prefixes of attributes
|
-- This is because the parser always checks that prefixes of attributes
|
||||||
-- are named.
|
-- are named.
|
||||||
|
|
||||||
return not (Is_Entity_Name (Prefix) and then Is_Type (Entity (Prefix)));
|
return not (Is_Entity_Name (Prefix)
|
||||||
|
and then Is_Type (Entity (Prefix))
|
||||||
|
and then not Is_Current_Instance (Prefix));
|
||||||
end Is_Object_Image;
|
end Is_Object_Image;
|
||||||
|
|
||||||
-------------------------
|
-------------------------
|
||||||
|
|
Loading…
Reference in New Issue