From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mail-wm1-x32f.google.com (mail-wm1-x32f.google.com [IPv6:2a00:1450:4864:20::32f]) by sourceware.org (Postfix) with ESMTPS id D63AB385842C for ; Tue, 5 Sep 2023 11:07:56 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org D63AB385842C Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com Received: by mail-wm1-x32f.google.com with SMTP id 5b1f17b1804b1-402cc6b8bedso20226415e9.1 for ; Tue, 05 Sep 2023 04:07:56 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1693912075; x=1694516875; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:from:to:cc:subject:date:message-id:reply-to; bh=32AuRgNPx8b2seSACzmLmztZaBJZ81obqlVRSTtiid4=; b=cu5lUB60cx6drGoCWMaA0es0Qf47Og3q5SqwYsj9wQWKA1ETS45xTq4wcQ8VrCIhSG MBiObFlrxNDFMpxeDr7H3ASo2EXYuoXRP3NzJaG4UB7+9jN/LNToD0JjP3GHwGFvh+8k XxXBlBDcmHU/4f7CSysdpjapnv73gSP//UoZTSXrLBCvbWbDwEU1TX7RhP6Cw9b1YaGY 8ww7Cwu7UPpwf40V9h64jqTqL2jRjDPiHVQscqxiJqlZs90wtgEZ/m6vHiHkMMEUQ48z nkHNbQQsK/s7m6PnZWk0nFqqmUG7q30DA2EgicZjrBsbHsAOO52ljM17IIPFfCdP6N8b WoRg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20221208; t=1693912075; x=1694516875; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:x-gm-message-state:from:to:cc:subject:date:message-id :reply-to; bh=32AuRgNPx8b2seSACzmLmztZaBJZ81obqlVRSTtiid4=; b=G2Qqa4sT/5SwHjksbTDrObALuSlM9cR5Dbb45qtC6HintjjV3b/Ghuux5f92IIZLO5 wkQOGqtDox7ALsE638e5F/KegVJhQvKMfSWmWX0dSzzJuzJXb9OaI+Z+AtCIaWWWPg7h iKepYMHWds+D73NjkWvbEOJcP0/LCW8z1/GwyHQ7CWzmQw4ys+87YDaLOS3rb1KXEb1z 9er3gotozffBzgU/ampbPM4K1IAH5Tg68OyBaqv+YoiElLJo7KM5LsWik+mb38RGDzxw u3j6NIa6q2x7LdE/IOJfS7PL26jE6iEY5E+lpv2upqxq8M7YgSd8N8rVwCMXjgcu83I8 8yPg== X-Gm-Message-State: AOJu0YxBLj75X0cK7+EMJJrchMAQvvUDFz7LZtUdJAWPweJLIx5hMDQQ h3QtS3VguPtecRsd98eXvPhFXLgtThJiKGj5kbQqhQ== X-Google-Smtp-Source: AGHT+IEEp8CTfKKmoC+6druNt11Rdrvo1NH0RagddAt1SClaOqK45lS8KVlTIF5eJAT2vIsKMjg/9w== X-Received: by 2002:a05:600c:2283:b0:3ff:516b:5c65 with SMTP id 3-20020a05600c228300b003ff516b5c65mr9140013wmf.30.1693912075501; Tue, 05 Sep 2023 04:07:55 -0700 (PDT) Received: from poulhies-Precision-5550.lan ([2001:861:3382:1a90:20fc:79e4:455c:1075]) by smtp.gmail.com with ESMTPSA id t8-20020a1c7708000000b003fef60005b5sm16610615wmi.9.2023.09.05.04.07.54 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 05 Sep 2023 04:07:54 -0700 (PDT) From: =?UTF-8?q?Marc=20Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [COMMITTED] ada: Enforce subtype conformance of interface primitives Date: Tue, 5 Sep 2023 13:07:53 +0200 Message-Id: <20230905110753.562161-1-poulhies@adacore.com> X-Mailer: git-send-email 2.40.0 MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Spam-Status: No, score=-13.7 required=5.0 tests=BAYES_00,DKIM_SIGNED,DKIM_VALID,DKIM_VALID_AU,DKIM_VALID_EF,GIT_PATCH_0,RCVD_IN_DNSWL_NONE,SPF_HELO_NONE,SPF_PASS,TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org List-Id: From: Javier Miranda 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. Tested on x86_64-pc-linux-gnu, committed on master. --- 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 042ace01724..3262236dd14 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 -- 2.40.0