From patchwork Tue Nov 24 10:17:02 2020 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: 1405417 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=sourceware.org; envelope-from=gcc-patches-bounces@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Received: from sourceware.org (unknown [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 4CgKjR5KtTz9sRR for ; Tue, 24 Nov 2020 21:18:19 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id EE854393BC0E; Tue, 24 Nov 2020 10:17:20 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from rock.gnat.com (rock.gnat.com [IPv6:2620:20:4000:0:a9e:1ff:fe9b:1d1]) by sourceware.org (Postfix) with ESMTP id D05AF389683E for ; Tue, 24 Nov 2020 10:17:05 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org D05AF389683E Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=derodat@adacore.com Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 34691116A63; Tue, 24 Nov 2020 05:17:02 -0500 (EST) X-Virus-Scanned: Debian amavisd-new at gnat.com Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id lLap6AiU4KhC; Tue, 24 Nov 2020 05:17:02 -0500 (EST) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 21A1D116B33; Tue, 24 Nov 2020 05:17:02 -0500 (EST) Received: by tron.gnat.com (Postfix, from userid 4862) id 2089F107; Tue, 24 Nov 2020 05:17:02 -0500 (EST) Date: Tue, 24 Nov 2020 05:17:02 -0500 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Subject: [Ada] AI12-0394 Named Numbers and User-Defined Numeric Literals Message-ID: <20201124101702.GA1243@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-Spam-Status: No, score=-10.8 required=5.0 tests=BAYES_00, GIT_PATCH_0, KAM_DMARC_STATUS, SPF_HELO_NONE, SPF_PASS, TXREP, T_FILL_THIS_FORM_SHORT autolearn=ham autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) 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: , Cc: Arnaud Charlet Errors-To: gcc-patches-bounces@gcc.gnu.org Sender: "Gcc-patches" Integer named numbers may now be used with types that have an Integer_Literal aspect. Real named numbers may be used with types that have a Real_Literal aspect with an overloading that takes two strings. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * sem_ch13.adb (Validate_Literal_Aspect): Add support for named numbers and in particular overload of the Real_Literal function. * sem_res.adb (Resolve): Add support for named numbers in Real_Literal and Integer_Literal resolution. * einfo.adb, einfo.ads (Related_Expression, Set_Related_Expression): Allow E_Function. * uintp.ads (UI_Image_Max): Bump size of buffer to avoid loosing precision. * sem_eval.adb: Fix typo in comment. * libgnat/a-nbnbin.adb, libgnat/a-nbnbin.ads (From_String): Return a Valid_Big_Integer. * libgnat/a-nbnbre.adb, libgnat/a-nbnbre.ads (From_String): New variant taking two strings. Return a Valid_Big_Real. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -3202,7 +3202,8 @@ package body Einfo is function Related_Expression (Id : E) return N is begin - pragma Assert (Ekind (Id) in Type_Kind | E_Constant | E_Variable); + pragma Assert + (Ekind (Id) in Type_Kind | E_Constant | E_Variable | E_Function); return Node24 (Id); end Related_Expression; @@ -6478,7 +6479,8 @@ package body Einfo is procedure Set_Related_Expression (Id : E; V : N) is begin pragma Assert - (Ekind (Id) in Type_Kind | E_Constant | E_Variable | E_Void); + (Ekind (Id) in + Type_Kind | E_Constant | E_Variable | E_Function | E_Void); Set_Node24 (Id, V); end Set_Related_Expression; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -4115,14 +4115,16 @@ package Einfo is -- only for type-related error messages. -- Related_Expression (Node24) --- Defined in variables and types. When Set for internally generated --- entities, it may be used to denote the source expression whose --- elaboration created the variable declaration. If set, it is used +-- Defined in variables, types and functions. When Set for internally +-- generated entities, it may be used to denote the source expression +-- whose elaboration created the variable declaration. If set, it is used -- for generating clearer messages from CodePeer. It is used on source -- entities that are variables in iterator specifications, to provide -- a link to the container that is the domain of iteration. This allows -- for better cross-reference information when the loop modifies elements -- of the container, and suppresses spurious warnings. +-- Finally this node is used on functions specified via the Real_Literal +-- aspect, to denote the 2-parameter overloading, if found. -- -- Shouldn't it also be used for the same purpose in errout? It seems -- odd to have two mechanisms here??? diff --git a/gcc/ada/libgnat/a-nbnbin.adb b/gcc/ada/libgnat/a-nbnbin.adb --- a/gcc/ada/libgnat/a-nbnbin.adb +++ b/gcc/ada/libgnat/a-nbnbin.adb @@ -235,7 +235,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is -- From_String -- ----------------- - function From_String (Arg : String) return Big_Integer is + function From_String (Arg : String) return Valid_Big_Integer is procedure Scan_Decimal (Arg : String; J : in out Natural; Result : out Big_Integer); -- Scan decimal value starting at Arg (J). Store value in Result if diff --git a/gcc/ada/libgnat/a-nbnbin.ads b/gcc/ada/libgnat/a-nbnbin.ads --- a/gcc/ada/libgnat/a-nbnbin.ads +++ b/gcc/ada/libgnat/a-nbnbin.ads @@ -113,7 +113,7 @@ is Post => To_String'Result'First = 1, Global => null; - function From_String (Arg : String) return Big_Integer + function From_String (Arg : String) return Valid_Big_Integer with Global => null; procedure Put_Image (S : in out Sink'Class; V : Big_Integer); diff --git a/gcc/ada/libgnat/a-nbnbre.adb b/gcc/ada/libgnat/a-nbnbre.adb --- a/gcc/ada/libgnat/a-nbnbre.adb +++ b/gcc/ada/libgnat/a-nbnbre.adb @@ -318,7 +318,7 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is -- From_String -- ----------------- - function From_String (Arg : String) return Big_Real is + function From_String (Arg : String) return Valid_Big_Real is Ten : constant Big_Integer := To_Big_Integer (10); Frac : Big_Integer; Exp : Integer := 0; @@ -373,6 +373,13 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is end; end From_String; + function From_String + (Numerator, Denominator : String) return Valid_Big_Real is + begin + return Big_Integers.From_String (Numerator) / + Big_Integers.From_String (Denominator); + end From_String; + -------------------------- -- From_Quotient_String -- -------------------------- diff --git a/gcc/ada/libgnat/a-nbnbre.ads b/gcc/ada/libgnat/a-nbnbre.ads --- a/gcc/ada/libgnat/a-nbnbre.ads +++ b/gcc/ada/libgnat/a-nbnbre.ads @@ -120,7 +120,9 @@ is Post => To_String'Result'First = 1, Global => null; - function From_String (Arg : String) return Big_Real + function From_String (Arg : String) return Valid_Big_Real + with Global => null; + function From_String (Numerator, Denominator : String) return Valid_Big_Real with Global => null; function To_Quotient_String (Arg : Big_Real) return String is diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -16177,12 +16177,31 @@ package body Sem_Ch13 is Func_Name : constant Node_Id := Expression (ASN); Overloaded : Boolean := Is_Overloaded (Func_Name); - I : Interp_Index; - It : Interp; - Param_Type : Entity_Id; - Match_Found : Boolean := False; - Is_Match : Boolean; - Match : Interp; + I : Interp_Index; + It : Interp; + Param_Type : Entity_Id; + Match_Found : Boolean := False; + Match2_Found : Boolean := False; + Is_Match : Boolean; + Match : Interp; + Match2 : Entity_Id := Empty; + + function Matching + (Param_Id : Entity_Id; Param_Type : Entity_Id) return Boolean; + -- Return True if Param_Id is a non aliased in parameter whose base type + -- is Param_Type. + + -------------- + -- Matching -- + -------------- + + function Matching + (Param_Id : Entity_Id; Param_Type : Entity_Id) return Boolean is + begin + return Base_Type (Etype (Param_Id)) = Param_Type + and then Ekind (Param_Id) = E_In_Parameter + and then not Is_Aliased (Param_Id); + end Matching; begin if not Is_Type (Typ) then @@ -16234,20 +16253,39 @@ package body Sem_Ch13 is Params : constant List_Id := Parameter_Specifications (Parent (It.Nam)); Param_Spec : Node_Id; - Param_Id : Entity_Id; begin if List_Length (Params) = 1 then Param_Spec := First (Params); + Is_Match := + Matching (Defining_Identifier (Param_Spec), Param_Type); + + -- Look for the optional overloaded 2-param Real_Literal - if not More_Ids (Param_Spec) then - Param_Id := Defining_Identifier (Param_Spec); + elsif List_Length (Params) = 2 + and then A_Id = Aspect_Real_Literal + then + Param_Spec := First (Params); - if Base_Type (Etype (Param_Id)) = Param_Type - and then Ekind (Param_Id) = E_In_Parameter - and then not Is_Aliased (Param_Id) + if Matching (Defining_Identifier (Param_Spec), Param_Type) + then + Param_Spec := Next (Param_Spec); + + if Matching (Defining_Identifier (Param_Spec), Param_Type) then - Is_Match := True; + if No (Match2) then + Match2 := It.Nam; + Match2_Found := True; + else + -- If we find more than one possible match then + -- do not take any into account here: since the + -- 2-parameter version of Real_Literal is optional + -- we cannot generate an error here, so let + -- standard resolution fail later if we do need to + -- call this variant. + + Match2_Found := False; + end if; end if; end if; end if; @@ -16282,6 +16320,12 @@ package body Sem_Ch13 is Set_Entity (Func_Name, Match.Nam); Set_Etype (Func_Name, Etype (Match.Nam)); Set_Is_Overloaded (Func_Name, False); + + -- Record the match for 2-parameter function if found + + if Match2_Found then + Set_Related_Expression (Match.Nam, Match2); + end if; end Validate_Literal_Aspect; ----------------------------------- diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -7318,7 +7318,7 @@ package body Sem_Eval is elsif Ekind (E) = E_Constant then - -- One case we can give a metter message is when we have a + -- One case we can give a better message is when we have a -- string literal created by concatenating an aggregate with -- an others expression. 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 @@ -2155,6 +2155,10 @@ package body Sem_Res is 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 @@ -2880,58 +2884,102 @@ package body Sem_Res is -- Rewrite Literal as a call if the corresponding literal aspect -- is set. - if Nkind (N) in N_Numeric_Or_String_Literal - and then Present - (Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N)))) + 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 declare - function Literal_Text (N : Node_Id) return String_Id; - -- Returns the text of a literal node + Lit_Aspect : constant Aspect_Id := + (if Nkind (N) = N_Identifier + then Named_Number_Aspect_Map (Ekind (Entity (N))) + else Literal_Aspect_Map (Nkind (N))); - ------------------- - -- Literal_Text -- - ------------------- + Loc : constant Source_Ptr := Sloc (N); - function Literal_Text (N : Node_Id) return String_Id is - begin - pragma Assert (Nkind (N) in N_Numeric_Or_String_Literal); + Callee : Entity_Id := + Entity (Expression (Find_Aspect (Typ, Lit_Aspect))); - if Nkind (N) = N_String_Literal then - return Strval (N); - else - return String_From_Numeric_Literal (N); - end if; - end Literal_Text; + Name : constant Node_Id := + Make_Identifier (Loc, Chars (Callee)); - Lit_Aspect : constant Aspect_Id := - Literal_Aspect_Map (Nkind (N)); + Param1 : Node_Id; + Param2 : Node_Id; + Params : List_Id; + Call : Node_Id; + Expr : Node_Id; - Callee : constant Entity_Id := - Entity (Expression (Find_Aspect (Typ, Lit_Aspect))); + begin + if Nkind (N) = N_Identifier then + Expr := Expression (Declaration_Node (Entity (N))); - Loc : constant Source_Ptr := Sloc (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); - Name : constant Node_Id := - Make_Identifier (Loc, Chars (Callee)); + else + UI_Image (Norm_Num (Expr_Value_R (Expr)), Decimal); + Start_String; + 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); - Param : constant Node_Id := - Make_String_Literal (Loc, Literal_Text (N)); + 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; - Params : constant List_Id := New_List (Param); + 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 : Node_Id := + Call := Make_Function_Call (Sloc => Loc, Name => Name, Parameter_Associations => Params); - begin + Set_Entity (Name, Callee); Set_Is_Overloaded (Name, False); + if Lit_Aspect = Aspect_String_Literal then - Set_Etype (Param, Standard_Wide_Wide_String); + Set_Etype (Param1, Standard_Wide_Wide_String); else - Set_Etype (Param, Standard_String); + Set_Etype (Param1, Standard_String); end if; + Set_Etype (Call, Etype (Callee)); -- Conversion needed in case of an inherited aspect @@ -2947,6 +2995,7 @@ package body Sem_Res is Rewrite (N, Call); end; + Analyze_And_Resolve (N, Typ); return; end if; diff --git a/gcc/ada/uintp.ads b/gcc/ada/uintp.ads --- a/gcc/ada/uintp.ads +++ b/gcc/ada/uintp.ads @@ -281,7 +281,7 @@ package Uintp is -- or decimal format. Auto, the default setting, lets the routine make a -- decision based on the value. - UI_Image_Max : constant := 48; -- Enough for a 128-bit number + UI_Image_Max : constant := 1024; UI_Image_Buffer : String (1 .. UI_Image_Max); UI_Image_Length : Natural; -- Buffer used for UI_Image as described below