@@ -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;
@@ -4115,14 +4115,16 @@ package Einfo is
-- only for type-related error messages.
-- Related_Expression (Node24)
+-- 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???
@@ -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
@@ -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);
@@ -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 --
--------------------------
@@ -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
@@ -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;
-----------------------------------
@@ -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.
@@ -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;
@@ -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