From 77630ba95a5b0220fdbb460727cf12e45a0c1115 Mon Sep 17 00:00:00 2001 From: Steve Baird Date: Thu, 29 Apr 2021 11:44:29 -0700 Subject: [PATCH] [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. --- gcc/ada/exp_ch3.adb | 51 ++++++++++++++++++++------------------------------- gcc/ada/sem_util.adb | 13 ++++++++++++- 2 files changed, 32 insertions(+), 32 deletions(-) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 2f997a3..504410d 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1926,6 +1926,7 @@ package body Exp_Ch3 is Proc_Id : Entity_Id; Rec_Type : Entity_Id; Set_Tag : Entity_Id := Empty; + Has_Late_Init_Comp : Boolean := False; -- set in Build_Init_Statements function Build_Assignment (Id : Entity_Id; @@ -2021,35 +2022,27 @@ package body Exp_Ch3 is Selector_Name => New_Occurrence_Of (Id, Default_Loc)); 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 -- declaration in derived types see the original tree, not a node -- rewritten during expansion of the init_proc. If the copy contains -- 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 ( Make_Assignment_Statement (Loc, @@ -2981,7 +2974,6 @@ package body Exp_Ch3 is Counter_Id : Entity_Id := Empty; Comp_Loc : Source_Ptr; Decl : Node_Id; - Has_Late_Init_Comp : Boolean; Id : Entity_Id; Parent_Stmts : List_Id; Stmts : List_Id; @@ -3097,10 +3089,9 @@ package body Exp_Ch3 is function Find_Current_Instance (N : Node_Id) return Traverse_Result is begin - if Nkind (N) = N_Attribute_Reference - and then Is_Access_Type (Etype (N)) - and then Is_Entity_Name (Prefix (N)) - and then Is_Type (Entity (Prefix (N))) + if Is_Entity_Name (N) + and then Present (Entity (N)) + and then Is_Current_Instance (N) then References_Current_Instance := True; return Abandon; @@ -3255,8 +3246,6 @@ package body Exp_Ch3 is -- step deals with regular components. The second step deals with -- components that require late initialization. - Has_Late_Init_Comp := False; - -- First pass : regular components Decl := First_Non_Pragma (Component_Items (Comp_List)); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index ef575d0..7ea809b 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -15691,6 +15691,15 @@ package body Sem_Util is -- statement is aliased if its type is immutably limited. 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))); 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 -- 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; ------------------------- -- 2.7.4