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

sem_eval.adb (Find_Universal_Operator_Type): New subprogram to identify the operand type of an operator on universal operands...

Browse Source 
2010-06-22  Thomas Quinot  <quinot@adacore.com>

	* sem_eval.adb (Find_Universal_Operator_Type): New
	subprogram to identify the operand type of an operator on universal
	operands, when an explicit scope indication is present. Diagnose the
	case where such a call is ambiguous.
	(Eval_Arithmetic_Op, Eval_Relational_Op, Eval_Unary_Op):
	Use the above to identify the operand type so it can be properly frozen.
	* sem_res.adb (Make_Call_Into_Operator): Remove bogus freeze of operand
	type, done in an arbitrary, possibly incorrect type (the presence of
	some numeric type in the scope is checked for legality, but when more
	than one such type is in the scope, we just pick a random one, not
	necessarily the expected one).
	* sem_utils.ads, sem_utils.adb (Is_Universal_Numeric_Type): New utility
	subprogram.

From-SVN: r161134
This commit is contained in:
Thomas Quinot 2010-06-22 07:03:30 +00:00 committed by Arnaud Charlet
parent ae77c68b39
commit d7567964ea
5 changed files with 122 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
gcc/ada/ChangeLog
View File

@ -1,3 +1,19 @@
2010-06-22 Thomas Quinot <quinot@adacore.com>
* sem_eval.adb (Find_Universal_Operator_Type): New
subprogram to identify the operand type of an operator on universal
operands, when an explicit scope indication is present. Diagnose the
case where such a call is ambiguous.
(Eval_Arithmetic_Op, Eval_Relational_Op, Eval_Unary_Op):
Use the above to identify the operand type so it can be properly frozen.
* sem_res.adb (Make_Call_Into_Operator): Remove bogus freeze of operand
type, done in an arbitrary, possibly incorrect type (the presence of
some numeric type in the scope is checked for legality, but when more
than one such type is in the scope, we just pick a random one, not
necessarily the expected one).
* sem_utils.ads, sem_utils.adb (Is_Universal_Numeric_Type): New utility
subprogram.
2010-06-22 Robert Dewar <dewar@adacore.com>
* sem_eval.adb: Minor reformatting.

116
gcc/ada/sem_eval.adb
View File

