[Ada] AI12-0394 Named Numbers and User-Defined Numeric Literals
authorArnaud Charlet <charlet@adacore.com>
Wed, 30 Sep 2020 12:34:57 +0000 (08:34 -0400)
committerPierre-Marie de Rodat <derodat@adacore.com>
Tue, 24 Nov 2020 10:16:02 +0000 (05:16 -0500)
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
gcc/ada/einfo.ads
gcc/ada/libgnat/a-nbnbin.adb
gcc/ada/libgnat/a-nbnbin.ads
gcc/ada/libgnat/a-nbnbre.adb
gcc/ada/libgnat/a-nbnbre.ads
gcc/ada/sem_ch13.adb
gcc/ada/sem_eval.adb
gcc/ada/sem_res.adb
gcc/ada/uintp.ads

index f39b3bcd1a13de4a8107bd43b0379d2b0f7ffc8d..3824b177684c20b8e9115797146498b0bbaca6ef 100644 (file)
@@ -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;
 
index be195ab23c5c7ec5aa7d6de7c0f4521716303181..bc58b88d20f8226d4d706de20446e509865bf853 100644 (file)
@@ -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???
index e40be35e72ed574046924ec3a4910a53412646d1..01f41d8722646eb237aedc3c795543b90ef78676 100644 (file)
@@ -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
index 7b4974a934f309757381cda52b24fa3c41788860..668da8df34214f798e1bf8a72c3260d1e5393b0a 100644 (file)
@@ -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);
index 055dedc59ad30b5ca468e974a33e88097a0dd028..8459539d21239042c453f70906be5a4077b672f7 100644 (file)
@@ -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 --
    --------------------------
index 5a8ebb9ccb19bf2b32d89267fc8694d57e914909..ee5636f21d13642d9a462720eb2ccefb2108a275 100644 (file)
@@ -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
index d8967dd5f7d7a57eddccabc9930a03fb8edb2d17..3a906c7f610613894eb710c0135d882f6c96fc4b 100644 (file)
@@ -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;
 
    -----------------------------------
index 12f2822f06b3224cc56e9838aac1f9d9b22c3120..a04c5fa513c92fc0c13c551e4284e0e419122aa6 100644 (file)
@@ -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.
 
index a24c9c2463850bc7cabe42532dff64b736166dbb..f2f0a12bef0bcab39f7aa7c8142a7a4e81bd799e 100644 (file)
@@ -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;
index 648ee3189a14d0fbef756d9520849716800303c4..abae0cdda905b2e5dd8d8092dff11b29ba6e0e03 100644 (file)
@@ -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