From patchwork Wed Jul 13 10:02:49 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: 217 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a98:d5ce:0:b0:178:cc93:bf7d with SMTP id g14csp164300eik; Wed, 13 Jul 2022 03:07:05 -0700 (PDT) X-Google-Smtp-Source: AGRyM1s9gHCgMcW36ebYEUIsIc+y9OfyajU5DKJlGu/oj45WuIiUSjnYPhJfza0ONleFevArKSGi X-Received: by 2002:a05:6402:2741:b0:434:fe8a:1f96 with SMTP id z1-20020a056402274100b00434fe8a1f96mr3675069edd.331.1657706825107; Wed, 13 Jul 2022 03:07:05 -0700 (PDT) ARC-Seal: i=1; a=rsa-sha256; t=1657706825; cv=none; d=google.com; s=arc-20160816; b=J1zwPCxd2TkdvuO5CPv51B46I06h21Eqhn029MiZxx9r4UPytvYDIObSDGYi/qptcQ bL2XOq3WQPe0Pqp+KzocEghsDxYG8CPHXu/5/8oPD4PZMrWEml0yiB5VAolU+xgfU4M3 VsP8p+FZz0xoLSsSzdkizEVEAI1lJsmoNJ8OcroLFUmNdE8FZ0dO9+csUj8Rd1vL7FRZ UGlh2WB+3nAPLmZWBBqkGGSUaqVczWDIUdmCz+a3ZlRHUSCrWxpcqRCyZ2GYJftX05VI U7j7qDQ5/pyJY2dgapwKBzvg1uDpQh/CDjy7jd6lLiSvxSIssPXbgo7NnWvREVWp9j0F QVXA== ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; h=sender:errors-to:cc:reply-to:from:list-subscribe:list-help :list-post:list-archive:list-unsubscribe:list-id:precedence :content-disposition:mime-version:message-id:subject:to:date :dmarc-filter:delivered-to:dkim-signature:dkim-filter; bh=ldLL8LmLGFVZCfC8JegVJwfk92fJ03AhmnhsZOsOrCo=; b=rRjP6/ALvIwWUU4MZOvCjvBoKkv/rAL9JSk1nCYZu10TTdt6g/rpGcMxe9W49E8WoI sPiIXZ8BhAAp1jEzy11hk8LB4FDfF16nyNIj3IXet8Gum2NH8POiYOqKhAMBKT45dRdd 1CyM4mmBAV7/WZRuAspuhSY2tRGR8zv0W0lIov0dsyH6l/qfnGPmjLf+ETjoQywQ1gkd oe8rZUThZFr30nEd/laSVSkS24hK7zl43TvdYs2jsaMf6A5rSv7jlTEgueeco1kubRy7 hL1UxfQ2bEkBox7sK2oLZr+1B3inh3t7giKHIiITv8+unxZ373QtsgIWIFpVez/hmiw2 U1UQ== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=EbFwnV2t; 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 sourceware.org (ip-8-43-85-97.sourceware.org. [8.43.85.97]) by mx.google.com with ESMTPS id l6-20020a056402254600b0043ad5430053si9277205edb.448.2022.07.13.03.07.04 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 13 Jul 2022 03:07:05 -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=EbFwnV2t; 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 50A0C385021F for ; Wed, 13 Jul 2022 10:04:41 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 50A0C385021F DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1657706681; bh=ldLL8LmLGFVZCfC8JegVJwfk92fJ03AhmnhsZOsOrCo=; h=Date:To:Subject:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:Cc:From; b=EbFwnV2tqVlieCDGRRRKs8TatFpZHN9FAjuuII5GImKFcUCX9CNOrWBmoQ0oaht6q ys8cn8xW+WUTS9U8JwqIz2d8XrrCOEk6Bghxg6WtPF3WvVrbt2BaJmLzUyA5bTtAQA 2aN/k5YffZB1Ne0/js3gerDG71V//2IFl+FO/FrE= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-ej1-x630.google.com (mail-ej1-x630.google.com [IPv6:2a00:1450:4864:20::630]) by sourceware.org (Postfix) with ESMTPS id 1901A3851A9D for ; Wed, 13 Jul 2022 10:02:52 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 1901A3851A9D Received: by mail-ej1-x630.google.com with SMTP id mf4so17768199ejc.3 for ; Wed, 13 Jul 2022 03:02:52 -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=ldLL8LmLGFVZCfC8JegVJwfk92fJ03AhmnhsZOsOrCo=; b=0bKZR+m7J2h8WNccCS/RzEYhj4TOTz6NIMjv32SibRzKadNvuPekN4UtCqUY1KQ+u+ 6+PfcKW96umjWBm0+38sYtbZflWMMwE8vCXaRWYY1lr7Sw3I3bVRqqgtO2xehfrX6s2P l7RqAKvB0q/mzuzSt8hzuQNlt3R84OY8Ty2LoOjDKet4i8PHZeE4t1jNF/VKryX3aPF4 zW34tGC4byX8Upmw3hh4B6ckyaQ1TvPDUlJeQfXhN25mZbpRW8Kh0MsN9az1aCdI5IaP 8+4zTb6yPtA5yBoukFzcgjRcLl3fWRBGYlefyeaOhzlU5j8iuoHIXg9lLDMM+B5iqhFf H5dQ== X-Gm-Message-State: AJIora+VlaXDBRJsjJZ/DgivlyAM5tugXspElIpBUEgzIu8zkUyyVRE6 pYo58CmH4fwZBJOysMg7ZIwQCxxZZ3RiwA== X-Received: by 2002:a17:907:3fa8:b0:72b:5895:f54f with SMTP id hr40-20020a1709073fa800b0072b5895f54fmr2615625ejc.464.1657706570887; Wed, 13 Jul 2022 03:02:50 -0700 (PDT) Received: from adacore.com ([45.147.211.82]) by smtp.gmail.com with ESMTPSA id rp17-20020a170906d97100b0072abb95c9f4sm4734482ejb.193.2022.07.13.03.02.50 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 13 Jul 2022 03:02:50 -0700 (PDT) Date: Wed, 13 Jul 2022 10:02:49 +0000 To: gcc-patches@gcc.gnu.org Subject: [Ada] Plug legality loophole for equality operator of untagged record types Message-ID: <20220713100249.GA994570@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+ouuuleilei=gmail.com@gcc.gnu.org Sender: "Gcc-patches" X-getmail-retrieved-from-mailbox: =?utf-8?q?INBOX?= X-GMAIL-THRID: =?utf-8?q?1738231591877438264?= X-GMAIL-MSGID: =?utf-8?q?1738231591877438264?= In Ada 2012, the RM 4.5.2(9.8) clause prevents an equality operator for an untagged record type from being declared after the type is frozen. While the clause is implemented in GNAT, the implementation has a loophole which lets subprogram bodies that are not the completion of a declaration pass the check without being flagged. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Set Acts_As_Spec earlier if the body is not the completion of a declaration. (Check_Untagged_Equality): Deal with subprogram bodies that are not the completion of a declaration and make sure that they are not flagged when they cause the freezing of the type themselves. Give a warning on the freezing point of the type in more cases. * sem_res.adb (Resolve_Equality_Op): Revert latest change. diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -4743,6 +4743,12 @@ package body Sem_Ch6 is Style.Body_With_No_Spec (N); end if; + -- First set Acts_As_Spec if appropriate + + if Nkind (N) /= N_Subprogram_Body_Stub then + Set_Acts_As_Spec (N); + end if; + New_Overloaded_Entity (Body_Id); -- A subprogram body should cause freezing of its own declaration, @@ -4767,7 +4773,6 @@ package body Sem_Ch6 is end if; if Nkind (N) /= N_Subprogram_Body_Stub then - Set_Acts_As_Spec (N); Generate_Definition (Body_Id); Generate_Reference (Body_Id, Body_Id, 'b', Set_Ref => False, Force => True); @@ -9525,15 +9530,85 @@ package body Sem_Ch6 is ----------------------------- procedure Check_Untagged_Equality (Eq_Op : Entity_Id) is - Typ : constant Entity_Id := Etype (First_Formal (Eq_Op)); - Decl : constant Node_Id := Unit_Declaration_Node (Eq_Op); - Obj_Decl : Node_Id; + Eq_Decl : constant Node_Id := Unit_Declaration_Node (Eq_Op); + Typ : constant Entity_Id := Etype (First_Formal (Eq_Op)); + + procedure Freezing_Point_Warning (N : Node_Id; S : String); + -- Output a warning about the freezing point N of Typ + + function Is_Actual_Of_Instantiation + (E : Entity_Id; + Inst : Node_Id) return Boolean; + -- Return True if E is an actual parameter of instantiation Inst + + ----------------------------------- + -- Output_Freezing_Point_Warning -- + ----------------------------------- + + procedure Freezing_Point_Warning (N : Node_Id; S : String) is + begin + Error_Msg_String (1 .. S'Length) := S; + Error_Msg_Strlen := S'Length; + + if Ada_Version >= Ada_2012 then + Error_Msg_NE ("type& is frozen by ~??", N, Typ); + Error_Msg_N + ("\an equality operator cannot be declared after this point??", + N); + + else + Error_Msg_NE ("type& is frozen by ~ (Ada 2012)?y?", N, Typ); + Error_Msg_N + ("\an equality operator cannot be declared after this point" + & " (Ada 2012)?y?", N); + end if; + end Freezing_Point_Warning; + + -------------------------------- + -- Is_Actual_Of_Instantiation -- + -------------------------------- + + function Is_Actual_Of_Instantiation + (E : Entity_Id; + Inst : Node_Id) return Boolean + is + Assoc : Node_Id; + + begin + if Present (Generic_Associations (Inst)) then + Assoc := First (Generic_Associations (Inst)); + + while Present (Assoc) loop + if Present (Explicit_Generic_Actual_Parameter (Assoc)) + and then + Is_Entity_Name (Explicit_Generic_Actual_Parameter (Assoc)) + and then + Entity (Explicit_Generic_Actual_Parameter (Assoc)) = E + then + return True; + end if; + + Next (Assoc); + end loop; + end if; + + return False; + end Is_Actual_Of_Instantiation; + + -- Local variable + + Decl : Node_Id; + + -- Start of processing for Check_Untagged_Equality begin - -- This check applies only if we have a subprogram declaration with an - -- untagged record type that is conformant to the predefined operator. + -- This check applies only if we have a subprogram declaration or a + -- subprogram body that is not a completion, for an untagged record + -- type, and that is conformant with the predefined operator. - if Nkind (Decl) /= N_Subprogram_Declaration + if (Nkind (Eq_Decl) /= N_Subprogram_Declaration + and then not (Nkind (Eq_Decl) = N_Subprogram_Body + and then Acts_As_Spec (Eq_Decl))) or else not Is_Record_Type (Typ) or else Is_Tagged_Type (Typ) or else not Is_User_Defined_Equality (Eq_Op) @@ -9572,9 +9647,59 @@ package body Sem_Ch6 is elsif Is_Generic_Actual_Type (Typ) then return; - -- Here we have a definite error of declaration after freezing + -- Here we may have an error of declaration after freezing, but we + -- must make sure not to flag the equality operator itself causing + -- the freezing when it is a subprogram body. else + Decl := Next (Declaration_Node (Typ)); + + while Present (Decl) and then Decl /= Eq_Decl loop + + -- The declaration of an object of the type + + if Nkind (Decl) = N_Object_Declaration + and then Etype (Defining_Identifier (Decl)) = Typ + then + Freezing_Point_Warning (Decl, "declaration"); + exit; + + -- The instantiation of a generic on the type + + elsif Nkind (Decl) in N_Generic_Instantiation + and then Is_Actual_Of_Instantiation (Typ, Decl) + then + Freezing_Point_Warning (Decl, "instantiation"); + exit; + + -- A noninstance proper body, body stub or entry body + + elsif Nkind (Decl) in N_Proper_Body + | N_Body_Stub + | N_Entry_Body + and then not Is_Generic_Instance (Defining_Entity (Decl)) + then + Freezing_Point_Warning (Decl, "body"); + exit; + + -- If we have reached the freeze node and immediately after we + -- have the body or generated code for the body, then it is the + -- body that caused the freezing and this is legal. + + elsif Nkind (Decl) = N_Freeze_Entity + and then Entity (Decl) = Typ + and then (Next (Decl) = Eq_Decl + or else + Sloc (Next (Decl)) = Sloc (Eq_Decl)) + then + return; + end if; + + Next (Decl); + end loop; + + -- Here we have a definite error of declaration after freezing + if Ada_Version >= Ada_2012 then Error_Msg_NE ("equality operator must be declared before type & is " @@ -9594,57 +9719,32 @@ package body Sem_Ch6 is & "frozen (RM 4.5.2 (9.8)) (Ada 2012)?y?", Eq_Op, Typ); end if; - -- If we are in the package body, we could just move the - -- declaration to the package spec, so add a message saying that. + -- If we have found no freezing point and the declaration of the + -- operator could not be reached from that of the type and we are + -- in a package body, this must be because the type is declared + -- in the spec of the package. Add a message tailored to this. - if In_Package_Body (Scope (Typ)) then + if No (Decl) and then In_Package_Body (Scope (Typ)) then if Ada_Version >= Ada_2012 then - Error_Msg_N - ("\move declaration to package spec<<", Eq_Op); - else - Error_Msg_N - ("\move declaration to package spec (Ada 2012)?y?", Eq_Op); - end if; - - -- Otherwise try to find the freezing point for better message. - - else - Obj_Decl := Next (Parent (Typ)); - while Present (Obj_Decl) and then Obj_Decl /= Decl loop - if Nkind (Obj_Decl) = N_Object_Declaration - and then Etype (Defining_Identifier (Obj_Decl)) = Typ - then - -- Freezing point, output warnings - - if Ada_Version >= Ada_2012 then - Error_Msg_NE - ("type& is frozen by declaration??", Obj_Decl, Typ); - Error_Msg_N - ("\an equality operator cannot be declared after " - & "this point??", - Obj_Decl); - else - Error_Msg_NE - ("type& is frozen by declaration (Ada 2012)?y?", - Obj_Decl, Typ); - Error_Msg_N - ("\an equality operator cannot be declared after " - & "this point (Ada 2012)?y?", - Obj_Decl); - end if; - - exit; - - -- If we reach generated code for subprogram declaration - -- or body, it is the body that froze the type and the - -- declaration is legal. - - elsif Sloc (Obj_Decl) = Sloc (Decl) then - return; + if Nkind (Eq_Decl) = N_Subprogram_Body then + Error_Msg_N + ("\put declaration in package spec<<", Eq_Op); + else + Error_Msg_N + ("\move declaration to package spec<<", Eq_Op); end if; - Next (Obj_Decl); - end loop; + else + if Nkind (Eq_Decl) = N_Subprogram_Body then + Error_Msg_N + ("\put declaration in package spec (Ada 2012)?y?", + Eq_Op); + else + Error_Msg_N + ("\move declaration to package spec (Ada 2012)?y?", + Eq_Op); + end if; + end if; end if; end if; @@ -9653,21 +9753,21 @@ package body Sem_Ch6 is -- a type has been derived from T. else - Obj_Decl := Next (Parent (Typ)); + Decl := Next (Declaration_Node (Typ)); - while Present (Obj_Decl) and then Obj_Decl /= Decl loop - if Nkind (Obj_Decl) = N_Full_Type_Declaration - and then Etype (Defining_Identifier (Obj_Decl)) = Typ + while Present (Decl) and then Decl /= Eq_Decl loop + if Nkind (Decl) = N_Full_Type_Declaration + and then Etype (Defining_Identifier (Decl)) = Typ then Error_Msg_N ("equality operator cannot appear after derivation", Eq_Op); Error_Msg_NE ("an equality operator for& cannot be declared after " & "this point??", - Obj_Decl, Typ); + Decl, Typ); end if; - Next (Obj_Decl); + Next (Decl); end loop; end if; end Check_Untagged_Equality; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -8967,14 +8967,7 @@ package body Sem_Res is then Eq := Get_User_Defined_Equality (T); - -- We need to make sure that the instance is not within the - -- same declarative region as the type, or else that it lies - -- after the declaration of the user-defined "=" operator. - - if Present (Eq) - and then (not In_Same_Extended_Unit (Eq, N) - or else Earlier_In_Extended_Unit (Eq, N)) - then + if Present (Eq) then if Is_Abstract_Subprogram (Eq) then Nondispatching_Call_To_Abstract_Operation (N, Eq); else