From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 7871) id C67D9385841B; Tue, 20 Jun 2023 07:46:31 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org C67D9385841B DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1687247191; bh=MSeKBiUWrz8jt3tQI4tcI80ThVqhbN+g4u6mHuZ90zU=; h=From:To:Subject:Date:From; b=mPtQfu0+MKhsfJc8MfIT9dyzq7wH6xf56HFQ4goaf0TnOeXiDZn/I0+QlGuFBn3tm JuXPes6vzcRi8vW9x5DtyOW/Ok97UL83Qdaoy519iH6ZmcDqRRXqlYSMsBjF6JWLck h7yvN1iIe5a5OhK//D54gY/gZ1XORb3qxBphM7+s= MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Marc Poulhi?s To: gcc-cvs@gcc.gnu.org Subject: [gcc r14-1969] ada: Small fixes to handling of private views in instances X-Act-Checkin: gcc X-Git-Author: Eric Botcazou X-Git-Refname: refs/heads/master X-Git-Oldrev: d22792bc24fa1df6d23ace67ca127fdcde979031 X-Git-Newrev: ccacd752a4a58f34b768122a1e463e8ca5f2728e Message-Id: <20230620074631.C67D9385841B@sourceware.org> Date: Tue, 20 Jun 2023 07:46:31 +0000 (GMT) List-Id: https://gcc.gnu.org/g:ccacd752a4a58f34b768122a1e463e8ca5f2728e commit r14-1969-gccacd752a4a58f34b768122a1e463e8ca5f2728e Author: Eric Botcazou Date: Mon May 29 12:02:28 2023 +0200 ada: Small fixes to handling of private views in instances The main change is the removal of the special bypass for private views in Resolve_Implicit_Dereference, which in exchange requires additional work in Check_Generic_Actuals and a couple more calls to Set_Global_Type in Save_References_In_Identifier. This also removes an unused parameter in Convert_View and adds a missing comment in Build_Derived_Record_Type. gcc/ada/ * exp_ch7.adb (Convert_View): Remove Ind parameter and adjust. * sem_ch12.adb (Check_Generic_Actuals): Check the type of both in and in out actual objects, as well as the type of formal parameters of actual subprograms. Extend the condition under which the views are swapped to nested generic constructs. (Save_References_In_Identifier): Call Set_Global_Type on a global identifier rewritten as an explicit dereference, either directly or after having first been rewritten as a function call. (Save_References_In_Operator): Set N2 unconditionally and reuse it. * sem_ch3.adb (Build_Derived_Record_Type): Add missing comment. * sem_res.adb (Resolve_Implicit_Dereference): Remove special bypass for private views in instances. Diff: --- gcc/ada/exp_ch7.adb | 24 ++------- gcc/ada/sem_ch12.adb | 139 +++++++++++++++++++++++++++++---------------------- gcc/ada/sem_ch3.adb | 9 +++- gcc/ada/sem_res.adb | 11 ---- 4 files changed, 92 insertions(+), 91 deletions(-) diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 42b41e5cf6b..f82301c0acd 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -394,13 +394,9 @@ package body Exp_Ch7 is -- Check recursively whether a loop or block contains a subprogram that -- may need an activation record. - function Convert_View - (Proc : Entity_Id; - Arg : Node_Id; - Ind : Pos := 1) return Node_Id; + function Convert_View (Proc : Entity_Id; Arg : Node_Id) return Node_Id; -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the - -- argument being passed to it. Ind indicates which formal of procedure - -- Proc we are trying to match. This function will, if necessary, generate + -- argument being passed to it. This function will, if necessary, generate -- a conversion between the partial and full view of Arg to match the type -- of the formal of Proc, or force a conversion to the class-wide type in -- the case where the operation is abstract. @@ -4402,22 +4398,12 @@ package body Exp_Ch7 is -- Convert_View -- ------------------ - function Convert_View - (Proc : Entity_Id; - Arg : Node_Id; - Ind : Pos := 1) return Node_Id - is - Fent : Entity_Id := First_Entity (Proc); - Ftyp : Entity_Id; + function Convert_View (Proc : Entity_Id; Arg : Node_Id) return Node_Id is + Ftyp : constant Entity_Id := Etype (First_Formal (Proc)); + Atyp : Entity_Id; begin - for J in 2 .. Ind loop - Next_Entity (Fent); - end loop; - - Ftyp := Etype (Fent); - if Nkind (Arg) in N_Type_Conversion | N_Unchecked_Type_Conversion then Atyp := Entity (Subtype_Mark (Arg)); else diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index f584a9f3fb5..a65bd0fdfb5 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -6964,8 +6964,61 @@ package body Sem_Ch12 is (Instance : Entity_Id; Is_Formal_Box : Boolean) is - E : Entity_Id; + Gen_Id : constant Entity_Id + := (if Is_Generic_Unit (Instance) then + Instance + elsif Is_Wrapper_Package (Instance) then + Generic_Parent + (Specification + (Unit_Declaration_Node (Related_Instance (Instance)))) + else + Generic_Parent (Package_Specification (Instance))); + -- The generic unit + + Parent_Scope : constant Entity_Id := Scope (Gen_Id); + -- The enclosing scope of the generic unit + + procedure Check_Actual_Type (Typ : Entity_Id); + -- If the type of the actual is a private type declared in the + -- enclosing scope of the generic unit, the body of the generic + -- sees the full view of the type (because it has to appear in + -- the corresponding package body). If the type is private now, + -- exchange views to restore the proper visibility in the instance. + + ----------------------- + -- Check_Actual_Type -- + ----------------------- + + procedure Check_Actual_Type (Typ : Entity_Id) is + Btyp : constant Entity_Id := Base_Type (Typ); + + begin + -- The exchange is only needed if the generic is defined + -- within a package which is not a common ancestor of the + -- scope of the instance, and is not already in scope. + + if Is_Private_Type (Btyp) + and then Scope (Btyp) = Parent_Scope + and then Ekind (Parent_Scope) in E_Package | E_Generic_Package + and then Scope (Instance) /= Parent_Scope + and then not Is_Child_Unit (Gen_Id) + then + Switch_View (Btyp); + + -- If the type of the entity is a subtype, it may also have + -- to be made visible, together with the base type of its + -- full view, after exchange. + + if Is_Private_Type (Typ) then + Switch_View (Typ); + Switch_View (Base_Type (Typ)); + end if; + end if; + end Check_Actual_Type; + Astype : Entity_Id; + E : Entity_Id; + Formal : Node_Id; begin E := First_Entity (Instance); @@ -7083,60 +7136,22 @@ package body Sem_Ch12 is Set_Is_Hidden (E, False); end if; - if Ekind (E) = E_Constant then - - -- If the type of the actual is a private type declared in the - -- enclosing scope of the generic unit, the body of the generic - -- sees the full view of the type (because it has to appear in - -- the corresponding package body). If the type is private now, - -- exchange views to restore the proper visiblity in the instance. - - declare - Typ : constant Entity_Id := Base_Type (Etype (E)); - -- The type of the actual - - Gen_Id : Entity_Id; - -- The generic unit - - Parent_Scope : Entity_Id; - -- The enclosing scope of the generic unit - - begin - if Is_Wrapper_Package (Instance) then - Gen_Id := - Generic_Parent - (Specification - (Unit_Declaration_Node - (Related_Instance (Instance)))); - else - Gen_Id := - Generic_Parent (Package_Specification (Instance)); - end if; - - Parent_Scope := Scope (Gen_Id); + -- Check directly the type of the actual objects - -- The exchange is only needed if the generic is defined - -- within a package which is not a common ancestor of the - -- scope of the instance, and is not already in scope. + if Ekind (E) in E_Constant | E_Variable then + Check_Actual_Type (Etype (E)); - if Is_Private_Type (Typ) - and then Scope (Typ) = Parent_Scope - and then Scope (Instance) /= Parent_Scope - and then Ekind (Parent_Scope) = E_Package - and then not Is_Child_Unit (Gen_Id) - then - Switch_View (Typ); + -- As well as the type of formal parameters of actual subprograms - -- If the type of the entity is a subtype, it may also have - -- to be made visible, together with the base type of its - -- full view, after exchange. - - if Is_Private_Type (Etype (E)) then - Switch_View (Etype (E)); - Switch_View (Base_Type (Etype (E))); - end if; - end if; - end; + elsif Ekind (E) in E_Function | E_Procedure + and then Is_Generic_Actual_Subprogram (E) + and then Present (Alias (E)) + then + Formal := First_Formal (Alias (E)); + while Present (Formal) loop + Check_Actual_Type (Etype (Formal)); + Next_Formal (Formal); + end loop; end if; Next_Entity (E); @@ -16561,8 +16576,10 @@ package body Sem_Ch12 is and then Is_Global (Entity (Prefix (N2))) then Set_Associated_Node (N, Prefix (N2)); + Set_Global_Type (N, Prefix (N2)); elsif Nkind (Prefix (N2)) = N_Function_Call + and then Is_Entity_Name (Name (Prefix (N2))) and then Present (Entity (Name (Prefix (N2)))) and then Is_Global (Entity (Name (Prefix (N2)))) then @@ -16573,6 +16590,9 @@ package body Sem_Ch12 is Name => New_Occurrence_Of (Entity (Name (Prefix (N2))), Loc)))); + Set_Associated_Node + (Name (Prefix (N)), Name (Prefix (N2))); + Set_Global_Type (Name (Prefix (N)), Name (Prefix (N2))); else Set_Associated_Node (N, Empty); @@ -16598,15 +16618,16 @@ package body Sem_Ch12 is procedure Save_References_In_Operator (N : Node_Id) is begin + N2 := Get_Associated_Node (N); + -- The node did not undergo a transformation - if Nkind (N) = Nkind (Get_Associated_Node (N)) then + if Nkind (N) = Nkind (N2) then if Nkind (N) = N_Op_Concat then - Set_Is_Component_Left_Opnd (N, - Is_Component_Left_Opnd (Get_Associated_Node (N))); - - Set_Is_Component_Right_Opnd (N, - Is_Component_Right_Opnd (Get_Associated_Node (N))); + Set_Is_Component_Left_Opnd + (N, Is_Component_Left_Opnd (N2)); + Set_Is_Component_Right_Opnd + (N, Is_Component_Right_Opnd (N2)); end if; Reset_Entity (N); @@ -16616,8 +16637,6 @@ package body Sem_Ch12 is -- applicable. else - N2 := Get_Associated_Node (N); - -- The operator resoved to a function call if Nkind (N2) = N_Function_Call then diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index b9302aae2a9..fb63690803b 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -9037,9 +9037,16 @@ package body Sem_Ch3 is -- Start of processing for Build_Derived_Record_Type begin + -- If the parent type is a private extension with discriminants, we + -- need to have an unconstrained type on which to apply the inherited + -- constraint, so we get to the full view. However, this means that the + -- derived type and its implicit base type created below will not point + -- to the same view of their respective parent type and, thus, special + -- glue code like Exp_Ch7.Convert_View is needed to bridge this gap. + if Ekind (Parent_Type) = E_Record_Type_With_Private - and then Present (Full_View (Parent_Type)) and then Has_Discriminants (Parent_Type) + and then Present (Full_View (Parent_Type)) then Parent_Base := Base_Type (Full_View (Parent_Type)); else diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 41787f3d2bc..266cf8e559e 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -9601,17 +9601,6 @@ package body Sem_Res is Desig_Typ : Entity_Id; begin - -- In an instance the proper view may not always be correct for - -- private types, see e.g. Sem_Type.Covers for similar handling. - - if Is_Private_Type (Etype (P)) - and then Present (Full_View (Etype (P))) - and then Is_Access_Type (Full_View (Etype (P))) - and then In_Instance - then - Set_Etype (P, Full_View (Etype (P))); - end if; - if Is_Access_Type (Etype (P)) then Desig_Typ := Implicitly_Designated_Type (Etype (P)); Insert_Explicit_Dereference (P);