From patchwork Mon Oct 25 15:09:36 2021 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: 46638 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 759363858435 for ; Mon, 25 Oct 2021 15:30:14 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 759363858435 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1635175814; bh=iuF+Zs9oisKXIq9n6KV0Tuf1/gDa7ErrwgaddphekLY=; h=Date:To:Subject:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:Cc:From; b=b7GftCffSInHpIWWV6ICH58gD0M8u40kYRMkGZyyMZdr9YpGGB+Uy2HG7sMuwwqbP SgaJU46ccqcIhgwFB/pytZWW2SXunDddFjFGqZO6C+g/30pya2QbPRWjEkAPI8a4Am gY1q9vlOF/4/xQZieONKbdfCKLWD+BFB7ENqwKo8= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-lj1-x231.google.com (mail-lj1-x231.google.com [IPv6:2a00:1450:4864:20::231]) by sourceware.org (Postfix) with ESMTPS id 9BF443858015 for ; Mon, 25 Oct 2021 15:09:39 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 9BF443858015 Received: by mail-lj1-x231.google.com with SMTP id f13so1710721ljo.12 for ; Mon, 25 Oct 2021 08:09:39 -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=iuF+Zs9oisKXIq9n6KV0Tuf1/gDa7ErrwgaddphekLY=; b=BCy8k5mSvL5dqzUUxSskiigo2VyMJ6OhQjlh/vXmTVShGCGT+G2NKZnq/KLXEgfzIH QrPQv+V43+HXF0evLb2uUkmgxW5ISENnnkX7lRj3M661rvO5M1wbqawKlaGMXubZ8wDG XKWWsejhiDYrNIWflzYHh9icZKEkOo/FdnnrgAHKRDLcaWxkCzd+2FupfUEj1jaCkVVE AAR4QQxhj/NrPevuRJjloPXP6QHnhXUXM9jnGKI+Xl0NzB0pnpO0SHLd3NpiNca6xHyC T6aa2FTpW59gfqNvve+2aUIoypj9YDQnuDMX9dNSA02h9QcjeBfFvPqbZjyrud4FS3Ut 45VA== X-Gm-Message-State: AOAM530XF+YP5jykn57wYpdlb5uO6XCl8amHpNMeiNU0k+8oRNkVJRx/ 9VwQ2KGgwLWNnJlVWMxurQS4lGZLZCi+b7kv X-Google-Smtp-Source: ABdhPJwSHUMnmFZ2WxAcNqD50cxfK16Dybz+oM6OM4CdjUe8Chia2JidkZ+UD8DzSvRSLiqmA+Z42g== X-Received: by 2002:a2e:9795:: with SMTP id y21mr19970017lji.283.1635174578491; Mon, 25 Oct 2021 08:09:38 -0700 (PDT) Received: from adacore.com ([2a02:2ab8:224:2ce:72b5:e8ff:feef:ee60]) by smtp.gmail.com with ESMTPSA id s18sm1678258lfg.27.2021.10.25.08.09.37 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 25 Oct 2021 08:09:37 -0700 (PDT) Date: Mon, 25 Oct 2021 15:09:36 +0000 To: gcc-patches@gcc.gnu.org Subject: [Ada] Spurious error on user-defined literal and operator Message-ID: <20211025150936.GA346849@adacore.com> MIME-Version: 1.0 Content-Disposition: inline X-Spam-Status: No, score=-12.6 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 autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) 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: Ed Schonberg Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" This patch improves the handling of the Ada_2022 aspect involving user-defined literals on integers, reals, and strings, when the literal that must be converted to a type (for which the aspect is defined) appears as an operand of a predefined operator. The target type may be given by the type of the context, or by the type of another operand of the operator. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * sem_ch4.adb (Has_Possible_Literal_Aspects): If analysis of an operator node fails to find a possible interpretation, and one of its operands is a literal or a named number, assign to the node the corresponding class type (Any_Integer, Any_String, etc). (Operator_Check): Call it before emitting a type error. * sem_res.adb (Has_Applicable_User_Defined_Literal): Given a literal and a type, determine whether the type has a user_defined aspect that can apply to the literal, and rewrite the node as call to the corresponding function. Most of the code was previously in procedure Resolve. (Try_User_Defined_Literal): Check operands of a predefined operator that fails to resolve, and apply Has_Applicable_User_Defined_Literal to literal operands if any, to find if a conversion will allow the operator to resolve properly. (Resolve): Call the above when a literal or an operator with a literal operand fails to resolve. diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -281,6 +281,19 @@ package body Sem_Ch4 is -- type is not directly visible. The routine uses this type to emit a more -- informative message. + function Has_Possible_Literal_Aspects (N : Node_Id) return Boolean; + -- Ada_2022: if an operand is a literal it may be subject to an + -- implicit conversion to a type for which a user-defined literal + -- function exists. During the first pass of type resolution we do + -- not know the context imposed on the literal, so we assume that + -- the literal type is a valid candidate and rely on the second pass + -- of resolution to find the type with the proper aspect. We only + -- add this interpretation if no other one was found, which may be + -- too restrictive but seems sufficient to handle most proper uses + -- of the new aspect. It is unclear whether a full implementation of + -- these aspects can be achieved without larger modifications to the + -- two-pass resolution algorithm. + procedure Remove_Abstract_Operations (N : Node_Id); -- Ada 2005: implementation of AI-310. An abstract non-dispatching -- operation is not a candidate interpretation. @@ -7541,6 +7554,9 @@ package body Sem_Ch4 is then return; + elsif Has_Possible_Literal_Aspects (N) then + return; + -- If we have a logical operator, one of whose operands is -- Boolean, then we know that the other operand cannot resolve to -- Boolean (since we got no interpretations), but in that case we @@ -7857,6 +7873,69 @@ package body Sem_Ch4 is end if; end Operator_Check; + ---------------------------------- + -- Has_Possible_Literal_Aspects -- + ---------------------------------- + + function Has_Possible_Literal_Aspects (N : Node_Id) return Boolean is + R : constant Node_Id := Right_Opnd (N); + L : Node_Id := Empty; + + procedure Check_Literal_Opnd (Opnd : Node_Id); + -- If an operand is a literal to which an aspect may apply, + -- add the corresponding type to operator node. + + ------------------------ + -- Check_Literal_Opnd -- + ------------------------ + + procedure Check_Literal_Opnd (Opnd : Node_Id) is + begin + if Nkind (Opnd) in N_Numeric_Or_String_Literal + or else (Is_Entity_Name (Opnd) + and then Present (Entity (Opnd)) + and then Is_Named_Number (Entity (Opnd))) + then + Add_One_Interp (N, Etype (Opnd), Etype (Opnd)); + end if; + end Check_Literal_Opnd; + + -- Start of processing for Has_Possible_Literal_Aspects + + begin + if Ada_Version < Ada_2022 then + return False; + end if; + + if Nkind (N) in N_Binary_Op then + L := Left_Opnd (N); + else + L := Empty; + end if; + Check_Literal_Opnd (R); + + -- Check left operand only if right one did not provide a + -- possible interpretation. Note that literal types are not + -- overloadable, in the sense that there is no overloadable + -- entity name whose several interpretations can be used to + -- indicate possible resulting types, so there is no way to + -- provide more than one interpretation to the operator node. + -- The choice of one operand over the other is arbitrary at + -- this point, and may lead to spurious resolution when both + -- operands are literals of different kinds, but the second + -- pass of resolution will examine anew both operands to + -- determine whether a user-defined literal may apply to + -- either or both. + + if Present (L) + and then Etype (N) = Any_Type + then + Check_Literal_Opnd (L); + end if; + + return Etype (N) /= Any_Type; + end Has_Possible_Literal_Aspects; + -------------------------------- -- Remove_Abstract_Operations -- -------------------------------- 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 @@ -103,6 +103,14 @@ package body Sem_Res is -- Note that Resolve_Attribute is separated off in Sem_Attr + function Has_Applicable_User_Defined_Literal + (N : Node_Id; + Typ : Entity_Id) return Boolean; + -- If N is a literal or a named number, check whether Typ + -- has a user-defined literal aspect that can apply to N. + -- If present, replace N with a call to the corresponding + -- function and return True. + procedure Check_Discriminant_Use (N : Node_Id); -- Enforce the restrictions on the use of discriminants when constraining -- a component of a discriminated type (record or concurrent type). @@ -286,6 +294,15 @@ package body Sem_Res is -- is only one requires a search over all visible entities, and happens -- only in very pathological cases (see 6115-006). + function Try_User_Defined_Literal + (N : Node_Id; + Typ : Entity_Id) return Boolean; + -- If an operator node has a literal operand, check whether the type + -- of the context, or the type of the other operand has a user-defined + -- literal aspect that can be applied to the literal to resolve the node. + -- If such aspect exists, replace literal with a call to the + -- corresponing function and return True, return false otherwise. + ------------------------- -- Ambiguous_Character -- ------------------------- @@ -409,6 +426,165 @@ package body Sem_Res is end if; end Analyze_And_Resolve; + ------------------------------------- + -- Has_Applicable_User_Defined_Literal -- + ------------------------------------- + + function Has_Applicable_User_Defined_Literal + (N : Node_Id; + Typ : Entity_Id) return Boolean + is + Loc : constant Source_Ptr := Sloc (N); + Literal_Aspect_Map : + constant array (N_Numeric_Or_String_Literal) of Aspect_Id := + (N_Integer_Literal => Aspect_Integer_Literal, + N_Real_Literal => Aspect_Real_Literal, + N_String_Literal => Aspect_String_Literal); + + Named_Number_Aspect_Map : constant array (Named_Kind) of Aspect_Id := + (E_Named_Integer => Aspect_Integer_Literal, + E_Named_Real => Aspect_Real_Literal); + + Lit_Aspect : Aspect_Id; + + Callee : Entity_Id; + Name : Node_Id; + Param1 : Node_Id; + Param2 : Node_Id; + Params : List_Id; + Call : Node_Id; + Expr : Node_Id; + + begin + if (Nkind (N) in N_Numeric_Or_String_Literal + and then Present + (Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N))))) + or else + (Nkind (N) = N_Identifier + and then Is_Named_Number (Entity (N)) + and then + Present + (Find_Aspect + (Typ, Named_Number_Aspect_Map (Ekind (Entity (N)))))) + then + Lit_Aspect := + (if Nkind (N) = N_Identifier + then Named_Number_Aspect_Map (Ekind (Entity (N))) + else Literal_Aspect_Map (Nkind (N))); + Callee := + Entity (Expression (Find_Aspect (Typ, Lit_Aspect))); + Name := Make_Identifier (Loc, Chars (Callee)); + + if Is_Derived_Type (Typ) + and then Is_Tagged_Type (Typ) + and then Base_Type (Etype (Callee)) /= Base_Type (Typ) + then + Callee := + Corresponding_Primitive_Op + (Ancestor_Op => Callee, + Descendant_Type => Base_Type (Typ)); + end if; + + -- Handle an identifier that denotes a named number. + + if Nkind (N) = N_Identifier then + Expr := Expression (Declaration_Node (Entity (N))); + + if Ekind (Entity (N)) = E_Named_Integer then + UI_Image (Expr_Value (Expr), Decimal); + Start_String; + Store_String_Chars + (UI_Image_Buffer (1 .. UI_Image_Length)); + Param1 := Make_String_Literal (Loc, End_String); + Params := New_List (Param1); + + else + UI_Image (Norm_Num (Expr_Value_R (Expr)), Decimal); + Start_String; + + if UR_Is_Negative (Expr_Value_R (Expr)) then + Store_String_Chars ("-"); + end if; + + Store_String_Chars + (UI_Image_Buffer (1 .. UI_Image_Length)); + Param1 := Make_String_Literal (Loc, End_String); + + -- Note: Set_Etype is called below on Param1 + + UI_Image (Norm_Den (Expr_Value_R (Expr)), Decimal); + Start_String; + Store_String_Chars + (UI_Image_Buffer (1 .. UI_Image_Length)); + Param2 := Make_String_Literal (Loc, End_String); + Set_Etype (Param2, Standard_String); + + Params := New_List (Param1, Param2); + + if Present (Related_Expression (Callee)) then + Callee := Related_Expression (Callee); + else + Error_Msg_NE + ("cannot resolve & for a named real", N, Callee); + return False; + end if; + end if; + + elsif Nkind (N) = N_String_Literal then + Param1 := Make_String_Literal (Loc, Strval (N)); + Params := New_List (Param1); + + else + Param1 := + Make_String_Literal + (Loc, String_From_Numeric_Literal (N)); + Params := New_List (Param1); + end if; + + Call := + Make_Function_Call + (Sloc => Loc, + Name => Name, + Parameter_Associations => Params); + + Set_Entity (Name, Callee); + Set_Is_Overloaded (Name, False); + + if Lit_Aspect = Aspect_String_Literal then + Set_Etype (Param1, Standard_Wide_Wide_String); + else + Set_Etype (Param1, Standard_String); + end if; + + Set_Etype (Call, Etype (Callee)); + + if Base_Type (Etype (Call)) /= Base_Type (Typ) then + -- Conversion may be needed in case of an inherited + -- aspect of a derived type. For a null extension, we + -- use a null extension aggregate instead because the + -- downward type conversion would be illegal. + + if Is_Null_Extension_Of + (Descendant => Typ, + Ancestor => Etype (Call)) + then + Call := Make_Extension_Aggregate (Loc, + Ancestor_Part => Call, + Null_Record_Present => True); + else + Call := Convert_To (Typ, Call); + end if; + end if; + + Rewrite (N, Call); + + Analyze_And_Resolve (N, Typ); + return True; + else + return False; + end if; + end Has_Applicable_User_Defined_Literal; + ---------------------------- -- Check_Discriminant_Use -- ---------------------------- @@ -2156,16 +2332,6 @@ package body Sem_Res is return; end Resolution_Failed; - Literal_Aspect_Map : - constant array (N_Numeric_Or_String_Literal) of Aspect_Id := - (N_Integer_Literal => Aspect_Integer_Literal, - N_Real_Literal => Aspect_Real_Literal, - N_String_Literal => Aspect_String_Literal); - - Named_Number_Aspect_Map : constant array (Named_Kind) of Aspect_Id := - (E_Named_Integer => Aspect_Integer_Literal, - E_Named_Real => Aspect_Real_Literal); - -- Start of processing for Resolve begin @@ -2884,143 +3050,14 @@ package body Sem_Res is end; end if; - -- Rewrite Literal as a call if the corresponding literal aspect - -- is set. + -- If node is a literal and context type has a user-defined + -- literal aspect, rewrite node as a call to the corresponding + -- function, which plays the role of an implicit conversion. - if (Nkind (N) in N_Numeric_Or_String_Literal - and then - Present - (Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N))))) - or else - (Nkind (N) = N_Identifier - and then Is_Named_Number (Entity (N)) - and then - Present - (Find_Aspect - (Typ, Named_Number_Aspect_Map (Ekind (Entity (N)))))) + if Nkind (N) in + N_Numeric_Or_String_Literal | N_Identifier + and then Has_Applicable_User_Defined_Literal (N, Typ) then - declare - Lit_Aspect : constant Aspect_Id := - (if Nkind (N) = N_Identifier - then Named_Number_Aspect_Map (Ekind (Entity (N))) - else Literal_Aspect_Map (Nkind (N))); - - Loc : constant Source_Ptr := Sloc (N); - - Callee : Entity_Id := - Entity (Expression (Find_Aspect (Typ, Lit_Aspect))); - - Name : constant Node_Id := - Make_Identifier (Loc, Chars (Callee)); - - Param1 : Node_Id; - Param2 : Node_Id; - Params : List_Id; - Call : Node_Id; - Expr : Node_Id; - - begin - if Is_Derived_Type (Typ) - and then Is_Tagged_Type (Typ) - and then Base_Type (Etype (Callee)) /= Base_Type (Typ) - then - Callee := - Corresponding_Primitive_Op - (Ancestor_Op => Callee, - Descendant_Type => Base_Type (Typ)); - end if; - - if Nkind (N) = N_Identifier then - Expr := Expression (Declaration_Node (Entity (N))); - - if Ekind (Entity (N)) = E_Named_Integer then - UI_Image (Expr_Value (Expr), Decimal); - Start_String; - Store_String_Chars - (UI_Image_Buffer (1 .. UI_Image_Length)); - Param1 := Make_String_Literal (Loc, End_String); - Params := New_List (Param1); - - else - UI_Image (Norm_Num (Expr_Value_R (Expr)), Decimal); - Start_String; - - if UR_Is_Negative (Expr_Value_R (Expr)) then - Store_String_Chars ("-"); - end if; - - Store_String_Chars - (UI_Image_Buffer (1 .. UI_Image_Length)); - Param1 := Make_String_Literal (Loc, End_String); - - -- Note: Set_Etype is called below on Param1 - - UI_Image (Norm_Den (Expr_Value_R (Expr)), Decimal); - Start_String; - Store_String_Chars - (UI_Image_Buffer (1 .. UI_Image_Length)); - Param2 := Make_String_Literal (Loc, End_String); - Set_Etype (Param2, Standard_String); - - Params := New_List (Param1, Param2); - - if Present (Related_Expression (Callee)) then - Callee := Related_Expression (Callee); - else - Error_Msg_NE - ("cannot resolve & for a named real", N, Callee); - return; - end if; - end if; - - elsif Nkind (N) = N_String_Literal then - Param1 := Make_String_Literal (Loc, Strval (N)); - Params := New_List (Param1); - else - Param1 := - Make_String_Literal - (Loc, String_From_Numeric_Literal (N)); - Params := New_List (Param1); - end if; - - Call := - Make_Function_Call - (Sloc => Loc, - Name => Name, - Parameter_Associations => Params); - - Set_Entity (Name, Callee); - Set_Is_Overloaded (Name, False); - - if Lit_Aspect = Aspect_String_Literal then - Set_Etype (Param1, Standard_Wide_Wide_String); - else - Set_Etype (Param1, Standard_String); - end if; - - Set_Etype (Call, Etype (Callee)); - - if Base_Type (Etype (Call)) /= Base_Type (Typ) then - -- Conversion may be needed in case of an inherited - -- aspect of a derived type. For a null extension, we - -- use a null extension aggregate instead because the - -- downward type conversion would be illegal. - - if Is_Null_Extension_Of - (Descendant => Typ, - Ancestor => Etype (Call)) - then - Call := Make_Extension_Aggregate (Loc, - Ancestor_Part => Call, - Null_Record_Present => True); - else - Call := Convert_To (Typ, Call); - end if; - end if; - - Rewrite (N, Call); - end; - Analyze_And_Resolve (N, Typ); return; end if; @@ -3116,6 +3153,14 @@ package body Sem_Res is ("missing ALL or SOME in quantified expression", Defining_Identifier (First (Component_Associations (N)))); + -- For an operator with no interpretation, check whether + -- one of its operands may be a user-defined literal. + + elsif Nkind (N) in N_Op + and then Try_User_Defined_Literal (N, Typ) + then + return; + else Wrong_Type (N, Typ); end if; @@ -12847,6 +12892,76 @@ package body Sem_Res is end if; end Simplify_Type_Conversion; + ------------------------------ + -- Try_User_Defined_Literal -- + ------------------------------ + + function Try_User_Defined_Literal + (N : Node_Id; + Typ : Entity_Id) return Boolean + is + begin + if Nkind (N) in N_Op_Add | N_Op_Divide | N_Op_Mod | N_Op_Multiply + | N_Op_Rem | N_Op_Subtract + then + + -- Both operands must have the same type as the context. + -- (ignoring for now fixed-point and exponentiation ops). + + if Has_Applicable_User_Defined_Literal (Right_Opnd (N), Typ) then + Resolve (Left_Opnd (N), Typ); + Analyze_And_Resolve (N, Typ); + return True; + end if; + + if + Has_Applicable_User_Defined_Literal (Left_Opnd (N), Typ) + then + Resolve (Right_Opnd (N), Typ); + Analyze_And_Resolve (N, Typ); + return True; + + else + return False; + end if; + + elsif Nkind (N) in N_Binary_Op then + -- For other operators the context does not impose a type on + -- the operands, but their types must match. + + if (Nkind (Left_Opnd (N)) + not in N_Integer_Literal | N_String_Literal | N_Real_Literal) + and then + Has_Applicable_User_Defined_Literal + (Right_Opnd (N), Etype (Left_Opnd (N))) + then + Analyze_And_Resolve (N, Typ); + return True; + + elsif (Nkind (Right_Opnd (N)) + not in N_Integer_Literal | N_String_Literal | N_Real_Literal) + and then + Has_Applicable_User_Defined_Literal + (Left_Opnd (N), Etype (Right_Opnd (N))) + then + Analyze_And_Resolve (N, Typ); + return True; + else + return False; + end if; + + elsif Nkind (N) in N_Unary_Op + and then + Has_Applicable_User_Defined_Literal (Right_Opnd (N), Typ) + then + Analyze_And_Resolve (N, Typ); + return True; + + else -- Other operators + return False; + end if; + end Try_User_Defined_Literal; + ----------------------------- -- Unique_Fixed_Point_Type -- -----------------------------