From patchwork Tue Sep 5 11:07:53 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 137497 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a59:ab0a:0:b0:3f2:4152:657d with SMTP id m10csp1605433vqo; Tue, 5 Sep 2023 04:10:04 -0700 (PDT) X-Google-Smtp-Source: AGHT+IFYp1/taZ1ubW+c0bqRH2zcV9jR/chsMNYcQ5jmxWyTCL5GHJEAaxy84gzuz8L7qQdPSog5 X-Received: by 2002:ac2:4f05:0:b0:500:bf44:b2b6 with SMTP id k5-20020ac24f05000000b00500bf44b2b6mr7961910lfr.45.1693912204442; Tue, 05 Sep 2023 04:10:04 -0700 (PDT) ARC-Seal: i=1; a=rsa-sha256; t=1693912204; cv=none; d=google.com; s=arc-20160816; b=PjSsLqt7ahYdXupFsyCsd5dN2DMZMIlYHNiv4skbNJlE5PRaf37qNIjEPJJXsf+k9G j460jGgDpX8YNE2JL7KyYnRc+v/TTJaROEmYHVq2YC2kDFo8lc/VN+xy+mcbcZ6MgbZw qoggtDhdDbKDOzgc6cNzNQLkId+8nB/ok6eCW4iE6hVhukdeM5JKZFq2LWaVE5F4O2I1 HDLzBgD45214HRWYeIym/a8EHajoU0cGGWmLzhgxzs4AY8vwDNi6CeP/xhD1LzIfbY7G 5Xv4E+dRR0bLACsrxXRcfmF52kN+6vhtZ6J4o94vGCMf13CsESLcU+lzhDNTtLuRu4P5 jK/w== ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; h=sender:errors-to:reply-to:from:list-subscribe:list-help:list-post :list-archive:list-unsubscribe:list-id:precedence :content-transfer-encoding:mime-version:message-id:date:subject:cc :to:dmarc-filter:delivered-to:dkim-signature:dkim-filter; bh=32AuRgNPx8b2seSACzmLmztZaBJZ81obqlVRSTtiid4=; fh=xMTG+Z2BAn45iekV7HxLGBKXrsSIb8vOWtd2ivRmbts=; b=O8hD5hf1pSWs1hJuwIu1zjSIDP1nwcF1c7SI8IlApzw/i0ruguMazraDt74BTT/Nwo wT4EoePwHGsO9OHJZuCHutmvcXZeGmY0alkH6gRakTMpl7FMfXE+k056adyLdrwJpNnX AZKiGWSvguctdUwysp8hKOA3UV1sJFzaPpZThlkPAIm2r0L7yIc4vF/A+0ElbD3LDFlq KLXSrXntboh/+5rUTjo3zrCUwgeyE11dYbOvRgBFUBQx66Wn+pq2W5VjqECtLaz1af/7 JQ1s6vWM4GPTCTrJeZLEzKmklD1xImuCg3cofUAsa3AOy0kFQc6zLQOC/tDON7mvd95Z MVGw== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=mGqxuDbw; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=gnu.org Received: from server2.sourceware.org (ip-8-43-85-97.sourceware.org. [8.43.85.97]) by mx.google.com with ESMTPS id d17-20020aa7d691000000b0052a1ce53c9asi7621913edr.517.2023.09.05.04.10.04 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 05 Sep 2023 04:10:04 -0700 (PDT) Received-SPF: pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) client-ip=8.43.85.97; Authentication-Results: mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=mGqxuDbw; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=gnu.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 53FCB3831398 for ; Tue, 5 Sep 2023 11:08:48 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 53FCB3831398 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1693912128; bh=32AuRgNPx8b2seSACzmLmztZaBJZ81obqlVRSTtiid4=; h=To:Cc:Subject:Date:List-Id:List-Unsubscribe:List-Archive: List-Post:List-Help:List-Subscribe:From:Reply-To:From; b=mGqxuDbwQiT0E2SY1f9Qd+xnVmU9Em8yBGwzhSWnAwz2X/4tvfBloCB7PJSNROyCq ILudgAFHw5borqnR5I16RhZma6zCFFQ7/EGp5S4z6QbaDMCCcW5gfAqz9JU/NJRzhm X1UX4bdIl1UNZrm3L+UdqcPJnrN6p75dlXsVlVP0= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org 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 Received: by mail-wm1-x32f.google.com with SMTP id 5b1f17b1804b1-402cc6b8bedso20226415e9.1 for ; Tue, 05 Sep 2023 04:07:56 -0700 (PDT) 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-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) 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 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 X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: =?utf-8?q?Marc_Poulhi=C3=A8s_via_Gcc-patches?= From: =?utf-8?q?Marc_Poulhi=C3=A8s?= Reply-To: =?utf-8?q?Marc_Poulhi=C3=A8s?= Errors-To: gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org Sender: "Gcc-patches" X-getmail-retrieved-from-mailbox: INBOX X-GMAIL-THRID: 1776195683898409480 X-GMAIL-MSGID: 1776195683898409480 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