From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 7871) id D313F3858434; Tue, 5 Sep 2023 11:07:39 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org D313F3858434 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1693912059; bh=cGUaFdQWGpSfFhbITx1n9FVA5fXofJxNGzwmmocZa5c=; h=From:To:Subject:Date:From; b=mTpxEg6o+amgu+JfiOEQs3K/spxy8EWKg8+MGFwUJ3HjNw2X02Gg2b6nvPJmYoky8 ckeoinzG/FJCe+MZVOIcDJqYB5I5NJBnXcqNoMrdwGMrUwdrm3uPbfzpHjb2FmholZ BMHV1s3VoLKhJ6junrToKhhEtIDDsEdLXoTocuxw= 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-3677] ada: Enforce subtype conformance of interface primitives X-Act-Checkin: gcc X-Git-Author: Javier Miranda X-Git-Refname: refs/heads/master X-Git-Oldrev: eb7c56a0340363422481e4bccd3f86ddda9f9a23 X-Git-Newrev: 8950360830f0d7f5f356ec447e8493be7b98c2cb Message-Id: <20230905110739.D313F3858434@sourceware.org> Date: Tue, 5 Sep 2023 11:07:39 +0000 (GMT) List-Id: https://gcc.gnu.org/g:8950360830f0d7f5f356ec447e8493be7b98c2cb commit r14-3677-g8950360830f0d7f5f356ec447e8493be7b98c2cb Author: Javier Miranda Date: Mon Jul 31 11:10:33 2023 +0000 ada: Enforce subtype conformance of interface primitives gcc/ada/ * sem_ch3.adb (Add_Internal_Interface_Entities): Add missing subtype-conformance check on primitives implementing interface primitives. (Error_Posted_In_Formals): New subprogram. Diff: --- gcc/ada/sem_ch3.adb | 105 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 105 insertions(+) diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 042ace017242..3262236dd148 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -1688,6 +1688,31 @@ package body Sem_Ch3 is ------------------------------------- procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is + + function Error_Posted_In_Formals (Subp : Entity_Id) return Boolean; + -- Determine if an error has been posted in some formal of Subp. + + ----------------------------- + -- Error_Posted_In_Formals -- + ----------------------------- + + function Error_Posted_In_Formals (Subp : Entity_Id) return Boolean is + Formal : Entity_Id := First_Formal (Subp); + + begin + while Present (Formal) loop + if Error_Posted (Formal) then + return True; + end if; + + Next_Formal (Formal); + end loop; + + return False; + end Error_Posted_In_Formals; + + -- Local variables + Elmt : Elmt_Id; Iface : Entity_Id; Iface_Elmt : Elmt_Id; @@ -1741,6 +1766,86 @@ package body Sem_Ch3 is pragma Assert (Present (Prim)); + -- Check subtype conformance; we skip this check if errors have + -- been reported in the primitive (or in the formals of the + -- primitive) because Find_Primitive_Covering_Interface relies + -- on the subprogram Type_Conformant to locate the primitive, + -- and reports errors if the formals don't match. + + if not Error_Posted (Prim) + and then not Error_Posted_In_Formals (Prim) + then + declare + Alias_Prim : Entity_Id; + Alias_Typ : Entity_Id; + Err_Loc : Node_Id := Empty; + Ret_Type : Entity_Id; + + begin + -- For inherited primitives, in case of reporting an + -- error, the error must be reported on this primitive + -- (i.e. in the name of its type declaration); otherwise + -- the error would be reported in the formal of the + -- alias primitive defined on its parent type. + + if Nkind (Parent (Prim)) = N_Full_Type_Declaration then + Err_Loc := Prim; + end if; + + -- Check subtype conformance of procedures, functions + -- with matching return type, or functions not returning + -- interface types. + + if Ekind (Prim) = E_Procedure + or else Etype (Iface_Prim) = Etype (Prim) + or else not Is_Interface (Etype (Iface_Prim)) + then + Check_Subtype_Conformant + (New_Id => Prim, + Old_Id => Iface_Prim, + Err_Loc => Err_Loc, + Skip_Controlling_Formals => True); + + -- Check subtype conformance of functions returning an + -- interface type; temporarily force both entities to + -- return the same type. Required because subprogram + -- Subtype_Conformant does not handle this case. + + else + Ret_Type := Etype (Iface_Prim); + Set_Etype (Iface_Prim, Etype (Prim)); + + Check_Subtype_Conformant + (New_Id => Prim, + Old_Id => Iface_Prim, + Err_Loc => Err_Loc, + Skip_Controlling_Formals => True); + + Set_Etype (Iface_Prim, Ret_Type); + end if; + + -- Complete the error when reported on inherited + -- primitives. + + if Nkind (Parent (Prim)) = N_Full_Type_Declaration + and then (Error_Posted (Prim) + or else Error_Posted_In_Formals (Prim)) + and then Present (Alias (Prim)) + then + Alias_Prim := Ultimate_Alias (Prim); + Alias_Typ := Find_Dispatching_Type (Alias_Prim); + + if Alias_Typ /= Tagged_Type + and then Is_Ancestor (Alias_Typ, Tagged_Type) + then + Error_Msg_Sloc := Sloc (Alias_Prim); + Error_Msg_N + ("in primitive inherited from #!", Prim); + end if; + end if; + end; + end if; + -- Ada 2012 (AI05-0197): If the name of the covering primitive -- differs from the name of the interface primitive then it is -- a private primitive inherited from a parent type. In such