From 80a09e02289bb693ada2601ea4cc9e0b6df3f375 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 30 Sep 2020 08:34:57 -0400 Subject: [PATCH] [Ada] AI12-0394 Named Numbers and User-Defined Numeric Literals 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. --- gcc/ada/einfo.adb | 6 +- gcc/ada/einfo.ads | 8 ++- gcc/ada/libgnat/a-nbnbin.adb | 2 +- gcc/ada/libgnat/a-nbnbin.ads | 2 +- gcc/ada/libgnat/a-nbnbre.adb | 9 ++- gcc/ada/libgnat/a-nbnbre.ads | 4 +- gcc/ada/sem_ch13.adb | 70 ++++++++++++++++++---- gcc/ada/sem_eval.adb | 2 +- gcc/ada/sem_res.adb | 111 +++++++++++++++++++++++++---------- gcc/ada/uintp.ads | 2 +- 10 files changed, 161 insertions(+), 55 deletions(-) diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index f39b3bcd1a1..3824b177684 100644 --- 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 index be195ab23c5..bc58b88d20f 100644 --- 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 index e40be35e72e..01f41d87226 100644 --- 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 index 7b4974a934f..668da8df342 100644 --- 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 index 055dedc59ad..8459539d212 100644 --- 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 index 5a8ebb9ccb1..ee5636f21d1 100644 --- 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 index d8967dd5f7d..3a906c7f610 100644 --- 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 index 12f2822f06b..a04c5fa513c 100644 --- 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 index a24c9c24638..f2f0a12bef0 100644 --- 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 index 648ee3189a1..abae0cdda90 100644 --- 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 -- 2.30.2