From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mail-wm1-x336.google.com (mail-wm1-x336.google.com [IPv6:2a00:1450:4864:20::336]) by sourceware.org (Postfix) with ESMTPS id 1AA3738754BE for ; Tue, 7 Nov 2023 09:20:43 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 1AA3738754BE Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 1AA3738754BE Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::336 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1699348845; cv=none; b=ABkf9vYn9py4lz2KnoXXDugc5nCgJrYy6snUbHcG2VWXsr21A41frTVd3GxyLo74zPFLu2d5GGRhKT+1h9/EgAS/6rfYqspUzfl2TKFXw8Mkwxlk4gQ41zMPmG+tpFmnnDOTNWGqPLShYwEpzdrJBtujuDyceE5EqwHP750s4B0= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1699348845; c=relaxed/simple; bh=xIYUVJWK0dD623aNkf2+MpI3nYiXGNEzKMTBkYfMwQs=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=rWYArnphWZFUvD3b2c6nzkl+0a87iaHVxiFfHhm7eMDoy6E4KQn9rlr5N+AedlMnYV22W6GVJ5Rmhhnl8uTESxIYqjkHtEApve/yOtYAOrAVORKnRZJZylT/mPx1LkeOxkuITboJyYnvFkeNTx3nyLRdLCxl0s+oy8YYoGXRnq8= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x336.google.com with SMTP id 5b1f17b1804b1-409299277bbso37881925e9.2 for ; Tue, 07 Nov 2023 01:20:43 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1699348842; x=1699953642; 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=G72Ac8xh27vZV2bXTInf/KOd7s7aGaBxfZbK7eguFUo=; b=iIRRuOmslu0ACWTxRnuzMEQMlFY98Jy0EWrfbcgNDYkYuI/PX4SWxWqvKgMU9jKAMX s/wWTHztOfM8Oj4mlJZTQYutbH4ciFATRD66AEDvtvipBsBOYK+CS8M6+imOL48e+Rqj 5+cai6MOvQiq3HXpcrSGD8HIPuRS1VLQQBOgsH45fNFqDk15UHJjWWznrkyAOqVrcHC8 SoL4fefaD3CdYpVE0XTIcgSzRjXqG0tsqLbVjb7Em2J10XQYOIiBapeEEkivaHoSm6zu P7GLIEUNcZguFpuy/N9RXM0C11JQWbiwiYc1HExlOZzjUsG54jt0tXRQafqewAi32d6f 9bkg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1699348842; x=1699953642; 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=G72Ac8xh27vZV2bXTInf/KOd7s7aGaBxfZbK7eguFUo=; b=HBOPk2a6lIirLDcsFXcJ1R1cejvIqNLNSeK02Jz45dylTtyxEdufKYDIZ/6NzxkOMd xzvhykY1Tp0gTGtByw0mdKk89BE7tqgDkzvWXPoLCvI056pUvcFalNOxiyzaZ7uZ4dbo Bic2tOMYjHFmLnqaGp6hvDB5bqxAjDOAZx2qU1eU/+CYFCH51RNR1dGQtQMBaIFawS+X o9agLLAU5QFbHos5IITD8BNjTC8bAGfbP4Y72pm1ssGcAOQZNahjrmQ7KnP+UxxCJLg7 O0/bd99tyNfK25U7HFmAyjDp75FVJ4xAH48Y3kWGEB8/X94/ltaM/dubO7p5GEdWb7OW CTtQ== X-Gm-Message-State: AOJu0YxnPHyong0Ww9g8sglX9bkwMv21OrejydeIWzw0TAT9eFCNX0FG dVYxuMtYMeNWPaKbG9OGB2qe2ORaFnzj19Ii0TZXPA== X-Google-Smtp-Source: AGHT+IFfwSROtKi+b+Btcd28fEx8LsiUTEaprGxesxMI79qLVMghz49zM9BVLszCO+EV0mtBlBZ4Iw== X-Received: by 2002:a05:600c:5404:b0:408:3ea0:3026 with SMTP id he4-20020a05600c540400b004083ea03026mr2038021wmb.11.1699348841832; Tue, 07 Nov 2023 01:20:41 -0800 (PST) Received: from localhost.localdomain ([2001:861:3382:1a90:dbc1:a1d1:2e58:4040]) by smtp.gmail.com with ESMTPSA id r18-20020a05600c35d200b00401e32b25adsm15150015wmq.4.2023.11.07.01.20.41 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 07 Nov 2023 01:20:41 -0800 (PST) From: =?UTF-8?q?Marc=20Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED] ada: Fix incorrect resolution of overloaded function call in instance Date: Tue, 7 Nov 2023 10:20:39 +0100 Message-ID: <20231107092039.3906837-1-poulhies@adacore.com> X-Mailer: git-send-email 2.42.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,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 List-Id: From: Eric Botcazou The problem occurs when the function call is the operand of an equality operator, the type used to do the comparison is declared outside of the generic construct but visible inside it, and this generic construct also declares two functions with the same profile except for the result type, one result type being the aforementioned type, the other being derived from this type but not visible inside the generic construct. When the second operand is either a literal or also overloaded, the call may be resolved to the second function instead of the first in instances. gcc/ada/ * gen_il-fields.ads (Opt_Field_Enum): Add Compare_Type. * gen_il-gen-gen_nodes.adb (N_Op_Eq): Likewise. (N_Op_Ge): Likewise. (N_Op_Gt): Likewise. (N_Op_Le): Likewise. (N_Op_Lt): Likewise. (N_Op_Ne): Likewise. * sinfo.ads (Compare_Type): Document new field. * sem_ch4.adb (Analyze_Comparison_Equality_Op): If the entity is already present, set the Compare_Type on overloaded operands if it is present on the node. * sem_ch12.adb (Check_Private_View): Look into the Compare_Type instead of the Etype for comparison operators. (Copy_Generic_Node): Remove obsolete code for comparison operators. (Save_Global_References.Save_References): Do not walk into the descendants of N_Implicit_Label_Declaration nodes. (Save_Global_References.Set_Global_Type): Look into the Compare_Type instead of the Etype for comparison operators. * sem_res.adb (Resolve_Comparison_Op): Set Compare_Type. (Resolve_Equality_Op): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/gen_il-fields.ads | 1 + gcc/ada/gen_il-gen-gen_nodes.adb | 18 +++++--- gcc/ada/sem_ch12.adb | 72 ++++++++++++++++++-------------- gcc/ada/sem_ch4.adb | 15 +++++-- gcc/ada/sem_res.adb | 2 + gcc/ada/sinfo.ads | 20 +++++++++ 6 files changed, 87 insertions(+), 41 deletions(-) diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index 1b40cd9472e..a0bfb398ebb 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -99,6 +99,7 @@ package Gen_IL.Fields is Comes_From_Check_Or_Contract, Comes_From_Extended_Return_Statement, Comes_From_Iterator, + Compare_Type, Compile_Time_Known_Aggregate, Component_Associations, Component_Clauses, diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index fdf928d60a3..996d8d78aea 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -267,32 +267,38 @@ begin -- Gen_IL.Gen.Gen_Nodes Cc (N_Op_Eq, N_Op_Compare, (Sm (Chars, Name_Id), Sy (Left_Opnd, Node_Id), - Sy (Right_Opnd, Node_Id))); + Sy (Right_Opnd, Node_Id), + Sm (Compare_Type, Node_Id))); Cc (N_Op_Ge, N_Op_Compare, (Sm (Chars, Name_Id), Sy (Left_Opnd, Node_Id), - Sy (Right_Opnd, Node_Id))); + Sy (Right_Opnd, Node_Id), + Sm (Compare_Type, Node_Id))); Cc (N_Op_Gt, N_Op_Compare, (Sm (Chars, Name_Id), Sy (Left_Opnd, Node_Id), - Sy (Right_Opnd, Node_Id))); + Sy (Right_Opnd, Node_Id), + Sm (Compare_Type, Node_Id))); Cc (N_Op_Le, N_Op_Compare, (Sm (Chars, Name_Id), Sy (Left_Opnd, Node_Id), - Sy (Right_Opnd, Node_Id))); + Sy (Right_Opnd, Node_Id), + Sm (Compare_Type, Node_Id))); Cc (N_Op_Lt, N_Op_Compare, (Sm (Chars, Name_Id), Sy (Left_Opnd, Node_Id), - Sy (Right_Opnd, Node_Id))); + Sy (Right_Opnd, Node_Id), + Sm (Compare_Type, Node_Id))); Cc (N_Op_Ne, N_Op_Compare, (Sm (Chars, Name_Id), Sy (Left_Opnd, Node_Id), - Sy (Right_Opnd, Node_Id))); + Sy (Right_Opnd, Node_Id), + Sm (Compare_Type, Node_Id))); Cc (N_Op_Or, N_Op_Boolean, (Sm (Chars, Name_Id), diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 582940da74b..f73e1b53b0e 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -7685,7 +7685,9 @@ package body Sem_Ch12 is ------------------------ procedure Check_Private_View (N : Node_Id) is - Typ : constant Entity_Id := Etype (N); + Comparison : constant Boolean := Nkind (N) in N_Op_Compare; + Typ : constant Entity_Id := + (if Comparison then Compare_Type (N) else Etype (N)); procedure Check_Private_Type (T : Entity_Id; Private_View : Boolean); -- Check that the available view of T matches Private_View and, if not, @@ -7749,10 +7751,16 @@ package body Sem_Ch12 is and then (not In_Open_Scopes (Scope (Typ)) or else Nkind (Parent (N)) = N_Subtype_Declaration) then - -- In the generic, only the private declaration was visible + declare + Assoc : constant Node_Id := Get_Associated_Node (N); + + begin + -- In the generic, only the private declaration was visible - Prepend_Elmt (Typ, Exchanged_Views); - Exchange_Declarations (Etype (Get_Associated_Node (N))); + Prepend_Elmt (Typ, Exchanged_Views); + Exchange_Declarations + (if Comparison then Compare_Type (Assoc) else Etype (Assoc)); + end; -- Check that the available views of Typ match their respective flag. -- Note that the type of a visible discriminant is never private. @@ -8166,30 +8174,6 @@ package body Sem_Ch12 is Set_Entity (New_N, Entity (Assoc)); Check_Private_View (N); - -- For the comparison and equality operators, the Etype - -- of the operator does not provide any information so, - -- if one of the operands is of a universal type, we need - -- to manually restore the full view of private types. - - if Nkind (N) in N_Op_Compare then - if Yields_Universal_Type (Left_Opnd (Assoc)) then - if Present (Etype (Right_Opnd (Assoc))) - and then - Is_Private_Type (Etype (Right_Opnd (Assoc))) - then - Switch_View (Etype (Right_Opnd (Assoc))); - end if; - - elsif Yields_Universal_Type (Right_Opnd (Assoc)) then - if Present (Etype (Left_Opnd (Assoc))) - and then - Is_Private_Type (Etype (Left_Opnd (Assoc))) - then - Switch_View (Etype (Left_Opnd (Assoc))); - end if; - end if; - end if; - -- The node is a reference to a global type and acts as the -- subtype mark of a qualified expression created in order -- to aid resolution of accidental overloading in instances. @@ -16883,6 +16867,11 @@ package body Sem_Ch12 is end if; end; + -- Do not walk the node pointed to by Label_Construct twice + + elsif Nkind (N) = N_Implicit_Label_Declaration then + null; + else Save_References_In_Descendants (N); end if; @@ -16894,10 +16883,27 @@ package body Sem_Ch12 is --------------------- procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is - Typ : constant Entity_Id := Etype (N2); + Comparison : constant Boolean := Nkind (N2) in N_Op_Compare; + Typ : constant Entity_Id := + (if Comparison then Compare_Type (N2) else Etype (N2)); begin - Set_Etype (N, Typ); + -- For a comparison (or equality) operator, the Etype is Boolean, so + -- it is always global. But the type subject to the Has_Private_View + -- processing is the Compare_Type, so we must specifically check it. + + if Comparison then + Set_Etype (N, Etype (N2)); + + if not Is_Global (Typ) then + return; + end if; + + Set_Compare_Type (N, Typ); + + else + Set_Etype (N, Typ); + end if; -- If the entity of N is not the associated node, this is a -- nested generic and it has an associated node as well, whose @@ -16939,7 +16945,11 @@ package body Sem_Ch12 is Set_Has_Private_View (N); if Present (Full_View (Typ)) then - Set_Etype (N2, Full_View (Typ)); + if Comparison then + Set_Compare_Type (N2, Full_View (Typ)); + else + Set_Etype (N2, Full_View (Typ)); + end if; end if; end if; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 78249258f55..83705b9dae1 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -2057,8 +2057,9 @@ package body Sem_Ch4 is -- For the predefined case, the result is Boolean, regardless of the -- type of the operands. The operands may even be limited, if they are -- generic actuals. If they are overloaded, label the operands with the - -- common type that must be present, or with the type of the formal of - -- the user-defined function. + -- compare type if it is present, typically because it is a global type + -- in a generic instance, or with the common type that must be present, + -- or with the type of the formal of the user-defined function. if Present (Entity (N)) then Op_Id := Entity (N); @@ -2071,7 +2072,10 @@ package body Sem_Ch4 is if Is_Overloaded (L) then if Ekind (Op_Id) = E_Operator then - Set_Etype (L, Intersect_Types (L, R)); + Set_Etype (L, + (if Present (Compare_Type (N)) + then Compare_Type (N) + else Intersect_Types (L, R))); else Set_Etype (L, Etype (First_Formal (Op_Id))); end if; @@ -2079,7 +2083,10 @@ package body Sem_Ch4 is if Is_Overloaded (R) then if Ekind (Op_Id) = E_Operator then - Set_Etype (R, Intersect_Types (L, R)); + Set_Etype (R, + (if Present (Compare_Type (N)) + then Compare_Type (N) + else Intersect_Types (L, R))); else Set_Etype (R, Etype (Next_Formal (First_Formal (Op_Id)))); end if; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index fa1365c2641..42f7c10c5c5 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -7611,6 +7611,7 @@ package body Sem_Res is Resolve (L, T); Resolve (R, T); + Set_Compare_Type (N, T); Check_Unset_Reference (L); Check_Unset_Reference (R); Generate_Operator_Reference (N, T); @@ -9119,6 +9120,7 @@ package body Sem_Res is Resolve (L, T); Resolve (R, T); + Set_Compare_Type (N, T); -- AI12-0413: user-defined primitive equality of an untagged record -- type hides the predefined equality operator, including within a diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index fc9bcfbd44d..8f962601985 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -962,6 +962,20 @@ package Sinfo is -- was constructed as part of the expansion of an iterator -- specification. + -- Compare_Type + -- Present in N_Op_Compare nodes. Set during resolution to the type of + -- the operands. It is used to propagate the type of the operands from + -- a N_Op_Compare node in a generic construct to the nodes created from + -- it in the various instances, when this type is global to the generic + -- construct. Resolution for global types cannot be redone in instances + -- because the instantiation can be done out of context, e.g. for bodies, + -- and the visibility of global types is incorrect in this case; that is + -- why the result of the resolution done in the generic construct needs + -- to be available in the instances but, unlike for arithmetic operators, + -- the Etype cannot be used to that effect for comparison operators. It + -- is also used as the type subject to the Has_Private_View processing on + -- the nodes instead of the Etype. + -- Compile_Time_Known_Aggregate -- Present in N_Aggregate nodes. Set for aggregates which can be fully -- evaluated at compile time without raising constraint error. Such @@ -4507,31 +4521,37 @@ package Sinfo is -- N_Op_Eq -- Sloc points to = + -- Compare_Type -- plus fields for binary operator -- plus fields for expression -- N_Op_Ne -- Sloc points to /= + -- Compare_Type -- plus fields for binary operator -- plus fields for expression -- N_Op_Lt -- Sloc points to < + -- Compare_Type -- plus fields for binary operator -- plus fields for expression -- N_Op_Le -- Sloc points to <= + -- Compare_Type -- plus fields for binary operator -- plus fields for expression -- N_Op_Gt -- Sloc points to > + -- Compare_Type -- plus fields for binary operator -- plus fields for expression -- N_Op_Ge -- Sloc points to >= + -- Compare_Type -- plus fields for binary operator -- plus fields for expression -- 2.42.0