@ -31,6 +31,7 @@ with Elists; use Elists;
with Errout; use Errout;
with Eval_Fat; use Eval_Fat;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Lib; use Lib;
with Namet; use Namet;
with Nmake; use Nmake;
@ -180,12 +181,14 @@ package body Sem_Eval is
-- used for producing the result of the static evaluation of the
-- logical operators
procedure Test_Ambiguous_Operator (N : Node_Id);
function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id;
-- Check whether an arithmetic operation with universal operands which
-- is a rewritten function call with an explicit scope indication is
-- ambiguous: P."+" (1, 2) will be ambiguous if there is more than one
-- visible numeric type declared in P and the context does not impose a
-- type on the result (e.g. in the expression of a type conversion).
-- If ambiguous, emit an error and return Empty, else return the result
-- type of the operator.
procedure Test_Expression_Is_Foldable
(N : Node_Id;
@ -1453,6 +1456,7 @@ package body Sem_Eval is
Right : constant Node_Id := Right_Opnd (N);
Ltype : constant Entity_Id := Etype (Left);
Rtype : constant Entity_Id := Etype (Right);
Otype : Entity_Id := Empty;
Stat : Boolean;
Fold : Boolean;
@ -1465,15 +1469,11 @@ package body Sem_Eval is
return;
end if;
if (Etype (Right) = Universal_Integer
or else
Etype (Right) = Universal_Real)
and then
(Etype (Left) = Universal_Integer
or else
Etype (Left) = Universal_Real)
if Is_Universal_Numeric_Type (Etype (Left))
and then
Is_Universal_Numeric_Type (Etype (Right))
then
Test_Ambiguous_Operator (N);
Otype := Find_Universal_Operator_Type (N);
end if;
-- Fold for cases where both operands are of integer type
@ -1582,9 +1582,9 @@ package body Sem_Eval is
Fold_Uint (N, Result, Stat);
end;
-- Cases where at least one operand is a real. We handle the cases
-- of both reals, or mixed/real integer cases (the latter happen
-- only for divide and multiply, and the result is always real).
-- Cases where at least one operand is a real. We handle the cases of
-- both reals, or mixed/real integer cases (the latter happen only for
-- divide and multiply, and the result is always real).
elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then
declare
@ -1627,6 +1627,14 @@ package body Sem_Eval is
Fold_Ureal (N, Result, Stat);
end;
end if;
-- If the operator was resolved to a specific type, make sure that type
-- is frozen even if the expression is folded into a literal (which has
-- a universal type).
if Present (Otype) then
Freeze_Before (N, Otype);
end if;
end Eval_Arithmetic_Op;
----------------------------
@ -2371,6 +2379,7 @@ package body Sem_Eval is
end if;
Fold_Uint (N, Test (Result), True);
Warn_On_Known_Condition (N);
end Eval_Membership_Op;
@ -2656,6 +2665,7 @@ package body Sem_Eval is
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
Typ : constant Entity_Id := Etype (Left);
Otype : Entity_Id := Empty;
Result : Boolean;
Stat : Boolean;
Fold : Boolean;
@ -2887,6 +2897,17 @@ package body Sem_Eval is
Set_Is_Static_Expression (N, False);
end if;
-- For operators on universal numeric types called as functions with
-- an explicit scope, determine appropriate specific numeric type, and
-- diagnose possible ambiguity.
if Is_Universal_Numeric_Type (Etype (Left))
and then
Is_Universal_Numeric_Type (Etype (Right))
then
Otype := Find_Universal_Operator_Type (N);
end if;
-- For static real type expressions, we cannot use Compile_Time_Compare
-- since it worries about run-time results which are not exact.
@ -2986,6 +3007,13 @@ package body Sem_Eval is
Fold_Uint (N, Test (Result), Stat);
end if;
-- For the case of a folded relational operator on a specific numeric
-- type, freeze operand type now.
if Present (Otype) then
Freeze_Before (N, Otype);
end if;
Warn_On_Known_Condition (N);
end Eval_Relational_Op;
@ -3401,6 +3429,7 @@ package body Sem_Eval is
procedure Eval_Unary_Op (N : Node_Id) is
Right : constant Node_Id := Right_Opnd (N);
Otype : Entity_Id := Empty;
Stat : Boolean;
Fold : Boolean;
@ -3417,7 +3446,7 @@ package body Sem_Eval is
or else
Etype (Right) = Universal_Real
then
Test_Ambiguous_Operator (N);
Otype := Find_Universal_Operator_Type (N);
end if;
-- Fold for integer case
@ -3475,6 +3504,14 @@ package body Sem_Eval is
Fold_Ureal (N, Result, Stat);
end;
end if;
-- If the operator was resolved to a specific type, make sure that type
-- is frozen even if the expression is folded into a literal (which has
-- a universal type).
if Present (Otype) then
Freeze_Before (N, Otype);
end if;
end Eval_Unary_Op;
-------------------------------
@ -4724,32 +4761,61 @@ package body Sem_Eval is
end if;
end Test;
-----------------------------
-- Test_Ambiguous_Operator --
-----------------------------
----------------------------------
-- Find_Universal_Operator_Type --
----------------------------------
procedure Test_Ambiguous_Operator (N : Node_Id) is
function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id is
PN : constant Node_Id := Parent (N);
Call : constant Node_Id := Original_Node (N);
Is_Int : constant Boolean := Is_Integer_Type (Etype (N));
Is_Fix : constant Boolean :=
Nkind (N) in N_Binary_Op
and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N));
-- A mixed-mode operation in this context indicates the
-- presence of fixed-point type in the designated package.
-- A mixed-mode operation in this context indicates the presence of
-- fixed-point type in the designated package.
Is_Relational : constant Boolean := Etype (N) = Standard_Boolean;
-- Case where N is a relational (or membership) operator (else it is an
-- arithmetic one).
In_Membership : constant Boolean :=
Nkind (PN) in N_Membership_Test
and then
Nkind (Right_Opnd (PN)) = N_Range
and then
Is_Universal_Numeric_Type (Etype (Left_Opnd (PN)))
and then
Is_Universal_Numeric_Type
(Etype (Low_Bound (Right_Opnd (PN))))
and then
Is_Universal_Numeric_Type
(Etype (High_Bound (Right_Opnd (PN))));
-- Case where N is part of a membership test with a universal range
E : Entity_Id;
Pack : Entity_Id;
Typ1 : Entity_Id;
Typ1 : Entity_Id := Empty;
Priv_E : Entity_Id;
begin
if Nkind (Call) /= N_Function_Call
or else Nkind (Name (Call)) /= N_Expanded_Name
then
return;
return Empty;
elsif Nkind (Parent (N)) = N_Type_Conversion then
-- There are two cases where the context does not imply the type of the
-- operands: either the universal expression appears in a type
-- type conversion, or we are in the case of a predefined relational
-- operator, where the context type is always Boolean.
elsif Nkind (Parent (N)) = N_Type_Conversion
or else
Is_Relational
or else
In_Membership
then
Pack := Entity (Prefix (Name (Call)));
-- If the prefix is a package declared elsewhere, iterate over
@ -4773,6 +4839,7 @@ package body Sem_Eval is
and then Is_Integer_Type (E) = Is_Int
and then
(Nkind (N) in N_Unary_Op
or else Is_Relational
or else Is_Fixed_Point_Type (E) = Is_Fix)
then
if No (Typ1) then
@ -4786,13 +4853,16 @@ package body Sem_Eval is
Error_Msg_N ("\possible interpretation (inherited)#", N);
Error_Msg_Sloc := Sloc (E);
Error_Msg_N ("\possible interpretation (inherited)#", N);
return Empty;
end if;
end if;
Next_Entity (E);
end loop;
end if;
end Test_Ambiguous_Operator;
return Typ1;
end Find_Universal_Operator_Type;
---------------------------------
-- Test_Expression_Is_Foldable --

