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 --