OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[Ada] AI12-0394 Named Numbers and User-Defined Numeric Literals

Browse Source 
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.
This commit is contained in:
Arnaud Charlet 2020-09-30 08:34:57 -04:00 committed by Pierre-Marie de Rodat
parent dcb1cad0e0
commit 80a09e0228
10 changed files with 162 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/ada/einfo.adb
View 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;

8
gcc/ada/einfo.ads
View 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???

2
gcc/ada/libgnat/a-nbnbin.adb
View 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

2
gcc/ada/libgnat/a-nbnbin.ads
View 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);

9
gcc/ada/libgnat/a-nbnbre.adb
View 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 --
--------------------------

4
gcc/ada/libgnat/a-nbnbre.ads
View 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

70
gcc/ada/sem_ch13.adb
View 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);
if not More_Ids (Param_Spec) then
Param_Id := Defining_Identifier (Param_Spec);
-- Look for the optional overloaded 2-param Real_Literal
if Base_Type (Etype (Param_Id)) = Param_Type
and then Ekind (Param_Id) = E_In_Parameter
and then not Is_Aliased (Param_Id)
elsif List_Length (Params) = 2
and then A_Id = Aspect_Real_Literal
then
Param_Spec := First (Params);
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;
-----------------------------------

2
gcc/ada/sem_eval.adb
View 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.

113
gcc/ada/sem_res.adb
View 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
-------------------
-- Literal_Text --
-------------------
function Literal_Text (N : Node_Id) return String_Id is
begin
pragma Assert (Nkind (N) in N_Numeric_Or_String_Literal);
if Nkind (N) = N_String_Literal then
return Strval (N);
else
return String_From_Numeric_Literal (N);
end if;
end Literal_Text;
Lit_Aspect : constant Aspect_Id :=
Literal_Aspect_Map (Nkind (N));
Callee : constant Entity_Id :=
Entity (Expression (Find_Aspect (Typ, Lit_Aspect)));
(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));
Param : constant Node_Id :=
Make_String_Literal (Loc, Literal_Text (N));
Param1 : Node_Id;
Param2 : Node_Id;
Params : List_Id;
Call : Node_Id;
Expr : Node_Id;
Params : constant List_Id := New_List (Param);
begin
if Nkind (N) = N_Identifier then
Expr := Expression (Declaration_Node (Entity (N)));
Call : Node_Id :=
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;
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);
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;

2
gcc/ada/uintp.ads
View 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