8
gcc/ada/sem_res.adb
View File

@ -1484,14 +1484,6 @@ package body Sem_Res is
else
Resolve (N, Typ);
end if;
-- For predefined operators on literals, the operation freezes
-- their type.
if Present (Orig_Type) then
Set_Etype (Act1, Orig_Type);
Freeze_Expression (Act1);
end if;
end Make_Call_Into_Operator;
-------------------

9
gcc/ada/sem_util.adb
View File

@ -7082,6 +7082,15 @@ package body Sem_Util is
return (U /= 0);
end Is_True;
-------------------------------
-- Is_Universal_Numeric_Type --
-------------------------------
function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is
begin
return T = Universal_Integer or else T = Universal_Real;
end Is_Universal_Numeric_Type;
-------------------
-- Is_Value_Type --
-------------------

5
gcc/ada/sem_util.ads
View File

@ -800,6 +800,9 @@ package Sem_Util is
-- Boolean operand (i.e. is either 0 for False, or 1 for True). This
-- function simply tests if it is True (i.e. non-zero)
function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean;
-- True if T is Universal_Integer or Universal_Real
function Is_Value_Type (T : Entity_Id) return Boolean;
-- Returns true if type T represents a value type. This is only relevant to
-- CIL, will always return false for other targets. A value type is a CIL
@ -1259,7 +1262,7 @@ package Sem_Util is
-- may be a child unit with any number of ancestors.
function Universal_Interpretation (Opnd : Node_Id) return Entity_Id;
-- Yields universal_Integer or Universal_Real if this is a candidate
-- Yields Universal_Integer or Universal_Real if this is a candidate
function Unqualify (Expr : Node_Id) return Node_Id;
-- Removes any qualifications from Expr. For example, for T1'(T2'(X)),