From patchwork Tue May 17 08:27:42 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 54077 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 9C89A3857348 for ; Tue, 17 May 2022 08:43:39 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 9C89A3857348 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1652777019; bh=wIkfP9eECDwrcmHiX8m699RsQ0GoTAvQTkWMjT2iy+I=; h=Date:To:Subject:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:Cc:From; b=wXbAQmgVuBmn9d8G922M+QTCcOIKlyrHHRdkORQjO29nRMAqfjDQ5xPLOrBwz4urP WrgJQGIQ/zr6MNr22UIvZSDxZyuUtSK6bUZ/hmsfkBm/9gu5NEVkKHKert9oO1SrqN 8kdnsxDwgx6C7BH8OlEr+9/sPYiA0cmyRz+4oPDM= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x42f.google.com (mail-wr1-x42f.google.com [IPv6:2a00:1450:4864:20::42f]) by sourceware.org (Postfix) with ESMTPS id D479E385741C for ; Tue, 17 May 2022 08:27:44 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org D479E385741C Received: by mail-wr1-x42f.google.com with SMTP id h14so3999052wrc.6 for ; Tue, 17 May 2022 01:27:44 -0700 (PDT) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:date:from:to:cc:subject:message-id:mime-version :content-disposition; bh=wIkfP9eECDwrcmHiX8m699RsQ0GoTAvQTkWMjT2iy+I=; b=oSGWvbeP234efbt5P9IfR7lF1IZ/MRcFcozbgYyT+e65i6Wht5O7it3kLr8FzsjC9V 4oL3jt+/dofPXvFGn3mzk6Mr1BH0kOT1FbpTktyhbRmK1SacJDNa8BhiEOQDoY0+Ds4s NRFNF2LhiYO+yGuZz2BkOdeChvYJ2l4WOtczWUNzw+yDh5xz4dqznjcKhu2KLG944ZDE lSw/GagbpBppw7f1ZSgpZQLHXnYOp0YS0PHCN5/9OHJHiWNKqFHtWPL+Qfy/IYH8KmVN jxvrThd67bjYAJJJv2DJoc84WPgIedXajB0xEy3AEl+2yCadmbGKQODPVLlPhsOtl4Lv OnKQ== X-Gm-Message-State: AOAM530Ipb+cq2r5+Chc3CeRclZaxRy6cfhJ8wwap4TJYNwH82bptkLj vnx843JUx4JQSaf5mFPFs+xoqNRQW6kO+Fk2 X-Google-Smtp-Source: ABdhPJzzASHl13gH2A4U4sCLdo9l0PA0WyUhzXt0OuuwmhorqKEv4IWSyywZ6PXjGBlbzIXzSp/Nyg== X-Received: by 2002:adf:f887:0:b0:20d:104c:66f4 with SMTP id u7-20020adff887000000b0020d104c66f4mr4871460wrp.528.1652776063688; Tue, 17 May 2022 01:27:43 -0700 (PDT) Received: from adacore.com ([45.147.211.82]) by smtp.gmail.com with ESMTPSA id h22-20020adfaa96000000b0020d0c37b350sm4738198wrc.27.2022.05.17.01.27.42 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 17 May 2022 01:27:43 -0700 (PDT) Date: Tue, 17 May 2022 08:27:42 +0000 To: gcc-patches@gcc.gnu.org Subject: [Ada] Fix bogus visibility error with partially parameterized formal package Message-ID: <20220517082742.GA1089503@adacore.com> MIME-Version: 1.0 Content-Disposition: inline X-Spam-Status: No, score=-12.8 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Pierre-Marie de Rodat via Gcc-patches From: Pierre-Marie de Rodat Reply-To: Pierre-Marie de Rodat Cc: Eric Botcazou Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" The problem comes from the special instantiation (abbreviated instantiation in GNAT parlance) done to check conformance between a formal package and its corresponding actual in a generic instantiation: the compiler instantiates the formal package, in the context of the generic instantiation, so that it can check the conformance of the actual with the result. More precisely, it occurs with formal packages that are only partially parameterized, i.e. that have at least one parameter association and an (others => <>) choice. In this case, RM 12.7(10/2) says that the visible part of the formal package contains a copy of the formal parameters that are not explicitly associated. The analysis of these copies for the abbreviated instantiation is not done in the correct context when the generic unit is a child generic unit. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * sem_ch12.ads (Is_Abbreviated_Instance): Declare. * sem_ch12.adb (Check_Abbreviated_Instance): Declare. (Requires_Conformance_Checking): Declare. (Analyze_Association.Process_Default): Fix subtype of parameter. (Analyze_Formal_Object_Declaration): Check whether it is in the visible part of abbreviated instance. (Analyze_Formal_Subprogram_Declaration): Likewise. (Analyze_Formal_Type_Declaration): Likewise. (Analyze_Package_Instantiation): Do not check for a generic child unit in the case of an abbreviated instance. (Check_Abbreviated_Instance): New procedure. (Check_Formal_Packages): Tidy up. (Copy_Generic_Elist): Fix comment. (Instantiate_Formal_Package): Tidy up. If the generic unit is a child unit, copy the qualified name onto the abbreviated instance. (Is_Abbreviated_Instance): New function. (Collect_Previous_Instances): Call Is_Abbreviated_Instance. (Requires_Conformance_Checking): New function. * sem_ch7.adb (Analyze_Package_Specification): Do not install the private declarations of the parent for an abbreviated instance. diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -516,6 +516,22 @@ package body Sem_Ch12 is -- The body of the wrapper is a call to the actual, with the generated -- pre/postconditon checks added. + procedure Check_Abbreviated_Instance + (N : Node_Id; + Parent_Installed : in out Boolean); + -- If the name of the generic unit in an abbreviated instantiation is an + -- expanded name, then the prefix may be an instance and the selector may + -- designate a child unit. If the parent is installed as a result of this + -- call, then Parent_Installed is set True, otherwise Parent_Installed is + -- unchanged by the call. + + -- This routine needs to be called for declaration nodes of formal objects, + -- types and subprograms to check whether they are the copy, present in the + -- visible part of the abbreviated instantiation of formal packages, of the + -- declaration node of their corresponding formal parameter in the template + -- of the formal package, as specified by RM 12.7(10/2), so as to establish + -- the proper context for their analysis. + procedure Check_Access_Definition (N : Node_Id); -- Subsidiary routine to null exclusion processing. Perform an assertion -- check on Ada version and the presence of an access definition in N. @@ -865,6 +881,10 @@ package body Sem_Ch12 is procedure Remove_Parent (In_Body : Boolean := False); -- Reverse effect after instantiation of child is complete + function Requires_Conformance_Checking (N : Node_Id) return Boolean; + -- Determine whether the formal package declaration N requires conformance + -- checking with actuals in instantiations. + procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id); -- Restore suffix 'P' to primitives of Prims_List and leave Prims_List -- set to No_Elist. @@ -1160,10 +1180,10 @@ package body Sem_Ch12 is -- association for it includes a box, or whether the associations -- include an Others clause. - procedure Process_Default (F : Entity_Id); - -- Add a copy of the declaration of generic formal F to the list of - -- associations, and add an explicit box association for F if there - -- is none yet, and the default comes from an Others_Choice. + procedure Process_Default (Formal : Node_Id); + -- Add a copy of the declaration of a generic formal to the list of + -- associations, and add an explicit box association for its entity + -- if there is none yet, and the default comes from an Others_Choice. function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean; -- Determine whether Subp renames one of the subprograms defined in the @@ -1517,9 +1537,9 @@ package body Sem_Ch12 is -- Process_Default -- --------------------- - procedure Process_Default (F : Entity_Id) is + procedure Process_Default (Formal : Node_Id) is Loc : constant Source_Ptr := Sloc (I_Node); - F_Id : constant Entity_Id := Defining_Entity (F); + F_Id : constant Entity_Id := Defining_Entity (Formal); Decl : Node_Id; Default : Node_Id; Id : Entity_Id; @@ -1528,10 +1548,10 @@ package body Sem_Ch12 is -- Append copy of formal declaration to associations, and create new -- defining identifier for it. - Decl := New_Copy_Tree (F); + Decl := New_Copy_Tree (Formal); Id := Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id)); - if Nkind (F) in N_Formal_Subprogram_Declaration then + if Nkind (Formal) in N_Formal_Subprogram_Declaration then Set_Defining_Unit_Name (Specification (Decl), Id); else @@ -2612,12 +2632,16 @@ package body Sem_Ch12 is procedure Analyze_Formal_Object_Declaration (N : Node_Id) is E : constant Node_Id := Default_Expression (N); Id : constant Node_Id := Defining_Identifier (N); - K : Entity_Kind; - T : Node_Id; + + K : Entity_Kind; + Parent_Installed : Boolean := False; + T : Node_Id; begin Enter_Name (Id); + Check_Abbreviated_Instance (Parent (N), Parent_Installed); + -- Determine the mode of the formal object if Out_Present (N) then @@ -2740,6 +2764,10 @@ package body Sem_Ch12 is if Has_Aspects (N) then Analyze_Aspect_Specifications (N, Id); end if; + + if Parent_Installed then + Remove_Parent; + end if; end Analyze_Formal_Object_Declaration; ---------------------------------------------- @@ -3279,7 +3307,9 @@ package body Sem_Ch12 is Def : constant Node_Id := Default_Name (N); Expr : constant Node_Id := Expression (N); Nam : constant Entity_Id := Defining_Unit_Name (Spec); - Subp : Entity_Id; + + Parent_Installed : Boolean := False; + Subp : Entity_Id; begin if Nam = Error then @@ -3291,6 +3321,8 @@ package body Sem_Ch12 is goto Leave; end if; + Check_Abbreviated_Instance (Parent (N), Parent_Installed); + Analyze_Subprogram_Declaration (N); Set_Is_Formal_Subprogram (Nam); Set_Has_Completion (Nam); @@ -3490,6 +3522,9 @@ package body Sem_Ch12 is Analyze_Aspect_Specifications (N, Nam); end if; + if Parent_Installed then + Remove_Parent; + end if; end Analyze_Formal_Subprogram_Declaration; ------------------------------------- @@ -3498,7 +3533,9 @@ package body Sem_Ch12 is procedure Analyze_Formal_Type_Declaration (N : Node_Id) is Def : constant Node_Id := Formal_Type_Definition (N); - T : Entity_Id; + + Parent_Installed : Boolean := False; + T : Entity_Id; begin T := Defining_Identifier (N); @@ -3510,6 +3547,8 @@ package body Sem_Ch12 is ("discriminants not allowed for this formal type", T); end if; + Check_Abbreviated_Instance (Parent (N), Parent_Installed); + -- Enter the new name, and branch to specific routine case Nkind (Def) is @@ -3578,6 +3617,10 @@ package body Sem_Ch12 is if Has_Aspects (N) then Analyze_Aspect_Specifications (N, T); end if; + + if Parent_Installed then + Remove_Parent; + end if; end Analyze_Formal_Type_Declaration; ------------------------------------ @@ -4258,7 +4301,13 @@ package body Sem_Ch12 is Generic_Renamings.Set_Last (0); Generic_Renamings_HTable.Reset; - Check_Generic_Child_Unit (Gen_Id, Parent_Installed); + -- Except for an abbreviated instance created to check a formal package, + -- install the parent if this is a generic child unit. + + if not Is_Abbreviated_Instance (Inst_Id) then + Check_Generic_Child_Unit (Gen_Id, Parent_Installed); + end if; + Gen_Unit := Entity (Gen_Id); -- A package instantiation is Ghost when it is subject to pragma Ghost @@ -6289,6 +6338,25 @@ package body Sem_Ch12 is Build_Elaboration_Entity (Decl_Cunit, New_Main); end Build_Instance_Compilation_Unit_Nodes; + -------------------------------- + -- Check_Abbreviated_Instance -- + -------------------------------- + + procedure Check_Abbreviated_Instance + (N : Node_Id; + Parent_Installed : in out Boolean) + is + Inst_Node : Node_Id; + + begin + if Nkind (N) = N_Package_Specification + and then Is_Abbreviated_Instance (Defining_Entity (N)) + then + Inst_Node := Get_Unit_Instantiation_Node (Defining_Entity (N)); + Check_Generic_Child_Unit (Name (Inst_Node), Parent_Installed); + end if; + end Check_Abbreviated_Instance; + ----------------------------- -- Check_Access_Definition -- ----------------------------- @@ -6738,43 +6806,23 @@ package body Sem_Ch12 is E : Entity_Id; Formal_P : Entity_Id; Formal_Decl : Node_Id; + begin -- Iterate through the declarations in the instance, looking for package - -- renaming declarations that denote instances of formal packages. Stop - -- when we find the renaming of the current package itself. The - -- declaration for a formal package without a box is followed by an - -- internal entity that repeats the instantiation. + -- renaming declarations that denote instances of formal packages, until + -- we find the renaming of the current package itself. The declaration + -- of a formal package that requires conformance checking is followed by + -- an internal entity that is the abbreviated instance. E := First_Entity (P_Id); while Present (E) loop if Ekind (E) = E_Package then - if Renamed_Entity (E) = P_Id then - exit; - - elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then - null; + exit when Renamed_Entity (E) = P_Id; - else + if Nkind (Parent (E)) = N_Package_Renaming_Declaration then Formal_Decl := Parent (Associated_Formal_Package (E)); - -- Nothing to check if the formal has a box or an others_clause - -- (necessarily with a box), or no associations altogether - - if Box_Present (Formal_Decl) - or else No (Generic_Associations (Formal_Decl)) - then - null; - - elsif Nkind (First (Generic_Associations (Formal_Decl))) = - N_Others_Choice - then - -- The internal validating package was generated but formal - -- and instance are known to be compatible. - - Formal_P := Next_Entity (E); - Remove (Unit_Declaration_Node (Formal_P)); - - else + if Requires_Conformance_Checking (Formal_Decl) then Formal_P := Next_Entity (E); -- If the instance is within an enclosing instance body @@ -7708,7 +7756,7 @@ package body Sem_Ch12 is function Copy_Generic_List (L : List_Id; Parent_Id : Node_Id) return List_Id; - -- Apply Copy_Node recursively to the members of a node list + -- Apply Copy_Generic_Node recursively to the members of a node list function In_Defining_Unit_Name (Nam : Node_Id) return Boolean; -- True if an identifier is part of the defining program unit name of @@ -10247,12 +10295,13 @@ package body Sem_Ch12 is is Loc : constant Source_Ptr := Sloc (Actual); Hidden_Formals : constant Elist_Id := New_Elmt_List; - Actual_Pack : Entity_Id; - Formal_Pack : Entity_Id; - Gen_Parent : Entity_Id; - Decls : List_Id; - Nod : Node_Id; - Parent_Spec : Node_Id; + + Actual_Pack : Entity_Id; + Formal_Pack : Entity_Id; + Gen_Parent : Entity_Id; + Decls : List_Id; + Nod : Node_Id; + Parent_Spec : Node_Id; procedure Find_Matching_Actual (F : Node_Id; @@ -10533,15 +10582,15 @@ package body Sem_Ch12 is Actual_Pack := Renamed_Entity (Actual_Pack); end if; - if Nkind (Analyzed_Formal) = N_Formal_Package_Declaration then - Gen_Parent := Get_Instance_Of (Entity (Name (Analyzed_Formal))); - Formal_Pack := Defining_Identifier (Analyzed_Formal); - else - Gen_Parent := - Generic_Parent (Specification (Analyzed_Formal)); - Formal_Pack := - Defining_Unit_Name (Specification (Analyzed_Formal)); - end if; + -- The analyzed formal is expected to be the result of the rewriting + -- of the formal package into a regular package by analysis. + + pragma Assert (Nkind (Analyzed_Formal) = N_Package_Declaration + and then Nkind (Original_Node (Analyzed_Formal)) = + N_Formal_Package_Declaration); + + Gen_Parent := Generic_Parent (Specification (Analyzed_Formal)); + Formal_Pack := Defining_Unit_Name (Specification (Analyzed_Formal)); if Nkind (Parent (Actual_Pack)) = N_Defining_Program_Unit_Name then Parent_Spec := Package_Specification (Actual_Pack); @@ -10708,20 +10757,9 @@ package body Sem_Ch12 is Next_Entity (Actual_Ent); end loop; - - -- No conformance to check if the generic has no formal parameters - -- and the formal package has no generic associations. - - if Is_Empty_List (Formals) - and then - (Box_Present (Formal) - or else No (Generic_Associations (Formal))) - then - return Decls; - end if; end; - -- If the formal is not declared with a box, reanalyze it as an + -- If the formal requires conformance checking, reanalyze it as an -- abbreviated instantiation, to verify the matching rules of 12.7. -- The actual checks are performed after the generic associations -- have been analyzed, to guarantee the same visibility for this @@ -10733,22 +10771,40 @@ package body Sem_Ch12 is -- checking, because it contains formal declarations for those -- defaulted parameters, and those should not reach the back-end. - if not Box_Present (Formal) then + if Requires_Conformance_Checking (Formal) then declare - I_Pack : constant Entity_Id := - Make_Temporary (Sloc (Actual), 'P'); + I_Pack : constant Entity_Id := Make_Temporary (Loc, 'P'); + + I_Nam : Node_Id; begin Set_Is_Internal (I_Pack); Mutate_Ekind (I_Pack, E_Package); + + -- Insert the package into the list of its hidden entities so + -- that the list is not empty for Is_Abbreviated_Instance. + + Append_Elmt (I_Pack, Hidden_Formals); + Set_Hidden_In_Formal_Instance (I_Pack, Hidden_Formals); + -- If the generic is a child unit, Check_Generic_Child_Unit + -- needs its original name in case it is qualified. + + if Is_Child_Unit (Gen_Parent) then + I_Nam := + New_Copy_Tree (Name (Original_Node (Analyzed_Formal))); + pragma Assert (Entity (I_Nam) = Gen_Parent); + + else + I_Nam := + New_Occurrence_Of (Get_Instance_Of (Gen_Parent), Loc); + end if; + Append_To (Decls, - Make_Package_Instantiation (Sloc (Actual), + Make_Package_Instantiation (Loc, Defining_Unit_Name => I_Pack, - Name => - New_Occurrence_Of - (Get_Instance_Of (Gen_Parent), Sloc (Actual)), + Name => I_Nam, Generic_Associations => Generic_Associations (Formal))); end; end if; @@ -14234,6 +14290,16 @@ package body Sem_Ch12 is return Decl_Nodes; end Instantiate_Type; + ----------------------------- + -- Is_Abbreviated_Instance -- + ----------------------------- + + function Is_Abbreviated_Instance (E : Entity_Id) return Boolean is + begin + return Ekind (E) = E_Package + and then Present (Hidden_In_Formal_Instance (E)); + end Is_Abbreviated_Instance; + --------------------- -- Is_In_Main_Unit -- --------------------- @@ -14323,7 +14389,7 @@ package body Sem_Ch12 is -- not analyzed here either. elsif Nkind (Decl) = N_Package_Instantiation - and then not Is_Internal (Defining_Entity (Decl)) + and then not Is_Abbreviated_Instance (Defining_Entity (Decl)) then Append_Elmt (Decl, Previous_Instances); @@ -15206,6 +15272,20 @@ package body Sem_Ch12 is end if; end Remove_Parent; + ----------------------------------- + -- Requires_Conformance_Checking -- + ----------------------------------- + + function Requires_Conformance_Checking (N : Node_Id) return Boolean is + begin + -- No conformance checking required if the generic actual part is empty, + -- or is a box or an others_clause (necessarily with a box). + + return Present (Generic_Associations (N)) + and then not Box_Present (N) + and then Nkind (First (Generic_Associations (N))) /= N_Others_Choice; + end Requires_Conformance_Checking; + ----------------- -- Restore_Env -- ----------------- diff --git a/gcc/ada/sem_ch12.ads b/gcc/ada/sem_ch12.ads --- a/gcc/ada/sem_ch12.ads +++ b/gcc/ada/sem_ch12.ads @@ -110,6 +110,10 @@ package Sem_Ch12 is -- function and procedure instances. The flag Body_Optional has the -- same purpose as described for Instantiate_Package_Body. + function Is_Abbreviated_Instance (E : Entity_Id) return Boolean; + -- Return true if E is a package created for an abbreviated instantiation + -- to check conformance between formal package and corresponding actual. + function Need_Subprogram_Instance_Body (N : Node_Id; Subp : Entity_Id) return Boolean; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -1813,9 +1813,13 @@ package body Sem_Ch7 is -- If this is a package associated with a generic instance or formal -- package, then the private declarations of each of the generic's - -- parents must be installed at this point. + -- parents must be installed at this point, but not if this is the + -- abbreviated instance created to check a formal package, see the + -- same condition in Analyze_Package_Instantiation. - if Is_Generic_Instance (Id) then + if Is_Generic_Instance (Id) + and then not Is_Abbreviated_Instance (Id) + then Install_Parent_Private_Declarations (Id); end if;