[Ada] Crash on folded operator with universal operands in functional form
Arnaud Charlet
charlet@adacore.com
Tue Jun 22 07:41:00 GMT 2010
This change fixes a compiler crash that may occur when a predefined operator
is called in function form with universal operands.
The following compilation must be accepted quietly:
pragma extend_system(Aux_DEC);
with system; use system;
procedure Universal_Folded_Functional_Operator is
type Rec is null record;
Siz : constant System.Unsigned_Longword :=
System."*"(Left => Rec'Size, Right => 2);
begin
null;
end;
Tested on x86_64-pc-linux-gnu, committed on trunk
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.
-------------- next part --------------
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 161078)
+++ sem_util.adb (working copy)
@@ -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 --
-------------------
Index: sem_util.ads
===================================================================
--- sem_util.ads (revision 161078)
+++ sem_util.ads (working copy)
@@ -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)),
Index: sem_res.adb
===================================================================
--- sem_res.adb (revision 161087)
+++ sem_res.adb (working copy)
@@ -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;
-------------------
Index: sem_eval.adb
===================================================================
--- sem_eval.adb (revision 161132)
+++ sem_eval.adb (working copy)
@@ -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 --
More information about the Gcc-patches
mailing list