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

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

5 files changed, 122 insertions, 32 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index cf19f2e..e9b3374 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -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.
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index 6c8eb66..1d9e0f6 100644
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -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;
+
+      --  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 then
+      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 --
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index e45dbe2..bf00a97 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -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;
 
    -------------------
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 583135e..340e8fe 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -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 --
    -------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 08d1284..1df648d 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -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)),